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, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, 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
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
:=
143 -----------------------
144 -- Local Subprograms --
145 -----------------------
147 procedure Set_Profile_Restrictions
(P
: Profile_Name
);
148 -- Set Restrictions_On_Target for the given profile
150 ------------------------------
151 -- Set_Profile_Restrictions --
152 ------------------------------
154 procedure Set_Profile_Restrictions
(P
: Profile_Name
) is
155 R
: Restriction_Flags
renames Profile_Info
(P
).Set
;
156 V
: Restriction_Values
renames Profile_Info
(P
).Value
;
159 for J
in R
'Range loop
161 Restrictions_On_Target
.Set
(J
) := True;
163 if J
in All_Parameter_Restrictions
then
164 Restrictions_On_Target
.Value
(J
) := V
(J
);
168 end Set_Profile_Restrictions
;
170 ---------------------------
171 -- Get_Target_Parameters --
172 ---------------------------
174 -- Version which reads in system.ads
176 procedure Get_Target_Parameters
is
177 Text
: Source_Buffer_Ptr
;
181 if Parameters_Obtained
then
185 Name_Buffer
(1 .. 10) := "system.ads";
188 Read_Source_File
(Name_Find
, Lo
=> 0, Hi
=> Hi
, Src
=> Text
);
191 Write_Line
("fatal error, run-time library not installed correctly");
192 Write_Line
("cannot locate file system.ads");
193 raise Unrecoverable_Error
;
196 Targparm
.Get_Target_Parameters
197 (System_Text
=> Text
,
200 end Get_Target_Parameters
;
202 -- Version where caller supplies system.ads text
204 procedure Get_Target_Parameters
205 (System_Text
: Source_Buffer_Ptr
;
206 Source_First
: Source_Ptr
;
207 Source_Last
: Source_Ptr
)
210 -- Scans source buffer containing source of system.ads
212 Fatal
: Boolean := False;
213 -- Set True if a fatal error is detected
216 -- Records boolean from system line
219 if Parameters_Obtained
then
222 Parameters_Obtained
:= True;
225 Opt
.Address_Is_Private
:= False;
228 Line_Loop
: while System_Text
(P
.. P
+ 10) /= "end System;" loop
230 -- Skip comments quickly
232 if System_Text
(P
) = '-' then
233 goto Line_Loop_Continue
;
235 -- Test for type Address is private
237 elsif System_Text
(P
.. P
+ 26) = " type Address is private;" then
238 Opt
.Address_Is_Private
:= True;
240 goto Line_Loop_Continue
;
242 -- Test for pragma Profile (Ravenscar);
244 elsif System_Text
(P
.. P
+ 26) =
245 "pragma Profile (Ravenscar);"
247 Set_Profile_Restrictions
(Ravenscar
);
248 Opt
.Task_Dispatching_Policy
:= 'F';
249 Opt
.Locking_Policy
:= 'C';
251 goto Line_Loop_Continue
;
253 -- Test for pragma Profile (Restricted);
255 elsif System_Text
(P
.. P
+ 27) =
256 "pragma Profile (Restricted);"
258 Set_Profile_Restrictions
(Restricted
);
260 goto Line_Loop_Continue
;
262 -- Test for pragma Restrictions
264 elsif System_Text
(P
.. P
+ 20) = "pragma Restrictions (" then
267 Rloop
: for K
in All_Boolean_Restrictions
loop
269 Rname
: constant String := Restriction_Id
'Image (K
);
272 for J
in Rname
'Range loop
273 if Fold_Upper
(System_Text
(P
+ Source_Ptr
(J
- 1)))
280 if System_Text
(P
+ Rname
'Length) = ')' then
281 Restrictions_On_Target
.Set
(K
) := True;
282 goto Line_Loop_Continue
;
290 Ploop
: for K
in All_Parameter_Restrictions
loop
292 Rname
: constant String :=
293 All_Parameter_Restrictions
'Image (K
);
299 for J
in Rname
'Range loop
300 if Fold_Upper
(System_Text
(P
+ Source_Ptr
(J
- 1)))
307 if System_Text
(P
+ Rname
'Length .. P
+ Rname
'Length + 3) =
310 P
:= P
+ Rname
'Length + 4;
314 if System_Text
(P
) in '0' .. '9' then
316 pragma Unsuppress
(Overflow_Check
);
319 -- Accumulate next digit
322 Character'Pos (System_Text
(P
)) -
326 -- On overflow, we just ignore the pragma since
327 -- that is the standard handling in this case.
329 when Constraint_Error
=>
330 goto Line_Loop_Continue
;
333 elsif System_Text
(P
) = '_' then
336 elsif System_Text
(P
) = ')' then
337 Restrictions_On_Target
.Value
(K
) := V
;
338 Restrictions_On_Target
.Set
(K
) := True;
339 goto Line_Loop_Continue
;
359 ("fatal error: system.ads is incorrectly formatted");
360 Write_Str
("unrecognized or incorrect restrictions pragma: ");
362 while System_Text
(P
) /= ')'
364 System_Text
(P
) /= ASCII
.LF
366 Write_Char
(System_Text
(P
));
374 -- Test for pragma Detect_Blocking;
376 elsif System_Text
(P
.. P
+ 22) = "pragma Detect_Blocking;" then
378 Opt
.Detect_Blocking
:= True;
379 goto Line_Loop_Continue
;
383 elsif System_Text
(P
.. P
+ 20) = "pragma Discard_Names;" then
385 Opt
.Global_Discard_Names
:= True;
386 goto Line_Loop_Continue
;
390 elsif System_Text
(P
.. P
+ 22) = "pragma Locking_Policy (" then
392 Opt
.Locking_Policy
:= System_Text
(P
);
393 Opt
.Locking_Policy_Sloc
:= System_Location
;
394 goto Line_Loop_Continue
;
398 elsif System_Text
(P
.. P
+ 24) = "pragma Normalize_Scalars;" then
400 Opt
.Normalize_Scalars
:= True;
401 Opt
.Init_Or_Norm_Scalars
:= True;
402 goto Line_Loop_Continue
;
406 elsif System_Text
(P
.. P
+ 19) = "pragma Polling (On);" then
408 Opt
.Polling_Required
:= True;
409 goto Line_Loop_Continue
;
411 -- Ignore pragma Pure (System)
413 elsif System_Text
(P
.. P
+ 20) = "pragma Pure (System);" then
415 goto Line_Loop_Continue
;
419 elsif System_Text
(P
.. P
+ 22) = "pragma Queuing_Policy (" then
421 Opt
.Queuing_Policy
:= System_Text
(P
);
422 Opt
.Queuing_Policy_Sloc
:= System_Location
;
423 goto Line_Loop_Continue
;
425 -- Suppress_Exception_Locations
427 elsif System_Text
(P
.. P
+ 34) =
428 "pragma Suppress_Exception_Locations;"
431 Opt
.Exception_Locations_Suppressed
:= True;
432 goto Line_Loop_Continue
;
434 -- Task_Dispatching Policy
436 elsif System_Text
(P
.. P
+ 31) =
437 "pragma Task_Dispatching_Policy ("
440 Opt
.Task_Dispatching_Policy
:= System_Text
(P
);
441 Opt
.Task_Dispatching_Policy_Sloc
:= System_Location
;
442 goto Line_Loop_Continue
;
444 -- No other pragmas are permitted
446 elsif System_Text
(P
.. P
+ 6) = "pragma " then
448 Write_Line
("unrecognized line in system.ads: ");
450 while System_Text
(P
) /= ')'
451 and then System_Text
(P
) /= ASCII
.LF
453 Write_Char
(System_Text
(P
));
461 -- See if we have a Run_Time_Name
463 elsif System_Text
(P
.. P
+ 38) =
464 " Run_Time_Name : constant String := """
469 while System_Text
(P
) in 'A' .. 'Z'
471 System_Text
(P
) in 'a' .. 'z'
473 System_Text
(P
) in '0' .. '9'
475 System_Text
(P
) = ' '
477 System_Text
(P
) = '_'
479 Add_Char_To_Name_Buffer
(System_Text
(P
));
483 if System_Text
(P
) /= '"'
484 or else System_Text
(P
+ 1) /= ';'
485 or else (System_Text
(P
+ 2) /= ASCII
.LF
487 System_Text
(P
+ 2) /= ASCII
.CR
)
491 ("incorrectly formatted Run_Time_Name in system.ads");
496 Run_Time_Name_On_Target
:= Name_Enter
;
499 goto Line_Loop_Continue
;
501 -- Next See if we have a configuration parameter
504 Config_Param_Loop
: for K
in Targparm_Tags
loop
505 if System_Text
(P
+ 3 .. P
+ 2 + Targparm_Str
(K
)'Length) =
508 P
:= P
+ 3 + Targparm_Str
(K
)'Length;
510 if Targparm_Flags
(K
) then
513 ("fatal error: system.ads is incorrectly formatted");
514 Write_Str
("duplicate line for parameter: ");
516 for J
in Targparm_Str
(K
)'Range loop
517 Write_Char
(Targparm_Str
(K
).all (J
));
525 Targparm_Flags
(K
) := True;
528 while System_Text
(P
) /= ':'
529 or else System_Text
(P
+ 1) /= '='
536 while System_Text
(P
) = ' ' loop
540 Result
:= (System_Text
(P
) = 'T');
543 when AAM
=> AAMP_On_Target
:= Result
;
544 when BDC
=> Backend_Divide_Checks_On_Target
:= Result
;
545 when BOC
=> Backend_Overflow_Checks_On_Target
:= Result
;
546 when CLA
=> Command_Line_Args_On_Target
:= Result
;
547 when CRT
=> Configurable_Run_Time_On_Target
:= Result
;
548 when CSV
=> Compiler_System_Version
:= Result
;
549 when D32
=> Duration_32_Bits_On_Target
:= Result
;
550 when DEN
=> Denorm_On_Target
:= Result
;
551 when DSP
=> Functions_Return_By_DSP_On_Target
:= Result
;
552 when EXS
=> Exit_Status_Supported_On_Target
:= Result
;
553 when FEL
=> Frontend_Layout_On_Target
:= Result
;
554 when FFO
=> Fractional_Fixed_Ops_On_Target
:= Result
;
555 when MOV
=> Machine_Overflows_On_Target
:= Result
;
556 when MRN
=> Machine_Rounds_On_Target
:= Result
;
557 when PAS
=> Preallocated_Stacks_On_Target
:= Result
;
558 when S64
=> Support_64_Bit_Divides_On_Target
:= Result
;
559 when SAG
=> Support_Aggregates_On_Target
:= Result
;
560 when SCA
=> Support_Composite_Assign_On_Target
:= Result
;
561 when SCC
=> Support_Composite_Compare_On_Target
:= Result
;
562 when SCD
=> Stack_Check_Default_On_Target
:= Result
;
563 when SCP
=> Stack_Check_Probes_On_Target
:= Result
;
564 when SLS
=> Support_Long_Shifts_On_Target
:= Result
;
565 when SSL
=> Suppress_Standard_Library_On_Target
:= Result
;
566 when SNZ
=> Signed_Zeros_On_Target
:= Result
;
567 when UAM
=> Use_Ada_Main_Program_Name_On_Target
:= Result
;
568 when VMS
=> OpenVMS_On_Target
:= Result
;
569 when ZCD
=> ZCX_By_Default_On_Target
:= Result
;
570 when ZCG
=> GCC_ZCX_Support_On_Target
:= Result
;
572 goto Line_Loop_Continue
;
575 -- Here we are seeing a parameter we do not understand. We
576 -- simply ignore this (will happen when an old compiler is
577 -- used to compile a newer version of GNAT which does not
580 end loop Config_Param_Loop
;
583 -- Here after processing one line of System spec
585 <<Line_Loop_Continue
>>
587 while System_Text
(P
) /= CR
and then System_Text
(P
) /= LF
loop
589 exit when P
>= Source_Last
;
592 while System_Text
(P
) = CR
or else System_Text
(P
) = LF
loop
594 exit when P
>= Source_Last
;
597 if P
>= Source_Last
then
599 Write_Line
("fatal error, system.ads not formatted correctly");
600 Write_Line
("unexpected end of file");
602 raise Unrecoverable_Error
;
606 -- Check no missing target parameter settings (skip for compiler vsn)
608 if not Compiler_System_Version
then
609 for K
in Targparm_Tags_OK
loop
610 if not Targparm_Flags
(K
) then
613 ("fatal error: system.ads is incorrectly formatted");
614 Write_Str
("missing line for parameter: ");
616 for J
in Targparm_Str
(K
)'Range loop
617 Write_Char
(Targparm_Str
(K
).all (J
));
628 raise Unrecoverable_Error
;
630 end Get_Target_Parameters
;