| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT RUN-TIME COMPONENTS -- |
| -- -- |
| -- T A R G P A R M -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1999-2022, 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 |
| FEX, -- Frontend_Exceptions |
| 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"; |
| FEX_Str : aliased constant Source_Buffer := "Frontend_Exceptions"; |
| 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, |
| FEX => FEX_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; |
| |
| <<Rloop_Continue>> 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; |
| |
| <<Ploop_Continue>> 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 |
| |
| <<Bad_Restrictions_Pragma>> |
| |
| 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; |
| |
| -- 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 FEX => Frontend_Exceptions_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 |
| |
| <<Line_Loop_Continue>> |
| |
| 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; |
