1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
9 -- Copyright (C) 1999-2012, 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 ASD
, -- Atomic_Sync_Default
44 BDC
, -- Backend_Divide_Checks
45 BOC
, -- Backend_Overflow_Checks
46 CLA
, -- Command_Line_Args
48 CRT
, -- Configurable_Run_Times
49 D32
, -- Duration_32_Bits
51 EXS
, -- Exit_Status_Supported
52 FEL
, -- Frontend_Layout
53 FFO
, -- Fractional_Fixed_Ops
55 MOV
, -- Machine_Overflows
56 MRN
, -- Machine_Rounds
57 PAS
, -- Preallocated_Stacks
58 RTX
, -- RTX_RTSS_Kernel_Module
59 SAG
, -- Support_Aggregates
60 SAP
, -- Support_Atomic_Primitives
61 SCA
, -- Support_Composite_Assign
62 SCC
, -- Support_Composite_Compare
63 SCD
, -- Stack_Check_Default
64 SCL
, -- Stack_Check_Limits
65 SCP
, -- Stack_Check_Probes
66 SLS
, -- Support_Long_Shifts
68 SSL
, -- Suppress_Standard_Library
69 UAM
, -- Use_Ada_Main_Program_Name
71 ZCD
); -- ZCX_By_Default
73 Targparm_Flags
: array (Targparm_Tags
) of Boolean := (others => False);
74 -- Flag is set True if corresponding parameter is scanned
76 -- The following list of string constants gives the parameter names
78 AAM_Str
: aliased constant Source_Buffer
:= "AAMP";
79 ACR_Str
: aliased constant Source_Buffer
:= "Always_Compatible_Rep";
80 ASD_Str
: aliased constant Source_Buffer
:= "Atomic_Sync_Default";
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 CLI_Str
: aliased constant Source_Buffer
:= "CLI";
85 CRT_Str
: aliased constant Source_Buffer
:= "Configurable_Run_Time";
86 D32_Str
: aliased constant Source_Buffer
:= "Duration_32_Bits";
87 DEN_Str
: aliased constant Source_Buffer
:= "Denorm";
88 EXS_Str
: aliased constant Source_Buffer
:= "Exit_Status_Supported";
89 FEL_Str
: aliased constant Source_Buffer
:= "Frontend_Layout";
90 FFO_Str
: aliased constant Source_Buffer
:= "Fractional_Fixed_Ops";
91 JVM_Str
: aliased constant Source_Buffer
:= "JVM";
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 RTX_Str
: aliased constant Source_Buffer
:= "RTX_RTSS_Kernel_Module";
96 SAG_Str
: aliased constant Source_Buffer
:= "Support_Aggregates";
97 SAP_Str
: aliased constant Source_Buffer
:= "Support_Atomic_Primitives";
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 SCL_Str
: aliased constant Source_Buffer
:= "Stack_Check_Limits";
102 SCP_Str
: aliased constant Source_Buffer
:= "Stack_Check_Probes";
103 SLS_Str
: aliased constant Source_Buffer
:= "Support_Long_Shifts";
104 SNZ_Str
: aliased constant Source_Buffer
:= "Signed_Zeros";
105 SSL_Str
: aliased constant Source_Buffer
:= "Suppress_Standard_Library";
106 UAM_Str
: aliased constant Source_Buffer
:= "Use_Ada_Main_Program_Name";
107 VMS_Str
: aliased constant Source_Buffer
:= "OpenVMS";
108 ZCD_Str
: aliased constant Source_Buffer
:= "ZCX_By_Default";
110 -- The following defines a set of pointers to the above strings,
111 -- indexed by the tag values.
113 type Buffer_Ptr
is access constant Source_Buffer
;
114 Targparm_Str
: constant array (Targparm_Tags
) of Buffer_Ptr
:=
147 -----------------------
148 -- Local Subprograms --
149 -----------------------
151 procedure Set_Profile_Restrictions
(P
: Profile_Name
);
152 -- Set Restrictions_On_Target for the given profile
154 ---------------------------
155 -- Get_Target_Parameters --
156 ---------------------------
158 -- Version which reads in system.ads
160 procedure Get_Target_Parameters
is
161 Text
: Source_Buffer_Ptr
;
165 if Parameters_Obtained
then
169 Name_Buffer
(1 .. 10) := "system.ads";
172 Read_Source_File
(Name_Find
, Lo
=> 0, Hi
=> Hi
, Src
=> Text
);
175 Write_Line
("fatal error, run-time library not installed correctly");
176 Write_Line
("cannot locate file system.ads");
177 raise Unrecoverable_Error
;
180 Get_Target_Parameters
181 (System_Text
=> Text
,
184 end Get_Target_Parameters
;
186 -- Version where caller supplies system.ads text
188 procedure Get_Target_Parameters
189 (System_Text
: Source_Buffer_Ptr
;
190 Source_First
: Source_Ptr
;
191 Source_Last
: Source_Ptr
)
194 -- Scans source buffer containing source of system.ads
196 Fatal
: Boolean := False;
197 -- Set True if a fatal error is detected
200 -- Records boolean from system line
203 if Parameters_Obtained
then
206 Parameters_Obtained
:= True;
209 Opt
.Address_Is_Private
:= False;
212 Line_Loop
: while System_Text
(P
.. P
+ 10) /= "end System;" loop
214 -- Skip comments quickly
216 if System_Text
(P
) = '-' then
217 goto Line_Loop_Continue
;
219 -- Test for type Address is private
221 elsif System_Text
(P
.. P
+ 26) = " type Address is private;" then
222 Opt
.Address_Is_Private
:= True;
224 goto Line_Loop_Continue
;
226 -- Test for pragma Profile (Ravenscar);
228 elsif System_Text
(P
.. P
+ 26) =
229 "pragma Profile (Ravenscar);"
231 Set_Profile_Restrictions
(Ravenscar
);
232 Opt
.Task_Dispatching_Policy
:= 'F';
233 Opt
.Locking_Policy
:= 'C';
235 goto Line_Loop_Continue
;
237 -- Test for pragma Profile (Restricted);
239 elsif System_Text
(P
.. P
+ 27) =
240 "pragma Profile (Restricted);"
242 Set_Profile_Restrictions
(Restricted
);
244 goto Line_Loop_Continue
;
246 -- Test for pragma Restrictions
248 elsif System_Text
(P
.. P
+ 20) = "pragma Restrictions (" then
251 Rloop
: for K
in All_Boolean_Restrictions
loop
253 Rname
: constant String := Restriction_Id
'Image (K
);
256 for J
in Rname
'Range loop
257 if Fold_Upper
(System_Text
(P
+ Source_Ptr
(J
- 1)))
264 if System_Text
(P
+ Rname
'Length) = ')' then
265 Restrictions_On_Target
.Set
(K
) := True;
266 goto Line_Loop_Continue
;
274 Ploop
: for K
in All_Parameter_Restrictions
loop
276 Rname
: constant String :=
277 All_Parameter_Restrictions
'Image (K
);
283 for J
in Rname
'Range loop
284 if Fold_Upper
(System_Text
(P
+ Source_Ptr
(J
- 1)))
291 if System_Text
(P
+ Rname
'Length .. P
+ Rname
'Length + 3) =
294 P
:= P
+ Rname
'Length + 4;
298 if System_Text
(P
) in '0' .. '9' then
300 pragma Unsuppress
(Overflow_Check
);
303 -- Accumulate next digit
306 Character'Pos (System_Text
(P
)) -
310 -- On overflow, we just ignore the pragma since
311 -- that is the standard handling in this case.
313 when Constraint_Error
=>
314 goto Line_Loop_Continue
;
317 elsif System_Text
(P
) = '_' then
320 elsif System_Text
(P
) = ')' then
321 Restrictions_On_Target
.Value
(K
) := V
;
322 Restrictions_On_Target
.Set
(K
) := True;
323 goto Line_Loop_Continue
;
343 ("fatal error: system.ads is incorrectly formatted");
344 Write_Str
("unrecognized or incorrect restrictions pragma: ");
346 while System_Text
(P
) /= ')'
348 System_Text
(P
) /= ASCII
.LF
350 Write_Char
(System_Text
(P
));
358 -- Test for pragma Detect_Blocking;
360 elsif System_Text
(P
.. P
+ 22) = "pragma Detect_Blocking;" then
362 Opt
.Detect_Blocking
:= True;
363 goto Line_Loop_Continue
;
367 elsif System_Text
(P
.. P
+ 20) = "pragma Discard_Names;" then
369 Opt
.Global_Discard_Names
:= True;
370 goto Line_Loop_Continue
;
374 elsif System_Text
(P
.. P
+ 22) = "pragma Locking_Policy (" then
376 Opt
.Locking_Policy
:= System_Text
(P
);
377 Opt
.Locking_Policy_Sloc
:= System_Location
;
378 goto Line_Loop_Continue
;
382 elsif System_Text
(P
.. P
+ 24) = "pragma Normalize_Scalars;" then
384 Opt
.Normalize_Scalars
:= True;
385 Opt
.Init_Or_Norm_Scalars
:= True;
386 goto Line_Loop_Continue
;
390 elsif System_Text
(P
.. P
+ 19) = "pragma Polling (On);" then
392 Opt
.Polling_Required
:= True;
393 goto Line_Loop_Continue
;
395 -- Ignore pragma Pure (System)
397 elsif System_Text
(P
.. P
+ 20) = "pragma Pure (System);" then
399 goto Line_Loop_Continue
;
403 elsif System_Text
(P
.. P
+ 22) = "pragma Queuing_Policy (" then
405 Opt
.Queuing_Policy
:= System_Text
(P
);
406 Opt
.Queuing_Policy_Sloc
:= System_Location
;
407 goto Line_Loop_Continue
;
409 -- Suppress_Exception_Locations
411 elsif System_Text
(P
.. P
+ 35) =
412 "pragma Suppress_Exception_Locations;"
415 Opt
.Exception_Locations_Suppressed
:= True;
416 goto Line_Loop_Continue
;
418 -- Task_Dispatching Policy
420 elsif System_Text
(P
.. P
+ 31) =
421 "pragma Task_Dispatching_Policy ("
424 Opt
.Task_Dispatching_Policy
:= System_Text
(P
);
425 Opt
.Task_Dispatching_Policy_Sloc
:= System_Location
;
426 goto Line_Loop_Continue
;
428 -- No other pragmas are permitted
430 elsif System_Text
(P
.. P
+ 6) = "pragma " then
432 Write_Line
("unrecognized line in system.ads: ");
434 while System_Text
(P
) /= ')'
435 and then System_Text
(P
) /= ASCII
.LF
437 Write_Char
(System_Text
(P
));
445 -- See if we have a Run_Time_Name
447 elsif System_Text
(P
.. P
+ 38) =
448 " Run_Time_Name : constant String := """
453 while System_Text
(P
) in 'A' .. 'Z'
455 System_Text
(P
) in 'a' .. 'z'
457 System_Text
(P
) in '0' .. '9'
459 System_Text
(P
) = ' '
461 System_Text
(P
) = '_'
463 Add_Char_To_Name_Buffer
(System_Text
(P
));
467 if System_Text
(P
) /= '"'
468 or else System_Text
(P
+ 1) /= ';'
469 or else (System_Text
(P
+ 2) /= ASCII
.LF
471 System_Text
(P
+ 2) /= ASCII
.CR
)
475 ("incorrectly formatted Run_Time_Name in system.ads");
480 Run_Time_Name_On_Target
:= Name_Enter
;
483 goto Line_Loop_Continue
;
485 -- See if we have an Executable_Extension
487 elsif System_Text
(P
.. P
+ 45) =
488 " Executable_Extension : constant String := """
493 while System_Text
(P
) /= '"'
494 and then System_Text
(P
) /= ASCII
.LF
496 Add_Char_To_Name_Buffer
(System_Text
(P
));
500 if System_Text
(P
) /= '"' or else System_Text
(P
+ 1) /= ';' then
503 ("incorrectly formatted Executable_Extension in system.ads");
508 Executable_Extension_On_Target
:= Name_Enter
;
511 goto Line_Loop_Continue
;
513 -- Next see if we have a configuration parameter
516 Config_Param_Loop
: for K
in Targparm_Tags
loop
517 if System_Text
(P
+ 3 .. P
+ 2 + Targparm_Str
(K
)'Length) =
520 P
:= P
+ 3 + Targparm_Str
(K
)'Length;
522 if Targparm_Flags
(K
) then
525 ("fatal error: system.ads is incorrectly formatted");
526 Write_Str
("duplicate line for parameter: ");
528 for J
in Targparm_Str
(K
)'Range loop
529 Write_Char
(Targparm_Str
(K
).all (J
));
537 Targparm_Flags
(K
) := True;
540 while System_Text
(P
) /= ':'
541 or else System_Text
(P
+ 1) /= '='
548 while System_Text
(P
) = ' ' loop
552 Result
:= (System_Text
(P
) = 'T');
555 when AAM
=> AAMP_On_Target
:= Result
;
556 when ACR
=> Always_Compatible_Rep_On_Target
:= Result
;
557 when ASD
=> Atomic_Sync_Default_On_Target
:= Result
;
558 when BDC
=> Backend_Divide_Checks_On_Target
:= Result
;
559 when BOC
=> Backend_Overflow_Checks_On_Target
:= Result
;
560 when CLA
=> Command_Line_Args_On_Target
:= Result
;
563 VM_Target
:= CLI_Target
;
564 Tagged_Type_Expansion
:= False;
566 -- This is wrong, this processing should be done in
567 -- Gnat1drv.Adjust_Global_Switches. It is not the
568 -- right level for targparm to know about tagged
571 when CRT
=> Configurable_Run_Time_On_Target
:= Result
;
572 when D32
=> Duration_32_Bits_On_Target
:= Result
;
573 when DEN
=> Denorm_On_Target
:= Result
;
574 when EXS
=> Exit_Status_Supported_On_Target
:= Result
;
575 when FEL
=> Frontend_Layout_On_Target
:= Result
;
576 when FFO
=> Fractional_Fixed_Ops_On_Target
:= Result
;
579 VM_Target
:= JVM_Target
;
580 Tagged_Type_Expansion
:= False;
582 -- This is wrong, this processing should be done in
583 -- Gnat1drv.Adjust_Global_Switches. It is not the
584 -- right level for targparm to know about tagged
587 when MOV
=> Machine_Overflows_On_Target
:= Result
;
588 when MRN
=> Machine_Rounds_On_Target
:= Result
;
589 when PAS
=> Preallocated_Stacks_On_Target
:= Result
;
590 when RTX
=> RTX_RTSS_Kernel_Module_On_Target
:= Result
;
591 when SAG
=> Support_Aggregates_On_Target
:= Result
;
592 when SAP
=> Support_Atomic_Primitives_On_Target
:= Result
;
593 when SCA
=> Support_Composite_Assign_On_Target
:= Result
;
594 when SCC
=> Support_Composite_Compare_On_Target
:= Result
;
595 when SCD
=> Stack_Check_Default_On_Target
:= Result
;
596 when SCL
=> Stack_Check_Limits_On_Target
:= Result
;
597 when SCP
=> Stack_Check_Probes_On_Target
:= Result
;
598 when SLS
=> Support_Long_Shifts_On_Target
:= Result
;
599 when SSL
=> Suppress_Standard_Library_On_Target
:= Result
;
600 when SNZ
=> Signed_Zeros_On_Target
:= Result
;
601 when UAM
=> Use_Ada_Main_Program_Name_On_Target
:= Result
;
602 when VMS
=> OpenVMS_On_Target
:= Result
;
603 when ZCD
=> ZCX_By_Default_On_Target
:= Result
;
605 goto Line_Loop_Continue
;
608 -- Here we are seeing a parameter we do not understand. We
609 -- simply ignore this (will happen when an old compiler is
610 -- used to compile a newer version of GNAT which does not
611 -- support the parameter).
613 end loop Config_Param_Loop
;
616 -- Here after processing one line of System spec
618 <<Line_Loop_Continue
>>
620 while System_Text
(P
) /= CR
and then System_Text
(P
) /= LF
loop
622 exit when P
>= Source_Last
;
625 while System_Text
(P
) = CR
or else System_Text
(P
) = LF
loop
627 exit when P
>= Source_Last
;
630 if P
>= Source_Last
then
632 Write_Line
("fatal error, system.ads not formatted correctly");
633 Write_Line
("unexpected end of file");
635 raise Unrecoverable_Error
;
639 -- Now that OpenVMS_On_Target has been given its definitive value,
640 -- change the multi-unit index character from '~' to '$' for OpenVMS.
642 if OpenVMS_On_Target
then
643 Multi_Unit_Index_Character
:= '$';
647 raise Unrecoverable_Error
;
649 end Get_Target_Parameters
;
651 ------------------------------
652 -- Set_Profile_Restrictions --
653 ------------------------------
655 procedure Set_Profile_Restrictions
(P
: Profile_Name
) is
656 R
: Restriction_Flags
renames Profile_Info
(P
).Set
;
657 V
: Restriction_Values
renames Profile_Info
(P
).Value
;
659 for J
in R
'Range loop
661 Restrictions_On_Target
.Set
(J
) := True;
663 if J
in All_Parameter_Restrictions
then
664 Restrictions_On_Target
.Value
(J
) := V
(J
);
668 end Set_Profile_Restrictions
;