gcc:
[official-gcc.git] / gcc / ada / targparm.adb
blob3aa3cc3207e9fa54dd341f263463039cda4e0e4d
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT RUN-TIME COMPONENTS --
4 -- --
5 -- T A R G P A R M --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1999-2006, Free Software Foundation, Inc. --
10 -- --
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, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
21 -- --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 -- --
25 ------------------------------------------------------------------------------
27 with Csets; use Csets;
28 with Namet; use Namet;
29 with Opt; use Opt;
30 with Osint; use Osint;
31 with Output; use Output;
33 package body Targparm is
34 use ASCII;
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
42 type Targparm_Tags is
43 (AAM, -- AAMP
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
50 DEN, -- Denorm
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
65 SNZ, -- Signed_Zeros
66 SSL, -- Suppress_Standard_Library
67 UAM, -- Use_Ada_Main_Program_Name
68 VMS, -- OpenVMS
69 ZCD, -- ZCX_By_Default
70 ZCG); -- GCC_ZCX_Support
72 subtype Targparm_Tags_OK is Targparm_Tags range AAM .. ZCG;
73 -- Range excluding obsolete entries
75 Targparm_Flags : array (Targparm_Tags) of Boolean := (others => False);
76 -- Flag is set True if corresponding parameter is scanned
78 -- The following list of string constants gives the parameter names
80 AAM_Str : aliased constant Source_Buffer := "AAMP";
81 BDC_Str : aliased constant Source_Buffer := "Backend_Divide_Checks";
82 BOC_Str : aliased constant Source_Buffer := "Backend_Overflow_Checks";
83 CLA_Str : aliased constant Source_Buffer := "Command_Line_Args";
84 CRT_Str : aliased constant Source_Buffer := "Configurable_Run_Time";
85 CSV_Str : aliased constant Source_Buffer := "Compiler_System_Version";
86 D32_Str : aliased constant Source_Buffer := "Duration_32_Bits";
87 DEN_Str : aliased constant Source_Buffer := "Denorm";
88 DSP_Str : aliased constant Source_Buffer := "Functions_Return_By_DSP";
89 EXS_Str : aliased constant Source_Buffer := "Exit_Status_Supported";
90 FEL_Str : aliased constant Source_Buffer := "Frontend_Layout";
91 FFO_Str : aliased constant Source_Buffer := "Fractional_Fixed_Ops";
92 MOV_Str : aliased constant Source_Buffer := "Machine_Overflows";
93 MRN_Str : aliased constant Source_Buffer := "Machine_Rounds";
94 PAS_Str : aliased constant Source_Buffer := "Preallocated_Stacks";
95 S64_Str : aliased constant Source_Buffer := "Support_64_Bit_Divides";
96 SAG_Str : aliased constant Source_Buffer := "Support_Aggregates";
97 SCA_Str : aliased constant Source_Buffer := "Support_Composite_Assign";
98 SCC_Str : aliased constant Source_Buffer := "Support_Composite_Compare";
99 SCD_Str : aliased constant Source_Buffer := "Stack_Check_Default";
100 SCP_Str : aliased constant Source_Buffer := "Stack_Check_Probes";
101 SLS_Str : aliased constant Source_Buffer := "Support_Long_Shifts";
102 SNZ_Str : aliased constant Source_Buffer := "Signed_Zeros";
103 SSL_Str : aliased constant Source_Buffer := "Suppress_Standard_Library";
104 UAM_Str : aliased constant Source_Buffer := "Use_Ada_Main_Program_Name";
105 VMS_Str : aliased constant Source_Buffer := "OpenVMS";
106 ZCD_Str : aliased constant Source_Buffer := "ZCX_By_Default";
107 ZCG_Str : aliased constant Source_Buffer := "GCC_ZCX_Support";
109 -- The following defines a set of pointers to the above strings,
110 -- indexed by the tag values.
112 type Buffer_Ptr is access constant Source_Buffer;
113 Targparm_Str : constant array (Targparm_Tags) of Buffer_Ptr :=
114 (AAM_Str'Access,
115 BDC_Str'Access,
116 BOC_Str'Access,
117 CLA_Str'Access,
118 CRT_Str'Access,
119 CSV_Str'Access,
120 D32_Str'Access,
121 DEN_Str'Access,
122 DSP_Str'Access,
123 EXS_Str'Access,
124 FEL_Str'Access,
125 FFO_Str'Access,
126 MOV_Str'Access,
127 MRN_Str'Access,
128 PAS_Str'Access,
129 S64_Str'Access,
130 SAG_Str'Access,
131 SCA_Str'Access,
132 SCC_Str'Access,
133 SCD_Str'Access,
134 SCP_Str'Access,
135 SLS_Str'Access,
136 SNZ_Str'Access,
137 SSL_Str'Access,
138 UAM_Str'Access,
139 VMS_Str'Access,
140 ZCD_Str'Access,
141 ZCG_Str'Access);
143 -----------------------
144 -- Local Subprograms --
145 -----------------------
147 procedure Set_Profile_Restrictions (P : Profile_Name);
148 -- Set Restrictions_On_Target for the given profile
150 ---------------------------
151 -- Get_Target_Parameters --
152 ---------------------------
154 -- Version which reads in system.ads
156 procedure Get_Target_Parameters is
157 Text : Source_Buffer_Ptr;
158 Hi : Source_Ptr;
160 begin
161 if Parameters_Obtained then
162 return;
163 end if;
165 Name_Buffer (1 .. 10) := "system.ads";
166 Name_Len := 10;
168 Read_Source_File (Name_Find, Lo => 0, Hi => Hi, Src => Text);
170 if Text = null then
171 Write_Line ("fatal error, run-time library not installed correctly");
172 Write_Line ("cannot locate file system.ads");
173 raise Unrecoverable_Error;
174 end if;
176 Targparm.Get_Target_Parameters
177 (System_Text => Text,
178 Source_First => 0,
179 Source_Last => Hi);
180 end Get_Target_Parameters;
182 -- Version where caller supplies system.ads text
184 procedure Get_Target_Parameters
185 (System_Text : Source_Buffer_Ptr;
186 Source_First : Source_Ptr;
187 Source_Last : Source_Ptr)
189 P : Source_Ptr;
190 -- Scans source buffer containing source of system.ads
192 Fatal : Boolean := False;
193 -- Set True if a fatal error is detected
195 Result : Boolean;
196 -- Records boolean from system line
198 begin
199 if Parameters_Obtained then
200 return;
201 else
202 Parameters_Obtained := True;
203 end if;
205 Opt.Address_Is_Private := False;
207 P := Source_First;
208 Line_Loop : while System_Text (P .. P + 10) /= "end System;" loop
210 -- Skip comments quickly
212 if System_Text (P) = '-' then
213 goto Line_Loop_Continue;
215 -- Test for type Address is private
217 elsif System_Text (P .. P + 26) = " type Address is private;" then
218 Opt.Address_Is_Private := True;
219 P := P + 26;
220 goto Line_Loop_Continue;
222 -- Test for pragma Profile (Ravenscar);
224 elsif System_Text (P .. P + 26) =
225 "pragma Profile (Ravenscar);"
226 then
227 Set_Profile_Restrictions (Ravenscar);
228 Opt.Task_Dispatching_Policy := 'F';
229 Opt.Locking_Policy := 'C';
230 P := P + 27;
231 goto Line_Loop_Continue;
233 -- Test for pragma Profile (Restricted);
235 elsif System_Text (P .. P + 27) =
236 "pragma Profile (Restricted);"
237 then
238 Set_Profile_Restrictions (Restricted);
239 P := P + 28;
240 goto Line_Loop_Continue;
242 -- Test for pragma Restrictions
244 elsif System_Text (P .. P + 20) = "pragma Restrictions (" then
245 P := P + 21;
247 Rloop : for K in All_Boolean_Restrictions loop
248 declare
249 Rname : constant String := Restriction_Id'Image (K);
251 begin
252 for J in Rname'Range loop
253 if Fold_Upper (System_Text (P + Source_Ptr (J - 1)))
254 /= Rname (J)
255 then
256 goto Rloop_Continue;
257 end if;
258 end loop;
260 if System_Text (P + Rname'Length) = ')' then
261 Restrictions_On_Target.Set (K) := True;
262 goto Line_Loop_Continue;
263 end if;
264 end;
266 <<Rloop_Continue>>
267 null;
268 end loop Rloop;
270 Ploop : for K in All_Parameter_Restrictions loop
271 declare
272 Rname : constant String :=
273 All_Parameter_Restrictions'Image (K);
275 V : Natural;
276 -- Accumulates value
278 begin
279 for J in Rname'Range loop
280 if Fold_Upper (System_Text (P + Source_Ptr (J - 1)))
281 /= Rname (J)
282 then
283 goto Ploop_Continue;
284 end if;
285 end loop;
287 if System_Text (P + Rname'Length .. P + Rname'Length + 3) =
288 " => "
289 then
290 P := P + Rname'Length + 4;
292 V := 0;
293 loop
294 if System_Text (P) in '0' .. '9' then
295 declare
296 pragma Unsuppress (Overflow_Check);
298 begin
299 -- Accumulate next digit
301 V := 10 * V +
302 Character'Pos (System_Text (P)) -
303 Character'Pos ('0');
305 exception
306 -- On overflow, we just ignore the pragma since
307 -- that is the standard handling in this case.
309 when Constraint_Error =>
310 goto Line_Loop_Continue;
311 end;
313 elsif System_Text (P) = '_' then
314 null;
316 elsif System_Text (P) = ')' then
317 Restrictions_On_Target.Value (K) := V;
318 Restrictions_On_Target.Set (K) := True;
319 goto Line_Loop_Continue;
321 else
322 exit Ploop;
323 end if;
325 P := P + 1;
326 end loop;
328 else
329 exit Ploop;
330 end if;
331 end;
333 <<Ploop_Continue>>
334 null;
335 end loop Ploop;
337 Set_Standard_Error;
338 Write_Line
339 ("fatal error: system.ads is incorrectly formatted");
340 Write_Str ("unrecognized or incorrect restrictions pragma: ");
342 while System_Text (P) /= ')'
343 and then
344 System_Text (P) /= ASCII.LF
345 loop
346 Write_Char (System_Text (P));
347 P := P + 1;
348 end loop;
350 Write_Eol;
351 Fatal := True;
352 Set_Standard_Output;
354 -- Test for pragma Detect_Blocking;
356 elsif System_Text (P .. P + 22) = "pragma Detect_Blocking;" then
357 P := P + 23;
358 Opt.Detect_Blocking := True;
359 goto Line_Loop_Continue;
361 -- Discard_Names
363 elsif System_Text (P .. P + 20) = "pragma Discard_Names;" then
364 P := P + 21;
365 Opt.Global_Discard_Names := True;
366 goto Line_Loop_Continue;
368 -- Locking Policy
370 elsif System_Text (P .. P + 22) = "pragma Locking_Policy (" then
371 P := P + 23;
372 Opt.Locking_Policy := System_Text (P);
373 Opt.Locking_Policy_Sloc := System_Location;
374 goto Line_Loop_Continue;
376 -- Normalize_Scalars
378 elsif System_Text (P .. P + 24) = "pragma Normalize_Scalars;" then
379 P := P + 25;
380 Opt.Normalize_Scalars := True;
381 Opt.Init_Or_Norm_Scalars := True;
382 goto Line_Loop_Continue;
384 -- Polling (On)
386 elsif System_Text (P .. P + 19) = "pragma Polling (On);" then
387 P := P + 20;
388 Opt.Polling_Required := True;
389 goto Line_Loop_Continue;
391 -- Ignore pragma Pure (System)
393 elsif System_Text (P .. P + 20) = "pragma Pure (System);" then
394 P := P + 21;
395 goto Line_Loop_Continue;
397 -- Queuing Policy
399 elsif System_Text (P .. P + 22) = "pragma Queuing_Policy (" then
400 P := P + 23;
401 Opt.Queuing_Policy := System_Text (P);
402 Opt.Queuing_Policy_Sloc := System_Location;
403 goto Line_Loop_Continue;
405 -- Suppress_Exception_Locations
407 elsif System_Text (P .. P + 34) =
408 "pragma Suppress_Exception_Locations;"
409 then
410 P := P + 35;
411 Opt.Exception_Locations_Suppressed := True;
412 goto Line_Loop_Continue;
414 -- Task_Dispatching Policy
416 elsif System_Text (P .. P + 31) =
417 "pragma Task_Dispatching_Policy ("
418 then
419 P := P + 32;
420 Opt.Task_Dispatching_Policy := System_Text (P);
421 Opt.Task_Dispatching_Policy_Sloc := System_Location;
422 goto Line_Loop_Continue;
424 -- No other pragmas are permitted
426 elsif System_Text (P .. P + 6) = "pragma " then
427 Set_Standard_Error;
428 Write_Line ("unrecognized line in system.ads: ");
430 while System_Text (P) /= ')'
431 and then System_Text (P) /= ASCII.LF
432 loop
433 Write_Char (System_Text (P));
434 P := P + 1;
435 end loop;
437 Write_Eol;
438 Set_Standard_Output;
439 Fatal := True;
441 -- See if we have a Run_Time_Name
443 elsif System_Text (P .. P + 38) =
444 " Run_Time_Name : constant String := """
445 then
446 P := P + 39;
448 Name_Len := 0;
449 while System_Text (P) in 'A' .. 'Z'
450 or else
451 System_Text (P) in 'a' .. 'z'
452 or else
453 System_Text (P) in '0' .. '9'
454 or else
455 System_Text (P) = ' '
456 or else
457 System_Text (P) = '_'
458 loop
459 Add_Char_To_Name_Buffer (System_Text (P));
460 P := P + 1;
461 end loop;
463 if System_Text (P) /= '"'
464 or else System_Text (P + 1) /= ';'
465 or else (System_Text (P + 2) /= ASCII.LF
466 and then
467 System_Text (P + 2) /= ASCII.CR)
468 then
469 Set_Standard_Error;
470 Write_Line
471 ("incorrectly formatted Run_Time_Name in system.ads");
472 Set_Standard_Output;
473 Fatal := True;
475 else
476 Run_Time_Name_On_Target := Name_Enter;
477 end if;
479 goto Line_Loop_Continue;
481 -- See if we have an Executable_Extension
483 elsif System_Text (P .. P + 45) =
484 " Executable_Extension : constant String := """
485 then
486 P := P + 46;
488 Name_Len := 0;
489 while System_Text (P) /= '"'
490 and then System_Text (P) /= ASCII.LF
491 loop
492 Add_Char_To_Name_Buffer (System_Text (P));
493 P := P + 1;
494 end loop;
496 if System_Text (P) /= '"' or else System_Text (P + 1) /= ';' then
497 Set_Standard_Error;
498 Write_Line
499 ("incorrectly formatted Executable_Extension in system.ads");
500 Set_Standard_Output;
501 Fatal := True;
503 else
504 Executable_Extension_On_Target := Name_Enter;
505 end if;
507 goto Line_Loop_Continue;
509 -- Next See if we have a configuration parameter
511 else
512 Config_Param_Loop : for K in Targparm_Tags loop
513 if System_Text (P + 3 .. P + 2 + Targparm_Str (K)'Length) =
514 Targparm_Str (K).all
515 then
516 P := P + 3 + Targparm_Str (K)'Length;
518 if Targparm_Flags (K) then
519 Set_Standard_Error;
520 Write_Line
521 ("fatal error: system.ads is incorrectly formatted");
522 Write_Str ("duplicate line for parameter: ");
524 for J in Targparm_Str (K)'Range loop
525 Write_Char (Targparm_Str (K).all (J));
526 end loop;
528 Write_Eol;
529 Set_Standard_Output;
530 Fatal := True;
532 else
533 Targparm_Flags (K) := True;
534 end if;
536 while System_Text (P) /= ':'
537 or else System_Text (P + 1) /= '='
538 loop
539 P := P + 1;
540 end loop;
542 P := P + 2;
544 while System_Text (P) = ' ' loop
545 P := P + 1;
546 end loop;
548 Result := (System_Text (P) = 'T');
550 case K is
551 when AAM => AAMP_On_Target := Result;
552 when BDC => Backend_Divide_Checks_On_Target := Result;
553 when BOC => Backend_Overflow_Checks_On_Target := Result;
554 when CLA => Command_Line_Args_On_Target := Result;
555 when CRT => Configurable_Run_Time_On_Target := Result;
556 when CSV => Compiler_System_Version := Result;
557 when D32 => Duration_32_Bits_On_Target := Result;
558 when DEN => Denorm_On_Target := Result;
559 when DSP => Functions_Return_By_DSP_On_Target := Result;
560 when EXS => Exit_Status_Supported_On_Target := Result;
561 when FEL => Frontend_Layout_On_Target := Result;
562 when FFO => Fractional_Fixed_Ops_On_Target := Result;
563 when MOV => Machine_Overflows_On_Target := Result;
564 when MRN => Machine_Rounds_On_Target := Result;
565 when PAS => Preallocated_Stacks_On_Target := Result;
566 when S64 => Support_64_Bit_Divides_On_Target := Result;
567 when SAG => Support_Aggregates_On_Target := Result;
568 when SCA => Support_Composite_Assign_On_Target := Result;
569 when SCC => Support_Composite_Compare_On_Target := Result;
570 when SCD => Stack_Check_Default_On_Target := Result;
571 when SCP => Stack_Check_Probes_On_Target := Result;
572 when SLS => Support_Long_Shifts_On_Target := Result;
573 when SSL => Suppress_Standard_Library_On_Target := Result;
574 when SNZ => Signed_Zeros_On_Target := Result;
575 when UAM => Use_Ada_Main_Program_Name_On_Target := Result;
576 when VMS => OpenVMS_On_Target := Result;
577 when ZCD => ZCX_By_Default_On_Target := Result;
578 when ZCG => GCC_ZCX_Support_On_Target := Result;
580 goto Line_Loop_Continue;
581 end case;
583 -- Here we are seeing a parameter we do not understand. We
584 -- simply ignore this (will happen when an old compiler is
585 -- used to compile a newer version of GNAT which does not
586 -- support the
587 end if;
588 end loop Config_Param_Loop;
589 end if;
591 -- Here after processing one line of System spec
593 <<Line_Loop_Continue>>
595 while System_Text (P) /= CR and then System_Text (P) /= LF loop
596 P := P + 1;
597 exit when P >= Source_Last;
598 end loop;
600 while System_Text (P) = CR or else System_Text (P) = LF loop
601 P := P + 1;
602 exit when P >= Source_Last;
603 end loop;
605 if P >= Source_Last then
606 Set_Standard_Error;
607 Write_Line ("fatal error, system.ads not formatted correctly");
608 Write_Line ("unexpected end of file");
609 Set_Standard_Output;
610 raise Unrecoverable_Error;
611 end if;
612 end loop Line_Loop;
614 -- Now that OpenVMS_On_Target has been given its definitive value,
615 -- change the multi-unit index character from '~' to '$' for OpenVMS.
617 if OpenVMS_On_Target then
618 Multi_Unit_Index_Character := '$';
619 end if;
621 -- Check no missing target parameter settings (skip for compiler vsn)
623 if not Compiler_System_Version then
624 for K in Targparm_Tags_OK loop
625 if not Targparm_Flags (K) then
626 Set_Standard_Error;
627 Write_Line
628 ("fatal error: system.ads is incorrectly formatted");
629 Write_Str ("missing line for parameter: ");
631 for J in Targparm_Str (K)'Range loop
632 Write_Char (Targparm_Str (K).all (J));
633 end loop;
635 Write_Eol;
636 Set_Standard_Output;
637 Fatal := True;
638 end if;
639 end loop;
640 end if;
642 if Fatal then
643 raise Unrecoverable_Error;
644 end if;
645 end Get_Target_Parameters;
647 ------------------------------
648 -- Set_Profile_Restrictions --
649 ------------------------------
651 procedure Set_Profile_Restrictions (P : Profile_Name) is
652 R : Restriction_Flags renames Profile_Info (P).Set;
653 V : Restriction_Values renames Profile_Info (P).Value;
654 begin
655 for J in R'Range loop
656 if R (J) then
657 Restrictions_On_Target.Set (J) := True;
659 if J in All_Parameter_Restrictions then
660 Restrictions_On_Target.Value (J) := V (J);
661 end if;
662 end if;
663 end loop;
664 end Set_Profile_Restrictions;
666 end Targparm;