parent
d23b8f573b
commit
70482933d8
|
@ -0,0 +1,283 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- B A C K _ E N D --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.23 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Atree; use Atree;
|
||||
with Debug; use Debug;
|
||||
with Elists; use Elists;
|
||||
with Lib; use Lib;
|
||||
with Osint; use Osint;
|
||||
with Opt; use Opt;
|
||||
with Osint; use Osint;
|
||||
with Namet; use Namet;
|
||||
with Nlists; use Nlists;
|
||||
with Stand; use Stand;
|
||||
with Sinput; use Sinput;
|
||||
with Stringt; use Stringt;
|
||||
with Switch; use Switch;
|
||||
with System; use System;
|
||||
with Types; use Types;
|
||||
|
||||
package body Back_End is
|
||||
|
||||
-- Local subprograms
|
||||
|
||||
-------------------
|
||||
-- Call_Back_End --
|
||||
-------------------
|
||||
|
||||
procedure Call_Back_End (Mode : Back_End_Mode_Type) is
|
||||
|
||||
-- The File_Record type has a lot of components that are meaningless
|
||||
-- to the back end, so a new record is created here to contain the
|
||||
-- needed information for each file.
|
||||
|
||||
type Needed_File_Info_Type is record
|
||||
File_Name : File_Name_Type;
|
||||
First_Sloc : Source_Ptr;
|
||||
Last_Sloc : Source_Ptr;
|
||||
Num_Source_Lines : Nat;
|
||||
end record;
|
||||
|
||||
File_Info_Array :
|
||||
array (Main_Unit .. Last_Unit) of Needed_File_Info_Type;
|
||||
|
||||
procedure gigi (
|
||||
gnat_root : Int;
|
||||
max_gnat_node : Int;
|
||||
number_name : Nat;
|
||||
nodes_ptr : Address;
|
||||
|
||||
next_node_ptr : Address;
|
||||
prev_node_ptr : Address;
|
||||
elists_ptr : Address;
|
||||
elmts_ptr : Address;
|
||||
|
||||
strings_ptr : Address;
|
||||
string_chars_ptr : Address;
|
||||
list_headers_ptr : Address;
|
||||
number_units : Int;
|
||||
|
||||
file_info_ptr : Address;
|
||||
gigi_standard_integer : Entity_Id;
|
||||
gigi_standard_long_long_float : Entity_Id;
|
||||
gigi_standard_exception_type : Entity_Id;
|
||||
gigi_operating_mode : Back_End_Mode_Type);
|
||||
|
||||
pragma Import (C, gigi);
|
||||
|
||||
S : Source_File_Index;
|
||||
|
||||
begin
|
||||
-- Skip call if in -gnatdH mode
|
||||
|
||||
if Debug_Flag_HH then
|
||||
return;
|
||||
end if;
|
||||
|
||||
for J in Main_Unit .. Last_Unit loop
|
||||
S := Source_Index (J);
|
||||
File_Info_Array (J).File_Name := File_Name (S);
|
||||
File_Info_Array (J).First_Sloc := Source_Text (S)'First;
|
||||
File_Info_Array (J).Last_Sloc := Source_Text (S)'Last;
|
||||
File_Info_Array (J).Num_Source_Lines := Num_Source_Lines (S);
|
||||
end loop;
|
||||
|
||||
gigi (
|
||||
gnat_root => Int (Cunit (Main_Unit)),
|
||||
max_gnat_node => Int (Last_Node_Id - First_Node_Id + 1),
|
||||
number_name => Name_Entries_Count,
|
||||
nodes_ptr => Nodes_Address,
|
||||
|
||||
next_node_ptr => Next_Node_Address,
|
||||
prev_node_ptr => Prev_Node_Address,
|
||||
elists_ptr => Elists_Address,
|
||||
elmts_ptr => Elmts_Address,
|
||||
|
||||
strings_ptr => Strings_Address,
|
||||
string_chars_ptr => String_Chars_Address,
|
||||
list_headers_ptr => Lists_Address,
|
||||
number_units => Num_Units,
|
||||
|
||||
file_info_ptr => File_Info_Array'Address,
|
||||
gigi_standard_integer => Standard_Integer,
|
||||
gigi_standard_long_long_float => Standard_Long_Long_Float,
|
||||
gigi_standard_exception_type => Standard_Exception_Type,
|
||||
gigi_operating_mode => Mode);
|
||||
end Call_Back_End;
|
||||
|
||||
-----------------------------
|
||||
-- Scan_Compiler_Arguments --
|
||||
-----------------------------
|
||||
|
||||
procedure Scan_Compiler_Arguments is
|
||||
|
||||
Next_Arg : Pos := 1;
|
||||
|
||||
subtype Big_String is String (Positive);
|
||||
type BSP is access Big_String;
|
||||
|
||||
type Arg_Array is array (Nat) of BSP;
|
||||
type Arg_Array_Ptr is access Arg_Array;
|
||||
|
||||
-- Import flag_stack_check from toplev.c.
|
||||
|
||||
flag_stack_check : Int;
|
||||
pragma Import (C, flag_stack_check); -- Import from toplev.c
|
||||
|
||||
save_argc : Nat;
|
||||
pragma Import (C, save_argc); -- Import from toplev.c
|
||||
|
||||
save_argv : Arg_Array_Ptr;
|
||||
pragma Import (C, save_argv); -- Import from toplev.c
|
||||
|
||||
Output_File_Name_Seen : Boolean := False;
|
||||
-- Set to True after having scanned the file_name for
|
||||
-- switch "-gnatO file_name"
|
||||
|
||||
-- Local functions
|
||||
|
||||
function Len_Arg (Arg : Pos) return Nat;
|
||||
-- Determine length of argument number Arg on the original
|
||||
-- command line from gnat1
|
||||
|
||||
procedure Scan_Back_End_Switches (Switch_Chars : String);
|
||||
-- Procedure to scan out switches stored in Switch_Chars. The first
|
||||
-- character is known to be a valid switch character, and there are no
|
||||
-- blanks or other switch terminator characters in the string, so the
|
||||
-- entire string should consist of valid switch characters, except that
|
||||
-- an optional terminating NUL character is allowed.
|
||||
--
|
||||
-- Back end switches have already been checked and processed by GCC
|
||||
-- in toplev.c, so no errors can occur and control will always return.
|
||||
-- The switches must still be scanned to skip the arguments of the
|
||||
-- "-o" or the (undocumented) "-dumpbase" switch, by incrementing
|
||||
-- the Next_Arg variable. The "-dumpbase" switch is used to set the
|
||||
-- basename for GCC dumpfiles.
|
||||
|
||||
-------------
|
||||
-- Len_Arg --
|
||||
-------------
|
||||
|
||||
function Len_Arg (Arg : Pos) return Nat is
|
||||
begin
|
||||
for J in 1 .. Nat'Last loop
|
||||
if save_argv (Arg).all (Natural (J)) = ASCII.NUL then
|
||||
return J - 1;
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
raise Program_Error;
|
||||
end Len_Arg;
|
||||
|
||||
----------------------------
|
||||
-- Scan_Back_End_Switches --
|
||||
----------------------------
|
||||
|
||||
procedure Scan_Back_End_Switches (Switch_Chars : String) is
|
||||
First : constant Positive := Switch_Chars'First + 1;
|
||||
Last : Natural := Switch_Chars'Last;
|
||||
|
||||
begin
|
||||
if Last >= First
|
||||
and then Switch_Chars (Last) = ASCII.NUL
|
||||
then
|
||||
Last := Last - 1;
|
||||
end if;
|
||||
|
||||
if Switch_Chars (First .. Last) = "o"
|
||||
or else Switch_Chars (First .. Last) = "dumpbase"
|
||||
|
||||
then
|
||||
Next_Arg := Next_Arg + 1;
|
||||
|
||||
elsif Switch_Chars (First .. Last) = "quiet" then
|
||||
null; -- do not record this switch
|
||||
|
||||
else
|
||||
-- Store any other GCC switches
|
||||
Store_Compilation_Switch (Switch_Chars);
|
||||
end if;
|
||||
end Scan_Back_End_Switches;
|
||||
|
||||
-- Start of processing for Scan_Compiler_Arguments
|
||||
|
||||
begin
|
||||
-- Acquire stack checking mode directly from GCC
|
||||
|
||||
Opt.Stack_Checking_Enabled := (flag_stack_check /= 0);
|
||||
|
||||
-- Loop through command line arguments, storing them for later access
|
||||
|
||||
while Next_Arg < save_argc loop
|
||||
|
||||
Look_At_Arg : declare
|
||||
Argv_Ptr : constant BSP := save_argv (Next_Arg);
|
||||
Argv_Len : constant Nat := Len_Arg (Next_Arg);
|
||||
Argv : String := Argv_Ptr (1 .. Natural (Argv_Len));
|
||||
|
||||
begin
|
||||
-- If the previous switch has set the Output_File_Name_Present
|
||||
-- flag (that is we have seen a -gnatO), then the next argument
|
||||
-- is the name of the output object file.
|
||||
|
||||
if Output_File_Name_Present
|
||||
and then not Output_File_Name_Seen
|
||||
then
|
||||
if Is_Switch (Argv) then
|
||||
Fail ("Object file name missing after -gnatO");
|
||||
|
||||
else
|
||||
Set_Output_Object_File_Name (Argv);
|
||||
Output_File_Name_Seen := True;
|
||||
end if;
|
||||
|
||||
elsif not Is_Switch (Argv) then -- must be a file name
|
||||
Add_File (Argv);
|
||||
|
||||
elsif Is_Front_End_Switch (Argv) then
|
||||
Scan_Front_End_Switches (Argv);
|
||||
|
||||
-- ??? Should be done in Scan_Front_End_Switches, after
|
||||
-- Switch is splitted in compiler/make/bind units
|
||||
|
||||
if Argv (2) /= 'I' then
|
||||
Store_Compilation_Switch (Argv);
|
||||
end if;
|
||||
|
||||
-- All non-front-end switches are back-end switches
|
||||
|
||||
else
|
||||
Scan_Back_End_Switches (Argv);
|
||||
end if;
|
||||
end Look_At_Arg;
|
||||
|
||||
Next_Arg := Next_Arg + 1;
|
||||
end loop;
|
||||
end Scan_Compiler_Arguments;
|
||||
|
||||
end Back_End;
|
|
@ -0,0 +1,69 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- B A C K _ E N D --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.7 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- Call the back end with all the information needed. Also contains other
|
||||
-- back-end specific interfaces required by the front end.
|
||||
|
||||
package Back_End is
|
||||
|
||||
type Back_End_Mode_Type is (
|
||||
Generate_Object,
|
||||
-- Full back end operation with object file generation
|
||||
|
||||
Declarations_Only,
|
||||
-- Partial back end operation with no object file generation. In this
|
||||
-- mode the only useful action performed by gigi is to process all
|
||||
-- declarations issuing any error messages (in partcicular those to
|
||||
-- do with rep clauses), and to back annotate representation info.
|
||||
|
||||
Skip);
|
||||
-- Back end call is skipped (syntax only, or errors found)
|
||||
|
||||
pragma Convention (C, Back_End_Mode_Type);
|
||||
for Back_End_Mode_Type use (0, 1, 2);
|
||||
|
||||
procedure Call_Back_End (Mode : Back_End_Mode_Type);
|
||||
-- Call back end, i.e. make call to driver traversing the tree and
|
||||
-- outputting code. This call is made with all tables locked.
|
||||
-- The back end is responsible for unlocking any tables it may need
|
||||
-- to change, and locking them again before returning.
|
||||
|
||||
procedure Scan_Compiler_Arguments;
|
||||
-- Acquires command-line parameters passed to the compiler and processes
|
||||
-- them. Calls Scan_Front_End_Switches for any front-end switches
|
||||
-- encountered.
|
||||
--
|
||||
-- The processing of arguments is private to the back end, since
|
||||
-- the way of acquiring the arguments as well as the set of allowable
|
||||
-- back end switches is different depending on the particular back end
|
||||
-- being used.
|
||||
--
|
||||
-- Any processed switches that influence the result of a compilation
|
||||
-- must be added to the Compilation_Arguments table.
|
||||
|
||||
end Back_End;
|
|
@ -0,0 +1,694 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- B C H E C K --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.39 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with ALI; use ALI;
|
||||
with ALI.Util; use ALI.Util;
|
||||
with Binderr; use Binderr;
|
||||
with Butil; use Butil;
|
||||
with Casing; use Casing;
|
||||
with Debug; use Debug;
|
||||
with Fname; use Fname;
|
||||
with Namet; use Namet;
|
||||
with Opt; use Opt;
|
||||
with Osint;
|
||||
with Output; use Output;
|
||||
with Rident; use Rident;
|
||||
with Types; use Types;
|
||||
|
||||
package body Bcheck is
|
||||
|
||||
-- Local subprograms
|
||||
|
||||
-- The following checking subprograms make up the parts
|
||||
-- of the configuration consistency check.
|
||||
|
||||
procedure Check_Consistent_Dynamic_Elaboration_Checking;
|
||||
procedure Check_Consistent_Floating_Point_Format;
|
||||
procedure Check_Consistent_Locking_Policy;
|
||||
procedure Check_Consistent_Normalize_Scalars;
|
||||
procedure Check_Consistent_Queuing_Policy;
|
||||
procedure Check_Consistent_Zero_Cost_Exception_Handling;
|
||||
procedure Check_Partition_Restrictions;
|
||||
|
||||
procedure Consistency_Error_Msg (Msg : String);
|
||||
-- Produce an error or a warning message, depending on whether
|
||||
-- an inconsistent configuration is permitted or not.
|
||||
|
||||
------------------------------------
|
||||
-- Check_Consistent_Configuration --
|
||||
------------------------------------
|
||||
|
||||
procedure Check_Configuration_Consistency is
|
||||
begin
|
||||
if Float_Format_Specified /= ' ' then
|
||||
Check_Consistent_Floating_Point_Format;
|
||||
end if;
|
||||
|
||||
if Queuing_Policy_Specified /= ' ' then
|
||||
Check_Consistent_Queuing_Policy;
|
||||
end if;
|
||||
|
||||
if Locking_Policy_Specified /= ' ' then
|
||||
Check_Consistent_Locking_Policy;
|
||||
end if;
|
||||
|
||||
if Zero_Cost_Exceptions_Specified then
|
||||
Check_Consistent_Zero_Cost_Exception_Handling;
|
||||
end if;
|
||||
|
||||
Check_Consistent_Normalize_Scalars;
|
||||
Check_Consistent_Dynamic_Elaboration_Checking;
|
||||
|
||||
Check_Partition_Restrictions;
|
||||
end Check_Configuration_Consistency;
|
||||
|
||||
---------------------------------------------------
|
||||
-- Check_Consistent_Dynamic_Elaboration_Checking --
|
||||
---------------------------------------------------
|
||||
|
||||
-- The rule here is that if a unit has dynamic elaboration checks,
|
||||
-- then any unit it withs must meeting one of the following criteria:
|
||||
|
||||
-- 1. There is a pragma Elaborate_All for the with'ed unit
|
||||
-- 2. The with'ed unit was compiled with dynamic elaboration checks
|
||||
-- 3. The with'ed unit has pragma Preelaborate or Pure
|
||||
-- 4. It is an internal GNAT unit (including children of GNAT)
|
||||
|
||||
procedure Check_Consistent_Dynamic_Elaboration_Checking is
|
||||
begin
|
||||
if Dynamic_Elaboration_Checks_Specified then
|
||||
for U in First_Unit_Entry .. Units.Last loop
|
||||
declare
|
||||
UR : Unit_Record renames Units.Table (U);
|
||||
|
||||
begin
|
||||
if UR.Dynamic_Elab then
|
||||
for W in UR.First_With .. UR.Last_With loop
|
||||
declare
|
||||
WR : With_Record renames Withs.Table (W);
|
||||
|
||||
begin
|
||||
if Get_Name_Table_Info (WR.Uname) /= 0 then
|
||||
declare
|
||||
WU : Unit_Record renames
|
||||
Units.Table
|
||||
(Unit_Id
|
||||
(Get_Name_Table_Info (WR.Uname)));
|
||||
|
||||
begin
|
||||
-- Case 1. Elaborate_All for with'ed unit
|
||||
|
||||
if WR.Elaborate_All then
|
||||
null;
|
||||
|
||||
-- Case 2. With'ed unit has dynamic elab checks
|
||||
|
||||
elsif WU.Dynamic_Elab then
|
||||
null;
|
||||
|
||||
-- Case 3. With'ed unit is Preelaborate or Pure
|
||||
|
||||
elsif WU.Preelab or WU.Pure then
|
||||
null;
|
||||
|
||||
-- Case 4. With'ed unit is internal file
|
||||
|
||||
elsif Is_Internal_File_Name (WU.Sfile) then
|
||||
null;
|
||||
|
||||
-- Issue warning, not one of the safe cases
|
||||
|
||||
else
|
||||
Error_Msg_Name_1 := UR.Sfile;
|
||||
Error_Msg
|
||||
("?% has dynamic elaboration checks " &
|
||||
"and with's");
|
||||
|
||||
Error_Msg_Name_1 := WU.Sfile;
|
||||
Error_Msg
|
||||
("? % which has static elaboration " &
|
||||
"checks");
|
||||
|
||||
Warnings_Detected := Warnings_Detected - 1;
|
||||
end if;
|
||||
end;
|
||||
end if;
|
||||
end;
|
||||
end loop;
|
||||
end if;
|
||||
end;
|
||||
end loop;
|
||||
end if;
|
||||
end Check_Consistent_Dynamic_Elaboration_Checking;
|
||||
|
||||
--------------------------------------------
|
||||
-- Check_Consistent_Floating_Point_Format --
|
||||
--------------------------------------------
|
||||
|
||||
-- The rule is that all files must be compiled with the same setting
|
||||
-- for the floating-point format.
|
||||
|
||||
procedure Check_Consistent_Floating_Point_Format is
|
||||
begin
|
||||
-- First search for a unit specifying a floating-point format and then
|
||||
-- check all remaining units against it.
|
||||
|
||||
Find_Format : for A1 in ALIs.First .. ALIs.Last loop
|
||||
if ALIs.Table (A1).Float_Format /= ' ' then
|
||||
Check_Format : declare
|
||||
Format : constant Character := ALIs.Table (A1).Float_Format;
|
||||
begin
|
||||
for A2 in A1 + 1 .. ALIs.Last loop
|
||||
if ALIs.Table (A2).Float_Format /= Format then
|
||||
Error_Msg_Name_1 := ALIs.Table (A1).Sfile;
|
||||
Error_Msg_Name_2 := ALIs.Table (A2).Sfile;
|
||||
|
||||
Consistency_Error_Msg
|
||||
("% and % compiled with different " &
|
||||
"floating-point representations");
|
||||
exit Find_Format;
|
||||
end if;
|
||||
end loop;
|
||||
end Check_Format;
|
||||
|
||||
exit Find_Format;
|
||||
end if;
|
||||
end loop Find_Format;
|
||||
end Check_Consistent_Floating_Point_Format;
|
||||
|
||||
-------------------------------------
|
||||
-- Check_Consistent_Locking_Policy --
|
||||
-------------------------------------
|
||||
|
||||
-- The rule is that all files for which the locking policy is
|
||||
-- significant must be compiled with the same setting.
|
||||
|
||||
procedure Check_Consistent_Locking_Policy is
|
||||
begin
|
||||
-- First search for a unit specifying a policy and then
|
||||
-- check all remaining units against it.
|
||||
|
||||
Find_Policy : for A1 in ALIs.First .. ALIs.Last loop
|
||||
if ALIs.Table (A1).Locking_Policy /= ' ' then
|
||||
Check_Policy : declare
|
||||
Policy : constant Character := ALIs.Table (A1).Locking_Policy;
|
||||
|
||||
begin
|
||||
for A2 in A1 + 1 .. ALIs.Last loop
|
||||
if ALIs.Table (A2).Locking_Policy /= ' ' and
|
||||
ALIs.Table (A2).Locking_Policy /= Policy
|
||||
then
|
||||
Error_Msg_Name_1 := ALIs.Table (A1).Sfile;
|
||||
Error_Msg_Name_2 := ALIs.Table (A2).Sfile;
|
||||
|
||||
Consistency_Error_Msg
|
||||
("% and % compiled with different locking policies");
|
||||
exit Find_Policy;
|
||||
end if;
|
||||
end loop;
|
||||
end Check_Policy;
|
||||
|
||||
exit Find_Policy;
|
||||
end if;
|
||||
end loop Find_Policy;
|
||||
end Check_Consistent_Locking_Policy;
|
||||
|
||||
----------------------------------------
|
||||
-- Check_Consistent_Normalize_Scalars --
|
||||
----------------------------------------
|
||||
|
||||
-- The rule is that if any unit is compiled with Normalized_Scalars,
|
||||
-- then all other units in the partition must also be compiled with
|
||||
-- Normalized_Scalars in effect.
|
||||
|
||||
-- There is some issue as to whether this consistency check is
|
||||
-- desirable, it is certainly required at the moment by the RM.
|
||||
-- We should keep a watch on the ARG and HRG deliberations here.
|
||||
-- GNAT no longer depends on this consistency (it used to do so,
|
||||
-- but that has been corrected in the latest version, since the
|
||||
-- Initialize_Scalars pragma does not require consistency.
|
||||
|
||||
procedure Check_Consistent_Normalize_Scalars is
|
||||
begin
|
||||
if Normalize_Scalars_Specified and No_Normalize_Scalars_Specified then
|
||||
Consistency_Error_Msg
|
||||
("some but not all files compiled with Normalize_Scalars");
|
||||
|
||||
Write_Eol;
|
||||
Write_Str ("files compiled with Normalize_Scalars");
|
||||
Write_Eol;
|
||||
|
||||
for A1 in ALIs.First .. ALIs.Last loop
|
||||
if ALIs.Table (A1).Normalize_Scalars then
|
||||
Write_Str (" ");
|
||||
Write_Name (ALIs.Table (A1).Sfile);
|
||||
Write_Eol;
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
Write_Eol;
|
||||
Write_Str ("files compiled without Normalize_Scalars");
|
||||
Write_Eol;
|
||||
|
||||
for A1 in ALIs.First .. ALIs.Last loop
|
||||
if not ALIs.Table (A1).Normalize_Scalars then
|
||||
Write_Str (" ");
|
||||
Write_Name (ALIs.Table (A1).Sfile);
|
||||
Write_Eol;
|
||||
end if;
|
||||
end loop;
|
||||
end if;
|
||||
end Check_Consistent_Normalize_Scalars;
|
||||
|
||||
-------------------------------------
|
||||
-- Check_Consistent_Queuing_Policy --
|
||||
-------------------------------------
|
||||
|
||||
-- The rule is that all files for which the queuing policy is
|
||||
-- significant must be compiled with the same setting.
|
||||
|
||||
procedure Check_Consistent_Queuing_Policy is
|
||||
begin
|
||||
-- First search for a unit specifying a policy and then
|
||||
-- check all remaining units against it.
|
||||
|
||||
Find_Policy : for A1 in ALIs.First .. ALIs.Last loop
|
||||
if ALIs.Table (A1).Queuing_Policy /= ' ' then
|
||||
Check_Policy : declare
|
||||
Policy : constant Character := ALIs.Table (A1).Queuing_Policy;
|
||||
begin
|
||||
for A2 in A1 + 1 .. ALIs.Last loop
|
||||
if ALIs.Table (A2).Queuing_Policy /= ' '
|
||||
and then
|
||||
ALIs.Table (A2).Queuing_Policy /= Policy
|
||||
then
|
||||
Error_Msg_Name_1 := ALIs.Table (A1).Sfile;
|
||||
Error_Msg_Name_2 := ALIs.Table (A2).Sfile;
|
||||
|
||||
Consistency_Error_Msg
|
||||
("% and % compiled with different queuing policies");
|
||||
exit Find_Policy;
|
||||
end if;
|
||||
end loop;
|
||||
end Check_Policy;
|
||||
|
||||
exit Find_Policy;
|
||||
end if;
|
||||
end loop Find_Policy;
|
||||
end Check_Consistent_Queuing_Policy;
|
||||
|
||||
---------------------------------------------------
|
||||
-- Check_Consistent_Zero_Cost_Exception_Handling --
|
||||
---------------------------------------------------
|
||||
|
||||
-- Check consistent zero cost exception handling. The rule is that
|
||||
-- all units must have the same exception handling mechanism.
|
||||
|
||||
procedure Check_Consistent_Zero_Cost_Exception_Handling is
|
||||
begin
|
||||
Check_Mechanism : for A1 in ALIs.First + 1 .. ALIs.Last loop
|
||||
if ALIs.Table (A1).Zero_Cost_Exceptions /=
|
||||
ALIs.Table (ALIs.First).Zero_Cost_Exceptions
|
||||
|
||||
then
|
||||
Error_Msg_Name_1 := ALIs.Table (A1).Sfile;
|
||||
Error_Msg_Name_2 := ALIs.Table (ALIs.First).Sfile;
|
||||
|
||||
Consistency_Error_Msg ("% and % compiled with different "
|
||||
& "exception handling mechanisms");
|
||||
end if;
|
||||
end loop Check_Mechanism;
|
||||
end Check_Consistent_Zero_Cost_Exception_Handling;
|
||||
|
||||
----------------------------------
|
||||
-- Check_Partition_Restrictions --
|
||||
----------------------------------
|
||||
|
||||
-- The rule is that if a restriction is specified in any unit,
|
||||
-- then all units must obey the restriction. The check applies
|
||||
-- only to restrictions which require partition wide consistency,
|
||||
-- and not to internal units.
|
||||
|
||||
-- The check is done in two steps. First for every restriction
|
||||
-- a unit specifying that restriction is found, if any.
|
||||
-- Second, all units are verified against the specified restrictions.
|
||||
|
||||
procedure Check_Partition_Restrictions is
|
||||
|
||||
R : array (Partition_Restrictions) of ALI_Id := (others => No_ALI_Id);
|
||||
-- Record the first unit specifying each partition restriction
|
||||
|
||||
V : array (Partition_Restrictions) of ALI_Id := (others => No_ALI_Id);
|
||||
-- Record the last unit violating each partition restriction
|
||||
|
||||
procedure List_Applicable_Restrictions;
|
||||
-- Output a list of restrictions that may be applied to the partition,
|
||||
-- without causing bind errors.
|
||||
|
||||
----------------------------------
|
||||
-- List_Applicable_Restrictions --
|
||||
----------------------------------
|
||||
|
||||
procedure List_Applicable_Restrictions is
|
||||
Additional_Restrictions_Listed : Boolean := False;
|
||||
|
||||
begin
|
||||
-- List any restrictions which were not violated and not specified
|
||||
|
||||
for J in Partition_Restrictions loop
|
||||
if V (J) = No_ALI_Id and R (J) = No_ALI_Id then
|
||||
if not Additional_Restrictions_Listed then
|
||||
Write_Str ("The following additional restrictions may be" &
|
||||
" applied to this partition:");
|
||||
Write_Eol;
|
||||
Additional_Restrictions_Listed := True;
|
||||
end if;
|
||||
|
||||
Write_Str ("pragma Restrictions (");
|
||||
|
||||
declare
|
||||
S : constant String := Restriction_Id'Image (J);
|
||||
|
||||
begin
|
||||
Name_Len := S'Length;
|
||||
Name_Buffer (1 .. Name_Len) := S;
|
||||
end;
|
||||
|
||||
Set_Casing (Mixed_Case);
|
||||
Write_Str (Name_Buffer (1 .. Name_Len));
|
||||
Write_Str (");");
|
||||
Write_Eol;
|
||||
end if;
|
||||
end loop;
|
||||
end List_Applicable_Restrictions;
|
||||
|
||||
-- Start of processing for Check_Partition_Restrictions
|
||||
|
||||
begin
|
||||
Find_Restrictions :
|
||||
for A in ALIs.First .. ALIs.Last loop
|
||||
for J in Partition_Restrictions loop
|
||||
if R (J) = No_ALI_Id and ALIs.Table (A).Restrictions (J) = 'r' then
|
||||
R (J) := A;
|
||||
end if;
|
||||
end loop;
|
||||
end loop Find_Restrictions;
|
||||
|
||||
Find_Violations :
|
||||
for A in ALIs.First .. ALIs.Last loop
|
||||
for J in Partition_Restrictions loop
|
||||
if ALIs.Table (A).Restrictions (J) = 'v'
|
||||
and then not Is_Internal_File_Name (ALIs.Table (A).Sfile)
|
||||
then
|
||||
-- A violation of a restriction was found, so check whether
|
||||
-- that restriction was actually in effect. If so, give an
|
||||
-- error message.
|
||||
|
||||
-- Note that all such violations found are reported.
|
||||
|
||||
V (J) := A;
|
||||
|
||||
if R (J) /= No_ALI_Id then
|
||||
Report_Violated_Restriction : declare
|
||||
M1 : constant String := "% has Restriction (";
|
||||
S : constant String := Restriction_Id'Image (J);
|
||||
M2 : String (1 .. M1'Length + S'Length + 1);
|
||||
|
||||
begin
|
||||
Name_Buffer (1 .. S'Length) := S;
|
||||
Name_Len := S'Length;
|
||||
Set_Casing
|
||||
(Units.Table (ALIs.Table (R (J)).First_Unit).Icasing);
|
||||
|
||||
M2 (M1'Range) := M1;
|
||||
M2 (M1'Length + 1 .. M2'Last - 1) :=
|
||||
Name_Buffer (1 .. S'Length);
|
||||
M2 (M2'Last) := ')';
|
||||
|
||||
Error_Msg_Name_1 := ALIs.Table (R (J)).Sfile;
|
||||
Consistency_Error_Msg (M2);
|
||||
Error_Msg_Name_1 := ALIs.Table (A).Sfile;
|
||||
Consistency_Error_Msg
|
||||
("but file % violates this restriction");
|
||||
end Report_Violated_Restriction;
|
||||
end if;
|
||||
end if;
|
||||
end loop;
|
||||
end loop Find_Violations;
|
||||
|
||||
if Debug_Flag_R then
|
||||
List_Applicable_Restrictions;
|
||||
end if;
|
||||
end Check_Partition_Restrictions;
|
||||
|
||||
-----------------------
|
||||
-- Check_Consistency --
|
||||
-----------------------
|
||||
|
||||
procedure Check_Consistency is
|
||||
Src : Source_Id;
|
||||
-- Source file Id for this Sdep entry
|
||||
|
||||
begin
|
||||
-- First, we go through the source table to see if there are any cases
|
||||
-- in which we should go after source files and compute checksums of
|
||||
-- the source files. We need to do this for any file for which we have
|
||||
-- mismatching time stamps and (so far) matching checksums.
|
||||
|
||||
for S in Source.First .. Source.Last loop
|
||||
|
||||
-- If all time stamps for a file match, then there is nothing to
|
||||
-- do, since we will not be checking checksums in that case anyway
|
||||
|
||||
if Source.Table (S).All_Timestamps_Match then
|
||||
null;
|
||||
|
||||
-- If we did not find the source file, then we can't compute its
|
||||
-- checksum anyway. Note that when we have a time stamp mismatch,
|
||||
-- we try to find the source file unconditionally (i.e. if
|
||||
-- Check_Source_Files is False).
|
||||
|
||||
elsif not Source.Table (S).Source_Found then
|
||||
null;
|
||||
|
||||
-- If we already have non-matching or missing checksums, then no
|
||||
-- need to try going after source file, since we won't trust the
|
||||
-- checksums in any case.
|
||||
|
||||
elsif not Source.Table (S).All_Checksums_Match then
|
||||
null;
|
||||
|
||||
-- Now we have the case where we have time stamp mismatches, and
|
||||
-- the source file is around, but so far all checksums match. This
|
||||
-- is the case where we need to compute the checksum from the source
|
||||
-- file, since otherwise we would ignore the time stamp mismatches,
|
||||
-- and that is wrong if the checksum of the source does not agree
|
||||
-- with the checksums in the ALI files.
|
||||
|
||||
elsif Check_Source_Files then
|
||||
if Source.Table (S).Checksum /=
|
||||
Get_File_Checksum (Source.Table (S).Sfile)
|
||||
then
|
||||
Source.Table (S).All_Checksums_Match := False;
|
||||
end if;
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
-- Loop through ALI files
|
||||
|
||||
ALIs_Loop : for A in ALIs.First .. ALIs.Last loop
|
||||
|
||||
-- Loop through Sdep entries in one ALI file
|
||||
|
||||
Sdep_Loop : for D in
|
||||
ALIs.Table (A).First_Sdep .. ALIs.Table (A).Last_Sdep
|
||||
loop
|
||||
Src := Source_Id (Get_Name_Table_Info (Sdep.Table (D).Sfile));
|
||||
|
||||
-- If the time stamps match, or all checksums match, then we
|
||||
-- are OK, otherwise we have a definite error.
|
||||
|
||||
if Sdep.Table (D).Stamp /= Source.Table (Src).Stamp
|
||||
and then not Source.Table (Src).All_Checksums_Match
|
||||
then
|
||||
Error_Msg_Name_1 := ALIs.Table (A).Sfile;
|
||||
Error_Msg_Name_2 := Sdep.Table (D).Sfile;
|
||||
|
||||
-- Two styles of message, depending on whether or not
|
||||
-- the updated file is the one that must be recompiled
|
||||
|
||||
if Error_Msg_Name_1 = Error_Msg_Name_2 then
|
||||
if Tolerate_Consistency_Errors then
|
||||
Error_Msg
|
||||
("?% has been modified and should be recompiled");
|
||||
else
|
||||
Error_Msg
|
||||
("% has been modified and must be recompiled");
|
||||
end if;
|
||||
|
||||
else
|
||||
if Tolerate_Consistency_Errors then
|
||||
Error_Msg
|
||||
("?% should be recompiled (% has been modified)");
|
||||
|
||||
else
|
||||
Error_Msg ("% must be recompiled (% has been modified)");
|
||||
end if;
|
||||
end if;
|
||||
|
||||
if (not Tolerate_Consistency_Errors) and Verbose_Mode then
|
||||
declare
|
||||
Msg : constant String := "file % has time stamp ";
|
||||
Buf : String (1 .. Msg'Length + Time_Stamp_Length);
|
||||
|
||||
begin
|
||||
Buf (1 .. Msg'Length) := Msg;
|
||||
Buf (Msg'Length + 1 .. Buf'Length) :=
|
||||
String (Source.Table (Src).Stamp);
|
||||
Error_Msg_Name_1 := ALIs.Table (A).Sfile;
|
||||
Error_Msg (Buf);
|
||||
|
||||
Buf (Msg'Length + 1 .. Buf'Length) :=
|
||||
String (Sdep.Table (D).Stamp);
|
||||
Error_Msg_Name_1 := Sdep.Table (D).Sfile;
|
||||
Error_Msg (Buf);
|
||||
end;
|
||||
end if;
|
||||
|
||||
-- Exit from the loop through Sdep entries once we find one
|
||||
-- that does not match.
|
||||
|
||||
exit Sdep_Loop;
|
||||
end if;
|
||||
|
||||
end loop Sdep_Loop;
|
||||
end loop ALIs_Loop;
|
||||
end Check_Consistency;
|
||||
|
||||
-------------------------------
|
||||
-- Check_Duplicated_Subunits --
|
||||
-------------------------------
|
||||
|
||||
procedure Check_Duplicated_Subunits is
|
||||
begin
|
||||
for J in Sdep.First .. Sdep.Last loop
|
||||
if Sdep.Table (J).Subunit_Name /= No_Name then
|
||||
Get_Decoded_Name_String (Sdep.Table (J).Subunit_Name);
|
||||
Name_Len := Name_Len + 2;
|
||||
Name_Buffer (Name_Len - 1) := '%';
|
||||
|
||||
-- See if there is a body or spec with the same name
|
||||
|
||||
for K in Boolean loop
|
||||
if K then
|
||||
Name_Buffer (Name_Len) := 'b';
|
||||
|
||||
else
|
||||
Name_Buffer (Name_Len) := 's';
|
||||
end if;
|
||||
|
||||
declare
|
||||
Info : constant Int := Get_Name_Table_Info (Name_Find);
|
||||
|
||||
begin
|
||||
if Info /= 0 then
|
||||
Set_Standard_Error;
|
||||
Write_Str ("error: subunit """);
|
||||
Write_Name_Decoded (Sdep.Table (J).Subunit_Name);
|
||||
Write_Str (""" in file """);
|
||||
Write_Name_Decoded (Sdep.Table (J).Sfile);
|
||||
Write_Char ('"');
|
||||
Write_Eol;
|
||||
Write_Str (" has same name as unit """);
|
||||
Write_Unit_Name (Units.Table (Unit_Id (Info)).Uname);
|
||||
Write_Str (""" found in file """);
|
||||
Write_Name_Decoded (Units.Table (Unit_Id (Info)).Sfile);
|
||||
Write_Char ('"');
|
||||
Write_Eol;
|
||||
Write_Str (" this is not allowed within a single "
|
||||
& "partition (RM 10.2(19))");
|
||||
Write_Eol;
|
||||
Osint.Exit_Program (Osint.E_Fatal);
|
||||
end if;
|
||||
end;
|
||||
end loop;
|
||||
end if;
|
||||
end loop;
|
||||
end Check_Duplicated_Subunits;
|
||||
|
||||
--------------------
|
||||
-- Check_Versions --
|
||||
--------------------
|
||||
|
||||
procedure Check_Versions is
|
||||
VL : constant Natural := ALIs.Table (ALIs.First).Ver_Len;
|
||||
|
||||
begin
|
||||
for A in ALIs.First .. ALIs.Last loop
|
||||
if ALIs.Table (A).Ver_Len /= VL
|
||||
or else ALIs.Table (A).Ver (1 .. VL) /=
|
||||
ALIs.Table (ALIs.First).Ver (1 .. VL)
|
||||
then
|
||||
Error_Msg_Name_1 := ALIs.Table (A).Sfile;
|
||||
Error_Msg_Name_2 := ALIs.Table (ALIs.First).Sfile;
|
||||
|
||||
Consistency_Error_Msg
|
||||
("% and % compiled with different GNAT versions");
|
||||
end if;
|
||||
end loop;
|
||||
end Check_Versions;
|
||||
|
||||
---------------------------
|
||||
-- Consistency_Error_Msg --
|
||||
---------------------------
|
||||
|
||||
procedure Consistency_Error_Msg (Msg : String) is
|
||||
begin
|
||||
if Tolerate_Consistency_Errors then
|
||||
|
||||
-- If consistency errors are tolerated,
|
||||
-- output the message as a warning.
|
||||
|
||||
declare
|
||||
Warning_Msg : String (1 .. Msg'Length + 1);
|
||||
|
||||
begin
|
||||
Warning_Msg (1) := '?';
|
||||
Warning_Msg (2 .. Warning_Msg'Last) := Msg;
|
||||
|
||||
Error_Msg (Warning_Msg);
|
||||
end;
|
||||
|
||||
-- Otherwise the consistency error is a true error
|
||||
|
||||
else
|
||||
Error_Msg (Msg);
|
||||
end if;
|
||||
end Consistency_Error_Msg;
|
||||
|
||||
end Bcheck;
|
|
@ -0,0 +1,52 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- B C H E C K --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.7 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-1999 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
package Bcheck is
|
||||
|
||||
-- This package contains the routines to perform binder consistency checks
|
||||
|
||||
procedure Check_Duplicated_Subunits;
|
||||
-- Check that no subunit names duplicate names of other packages in
|
||||
-- the partition (check required by RM 10.2(19)).
|
||||
|
||||
procedure Check_Versions;
|
||||
-- Check correct library and standard versions used
|
||||
|
||||
procedure Check_Consistency;
|
||||
-- This procedure performs checks that the ALI files are consistent
|
||||
-- with the corresponding source files and with one another. At the
|
||||
-- time this is called, the Source table has been completely built and
|
||||
-- contains either the time stamp from the actual source file if the
|
||||
-- Check_Source_Files mode is set, or the latest stamp found in any of
|
||||
-- the ALI files in the program.
|
||||
|
||||
procedure Check_Configuration_Consistency;
|
||||
-- This procedure performs a similar check that configuration pragma
|
||||
-- set items that are required to be consistent are in fact consistent
|
||||
|
||||
end Bcheck;
|
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,55 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- B I N D E --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.9 $ --
|
||||
-- --
|
||||
-- Copyright (C) 1992-1997 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This package contains the routines to determine elaboration order
|
||||
|
||||
with ALI; use ALI;
|
||||
with Table;
|
||||
with Types; use Types;
|
||||
|
||||
package Binde is
|
||||
|
||||
-- The following table records the chosen elaboration order. It is used
|
||||
-- by Gen_Elab_Call to generate the sequence of elaboration calls. Note
|
||||
-- that units are included in this table even if they have no elaboration
|
||||
-- routine, since the table is also used to drive the generation of object
|
||||
-- files in the binder output. Gen_Elab_Call skips any units that have no
|
||||
-- elaboration routine.
|
||||
|
||||
package Elab_Order is new Table.Table (
|
||||
Table_Component_Type => Unit_Id,
|
||||
Table_Index_Type => Nat,
|
||||
Table_Low_Bound => 1,
|
||||
Table_Initial => 500,
|
||||
Table_Increment => 200,
|
||||
Table_Name => "Elab_Order");
|
||||
|
||||
procedure Find_Elab_Order;
|
||||
-- Determine elaboration order
|
||||
|
||||
end Binde;
|
|
@ -0,0 +1,198 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- B I N D E R R --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.22 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-2000 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Butil; use Butil;
|
||||
with Namet; use Namet;
|
||||
with Opt; use Opt;
|
||||
with Output; use Output;
|
||||
|
||||
package body Binderr is
|
||||
|
||||
---------------
|
||||
-- Error_Msg --
|
||||
---------------
|
||||
|
||||
procedure Error_Msg (Msg : String) is
|
||||
begin
|
||||
if Msg (Msg'First) = '?' then
|
||||
if Warning_Mode = Suppress then
|
||||
return;
|
||||
end if;
|
||||
|
||||
if Warning_Mode = Treat_As_Error then
|
||||
Errors_Detected := Errors_Detected + 1;
|
||||
else
|
||||
Warnings_Detected := Warnings_Detected + 1;
|
||||
end if;
|
||||
|
||||
else
|
||||
Errors_Detected := Errors_Detected + 1;
|
||||
end if;
|
||||
|
||||
if Brief_Output or else (not Verbose_Mode) then
|
||||
Set_Standard_Error;
|
||||
Error_Msg_Output (Msg, Info => False);
|
||||
Set_Standard_Output;
|
||||
end if;
|
||||
|
||||
if Verbose_Mode then
|
||||
if Errors_Detected + Warnings_Detected = 0 then
|
||||
Write_Eol;
|
||||
end if;
|
||||
|
||||
Error_Msg_Output (Msg, Info => False);
|
||||
end if;
|
||||
|
||||
if Warnings_Detected + Errors_Detected > Maximum_Errors then
|
||||
raise Unrecoverable_Error;
|
||||
end if;
|
||||
|
||||
end Error_Msg;
|
||||
|
||||
--------------------
|
||||
-- Error_Msg_Info --
|
||||
--------------------
|
||||
|
||||
procedure Error_Msg_Info (Msg : String) is
|
||||
begin
|
||||
if Brief_Output or else (not Verbose_Mode) then
|
||||
Set_Standard_Error;
|
||||
Error_Msg_Output (Msg, Info => True);
|
||||
Set_Standard_Output;
|
||||
end if;
|
||||
|
||||
if Verbose_Mode then
|
||||
Error_Msg_Output (Msg, Info => True);
|
||||
end if;
|
||||
|
||||
end Error_Msg_Info;
|
||||
|
||||
----------------------
|
||||
-- Error_Msg_Output --
|
||||
----------------------
|
||||
|
||||
procedure Error_Msg_Output (Msg : String; Info : Boolean) is
|
||||
Use_Second_Name : Boolean := False;
|
||||
|
||||
begin
|
||||
if Warnings_Detected + Errors_Detected > Maximum_Errors then
|
||||
Write_Str ("error: maximum errors exceeded");
|
||||
Write_Eol;
|
||||
return;
|
||||
end if;
|
||||
|
||||
if Msg (Msg'First) = '?' then
|
||||
Write_Str ("warning: ");
|
||||
elsif Info then
|
||||
if not Info_Prefix_Suppress then
|
||||
Write_Str ("info: ");
|
||||
end if;
|
||||
else
|
||||
Write_Str ("error: ");
|
||||
end if;
|
||||
|
||||
for I in Msg'Range loop
|
||||
if Msg (I) = '%' then
|
||||
|
||||
if Use_Second_Name then
|
||||
Get_Name_String (Error_Msg_Name_2);
|
||||
else
|
||||
Use_Second_Name := True;
|
||||
Get_Name_String (Error_Msg_Name_1);
|
||||
end if;
|
||||
|
||||
Write_Char ('"');
|
||||
Write_Str (Name_Buffer (1 .. Name_Len));
|
||||
Write_Char ('"');
|
||||
|
||||
elsif Msg (I) = '&' then
|
||||
Write_Char ('"');
|
||||
|
||||
if Use_Second_Name then
|
||||
Write_Unit_Name (Error_Msg_Name_2);
|
||||
else
|
||||
Use_Second_Name := True;
|
||||
Write_Unit_Name (Error_Msg_Name_1);
|
||||
end if;
|
||||
|
||||
Write_Char ('"');
|
||||
|
||||
elsif Msg (I) /= '?' then
|
||||
Write_Char (Msg (I));
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
Write_Eol;
|
||||
end Error_Msg_Output;
|
||||
|
||||
----------------------
|
||||
-- Finalize_Binderr --
|
||||
----------------------
|
||||
|
||||
procedure Finalize_Binderr is
|
||||
begin
|
||||
-- Message giving number of errors detected (verbose mode only)
|
||||
|
||||
if Verbose_Mode then
|
||||
Write_Eol;
|
||||
|
||||
if Errors_Detected = 0 then
|
||||
Write_Str ("No errors");
|
||||
|
||||
elsif Errors_Detected = 1 then
|
||||
Write_Str ("1 error");
|
||||
|
||||
else
|
||||
Write_Int (Errors_Detected);
|
||||
Write_Str (" errors");
|
||||
end if;
|
||||
|
||||
if Warnings_Detected = 1 then
|
||||
Write_Str (", 1 warning");
|
||||
|
||||
elsif Warnings_Detected > 1 then
|
||||
Write_Str (", ");
|
||||
Write_Int (Warnings_Detected);
|
||||
Write_Str (" warnings");
|
||||
end if;
|
||||
|
||||
Write_Eol;
|
||||
end if;
|
||||
end Finalize_Binderr;
|
||||
|
||||
------------------------
|
||||
-- Initialize_Binderr --
|
||||
------------------------
|
||||
|
||||
procedure Initialize_Binderr is
|
||||
begin
|
||||
Errors_Detected := 0;
|
||||
Warnings_Detected := 0;
|
||||
end Initialize_Binderr;
|
||||
|
||||
end Binderr;
|
|
@ -0,0 +1,117 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- B I N D E R R --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.13 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-2000 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This package contains the routines to output error messages for the binder
|
||||
-- and also the routines for handling fatal error conditions in the binder.
|
||||
|
||||
with Types; use Types;
|
||||
|
||||
package Binderr is
|
||||
|
||||
Errors_Detected : Int;
|
||||
-- Number of errors detected so far
|
||||
|
||||
Warnings_Detected : Int;
|
||||
-- Number of warnings detected
|
||||
|
||||
Info_Prefix_Suppress : Boolean := False;
|
||||
-- If set to True, the normal "info: " header before messages generated
|
||||
-- by Error_Msg_Info will be omitted.
|
||||
|
||||
---------------------------------------------------------
|
||||
-- Error Message Text and Message Insertion Characters --
|
||||
---------------------------------------------------------
|
||||
|
||||
-- Error message text strings are composed of letters, digits and the
|
||||
-- special characters space, comma, period, colon and semicolon,
|
||||
-- apostrophe and parentheses. Special insertion characters can also
|
||||
-- appear which cause the error message circuit to modify the given
|
||||
-- string as follows:
|
||||
|
||||
-- Insertion character % (Percent: insert file name from Names table)
|
||||
-- The character % is replaced by the text for the file name specified
|
||||
-- by the Name_Id value stored in Error_Msg_Name_1. The name is always
|
||||
-- enclosed in quotes. A second % may appear in a single message in
|
||||
-- which case it is similarly replaced by the name which is specified
|
||||
-- by the Name_Id value stored in Error_Msg_Name_2.
|
||||
|
||||
-- Insertion character & (Ampersand: insert unit name from Names table)
|
||||
-- The character & is replaced by the text for the unit name specified
|
||||
-- by the Name_Id value stored in Error_Msg_Name_1. The name is always
|
||||
-- enclosed in quotes. A second & may appear in a single message in
|
||||
-- which case it is similarly replaced by the name which is specified
|
||||
-- by the Name_Id value stored in Error_Msg_Name_2.
|
||||
|
||||
-- Insertion character ? (Question mark: warning message)
|
||||
-- The character ?, which must be the first character in the message
|
||||
-- string, signals a warning message instead of an error message.
|
||||
|
||||
-----------------------------------------------------
|
||||
-- Global Values Used for Error Message Insertions --
|
||||
-----------------------------------------------------
|
||||
|
||||
-- The following global variables are essentially additional parameters
|
||||
-- passed to the error message routine for insertion sequences described
|
||||
-- above. The reason these are passed globally is that the insertion
|
||||
-- mechanism is essentially an untyped one in which the appropriate
|
||||
-- variables are set dependingon the specific insertion characters used.
|
||||
|
||||
Error_Msg_Name_1 : Name_Id;
|
||||
Error_Msg_Name_2 : Name_Id;
|
||||
-- Name_Id values for % insertion characters in message
|
||||
|
||||
------------------------------
|
||||
-- Error Output Subprograms --
|
||||
------------------------------
|
||||
|
||||
procedure Error_Msg (Msg : String);
|
||||
-- Output specified error message to standard error or standard output
|
||||
-- as governed by the brief and verbose switches, and update error
|
||||
-- counts appropriately
|
||||
|
||||
procedure Error_Msg_Info (Msg : String);
|
||||
-- Output information line. Indentical in effect to Error_Msg, except
|
||||
-- that the prefix is info: instead of error: and the error count is
|
||||
-- not incremented. The prefix may be suppressed by setting the global
|
||||
-- variable Info_Prefix_Suppress to True.
|
||||
|
||||
procedure Error_Msg_Output (Msg : String; Info : Boolean);
|
||||
-- Output given message, with insertions, to current message output file.
|
||||
-- The second argument is True for an info message, false for a normal
|
||||
-- warning or error message. Normally this is not called directly, but
|
||||
-- rather only by Error_Msg or Error_Msg_Info. It is called directly
|
||||
-- when the caller must control whether the output goes to stderr or
|
||||
-- stdout (Error_Msg_Output always goes to the current output file).
|
||||
|
||||
procedure Finalize_Binderr;
|
||||
-- Finalize error output for one file
|
||||
|
||||
procedure Initialize_Binderr;
|
||||
-- Initialize error output for one file
|
||||
|
||||
end Binderr;
|
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,47 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- B I N D G E N --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.7 $ --
|
||||
-- --
|
||||
-- Copyright (C) 1992,1993,1994,1995,1996 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This package contains the routines to output the binder file. This is
|
||||
-- a C program which contains the following:
|
||||
|
||||
-- initialization for main program case
|
||||
-- sequence of calls to elaboration routines in appropriate order
|
||||
-- call to main program for main program case
|
||||
|
||||
-- See the body for exact details of the file that is generated
|
||||
|
||||
package Bindgen is
|
||||
|
||||
------------------
|
||||
-- Subprograms --
|
||||
------------------
|
||||
|
||||
procedure Gen_Output_File (Filename : String);
|
||||
-- Filename is the full path name of the binder output file
|
||||
|
||||
end Bindgen;
|
|
@ -0,0 +1,273 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GBIND BINDER COMPONENTS --
|
||||
-- --
|
||||
-- B I N D U S G --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.52 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Osint; use Osint;
|
||||
with Output; use Output;
|
||||
|
||||
procedure Bindusg is
|
||||
|
||||
procedure Write_Switch_Char;
|
||||
-- Write two spaces followed by appropriate switch character
|
||||
|
||||
procedure Write_Switch_Char is
|
||||
begin
|
||||
Write_Str (" ");
|
||||
Write_Char (Switch_Character);
|
||||
end Write_Switch_Char;
|
||||
|
||||
-- Start of processing for Bindusg
|
||||
|
||||
begin
|
||||
-- Usage line
|
||||
|
||||
Write_Str ("Usage: ");
|
||||
Write_Program_Name;
|
||||
Write_Char (' ');
|
||||
Write_Str ("switches lfile");
|
||||
Write_Eol;
|
||||
Write_Eol;
|
||||
|
||||
-- Line for -aO switch
|
||||
|
||||
Write_Switch_Char;
|
||||
Write_Str ("aOdir Specify library files search path");
|
||||
Write_Eol;
|
||||
|
||||
-- Line for -aI switch
|
||||
|
||||
Write_Switch_Char;
|
||||
Write_Str ("aIdir Specify source files search path");
|
||||
Write_Eol;
|
||||
|
||||
-- Line for A switch
|
||||
|
||||
Write_Switch_Char;
|
||||
Write_Str ("A Generate binder program in Ada (default)");
|
||||
Write_Eol;
|
||||
|
||||
-- Line for -b switch
|
||||
|
||||
Write_Switch_Char;
|
||||
Write_Str ("b Generate brief messages to std");
|
||||
Write_Str ("err even if verbose mode set");
|
||||
Write_Eol;
|
||||
|
||||
-- Line for -c switch
|
||||
|
||||
Write_Switch_Char;
|
||||
Write_Str ("c Check only, no generation of b");
|
||||
Write_Str ("inder output file");
|
||||
Write_Eol;
|
||||
|
||||
-- Line for C switch
|
||||
|
||||
Write_Switch_Char;
|
||||
Write_Str ("C Generate binder program in C");
|
||||
Write_Eol;
|
||||
|
||||
-- Line for -e switch
|
||||
|
||||
Write_Switch_Char;
|
||||
Write_Str ("e Output complete list of elabor");
|
||||
Write_Str ("ation order dependencies");
|
||||
Write_Eol;
|
||||
|
||||
-- Line for -E switch
|
||||
|
||||
Write_Switch_Char;
|
||||
Write_Str ("E Store tracebacks in Exception occurrences");
|
||||
Write_Eol;
|
||||
|
||||
-- Line for -f switch
|
||||
|
||||
Write_Switch_Char;
|
||||
Write_Str ("f Force RM elaboration ordering rules");
|
||||
Write_Eol;
|
||||
|
||||
-- Line for -h switch
|
||||
|
||||
Write_Switch_Char;
|
||||
Write_Str ("h Output this usage (help) infor");
|
||||
Write_Str ("mation");
|
||||
Write_Eol;
|
||||
|
||||
-- Line for -I switch
|
||||
|
||||
Write_Switch_Char;
|
||||
Write_Str ("Idir Specify library and source files search path");
|
||||
Write_Eol;
|
||||
|
||||
-- Line for -I- switch
|
||||
|
||||
Write_Switch_Char;
|
||||
Write_Str ("I- Don't look for sources & library files");
|
||||
Write_Str (" in default directory");
|
||||
Write_Eol;
|
||||
|
||||
-- Line for -K switch
|
||||
|
||||
Write_Switch_Char;
|
||||
Write_Str ("K Give list of linker options specified for link");
|
||||
Write_Eol;
|
||||
|
||||
-- Line for -l switch
|
||||
|
||||
Write_Switch_Char;
|
||||
Write_Str ("l Output chosen elaboration order");
|
||||
Write_Eol;
|
||||
|
||||
-- Line of -L switch
|
||||
|
||||
Write_Switch_Char;
|
||||
Write_Str ("Lxyz Library build: adainit/final ");
|
||||
Write_Str ("renamed to xyzinit/final, implies -n");
|
||||
Write_Eol;
|
||||
|
||||
-- Line for -M switch
|
||||
|
||||
Write_Switch_Char;
|
||||
Write_Str ("Mxyz Rename generated main program from main to xyz");
|
||||
Write_Eol;
|
||||
|
||||
-- Line for -m switch
|
||||
|
||||
Write_Switch_Char;
|
||||
Write_Str ("mnnn Limit number of detected error");
|
||||
Write_Str ("s to nnn (1-999)");
|
||||
Write_Eol;
|
||||
|
||||
-- Line for -n switch
|
||||
|
||||
Write_Switch_Char;
|
||||
Write_Str ("n No Ada main program (foreign main routine)");
|
||||
Write_Eol;
|
||||
|
||||
-- Line for -nostdinc
|
||||
|
||||
Write_Switch_Char;
|
||||
Write_Str ("nostdinc Don't look for source files");
|
||||
Write_Str (" in the system default directory");
|
||||
Write_Eol;
|
||||
|
||||
-- Line for -nostdlib
|
||||
|
||||
Write_Switch_Char;
|
||||
Write_Str ("nostdlib Don't look for library files");
|
||||
Write_Str (" in the system default directory");
|
||||
Write_Eol;
|
||||
|
||||
-- Line for -o switch
|
||||
|
||||
Write_Switch_Char;
|
||||
Write_Str ("o file Give the output file name (default is b~xxx.adb) ");
|
||||
Write_Eol;
|
||||
|
||||
-- Line for -O switch
|
||||
|
||||
Write_Switch_Char;
|
||||
Write_Str ("O Give list of objects required for link");
|
||||
Write_Eol;
|
||||
|
||||
-- Line for -p switch
|
||||
|
||||
Write_Switch_Char;
|
||||
Write_Str ("p Pessimistic (worst-case) elaborat");
|
||||
Write_Str ("ion order");
|
||||
Write_Eol;
|
||||
|
||||
-- Line for -s switch
|
||||
|
||||
Write_Switch_Char;
|
||||
Write_Str ("s Require all source files to be");
|
||||
Write_Str (" present");
|
||||
Write_Eol;
|
||||
|
||||
-- Line for -Sxx switch
|
||||
|
||||
Write_Switch_Char;
|
||||
Write_Str ("S?? Sin/lo/hi/xx for Initialize_Scalars");
|
||||
Write_Str (" invalid/low/high/hex");
|
||||
Write_Eol;
|
||||
|
||||
-- Line for -static
|
||||
|
||||
Write_Switch_Char;
|
||||
Write_Str ("static Link against a static GNAT run time");
|
||||
Write_Eol;
|
||||
|
||||
-- Line for -shared
|
||||
|
||||
Write_Switch_Char;
|
||||
Write_Str ("shared Link against a shared GNAT run time");
|
||||
Write_Eol;
|
||||
|
||||
-- Line for -t switch
|
||||
|
||||
Write_Switch_Char;
|
||||
Write_Str ("t Tolerate time stamp and other consistency errors");
|
||||
Write_Eol;
|
||||
|
||||
-- Line for -T switch
|
||||
|
||||
Write_Switch_Char;
|
||||
Write_Str ("Tn Set time slice value to n microseconds (n >= 0)");
|
||||
Write_Eol;
|
||||
|
||||
-- Line for -v switch
|
||||
|
||||
Write_Switch_Char;
|
||||
Write_Str ("v Verbose mode. Error messages, ");
|
||||
Write_Str ("header, summary output to stdout");
|
||||
Write_Eol;
|
||||
|
||||
-- Lines for -w switch
|
||||
|
||||
Write_Switch_Char;
|
||||
Write_Str ("wx Warning mode. (x=s/e for supp");
|
||||
Write_Str ("ress/treat as error)");
|
||||
Write_Eol;
|
||||
|
||||
-- Line for -x switch
|
||||
|
||||
Write_Switch_Char;
|
||||
Write_Str ("x Exclude source files (check ob");
|
||||
Write_Str ("ject consistency only)");
|
||||
Write_Eol;
|
||||
|
||||
-- Line for -z switch
|
||||
|
||||
Write_Switch_Char;
|
||||
Write_Str ("z No main subprogram (zero main)");
|
||||
Write_Eol;
|
||||
|
||||
-- Line for sfile
|
||||
|
||||
Write_Str (" lfile Library file names");
|
||||
Write_Eol;
|
||||
|
||||
end Bindusg;
|
|
@ -0,0 +1,31 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- B I N D U S G --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.3 $ --
|
||||
-- --
|
||||
-- Copyright (C) 1992,1993,1994 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- Procedure to generate screen of usage information if no file name present
|
||||
|
||||
procedure Bindusg;
|
|
@ -0,0 +1,185 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- B U T I L --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.16 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Hostparm; use Hostparm;
|
||||
with Namet; use Namet;
|
||||
with Output; use Output;
|
||||
|
||||
package body Butil is
|
||||
|
||||
--------------------------
|
||||
-- Get_Unit_Name_String --
|
||||
--------------------------
|
||||
|
||||
procedure Get_Unit_Name_String (U : Unit_Name_Type) is
|
||||
begin
|
||||
Get_Name_String (U);
|
||||
|
||||
if Name_Buffer (Name_Len) = 's' then
|
||||
Name_Buffer (Name_Len - 1 .. Name_Len + 5) := " (spec)";
|
||||
else
|
||||
Name_Buffer (Name_Len - 1 .. Name_Len + 5) := " (body)";
|
||||
end if;
|
||||
|
||||
Name_Len := Name_Len + 5;
|
||||
end Get_Unit_Name_String;
|
||||
|
||||
----------------------
|
||||
-- Is_Internal_Unit --
|
||||
----------------------
|
||||
|
||||
-- Note: the reason we do not use the Fname package for this function
|
||||
-- is that it would drag too much junk into the binder.
|
||||
|
||||
function Is_Internal_Unit return Boolean is
|
||||
begin
|
||||
return Is_Predefined_Unit
|
||||
or else (Name_Len > 4
|
||||
and then (Name_Buffer (1 .. 5) = "gnat%"
|
||||
or else
|
||||
Name_Buffer (1 .. 5) = "gnat."))
|
||||
or else
|
||||
(OpenVMS
|
||||
and then Name_Len > 3
|
||||
and then (Name_Buffer (1 .. 4) = "dec%"
|
||||
or else
|
||||
Name_Buffer (1 .. 4) = "dec."));
|
||||
|
||||
end Is_Internal_Unit;
|
||||
|
||||
------------------------
|
||||
-- Is_Predefined_Unit --
|
||||
------------------------
|
||||
|
||||
-- Note: the reason we do not use the Fname package for this function
|
||||
-- is that it would drag too much junk into the binder.
|
||||
|
||||
function Is_Predefined_Unit return Boolean is
|
||||
begin
|
||||
return (Name_Len > 3
|
||||
and then Name_Buffer (1 .. 4) = "ada.")
|
||||
|
||||
or else (Name_Len > 6
|
||||
and then Name_Buffer (1 .. 7) = "system.")
|
||||
|
||||
or else (Name_Len > 10
|
||||
and then Name_Buffer (1 .. 11) = "interfaces.")
|
||||
|
||||
or else (Name_Len > 3
|
||||
and then Name_Buffer (1 .. 4) = "ada%")
|
||||
|
||||
or else (Name_Len > 8
|
||||
and then Name_Buffer (1 .. 9) = "calendar%")
|
||||
|
||||
or else (Name_Len > 9
|
||||
and then Name_Buffer (1 .. 10) = "direct_io%")
|
||||
|
||||
or else (Name_Len > 10
|
||||
and then Name_Buffer (1 .. 11) = "interfaces%")
|
||||
|
||||
or else (Name_Len > 13
|
||||
and then Name_Buffer (1 .. 14) = "io_exceptions%")
|
||||
|
||||
or else (Name_Len > 12
|
||||
and then Name_Buffer (1 .. 13) = "machine_code%")
|
||||
|
||||
or else (Name_Len > 13
|
||||
and then Name_Buffer (1 .. 14) = "sequential_io%")
|
||||
|
||||
or else (Name_Len > 6
|
||||
and then Name_Buffer (1 .. 7) = "system%")
|
||||
|
||||
or else (Name_Len > 7
|
||||
and then Name_Buffer (1 .. 8) = "text_io%")
|
||||
|
||||
or else (Name_Len > 20
|
||||
and then Name_Buffer (1 .. 21) = "unchecked_conversion%")
|
||||
|
||||
or else (Name_Len > 22
|
||||
and then Name_Buffer (1 .. 23) = "unchecked_deallocation%")
|
||||
|
||||
or else (Name_Len > 4
|
||||
and then Name_Buffer (1 .. 5) = "gnat%")
|
||||
|
||||
or else (Name_Len > 4
|
||||
and then Name_Buffer (1 .. 5) = "gnat.");
|
||||
end Is_Predefined_Unit;
|
||||
|
||||
----------------
|
||||
-- Uname_Less --
|
||||
----------------
|
||||
|
||||
function Uname_Less (U1, U2 : Unit_Name_Type) return Boolean is
|
||||
begin
|
||||
Get_Name_String (U1);
|
||||
|
||||
declare
|
||||
U1_Name : constant String (1 .. Name_Len) :=
|
||||
Name_Buffer (1 .. Name_Len);
|
||||
Min_Length : Natural;
|
||||
|
||||
begin
|
||||
Get_Name_String (U2);
|
||||
|
||||
if Name_Len < U1_Name'Last then
|
||||
Min_Length := Name_Len;
|
||||
else
|
||||
Min_Length := U1_Name'Last;
|
||||
end if;
|
||||
|
||||
for I in 1 .. Min_Length loop
|
||||
if U1_Name (I) > Name_Buffer (I) then
|
||||
return False;
|
||||
elsif U1_Name (I) < Name_Buffer (I) then
|
||||
return True;
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
return U1_Name'Last < Name_Len;
|
||||
end;
|
||||
end Uname_Less;
|
||||
|
||||
---------------------
|
||||
-- Write_Unit_Name --
|
||||
---------------------
|
||||
|
||||
procedure Write_Unit_Name (U : Unit_Name_Type) is
|
||||
begin
|
||||
Get_Name_String (U);
|
||||
Write_Str (Name_Buffer (1 .. Name_Len - 2));
|
||||
|
||||
if Name_Buffer (Name_Len) = 's' then
|
||||
Write_Str (" (spec)");
|
||||
else
|
||||
Write_Str (" (body)");
|
||||
end if;
|
||||
|
||||
Name_Len := Name_Len + 5;
|
||||
end Write_Unit_Name;
|
||||
|
||||
end Butil;
|
|
@ -0,0 +1,61 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- B U T I L --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.9 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Types; use Types;
|
||||
|
||||
package Butil is
|
||||
|
||||
-- This package contains utility routines for the binder
|
||||
|
||||
function Is_Predefined_Unit return Boolean;
|
||||
-- Given a unit name stored in Name_Buffer with length in Name_Len,
|
||||
-- returns True if this is the name of a predefined unit or a child of
|
||||
-- a predefined unit (including the obsolescent renamings). This is used
|
||||
-- in the preference selection (see Better_Choice in body of Binde).
|
||||
|
||||
function Is_Internal_Unit return Boolean;
|
||||
-- Given a unit name stored in Name_Buffer with length in Name_Len,
|
||||
-- returns True if this is the name of an internal unit or a child of
|
||||
-- an internal. Similar in usage to Is_Predefined_Unit.
|
||||
|
||||
-- Note: the following functions duplicate functionality in Uname, but
|
||||
-- we want to avoid bringing Uname into the binder since it generates
|
||||
-- to many unnecessary dependencies, and makes the binder too large.
|
||||
|
||||
function Uname_Less (U1, U2 : Unit_Name_Type) return Boolean;
|
||||
-- Determines if the unit name U1 is alphabetically before U2
|
||||
|
||||
procedure Get_Unit_Name_String (U : Unit_Name_Type);
|
||||
-- Compute unit name with (body) or (spec) after as required. On return
|
||||
-- the result is stored in Name_Buffer and Name_Len is the length.
|
||||
|
||||
procedure Write_Unit_Name (U : Unit_Name_Type);
|
||||
-- Output unit name with (body) or (spec) after as required. On return
|
||||
-- Name_Len is set to the number of characters which were output.
|
||||
|
||||
end Butil;
|
|
@ -0,0 +1,95 @@
|
|||
/****************************************************************************
|
||||
* *
|
||||
* GNAT COMPILER COMPONENTS *
|
||||
* *
|
||||
* C A L *
|
||||
* *
|
||||
* C Implementation File *
|
||||
* *
|
||||
* $Revision: 1.1 $
|
||||
* *
|
||||
* Copyright (C) 1992-2001, 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- *
|
||||
* 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. *
|
||||
* *
|
||||
* As a special exception, if you link this file with other files to *
|
||||
* produce an executable, this file does not by itself cause the resulting *
|
||||
* executable to be covered by the GNU General Public License. This except- *
|
||||
* ion does not however invalidate any other reasons why the executable *
|
||||
* file might be covered by the GNU Public License. *
|
||||
* *
|
||||
* GNAT was originally developed by the GNAT team at New York University. *
|
||||
* It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). *
|
||||
* *
|
||||
****************************************************************************/
|
||||
|
||||
/* This file contains those routines named by Import pragmas in package */
|
||||
/* GNAT.Calendar. It is used to to Duration to timeval convertion. */
|
||||
/* These are simple wrappers function to abstarct the fact that the C */
|
||||
/* struct timeval fields type are not normalized (they are generaly */
|
||||
/* defined as int or long values). */
|
||||
|
||||
#if defined(VMS)
|
||||
|
||||
/* this is temporary code to avoid build failure under VMS */
|
||||
|
||||
void
|
||||
__gnat_timeval_to_duration (void *t, long *sec, long *usec)
|
||||
{
|
||||
}
|
||||
|
||||
void
|
||||
__gnat_duration_to_timeval (long sec, long usec, void *t)
|
||||
{
|
||||
}
|
||||
|
||||
#else
|
||||
|
||||
#if defined (__vxworks)
|
||||
#include <sys/times.h>
|
||||
#else
|
||||
#include <sys/time.h>
|
||||
#endif
|
||||
|
||||
void
|
||||
__gnat_timeval_to_duration (struct timeval *t, long *sec, long *usec)
|
||||
{
|
||||
*sec = (long) t->tv_sec;
|
||||
*usec = (long) t->tv_usec;
|
||||
}
|
||||
|
||||
void
|
||||
__gnat_duration_to_timeval (long sec, long usec, struct timeval *t)
|
||||
{
|
||||
/* here we are doing implicit convertion from a long to the struct timeval
|
||||
fields types. */
|
||||
|
||||
t->tv_sec = sec;
|
||||
t->tv_usec = usec;
|
||||
}
|
||||
#endif
|
||||
|
||||
#ifdef __alpha_vxworks
|
||||
#include "vxWorks.h"
|
||||
#elif defined (__vxworks)
|
||||
#include <types/vxTypesOld.h>
|
||||
#endif
|
||||
|
||||
/* Return the value of the "time" C library function. We always return
|
||||
a long and do it this way to avoid problems with not knowing
|
||||
what time_t is on the target. */
|
||||
|
||||
long
|
||||
gnat_time ()
|
||||
{
|
||||
return time (0);
|
||||
}
|
|
@ -0,0 +1,20 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT RUNTIME COMPONENTS --
|
||||
-- --
|
||||
-- C A L E N D A R --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.6 $ --
|
||||
-- --
|
||||
-- This specification is adapted from the Ada Reference Manual for use with --
|
||||
-- GNAT. In accordance with the copyright of that document, you can freely --
|
||||
-- copy and modify this specification, provided that if you redistribute a --
|
||||
-- modified version, any changes that you have made are clearly indicated. --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Ada.Calendar;
|
||||
|
||||
package Calendar renames Ada.Calendar;
|
|
@ -0,0 +1,186 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- C A S I N G --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.23 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- As a special exception, if other files instantiate generics from this --
|
||||
-- unit, or you link this unit with other files to produce an executable, --
|
||||
-- this unit does not by itself cause the resulting executable to be --
|
||||
-- covered by the GNU General Public License. This exception does not --
|
||||
-- however invalidate any other reasons why the executable file might be --
|
||||
-- covered by the GNU Public License. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Csets; use Csets;
|
||||
with Namet; use Namet;
|
||||
with Opt; use Opt;
|
||||
with Types; use Types;
|
||||
with Widechar; use Widechar;
|
||||
|
||||
package body Casing is
|
||||
|
||||
----------------------
|
||||
-- Determine_Casing --
|
||||
----------------------
|
||||
|
||||
function Determine_Casing (Ident : Text_Buffer) return Casing_Type is
|
||||
|
||||
All_Lower : Boolean := True;
|
||||
-- Set False if upper case letter found
|
||||
|
||||
All_Upper : Boolean := True;
|
||||
-- Set False if lower case letter found
|
||||
|
||||
Mixed : Boolean := True;
|
||||
-- Set False if exception to mixed case rule found (lower case letter
|
||||
-- at start or after underline, or upper case letter elsewhere).
|
||||
|
||||
Decisive : Boolean := False;
|
||||
-- Set True if at least one instance of letter not after underline
|
||||
|
||||
After_Und : Boolean := True;
|
||||
-- True at start of string, and after an underline character
|
||||
|
||||
begin
|
||||
for S in Ident'Range loop
|
||||
if Ident (S) = '_' or else Ident (S) = '.' then
|
||||
After_Und := True;
|
||||
|
||||
elsif Is_Lower_Case_Letter (Ident (S)) then
|
||||
All_Upper := False;
|
||||
|
||||
if not After_Und then
|
||||
Decisive := True;
|
||||
else
|
||||
After_Und := False;
|
||||
Mixed := False;
|
||||
end if;
|
||||
|
||||
elsif Is_Upper_Case_Letter (Ident (S)) then
|
||||
All_Lower := False;
|
||||
|
||||
if not After_Und then
|
||||
Decisive := True;
|
||||
Mixed := False;
|
||||
else
|
||||
After_Und := False;
|
||||
end if;
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
-- Now we can figure out the result from the flags we set in that loop
|
||||
|
||||
if All_Lower then
|
||||
return All_Lower_Case;
|
||||
|
||||
elsif not Decisive then
|
||||
return Unknown;
|
||||
|
||||
elsif All_Upper then
|
||||
return All_Upper_Case;
|
||||
|
||||
elsif Mixed then
|
||||
return Mixed_Case;
|
||||
|
||||
else
|
||||
return Unknown;
|
||||
end if;
|
||||
end Determine_Casing;
|
||||
|
||||
------------------------
|
||||
-- Set_All_Upper_Case --
|
||||
------------------------
|
||||
|
||||
procedure Set_All_Upper_Case is
|
||||
begin
|
||||
Set_Casing (All_Upper_Case);
|
||||
end Set_All_Upper_Case;
|
||||
|
||||
----------------
|
||||
-- Set_Casing --
|
||||
----------------
|
||||
|
||||
procedure Set_Casing (C : Casing_Type; D : Casing_Type := Mixed_Case) is
|
||||
Ptr : Natural;
|
||||
|
||||
Actual_Casing : Casing_Type;
|
||||
-- Set from C or D as appropriate
|
||||
|
||||
After_Und : Boolean := True;
|
||||
-- True at start of string, and after an underline character or after
|
||||
-- any other special character that is not a normal identifier char).
|
||||
|
||||
begin
|
||||
if C /= Unknown then
|
||||
Actual_Casing := C;
|
||||
else
|
||||
Actual_Casing := D;
|
||||
end if;
|
||||
|
||||
Ptr := 1;
|
||||
|
||||
while Ptr <= Name_Len loop
|
||||
if Name_Buffer (Ptr) = ASCII.ESC
|
||||
or else Name_Buffer (Ptr) = '['
|
||||
or else (Upper_Half_Encoding
|
||||
and then Name_Buffer (Ptr) in Upper_Half_Character)
|
||||
then
|
||||
Skip_Wide (Name_Buffer, Ptr);
|
||||
After_Und := False;
|
||||
|
||||
elsif Name_Buffer (Ptr) = '_'
|
||||
or else not Identifier_Char (Name_Buffer (Ptr))
|
||||
then
|
||||
After_Und := True;
|
||||
Ptr := Ptr + 1;
|
||||
|
||||
elsif Is_Lower_Case_Letter (Name_Buffer (Ptr)) then
|
||||
if Actual_Casing = All_Upper_Case
|
||||
or else (After_Und and then Actual_Casing = Mixed_Case)
|
||||
then
|
||||
Name_Buffer (Ptr) := Fold_Upper (Name_Buffer (Ptr));
|
||||
end if;
|
||||
|
||||
After_Und := False;
|
||||
Ptr := Ptr + 1;
|
||||
|
||||
elsif Is_Upper_Case_Letter (Name_Buffer (Ptr)) then
|
||||
if Actual_Casing = All_Lower_Case
|
||||
or else (not After_Und and then Actual_Casing = Mixed_Case)
|
||||
then
|
||||
Name_Buffer (Ptr) := Fold_Lower (Name_Buffer (Ptr));
|
||||
end if;
|
||||
|
||||
After_Und := False;
|
||||
Ptr := Ptr + 1;
|
||||
|
||||
else -- all other characters
|
||||
After_Und := False;
|
||||
Ptr := Ptr + 1;
|
||||
end if;
|
||||
end loop;
|
||||
end Set_Casing;
|
||||
|
||||
end Casing;
|
|
@ -0,0 +1,90 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- C A S I N G --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.12 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-2000 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- As a special exception, if other files instantiate generics from this --
|
||||
-- unit, or you link this unit with other files to produce an executable, --
|
||||
-- this unit does not by itself cause the resulting executable to be --
|
||||
-- covered by the GNU General Public License. This exception does not --
|
||||
-- however invalidate any other reasons why the executable file might be --
|
||||
-- covered by the GNU Public License. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Types; use Types;
|
||||
|
||||
package Casing is
|
||||
|
||||
-- This package contains data and subprograms to support the feature that
|
||||
-- recognizes the letter case styles used in the source program being
|
||||
-- compiled, and uses this information for error message formatting, and
|
||||
-- for recognizing reserved words that are misused as identifiers.
|
||||
|
||||
-------------------------------
|
||||
-- Case Control Declarations --
|
||||
-------------------------------
|
||||
|
||||
-- Declaration of type for describing casing convention
|
||||
|
||||
type Casing_Type is (
|
||||
|
||||
All_Upper_Case,
|
||||
-- All letters are upper case
|
||||
|
||||
All_Lower_Case,
|
||||
-- All letters are lower case
|
||||
|
||||
Mixed_Case,
|
||||
-- The initial letter, and any letters after underlines are upper case.
|
||||
-- All other letters are lower case
|
||||
|
||||
Unknown
|
||||
-- Used if an identifier does not distinguish between the above cases,
|
||||
-- (e.g. X, Y_3, M4, A_B, or if it is inconsistent ABC_def).
|
||||
);
|
||||
|
||||
------------------------------
|
||||
-- Case Control Subprograms --
|
||||
------------------------------
|
||||
|
||||
procedure Set_Casing (C : Casing_Type; D : Casing_Type := Mixed_Case);
|
||||
-- Takes the name stored in the first Name_Len positions of Name_Buffer
|
||||
-- and modifies it to be consistent with the casing given by C, or if
|
||||
-- C = Unknown, then with the casing given by D. The name is basically
|
||||
-- treated as an identifier, except that special separator characters
|
||||
-- other than underline are permitted and treated like underlines (this
|
||||
-- handles cases like minus and period in unit names, apostrophes in error
|
||||
-- messages, angle brackets in names like <any_type>, etc).
|
||||
|
||||
procedure Set_All_Upper_Case;
|
||||
pragma Inline (Set_All_Upper_Case);
|
||||
-- This procedure is called with an identifier name stored in Name_Buffer.
|
||||
-- On return, the identifier is converted to all upper case. The call is
|
||||
-- equivalent to Set_Casing (All_Upper_Case).
|
||||
|
||||
function Determine_Casing (Ident : Text_Buffer) return Casing_Type;
|
||||
-- Determines the casing of the identifier/keyword string Ident
|
||||
|
||||
end Casing;
|
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,526 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- C H E C K S --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.55 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- Package containing routines used to deal with runtime checks. These
|
||||
-- routines are used both by the semantics and by the expander. In some
|
||||
-- cases, checks are enabled simply by setting flags for gigi, and in
|
||||
-- other cases the code for the check is expanded.
|
||||
|
||||
-- The approach used for range and length checks, in regards to suppressed
|
||||
-- checks, is to attempt to detect at compilation time that a constraint
|
||||
-- error will occur. If this is detected a warning or error is issued and the
|
||||
-- offending expression or statement replaced with a constraint error node.
|
||||
-- This always occurs whether checks are suppressed or not. Dynamic range
|
||||
-- checks are, of course, not inserted if checks are suppressed.
|
||||
|
||||
with Types; use Types;
|
||||
with Uintp; use Uintp;
|
||||
|
||||
package Checks is
|
||||
|
||||
procedure Initialize;
|
||||
-- Called for each new main source program, to initialize internal
|
||||
-- variables used in the package body of the Checks unit.
|
||||
|
||||
function Access_Checks_Suppressed (E : Entity_Id) return Boolean;
|
||||
function Accessibility_Checks_Suppressed (E : Entity_Id) return Boolean;
|
||||
function Discriminant_Checks_Suppressed (E : Entity_Id) return Boolean;
|
||||
function Division_Checks_Suppressed (E : Entity_Id) return Boolean;
|
||||
function Elaboration_Checks_Suppressed (E : Entity_Id) return Boolean;
|
||||
function Index_Checks_Suppressed (E : Entity_Id) return Boolean;
|
||||
function Length_Checks_Suppressed (E : Entity_Id) return Boolean;
|
||||
function Overflow_Checks_Suppressed (E : Entity_Id) return Boolean;
|
||||
function Range_Checks_Suppressed (E : Entity_Id) return Boolean;
|
||||
function Storage_Checks_Suppressed (E : Entity_Id) return Boolean;
|
||||
function Tag_Checks_Suppressed (E : Entity_Id) return Boolean;
|
||||
-- These functions check to see if the named check is suppressed,
|
||||
-- either by an active scope suppress setting, or because the check
|
||||
-- has been specifically suppressed for the given entity. If no entity
|
||||
-- is relevant for the current check, then Empty is used as an argument.
|
||||
-- Note: the reason we insist on specifying Empty is to force the
|
||||
-- caller to think about whether there is any relevant entity that
|
||||
-- should be checked.
|
||||
|
||||
-- General note on following checks. These checks are always active if
|
||||
-- Expander_Active and not Inside_A_Generic. They are inactive and have
|
||||
-- no effect Inside_A_Generic. In the case where not Expander_Active
|
||||
-- and not Inside_A_Generic, most of them are inactive, but some of them
|
||||
-- operate anyway since they may generate useful compile time warnings.
|
||||
|
||||
procedure Apply_Access_Check (N : Node_Id);
|
||||
-- Determines whether an expression node should be flagged as needing
|
||||
-- a runtime access check. If the node requires such a check, the
|
||||
-- Do_Access_Check flag is turned on.
|
||||
|
||||
procedure Apply_Accessibility_Check (N : Node_Id; Typ : Entity_Id);
|
||||
-- Given a name N denoting an access parameter, emits a run-time
|
||||
-- accessibility check (if necessary), checking that the level of
|
||||
-- the object denoted by the access parameter is not deeper than the
|
||||
-- level of the type Typ. Program_Error is raised if the check fails.
|
||||
|
||||
procedure Apply_Array_Size_Check (N : Node_Id; Typ : Entity_Id);
|
||||
-- N is the node for an object declaration that declares an object of
|
||||
-- array type Typ. This routine generates, if necessary, a check that
|
||||
-- the size of the array is not too large, raising Storage_Error if so.
|
||||
|
||||
procedure Apply_Arithmetic_Overflow_Check (N : Node_Id);
|
||||
-- Given a binary arithmetic operator (+ - *) expand a software integer
|
||||
-- overflow check using range checks on a larger checking type or a call
|
||||
-- to an appropriate runtime routine. This is used for all three operators
|
||||
-- for the signed integer case, and for +/- in the fixed-point case. The
|
||||
-- check is expanded only if Software_Overflow_Checking is enabled and
|
||||
-- Do_Overflow_Check is set on node N. Note that divide is handled
|
||||
-- separately using Apply_Arithmetic_Divide_Overflow_Check.
|
||||
|
||||
procedure Apply_Constraint_Check
|
||||
(N : Node_Id;
|
||||
Typ : Entity_Id;
|
||||
No_Sliding : Boolean := False);
|
||||
-- Top-level procedure, calls all the others depending on the class of Typ.
|
||||
-- Checks that expression N verifies the constraint of type Typ. No_Sliding
|
||||
-- is only relevant for constrained array types, id set to true, it
|
||||
-- checks that indexes are in range.
|
||||
|
||||
procedure Apply_Discriminant_Check
|
||||
(N : Node_Id;
|
||||
Typ : Entity_Id;
|
||||
Lhs : Node_Id := Empty);
|
||||
-- Given an expression N of a discriminated type, or of an access type
|
||||
-- whose designated type is a discriminanted type, generates a check to
|
||||
-- ensure that the expression can be converted to the subtype given as
|
||||
-- the second parameter. Lhs is empty except in the case of assignments,
|
||||
-- where the target object may be needed to determine the subtype to
|
||||
-- check against (such as the cases of unconstrained formal parameters
|
||||
-- and unconstrained aliased objects). For the case of unconstrained
|
||||
-- formals, the check is peformed only if the corresponding actual is
|
||||
-- constrained, i.e., whether Lhs'Constrained is True.
|
||||
|
||||
function Build_Discriminant_Checks
|
||||
(N : Node_Id;
|
||||
T_Typ : Entity_Id)
|
||||
return Node_Id;
|
||||
-- Subsidiary routine for Apply_Discriminant_Check. Builds the expression
|
||||
-- that compares discriminants of the expression with discriminants of the
|
||||
-- type. Also used directly for membership tests (see Exp_Ch4.Expand_N_In).
|
||||
|
||||
procedure Apply_Divide_Check (N : Node_Id);
|
||||
-- The node kind is N_Op_Divide, N_Op_Mod, or N_Op_Rem. An appropriate
|
||||
-- check is generated to ensure that the right operand is non-zero. In
|
||||
-- the divide case, we also check that we do not have the annoying case
|
||||
-- of the largest negative number divided by minus one.
|
||||
|
||||
procedure Apply_Type_Conversion_Checks (N : Node_Id);
|
||||
-- N is an N_Type_Conversion node. A type conversion actually involves
|
||||
-- two sorts of checks. The first check is the checks that ensures that
|
||||
-- the operand in the type conversion fits onto the base type of the
|
||||
-- subtype it is being converted to (see RM 4.6 (28)-(50)). The second
|
||||
-- check is there to ensure that once the operand has been converted to
|
||||
-- a value of the target type, this converted value meets the
|
||||
-- constraints imposed by the target subtype (see RM 4.6 (51)).
|
||||
|
||||
procedure Apply_Universal_Integer_Attribute_Checks (N : Node_Id);
|
||||
-- The argument N is an attribute reference node intended for processing
|
||||
-- by gigi. The attribute is one that returns a universal integer, but
|
||||
-- the attribute reference node is currently typed with the expected
|
||||
-- result type. This routine deals with range and overflow checks needed
|
||||
-- to make sure that the universal result is in range.
|
||||
|
||||
procedure Determine_Range
|
||||
(N : Node_Id;
|
||||
OK : out Boolean;
|
||||
Lo : out Uint;
|
||||
Hi : out Uint);
|
||||
-- N is a node for a subexpression. If N is of a discrete type with
|
||||
-- no error indications, and no other peculiarities (e.g. missing
|
||||
-- type fields), then OK is True on return, and Lo and Hi are set
|
||||
-- to a conservative estimate of the possible range of values of N.
|
||||
-- Thus if OK is True on return, the value of the subexpression N is
|
||||
-- known to like in the range Lo .. Hi (inclusive). If the expression
|
||||
-- is not of a discrete type, or some kind of error condition is
|
||||
-- detected, then OK is False on exit, and Lo/Hi are set to No_Uint.
|
||||
-- Thus the significance of OK being False on return is that no
|
||||
-- useful information is available on the range of the expression.
|
||||
|
||||
-----------------------------
|
||||
-- Length and Range Checks --
|
||||
-----------------------------
|
||||
|
||||
-- In the following procedures, there are three arguments which have
|
||||
-- a common meaning as follows:
|
||||
|
||||
-- Expr The expression to be checked. If a check is required,
|
||||
-- the appropriate flag will be placed on this node. Whether
|
||||
-- this node is further examined depends on the setting of
|
||||
-- the parameter Source_Typ, as described below.
|
||||
|
||||
-- Target_Typ The target type on which the check is to be based. For
|
||||
-- example, if we have a scalar range check, then the check
|
||||
-- is that we are in range of this type.
|
||||
|
||||
-- Source_Typ Normally Empty, but can be set to a type, in which case
|
||||
-- this type is used for the check, see below.
|
||||
|
||||
-- The checks operate in one of two modes:
|
||||
|
||||
-- If Source_Typ is Empty, then the node Expr is examined, at the
|
||||
-- very least to get the source subtype. In addition for some of
|
||||
-- the checks, the actual form of the node may be examined. For
|
||||
-- example, a node of type Integer whose actual form is an Integer
|
||||
-- conversion from a type with range 0 .. 3 can be determined to
|
||||
-- have a value in the range 0 .. 3.
|
||||
|
||||
-- If Source_Typ is given, then nothing can be assumed about the
|
||||
-- Expr, and indeed its contents are not examined. In this case the
|
||||
-- check is based on the assumption that Expr can be an arbitrary
|
||||
-- value of the given Source_Typ.
|
||||
|
||||
-- Currently, the only case in which a Source_Typ is explicitly supplied
|
||||
-- is for the case of Out and In_Out parameters, where, for the conversion
|
||||
-- on return (the Out direction), the types must be reversed. This is
|
||||
-- handled by the caller.
|
||||
|
||||
procedure Apply_Length_Check
|
||||
(Ck_Node : Node_Id;
|
||||
Target_Typ : Entity_Id;
|
||||
Source_Typ : Entity_Id := Empty);
|
||||
-- This procedure builds a sequence of declarations to do a length check
|
||||
-- that checks if the lengths of the two arrays Target_Typ and source type
|
||||
-- are the same. The resulting actions are inserted at Node using a call
|
||||
-- to Insert_Actions.
|
||||
--
|
||||
-- For access types, the Directly_Designated_Type is retrieved and
|
||||
-- processing continues as enumerated above, with a guard against
|
||||
-- null values.
|
||||
--
|
||||
-- Note: calls to Apply_Length_Check currently never supply an explicit
|
||||
-- Source_Typ parameter, but Apply_Length_Check takes this parameter and
|
||||
-- processes it as described above for consistency with the other routines
|
||||
-- in this section.
|
||||
|
||||
procedure Apply_Range_Check
|
||||
(Ck_Node : Node_Id;
|
||||
Target_Typ : Entity_Id;
|
||||
Source_Typ : Entity_Id := Empty);
|
||||
-- For an Node of kind N_Range, constructs a range check action that
|
||||
-- tests first that the range is not null and then that the range
|
||||
-- is contained in the Target_Typ range.
|
||||
--
|
||||
-- For scalar types, constructs a range check action that first tests that
|
||||
-- the expression is contained in the Target_Typ range. The difference
|
||||
-- between this and Apply_Scalar_Range_Check is that the latter generates
|
||||
-- the actual checking code in gigi against the Etype of the expression.
|
||||
--
|
||||
-- For constrained array types, construct series of range check actions
|
||||
-- to check that each Expr range is properly contained in the range of
|
||||
-- Target_Typ.
|
||||
--
|
||||
-- For a type conversion to an unconstrained array type, constructs
|
||||
-- a range check action to check that the bounds of the source type
|
||||
-- are within the constraints imposed by the Target_Typ.
|
||||
--
|
||||
-- For access types, the Directly_Designated_Type is retrieved and
|
||||
-- processing continues as enumerated above, with a guard against
|
||||
-- null values.
|
||||
--
|
||||
-- The source type is used by type conversions to unconstrained array
|
||||
-- types to retrieve the corresponding bounds.
|
||||
|
||||
procedure Apply_Static_Length_Check
|
||||
(Expr : Node_Id;
|
||||
Target_Typ : Entity_Id;
|
||||
Source_Typ : Entity_Id := Empty);
|
||||
-- Tries to determine statically whether the two array types source type
|
||||
-- and Target_Typ have the same length. If it can be determined at compile
|
||||
-- time that they do not, then an N_Raise_Constraint_Error node replaces
|
||||
-- Expr, and a warning message is issued.
|
||||
|
||||
procedure Apply_Scalar_Range_Check
|
||||
(Expr : Node_Id;
|
||||
Target_Typ : Entity_Id;
|
||||
Source_Typ : Entity_Id := Empty;
|
||||
Fixed_Int : Boolean := False);
|
||||
-- For scalar types, determines whether an expression node should be
|
||||
-- flagged as needing a runtime range check. If the node requires such
|
||||
-- a check, the Do_Range_Check flag is turned on. The Fixed_Int flag
|
||||
-- if set causes any fixed-point values to be treated as though they
|
||||
-- were discrete values (i.e. the underlying integer value is used).
|
||||
|
||||
type Check_Result is private;
|
||||
-- Type used to return result of Range_Check call, for later use in
|
||||
-- call to Insert_Range_Checks procedure.
|
||||
|
||||
procedure Append_Range_Checks
|
||||
(Checks : Check_Result;
|
||||
Stmts : List_Id;
|
||||
Suppress_Typ : Entity_Id;
|
||||
Static_Sloc : Source_Ptr;
|
||||
Flag_Node : Node_Id);
|
||||
-- Called to append range checks as returned by a call to Range_Check.
|
||||
-- Stmts is a list to which either the dynamic check is appended or
|
||||
-- the raise Constraint_Error statement is appended (for static checks).
|
||||
-- Static_Sloc is the Sloc at which the raise CE node points,
|
||||
-- Flag_Node is used as the node at which to set the Has_Dynamic_Check
|
||||
-- flag. Checks_On is a boolean value that says if range and index checking
|
||||
-- is on or not.
|
||||
|
||||
procedure Enable_Range_Check (N : Node_Id);
|
||||
pragma Inline (Enable_Range_Check);
|
||||
-- Set Do_Range_Check flag in node N to True unless Kill_Range_Check flag
|
||||
-- is set in N (the purpose of the latter flag is precisely to prevent
|
||||
-- Do_Range_Check from being set).
|
||||
|
||||
procedure Insert_Range_Checks
|
||||
(Checks : Check_Result;
|
||||
Node : Node_Id;
|
||||
Suppress_Typ : Entity_Id;
|
||||
Static_Sloc : Source_Ptr := No_Location;
|
||||
Flag_Node : Node_Id := Empty;
|
||||
Do_Before : Boolean := False);
|
||||
-- Called to insert range checks as returned by a call to Range_Check.
|
||||
-- Node is the node after which either the dynamic check is inserted or
|
||||
-- the raise Constraint_Error statement is inserted (for static checks).
|
||||
-- Suppress_Typ is the type to check to determine if checks are suppressed.
|
||||
-- Static_Sloc, if passed, is the Sloc at which the raise CE node points,
|
||||
-- otherwise Sloc (Node) is used. The Has_Dynamic_Check flag is normally
|
||||
-- set at Node. If Flag_Node is present, then this is used instead as the
|
||||
-- node at which to set the Has_Dynamic_Check flag. Normally the check is
|
||||
-- inserted after, if Do_Before is True, the check is inserted before
|
||||
-- Node.
|
||||
|
||||
function Range_Check
|
||||
(Ck_Node : Node_Id;
|
||||
Target_Typ : Entity_Id;
|
||||
Source_Typ : Entity_Id := Empty;
|
||||
Warn_Node : Node_Id := Empty)
|
||||
return Check_Result;
|
||||
-- Like Apply_Range_Check, except it does not modify anything. Instead
|
||||
-- it returns an encapsulated result of the check operations for later
|
||||
-- use in a call to Insert_Range_Checks. If Warn_Node is non-empty, its
|
||||
-- Sloc is used, in the static case, for the generated warning or error.
|
||||
-- Additionally, it is used rather than Expr (or Low/High_Bound of Expr)
|
||||
-- in constructing the check.
|
||||
|
||||
-----------------------
|
||||
-- Validity Checking --
|
||||
-----------------------
|
||||
|
||||
-- In (RM 13.9.1(9-11)) we have the following rules on invalid values
|
||||
|
||||
-- 9 If the representation of a scalar object does not represent a
|
||||
-- value of the object's subtype (perhaps because the object was not
|
||||
-- initialized), the object is said to have an invalid representation.
|
||||
-- It is a bounded error to evaluate the value of such an object. If
|
||||
-- the error is detected, either Constraint_Error or Program_Error is
|
||||
-- raised. Otherwise, execution continues using the invalid
|
||||
-- representation. The rules of the language outside this subclause
|
||||
-- assume that all objects have valid representations. The semantics
|
||||
-- of operations on invalid representations are as follows:
|
||||
--
|
||||
-- 10 If the representation of the object represents a value of the
|
||||
-- object's type, the value of the type is used.
|
||||
--
|
||||
-- 11 If the representation of the object does not represent a value
|
||||
-- of the object's type, the semantics of operations on such
|
||||
-- representations is implementation-defined, but does not by
|
||||
-- itself lead to erroneous or unpredictable execution, or to
|
||||
-- other objects becoming abnormal.
|
||||
|
||||
-- We quote the rules in full here since they are quite delicate. Most
|
||||
-- of the time, we can just compute away with wrong values, and get a
|
||||
-- possibly wrong result, which is well within the range of allowed
|
||||
-- implementation defined behavior. The two tricky cases are subscripted
|
||||
-- array assignments, where we don't want to do wild stores, and case
|
||||
-- statements where we don't want to do wild jumps.
|
||||
|
||||
-- In GNAT, we control validity checking with a switch -gnatV that
|
||||
-- can take three parameters, n/d/f for None/Default/Full. These
|
||||
-- modes have the following meanings:
|
||||
|
||||
-- None (no validity checking)
|
||||
|
||||
-- In this mode, there is no specific checking for invalid values
|
||||
-- and the code generator assumes that all stored values are always
|
||||
-- within the bounds of the object subtype. The consequences are as
|
||||
-- follows:
|
||||
|
||||
-- For case statements, an out of range invalid value will cause
|
||||
-- Constraint_Error to be raised, or an arbitrary one of the case
|
||||
-- alternatives will be executed. Wild jumps cannot result even
|
||||
-- in this mode, since we always do a range check
|
||||
|
||||
-- For subscripted array assignments, wild stores will result in
|
||||
-- the expected manner when addresses are calculated using values
|
||||
-- of subscripts that are out of range.
|
||||
|
||||
-- It could perhaps be argued that this mode is still conformant with
|
||||
-- the letter of the RM, since implementation defined is a rather
|
||||
-- broad category, but certainly it is not in the spirit of the
|
||||
-- RM requirement, since wild stores certainly seem to be a case of
|
||||
-- erroneous behavior.
|
||||
|
||||
-- Default (default standard RM-compatible validity checking)
|
||||
|
||||
-- In this mode, which is the default, minimal validity checking is
|
||||
-- performed to ensure no erroneous behavior as follows:
|
||||
|
||||
-- For case statements, an out of range invalid value will cause
|
||||
-- Constraint_Error to be raised.
|
||||
|
||||
-- For subscripted array assignments, invalid out of range
|
||||
-- subscript values will cause Constraint_Error to be raised.
|
||||
|
||||
-- Full (Full validity checking)
|
||||
|
||||
-- In this mode, the protections guaranteed by the standard mode are
|
||||
-- in place, and the following additional checks are made:
|
||||
|
||||
-- For every assignment, the right side is checked for validity
|
||||
|
||||
-- For every call, IN and IN OUT parameters are checked for validity
|
||||
|
||||
-- For every subscripted array reference, both for stores and loads,
|
||||
-- all subscripts are checked for validity.
|
||||
|
||||
-- These checks are not required by the RM, but will in practice
|
||||
-- improve the detection of uninitialized variables, particularly
|
||||
-- if used in conjunction with pragma Normalize_Scalars.
|
||||
|
||||
-- In the above description, we talk about performing validity checks,
|
||||
-- but we don't actually generate a check in a case where the compiler
|
||||
-- can be sure that the value is valid. Note that this assurance must
|
||||
-- be achieved without assuming that any uninitialized value lies within
|
||||
-- the range of its type. The following are cases in which values are
|
||||
-- known to be valid. The flag Is_Known_Valid is used to keep track of
|
||||
-- some of these cases.
|
||||
|
||||
-- If all possible stored values are valid, then any uninitialized
|
||||
-- value must be valid.
|
||||
|
||||
-- Literals, including enumeration literals, are clearly always valid.
|
||||
|
||||
-- Constants are always assumed valid, with a validity check being
|
||||
-- performed on the initializing value where necessary to ensure that
|
||||
-- this is the case.
|
||||
|
||||
-- For variables, the status is set to known valid if there is an
|
||||
-- initializing expression. Again a check is made on the initializing
|
||||
-- value if necessary to ensure that this assumption is valid. The
|
||||
-- status can change as a result of local assignments to a variable.
|
||||
-- If a known valid value is unconditionally assigned, then we mark
|
||||
-- the left side as known valid. If a value is assigned that is not
|
||||
-- known to be valid, then we mark the left side as invalid. This
|
||||
-- kind of processing does NOT apply to non-local variables since we
|
||||
-- are not following the flow graph (more properly the flow of actual
|
||||
-- processing only corresponds to the flow graph for local assignments).
|
||||
-- For non-local variables, we preserve the current setting, i.e. a
|
||||
-- validity check is performed when assigning to a knonwn valid global.
|
||||
|
||||
-- Note: no validity checking is required if range checks are suppressed
|
||||
-- regardless of the setting of the validity checking mode.
|
||||
|
||||
-- The following procedures are used in handling validity checking
|
||||
|
||||
procedure Apply_Subscript_Validity_Checks (Expr : Node_Id);
|
||||
-- Expr is the node for an indexed component. If validity checking and
|
||||
-- range checking are enabled, all subscripts for this indexed component
|
||||
-- are checked for validity.
|
||||
|
||||
procedure Check_Valid_Lvalue_Subscripts (Expr : Node_Id);
|
||||
-- Expr is a lvalue, i.e. an expression representing the target of
|
||||
-- an assignment. This procedure checks for this expression involving
|
||||
-- an assignment to an array value. We have to be sure that all the
|
||||
-- subscripts in such a case are valid, since according to the rules
|
||||
-- in (RM 13.9.1(9-11)) such assignments are not permitted to result
|
||||
-- in erroneous behavior in the case of invalid subscript values.
|
||||
|
||||
procedure Ensure_Valid (Expr : Node_Id; Holes_OK : Boolean := False);
|
||||
-- Ensure that Expr represents a valid value of its type. If this type
|
||||
-- is not a scalar type, then the call has no effect, since validity
|
||||
-- is only an issue for scalar types. The effect of this call is to
|
||||
-- check if the value is known valid, if so, nothing needs to be done.
|
||||
-- If this is not known, then either Expr is set to be range checked,
|
||||
-- or specific checking code is inserted so that an exception is raised
|
||||
-- if the value is not valid.
|
||||
--
|
||||
-- The optional argument Holes_OK indicates whether it is necessary to
|
||||
-- worry about enumeration types with non-standard representations leading
|
||||
-- to "holes" in the range of possible representations. If Holes_OK is
|
||||
-- True, then such values are assumed valid (this is used when the caller
|
||||
-- will make a separate check for this case anyway). If Holes_OK is False,
|
||||
-- then this case is checked, and code is inserted to ensure that Expr is
|
||||
-- valid, raising Constraint_Error if the value is not valid.
|
||||
|
||||
function Expr_Known_Valid (Expr : Node_Id) return Boolean;
|
||||
-- This function tests it the value of Expr is known to be valid in
|
||||
-- the sense of RM 13.9.1(9-11). In the case of GNAT, it is only
|
||||
-- discrete types which are a concern, since for non-discrete types
|
||||
-- we simply continue computation with invalid values, which does
|
||||
-- not lead to erroneous behavior. Thus Expr_Known_Valid always
|
||||
-- returns True if the type of Expr is non-discrete. For discrete
|
||||
-- types the value returned is True only if it can be determined
|
||||
-- that the value is Valid. Otherwise False is returned.
|
||||
|
||||
procedure Insert_Valid_Check (Expr : Node_Id);
|
||||
-- Inserts code that will check for the value of Expr being valid, in
|
||||
-- the sense of the 'Valid attribute returning True. Constraint_Error
|
||||
-- will be raised if the value is not valid.
|
||||
|
||||
private
|
||||
|
||||
type Check_Result is array (Positive range 1 .. 2) of Node_Id;
|
||||
-- There are two cases for the result returned by Range_Check:
|
||||
--
|
||||
-- For the static case the result is one or two nodes that should cause
|
||||
-- a Constraint_Error. Typically these will include Expr itself or the
|
||||
-- direct descendents of Expr, such as Low/High_Bound (Expr)). It is the
|
||||
-- responsibility of the caller to rewrite and substitute the nodes with
|
||||
-- N_Raise_Constraint_Error nodes.
|
||||
--
|
||||
-- For the non-static case a single N_Raise_Constraint_Error node
|
||||
-- with a non-empty Condition field is returned.
|
||||
--
|
||||
-- Unused entries in Check_Result, if any, are simply set to Empty
|
||||
-- For external clients, the required processing on this result is
|
||||
-- achieved using the Insert_Range_Checks routine.
|
||||
|
||||
pragma Inline (Access_Checks_Suppressed);
|
||||
pragma Inline (Accessibility_Checks_Suppressed);
|
||||
pragma Inline (Discriminant_Checks_Suppressed);
|
||||
pragma Inline (Division_Checks_Suppressed);
|
||||
pragma Inline (Elaboration_Checks_Suppressed);
|
||||
pragma Inline (Index_Checks_Suppressed);
|
||||
pragma Inline (Length_Checks_Suppressed);
|
||||
pragma Inline (Overflow_Checks_Suppressed);
|
||||
pragma Inline (Range_Checks_Suppressed);
|
||||
pragma Inline (Storage_Checks_Suppressed);
|
||||
pragma Inline (Tag_Checks_Suppressed);
|
||||
|
||||
pragma Inline (Apply_Length_Check);
|
||||
pragma Inline (Apply_Range_Check);
|
||||
pragma Inline (Apply_Static_Length_Check);
|
||||
end Checks;
|
|
@ -0,0 +1,145 @@
|
|||
/****************************************************************************
|
||||
* *
|
||||
* GNAT COMPILER COMPONENTS *
|
||||
* *
|
||||
* C I O *
|
||||
* *
|
||||
* C Implementation File *
|
||||
* *
|
||||
* $Revision: 1.2 $
|
||||
* *
|
||||
* Copyright (C) 1992-2001 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- *
|
||||
* 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. *
|
||||
* *
|
||||
* As a special exception, if you link this file with other files to *
|
||||
* produce an executable, this file does not by itself cause the resulting *
|
||||
* executable to be covered by the GNU General Public License. This except- *
|
||||
* ion does not however invalidate any other reasons why the executable *
|
||||
* file might be covered by the GNU Public License. *
|
||||
* *
|
||||
* GNAT was originally developed by the GNAT team at New York University. *
|
||||
* It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). *
|
||||
* *
|
||||
****************************************************************************/
|
||||
|
||||
#ifdef IN_RTS
|
||||
#include "tconfig.h"
|
||||
#include "tsystem.h"
|
||||
#include <sys/stat.h>
|
||||
#else
|
||||
#include "config.h"
|
||||
#include "system.h"
|
||||
#endif
|
||||
|
||||
#include "adaint.h"
|
||||
|
||||
#ifdef __RT__
|
||||
|
||||
/* Linux kernel modules don't have inputs, so don't define get_int.
|
||||
Simple output can be done via printk. */
|
||||
|
||||
void
|
||||
put_char (c)
|
||||
int c;
|
||||
{
|
||||
printk ("%c", c);
|
||||
}
|
||||
|
||||
void
|
||||
put_char_stderr (c)
|
||||
int c;
|
||||
{
|
||||
put_char (c);
|
||||
}
|
||||
|
||||
void
|
||||
put_int (x)
|
||||
int x;
|
||||
{
|
||||
printk ("%d", x);
|
||||
}
|
||||
|
||||
void
|
||||
put_int_stderr (int x)
|
||||
{
|
||||
put_int (x);
|
||||
}
|
||||
|
||||
#else
|
||||
|
||||
/* Don't use macros on linux since they cause incompatible changes between
|
||||
glibc 2.0 and 2.1 */
|
||||
#ifdef linux
|
||||
#undef putchar
|
||||
#undef getchar
|
||||
#undef fputc
|
||||
#undef stderr
|
||||
#endif
|
||||
|
||||
int
|
||||
get_char ()
|
||||
{
|
||||
#ifdef VMS
|
||||
return decc$getchar();
|
||||
#else
|
||||
return getchar ();
|
||||
#endif
|
||||
}
|
||||
|
||||
int
|
||||
get_int ()
|
||||
{
|
||||
int x;
|
||||
|
||||
scanf (" %d", &x);
|
||||
return x;
|
||||
}
|
||||
|
||||
void
|
||||
put_int (x)
|
||||
int x;
|
||||
{
|
||||
printf ("%d", x);
|
||||
}
|
||||
|
||||
void
|
||||
put_int_stderr (x)
|
||||
int x;
|
||||
{
|
||||
fprintf (stderr, "%d", x);
|
||||
}
|
||||
|
||||
void
|
||||
put_char (c)
|
||||
int c;
|
||||
{
|
||||
putchar (c);
|
||||
}
|
||||
|
||||
void
|
||||
put_char_stderr (c)
|
||||
int c;
|
||||
{
|
||||
fputc (c, stderr);
|
||||
}
|
||||
#endif
|
||||
|
||||
#ifdef __vxworks
|
||||
|
||||
char *
|
||||
mktemp (template)
|
||||
char *template;
|
||||
{
|
||||
return tmpnam (NULL);
|
||||
}
|
||||
#endif
|
|
@ -0,0 +1,357 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- C O M P E R R --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.57 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This package contains routines called when a fatal internal compiler
|
||||
-- error is detected. Calls to these routines cause termination of the
|
||||
-- current compilation with appropriate error output.
|
||||
|
||||
with Atree; use Atree;
|
||||
with Debug; use Debug;
|
||||
with Errout; use Errout;
|
||||
with Fname; use Fname;
|
||||
with Gnatvsn; use Gnatvsn;
|
||||
with Lib; use Lib;
|
||||
with Namet; use Namet;
|
||||
with Osint; use Osint;
|
||||
with Output; use Output;
|
||||
with Sinput; use Sinput;
|
||||
with Sprint; use Sprint;
|
||||
with Sdefault; use Sdefault;
|
||||
with Treepr; use Treepr;
|
||||
with Types; use Types;
|
||||
|
||||
with Ada.Exceptions; use Ada.Exceptions;
|
||||
|
||||
with System.Soft_Links; use System.Soft_Links;
|
||||
|
||||
package body Comperr is
|
||||
|
||||
-----------------------
|
||||
-- Local Subprograms --
|
||||
-----------------------
|
||||
|
||||
procedure Repeat_Char (Char : Character; Col : Nat; After : Character);
|
||||
-- Output Char until current column is at or past Col, and then output
|
||||
-- the character given by After (if column is already past Col on entry,
|
||||
-- then the effect is simply to output the After character).
|
||||
|
||||
--------------------
|
||||
-- Compiler_Abort --
|
||||
--------------------
|
||||
|
||||
procedure Compiler_Abort
|
||||
(X : String;
|
||||
Code : Integer := 0)
|
||||
is
|
||||
procedure End_Line;
|
||||
-- Add blanks up to column 76, and then a final vertical bar
|
||||
|
||||
procedure End_Line is
|
||||
begin
|
||||
Repeat_Char (' ', 76, '|');
|
||||
Write_Eol;
|
||||
end End_Line;
|
||||
|
||||
Public_Version : constant Boolean := (Gnat_Version_String (5) = 'p');
|
||||
|
||||
-- Start of processing for Compiler_Abort
|
||||
|
||||
begin
|
||||
-- If errors have already occured, then we guess that the abort may
|
||||
-- well be caused by previous errors, and we don't make too much fuss
|
||||
-- about it, since we want to let the programmer fix the errors first.
|
||||
|
||||
-- Debug flag K disables this behavior (useful for debugging)
|
||||
|
||||
if Errors_Detected /= 0 and then not Debug_Flag_K then
|
||||
Errout.Finalize;
|
||||
|
||||
Set_Standard_Error;
|
||||
Write_Str ("compilation abandoned due to previous error");
|
||||
Write_Eol;
|
||||
|
||||
Set_Standard_Output;
|
||||
Source_Dump;
|
||||
Tree_Dump;
|
||||
Exit_Program (E_Errors);
|
||||
|
||||
-- Otherwise give message with details of the abort
|
||||
|
||||
else
|
||||
Set_Standard_Error;
|
||||
|
||||
-- Generate header for bug box
|
||||
|
||||
Write_Char ('+');
|
||||
Repeat_Char ('=', 29, 'G');
|
||||
Write_Str ("NAT BUG DETECTED");
|
||||
Repeat_Char ('=', 76, '+');
|
||||
Write_Eol;
|
||||
|
||||
-- Output GNAT version identification
|
||||
|
||||
Write_Str ("| ");
|
||||
Write_Str (Gnat_Version_String);
|
||||
Write_Str (" (");
|
||||
|
||||
-- Output target name, deleting junk final reverse slash
|
||||
|
||||
if Target_Name.all (Target_Name.all'Last) = '\'
|
||||
or else Target_Name.all (Target_Name.all'Last) = '/'
|
||||
then
|
||||
Write_Str (Target_Name.all (1 .. Target_Name.all'Last - 1));
|
||||
else
|
||||
Write_Str (Target_Name.all);
|
||||
end if;
|
||||
|
||||
-- Output identification of error
|
||||
|
||||
Write_Str (") ");
|
||||
|
||||
if X'Length + Column > 76 then
|
||||
if Code < 0 then
|
||||
Write_Str ("GCC error:");
|
||||
end if;
|
||||
|
||||
End_Line;
|
||||
|
||||
Write_Str ("| ");
|
||||
end if;
|
||||
|
||||
if X'Length > 70 then
|
||||
declare
|
||||
Last_Blank : Integer := 70;
|
||||
|
||||
begin
|
||||
for P in 40 .. 69 loop
|
||||
if X (P) = ' ' then
|
||||
Last_Blank := P;
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
Write_Str (X (1 .. Last_Blank));
|
||||
End_Line;
|
||||
Write_Str ("| ");
|
||||
Write_Str (X (Last_Blank + 1 .. X'Length));
|
||||
end;
|
||||
else
|
||||
Write_Str (X);
|
||||
end if;
|
||||
|
||||
if Code > 0 then
|
||||
Write_Str (", Code=");
|
||||
Write_Int (Int (Code));
|
||||
|
||||
elsif Code = 0 then
|
||||
|
||||
-- For exception case, get exception message from the TSD. Note
|
||||
-- that it would be neater and cleaner to pass the exception
|
||||
-- message (obtained from Exception_Message) as a parameter to
|
||||
-- Compiler_Abort, but we can't do this quite yet since it would
|
||||
-- cause bootstrap path problems for 3.10 to 3.11.
|
||||
|
||||
Write_Char (' ');
|
||||
Write_Str (Exception_Message (Get_Current_Excep.all.all));
|
||||
end if;
|
||||
|
||||
End_Line;
|
||||
|
||||
-- Output source location information
|
||||
|
||||
if Sloc (Current_Error_Node) <= Standard_Location
|
||||
or else Sloc (Current_Error_Node) = No_Location
|
||||
then
|
||||
Write_Str ("| No source file position information available");
|
||||
End_Line;
|
||||
else
|
||||
Write_Str ("| Error detected at ");
|
||||
Write_Location (Sloc (Current_Error_Node));
|
||||
End_Line;
|
||||
end if;
|
||||
|
||||
-- There are two cases now. If the file gnat_bug.box exists,
|
||||
-- we use the contents of this file at this point.
|
||||
|
||||
declare
|
||||
Lo : Source_Ptr;
|
||||
Hi : Source_Ptr;
|
||||
Src : Source_Buffer_Ptr;
|
||||
|
||||
begin
|
||||
Namet.Unlock;
|
||||
Name_Buffer (1 .. 12) := "gnat_bug.box";
|
||||
Name_Len := 12;
|
||||
Read_Source_File (Name_Enter, 0, Hi, Src);
|
||||
|
||||
-- If we get a Src file, we use it
|
||||
|
||||
if Src /= null then
|
||||
Lo := 0;
|
||||
|
||||
Outer : while Lo < Hi loop
|
||||
Write_Str ("| ");
|
||||
|
||||
Inner : loop
|
||||
exit Inner when Src (Lo) = ASCII.CR
|
||||
or else Src (Lo) = ASCII.LF;
|
||||
Write_Char (Src (Lo));
|
||||
Lo := Lo + 1;
|
||||
end loop Inner;
|
||||
|
||||
End_Line;
|
||||
|
||||
while Lo <= Hi
|
||||
and then (Src (Lo) = ASCII.CR
|
||||
or else Src (Lo) = ASCII.LF)
|
||||
loop
|
||||
Lo := Lo + 1;
|
||||
end loop;
|
||||
end loop Outer;
|
||||
|
||||
-- Otherwise we use the standard fixed text
|
||||
|
||||
else
|
||||
Write_Str
|
||||
("| Please submit bug report by email to report@gnat.com.");
|
||||
End_Line;
|
||||
|
||||
if not Public_Version then
|
||||
Write_Str
|
||||
("| Use a subject line meaningful to you" &
|
||||
" and us to track the bug.");
|
||||
End_Line;
|
||||
|
||||
Write_Str
|
||||
("| (include your customer number #nnn " &
|
||||
"in the subject line).");
|
||||
End_Line;
|
||||
end if;
|
||||
|
||||
Write_Str
|
||||
("| Include the entire contents of this bug " &
|
||||
"box in the report.");
|
||||
End_Line;
|
||||
|
||||
Write_Str
|
||||
("| Include the exact gcc or gnatmake command " &
|
||||
"that you entered.");
|
||||
End_Line;
|
||||
|
||||
Write_Str
|
||||
("| Also include sources listed below in gnatchop format");
|
||||
End_Line;
|
||||
|
||||
Write_Str
|
||||
("| (concatenated together with no headers between files).");
|
||||
End_Line;
|
||||
|
||||
if Public_Version then
|
||||
Write_Str
|
||||
("| (use plain ASCII or MIME attachment).");
|
||||
End_Line;
|
||||
|
||||
Write_Str
|
||||
("| See gnatinfo.txt for full info on procedure " &
|
||||
"for submitting bugs.");
|
||||
End_Line;
|
||||
|
||||
else
|
||||
Write_Str
|
||||
("| (use plain ASCII or MIME attachment, or FTP "
|
||||
& "to your customer directory).");
|
||||
End_Line;
|
||||
|
||||
Write_Str
|
||||
("| See README.GNATPRO for full info on procedure " &
|
||||
"for submitting bugs.");
|
||||
End_Line;
|
||||
end if;
|
||||
end if;
|
||||
end;
|
||||
|
||||
-- Complete output of bug box
|
||||
|
||||
Write_Char ('+');
|
||||
Repeat_Char ('=', 76, '+');
|
||||
Write_Eol;
|
||||
|
||||
if Debug_Flag_3 then
|
||||
Write_Eol;
|
||||
Write_Eol;
|
||||
Print_Tree_Node (Current_Error_Node);
|
||||
Write_Eol;
|
||||
end if;
|
||||
|
||||
Write_Eol;
|
||||
|
||||
Write_Line ("Please include these source files with error report");
|
||||
Write_Eol;
|
||||
|
||||
for U in Main_Unit .. Last_Unit loop
|
||||
begin
|
||||
if not Is_Internal_File_Name
|
||||
(File_Name (Source_Index (U)))
|
||||
then
|
||||
Write_Name (Full_File_Name (Source_Index (U)));
|
||||
Write_Eol;
|
||||
end if;
|
||||
|
||||
-- No point in double bug box if we blow up trying to print
|
||||
-- the list of file names! Output informative msg and quit.
|
||||
|
||||
exception
|
||||
when others =>
|
||||
Write_Str ("list may be incomplete");
|
||||
exit;
|
||||
end;
|
||||
end loop;
|
||||
|
||||
Write_Eol;
|
||||
Set_Standard_Output;
|
||||
|
||||
Tree_Dump;
|
||||
Source_Dump;
|
||||
raise Unrecoverable_Error;
|
||||
end if;
|
||||
|
||||
end Compiler_Abort;
|
||||
|
||||
-----------------
|
||||
-- Repeat_Char --
|
||||
-----------------
|
||||
|
||||
procedure Repeat_Char (Char : Character; Col : Nat; After : Character) is
|
||||
begin
|
||||
while Column < Col loop
|
||||
Write_Char (Char);
|
||||
end loop;
|
||||
|
||||
Write_Char (After);
|
||||
end Repeat_Char;
|
||||
|
||||
end Comperr;
|
|
@ -0,0 +1,96 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- C O M P E R R --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.18 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-2000 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This package contains the routine called when a fatal internal compiler
|
||||
-- error is detected. Calls to this routines cause termination of the
|
||||
-- current compilation with appropriate error output.
|
||||
|
||||
package Comperr is
|
||||
|
||||
procedure Compiler_Abort
|
||||
(X : String;
|
||||
Code : Integer := 0);
|
||||
-- Signals an internal compiler error. Never returns control. Depending
|
||||
-- on processing may end up raising Unrecoverable_Error, or exiting
|
||||
-- directly. The message output is a "bug box" containing the
|
||||
-- string passed as an argument. The node in Current_Error_Node is used
|
||||
-- to provide the location where the error should be signalled. The
|
||||
-- message includes the node id, and the code parameter if it is positive.
|
||||
-- Note that this is only used at the outer level (to handle constraint
|
||||
-- errors or assert errors etc.) In the normal logic of the compiler we
|
||||
-- always use pragma Assert to check for errors, and if necessary an
|
||||
-- explicit abort is achieved by pragma Assert (False). Code is positive
|
||||
-- for a gigi abort (giving the gigi abort code), zero for a front
|
||||
-- end exception (with possible message stored in TSD.Current_Excep,
|
||||
-- and negative (an unused value) for a GCC abort.
|
||||
|
||||
------------------------------
|
||||
-- Use of gnat_bug.box File --
|
||||
------------------------------
|
||||
|
||||
-- When comperr generates the "bug box". The first two lines contain
|
||||
-- information on the version number, type of abort, and source location.
|
||||
|
||||
-- Normally the remaining text is one of the following two forms
|
||||
-- depending on the version number (p identifies public versions):
|
||||
|
||||
-- Please submit bug report by email to report@gnat.com.
|
||||
-- Use a subject line meaningful to you and us to track the bug.
|
||||
-- (include your customer number #nnn in the subject line).
|
||||
-- Include the entire contents of this bug box in the report.
|
||||
-- Include the exact gcc or gnatmake command that you entered.
|
||||
-- Also include sources listed below in gnatchop format
|
||||
-- (concatenated together with no headers between files).
|
||||
-- (use plain ASCII or MIME attachment,
|
||||
-- or FTP to your customer directory).
|
||||
-- See README.GNATPRO for full info on procedure for submitting bugs.
|
||||
|
||||
-- or (public version case)
|
||||
|
||||
-- Please submit bug report by email to report@gnat.com.
|
||||
-- Use a subject line meaningful to you and us to track the bug.
|
||||
-- (include your customer number #nnn in the subject line).
|
||||
-- Include the entire contents of this bug box in the report.
|
||||
-- Include the exact gcc or gnatmake command that you entered.
|
||||
-- Also include sources listed below in gnatchop format
|
||||
-- (concatenated together with no headers between files).
|
||||
-- See gnatinfo.txt for full info on procedure for submitting bugs.
|
||||
|
||||
-- However, an alternative mechanism exists for easily substituting
|
||||
-- different text for this message. Compiler_Abort checks for the
|
||||
-- existence of the file "gnat_bug.box" in the current source path.
|
||||
-- Most typically this file, if present, will be in the directory
|
||||
-- containing the run-time sources.
|
||||
|
||||
-- If this file is present, then it is a plain ASCII file, whose
|
||||
-- contents replace the above quoted paragraphs. The lines in this
|
||||
-- file should be 72 characters or less to avoid misformatting the
|
||||
-- right boundary of the box. Note that the file does not contain
|
||||
-- the vertical bar characters or any leading spaces in lines.
|
||||
|
||||
end Comperr;
|
|
@ -0,0 +1,39 @@
|
|||
# Top level configure fragment for GNU Ada (GNAT).
|
||||
# Copyright (C) 1994 Free Software Foundation, Inc.
|
||||
|
||||
#This file is part of GNU CC.
|
||||
|
||||
#GNU CC is free software; you can redistribute it and/or modify
|
||||
#it under the terms of the GNU General Public License as published by
|
||||
#the Free Software Foundation; either version 2, or (at your option)
|
||||
#any later version.
|
||||
|
||||
#GNU CC is distributed in the hope that it will be useful,
|
||||
#but WITHOUT 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
|
||||
#along with GNU CC; see the file COPYING. If not, write to
|
||||
#the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
|
||||
|
||||
# Configure looks for the existence of this file to auto-config each language.
|
||||
# We define several parameters used by configure:
|
||||
#
|
||||
# language - name of language as it would appear in $(LANGUAGES)
|
||||
# boot_language - "yes" if we need to build this language in stage1
|
||||
# compilers - value to add to $(COMPILERS)
|
||||
# stagestuff - files to add to $(STAGESTUFF)
|
||||
# diff_excludes - files to ignore when building diffs between two versions.
|
||||
|
||||
language="ada"
|
||||
boot_language=yes
|
||||
boot_language_boot_flags='ADAFLAGS="$(BOOT_ADAFLAGS)"'
|
||||
|
||||
compilers="gnat1\$(exeext)"
|
||||
|
||||
stagestuff="gnatbind\$(exeext) gnat1\$(exeext)"
|
||||
|
||||
diff_excludes="-x ada/a-einfo.h -x ada/a-sinfo.h -x ada/nmake.adb -x ada/nmake.ads -x ada/treeprs.ads -x ada/sysid.ads"
|
||||
|
||||
outputs=ada/Makefile
|
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,99 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- C S E T S --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.16 $ --
|
||||
-- --
|
||||
-- Copyright (C) 1992-1997 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- As a special exception, if other files instantiate generics from this --
|
||||
-- unit, or you link this unit with other files to produce an executable, --
|
||||
-- this unit does not by itself cause the resulting executable to be --
|
||||
-- covered by the GNU General Public License. This exception does not --
|
||||
-- however invalidate any other reasons why the executable file might be --
|
||||
-- covered by the GNU Public License. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
package Csets is
|
||||
pragma Elaborate_Body (Csets);
|
||||
|
||||
-- This package contains character tables for the various character
|
||||
-- sets that are supported for source representation. Character and
|
||||
-- string literals are not affected, only identifiers. For each set,
|
||||
-- the table in this package gives the mapping of letters to their
|
||||
-- upper case equivalent. Each table thus provides the information
|
||||
-- for building the table used to fold lower case to upper case, and
|
||||
-- also the table of flags showing which characters are allowed in
|
||||
-- identifiers.
|
||||
|
||||
type Translate_Table is array (Character) of Character;
|
||||
-- Type used to describe translate tables
|
||||
|
||||
type Char_Array_Flags is array (Character) of Boolean;
|
||||
-- Type used for character attribute arrays. Note that we deliberately
|
||||
-- do NOT pack this table, since we don't want the extra overhead of
|
||||
-- accessing a packed bit string.
|
||||
|
||||
-----------------------------------------------
|
||||
-- Character Tables For Current Compilation --
|
||||
-----------------------------------------------
|
||||
|
||||
procedure Initialize;
|
||||
-- Routine to initialize following character tables, whose content depends
|
||||
-- on the character code being used to represent the source program. In
|
||||
-- particular, the use of the upper half of the 8-bit code set varies.
|
||||
-- The character set in use is specified by the value stored in
|
||||
-- Opt.Identifier_Character_Set, which has the following settings:
|
||||
|
||||
-- '1' Latin-1
|
||||
-- '2' Latin-2
|
||||
-- '3' Latin-3
|
||||
-- '4' Latin-4
|
||||
-- 'p' IBM PC (code page 437)
|
||||
-- '8' IBM PC (code page 850)
|
||||
-- 'f' Full upper set (all distinct)
|
||||
-- 'n' No upper characters (Ada/83 rules)
|
||||
-- 'w' Latin-1 plus wide characters also allowed
|
||||
|
||||
function Is_Upper_Case_Letter (C : Character) return Boolean;
|
||||
pragma Inline (Is_Upper_Case_Letter);
|
||||
-- Determine if character is upper case letter
|
||||
|
||||
function Is_Lower_Case_Letter (C : Character) return Boolean;
|
||||
pragma Inline (Is_Lower_Case_Letter);
|
||||
-- Determine if character is lower case letter
|
||||
|
||||
Fold_Upper : Translate_Table;
|
||||
-- Table to fold lower case identifier letters to upper case
|
||||
|
||||
Fold_Lower : Translate_Table;
|
||||
-- Table to fold upper case identifier letters to lower case
|
||||
|
||||
Identifier_Char : Char_Array_Flags;
|
||||
-- This table has True entries for all characters that can legally appear
|
||||
-- in identifiers, including digits, the underline character, all letters
|
||||
-- including upper and lower case and extended letters (as controlled by
|
||||
-- the setting of Opt.Identifier_Character_Set, left bracket for brackets
|
||||
-- notation wide characters and also ESC if wide characters are permitted
|
||||
-- in identifiers using escape sequences starting with ESC.
|
||||
|
||||
end Csets;
|
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,52 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- C S T A N D --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.4 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-2000 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This package contains the procedure that is used to create the tree for
|
||||
-- package Standard and initialize the entities in package Stand.
|
||||
|
||||
with Types; use Types;
|
||||
|
||||
package CStand is
|
||||
|
||||
procedure Create_Standard;
|
||||
-- This procedure creates the tree for package standard, and initializes
|
||||
-- the Standard_Entities array and Standard_Package_Node. First the
|
||||
-- syntactic representation is created (as though the parser had parsed
|
||||
-- a copy of the source of Standard) and then semantic information is
|
||||
-- added as it would be by the semantic phases of the compiler. The
|
||||
-- tree is in the standard format defined by Syntax_Info, except that
|
||||
-- all Sloc values are set to Standard_Location except for nodes that
|
||||
-- are part of package ASCII, which have Sloc = Standard_ASCII_Location.
|
||||
-- The semantics info is in the format given by Entity_Info. The global
|
||||
-- variables Last_Standard_Node_Id and Last_Standard_List_Id are also set.
|
||||
|
||||
procedure Set_Float_Bounds (Id : Entity_Id);
|
||||
-- Procedure to set bounds for float type or subtype. Id is the entity
|
||||
-- whose bounds and type are to be set (a floating-point type).
|
||||
|
||||
end CStand;
|
|
@ -0,0 +1,247 @@
|
|||
/****************************************************************************
|
||||
* *
|
||||
* GNAT RUN-TIME COMPONENTS *
|
||||
* *
|
||||
* C S T R E A M S *
|
||||
* *
|
||||
* Auxiliary C functions for Interfaces.C.Streams *
|
||||
* *
|
||||
* $Revision: 1.1 $
|
||||
* *
|
||||
* Copyright (C) 1992-2001 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- *
|
||||
* 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. *
|
||||
* *
|
||||
* As a special exception, if you link this file with other files to *
|
||||
* produce an executable, this file does not by itself cause the resulting *
|
||||
* executable to be covered by the GNU General Public License. This except- *
|
||||
* ion does not however invalidate any other reasons why the executable *
|
||||
* file might be covered by the GNU Public License. *
|
||||
* *
|
||||
* GNAT was originally developed by the GNAT team at New York University. *
|
||||
* It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). *
|
||||
* *
|
||||
****************************************************************************/
|
||||
|
||||
/* Routines required for implementing routines in Interfaces.C.Streams */
|
||||
|
||||
#ifdef __vxworks
|
||||
#include "vxWorks.h"
|
||||
#endif
|
||||
|
||||
#ifdef IN_RTS
|
||||
#include "tconfig.h"
|
||||
#include "tsystem.h"
|
||||
#include <sys/stat.h>
|
||||
#else
|
||||
#include "config.h"
|
||||
#include "system.h"
|
||||
#endif
|
||||
|
||||
#include "adaint.h"
|
||||
|
||||
#ifdef __EMX__
|
||||
int max_path_len = _MAX_PATH;
|
||||
#elif defined (VMS)
|
||||
#include <unixlib.h>
|
||||
int max_path_len = 255; /* PATH_MAX */
|
||||
|
||||
#elif defined (__vxworks) || defined (__OPENNT)
|
||||
|
||||
int max_path_len = PATH_MAX;
|
||||
|
||||
#else
|
||||
|
||||
#ifdef linux
|
||||
|
||||
/* Don't use macros on linux since they cause incompatible changes between
|
||||
glibc 2.0 and 2.1 */
|
||||
|
||||
#ifdef stderr
|
||||
# undef stderr
|
||||
#endif
|
||||
#ifdef stdin
|
||||
# undef stdin
|
||||
#endif
|
||||
#ifdef stdout
|
||||
# undef stdout
|
||||
#endif
|
||||
|
||||
#endif
|
||||
|
||||
#include <sys/param.h>
|
||||
|
||||
int max_path_len = MAXPATHLEN;
|
||||
#endif
|
||||
|
||||
/* The _IONBF value in CYGNUS or MINGW32 stdio.h is wrong. */
|
||||
#if defined (WINNT) || defined (_WINNT)
|
||||
#undef _IONBF
|
||||
#define _IONBF 0004
|
||||
#endif
|
||||
|
||||
|
||||
int
|
||||
__gnat_feof (stream)
|
||||
FILE *stream;
|
||||
{
|
||||
return (feof (stream));
|
||||
}
|
||||
|
||||
int
|
||||
__gnat_ferror (stream)
|
||||
FILE *stream;
|
||||
{
|
||||
return (ferror (stream));
|
||||
}
|
||||
|
||||
int
|
||||
__gnat_fileno (stream)
|
||||
FILE *stream;
|
||||
{
|
||||
return (fileno (stream));
|
||||
}
|
||||
|
||||
int
|
||||
__gnat_is_regular_file_fd (fd)
|
||||
int fd;
|
||||
{
|
||||
int ret;
|
||||
struct stat statbuf;
|
||||
|
||||
#ifdef __EMX__
|
||||
/* Programs using screen I/O may need to reset the FPU after
|
||||
initialization of screen-handling related DLL's, so force
|
||||
DLL initialization by doing a null-write and then reset the FPU */
|
||||
|
||||
DosWrite (0, &ret, 0, &ret);
|
||||
__gnat_init_float();
|
||||
#endif
|
||||
|
||||
ret = fstat (fd, &statbuf);
|
||||
return (!ret && S_ISREG (statbuf.st_mode));
|
||||
}
|
||||
|
||||
/* on some systems, the constants for seek are not defined, if so, then
|
||||
provide the conventional definitions */
|
||||
|
||||
#ifndef SEEK_SET
|
||||
#define SEEK_SET 0 /* Set file pointer to offset */
|
||||
#define SEEK_CUR 1 /* Set file pointer to its current value plus offset */
|
||||
#define SEEK_END 2 /* Set file pointer to the size of the file plus offset */
|
||||
#endif
|
||||
|
||||
/* if L_tmpnam is not set, use a large number that should be safe */
|
||||
#ifndef L_tmpnam
|
||||
#define L_tmpnam 256
|
||||
#endif
|
||||
|
||||
int __gnat_constant_eof = EOF;
|
||||
int __gnat_constant_iofbf = _IOFBF;
|
||||
int __gnat_constant_iolbf = _IOLBF;
|
||||
int __gnat_constant_ionbf = _IONBF;
|
||||
int __gnat_constant_l_tmpnam = L_tmpnam;
|
||||
int __gnat_constant_seek_cur = SEEK_CUR;
|
||||
int __gnat_constant_seek_end = SEEK_END;
|
||||
int __gnat_constant_seek_set = SEEK_SET;
|
||||
|
||||
FILE *
|
||||
__gnat_constant_stderr ()
|
||||
{
|
||||
return stderr;
|
||||
}
|
||||
|
||||
FILE *
|
||||
__gnat_constant_stdin ()
|
||||
{
|
||||
return stdin;
|
||||
}
|
||||
|
||||
FILE *
|
||||
__gnat_constant_stdout ()
|
||||
{
|
||||
return stdout;
|
||||
}
|
||||
|
||||
char *
|
||||
__gnat_full_name (nam, buffer)
|
||||
char *nam;
|
||||
char *buffer;
|
||||
{
|
||||
char *p;
|
||||
|
||||
#if defined(__EMX__) || defined (__MINGW32__)
|
||||
/* If this is a device file return it as is; under Windows NT and
|
||||
OS/2 a device file end with ":". */
|
||||
if (nam [strlen (nam) - 1] == ':')
|
||||
strcpy (buffer, nam);
|
||||
else
|
||||
{
|
||||
_fullpath (buffer, nam, max_path_len);
|
||||
|
||||
for (p = buffer; *p; p++)
|
||||
if (*p == '/')
|
||||
*p = '\\';
|
||||
}
|
||||
|
||||
#elif defined (MSDOS)
|
||||
_fixpath (nam, buffer);
|
||||
|
||||
#elif defined (sgi)
|
||||
|
||||
/* Use realpath function which resolves links and references to .. and ..
|
||||
on those Unix systems that support it. Note that linux provides it but
|
||||
cannot handle more than 5 symbolic links in a full name, so we use the
|
||||
getcwd approach instead. */
|
||||
realpath (nam, buffer);
|
||||
|
||||
#elif defined (VMS)
|
||||
strcpy (buffer, __gnat_to_canonical_file_spec (nam));
|
||||
|
||||
if (buffer[0] == '/')
|
||||
strcpy (buffer, __gnat_to_host_file_spec (buffer));
|
||||
else
|
||||
{
|
||||
char nambuffer [MAXPATHLEN];
|
||||
|
||||
strcpy (nambuffer, buffer);
|
||||
strcpy (buffer, getcwd (buffer, max_path_len, 0));
|
||||
strcat (buffer, "/");
|
||||
strcat (buffer, nambuffer);
|
||||
strcpy (buffer, __gnat_to_host_file_spec (buffer));
|
||||
}
|
||||
|
||||
return buffer;
|
||||
|
||||
#else
|
||||
if (nam[0] != '/')
|
||||
{
|
||||
p = getcwd (buffer, max_path_len);
|
||||
if (p == 0)
|
||||
{
|
||||
buffer[0] = '\0';
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* If the name returned is an absolute path, it is safe to append '/'
|
||||
to the path and concatenate the name of the file. */
|
||||
if (buffer[0] == '/')
|
||||
strcat (buffer, "/");
|
||||
|
||||
strcat (buffer, nam);
|
||||
}
|
||||
else
|
||||
strcpy (buffer, nam);
|
||||
|
||||
return buffer;
|
||||
#endif
|
||||
}
|
|
@ -0,0 +1,110 @@
|
|||
/****************************************************************************
|
||||
* *
|
||||
* GNAT COMPILER COMPONENTS *
|
||||
* *
|
||||
* C U I N T P *
|
||||
* *
|
||||
* C Implementation File *
|
||||
* *
|
||||
* $Revision: 1.1 $
|
||||
* *
|
||||
* Copyright (C) 1992-2001 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- *
|
||||
* 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. *
|
||||
* *
|
||||
* GNAT was originally developed by the GNAT team at New York University. *
|
||||
* It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). *
|
||||
* *
|
||||
****************************************************************************/
|
||||
|
||||
/* This file corresponds to the Ada package body Uintp. It was created
|
||||
manually from the files uintp.ads and uintp.adb. */
|
||||
|
||||
#include "config.h"
|
||||
#include "system.h"
|
||||
#include "tree.h"
|
||||
#include "ada.h"
|
||||
#include "types.h"
|
||||
#include "uintp.h"
|
||||
#include "atree.h"
|
||||
#include "elists.h"
|
||||
#include "nlists.h"
|
||||
#include "stringt.h"
|
||||
#include "fe.h"
|
||||
#include "gigi.h"
|
||||
|
||||
/* Universal integers are represented by the Uint type which is an index into
|
||||
the Uints_Ptr table containing Uint_Entry values. A Uint_Entry contains an
|
||||
index and length for getting the "digits" of the universal integer from the
|
||||
Udigits_Ptr table.
|
||||
|
||||
For efficiency, this method is used only for integer values larger than the
|
||||
constant Uint_Bias. If a Uint is less than this constant, then it contains
|
||||
the integer value itself. The origin of the Uints_Ptr table is adjusted so
|
||||
that a Uint value of Uint_Bias indexes the first element. */
|
||||
|
||||
/* Similarly to UI_To_Int, but return a GCC INTEGER_CST. Overflow is tested
|
||||
by the constant-folding used to build the node. TYPE is the GCC type of the
|
||||
resulting node. */
|
||||
|
||||
tree
|
||||
UI_To_gnu (Input, type)
|
||||
Uint Input;
|
||||
tree type;
|
||||
{
|
||||
tree gnu_ret;
|
||||
|
||||
if (Input <= Uint_Direct_Last)
|
||||
gnu_ret = convert (type, build_int_2 (Input - Uint_Direct_Bias,
|
||||
Input < Uint_Direct_Bias ? -1 : 0));
|
||||
else
|
||||
{
|
||||
Int Idx = Uints_Ptr[Input].Loc;
|
||||
Pos Length = Uints_Ptr[Input].Length;
|
||||
Int First = Udigits_Ptr[Idx];
|
||||
/* Do computations in integer type or TYPE whichever is wider, then
|
||||
convert later. This avoid overflow if type is short integer. */
|
||||
tree comp_type
|
||||
= (TYPE_PRECISION (type) >= TYPE_PRECISION (integer_type_node)
|
||||
? type : integer_type_node);
|
||||
tree gnu_base = convert (comp_type, build_int_2 (Base, 0));
|
||||
|
||||
if (Length <= 0)
|
||||
gigi_abort (601);
|
||||
|
||||
gnu_ret = convert (comp_type, build_int_2 (First, First < 0 ? -1 : 0));
|
||||
if (First < 0)
|
||||
for (Idx++, Length--; Length; Idx++, Length--)
|
||||
gnu_ret = fold (build (MINUS_EXPR, comp_type,
|
||||
fold (build (MULT_EXPR, comp_type,
|
||||
gnu_ret, gnu_base)),
|
||||
convert (comp_type,
|
||||
build_int_2 (Udigits_Ptr[Idx], 0))));
|
||||
else
|
||||
for (Idx++, Length--; Length; Idx++, Length--)
|
||||
gnu_ret = fold (build (PLUS_EXPR, comp_type,
|
||||
fold (build (MULT_EXPR, comp_type,
|
||||
gnu_ret, gnu_base)),
|
||||
convert (comp_type,
|
||||
build_int_2 (Udigits_Ptr[Idx], 0))));
|
||||
}
|
||||
|
||||
gnu_ret = convert (type, gnu_ret);
|
||||
|
||||
/* We don't need any NOP_EXPR or NON_LVALUE_EXPR on GNU_RET. */
|
||||
while ((TREE_CODE (gnu_ret) == NOP_EXPR
|
||||
|| TREE_CODE (gnu_ret) == NON_LVALUE_EXPR)
|
||||
&& TREE_TYPE (TREE_OPERAND (gnu_ret, 0)) == TREE_TYPE (gnu_ret))
|
||||
gnu_ret = TREE_OPERAND (gnu_ret, 0);
|
||||
|
||||
return gnu_ret;
|
||||
}
|
|
@ -0,0 +1,577 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- D E B U G --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.88 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- As a special exception, if other files instantiate generics from this --
|
||||
-- unit, or you link this unit with other files to produce an executable, --
|
||||
-- this unit does not by itself cause the resulting executable to be --
|
||||
-- covered by the GNU General Public License. This exception does not --
|
||||
-- however invalidate any other reasons why the executable file might be --
|
||||
-- covered by the GNU Public License. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
package body Debug is
|
||||
|
||||
---------------------------------
|
||||
-- Summary of Debug Flag Usage --
|
||||
---------------------------------
|
||||
|
||||
-- Debug flags for compiler (GNAT1 and GNATF)
|
||||
|
||||
-- da Generate messages tracking semantic analyzer progress
|
||||
-- db Show encoding of type names for debug output
|
||||
-- dc List names of units as they are compiled
|
||||
-- dd Dynamic allocation of tables messages generated
|
||||
-- de List the entity table
|
||||
-- df Full tree/source print (includes withed units)
|
||||
-- dg Print source from tree (generated code only)
|
||||
-- dh Generate listing showing loading of name table hash chains
|
||||
-- di Generate messages for visibility linking/delinking
|
||||
-- dj Suppress "junk null check" for access parameter values
|
||||
-- dk Generate GNATBUG message on abort, even if previous errors
|
||||
-- dl Generate unit load trace messages
|
||||
-- dm Allow VMS features even if not OpenVMS version
|
||||
-- dn Generate messages for node/list allocation
|
||||
-- do Print source from tree (original code only)
|
||||
-- dp Generate messages for parser scope stack push/pops
|
||||
-- dq
|
||||
-- dr Generate parser resynchronization messages
|
||||
-- ds Print source from tree (including original and generated stuff)
|
||||
-- dt Print full tree
|
||||
-- du Uncheck categorization pragmas
|
||||
-- dv Output trace of overload resolution
|
||||
-- dw Print trace of semantic scope stack
|
||||
-- dx Force expansion on, even if no code being generated
|
||||
-- dy Print tree of package Standard
|
||||
-- dz Print source of package Standard
|
||||
|
||||
-- dA All entities included in representation information output
|
||||
-- dB Output debug encoding of type names and variants
|
||||
-- dC
|
||||
-- dD Delete elaboration checks in inner level routines
|
||||
-- dE Apply elaboration checks to predefined units
|
||||
-- dF Front end data layout enabled.
|
||||
-- dG Generate input showing file creating info for debug file
|
||||
-- dH Hold (kill) call to gigi
|
||||
-- dI Inhibit internal name numbering in gnatG listing
|
||||
-- dJ Output debugging trace info for JGNAT (Java VM version of GNAT)
|
||||
-- dK Kill all error messages
|
||||
-- dL Output trace information on elaboration checking
|
||||
-- dM
|
||||
-- dN Do not generate file/line exception messages
|
||||
-- dO Output immediate error messages
|
||||
-- dP Do not check for controlled objects in preelaborable packages
|
||||
-- dQ
|
||||
-- dR Bypass check for correct version of s-rpc
|
||||
-- dS Never convert numbers to machine numbers in Sem_Eval
|
||||
-- dT Convert to machine numbers only for constant declarations
|
||||
-- dU Enable garbage collection of unreachable entities
|
||||
-- dV Enable viewing of all symbols in debugger
|
||||
-- dW
|
||||
-- dX Enable Frontend ZCX even when it is not supported
|
||||
-- dY
|
||||
-- dZ
|
||||
|
||||
-- d1 Error msgs have node numbers where possible
|
||||
-- d2 Eliminate error flags in verbose form error messages
|
||||
-- d3 Dump bad node in Comperr on an abort
|
||||
-- d4 Inhibit automatic krunch of predefined library unit files
|
||||
-- d5 Debug output for tree read/write
|
||||
-- d6 Default access unconstrained to thin pointers
|
||||
-- d7 Do not output version & file time stamp in -gnatv or -gnatl mode
|
||||
-- d8 Force opposite endianness in packed stuff
|
||||
-- d9
|
||||
|
||||
-- Debug flags for binder (GNATBIND)
|
||||
|
||||
-- da
|
||||
-- db
|
||||
-- dc List units as they are chosen
|
||||
-- dd
|
||||
-- de Elaboration dependencies including system units
|
||||
-- df
|
||||
-- dg
|
||||
-- dh
|
||||
-- di
|
||||
-- dj
|
||||
-- dk
|
||||
-- dl
|
||||
-- dm
|
||||
-- dn List details of manipulation of Num_Pred values
|
||||
-- do
|
||||
-- dp
|
||||
-- dq
|
||||
-- dr List additional restrictions that may be specified
|
||||
-- ds
|
||||
-- dt
|
||||
-- du List units as they are acquired
|
||||
-- dv
|
||||
-- dw
|
||||
-- dx
|
||||
-- dy
|
||||
-- dz
|
||||
|
||||
-- d1
|
||||
-- d2
|
||||
-- d3
|
||||
-- d4
|
||||
-- d5
|
||||
-- d6
|
||||
-- d7
|
||||
-- d8
|
||||
-- d9
|
||||
|
||||
-- Debug flags used in package Make and its clients (e.g. GNATMAKE)
|
||||
|
||||
-- da
|
||||
-- db
|
||||
-- dc
|
||||
-- dd
|
||||
-- de
|
||||
-- df
|
||||
-- dg
|
||||
-- dh
|
||||
-- di
|
||||
-- dj
|
||||
-- dk
|
||||
-- dl
|
||||
-- dm
|
||||
-- dn
|
||||
-- do
|
||||
-- dp Prints the contents of the Q used by Make.Compile_Sources
|
||||
-- dq Prints source files as they are enqueued and dequeued
|
||||
-- dr
|
||||
-- ds
|
||||
-- dt
|
||||
-- du
|
||||
-- dv
|
||||
-- dw Prints the list of units withed by the unit currently explored
|
||||
-- dx
|
||||
-- dy
|
||||
-- dz
|
||||
|
||||
-- d1
|
||||
-- d2
|
||||
-- d3
|
||||
-- d4
|
||||
-- d5
|
||||
-- d6
|
||||
-- d7
|
||||
-- d8
|
||||
-- d9
|
||||
|
||||
--------------------------------------------
|
||||
-- Documentation for Compiler Debug Flags --
|
||||
--------------------------------------------
|
||||
|
||||
-- da Generate messages tracking semantic analyzer progress. A message
|
||||
-- is output showing each node as it gets analyzed, expanded,
|
||||
-- resolved, or evaluated. This option is useful for finding out
|
||||
-- exactly where a bomb during semantic analysis is occurring.
|
||||
|
||||
-- db In Exp_Dbug, certain type names are encoded to include debugging
|
||||
-- information. This debug switch causes lines to be output showing
|
||||
-- the encodings used.
|
||||
|
||||
-- dc List names of units as they are compiled. One line of output will
|
||||
-- be generated at the start of compiling each unit (package or
|
||||
-- subprogram).
|
||||
|
||||
-- dd Dynamic allocation of tables messages generated. Each time a
|
||||
-- table is reallocated, a line is output indicating the expansion.
|
||||
|
||||
-- dD Delete new elaboration checks. This flag causes GNAT to return
|
||||
-- to the 3.13a elaboration semantics, and to suppress the fixing
|
||||
-- of two bugs. The first is in the context of inner routines in
|
||||
-- dynamic elaboration mode, when the subprogram we are in was
|
||||
-- called at elaboration time by a unit that was also compiled with
|
||||
-- dynamic elaboration checks. In this case, if A calls B calls C,
|
||||
-- and all are in different units, we need an elaboration check at
|
||||
-- each call. These nested checks were only put in recently (see
|
||||
-- version 1.80 of Sem_Elab) and we provide this debug flag to
|
||||
-- revert to the previous behavior in case of regressions. The
|
||||
-- other behavior reverted by this flag is the treatment of the
|
||||
-- Elaborate_Body pragma in static elaboration mode. This used to
|
||||
-- be treated as not needing elaboration checking, but in fact in
|
||||
-- general Elaborate_All is still required because of nested calls.
|
||||
|
||||
-- de List the entity table
|
||||
|
||||
-- df Full tree/source print (includes withed units). Normally the tree
|
||||
-- output (dt) or recreated source output (dg,do,ds) includes only
|
||||
-- the main unit. If df is set, then the output in either case
|
||||
-- includes all compiled units (see also dg,do,ds,dt). Note that to
|
||||
-- be effective, this swich must be used in combination with one or
|
||||
-- more of dt, dg, do or ds.
|
||||
|
||||
-- dF Front end data layout enabled. Normally front end data layout
|
||||
-- is only enabled if the target parameter Backend_Layout is False.
|
||||
-- This debugging switch enables it unconditionally.
|
||||
|
||||
-- dg Print the source recreated from the generated tree. In the case
|
||||
-- where the tree has been rewritten this output includes only the
|
||||
-- generated code, not the original code (see also df,do,ds,dz).
|
||||
-- This flag differs from -gnatG in that the output also includes
|
||||
-- non-source generated null statements, and freeze nodes, which
|
||||
-- are normally omitted in -gnatG mode.
|
||||
|
||||
-- dG Print trace information showing calls to Create_Debug_Source and
|
||||
-- Write_Debug_Line. Used for debugging -gnatD operation problems.
|
||||
|
||||
-- dh Generates a table at the end of a compilation showing how the hash
|
||||
-- table chains built by the Namet package are loaded. This is useful
|
||||
-- in ensuring that the hashing algorithm (in Namet.Hash) is working
|
||||
-- effectively with typical sets of program identifiers.
|
||||
|
||||
-- dH Inhibit call to gigi. This is useful for testing front end data
|
||||
-- layout, and may be useful in other debugging situations where
|
||||
-- you do not want gigi to intefere with the testing.
|
||||
|
||||
-- di Generate messages for visibility linking/delinking
|
||||
|
||||
-- dj Suppress "junk null check" for access parameters. This flag permits
|
||||
-- Ada programs to pass null parameters to access parameters, and to
|
||||
-- explicitly check such access values against the null literal.
|
||||
-- Neither of these is valid Ada, but both were allowed in versions of
|
||||
-- GNAT before 3.10, so this switch can ease the transition process.
|
||||
|
||||
-- dJ Generate debugging trace output for the JGNAT back end. This
|
||||
-- consists of symbolic Java Byte Code sequences for all generated
|
||||
-- classes plus additional information to indicate local variables
|
||||
-- and methods.
|
||||
|
||||
-- dk Immediate kill on abort. Normally on an abort (i.e. a call to
|
||||
-- Comperr.Compiler_Abort), the GNATBUG message is not given if
|
||||
-- there is a previous error. This debug switch bypasses this test
|
||||
-- and gives the message unconditionally (useful for debugging).
|
||||
|
||||
-- dK Kill all error messages. This debug flag suppresses the output
|
||||
-- of all error messages. It is used in regression tests where the
|
||||
-- error messages are target dependent and irrelevant.
|
||||
|
||||
-- dl Generate unit load trace messages. A line of traceback output is
|
||||
-- generated each time a request is made to the library manager to
|
||||
-- load a new unit.
|
||||
|
||||
-- dm Some features are permitted only in OpenVMS ports of GNAT (e.g.
|
||||
-- the specification of passing by descriptor). Normally any use
|
||||
-- of these features will be flagged as an error, but this debug
|
||||
-- flag allows acceptance of these features in non OpenVMS ports.
|
||||
-- Of course they may not have any useful effect, and in particular
|
||||
-- attempting to generate code with this flag set may blow up.
|
||||
-- The flag also forces the use of 64-bits for Long_Integer.
|
||||
|
||||
-- dn Generate messages for node/list allocation. Each time a node or
|
||||
-- list header is allocated, a line of output is generated. Certain
|
||||
-- other basic tree operations also cause a line of output to be
|
||||
-- generated. This option is useful in seeing where the parser is
|
||||
-- blowing up.;
|
||||
|
||||
-- dN Do not generate file/line exception messages. Normally we do the
|
||||
-- explicit generation of these messages, but since these can only
|
||||
-- be disabled using pragma Discard_Names, this switch may be useful.
|
||||
|
||||
-- do Print the source recreated from the generated tree. In the case
|
||||
-- where the tree has been rewritten, this output includes only the
|
||||
-- original code, not the generated code (see also df,dg,ds,dz).
|
||||
|
||||
-- dp Generate messages for parser scope stack push/pops. A line of
|
||||
-- output by the parser each time the parser scope stack is either
|
||||
-- pushed or popped. Useful in debugging situations where the
|
||||
-- parser scope stack ends up incorrectly synchronized
|
||||
|
||||
-- dr Generate parser resynchronization messages. Normally the parser
|
||||
-- resynchronizes quietly. With this debug option, two messages
|
||||
-- are generated, one when the parser starts a resynchronization
|
||||
-- skip, and another when it resumes parsing. Useful in debugging
|
||||
-- inadequate error recovery situations.
|
||||
|
||||
-- ds Print the source recreated from the generated tree. In the case
|
||||
-- where the tree has been rewritten this output includes both the
|
||||
-- generated code and the original code with the generated code
|
||||
-- being enlosed in curly brackets (see also df,do,ds,dz)
|
||||
|
||||
-- dt Print full tree. The generated tree is output (see also df,dy)
|
||||
|
||||
-- du Uncheck categorization pragmas. This debug switch causes the
|
||||
-- categorization pragmas (Pure, Preelaborate etc) to be ignored
|
||||
-- so that normal checks are not made (this is particularly useful
|
||||
-- for adding temporary debugging code to units that have pragmas
|
||||
-- that are inconsistent with the debugging code added.
|
||||
|
||||
-- dw Write semantic scope stack messages. Each time a scope is created
|
||||
-- or removed, a message is output (see the Sem_Ch8.New_Scope and
|
||||
-- Sem_Ch8.Pop_Scope subprograms).
|
||||
|
||||
-- dx Force expansion on, even if no code being generated. Normally the
|
||||
-- expander is inhibited if no code is generated. This switch forces
|
||||
-- expansion to proceed normally even if the backend is not being
|
||||
-- called. This is particularly useful for debugging purposes when
|
||||
-- using the front-end only version of the compiler (which normally
|
||||
-- would never do any expansion).
|
||||
|
||||
-- dy Print tree of package Standard. Normally the tree print out does
|
||||
-- not include package Standard, even if the -df switch is set. This
|
||||
-- switch forces output of the internal tree built for Standard.
|
||||
|
||||
-- dz Print source of package Standard. Normally the source print out
|
||||
-- does not include package Standard, even if the -df switch is set.
|
||||
-- This switch forces output of the source recreated from the internal
|
||||
-- tree built for Standard.
|
||||
|
||||
-- dA Forces output of representation information, including full
|
||||
-- information for all internal type and object entities, as well
|
||||
-- as all user defined type and object entities.
|
||||
|
||||
-- dB Output debug encodings for types and variants. See Exp_Dbug for
|
||||
-- exact form of the generated output.
|
||||
|
||||
-- dE Apply compile time elaboration checking for with relations between
|
||||
-- predefined units. Normally no checks are made (it seems that at
|
||||
-- least on the SGI, such checks run into trouble).
|
||||
|
||||
-- dI Inhibit internal name numbering in gnatDG listing. For internal
|
||||
-- names of the form <uppercase-letters><digits><suffix>, the output
|
||||
-- will be modified to <uppercase-letters>...<suffix>. This is used
|
||||
-- in the fixed bugs run to minimize system and version dependency
|
||||
-- in filed -gnatDG output.
|
||||
|
||||
-- dL Output trace information on elaboration checking. This debug
|
||||
-- switch causes output to be generated showing each call or
|
||||
-- instantiation as it is checked, and the progress of the recursive
|
||||
-- trace through calls at elaboration time.
|
||||
|
||||
-- dO Output immediate error messages. This causes error messages to
|
||||
-- be output as soon as they are generated (disconnecting several
|
||||
-- circuits for improvement of messages, deletion of duplicate
|
||||
-- messages etc). Useful to diagnose compiler bombs caused by
|
||||
-- erroneous handling of error situations
|
||||
|
||||
-- dP Do not check for controlled objects in preelaborable packages.
|
||||
-- RM 10.2.1(9) forbids the use of library level controlled objects
|
||||
-- in preelaborable packages, but this restriction is a huge pain,
|
||||
-- especially in the predefined library units.
|
||||
|
||||
-- dR Bypass the check for a proper version of s-rpc being present
|
||||
-- to use the -gnatz? switch. This allows debugging of the use
|
||||
-- of stubs generation without needing to have GLADE (or some
|
||||
-- other PCS installed).
|
||||
|
||||
-- dS Omit conversion of fpt numbers to exact machine numbers in
|
||||
-- non-static evaluation contexts (see Check_Non_Static_Context).
|
||||
-- This is intended for testing out timing problems with this
|
||||
-- conversion circuit.
|
||||
|
||||
-- dT Similar to dS, but omits the conversions only in the case where
|
||||
-- the parent is not a constant declaration.
|
||||
|
||||
-- dU Enable garbage collection of unreachable entities. This enables
|
||||
-- both the reachability analysis and changing the Is_Public and
|
||||
-- Is_Eliminated flags.
|
||||
|
||||
-- dV Enable viewing of all symbols in debugger. Causes debug information
|
||||
-- to be generated for all symbols, including internal symbols. This
|
||||
-- is enabled by default for -gnatD, but this switch allows this to
|
||||
-- be enabled without generating modified source files. Note that the
|
||||
-- use of -gnatdV ensures in the dwarf/elf case that all symbols that
|
||||
-- are present in the elf tables are also in the dwarf tables (which
|
||||
-- seems to be required by some tools).
|
||||
|
||||
-- dX Enable frontend ZCX even when it is not supported. Equivalent to
|
||||
-- -gnatZ but without verifying that System.Front_End_ZCX_Support
|
||||
-- is set. This causes the front end to generate suitable tables
|
||||
-- for ZCX handling even when the runtime cannot handle ZCX. This
|
||||
-- is used for testing the front end for correct ZCX operation, and
|
||||
-- in particular is useful for multi-target testing.
|
||||
|
||||
-- d1 Error msgs have node numbers where possible. Normally error
|
||||
-- messages have only source locations. This option is useful when
|
||||
-- debugging errors caused by expanded code, where the source location
|
||||
-- does not give enough information.
|
||||
|
||||
-- d2 Suppress output of the error position flags for verbose form error
|
||||
-- messages. The messages are still interspersed in the listing, but
|
||||
-- without any error flags or extra blank lines. Also causes an extra
|
||||
-- <<< to be output at the right margin. This is intended to be the
|
||||
-- easiest format for checking conformance of ACVC B tests.
|
||||
|
||||
-- d3 Causes Comperr to dump the contents of the node for which an abort
|
||||
-- was detected (normally only the Node_Id of the node is output).
|
||||
|
||||
-- d4 Inhibits automatic krunching of predefined library unit file names.
|
||||
-- Normally, as described in the spec of package Krunch, such files
|
||||
-- are automatically krunched to 8 characters, with special treatment
|
||||
-- of the prefixes Ada, System, and Interfaces. Setting this debug
|
||||
-- switch disables this special treatment.
|
||||
|
||||
-- d6 Normally access-to-unconstrained-array types are represented
|
||||
-- using fat (double) pointers. Using this debug flag causes them
|
||||
-- to default to thin. This can be used to test the performance
|
||||
-- implications of using thin pointers, and also to test that the
|
||||
-- compiler functions correctly with this choice.
|
||||
|
||||
-- d7 Normally a -gnatl or -gnatv listing includes the time stamp
|
||||
-- of the source file. This debug flag suppresses this output,
|
||||
-- and also suppresses the message with the version number.
|
||||
-- This is useful in certain regression tests.
|
||||
|
||||
-- d8 This forces the packed stuff to generate code assuming the
|
||||
-- opposite endianness from the actual correct value. Useful in
|
||||
-- testing out code generation from the packed routines.
|
||||
|
||||
------------------------------------------
|
||||
-- Documentation for Binder Debug Flags --
|
||||
------------------------------------------
|
||||
|
||||
-- dc List units as they are chosen. As units are selected for addition to
|
||||
-- the elaboration order, a line of output is generated showing which
|
||||
-- unit has been selected.
|
||||
|
||||
-- de Similar to the effect of -e (output complete list of elaboration
|
||||
-- dependencies) except that internal units are included in the
|
||||
-- listing.
|
||||
|
||||
-- dn List details of manipulation of Num_Pred values during execution of
|
||||
-- the algorithm used to determine a correct order of elaboration. This
|
||||
-- is useful in diagnosing any problems in its behavior.
|
||||
|
||||
-- dr List restrictions which have not been specified, but could have
|
||||
-- been without causing bind errors.
|
||||
|
||||
-- du List unit name and file name for each unit as it is read in
|
||||
|
||||
------------------------------------------------------------
|
||||
-- Documentation for the Debug Flags used in package Make --
|
||||
------------------------------------------------------------
|
||||
|
||||
-- Please note that such flags apply to all of Make clients,
|
||||
-- such as gnatmake.
|
||||
|
||||
-- dp Prints the Q used by routine Make.Compile_Sources every time
|
||||
-- we go around the main compile loop of Make.Compile_Sources
|
||||
|
||||
-- dq Prints source files as they are enqueued and dequeued in the Q
|
||||
-- used by routine Make.Compile_Sources. Useful to figure out the
|
||||
-- order in which sources are recompiled.
|
||||
|
||||
-- dw Prints the list of units withed by the unit currently explored
|
||||
-- during the main loop of Make.Compile_Sources.
|
||||
|
||||
----------------------
|
||||
-- Get_Debug_Flag_K --
|
||||
----------------------
|
||||
|
||||
function Get_Debug_Flag_K return Boolean is
|
||||
begin
|
||||
return Debug_Flag_K;
|
||||
end Get_Debug_Flag_K;
|
||||
|
||||
--------------------
|
||||
-- Set_Debug_Flag --
|
||||
--------------------
|
||||
|
||||
procedure Set_Debug_Flag (C : Character; Val : Boolean := True) is
|
||||
subtype Dig is Character range '1' .. '9';
|
||||
subtype LLet is Character range 'a' .. 'z';
|
||||
subtype ULet is Character range 'A' .. 'Z';
|
||||
|
||||
begin
|
||||
if C in Dig then
|
||||
case Dig (C) is
|
||||
when '1' => Debug_Flag_1 := Val;
|
||||
when '2' => Debug_Flag_2 := Val;
|
||||
when '3' => Debug_Flag_3 := Val;
|
||||
when '4' => Debug_Flag_4 := Val;
|
||||
when '5' => Debug_Flag_5 := Val;
|
||||
when '6' => Debug_Flag_6 := Val;
|
||||
when '7' => Debug_Flag_7 := Val;
|
||||
when '8' => Debug_Flag_8 := Val;
|
||||
when '9' => Debug_Flag_9 := Val;
|
||||
end case;
|
||||
|
||||
elsif C in ULet then
|
||||
case ULet (C) is
|
||||
when 'A' => Debug_Flag_AA := Val;
|
||||
when 'B' => Debug_Flag_BB := Val;
|
||||
when 'C' => Debug_Flag_CC := Val;
|
||||
when 'D' => Debug_Flag_DD := Val;
|
||||
when 'E' => Debug_Flag_EE := Val;
|
||||
when 'F' => Debug_Flag_FF := Val;
|
||||
when 'G' => Debug_Flag_GG := Val;
|
||||
when 'H' => Debug_Flag_HH := Val;
|
||||
when 'I' => Debug_Flag_II := Val;
|
||||
when 'J' => Debug_Flag_JJ := Val;
|
||||
when 'K' => Debug_Flag_KK := Val;
|
||||
when 'L' => Debug_Flag_LL := Val;
|
||||
when 'M' => Debug_Flag_MM := Val;
|
||||
when 'N' => Debug_Flag_NN := Val;
|
||||
when 'O' => Debug_Flag_OO := Val;
|
||||
when 'P' => Debug_Flag_PP := Val;
|
||||
when 'Q' => Debug_Flag_QQ := Val;
|
||||
when 'R' => Debug_Flag_RR := Val;
|
||||
when 'S' => Debug_Flag_SS := Val;
|
||||
when 'T' => Debug_Flag_TT := Val;
|
||||
when 'U' => Debug_Flag_UU := Val;
|
||||
when 'V' => Debug_Flag_VV := Val;
|
||||
when 'W' => Debug_Flag_WW := Val;
|
||||
when 'X' => Debug_Flag_XX := Val;
|
||||
when 'Y' => Debug_Flag_YY := Val;
|
||||
when 'Z' => Debug_Flag_ZZ := Val;
|
||||
end case;
|
||||
|
||||
else
|
||||
case LLet (C) is
|
||||
when 'a' => Debug_Flag_A := Val;
|
||||
when 'b' => Debug_Flag_B := Val;
|
||||
when 'c' => Debug_Flag_C := Val;
|
||||
when 'd' => Debug_Flag_D := Val;
|
||||
when 'e' => Debug_Flag_E := Val;
|
||||
when 'f' => Debug_Flag_F := Val;
|
||||
when 'g' => Debug_Flag_G := Val;
|
||||
when 'h' => Debug_Flag_H := Val;
|
||||
when 'i' => Debug_Flag_I := Val;
|
||||
when 'j' => Debug_Flag_J := Val;
|
||||
when 'k' => Debug_Flag_K := Val;
|
||||
when 'l' => Debug_Flag_L := Val;
|
||||
when 'm' => Debug_Flag_M := Val;
|
||||
when 'n' => Debug_Flag_N := Val;
|
||||
when 'o' => Debug_Flag_O := Val;
|
||||
when 'p' => Debug_Flag_P := Val;
|
||||
when 'q' => Debug_Flag_Q := Val;
|
||||
when 'r' => Debug_Flag_R := Val;
|
||||
when 's' => Debug_Flag_S := Val;
|
||||
when 't' => Debug_Flag_T := Val;
|
||||
when 'u' => Debug_Flag_U := Val;
|
||||
when 'v' => Debug_Flag_V := Val;
|
||||
when 'w' => Debug_Flag_W := Val;
|
||||
when 'x' => Debug_Flag_X := Val;
|
||||
when 'y' => Debug_Flag_Y := Val;
|
||||
when 'z' => Debug_Flag_Z := Val;
|
||||
end case;
|
||||
end if;
|
||||
end Set_Debug_Flag;
|
||||
|
||||
end Debug;
|
|
@ -0,0 +1,128 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- D E B U G --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.31 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-1999 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- As a special exception, if other files instantiate generics from this --
|
||||
-- unit, or you link this unit with other files to produce an executable, --
|
||||
-- this unit does not by itself cause the resulting executable to be --
|
||||
-- covered by the GNU General Public License. This exception does not --
|
||||
-- however invalidate any other reasons why the executable file might be --
|
||||
-- covered by the GNU Public License. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
package Debug is
|
||||
pragma Preelaborate (Debug);
|
||||
|
||||
-- This package contains global flags used to control the inclusion
|
||||
-- of debugging code in various phases of the compiler.
|
||||
|
||||
-------------------------
|
||||
-- Dynamic Debug Flags --
|
||||
-------------------------
|
||||
|
||||
-- Thirty six flags that can be used to active various specialized
|
||||
-- debugging output information. The flags are preset to False, which
|
||||
-- corresponds to the given output being suppressed. The individual
|
||||
-- flags can be turned on using the undocumented switch /dxxx where
|
||||
-- xxx is a string of letters for flags to be turned on. Documentation
|
||||
-- on the current usage of these flags is contained in the body of Debug
|
||||
-- rather than the spec, so that we don't have to recompile the world
|
||||
-- when a new debug flag is added
|
||||
|
||||
Debug_Flag_A : Boolean := False;
|
||||
Debug_Flag_B : Boolean := False;
|
||||
Debug_Flag_C : Boolean := False;
|
||||
Debug_Flag_D : Boolean := False;
|
||||
Debug_Flag_E : Boolean := False;
|
||||
Debug_Flag_F : Boolean := False;
|
||||
Debug_Flag_G : Boolean := False;
|
||||
Debug_Flag_H : Boolean := False;
|
||||
Debug_Flag_I : Boolean := False;
|
||||
Debug_Flag_J : Boolean := False;
|
||||
Debug_Flag_K : Boolean := False;
|
||||
Debug_Flag_L : Boolean := False;
|
||||
Debug_Flag_M : Boolean := False;
|
||||
Debug_Flag_N : Boolean := False;
|
||||
Debug_Flag_O : Boolean := False;
|
||||
Debug_Flag_P : Boolean := False;
|
||||
Debug_Flag_Q : Boolean := False;
|
||||
Debug_Flag_R : Boolean := False;
|
||||
Debug_Flag_S : Boolean := False;
|
||||
Debug_Flag_T : Boolean := False;
|
||||
Debug_Flag_U : Boolean := False;
|
||||
Debug_Flag_V : Boolean := False;
|
||||
Debug_Flag_W : Boolean := False;
|
||||
Debug_Flag_X : Boolean := False;
|
||||
Debug_Flag_Y : Boolean := False;
|
||||
Debug_Flag_Z : Boolean := False;
|
||||
|
||||
Debug_Flag_AA : Boolean := False;
|
||||
Debug_Flag_BB : Boolean := False;
|
||||
Debug_Flag_CC : Boolean := False;
|
||||
Debug_Flag_DD : Boolean := False;
|
||||
Debug_Flag_EE : Boolean := False;
|
||||
Debug_Flag_FF : Boolean := False;
|
||||
Debug_Flag_GG : Boolean := False;
|
||||
Debug_Flag_HH : Boolean := False;
|
||||
Debug_Flag_II : Boolean := False;
|
||||
Debug_Flag_JJ : Boolean := False;
|
||||
Debug_Flag_KK : Boolean := False;
|
||||
Debug_Flag_LL : Boolean := False;
|
||||
Debug_Flag_MM : Boolean := False;
|
||||
Debug_Flag_NN : Boolean := False;
|
||||
Debug_Flag_OO : Boolean := False;
|
||||
Debug_Flag_PP : Boolean := False;
|
||||
Debug_Flag_QQ : Boolean := False;
|
||||
Debug_Flag_RR : Boolean := False;
|
||||
Debug_Flag_SS : Boolean := False;
|
||||
Debug_Flag_TT : Boolean := False;
|
||||
Debug_Flag_UU : Boolean := False;
|
||||
Debug_Flag_VV : Boolean := False;
|
||||
Debug_Flag_WW : Boolean := False;
|
||||
Debug_Flag_XX : Boolean := False;
|
||||
Debug_Flag_YY : Boolean := False;
|
||||
Debug_Flag_ZZ : Boolean := False;
|
||||
|
||||
Debug_Flag_1 : Boolean := False;
|
||||
Debug_Flag_2 : Boolean := False;
|
||||
Debug_Flag_3 : Boolean := False;
|
||||
Debug_Flag_4 : Boolean := False;
|
||||
Debug_Flag_5 : Boolean := False;
|
||||
Debug_Flag_6 : Boolean := False;
|
||||
Debug_Flag_7 : Boolean := False;
|
||||
Debug_Flag_8 : Boolean := False;
|
||||
Debug_Flag_9 : Boolean := False;
|
||||
|
||||
function Get_Debug_Flag_K return Boolean;
|
||||
-- This function is called from C code to get the setting of the K flag
|
||||
-- (it does not work to try to access a constant object directly).
|
||||
|
||||
procedure Set_Debug_Flag (C : Character; Val : Boolean := True);
|
||||
-- Where C is 0-9, A-Z, or a-z, sets the corresponding debug flag to
|
||||
-- the given value. In the checks off version of debug, the call to
|
||||
-- Set_Debug_Flag is always a null operation.
|
||||
|
||||
end Debug;
|
|
@ -0,0 +1,128 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- D E B U G _ A --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.11 $ --
|
||||
-- --
|
||||
-- Copyright (C) 1992-1998 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Atree; use Atree;
|
||||
with Debug; use Debug;
|
||||
with Sinfo; use Sinfo;
|
||||
with Sinput; use Sinput;
|
||||
with Output; use Output;
|
||||
|
||||
package body Debug_A is
|
||||
|
||||
Debug_A_Depth : Natural := 0;
|
||||
-- Output for the debug A flag is preceded by a sequence of vertical bar
|
||||
-- characters corresponding to the recursion depth of the actions being
|
||||
-- recorded (analysis, expansion, resolution and evaluation of nodes)
|
||||
-- This variable records the depth.
|
||||
|
||||
Max_Node_Ids : constant := 200;
|
||||
-- Maximum number of Node_Id values that get stacked
|
||||
|
||||
Node_Ids : array (1 .. Max_Node_Ids) of Node_Id;
|
||||
-- A stack used to keep track of Node_Id values for setting the value of
|
||||
-- Current_Error_Node correctly. Note that if we have more than 200
|
||||
-- recursion levels, we just don't reset the right value on exit, which
|
||||
-- is not crucial, since this is only for debugging!
|
||||
|
||||
-----------------------
|
||||
-- Local Subprograms --
|
||||
-----------------------
|
||||
|
||||
procedure Debug_Output_Astring;
|
||||
-- Outputs Debug_A_Depth number of vertical bars, used to preface messages
|
||||
|
||||
-------------------
|
||||
-- Debug_A_Entry --
|
||||
-------------------
|
||||
|
||||
procedure Debug_A_Entry (S : String; N : Node_Id) is
|
||||
begin
|
||||
if Debug_Flag_A then
|
||||
Debug_Output_Astring;
|
||||
Write_Str (S);
|
||||
Write_Str ("Node_Id = ");
|
||||
Write_Int (Int (N));
|
||||
Write_Str (" ");
|
||||
Write_Location (Sloc (N));
|
||||
Write_Str (" ");
|
||||
Write_Str (Node_Kind'Image (Nkind (N)));
|
||||
Write_Eol;
|
||||
end if;
|
||||
|
||||
Debug_A_Depth := Debug_A_Depth + 1;
|
||||
Current_Error_Node := N;
|
||||
|
||||
if Debug_A_Depth <= Max_Node_Ids then
|
||||
Node_Ids (Debug_A_Depth) := N;
|
||||
end if;
|
||||
end Debug_A_Entry;
|
||||
|
||||
------------------
|
||||
-- Debug_A_Exit --
|
||||
------------------
|
||||
|
||||
procedure Debug_A_Exit (S : String; N : Node_Id; Comment : String) is
|
||||
begin
|
||||
Debug_A_Depth := Debug_A_Depth - 1;
|
||||
|
||||
if Debug_A_Depth in 1 .. Max_Node_Ids then
|
||||
Current_Error_Node := Node_Ids (Debug_A_Depth);
|
||||
end if;
|
||||
|
||||
if Debug_Flag_A then
|
||||
Debug_Output_Astring;
|
||||
Write_Str (S);
|
||||
Write_Str ("Node_Id = ");
|
||||
Write_Int (Int (N));
|
||||
Write_Str (Comment);
|
||||
Write_Eol;
|
||||
end if;
|
||||
end Debug_A_Exit;
|
||||
|
||||
--------------------------
|
||||
-- Debug_Output_Astring --
|
||||
--------------------------
|
||||
|
||||
procedure Debug_Output_Astring is
|
||||
Vbars : String := "|||||||||||||||||||||||||";
|
||||
-- Should be constant, removed because of GNAT 1.78 bug ???
|
||||
|
||||
begin
|
||||
if Debug_A_Depth > Vbars'Length then
|
||||
for I in Vbars'Length .. Debug_A_Depth loop
|
||||
Write_Char ('|');
|
||||
end loop;
|
||||
|
||||
Write_Str (Vbars);
|
||||
|
||||
else
|
||||
Write_Str (Vbars (1 .. Debug_A_Depth));
|
||||
end if;
|
||||
end Debug_Output_Astring;
|
||||
|
||||
end Debug_A;
|
|
@ -0,0 +1,66 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- D E B U G _ A --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.8 $ --
|
||||
-- --
|
||||
-- Copyright (C) 1992-1998 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This package contains data and subprograms to support the A debug switch
|
||||
-- that is used to generate output showing what node is being analyzed,
|
||||
-- resolved, evaluated, or expanded.
|
||||
|
||||
with Types; use Types;
|
||||
|
||||
package Debug_A is
|
||||
|
||||
-- Note: the following subprograms are used in a stack like manner, with
|
||||
-- an exit call matching each entry call. This means that they can keep
|
||||
-- track of the current node being worked on, with the entry call setting
|
||||
-- a new value, by pushing the Node_Id value on a stack, and the exit call
|
||||
-- popping this value off. Comperr.Current_Error_Node is set by both the
|
||||
-- entry and exit routines to point to the current node so that an abort
|
||||
-- message indicates the node involved as accurately as possible.
|
||||
|
||||
procedure Debug_A_Entry (S : String; N : Node_Id);
|
||||
pragma Inline (Debug_A_Entry);
|
||||
-- Generates a message prefixed by a sequence of bars showing the nesting
|
||||
-- depth (depth increases by 1 for a Debug_A_Entry call and is decreased
|
||||
-- by the corresponding Debug_A_Exit call). Then the string is output
|
||||
-- (analyzing, expanding etc), followed by the node number and its kind.
|
||||
-- This output is generated only if the debug A flag is set. If the debug
|
||||
-- A flag is not set, then no output is generated. This call also sets the
|
||||
-- Node_Id value in Comperr.Current_Error_Node in case a bomb occurs. This
|
||||
-- is done unconditionally, whether or not the debug A flag is set.
|
||||
|
||||
procedure Debug_A_Exit (S : String; N : Node_Id; Comment : String);
|
||||
pragma Inline (Debug_A_Exit);
|
||||
-- Generates the corresponding termination message. The message is preceded
|
||||
-- by a sequence of bars, followed by the string S, the node number, and
|
||||
-- a trailing comment (e.g. " (already evaluated)"). This output is
|
||||
-- generated only if the debug A flag is set. If the debug A flag is not
|
||||
-- set, then no output is generated. This call also resets the value in
|
||||
-- Comperr.Current_Error_Node to what it was before the corresponding call
|
||||
-- to Debug_A_Entry.
|
||||
|
||||
end Debug_A;
|
|
@ -0,0 +1,211 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT RUNTIME COMPONENTS --
|
||||
-- --
|
||||
-- D E C . I O --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.2 $
|
||||
-- --
|
||||
-- Copyright (C) 2001 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- As a special exception, if other files instantiate generics from this --
|
||||
-- unit, or you link this unit with other files to produce an executable, --
|
||||
-- this unit does not by itself cause the resulting executable to be --
|
||||
-- covered by the GNU General Public License. This exception does not --
|
||||
-- however invalidate any other reasons why the executable file might be --
|
||||
-- covered by the GNU Public License. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This is an AlphaVMS package that provides the interface between
|
||||
-- GNAT, DECLib IO packages and the DECLib Bliss library.
|
||||
|
||||
pragma Extend_System (Aux_DEC);
|
||||
|
||||
with System; use System;
|
||||
with System.Task_Primitives; use System.Task_Primitives;
|
||||
with System.Task_Primitives.Operations; use System.Task_Primitives.Operations;
|
||||
with IO_Exceptions; use IO_Exceptions;
|
||||
with Aux_IO_Exceptions; use Aux_IO_Exceptions;
|
||||
|
||||
package body DEC.IO is
|
||||
|
||||
type File_Type is record
|
||||
FCB : Integer := 0; -- Temporary
|
||||
SEQ : Integer := 0;
|
||||
end record;
|
||||
|
||||
for File_Type'Size use 64;
|
||||
for File_Type'Alignment use 8;
|
||||
|
||||
for File_Type use record
|
||||
FCB at 0 range 0 .. 31;
|
||||
SEQ at 4 range 0 .. 31;
|
||||
end record;
|
||||
|
||||
-----------------------
|
||||
-- Local Subprograms --
|
||||
-----------------------
|
||||
|
||||
function GNAT_Name_64 (File : File_Type) return String;
|
||||
pragma Export_Function (GNAT_Name_64, "GNAT$NAME_64");
|
||||
-- ??? comment
|
||||
|
||||
function GNAT_Form_64 (File : File_Type) return String;
|
||||
pragma Export_Function (GNAT_Form_64, "GNAT$FORM_64");
|
||||
-- ??? comment
|
||||
|
||||
procedure Init_IO;
|
||||
pragma Interface (C, Init_IO);
|
||||
pragma Import_Procedure (Init_IO, "GNAT$$INIT_IO");
|
||||
-- ??? comment
|
||||
|
||||
----------------
|
||||
-- IO_Locking --
|
||||
----------------
|
||||
|
||||
package body IO_Locking is
|
||||
|
||||
------------------
|
||||
-- Create_Mutex --
|
||||
------------------
|
||||
|
||||
function Create_Mutex return Access_Mutex is
|
||||
M : constant Access_Mutex := new RTS_Lock;
|
||||
|
||||
begin
|
||||
Initialize_Lock (M, Global_Task_Level);
|
||||
return M;
|
||||
end Create_Mutex;
|
||||
|
||||
-------------
|
||||
-- Acquire --
|
||||
-------------
|
||||
|
||||
procedure Acquire (M : Access_Mutex) is
|
||||
begin
|
||||
Write_Lock (M);
|
||||
end Acquire;
|
||||
|
||||
-------------
|
||||
-- Release --
|
||||
-------------
|
||||
|
||||
procedure Release (M : Access_Mutex) is
|
||||
begin
|
||||
Unlock (M);
|
||||
end Release;
|
||||
|
||||
end IO_Locking;
|
||||
|
||||
------------------
|
||||
-- GNAT_Name_64 --
|
||||
------------------
|
||||
|
||||
function GNAT_Name_64 (File : File_Type) return String is
|
||||
subtype Buffer_Subtype is String (1 .. 8192);
|
||||
|
||||
Buffer : Buffer_Subtype;
|
||||
Length : System.Integer_32;
|
||||
|
||||
procedure Get_Name
|
||||
(File : System.Address;
|
||||
MaxLen : System.Integer_32;
|
||||
Buffer : out Buffer_Subtype;
|
||||
Length : out System.Integer_32);
|
||||
pragma Interface (C, Get_Name);
|
||||
pragma Import_Procedure
|
||||
(Get_Name, "GNAT$FILE_NAME",
|
||||
Mechanism => (Value, Value, Reference, Reference));
|
||||
|
||||
begin
|
||||
Get_Name (File'Address, Buffer'Length, Buffer, Length);
|
||||
return Buffer (1 .. Integer (Length));
|
||||
end GNAT_Name_64;
|
||||
|
||||
------------------
|
||||
-- GNAT_Form_64 --
|
||||
------------------
|
||||
|
||||
function GNAT_Form_64 (File : File_Type) return String is
|
||||
subtype Buffer_Subtype is String (1 .. 8192);
|
||||
|
||||
Buffer : Buffer_Subtype;
|
||||
Length : System.Integer_32;
|
||||
|
||||
procedure Get_Form
|
||||
(File : System.Address;
|
||||
MaxLen : System.Integer_32;
|
||||
Buffer : out Buffer_Subtype;
|
||||
Length : out System.Integer_32);
|
||||
pragma Interface (C, Get_Form);
|
||||
pragma Import_Procedure
|
||||
(Get_Form, "GNAT$FILE_FORM",
|
||||
Mechanism => (Value, Value, Reference, Reference));
|
||||
|
||||
begin
|
||||
Get_Form (File'Address, Buffer'Length, Buffer, Length);
|
||||
return Buffer (1 .. Integer (Length));
|
||||
end GNAT_Form_64;
|
||||
|
||||
------------------------
|
||||
-- Raise_IO_Exception --
|
||||
------------------------
|
||||
|
||||
procedure Raise_IO_Exception (EN : Exception_Number) is
|
||||
begin
|
||||
case EN is
|
||||
when GNAT_EN_LOCK_ERROR => raise LOCK_ERROR;
|
||||
when GNAT_EN_EXISTENCE_ERROR => raise EXISTENCE_ERROR;
|
||||
when GNAT_EN_KEY_ERROR => raise KEY_ERROR;
|
||||
when GNAT_EN_KEYSIZERR => raise PROGRAM_ERROR; -- KEYSIZERR;
|
||||
when GNAT_EN_STAOVF => raise STORAGE_ERROR; -- STAOVF;
|
||||
when GNAT_EN_CONSTRAINT_ERRO => raise CONSTRAINT_ERROR;
|
||||
when GNAT_EN_IOSYSFAILED => raise DEVICE_ERROR; -- IOSYSFAILED;
|
||||
when GNAT_EN_LAYOUT_ERROR => raise LAYOUT_ERROR;
|
||||
when GNAT_EN_STORAGE_ERROR => raise STORAGE_ERROR;
|
||||
when GNAT_EN_DATA_ERROR => raise DATA_ERROR;
|
||||
when GNAT_EN_DEVICE_ERROR => raise DEVICE_ERROR;
|
||||
when GNAT_EN_END_ERROR => raise END_ERROR;
|
||||
when GNAT_EN_MODE_ERROR => raise MODE_ERROR;
|
||||
when GNAT_EN_NAME_ERROR => raise NAME_ERROR;
|
||||
when GNAT_EN_STATUS_ERROR => raise STATUS_ERROR;
|
||||
when GNAT_EN_NOT_OPEN => raise USE_ERROR; -- NOT_OPEN;
|
||||
when GNAT_EN_ALREADY_OPEN => raise USE_ERROR; -- ALREADY_OPEN;
|
||||
when GNAT_EN_USE_ERROR => raise USE_ERROR;
|
||||
when GNAT_EN_UNSUPPORTED => raise USE_ERROR; -- UNSUPPORTED;
|
||||
when GNAT_EN_FAC_MODE_MISMAT => raise USE_ERROR; -- FAC_MODE_MISMAT;
|
||||
when GNAT_EN_ORG_MISMATCH => raise USE_ERROR; -- ORG_MISMATCH;
|
||||
when GNAT_EN_RFM_MISMATCH => raise USE_ERROR; -- RFM_MISMATCH;
|
||||
when GNAT_EN_RAT_MISMATCH => raise USE_ERROR; -- RAT_MISMATCH;
|
||||
when GNAT_EN_MRS_MISMATCH => raise USE_ERROR; -- MRS_MISMATCH;
|
||||
when GNAT_EN_MRN_MISMATCH => raise USE_ERROR; -- MRN_MISMATCH;
|
||||
when GNAT_EN_KEY_MISMATCH => raise USE_ERROR; -- KEY_MISMATCH;
|
||||
when GNAT_EN_MAXLINEXC => raise CONSTRAINT_ERROR; -- MAXLINEXC;
|
||||
when GNAT_EN_LINEXCMRS => raise CONSTRAINT_ERROR; -- LINEXCMRS;
|
||||
end case;
|
||||
end Raise_IO_Exception;
|
||||
|
||||
-------------------------
|
||||
-- Package Elaboration --
|
||||
-------------------------
|
||||
|
||||
begin
|
||||
Init_IO;
|
||||
end DEC.IO;
|
|
@ -0,0 +1,125 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT RUNTIME COMPONENTS --
|
||||
-- --
|
||||
-- D E C . I O --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.2 $
|
||||
-- --
|
||||
-- Copyright (C) 1996-2001 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- As a special exception, if other files instantiate generics from this --
|
||||
-- unit, or you link this unit with other files to produce an executable, --
|
||||
-- this unit does not by itself cause the resulting executable to be --
|
||||
-- covered by the GNU General Public License. This exception does not --
|
||||
-- however invalidate any other reasons why the executable file might be --
|
||||
-- covered by the GNU Public License. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This is an AlphaVMS package that contains the declarations and
|
||||
-- function specifications needed by the DECLib IO packages.
|
||||
|
||||
with System.Task_Primitives;
|
||||
package DEC.IO is
|
||||
private
|
||||
|
||||
type Exception_Number is (
|
||||
GNAT_EN_LOCK_ERROR,
|
||||
GNAT_EN_EXISTENCE_ERROR,
|
||||
GNAT_EN_KEY_ERROR,
|
||||
GNAT_EN_KEYSIZERR,
|
||||
GNAT_EN_STAOVF,
|
||||
GNAT_EN_CONSTRAINT_ERRO,
|
||||
GNAT_EN_IOSYSFAILED,
|
||||
GNAT_EN_LAYOUT_ERROR,
|
||||
GNAT_EN_STORAGE_ERROR,
|
||||
GNAT_EN_DATA_ERROR,
|
||||
GNAT_EN_DEVICE_ERROR,
|
||||
GNAT_EN_END_ERROR,
|
||||
GNAT_EN_MODE_ERROR,
|
||||
GNAT_EN_NAME_ERROR,
|
||||
GNAT_EN_STATUS_ERROR,
|
||||
GNAT_EN_NOT_OPEN,
|
||||
GNAT_EN_ALREADY_OPEN,
|
||||
GNAT_EN_USE_ERROR,
|
||||
GNAT_EN_UNSUPPORTED,
|
||||
GNAT_EN_FAC_MODE_MISMAT,
|
||||
GNAT_EN_ORG_MISMATCH,
|
||||
GNAT_EN_RFM_MISMATCH,
|
||||
GNAT_EN_RAT_MISMATCH,
|
||||
GNAT_EN_MRS_MISMATCH,
|
||||
GNAT_EN_MRN_MISMATCH,
|
||||
GNAT_EN_KEY_MISMATCH,
|
||||
GNAT_EN_MAXLINEXC,
|
||||
GNAT_EN_LINEXCMRS);
|
||||
|
||||
for Exception_Number'Size use 32;
|
||||
|
||||
for Exception_Number use (
|
||||
GNAT_EN_LOCK_ERROR => 1,
|
||||
GNAT_EN_EXISTENCE_ERROR => 2,
|
||||
GNAT_EN_KEY_ERROR => 3,
|
||||
GNAT_EN_KEYSIZERR => 4,
|
||||
GNAT_EN_STAOVF => 5,
|
||||
GNAT_EN_CONSTRAINT_ERRO => 6,
|
||||
GNAT_EN_IOSYSFAILED => 7,
|
||||
GNAT_EN_LAYOUT_ERROR => 8,
|
||||
GNAT_EN_STORAGE_ERROR => 9,
|
||||
GNAT_EN_DATA_ERROR => 10,
|
||||
GNAT_EN_DEVICE_ERROR => 11,
|
||||
GNAT_EN_END_ERROR => 12,
|
||||
GNAT_EN_MODE_ERROR => 13,
|
||||
GNAT_EN_NAME_ERROR => 14,
|
||||
GNAT_EN_STATUS_ERROR => 15,
|
||||
GNAT_EN_NOT_OPEN => 16,
|
||||
GNAT_EN_ALREADY_OPEN => 17,
|
||||
GNAT_EN_USE_ERROR => 18,
|
||||
GNAT_EN_UNSUPPORTED => 19,
|
||||
GNAT_EN_FAC_MODE_MISMAT => 20,
|
||||
GNAT_EN_ORG_MISMATCH => 21,
|
||||
GNAT_EN_RFM_MISMATCH => 22,
|
||||
GNAT_EN_RAT_MISMATCH => 23,
|
||||
GNAT_EN_MRS_MISMATCH => 24,
|
||||
GNAT_EN_MRN_MISMATCH => 25,
|
||||
GNAT_EN_KEY_MISMATCH => 26,
|
||||
GNAT_EN_MAXLINEXC => 27,
|
||||
GNAT_EN_LINEXCMRS => 28);
|
||||
|
||||
procedure Raise_IO_Exception (EN : Exception_Number);
|
||||
pragma Export_Procedure (Raise_IO_Exception, "GNAT$RAISE_IO_EXCEPTION",
|
||||
Mechanism => Value);
|
||||
|
||||
package IO_Locking is
|
||||
type Access_Mutex is private;
|
||||
function Create_Mutex return Access_Mutex;
|
||||
procedure Acquire (M : Access_Mutex);
|
||||
procedure Release (M : Access_Mutex);
|
||||
|
||||
private
|
||||
type Access_Mutex is access System.Task_Primitives.RTS_Lock;
|
||||
pragma Export_Function (Create_Mutex, "GNAT$CREATE_MUTEX",
|
||||
Mechanism => Value);
|
||||
pragma Export_Procedure (Acquire, "GNAT$ACQUIRE_MUTEX",
|
||||
Mechanism => Value);
|
||||
pragma Export_Procedure (Release, "GNAT$RELEASE_MUTEX",
|
||||
Mechanism => Value);
|
||||
end IO_Locking;
|
||||
|
||||
end DEC.IO;
|
|
@ -0,0 +1,42 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT RUNTIME COMPONENTS --
|
||||
-- --
|
||||
-- D E C --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.5 $
|
||||
-- --
|
||||
-- Copyright (C) 1996-2001 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- As a special exception, if other files instantiate generics from this --
|
||||
-- unit, or you link this unit with other files to produce an executable, --
|
||||
-- this unit does not by itself cause the resulting executable to be --
|
||||
-- covered by the GNU General Public License. This exception does not --
|
||||
-- however invalidate any other reasons why the executable file might be --
|
||||
-- covered by the GNU Public License. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This is an AlphaVMS package, which is imported by every package in
|
||||
-- DECLib and tested for in gnatbind, in order to add "-ldecgnat" to
|
||||
-- the bind. It is also a convenient parent for all DEC IO child packages.
|
||||
|
||||
package DEC is
|
||||
pragma Pure (DEC);
|
||||
end DEC;
|
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,40 @@
|
|||
/****************************************************************************
|
||||
* *
|
||||
* GNAT COMPILER COMPONENTS *
|
||||
* *
|
||||
* D E F T A R G *
|
||||
* *
|
||||
* Body *
|
||||
* *
|
||||
* $Revision: 1.1 $
|
||||
* *
|
||||
* Copyright (C) 1992-2001 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- *
|
||||
* 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. *
|
||||
* *
|
||||
* As a special exception, if you link this file with other files to *
|
||||
* produce an executable, this file does not by itself cause the resulting *
|
||||
* executable to be covered by the GNU General Public License. This except- *
|
||||
* ion does not however invalidate any other reasons why the executable *
|
||||
* file might be covered by the GNU Public License. *
|
||||
* *
|
||||
* GNAT was originally developed by the GNAT team at New York University. *
|
||||
* It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). *
|
||||
* *
|
||||
****************************************************************************/
|
||||
|
||||
/* Include a default definition for TARGET_FLAGS for gnatpsta. */
|
||||
|
||||
#include "config.h"
|
||||
#define MIN(X,Y) ((X) < (Y) ? (X) : (Y))
|
||||
|
||||
int target_flags = TARGET_DEFAULT;
|
|
@ -0,0 +1,21 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT RUNTIME COMPONENTS --
|
||||
-- --
|
||||
-- D I R E C T _ I O --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.8 $ --
|
||||
-- --
|
||||
-- This specification is adapted from the Ada Reference Manual for use with --
|
||||
-- GNAT. In accordance with the copyright of that document, you can freely --
|
||||
-- copy and modify this specification, provided that if you redistribute a --
|
||||
-- modified version, any changes that you have made are clearly indicated. --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
pragma Ada_95;
|
||||
with Ada.Direct_IO;
|
||||
|
||||
generic package Direct_IO renames Ada.Direct_IO;
|
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,469 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- E L I S T S --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.22 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- As a special exception, if other files instantiate generics from this --
|
||||
-- unit, or you link this unit with other files to produce an executable, --
|
||||
-- this unit does not by itself cause the resulting executable to be --
|
||||
-- covered by the GNU General Public License. This exception does not --
|
||||
-- however invalidate any other reasons why the executable file might be --
|
||||
-- covered by the GNU Public License. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- WARNING: There is a C version of this package. Any changes to this
|
||||
-- source file must be properly reflected in the C header a-elists.h.
|
||||
|
||||
with Alloc;
|
||||
with Debug; use Debug;
|
||||
with Output; use Output;
|
||||
with Table;
|
||||
|
||||
package body Elists is
|
||||
|
||||
-------------------------------------
|
||||
-- Implementation of Element Lists --
|
||||
-------------------------------------
|
||||
|
||||
-- Element lists are composed of three types of entities. The element
|
||||
-- list header, which references the first and last elements of the
|
||||
-- list, the elements themselves which are singly linked and also
|
||||
-- reference the nodes on the list, and finally the nodes themselves.
|
||||
-- The following diagram shows how an element list is represented:
|
||||
|
||||
-- +----------------------------------------------------+
|
||||
-- | +------------------------------------------+ |
|
||||
-- | | | |
|
||||
-- V | V |
|
||||
-- +-----|--+ +-------+ +-------+ +-------+ |
|
||||
-- | Elmt | | 1st | | 2nd | | Last | |
|
||||
-- | List |--->| Elmt |--->| Elmt ---...-->| Elmt ---+
|
||||
-- | Header | | | | | | | | | |
|
||||
-- +--------+ +---|---+ +---|---+ +---|---+
|
||||
-- | | |
|
||||
-- V V V
|
||||
-- +-------+ +-------+ +-------+
|
||||
-- | | | | | |
|
||||
-- | Node1 | | Node2 | | Node3 |
|
||||
-- | | | | | |
|
||||
-- +-------+ +-------+ +-------+
|
||||
|
||||
-- The list header is an entry in the Elists table. The values used for
|
||||
-- the type Elist_Id are subscripts into this table. The First_Elmt field
|
||||
-- (Lfield1) points to the first element on the list, or to No_Elmt in the
|
||||
-- case of an empty list. Similarly the Last_Elmt field (Lfield2) points to
|
||||
-- the last element on the list or to No_Elmt in the case of an empty list.
|
||||
|
||||
-- The elements themselves are entries in the Elmts table. The Next field
|
||||
-- of each entry points to the next element, or to the Elist header if this
|
||||
-- is the last item in the list. The Node field points to the node which
|
||||
-- is referenced by the corresponding list entry.
|
||||
|
||||
--------------------------
|
||||
-- Element List Tables --
|
||||
--------------------------
|
||||
|
||||
type Elist_Header is record
|
||||
First : Elmt_Id;
|
||||
Last : Elmt_Id;
|
||||
end record;
|
||||
|
||||
package Elists is new Table.Table (
|
||||
Table_Component_Type => Elist_Header,
|
||||
Table_Index_Type => Elist_Id,
|
||||
Table_Low_Bound => First_Elist_Id,
|
||||
Table_Initial => Alloc.Elists_Initial,
|
||||
Table_Increment => Alloc.Elists_Increment,
|
||||
Table_Name => "Elists");
|
||||
|
||||
type Elmt_Item is record
|
||||
Node : Node_Id;
|
||||
Next : Union_Id;
|
||||
end record;
|
||||
|
||||
package Elmts is new Table.Table (
|
||||
Table_Component_Type => Elmt_Item,
|
||||
Table_Index_Type => Elmt_Id,
|
||||
Table_Low_Bound => First_Elmt_Id,
|
||||
Table_Initial => Alloc.Elmts_Initial,
|
||||
Table_Increment => Alloc.Elmts_Increment,
|
||||
Table_Name => "Elmts");
|
||||
|
||||
-----------------
|
||||
-- Append_Elmt --
|
||||
-----------------
|
||||
|
||||
procedure Append_Elmt (Node : Node_Id; To : Elist_Id) is
|
||||
L : constant Elmt_Id := Elists.Table (To).Last;
|
||||
|
||||
begin
|
||||
Elmts.Increment_Last;
|
||||
Elmts.Table (Elmts.Last).Node := Node;
|
||||
Elmts.Table (Elmts.Last).Next := Union_Id (To);
|
||||
|
||||
if L = No_Elmt then
|
||||
Elists.Table (To).First := Elmts.Last;
|
||||
else
|
||||
Elmts.Table (L).Next := Union_Id (Elmts.Last);
|
||||
end if;
|
||||
|
||||
Elists.Table (To).Last := Elmts.Last;
|
||||
|
||||
if Debug_Flag_N then
|
||||
Write_Str ("Append new element Elmt_Id = ");
|
||||
Write_Int (Int (Elmts.Last));
|
||||
Write_Str (" to list Elist_Id = ");
|
||||
Write_Int (Int (To));
|
||||
Write_Str (" referencing Node_Id = ");
|
||||
Write_Int (Int (Node));
|
||||
Write_Eol;
|
||||
end if;
|
||||
end Append_Elmt;
|
||||
|
||||
--------------------
|
||||
-- Elists_Address --
|
||||
--------------------
|
||||
|
||||
function Elists_Address return System.Address is
|
||||
begin
|
||||
return Elists.Table (First_Elist_Id)'Address;
|
||||
end Elists_Address;
|
||||
|
||||
-------------------
|
||||
-- Elmts_Address --
|
||||
-------------------
|
||||
|
||||
function Elmts_Address return System.Address is
|
||||
begin
|
||||
return Elmts.Table (First_Elmt_Id)'Address;
|
||||
end Elmts_Address;
|
||||
|
||||
----------------
|
||||
-- First_Elmt --
|
||||
----------------
|
||||
|
||||
function First_Elmt (List : Elist_Id) return Elmt_Id is
|
||||
begin
|
||||
pragma Assert (List > Elist_Low_Bound);
|
||||
return Elists.Table (List).First;
|
||||
end First_Elmt;
|
||||
|
||||
----------------
|
||||
-- Initialize --
|
||||
----------------
|
||||
|
||||
procedure Initialize is
|
||||
begin
|
||||
Elists.Init;
|
||||
Elmts.Init;
|
||||
end Initialize;
|
||||
|
||||
-----------------------
|
||||
-- Insert_Elmt_After --
|
||||
-----------------------
|
||||
|
||||
procedure Insert_Elmt_After (Node : Node_Id; Elmt : Elmt_Id) is
|
||||
N : constant Union_Id := Elmts.Table (Elmt).Next;
|
||||
|
||||
begin
|
||||
|
||||
pragma Assert (Elmt /= No_Elmt);
|
||||
|
||||
Elmts.Increment_Last;
|
||||
Elmts.Table (Elmts.Last).Node := Node;
|
||||
Elmts.Table (Elmts.Last).Next := N;
|
||||
|
||||
Elmts.Table (Elmt).Next := Union_Id (Elmts.Last);
|
||||
|
||||
if N in Elist_Range then
|
||||
Elists.Table (Elist_Id (N)).Last := Elmts.Last;
|
||||
end if;
|
||||
end Insert_Elmt_After;
|
||||
|
||||
------------------------
|
||||
-- Is_Empty_Elmt_List --
|
||||
------------------------
|
||||
|
||||
function Is_Empty_Elmt_List (List : Elist_Id) return Boolean is
|
||||
begin
|
||||
return Elists.Table (List).First = No_Elmt;
|
||||
end Is_Empty_Elmt_List;
|
||||
|
||||
-------------------
|
||||
-- Last_Elist_Id --
|
||||
-------------------
|
||||
|
||||
function Last_Elist_Id return Elist_Id is
|
||||
begin
|
||||
return Elists.Last;
|
||||
end Last_Elist_Id;
|
||||
|
||||
---------------
|
||||
-- Last_Elmt --
|
||||
---------------
|
||||
|
||||
function Last_Elmt (List : Elist_Id) return Elmt_Id is
|
||||
begin
|
||||
return Elists.Table (List).Last;
|
||||
end Last_Elmt;
|
||||
|
||||
------------------
|
||||
-- Last_Elmt_Id --
|
||||
------------------
|
||||
|
||||
function Last_Elmt_Id return Elmt_Id is
|
||||
begin
|
||||
return Elmts.Last;
|
||||
end Last_Elmt_Id;
|
||||
|
||||
----------
|
||||
-- Lock --
|
||||
----------
|
||||
|
||||
procedure Lock is
|
||||
begin
|
||||
Elists.Locked := True;
|
||||
Elmts.Locked := True;
|
||||
Elists.Release;
|
||||
Elmts.Release;
|
||||
end Lock;
|
||||
|
||||
-------------------
|
||||
-- New_Elmt_List --
|
||||
-------------------
|
||||
|
||||
function New_Elmt_List return Elist_Id is
|
||||
begin
|
||||
Elists.Increment_Last;
|
||||
Elists.Table (Elists.Last).First := No_Elmt;
|
||||
Elists.Table (Elists.Last).Last := No_Elmt;
|
||||
|
||||
if Debug_Flag_N then
|
||||
Write_Str ("Allocate new element list, returned ID = ");
|
||||
Write_Int (Int (Elists.Last));
|
||||
Write_Eol;
|
||||
end if;
|
||||
|
||||
return Elists.Last;
|
||||
end New_Elmt_List;
|
||||
|
||||
---------------
|
||||
-- Next_Elmt --
|
||||
---------------
|
||||
|
||||
function Next_Elmt (Elmt : Elmt_Id) return Elmt_Id is
|
||||
N : constant Union_Id := Elmts.Table (Elmt).Next;
|
||||
|
||||
begin
|
||||
if N in Elist_Range then
|
||||
return No_Elmt;
|
||||
else
|
||||
return Elmt_Id (N);
|
||||
end if;
|
||||
end Next_Elmt;
|
||||
|
||||
procedure Next_Elmt (Elmt : in out Elmt_Id) is
|
||||
begin
|
||||
Elmt := Next_Elmt (Elmt);
|
||||
end Next_Elmt;
|
||||
|
||||
--------
|
||||
-- No --
|
||||
--------
|
||||
|
||||
function No (List : Elist_Id) return Boolean is
|
||||
begin
|
||||
return List = No_Elist;
|
||||
end No;
|
||||
|
||||
function No (Elmt : Elmt_Id) return Boolean is
|
||||
begin
|
||||
return Elmt = No_Elmt;
|
||||
end No;
|
||||
|
||||
-----------
|
||||
-- Node --
|
||||
-----------
|
||||
|
||||
function Node (Elmt : Elmt_Id) return Node_Id is
|
||||
begin
|
||||
if Elmt = No_Elmt then
|
||||
return Empty;
|
||||
else
|
||||
return Elmts.Table (Elmt).Node;
|
||||
end if;
|
||||
end Node;
|
||||
|
||||
----------------
|
||||
-- Num_Elists --
|
||||
----------------
|
||||
|
||||
function Num_Elists return Nat is
|
||||
begin
|
||||
return Int (Elmts.Last) - Int (Elmts.First) + 1;
|
||||
end Num_Elists;
|
||||
|
||||
------------------
|
||||
-- Prepend_Elmt --
|
||||
------------------
|
||||
|
||||
procedure Prepend_Elmt (Node : Node_Id; To : Elist_Id) is
|
||||
F : constant Elmt_Id := Elists.Table (To).First;
|
||||
|
||||
begin
|
||||
Elmts.Increment_Last;
|
||||
Elmts.Table (Elmts.Last).Node := Node;
|
||||
|
||||
if F = No_Elmt then
|
||||
Elists.Table (To).Last := Elmts.Last;
|
||||
Elmts.Table (Elmts.Last).Next := Union_Id (To);
|
||||
else
|
||||
Elmts.Table (Elmts.Last).Next := Union_Id (F);
|
||||
end if;
|
||||
|
||||
Elists.Table (To).First := Elmts.Last;
|
||||
|
||||
end Prepend_Elmt;
|
||||
|
||||
-------------
|
||||
-- Present --
|
||||
-------------
|
||||
|
||||
function Present (List : Elist_Id) return Boolean is
|
||||
begin
|
||||
return List /= No_Elist;
|
||||
end Present;
|
||||
|
||||
function Present (Elmt : Elmt_Id) return Boolean is
|
||||
begin
|
||||
return Elmt /= No_Elmt;
|
||||
end Present;
|
||||
|
||||
-----------------
|
||||
-- Remove_Elmt --
|
||||
-----------------
|
||||
|
||||
procedure Remove_Elmt (List : Elist_Id; Elmt : Elmt_Id) is
|
||||
Nxt : Elmt_Id;
|
||||
Prv : Elmt_Id;
|
||||
|
||||
begin
|
||||
Nxt := Elists.Table (List).First;
|
||||
|
||||
-- Case of removing only element in the list
|
||||
|
||||
if Elmts.Table (Nxt).Next in Elist_Range then
|
||||
|
||||
pragma Assert (Nxt = Elmt);
|
||||
|
||||
Elists.Table (List).First := No_Elmt;
|
||||
Elists.Table (List).Last := No_Elmt;
|
||||
|
||||
-- Case of removing the first element in the list
|
||||
|
||||
elsif Nxt = Elmt then
|
||||
Elists.Table (List).First := Elmt_Id (Elmts.Table (Nxt).Next);
|
||||
|
||||
-- Case of removing second or later element in the list
|
||||
|
||||
else
|
||||
loop
|
||||
Prv := Nxt;
|
||||
Nxt := Elmt_Id (Elmts.Table (Prv).Next);
|
||||
exit when Nxt = Elmt
|
||||
or else Elmts.Table (Nxt).Next in Elist_Range;
|
||||
end loop;
|
||||
|
||||
pragma Assert (Nxt = Elmt);
|
||||
|
||||
Elmts.Table (Prv).Next := Elmts.Table (Nxt).Next;
|
||||
|
||||
if Elmts.Table (Prv).Next in Elist_Range then
|
||||
Elists.Table (List).Last := Prv;
|
||||
end if;
|
||||
end if;
|
||||
end Remove_Elmt;
|
||||
|
||||
----------------------
|
||||
-- Remove_Last_Elmt --
|
||||
----------------------
|
||||
|
||||
procedure Remove_Last_Elmt (List : Elist_Id) is
|
||||
Nxt : Elmt_Id;
|
||||
Prv : Elmt_Id;
|
||||
|
||||
begin
|
||||
Nxt := Elists.Table (List).First;
|
||||
|
||||
-- Case of removing only element in the list
|
||||
|
||||
if Elmts.Table (Nxt).Next in Elist_Range then
|
||||
Elists.Table (List).First := No_Elmt;
|
||||
Elists.Table (List).Last := No_Elmt;
|
||||
|
||||
-- Case of at least two elements in list
|
||||
|
||||
else
|
||||
loop
|
||||
Prv := Nxt;
|
||||
Nxt := Elmt_Id (Elmts.Table (Prv).Next);
|
||||
exit when Elmts.Table (Nxt).Next in Elist_Range;
|
||||
end loop;
|
||||
|
||||
Elmts.Table (Prv).Next := Elmts.Table (Nxt).Next;
|
||||
Elists.Table (List).Last := Prv;
|
||||
end if;
|
||||
end Remove_Last_Elmt;
|
||||
|
||||
------------------
|
||||
-- Replace_Elmt --
|
||||
------------------
|
||||
|
||||
procedure Replace_Elmt (Elmt : Elmt_Id; New_Node : Node_Id) is
|
||||
begin
|
||||
Elmts.Table (Elmt).Node := New_Node;
|
||||
end Replace_Elmt;
|
||||
|
||||
---------------
|
||||
-- Tree_Read --
|
||||
---------------
|
||||
|
||||
procedure Tree_Read is
|
||||
begin
|
||||
Elists.Tree_Read;
|
||||
Elmts.Tree_Read;
|
||||
end Tree_Read;
|
||||
|
||||
----------------
|
||||
-- Tree_Write --
|
||||
----------------
|
||||
|
||||
procedure Tree_Write is
|
||||
begin
|
||||
Elists.Tree_Write;
|
||||
Elmts.Tree_Write;
|
||||
end Tree_Write;
|
||||
|
||||
end Elists;
|
|
@ -0,0 +1,171 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- E L I S T S --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.14 $ --
|
||||
-- --
|
||||
-- Copyright (C) 1992-1998 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- As a special exception, if other files instantiate generics from this --
|
||||
-- unit, or you link this unit with other files to produce an executable, --
|
||||
-- this unit does not by itself cause the resulting executable to be --
|
||||
-- covered by the GNU General Public License. This exception does not --
|
||||
-- however invalidate any other reasons why the executable file might be --
|
||||
-- covered by the GNU Public License. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This package provides facilities for manipulating lists of nodes (see
|
||||
-- package Atree for format and implementation of tree nodes). Separate list
|
||||
-- elements are allocated to represent elements of these lists, so it is
|
||||
-- possible for a given node to be on more than one element list at a time.
|
||||
-- See also package Nlists, which provides another form that is threaded
|
||||
-- through the nodes themselves (using the Link field), which is more time
|
||||
-- and space efficient, but a node can be only one such list.
|
||||
|
||||
with Types; use Types;
|
||||
with System;
|
||||
|
||||
package Elists is
|
||||
|
||||
-- An element list is represented by a header that is allocated in the
|
||||
-- Elist header table. This header contains pointers to the first and
|
||||
-- last elements in the list, or to No_Elmt if the list is empty.
|
||||
|
||||
-- The elements in the list each contain a pointer to the next element
|
||||
-- and a pointer to the referenced node. Putting a node into an element
|
||||
-- list causes no change at all to the node itself, so a node may be
|
||||
-- included in multiple element lists, and the nodes thus included may
|
||||
-- or may not be elements of node lists (see package Nlists).
|
||||
|
||||
procedure Initialize;
|
||||
-- Initialize allocation of element list tables. Called at the start of
|
||||
-- compiling each new main source file. Note that Initialize must not be
|
||||
-- called if Tree_Read is used.
|
||||
|
||||
procedure Lock;
|
||||
-- Lock tables used for element lists before calling backend
|
||||
|
||||
procedure Tree_Read;
|
||||
-- Initializes internal tables from current tree file using Tree_Read.
|
||||
-- Note that Initialize should not be called if Tree_Read is used.
|
||||
-- Tree_Read includes all necessary initialization.
|
||||
|
||||
procedure Tree_Write;
|
||||
-- Writes out internal tables to current tree file using Tree_Write
|
||||
|
||||
function Last_Elist_Id return Elist_Id;
|
||||
-- Returns Id of last allocated element list header
|
||||
|
||||
function Elists_Address return System.Address;
|
||||
-- Return address of Elists table (used in Back_End for Gigi call)
|
||||
|
||||
function Num_Elists return Nat;
|
||||
-- Number of currently allocated element lists
|
||||
|
||||
function Last_Elmt_Id return Elmt_Id;
|
||||
-- Returns Id of last allocated list element
|
||||
|
||||
function Elmts_Address return System.Address;
|
||||
-- Return address of Elmts table (used in Back_End for Gigi call)
|
||||
|
||||
function Node (Elmt : Elmt_Id) return Node_Id;
|
||||
pragma Inline (Node);
|
||||
-- Returns the value of a given list element. Returns Empty if Elmt
|
||||
-- is set to No_Elmt.
|
||||
|
||||
function New_Elmt_List return Elist_Id;
|
||||
-- Creates a new empty element list. Typically this is used to initialize
|
||||
-- a field in some other node which points to an element list where the
|
||||
-- list is then subsequently filled in using Append calls.
|
||||
|
||||
function First_Elmt (List : Elist_Id) return Elmt_Id;
|
||||
pragma Inline (First_Elmt);
|
||||
-- Obtains the first element of the given element list or, if the
|
||||
-- list has no items, then No_Elmt is returned.
|
||||
|
||||
function Last_Elmt (List : Elist_Id) return Elmt_Id;
|
||||
pragma Inline (Last_Elmt);
|
||||
-- Obtains the last element of the given element list or, if the
|
||||
-- list has no items, then No_Elmt is returned.
|
||||
|
||||
function Next_Elmt (Elmt : Elmt_Id) return Elmt_Id;
|
||||
pragma Inline (Next_Elmt);
|
||||
-- This function returns the next element on an element list. The argument
|
||||
-- must be a list element other than No_Elmt. Returns No_Elmt if the given
|
||||
-- element is the last element of the list.
|
||||
|
||||
procedure Next_Elmt (Elmt : in out Elmt_Id);
|
||||
pragma Inline (Next_Elmt);
|
||||
-- Next_Elmt (Elmt) is equivalent to Elmt := Next_Elmt (Elmt)
|
||||
|
||||
function Is_Empty_Elmt_List (List : Elist_Id) return Boolean;
|
||||
pragma Inline (Is_Empty_Elmt_List);
|
||||
-- This function determines if a given tree id references an element list
|
||||
-- that contains no items.
|
||||
|
||||
procedure Append_Elmt (Node : Node_Id; To : Elist_Id);
|
||||
-- Appends Node at the end of To, allocating a new element.
|
||||
|
||||
procedure Prepend_Elmt (Node : Node_Id; To : Elist_Id);
|
||||
-- Appends Node at the beginning of To, allocating a new element.
|
||||
|
||||
procedure Insert_Elmt_After (Node : Node_Id; Elmt : Elmt_Id);
|
||||
-- Add a new element (Node) right after the pre-existing element Elmt
|
||||
-- It is invalid to call this subprogram with Elmt = No_Elmt.
|
||||
|
||||
procedure Replace_Elmt (Elmt : Elmt_Id; New_Node : Node_Id);
|
||||
pragma Inline (Replace_Elmt);
|
||||
-- Causes the given element of the list to refer to New_Node, the node
|
||||
-- which was previously referred to by Elmt is effectively removed from
|
||||
-- the list and replaced by New_Node.
|
||||
|
||||
procedure Remove_Elmt (List : Elist_Id; Elmt : Elmt_Id);
|
||||
-- Removes Elmt from the given list. The node itself is not affected,
|
||||
-- but the space used by the list element may be (but is not required
|
||||
-- to be) freed for reuse in a subsequent Append_Elmt call.
|
||||
|
||||
procedure Remove_Last_Elmt (List : Elist_Id);
|
||||
-- Removes the last element of the given list. The node itself is not
|
||||
-- affected, but the space used by the list element may be (but is not
|
||||
-- required to be) freed for reuse in a subsequent Append_Elmt call.
|
||||
|
||||
function No (List : Elist_Id) return Boolean;
|
||||
pragma Inline (No);
|
||||
-- Tests given Id for equality with No_Elist. This allows notations like
|
||||
-- "if No (Statements)" as opposed to "if Statements = No_Elist".
|
||||
|
||||
function Present (List : Elist_Id) return Boolean;
|
||||
pragma Inline (Present);
|
||||
-- Tests given Id for inequality with No_Elist. This allows notations like
|
||||
-- "if Present (Statements)" as opposed to "if Statements /= No_Elist".
|
||||
|
||||
function No (Elmt : Elmt_Id) return Boolean;
|
||||
pragma Inline (No);
|
||||
-- Tests given Id for equality with No_Elmt. This allows notations like
|
||||
-- "if No (Operation)" as opposed to "if Operation = No_Elmt".
|
||||
|
||||
function Present (Elmt : Elmt_Id) return Boolean;
|
||||
pragma Inline (Present);
|
||||
-- Tests given Id for inequality with No_Elmt. This allows notations like
|
||||
-- "if Present (Operation)" as opposed to "if Operation /= No_Elmt".
|
||||
|
||||
end Elists;
|
|
@ -0,0 +1,107 @@
|
|||
/****************************************************************************
|
||||
* *
|
||||
* GNAT COMPILER COMPONENTS *
|
||||
* *
|
||||
* E L I S T S *
|
||||
* *
|
||||
* C Header File *
|
||||
* *
|
||||
* $Revision: 1.1 $
|
||||
* *
|
||||
* Copyright (C) 1992-2001 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- *
|
||||
* 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. *
|
||||
* *
|
||||
* GNAT was originally developed by the GNAT team at New York University. *
|
||||
* It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). *
|
||||
* *
|
||||
****************************************************************************/
|
||||
|
||||
/* This is the C header corresponding to the Ada package specification for
|
||||
Elists. It also contains the implementations of inlined functions from the
|
||||
package body for Elists. It was generated manually from elists.ads and
|
||||
elists.adb and must be kept synchronized with changes in these files.
|
||||
|
||||
Note that only routines for reading the tree are included, since the
|
||||
tree transformer is not supposed to modify the tree in any way. */
|
||||
|
||||
/* The following are the structures used to hold element lists */
|
||||
|
||||
struct Elist_Header
|
||||
{
|
||||
Elmt_Id first;
|
||||
Elmt_Id last;
|
||||
};
|
||||
|
||||
struct Elmt_Item
|
||||
{
|
||||
Node_Id node;
|
||||
Int next;
|
||||
};
|
||||
|
||||
/* The element list headers and element descriptors themselves are stored in
|
||||
two arrays. The pointers to these arrays are passed as a parameter to the
|
||||
tree transformer procedure and stored in the global variables Elists_Ptr
|
||||
and Elmts_Ptr after adjusting them by subtracting Elist_First_Entry and
|
||||
Elmt_First_Entry, so that Elist_Id and Elmt_Id values can be used as
|
||||
subscripts into these arrays */
|
||||
|
||||
extern struct Elist_Header *Elists_Ptr;
|
||||
extern struct Elmt_Item *Elmts_Ptr;
|
||||
|
||||
/* Element List Access Functions: */
|
||||
|
||||
static Node_Id Node PARAMS ((Elmt_Id));
|
||||
static Elmt_Id First_Elmt PARAMS ((Elist_Id));
|
||||
static Elmt_Id Last_Elmt PARAMS ((Elist_Id));
|
||||
static Elmt_Id Next_Elmt PARAMS ((Elmt_Id));
|
||||
static Boolean Is_Empty_Elmt_List PARAMS ((Elist_Id));
|
||||
|
||||
INLINE Node_Id
|
||||
Node (Elmt)
|
||||
Elmt_Id Elmt;
|
||||
{
|
||||
return Elmts_Ptr [Elmt].node;
|
||||
}
|
||||
|
||||
INLINE Elmt_Id
|
||||
First_Elmt (List)
|
||||
Elist_Id List;
|
||||
{
|
||||
return Elists_Ptr [List].first;
|
||||
}
|
||||
|
||||
INLINE Elmt_Id
|
||||
Last_Elmt (List)
|
||||
Elist_Id List;
|
||||
{
|
||||
return Elists_Ptr [List].last;
|
||||
}
|
||||
|
||||
INLINE Elmt_Id
|
||||
Next_Elmt (Node)
|
||||
Elmt_Id Node;
|
||||
{
|
||||
Int N = Elmts_Ptr [Node].next;
|
||||
|
||||
if (IN (N, Elist_Range))
|
||||
return No_Elmt;
|
||||
else
|
||||
return N;
|
||||
}
|
||||
|
||||
INLINE Boolean
|
||||
Is_Empty_Elmt_List (Id)
|
||||
Elist_Id Id;
|
||||
{
|
||||
return Elists_Ptr [Id].first == No_Elmt;
|
||||
}
|
|
@ -0,0 +1,57 @@
|
|||
/****************************************************************************
|
||||
* *
|
||||
* GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS *
|
||||
* *
|
||||
* E R R N O *
|
||||
* *
|
||||
* C Implementation File *
|
||||
* *
|
||||
* $Revision: 1.1 $
|
||||
* *
|
||||
* Copyright (C) 1992-2001 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- *
|
||||
* 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. *
|
||||
* *
|
||||
* As a special exception, if you link this file with other files to *
|
||||
* produce an executable, this file does not by itself cause the resulting *
|
||||
* executable to be covered by the GNU General Public License. This except- *
|
||||
* ion does not however invalidate any other reasons why the executable *
|
||||
* file might be covered by the GNU Public License. *
|
||||
* *
|
||||
* GNAT was originally developed by the GNAT team at New York University. *
|
||||
* It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). *
|
||||
* *
|
||||
****************************************************************************/
|
||||
|
||||
/* This file provides access to the C-language errno to the Ada interface
|
||||
for POSIX. It is not possible in general to import errno, even in
|
||||
Ada compilers that allow (as GNAT does) the importation of variables,
|
||||
as it may be defined using a macro.
|
||||
*/
|
||||
|
||||
|
||||
#define _REENTRANT
|
||||
#define _THREAD_SAFE
|
||||
|
||||
#include <errno.h>
|
||||
int
|
||||
__get_errno()
|
||||
{
|
||||
return errno;
|
||||
}
|
||||
|
||||
void
|
||||
__set_errno(err)
|
||||
int err;
|
||||
{
|
||||
errno = err;
|
||||
}
|
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,504 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- E R R O U T --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.70 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This package contains the routines to output error messages. They
|
||||
-- are basically system independent, however in some environments, e.g.
|
||||
-- when the parser is embedded into an editor, it may be appropriate
|
||||
-- to replace the implementation of this package.
|
||||
|
||||
with Table;
|
||||
with Types; use Types;
|
||||
with Uintp; use Uintp;
|
||||
|
||||
package Errout is
|
||||
|
||||
Errors_Detected : Nat;
|
||||
-- Number of errors detected so far
|
||||
|
||||
Warnings_Detected : Nat;
|
||||
-- Number of warnings detected
|
||||
|
||||
type Compiler_State_Type is (Parsing, Analyzing);
|
||||
Compiler_State : Compiler_State_Type;
|
||||
-- Indicates current state of compilation. This is put in the Errout
|
||||
-- spec because it affects the action of the error message handling.
|
||||
-- In particular, an attempt is made by Errout to suppress cascaded
|
||||
-- error messages in Parsing mode, but not in the other modes.
|
||||
|
||||
Current_Error_Source_File : Source_File_Index;
|
||||
-- Id of current messages. Used to post file name when unit changes. This
|
||||
-- is initialized to Main_Source_File at the start of a compilation, which
|
||||
-- means that no file names will be output unless there are errors in units
|
||||
-- other than the main unit. However, if the main unit has a pragma
|
||||
-- Source_Reference line, then this is initialized to No_Source_File,
|
||||
-- to force an initial reference to the real source file name.
|
||||
|
||||
Raise_Exception_On_Error : Nat := 0;
|
||||
-- If this value is non-zero, then any attempt to generate an error
|
||||
-- message raises the exception Error_Msg_Exception, and the error
|
||||
-- message is not output. This is used for defending against junk
|
||||
-- resulting from illegalities, and also for substitution of more
|
||||
-- appropriate error messages from higher semantic levels. It is
|
||||
-- a counter so that the increment/decrement protocol nests neatly.
|
||||
|
||||
Error_Msg_Exception : exception;
|
||||
-- Exception raised if Raise_Exception_On_Error is true
|
||||
|
||||
-----------------------------------
|
||||
-- Suppression of Error Messages --
|
||||
-----------------------------------
|
||||
|
||||
-- In an effort to reduce the impact of redundant error messages, the
|
||||
-- error output routines in this package normally suppress certain
|
||||
-- classes of messages as follows:
|
||||
|
||||
-- 1. Identical messages placed at the same point in the text. Such
|
||||
-- duplicate error message result for example from rescanning
|
||||
-- sections of the text that contain lexical errors. Only one of
|
||||
-- such a set of duplicate messages is output, and the rest are
|
||||
-- suppressed.
|
||||
|
||||
-- 2. If more than one parser message is generated for a single source
|
||||
-- line, then only the first message is output, the remaining
|
||||
-- messages on the same line are suppressed.
|
||||
|
||||
-- 3. If a message is posted on a node for which a message has been
|
||||
-- previously posted, then only the first message is retained. The
|
||||
-- Error_Posted flag is used to detect such multiple postings. Note
|
||||
-- that this only applies to semantic messages, since otherwise
|
||||
-- for parser messages, this would be a special case of case 2.
|
||||
|
||||
-- 4. If a message is posted on a node whose Etype or Entity
|
||||
-- fields reference entities on which an error message has
|
||||
-- already been placed, as indicated by the Error_Posted flag
|
||||
-- being set on these entities, then the message is suppressed.
|
||||
|
||||
-- 5. If a message attempts to insert an Error node, or a direct
|
||||
-- reference to the Any_Type node, then the message is suppressed.
|
||||
|
||||
-- This normal suppression action may be overridden in cases 2-5 (but not
|
||||
-- in case 1) by setting All_Errors mode, or by setting the special
|
||||
-- unconditional message insertion character (!) at the end of the message
|
||||
-- text as described below.
|
||||
|
||||
---------------------------------------------------------
|
||||
-- Error Message Text and Message Insertion Characters --
|
||||
---------------------------------------------------------
|
||||
|
||||
-- Error message text strings are composed of lower case letters, digits
|
||||
-- and the special characters space, comma, period, colon and semicolon,
|
||||
-- apostrophe and parentheses. Special insertion characters can also
|
||||
-- appear which cause the error message circuit to modify the given
|
||||
-- string as follows:
|
||||
|
||||
-- Insertion character % (Percent: insert name from Names table)
|
||||
-- The character % is replaced by the text for the name specified by
|
||||
-- the Name_Id value stored in Error_Msg_Name_1. A blank precedes
|
||||
-- the name if it is preceded by a non-blank character other than a
|
||||
-- left parenthesis. The name is enclosed in quotes unless manual
|
||||
-- quotation mode is set. If the Name_Id is set to No_Name, then
|
||||
-- no insertion occurs; if the Name_Id is set to Error_Name, then
|
||||
-- the string <error> is inserted. A second and third % may appear
|
||||
-- in a single message, similarly replaced by the names which are
|
||||
-- specified by the Name_Id values stored in Error_Msg_Name_2 and
|
||||
-- Error_Msg_Name_3. The names are decoded and cased according to
|
||||
-- the current identifier casing mode.
|
||||
|
||||
-- Insertion character $ (Dollar: insert unit name from Names table)
|
||||
-- The character $ is treated similarly to %, except that the name
|
||||
-- is obtained from the Unit_Name_Type value in Error_Msg_Unit_1
|
||||
-- and Error_Msg_Unit_2, as provided by Get_Unit_Name_String in
|
||||
-- package Uname. Note that this name includes the postfix (spec)
|
||||
-- or (body) strings. If this postfix is not required, use the
|
||||
-- normal % insertion for the unit name.
|
||||
|
||||
-- Insertion character { (Left brace: insert literally from names table)
|
||||
-- The character { is treated similarly to %, except that the
|
||||
-- name is output literally as stored in the names table without
|
||||
-- adjusting the casing. This can be used for file names and in
|
||||
-- other situations where the name string is to be output unchanged.
|
||||
|
||||
-- Insertion character * (Asterisk, insert reserved word name)
|
||||
-- The insertion character * is treated exactly like % except that
|
||||
-- the resulting name is cased according to the default conventions
|
||||
-- for reserved words (see package Scans).
|
||||
|
||||
-- Insertion character & (Ampersand: insert name from node)
|
||||
-- The insertion character & is treated similarly to %, except that
|
||||
-- the name is taken from the Chars field of the given node, and may
|
||||
-- refer to a child unit name, or a selected component. The casing
|
||||
-- is, if possible, taken from the original source reference, which
|
||||
-- is obtained from the Sloc field of the given node or nodes. If no
|
||||
-- Sloc is available (happens e.g. for nodes in package Standard),
|
||||
-- then the default case (see Scans spec) is used. The nodes to be
|
||||
-- used are stored in Error_Msg_Node_1, Error_Msg_Node_2. No insertion
|
||||
-- occurs for the Empty node, and the Error node results in the
|
||||
-- insertion of the characters <error>. In addition, if the special
|
||||
-- global variable Error_Msg_Qual_Level is non-zero, then the
|
||||
-- reference will include up to the given number of levels of
|
||||
-- qualification, using the scope chain.
|
||||
|
||||
-- Insertion character # (Pound: insert line number reference)
|
||||
-- The character # is replaced by the string indicating the source
|
||||
-- position stored in Error_Msg_Sloc. There are three cases:
|
||||
--
|
||||
-- for package Standard: in package Standard
|
||||
-- for locations in current file: at line nnn:ccc
|
||||
-- for locations in other files: at filename:nnn:ccc
|
||||
--
|
||||
-- By convention, the # insertion character is only used at the end
|
||||
-- of an error message, so the above strings only appear as the last
|
||||
-- characters of an error message.
|
||||
|
||||
-- Insertion character } (Right brace: insert type reference)
|
||||
-- The character } is replaced by a string describing the type
|
||||
-- referenced by the entity whose Id is stored in Error_Msg_Node_1.
|
||||
-- the string gives the name or description of the type, and also
|
||||
-- where appropriate the location of its declaration. Special
|
||||
-- cases like "some integer type" are handled appropriately. Only
|
||||
-- one } is allowed in a message, since there is not enough room
|
||||
-- for two (the insertion can be quite long, including a file name)
|
||||
-- In addition, if the special global variable Error_Msg_Qual_Level
|
||||
-- is non-zero, then the reference will include up to the given
|
||||
-- number of levels of qualification, using the scope chain.
|
||||
|
||||
-- Insertion character @ (At: insert column number reference)
|
||||
-- The character @ is replaced by null if the RM_Column_Check mode is
|
||||
-- off (False). If the switch is on (True), then @ is replaced by the
|
||||
-- text string " in column nnn" where nnn is the decimal representation
|
||||
-- of the column number stored in Error_Msg_Col plus one (the plus one
|
||||
-- is because the number is stored 0-origin and displayed 1-origin).
|
||||
|
||||
-- Insertion character ^ (Carret: insert integer value)
|
||||
-- The character ^ is replaced by the decimal conversion of the Uint
|
||||
-- value stored in Error_Msg_Uint_1, with a possible leading minus.
|
||||
-- A second ^ may occur in the message, in which case it is replaced
|
||||
-- by the decimal conversion of the Uint value in Error_Msg_Uint_2.
|
||||
|
||||
-- Insertion character ! (Exclamation: unconditional message)
|
||||
-- The character ! appearing as the last character of a message makes
|
||||
-- the message unconditional which means that it is output even if it
|
||||
-- would normally be suppressed. See section above for a description
|
||||
-- of the cases in which messages are normally suppressed.
|
||||
|
||||
-- Insertion character ? (Question: warning message)
|
||||
-- The character ? appearing anywhere in a message makes the message
|
||||
-- a warning instead of a normal error message, and the text of the
|
||||
-- message will be preceded by "Warning:" instead of "Error:" The
|
||||
-- handling of warnings if further controlled by the Warning_Mode
|
||||
-- option (-w switch), see package Opt for further details, and
|
||||
-- also by the current setting from pragma Warnings. This pragma
|
||||
-- applies only to warnings issued from the semantic phase (not
|
||||
-- the parser), but currently all relevant warnings are posted
|
||||
-- by the semantic phase anyway. Messages starting with (style)
|
||||
-- are also treated as warning messages.
|
||||
|
||||
-- Insertion character A-Z (Upper case letter: Ada reserved word)
|
||||
-- If two or more upper case letters appear in the message, they are
|
||||
-- taken as an Ada reserved word, and are converted to the default
|
||||
-- case for reserved words (see Scans package spec). Surrounding
|
||||
-- quotes are added unless manual quotation mode is currently set.
|
||||
|
||||
-- Insertion character ` (Backquote: set manual quotation mode)
|
||||
-- The backquote character always appears in pairs. Each backquote
|
||||
-- of the pair is replaced by a double quote character. In addition,
|
||||
-- Any reserved keywords, or name insertions between these backquotes
|
||||
-- are not surrounded by the usual automatic double quotes. See the
|
||||
-- section below on manual quotation mode for further details.
|
||||
|
||||
-- Insertion character ' (Quote: literal character)
|
||||
-- Precedes a character which is placed literally into the message.
|
||||
-- Used to insert characters into messages that are one of the
|
||||
-- insertion characters defined here.
|
||||
|
||||
-- Insertion character \ (Backslash: continuation message)
|
||||
-- Indicates that the message is a continuation of a message
|
||||
-- previously posted. This is used to ensure that such groups
|
||||
-- of messages are treated as a unit. The \ character must be
|
||||
-- the first character of the message text.
|
||||
|
||||
-----------------------------------------------------
|
||||
-- Global Values Used for Error Message Insertions --
|
||||
-----------------------------------------------------
|
||||
|
||||
-- The following global variables are essentially additional parameters
|
||||
-- passed to the error message routine for insertion sequences described
|
||||
-- above. The reason these are passed globally is that the insertion
|
||||
-- mechanism is essentially an untyped one in which the appropriate
|
||||
-- variables are set dependingon the specific insertion characters used.
|
||||
|
||||
Error_Msg_Col : Column_Number;
|
||||
-- Column for @ insertion character in message
|
||||
|
||||
Error_Msg_Uint_1 : Uint;
|
||||
Error_Msg_Uint_2 : Uint;
|
||||
-- Uint values for ^ insertion characters in message
|
||||
|
||||
Error_Msg_Sloc : Source_Ptr;
|
||||
-- Source location for # insertion character in message
|
||||
|
||||
Error_Msg_Name_1 : Name_Id;
|
||||
Error_Msg_Name_2 : Name_Id;
|
||||
Error_Msg_Name_3 : Name_Id;
|
||||
-- Name_Id values for % insertion characters in message
|
||||
|
||||
Error_Msg_Unit_1 : Name_Id;
|
||||
Error_Msg_Unit_2 : Name_Id;
|
||||
-- Name_Id values for $ insertion characters in message
|
||||
|
||||
Error_Msg_Node_1 : Node_Id;
|
||||
Error_Msg_Node_2 : Node_Id;
|
||||
-- Node_Id values for & insertion characters in message
|
||||
|
||||
Error_Msg_Qual_Level : Int := 0;
|
||||
-- Number of levels of qualification required for type name (see the
|
||||
-- description of the } insertion character. Note that this value does
|
||||
-- note get reset by any Error_Msg call, so the caller is responsible
|
||||
-- for resetting it.
|
||||
|
||||
Warn_On_Instance : Boolean := False;
|
||||
-- Normally if a warning is generated in a generic template from the
|
||||
-- analysis of the template, then the warning really belongs in the
|
||||
-- template, and the default value of False for this Boolean achieves
|
||||
-- that effect. If Warn_On_Instance is set True, then the warnings are
|
||||
-- generated on the instantiation (referring to the template) rather
|
||||
-- than on the template itself.
|
||||
|
||||
-----------------------------------------------------
|
||||
-- Format of Messages and Manual Quotation Control --
|
||||
-----------------------------------------------------
|
||||
|
||||
-- Messages are generally all in lower case, except for inserted names
|
||||
-- and appear in one of the following three forms:
|
||||
|
||||
-- error: text
|
||||
-- warning: text
|
||||
|
||||
-- The prefixes error and warning are supplied automatically (depending
|
||||
-- on the use of the ? insertion character), and the call to the error
|
||||
-- message routine supplies the text. The "error: " prefix is omitted
|
||||
-- in brief error message formats.
|
||||
|
||||
-- Reserved Ada keywords in the message are in the default keyword case
|
||||
-- (determined from the given source program), surrounded by quotation
|
||||
-- marks. This is achieved by spelling the reserved word in upper case
|
||||
-- letters, which is recognized as a request for insertion of quotation
|
||||
-- marks by the error text processor. Thus for example:
|
||||
|
||||
-- Error_Msg_AP ("IS expected");
|
||||
|
||||
-- would result in the output of one of the following:
|
||||
|
||||
-- error: "is" expected
|
||||
-- error: "IS" expected
|
||||
-- error: "Is" expected
|
||||
|
||||
-- the choice between these being made by looking at the casing convention
|
||||
-- used for keywords (actually the first compilation unit keyword) in the
|
||||
-- source file.
|
||||
|
||||
-- In the case of names, the default mode for the error text processor
|
||||
-- is to surround the name by quotation marks automatically. The case
|
||||
-- used for the identifier names is taken from the source program where
|
||||
-- possible, and otherwise is the default casing convention taken from
|
||||
-- the source file usage.
|
||||
|
||||
-- In some cases, better control over the placement of quote marks is
|
||||
-- required. This is achieved using manual quotation mode. In this mode,
|
||||
-- one or more insertion sequences is surrounded by backquote characters.
|
||||
-- The backquote characters are output as double quote marks, and normal
|
||||
-- automatic insertion of quotes is suppressed between the double quotes.
|
||||
-- For example:
|
||||
|
||||
-- Error_Msg_AP ("`END &;` expected");
|
||||
|
||||
-- generates a message like
|
||||
|
||||
-- error: "end Open_Scope;" expected
|
||||
|
||||
-- where the node specifying the name Open_Scope has been stored in
|
||||
-- Error_Msg_Node_1 prior to the call. The great majority of error
|
||||
-- messages operates in normal quotation mode.
|
||||
|
||||
-- Note: the normal automatic insertion of spaces before insertion
|
||||
-- sequences (such as those that come from & and %) is suppressed in
|
||||
-- manual quotation mode, so blanks, if needed as in the above example,
|
||||
-- must be explicitly present.
|
||||
|
||||
----------------------------
|
||||
-- Message ID Definitions --
|
||||
----------------------------
|
||||
|
||||
type Error_Msg_Id is new Int;
|
||||
-- A type used to represent specific error messages. Used by the clients
|
||||
-- of this package only in the context of the Get_Error_Id and
|
||||
-- Change_Error_Text subprograms.
|
||||
|
||||
No_Error_Msg : constant Error_Msg_Id := 0;
|
||||
-- A constant which is different from any value returned by Get_Error_Id.
|
||||
-- Typically used by a client to indicate absense of a saved Id value.
|
||||
|
||||
function Get_Msg_Id return Error_Msg_Id;
|
||||
-- Returns the Id of the message most recently posted using one of the
|
||||
-- Error_Msg routines.
|
||||
|
||||
function Get_Location (E : Error_Msg_Id) return Source_Ptr;
|
||||
-- Returns the flag location of the error message with the given id E.
|
||||
|
||||
------------------------
|
||||
-- List Pragmas Table --
|
||||
------------------------
|
||||
|
||||
-- When a pragma Page or pragma List is encountered by the parser, an
|
||||
-- entry is made in the following table. This table is then used to
|
||||
-- control the full listing if one is being generated. Note that the
|
||||
-- reason we do the processing in the parser is so that we get proper
|
||||
-- listing control even in syntax check only mode.
|
||||
|
||||
type List_Pragma_Type is (List_On, List_Off, Page);
|
||||
|
||||
type List_Pragma_Record is record
|
||||
Ptyp : List_Pragma_Type;
|
||||
Ploc : Source_Ptr;
|
||||
end record;
|
||||
|
||||
-- Note: Ploc points to the terminating semicolon in the List_Off and
|
||||
-- Page cases, and to the pragma keyword for List_On. In the case of
|
||||
-- a pragma List_Off, a List_On entry is also made in the table,
|
||||
-- pointing to the pragma keyword. This ensures that, as required,
|
||||
-- a List (Off) pragma is listed even in list off mode.
|
||||
|
||||
package List_Pragmas is new Table.Table (
|
||||
Table_Component_Type => List_Pragma_Record,
|
||||
Table_Index_Type => Int,
|
||||
Table_Low_Bound => 1,
|
||||
Table_Initial => 50,
|
||||
Table_Increment => 200,
|
||||
Table_Name => "List_Pragmas");
|
||||
|
||||
---------------------------
|
||||
-- Ignore_Errors Feature --
|
||||
---------------------------
|
||||
|
||||
-- In certain cases, notably for optional subunits, the compiler operates
|
||||
-- in a mode where errors are to be ignored, and the whole unit is to be
|
||||
-- considered as not present. To implement this we provide the following
|
||||
-- flag to enable special handling, where error messages are suppressed,
|
||||
-- but the Fatal_Error flag will still be set in the normal manner.
|
||||
|
||||
Ignore_Errors_Enable : Nat := 0;
|
||||
-- Triggering switch. If non-zero, then ignore errors mode is activated.
|
||||
-- This is a counter to allow convenient nesting of enable/disable.
|
||||
|
||||
------------------------------
|
||||
-- Error Output Subprograms --
|
||||
------------------------------
|
||||
|
||||
procedure Initialize;
|
||||
-- Initializes for output of error messages. Must be called for each
|
||||
-- source file before using any of the other routines in the package.
|
||||
|
||||
procedure Finalize;
|
||||
-- Finalize processing of error messages for one file and output message
|
||||
-- indicating the number of detected errors.
|
||||
|
||||
procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr);
|
||||
-- Output a message at specified location. Can be called from the parser
|
||||
-- or the semantic analyzer.
|
||||
|
||||
procedure Error_Msg_S (Msg : String);
|
||||
-- Output a message at current scan pointer location. This routine can be
|
||||
-- called only from the parser, since it references Scan_Ptr.
|
||||
|
||||
procedure Error_Msg_AP (Msg : String);
|
||||
-- Output a message just after the previous token. This routine can be
|
||||
-- called only from the parser, since it references Prev_Token_Ptr.
|
||||
|
||||
procedure Error_Msg_BC (Msg : String);
|
||||
-- Output a message just before the current token. Note that the important
|
||||
-- difference between this and the previous routine is that the BC case
|
||||
-- posts a flag on the current line, whereas AP can post a flag at the
|
||||
-- end of the preceding line. This routine can be called only from the
|
||||
-- parser, since it references Token_Ptr.
|
||||
|
||||
procedure Error_Msg_SC (Msg : String);
|
||||
-- Output a message at the start of the current token, unless we are at
|
||||
-- the end of file, in which case we always output the message after the
|
||||
-- last real token in the file. This routine can be called only from the
|
||||
-- parser, since it references Token_Ptr.
|
||||
|
||||
procedure Error_Msg_SP (Msg : String);
|
||||
-- Output a message at the start of the previous token. This routine can
|
||||
-- be called only from the parser, since it references Prev_Token_Ptr.
|
||||
|
||||
procedure Error_Msg_N (Msg : String; N : Node_Or_Entity_Id);
|
||||
-- Output a message at the Sloc of the given node. This routine can be
|
||||
-- called from the parser or the semantic analyzer, although the call
|
||||
-- from the latter is much more common (and is the most usual way of
|
||||
-- generating error messages from the analyzer). The message text may
|
||||
-- contain a single & insertion, which will reference the given node.
|
||||
|
||||
procedure Error_Msg_NE
|
||||
(Msg : String;
|
||||
N : Node_Or_Entity_Id;
|
||||
E : Node_Or_Entity_Id);
|
||||
-- Output a message at the Sloc of the given node, with an insertion of
|
||||
-- the name from the given entity node. This is used by the semantic
|
||||
-- routines, where this is a common error message situation. The Msg
|
||||
-- text will contain a & or } as usual to mark the insertion point.
|
||||
-- This routine can be called from the parser or the analyzer.
|
||||
|
||||
procedure Change_Error_Text (Error_Id : Error_Msg_Id; New_Msg : String);
|
||||
-- The error message text of the message identified by Id is replaced by
|
||||
-- the given text. This text may contain insertion characters in the
|
||||
-- usual manner, and need not be the same length as the original text.
|
||||
|
||||
procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr);
|
||||
-- All error messages whose location is in the range From .. To (not
|
||||
-- including the end points) will be deleted from the error listing.
|
||||
|
||||
procedure Remove_Warning_Messages (N : Node_Id);
|
||||
-- Remove any warning messages corresponding to the Sloc of N or any
|
||||
-- of its descendent nodes. No effect if no such warnings.
|
||||
|
||||
procedure Set_Warnings_Mode_Off (Loc : Source_Ptr);
|
||||
-- Called in response to a pragma Warnings (Off) to record the source
|
||||
-- location from which warnings are to be turned off.
|
||||
|
||||
procedure Set_Warnings_Mode_On (Loc : Source_Ptr);
|
||||
-- Called in response to a pragma Warnings (On) to record the source
|
||||
-- location from which warnings are to be turned back on.
|
||||
|
||||
function Compilation_Errors return Boolean;
|
||||
-- Returns true if errors have been detected, or warnings in -gnatwe
|
||||
-- (treat warnings as errors) mode.
|
||||
|
||||
procedure dmsg (Id : Error_Msg_Id);
|
||||
-- Debugging routine to dump an error message
|
||||
|
||||
end Errout;
|
|
@ -0,0 +1,935 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- E V A L _ F A T --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.33 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Einfo; use Einfo;
|
||||
with Sem_Util; use Sem_Util;
|
||||
with Ttypef; use Ttypef;
|
||||
with Targparm; use Targparm;
|
||||
|
||||
package body Eval_Fat is
|
||||
|
||||
Radix : constant Int := 2;
|
||||
-- This code is currently only correct for the radix 2 case. We use
|
||||
-- the symbolic value Radix where possible to help in the unlikely
|
||||
-- case of anyone ever having to adjust this code for another value,
|
||||
-- and for documentation purposes.
|
||||
|
||||
type Radix_Power_Table is array (Int range 1 .. 4) of Int;
|
||||
|
||||
Radix_Powers : constant Radix_Power_Table
|
||||
:= (Radix**1, Radix**2, Radix**3, Radix**4);
|
||||
|
||||
function Float_Radix return T renames Ureal_2;
|
||||
-- Radix expressed in real form
|
||||
|
||||
-----------------------
|
||||
-- Local Subprograms --
|
||||
-----------------------
|
||||
|
||||
procedure Decompose
|
||||
(RT : R;
|
||||
X : in T;
|
||||
Fraction : out T;
|
||||
Exponent : out UI;
|
||||
Mode : Rounding_Mode := Round);
|
||||
-- Decomposes a non-zero floating-point number into fraction and
|
||||
-- exponent parts. The fraction is in the interval 1.0 / Radix ..
|
||||
-- T'Pred (1.0) and uses Rbase = Radix.
|
||||
-- The result is rounded to a nearest machine number.
|
||||
|
||||
procedure Decompose_Int
|
||||
(RT : R;
|
||||
X : in T;
|
||||
Fraction : out UI;
|
||||
Exponent : out UI;
|
||||
Mode : Rounding_Mode);
|
||||
-- This is similar to Decompose, except that the Fraction value returned
|
||||
-- is an integer representing the value Fraction * Scale, where Scale is
|
||||
-- the value (Radix ** Machine_Mantissa (RT)). The value is obtained by
|
||||
-- using biased rounding (halfway cases round away from zero), round to
|
||||
-- even, a floor operation or a ceiling operation depending on the setting
|
||||
-- of Mode (see corresponding descriptions in Urealp).
|
||||
-- In case rounding was specified, Rounding_Was_Biased is set True
|
||||
-- if the input was indeed halfway between to machine numbers and
|
||||
-- got rounded away from zero to an odd number.
|
||||
|
||||
function Eps_Model (RT : R) return T;
|
||||
-- Return the smallest model number of R.
|
||||
|
||||
function Eps_Denorm (RT : R) return T;
|
||||
-- Return the smallest denormal of type R.
|
||||
|
||||
function Machine_Mantissa (RT : R) return Nat;
|
||||
-- Get value of machine mantissa
|
||||
|
||||
--------------
|
||||
-- Adjacent --
|
||||
--------------
|
||||
|
||||
function Adjacent (RT : R; X, Towards : T) return T is
|
||||
begin
|
||||
if Towards = X then
|
||||
return X;
|
||||
|
||||
elsif Towards > X then
|
||||
return Succ (RT, X);
|
||||
|
||||
else
|
||||
return Pred (RT, X);
|
||||
end if;
|
||||
end Adjacent;
|
||||
|
||||
-------------
|
||||
-- Ceiling --
|
||||
-------------
|
||||
|
||||
function Ceiling (RT : R; X : T) return T is
|
||||
XT : constant T := Truncation (RT, X);
|
||||
|
||||
begin
|
||||
if UR_Is_Negative (X) then
|
||||
return XT;
|
||||
|
||||
elsif X = XT then
|
||||
return X;
|
||||
|
||||
else
|
||||
return XT + Ureal_1;
|
||||
end if;
|
||||
end Ceiling;
|
||||
|
||||
-------------
|
||||
-- Compose --
|
||||
-------------
|
||||
|
||||
function Compose (RT : R; Fraction : T; Exponent : UI) return T is
|
||||
Arg_Frac : T;
|
||||
Arg_Exp : UI;
|
||||
|
||||
begin
|
||||
if UR_Is_Zero (Fraction) then
|
||||
return Fraction;
|
||||
else
|
||||
Decompose (RT, Fraction, Arg_Frac, Arg_Exp);
|
||||
return Scaling (RT, Arg_Frac, Exponent);
|
||||
end if;
|
||||
end Compose;
|
||||
|
||||
---------------
|
||||
-- Copy_Sign --
|
||||
---------------
|
||||
|
||||
function Copy_Sign (RT : R; Value, Sign : T) return T is
|
||||
Result : T;
|
||||
|
||||
begin
|
||||
Result := abs Value;
|
||||
|
||||
if UR_Is_Negative (Sign) then
|
||||
return -Result;
|
||||
else
|
||||
return Result;
|
||||
end if;
|
||||
end Copy_Sign;
|
||||
|
||||
---------------
|
||||
-- Decompose --
|
||||
---------------
|
||||
|
||||
procedure Decompose
|
||||
(RT : R;
|
||||
X : in T;
|
||||
Fraction : out T;
|
||||
Exponent : out UI;
|
||||
Mode : Rounding_Mode := Round)
|
||||
is
|
||||
Int_F : UI;
|
||||
|
||||
begin
|
||||
Decompose_Int (RT, abs X, Int_F, Exponent, Mode);
|
||||
|
||||
Fraction := UR_From_Components
|
||||
(Num => Int_F,
|
||||
Den => UI_From_Int (Machine_Mantissa (RT)),
|
||||
Rbase => Radix,
|
||||
Negative => False);
|
||||
|
||||
if UR_Is_Negative (X) then
|
||||
Fraction := -Fraction;
|
||||
end if;
|
||||
|
||||
return;
|
||||
end Decompose;
|
||||
|
||||
-------------------
|
||||
-- Decompose_Int --
|
||||
-------------------
|
||||
|
||||
-- This procedure should be modified with care, as there
|
||||
-- are many non-obvious details that may cause problems
|
||||
-- that are hard to detect. The cases of positive and
|
||||
-- negative zeroes are also special and should be
|
||||
-- verified separately.
|
||||
|
||||
procedure Decompose_Int
|
||||
(RT : R;
|
||||
X : in T;
|
||||
Fraction : out UI;
|
||||
Exponent : out UI;
|
||||
Mode : Rounding_Mode)
|
||||
is
|
||||
Base : Int := Rbase (X);
|
||||
N : UI := abs Numerator (X);
|
||||
D : UI := Denominator (X);
|
||||
|
||||
N_Times_Radix : UI;
|
||||
|
||||
Even : Boolean;
|
||||
-- True iff Fraction is even
|
||||
|
||||
Most_Significant_Digit : constant UI :=
|
||||
Radix ** (Machine_Mantissa (RT) - 1);
|
||||
|
||||
Uintp_Mark : Uintp.Save_Mark;
|
||||
-- The code is divided into blocks that systematically release
|
||||
-- intermediate values (this routine generates lots of junk!)
|
||||
|
||||
begin
|
||||
Calculate_D_And_Exponent_1 : begin
|
||||
Uintp_Mark := Mark;
|
||||
Exponent := Uint_0;
|
||||
|
||||
-- In cases where Base > 1, the actual denominator is
|
||||
-- Base**D. For cases where Base is a power of Radix, use
|
||||
-- the value 1 for the Denominator and adjust the exponent.
|
||||
|
||||
-- Note: Exponent has different sign from D, because D is a divisor
|
||||
|
||||
for Power in 1 .. Radix_Powers'Last loop
|
||||
if Base = Radix_Powers (Power) then
|
||||
Exponent := -D * Power;
|
||||
Base := 0;
|
||||
D := Uint_1;
|
||||
exit;
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
Release_And_Save (Uintp_Mark, D, Exponent);
|
||||
end Calculate_D_And_Exponent_1;
|
||||
|
||||
if Base > 0 then
|
||||
Calculate_Exponent : begin
|
||||
Uintp_Mark := Mark;
|
||||
|
||||
-- For bases that are a multiple of the Radix, divide
|
||||
-- the base by Radix and adjust the Exponent. This will
|
||||
-- help because D will be much smaller and faster to process.
|
||||
|
||||
-- This occurs for decimal bases on a machine with binary
|
||||
-- floating-point for example. When calculating 1E40,
|
||||
-- with Radix = 2, N will be 93 bits instead of 133.
|
||||
|
||||
-- N E
|
||||
-- ------ * Radix
|
||||
-- D
|
||||
-- Base
|
||||
|
||||
-- N E
|
||||
-- = -------------------------- * Radix
|
||||
-- D D
|
||||
-- (Base/Radix) * Radix
|
||||
|
||||
-- N E-D
|
||||
-- = --------------- * Radix
|
||||
-- D
|
||||
-- (Base/Radix)
|
||||
|
||||
-- This code is commented out, because it causes numerous
|
||||
-- failures in the regression suite. To be studied ???
|
||||
|
||||
while False and then Base > 0 and then Base mod Radix = 0 loop
|
||||
Base := Base / Radix;
|
||||
Exponent := Exponent + D;
|
||||
end loop;
|
||||
|
||||
Release_And_Save (Uintp_Mark, Exponent);
|
||||
end Calculate_Exponent;
|
||||
|
||||
-- For remaining bases we must actually compute
|
||||
-- the exponentiation.
|
||||
|
||||
-- Because the exponentiation can be negative, and D must
|
||||
-- be integer, the numerator is corrected instead.
|
||||
|
||||
Calculate_N_And_D : begin
|
||||
Uintp_Mark := Mark;
|
||||
|
||||
if D < 0 then
|
||||
N := N * Base ** (-D);
|
||||
D := Uint_1;
|
||||
else
|
||||
D := Base ** D;
|
||||
end if;
|
||||
|
||||
Release_And_Save (Uintp_Mark, N, D);
|
||||
end Calculate_N_And_D;
|
||||
|
||||
Base := 0;
|
||||
end if;
|
||||
|
||||
-- Now scale N and D so that N / D is a value in the
|
||||
-- interval [1.0 / Radix, 1.0) and adjust Exponent accordingly,
|
||||
-- so the value N / D * Radix ** Exponent remains unchanged.
|
||||
|
||||
-- Step 1 - Adjust N so N / D >= 1 / Radix, or N = 0
|
||||
|
||||
-- N and D are positive, so N / D >= 1 / Radix implies N * Radix >= D.
|
||||
-- This scaling is not possible for N is Uint_0 as there
|
||||
-- is no way to scale Uint_0 so the first digit is non-zero.
|
||||
|
||||
Calculate_N_And_Exponent : begin
|
||||
Uintp_Mark := Mark;
|
||||
|
||||
N_Times_Radix := N * Radix;
|
||||
|
||||
if N /= Uint_0 then
|
||||
while not (N_Times_Radix >= D) loop
|
||||
N := N_Times_Radix;
|
||||
Exponent := Exponent - 1;
|
||||
|
||||
N_Times_Radix := N * Radix;
|
||||
end loop;
|
||||
end if;
|
||||
|
||||
Release_And_Save (Uintp_Mark, N, Exponent);
|
||||
end Calculate_N_And_Exponent;
|
||||
|
||||
-- Step 2 - Adjust D so N / D < 1
|
||||
|
||||
-- Scale up D so N / D < 1, so N < D
|
||||
|
||||
Calculate_D_And_Exponent_2 : begin
|
||||
Uintp_Mark := Mark;
|
||||
|
||||
while not (N < D) loop
|
||||
|
||||
-- As N / D >= 1, N / (D * Radix) will be at least 1 / Radix,
|
||||
-- so the result of Step 1 stays valid
|
||||
|
||||
D := D * Radix;
|
||||
Exponent := Exponent + 1;
|
||||
end loop;
|
||||
|
||||
Release_And_Save (Uintp_Mark, D, Exponent);
|
||||
end Calculate_D_And_Exponent_2;
|
||||
|
||||
-- Here the value N / D is in the range [1.0 / Radix .. 1.0)
|
||||
|
||||
-- Now find the fraction by doing a very simple-minded
|
||||
-- division until enough digits have been computed.
|
||||
|
||||
-- This division works for all radices, but is only efficient for
|
||||
-- a binary radix. It is just like a manual division algorithm,
|
||||
-- but instead of moving the denominator one digit right, we move
|
||||
-- the numerator one digit left so the numerator and denominator
|
||||
-- remain integral.
|
||||
|
||||
Fraction := Uint_0;
|
||||
Even := True;
|
||||
|
||||
Calculate_Fraction_And_N : begin
|
||||
Uintp_Mark := Mark;
|
||||
|
||||
loop
|
||||
while N >= D loop
|
||||
N := N - D;
|
||||
Fraction := Fraction + 1;
|
||||
Even := not Even;
|
||||
end loop;
|
||||
|
||||
-- Stop when the result is in [1.0 / Radix, 1.0)
|
||||
|
||||
exit when Fraction >= Most_Significant_Digit;
|
||||
|
||||
N := N * Radix;
|
||||
Fraction := Fraction * Radix;
|
||||
Even := True;
|
||||
end loop;
|
||||
|
||||
Release_And_Save (Uintp_Mark, Fraction, N);
|
||||
end Calculate_Fraction_And_N;
|
||||
|
||||
Calculate_Fraction_And_Exponent : begin
|
||||
Uintp_Mark := Mark;
|
||||
|
||||
-- Put back sign before applying the rounding.
|
||||
|
||||
if UR_Is_Negative (X) then
|
||||
Fraction := -Fraction;
|
||||
end if;
|
||||
|
||||
-- Determine correct rounding based on the remainder
|
||||
-- which is in N and the divisor D.
|
||||
|
||||
Rounding_Was_Biased := False; -- Until proven otherwise
|
||||
|
||||
case Mode is
|
||||
when Round_Even =>
|
||||
|
||||
-- This rounding mode should not be used for static
|
||||
-- expressions, but only for compile-time evaluation
|
||||
-- of non-static expressions.
|
||||
|
||||
if (Even and then N * 2 > D)
|
||||
or else
|
||||
(not Even and then N * 2 >= D)
|
||||
then
|
||||
Fraction := Fraction + 1;
|
||||
end if;
|
||||
|
||||
when Round =>
|
||||
|
||||
-- Do not round to even as is done with IEEE arithmetic,
|
||||
-- but instead round away from zero when the result is
|
||||
-- exactly between two machine numbers. See RM 4.9(38).
|
||||
|
||||
if N * 2 >= D then
|
||||
Fraction := Fraction + 1;
|
||||
|
||||
Rounding_Was_Biased := Even and then N * 2 = D;
|
||||
-- Check for the case where the result is actually
|
||||
-- different from Round_Even.
|
||||
end if;
|
||||
|
||||
when Ceiling =>
|
||||
if N > Uint_0 then
|
||||
Fraction := Fraction + 1;
|
||||
end if;
|
||||
|
||||
when Floor => null;
|
||||
end case;
|
||||
|
||||
-- The result must be normalized to [1.0/Radix, 1.0),
|
||||
-- so adjust if the result is 1.0 because of rounding.
|
||||
|
||||
if Fraction = Most_Significant_Digit * Radix then
|
||||
Fraction := Most_Significant_Digit;
|
||||
Exponent := Exponent + 1;
|
||||
end if;
|
||||
|
||||
Release_And_Save (Uintp_Mark, Fraction, Exponent);
|
||||
end Calculate_Fraction_And_Exponent;
|
||||
|
||||
end Decompose_Int;
|
||||
|
||||
----------------
|
||||
-- Eps_Denorm --
|
||||
----------------
|
||||
|
||||
function Eps_Denorm (RT : R) return T is
|
||||
Digs : constant UI := Digits_Value (RT);
|
||||
Emin : Int;
|
||||
Mant : Int;
|
||||
|
||||
begin
|
||||
if Vax_Float (RT) then
|
||||
if Digs = VAXFF_Digits then
|
||||
Emin := VAXFF_Machine_Emin;
|
||||
Mant := VAXFF_Machine_Mantissa;
|
||||
|
||||
elsif Digs = VAXDF_Digits then
|
||||
Emin := VAXDF_Machine_Emin;
|
||||
Mant := VAXDF_Machine_Mantissa;
|
||||
|
||||
else
|
||||
pragma Assert (Digs = VAXGF_Digits);
|
||||
Emin := VAXGF_Machine_Emin;
|
||||
Mant := VAXGF_Machine_Mantissa;
|
||||
end if;
|
||||
|
||||
elsif Is_AAMP_Float (RT) then
|
||||
if Digs = AAMPS_Digits then
|
||||
Emin := AAMPS_Machine_Emin;
|
||||
Mant := AAMPS_Machine_Mantissa;
|
||||
|
||||
else
|
||||
pragma Assert (Digs = AAMPL_Digits);
|
||||
Emin := AAMPL_Machine_Emin;
|
||||
Mant := AAMPL_Machine_Mantissa;
|
||||
end if;
|
||||
|
||||
else
|
||||
if Digs = IEEES_Digits then
|
||||
Emin := IEEES_Machine_Emin;
|
||||
Mant := IEEES_Machine_Mantissa;
|
||||
|
||||
elsif Digs = IEEEL_Digits then
|
||||
Emin := IEEEL_Machine_Emin;
|
||||
Mant := IEEEL_Machine_Mantissa;
|
||||
|
||||
else
|
||||
pragma Assert (Digs = IEEEX_Digits);
|
||||
Emin := IEEEX_Machine_Emin;
|
||||
Mant := IEEEX_Machine_Mantissa;
|
||||
end if;
|
||||
end if;
|
||||
|
||||
return Float_Radix ** UI_From_Int (Emin - Mant);
|
||||
end Eps_Denorm;
|
||||
|
||||
---------------
|
||||
-- Eps_Model --
|
||||
---------------
|
||||
|
||||
function Eps_Model (RT : R) return T is
|
||||
Digs : constant UI := Digits_Value (RT);
|
||||
Emin : Int;
|
||||
|
||||
begin
|
||||
if Vax_Float (RT) then
|
||||
if Digs = VAXFF_Digits then
|
||||
Emin := VAXFF_Machine_Emin;
|
||||
|
||||
elsif Digs = VAXDF_Digits then
|
||||
Emin := VAXDF_Machine_Emin;
|
||||
|
||||
else
|
||||
pragma Assert (Digs = VAXGF_Digits);
|
||||
Emin := VAXGF_Machine_Emin;
|
||||
end if;
|
||||
|
||||
elsif Is_AAMP_Float (RT) then
|
||||
if Digs = AAMPS_Digits then
|
||||
Emin := AAMPS_Machine_Emin;
|
||||
|
||||
else
|
||||
pragma Assert (Digs = AAMPL_Digits);
|
||||
Emin := AAMPL_Machine_Emin;
|
||||
end if;
|
||||
|
||||
else
|
||||
if Digs = IEEES_Digits then
|
||||
Emin := IEEES_Machine_Emin;
|
||||
|
||||
elsif Digs = IEEEL_Digits then
|
||||
Emin := IEEEL_Machine_Emin;
|
||||
|
||||
else
|
||||
pragma Assert (Digs = IEEEX_Digits);
|
||||
Emin := IEEEX_Machine_Emin;
|
||||
end if;
|
||||
end if;
|
||||
|
||||
return Float_Radix ** UI_From_Int (Emin);
|
||||
end Eps_Model;
|
||||
|
||||
--------------
|
||||
-- Exponent --
|
||||
--------------
|
||||
|
||||
function Exponent (RT : R; X : T) return UI is
|
||||
X_Frac : UI;
|
||||
X_Exp : UI;
|
||||
|
||||
begin
|
||||
if UR_Is_Zero (X) then
|
||||
return Uint_0;
|
||||
else
|
||||
Decompose_Int (RT, X, X_Frac, X_Exp, Round_Even);
|
||||
return X_Exp;
|
||||
end if;
|
||||
end Exponent;
|
||||
|
||||
-----------
|
||||
-- Floor --
|
||||
-----------
|
||||
|
||||
function Floor (RT : R; X : T) return T is
|
||||
XT : constant T := Truncation (RT, X);
|
||||
|
||||
begin
|
||||
if UR_Is_Positive (X) then
|
||||
return XT;
|
||||
|
||||
elsif XT = X then
|
||||
return X;
|
||||
|
||||
else
|
||||
return XT - Ureal_1;
|
||||
end if;
|
||||
end Floor;
|
||||
|
||||
--------------
|
||||
-- Fraction --
|
||||
--------------
|
||||
|
||||
function Fraction (RT : R; X : T) return T is
|
||||
X_Frac : T;
|
||||
X_Exp : UI;
|
||||
|
||||
begin
|
||||
if UR_Is_Zero (X) then
|
||||
return X;
|
||||
else
|
||||
Decompose (RT, X, X_Frac, X_Exp);
|
||||
return X_Frac;
|
||||
end if;
|
||||
end Fraction;
|
||||
|
||||
------------------
|
||||
-- Leading_Part --
|
||||
------------------
|
||||
|
||||
function Leading_Part (RT : R; X : T; Radix_Digits : UI) return T is
|
||||
L : UI;
|
||||
Y, Z : T;
|
||||
|
||||
begin
|
||||
if Radix_Digits >= Machine_Mantissa (RT) then
|
||||
return X;
|
||||
|
||||
else
|
||||
L := Exponent (RT, X) - Radix_Digits;
|
||||
Y := Truncation (RT, Scaling (RT, X, -L));
|
||||
Z := Scaling (RT, Y, L);
|
||||
return Z;
|
||||
end if;
|
||||
|
||||
end Leading_Part;
|
||||
|
||||
-------------
|
||||
-- Machine --
|
||||
-------------
|
||||
|
||||
function Machine (RT : R; X : T; Mode : Rounding_Mode) return T is
|
||||
X_Frac : T;
|
||||
X_Exp : UI;
|
||||
|
||||
begin
|
||||
if UR_Is_Zero (X) then
|
||||
return X;
|
||||
else
|
||||
Decompose (RT, X, X_Frac, X_Exp, Mode);
|
||||
return Scaling (RT, X_Frac, X_Exp);
|
||||
end if;
|
||||
end Machine;
|
||||
|
||||
----------------------
|
||||
-- Machine_Mantissa --
|
||||
----------------------
|
||||
|
||||
function Machine_Mantissa (RT : R) return Nat is
|
||||
Digs : constant UI := Digits_Value (RT);
|
||||
Mant : Nat;
|
||||
|
||||
begin
|
||||
if Vax_Float (RT) then
|
||||
if Digs = VAXFF_Digits then
|
||||
Mant := VAXFF_Machine_Mantissa;
|
||||
|
||||
elsif Digs = VAXDF_Digits then
|
||||
Mant := VAXDF_Machine_Mantissa;
|
||||
|
||||
else
|
||||
pragma Assert (Digs = VAXGF_Digits);
|
||||
Mant := VAXGF_Machine_Mantissa;
|
||||
end if;
|
||||
|
||||
elsif Is_AAMP_Float (RT) then
|
||||
if Digs = AAMPS_Digits then
|
||||
Mant := AAMPS_Machine_Mantissa;
|
||||
|
||||
else
|
||||
pragma Assert (Digs = AAMPL_Digits);
|
||||
Mant := AAMPL_Machine_Mantissa;
|
||||
end if;
|
||||
|
||||
else
|
||||
if Digs = IEEES_Digits then
|
||||
Mant := IEEES_Machine_Mantissa;
|
||||
|
||||
elsif Digs = IEEEL_Digits then
|
||||
Mant := IEEEL_Machine_Mantissa;
|
||||
|
||||
else
|
||||
pragma Assert (Digs = IEEEX_Digits);
|
||||
Mant := IEEEX_Machine_Mantissa;
|
||||
end if;
|
||||
end if;
|
||||
|
||||
return Mant;
|
||||
end Machine_Mantissa;
|
||||
|
||||
-----------
|
||||
-- Model --
|
||||
-----------
|
||||
|
||||
function Model (RT : R; X : T) return T is
|
||||
X_Frac : T;
|
||||
X_Exp : UI;
|
||||
|
||||
begin
|
||||
Decompose (RT, X, X_Frac, X_Exp);
|
||||
return Compose (RT, X_Frac, X_Exp);
|
||||
end Model;
|
||||
|
||||
----------
|
||||
-- Pred --
|
||||
----------
|
||||
|
||||
function Pred (RT : R; X : T) return T is
|
||||
Result_F : UI;
|
||||
Result_X : UI;
|
||||
|
||||
begin
|
||||
if abs X < Eps_Model (RT) then
|
||||
if Denorm_On_Target then
|
||||
return X - Eps_Denorm (RT);
|
||||
|
||||
elsif X > Ureal_0 then
|
||||
-- Target does not support denorms, so predecessor is 0.0
|
||||
return Ureal_0;
|
||||
|
||||
else
|
||||
-- Target does not support denorms, and X is 0.0
|
||||
-- or at least bigger than -Eps_Model (RT)
|
||||
|
||||
return -Eps_Model (RT);
|
||||
end if;
|
||||
|
||||
else
|
||||
Decompose_Int (RT, X, Result_F, Result_X, Ceiling);
|
||||
return UR_From_Components
|
||||
(Num => Result_F - 1,
|
||||
Den => Machine_Mantissa (RT) - Result_X,
|
||||
Rbase => Radix,
|
||||
Negative => False);
|
||||
-- Result_F may be false, but this is OK as UR_From_Components
|
||||
-- handles that situation.
|
||||
end if;
|
||||
end Pred;
|
||||
|
||||
---------------
|
||||
-- Remainder --
|
||||
---------------
|
||||
|
||||
function Remainder (RT : R; X, Y : T) return T is
|
||||
A : T;
|
||||
B : T;
|
||||
Arg : T;
|
||||
P : T;
|
||||
Arg_Frac : T;
|
||||
P_Frac : T;
|
||||
Sign_X : T;
|
||||
IEEE_Rem : T;
|
||||
Arg_Exp : UI;
|
||||
P_Exp : UI;
|
||||
K : UI;
|
||||
P_Even : Boolean;
|
||||
|
||||
begin
|
||||
if UR_Is_Positive (X) then
|
||||
Sign_X := Ureal_1;
|
||||
else
|
||||
Sign_X := -Ureal_1;
|
||||
end if;
|
||||
|
||||
Arg := abs X;
|
||||
P := abs Y;
|
||||
|
||||
if Arg < P then
|
||||
P_Even := True;
|
||||
IEEE_Rem := Arg;
|
||||
P_Exp := Exponent (RT, P);
|
||||
|
||||
else
|
||||
-- ??? what about zero cases?
|
||||
Decompose (RT, Arg, Arg_Frac, Arg_Exp);
|
||||
Decompose (RT, P, P_Frac, P_Exp);
|
||||
|
||||
P := Compose (RT, P_Frac, Arg_Exp);
|
||||
K := Arg_Exp - P_Exp;
|
||||
P_Even := True;
|
||||
IEEE_Rem := Arg;
|
||||
|
||||
for Cnt in reverse 0 .. UI_To_Int (K) loop
|
||||
if IEEE_Rem >= P then
|
||||
P_Even := False;
|
||||
IEEE_Rem := IEEE_Rem - P;
|
||||
else
|
||||
P_Even := True;
|
||||
end if;
|
||||
|
||||
P := P * Ureal_Half;
|
||||
end loop;
|
||||
end if;
|
||||
|
||||
-- That completes the calculation of modulus remainder. The final step
|
||||
-- is get the IEEE remainder. Here we compare Rem with (abs Y) / 2.
|
||||
|
||||
if P_Exp >= 0 then
|
||||
A := IEEE_Rem;
|
||||
B := abs Y * Ureal_Half;
|
||||
|
||||
else
|
||||
A := IEEE_Rem * Ureal_2;
|
||||
B := abs Y;
|
||||
end if;
|
||||
|
||||
if A > B or else (A = B and then not P_Even) then
|
||||
IEEE_Rem := IEEE_Rem - abs Y;
|
||||
end if;
|
||||
|
||||
return Sign_X * IEEE_Rem;
|
||||
|
||||
end Remainder;
|
||||
|
||||
--------------
|
||||
-- Rounding --
|
||||
--------------
|
||||
|
||||
function Rounding (RT : R; X : T) return T is
|
||||
Result : T;
|
||||
Tail : T;
|
||||
|
||||
begin
|
||||
Result := Truncation (RT, abs X);
|
||||
Tail := abs X - Result;
|
||||
|
||||
if Tail >= Ureal_Half then
|
||||
Result := Result + Ureal_1;
|
||||
end if;
|
||||
|
||||
if UR_Is_Negative (X) then
|
||||
return -Result;
|
||||
else
|
||||
return Result;
|
||||
end if;
|
||||
|
||||
end Rounding;
|
||||
|
||||
-------------
|
||||
-- Scaling --
|
||||
-------------
|
||||
|
||||
function Scaling (RT : R; X : T; Adjustment : UI) return T is
|
||||
begin
|
||||
if Rbase (X) = Radix then
|
||||
return UR_From_Components
|
||||
(Num => Numerator (X),
|
||||
Den => Denominator (X) - Adjustment,
|
||||
Rbase => Radix,
|
||||
Negative => UR_Is_Negative (X));
|
||||
|
||||
elsif Adjustment >= 0 then
|
||||
return X * Radix ** Adjustment;
|
||||
else
|
||||
return X / Radix ** (-Adjustment);
|
||||
end if;
|
||||
end Scaling;
|
||||
|
||||
----------
|
||||
-- Succ --
|
||||
----------
|
||||
|
||||
function Succ (RT : R; X : T) return T is
|
||||
Result_F : UI;
|
||||
Result_X : UI;
|
||||
|
||||
begin
|
||||
if abs X < Eps_Model (RT) then
|
||||
if Denorm_On_Target then
|
||||
return X + Eps_Denorm (RT);
|
||||
|
||||
elsif X < Ureal_0 then
|
||||
-- Target does not support denorms, so successor is 0.0
|
||||
return Ureal_0;
|
||||
|
||||
else
|
||||
-- Target does not support denorms, and X is 0.0
|
||||
-- or at least smaller than Eps_Model (RT)
|
||||
|
||||
return Eps_Model (RT);
|
||||
end if;
|
||||
|
||||
else
|
||||
Decompose_Int (RT, X, Result_F, Result_X, Floor);
|
||||
return UR_From_Components
|
||||
(Num => Result_F + 1,
|
||||
Den => Machine_Mantissa (RT) - Result_X,
|
||||
Rbase => Radix,
|
||||
Negative => False);
|
||||
-- Result_F may be false, but this is OK as UR_From_Components
|
||||
-- handles that situation.
|
||||
end if;
|
||||
end Succ;
|
||||
|
||||
----------------
|
||||
-- Truncation --
|
||||
----------------
|
||||
|
||||
function Truncation (RT : R; X : T) return T is
|
||||
begin
|
||||
return UR_From_Uint (UR_Trunc (X));
|
||||
end Truncation;
|
||||
|
||||
-----------------------
|
||||
-- Unbiased_Rounding --
|
||||
-----------------------
|
||||
|
||||
function Unbiased_Rounding (RT : R; X : T) return T is
|
||||
Abs_X : constant T := abs X;
|
||||
Result : T;
|
||||
Tail : T;
|
||||
|
||||
begin
|
||||
Result := Truncation (RT, Abs_X);
|
||||
Tail := Abs_X - Result;
|
||||
|
||||
if Tail > Ureal_Half then
|
||||
Result := Result + Ureal_1;
|
||||
|
||||
elsif Tail = Ureal_Half then
|
||||
Result := Ureal_2 *
|
||||
Truncation (RT, (Result / Ureal_2) + Ureal_Half);
|
||||
end if;
|
||||
|
||||
if UR_Is_Negative (X) then
|
||||
return -Result;
|
||||
elsif UR_Is_Positive (X) then
|
||||
return Result;
|
||||
|
||||
-- For zero case, make sure sign of zero is preserved
|
||||
|
||||
else
|
||||
return X;
|
||||
end if;
|
||||
|
||||
end Unbiased_Rounding;
|
||||
|
||||
end Eval_Fat;
|
|
@ -0,0 +1,91 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- E V A L _ F A T --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.4 $ --
|
||||
-- --
|
||||
-- Copyright (C) 1992-2000 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This package provides for compile-time evaluation of static calls to the
|
||||
-- floating-point attribute functions. It is the compile-time equivalent of
|
||||
-- the System.Fat_Gen runtime package. The coding is quite similar, as are
|
||||
-- the subprogram specs, except that the type is passed as an explicit
|
||||
-- first parameter (and used via ttypes, to obtain the necessary information
|
||||
-- about the characteristics of the type for computing the results.
|
||||
|
||||
with Types; use Types;
|
||||
with Uintp; use Uintp;
|
||||
with Urealp; use Urealp;
|
||||
|
||||
package Eval_Fat is
|
||||
|
||||
subtype UI is Uint;
|
||||
-- The compile time representation of universal integer
|
||||
|
||||
subtype T is Ureal;
|
||||
-- The compile time representation of floating-point values
|
||||
|
||||
subtype R is Entity_Id;
|
||||
-- The compile time representation of the floating-point root type
|
||||
|
||||
type Rounding_Mode is (Floor, Ceiling, Round, Round_Even);
|
||||
-- Used to indicate rounding mode for Machine attribute
|
||||
|
||||
Rounding_Was_Biased : Boolean;
|
||||
-- Set if last use of Machine rounded a halfway case away from zero
|
||||
|
||||
function Adjacent (RT : R; X, Towards : T) return T;
|
||||
|
||||
function Ceiling (RT : R; X : T) return T;
|
||||
|
||||
function Compose (RT : R; Fraction : T; Exponent : UI) return T;
|
||||
|
||||
function Copy_Sign (RT : R; Value, Sign : T) return T;
|
||||
|
||||
function Exponent (RT : R; X : T) return UI;
|
||||
|
||||
function Floor (RT : R; X : T) return T;
|
||||
|
||||
function Fraction (RT : R; X : T) return T;
|
||||
|
||||
function Leading_Part (RT : R; X : T; Radix_Digits : UI) return T;
|
||||
|
||||
function Machine (RT : R; X : T; Mode : Rounding_Mode) return T;
|
||||
|
||||
function Model (RT : R; X : T) return T;
|
||||
|
||||
function Pred (RT : R; X : T) return T;
|
||||
|
||||
function Remainder (RT : R; X, Y : T) return T;
|
||||
|
||||
function Rounding (RT : R; X : T) return T;
|
||||
|
||||
function Scaling (RT : R; X : T; Adjustment : UI) return T;
|
||||
|
||||
function Succ (RT : R; X : T) return T;
|
||||
|
||||
function Truncation (RT : R; X : T) return T;
|
||||
|
||||
function Unbiased_Rounding (RT : R; X : T) return T;
|
||||
|
||||
end Eval_Fat;
|
|
@ -0,0 +1,59 @@
|
|||
/****************************************************************************
|
||||
* *
|
||||
* GNAT COMPILER COMPONENTS *
|
||||
* *
|
||||
* E X I T *
|
||||
* *
|
||||
* C Implementation File *
|
||||
* *
|
||||
* $Revision: 1.1 $
|
||||
* *
|
||||
* Copyright (C) 1992-2001 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- *
|
||||
* 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. *
|
||||
* *
|
||||
* As a special exception, if you link this file with other files to *
|
||||
* produce an executable, this file does not by itself cause the resulting *
|
||||
* executable to be covered by the GNU General Public License. This except- *
|
||||
* ion does not however invalidate any other reasons why the executable *
|
||||
* file might be covered by the GNU Public License. *
|
||||
* *
|
||||
* GNAT was originally developed by the GNAT team at New York University. *
|
||||
* It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). *
|
||||
* *
|
||||
****************************************************************************/
|
||||
|
||||
#ifdef __alpha_vxworks
|
||||
#include "vxWorks.h"
|
||||
#endif
|
||||
|
||||
#ifdef IN_RTS
|
||||
#include "tconfig.h"
|
||||
#include "tsystem.h"
|
||||
#include <sys/stat.h>
|
||||
#else
|
||||
#include "config.h"
|
||||
#include "system.h"
|
||||
#endif
|
||||
|
||||
#include "adaint.h"
|
||||
|
||||
/* Routine used by Ada.Command_Line.Set_Exit_Status */
|
||||
|
||||
int gnat_exit_status = 0;
|
||||
|
||||
void
|
||||
__gnat_set_exit_status (i)
|
||||
int i;
|
||||
{
|
||||
gnat_exit_status = i;
|
||||
}
|
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,57 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- E X P _ A G G R --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.6 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-2000 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Types; use Types;
|
||||
|
||||
package Exp_Aggr is
|
||||
|
||||
procedure Expand_N_Aggregate (N : Node_Id);
|
||||
procedure Expand_N_Extension_Aggregate (N : Node_Id);
|
||||
|
||||
function Is_Delayed_Aggregate (N : Node_Id) return Boolean;
|
||||
-- returns True if N is a delayed aggregate of some kind
|
||||
|
||||
procedure Convert_Aggr_In_Object_Decl (N : Node_Id);
|
||||
-- N is a N_Object_Declaration with an expression which must be
|
||||
-- an N_Aggregate or N_Extension_Aggregate with Expansion_Delayed
|
||||
-- This procedure performs in-place aggregate assignment.
|
||||
|
||||
procedure Convert_Aggr_In_Allocator (Decl, Aggr : Node_Id);
|
||||
-- Decl is an access N_Object_Declaration (produced during
|
||||
-- allocator expansion), Aggr is the initial expression aggregate
|
||||
-- of an allocator. This procedure perform in-place aggregate
|
||||
-- assignent in the newly allocated object.
|
||||
|
||||
procedure Convert_Aggr_In_Assignment (N : Node_Id);
|
||||
-- Decl is an access N_Object_Declaration (produced during
|
||||
-- allocator expansion), Aggr is the initial expression aggregate
|
||||
-- of an allocator. This procedure perform in-place aggregate
|
||||
-- assignent in the newly allocated object.
|
||||
|
||||
|
||||
end Exp_Aggr;
|
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,35 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- E X P _ A T T R --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.3 $ --
|
||||
-- --
|
||||
-- Copyright (C) 1992,1993,1994 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- Expand routines for attribute references
|
||||
|
||||
with Types; use Types;
|
||||
|
||||
package Exp_Attr is
|
||||
procedure Expand_N_Attribute_Reference (N : Node_Id);
|
||||
end Exp_Attr;
|
|
@ -0,0 +1,32 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- E X P _ C H 1 0 --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.3 $ --
|
||||
-- --
|
||||
-- Copyright (C) 1992,1993,1994 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- Expand routines for chapter 10 constructs
|
||||
|
||||
package Exp_Ch10 is
|
||||
end Exp_Ch10;
|
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,119 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- E X P _ C H 1 1 --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.25 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-2000 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- Expand routines for chapter 11 constructs
|
||||
|
||||
with Types; use Types;
|
||||
|
||||
package Exp_Ch11 is
|
||||
procedure Expand_N_Exception_Declaration (N : Node_Id);
|
||||
procedure Expand_N_Handled_Sequence_Of_Statements (N : Node_Id);
|
||||
procedure Expand_N_Raise_Constraint_Error (N : Node_Id);
|
||||
procedure Expand_N_Raise_Program_Error (N : Node_Id);
|
||||
procedure Expand_N_Raise_Statement (N : Node_Id);
|
||||
procedure Expand_N_Raise_Storage_Error (N : Node_Id);
|
||||
procedure Expand_N_Subprogram_Info (N : Node_Id);
|
||||
|
||||
-- Data structures for gathering information to build exception tables
|
||||
-- See runtime routine Ada.Exceptions for full details on the format and
|
||||
-- content of these tables.
|
||||
|
||||
procedure Initialize;
|
||||
-- Initializes these data structures for a new main unit file
|
||||
|
||||
procedure Expand_At_End_Handler (HSS : Node_Id; Block : Node_Id);
|
||||
-- Given a handled statement sequence, HSS, for which the At_End_Proc
|
||||
-- field is set, and which currently has no exception handlers, this
|
||||
-- procedure expands the special exception handler required.
|
||||
-- This procedure also create a new scope for the given Block, if
|
||||
-- Block is not Empty.
|
||||
|
||||
procedure Expand_Exception_Handlers (HSS : Node_Id);
|
||||
-- This procedure expands exception handlers, and is called as part
|
||||
-- of the processing for Expand_N_Handled_Sequence_Of_Statements and
|
||||
-- is also called from Expand_At_End_Handler. N is the handled sequence
|
||||
-- of statements that has the exception handler(s) to be expanded. This
|
||||
-- is also called to expand the special exception handler built for
|
||||
-- accept bodies (see Exp_Ch9.Build_Accept_Body).
|
||||
|
||||
procedure Generate_Unit_Exception_Table;
|
||||
-- Procedure called by main driver to generate unit exception table if
|
||||
-- zero cost exceptions are enabled. See System.Exceptions for details.
|
||||
|
||||
function Is_Non_Ada_Error (E : Entity_Id) return Boolean;
|
||||
-- This function is provided for Gigi use. It returns True if operating on
|
||||
-- VMS, and the argument E is the entity for System.Aux_Dec.Non_Ada_Error.
|
||||
-- This is used to generate the special matching code for this exception.
|
||||
|
||||
procedure Remove_Handler_Entries (N : Node_Id);
|
||||
-- This procedure is called when optimization circuits determine that
|
||||
-- an entire subtree can be removed. If the subtree contains handler
|
||||
-- entries in zero cost exception mode, then such removal can lead to
|
||||
-- dangling references to non-existent handlers in the handler table.
|
||||
-- This procedure removes such references.
|
||||
|
||||
--------------------------------------
|
||||
-- Subprogram_Descriptor Generation --
|
||||
--------------------------------------
|
||||
|
||||
-- Subprogram descriptors are required for all subprograms, including
|
||||
-- explicit subprograms defined in the program, subprograms that are
|
||||
-- imported via pragma Import, and also for the implicit elaboration
|
||||
-- subprograms used to elaborate package specs and bodies.
|
||||
|
||||
procedure Generate_Subprogram_Descriptor_For_Package
|
||||
(N : Node_Id;
|
||||
Spec : Entity_Id);
|
||||
-- This is used to create a descriptor for the implicit elaboration
|
||||
-- procedure for a package spec of body. The compiler only generates
|
||||
-- such descriptors if the package spec or body contains exception
|
||||
-- handlers (either explicitly in the case of a body, or from generic
|
||||
-- package instantiations). N is the node for the package body or
|
||||
-- spec, and Spec is the package body or package entity respectively.
|
||||
-- N must be a compilation unit, and the descriptor is placed at
|
||||
-- the end of the actions for the auxiliary compilation unit node.
|
||||
|
||||
procedure Generate_Subprogram_Descriptor_For_Subprogram
|
||||
(N : Node_Id;
|
||||
Spec : Entity_Id);
|
||||
-- This is used to create a desriptor for a subprogram, both those
|
||||
-- present in the source, and those implicitly generated by code
|
||||
-- expansion. N is the subprogram body node, and Spec is the entity
|
||||
-- for the subprogram. The descriptor is placed at the end of the
|
||||
-- Last exception handler, or, if there are no handlers, at the end
|
||||
-- of the statement sequence.
|
||||
|
||||
procedure Generate_Subprogram_Descriptor_For_Imported_Subprogram
|
||||
(Spec : Entity_Id;
|
||||
Slist : List_Id);
|
||||
-- This is used to create a descriptor for an imported subprogram.
|
||||
-- Such descriptors are needed for propagation of exceptions through
|
||||
-- such subprograms. The descriptor never references any handlers,
|
||||
-- and is appended to the given Slist.
|
||||
|
||||
end Exp_Ch11;
|
|
@ -0,0 +1,69 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- E X P _ C H 1 2 --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.7 $
|
||||
-- --
|
||||
-- Copyright (C) 1997-2001 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Atree; use Atree;
|
||||
with Checks; use Checks;
|
||||
with Einfo; use Einfo;
|
||||
with Exp_Util; use Exp_Util;
|
||||
with Nmake; use Nmake;
|
||||
with Sinfo; use Sinfo;
|
||||
with Stand; use Stand;
|
||||
with Tbuild; use Tbuild;
|
||||
|
||||
package body Exp_Ch12 is
|
||||
|
||||
------------------------------------
|
||||
-- Expand_N_Generic_Instantiation --
|
||||
------------------------------------
|
||||
|
||||
-- If elaboration entity is defined and this is not an outer level entity,
|
||||
-- we need to generate a check for it here.
|
||||
|
||||
procedure Expand_N_Generic_Instantiation (N : Node_Id) is
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
Ent : constant Entity_Id := Entity (Name (N));
|
||||
|
||||
begin
|
||||
if Etype (Name (N)) = Any_Type then
|
||||
return;
|
||||
end if;
|
||||
|
||||
if Present (Elaboration_Entity (Ent))
|
||||
and then not Is_Compilation_Unit (Ent)
|
||||
and then not Elaboration_Checks_Suppressed (Ent)
|
||||
then
|
||||
Insert_Action (Instance_Spec (N),
|
||||
Make_Raise_Program_Error (Loc,
|
||||
Condition =>
|
||||
Make_Op_Not (Loc,
|
||||
Right_Opnd =>
|
||||
New_Occurrence_Of (Elaboration_Entity (Ent), Loc))));
|
||||
end if;
|
||||
end Expand_N_Generic_Instantiation;
|
||||
|
||||
end Exp_Ch12;
|
|
@ -0,0 +1,35 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- E X P _ C H 1 2 --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.4 $ --
|
||||
-- --
|
||||
-- Copyright (C) 1992-1997 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- Expand routines for chapter 12 constructs
|
||||
|
||||
with Types; use Types;
|
||||
|
||||
package Exp_Ch12 is
|
||||
procedure Expand_N_Generic_Instantiation (N : Node_Id);
|
||||
end Exp_Ch12;
|
|
@ -0,0 +1,425 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- E X P _ C H 1 3 --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.76 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001, 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Atree; use Atree;
|
||||
with Einfo; use Einfo;
|
||||
with Exp_Ch3; use Exp_Ch3;
|
||||
with Exp_Ch6; use Exp_Ch6;
|
||||
with Exp_Imgv; use Exp_Imgv;
|
||||
with Exp_Util; use Exp_Util;
|
||||
with Nlists; use Nlists;
|
||||
with Nmake; use Nmake;
|
||||
with Rtsfind; use Rtsfind;
|
||||
with Sem; use Sem;
|
||||
with Sem_Ch7; use Sem_Ch7;
|
||||
with Sem_Ch8; use Sem_Ch8;
|
||||
with Sem_Eval; use Sem_Eval;
|
||||
with Sem_Util; use Sem_Util;
|
||||
with Sinfo; use Sinfo;
|
||||
with Snames; use Snames;
|
||||
with Stand; use Stand;
|
||||
with Stringt; use Stringt;
|
||||
with Tbuild; use Tbuild;
|
||||
with Uintp; use Uintp;
|
||||
|
||||
package body Exp_Ch13 is
|
||||
|
||||
------------------------------------------
|
||||
-- Expand_N_Attribute_Definition_Clause --
|
||||
------------------------------------------
|
||||
|
||||
-- Expansion action depends on attribute involved
|
||||
|
||||
procedure Expand_N_Attribute_Definition_Clause (N : Node_Id) is
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
Exp : constant Node_Id := Expression (N);
|
||||
Ent : Entity_Id;
|
||||
V : Node_Id;
|
||||
|
||||
begin
|
||||
Ent := Entity (Name (N));
|
||||
|
||||
if Is_Type (Ent) then
|
||||
Ent := Underlying_Type (Ent);
|
||||
end if;
|
||||
|
||||
case Get_Attribute_Id (Chars (N)) is
|
||||
|
||||
-------------
|
||||
-- Address --
|
||||
-------------
|
||||
|
||||
when Attribute_Address =>
|
||||
|
||||
-- If there is an initialization which did not come from
|
||||
-- the source program, then it is an artifact of our
|
||||
-- expansion, and we suppress it. The case we are most
|
||||
-- concerned about here is the initialization of a packed
|
||||
-- array to all false, which seems inappropriate for a
|
||||
-- variable to which an address clause is applied. The
|
||||
-- expression may itself have been rewritten if the type is a
|
||||
-- packed array, so we need to examine whether the original
|
||||
-- node is in the source.
|
||||
|
||||
declare
|
||||
Decl : constant Node_Id := Declaration_Node (Ent);
|
||||
|
||||
begin
|
||||
if Nkind (Decl) = N_Object_Declaration
|
||||
and then Present (Expression (Decl))
|
||||
and then
|
||||
not Comes_From_Source (Original_Node (Expression (Decl)))
|
||||
then
|
||||
Set_Expression (Decl, Empty);
|
||||
end if;
|
||||
end;
|
||||
|
||||
---------------
|
||||
-- Alignment --
|
||||
---------------
|
||||
|
||||
when Attribute_Alignment =>
|
||||
|
||||
-- As required by Gigi, we guarantee that the operand is an
|
||||
-- integer literal (this simplifies things in Gigi).
|
||||
|
||||
if Nkind (Exp) /= N_Integer_Literal then
|
||||
Rewrite
|
||||
(Exp, Make_Integer_Literal (Loc, Expr_Value (Exp)));
|
||||
end if;
|
||||
|
||||
------------------
|
||||
-- External_Tag --
|
||||
------------------
|
||||
|
||||
-- For the rep clause "for x'external_tag use y" generate:
|
||||
|
||||
-- xV : constant string := y;
|
||||
-- Set_External_Tag (x'tag, xV'Address);
|
||||
-- Register_Tag (x'tag);
|
||||
|
||||
-- note that register_tag has been delayed up to now because
|
||||
-- the external_tag must be set before resistering.
|
||||
|
||||
when Attribute_External_Tag => External_Tag : declare
|
||||
E : Entity_Id;
|
||||
Old_Val : String_Id := Strval (Expr_Value_S (Exp));
|
||||
New_Val : String_Id;
|
||||
|
||||
begin
|
||||
-- Create a new nul terminated string if it is not already
|
||||
|
||||
if String_Length (Old_Val) > 0
|
||||
and then Get_String_Char (Old_Val, String_Length (Old_Val)) = 0
|
||||
then
|
||||
New_Val := Old_Val;
|
||||
else
|
||||
Start_String (Old_Val);
|
||||
Store_String_Char (Get_Char_Code (ASCII.NUL));
|
||||
New_Val := End_String;
|
||||
end if;
|
||||
|
||||
E :=
|
||||
Make_Defining_Identifier (Loc,
|
||||
New_External_Name (Chars (Ent), 'A'));
|
||||
|
||||
Insert_Action (N,
|
||||
Make_Object_Declaration (Loc,
|
||||
Defining_Identifier => E,
|
||||
Constant_Present => True,
|
||||
Object_Definition =>
|
||||
New_Reference_To (Standard_String, Loc),
|
||||
Expression =>
|
||||
Make_String_Literal (Loc, Strval => New_Val)));
|
||||
|
||||
Insert_Actions (N, New_List (
|
||||
Make_Procedure_Call_Statement (Loc,
|
||||
Name => New_Reference_To (RTE (RE_Set_External_Tag), Loc),
|
||||
Parameter_Associations => New_List (
|
||||
Make_Attribute_Reference (Loc,
|
||||
Attribute_Name => Name_Tag,
|
||||
Prefix => New_Occurrence_Of (Ent, Loc)),
|
||||
|
||||
Make_Attribute_Reference (Loc,
|
||||
Attribute_Name => Name_Address,
|
||||
Prefix => New_Occurrence_Of (E, Loc)))),
|
||||
|
||||
Make_Procedure_Call_Statement (Loc,
|
||||
Name => New_Reference_To (RTE (RE_Register_Tag), Loc),
|
||||
Parameter_Associations => New_List (
|
||||
Make_Attribute_Reference (Loc,
|
||||
Attribute_Name => Name_Tag,
|
||||
Prefix => New_Occurrence_Of (Ent, Loc))))));
|
||||
end External_Tag;
|
||||
|
||||
------------------
|
||||
-- Storage_Size --
|
||||
------------------
|
||||
|
||||
when Attribute_Storage_Size =>
|
||||
|
||||
-- If the type is a task type, then assign the value of the
|
||||
-- storage size to the Size variable associated with the task.
|
||||
-- task_typeZ := expression
|
||||
|
||||
if Ekind (Ent) = E_Task_Type then
|
||||
Insert_Action (N,
|
||||
Make_Assignment_Statement (Loc,
|
||||
Name => New_Reference_To (Storage_Size_Variable (Ent), Loc),
|
||||
Expression =>
|
||||
Convert_To (RTE (RE_Size_Type), Expression (N))));
|
||||
|
||||
-- For Storage_Size for an access type, create a variable to hold
|
||||
-- the value of the specified size with name typeV and expand an
|
||||
-- assignment statement to initialze this value.
|
||||
|
||||
elsif Is_Access_Type (Ent) then
|
||||
|
||||
V := Make_Defining_Identifier (Loc,
|
||||
New_External_Name (Chars (Ent), 'V'));
|
||||
|
||||
Insert_Action (N,
|
||||
Make_Object_Declaration (Loc,
|
||||
Defining_Identifier => V,
|
||||
Object_Definition =>
|
||||
New_Reference_To (RTE (RE_Storage_Offset), Loc),
|
||||
Expression =>
|
||||
Convert_To (RTE (RE_Storage_Offset), Expression (N))));
|
||||
|
||||
Set_Storage_Size_Variable (Ent, Entity_Id (V));
|
||||
end if;
|
||||
|
||||
-- Other attributes require no expansion
|
||||
|
||||
when others =>
|
||||
null;
|
||||
|
||||
end case;
|
||||
|
||||
end Expand_N_Attribute_Definition_Clause;
|
||||
|
||||
----------------------------
|
||||
-- Expand_N_Freeze_Entity --
|
||||
----------------------------
|
||||
|
||||
procedure Expand_N_Freeze_Entity (N : Node_Id) is
|
||||
E : constant Entity_Id := Entity (N);
|
||||
E_Scope : Entity_Id;
|
||||
S : Entity_Id;
|
||||
In_Other_Scope : Boolean;
|
||||
In_Outer_Scope : Boolean;
|
||||
Decl : Node_Id;
|
||||
|
||||
begin
|
||||
if not Is_Type (E) and then not Is_Subprogram (E) then
|
||||
return;
|
||||
end if;
|
||||
|
||||
E_Scope := Scope (E);
|
||||
|
||||
-- If we are freezing entities defined in protected types, they
|
||||
-- belong in the enclosing scope, given that the original type
|
||||
-- has been expanded away. The same is true for entities in task types,
|
||||
-- in particular the parameter records of entries (Entities in bodies
|
||||
-- are all frozen within the body). If we are in the task body, this
|
||||
-- is a proper scope.
|
||||
|
||||
if Ekind (E_Scope) = E_Protected_Type
|
||||
or else (Ekind (E_Scope) = E_Task_Type
|
||||
and then not Has_Completion (E_Scope))
|
||||
then
|
||||
E_Scope := Scope (E_Scope);
|
||||
end if;
|
||||
|
||||
S := Current_Scope;
|
||||
while S /= Standard_Standard and then S /= E_Scope loop
|
||||
S := Scope (S);
|
||||
end loop;
|
||||
|
||||
In_Other_Scope := not (S = E_Scope);
|
||||
In_Outer_Scope := (not In_Other_Scope) and then (S /= Current_Scope);
|
||||
|
||||
-- If the entity being frozen is defined in a scope that is not
|
||||
-- currently on the scope stack, we must establish the proper
|
||||
-- visibility before freezing the entity and related subprograms.
|
||||
|
||||
if In_Other_Scope then
|
||||
New_Scope (E_Scope);
|
||||
Install_Visible_Declarations (E_Scope);
|
||||
|
||||
if Ekind (E_Scope) = E_Package or else
|
||||
Ekind (E_Scope) = E_Generic_Package or else
|
||||
Is_Protected_Type (E_Scope) or else
|
||||
Is_Task_Type (E_Scope)
|
||||
then
|
||||
Install_Private_Declarations (E_Scope);
|
||||
end if;
|
||||
|
||||
-- If the entity is in an outer scope, then that scope needs to
|
||||
-- temporarily become the current scope so that operations created
|
||||
-- during type freezing will be declared in the right scope and
|
||||
-- can properly override any corresponding inherited operations.
|
||||
|
||||
elsif In_Outer_Scope then
|
||||
New_Scope (E_Scope);
|
||||
end if;
|
||||
|
||||
-- If type, freeze the type
|
||||
|
||||
if Is_Type (E) then
|
||||
Freeze_Type (N);
|
||||
|
||||
-- And for enumeration type, build the enumeration tables
|
||||
|
||||
if Is_Enumeration_Type (E) then
|
||||
Build_Enumeration_Image_Tables (E, N);
|
||||
end if;
|
||||
|
||||
-- If subprogram, freeze the subprogram
|
||||
|
||||
elsif Is_Subprogram (E) then
|
||||
Freeze_Subprogram (N);
|
||||
|
||||
-- No other entities require any front end freeze actions
|
||||
|
||||
else
|
||||
null;
|
||||
end if;
|
||||
|
||||
-- Analyze actions generated by freezing. The init_proc contains
|
||||
-- source expressions that may raise constraint_error, and the
|
||||
-- assignment procedure for complex types needs checks on individual
|
||||
-- component assignments, but all other freezing actions should be
|
||||
-- compiled with all checks off.
|
||||
|
||||
if Present (Actions (N)) then
|
||||
Decl := First (Actions (N));
|
||||
|
||||
while Present (Decl) loop
|
||||
|
||||
if Nkind (Decl) = N_Subprogram_Body
|
||||
and then (Chars (Defining_Entity (Decl)) = Name_uInit_Proc
|
||||
or else Chars (Defining_Entity (Decl)) = Name_uAssign)
|
||||
then
|
||||
Analyze (Decl);
|
||||
|
||||
-- A subprogram body created for a renaming_as_body completes
|
||||
-- a previous declaration, which may be in a different scope.
|
||||
-- Establish the proper scope before analysis.
|
||||
|
||||
elsif Nkind (Decl) = N_Subprogram_Body
|
||||
and then Present (Corresponding_Spec (Decl))
|
||||
and then Scope (Corresponding_Spec (Decl)) /= Current_Scope
|
||||
then
|
||||
New_Scope (Scope (Corresponding_Spec (Decl)));
|
||||
Analyze (Decl, Suppress => All_Checks);
|
||||
Pop_Scope;
|
||||
|
||||
else
|
||||
Analyze (Decl, Suppress => All_Checks);
|
||||
end if;
|
||||
|
||||
Next (Decl);
|
||||
end loop;
|
||||
end if;
|
||||
|
||||
if In_Other_Scope then
|
||||
if Ekind (Current_Scope) = E_Package then
|
||||
End_Package_Scope (E_Scope);
|
||||
else
|
||||
End_Scope;
|
||||
end if;
|
||||
|
||||
elsif In_Outer_Scope then
|
||||
Pop_Scope;
|
||||
end if;
|
||||
end Expand_N_Freeze_Entity;
|
||||
|
||||
-------------------------------------------
|
||||
-- Expand_N_Record_Representation_Clause --
|
||||
-------------------------------------------
|
||||
|
||||
-- The only expansion required is for the case of a mod clause present,
|
||||
-- which is removed, and translated into an alignment representation
|
||||
-- clause inserted immediately after the record rep clause with any
|
||||
-- initial pragmas inserted at the start of the component clause list.
|
||||
|
||||
procedure Expand_N_Record_Representation_Clause (N : Node_Id) is
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
Rectype : constant Entity_Id := Entity (Identifier (N));
|
||||
Mod_Val : Uint;
|
||||
Citems : List_Id;
|
||||
Repitem : Node_Id;
|
||||
AtM_Nod : Node_Id;
|
||||
|
||||
begin
|
||||
if Present (Mod_Clause (N)) then
|
||||
Mod_Val := Expr_Value (Expression (Mod_Clause (N)));
|
||||
Citems := Pragmas_Before (Mod_Clause (N));
|
||||
|
||||
if Present (Citems) then
|
||||
Append_List_To (Citems, Component_Clauses (N));
|
||||
Set_Component_Clauses (N, Citems);
|
||||
end if;
|
||||
|
||||
AtM_Nod :=
|
||||
Make_Attribute_Definition_Clause (Loc,
|
||||
Name => New_Reference_To (Base_Type (Rectype), Loc),
|
||||
Chars => Name_Alignment,
|
||||
Expression => Make_Integer_Literal (Loc, Mod_Val));
|
||||
|
||||
Set_From_At_Mod (AtM_Nod);
|
||||
Insert_After (N, AtM_Nod);
|
||||
Set_Mod_Clause (N, Empty);
|
||||
end if;
|
||||
|
||||
-- If the record representation clause has no components, then
|
||||
-- completely remove it. Note that we also have to remove
|
||||
-- ourself from the Rep Item list.
|
||||
|
||||
if Is_Empty_List (Component_Clauses (N)) then
|
||||
if First_Rep_Item (Rectype) = N then
|
||||
Set_First_Rep_Item (Rectype, Next_Rep_Item (N));
|
||||
else
|
||||
Repitem := First_Rep_Item (Rectype);
|
||||
while Present (Next_Rep_Item (Repitem)) loop
|
||||
if Next_Rep_Item (Repitem) = N then
|
||||
Set_Next_Rep_Item (Repitem, Next_Rep_Item (N));
|
||||
exit;
|
||||
end if;
|
||||
|
||||
Next_Rep_Item (Repitem);
|
||||
end loop;
|
||||
end if;
|
||||
|
||||
Rewrite (N,
|
||||
Make_Null_Statement (Loc));
|
||||
end if;
|
||||
end Expand_N_Record_Representation_Clause;
|
||||
|
||||
end Exp_Ch13;
|
|
@ -0,0 +1,39 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- E X P _ C H 1 3 --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.6 $ --
|
||||
-- --
|
||||
-- Copyright (C) 1992,1993,1994 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- Expand routines for chapter 13 constructs
|
||||
|
||||
with Types; use Types;
|
||||
|
||||
package Exp_Ch13 is
|
||||
|
||||
procedure Expand_N_Attribute_Definition_Clause (N : Node_Id);
|
||||
procedure Expand_N_Freeze_Entity (N : Node_Id);
|
||||
procedure Expand_N_Record_Representation_Clause (N : Node_Id);
|
||||
|
||||
end Exp_Ch13;
|
|
@ -0,0 +1,487 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- E X P _ C H 2 --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.64 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Atree; use Atree;
|
||||
with Einfo; use Einfo;
|
||||
with Elists; use Elists;
|
||||
with Exp_Smem; use Exp_Smem;
|
||||
with Exp_Util; use Exp_Util;
|
||||
with Exp_VFpt; use Exp_VFpt;
|
||||
with Nmake; use Nmake;
|
||||
with Sem; use Sem;
|
||||
with Sem_Res; use Sem_Res;
|
||||
with Sem_Util; use Sem_Util;
|
||||
with Sinfo; use Sinfo;
|
||||
with Tbuild; use Tbuild;
|
||||
with Snames; use Snames;
|
||||
|
||||
package body Exp_Ch2 is
|
||||
|
||||
-----------------------
|
||||
-- Local Subprograms --
|
||||
-----------------------
|
||||
|
||||
procedure Expand_Discriminant (N : Node_Id);
|
||||
-- An occurence of a discriminant within a discriminated type is replaced
|
||||
-- with the corresponding discriminal, that is to say the formal parameter
|
||||
-- of the initialization procedure for the type that is associated with
|
||||
-- that particular discriminant. This replacement is not performed for
|
||||
-- discriminants of records that appear in constraints of component of the
|
||||
-- record, because Gigi uses the discriminant name to retrieve its value.
|
||||
-- In the other hand, it has to be performed for default expressions of
|
||||
-- components because they are used in the record init procedure. See
|
||||
-- Einfo for more details, and Exp_Ch3, Exp_Ch9 for examples of use.
|
||||
-- For discriminants of tasks and protected types, the transformation is
|
||||
-- more complex when it occurs within a default expression for an entry
|
||||
-- or protected operation. The corresponding default_expression_function
|
||||
-- has an additional parameter which is the target of an entry call, and
|
||||
-- the discriminant of the task must be replaced with a reference to the
|
||||
-- discriminant of that formal parameter.
|
||||
|
||||
procedure Expand_Entity_Reference (N : Node_Id);
|
||||
-- Common processing for expansion of identifiers and expanded names
|
||||
|
||||
procedure Expand_Entry_Index_Parameter (N : Node_Id);
|
||||
-- A reference to the identifier in the entry index specification
|
||||
-- of a protected entry body is modified to a reference to a constant
|
||||
-- definintion equal to the index of the entry family member being
|
||||
-- called. This constant is calculated as part of the elaboration
|
||||
-- of the expanded code for the body, and is calculated from the
|
||||
-- object-wide entry index returned by Next_Entry_Call.
|
||||
|
||||
procedure Expand_Entry_Parameter (N : Node_Id);
|
||||
-- A reference to an entry parameter is modified to be a reference to
|
||||
-- the corresponding component of the entry parameter record that is
|
||||
-- passed by the runtime to the accept body procedure
|
||||
|
||||
procedure Expand_Formal (N : Node_Id);
|
||||
-- A reference to a formal parameter of a protected subprogram is
|
||||
-- expanded to the corresponding formal of the unprotected procedure
|
||||
-- used to represent the protected subprogram within the protected object.
|
||||
|
||||
procedure Expand_Protected_Private (N : Node_Id);
|
||||
-- A reference to a private object of a protected type is expanded
|
||||
-- to a component selected from the record used to implement
|
||||
-- the protected object. Such a record is passed to all operations
|
||||
-- on a protected object in a parameter named _object. Such an object
|
||||
-- is a constant within a function, and a variable otherwise.
|
||||
|
||||
procedure Expand_Renaming (N : Node_Id);
|
||||
-- For renamings, just replace the identifier by the corresponding
|
||||
-- name expression. Note that this has been evaluated (see routine
|
||||
-- Exp_Ch8.Expand_N_Object_Renaming.Evaluate_Name) so this gives
|
||||
-- the correct renaming semantics.
|
||||
|
||||
-------------------------
|
||||
-- Expand_Discriminant --
|
||||
-------------------------
|
||||
|
||||
procedure Expand_Discriminant (N : Node_Id) is
|
||||
Scop : constant Entity_Id := Scope (Entity (N));
|
||||
P : Node_Id := N;
|
||||
Parent_P : Node_Id := Parent (P);
|
||||
In_Entry : Boolean := False;
|
||||
|
||||
begin
|
||||
-- The Incomplete_Or_Private_Kind happens while resolving the
|
||||
-- discriminant constraint involved in a derived full type,
|
||||
-- such as:
|
||||
|
||||
-- type D is private;
|
||||
-- type D(C : ...) is new T(C);
|
||||
|
||||
if Ekind (Scop) = E_Record_Type
|
||||
or Ekind (Scop) in Incomplete_Or_Private_Kind
|
||||
then
|
||||
|
||||
-- Find the origin by walking up the tree till the component
|
||||
-- declaration
|
||||
|
||||
while Present (Parent_P)
|
||||
and then Nkind (Parent_P) /= N_Component_Declaration
|
||||
loop
|
||||
P := Parent_P;
|
||||
Parent_P := Parent (P);
|
||||
end loop;
|
||||
|
||||
-- If the discriminant reference was part of the default expression
|
||||
-- it has to be "discriminalized"
|
||||
|
||||
if Present (Parent_P) and then P = Expression (Parent_P) then
|
||||
Set_Entity (N, Discriminal (Entity (N)));
|
||||
end if;
|
||||
|
||||
elsif Is_Concurrent_Type (Scop) then
|
||||
while Present (Parent_P)
|
||||
and then Nkind (Parent_P) /= N_Subprogram_Body
|
||||
loop
|
||||
P := Parent_P;
|
||||
|
||||
if Nkind (P) = N_Entry_Declaration then
|
||||
In_Entry := True;
|
||||
end if;
|
||||
|
||||
Parent_P := Parent (Parent_P);
|
||||
end loop;
|
||||
|
||||
-- If the discriminant occurs within the default expression for
|
||||
-- a formal of an entry or protected operation, create a default
|
||||
-- function for it, and replace the discriminant with a reference
|
||||
-- to the discriminant of the formal of the default function.
|
||||
-- The discriminant entity is the one defined in the corresponding
|
||||
-- record.
|
||||
|
||||
if Present (Parent_P)
|
||||
and then Present (Corresponding_Spec (Parent_P))
|
||||
then
|
||||
|
||||
declare
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
D_Fun : Entity_Id := Corresponding_Spec (Parent_P);
|
||||
Formal : Entity_Id := First_Formal (D_Fun);
|
||||
New_N : Node_Id;
|
||||
Disc : Entity_Id;
|
||||
|
||||
begin
|
||||
-- Verify that we are within a default function: the type of
|
||||
-- its formal parameter is the same task or protected type.
|
||||
|
||||
if Present (Formal)
|
||||
and then Etype (Formal) = Scope (Entity (N))
|
||||
then
|
||||
Disc := CR_Discriminant (Entity (N));
|
||||
|
||||
New_N :=
|
||||
Make_Selected_Component (Loc,
|
||||
Prefix => New_Occurrence_Of (Formal, Loc),
|
||||
Selector_Name => New_Occurrence_Of (Disc, Loc));
|
||||
|
||||
Set_Etype (New_N, Etype (N));
|
||||
Rewrite (N, New_N);
|
||||
|
||||
else
|
||||
Set_Entity (N, Discriminal (Entity (N)));
|
||||
end if;
|
||||
end;
|
||||
|
||||
elsif Nkind (Parent (N)) = N_Range
|
||||
and then In_Entry
|
||||
then
|
||||
Set_Entity (N, CR_Discriminant (Entity (N)));
|
||||
else
|
||||
Set_Entity (N, Discriminal (Entity (N)));
|
||||
end if;
|
||||
|
||||
else
|
||||
Set_Entity (N, Discriminal (Entity (N)));
|
||||
end if;
|
||||
end Expand_Discriminant;
|
||||
|
||||
-----------------------------
|
||||
-- Expand_Entity_Reference --
|
||||
-----------------------------
|
||||
|
||||
procedure Expand_Entity_Reference (N : Node_Id) is
|
||||
E : constant Entity_Id := Entity (N);
|
||||
|
||||
begin
|
||||
if Ekind (E) = E_Discriminant then
|
||||
Expand_Discriminant (N);
|
||||
|
||||
elsif Is_Entry_Formal (E) then
|
||||
Expand_Entry_Parameter (N);
|
||||
|
||||
elsif Ekind (E) = E_Component
|
||||
and then Is_Protected_Private (E)
|
||||
then
|
||||
Expand_Protected_Private (N);
|
||||
|
||||
elsif Ekind (E) = E_Entry_Index_Parameter then
|
||||
Expand_Entry_Index_Parameter (N);
|
||||
|
||||
elsif Is_Formal (E) then
|
||||
Expand_Formal (N);
|
||||
|
||||
elsif Is_Renaming_Of_Object (E) then
|
||||
Expand_Renaming (N);
|
||||
|
||||
elsif Ekind (E) = E_Variable
|
||||
and then Is_Shared_Passive (E)
|
||||
then
|
||||
Expand_Shared_Passive_Variable (N);
|
||||
end if;
|
||||
end Expand_Entity_Reference;
|
||||
|
||||
----------------------------------
|
||||
-- Expand_Entry_Index_Parameter --
|
||||
----------------------------------
|
||||
|
||||
procedure Expand_Entry_Index_Parameter (N : Node_Id) is
|
||||
begin
|
||||
Set_Entity (N, Entry_Index_Constant (Entity (N)));
|
||||
end Expand_Entry_Index_Parameter;
|
||||
|
||||
----------------------------
|
||||
-- Expand_Entry_Parameter --
|
||||
----------------------------
|
||||
|
||||
procedure Expand_Entry_Parameter (N : Node_Id) is
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
Ent_Formal : constant Entity_Id := Entity (N);
|
||||
Ent_Spec : constant Entity_Id := Scope (Ent_Formal);
|
||||
Parm_Type : constant Entity_Id := Entry_Parameters_Type (Ent_Spec);
|
||||
Acc_Stack : constant Elist_Id := Accept_Address (Ent_Spec);
|
||||
Addr_Ent : constant Entity_Id := Node (Last_Elmt (Acc_Stack));
|
||||
P_Comp_Ref : Entity_Id;
|
||||
|
||||
begin
|
||||
-- What we need is a reference to the corresponding component of the
|
||||
-- parameter record object. The Accept_Address field of the entry
|
||||
-- entity references the address variable that contains the address
|
||||
-- of the accept parameters record. We first have to do an unchecked
|
||||
-- conversion to turn this into a pointer to the parameter record and
|
||||
-- then we select the required parameter field.
|
||||
|
||||
P_Comp_Ref :=
|
||||
Make_Selected_Component (Loc,
|
||||
Prefix =>
|
||||
Unchecked_Convert_To (Parm_Type,
|
||||
New_Reference_To (Addr_Ent, Loc)),
|
||||
Selector_Name =>
|
||||
New_Reference_To (Entry_Component (Ent_Formal), Loc));
|
||||
|
||||
-- For all types of parameters, the constructed parameter record
|
||||
-- object contains a pointer to the parameter. Thus we must
|
||||
-- dereference them to access them (this will often be redundant,
|
||||
-- since the needed deference is implicit, but no harm is done by
|
||||
-- making it explicit).
|
||||
|
||||
Rewrite (N,
|
||||
Make_Explicit_Dereference (Loc, P_Comp_Ref));
|
||||
|
||||
Analyze (N);
|
||||
end Expand_Entry_Parameter;
|
||||
|
||||
-------------------
|
||||
-- Expand_Formal --
|
||||
-------------------
|
||||
|
||||
procedure Expand_Formal (N : Node_Id) is
|
||||
E : constant Entity_Id := Entity (N);
|
||||
Subp : constant Entity_Id := Scope (E);
|
||||
|
||||
begin
|
||||
if Is_Protected_Type (Scope (Subp))
|
||||
and then Chars (Subp) /= Name_uInit_Proc
|
||||
and then Present (Protected_Formal (E))
|
||||
then
|
||||
Set_Entity (N, Protected_Formal (E));
|
||||
end if;
|
||||
end Expand_Formal;
|
||||
|
||||
----------------------------
|
||||
-- Expand_N_Expanded_Name --
|
||||
----------------------------
|
||||
|
||||
procedure Expand_N_Expanded_Name (N : Node_Id) is
|
||||
begin
|
||||
Expand_Entity_Reference (N);
|
||||
end Expand_N_Expanded_Name;
|
||||
|
||||
-------------------------
|
||||
-- Expand_N_Identifier --
|
||||
-------------------------
|
||||
|
||||
procedure Expand_N_Identifier (N : Node_Id) is
|
||||
begin
|
||||
Expand_Entity_Reference (N);
|
||||
end Expand_N_Identifier;
|
||||
|
||||
---------------------------
|
||||
-- Expand_N_Real_Literal --
|
||||
---------------------------
|
||||
|
||||
procedure Expand_N_Real_Literal (N : Node_Id) is
|
||||
begin
|
||||
if Vax_Float (Etype (N)) then
|
||||
Expand_Vax_Real_Literal (N);
|
||||
end if;
|
||||
end Expand_N_Real_Literal;
|
||||
|
||||
------------------------------
|
||||
-- Expand_Protected_Private --
|
||||
------------------------------
|
||||
|
||||
procedure Expand_Protected_Private (N : Node_Id) is
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
E : constant Entity_Id := Entity (N);
|
||||
Op : constant Node_Id := Protected_Operation (E);
|
||||
Scop : Entity_Id;
|
||||
Lo : Node_Id;
|
||||
Hi : Node_Id;
|
||||
D_Range : Node_Id;
|
||||
|
||||
begin
|
||||
if Nkind (Op) /= N_Subprogram_Body
|
||||
or else Nkind (Specification (Op)) /= N_Function_Specification
|
||||
then
|
||||
Set_Ekind (Prival (E), E_Variable);
|
||||
else
|
||||
Set_Ekind (Prival (E), E_Constant);
|
||||
end if;
|
||||
|
||||
-- If the private component appears in an assignment (either lhs or
|
||||
-- rhs) and is a one-dimensional array constrained by a discriminant,
|
||||
-- rewrite as P (Lo .. Hi) with an explicit range, so that discriminal
|
||||
-- is directly visible. This solves delicate visibility problems.
|
||||
|
||||
if Comes_From_Source (N)
|
||||
and then Is_Array_Type (Etype (E))
|
||||
and then Number_Dimensions (Etype (E)) = 1
|
||||
and then not Within_Init_Proc
|
||||
then
|
||||
Lo := Type_Low_Bound (Etype (First_Index (Etype (E))));
|
||||
Hi := Type_High_Bound (Etype (First_Index (Etype (E))));
|
||||
|
||||
if Nkind (Parent (N)) = N_Assignment_Statement
|
||||
and then ((Is_Entity_Name (Lo)
|
||||
and then Ekind (Entity (Lo)) = E_In_Parameter)
|
||||
or else (Is_Entity_Name (Hi)
|
||||
and then
|
||||
Ekind (Entity (Hi)) = E_In_Parameter))
|
||||
then
|
||||
D_Range := New_Node (N_Range, Loc);
|
||||
|
||||
if Is_Entity_Name (Lo)
|
||||
and then Ekind (Entity (Lo)) = E_In_Parameter
|
||||
then
|
||||
Set_Low_Bound (D_Range,
|
||||
Make_Identifier (Loc, Chars (Entity (Lo))));
|
||||
else
|
||||
Set_Low_Bound (D_Range, Duplicate_Subexpr (Lo));
|
||||
end if;
|
||||
|
||||
if Is_Entity_Name (Hi)
|
||||
and then Ekind (Entity (Hi)) = E_In_Parameter
|
||||
then
|
||||
Set_High_Bound (D_Range,
|
||||
Make_Identifier (Loc, Chars (Entity (Hi))));
|
||||
else
|
||||
Set_High_Bound (D_Range, Duplicate_Subexpr (Hi));
|
||||
end if;
|
||||
|
||||
Rewrite (N,
|
||||
Make_Slice (Loc,
|
||||
Prefix => New_Occurrence_Of (E, Loc),
|
||||
Discrete_Range => D_Range));
|
||||
|
||||
Analyze_And_Resolve (N, Etype (E));
|
||||
return;
|
||||
end if;
|
||||
end if;
|
||||
|
||||
-- The type of the reference is the type of the prival, which may
|
||||
-- differ from that of the original component if it is an itype.
|
||||
|
||||
Set_Entity (N, Prival (E));
|
||||
Set_Etype (N, Etype (Prival (E)));
|
||||
Scop := Current_Scope;
|
||||
|
||||
-- Find entity for protected operation, which must be on scope stack.
|
||||
|
||||
while not Is_Protected_Type (Scope (Scop)) loop
|
||||
Scop := Scope (Scop);
|
||||
end loop;
|
||||
|
||||
Append_Elmt (N, Privals_Chain (Scop));
|
||||
end Expand_Protected_Private;
|
||||
|
||||
---------------------
|
||||
-- Expand_Renaming --
|
||||
---------------------
|
||||
|
||||
procedure Expand_Renaming (N : Node_Id) is
|
||||
E : constant Entity_Id := Entity (N);
|
||||
T : constant Entity_Id := Etype (N);
|
||||
|
||||
begin
|
||||
Rewrite (N, New_Copy_Tree (Renamed_Object (E)));
|
||||
|
||||
-- We mark the copy as unanalyzed, so that it is sure to be
|
||||
-- reanalyzed at the top level. This is needed in the packed
|
||||
-- case since we specifically avoided expanding packed array
|
||||
-- references when the renaming declaration was analyzed.
|
||||
|
||||
Reset_Analyzed_Flags (N);
|
||||
Analyze_And_Resolve (N, T);
|
||||
end Expand_Renaming;
|
||||
|
||||
------------------
|
||||
-- Param_Entity --
|
||||
------------------
|
||||
|
||||
-- This would be trivial, simply a test for an identifier that was a
|
||||
-- reference to a formal, if it were not for the fact that a previous
|
||||
-- call to Expand_Entry_Parameter will have modified the reference
|
||||
-- to the identifier to be of the form
|
||||
|
||||
-- typ!(recobj).rec.all'Constrained
|
||||
|
||||
-- where rec is a selector whose Entry_Formal link points to the formal
|
||||
|
||||
function Param_Entity (N : Node_Id) return Entity_Id is
|
||||
begin
|
||||
-- Simple reference case
|
||||
|
||||
if Nkind (N) = N_Identifier then
|
||||
if Is_Formal (Entity (N)) then
|
||||
return Entity (N);
|
||||
end if;
|
||||
|
||||
else
|
||||
if Nkind (N) = N_Explicit_Dereference then
|
||||
declare
|
||||
P : constant Node_Id := Prefix (N);
|
||||
S : Node_Id;
|
||||
|
||||
begin
|
||||
if Nkind (P) = N_Selected_Component then
|
||||
S := Selector_Name (P);
|
||||
|
||||
if Present (Entry_Formal (Entity (S))) then
|
||||
return Entry_Formal (Entity (S));
|
||||
end if;
|
||||
end if;
|
||||
end;
|
||||
end if;
|
||||
end if;
|
||||
|
||||
return (Empty);
|
||||
end Param_Entity;
|
||||
|
||||
end Exp_Ch2;
|
|
@ -0,0 +1,47 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- E X P _ C H 2 --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.7 $ --
|
||||
-- --
|
||||
-- Copyright (C) 1992-1997 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- Expand routines for chapter 2 constructs
|
||||
|
||||
with Types; use Types;
|
||||
package Exp_Ch2 is
|
||||
|
||||
procedure Expand_N_Expanded_Name (N : Node_Id);
|
||||
procedure Expand_N_Identifier (N : Node_Id);
|
||||
procedure Expand_N_Real_Literal (N : Node_Id);
|
||||
|
||||
function Param_Entity (N : Node_Id) return Entity_Id;
|
||||
-- Given an expression N, determines if the expression is a reference
|
||||
-- to a formal (of a subprogram or entry), and if so returns the Id
|
||||
-- of the corresponding formal entity, otherwise returns Empty. The
|
||||
-- reason that this is in Exp_Ch2 is that it has to deal with the
|
||||
-- case where the reference is to an entry formal, and has been
|
||||
-- expanded already. Since Exp_Ch2 is in charge of the expansion, it
|
||||
-- is best suited to knowing how to detect this case.
|
||||
|
||||
end Exp_Ch2;
|
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,104 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- E X P _ C H 3 --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.36 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- Expand routines for chapter 3 constructs
|
||||
|
||||
with Types; use Types;
|
||||
with Elists; use Elists;
|
||||
|
||||
package Exp_Ch3 is
|
||||
|
||||
procedure Expand_N_Object_Declaration (N : Node_Id);
|
||||
procedure Expand_N_Subtype_Indication (N : Node_Id);
|
||||
procedure Expand_N_Variant_Part (N : Node_Id);
|
||||
procedure Expand_N_Full_Type_Declaration (N : Node_Id);
|
||||
|
||||
procedure Expand_Previous_Access_Type (N : Node_Id; Def_Id : Entity_Id);
|
||||
-- For a full type declaration that contains tasks, or that is a task,
|
||||
-- check whether there exists an access type whose designated type is an
|
||||
-- incomplete declarations for the current composite type. If so, build
|
||||
-- the master for that access type, now that it is known to denote an
|
||||
-- object with tasks.
|
||||
|
||||
procedure Expand_Derived_Record (T : Entity_Id; Def : Node_Id);
|
||||
-- Add a field _parent in the extension part of the record.
|
||||
|
||||
procedure Build_Discr_Checking_Funcs (N : Node_Id);
|
||||
-- Builds function which checks whether the component name is consistent
|
||||
-- with the current discriminants. N is the full type declaration node,
|
||||
-- and the discriminant checking functions are inserted after this node.
|
||||
|
||||
function Build_Initialization_Call
|
||||
(Loc : Source_Ptr;
|
||||
Id_Ref : Node_Id;
|
||||
Typ : Entity_Id;
|
||||
In_Init_Proc : Boolean := False;
|
||||
Enclos_Type : Entity_Id := Empty;
|
||||
Discr_Map : Elist_Id := New_Elmt_List)
|
||||
return List_Id;
|
||||
-- Builds a call to the initialization procedure of the Id entity. Id_Ref
|
||||
-- is either a new reference to Id (for record fields), or an indexed
|
||||
-- component (for array elements). Loc is the source location for the
|
||||
-- constructed tree, and Typ is the type of the entity (the initialization
|
||||
-- procedure of the base type is the procedure that actually gets called).
|
||||
-- In_Init_Proc has to be set to True when the call is itself in an Init
|
||||
-- procedure in order to enable the use of discriminals. Enclos_type is
|
||||
-- the type of the init_proc and it is used for various expansion cases
|
||||
-- including the case where Typ is a task type which is a array component,
|
||||
-- the indices of the enclosing type are used to build the string that
|
||||
-- identifies each task at runtime.
|
||||
--
|
||||
-- Discr_Map is used to replace discriminants by their discriminals in
|
||||
-- expressions used to constrain record components. In the presence of
|
||||
-- entry families bounded by discriminants, protected type discriminants
|
||||
-- can appear within expressions in array bounds (not as stand-alone
|
||||
-- identifiers) and a general replacement is necessary.
|
||||
|
||||
procedure Freeze_Type (N : Node_Id);
|
||||
-- This procedure executes the freezing actions associated with the given
|
||||
-- freeze type node N.
|
||||
|
||||
function Needs_Simple_Initialization (T : Entity_Id) return Boolean;
|
||||
-- Certain types need initialization even though there is no specific
|
||||
-- initialization routine. In this category are access types (which
|
||||
-- need initializing to null), packed array types whose implementation
|
||||
-- is a modular type, and all scalar types if Normalize_Scalars is set,
|
||||
-- as well as private types whose underlying type is present and meets
|
||||
-- any of these criteria. Finally, descendants of String and Wide_String
|
||||
-- also need initialization in Initialize/Normalize_Scalars mode.
|
||||
|
||||
function Get_Simple_Init_Val
|
||||
(T : Entity_Id;
|
||||
Loc : Source_Ptr)
|
||||
return Node_Id;
|
||||
-- For a type which Needs_Simple_Initialization (see above), prepares
|
||||
-- the tree for an expression representing the required initial value.
|
||||
-- Loc is the source location used in constructing this tree which is
|
||||
-- returned as the result of the call.
|
||||
|
||||
end Exp_Ch3;
|
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,94 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- E X P _ C H 4 --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.42 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- Expand routines for chapter 4 constructs
|
||||
|
||||
with Types; use Types;
|
||||
|
||||
package Exp_Ch4 is
|
||||
|
||||
procedure Expand_N_Allocator (N : Node_Id);
|
||||
procedure Expand_N_And_Then (N : Node_Id);
|
||||
procedure Expand_N_Conditional_Expression (N : Node_Id);
|
||||
procedure Expand_N_In (N : Node_Id);
|
||||
procedure Expand_N_Explicit_Dereference (N : Node_Id);
|
||||
procedure Expand_N_Indexed_Component (N : Node_Id);
|
||||
procedure Expand_N_Not_In (N : Node_Id);
|
||||
procedure Expand_N_Null (N : Node_Id);
|
||||
procedure Expand_N_Op_Abs (N : Node_Id);
|
||||
procedure Expand_N_Op_Add (N : Node_Id);
|
||||
procedure Expand_N_Op_And (N : Node_Id);
|
||||
procedure Expand_N_Op_Concat (N : Node_Id);
|
||||
procedure Expand_N_Op_Divide (N : Node_Id);
|
||||
procedure Expand_N_Op_Expon (N : Node_Id);
|
||||
procedure Expand_N_Op_Eq (N : Node_Id);
|
||||
procedure Expand_N_Op_Ge (N : Node_Id);
|
||||
procedure Expand_N_Op_Gt (N : Node_Id);
|
||||
procedure Expand_N_Op_Le (N : Node_Id);
|
||||
procedure Expand_N_Op_Lt (N : Node_Id);
|
||||
procedure Expand_N_Op_Minus (N : Node_Id);
|
||||
procedure Expand_N_Op_Mod (N : Node_Id);
|
||||
procedure Expand_N_Op_Multiply (N : Node_Id);
|
||||
procedure Expand_N_Op_Ne (N : Node_Id);
|
||||
procedure Expand_N_Op_Not (N : Node_Id);
|
||||
procedure Expand_N_Op_Or (N : Node_Id);
|
||||
procedure Expand_N_Op_Plus (N : Node_Id);
|
||||
procedure Expand_N_Op_Rem (N : Node_Id);
|
||||
procedure Expand_N_Op_Rotate_Left (N : Node_Id);
|
||||
procedure Expand_N_Op_Rotate_Right (N : Node_Id);
|
||||
procedure Expand_N_Op_Shift_Left (N : Node_Id);
|
||||
procedure Expand_N_Op_Shift_Right (N : Node_Id);
|
||||
procedure Expand_N_Op_Shift_Right_Arithmetic (N : Node_Id);
|
||||
procedure Expand_N_Op_Subtract (N : Node_Id);
|
||||
procedure Expand_N_Op_Xor (N : Node_Id);
|
||||
procedure Expand_N_Or_Else (N : Node_Id);
|
||||
procedure Expand_N_Qualified_Expression (N : Node_Id);
|
||||
procedure Expand_N_Selected_Component (N : Node_Id);
|
||||
procedure Expand_N_Slice (N : Node_Id);
|
||||
procedure Expand_N_Type_Conversion (N : Node_Id);
|
||||
procedure Expand_N_Unchecked_Expression (N : Node_Id);
|
||||
procedure Expand_N_Unchecked_Type_Conversion (N : Node_Id);
|
||||
|
||||
function Expand_Record_Equality
|
||||
(Nod : Node_Id;
|
||||
Typ : Entity_Id;
|
||||
Lhs : Node_Id;
|
||||
Rhs : Node_Id;
|
||||
Bodies : List_Id)
|
||||
return Node_Id;
|
||||
-- Expand a record equality into an expression that compares the fields
|
||||
-- individually to yield the required Boolean result. Loc is the
|
||||
-- location for the generated nodes. Typ is the type of the record, and
|
||||
-- Lhs, Rhs are the record expressions to be compared, these
|
||||
-- expressions need not to be analyzed but have to be side-effect free.
|
||||
-- Bodies is a list on which to attach bodies of local functions that
|
||||
-- are created in the process. This is the responsability of the caller
|
||||
-- to insert those bodies at the right place. Nod provdies the Sloc
|
||||
-- value for generated code.
|
||||
|
||||
end Exp_Ch4;
|
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,42 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- E X P _ C H 5 --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.15 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-1999, 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- Expand routines for chapter 5 constructs
|
||||
|
||||
with Types; use Types;
|
||||
|
||||
package Exp_Ch5 is
|
||||
procedure Expand_N_Assignment_Statement (N : Node_Id);
|
||||
procedure Expand_N_Block_Statement (N : Node_Id);
|
||||
procedure Expand_N_Case_Statement (N : Node_Id);
|
||||
procedure Expand_N_Exit_Statement (N : Node_Id);
|
||||
procedure Expand_N_Goto_Statement (N : Node_Id);
|
||||
procedure Expand_N_If_Statement (N : Node_Id);
|
||||
procedure Expand_N_Loop_Statement (N : Node_Id);
|
||||
procedure Expand_N_Return_Statement (N : Node_Id);
|
||||
end Exp_Ch5;
|
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,50 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- E X P _ C H 6 --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.13 $ --
|
||||
-- --
|
||||
-- Copyright (C) 1992,1993,1994,1995 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- Expand routines for chapter 6 constructs
|
||||
|
||||
with Types; use Types;
|
||||
|
||||
package Exp_Ch6 is
|
||||
|
||||
procedure Expand_N_Function_Call (N : Node_Id);
|
||||
procedure Expand_N_Subprogram_Body (N : Node_Id);
|
||||
procedure Expand_N_Subprogram_Body_Stub (N : Node_Id);
|
||||
procedure Expand_N_Subprogram_Declaration (N : Node_Id);
|
||||
procedure Expand_N_Procedure_Call_Statement (N : Node_Id);
|
||||
|
||||
procedure Expand_Call (N : Node_Id);
|
||||
-- This procedure contains common processing for Expand_N_Function_Call,
|
||||
-- Expand_N_Procedure_Statement, and Expand_N_Entry_Call.
|
||||
|
||||
procedure Freeze_Subprogram (N : Node_Id);
|
||||
-- generate the appropriate expansions related to Subprogram freeze
|
||||
-- nodes (e. g. the filling of the corresponding Dispatch Table for
|
||||
-- Primitive Operations)
|
||||
|
||||
end Exp_Ch6;
|
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,194 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- E X P _ C H 7 --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.42 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-2000 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Types; use Types;
|
||||
|
||||
package Exp_Ch7 is
|
||||
|
||||
procedure Expand_N_Package_Body (N : Node_Id);
|
||||
procedure Expand_N_Package_Declaration (N : Node_Id);
|
||||
|
||||
------------------------------
|
||||
-- Finalization Management --
|
||||
------------------------------
|
||||
|
||||
function In_Finalization_Root (E : Entity_Id) return Boolean;
|
||||
-- True if current scope is in package System.Finalization_Root. Used
|
||||
-- to avoid certain expansions that would involve circularity in the
|
||||
-- Rtsfind mechanism.
|
||||
|
||||
procedure Build_Final_List (N : Node_Id; Typ : Entity_Id);
|
||||
-- Build finalization list for anonymous access types, and for access
|
||||
-- types that are frozen before their designated types are known to
|
||||
-- be controlled.
|
||||
|
||||
procedure Build_Controlling_Procs (Typ : Entity_Id);
|
||||
-- Typ is a record, and array type having controlled components.
|
||||
-- Create the procedures Deep_Initialize, Deep_Adjust and Deep_Finalize
|
||||
-- that take care of finalization management at run-time.
|
||||
|
||||
function Controller_Component (Typ : Entity_Id) return Entity_Id;
|
||||
-- Returns the entity of the component whose name is 'Name_uController'
|
||||
|
||||
function Controlled_Type (T : Entity_Id) return Boolean;
|
||||
-- True if T potentially needs finalization actions
|
||||
|
||||
function Find_Final_List
|
||||
(E : Entity_Id;
|
||||
Ref : Node_Id := Empty)
|
||||
return Node_Id;
|
||||
-- E is an entity representing a controlled object, a controlled type
|
||||
-- or a scope. If Ref is not empty, it is a reference to a controlled
|
||||
-- record, the closest Final list is in the controller component of
|
||||
-- the record containing Ref otherwise this function returns a
|
||||
-- reference to the final list attached to the closest dynamic scope
|
||||
-- (that can be E itself) creating this final list if necessary.
|
||||
|
||||
function Has_New_Controlled_Component (E : Entity_Id) return Boolean;
|
||||
-- E is a type entity. Give the same resul as Has_Controlled_Component
|
||||
-- except for tagged extensions where the result is True only if the
|
||||
-- latest extension contains a controlled component.
|
||||
|
||||
function Make_Attach_Call
|
||||
(Obj_Ref : Node_Id;
|
||||
Flist_Ref : Node_Id;
|
||||
With_Attach : Node_Id)
|
||||
return Node_Id;
|
||||
-- Attach the referenced object to the referenced Final Chain
|
||||
-- 'Flist_Ref' With_Attach is an expression of type Short_Short_Integer
|
||||
-- which can be either '0' to signify no attachment, '1' for
|
||||
-- attachement to a simply linked list or '2' for attachement to a
|
||||
-- doubly linked list.
|
||||
|
||||
function Make_Init_Call
|
||||
(Ref : Node_Id;
|
||||
Typ : Entity_Id;
|
||||
Flist_Ref : Node_Id;
|
||||
With_Attach : Node_Id)
|
||||
return List_Id;
|
||||
-- Ref is an expression (with no-side effect and is not required to
|
||||
-- have been previously analyzed) that references the object to be
|
||||
-- initialized. Typ is the expected type of Ref, which is a controlled
|
||||
-- type (Is_Controlled) or a type with controlled components
|
||||
-- (Has_Controlled). 'Dynamic_Case' controls the way the object is
|
||||
-- attached which is different whether the object is dynamically
|
||||
-- allocated or not.
|
||||
--
|
||||
-- This function will generate the appropriate calls to make
|
||||
-- sure that the objects referenced by Ref are initialized. The
|
||||
-- generate code is quite different depending on the fact the type
|
||||
-- IS_Controlled or HAS_Controlled but this is not the problem of the
|
||||
-- caller, the details are in the body.
|
||||
|
||||
function Make_Adjust_Call
|
||||
(Ref : Node_Id;
|
||||
Typ : Entity_Id;
|
||||
Flist_Ref : Node_Id;
|
||||
With_Attach : Node_Id)
|
||||
return List_Id;
|
||||
-- Ref is an expression (with no-side effect and is not required to
|
||||
-- have been previously analyzed) that references the object to be
|
||||
-- adjusted. Typ is the expected type of Ref, which is a controlled
|
||||
-- type (Is_Controlled) or a type with controlled components
|
||||
-- (Has_Controlled).
|
||||
--
|
||||
-- This function will generate the appropriate calls to make
|
||||
-- sure that the objects referenced by Ref are adjusted. The generated
|
||||
-- code is quite different depending on the fact the type IS_Controlled
|
||||
-- or HAS_Controlled but this is not the problem of the caller, the
|
||||
-- details are in the body. If the parameter With_Attach is set to
|
||||
-- True, the finalizable objects involved are attached to the proper
|
||||
-- finalization chain. The objects must be attached when the adjust
|
||||
-- takes place after an initialization expression but not when it takes
|
||||
-- place after a regular assignment.
|
||||
--
|
||||
-- The description of With_Attach is completely obsolete ???
|
||||
|
||||
function Make_Final_Call
|
||||
(Ref : Node_Id;
|
||||
Typ : Entity_Id;
|
||||
With_Detach : Node_Id)
|
||||
return List_Id;
|
||||
-- Ref is an expression (with no-side effect and is not required to
|
||||
-- have been previously analyzed) that references the object
|
||||
-- to be Finalized. Typ is the expected type of Ref, which is a
|
||||
-- controlled type (Is_Controlled) or a type with controlled
|
||||
-- components (Has_Controlled).
|
||||
--
|
||||
-- This function will generate the appropriate calls to make
|
||||
-- sure that the objects referenced by Ref are finalized. The generated
|
||||
-- code is quite different depending on the fact the type IS_Controlled
|
||||
-- or HAS_Controlled but this is not the problem of the caller, the
|
||||
-- details are in the body. If the parameter With_Detach is set to
|
||||
-- True, the finalizable objects involved are detached from the proper
|
||||
-- finalization chain. The objects must be detached when finalizing an
|
||||
-- unchecked deallocated object but not when finalizing the target of
|
||||
-- an assignment, it is not necessary either on scope exit.
|
||||
|
||||
procedure Expand_Ctrl_Function_Call (N : Node_Id);
|
||||
-- Expand a call to a function returning a controlled value. That is to
|
||||
-- say attach the result of the call to the current finalization list,
|
||||
-- which is the one of the transient scope created for such constructs.
|
||||
|
||||
--------------------------------
|
||||
-- Transient Scope Management --
|
||||
--------------------------------
|
||||
|
||||
procedure Expand_Cleanup_Actions (N : Node_Id);
|
||||
-- Expand the necessary stuff into a scope to enable finalization of local
|
||||
-- objects and deallocation of transient data when exiting the scope. N is
|
||||
-- a "scope node" that is to say one of the following: N_Block_Statement,
|
||||
-- N_Subprogram_Body, N_Task_Body, N_Entry_Body.
|
||||
|
||||
procedure Establish_Transient_Scope (N : Node_Id; Sec_Stack : Boolean);
|
||||
-- Push a new transient scope on the scope stack. N is the node responsible
|
||||
-- for the need of a transient scope. If Sec_Stack is True then the
|
||||
-- secondary stack is brought in, otherwise it isn't.
|
||||
|
||||
function Node_To_Be_Wrapped return Node_Id;
|
||||
-- return the node to be wrapped if the current scope is transient.
|
||||
|
||||
procedure Store_Before_Actions_In_Scope (L : List_Id);
|
||||
-- Append the list L of actions to the end of the before-actions store
|
||||
-- in the top of the scope stack
|
||||
|
||||
procedure Store_After_Actions_In_Scope (L : List_Id);
|
||||
-- Append the list L of actions to the beginning of the after-actions
|
||||
-- store in the top of the scope stack
|
||||
|
||||
procedure Wrap_Transient_Declaration (N : Node_Id);
|
||||
-- N is an object declaration. Expand the finalization calls after the
|
||||
-- declaration and make the outer scope beeing the transient one.
|
||||
|
||||
procedure Wrap_Transient_Expression (N : Node_Id);
|
||||
-- N is a sub-expression. Expand a transient block around an expression
|
||||
|
||||
procedure Wrap_Transient_Statement (N : Node_Id);
|
||||
-- N is a statement. Expand a transient block around an instruction
|
||||
|
||||
end Exp_Ch7;
|
|
@ -0,0 +1,282 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- E X P _ C H 8 --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.27 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Atree; use Atree;
|
||||
with Einfo; use Einfo;
|
||||
with Exp_Dbug; use Exp_Dbug;
|
||||
with Exp_Util; use Exp_Util;
|
||||
with Nlists; use Nlists;
|
||||
with Sem; use Sem;
|
||||
with Sem_Ch8; use Sem_Ch8;
|
||||
with Sinfo; use Sinfo;
|
||||
with Stand; use Stand;
|
||||
|
||||
package body Exp_Ch8 is
|
||||
|
||||
---------------------------------------------
|
||||
-- Expand_N_Exception_Renaming_Declaration --
|
||||
---------------------------------------------
|
||||
|
||||
procedure Expand_N_Exception_Renaming_Declaration (N : Node_Id) is
|
||||
Decl : constant Node_Id := Debug_Renaming_Declaration (N);
|
||||
|
||||
begin
|
||||
if Present (Decl) then
|
||||
Insert_Action (N, Decl);
|
||||
end if;
|
||||
end Expand_N_Exception_Renaming_Declaration;
|
||||
|
||||
------------------------------------------
|
||||
-- Expand_N_Object_Renaming_Declaration --
|
||||
------------------------------------------
|
||||
|
||||
-- Most object renaming cases can be done by just capturing the address
|
||||
-- of the renamed object. The cases in which this is not true are when
|
||||
-- this address is not computable, since it involves extraction of a
|
||||
-- packed array element, or of a record component to which a component
|
||||
-- clause applies (that can specify an arbitrary bit boundary).
|
||||
|
||||
-- In these two cases, we pre-evaluate the renaming expression, by
|
||||
-- extracting and freezing the values of any subscripts, and then we
|
||||
-- set the flag Is_Renaming_Of_Object which means that any reference
|
||||
-- to the object will be handled by macro substitution in the front
|
||||
-- end, and the back end will know to ignore the renaming declaration.
|
||||
|
||||
-- The other special processing required is for the case of renaming
|
||||
-- of an object of a class wide type, where it is necessary to build
|
||||
-- the appropriate subtype for the renamed object.
|
||||
-- More comments needed for this para ???
|
||||
|
||||
procedure Expand_N_Object_Renaming_Declaration (N : Node_Id) is
|
||||
Nam : Node_Id := Name (N);
|
||||
T : Entity_Id;
|
||||
Decl : Node_Id;
|
||||
|
||||
procedure Evaluate_Name (Fname : Node_Id);
|
||||
-- A recursive procedure used to freeze a name in the sense described
|
||||
-- above, i.e. any variable references or function calls are removed.
|
||||
-- Of course the outer level variable reference must not be removed.
|
||||
-- For example in A(J,F(K)), A is left as is, but J and F(K) are
|
||||
-- evaluated and removed.
|
||||
|
||||
function Evaluation_Required (Nam : Node_Id) return Boolean;
|
||||
-- Determines whether it is necessary to do static name evaluation
|
||||
-- for renaming of Nam. It is considered necessary if evaluating the
|
||||
-- name involves indexing a packed array, or extracting a component
|
||||
-- of a record to which a component clause applies. Note that we are
|
||||
-- only interested in these operations if they occur as part of the
|
||||
-- name itself, subscripts are just values that are computed as part
|
||||
-- of the evaluation, so their form is unimportant.
|
||||
|
||||
-------------------
|
||||
-- Evaluate_Name --
|
||||
-------------------
|
||||
|
||||
procedure Evaluate_Name (Fname : Node_Id) is
|
||||
K : constant Node_Kind := Nkind (Fname);
|
||||
E : Node_Id;
|
||||
|
||||
begin
|
||||
-- For an explicit dereference, we simply force the evaluation
|
||||
-- of the name expression. The dereference provides a value that
|
||||
-- is the address for the renamed object, and it is precisely
|
||||
-- this value that we want to preserve.
|
||||
|
||||
if K = N_Explicit_Dereference then
|
||||
Force_Evaluation (Prefix (Fname));
|
||||
|
||||
-- For a selected component, we simply evaluate the prefix
|
||||
|
||||
elsif K = N_Selected_Component then
|
||||
Evaluate_Name (Prefix (Fname));
|
||||
|
||||
-- For an indexed component, or an attribute reference, we evaluate
|
||||
-- the prefix, which is itself a name, recursively, and then force
|
||||
-- the evaluation of all the subscripts (or attribute expressions).
|
||||
|
||||
elsif K = N_Indexed_Component
|
||||
or else K = N_Attribute_Reference
|
||||
then
|
||||
Evaluate_Name (Prefix (Fname));
|
||||
|
||||
E := First (Expressions (Fname));
|
||||
while Present (E) loop
|
||||
Force_Evaluation (E);
|
||||
|
||||
if Original_Node (E) /= E then
|
||||
Set_Do_Range_Check (E, Do_Range_Check (Original_Node (E)));
|
||||
end if;
|
||||
|
||||
Next (E);
|
||||
end loop;
|
||||
|
||||
-- For a slice, we evaluate the prefix, as for the indexed component
|
||||
-- case and then, if there is a range present, either directly or
|
||||
-- as the constraint of a discrete subtype indication, we evaluate
|
||||
-- the two bounds of this range.
|
||||
|
||||
elsif K = N_Slice then
|
||||
Evaluate_Name (Prefix (Fname));
|
||||
|
||||
declare
|
||||
DR : constant Node_Id := Discrete_Range (Fname);
|
||||
Constr : Node_Id;
|
||||
Rexpr : Node_Id;
|
||||
|
||||
begin
|
||||
if Nkind (DR) = N_Range then
|
||||
Force_Evaluation (Low_Bound (DR));
|
||||
Force_Evaluation (High_Bound (DR));
|
||||
|
||||
elsif Nkind (DR) = N_Subtype_Indication then
|
||||
Constr := Constraint (DR);
|
||||
|
||||
if Nkind (Constr) = N_Range_Constraint then
|
||||
Rexpr := Range_Expression (Constr);
|
||||
|
||||
Force_Evaluation (Low_Bound (Rexpr));
|
||||
Force_Evaluation (High_Bound (Rexpr));
|
||||
end if;
|
||||
end if;
|
||||
end;
|
||||
|
||||
-- For a type conversion, the expression of the conversion must be
|
||||
-- the name of an object, and we simply need to evaluate this name.
|
||||
|
||||
elsif K = N_Type_Conversion then
|
||||
Evaluate_Name (Expression (Fname));
|
||||
|
||||
-- For a function call, we evaluate the call.
|
||||
|
||||
elsif K = N_Function_Call then
|
||||
Force_Evaluation (Fname);
|
||||
|
||||
-- The remaining cases are direct name, operator symbol and
|
||||
-- character literal. In all these cases, we do nothing, since
|
||||
-- we want to reevaluate each time the renamed object is used.
|
||||
|
||||
else
|
||||
return;
|
||||
end if;
|
||||
end Evaluate_Name;
|
||||
|
||||
-------------------------
|
||||
-- Evaluation_Required --
|
||||
-------------------------
|
||||
|
||||
function Evaluation_Required (Nam : Node_Id) return Boolean is
|
||||
begin
|
||||
if Nkind (Nam) = N_Indexed_Component
|
||||
or else Nkind (Nam) = N_Slice
|
||||
then
|
||||
if Is_Packed (Etype (Prefix (Nam))) then
|
||||
return True;
|
||||
else
|
||||
return Evaluation_Required (Prefix (Nam));
|
||||
end if;
|
||||
|
||||
elsif Nkind (Nam) = N_Selected_Component then
|
||||
if Present (Component_Clause (Entity (Selector_Name (Nam)))) then
|
||||
return True;
|
||||
else
|
||||
return Evaluation_Required (Prefix (Nam));
|
||||
end if;
|
||||
|
||||
else
|
||||
return False;
|
||||
end if;
|
||||
end Evaluation_Required;
|
||||
|
||||
-- Start of processing for Expand_N_Object_Renaming_Declaration
|
||||
|
||||
begin
|
||||
-- Perform name evaluation if required
|
||||
|
||||
if Evaluation_Required (Nam) then
|
||||
Evaluate_Name (Nam);
|
||||
Set_Is_Renaming_Of_Object (Defining_Identifier (N));
|
||||
end if;
|
||||
|
||||
-- Deal with construction of subtype in class-wide case
|
||||
|
||||
T := Etype (Defining_Identifier (N));
|
||||
|
||||
if Is_Class_Wide_Type (T) then
|
||||
Expand_Subtype_From_Expr (N, T, Subtype_Mark (N), Name (N));
|
||||
Find_Type (Subtype_Mark (N));
|
||||
Set_Etype (Defining_Identifier (N), Entity (Subtype_Mark (N)));
|
||||
end if;
|
||||
|
||||
-- Create renaming entry for debug information
|
||||
|
||||
Decl := Debug_Renaming_Declaration (N);
|
||||
|
||||
if Present (Decl) then
|
||||
Insert_Action (N, Decl);
|
||||
end if;
|
||||
end Expand_N_Object_Renaming_Declaration;
|
||||
|
||||
-------------------------------------------
|
||||
-- Expand_N_Package_Renaming_Declaration --
|
||||
-------------------------------------------
|
||||
|
||||
procedure Expand_N_Package_Renaming_Declaration (N : Node_Id) is
|
||||
Decl : constant Node_Id := Debug_Renaming_Declaration (N);
|
||||
|
||||
begin
|
||||
if Present (Decl) then
|
||||
|
||||
-- If we are in a compilation unit, then this is an outer
|
||||
-- level declaration, and must have a scope of Standard
|
||||
|
||||
if Nkind (Parent (N)) = N_Compilation_Unit then
|
||||
declare
|
||||
Aux : constant Node_Id := Aux_Decls_Node (Parent (N));
|
||||
|
||||
begin
|
||||
New_Scope (Standard_Standard);
|
||||
|
||||
if No (Actions (Aux)) then
|
||||
Set_Actions (Aux, New_List (Decl));
|
||||
else
|
||||
Append (Decl, Actions (Aux));
|
||||
end if;
|
||||
|
||||
Analyze (Decl);
|
||||
Pop_Scope;
|
||||
end;
|
||||
|
||||
-- Otherwise, just insert after the package declaration
|
||||
|
||||
else
|
||||
Insert_Action (N, Decl);
|
||||
end if;
|
||||
end if;
|
||||
end Expand_N_Package_Renaming_Declaration;
|
||||
|
||||
end Exp_Ch8;
|
|
@ -0,0 +1,37 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- E X P _ C H 8 --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.7 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-2000 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- Expand routines for chapter 8 constructs
|
||||
|
||||
with Types; use Types;
|
||||
|
||||
package Exp_Ch8 is
|
||||
procedure Expand_N_Exception_Renaming_Declaration (N : Node_Id);
|
||||
procedure Expand_N_Object_Renaming_Declaration (N : Node_Id);
|
||||
procedure Expand_N_Package_Renaming_Declaration (N : Node_Id);
|
||||
end Exp_Ch8;
|
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,312 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- E X P _ C H 9 --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.56 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-1999 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- Expand routines for chapter 9 constructs
|
||||
|
||||
with Types; use Types;
|
||||
|
||||
package Exp_Ch9 is
|
||||
|
||||
procedure Add_Discriminal_Declarations
|
||||
(Decls : List_Id;
|
||||
Typ : Entity_Id;
|
||||
Name : Name_Id;
|
||||
Loc : Source_Ptr);
|
||||
-- This routine is used to add discriminal declarations to task and
|
||||
-- protected operation bodies. The discriminants are available by normal
|
||||
-- selection from the concurrent object (whose name is passed as the third
|
||||
-- parameter). Discriminant references inside the body have already
|
||||
-- been replaced by references to the corresponding discriminals. The
|
||||
-- declarations constructed by this procedure hook the references up with
|
||||
-- the objects:
|
||||
--
|
||||
-- discriminal_name : discr_type renames name.discriminant_name;
|
||||
--
|
||||
-- Obviously we could have expanded the discriminant references in the
|
||||
-- first place to be the appropriate selection, but this turns out to
|
||||
-- be hard to do because it would introduce difference in handling of
|
||||
-- discriminant references depending on their location.
|
||||
|
||||
procedure Add_Private_Declarations
|
||||
(Decls : List_Id;
|
||||
Typ : Entity_Id;
|
||||
Name : Name_Id;
|
||||
Loc : Source_Ptr);
|
||||
-- This routine is used to add private declarations to protected bodies.
|
||||
-- These are analogous to the discriminal declarations added to tasks
|
||||
-- and protected operations, and consist of a renaming of each private
|
||||
-- object to a selection from the concurrent object passed as an extra
|
||||
-- parameter to each such operation:
|
||||
-- private_name : private_type renames name.private_name;
|
||||
-- As with discriminals, private references inside the protected
|
||||
-- subprogram bodies have already been replaced by references to the
|
||||
-- corresponding privals.
|
||||
|
||||
procedure Build_Activation_Chain_Entity (N : Node_Id);
|
||||
-- Given a declaration N of an object that is a task, or contains tasks
|
||||
-- (other than allocators to tasks) this routine ensures that an activation
|
||||
-- chain has been declared in the appropriate scope, building the required
|
||||
-- declaration for the chain variable if not. The name of this variable
|
||||
-- is always _Chain and it is accessed by name. This procedure also adds
|
||||
-- an appropriate call to Activate_Tasks to activate the tasks for this
|
||||
-- activation chain. It does not however deal with the call needed in the
|
||||
-- case of allocators to Expunge_Unactivated_Tasks, this is separately
|
||||
-- handled in the Expand_Task_Allocator routine.
|
||||
|
||||
function Build_Call_With_Task (N : Node_Id; E : Entity_Id) return Node_Id;
|
||||
-- N is a node representing the name of a task or an access to a task.
|
||||
-- The value returned is a call to the function whose name is the entity
|
||||
-- E (typically a runtime routine entity obtained using RTE) with the
|
||||
-- Task_Id of the associated task as the parameter. The caller is
|
||||
-- responsible for analyzing and resolving the resulting tree.
|
||||
|
||||
procedure Build_Master_Entity (E : Entity_Id);
|
||||
-- Given an entity E for the declaration of an object containing tasks
|
||||
-- or of a type declaration for an allocator whose designated type is a
|
||||
-- task or contains tasks, this routine marks the appropriate enclosing
|
||||
-- context as a master, and also declares a variable called _Master in
|
||||
-- the current declarative part which captures the value of Current_Master
|
||||
-- (if not already built by a prior call). We build this object (instead
|
||||
-- of just calling Current_Master) for two reasons. First it is clearly
|
||||
-- more efficient to call Current_Master only once for a bunch of tasks
|
||||
-- in the same declarative part, and second it makes things easier in
|
||||
-- generating the initialization routines, since they can just reference
|
||||
-- the object _Master by name, and they will get the proper Current_Master
|
||||
-- value at the outer level, and copy in the parameter value for the outer
|
||||
-- initialization call if the call is for a nested component). Note that
|
||||
-- in the case of nested packages, we only really need to make one such
|
||||
-- object at the outer level, but it is much easier to generate one per
|
||||
-- declarative part.
|
||||
|
||||
function Build_Protected_Sub_Specification
|
||||
(N : Node_Id;
|
||||
Prottyp : Entity_Id;
|
||||
Unprotected : Boolean := False)
|
||||
return Node_Id;
|
||||
-- Build specification for protected subprogram. This is called when
|
||||
-- expanding a protected type, and also when expanding the declaration for
|
||||
-- an Access_To_Protected_Subprogram type. In the latter case, Prottyp is
|
||||
-- empty, and the first parameter of the signature of the protected op is
|
||||
-- of type System.Address.
|
||||
|
||||
procedure Build_Protected_Subprogram_Call
|
||||
(N : Node_Id;
|
||||
Name : Node_Id;
|
||||
Rec : Node_Id;
|
||||
External : Boolean := True);
|
||||
-- The node N is a subprogram or entry call to a protected subprogram.
|
||||
-- This procedure rewrites this call with the appropriate expansion.
|
||||
-- Name is the subprogram, and Rec is the record corresponding to the
|
||||
-- protected object. External is False if the call is to another
|
||||
-- protected subprogram within the same object.
|
||||
|
||||
procedure Build_Task_Activation_Call (N : Node_Id);
|
||||
-- This procedure is called for constructs that can be task activators
|
||||
-- i.e. task bodies, subprogram bodies, package bodies and blocks. If
|
||||
-- the construct is a task activator (as indicated by the non-empty
|
||||
-- setting of Activation_Chain_Entity, either in the construct, or, in
|
||||
-- the case of a package body, in its associated package spec), then
|
||||
-- a call to Activate_Tasks with this entity as the single parameter
|
||||
-- is inserted at the start of the statements of the activator.
|
||||
|
||||
procedure Build_Task_Allocate_Block
|
||||
(Actions : List_Id;
|
||||
N : Node_Id;
|
||||
Args : List_Id);
|
||||
-- This routine is used in the case of allocators where the designated
|
||||
-- type is a task or contains tasks. In this case, the normal initialize
|
||||
-- call is replaced by:
|
||||
--
|
||||
-- blockname : label;
|
||||
-- blockname : declare
|
||||
-- _Chain : Activation_Chain;
|
||||
--
|
||||
-- procedure _Expunge is
|
||||
-- begin
|
||||
-- Expunge_Unactivated_Tasks (_Chain);
|
||||
-- end;
|
||||
--
|
||||
-- begin
|
||||
-- Init (Args);
|
||||
-- Activate_Tasks (_Chain);
|
||||
-- at end
|
||||
-- _Expunge;
|
||||
-- end;
|
||||
--
|
||||
-- to get the task or tasks created and initialized. The expunge call
|
||||
-- ensures that any tasks that get created but not activated due to an
|
||||
-- exception are properly expunged (it has no effect in the normal case)
|
||||
-- The argument N is the allocator, and Args is the list of arguments
|
||||
-- for the initialization call, constructed by the caller, which uses
|
||||
-- the Master_Id of the access type as the _Master parameter, and _Chain
|
||||
-- (defined above) as the _Chain parameter.
|
||||
|
||||
function Concurrent_Ref (N : Node_Id) return Node_Id;
|
||||
-- Given the name of a concurrent object (task or protected object), or
|
||||
-- the name of an access to a concurrent object, this function returns an
|
||||
-- expression referencing the associated Task_Id or Protection object,
|
||||
-- respectively. Note that a special case is when the name is a reference
|
||||
-- to a task type name. This can only happen within a task body, and the
|
||||
-- meaning is to get the Task_Id for the currently executing task.
|
||||
|
||||
function Convert_Concurrent
|
||||
(N : Node_Id;
|
||||
Typ : Entity_Id)
|
||||
return Node_Id;
|
||||
-- N is an expression of type Typ. If the type is not a concurrent
|
||||
-- type then it is returned unchanged. If it is a task or protected
|
||||
-- reference, Convert_Concurrent creates an unchecked conversion node
|
||||
-- from this expression to the corresponding concurrent record type
|
||||
-- value. We need this in any situation where the concurrent type is
|
||||
-- used, because the actual concurrent object is an object of the
|
||||
-- corresponding concurrent type, and manipulations on the concurrent
|
||||
-- object actually manipulate the corresponding object of the record
|
||||
-- type.
|
||||
|
||||
function Entry_Index_Expression
|
||||
(Sloc : Source_Ptr;
|
||||
Ent : Entity_Id;
|
||||
Index : Node_Id;
|
||||
Ttyp : Entity_Id)
|
||||
return Node_Id;
|
||||
-- Returns an expression to compute a task entry index given the name
|
||||
-- of the entry or entry family. For the case of a task entry family,
|
||||
-- the Index parameter contains the expression for the subscript.
|
||||
-- Ttyp is the task type.
|
||||
|
||||
procedure Establish_Task_Master (N : Node_Id);
|
||||
-- Given a subprogram body, or a block statement, or a task body, this
|
||||
-- proccedure makes the necessary transformations required of a task
|
||||
-- master (add Enter_Master call at start, and establish a cleanup
|
||||
-- routine to make sure Complete_Master is called on exit).
|
||||
|
||||
procedure Expand_Access_Protected_Subprogram_Type (N : Node_Id);
|
||||
-- Build Equivalent_Type for an Access_to_protected_Subprogram.
|
||||
|
||||
procedure Expand_Accept_Declarations (N : Node_Id; Ent : Entity_Id);
|
||||
-- Expand declarations required for accept statement. See bodies of
|
||||
-- both Expand_Accept_Declarations and Expand_N_Accept_Statement for
|
||||
-- full details of the nature and use of these declarations, which
|
||||
-- are inserted immediately before the accept node N. The second
|
||||
-- argument is the entity for the corresponding entry.
|
||||
|
||||
procedure Expand_Entry_Barrier (N : Node_Id; Ent : Entity_Id);
|
||||
-- Expand the entry barrier into a function. This is called directly
|
||||
-- from Analyze_Entry_Body so that the discriminals and privals of the
|
||||
-- barrier can be attached to the function declaration list, and a new
|
||||
-- set prepared for the entry body procedure, bedore the entry body
|
||||
-- statement sequence can be expanded. The resulting function is analyzed
|
||||
-- now, within the context of the protected object, to resolve calls to
|
||||
-- other protected functions.
|
||||
|
||||
procedure Expand_Entry_Body_Declarations (N : Node_Id);
|
||||
-- Expand declarations required for the expansion of the
|
||||
-- statements of the body.
|
||||
|
||||
procedure Expand_N_Abort_Statement (N : Node_Id);
|
||||
procedure Expand_N_Accept_Statement (N : Node_Id);
|
||||
procedure Expand_N_Asynchronous_Select (N : Node_Id);
|
||||
procedure Expand_N_Conditional_Entry_Call (N : Node_Id);
|
||||
procedure Expand_N_Delay_Relative_Statement (N : Node_Id);
|
||||
procedure Expand_N_Delay_Until_Statement (N : Node_Id);
|
||||
procedure Expand_N_Entry_Body (N : Node_Id);
|
||||
procedure Expand_N_Entry_Call_Statement (N : Node_Id);
|
||||
procedure Expand_N_Entry_Declaration (N : Node_Id);
|
||||
procedure Expand_N_Protected_Body (N : Node_Id);
|
||||
|
||||
procedure Expand_N_Protected_Type_Declaration (N : Node_Id);
|
||||
-- Expands protected type declarations. This results, among
|
||||
-- other things, in the declaration of a record type for the
|
||||
-- representation of protected objects and (if there are entries)
|
||||
-- in an entry service procedure. The Protection value used by
|
||||
-- the GNARL to control the object will always be the first
|
||||
-- field of the record, and the entry service procedure spec
|
||||
-- (if it exists) will always immediately follow the record
|
||||
-- declaration. This allows these two nodes to be found from
|
||||
-- the type using Corresponding_Record, without benefit of
|
||||
-- of further attributes.
|
||||
|
||||
procedure Expand_N_Requeue_Statement (N : Node_Id);
|
||||
procedure Expand_N_Selective_Accept (N : Node_Id);
|
||||
procedure Expand_N_Single_Task_Declaration (N : Node_Id);
|
||||
procedure Expand_N_Task_Body (N : Node_Id);
|
||||
procedure Expand_N_Task_Type_Declaration (N : Node_Id);
|
||||
procedure Expand_N_Timed_Entry_Call (N : Node_Id);
|
||||
|
||||
procedure Expand_Protected_Body_Declarations
|
||||
(N : Node_Id;
|
||||
Spec_Id : Entity_Id);
|
||||
-- Expand declarations required for a protected body. See bodies of
|
||||
-- both Expand_Protected_Body_Declarations and Expand_N_Protected_Body
|
||||
-- for full details of the nature and use of these declarations.
|
||||
-- The second argument is the entity for the corresponding
|
||||
-- protected type declaration.
|
||||
|
||||
function External_Subprogram (E : Entity_Id) return Entity_Id;
|
||||
-- return the external version of a protected operation, which locks
|
||||
-- the object before invoking the internal protected subprogram body.
|
||||
|
||||
function First_Protected_Operation (D : List_Id) return Node_Id;
|
||||
-- Given the declarations list for a protected body, find the
|
||||
-- first protected operation body.
|
||||
|
||||
function Make_Task_Create_Call (Task_Rec : Entity_Id) return Node_Id;
|
||||
-- Given the entity of the record type created for a task type, build
|
||||
-- the call to Create_Task
|
||||
|
||||
function Make_Initialize_Protection
|
||||
(Protect_Rec : Entity_Id)
|
||||
return List_Id;
|
||||
-- Given the entity of the record type created for a protected type, build
|
||||
-- a list of statements needed for proper initialization of the object.
|
||||
|
||||
function Next_Protected_Operation (N : Node_Id) return Node_Id;
|
||||
-- Given a protected operation node (a subprogram or entry body),
|
||||
-- find the following node in the declarations list.
|
||||
|
||||
procedure Set_Discriminals
|
||||
(Dec : Node_Id;
|
||||
Op : Node_Id;
|
||||
Loc : Source_Ptr);
|
||||
-- Replace discriminals in a protected type for use by the
|
||||
-- next protected operation on the type. Each operation needs a
|
||||
-- new set of discirminals, since it needs a unique renaming of
|
||||
-- the discriminant fields in the record used to implement the
|
||||
-- protected type.
|
||||
|
||||
procedure Set_Privals
|
||||
(Dec : Node_Id;
|
||||
Op : Node_Id;
|
||||
Loc : Source_Ptr);
|
||||
-- Associates a new set of privals (placeholders for later access to
|
||||
-- private components of protected objects) with the private object
|
||||
-- declarations of a protected object. These will be used to expand
|
||||
-- the references to private objects in the next protected
|
||||
-- subprogram or entry body to be expanded.
|
||||
|
||||
end Exp_Ch9;
|
|
@ -0,0 +1,499 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- E X P _ C O D E --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.17 $
|
||||
-- --
|
||||
-- Copyright (C) 1996-2001 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Atree; use Atree;
|
||||
with Einfo; use Einfo;
|
||||
with Errout; use Errout;
|
||||
with Fname; use Fname;
|
||||
with Lib; use Lib;
|
||||
with Namet; use Namet;
|
||||
with Nlists; use Nlists;
|
||||
with Nmake; use Nmake;
|
||||
with Opt; use Opt;
|
||||
with Rtsfind; use Rtsfind;
|
||||
with Sem_Eval; use Sem_Eval;
|
||||
with Sem_Util; use Sem_Util;
|
||||
with Sinfo; use Sinfo;
|
||||
with Stringt; use Stringt;
|
||||
with Tbuild; use Tbuild;
|
||||
|
||||
package body Exp_Code is
|
||||
|
||||
-----------------------
|
||||
-- Local_Subprograms --
|
||||
-----------------------
|
||||
|
||||
function Asm_Constraint (Operand_Var : Node_Id) return Node_Id;
|
||||
-- Common processing for Asm_Input_Constraint and Asm_Output_Constraint.
|
||||
-- Obtains the constraint argument from the global operand variable
|
||||
-- Operand_Var, which must be non-Empty.
|
||||
|
||||
function Asm_Operand (Operand_Var : Node_Id) return Node_Id;
|
||||
-- Common processing for Asm_Input_Value and Asm_Output_Variable. Obtains
|
||||
-- the value/variable argument from Operand_Var, the global operand
|
||||
-- variable. Returns Empty if no operand available.
|
||||
|
||||
function Get_String_Node (S : Node_Id) return Node_Id;
|
||||
-- Given S, a static expression node of type String, returns the
|
||||
-- string literal node. This is needed to deal with the use of constants
|
||||
-- for these expressions, which is perfectly permissible.
|
||||
|
||||
procedure Next_Asm_Operand (Operand_Var : in out Node_Id);
|
||||
-- Common processing for Next_Asm_Input and Next_Asm_Output, updates
|
||||
-- the value of the global operand variable Operand_Var appropriately.
|
||||
|
||||
procedure Setup_Asm_IO_Args (Arg : Node_Id; Operand_Var : out Node_Id);
|
||||
-- Common processing for Setup_Asm_Inputs and Setup_Asm_Outputs. Arg
|
||||
-- is the actual parameter from the call, and Operand_Var is the global
|
||||
-- operand variable to be initialized to the first operand.
|
||||
|
||||
----------------------
|
||||
-- Global Variables --
|
||||
----------------------
|
||||
|
||||
Current_Input_Operand : Node_Id := Empty;
|
||||
-- Points to current Asm_Input_Operand attribute reference. Initialized
|
||||
-- by Setup_Asm_Inputs, updated by Next_Asm_Input, and referenced by
|
||||
-- Asm_Input_Constraint and Asm_Input_Value.
|
||||
|
||||
Current_Output_Operand : Node_Id := Empty;
|
||||
-- Points to current Asm_Output_Operand attribute reference. Initialized
|
||||
-- by Setup_Asm_Outputs, updated by Next_Asm_Output, and referenced by
|
||||
-- Asm_Output_Constraint and Asm_Output_Variable.
|
||||
|
||||
--------------------
|
||||
-- Asm_Constraint --
|
||||
--------------------
|
||||
|
||||
function Asm_Constraint (Operand_Var : Node_Id) return Node_Id is
|
||||
begin
|
||||
pragma Assert (Present (Operand_Var));
|
||||
return Get_String_Node (First (Expressions (Operand_Var)));
|
||||
end Asm_Constraint;
|
||||
|
||||
--------------------------
|
||||
-- Asm_Input_Constraint --
|
||||
--------------------------
|
||||
|
||||
-- Note: error checking on Asm_Input attribute done in Sem_Attr
|
||||
|
||||
function Asm_Input_Constraint return Node_Id is
|
||||
begin
|
||||
return Get_String_Node (Asm_Constraint (Current_Input_Operand));
|
||||
end Asm_Input_Constraint;
|
||||
|
||||
---------------------
|
||||
-- Asm_Input_Value --
|
||||
---------------------
|
||||
|
||||
-- Note: error checking on Asm_Input attribute done in Sem_Attr
|
||||
|
||||
function Asm_Input_Value return Node_Id is
|
||||
begin
|
||||
return Asm_Operand (Current_Input_Operand);
|
||||
end Asm_Input_Value;
|
||||
|
||||
-----------------
|
||||
-- Asm_Operand --
|
||||
-----------------
|
||||
|
||||
function Asm_Operand (Operand_Var : Node_Id) return Node_Id is
|
||||
begin
|
||||
if No (Operand_Var) then
|
||||
return Empty;
|
||||
else
|
||||
return Next (First (Expressions (Operand_Var)));
|
||||
end if;
|
||||
end Asm_Operand;
|
||||
|
||||
---------------------------
|
||||
-- Asm_Output_Constraint --
|
||||
---------------------------
|
||||
|
||||
-- Note: error checking on Asm_Output attribute done in Sem_Attr
|
||||
|
||||
function Asm_Output_Constraint return Node_Id is
|
||||
begin
|
||||
return Asm_Constraint (Current_Output_Operand);
|
||||
end Asm_Output_Constraint;
|
||||
|
||||
-------------------------
|
||||
-- Asm_Output_Variable --
|
||||
-------------------------
|
||||
|
||||
-- Note: error checking on Asm_Output attribute done in Sem_Attr
|
||||
|
||||
function Asm_Output_Variable return Node_Id is
|
||||
begin
|
||||
return Asm_Operand (Current_Output_Operand);
|
||||
end Asm_Output_Variable;
|
||||
|
||||
------------------
|
||||
-- Asm_Template --
|
||||
------------------
|
||||
|
||||
function Asm_Template (N : Node_Id) return Node_Id is
|
||||
Call : constant Node_Id := Expression (Expression (N));
|
||||
Temp : constant Node_Id := First_Actual (Call);
|
||||
|
||||
begin
|
||||
-- Require static expression for template. We also allow a string
|
||||
-- literal (this is useful for Ada 83 mode where string expressions
|
||||
-- are never static).
|
||||
|
||||
if Is_OK_Static_Expression (Temp)
|
||||
or else (Ada_83 and then Nkind (Temp) = N_String_Literal)
|
||||
then
|
||||
return Get_String_Node (Temp);
|
||||
|
||||
else
|
||||
Error_Msg_N ("asm template argument is not static", Temp);
|
||||
return Empty;
|
||||
end if;
|
||||
end Asm_Template;
|
||||
|
||||
----------------------
|
||||
-- Clobber_Get_Next --
|
||||
----------------------
|
||||
|
||||
Clobber_Node : Node_Id;
|
||||
-- String literal node for clobber string. Initialized by Clobber_Setup,
|
||||
-- and not modified by Clobber_Get_Next. Empty if clobber string was in
|
||||
-- error (resulting in no clobber arguments being returned).
|
||||
|
||||
Clobber_Ptr : Nat;
|
||||
-- Pointer to current character of string. Initialized to 1 by the call
|
||||
-- to Clobber_Setup, and then updated by Clobber_Get_Next.
|
||||
|
||||
function Clobber_Get_Next return Address is
|
||||
Str : constant String_Id := Strval (Clobber_Node);
|
||||
Len : constant Nat := String_Length (Str);
|
||||
C : Character;
|
||||
|
||||
begin
|
||||
if No (Clobber_Node) then
|
||||
return Null_Address;
|
||||
end if;
|
||||
|
||||
-- Skip spaces and commas before next register name
|
||||
|
||||
loop
|
||||
-- Return null string if no more names
|
||||
|
||||
if Clobber_Ptr > Len then
|
||||
return Null_Address;
|
||||
end if;
|
||||
|
||||
C := Get_Character (Get_String_Char (Str, Clobber_Ptr));
|
||||
exit when C /= ',' and then C /= ' ';
|
||||
Clobber_Ptr := Clobber_Ptr + 1;
|
||||
end loop;
|
||||
|
||||
-- Acquire next register name
|
||||
|
||||
Name_Len := 0;
|
||||
loop
|
||||
Name_Len := Name_Len + 1;
|
||||
Name_Buffer (Name_Len) := C;
|
||||
Clobber_Ptr := Clobber_Ptr + 1;
|
||||
exit when Clobber_Ptr > Len;
|
||||
C := Get_Character (Get_String_Char (Str, Clobber_Ptr));
|
||||
exit when C = ',' or else C = ' ';
|
||||
end loop;
|
||||
|
||||
Name_Buffer (Name_Len + 1) := ASCII.NUL;
|
||||
return Name_Buffer'Address;
|
||||
|
||||
end Clobber_Get_Next;
|
||||
|
||||
-------------------
|
||||
-- Clobber_Setup --
|
||||
-------------------
|
||||
|
||||
procedure Clobber_Setup (N : Node_Id) is
|
||||
Call : constant Node_Id := Expression (Expression (N));
|
||||
Clob : constant Node_Id := Next_Actual (
|
||||
Next_Actual (
|
||||
Next_Actual (
|
||||
First_Actual (Call))));
|
||||
|
||||
begin
|
||||
if not Is_OK_Static_Expression (Clob) then
|
||||
Error_Msg_N ("asm clobber argument is not static", Clob);
|
||||
Clobber_Node := Empty;
|
||||
|
||||
else
|
||||
Clobber_Node := Get_String_Node (Clob);
|
||||
Clobber_Ptr := 1;
|
||||
end if;
|
||||
end Clobber_Setup;
|
||||
|
||||
---------------------
|
||||
-- Expand_Asm_Call --
|
||||
---------------------
|
||||
|
||||
procedure Expand_Asm_Call (N : Node_Id) is
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
|
||||
procedure Check_IO_Operand (N : Node_Id);
|
||||
-- Check for incorrect input or output operand
|
||||
|
||||
procedure Check_IO_Operand (N : Node_Id) is
|
||||
Err : Node_Id := N;
|
||||
|
||||
begin
|
||||
-- The only identifier allows is No_xxput_Operands. Since we
|
||||
-- know the type is right, it is sufficient to see if the
|
||||
-- referenced entity is in a runtime routine.
|
||||
|
||||
if Nkind (N) = N_Identifier
|
||||
and then
|
||||
Is_Predefined_File_Name (Unit_File_Name
|
||||
(Get_Source_Unit (Entity (N))))
|
||||
then
|
||||
return;
|
||||
|
||||
-- An attribute reference is fine, again the analysis reasonably
|
||||
-- guarantees that the attribute must be subtype'Asm_??put.
|
||||
|
||||
elsif Nkind (N) = N_Attribute_Reference then
|
||||
return;
|
||||
|
||||
-- The only other allowed form is an array aggregate in which
|
||||
-- all the entries are positional and are attribute references.
|
||||
|
||||
elsif Nkind (N) = N_Aggregate then
|
||||
if Present (Component_Associations (N)) then
|
||||
Err := First (Component_Associations (N));
|
||||
|
||||
elsif Present (Expressions (N)) then
|
||||
Err := First (Expressions (N));
|
||||
while Present (Err) loop
|
||||
exit when Nkind (Err) /= N_Attribute_Reference;
|
||||
Next (Err);
|
||||
end loop;
|
||||
|
||||
if No (Err) then
|
||||
return;
|
||||
end if;
|
||||
end if;
|
||||
end if;
|
||||
|
||||
-- If we fall through, Err is pointing to the bad node
|
||||
|
||||
Error_Msg_N ("Asm operand has wrong form", Err);
|
||||
end Check_IO_Operand;
|
||||
|
||||
-- Start of processing for Expand_Asm_Call
|
||||
|
||||
begin
|
||||
-- Check that the input and output operands have the right
|
||||
-- form, as required by the documentation of the Asm feature:
|
||||
|
||||
-- OUTPUT_OPERAND_LIST ::=
|
||||
-- No_Output_Operands
|
||||
-- | OUTPUT_OPERAND_ATTRIBUTE
|
||||
-- | (OUTPUT_OPERAND_ATTRIBUTE @{,OUTPUT_OPERAND_ATTRIBUTE@})
|
||||
|
||||
-- OUTPUT_OPERAND_ATTRIBUTE ::=
|
||||
-- SUBTYPE_MARK'Asm_Output (static_string_EXPRESSION, NAME)
|
||||
|
||||
-- INPUT_OPERAND_LIST ::=
|
||||
-- No_Input_Operands
|
||||
-- | INPUT_OPERAND_ATTRIBUTE
|
||||
-- | (INPUT_OPERAND_ATTRIBUTE @{,INPUT_OPERAND_ATTRIBUTE@})
|
||||
|
||||
-- INPUT_OPERAND_ATTRIBUTE ::=
|
||||
-- SUBTYPE_MARK'Asm_Input (static_string_EXPRESSION, EXPRESSION)
|
||||
|
||||
declare
|
||||
Arg_Output : constant Node_Id := Next_Actual (First_Actual (N));
|
||||
Arg_Input : constant Node_Id := Next_Actual (Arg_Output);
|
||||
|
||||
begin
|
||||
Check_IO_Operand (Arg_Output);
|
||||
Check_IO_Operand (Arg_Input);
|
||||
end;
|
||||
|
||||
-- If we have the function call case, we are inside a code statement,
|
||||
-- and the tree is already in the necessary form for gigi.
|
||||
|
||||
if Nkind (N) = N_Function_Call then
|
||||
null;
|
||||
|
||||
-- For the procedure case, we convert the call into a code statement
|
||||
|
||||
else
|
||||
pragma Assert (Nkind (N) = N_Procedure_Call_Statement);
|
||||
|
||||
-- Note: strictly we should change the procedure call to a function
|
||||
-- call in the qualified expression, but since we are not going to
|
||||
-- reanalyze (see below), and the interface subprograms in this
|
||||
-- package don't care, we can leave it as a procedure call.
|
||||
|
||||
Rewrite (N,
|
||||
Make_Code_Statement (Loc,
|
||||
Expression =>
|
||||
Make_Qualified_Expression (Loc,
|
||||
Subtype_Mark => New_Occurrence_Of (RTE (RE_Asm_Insn), Loc),
|
||||
Expression => Relocate_Node (N))));
|
||||
|
||||
-- There is no need to reanalyze this node, it is completely analyzed
|
||||
-- already, at least sufficiently for the purposes of the abstract
|
||||
-- procedural interface defined in this package.
|
||||
|
||||
Set_Analyzed (N);
|
||||
end if;
|
||||
end Expand_Asm_Call;
|
||||
|
||||
---------------------
|
||||
-- Get_String_Node --
|
||||
---------------------
|
||||
|
||||
function Get_String_Node (S : Node_Id) return Node_Id is
|
||||
begin
|
||||
if Nkind (S) = N_String_Literal then
|
||||
return S;
|
||||
|
||||
else
|
||||
pragma Assert (Ekind (Entity (S)) = E_Constant);
|
||||
return Get_String_Node (Constant_Value (Entity (S)));
|
||||
end if;
|
||||
end Get_String_Node;
|
||||
|
||||
---------------------
|
||||
-- Is_Asm_Volatile --
|
||||
---------------------
|
||||
|
||||
function Is_Asm_Volatile (N : Node_Id) return Boolean is
|
||||
Call : constant Node_Id := Expression (Expression (N));
|
||||
Vol : constant Node_Id :=
|
||||
Next_Actual (
|
||||
Next_Actual (
|
||||
Next_Actual (
|
||||
Next_Actual (
|
||||
First_Actual (Call)))));
|
||||
|
||||
begin
|
||||
if not Is_OK_Static_Expression (Vol) then
|
||||
Error_Msg_N ("asm volatile argument is not static", Vol);
|
||||
return False;
|
||||
|
||||
else
|
||||
return Is_True (Expr_Value (Vol));
|
||||
end if;
|
||||
end Is_Asm_Volatile;
|
||||
|
||||
--------------------
|
||||
-- Next_Asm_Input --
|
||||
--------------------
|
||||
|
||||
procedure Next_Asm_Input is
|
||||
begin
|
||||
Next_Asm_Operand (Current_Input_Operand);
|
||||
end Next_Asm_Input;
|
||||
|
||||
----------------------
|
||||
-- Next_Asm_Operand --
|
||||
----------------------
|
||||
|
||||
procedure Next_Asm_Operand (Operand_Var : in out Node_Id) is
|
||||
begin
|
||||
pragma Assert (Present (Operand_Var));
|
||||
|
||||
if Nkind (Parent (Operand_Var)) = N_Aggregate then
|
||||
Operand_Var := Next (Operand_Var);
|
||||
|
||||
else
|
||||
Operand_Var := Empty;
|
||||
end if;
|
||||
end Next_Asm_Operand;
|
||||
|
||||
---------------------
|
||||
-- Next_Asm_Output --
|
||||
---------------------
|
||||
|
||||
procedure Next_Asm_Output is
|
||||
begin
|
||||
Next_Asm_Operand (Current_Output_Operand);
|
||||
end Next_Asm_Output;
|
||||
|
||||
----------------------
|
||||
-- Setup_Asm_Inputs --
|
||||
----------------------
|
||||
|
||||
procedure Setup_Asm_Inputs (N : Node_Id) is
|
||||
Call : constant Node_Id := Expression (Expression (N));
|
||||
|
||||
begin
|
||||
Setup_Asm_IO_Args
|
||||
(Next_Actual (Next_Actual (First_Actual (Call))),
|
||||
Current_Input_Operand);
|
||||
end Setup_Asm_Inputs;
|
||||
|
||||
-----------------------
|
||||
-- Setup_Asm_IO_Args --
|
||||
-----------------------
|
||||
|
||||
procedure Setup_Asm_IO_Args (Arg : Node_Id; Operand_Var : out Node_Id) is
|
||||
begin
|
||||
-- Case of single argument
|
||||
|
||||
if Nkind (Arg) = N_Attribute_Reference then
|
||||
Operand_Var := Arg;
|
||||
|
||||
-- Case of list of arguments
|
||||
|
||||
elsif Nkind (Arg) = N_Aggregate then
|
||||
if Expressions (Arg) = No_List then
|
||||
Operand_Var := Empty;
|
||||
else
|
||||
Operand_Var := First (Expressions (Arg));
|
||||
end if;
|
||||
|
||||
-- Otherwise must be default (no operands) case
|
||||
|
||||
else
|
||||
Operand_Var := Empty;
|
||||
end if;
|
||||
end Setup_Asm_IO_Args;
|
||||
|
||||
-----------------------
|
||||
-- Setup_Asm_Outputs --
|
||||
-----------------------
|
||||
|
||||
procedure Setup_Asm_Outputs (N : Node_Id) is
|
||||
Call : constant Node_Id := Expression (Expression (N));
|
||||
|
||||
begin
|
||||
Setup_Asm_IO_Args
|
||||
(Next_Actual (First_Actual (Call)),
|
||||
Current_Output_Operand);
|
||||
end Setup_Asm_Outputs;
|
||||
|
||||
end Exp_Code;
|
|
@ -0,0 +1,125 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- E X P _ C O D E --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.5 $ --
|
||||
-- --
|
||||
-- Copyright (C) 1996 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- Processing for handling code statements
|
||||
|
||||
with Types; use Types;
|
||||
|
||||
with System; use System;
|
||||
package Exp_Code is
|
||||
|
||||
procedure Expand_Asm_Call (N : Node_Id);
|
||||
-- Expands a call to Asm or Asm_Volatile into an equivalent
|
||||
-- N_Code_Statement node.
|
||||
|
||||
-- The following routines provide an abstract interface to analyze
|
||||
-- code statements, for use by Gigi processing for code statements.
|
||||
-- Note that the implementations of these routines must not attempt
|
||||
-- to expand tables that are frozen on entry to Gigi.
|
||||
|
||||
function Is_Asm_Volatile (N : Node_Id) return Boolean;
|
||||
-- Given an N_Code_Statement node N, return True in the Asm_Volatile
|
||||
-- case and False in the Asm case.
|
||||
|
||||
function Asm_Template (N : Node_Id) return Node_Id;
|
||||
-- Given an N_Code_Statement node N, returns string literal node for
|
||||
-- template in call
|
||||
|
||||
procedure Clobber_Setup (N : Node_Id);
|
||||
-- Given an N_Code_Statement node N, setup to process the clobber list
|
||||
-- with subsequent calls to Clobber_Get_Next.
|
||||
|
||||
function Clobber_Get_Next return System.Address;
|
||||
-- Can only be called after a previous call to Clobber_Setup. The
|
||||
-- returned value is a pointer to a null terminated (C format) string
|
||||
-- for the next register argument. Null_Address is returned when there
|
||||
-- are no more arguments.
|
||||
|
||||
procedure Setup_Asm_Inputs (N : Node_Id);
|
||||
-- Given an N_Code_Statement node N, setup to read list of Asm_Input
|
||||
-- arguments. The protocol is to construct a loop as follows:
|
||||
--
|
||||
-- Setup_Asm_Inputs (N);
|
||||
-- while Present (Asm_Input_Value)
|
||||
-- body
|
||||
-- Next_Asm_Input;
|
||||
-- end loop;
|
||||
--
|
||||
-- where the loop body calls Asm_Input_Constraint or Asm_Input_Value to
|
||||
-- obtain the constraint string or input value expression from the current
|
||||
-- Asm_Input argument.
|
||||
|
||||
function Asm_Input_Constraint return Node_Id;
|
||||
-- Called within a loop initialized by Setup_Asm_Inputs and controlled
|
||||
-- by Next_Asm_Input as described above. Returns a string literal node
|
||||
-- for the constraint component of the current Asm_Input_Parameter, or
|
||||
-- Empty if there are no more Asm_Input parameters.
|
||||
|
||||
function Asm_Input_Value return Node_Id;
|
||||
-- Called within a loop initialized by Setup_Asm_Inputs and controlled
|
||||
-- by Next_Asm_Input as described above. Returns the expression node for
|
||||
-- the value component of the current Asm_Input parameter, or Empty if
|
||||
-- there are no more Asm_Input parameters.
|
||||
|
||||
procedure Next_Asm_Input;
|
||||
-- Step to next Asm_Input parameter. It is an error to call this procedure
|
||||
-- if there are no more available parameters (which is impossible if the
|
||||
-- call appears in a loop as in the above example).
|
||||
|
||||
procedure Setup_Asm_Outputs (N : Node_Id);
|
||||
-- Given an N_Code_Statement node N, setup to read list of Asm_Output
|
||||
-- arguments. The protocol is to construct a loop as follows:
|
||||
--
|
||||
-- Setup_Asm_Outputs (N);
|
||||
-- while Present (Asm_Output_Value)
|
||||
-- body
|
||||
-- Next_Asm_Output;
|
||||
-- end loop;
|
||||
--
|
||||
-- where the loop body calls Asm_Output_Constraint or Asm_Output_Variable
|
||||
-- to obtain the constraint string or output variable name from the current
|
||||
-- Asm_Output argument.
|
||||
|
||||
function Asm_Output_Constraint return Node_Id;
|
||||
-- Called within a loop initialized by Setup_Asm_Outputs and controlled
|
||||
-- by Next_Asm_Output as described above. Returns a string literal node
|
||||
-- for the constraint component of the current Asm_Output_Parameter, or
|
||||
-- Empty if there are no more Asm_Output parameters.
|
||||
|
||||
function Asm_Output_Variable return Node_Id;
|
||||
-- Called within a loop initialized by Setup_Asm_Outputs and controlled
|
||||
-- by Next_Asm_Output as described above. Returns the expression node for
|
||||
-- the output variable component of the current Asm_Output parameter, or
|
||||
-- Empty if there are no more Asm_Output parameters.
|
||||
|
||||
procedure Next_Asm_Output;
|
||||
-- Step to next Asm_Output parameter. It is an error to call this procedure
|
||||
-- if there are no more available parameters (which is impossible if the
|
||||
-- call appears in a loop as in the above example).
|
||||
|
||||
end Exp_Code;
|
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,96 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- E X P _ D I S P --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.9 $ --
|
||||
-- --
|
||||
-- Copyright (C) 1992-1998 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This package contains routines involved in tagged types and dynamic
|
||||
-- dispatching expansion
|
||||
|
||||
with Types; use Types;
|
||||
package Exp_Disp is
|
||||
|
||||
type DT_Access_Action is
|
||||
(CW_Membership,
|
||||
DT_Entry_Size,
|
||||
DT_Prologue_Size,
|
||||
Get_Expanded_Name,
|
||||
Get_External_Tag,
|
||||
Get_Prim_Op_Address,
|
||||
Get_RC_Offset,
|
||||
Get_Remotely_Callable,
|
||||
Get_TSD,
|
||||
Inherit_DT,
|
||||
Inherit_TSD,
|
||||
Register_Tag,
|
||||
Set_Expanded_Name,
|
||||
Set_External_Tag,
|
||||
Set_Prim_Op_Address,
|
||||
Set_RC_Offset,
|
||||
Set_Remotely_Callable,
|
||||
Set_TSD,
|
||||
TSD_Entry_Size,
|
||||
TSD_Prologue_Size);
|
||||
|
||||
|
||||
function Fill_DT_Entry
|
||||
(Loc : Source_Ptr;
|
||||
Prim : Entity_Id)
|
||||
return Node_Id;
|
||||
-- Generate the code necessary to fill the appropriate entry of the
|
||||
-- dispatch table of Prim's controlling type with Prim's address.
|
||||
|
||||
function Make_DT_Access_Action
|
||||
(Typ : Entity_Id;
|
||||
Action : DT_Access_Action;
|
||||
Args : List_Id)
|
||||
return Node_Id;
|
||||
-- Generate a call to one of the Dispatch Table Access Subprograms defined
|
||||
-- in Ada.Tags or in Interfaces.Cpp
|
||||
|
||||
function Make_DT (Typ : Entity_Id) return List_Id;
|
||||
-- Expand the declarations for the Dispatch Table (or the Vtable in
|
||||
-- the case of type whose ancestor is a CPP_Class)
|
||||
|
||||
procedure Set_All_DT_Position (Typ : Entity_Id);
|
||||
-- Set the DT_Position field for each primitive operation. In the CPP
|
||||
-- Class case check that no pragma CPP_Virtual is missing and that the
|
||||
-- DT_Position are coherent
|
||||
|
||||
procedure Expand_Dispatch_Call (Call_Node : Node_Id);
|
||||
-- Expand the call to the operation through the dispatch table and perform
|
||||
-- the required tag checks when appropriate. For CPP types the call is
|
||||
-- done through the Vtable (tag checks are not relevant)
|
||||
|
||||
procedure Set_Default_Constructor (Typ : Entity_Id);
|
||||
-- Typ is a CPP_Class type. Create the Init procedure of that type to
|
||||
-- be the default constructor (i.e. the function returning this type,
|
||||
-- having a pragma CPP_Constructor and no parameter)
|
||||
|
||||
function Get_Remotely_Callable (Obj : Node_Id) return Node_Id;
|
||||
-- Return an expression that holds True if the object can be transmitted
|
||||
-- onto another partition according to E.4 (18)
|
||||
|
||||
end Exp_Disp;
|
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,83 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- E X P _ D I S T --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.18 $ --
|
||||
-- --
|
||||
-- Copyright (C) 1992-1998 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This package contains utility routines used for the generation of the
|
||||
-- stubs relevant to the distribution annex.
|
||||
|
||||
with Types; use Types;
|
||||
|
||||
package Exp_Dist is
|
||||
|
||||
procedure Add_RAST_Features (Vis_Decl : in Node_Id);
|
||||
-- Build and add bodies for dereference and 'Access subprograms for a
|
||||
-- remote access to subprogram type. Vis_Decl is the declaration node for
|
||||
-- the RAS type.
|
||||
|
||||
procedure Add_RACW_Features (RACW_Type : in Entity_Id);
|
||||
-- Add RACW features. If the RACW and the designated type are not in the
|
||||
-- same scope, then Add_RACW_Primitive_Declarations_And_Bodies is called
|
||||
-- automatically since we do know the primitive list already.
|
||||
|
||||
procedure Add_RACW_Primitive_Declarations_And_Bodies
|
||||
(Designated_Type : in Entity_Id;
|
||||
Insertion_Node : in Node_Id;
|
||||
Decls : in List_Id);
|
||||
-- Add primitive for the stub type, and the RPC receiver. The declarations
|
||||
-- are inserted after insertion_Node, while the bodies are appened at the
|
||||
-- end of Decls.
|
||||
|
||||
procedure Remote_Types_Tagged_Full_View_Encountered
|
||||
(Full_View : in Entity_Id);
|
||||
-- When a full view with a private view is encountered in a Remote_Types
|
||||
-- package and corresponds to a tagged type, then this procedure is called
|
||||
-- to generate the needed RACW features if it is needed.
|
||||
|
||||
procedure RACW_Type_Is_Asynchronous (RACW_Type : in Entity_Id);
|
||||
-- This subprogram must be called when it is detected that the RACW type
|
||||
-- is asynchronous.
|
||||
|
||||
procedure Expand_Calling_Stubs_Bodies (Unit_Node : in Node_Id);
|
||||
-- Call the expansion phase for the calling stubs. The code will be added
|
||||
-- at the end of the compilation unit, which is a package spec.
|
||||
|
||||
procedure Expand_Receiving_Stubs_Bodies (Unit_Node : in Node_Id);
|
||||
-- Call the expansion phase for the calling stubs. The code will be added
|
||||
-- at the end of the compilation unit, which may be either a package spec
|
||||
-- or a package body.
|
||||
|
||||
procedure Expand_All_Calls_Remote_Subprogram_Call (N : in Node_Id);
|
||||
-- Rewrite a call to a subprogram located in a Remote_Call_Interface
|
||||
-- package on which the pragma All_Calls_Remote applies so that it
|
||||
-- goes through the PCS. N is either an N_Procedure_Call_Statement
|
||||
-- or an N_Function_Call node.
|
||||
|
||||
procedure Build_Passive_Partition_Stub (U : Node_Id);
|
||||
-- Build stub for a shared passive package. U is the analyzed
|
||||
-- compilation unit for a package declaration.
|
||||
|
||||
end Exp_Dist;
|
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,143 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- E X P _ F I X D --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.5 $ --
|
||||
-- --
|
||||
-- Copyright (C) 1992,1993,1994 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- Expand routines for fixed-point convert, divide and multiply operations
|
||||
|
||||
with Types; use Types;
|
||||
|
||||
package Exp_Fixd is
|
||||
|
||||
-- General note on universal fixed. In the routines below, a fixed-point
|
||||
-- type is always a specific fixed-point type or universal real, never
|
||||
-- universal fixed. Universal fixed only appears as the result type of a
|
||||
-- division or multplication and in all such cases, the parent node, which
|
||||
-- must be either a conversion node or a 'Round attribute reference node,
|
||||
-- has the specific type information. In both cases, the parent node is
|
||||
-- removed from the tree, and the appropriate routine in this package is
|
||||
-- called with a multiply or divide node with all types (and also possibly
|
||||
-- the Rounded_Result flag) set.
|
||||
|
||||
----------------------------
|
||||
-- Fixed-Point Conversion --
|
||||
----------------------------
|
||||
|
||||
procedure Expand_Convert_Fixed_To_Fixed (N : Node_Id);
|
||||
-- This routine expands the conversion of one fixed-point type to another,
|
||||
-- N is the N_Op_Conversion node with the result and expression types (and
|
||||
-- possibly the Rounded_Result flag) set.
|
||||
|
||||
procedure Expand_Convert_Fixed_To_Float (N : Node_Id);
|
||||
-- This routine expands the conversion from a fixed-point type to a
|
||||
-- floating-point type. N is an N_Type_Conversion node with the result
|
||||
-- and expression types set.
|
||||
|
||||
procedure Expand_Convert_Fixed_To_Integer (N : Node_Id);
|
||||
-- This routine expands the conversion from a fixed-point type to an
|
||||
-- integer type. N is an N_Type_Conversion node with the result and
|
||||
-- operand types set.
|
||||
|
||||
procedure Expand_Convert_Float_To_Fixed (N : Node_Id);
|
||||
-- This routine expands the conversion from a floating-point type to
|
||||
-- a fixed-point type. N is an N_Type_Conversion node with the result
|
||||
-- and operand types (and possibly the Rounded_Result flag) set.
|
||||
|
||||
procedure Expand_Convert_Integer_To_Fixed (N : Node_Id);
|
||||
-- This routine expands the conversion from an integer type to a
|
||||
-- fixed-point type. N is an N_Type_Conversion node with the result
|
||||
-- and operand types (and possibly the Rounded_Result flag) set.
|
||||
|
||||
--------------------------
|
||||
-- Fixed-Point Division --
|
||||
--------------------------
|
||||
|
||||
procedure Expand_Decimal_Divide_Call (N : Node_Id);
|
||||
-- This routine expands a call to the procedure Decimal.Divide. The
|
||||
-- argument N is the N_Function_Call node.
|
||||
|
||||
procedure Expand_Divide_Fixed_By_Fixed_Giving_Fixed (N : Node_Id);
|
||||
-- This routine expands the division between fixed-point types, with
|
||||
-- a fixed-point type result. N is an N_Op_Divide node with operand
|
||||
-- and result types (and possibly the Rounded_Result flag) set. Either
|
||||
-- (but not both) of the operands may be universal real.
|
||||
|
||||
procedure Expand_Divide_Fixed_By_Fixed_Giving_Float (N : Node_Id);
|
||||
-- This routine expands the division between two fixed-point types with
|
||||
-- a floating-point result. N is an N_Op_Divide node with the result
|
||||
-- and operand types set. Either (but not both) of the operands may be
|
||||
-- universal real.
|
||||
|
||||
procedure Expand_Divide_Fixed_By_Fixed_Giving_Integer (N : Node_Id);
|
||||
-- This routine expands the division between two fixed-point types with
|
||||
-- an integer type result. N is an N_Op_Divide node with the result and
|
||||
-- operand types set. Either (but not both) of the operands may be
|
||||
-- universal real.
|
||||
|
||||
procedure Expand_Divide_Fixed_By_Integer_Giving_Fixed (N : Node_Id);
|
||||
-- This routine expands the division between a fixed-point type and
|
||||
-- standard integer type. The result type is the same fixed-point type
|
||||
-- as the operand type. N is an N_Op_Divide node with the result and
|
||||
-- left operand types being the fixed-point type, and the right operand
|
||||
-- type being standard integer (and possibly Rounded_Result set).
|
||||
|
||||
--------------------------------
|
||||
-- Fixed-Point Multiplication --
|
||||
--------------------------------
|
||||
|
||||
procedure Expand_Multiply_Fixed_By_Fixed_Giving_Fixed (N : Node_Id);
|
||||
-- This routine expands the multiplication between fixed-point types
|
||||
-- with a fixed-point type result. N is an N_Op_Multiply node with the
|
||||
-- result and operand types set. Either (but not both) of the operands
|
||||
-- may be universal real.
|
||||
|
||||
procedure Expand_Multiply_Fixed_By_Fixed_Giving_Float (N : Node_Id);
|
||||
-- This routine expands the multiplication between two fixed-point types
|
||||
-- with a floating-point result. N is an N_Op_Multiply node with the
|
||||
-- result and operand types set. Either (but not both) of the operands
|
||||
-- may be universal real.
|
||||
|
||||
procedure Expand_Multiply_Fixed_By_Fixed_Giving_Integer (N : Node_Id);
|
||||
-- This routine expands the multiplication between two fixed-point types
|
||||
-- with an integer result. N is an N_Op_Multiply node with the result
|
||||
-- and operand types set. Either (but not both) of the operands may be
|
||||
-- be universal real.
|
||||
|
||||
procedure Expand_Multiply_Fixed_By_Integer_Giving_Fixed (N : Node_Id);
|
||||
-- This routine expands the multiplication between a fixed-point type and
|
||||
-- a standard integer type. The result type is the same fixed-point type
|
||||
-- as the fixed operand type. N is an N_Op_Multiply node whose result type
|
||||
-- and left operand types are the fixed-point type, and whose right operand
|
||||
-- type is always standard integer.
|
||||
|
||||
procedure Expand_Multiply_Integer_By_Fixed_Giving_Fixed (N : Node_Id);
|
||||
-- This routine expands the multiplication between standard integer and a
|
||||
-- fixed-point type. The result type is the same fixed-point type as the
|
||||
-- the fixed operand type. N is an N_Op_Multiply node whose result type
|
||||
-- and right operand types are the fixed-point type, and whose left operand
|
||||
-- type is always standard integer.
|
||||
|
||||
end Exp_Fixd;
|
|
@ -0,0 +1,862 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- E X P _ I M G V --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.4 $
|
||||
-- --
|
||||
-- Copyright (C) 2001 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Atree; use Atree;
|
||||
with Casing; use Casing;
|
||||
with Checks; use Checks;
|
||||
with Einfo; use Einfo;
|
||||
with Exp_Util; use Exp_Util;
|
||||
with Namet; use Namet;
|
||||
with Nmake; use Nmake;
|
||||
with Nlists; use Nlists;
|
||||
with Opt; use Opt;
|
||||
with Rtsfind; use Rtsfind;
|
||||
with Sem_Res; use Sem_Res;
|
||||
with Sinfo; use Sinfo;
|
||||
with Snames; use Snames;
|
||||
with Stand; use Stand;
|
||||
with Stringt; use Stringt;
|
||||
with Tbuild; use Tbuild;
|
||||
with Ttypes; use Ttypes;
|
||||
with Uintp; use Uintp;
|
||||
|
||||
package body Exp_Imgv is
|
||||
|
||||
------------------------------------
|
||||
-- Build_Enumeration_Image_Tables --
|
||||
------------------------------------
|
||||
|
||||
procedure Build_Enumeration_Image_Tables (E : Entity_Id; N : Node_Id) is
|
||||
Loc : constant Source_Ptr := Sloc (E);
|
||||
Str : String_Id;
|
||||
Ind : List_Id;
|
||||
Lit : Entity_Id;
|
||||
Nlit : Nat;
|
||||
Len : Nat;
|
||||
Estr : Entity_Id;
|
||||
Eind : Entity_Id;
|
||||
Ityp : Node_Id;
|
||||
|
||||
begin
|
||||
-- Nothing to do for other than a root enumeration type
|
||||
|
||||
if E /= Root_Type (E) then
|
||||
return;
|
||||
|
||||
-- Nothing to do if pragma Discard_Names applies
|
||||
|
||||
elsif Discard_Names (E) then
|
||||
return;
|
||||
end if;
|
||||
|
||||
-- Otherwise tables need constructing
|
||||
|
||||
Start_String;
|
||||
Ind := New_List;
|
||||
Lit := First_Literal (E);
|
||||
Len := 1;
|
||||
Nlit := 0;
|
||||
|
||||
loop
|
||||
Append_To (Ind,
|
||||
Make_Integer_Literal (Loc, UI_From_Int (Len)));
|
||||
|
||||
exit when No (Lit);
|
||||
Nlit := Nlit + 1;
|
||||
|
||||
Get_Unqualified_Decoded_Name_String (Chars (Lit));
|
||||
|
||||
if Name_Buffer (1) /= ''' then
|
||||
Set_Casing (All_Upper_Case);
|
||||
end if;
|
||||
|
||||
Store_String_Chars (Name_Buffer (1 .. Name_Len));
|
||||
Len := Len + Int (Name_Len);
|
||||
Next_Literal (Lit);
|
||||
end loop;
|
||||
|
||||
if Len < Int (2 ** (8 - 1)) then
|
||||
Ityp := Standard_Integer_8;
|
||||
elsif Len < Int (2 ** (16 - 1)) then
|
||||
Ityp := Standard_Integer_16;
|
||||
else
|
||||
Ityp := Standard_Integer_32;
|
||||
end if;
|
||||
|
||||
Str := End_String;
|
||||
|
||||
Estr :=
|
||||
Make_Defining_Identifier (Loc,
|
||||
Chars => New_External_Name (Chars (E), 'S'));
|
||||
|
||||
Eind :=
|
||||
Make_Defining_Identifier (Loc,
|
||||
Chars => New_External_Name (Chars (E), 'I'));
|
||||
|
||||
Set_Lit_Strings (E, Estr);
|
||||
Set_Lit_Indexes (E, Eind);
|
||||
|
||||
Insert_Actions (N,
|
||||
New_List (
|
||||
Make_Object_Declaration (Loc,
|
||||
Defining_Identifier => Estr,
|
||||
Constant_Present => True,
|
||||
Object_Definition =>
|
||||
New_Occurrence_Of (Standard_String, Loc),
|
||||
Expression =>
|
||||
Make_String_Literal (Loc,
|
||||
Strval => Str)),
|
||||
|
||||
Make_Object_Declaration (Loc,
|
||||
Defining_Identifier => Eind,
|
||||
Constant_Present => True,
|
||||
|
||||
Object_Definition =>
|
||||
Make_Constrained_Array_Definition (Loc,
|
||||
Discrete_Subtype_Definitions => New_List (
|
||||
Make_Range (Loc,
|
||||
Low_Bound => Make_Integer_Literal (Loc, 0),
|
||||
High_Bound => Make_Integer_Literal (Loc, Nlit))),
|
||||
Subtype_Indication => New_Occurrence_Of (Ityp, Loc)),
|
||||
|
||||
Expression =>
|
||||
Make_Aggregate (Loc,
|
||||
Expressions => Ind))),
|
||||
Suppress => All_Checks);
|
||||
|
||||
end Build_Enumeration_Image_Tables;
|
||||
|
||||
----------------------------
|
||||
-- Expand_Image_Attribute --
|
||||
----------------------------
|
||||
|
||||
-- For all non-enumeration types, and for enumeration types declared
|
||||
-- in packages Standard or System, typ'Image (Val) expands into:
|
||||
|
||||
-- Image_xx (tp (Expr) [, pm])
|
||||
|
||||
-- The name xx and type conversion tp (Expr) (called tv below) depend on
|
||||
-- the root type of Expr. The argument pm is an extra type dependent
|
||||
-- parameter only used in some cases as follows:
|
||||
|
||||
-- For types whose root type is Character
|
||||
-- xx = Character
|
||||
-- tv = Character (Expr)
|
||||
|
||||
-- For types whose root type is Boolean
|
||||
-- xx = Boolean
|
||||
-- tv = Boolean (Expr)
|
||||
|
||||
-- For signed integer types with size <= Integer'Size
|
||||
-- xx = Integer
|
||||
-- tv = Integer (Expr)
|
||||
|
||||
-- For other signed integer types
|
||||
-- xx = Long_Long_Integer
|
||||
-- tv = Long_Long_Integer (Expr)
|
||||
|
||||
-- For modular types with modulus <= System.Unsigned_Types.Unsigned
|
||||
-- xx = Unsigned
|
||||
-- tv = System.Unsigned_Types.Unsigned (Expr)
|
||||
|
||||
-- For other modular integer types
|
||||
-- xx = Long_Long_Unsigned
|
||||
-- tv = System.Unsigned_Types.Long_Long_Unsigned (Expr)
|
||||
|
||||
-- For types whose root type is Wide_Character
|
||||
-- xx = Wide_Character
|
||||
-- tv = Wide_Character (Expr)
|
||||
-- pm = Wide_Character_Encoding_Method
|
||||
|
||||
-- For floating-point types
|
||||
-- xx = Floating_Point
|
||||
-- tv = Long_Long_Float (Expr)
|
||||
-- pm = typ'Digits
|
||||
|
||||
-- For ordinary fixed-point types
|
||||
-- xx = Ordinary_Fixed_Point
|
||||
-- tv = Long_Long_Float (Expr)
|
||||
-- pm = typ'Aft
|
||||
|
||||
-- For decimal fixed-point types with size = Integer'Size
|
||||
-- xx = Decimal
|
||||
-- tv = Integer (Expr)
|
||||
-- pm = typ'Scale
|
||||
|
||||
-- For decimal fixed-point types with size > Integer'Size
|
||||
-- xx = Long_Long_Decimal
|
||||
-- tv = Long_Long_Integer (Expr)
|
||||
-- pm = typ'Scale
|
||||
|
||||
-- Note: for the decimal fixed-point type cases, the conversion is
|
||||
-- done literally without scaling (i.e. the actual expression that
|
||||
-- is generated is Image_xx (tp?(Expr) [, pm])
|
||||
|
||||
-- For enumeration types other than those declared packages Standard
|
||||
-- or System, typ'Image (X) expands into:
|
||||
|
||||
-- Image_Enumeration_NN (typ'Pos (X), typS, typI'Address)
|
||||
|
||||
-- where typS and typI are the entities constructed as described in
|
||||
-- the spec for the procedure Build_Enumeration_Image_Tables and NN
|
||||
-- is 32/16/8 depending on the element type of Lit_Indexes.
|
||||
|
||||
procedure Expand_Image_Attribute (N : Node_Id) is
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
Exprs : constant List_Id := Expressions (N);
|
||||
Pref : constant Node_Id := Prefix (N);
|
||||
Ptyp : constant Entity_Id := Entity (Pref);
|
||||
Rtyp : constant Entity_Id := Root_Type (Ptyp);
|
||||
Expr : constant Node_Id := Relocate_Node (First (Exprs));
|
||||
Imid : RE_Id;
|
||||
Tent : Entity_Id;
|
||||
Arglist : List_Id;
|
||||
Func : RE_Id;
|
||||
Ttyp : Entity_Id;
|
||||
|
||||
begin
|
||||
if Rtyp = Standard_Boolean then
|
||||
Imid := RE_Image_Boolean;
|
||||
Tent := Rtyp;
|
||||
|
||||
elsif Rtyp = Standard_Character then
|
||||
Imid := RE_Image_Character;
|
||||
Tent := Rtyp;
|
||||
|
||||
elsif Rtyp = Standard_Wide_Character then
|
||||
Imid := RE_Image_Wide_Character;
|
||||
Tent := Rtyp;
|
||||
|
||||
elsif Is_Signed_Integer_Type (Rtyp) then
|
||||
if Esize (Rtyp) <= Esize (Standard_Integer) then
|
||||
Imid := RE_Image_Integer;
|
||||
Tent := Standard_Integer;
|
||||
else
|
||||
Imid := RE_Image_Long_Long_Integer;
|
||||
Tent := Standard_Long_Long_Integer;
|
||||
end if;
|
||||
|
||||
elsif Is_Modular_Integer_Type (Rtyp) then
|
||||
if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then
|
||||
Imid := RE_Image_Unsigned;
|
||||
Tent := RTE (RE_Unsigned);
|
||||
else
|
||||
Imid := RE_Image_Long_Long_Unsigned;
|
||||
Tent := RTE (RE_Long_Long_Unsigned);
|
||||
end if;
|
||||
|
||||
elsif Is_Decimal_Fixed_Point_Type (Rtyp) then
|
||||
if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
|
||||
Imid := RE_Image_Decimal;
|
||||
Tent := Standard_Integer;
|
||||
else
|
||||
Imid := RE_Image_Long_Long_Decimal;
|
||||
Tent := Standard_Long_Long_Integer;
|
||||
end if;
|
||||
|
||||
elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then
|
||||
Imid := RE_Image_Ordinary_Fixed_Point;
|
||||
Tent := Standard_Long_Long_Float;
|
||||
|
||||
elsif Is_Floating_Point_Type (Rtyp) then
|
||||
Imid := RE_Image_Floating_Point;
|
||||
Tent := Standard_Long_Long_Float;
|
||||
|
||||
-- Only other possibility is user defined enumeration type
|
||||
|
||||
else
|
||||
if Discard_Names (First_Subtype (Ptyp))
|
||||
or else No (Lit_Strings (Root_Type (Ptyp)))
|
||||
then
|
||||
-- When pragma Discard_Names applies to the first subtype,
|
||||
-- then build (Pref'Pos)'Img.
|
||||
|
||||
Rewrite (N,
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix =>
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix => Pref,
|
||||
Attribute_Name => Name_Pos,
|
||||
Expressions => New_List (Expr)),
|
||||
Attribute_Name =>
|
||||
Name_Img));
|
||||
Analyze_And_Resolve (N, Standard_String);
|
||||
|
||||
else
|
||||
-- Here we get the Image of an enumeration type
|
||||
|
||||
Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
|
||||
|
||||
if Ttyp = Standard_Integer_8 then
|
||||
Func := RE_Image_Enumeration_8;
|
||||
elsif Ttyp = Standard_Integer_16 then
|
||||
Func := RE_Image_Enumeration_16;
|
||||
else
|
||||
Func := RE_Image_Enumeration_32;
|
||||
end if;
|
||||
|
||||
-- Apply a validity check, since it is a bit drastic to
|
||||
-- get a completely junk image value for an invalid value.
|
||||
|
||||
if not Expr_Known_Valid (Expr) then
|
||||
Insert_Valid_Check (Expr);
|
||||
end if;
|
||||
|
||||
Rewrite (N,
|
||||
Make_Function_Call (Loc,
|
||||
Name => New_Occurrence_Of (RTE (Func), Loc),
|
||||
Parameter_Associations => New_List (
|
||||
Make_Attribute_Reference (Loc,
|
||||
Attribute_Name => Name_Pos,
|
||||
Prefix => New_Occurrence_Of (Ptyp, Loc),
|
||||
Expressions => New_List (Expr)),
|
||||
New_Occurrence_Of (Lit_Strings (Rtyp), Loc),
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
|
||||
Attribute_Name => Name_Address))));
|
||||
|
||||
Analyze_And_Resolve (N, Standard_String);
|
||||
end if;
|
||||
|
||||
return;
|
||||
end if;
|
||||
|
||||
-- If we fall through, we have one of the cases that is handled by
|
||||
-- calling one of the System.Img_xx routines.
|
||||
|
||||
Arglist := New_List (Convert_To (Tent, Relocate_Node (Expr)));
|
||||
|
||||
-- For floating-point types, append Digits argument
|
||||
|
||||
if Is_Floating_Point_Type (Rtyp) then
|
||||
Append_To (Arglist,
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix => New_Reference_To (Ptyp, Loc),
|
||||
Attribute_Name => Name_Digits));
|
||||
|
||||
-- For ordinary fixed-point types, append Aft parameter
|
||||
|
||||
elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then
|
||||
Append_To (Arglist,
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix => New_Reference_To (Ptyp, Loc),
|
||||
Attribute_Name => Name_Aft));
|
||||
|
||||
-- For wide character, append encoding method
|
||||
|
||||
elsif Rtyp = Standard_Wide_Character then
|
||||
Append_To (Arglist,
|
||||
Make_Integer_Literal (Loc,
|
||||
Intval => Int (Wide_Character_Encoding_Method)));
|
||||
|
||||
-- For decimal, append Scale and also set to do literal conversion
|
||||
|
||||
elsif Is_Decimal_Fixed_Point_Type (Rtyp) then
|
||||
Append_To (Arglist,
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix => New_Reference_To (Ptyp, Loc),
|
||||
Attribute_Name => Name_Scale));
|
||||
|
||||
Set_Conversion_OK (First (Arglist));
|
||||
Set_Etype (First (Arglist), Tent);
|
||||
end if;
|
||||
|
||||
Rewrite (N,
|
||||
Make_Function_Call (Loc,
|
||||
Name => New_Reference_To (RTE (Imid), Loc),
|
||||
Parameter_Associations => Arglist));
|
||||
|
||||
Analyze_And_Resolve (N, Standard_String);
|
||||
end Expand_Image_Attribute;
|
||||
|
||||
----------------------------
|
||||
-- Expand_Value_Attribute --
|
||||
----------------------------
|
||||
|
||||
-- For scalar types derived from Boolean, Character and integer types
|
||||
-- in package Standard, typ'Value (X) expands into:
|
||||
|
||||
-- btyp (Value_xx (X))
|
||||
|
||||
-- where btyp is he base type of the prefix, and
|
||||
|
||||
-- For types whose root type is Character
|
||||
-- xx = Character
|
||||
|
||||
-- For types whose root type is Boolean
|
||||
-- xx = Boolean
|
||||
|
||||
-- For signed integer types with size <= Integer'Size
|
||||
-- xx = Integer
|
||||
|
||||
-- For other signed integer types
|
||||
-- xx = Long_Long_Integer
|
||||
|
||||
-- For modular types with modulus <= System.Unsigned_Types.Unsigned
|
||||
-- xx = Unsigned
|
||||
|
||||
-- For other modular integer types
|
||||
-- xx = Long_Long_Unsigned
|
||||
|
||||
-- For floating-point types and ordinary fixed-point types
|
||||
-- xx = Real
|
||||
|
||||
-- For types derived from Wide_Character, typ'Value (X) expands into
|
||||
|
||||
-- Value_Wide_Character (X, Wide_Character_Encoding_Method)
|
||||
|
||||
-- For decimal types with size <= Integer'Size, typ'Value (X)
|
||||
-- expands into
|
||||
|
||||
-- btyp?(Value_Decimal (X, typ'Scale));
|
||||
|
||||
-- For all other decimal types, typ'Value (X) expands into
|
||||
|
||||
-- btyp?(Value_Long_Long_Decimal (X, typ'Scale))
|
||||
|
||||
-- For enumeration types other than those derived from types Boolean,
|
||||
-- Character, and Wide_Character in Standard, typ'Value (X) expands to:
|
||||
|
||||
-- Enum'Val (Value_Enumeration_NN (typS, typI'Address, Num, X))
|
||||
|
||||
-- where typS and typI and the Lit_Strings and Lit_Indexes entities
|
||||
-- from T's root type entitym and Num is Enum'Pos (Enum'Last). The
|
||||
-- Value_Enumeration_NN function will search the tables looking for
|
||||
-- X and return the position number in the table if found which is
|
||||
-- used to provide the result of 'Value (using Enum'Val). If the
|
||||
-- value is not found Constraint_Error is raised. The suffix _NN
|
||||
-- depends on the element type of typI.
|
||||
|
||||
procedure Expand_Value_Attribute (N : Node_Id) is
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
Typ : constant Entity_Id := Etype (N);
|
||||
Btyp : constant Entity_Id := Base_Type (Typ);
|
||||
Rtyp : constant Entity_Id := Root_Type (Typ);
|
||||
Exprs : constant List_Id := Expressions (N);
|
||||
Vid : RE_Id;
|
||||
Args : List_Id;
|
||||
Func : RE_Id;
|
||||
Ttyp : Entity_Id;
|
||||
|
||||
begin
|
||||
Args := Exprs;
|
||||
|
||||
if Rtyp = Standard_Character then
|
||||
Vid := RE_Value_Character;
|
||||
|
||||
elsif Rtyp = Standard_Boolean then
|
||||
Vid := RE_Value_Boolean;
|
||||
|
||||
elsif Rtyp = Standard_Wide_Character then
|
||||
Vid := RE_Value_Wide_Character;
|
||||
Append_To (Args,
|
||||
Make_Integer_Literal (Loc,
|
||||
Intval => Int (Wide_Character_Encoding_Method)));
|
||||
|
||||
elsif Rtyp = Base_Type (Standard_Short_Short_Integer)
|
||||
or else Rtyp = Base_Type (Standard_Short_Integer)
|
||||
or else Rtyp = Base_Type (Standard_Integer)
|
||||
then
|
||||
Vid := RE_Value_Integer;
|
||||
|
||||
elsif Is_Signed_Integer_Type (Rtyp) then
|
||||
Vid := RE_Value_Long_Long_Integer;
|
||||
|
||||
elsif Is_Modular_Integer_Type (Rtyp) then
|
||||
if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then
|
||||
Vid := RE_Value_Unsigned;
|
||||
else
|
||||
Vid := RE_Value_Long_Long_Unsigned;
|
||||
end if;
|
||||
|
||||
elsif Is_Decimal_Fixed_Point_Type (Rtyp) then
|
||||
if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
|
||||
Vid := RE_Value_Decimal;
|
||||
else
|
||||
Vid := RE_Value_Long_Long_Decimal;
|
||||
end if;
|
||||
|
||||
Append_To (Args,
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix => New_Reference_To (Typ, Loc),
|
||||
Attribute_Name => Name_Scale));
|
||||
|
||||
Rewrite (N,
|
||||
OK_Convert_To (Btyp,
|
||||
Make_Function_Call (Loc,
|
||||
Name => New_Reference_To (RTE (Vid), Loc),
|
||||
Parameter_Associations => Args)));
|
||||
|
||||
Set_Etype (N, Btyp);
|
||||
Analyze_And_Resolve (N, Btyp);
|
||||
return;
|
||||
|
||||
elsif Is_Real_Type (Rtyp) then
|
||||
Vid := RE_Value_Real;
|
||||
|
||||
-- Only other possibility is user defined enumeration type
|
||||
|
||||
else
|
||||
pragma Assert (Is_Enumeration_Type (Rtyp));
|
||||
|
||||
-- Case of pragma Discard_Names, transform the Value
|
||||
-- attribute to Btyp'Val (Long_Long_Integer'Value (Args))
|
||||
|
||||
if Discard_Names (First_Subtype (Typ))
|
||||
or else No (Lit_Strings (Rtyp))
|
||||
then
|
||||
Rewrite (N,
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix => New_Reference_To (Btyp, Loc),
|
||||
Attribute_Name => Name_Val,
|
||||
Expressions => New_List (
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix =>
|
||||
New_Occurrence_Of (Standard_Long_Long_Integer, Loc),
|
||||
Attribute_Name => Name_Value,
|
||||
Expressions => Args))));
|
||||
|
||||
Analyze_And_Resolve (N, Btyp);
|
||||
|
||||
-- Here for normal case where we have enumeration tables, this
|
||||
-- is where we build
|
||||
|
||||
-- T'Val (Value_Enumeration_NN (typS, typI'Address, Num, X))
|
||||
|
||||
else
|
||||
Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
|
||||
|
||||
if Ttyp = Standard_Integer_8 then
|
||||
Func := RE_Value_Enumeration_8;
|
||||
elsif Ttyp = Standard_Integer_16 then
|
||||
Func := RE_Value_Enumeration_16;
|
||||
else
|
||||
Func := RE_Value_Enumeration_32;
|
||||
end if;
|
||||
|
||||
Prepend_To (Args,
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix => New_Occurrence_Of (Rtyp, Loc),
|
||||
Attribute_Name => Name_Pos,
|
||||
Expressions => New_List (
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix => New_Occurrence_Of (Rtyp, Loc),
|
||||
Attribute_Name => Name_Last))));
|
||||
|
||||
Prepend_To (Args,
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
|
||||
Attribute_Name => Name_Address));
|
||||
|
||||
Prepend_To (Args,
|
||||
New_Occurrence_Of (Lit_Strings (Rtyp), Loc));
|
||||
|
||||
Rewrite (N,
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix => New_Reference_To (Typ, Loc),
|
||||
Attribute_Name => Name_Val,
|
||||
Expressions => New_List (
|
||||
Make_Function_Call (Loc,
|
||||
Name =>
|
||||
New_Reference_To (RTE (Func), Loc),
|
||||
Parameter_Associations => Args))));
|
||||
|
||||
Analyze_And_Resolve (N, Btyp);
|
||||
end if;
|
||||
|
||||
return;
|
||||
end if;
|
||||
|
||||
-- Fall through for all cases except user defined enumeration type
|
||||
-- and decimal types, with Vid set to the Id of the entity for the
|
||||
-- Value routine and Args set to the list of parameters for the call.
|
||||
|
||||
Rewrite (N,
|
||||
Convert_To (Btyp,
|
||||
Make_Function_Call (Loc,
|
||||
Name => New_Reference_To (RTE (Vid), Loc),
|
||||
Parameter_Associations => Args)));
|
||||
|
||||
Analyze_And_Resolve (N, Btyp);
|
||||
end Expand_Value_Attribute;
|
||||
|
||||
----------------------------
|
||||
-- Expand_Width_Attribute --
|
||||
----------------------------
|
||||
|
||||
-- The processing here also handles the case of Wide_Width. With the
|
||||
-- exceptions noted, the processing is identical
|
||||
|
||||
-- For scalar types derived from Boolean, character and integer types
|
||||
-- in package Standard. Note that the Width attribute is computed at
|
||||
-- compile time for all cases except those involving non-static sub-
|
||||
-- types. For such subtypes, typ'Width and typ'Wide_Width expands into:
|
||||
|
||||
-- Result_Type (xx (yy (Ptyp'First), yy (Ptyp'Last)))
|
||||
|
||||
-- where
|
||||
|
||||
-- For types whose root type is Character
|
||||
-- xx = Width_Character (Wide_Width_Character for Wide_Width case)
|
||||
-- yy = Character
|
||||
|
||||
-- For types whose root type is Boolean
|
||||
-- xx = Width_Boolean
|
||||
-- yy = Boolean
|
||||
|
||||
-- For signed integer types
|
||||
-- xx = Width_Long_Long_Integer
|
||||
-- yy = Long_Long_Integer
|
||||
|
||||
-- For modular integer types
|
||||
-- xx = Width_Long_Long_Unsigned
|
||||
-- yy = Long_Long_Unsigned
|
||||
|
||||
-- For types derived from Wide_Character, typ'Width expands into
|
||||
|
||||
-- Result_Type (Width_Wide_Character (
|
||||
-- Wide_Character (typ'First),
|
||||
-- Wide_Character (typ'Last),
|
||||
-- Wide_Character_Encoding_Method);
|
||||
|
||||
-- and typ'Wide_Width expands into:
|
||||
|
||||
-- Result_Type (Wide_Width_Wide_Character (
|
||||
-- Wide_Character (typ'First),
|
||||
-- Wide_Character (typ'Last));
|
||||
|
||||
-- For real types, typ'Width and typ'Wide_Width expand into
|
||||
|
||||
-- if Ptyp'First > Ptyp'Last then 0 else btyp'Width end if
|
||||
|
||||
-- where btyp is the base type. This looks recursive but it isn't
|
||||
-- because the base type is always static, and hence the expression
|
||||
-- in the else is reduced to an integer literal.
|
||||
|
||||
-- For user defined enumeration types, typ'Width expands into
|
||||
|
||||
-- Result_Type (Width_Enumeration_NN
|
||||
-- (typS,
|
||||
-- typI'Address,
|
||||
-- typ'Pos (typ'First),
|
||||
-- typ'Pos (Typ'Last)));
|
||||
|
||||
-- and typ'Wide_Width expands into:
|
||||
|
||||
-- Result_Type (Wide_Width_Enumeration_NN
|
||||
-- (typS,
|
||||
-- typI,
|
||||
-- typ'Pos (typ'First),
|
||||
-- typ'Pos (Typ'Last))
|
||||
-- Wide_Character_Encoding_Method);
|
||||
|
||||
-- where typS and typI are the enumeration image strings and
|
||||
-- indexes table, as described in Build_Enumeration_Image_Tables.
|
||||
-- NN is 8/16/32 for depending on the element type for typI.
|
||||
|
||||
procedure Expand_Width_Attribute (N : Node_Id; Wide : Boolean) is
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
Typ : constant Entity_Id := Etype (N);
|
||||
Pref : constant Node_Id := Prefix (N);
|
||||
Ptyp : constant Entity_Id := Etype (Pref);
|
||||
Rtyp : constant Entity_Id := Root_Type (Ptyp);
|
||||
XX : RE_Id;
|
||||
YY : Entity_Id;
|
||||
Arglist : List_Id;
|
||||
Ttyp : Entity_Id;
|
||||
|
||||
begin
|
||||
-- Types derived from Standard.Boolean
|
||||
|
||||
if Rtyp = Standard_Boolean then
|
||||
XX := RE_Width_Boolean;
|
||||
YY := Rtyp;
|
||||
|
||||
-- Types derived from Standard.Character
|
||||
|
||||
elsif Rtyp = Standard_Character then
|
||||
if not Wide then
|
||||
XX := RE_Width_Character;
|
||||
else
|
||||
XX := RE_Wide_Width_Character;
|
||||
end if;
|
||||
|
||||
YY := Rtyp;
|
||||
|
||||
-- Types derived from Standard.Wide_Character
|
||||
|
||||
elsif Rtyp = Standard_Wide_Character then
|
||||
if not Wide then
|
||||
XX := RE_Width_Wide_Character;
|
||||
else
|
||||
XX := RE_Wide_Width_Wide_Character;
|
||||
end if;
|
||||
|
||||
YY := Rtyp;
|
||||
|
||||
-- Signed integer types
|
||||
|
||||
elsif Is_Signed_Integer_Type (Rtyp) then
|
||||
XX := RE_Width_Long_Long_Integer;
|
||||
YY := Standard_Long_Long_Integer;
|
||||
|
||||
-- Modular integer types
|
||||
|
||||
elsif Is_Modular_Integer_Type (Rtyp) then
|
||||
XX := RE_Width_Long_Long_Unsigned;
|
||||
YY := RTE (RE_Long_Long_Unsigned);
|
||||
|
||||
-- Real types
|
||||
|
||||
elsif Is_Real_Type (Rtyp) then
|
||||
|
||||
Rewrite (N,
|
||||
Make_Conditional_Expression (Loc,
|
||||
Expressions => New_List (
|
||||
|
||||
Make_Op_Gt (Loc,
|
||||
Left_Opnd =>
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix => New_Reference_To (Ptyp, Loc),
|
||||
Attribute_Name => Name_First),
|
||||
|
||||
Right_Opnd =>
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix => New_Reference_To (Ptyp, Loc),
|
||||
Attribute_Name => Name_Last)),
|
||||
|
||||
Make_Integer_Literal (Loc, 0),
|
||||
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix => New_Reference_To (Base_Type (Ptyp), Loc),
|
||||
Attribute_Name => Name_Width))));
|
||||
|
||||
Analyze_And_Resolve (N, Typ);
|
||||
return;
|
||||
|
||||
-- User defined enumeration types
|
||||
|
||||
else
|
||||
pragma Assert (Is_Enumeration_Type (Rtyp));
|
||||
|
||||
Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
|
||||
|
||||
if not Wide then
|
||||
if Ttyp = Standard_Integer_8 then
|
||||
XX := RE_Width_Enumeration_8;
|
||||
elsif Ttyp = Standard_Integer_16 then
|
||||
XX := RE_Width_Enumeration_16;
|
||||
else
|
||||
XX := RE_Width_Enumeration_32;
|
||||
end if;
|
||||
|
||||
else
|
||||
if Ttyp = Standard_Integer_8 then
|
||||
XX := RE_Wide_Width_Enumeration_8;
|
||||
elsif Ttyp = Standard_Integer_16 then
|
||||
XX := RE_Wide_Width_Enumeration_16;
|
||||
else
|
||||
XX := RE_Wide_Width_Enumeration_32;
|
||||
end if;
|
||||
end if;
|
||||
|
||||
Arglist :=
|
||||
New_List (
|
||||
New_Occurrence_Of (Lit_Strings (Rtyp), Loc),
|
||||
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
|
||||
Attribute_Name => Name_Address),
|
||||
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix => New_Reference_To (Ptyp, Loc),
|
||||
Attribute_Name => Name_Pos,
|
||||
|
||||
Expressions => New_List (
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix => New_Reference_To (Ptyp, Loc),
|
||||
Attribute_Name => Name_First))),
|
||||
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix => New_Reference_To (Ptyp, Loc),
|
||||
Attribute_Name => Name_Pos,
|
||||
|
||||
Expressions => New_List (
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix => New_Reference_To (Ptyp, Loc),
|
||||
Attribute_Name => Name_Last))));
|
||||
|
||||
-- For enumeration'Wide_Width, add encoding method parameter
|
||||
|
||||
if Wide then
|
||||
Append_To (Arglist,
|
||||
Make_Integer_Literal (Loc,
|
||||
Intval => Int (Wide_Character_Encoding_Method)));
|
||||
end if;
|
||||
|
||||
Rewrite (N,
|
||||
Convert_To (Typ,
|
||||
Make_Function_Call (Loc,
|
||||
Name => New_Reference_To (RTE (XX), Loc),
|
||||
Parameter_Associations => Arglist)));
|
||||
|
||||
Analyze_And_Resolve (N, Typ);
|
||||
return;
|
||||
end if;
|
||||
|
||||
-- If we fall through XX and YY are set
|
||||
|
||||
Arglist := New_List (
|
||||
Convert_To (YY,
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix => New_Reference_To (Ptyp, Loc),
|
||||
Attribute_Name => Name_First)),
|
||||
|
||||
Convert_To (YY,
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix => New_Reference_To (Ptyp, Loc),
|
||||
Attribute_Name => Name_Last)));
|
||||
|
||||
-- For Wide_Character'Width, add encoding method parameter
|
||||
|
||||
if Rtyp = Standard_Wide_Character and then Wide then
|
||||
Append_To (Arglist,
|
||||
Make_Integer_Literal (Loc,
|
||||
Intval => Int (Wide_Character_Encoding_Method)));
|
||||
end if;
|
||||
|
||||
Rewrite (N,
|
||||
Convert_To (Typ,
|
||||
Make_Function_Call (Loc,
|
||||
Name => New_Reference_To (RTE (XX), Loc),
|
||||
Parameter_Associations => Arglist)));
|
||||
|
||||
Analyze_And_Resolve (N, Typ);
|
||||
end Expand_Width_Attribute;
|
||||
|
||||
end Exp_Imgv;
|
|
@ -0,0 +1,87 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- E X P _ I M G V --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.2 $ --
|
||||
-- --
|
||||
-- Copyright (C) 2000 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- Expand routines for Image, Value and Width attributes. These are the
|
||||
-- attributes that make use of enumeration type image tables.
|
||||
|
||||
with Types; use Types;
|
||||
|
||||
package Exp_Imgv is
|
||||
|
||||
procedure Build_Enumeration_Image_Tables (E : Entity_Id; N : Node_Id);
|
||||
-- Build the enumeration image tables for E, which is an enumeration
|
||||
-- base type. The node N is the point in the tree where the resulting
|
||||
-- declarations are to be inserted.
|
||||
--
|
||||
-- The form of the tables generated is as follows:
|
||||
--
|
||||
-- xxxS : string := "chars";
|
||||
-- xxxI : array (0 .. N) of Natural_8/16/32 := (1, n, .., n);
|
||||
--
|
||||
-- Here xxxS is a string obtained by concatenating all the names
|
||||
-- of the enumeration literals in sequence, representing any wide
|
||||
-- characters according to the current wide character encoding
|
||||
-- method, and with all letters forced to upper case.
|
||||
--
|
||||
-- The array xxxI is an array of ones origin indexes to the start
|
||||
-- of each name, with one extra entry at the end, which is the index
|
||||
-- to the character just past the end of the last literal, i.e. it is
|
||||
-- the length of xxxS + 1. The element type is the shortest of the
|
||||
-- possible types that will hold all the values.
|
||||
--
|
||||
-- For example, for the type
|
||||
--
|
||||
-- type x is (hello,'!',goodbye);
|
||||
--
|
||||
-- the generated tables would consist of
|
||||
--
|
||||
-- xxxS : String := "hello'!'goodbye";
|
||||
-- xxxI : array (0 .. 3) of Natural_8 := (1, 6, 9, 16);
|
||||
--
|
||||
-- Here Natural_8 is used since 16 < 2**(8-1)
|
||||
--
|
||||
-- If the entity E needs the tables constructing, the necessary
|
||||
-- declarations are constructed, and the fields Lit_Strings and
|
||||
-- Lit_Indexes of E are set to point to the corresponding entities.
|
||||
-- If no tables are needed (E is not a user defined enumeration
|
||||
-- root type, or pragma Discard_Names is in effect, then the
|
||||
-- declarations are not constructed, and the fields remain Empty.
|
||||
|
||||
procedure Expand_Image_Attribute (N : Node_Id);
|
||||
-- This procedure is called from Exp_Attr to expand an occurrence
|
||||
-- of the attribute Image.
|
||||
|
||||
procedure Expand_Value_Attribute (N : Node_Id);
|
||||
-- This procedure is called from Exp_Attr to expand an occurrence
|
||||
-- of the attribute Value.
|
||||
|
||||
procedure Expand_Width_Attribute (N : Node_Id; Wide : Boolean);
|
||||
-- This procedure is called from Exp_Attr to expand an occurrence of
|
||||
-- the attributes Width (Wide = False) or Wide_Width (Wide = True).
|
||||
|
||||
end Exp_Imgv;
|
|
@ -0,0 +1,755 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- E X P _ I N T R --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.76 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Atree; use Atree;
|
||||
with Einfo; use Einfo;
|
||||
with Errout; use Errout;
|
||||
with Exp_Ch4; use Exp_Ch4;
|
||||
with Exp_Ch7; use Exp_Ch7;
|
||||
with Exp_Ch9; use Exp_Ch9;
|
||||
with Exp_Ch11; use Exp_Ch11;
|
||||
with Exp_Code; use Exp_Code;
|
||||
with Exp_Fixd; use Exp_Fixd;
|
||||
with Exp_Util; use Exp_Util;
|
||||
with Itypes; use Itypes;
|
||||
with Namet; use Namet;
|
||||
with Nmake; use Nmake;
|
||||
with Nlists; use Nlists;
|
||||
with Restrict; use Restrict;
|
||||
with Rtsfind; use Rtsfind;
|
||||
with Sem; use Sem;
|
||||
with Sem_Eval; use Sem_Eval;
|
||||
with Sem_Res; use Sem_Res;
|
||||
with Sem_Util; use Sem_Util;
|
||||
with Sinfo; use Sinfo;
|
||||
with Sinput; use Sinput;
|
||||
with Snames; use Snames;
|
||||
with Stand; use Stand;
|
||||
with Stringt; use Stringt;
|
||||
with Tbuild; use Tbuild;
|
||||
with Uintp; use Uintp;
|
||||
with Urealp; use Urealp;
|
||||
|
||||
package body Exp_Intr is
|
||||
|
||||
-----------------------
|
||||
-- Local Subprograms --
|
||||
-----------------------
|
||||
|
||||
procedure Expand_Is_Negative (N : Node_Id);
|
||||
-- Expand a call to the intrinsic Is_Negative function
|
||||
|
||||
procedure Expand_Exception_Call (N : Node_Id; Ent : RE_Id);
|
||||
-- Expand a call to Exception_Information/Message/Name. The first
|
||||
-- parameter, N, is the node for the function call, and Ent is the
|
||||
-- entity for the corresponding routine in the Ada.Exceptions package.
|
||||
|
||||
procedure Expand_Import_Call (N : Node_Id);
|
||||
-- Expand a call to Import_Address/Longest_Integer/Value. The parameter
|
||||
-- N is the node for the function call.
|
||||
|
||||
procedure Expand_Shift (N : Node_Id; E : Entity_Id; K : Node_Kind);
|
||||
-- Expand an intrinsic shift operation, N and E are from the call to
|
||||
-- Expand_Instrinsic_Call (call node and subprogram spec entity) and
|
||||
-- K is the kind for the shift node
|
||||
|
||||
procedure Expand_Unc_Conversion (N : Node_Id; E : Entity_Id);
|
||||
-- Expand a call to an instantiation of Unchecked_Convertion into a node
|
||||
-- N_Unchecked_Type_Conversion.
|
||||
|
||||
procedure Expand_Unc_Deallocation (N : Node_Id; E : Entity_Id);
|
||||
-- Expand a call to an instantiation of Unchecked_Deallocation into a node
|
||||
-- N_Free_Statement and appropriate context.
|
||||
|
||||
procedure Expand_Source_Info (N : Node_Id; E : Entity_Id; Nam : Name_Id);
|
||||
-- Rewrite the node by the appropriate string or positive constant.
|
||||
-- Nam can be one of the following:
|
||||
-- Name_File - expand string that is the name of source file
|
||||
-- Name_Line - expand integer line number
|
||||
-- Name_Source_Location - expand string of form file:line
|
||||
-- Name_Enclosing_Entity - expand string with name of enclosing entity
|
||||
|
||||
---------------------------
|
||||
-- Expand_Exception_Call --
|
||||
---------------------------
|
||||
|
||||
-- If the function call is not within an exception handler, then the
|
||||
-- call is replaced by a null string. Otherwise the appropriate routine
|
||||
-- in Ada.Exceptions is called passing the choice parameter specification
|
||||
-- from the enclosing handler. If the enclosing handler lacks a choice
|
||||
-- parameter, then one is supplied.
|
||||
|
||||
procedure Expand_Exception_Call (N : Node_Id; Ent : RE_Id) is
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
P : Node_Id;
|
||||
E : Entity_Id;
|
||||
S : String_Id;
|
||||
|
||||
begin
|
||||
-- Climb up parents to see if we are in exception handler
|
||||
|
||||
P := Parent (N);
|
||||
loop
|
||||
-- Case of not in exception handler
|
||||
|
||||
if No (P) then
|
||||
Start_String;
|
||||
S := End_String;
|
||||
Rewrite (N,
|
||||
Make_String_Literal (Loc,
|
||||
Strval => S));
|
||||
exit;
|
||||
|
||||
-- Case of in exception handler
|
||||
|
||||
elsif Nkind (P) = N_Exception_Handler then
|
||||
if No (Choice_Parameter (P)) then
|
||||
|
||||
-- If no choice parameter present, then put one there. Note
|
||||
-- that we do not need to put it on the entity chain, since
|
||||
-- no one will be referencing it by normal visibility methods.
|
||||
|
||||
E := Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
|
||||
Set_Choice_Parameter (P, E);
|
||||
Set_Ekind (E, E_Variable);
|
||||
Set_Etype (E, RTE (RE_Exception_Occurrence));
|
||||
Set_Scope (E, Current_Scope);
|
||||
end if;
|
||||
|
||||
Rewrite (N,
|
||||
Make_Function_Call (Loc,
|
||||
Name => New_Occurrence_Of (RTE (Ent), Loc),
|
||||
Parameter_Associations => New_List (
|
||||
New_Occurrence_Of (Choice_Parameter (P), Loc))));
|
||||
exit;
|
||||
|
||||
-- Keep climbing!
|
||||
|
||||
else
|
||||
P := Parent (P);
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
Analyze_And_Resolve (N, Standard_String);
|
||||
end Expand_Exception_Call;
|
||||
|
||||
------------------------
|
||||
-- Expand_Import_Call --
|
||||
------------------------
|
||||
|
||||
-- The function call must have a static string as its argument. We create
|
||||
-- a dummy variable which uses this string as the external name in an
|
||||
-- Import pragma. The result is then obtained as the address of this
|
||||
-- dummy variable, converted to the appropriate target type.
|
||||
|
||||
procedure Expand_Import_Call (N : Node_Id) is
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
Ent : constant Entity_Id := Entity (Name (N));
|
||||
Str : constant Node_Id := First_Actual (N);
|
||||
Dum : Entity_Id;
|
||||
|
||||
begin
|
||||
Dum := Make_Defining_Identifier (Loc, New_Internal_Name ('D'));
|
||||
|
||||
Insert_Actions (N, New_List (
|
||||
Make_Object_Declaration (Loc,
|
||||
Defining_Identifier => Dum,
|
||||
Object_Definition =>
|
||||
New_Occurrence_Of (Standard_Character, Loc)),
|
||||
|
||||
Make_Pragma (Loc,
|
||||
Chars => Name_Import,
|
||||
Pragma_Argument_Associations => New_List (
|
||||
Make_Pragma_Argument_Association (Loc,
|
||||
Expression => Make_Identifier (Loc, Name_Ada)),
|
||||
|
||||
Make_Pragma_Argument_Association (Loc,
|
||||
Expression => Make_Identifier (Loc, Chars (Dum))),
|
||||
|
||||
Make_Pragma_Argument_Association (Loc,
|
||||
Chars => Name_Link_Name,
|
||||
Expression => Relocate_Node (Str))))));
|
||||
|
||||
Rewrite (N,
|
||||
Unchecked_Convert_To (Etype (Ent),
|
||||
Make_Attribute_Reference (Loc,
|
||||
Attribute_Name => Name_Address,
|
||||
Prefix => Make_Identifier (Loc, Chars (Dum)))));
|
||||
|
||||
Analyze_And_Resolve (N, Etype (Ent));
|
||||
end Expand_Import_Call;
|
||||
|
||||
---------------------------
|
||||
-- Expand_Intrinsic_Call --
|
||||
---------------------------
|
||||
|
||||
procedure Expand_Intrinsic_Call (N : Node_Id; E : Entity_Id) is
|
||||
Nam : Name_Id;
|
||||
|
||||
begin
|
||||
-- If the intrinsic subprogram is generic, gets its original name.
|
||||
|
||||
if Present (Parent (E))
|
||||
and then Present (Generic_Parent (Parent (E)))
|
||||
then
|
||||
Nam := Chars (Generic_Parent (Parent (E)));
|
||||
else
|
||||
Nam := Chars (E);
|
||||
end if;
|
||||
|
||||
if Nam = Name_Asm then
|
||||
Expand_Asm_Call (N);
|
||||
|
||||
elsif Nam = Name_Divide then
|
||||
Expand_Decimal_Divide_Call (N);
|
||||
|
||||
elsif Nam = Name_Exception_Information then
|
||||
Expand_Exception_Call (N, RE_Exception_Information);
|
||||
|
||||
elsif Nam = Name_Exception_Message then
|
||||
Expand_Exception_Call (N, RE_Exception_Message);
|
||||
|
||||
elsif Nam = Name_Exception_Name then
|
||||
Expand_Exception_Call (N, RE_Exception_Name_Simple);
|
||||
|
||||
elsif Nam = Name_Import_Address
|
||||
or else
|
||||
Nam = Name_Import_Largest_Value
|
||||
or else
|
||||
Nam = Name_Import_Value
|
||||
then
|
||||
Expand_Import_Call (N);
|
||||
|
||||
elsif Nam = Name_Is_Negative then
|
||||
Expand_Is_Negative (N);
|
||||
|
||||
elsif Nam = Name_Rotate_Left then
|
||||
Expand_Shift (N, E, N_Op_Rotate_Left);
|
||||
|
||||
elsif Nam = Name_Rotate_Right then
|
||||
Expand_Shift (N, E, N_Op_Rotate_Right);
|
||||
|
||||
elsif Nam = Name_Shift_Left then
|
||||
Expand_Shift (N, E, N_Op_Shift_Left);
|
||||
|
||||
elsif Nam = Name_Shift_Right then
|
||||
Expand_Shift (N, E, N_Op_Shift_Right);
|
||||
|
||||
elsif Nam = Name_Shift_Right_Arithmetic then
|
||||
Expand_Shift (N, E, N_Op_Shift_Right_Arithmetic);
|
||||
|
||||
elsif Nam = Name_Unchecked_Conversion then
|
||||
Expand_Unc_Conversion (N, E);
|
||||
|
||||
elsif Nam = Name_Unchecked_Deallocation then
|
||||
Expand_Unc_Deallocation (N, E);
|
||||
|
||||
elsif Nam = Name_File
|
||||
or else Nam = Name_Line
|
||||
or else Nam = Name_Source_Location
|
||||
or else Nam = Name_Enclosing_Entity
|
||||
then
|
||||
Expand_Source_Info (N, E, Nam);
|
||||
|
||||
else
|
||||
-- Only other possibility is a renaming, in which case we expand
|
||||
-- the call to the original operation (which must be intrinsic).
|
||||
|
||||
pragma Assert (Present (Alias (E)));
|
||||
Expand_Intrinsic_Call (N, Alias (E));
|
||||
end if;
|
||||
|
||||
end Expand_Intrinsic_Call;
|
||||
|
||||
------------------------
|
||||
-- Expand_Is_Negative --
|
||||
------------------------
|
||||
|
||||
procedure Expand_Is_Negative (N : Node_Id) is
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
Opnd : constant Node_Id := Relocate_Node (First_Actual (N));
|
||||
|
||||
begin
|
||||
|
||||
-- We replace the function call by the following expression
|
||||
|
||||
-- if Opnd < 0.0 then
|
||||
-- True
|
||||
-- else
|
||||
-- if Opnd > 0.0 then
|
||||
-- False;
|
||||
-- else
|
||||
-- Float_Unsigned!(Float (Opnd)) /= 0
|
||||
-- end if;
|
||||
-- end if;
|
||||
|
||||
Rewrite (N,
|
||||
Make_Conditional_Expression (Loc,
|
||||
Expressions => New_List (
|
||||
Make_Op_Lt (Loc,
|
||||
Left_Opnd => Duplicate_Subexpr (Opnd),
|
||||
Right_Opnd => Make_Real_Literal (Loc, Ureal_0)),
|
||||
|
||||
New_Occurrence_Of (Standard_True, Loc),
|
||||
|
||||
Make_Conditional_Expression (Loc,
|
||||
Expressions => New_List (
|
||||
Make_Op_Gt (Loc,
|
||||
Left_Opnd => Duplicate_Subexpr (Opnd),
|
||||
Right_Opnd => Make_Real_Literal (Loc, Ureal_0)),
|
||||
|
||||
New_Occurrence_Of (Standard_False, Loc),
|
||||
|
||||
Make_Op_Ne (Loc,
|
||||
Left_Opnd =>
|
||||
Unchecked_Convert_To (RTE (RE_Float_Unsigned),
|
||||
Convert_To (Standard_Float,
|
||||
Duplicate_Subexpr (Opnd))),
|
||||
Right_Opnd =>
|
||||
Make_Integer_Literal (Loc, 0)))))));
|
||||
|
||||
Analyze_And_Resolve (N, Standard_Boolean);
|
||||
end Expand_Is_Negative;
|
||||
|
||||
------------------
|
||||
-- Expand_Shift --
|
||||
------------------
|
||||
|
||||
-- This procedure is used to convert a call to a shift function to the
|
||||
-- corresponding operator node. This conversion is not done by the usual
|
||||
-- circuit for converting calls to operator functions (e.g. "+"(1,2)) to
|
||||
-- operator nodes, because shifts are not predefined operators.
|
||||
|
||||
-- As a result, whenever a shift is used in the source program, it will
|
||||
-- remain as a call until converted by this routine to the operator node
|
||||
-- form which Gigi is expecting to see.
|
||||
|
||||
-- Note: it is possible for the expander to generate shift operator nodes
|
||||
-- directly, which will be analyzed in the normal manner by calling Analyze
|
||||
-- and Resolve. Such shift operator nodes will not be seen by Expand_Shift.
|
||||
|
||||
procedure Expand_Shift (N : Node_Id; E : Entity_Id; K : Node_Kind) is
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
Typ : constant Entity_Id := Etype (N);
|
||||
Left : constant Node_Id := First_Actual (N);
|
||||
Right : constant Node_Id := Next_Actual (Left);
|
||||
Ltyp : constant Node_Id := Etype (Left);
|
||||
Rtyp : constant Node_Id := Etype (Right);
|
||||
Snode : Node_Id;
|
||||
|
||||
begin
|
||||
Snode := New_Node (K, Loc);
|
||||
Set_Left_Opnd (Snode, Relocate_Node (Left));
|
||||
Set_Right_Opnd (Snode, Relocate_Node (Right));
|
||||
Set_Chars (Snode, Chars (E));
|
||||
Set_Etype (Snode, Base_Type (Typ));
|
||||
Set_Entity (Snode, E);
|
||||
|
||||
if Compile_Time_Known_Value (Type_High_Bound (Rtyp))
|
||||
and then Expr_Value (Type_High_Bound (Rtyp)) < Esize (Ltyp)
|
||||
then
|
||||
Set_Shift_Count_OK (Snode, True);
|
||||
end if;
|
||||
|
||||
-- Do the rewrite. Note that we don't call Analyze and Resolve on
|
||||
-- this node, because it already got analyzed and resolved when
|
||||
-- it was a function call!
|
||||
|
||||
Rewrite (N, Snode);
|
||||
Set_Analyzed (N);
|
||||
|
||||
end Expand_Shift;
|
||||
|
||||
------------------------
|
||||
-- Expand_Source_Info --
|
||||
------------------------
|
||||
|
||||
procedure Expand_Source_Info (N : Node_Id; E : Entity_Id; Nam : Name_Id) is
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
Ent : Entity_Id;
|
||||
|
||||
begin
|
||||
-- Integer cases
|
||||
|
||||
if Nam = Name_Line then
|
||||
Rewrite (N,
|
||||
Make_Integer_Literal (Loc,
|
||||
Intval => UI_From_Int (Int (Get_Logical_Line_Number (Loc)))));
|
||||
Analyze_And_Resolve (N, Standard_Positive);
|
||||
|
||||
-- String cases
|
||||
|
||||
else
|
||||
case Nam is
|
||||
when Name_File =>
|
||||
Get_Decoded_Name_String
|
||||
(Reference_Name (Get_Source_File_Index (Loc)));
|
||||
|
||||
when Name_Source_Location =>
|
||||
Build_Location_String (Loc);
|
||||
|
||||
when Name_Enclosing_Entity =>
|
||||
Name_Len := 0;
|
||||
|
||||
Ent := Current_Scope;
|
||||
|
||||
-- Skip enclosing blocks to reach enclosing unit.
|
||||
|
||||
while Present (Ent) loop
|
||||
exit when Ekind (Ent) /= E_Block
|
||||
and then Ekind (Ent) /= E_Loop;
|
||||
Ent := Scope (Ent);
|
||||
end loop;
|
||||
|
||||
-- Ent now points to the relevant defining entity
|
||||
|
||||
declare
|
||||
SDef : Source_Ptr := Sloc (Ent);
|
||||
TDef : Source_Buffer_Ptr;
|
||||
|
||||
begin
|
||||
TDef := Source_Text (Get_Source_File_Index (SDef));
|
||||
Name_Len := 0;
|
||||
|
||||
while TDef (SDef) in '0' .. '9'
|
||||
or else TDef (SDef) >= 'A'
|
||||
or else TDef (SDef) = ASCII.ESC
|
||||
loop
|
||||
Add_Char_To_Name_Buffer (TDef (SDef));
|
||||
SDef := SDef + 1;
|
||||
end loop;
|
||||
end;
|
||||
|
||||
when others =>
|
||||
raise Program_Error;
|
||||
end case;
|
||||
|
||||
Rewrite (N,
|
||||
Make_String_Literal (Loc, Strval => String_From_Name_Buffer));
|
||||
Analyze_And_Resolve (N, Standard_String);
|
||||
end if;
|
||||
|
||||
Set_Is_Static_Expression (N);
|
||||
end Expand_Source_Info;
|
||||
|
||||
---------------------------
|
||||
-- Expand_Unc_Conversion --
|
||||
---------------------------
|
||||
|
||||
procedure Expand_Unc_Conversion (N : Node_Id; E : Entity_Id) is
|
||||
Func : constant Entity_Id := Entity (Name (N));
|
||||
Conv : Node_Id;
|
||||
Ftyp : Entity_Id;
|
||||
|
||||
begin
|
||||
-- Rewrite as unchecked conversion node. Note that we must convert
|
||||
-- the operand to the formal type of the input parameter of the
|
||||
-- function, so that the resulting N_Unchecked_Type_Conversion
|
||||
-- call indicates the correct types for Gigi.
|
||||
|
||||
-- Right now, we only do this if a scalar type is involved. It is
|
||||
-- not clear if it is needed in other cases. If we do attempt to
|
||||
-- do the conversion unconditionally, it crashes 3411-018. To be
|
||||
-- investigated further ???
|
||||
|
||||
Conv := Relocate_Node (First_Actual (N));
|
||||
Ftyp := Etype (First_Formal (Func));
|
||||
|
||||
if Is_Scalar_Type (Ftyp) then
|
||||
Conv := Convert_To (Ftyp, Conv);
|
||||
Set_Parent (Conv, N);
|
||||
Analyze_And_Resolve (Conv);
|
||||
end if;
|
||||
|
||||
-- We do the analysis here, because we do not want the compiler
|
||||
-- to try to optimize or otherwise reorganize the unchecked
|
||||
-- conversion node.
|
||||
|
||||
Rewrite (N, Unchecked_Convert_To (Etype (E), Conv));
|
||||
Set_Etype (N, Etype (E));
|
||||
Set_Analyzed (N);
|
||||
|
||||
if Nkind (N) = N_Unchecked_Type_Conversion then
|
||||
Expand_N_Unchecked_Type_Conversion (N);
|
||||
end if;
|
||||
end Expand_Unc_Conversion;
|
||||
|
||||
-----------------------------
|
||||
-- Expand_Unc_Deallocation --
|
||||
-----------------------------
|
||||
|
||||
-- Generate the following Code :
|
||||
|
||||
-- if Arg /= null then
|
||||
-- <Finalize_Call> (.., T'Class(Arg.all), ..); -- for controlled types
|
||||
-- Free (Arg);
|
||||
-- Arg := Null;
|
||||
-- end if;
|
||||
|
||||
-- For a task, we also generate a call to Free_Task to ensure that the
|
||||
-- task itself is freed if it is terminated, ditto for a simple protected
|
||||
-- object, with a call to Finalize_Protection
|
||||
|
||||
procedure Expand_Unc_Deallocation (N : Node_Id; E : Entity_Id) is
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
Arg : constant Node_Id := First_Actual (N);
|
||||
Typ : constant Entity_Id := Etype (Arg);
|
||||
Stmts : constant List_Id := New_List;
|
||||
Pool : constant Entity_Id :=
|
||||
Associated_Storage_Pool (Underlying_Type (Root_Type (Typ)));
|
||||
|
||||
Desig_T : Entity_Id := Designated_Type (Typ);
|
||||
Gen_Code : Node_Id;
|
||||
Free_Node : Node_Id;
|
||||
Deref : Node_Id;
|
||||
Free_Arg : Node_Id;
|
||||
Free_Cod : List_Id;
|
||||
Blk : Node_Id;
|
||||
|
||||
begin
|
||||
if Controlled_Type (Desig_T) then
|
||||
|
||||
Deref := Make_Explicit_Dereference (Loc, Duplicate_Subexpr (Arg));
|
||||
|
||||
-- If the type is tagged, then we must force dispatching on the
|
||||
-- finalization call because the designated type may not be the
|
||||
-- actual type of the object
|
||||
|
||||
if Is_Tagged_Type (Desig_T)
|
||||
and then not Is_Class_Wide_Type (Desig_T)
|
||||
then
|
||||
Deref := Unchecked_Convert_To (Class_Wide_Type (Desig_T), Deref);
|
||||
end if;
|
||||
|
||||
Free_Cod :=
|
||||
Make_Final_Call
|
||||
(Ref => Deref,
|
||||
Typ => Desig_T,
|
||||
With_Detach => New_Reference_To (Standard_True, Loc));
|
||||
|
||||
if Abort_Allowed then
|
||||
Prepend_To (Free_Cod,
|
||||
Build_Runtime_Call (Loc, RE_Abort_Defer));
|
||||
|
||||
Blk :=
|
||||
Make_Block_Statement (Loc, Handled_Statement_Sequence =>
|
||||
Make_Handled_Sequence_Of_Statements (Loc,
|
||||
Statements => Free_Cod,
|
||||
At_End_Proc =>
|
||||
New_Occurrence_Of (RTE (RE_Abort_Undefer_Direct), Loc)));
|
||||
|
||||
-- We now expand the exception (at end) handler. We set a
|
||||
-- temporary parent pointer since we have not attached Blk
|
||||
-- to the tree yet.
|
||||
|
||||
Set_Parent (Blk, N);
|
||||
Analyze (Blk);
|
||||
Expand_At_End_Handler
|
||||
(Handled_Statement_Sequence (Blk), Entity (Identifier (Blk)));
|
||||
Append (Blk, Stmts);
|
||||
|
||||
else
|
||||
Append_List_To (Stmts, Free_Cod);
|
||||
end if;
|
||||
end if;
|
||||
|
||||
-- For a task type, call Free_Task before freeing the ATCB.
|
||||
|
||||
if Is_Task_Type (Desig_T) then
|
||||
|
||||
declare
|
||||
Stat : Node_Id := Prev (N);
|
||||
Nam1 : Node_Id;
|
||||
Nam2 : Node_Id;
|
||||
|
||||
begin
|
||||
-- An Abort followed by a Free will not do what the user
|
||||
-- expects, because the abort is not immediate. This is worth
|
||||
-- a friendly warning.
|
||||
|
||||
while Present (Stat)
|
||||
and then not Comes_From_Source (Original_Node (Stat))
|
||||
loop
|
||||
Prev (Stat);
|
||||
end loop;
|
||||
|
||||
if Present (Stat)
|
||||
and then Nkind (Original_Node (Stat)) = N_Abort_Statement
|
||||
then
|
||||
Stat := Original_Node (Stat);
|
||||
Nam1 := First (Names (Stat));
|
||||
Nam2 := Original_Node (First (Parameter_Associations (N)));
|
||||
|
||||
if Nkind (Nam1) = N_Explicit_Dereference
|
||||
and then Is_Entity_Name (Prefix (Nam1))
|
||||
and then Is_Entity_Name (Nam2)
|
||||
and then Entity (Prefix (Nam1)) = Entity (Nam2)
|
||||
then
|
||||
Error_Msg_N ("Abort may take time to complete?", N);
|
||||
Error_Msg_N ("\deallocation might have no effect?", N);
|
||||
Error_Msg_N ("\safer to wait for termination.?", N);
|
||||
end if;
|
||||
end if;
|
||||
end;
|
||||
|
||||
Append_To (Stmts,
|
||||
Make_Procedure_Call_Statement (Loc,
|
||||
Name => New_Reference_To (RTE (RE_Free_Task), Loc),
|
||||
Parameter_Associations => New_List (
|
||||
Concurrent_Ref (Duplicate_Subexpr (Arg)))));
|
||||
end if;
|
||||
|
||||
-- For a protected type with no entries, call Finalize_Protection
|
||||
-- before freeing the PO.
|
||||
|
||||
if Is_Protected_Type (Desig_T) and then not Has_Entries (Desig_T) then
|
||||
Append_To (Stmts,
|
||||
Make_Procedure_Call_Statement (Loc,
|
||||
Name => New_Reference_To (RTE (RE_Finalize_Protection), Loc),
|
||||
Parameter_Associations => New_List (
|
||||
Concurrent_Ref (Duplicate_Subexpr (Arg)))));
|
||||
end if;
|
||||
|
||||
-- Normal processing for non-controlled types
|
||||
|
||||
Free_Arg := Duplicate_Subexpr (Arg);
|
||||
Free_Node := Make_Free_Statement (Loc, Empty);
|
||||
Append_To (Stmts, Free_Node);
|
||||
Set_Storage_Pool (Free_Node, Pool);
|
||||
|
||||
-- Make implicit if statement. We omit this if we are the then part
|
||||
-- of a test of the form:
|
||||
|
||||
-- if not (Arg = null) then
|
||||
|
||||
-- i.e. if the test is explicit in the source. Arg must be a simple
|
||||
-- identifier for the purposes of this special test. Note that the
|
||||
-- use of /= in the source is always transformed into the above form.
|
||||
|
||||
declare
|
||||
Test_Needed : Boolean := True;
|
||||
P : constant Node_Id := Parent (N);
|
||||
C : Node_Id;
|
||||
|
||||
begin
|
||||
if Nkind (Arg) = N_Identifier
|
||||
and then Nkind (P) = N_If_Statement
|
||||
and then First (Then_Statements (P)) = N
|
||||
then
|
||||
if Nkind (Condition (P)) = N_Op_Not then
|
||||
C := Right_Opnd (Condition (P));
|
||||
|
||||
if Nkind (C) = N_Op_Eq
|
||||
and then Nkind (Left_Opnd (C)) = N_Identifier
|
||||
and then Chars (Arg) = Chars (Left_Opnd (C))
|
||||
and then Nkind (Right_Opnd (C)) = N_Null
|
||||
then
|
||||
Test_Needed := False;
|
||||
end if;
|
||||
end if;
|
||||
end if;
|
||||
|
||||
-- Generate If_Statement if needed
|
||||
|
||||
if Test_Needed then
|
||||
Gen_Code :=
|
||||
Make_Implicit_If_Statement (N,
|
||||
Condition =>
|
||||
Make_Op_Ne (Loc,
|
||||
Left_Opnd => Duplicate_Subexpr (Arg),
|
||||
Right_Opnd => Make_Null (Loc)),
|
||||
Then_Statements => Stmts);
|
||||
|
||||
else
|
||||
Gen_Code :=
|
||||
Make_Block_Statement (Loc,
|
||||
Handled_Statement_Sequence =>
|
||||
Make_Handled_Sequence_Of_Statements (Loc,
|
||||
Statements => Stmts));
|
||||
end if;
|
||||
end;
|
||||
|
||||
-- Deal with storage pool
|
||||
|
||||
if Present (Pool) then
|
||||
|
||||
-- Freeing the secondary stack is meaningless
|
||||
|
||||
if Is_RTE (Pool, RE_SS_Pool) then
|
||||
null;
|
||||
|
||||
else
|
||||
Set_Procedure_To_Call (Free_Node,
|
||||
Find_Prim_Op (Etype (Pool), Name_Deallocate));
|
||||
|
||||
-- If the type is class wide, we generate an implicit type
|
||||
-- with the right dynamic size, so that the deallocate call
|
||||
-- gets the right size parameter computed by gigi
|
||||
|
||||
if Is_Class_Wide_Type (Desig_T) then
|
||||
declare
|
||||
Acc_Type : constant Entity_Id :=
|
||||
Create_Itype (E_Access_Type, N);
|
||||
Deref : constant Node_Id :=
|
||||
Make_Explicit_Dereference (Loc,
|
||||
Duplicate_Subexpr (Arg));
|
||||
|
||||
begin
|
||||
Set_Etype (Deref, Typ);
|
||||
Set_Parent (Deref, Free_Node);
|
||||
|
||||
Set_Etype (Acc_Type, Acc_Type);
|
||||
Set_Size_Info (Acc_Type, Typ);
|
||||
Set_Directly_Designated_Type
|
||||
(Acc_Type, Entity (Make_Subtype_From_Expr
|
||||
(Deref, Desig_T)));
|
||||
|
||||
Free_Arg := Unchecked_Convert_To (Acc_Type, Free_Arg);
|
||||
end;
|
||||
end if;
|
||||
end if;
|
||||
end if;
|
||||
|
||||
Set_Expression (Free_Node, Free_Arg);
|
||||
|
||||
declare
|
||||
Lhs : Node_Id := Duplicate_Subexpr (Arg);
|
||||
|
||||
begin
|
||||
Set_Assignment_OK (Lhs);
|
||||
Append_To (Stmts,
|
||||
Make_Assignment_Statement (Loc,
|
||||
Name => Lhs,
|
||||
Expression => Make_Null (Loc)));
|
||||
end;
|
||||
|
||||
Rewrite (N, Gen_Code);
|
||||
Analyze (N);
|
||||
end Expand_Unc_Deallocation;
|
||||
|
||||
end Exp_Intr;
|
|
@ -0,0 +1,42 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- E X P _ I N T R --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.2 $ --
|
||||
-- --
|
||||
-- Copyright (C) 1992,1993,1994 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- Processing for expanding intrinsic subprogram calls
|
||||
|
||||
with Types; use Types;
|
||||
|
||||
package Exp_Intr is
|
||||
|
||||
procedure Expand_Intrinsic_Call (N : Node_Id; E : Entity_Id);
|
||||
-- N is either a function call node, or a procedure call statement node
|
||||
-- where the corresponding subprogram is intrinsic (i.e. was the subject
|
||||
-- of a Import or Interface pragma specifying the subprogram as intrinsic.
|
||||
-- The effect is to replace the call with appropriate specialized nodes.
|
||||
-- The second argument is the entity for the subprogram spec.
|
||||
|
||||
end Exp_Intr;
|
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,280 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- E X P _ P A K D --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.22 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- Expand routines for manipulation of packed arrays
|
||||
|
||||
with Types; use Types;
|
||||
|
||||
package Exp_Pakd is
|
||||
|
||||
-------------------------------------
|
||||
-- Implementation of Packed Arrays --
|
||||
-------------------------------------
|
||||
|
||||
-- When a packed array (sub)type is frozen, we create a corresponding
|
||||
-- type that will be used to hold the bits of the packed value, and
|
||||
-- store the entity for this type in the Packed_Array_Type field of the
|
||||
-- E_Array_Type or E_Array_Subtype entity for the packed array.
|
||||
|
||||
-- This packed array type has the name xxxPn, where xxx is the name
|
||||
-- of the packed type, and n is the component size. The expanded
|
||||
-- declaration declares a type that is one of the following:
|
||||
|
||||
-- For an unconstrained array with component size 1,2,4 or any other
|
||||
-- odd component size. These are the cases in which we do not need
|
||||
-- to align the underlying array.
|
||||
|
||||
-- type xxxPn is new Packed_Bytes1;
|
||||
|
||||
-- For an unconstrained array with component size that is divisible
|
||||
-- by 2, but not divisible by 4 (other than 2 itself). These are the
|
||||
-- cases in which we can generate better code if the underlying array
|
||||
-- is 2-byte aligned (see System.Pack_14 in file s-pack14 for example).
|
||||
|
||||
-- type xxxPn is new Packed_Bytes2;
|
||||
|
||||
-- For an unconstrained array with component size that is divisible
|
||||
-- by 4, other than powers of 2 (which either come under the 1,2,4
|
||||
-- exception above, or are not packed at all). These are cases where
|
||||
-- we can generate better code if the underlying array is 4-byte
|
||||
-- aligned (see System.Pack_20 in file s-pack20 for example).
|
||||
|
||||
-- type xxxPn is new Packed_Bytes4;
|
||||
|
||||
-- For a constrained array with a static index type where the number
|
||||
-- of bits does not exceed the size of Unsigned:
|
||||
|
||||
-- type xxxPn is new Unsigned range 0 .. 2 ** nbits - 1;
|
||||
|
||||
-- For a constrained array with a static index type where the number
|
||||
-- of bits is greater than the size of Unsigned, but does not exceed
|
||||
-- the size of Long_Long_Unsigned:
|
||||
|
||||
-- type xxxPn is new Long_Long_Unsigned range 0 .. 2 ** nbits - 1;
|
||||
|
||||
-- For all other constrained arrays, we use one of
|
||||
|
||||
-- type xxxPn is new Packed_Bytes1 (0 .. m);
|
||||
-- type xxxPn is new Packed_Bytes2 (0 .. m);
|
||||
-- type xxxPn is new Packed_Bytes4 (0 .. m);
|
||||
|
||||
-- where m is calculated (from the length of the original packed array)
|
||||
-- to hold the required number of bits, and the choice of the particular
|
||||
-- Packed_Bytes{1,2,4} type is made on the basis of alignment needs as
|
||||
-- described above for the unconstrained case.
|
||||
|
||||
-- When a variable of packed array type is allocated, gigi will allocate
|
||||
-- the amount of space indicated by the corresponding packed array type.
|
||||
-- However, we do NOT attempt to rewrite the types of any references or
|
||||
-- to retype the variable itself, since this would cause all kinds of
|
||||
-- semantic problems in the front end (remember that expansion proceeds
|
||||
-- at the same time as analysis).
|
||||
|
||||
-- For an indexed reference to a packed array, we simply convert the
|
||||
-- reference to the appropriate equivalent reference to the object
|
||||
-- of the packed array type (using unchecked conversion).
|
||||
|
||||
-- In some cases (for internally generated types, and for the subtypes
|
||||
-- for record fields that depend on a discriminant), the corresponding
|
||||
-- packed type cannot be easily generated in advance. In these cases,
|
||||
-- we generate the required subtype on the fly at the reference point.
|
||||
|
||||
-- For the modular case, any unused bits are initialized to zero, and
|
||||
-- all operations maintain these bits as zero (where necessary all
|
||||
-- unchecked conversions from corresponding array values require
|
||||
-- these bits to be clear, which is done automatically by gigi).
|
||||
|
||||
-- For the array cases, there can be unused bits in the last byte, and
|
||||
-- these are neither initialized, nor treated specially in operations
|
||||
-- (i.e. it is allowable for these bits to be clobbered, e.g. by not).
|
||||
|
||||
---------------------------
|
||||
-- Endian Considerations --
|
||||
---------------------------
|
||||
|
||||
-- The standard does not specify the way in which bits are numbered in
|
||||
-- a packed array. There are two reasonable rules for deciding this:
|
||||
|
||||
-- Store the first bit at right end (low order) word. This means
|
||||
-- that the scaled subscript can be used directly as a right shift
|
||||
-- count (if we put bit 0 at the left end, then we need an extra
|
||||
-- subtract to compute the shift count.
|
||||
|
||||
-- Layout the bits so that if the packed boolean array is overlaid on
|
||||
-- a record, using unchecked conversion, then bit 0 of the array is
|
||||
-- the same as the bit numbered bit 0 in a record representation
|
||||
-- clause applying to the record. For example:
|
||||
|
||||
-- type Rec is record
|
||||
-- C : Bits4;
|
||||
-- D : Bits7;
|
||||
-- E : Bits5;
|
||||
-- end record;
|
||||
|
||||
-- for Rec use record
|
||||
-- C at 0 range 0 .. 3;
|
||||
-- D at 0 range 4 .. 10;
|
||||
-- E at 0 range 11 .. 15;
|
||||
-- end record;
|
||||
|
||||
-- type P16 is array (0 .. 15) of Boolean;
|
||||
-- pragma Pack (P16);
|
||||
|
||||
-- Now if we use unchecked conversion to convert a value of the record
|
||||
-- type to the packed array type, according to this second criterion,
|
||||
-- we would expect field D to occupy bits 4..10 of the Boolean array.
|
||||
|
||||
-- Although not required, this correspondence seems a highly desirable
|
||||
-- property, and is one that GNAT decides to guarantee. For a little
|
||||
-- endian machine, we can also meet the first requirement, but for a
|
||||
-- big endian machine, it will be necessary to store the first bit of
|
||||
-- a Boolean array in the left end (most significant) bit of the word.
|
||||
-- This may cost an extra instruction on some machines, but we consider
|
||||
-- that a worthwhile price to pay for the consistency.
|
||||
|
||||
-- One more important point arises in the case where we have a constrained
|
||||
-- subtype of an unconstrained array. Take the case of 20-bits. For the
|
||||
-- unconstrained representation, we would use an array of bytes:
|
||||
|
||||
-- Little-endian case
|
||||
-- 8-7-6-5-4-3-2-1 16-15-14-13-12-11-10-9 x-x-x-x-20-19-18-17
|
||||
|
||||
-- Big-endian case
|
||||
-- 1-2-3-4-5-6-7-8 9-10-11-12-13-14-15-16 17-18-19-20-x-x-x-x
|
||||
|
||||
-- For the constrained case, we use a 20-bit modular value, but in
|
||||
-- general this value may well be stored in 32 bits. Let's look at
|
||||
-- what it looks like:
|
||||
|
||||
-- Little-endian case
|
||||
|
||||
-- x-x-x-x-x-x-x-x-x-x-x-x-20-19-18-17-...-10-9-8-7-6-5-4-3-2-1
|
||||
|
||||
-- which stored in memory looks like
|
||||
|
||||
-- 8-7-...-2-1 16-15-...-10-9 x-x-x-x-20-19-18-17 x-x-x-x-x-x-x
|
||||
|
||||
-- An important rule is that the constrained and unconstrained cases
|
||||
-- must have the same bit representation in memory, since we will often
|
||||
-- convert from one to the other (e.g. when calling a procedure whose
|
||||
-- formal is unconstrained). As we see, that criterion is met for the
|
||||
-- little-endian case above. Now let's look at the big-endian case:
|
||||
|
||||
-- Big-endian case
|
||||
|
||||
-- x-x-x-x-x-x-x-x-x-x-x-x-1-2-3-4-5-6-7-8-9-10-...-17-18-19-20
|
||||
|
||||
-- which stored in memory looks like
|
||||
|
||||
-- x-x-x-x-x-x-x-x x-x-x-x-1-2-3-4 5-6-...11-12 13-14-...-19-20
|
||||
|
||||
-- That won't do, the representation value in memory is NOT the same in
|
||||
-- the constrained and unconstrained case. The solution is to store the
|
||||
-- modular value left-justified:
|
||||
|
||||
-- 1-2-3-4-5-6-7-8-9-10-...-17-18-19-20-x-x-x-x-x-x-x-x-x-x-x
|
||||
|
||||
-- which stored in memory looks like
|
||||
|
||||
-- 1-2-...-7-8 9-10-...15-16 17-18-19-20-x-x-x-x x-x-x-x-x-x-x-x
|
||||
|
||||
-- and now, we do indeed have the same representation. The special flag
|
||||
-- Is_Left_Justified_Modular is set in the modular type used as the
|
||||
-- packed array type in the big-endian case to ensure that this required
|
||||
-- left justification occurs.
|
||||
|
||||
-----------------
|
||||
-- Subprograms --
|
||||
-----------------
|
||||
|
||||
procedure Create_Packed_Array_Type (Typ : Entity_Id);
|
||||
-- Typ is a array type or subtype to which pragma Pack applies. If the
|
||||
-- Packed_Array_Type field of Typ is already set, then the call has no
|
||||
-- effect, otherwise a suitable type or subtype is created and stored
|
||||
-- in the Packed_Array_Type field of Typ. This created type is an Itype
|
||||
-- so that Gigi will simply elaborate and freeze the type on first use
|
||||
-- (which is typically the definition of the corresponding array type).
|
||||
--
|
||||
-- Note: although this routine is included in the expander package for
|
||||
-- packed types, it is actually called unconditionally from Freeze,
|
||||
-- whether or not expansion (and code generation) is enabled. We do this
|
||||
-- since we want gigi to be able to properly compute type charactersitics
|
||||
-- (for the Data Decomposition Annex of ASIS, and possible other future
|
||||
-- uses) even if code generation is not active. Strictly this means that
|
||||
-- this procedure is not part of the expander, but it seems appropriate
|
||||
-- to keep it together with the other expansion routines that have to do
|
||||
-- with packed array types.
|
||||
|
||||
procedure Expand_Packed_Boolean_Operator (N : Node_Id);
|
||||
-- N is an N_Op_And, N_Op_Or or N_Op_Xor node whose operand type is a
|
||||
-- packed boolean array. This routine expands the appropriate operations
|
||||
-- to carry out the logical operation on the packed arrays. It handles
|
||||
-- both the modular and array representation cases.
|
||||
|
||||
procedure Expand_Packed_Element_Reference (N : Node_Id);
|
||||
-- N is an N_Indexed_Component node whose prefix is a packed array. In
|
||||
-- the bit packed case, this routine can only be used for the expression
|
||||
-- evaluation case not the assignment case, since the result is not a
|
||||
-- variable. See Expand_Bit_Packed_Element_Set for how he assignment case
|
||||
-- is handled in the bit packed case. For the enumeration case, the result
|
||||
-- of this call is always a variable, so the call can be used for both the
|
||||
-- expression evaluation and assignment cases.
|
||||
|
||||
procedure Expand_Bit_Packed_Element_Set (N : Node_Id);
|
||||
-- N is an N_Assignment_Statement node whose name is an indexed
|
||||
-- component of a bit-packed array. This procedure rewrites the entire
|
||||
-- assignment statement with appropriate code to set the referenced
|
||||
-- bits of the packed array type object. Note that this procedure is
|
||||
-- used only for the bit-packed case, not for the enumeration case.
|
||||
|
||||
procedure Expand_Packed_Eq (N : Node_Id);
|
||||
-- N is an N_Op_Eq node where the operands are packed arrays whose
|
||||
-- representation is an array-of-bytes type (the case where a modular
|
||||
-- type is used for the representation does not require any special
|
||||
-- handling, because in the modular case, unused bits are zeroes.
|
||||
|
||||
procedure Expand_Packed_Not (N : Node_Id);
|
||||
-- N is an N_Op_Not node where the operand is packed array of Boolean
|
||||
-- in standard representation (i.e. component size is one bit). This
|
||||
-- procedure expands the corresponding not operation. Note that the
|
||||
-- non-standard representation case is handled by using a loop through
|
||||
-- elements generated by the normal non-packed circuitry.
|
||||
|
||||
function Involves_Packed_Array_Reference (N : Node_Id) return Boolean;
|
||||
-- N is the node for a name. This function returns true if the name
|
||||
-- involves a packed array reference. A node involves a packed array
|
||||
-- reference if it is itself an indexed compoment referring to a bit-
|
||||
-- packed array, or it is a selected component whose prefix involves
|
||||
-- a packed array reference.
|
||||
|
||||
procedure Expand_Packed_Address_Reference (N : Node_Id);
|
||||
-- The node N is an attribute reference for the 'Address reference, where
|
||||
-- the prefix involves a packed array reference. This routine expands the
|
||||
-- necessary code for performing the address reference in this case.
|
||||
|
||||
end Exp_Pakd;
|
|
@ -0,0 +1,539 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- E X P _ P R A G --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.53 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Atree; use Atree;
|
||||
with Casing; use Casing;
|
||||
with Einfo; use Einfo;
|
||||
with Errout; use Errout;
|
||||
with Exp_Ch11; use Exp_Ch11;
|
||||
with Exp_Tss; use Exp_Tss;
|
||||
with Exp_Util; use Exp_Util;
|
||||
with Expander; use Expander;
|
||||
with Namet; use Namet;
|
||||
with Nlists; use Nlists;
|
||||
with Nmake; use Nmake;
|
||||
with Opt; use Opt;
|
||||
with Rtsfind; use Rtsfind;
|
||||
with Sem; use Sem;
|
||||
with Sem_Eval; use Sem_Eval;
|
||||
with Sem_Res; use Sem_Res;
|
||||
with Sem_Util; use Sem_Util;
|
||||
with Sinfo; use Sinfo;
|
||||
with Sinput; use Sinput;
|
||||
with Snames; use Snames;
|
||||
with Stringt; use Stringt;
|
||||
with Stand; use Stand;
|
||||
with Tbuild; use Tbuild;
|
||||
with Uintp; use Uintp;
|
||||
|
||||
package body Exp_Prag is
|
||||
|
||||
-----------------------
|
||||
-- Local Subprograms --
|
||||
-----------------------
|
||||
|
||||
function Arg1 (N : Node_Id) return Node_Id;
|
||||
function Arg2 (N : Node_Id) return Node_Id;
|
||||
function Arg3 (N : Node_Id) return Node_Id;
|
||||
-- Obtain specified Pragma_Argument_Association
|
||||
|
||||
procedure Expand_Pragma_Abort_Defer (N : Node_Id);
|
||||
procedure Expand_Pragma_Assert (N : Node_Id);
|
||||
procedure Expand_Pragma_Import (N : Node_Id);
|
||||
procedure Expand_Pragma_Import_Export_Exception (N : Node_Id);
|
||||
procedure Expand_Pragma_Inspection_Point (N : Node_Id);
|
||||
procedure Expand_Pragma_Interrupt_Priority (N : Node_Id);
|
||||
|
||||
--------------
|
||||
-- Arg1,2,3 --
|
||||
--------------
|
||||
|
||||
function Arg1 (N : Node_Id) return Node_Id is
|
||||
begin
|
||||
return First (Pragma_Argument_Associations (N));
|
||||
end Arg1;
|
||||
|
||||
function Arg2 (N : Node_Id) return Node_Id is
|
||||
begin
|
||||
return Next (Arg1 (N));
|
||||
end Arg2;
|
||||
|
||||
function Arg3 (N : Node_Id) return Node_Id is
|
||||
begin
|
||||
return Next (Arg2 (N));
|
||||
end Arg3;
|
||||
|
||||
---------------------
|
||||
-- Expand_N_Pragma --
|
||||
---------------------
|
||||
|
||||
procedure Expand_N_Pragma (N : Node_Id) is
|
||||
begin
|
||||
-- Note: we may have a pragma whose chars field is not a
|
||||
-- recognized pragma, and we must ignore it at this stage.
|
||||
|
||||
if Is_Pragma_Name (Chars (N)) then
|
||||
case Get_Pragma_Id (Chars (N)) is
|
||||
|
||||
-- Pragmas requiring special expander action
|
||||
|
||||
when Pragma_Abort_Defer =>
|
||||
Expand_Pragma_Abort_Defer (N);
|
||||
|
||||
when Pragma_Assert =>
|
||||
Expand_Pragma_Assert (N);
|
||||
|
||||
when Pragma_Export_Exception =>
|
||||
Expand_Pragma_Import_Export_Exception (N);
|
||||
|
||||
when Pragma_Import =>
|
||||
Expand_Pragma_Import (N);
|
||||
|
||||
when Pragma_Import_Exception =>
|
||||
Expand_Pragma_Import_Export_Exception (N);
|
||||
|
||||
when Pragma_Inspection_Point =>
|
||||
Expand_Pragma_Inspection_Point (N);
|
||||
|
||||
when Pragma_Interrupt_Priority =>
|
||||
Expand_Pragma_Interrupt_Priority (N);
|
||||
|
||||
-- All other pragmas need no expander action
|
||||
|
||||
when others => null;
|
||||
end case;
|
||||
end if;
|
||||
|
||||
end Expand_N_Pragma;
|
||||
|
||||
-------------------------------
|
||||
-- Expand_Pragma_Abort_Defer --
|
||||
-------------------------------
|
||||
|
||||
-- An Abort_Defer pragma appears as the first statement in a handled
|
||||
-- statement sequence (right after the begin). It defers aborts for
|
||||
-- the entire statement sequence, but not for any declarations or
|
||||
-- handlers (if any) associated with this statement sequence.
|
||||
|
||||
-- The transformation is to transform
|
||||
|
||||
-- pragma Abort_Defer;
|
||||
-- statements;
|
||||
|
||||
-- into
|
||||
|
||||
-- begin
|
||||
-- Abort_Defer.all;
|
||||
-- statements
|
||||
-- exception
|
||||
-- when all others =>
|
||||
-- Abort_Undefer.all;
|
||||
-- raise;
|
||||
-- at end
|
||||
-- Abort_Undefer_Direct;
|
||||
-- end;
|
||||
|
||||
procedure Expand_Pragma_Abort_Defer (N : Node_Id) is
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
Stm : Node_Id;
|
||||
Stms : List_Id;
|
||||
HSS : Node_Id;
|
||||
Blk : constant Entity_Id :=
|
||||
New_Internal_Entity (E_Block, Current_Scope, Sloc (N), 'B');
|
||||
|
||||
begin
|
||||
Stms := New_List (Build_Runtime_Call (Loc, RE_Abort_Defer));
|
||||
|
||||
loop
|
||||
Stm := Remove_Next (N);
|
||||
exit when No (Stm);
|
||||
Append (Stm, Stms);
|
||||
end loop;
|
||||
|
||||
HSS :=
|
||||
Make_Handled_Sequence_Of_Statements (Loc,
|
||||
Statements => Stms,
|
||||
At_End_Proc =>
|
||||
New_Occurrence_Of (RTE (RE_Abort_Undefer_Direct), Loc));
|
||||
|
||||
Rewrite (N,
|
||||
Make_Block_Statement (Loc,
|
||||
Handled_Statement_Sequence => HSS));
|
||||
|
||||
Set_Scope (Blk, Current_Scope);
|
||||
Set_Etype (Blk, Standard_Void_Type);
|
||||
Set_Identifier (N, New_Occurrence_Of (Blk, Sloc (N)));
|
||||
Expand_At_End_Handler (HSS, Blk);
|
||||
Analyze (N);
|
||||
end Expand_Pragma_Abort_Defer;
|
||||
|
||||
--------------------------
|
||||
-- Expand_Pragma_Assert --
|
||||
--------------------------
|
||||
|
||||
procedure Expand_Pragma_Assert (N : Node_Id) is
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
Cond : constant Node_Id := Expression (Arg1 (N));
|
||||
Msg : String_Id;
|
||||
|
||||
begin
|
||||
-- We already know that assertions are enabled, because otherwise
|
||||
-- the semantic pass dealt with rewriting the assertion (see Sem_Prag)
|
||||
|
||||
pragma Assert (Assertions_Enabled);
|
||||
|
||||
-- Since assertions are on, we rewrite the pragma with its
|
||||
-- corresponding if statement, and then analyze the statement
|
||||
-- The expansion transforms:
|
||||
|
||||
-- pragma Assert (condition [,message]);
|
||||
|
||||
-- into
|
||||
|
||||
-- if not condition then
|
||||
-- System.Assertions.Raise_Assert_Failure (Str);
|
||||
-- end if;
|
||||
|
||||
-- where Str is the message if one is present, or the default of
|
||||
-- file:line if no message is given.
|
||||
|
||||
-- First, we need to prepare the character literal
|
||||
|
||||
if Present (Arg2 (N)) then
|
||||
Msg := Strval (Expr_Value_S (Expression (Arg2 (N))));
|
||||
else
|
||||
Build_Location_String (Loc);
|
||||
Msg := String_From_Name_Buffer;
|
||||
end if;
|
||||
|
||||
-- Now generate the if statement. Note that we consider this to be
|
||||
-- an explicit conditional in the source, not an implicit if, so we
|
||||
-- do not call Make_Implicit_If_Statement.
|
||||
|
||||
Rewrite (N,
|
||||
Make_If_Statement (Loc,
|
||||
Condition =>
|
||||
Make_Op_Not (Loc,
|
||||
Right_Opnd => Cond),
|
||||
Then_Statements => New_List (
|
||||
Make_Procedure_Call_Statement (Loc,
|
||||
Name =>
|
||||
New_Reference_To (RTE (RE_Raise_Assert_Failure), Loc),
|
||||
Parameter_Associations => New_List (
|
||||
Make_String_Literal (Loc, Msg))))));
|
||||
|
||||
Analyze (N);
|
||||
|
||||
-- If new condition is always false, give a warning
|
||||
|
||||
if Nkind (N) = N_Procedure_Call_Statement
|
||||
and then Is_RTE (Entity (Name (N)), RE_Raise_Assert_Failure)
|
||||
then
|
||||
-- If original condition was a Standard.False, we assume
|
||||
-- that this is indeed intented to raise assert error
|
||||
-- and no warning is required.
|
||||
|
||||
if Is_Entity_Name (Original_Node (Cond))
|
||||
and then Entity (Original_Node (Cond)) = Standard_False
|
||||
then
|
||||
return;
|
||||
else
|
||||
Error_Msg_N ("?assertion will fail at run-time", N);
|
||||
end if;
|
||||
end if;
|
||||
end Expand_Pragma_Assert;
|
||||
|
||||
--------------------------
|
||||
-- Expand_Pragma_Import --
|
||||
--------------------------
|
||||
|
||||
-- When applied to a variable, the default initialization must not be
|
||||
-- done. As it is already done when the pragma is found, we just get rid
|
||||
-- of the call the initialization procedure which followed the object
|
||||
-- declaration.
|
||||
|
||||
-- We can't use the freezing mechanism for this purpose, since we
|
||||
-- have to elaborate the initialization expression when it is first
|
||||
-- seen (i.e. this elaboration cannot be deferred to the freeze point).
|
||||
|
||||
procedure Expand_Pragma_Import (N : Node_Id) is
|
||||
Def_Id : constant Entity_Id := Entity (Expression (Arg2 (N)));
|
||||
Typ : Entity_Id;
|
||||
After_Def : Node_Id;
|
||||
|
||||
begin
|
||||
if Ekind (Def_Id) = E_Variable then
|
||||
Typ := Etype (Def_Id);
|
||||
After_Def := Next (Parent (Def_Id));
|
||||
|
||||
if Has_Non_Null_Base_Init_Proc (Typ)
|
||||
and then Nkind (After_Def) = N_Procedure_Call_Statement
|
||||
and then Is_Entity_Name (Name (After_Def))
|
||||
and then Entity (Name (After_Def)) = Base_Init_Proc (Typ)
|
||||
then
|
||||
Remove (After_Def);
|
||||
|
||||
elsif Is_Access_Type (Typ) then
|
||||
Set_Expression (Parent (Def_Id), Empty);
|
||||
end if;
|
||||
end if;
|
||||
end Expand_Pragma_Import;
|
||||
|
||||
-------------------------------------------
|
||||
-- Expand_Pragma_Import_Export_Exception --
|
||||
-------------------------------------------
|
||||
|
||||
-- For a VMS exception fix up the language field with "VMS"
|
||||
-- instead of "Ada" (gigi needs this), create a constant that will be the
|
||||
-- value of the VMS condition code and stuff the Interface_Name field
|
||||
-- with the unexpanded name of the exception (if not already set).
|
||||
-- For a Ada exception, just stuff the Interface_Name field
|
||||
-- with the unexpanded name of the exception (if not already set).
|
||||
|
||||
procedure Expand_Pragma_Import_Export_Exception (N : Node_Id) is
|
||||
Id : constant Entity_Id := Entity (Expression (Arg1 (N)));
|
||||
Call : constant Node_Id := Register_Exception_Call (Id);
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
begin
|
||||
if Present (Call) then
|
||||
declare
|
||||
Excep_Internal : constant Node_Id :=
|
||||
Make_Defining_Identifier
|
||||
(Loc, New_Internal_Name ('V'));
|
||||
Export_Pragma : Node_Id;
|
||||
Excep_Alias : Node_Id;
|
||||
Excep_Object : Node_Id;
|
||||
Excep_Image : String_Id;
|
||||
Exdata : List_Id;
|
||||
Lang1 : Node_Id;
|
||||
Lang2 : Node_Id;
|
||||
Lang3 : Node_Id;
|
||||
Code : Node_Id;
|
||||
begin
|
||||
if Present (Interface_Name (Id)) then
|
||||
Excep_Image := Strval (Interface_Name (Id));
|
||||
else
|
||||
Get_Name_String (Chars (Id));
|
||||
Set_All_Upper_Case;
|
||||
Excep_Image := String_From_Name_Buffer;
|
||||
end if;
|
||||
|
||||
Exdata := Component_Associations (Expression (Parent (Id)));
|
||||
|
||||
if Is_VMS_Exception (Id) then
|
||||
|
||||
Lang1 := Next (First (Exdata));
|
||||
Lang2 := Next (Lang1);
|
||||
Lang3 := Next (Lang2);
|
||||
|
||||
Rewrite (Expression (Lang1),
|
||||
Make_Character_Literal (Loc, Name_uV, Get_Char_Code ('V')));
|
||||
Analyze (Expression (Lang1));
|
||||
|
||||
Rewrite (Expression (Lang2),
|
||||
Make_Character_Literal (Loc, Name_uM, Get_Char_Code ('M')));
|
||||
Analyze (Expression (Lang2));
|
||||
|
||||
Rewrite (Expression (Lang3),
|
||||
Make_Character_Literal (Loc, Name_uS, Get_Char_Code ('S')));
|
||||
Analyze (Expression (Lang3));
|
||||
|
||||
if Exception_Code (Id) /= No_Uint then
|
||||
Code := Make_Integer_Literal (Loc, Exception_Code (Id));
|
||||
|
||||
Excep_Object :=
|
||||
Make_Object_Declaration (Loc,
|
||||
Defining_Identifier => Excep_Internal,
|
||||
Object_Definition =>
|
||||
New_Reference_To (Standard_Integer, Loc));
|
||||
|
||||
Insert_Action (N, Excep_Object);
|
||||
Analyze (Excep_Object);
|
||||
|
||||
Start_String;
|
||||
Store_String_Int (UI_To_Int (Exception_Code (Id)) / 8 * 8);
|
||||
|
||||
Excep_Alias :=
|
||||
Make_Pragma
|
||||
(Loc,
|
||||
Name_Linker_Alias,
|
||||
New_List
|
||||
(Make_Pragma_Argument_Association
|
||||
(Sloc => Loc,
|
||||
Expression =>
|
||||
New_Reference_To (Excep_Internal, Loc)),
|
||||
Make_Pragma_Argument_Association
|
||||
(Sloc => Loc,
|
||||
Expression =>
|
||||
Make_String_Literal
|
||||
(Sloc => Loc,
|
||||
Strval => End_String))));
|
||||
|
||||
Insert_Action (N, Excep_Alias);
|
||||
Analyze (Excep_Alias);
|
||||
|
||||
Export_Pragma :=
|
||||
Make_Pragma
|
||||
(Loc,
|
||||
Name_Export,
|
||||
New_List
|
||||
(Make_Pragma_Argument_Association
|
||||
(Sloc => Loc,
|
||||
Expression => Make_Identifier (Loc, Name_C)),
|
||||
Make_Pragma_Argument_Association
|
||||
(Sloc => Loc,
|
||||
Expression =>
|
||||
New_Reference_To (Excep_Internal, Loc)),
|
||||
Make_Pragma_Argument_Association
|
||||
(Sloc => Loc,
|
||||
Expression =>
|
||||
Make_String_Literal
|
||||
(Sloc => Loc,
|
||||
Strval => Excep_Image)),
|
||||
Make_Pragma_Argument_Association
|
||||
(Sloc => Loc,
|
||||
Expression =>
|
||||
Make_String_Literal
|
||||
(Sloc => Loc,
|
||||
Strval => Excep_Image))));
|
||||
|
||||
Insert_Action (N, Export_Pragma);
|
||||
Analyze (Export_Pragma);
|
||||
|
||||
else
|
||||
Code :=
|
||||
Unchecked_Convert_To (Standard_Integer,
|
||||
Make_Function_Call (Loc,
|
||||
Name =>
|
||||
New_Reference_To (RTE (RE_Import_Value), Loc),
|
||||
Parameter_Associations => New_List
|
||||
(Make_String_Literal (Loc,
|
||||
Strval => Excep_Image))));
|
||||
end if;
|
||||
|
||||
Rewrite (Call,
|
||||
Make_Procedure_Call_Statement (Loc,
|
||||
Name => New_Reference_To
|
||||
(RTE (RE_Register_VMS_Exception), Loc),
|
||||
Parameter_Associations => New_List (Code)));
|
||||
|
||||
Analyze_And_Resolve (Code, Standard_Integer);
|
||||
Analyze (Call);
|
||||
|
||||
end if;
|
||||
|
||||
if not Present (Interface_Name (Id)) then
|
||||
Set_Interface_Name (Id,
|
||||
Make_String_Literal
|
||||
(Sloc => Loc,
|
||||
Strval => Excep_Image));
|
||||
end if;
|
||||
end;
|
||||
end if;
|
||||
end Expand_Pragma_Import_Export_Exception;
|
||||
|
||||
------------------------------------
|
||||
-- Expand_Pragma_Inspection_Point --
|
||||
------------------------------------
|
||||
|
||||
-- If no argument is given, then we supply a default argument list that
|
||||
-- includes all objects declared at the source level in all subprograms
|
||||
-- that enclose the inspection point pragma.
|
||||
|
||||
procedure Expand_Pragma_Inspection_Point (N : Node_Id) is
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
A : List_Id;
|
||||
Assoc : Node_Id;
|
||||
S : Entity_Id;
|
||||
E : Entity_Id;
|
||||
|
||||
begin
|
||||
if No (Pragma_Argument_Associations (N)) then
|
||||
A := New_List;
|
||||
S := Current_Scope;
|
||||
|
||||
while S /= Standard_Standard loop
|
||||
E := First_Entity (S);
|
||||
while Present (E) loop
|
||||
if Comes_From_Source (E)
|
||||
and then Is_Object (E)
|
||||
and then not Is_Entry_Formal (E)
|
||||
and then Ekind (E) /= E_Component
|
||||
and then Ekind (E) /= E_Discriminant
|
||||
and then Ekind (E) /= E_Generic_In_Parameter
|
||||
and then Ekind (E) /= E_Generic_In_Out_Parameter
|
||||
then
|
||||
Append_To (A,
|
||||
Make_Pragma_Argument_Association (Loc,
|
||||
Expression => New_Occurrence_Of (E, Loc)));
|
||||
end if;
|
||||
|
||||
Next_Entity (E);
|
||||
end loop;
|
||||
|
||||
S := Scope (S);
|
||||
end loop;
|
||||
|
||||
Set_Pragma_Argument_Associations (N, A);
|
||||
end if;
|
||||
|
||||
-- Expand the arguments of the pragma. Expanding an entity reference
|
||||
-- is a noop, except in a protected operation, where a reference may
|
||||
-- have to be transformed into a reference to the corresponding prival.
|
||||
-- Are there other pragmas that may require this ???
|
||||
|
||||
Assoc := First (Pragma_Argument_Associations (N));
|
||||
|
||||
while Present (Assoc) loop
|
||||
Expand (Expression (Assoc));
|
||||
Next (Assoc);
|
||||
end loop;
|
||||
end Expand_Pragma_Inspection_Point;
|
||||
|
||||
--------------------------------------
|
||||
-- Expand_Pragma_Interrupt_Priority --
|
||||
--------------------------------------
|
||||
|
||||
-- Supply default argument if none exists (System.Interrupt_Priority'Last)
|
||||
|
||||
procedure Expand_Pragma_Interrupt_Priority (N : Node_Id) is
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
|
||||
begin
|
||||
if No (Pragma_Argument_Associations (N)) then
|
||||
Set_Pragma_Argument_Associations (N, New_List (
|
||||
Make_Pragma_Argument_Association (Loc,
|
||||
Expression =>
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix =>
|
||||
New_Occurrence_Of (RTE (RE_Interrupt_Priority), Loc),
|
||||
Attribute_Name => Name_Last))));
|
||||
end if;
|
||||
end Expand_Pragma_Interrupt_Priority;
|
||||
|
||||
end Exp_Prag;
|
|
@ -0,0 +1,37 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- E X P _ P R A G --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.3 $ --
|
||||
-- --
|
||||
-- Copyright (C) 1992,1993,1994 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- Expand routines for pragmas
|
||||
|
||||
with Types; use Types;
|
||||
|
||||
package Exp_Prag is
|
||||
|
||||
procedure Expand_N_Pragma (N : Node_Id);
|
||||
|
||||
end Exp_Prag;
|
|
@ -0,0 +1,502 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- E X P _ S M E M --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.5 $
|
||||
-- --
|
||||
-- Copyright (C) 1998-2000 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Atree; use Atree;
|
||||
with Einfo; use Einfo;
|
||||
with Exp_Util; use Exp_Util;
|
||||
with Nmake; use Nmake;
|
||||
with Namet; use Namet;
|
||||
with Nlists; use Nlists;
|
||||
with Rtsfind; use Rtsfind;
|
||||
with Sem; use Sem;
|
||||
with Sem_Util; use Sem_Util;
|
||||
with Sinfo; use Sinfo;
|
||||
with Snames; use Snames;
|
||||
with Stand; use Stand;
|
||||
with Stringt; use Stringt;
|
||||
with Tbuild; use Tbuild;
|
||||
|
||||
package body Exp_Smem is
|
||||
|
||||
Insert_Node : Node_Id;
|
||||
-- Node after which a write call is to be inserted
|
||||
|
||||
-----------------------
|
||||
-- Local Subprograms --
|
||||
-----------------------
|
||||
|
||||
procedure Add_Read_Before (N : Node_Id);
|
||||
-- Insert a Shared_Var_ROpen call for variable before node N
|
||||
|
||||
procedure Add_Write_After (N : Node_Id);
|
||||
-- Insert a Shared_Var_WOpen call for variable after the node
|
||||
-- Insert_Node, as recorded by On_Lhs_Of_Assigment (where it points
|
||||
-- to the assignment statement) or Is_Out_Actual (where it points to
|
||||
-- the procedure call statement).
|
||||
|
||||
procedure Build_Full_Name
|
||||
(E : in Entity_Id;
|
||||
N : out String_Id);
|
||||
-- Build the fully qualified string name of a shared variable.
|
||||
|
||||
function On_Lhs_Of_Assignment (N : Node_Id) return Boolean;
|
||||
-- Determines if N is on the left hand of the assignment. This means
|
||||
-- that either it is a simple variable, or it is a record or array
|
||||
-- variable with a corresponding selected or indexed component on
|
||||
-- the left side of an assignment. If the result is True, then
|
||||
-- Insert_Node is set to point to the assignment
|
||||
|
||||
function Is_Out_Actual (N : Node_Id) return Boolean;
|
||||
-- In a similar manner, this function determines if N appears as an
|
||||
-- OUT or IN OUT parameter to a procedure call. If the result is
|
||||
-- True, then Insert_Node is set to point to the assignment.
|
||||
|
||||
---------------------
|
||||
-- Add_Read_Before --
|
||||
---------------------
|
||||
|
||||
procedure Add_Read_Before (N : Node_Id) is
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
Ent : constant Node_Id := Entity (N);
|
||||
|
||||
begin
|
||||
if Present (Shared_Var_Read_Proc (Ent)) then
|
||||
Insert_Action (N,
|
||||
Make_Procedure_Call_Statement (Loc,
|
||||
Name =>
|
||||
New_Occurrence_Of (Shared_Var_Read_Proc (Ent), Loc),
|
||||
Parameter_Associations => Empty_List));
|
||||
end if;
|
||||
end Add_Read_Before;
|
||||
|
||||
-------------------------------
|
||||
-- Add_Shared_Var_Lock_Procs --
|
||||
-------------------------------
|
||||
|
||||
procedure Add_Shared_Var_Lock_Procs (N : Node_Id) is
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
Obj : constant Entity_Id := Entity (Expression (First_Actual (N)));
|
||||
Inode : Node_Id;
|
||||
Vnm : String_Id;
|
||||
|
||||
begin
|
||||
-- We have to add Shared_Var_Lock and Shared_Var_Unlock calls around
|
||||
-- the procedure or function call node. First we locate the right
|
||||
-- place to do the insertion, which is the call itself in the
|
||||
-- procedure call case, or else the nearest non subexpression
|
||||
-- node that contains the function call.
|
||||
|
||||
Inode := N;
|
||||
while Nkind (Inode) /= N_Procedure_Call_Statement
|
||||
and then Nkind (Inode) in N_Subexpr
|
||||
loop
|
||||
Inode := Parent (Inode);
|
||||
end loop;
|
||||
|
||||
-- Now insert the Lock and Unlock calls and the read/write calls
|
||||
|
||||
-- Two concerns here. First we are not dealing with the exception
|
||||
-- case, really we need some kind of cleanup routine to do the
|
||||
-- Unlock. Second, these lock calls should be inside the protected
|
||||
-- object processing, not outside, otherwise they can be done at
|
||||
-- the wrong priority, resulting in dead lock situations ???
|
||||
|
||||
Build_Full_Name (Obj, Vnm);
|
||||
|
||||
-- First insert the Lock call before
|
||||
|
||||
Insert_Before_And_Analyze (Inode,
|
||||
Make_Procedure_Call_Statement (Loc,
|
||||
Name => New_Occurrence_Of (RTE (RE_Shared_Var_Lock), Loc),
|
||||
Parameter_Associations => New_List (
|
||||
Make_String_Literal (Loc, Vnm))));
|
||||
|
||||
-- Now, right after the Lock, insert a call to read the object
|
||||
|
||||
Insert_Before_And_Analyze (Inode,
|
||||
Make_Procedure_Call_Statement (Loc,
|
||||
Name => New_Occurrence_Of (Shared_Var_Read_Proc (Obj), Loc)));
|
||||
|
||||
-- Now insert the Unlock call after
|
||||
|
||||
Insert_After_And_Analyze (Inode,
|
||||
Make_Procedure_Call_Statement (Loc,
|
||||
Name => New_Occurrence_Of (RTE (RE_Shared_Var_Unlock), Loc),
|
||||
Parameter_Associations => New_List (
|
||||
Make_String_Literal (Loc, Vnm))));
|
||||
|
||||
-- Now for a procedure call, but not a function call, insert the
|
||||
-- call to write the object just before the unlock.
|
||||
|
||||
if Nkind (N) = N_Procedure_Call_Statement then
|
||||
Insert_After_And_Analyze (Inode,
|
||||
Make_Procedure_Call_Statement (Loc,
|
||||
Name => New_Occurrence_Of (Shared_Var_Assign_Proc (Obj), Loc)));
|
||||
end if;
|
||||
|
||||
end Add_Shared_Var_Lock_Procs;
|
||||
|
||||
---------------------
|
||||
-- Add_Write_After --
|
||||
---------------------
|
||||
|
||||
procedure Add_Write_After (N : Node_Id) is
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
Ent : constant Node_Id := Entity (N);
|
||||
|
||||
begin
|
||||
if Present (Shared_Var_Assign_Proc (Ent)) then
|
||||
Insert_After_And_Analyze (Insert_Node,
|
||||
Make_Procedure_Call_Statement (Loc,
|
||||
Name =>
|
||||
New_Occurrence_Of (Shared_Var_Assign_Proc (Ent), Loc),
|
||||
Parameter_Associations => Empty_List));
|
||||
end if;
|
||||
end Add_Write_After;
|
||||
|
||||
---------------------
|
||||
-- Build_Full_Name --
|
||||
---------------------
|
||||
|
||||
procedure Build_Full_Name
|
||||
(E : in Entity_Id;
|
||||
N : out String_Id)
|
||||
is
|
||||
|
||||
procedure Build_Name (E : Entity_Id);
|
||||
-- This is a recursive routine used to construct the fully
|
||||
-- qualified string name of the package corresponding to the
|
||||
-- shared variable.
|
||||
|
||||
procedure Build_Name (E : Entity_Id) is
|
||||
begin
|
||||
if Scope (E) /= Standard_Standard then
|
||||
Build_Name (Scope (E));
|
||||
Store_String_Char ('.');
|
||||
end if;
|
||||
|
||||
Get_Decoded_Name_String (Chars (E));
|
||||
Store_String_Chars (Name_Buffer (1 .. Name_Len));
|
||||
end Build_Name;
|
||||
|
||||
begin
|
||||
Start_String;
|
||||
Build_Name (E);
|
||||
N := End_String;
|
||||
end Build_Full_Name;
|
||||
|
||||
------------------------------------
|
||||
-- Expand_Shared_Passive_Variable --
|
||||
------------------------------------
|
||||
|
||||
procedure Expand_Shared_Passive_Variable (N : Node_Id) is
|
||||
Typ : constant Entity_Id := Etype (N);
|
||||
|
||||
begin
|
||||
-- Nothing to do for protected or limited objects
|
||||
|
||||
if Is_Limited_Type (Typ) or else Is_Concurrent_Type (Typ) then
|
||||
return;
|
||||
|
||||
-- If we are on the left hand side of an assignment, then we add
|
||||
-- the write call after the assignment.
|
||||
|
||||
elsif On_Lhs_Of_Assignment (N) then
|
||||
Add_Write_After (N);
|
||||
|
||||
-- If we are a parameter for an out or in out formal, then put
|
||||
-- the read before and the write after.
|
||||
|
||||
elsif Is_Out_Actual (N) then
|
||||
Add_Read_Before (N);
|
||||
Add_Write_After (N);
|
||||
|
||||
-- All other cases are simple reads
|
||||
|
||||
else
|
||||
Add_Read_Before (N);
|
||||
end if;
|
||||
end Expand_Shared_Passive_Variable;
|
||||
|
||||
-------------------
|
||||
-- Is_Out_Actual --
|
||||
-------------------
|
||||
|
||||
function Is_Out_Actual (N : Node_Id) return Boolean is
|
||||
Parnt : constant Node_Id := Parent (N);
|
||||
Formal : Entity_Id;
|
||||
Call : Node_Id;
|
||||
Actual : Node_Id;
|
||||
|
||||
begin
|
||||
if (Nkind (Parnt) = N_Indexed_Component
|
||||
or else
|
||||
Nkind (Parnt) = N_Selected_Component)
|
||||
and then N = Prefix (Parnt)
|
||||
then
|
||||
return Is_Out_Actual (Parnt);
|
||||
|
||||
elsif Nkind (Parnt) = N_Parameter_Association
|
||||
and then N = Explicit_Actual_Parameter (Parnt)
|
||||
then
|
||||
Call := Parent (Parnt);
|
||||
|
||||
elsif Nkind (Parnt) = N_Procedure_Call_Statement then
|
||||
Call := Parnt;
|
||||
|
||||
else
|
||||
return False;
|
||||
end if;
|
||||
|
||||
-- Fall here if we are definitely a parameter
|
||||
|
||||
Actual := First_Actual (Call);
|
||||
Formal := First_Formal (Entity (Name (Call)));
|
||||
|
||||
loop
|
||||
if Actual = N then
|
||||
if Ekind (Formal) /= E_In_Parameter then
|
||||
Insert_Node := Call;
|
||||
return True;
|
||||
else
|
||||
return False;
|
||||
end if;
|
||||
|
||||
else
|
||||
Actual := Next_Actual (Actual);
|
||||
Formal := Next_Formal (Formal);
|
||||
end if;
|
||||
end loop;
|
||||
end Is_Out_Actual;
|
||||
|
||||
---------------------------
|
||||
-- Make_Shared_Var_Procs --
|
||||
---------------------------
|
||||
|
||||
procedure Make_Shared_Var_Procs (N : Node_Id) is
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
Ent : constant Entity_Id := Defining_Identifier (N);
|
||||
Typ : constant Entity_Id := Etype (Ent);
|
||||
Vnm : String_Id;
|
||||
Atr : Node_Id;
|
||||
|
||||
Assign_Proc : constant Entity_Id :=
|
||||
Make_Defining_Identifier (Loc,
|
||||
Chars => New_External_Name (Chars (Ent), 'A'));
|
||||
|
||||
Read_Proc : constant Entity_Id :=
|
||||
Make_Defining_Identifier (Loc,
|
||||
Chars => New_External_Name (Chars (Ent), 'R'));
|
||||
|
||||
S : Entity_Id;
|
||||
|
||||
-- Start of processing for Make_Shared_Var_Procs
|
||||
|
||||
begin
|
||||
Build_Full_Name (Ent, Vnm);
|
||||
|
||||
-- We turn off Shared_Passive during construction and analysis of
|
||||
-- the assign and read routines, to avoid improper attempts to
|
||||
-- process the variable references within these procedures.
|
||||
|
||||
Set_Is_Shared_Passive (Ent, False);
|
||||
|
||||
-- Construct assignment routine
|
||||
|
||||
-- procedure VarA is
|
||||
-- S : Ada.Streams.Stream_IO.Stream_Access;
|
||||
-- begin
|
||||
-- S := Shared_Var_WOpen ("pkg.var");
|
||||
-- typ'Write (S, var);
|
||||
-- Shared_Var_Close (S);
|
||||
-- end VarA;
|
||||
|
||||
S := Make_Defining_Identifier (Loc, Name_uS);
|
||||
|
||||
Atr :=
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix => New_Occurrence_Of (Typ, Loc),
|
||||
Attribute_Name => Name_Write,
|
||||
Expressions => New_List (
|
||||
New_Reference_To (S, Loc),
|
||||
New_Occurrence_Of (Ent, Loc)));
|
||||
|
||||
Set_OK_For_Stream (Atr, True);
|
||||
|
||||
Insert_After_And_Analyze (N,
|
||||
Make_Subprogram_Body (Loc,
|
||||
Specification =>
|
||||
Make_Procedure_Specification (Loc,
|
||||
Defining_Unit_Name => Assign_Proc),
|
||||
|
||||
-- S : Ada.Streams.Stream_IO.Stream_Access;
|
||||
|
||||
Declarations => New_List (
|
||||
Make_Object_Declaration (Loc,
|
||||
Defining_Identifier => S,
|
||||
Object_Definition =>
|
||||
New_Occurrence_Of (RTE (RE_Stream_Access), Loc))),
|
||||
|
||||
Handled_Statement_Sequence =>
|
||||
Make_Handled_Sequence_Of_Statements (Loc,
|
||||
Statements => New_List (
|
||||
|
||||
-- S := Shared_Var_WOpen ("pkg.var");
|
||||
|
||||
Make_Assignment_Statement (Loc,
|
||||
Name => New_Reference_To (S, Loc),
|
||||
Expression =>
|
||||
Make_Function_Call (Loc,
|
||||
Name =>
|
||||
New_Occurrence_Of
|
||||
(RTE (RE_Shared_Var_WOpen), Loc),
|
||||
Parameter_Associations => New_List (
|
||||
Make_String_Literal (Loc, Vnm)))),
|
||||
|
||||
Atr,
|
||||
|
||||
-- Shared_Var_Close (S);
|
||||
|
||||
Make_Procedure_Call_Statement (Loc,
|
||||
Name =>
|
||||
New_Occurrence_Of (RTE (RE_Shared_Var_Close), Loc),
|
||||
Parameter_Associations =>
|
||||
New_List (New_Reference_To (S, Loc)))))));
|
||||
|
||||
-- Construct read routine
|
||||
|
||||
-- procedure varR is
|
||||
-- S : Ada.Streams.Stream_IO.Stream_Access;
|
||||
-- begin
|
||||
-- S := Shared_Var_ROpen ("pkg.var");
|
||||
-- if S /= null then
|
||||
-- typ'Read (S, Var);
|
||||
-- Shared_Var_Close (S);
|
||||
-- end if;
|
||||
-- end varR;
|
||||
|
||||
S := Make_Defining_Identifier (Loc, Name_uS);
|
||||
|
||||
Atr :=
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix => New_Occurrence_Of (Typ, Loc),
|
||||
Attribute_Name => Name_Read,
|
||||
Expressions => New_List (
|
||||
New_Reference_To (S, Loc),
|
||||
New_Occurrence_Of (Ent, Loc)));
|
||||
|
||||
Set_OK_For_Stream (Atr, True);
|
||||
|
||||
Insert_After_And_Analyze (N,
|
||||
Make_Subprogram_Body (Loc,
|
||||
Specification =>
|
||||
Make_Procedure_Specification (Loc,
|
||||
Defining_Unit_Name => Read_Proc),
|
||||
|
||||
-- S : Ada.Streams.Stream_IO.Stream_Access;
|
||||
|
||||
Declarations => New_List (
|
||||
Make_Object_Declaration (Loc,
|
||||
Defining_Identifier => S,
|
||||
Object_Definition =>
|
||||
New_Occurrence_Of (RTE (RE_Stream_Access), Loc))),
|
||||
|
||||
Handled_Statement_Sequence =>
|
||||
Make_Handled_Sequence_Of_Statements (Loc,
|
||||
Statements => New_List (
|
||||
|
||||
-- S := Shared_Var_ROpen ("pkg.var");
|
||||
|
||||
Make_Assignment_Statement (Loc,
|
||||
Name => New_Reference_To (S, Loc),
|
||||
Expression =>
|
||||
Make_Function_Call (Loc,
|
||||
Name =>
|
||||
New_Occurrence_Of
|
||||
(RTE (RE_Shared_Var_ROpen), Loc),
|
||||
Parameter_Associations => New_List (
|
||||
Make_String_Literal (Loc, Vnm)))),
|
||||
|
||||
-- if S /= null then
|
||||
|
||||
Make_Implicit_If_Statement (N,
|
||||
Condition =>
|
||||
Make_Op_Ne (Loc,
|
||||
Left_Opnd => New_Reference_To (S, Loc),
|
||||
Right_Opnd => Make_Null (Loc)),
|
||||
|
||||
Then_Statements => New_List (
|
||||
|
||||
-- typ'Read (S, Var);
|
||||
|
||||
Atr,
|
||||
|
||||
-- Shared_Var_Close (S);
|
||||
|
||||
Make_Procedure_Call_Statement (Loc,
|
||||
Name =>
|
||||
New_Occurrence_Of
|
||||
(RTE (RE_Shared_Var_Close), Loc),
|
||||
Parameter_Associations =>
|
||||
New_List (New_Reference_To (S, Loc)))))))));
|
||||
|
||||
Set_Is_Shared_Passive (Ent, True);
|
||||
Set_Shared_Var_Assign_Proc (Ent, Assign_Proc);
|
||||
Set_Shared_Var_Read_Proc (Ent, Read_Proc);
|
||||
end Make_Shared_Var_Procs;
|
||||
|
||||
--------------------------
|
||||
-- On_Lhs_Of_Assignment --
|
||||
--------------------------
|
||||
|
||||
function On_Lhs_Of_Assignment (N : Node_Id) return Boolean is
|
||||
P : constant Node_Id := Parent (N);
|
||||
|
||||
begin
|
||||
if Nkind (P) = N_Assignment_Statement then
|
||||
if N = Name (P) then
|
||||
Insert_Node := P;
|
||||
return True;
|
||||
else
|
||||
return False;
|
||||
end if;
|
||||
|
||||
elsif (Nkind (P) = N_Indexed_Component
|
||||
or else
|
||||
Nkind (P) = N_Selected_Component)
|
||||
and then N = Prefix (P)
|
||||
then
|
||||
return On_Lhs_Of_Assignment (P);
|
||||
|
||||
else
|
||||
return False;
|
||||
end if;
|
||||
end On_Lhs_Of_Assignment;
|
||||
|
||||
|
||||
end Exp_Smem;
|
|
@ -0,0 +1,60 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- E X P _ S M E M --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.3 $ --
|
||||
-- --
|
||||
-- Copyright (C) 1998-2000, 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This package contains routines involved in the required expansions for
|
||||
-- handling shared memory accesses for variables in Shared_Passive packages.
|
||||
|
||||
-- See detailed documentation in System.Shared_Storage spec for a full
|
||||
-- description of the approach that is taken for handling distributed
|
||||
-- shared memory. This expansion unit in the compiler is responsible
|
||||
-- for generating the calls to routines in System.Shared_Storage.
|
||||
|
||||
with Types; use Types;
|
||||
package Exp_Smem is
|
||||
|
||||
procedure Expand_Shared_Passive_Variable (N : Node_Id);
|
||||
-- N is the identifier for a shared passive variable. This routine is
|
||||
-- responsible for determining if this is an assigned to N, or a
|
||||
-- reference to N, and generating the required calls to the shared
|
||||
-- memory read/write procedures.
|
||||
|
||||
procedure Add_Shared_Var_Lock_Procs (N : Node_Id);
|
||||
-- The argument is a protected subprogram call, before it is rewritten
|
||||
-- by Exp_Ch9.Build_Protected_Subprogram_Call. This routine, which is
|
||||
-- called only in the case of an external call to a protected object
|
||||
-- that has Is_Shared_Passive set, deals with installing the required
|
||||
-- global lock calls for this case. It also generates the necessary
|
||||
-- read/write calls for the protected object within the lock region.
|
||||
|
||||
procedure Make_Shared_Var_Procs (N : Node_Id);
|
||||
-- N is the node for the declaration of a shared passive variable. This
|
||||
-- procedure constructs and inserts the read and assignment procedures
|
||||
-- for the shared memory variable. See System.Shared_Storage for a full
|
||||
-- description of these procedures and how they are used.
|
||||
|
||||
end Exp_Smem;
|
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,145 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- E X P _ S T R M --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.7 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-1999 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- --
|
||||
-- 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. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- Routines to build stream subprograms for composite types
|
||||
|
||||
with Types; use Types;
|
||||
|
||||
package Exp_Strm is
|
||||
|
||||
function Build_Elementary_Input_Call (N : Node_Id) return Node_Id;
|
||||
-- Build call to Read attribute function for elementary type. Also used
|
||||
-- for Input attributes for elementary types with an appropriate extra
|
||||
-- assignment statement. N is the attribute reference node.
|
||||
|
||||
function Build_Elementary_Write_Call (N : Node_Id) return Node_Id;
|
||||
-- Build call to Write attribute function for elementary type. Also used
|
||||
-- for Output attributes for elementary types (since the effect of the
|
||||
-- two attributes is identical for elementary types). N is the attribute
|
||||
-- reference node.
|
||||
|
||||
function Build_Stream_Attr_Profile
|
||||
(Loc : Source_Ptr;
|
||||
Typ : Entity_Id;
|
||||
Nam : Name_Id)
|
||||
return List_Id;
|
||||
-- Builds the parameter profile for the stream attribute identified by
|
||||
-- the given name (which is the underscore version, e.g. Name_uWrite to
|
||||
-- identify the Write attribute). This is used for the tagged case to
|
||||
-- build the spec for the primitive operation.
|
||||
|
||||
-- The following routines build procedures and functions for stream
|
||||
-- attributes applied to composite types. For each of these routines,
|
||||
-- Loc is used to provide the location for the constructed subprogram
|
||||
-- declaration. Typ is the base type to which the subprogram applies
|
||||
-- (i.e. the base type of the stream attribute prefix). The returned
|
||||
-- results are the declaration and name (entity) of the subprogram.
|
||||
|
||||
procedure Build_Array_Input_Function
|
||||
(Loc : Source_Ptr;
|
||||
Typ : Entity_Id;
|
||||
Decl : out Node_Id;
|
||||
Fnam : out Entity_Id);
|
||||
-- Build function for Input attribute for array type
|
||||
|
||||
procedure Build_Array_Output_Procedure
|
||||
(Loc : Source_Ptr;
|
||||
Typ : Entity_Id;
|
||||
Decl : out Node_Id;
|
||||
Pnam : out Entity_Id);
|
||||
-- Build procedure for Output attribute for array type
|
||||
|
||||
procedure Build_Array_Read_Procedure
|
||||
(Nod : Node_Id;
|
||||
Typ : Entity_Id;
|
||||
Decl : out Node_Id;
|
||||
Pnam : out Entity_Id);
|
||||
-- Build procedure for Read attribute for array type. Nod provides the
|
||||
-- Sloc value for generated code.
|
||||
|
||||
procedure Build_Array_Write_Procedure
|
||||
(Nod : Node_Id;
|
||||
Typ : Entity_Id;
|
||||
Decl : out Node_Id;
|
||||
Pnam : out Entity_Id);
|
||||
-- Build procedure for Write attribute for array type. Nod provides the
|
||||
-- Sloc value for generated code.
|
||||
|
||||
procedure Build_Mutable_Record_Read_Procedure
|
||||
(Loc : Source_Ptr;
|
||||
Typ : Entity_Id;
|
||||
Decl : out Node_Id;
|
||||
Pnam : out Entity_Id);
|
||||
-- Build procedure to Read a record with default discriminants.
|
||||
-- Discriminants must be read explicitly (RM 13.13.2(9)) in the
|
||||
-- same manner as is done for 'Input.
|
||||
|
||||
procedure Build_Mutable_Record_Write_Procedure
|
||||
(Loc : Source_Ptr;
|
||||
Typ : Entity_Id;
|
||||
Decl : out Node_Id;
|
||||
Pnam : out Entity_Id);
|
||||
-- Build procedure to write a record with default discriminants.
|
||||
-- Discriminants must be written explicitly (RM 13.13.2(9)) in
|
||||
-- the same manner as is done for 'Output.
|
||||
|
||||
procedure Build_Record_Or_Elementary_Input_Function
|
||||
(Loc : Source_Ptr;
|
||||
Typ : Entity_Id;
|
||||
Decl : out Node_Id;
|
||||
Fnam : out Entity_Id);
|
||||
-- Build function for Input attribute for record type or for an
|
||||
-- elementary type (the latter is used only in the case where a
|
||||
-- user defined Read routine is defined, since in other cases,
|
||||
-- Input calls the appropriate runtime library routine directly.
|
||||
|
||||
procedure Build_Record_Or_Elementary_Output_Procedure
|
||||
(Loc : Source_Ptr;
|
||||
Typ : Entity_Id;
|
||||
Decl : out Node_Id;
|
||||
Pnam : out Entity_Id);
|
||||
-- Build procedure for Output attribute for record type or for an
|
||||
-- elementary type (the latter is used only in the case where a
|
||||
-- user defined Write routine is defined, since in other cases,
|
||||
-- Output calls the appropriate runtime library routine directly.
|
||||
|
||||
procedure Build_Record_Read_Procedure
|
||||
(Loc : Source_Ptr;
|
||||
Typ : Entity_Id;
|
||||
Decl : out Node_Id;
|
||||
Pnam : out Entity_Id);
|
||||
-- Build procedure for Read attribute for record type
|
||||
|
||||
procedure Build_Record_Write_Procedure
|
||||
(Loc : Source_Ptr;
|
||||
Typ : Entity_Id;
|
||||
Decl : out Node_Id;
|
||||
Pnam : out Entity_Id);
|
||||
-- Build procedure for Write attribute for record type
|
||||
|
||||
end Exp_Strm;
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue