1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
9 -- Copyright (C) 1999-2005 Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Csets; use Csets;
28 with Namet; use Namet;
30 with Osint; use Osint;
31 with Output; use Output;
33 package body Targparm is
36 Parameters_Obtained : Boolean := False;
37 -- Set True after first call to Get_Target_Parameters. Used to avoid
38 -- reading system.ads more than once, since it cannot change.
40 -- The following array defines a tag name for each entry
44 BDC, -- Backend_Divide_Checks
45 BOC, -- Backend_Overflow_Checks
46 CLA, -- Command_Line_Args
47 CRT, -- Configurable_Run_Times
48 CSV, -- Compiler_System_Version
49 D32, -- Duration_32_Bits
51 DSP, -- Functions_Return_By_DSP
52 EXS, -- Exit_Status_Supported
53 FEL, -- Frontend_Layout
54 FFO, -- Fractional_Fixed_Ops
55 MOV, -- Machine_Overflows
56 MRN, -- Machine_Rounds
57 PAS, -- Preallocated_Stacks
58 S64, -- Support_64_Bit_Divides
59 SAG, -- Support_Aggregates
60 SCA, -- Support_Composite_Assign
61 SCC, -- Support_Composite_Compare
62 SCD, -- Stack_Check_Default
63 SCP, -- Stack_Check_Probes
64 SLS, -- Support_Long_Shifts
66 SSL, -- Suppress_Standard_Library
67 UAM, -- Use_Ada_Main_Program_Name
69 ZCD, -- ZCX_By_Default
70 ZCG, -- GCC_ZCX_Support
71 ZCF); -- Front_End_ZCX_Support
73 subtype Targparm_Tags_OK is Targparm_Tags range AAM .. ZCF;
74 -- Range excluding obsolete entries
76 Targparm_Flags : array (Targparm_Tags) of Boolean := (others => False);
77 -- Flag is set True if corresponding parameter is scanned
79 -- The following list of string constants gives the parameter names
81 AAM_Str : aliased constant Source_Buffer := "AAMP";
82 BDC_Str : aliased constant Source_Buffer := "Backend_Divide_Checks";
83 BOC_Str : aliased constant Source_Buffer := "Backend_Overflow_Checks";
84 CLA_Str : aliased constant Source_Buffer := "Command_Line_Args";
85 CRT_Str : aliased constant Source_Buffer := "Configurable_Run_Time";
86 CSV_Str : aliased constant Source_Buffer := "Compiler_System_Version";
87 D32_Str : aliased constant Source_Buffer := "Duration_32_Bits";
88 DEN_Str : aliased constant Source_Buffer := "Denorm";
89 DSP_Str : aliased constant Source_Buffer := "Functions_Return_By_DSP";
90 EXS_Str : aliased constant Source_Buffer := "Exit_Status_Supported";
91 FEL_Str : aliased constant Source_Buffer := "Frontend_Layout";
92 FFO_Str : aliased constant Source_Buffer := "Fractional_Fixed_Ops";
93 MOV_Str : aliased constant Source_Buffer := "Machine_Overflows";
94 MRN_Str : aliased constant Source_Buffer := "Machine_Rounds";
95 PAS_Str : aliased constant Source_Buffer := "Preallocated_Stacks";
96 S64_Str : aliased constant Source_Buffer := "Support_64_Bit_Divides";
97 SAG_Str : aliased constant Source_Buffer := "Support_Aggregates";
98 SCA_Str : aliased constant Source_Buffer := "Support_Composite_Assign";
99 SCC_Str : aliased constant Source_Buffer := "Support_Composite_Compare";
100 SCD_Str : aliased constant Source_Buffer := "Stack_Check_Default";
101 SCP_Str : aliased constant Source_Buffer := "Stack_Check_Probes";
102 SLS_Str : aliased constant Source_Buffer := "Support_Long_Shifts";
103 SNZ_Str : aliased constant Source_Buffer := "Signed_Zeros";
104 SSL_Str : aliased constant Source_Buffer := "Suppress_Standard_Library";
105 UAM_Str : aliased constant Source_Buffer := "Use_Ada_Main_Program_Name";
106 VMS_Str : aliased constant Source_Buffer := "OpenVMS";
107 ZCD_Str : aliased constant Source_Buffer := "ZCX_By_Default";
108 ZCG_Str : aliased constant Source_Buffer := "GCC_ZCX_Support";
109 ZCF_Str : aliased constant Source_Buffer := "Front_End_ZCX_Support";
111 -- The following defines a set of pointers to the above strings,
112 -- indexed by the tag values.
114 type Buffer_Ptr is access constant Source_Buffer;
115 Targparm_Str : constant array (Targparm_Tags) of Buffer_Ptr :=
146 -----------------------
147 -- Local Subprograms --
148 -----------------------
150 procedure Set_Profile_Restrictions (P : Profile_Name);
151 -- Set Restrictions_On_Target for the given profile
153 ------------------------------
154 -- Set_Profile_Restrictions --
155 ------------------------------
157 procedure Set_Profile_Restrictions (P : Profile_Name) is
158 R : Restriction_Flags renames Profile_Info (P).Set;
159 V : Restriction_Values renames Profile_Info (P).Value;
162 for J in R'Range loop
164 Restrictions_On_Target.Set (J) := True;
166 if J in All_Parameter_Restrictions then
167 Restrictions_On_Target.Value (J) := V (J);
171 end Set_Profile_Restrictions;
173 ---------------------------
174 -- Get_Target_Parameters --
175 ---------------------------
177 -- Version which reads in system.ads
179 procedure Get_Target_Parameters is
180 Text : Source_Buffer_Ptr;
184 if Parameters_Obtained then
188 Name_Buffer (1 .. 10) := "system.ads";
191 Read_Source_File (Name_Find, Lo => 0, Hi => Hi, Src => Text);
194 Write_Line ("fatal error, run-time library not installed correctly");
195 Write_Line ("cannot locate file system.ads");
196 raise Unrecoverable_Error;
199 Targparm.Get_Target_Parameters
200 (System_Text => Text,
203 end Get_Target_Parameters;
205 -- Version where caller supplies system.ads text
207 procedure Get_Target_Parameters
208 (System_Text : Source_Buffer_Ptr;
209 Source_First : Source_Ptr;
210 Source_Last : Source_Ptr)
213 -- Scans source buffer containing source of system.ads
215 Fatal : Boolean := False;
216 -- Set True if a fatal error is detected
219 -- Records boolean from system line
222 if Parameters_Obtained then
225 Parameters_Obtained := True;
228 Opt.Address_Is_Private := False;
231 Line_Loop : while System_Text (P .. P + 10) /= "end System;" loop
233 -- Skip comments quickly
235 if System_Text (P) = '-' then
236 goto Line_Loop_Continue;
238 -- Test for type Address is private
240 elsif System_Text (P .. P + 26) = " type Address is private;" then
241 Opt.Address_Is_Private := True;
243 goto Line_Loop_Continue;
245 -- Test for pragma Profile (Ravenscar);
247 elsif System_Text (P .. P + 26) =
248 "pragma Profile (Ravenscar);"
250 Set_Profile_Restrictions (Ravenscar);
251 Opt.Task_Dispatching_Policy := 'F';
252 Opt.Locking_Policy := 'C';
254 goto Line_Loop_Continue;
256 -- Test for pragma Profile (Restricted);
258 elsif System_Text (P .. P + 27) =
259 "pragma Profile (Restricted);"
261 Set_Profile_Restrictions (Restricted);
263 goto Line_Loop_Continue;
265 -- Test for pragma Restrictions
267 elsif System_Text (P .. P + 20) = "pragma Restrictions (" then
270 Rloop : for K in All_Boolean_Restrictions loop
272 Rname : constant String := Restriction_Id'Image (K);
275 for J in Rname'Range loop
276 if Fold_Upper (System_Text (P + Source_Ptr (J - 1)))
283 if System_Text (P + Rname'Length) = ')' then
284 Restrictions_On_Target.Set (K) := True;
285 goto Line_Loop_Continue;
293 Ploop : for K in All_Parameter_Restrictions loop
295 Rname : constant String :=
296 All_Parameter_Restrictions'Image (K);
302 for J in Rname'Range loop
303 if Fold_Upper (System_Text (P + Source_Ptr (J - 1)))
310 if System_Text (P + Rname'Length .. P + Rname'Length + 3) =
313 P := P + Rname'Length + 4;
317 if System_Text (P) in '0' .. '9' then
319 pragma Unsuppress (Overflow_Check);
322 -- Accumulate next digit
325 Character'Pos (System_Text (P)) -
329 -- On overflow, we just ignore the pragma since
330 -- that is the standard handling in this case.
332 when Constraint_Error =>
333 goto Line_Loop_Continue;
336 elsif System_Text (P) = '_' then
339 elsif System_Text (P) = ')' then
340 Restrictions_On_Target.Value (K) := V;
341 Restrictions_On_Target.Set (K) := True;
342 goto Line_Loop_Continue;
362 ("fatal error: system.ads is incorrectly formatted");
363 Write_Str ("unrecognized or incorrect restrictions pragma: ");
365 while System_Text (P) /= ')'
367 System_Text (P) /= ASCII.LF
369 Write_Char (System_Text (P));
377 -- Test for pragma Detect_Blocking;
379 elsif System_Text (P .. P + 22) = "pragma Detect_Blocking;" then
381 Opt.Detect_Blocking := True;
382 goto Line_Loop_Continue;
386 elsif System_Text (P .. P + 20) = "pragma Discard_Names;" then
388 Opt.Global_Discard_Names := True;
389 goto Line_Loop_Continue;
393 elsif System_Text (P .. P + 22) = "pragma Locking_Policy (" then
395 Opt.Locking_Policy := System_Text (P);
396 Opt.Locking_Policy_Sloc := System_Location;
397 goto Line_Loop_Continue;
401 elsif System_Text (P .. P + 24) = "pragma Normalize_Scalars;" then
403 Opt.Normalize_Scalars := True;
404 Opt.Init_Or_Norm_Scalars := True;
405 goto Line_Loop_Continue;
409 elsif System_Text (P .. P + 19) = "pragma Polling (On);" then
411 Opt.Polling_Required := True;
412 goto Line_Loop_Continue;
414 -- Ignore pragma Pure (System)
416 elsif System_Text (P .. P + 20) = "pragma Pure (System);" then
418 goto Line_Loop_Continue;
422 elsif System_Text (P .. P + 22) = "pragma Queuing_Policy (" then
424 Opt.Queuing_Policy := System_Text (P);
425 Opt.Queuing_Policy_Sloc := System_Location;
426 goto Line_Loop_Continue;
428 -- Suppress_Exception_Locations
430 elsif System_Text (P .. P + 34) =
431 "pragma Suppress_Exception_Locations;"
434 Opt.Exception_Locations_Suppressed := True;
435 goto Line_Loop_Continue;
437 -- Task_Dispatching Policy
439 elsif System_Text (P .. P + 31) =
440 "pragma Task_Dispatching_Policy ("
443 Opt.Task_Dispatching_Policy := System_Text (P);
444 Opt.Task_Dispatching_Policy_Sloc := System_Location;
445 goto Line_Loop_Continue;
447 -- No other pragmas are permitted
449 elsif System_Text (P .. P + 6) = "pragma " then
451 Write_Line ("unrecognized line in system.ads: ");
453 while System_Text (P) /= ')'
454 and then System_Text (P) /= ASCII.LF
456 Write_Char (System_Text (P));
464 -- See if we have a Run_Time_Name
466 elsif System_Text (P .. P + 38) =
467 " Run_Time_Name : constant String := """
472 while System_Text (P) in 'A' .. 'Z'
474 System_Text (P) in 'a' .. 'z'
476 System_Text (P) in '0' .. '9'
478 System_Text (P) = ' '
480 System_Text (P) = '_'
482 Add_Char_To_Name_Buffer (System_Text (P));
486 if System_Text (P) /= '"'
487 or else System_Text (P + 1) /= ';'
488 or else (System_Text (P + 2) /= ASCII.LF
490 System_Text (P + 2) /= ASCII.CR)
494 ("incorrectly formatted Run_Time_Name in system.ads");
499 Run_Time_Name_On_Target := Name_Enter;
502 goto Line_Loop_Continue;
504 -- Next See if we have a configuration parameter
507 Config_Param_Loop : for K in Targparm_Tags loop
508 if System_Text (P + 3 .. P + 2 + Targparm_Str (K)'Length) =
511 P := P + 3 + Targparm_Str (K)'Length;
513 if Targparm_Flags (K) then
516 ("fatal error: system.ads is incorrectly formatted");
517 Write_Str ("duplicate line for parameter: ");
519 for J in Targparm_Str (K)'Range loop
520 Write_Char (Targparm_Str (K).all (J));
528 Targparm_Flags (K) := True;
531 while System_Text (P) /= ':'
532 or else System_Text (P + 1) /= '='
539 while System_Text (P) = ' ' loop
543 Result := (System_Text (P) = 'T');
546 when AAM => AAMP_On_Target := Result;
547 when BDC => Backend_Divide_Checks_On_Target := Result;
548 when BOC => Backend_Overflow_Checks_On_Target := Result;
549 when CLA => Command_Line_Args_On_Target := Result;
550 when CRT => Configurable_Run_Time_On_Target := Result;
551 when CSV => Compiler_System_Version := Result;
552 when D32 => Duration_32_Bits_On_Target := Result;
553 when DEN => Denorm_On_Target := Result;
554 when DSP => Functions_Return_By_DSP_On_Target := Result;
555 when EXS => Exit_Status_Supported_On_Target := Result;
556 when FEL => Frontend_Layout_On_Target := Result;
557 when FFO => Fractional_Fixed_Ops_On_Target := Result;
558 when MOV => Machine_Overflows_On_Target := Result;
559 when MRN => Machine_Rounds_On_Target := Result;
560 when PAS => Preallocated_Stacks_On_Target := Result;
561 when S64 => Support_64_Bit_Divides_On_Target := Result;
562 when SAG => Support_Aggregates_On_Target := Result;
563 when SCA => Support_Composite_Assign_On_Target := Result;
564 when SCC => Support_Composite_Compare_On_Target := Result;
565 when SCD => Stack_Check_Default_On_Target := Result;
566 when SCP => Stack_Check_Probes_On_Target := Result;
567 when SLS => Support_Long_Shifts_On_Target := Result;
568 when SSL => Suppress_Standard_Library_On_Target := Result;
569 when SNZ => Signed_Zeros_On_Target := Result;
570 when UAM => Use_Ada_Main_Program_Name_On_Target := Result;
571 when VMS => OpenVMS_On_Target := Result;
572 when ZCD => ZCX_By_Default_On_Target := Result;
573 when ZCG => GCC_ZCX_Support_On_Target := Result;
574 when ZCF => Front_End_ZCX_Support_On_Target := Result;
576 goto Line_Loop_Continue;
579 -- Here we are seeing a parameter we do not understand. We
580 -- simply ignore this (will happen when an old compiler is
581 -- used to compile a newer version of GNAT which does not
584 end loop Config_Param_Loop;
587 -- Here after processing one line of System spec
589 <<Line_Loop_Continue>>
591 while System_Text (P) /= CR and then System_Text (P) /= LF loop
593 exit when P >= Source_Last;
596 while System_Text (P) = CR or else System_Text (P) = LF loop
598 exit when P >= Source_Last;
601 if P >= Source_Last then
603 Write_Line ("fatal error, system.ads not formatted correctly");
604 Write_Line ("unexpected end of file");
606 raise Unrecoverable_Error;
610 -- Check no missing target parameter settings (skip for compiler vsn)
612 if not Compiler_System_Version then
613 for K in Targparm_Tags_OK loop
614 if not Targparm_Flags (K) then
617 ("fatal error: system.ads is incorrectly formatted");
618 Write_Str ("missing line for parameter: ");
620 for J in Targparm_Str (K)'Range loop
621 Write_Char (Targparm_Str (K).all (J));
633 raise Unrecoverable_Error;
635 end Get_Target_Parameters;