------------------------------------------------------------------------------ -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- -- T A R G P A R M -- -- -- -- B o d y -- -- -- -- Copyright (C) 1999-2024, 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; with Osint; use Osint; with Output; use Output; with System.OS_Lib; use System.OS_Lib; 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 (ACR, -- Always_Compatible_Rep ASD, -- Atomic_Sync_Default BDC, -- Backend_Divide_Checks BOC, -- Backend_Overflow_Checks CLA, -- Command_Line_Args CRT, -- Configurable_Run_Times D32, -- Duration_32_Bits DEN, -- Denorm EXS, -- Exit_Status_Supported 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 ZCX); -- 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 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"; 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"; 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"; ZCX_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 := (ACR => ACR_Str'Access, ASD => ASD_Str'Access, BDC => BDC_Str'Access, BOC => BOC_Str'Access, CLA => CLA_Str'Access, CRT => CRT_Str'Access, D32 => D32_Str'Access, DEN => DEN_Str'Access, EXS => EXS_Str'Access, MOV => MOV_Str'Access, MRN => MRN_Str'Access, PAS => PAS_Str'Access, SAG => SAG_Str'Access, SAP => SAP_Str'Access, SCA => SCA_Str'Access, SCC => SCC_Str'Access, SCD => SCD_Str'Access, SCL => SCL_Str'Access, SCP => SCP_Str'Access, SLS => SLS_Str'Access, SNZ => SNZ_Str'Access, SSL => SSL_Str'Access, UAM => UAM_Str'Access, ZCX => ZCX_Str'Access); ----------------------- -- Local Subprograms -- ----------------------- procedure Set_Profile_Restrictions (P : Profile_Name); -- Set Restrictions_On_Target for the given profile --------------------------- -- Get_Target_Parameters -- --------------------------- -- Version that reads in system.ads procedure Get_Target_Parameters (Make_Id : Make_Id_Type := null; Make_SC : Make_SC_Type := null; Set_NOD : Set_NOD_Type := null; Set_NSA : Set_NSA_Type := null; Set_NUA : Set_NUA_Type := null; Set_NUP : Set_NUP_Type := null) is FD : File_Descriptor; Hi : Source_Ptr; Text : Source_Buffer_Ptr; begin if Parameters_Obtained then return; end if; Read_Source_File (Name_Find ("system.ads"), 0, Hi, Text, FD); if Null_Source_Buffer_Ptr (Text) then Write_Line ("fatal error, run-time library not installed correctly"); if FD = Osint.Null_FD then Write_Line ("cannot locate file system.ads"); else Write_Line ("no read access for file system.ads"); end if; 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_NOD => Set_NOD, Set_NSA => Set_NSA, Set_NUA => Set_NUA, Set_NUP => Set_NUP); 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_NOD : Set_NOD_Type := null; Set_NSA : Set_NSA_Type := null; Set_NUA : Set_NUA_Type := null; Set_NUP : Set_NUP_Type := null) is pragma Assert (System_Text'First = Source_First); pragma Assert (System_Text'Last = Source_Last); 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 OK : Boolean; -- Status result from Set_NUP/NSA/NUA call PR_Start : Source_Ptr; -- Pointer to ( following pragma Restrictions procedure Collect_Name; -- Scan a name starting at System_Text (P), and put Name in Name_Buffer, -- with Name_Len being length, folded to lower case. On return, P points -- just past the last character (which should be a right paren). function Looking_At (S : Source_Buffer) return Boolean; -- True if P points to the same text as S in System_Text function Looking_At_Skip (S : Source_Buffer) return Boolean; -- True if P points to the same text as S in System_Text, -- and if True, moves P forward to skip S as a side effect. ------------------ -- Collect_Name -- ------------------ procedure Collect_Name is begin Name_Len := 0; loop if System_Text (P) in 'a' .. 'z' or else System_Text (P) = '_' or else System_Text (P) in '0' .. '9' then Name_Buffer (Name_Len + 1) := System_Text (P); elsif System_Text (P) in 'A' .. 'Z' then Name_Buffer (Name_Len + 1) := Character'Val (Character'Pos (System_Text (P)) + 32); else exit; end if; P := P + 1; Name_Len := Name_Len + 1; end loop; end Collect_Name; ---------------- -- Looking_At -- ---------------- function Looking_At (S : Source_Buffer) return Boolean is Last : constant Source_Ptr := P + S'Length - 1; begin return Last <= System_Text'Last and then System_Text (P .. Last) = S; end Looking_At; --------------------- -- Looking_At_Skip -- --------------------- function Looking_At_Skip (S : Source_Buffer) return Boolean is Result : constant Boolean := Looking_At (S); begin if Result then P := P + S'Length; end if; return Result; end Looking_At_Skip; -- Start of processing for Get_Target_Parameters begin if Parameters_Obtained then return; end if; Parameters_Obtained := True; 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; while not Looking_At ("end System;") loop -- Skip comments if Looking_At ("-") then goto Line_Loop_Continue; -- Test for type Address is private elsif Looking_At_Skip (" type Address is private;") then Opt.Address_Is_Private := True; goto Line_Loop_Continue; -- Test for pragma Profile (Ravenscar); elsif Looking_At_Skip ("pragma Profile (Ravenscar);") then Set_Profile_Restrictions (Ravenscar); Opt.Task_Dispatching_Policy := 'F'; Opt.Locking_Policy := 'C'; goto Line_Loop_Continue; -- Test for pragma Profile (Jorvik); elsif Looking_At_Skip ("pragma Profile (Jorvik);") then Set_Profile_Restrictions (Jorvik); Opt.Task_Dispatching_Policy := 'F'; Opt.Locking_Policy := 'C'; goto Line_Loop_Continue; -- Test for pragma Profile (GNAT_Extended_Ravenscar); elsif Looking_At_Skip ("pragma Profile (GNAT_Extended_Ravenscar);") then Set_Profile_Restrictions (GNAT_Extended_Ravenscar); Opt.Task_Dispatching_Policy := 'F'; Opt.Locking_Policy := 'C'; goto Line_Loop_Continue; -- Test for pragma Profile (GNAT_Ravenscar_EDF); elsif Looking_At_Skip ("pragma Profile (GNAT_Ravenscar_EDF);") then Set_Profile_Restrictions (GNAT_Ravenscar_EDF); Opt.Task_Dispatching_Policy := 'E'; Opt.Locking_Policy := 'C'; goto Line_Loop_Continue; -- Test for pragma Profile (Restricted); elsif Looking_At_Skip ("pragma Profile (Restricted);") then Set_Profile_Restrictions (Restricted); goto Line_Loop_Continue; -- Test for pragma Restrictions elsif Looking_At_Skip ("pragma Restrictions (") then PR_Start := P - 1; -- Boolean restrictions 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; <> null; end loop; -- Restrictions taking integer parameter Ploop : for K in Integer_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; <> null; end loop Ploop; -- No_Dependence case if Looking_At_Skip ("No_Dependence => ") then -- 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_NOD (Unit); goto Line_Loop_Continue; end; -- No_Specification_Of_Aspect case elsif Looking_At_Skip ("No_Specification_Of_Aspect => ") then -- Skip this processing (and simply ignore the pragma), if -- caller did not supply the subprogram we need to process -- such lines. if Set_NSA = null then goto Line_Loop_Continue; end if; -- We have scanned -- "pragma Restrictions (No_Specification_Of_Aspect =>" Collect_Name; if System_Text (P) /= ')' then goto Bad_Restrictions_Pragma; else Set_NSA (Name_Find, OK); if OK then goto Line_Loop_Continue; else goto Bad_Restrictions_Pragma; end if; end if; -- No_Use_Of_Attribute case elsif Looking_At_Skip ("No_Use_Of_Attribute => ") then -- Skip this processing (and simply ignore No_Use_Of_Attribute -- lines) if caller did not supply the subprogram we need to -- process such lines. if Set_NUA = null then goto Line_Loop_Continue; end if; -- We have scanned -- "pragma Restrictions (No_Use_Of_Attribute =>" Collect_Name; if System_Text (P) /= ')' then goto Bad_Restrictions_Pragma; else Set_NUA (Name_Find, OK); if OK then goto Line_Loop_Continue; else goto Bad_Restrictions_Pragma; end if; end if; -- No_Use_Of_Pragma case elsif Looking_At_Skip ("No_Use_Of_Pragma => ") then -- Skip this processing (and simply ignore No_Use_Of_Pragma -- lines) if caller did not supply the subprogram we need to -- process such lines. if Set_NUP = null then goto Line_Loop_Continue; end if; -- We have scanned -- "pragma Restrictions (No_Use_Of_Pragma =>" Collect_Name; if System_Text (P) /= ')' then goto Bad_Restrictions_Pragma; else Set_NUP (Name_Find, OK); if OK then goto Line_Loop_Continue; else goto Bad_Restrictions_Pragma; end if; end if; 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: "); P := PR_Start; loop exit when System_Text (P) = ASCII.LF; Write_Char (System_Text (P)); exit when System_Text (P) = ')'; P := P + 1; end loop; Write_Eol; Fatal := True; Set_Standard_Output; -- Test for pragma Detect_Blocking; elsif Looking_At_Skip ("pragma Detect_Blocking;") then Opt.Detect_Blocking := True; goto Line_Loop_Continue; -- Discard_Names elsif Looking_At_Skip ("pragma Discard_Names;") then Opt.Global_Discard_Names := True; goto Line_Loop_Continue; -- Locking Policy elsif Looking_At_Skip ("pragma Locking_Policy (") then Opt.Locking_Policy := System_Text (P); Opt.Locking_Policy_Sloc := System_Location; goto Line_Loop_Continue; -- Normalize_Scalars elsif Looking_At_Skip ("pragma Normalize_Scalars;") then Opt.Normalize_Scalars := True; Opt.Init_Or_Norm_Scalars := True; goto Line_Loop_Continue; -- Partition_Elaboration_Policy elsif Looking_At_Skip ("pragma Partition_Elaboration_Policy (") then Opt.Partition_Elaboration_Policy := System_Text (P); Opt.Partition_Elaboration_Policy_Sloc := System_Location; goto Line_Loop_Continue; -- Queuing Policy elsif Looking_At_Skip ("pragma Queuing_Policy (") then Opt.Queuing_Policy := System_Text (P); Opt.Queuing_Policy_Sloc := System_Location; goto Line_Loop_Continue; -- Suppress_Exception_Locations elsif Looking_At_Skip ("pragma Suppress_Exception_Locations;") then Opt.Exception_Locations_Suppressed := True; goto Line_Loop_Continue; -- Task_Dispatching Policy elsif Looking_At_Skip ("pragma Task_Dispatching_Policy (") then Opt.Task_Dispatching_Policy := System_Text (P); Opt.Task_Dispatching_Policy_Sloc := System_Location; goto Line_Loop_Continue; -- Allow "pragma Style_Checks (On);" and "pragma Style_Checks (Off);" -- to make it possible to have long "pragma Restrictions" line. elsif Looking_At_Skip ("pragma Style_Checks (On);") or else Looking_At_Skip ("pragma Style_Checks (Off);") then goto Line_Loop_Continue; -- No other configuration pragmas are permitted elsif Looking_At ("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 Looking_At_Skip ("pragma Pure (System);") then 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 Looking_At_Skip (" Run_Time_Name : constant String := """) then 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 Looking_At_Skip (" Executable_Extension : constant String := """) then 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 Looking_At_Skip (" " & Targparm_Str (K).all) then 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 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 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 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 ZCX => 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 <> while P < Source_Last and then System_Text (P) /= CR and then System_Text (P) /= LF loop P := P + 1; end loop; while P < Source_Last and then (System_Text (P) = CR or else System_Text (P) = LF) loop P := P + 1; 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; 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;