1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
9 -- Copyright (C) 1999-2007, 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 3, 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 COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Csets; use Csets;
28 with Osint; use Osint;
29 with Output; use Output;
31 package body Targparm is
34 Parameters_Obtained : Boolean := False;
35 -- Set True after first call to Get_Target_Parameters. Used to avoid
36 -- reading system.ads more than once, since it cannot change.
38 -- The following array defines a tag name for each entry
42 ACR, -- Always_Compatible_Rep
43 BDC, -- Backend_Divide_Checks
44 BOC, -- Backend_Overflow_Checks
45 CLA, -- Command_Line_Args
47 CRT, -- Configurable_Run_Times
48 D32, -- Duration_32_Bits
50 EXS, -- Exit_Status_Supported
51 FEL, -- Frontend_Layout
52 FFO, -- Fractional_Fixed_Ops
54 MOV, -- Machine_Overflows
55 MRN, -- Machine_Rounds
56 PAS, -- Preallocated_Stacks
57 S64, -- Support_64_Bit_Divides
58 SAG, -- Support_Aggregates
59 SCA, -- Support_Composite_Assign
60 SCC, -- Support_Composite_Compare
61 SCD, -- Stack_Check_Default
62 SCL, -- Stack_Check_Limits
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
72 Targparm_Flags : array (Targparm_Tags) of Boolean := (others => False);
73 -- Flag is set True if corresponding parameter is scanned
75 -- The following list of string constants gives the parameter names
77 AAM_Str : aliased constant Source_Buffer := "AAMP";
78 ACR_Str : aliased constant Source_Buffer := "Always_Compatible_Rep";
79 BDC_Str : aliased constant Source_Buffer := "Backend_Divide_Checks";
80 BOC_Str : aliased constant Source_Buffer := "Backend_Overflow_Checks";
81 CLA_Str : aliased constant Source_Buffer := "Command_Line_Args";
82 CLI_Str : aliased constant Source_Buffer := "CLI";
83 CRT_Str : aliased constant Source_Buffer := "Configurable_Run_Time";
84 D32_Str : aliased constant Source_Buffer := "Duration_32_Bits";
85 DEN_Str : aliased constant Source_Buffer := "Denorm";
86 EXS_Str : aliased constant Source_Buffer := "Exit_Status_Supported";
87 FEL_Str : aliased constant Source_Buffer := "Frontend_Layout";
88 FFO_Str : aliased constant Source_Buffer := "Fractional_Fixed_Ops";
89 JVM_Str : aliased constant Source_Buffer := "JVM";
90 MOV_Str : aliased constant Source_Buffer := "Machine_Overflows";
91 MRN_Str : aliased constant Source_Buffer := "Machine_Rounds";
92 PAS_Str : aliased constant Source_Buffer := "Preallocated_Stacks";
93 S64_Str : aliased constant Source_Buffer := "Support_64_Bit_Divides";
94 SAG_Str : aliased constant Source_Buffer := "Support_Aggregates";
95 SCA_Str : aliased constant Source_Buffer := "Support_Composite_Assign";
96 SCC_Str : aliased constant Source_Buffer := "Support_Composite_Compare";
97 SCD_Str : aliased constant Source_Buffer := "Stack_Check_Default";
98 SCL_Str : aliased constant Source_Buffer := "Stack_Check_Limits";
99 SCP_Str : aliased constant Source_Buffer := "Stack_Check_Probes";
100 SLS_Str : aliased constant Source_Buffer := "Support_Long_Shifts";
101 SNZ_Str : aliased constant Source_Buffer := "Signed_Zeros";
102 SSL_Str : aliased constant Source_Buffer := "Suppress_Standard_Library";
103 UAM_Str : aliased constant Source_Buffer := "Use_Ada_Main_Program_Name";
104 VMS_Str : aliased constant Source_Buffer := "OpenVMS";
105 ZCD_Str : aliased constant Source_Buffer := "ZCX_By_Default";
106 ZCG_Str : aliased constant Source_Buffer := "GCC_ZCX_Support";
108 -- The following defines a set of pointers to the above strings,
109 -- indexed by the tag values.
111 type Buffer_Ptr is access constant Source_Buffer;
112 Targparm_Str : constant array (Targparm_Tags) of Buffer_Ptr :=
144 -----------------------
145 -- Local Subprograms --
146 -----------------------
148 procedure Set_Profile_Restrictions (P : Profile_Name);
149 -- Set Restrictions_On_Target for the given profile
151 ---------------------------
152 -- Get_Target_Parameters --
153 ---------------------------
155 -- Version which reads in system.ads
157 procedure Get_Target_Parameters is
158 Text : Source_Buffer_Ptr;
162 if Parameters_Obtained then
166 Name_Buffer (1 .. 10) := "system.ads";
169 Read_Source_File (Name_Find, Lo => 0, Hi => Hi, Src => Text);
172 Write_Line ("fatal error, run-time library not installed correctly");
173 Write_Line ("cannot locate file system.ads");
174 raise Unrecoverable_Error;
177 Get_Target_Parameters
178 (System_Text => Text,
181 end Get_Target_Parameters;
183 -- Version where caller supplies system.ads text
185 procedure Get_Target_Parameters
186 (System_Text : Source_Buffer_Ptr;
187 Source_First : Source_Ptr;
188 Source_Last : Source_Ptr)
191 -- Scans source buffer containing source of system.ads
193 Fatal : Boolean := False;
194 -- Set True if a fatal error is detected
197 -- Records boolean from system line
200 if Parameters_Obtained then
203 Parameters_Obtained := True;
206 Opt.Address_Is_Private := False;
209 Line_Loop : while System_Text (P .. P + 10) /= "end System;" loop
211 -- Skip comments quickly
213 if System_Text (P) = '-' then
214 goto Line_Loop_Continue;
216 -- Test for type Address is private
218 elsif System_Text (P .. P + 26) = " type Address is private;" then
219 Opt.Address_Is_Private := True;
221 goto Line_Loop_Continue;
223 -- Test for pragma Profile (Ravenscar);
225 elsif System_Text (P .. P + 26) =
226 "pragma Profile (Ravenscar);"
228 Set_Profile_Restrictions (Ravenscar);
229 Opt.Task_Dispatching_Policy := 'F';
230 Opt.Locking_Policy := 'C';
232 goto Line_Loop_Continue;
234 -- Test for pragma Profile (Restricted);
236 elsif System_Text (P .. P + 27) =
237 "pragma Profile (Restricted);"
239 Set_Profile_Restrictions (Restricted);
241 goto Line_Loop_Continue;
243 -- Test for pragma Restrictions
245 elsif System_Text (P .. P + 20) = "pragma Restrictions (" then
248 Rloop : for K in All_Boolean_Restrictions loop
250 Rname : constant String := Restriction_Id'Image (K);
253 for J in Rname'Range loop
254 if Fold_Upper (System_Text (P + Source_Ptr (J - 1)))
261 if System_Text (P + Rname'Length) = ')' then
262 Restrictions_On_Target.Set (K) := True;
263 goto Line_Loop_Continue;
271 Ploop : for K in All_Parameter_Restrictions loop
273 Rname : constant String :=
274 All_Parameter_Restrictions'Image (K);
280 for J in Rname'Range loop
281 if Fold_Upper (System_Text (P + Source_Ptr (J - 1)))
288 if System_Text (P + Rname'Length .. P + Rname'Length + 3) =
291 P := P + Rname'Length + 4;
295 if System_Text (P) in '0' .. '9' then
297 pragma Unsuppress (Overflow_Check);
300 -- Accumulate next digit
303 Character'Pos (System_Text (P)) -
307 -- On overflow, we just ignore the pragma since
308 -- that is the standard handling in this case.
310 when Constraint_Error =>
311 goto Line_Loop_Continue;
314 elsif System_Text (P) = '_' then
317 elsif System_Text (P) = ')' then
318 Restrictions_On_Target.Value (K) := V;
319 Restrictions_On_Target.Set (K) := True;
320 goto Line_Loop_Continue;
340 ("fatal error: system.ads is incorrectly formatted");
341 Write_Str ("unrecognized or incorrect restrictions pragma: ");
343 while System_Text (P) /= ')'
345 System_Text (P) /= ASCII.LF
347 Write_Char (System_Text (P));
355 -- Test for pragma Detect_Blocking;
357 elsif System_Text (P .. P + 22) = "pragma Detect_Blocking;" then
359 Opt.Detect_Blocking := True;
360 goto Line_Loop_Continue;
364 elsif System_Text (P .. P + 20) = "pragma Discard_Names;" then
366 Opt.Global_Discard_Names := True;
367 goto Line_Loop_Continue;
371 elsif System_Text (P .. P + 22) = "pragma Locking_Policy (" then
373 Opt.Locking_Policy := System_Text (P);
374 Opt.Locking_Policy_Sloc := System_Location;
375 goto Line_Loop_Continue;
379 elsif System_Text (P .. P + 24) = "pragma Normalize_Scalars;" then
381 Opt.Normalize_Scalars := True;
382 Opt.Init_Or_Norm_Scalars := True;
383 goto Line_Loop_Continue;
387 elsif System_Text (P .. P + 19) = "pragma Polling (On);" then
389 Opt.Polling_Required := True;
390 goto Line_Loop_Continue;
392 -- Ignore pragma Pure (System)
394 elsif System_Text (P .. P + 20) = "pragma Pure (System);" then
396 goto Line_Loop_Continue;
400 elsif System_Text (P .. P + 22) = "pragma Queuing_Policy (" then
402 Opt.Queuing_Policy := System_Text (P);
403 Opt.Queuing_Policy_Sloc := System_Location;
404 goto Line_Loop_Continue;
406 -- Suppress_Exception_Locations
408 elsif System_Text (P .. P + 34) =
409 "pragma Suppress_Exception_Locations;"
412 Opt.Exception_Locations_Suppressed := True;
413 goto Line_Loop_Continue;
415 -- Task_Dispatching Policy
417 elsif System_Text (P .. P + 31) =
418 "pragma Task_Dispatching_Policy ("
421 Opt.Task_Dispatching_Policy := System_Text (P);
422 Opt.Task_Dispatching_Policy_Sloc := System_Location;
423 goto Line_Loop_Continue;
425 -- No other pragmas are permitted
427 elsif System_Text (P .. P + 6) = "pragma " then
429 Write_Line ("unrecognized line in system.ads: ");
431 while System_Text (P) /= ')'
432 and then System_Text (P) /= ASCII.LF
434 Write_Char (System_Text (P));
442 -- See if we have a Run_Time_Name
444 elsif System_Text (P .. P + 38) =
445 " Run_Time_Name : constant String := """
450 while System_Text (P) in 'A' .. 'Z'
452 System_Text (P) in 'a' .. 'z'
454 System_Text (P) in '0' .. '9'
456 System_Text (P) = ' '
458 System_Text (P) = '_'
460 Add_Char_To_Name_Buffer (System_Text (P));
464 if System_Text (P) /= '"'
465 or else System_Text (P + 1) /= ';'
466 or else (System_Text (P + 2) /= ASCII.LF
468 System_Text (P + 2) /= ASCII.CR)
472 ("incorrectly formatted Run_Time_Name in system.ads");
477 Run_Time_Name_On_Target := Name_Enter;
480 goto Line_Loop_Continue;
482 -- See if we have an Executable_Extension
484 elsif System_Text (P .. P + 45) =
485 " Executable_Extension : constant String := """
490 while System_Text (P) /= '"'
491 and then System_Text (P) /= ASCII.LF
493 Add_Char_To_Name_Buffer (System_Text (P));
497 if System_Text (P) /= '"' or else System_Text (P + 1) /= ';' then
500 ("incorrectly formatted Executable_Extension in system.ads");
505 Executable_Extension_On_Target := Name_Enter;
508 goto Line_Loop_Continue;
510 -- Next See if we have a configuration parameter
513 Config_Param_Loop : for K in Targparm_Tags loop
514 if System_Text (P + 3 .. P + 2 + Targparm_Str (K)'Length) =
517 P := P + 3 + Targparm_Str (K)'Length;
519 if Targparm_Flags (K) then
522 ("fatal error: system.ads is incorrectly formatted");
523 Write_Str ("duplicate line for parameter: ");
525 for J in Targparm_Str (K)'Range loop
526 Write_Char (Targparm_Str (K).all (J));
534 Targparm_Flags (K) := True;
537 while System_Text (P) /= ':'
538 or else System_Text (P + 1) /= '='
545 while System_Text (P) = ' ' loop
549 Result := (System_Text (P) = 'T');
552 when AAM => AAMP_On_Target := Result;
553 when ACR => Always_Compatible_Rep_On_Target := Result;
554 when BDC => Backend_Divide_Checks_On_Target := Result;
555 when BOC => Backend_Overflow_Checks_On_Target := Result;
556 when CLA => Command_Line_Args_On_Target := Result;
559 VM_Target := CLI_Target;
562 when CRT => Configurable_Run_Time_On_Target := Result;
563 when D32 => Duration_32_Bits_On_Target := Result;
564 when DEN => Denorm_On_Target := Result;
565 when EXS => Exit_Status_Supported_On_Target := Result;
566 when FEL => Frontend_Layout_On_Target := Result;
567 when FFO => Fractional_Fixed_Ops_On_Target := Result;
570 VM_Target := JVM_Target;
573 when MOV => Machine_Overflows_On_Target := Result;
574 when MRN => Machine_Rounds_On_Target := Result;
575 when PAS => Preallocated_Stacks_On_Target := Result;
576 when S64 => Support_64_Bit_Divides_On_Target := Result;
577 when SAG => Support_Aggregates_On_Target := Result;
578 when SCA => Support_Composite_Assign_On_Target := Result;
579 when SCC => Support_Composite_Compare_On_Target := Result;
580 when SCD => Stack_Check_Default_On_Target := Result;
581 when SCL => Stack_Check_Limits_On_Target := Result;
582 when SCP => Stack_Check_Probes_On_Target := Result;
583 when SLS => Support_Long_Shifts_On_Target := Result;
584 when SSL => Suppress_Standard_Library_On_Target := Result;
585 when SNZ => Signed_Zeros_On_Target := Result;
586 when UAM => Use_Ada_Main_Program_Name_On_Target := Result;
587 when VMS => OpenVMS_On_Target := Result;
588 when ZCD => ZCX_By_Default_On_Target := Result;
589 when ZCG => GCC_ZCX_Support_On_Target := Result;
591 goto Line_Loop_Continue;
594 -- Here we are seeing a parameter we do not understand. We
595 -- simply ignore this (will happen when an old compiler is
596 -- used to compile a newer version of GNAT which does not
597 -- support the parameter).
599 end loop Config_Param_Loop;
602 -- Here after processing one line of System spec
604 <<Line_Loop_Continue>>
606 while System_Text (P) /= CR and then System_Text (P) /= LF loop
608 exit when P >= Source_Last;
611 while System_Text (P) = CR or else System_Text (P) = LF loop
613 exit when P >= Source_Last;
616 if P >= Source_Last then
618 Write_Line ("fatal error, system.ads not formatted correctly");
619 Write_Line ("unexpected end of file");
621 raise Unrecoverable_Error;
625 -- Now that OpenVMS_On_Target has been given its definitive value,
626 -- change the multi-unit index character from '~' to '$' for OpenVMS.
628 if OpenVMS_On_Target then
629 Multi_Unit_Index_Character := '$';
633 raise Unrecoverable_Error;
635 end Get_Target_Parameters;
637 ------------------------------
638 -- Set_Profile_Restrictions --
639 ------------------------------
641 procedure Set_Profile_Restrictions (P : Profile_Name) is
642 R : Restriction_Flags renames Profile_Info (P).Set;
643 V : Restriction_Values renames Profile_Info (P).Value;
645 for J in R'Range loop
647 Restrictions_On_Target.Set (J) := True;
649 if J in All_Parameter_Restrictions then
650 Restrictions_On_Target.Value (J) := V (J);
654 end Set_Profile_Restrictions;