blob: 8824f4fc2ef73d75465778d27659ca007dd62f3d [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- T A R G P A R M --
-- --
-- B o d y --
-- --
-- Copyright (C) 1999-2014, 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 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Csets; use Csets;
with Opt; use Opt;
with Osint; use Osint;
with Output; use Output;
package body Targparm is
use ASCII;
Parameters_Obtained : Boolean := False;
-- Set True after first call to Get_Target_Parameters. Used to avoid
-- reading system.ads more than once, since it cannot change.
-- The following array defines a tag name for each entry
type Targparm_Tags is
(AAM, -- AAMP
ACR, -- Always_Compatible_Rep
ASD, -- Atomic_Sync_Default
BDC, -- Backend_Divide_Checks
BOC, -- Backend_Overflow_Checks
CLA, -- Command_Line_Args
CLI, -- CLI (.NET)
CRT, -- Configurable_Run_Times
D32, -- Duration_32_Bits
DEN, -- Denorm
EXS, -- Exit_Status_Supported
FEL, -- Frontend_Layout
FFO, -- Fractional_Fixed_Ops
JVM, -- JVM
MOV, -- Machine_Overflows
MRN, -- Machine_Rounds
PAS, -- Preallocated_Stacks
SAG, -- Support_Aggregates
SAP, -- Support_Atomic_Primitives
SCA, -- Support_Composite_Assign
SCC, -- Support_Composite_Compare
SCD, -- Stack_Check_Default
SCL, -- Stack_Check_Limits
SCP, -- Stack_Check_Probes
SLS, -- Support_Long_Shifts
SNZ, -- Signed_Zeros
SSL, -- Suppress_Standard_Library
UAM, -- Use_Ada_Main_Program_Name
ZCD); -- ZCX_By_Default
Targparm_Flags : array (Targparm_Tags) of Boolean := (others => False);
-- Flag is set True if corresponding parameter is scanned
-- The following list of string constants gives the parameter names
AAM_Str : aliased constant Source_Buffer := "AAMP";
ACR_Str : aliased constant Source_Buffer := "Always_Compatible_Rep";
ASD_Str : aliased constant Source_Buffer := "Atomic_Sync_Default";
BDC_Str : aliased constant Source_Buffer := "Backend_Divide_Checks";
BOC_Str : aliased constant Source_Buffer := "Backend_Overflow_Checks";
CLA_Str : aliased constant Source_Buffer := "Command_Line_Args";
CLI_Str : aliased constant Source_Buffer := "CLI";
CRT_Str : aliased constant Source_Buffer := "Configurable_Run_Time";
D32_Str : aliased constant Source_Buffer := "Duration_32_Bits";
DEN_Str : aliased constant Source_Buffer := "Denorm";
EXS_Str : aliased constant Source_Buffer := "Exit_Status_Supported";
FEL_Str : aliased constant Source_Buffer := "Frontend_Layout";
FFO_Str : aliased constant Source_Buffer := "Fractional_Fixed_Ops";
JVM_Str : aliased constant Source_Buffer := "JVM";
MOV_Str : aliased constant Source_Buffer := "Machine_Overflows";
MRN_Str : aliased constant Source_Buffer := "Machine_Rounds";
PAS_Str : aliased constant Source_Buffer := "Preallocated_Stacks";
SAG_Str : aliased constant Source_Buffer := "Support_Aggregates";
SAP_Str : aliased constant Source_Buffer := "Support_Atomic_Primitives";
SCA_Str : aliased constant Source_Buffer := "Support_Composite_Assign";
SCC_Str : aliased constant Source_Buffer := "Support_Composite_Compare";
SCD_Str : aliased constant Source_Buffer := "Stack_Check_Default";
SCL_Str : aliased constant Source_Buffer := "Stack_Check_Limits";
SCP_Str : aliased constant Source_Buffer := "Stack_Check_Probes";
SLS_Str : aliased constant Source_Buffer := "Support_Long_Shifts";
SNZ_Str : aliased constant Source_Buffer := "Signed_Zeros";
SSL_Str : aliased constant Source_Buffer := "Suppress_Standard_Library";
UAM_Str : aliased constant Source_Buffer := "Use_Ada_Main_Program_Name";
ZCD_Str : aliased constant Source_Buffer := "ZCX_By_Default";
-- The following defines a set of pointers to the above strings,
-- indexed by the tag values.
type Buffer_Ptr is access constant Source_Buffer;
Targparm_Str : constant array (Targparm_Tags) of Buffer_Ptr :=
(AAM_Str'Access,
ACR_Str'Access,
ASD_Str'Access,
BDC_Str'Access,
BOC_Str'Access,
CLA_Str'Access,
CLI_Str'Access,
CRT_Str'Access,
D32_Str'Access,
DEN_Str'Access,
EXS_Str'Access,
FEL_Str'Access,
FFO_Str'Access,
JVM_Str'Access,
MOV_Str'Access,
MRN_Str'Access,
PAS_Str'Access,
SAG_Str'Access,
SAP_Str'Access,
SCA_Str'Access,
SCC_Str'Access,
SCD_Str'Access,
SCL_Str'Access,
SCP_Str'Access,
SLS_Str'Access,
SNZ_Str'Access,
SSL_Str'Access,
UAM_Str'Access,
ZCD_Str'Access);
-----------------------
-- Local Subprograms --
-----------------------
procedure Set_Profile_Restrictions (P : Profile_Name);
-- Set Restrictions_On_Target for the given profile
---------------------------
-- Get_Target_Parameters --
---------------------------
-- Version which reads in system.ads
procedure Get_Target_Parameters
(Make_Id : Make_Id_Type := null;
Make_SC : Make_SC_Type := null;
Set_RND : Set_RND_Type := null)
is
Text : Source_Buffer_Ptr;
Hi : Source_Ptr;
begin
if Parameters_Obtained then
return;
end if;
Name_Buffer (1 .. 10) := "system.ads";
Name_Len := 10;
Read_Source_File (Name_Find, Lo => 0, Hi => Hi, Src => Text);
if Text = null then
Write_Line ("fatal error, run-time library not installed correctly");
Write_Line ("cannot locate file system.ads");
raise Unrecoverable_Error;
end if;
Get_Target_Parameters
(System_Text => Text,
Source_First => 0,
Source_Last => Hi,
Make_Id => Make_Id,
Make_SC => Make_SC,
Set_RND => Set_RND);
end Get_Target_Parameters;
-- Version where caller supplies system.ads text
procedure Get_Target_Parameters
(System_Text : Source_Buffer_Ptr;
Source_First : Source_Ptr;
Source_Last : Source_Ptr;
Make_Id : Make_Id_Type := null;
Make_SC : Make_SC_Type := null;
Set_RND : Set_RND_Type := null)
is
P : Source_Ptr;
-- Scans source buffer containing source of system.ads
Fatal : Boolean := False;
-- Set True if a fatal error is detected
Result : Boolean;
-- Records boolean from system line
begin
if Parameters_Obtained then
return;
else
Parameters_Obtained := True;
end if;
Opt.Address_Is_Private := False;
-- Loop through source lines
-- Note: in the case or pragmas, we are only interested in pragmas that
-- appear as configuration pragmas. These are left justified, so they
-- do not have three spaces at the start. Pragmas appearing within the
-- package (like Pure and No_Elaboration_Code_All) will have the three
-- spaces at the start and so will be ignored.
-- For a special exception, see processing for pragma Pure below
P := Source_First;
Line_Loop : while System_Text (P .. P + 10) /= "end System;" loop
-- Skip comments quickly
if System_Text (P) = '-' then
goto Line_Loop_Continue;
-- Test for type Address is private
elsif System_Text (P .. P + 26) = " type Address is private;" then
Opt.Address_Is_Private := True;
P := P + 26;
goto Line_Loop_Continue;
-- Test for pragma Profile (Ravenscar);
elsif System_Text (P .. P + 26) =
"pragma Profile (Ravenscar);"
then
Set_Profile_Restrictions (Ravenscar);
Opt.Task_Dispatching_Policy := 'F';
Opt.Locking_Policy := 'C';
P := P + 27;
goto Line_Loop_Continue;
-- Test for pragma Profile (Restricted);
elsif System_Text (P .. P + 27) =
"pragma Profile (Restricted);"
then
Set_Profile_Restrictions (Restricted);
P := P + 28;
goto Line_Loop_Continue;
-- Test for pragma Restrictions
elsif System_Text (P .. P + 20) = "pragma Restrictions (" then
P := P + 21;
Rloop : for K in All_Boolean_Restrictions loop
declare
Rname : constant String := Restriction_Id'Image (K);
begin
for J in Rname'Range loop
if Fold_Upper (System_Text (P + Source_Ptr (J - 1)))
/= Rname (J)
then
goto Rloop_Continue;
end if;
end loop;
if System_Text (P + Rname'Length) = ')' then
Restrictions_On_Target.Set (K) := True;
goto Line_Loop_Continue;
end if;
end;
<<Rloop_Continue>>
null;
end loop Rloop;
Ploop : for K in All_Parameter_Restrictions loop
declare
Rname : constant String :=
All_Parameter_Restrictions'Image (K);
V : Natural;
-- Accumulates value
begin
for J in Rname'Range loop
if Fold_Upper (System_Text (P + Source_Ptr (J - 1)))
/= Rname (J)
then
goto Ploop_Continue;
end if;
end loop;
if System_Text (P + Rname'Length .. P + Rname'Length + 3) =
" => "
then
P := P + Rname'Length + 4;
V := 0;
loop
if System_Text (P) in '0' .. '9' then
declare
pragma Unsuppress (Overflow_Check);
begin
-- Accumulate next digit
V := 10 * V +
Character'Pos (System_Text (P)) -
Character'Pos ('0');
exception
-- On overflow, we just ignore the pragma since
-- that is the standard handling in this case.
when Constraint_Error =>
goto Line_Loop_Continue;
end;
elsif System_Text (P) = '_' then
null;
elsif System_Text (P) = ')' then
Restrictions_On_Target.Value (K) := V;
Restrictions_On_Target.Set (K) := True;
goto Line_Loop_Continue;
else
exit Ploop;
end if;
P := P + 1;
end loop;
else
exit Ploop;
end if;
end;
<<Ploop_Continue>>
null;
end loop Ploop;
-- No_Dependence case
if System_Text (P .. P + 16) = "No_Dependence => " then
P := P + 17;
-- Skip this processing (and simply ignore No_Dependence lines)
-- if caller did not supply the three subprograms we need to
-- process these lines.
if Make_Id = null then
goto Line_Loop_Continue;
end if;
-- We have scanned out "pragma Restrictions (No_Dependence =>"
declare
Unit : Node_Id;
Id : Node_Id;
Start : Source_Ptr;
begin
Unit := Empty;
-- Loop through components of name, building up Unit
loop
Start := P;
while System_Text (P) /= '.'
and then
System_Text (P) /= ')'
loop
P := P + 1;
end loop;
Id := Make_Id (System_Text (Start .. P - 1));
-- If first name, just capture the identifier
if Unit = Empty then
Unit := Id;
else
Unit := Make_SC (Unit, Id);
end if;
exit when System_Text (P) = ')';
P := P + 1;
end loop;
Set_RND (Unit);
goto Line_Loop_Continue;
end;
end if;
-- Here if unrecognizable restrictions pragma form
Set_Standard_Error;
Write_Line
("fatal error: system.ads is incorrectly formatted");
Write_Str ("unrecognized or incorrect restrictions pragma: ");
while System_Text (P) /= ')'
and then
System_Text (P) /= ASCII.LF
loop
Write_Char (System_Text (P));
P := P + 1;
end loop;
Write_Eol;
Fatal := True;
Set_Standard_Output;
-- Test for pragma Detect_Blocking;
elsif System_Text (P .. P + 22) = "pragma Detect_Blocking;" then
P := P + 23;
Opt.Detect_Blocking := True;
goto Line_Loop_Continue;
-- Discard_Names
elsif System_Text (P .. P + 20) = "pragma Discard_Names;" then
P := P + 21;
Opt.Global_Discard_Names := True;
goto Line_Loop_Continue;
-- Locking Policy
elsif System_Text (P .. P + 22) = "pragma Locking_Policy (" then
P := P + 23;
Opt.Locking_Policy := System_Text (P);
Opt.Locking_Policy_Sloc := System_Location;
goto Line_Loop_Continue;
-- Normalize_Scalars
elsif System_Text (P .. P + 24) = "pragma Normalize_Scalars;" then
P := P + 25;
Opt.Normalize_Scalars := True;
Opt.Init_Or_Norm_Scalars := True;
goto Line_Loop_Continue;
-- Partition_Elaboration_Policy
elsif System_Text (P .. P + 36) =
"pragma Partition_Elaboration_Policy ("
then
P := P + 37;
Opt.Partition_Elaboration_Policy := System_Text (P);
Opt.Partition_Elaboration_Policy_Sloc := System_Location;
goto Line_Loop_Continue;
-- Polling (On)
elsif System_Text (P .. P + 19) = "pragma Polling (On);" then
P := P + 20;
Opt.Polling_Required := True;
goto Line_Loop_Continue;
-- Queuing Policy
elsif System_Text (P .. P + 22) = "pragma Queuing_Policy (" then
P := P + 23;
Opt.Queuing_Policy := System_Text (P);
Opt.Queuing_Policy_Sloc := System_Location;
goto Line_Loop_Continue;
-- Suppress_Exception_Locations
elsif System_Text (P .. P + 35) =
"pragma Suppress_Exception_Locations;"
then
P := P + 36;
Opt.Exception_Locations_Suppressed := True;
goto Line_Loop_Continue;
-- Task_Dispatching Policy
elsif System_Text (P .. P + 31) =
"pragma Task_Dispatching_Policy ("
then
P := P + 32;
Opt.Task_Dispatching_Policy := System_Text (P);
Opt.Task_Dispatching_Policy_Sloc := System_Location;
goto Line_Loop_Continue;
-- No other configuration pragmas are permitted
elsif System_Text (P .. P + 6) = "pragma " then
-- Special exception, we allow pragma Pure (System) appearing in
-- column one. This is an obsolete usage which may show up in old
-- tests with an obsolete version of system.ads, so we recognize
-- and ignore it to make life easier in handling such tests.
if System_Text (P .. P + 20) = "pragma Pure (System);" then
P := P + 21;
goto Line_Loop_Continue;
end if;
Set_Standard_Error;
Write_Line ("unrecognized line in system.ads: ");
while System_Text (P) /= ')'
and then System_Text (P) /= ASCII.LF
loop
Write_Char (System_Text (P));
P := P + 1;
end loop;
Write_Eol;
Set_Standard_Output;
Fatal := True;
-- See if we have a Run_Time_Name
elsif System_Text (P .. P + 38) =
" Run_Time_Name : constant String := """
then
P := P + 39;
Name_Len := 0;
while System_Text (P) in 'A' .. 'Z'
or else
System_Text (P) in 'a' .. 'z'
or else
System_Text (P) in '0' .. '9'
or else
System_Text (P) = ' '
or else
System_Text (P) = '_'
loop
Add_Char_To_Name_Buffer (System_Text (P));
P := P + 1;
end loop;
if System_Text (P) /= '"'
or else System_Text (P + 1) /= ';'
or else (System_Text (P + 2) /= ASCII.LF
and then
System_Text (P + 2) /= ASCII.CR)
then
Set_Standard_Error;
Write_Line
("incorrectly formatted Run_Time_Name in system.ads");
Set_Standard_Output;
Fatal := True;
else
Run_Time_Name_On_Target := Name_Enter;
end if;
goto Line_Loop_Continue;
-- See if we have an Executable_Extension
elsif System_Text (P .. P + 45) =
" Executable_Extension : constant String := """
then
P := P + 46;
Name_Len := 0;
while System_Text (P) /= '"'
and then System_Text (P) /= ASCII.LF
loop
Add_Char_To_Name_Buffer (System_Text (P));
P := P + 1;
end loop;
if System_Text (P) /= '"' or else System_Text (P + 1) /= ';' then
Set_Standard_Error;
Write_Line
("incorrectly formatted Executable_Extension in system.ads");
Set_Standard_Output;
Fatal := True;
else
Executable_Extension_On_Target := Name_Enter;
end if;
goto Line_Loop_Continue;
-- Next see if we have a configuration parameter
else
Config_Param_Loop : for K in Targparm_Tags loop
if System_Text (P + 3 .. P + 2 + Targparm_Str (K)'Length) =
Targparm_Str (K).all
then
P := P + 3 + Targparm_Str (K)'Length;
if Targparm_Flags (K) then
Set_Standard_Error;
Write_Line
("fatal error: system.ads is incorrectly formatted");
Write_Str ("duplicate line for parameter: ");
for J in Targparm_Str (K)'Range loop
Write_Char (Targparm_Str (K).all (J));
end loop;
Write_Eol;
Set_Standard_Output;
Fatal := True;
else
Targparm_Flags (K) := True;
end if;
while System_Text (P) /= ':'
or else System_Text (P + 1) /= '='
loop
P := P + 1;
end loop;
P := P + 2;
while System_Text (P) = ' ' loop
P := P + 1;
end loop;
Result := (System_Text (P) = 'T');
case K is
when AAM => AAMP_On_Target := Result;
when ACR => Always_Compatible_Rep_On_Target := Result;
when ASD => Atomic_Sync_Default_On_Target := Result;
when BDC => Backend_Divide_Checks_On_Target := Result;
when BOC => Backend_Overflow_Checks_On_Target := Result;
when CLA => Command_Line_Args_On_Target := Result;
when CLI =>
if Result then
VM_Target := CLI_Target;
Tagged_Type_Expansion := False;
end if;
-- This is wrong, this processing should be done in
-- Gnat1drv.Adjust_Global_Switches. It is not the
-- right level for targparm to know about tagged
-- type extension???
when CRT => Configurable_Run_Time_On_Target := Result;
when D32 => Duration_32_Bits_On_Target := Result;
when DEN => Denorm_On_Target := Result;
when EXS => Exit_Status_Supported_On_Target := Result;
when FEL => Frontend_Layout_On_Target := Result;
when FFO => Fractional_Fixed_Ops_On_Target := Result;
when JVM =>
if Result then
VM_Target := JVM_Target;
Tagged_Type_Expansion := False;
end if;
-- This is wrong, this processing should be done in
-- Gnat1drv.Adjust_Global_Switches. It is not the
-- right level for targparm to know about tagged
-- type extension???
when MOV => Machine_Overflows_On_Target := Result;
when MRN => Machine_Rounds_On_Target := Result;
when PAS => Preallocated_Stacks_On_Target := Result;
when SAG => Support_Aggregates_On_Target := Result;
when SAP => Support_Atomic_Primitives_On_Target := Result;
when SCA => Support_Composite_Assign_On_Target := Result;
when SCC => Support_Composite_Compare_On_Target := Result;
when SCD => Stack_Check_Default_On_Target := Result;
when SCL => Stack_Check_Limits_On_Target := Result;
when SCP => Stack_Check_Probes_On_Target := Result;
when SLS => Support_Long_Shifts_On_Target := Result;
when SSL => Suppress_Standard_Library_On_Target := Result;
when SNZ => Signed_Zeros_On_Target := Result;
when UAM => Use_Ada_Main_Program_Name_On_Target := Result;
when ZCD => ZCX_By_Default_On_Target := Result;
goto Line_Loop_Continue;
end case;
-- Here we are seeing a parameter we do not understand. We
-- simply ignore this (will happen when an old compiler is
-- used to compile a newer version of GNAT which does not
-- support the parameter).
end if;
end loop Config_Param_Loop;
end if;
-- Here after processing one line of System spec
<<Line_Loop_Continue>>
while System_Text (P) /= CR and then System_Text (P) /= LF loop
P := P + 1;
exit when P >= Source_Last;
end loop;
while System_Text (P) = CR or else System_Text (P) = LF loop
P := P + 1;
exit when P >= Source_Last;
end loop;
if P >= Source_Last then
Set_Standard_Error;
Write_Line ("fatal error, system.ads not formatted correctly");
Write_Line ("unexpected end of file");
Set_Standard_Output;
raise Unrecoverable_Error;
end if;
end loop Line_Loop;
if Fatal then
raise Unrecoverable_Error;
end if;
end Get_Target_Parameters;
------------------------------
-- Set_Profile_Restrictions --
------------------------------
procedure Set_Profile_Restrictions (P : Profile_Name) is
R : Restriction_Flags renames Profile_Info (P).Set;
V : Restriction_Values renames Profile_Info (P).Value;
begin
for J in R'Range loop
if R (J) then
Restrictions_On_Target.Set (J) := True;
if J in All_Parameter_Restrictions then
Restrictions_On_Target.Value (J) := V (J);
end if;
end if;
end loop;
end Set_Profile_Restrictions;
end Targparm;