1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
9 -- Copyright (C) 1999-2003 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_Time
48 D32
, -- Duration_32_Bits
50 DSP
, -- Functions_Return_By_DSP
51 EXS
, -- Exit_Status_Supported
52 FEL
, -- Frontend_Layout
53 FFO
, -- Fractional_Fixed_Ops
54 MOV
, -- Machine_Overflows
55 MRN
, -- Machine_Rounds
56 S64
, -- Support_64_Bit_Divides
57 SAG
, -- Support_Aggregates
58 SCA
, -- Support_Composite_Assign
59 SCC
, -- Support_Composite_Compare
60 SCD
, -- Stack_Check_Default
61 SCP
, -- Stack_Check_Probes
62 SLS
, -- Support_Long_Shifts
64 SSL
, -- Suppress_Standard_Library
65 UAM
, -- Use_Ada_Main_Program_Name
67 ZCD
, -- ZCX_By_Default
68 ZCG
, -- GCC_ZCX_Support
69 ZCF
, -- Front_End_ZCX_Support
71 -- The following entries are obsolete and can eventually be removed
73 HIM
, -- High_Integrity_Mode
74 LSI
); -- Long_Shifts_Inlined
76 subtype Targparm_Tags_OK
is Targparm_Tags
range AAM
.. ZCF
;
77 -- Range excluding obsolete entries
79 Targparm_Flags
: array (Targparm_Tags
) of Boolean := (others => False);
80 -- Flag is set True if corresponding parameter is scanned
82 -- The following list of string constants gives the parameter names
84 AAM_Str
: aliased constant Source_Buffer
:= "AAMP";
85 BDC_Str
: aliased constant Source_Buffer
:= "Backend_Divide_Checks";
86 BOC_Str
: aliased constant Source_Buffer
:= "Backend_Overflow_Checks";
87 CLA_Str
: aliased constant Source_Buffer
:= "Command_Line_Args";
88 CRT_Str
: aliased constant Source_Buffer
:= "Configurable_Run_Time";
89 D32_Str
: aliased constant Source_Buffer
:= "Duration_32_Bits";
90 DEN_Str
: aliased constant Source_Buffer
:= "Denorm";
91 DSP_Str
: aliased constant Source_Buffer
:= "Functions_Return_By_DSP";
92 EXS_Str
: aliased constant Source_Buffer
:= "Exit_Status_Supported";
93 FEL_Str
: aliased constant Source_Buffer
:= "Frontend_Layout";
94 FFO_Str
: aliased constant Source_Buffer
:= "Fractional_Fixed_Ops";
95 MOV_Str
: aliased constant Source_Buffer
:= "Machine_Overflows";
96 MRN_Str
: aliased constant Source_Buffer
:= "Machine_Rounds";
97 S64_Str
: aliased constant Source_Buffer
:= "Support_64_Bit_Divides";
98 SAG_Str
: aliased constant Source_Buffer
:= "Support_Aggregates";
99 SCA_Str
: aliased constant Source_Buffer
:= "Support_Composite_Assign";
100 SCC_Str
: aliased constant Source_Buffer
:= "Support_Composite_Compare";
101 SCD_Str
: aliased constant Source_Buffer
:= "Stack_Check_Default";
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";
109 ZCG_Str
: aliased constant Source_Buffer
:= "GCC_ZCX_Support";
110 ZCF_Str
: aliased constant Source_Buffer
:= "Front_End_ZCX_Support";
114 HIM_Str
: aliased constant Source_Buffer
:= "High_Integrity_Mode";
115 LSI_Str
: aliased constant Source_Buffer
:= "Long_Shifts_Inlined";
117 -- The following defines a set of pointers to the above strings,
118 -- indexed by the tag values.
120 type Buffer_Ptr
is access constant Source_Buffer
;
121 Targparm_Str
: constant array (Targparm_Tags
) of Buffer_Ptr
:=
155 ---------------------------
156 -- Get_Target_Parameters --
157 ---------------------------
159 -- Version which reads in system.ads
161 procedure Get_Target_Parameters
is
162 Text
: Source_Buffer_Ptr
;
166 if Parameters_Obtained
then
170 Name_Buffer
(1 .. 10) := "system.ads";
173 Read_Source_File
(Name_Find
, Lo
=> 0, Hi
=> Hi
, Src
=> Text
);
176 Write_Line
("fatal error, run-time library not installed correctly");
177 Write_Line
("cannot locate file system.ads");
178 raise Unrecoverable_Error
;
181 Targparm
.Get_Target_Parameters
182 (System_Text
=> Text
,
185 end Get_Target_Parameters
;
187 -- Version where caller supplies system.ads text
189 procedure Get_Target_Parameters
190 (System_Text
: Source_Buffer_Ptr
;
191 Source_First
: Source_Ptr
;
192 Source_Last
: Source_Ptr
)
197 Fatal
: Boolean := False;
198 -- Set True if a fatal error is detected
201 -- Records boolean from system line
204 if Parameters_Obtained
then
207 Parameters_Obtained
:= True;
211 Line_Loop
: while System_Text
(P
.. P
+ 10) /= "end System;" loop
213 -- Skip comments quickly
215 if System_Text
(P
) = '-' then
216 goto Line_Loop_Continue
;
218 -- Test for pragma Restrictions
220 elsif System_Text
(P
.. P
+ 20) = "pragma Restrictions (" then
223 Rloop
: for K
in Partition_Restrictions
loop
225 Rname
: constant String := Restriction_Id
'Image (K
);
228 for J
in Rname
'Range loop
229 if Fold_Upper
(System_Text
(P
+ Source_Ptr
(J
- 1)))
236 if System_Text
(P
+ Rname
'Length) = ')' then
237 Restrictions_On_Target
(K
) := True;
238 goto Line_Loop_Continue
;
246 Ploop
: for K
in Restriction_Parameter_Id
loop
248 Rname
: constant String :=
249 Restriction_Parameter_Id
'Image (K
);
252 for J
in Rname
'Range loop
253 if Fold_Upper
(System_Text
(P
+ Source_Ptr
(J
- 1)))
260 if System_Text
(P
+ Rname
'Length .. P
+ Rname
'Length + 3) =
263 P
:= P
+ Rname
'Length + 4;
267 if System_Text
(P
) in '0' .. '9' then
268 V
:= 10 * V
+ Character'Pos (System_Text
(P
)) - 48;
269 elsif System_Text
(P
) = '_' then
271 elsif System_Text
(P
) = ')' then
272 Restriction_Parameters_On_Target
(K
) := V
;
273 goto Line_Loop_Continue
;
289 ("fatal error: system.ads is incorrectly formatted");
290 Write_Str
("unrecognized restrictions pragma: ");
292 while System_Text
(P
) /= ')'
294 System_Text
(P
) /= ASCII
.LF
296 Write_Char
(System_Text
(P
));
306 elsif System_Text
(P
.. P
+ 20) = "pragma Discard_Names;" then
308 Opt
.Global_Discard_Names
:= True;
309 goto Line_Loop_Continue
;
313 elsif System_Text
(P
.. P
+ 22) = "pragma Locking_Policy (" then
315 Opt
.Locking_Policy
:= System_Text
(P
);
316 Opt
.Locking_Policy_Sloc
:= System_Location
;
317 goto Line_Loop_Continue
;
321 elsif System_Text
(P
.. P
+ 24) = "pragma Normalize_Scalars;" then
323 Opt
.Normalize_Scalars
:= True;
324 Opt
.Init_Or_Norm_Scalars
:= True;
325 goto Line_Loop_Continue
;
329 elsif System_Text
(P
.. P
+ 19) = "pragma Polling (On);" then
331 Opt
.Polling_Required
:= True;
332 goto Line_Loop_Continue
;
334 -- Ignore pragma Pure (System)
336 elsif System_Text
(P
.. P
+ 20) = "pragma Pure (System);" then
338 goto Line_Loop_Continue
;
342 elsif System_Text
(P
.. P
+ 22) = "pragma Queuing_Policy (" then
344 Opt
.Queuing_Policy
:= System_Text
(P
);
345 Opt
.Queuing_Policy_Sloc
:= System_Location
;
346 goto Line_Loop_Continue
;
348 -- Suppress_Exception_Locations
350 elsif System_Text
(P
.. P
+ 34) =
351 "pragma Suppress_Exception_Locations;"
354 Opt
.Exception_Locations_Suppressed
:= True;
355 goto Line_Loop_Continue
;
357 -- Task_Dispatching Policy
359 elsif System_Text
(P
.. P
+ 31) =
360 "pragma Task_Dispatching_Policy ("
363 Opt
.Task_Dispatching_Policy
:= System_Text
(P
);
364 Opt
.Task_Dispatching_Policy_Sloc
:= System_Location
;
365 goto Line_Loop_Continue
;
367 -- No other pragmas are permitted
369 elsif System_Text
(P
.. P
+ 6) = "pragma " then
371 Write_Line
("unrecognized line in system.ads: ");
373 while System_Text
(P
) /= ')'
374 and then System_Text
(P
) /= ASCII
.LF
376 Write_Char
(System_Text
(P
));
384 -- See if we have a Run_Time_Name
386 elsif System_Text
(P
.. P
+ 38) =
387 " Run_Time_Name : constant String := """
392 while System_Text
(P
) in 'A' .. 'Z'
394 System_Text
(P
) in 'a' .. 'z'
396 System_Text
(P
) in '0' .. '9'
398 System_Text
(P
) = ' '
400 System_Text
(P
) = '_'
402 Add_Char_To_Name_Buffer
(System_Text
(P
));
406 if System_Text
(P
) /= '"'
407 or else System_Text
(P
+ 1) /= ';'
408 or else (System_Text
(P
+ 2) /= ASCII
.LF
410 System_Text
(P
+ 2) /= ASCII
.CR
)
414 ("incorrectly formatted Run_Time_Name in system.ads");
419 Run_Time_Name_On_Target
:= Name_Enter
;
422 goto Line_Loop_Continue
;
424 -- Next See if we have a configuration parameter
427 Config_Param_Loop
: for K
in Targparm_Tags
loop
428 if System_Text
(P
+ 3 .. P
+ 2 + Targparm_Str
(K
)'Length) =
431 P
:= P
+ 3 + Targparm_Str
(K
)'Length;
434 if Targparm_Flags
(K
) then
437 ("fatal error: system.ads is incorrectly formatted");
438 Write_Str
("duplicate line for parameter: ");
440 for J
in Targparm_Str
(K
)'Range loop
441 Write_Char
(Targparm_Str
(K
).all (J
));
449 Targparm_Flags
(K
) := True;
452 while System_Text
(P
) /= ':'
453 or else System_Text
(P
+ 1) /= '='
460 while System_Text
(P
) = ' ' loop
464 Result
:= (System_Text
(P
) = 'T');
467 when AAM
=> AAMP_On_Target
:= Result
;
468 when BDC
=> Backend_Divide_Checks_On_Target
:= Result
;
469 when BOC
=> Backend_Overflow_Checks_On_Target
:= Result
;
470 when CLA
=> Command_Line_Args_On_Target
:= Result
;
471 when CRT
=> Configurable_Run_Time_On_Target
:= Result
;
472 when D32
=> Duration_32_Bits_On_Target
:= Result
;
473 when DEN
=> Denorm_On_Target
:= Result
;
474 when DSP
=> Functions_Return_By_DSP_On_Target
:= Result
;
475 when EXS
=> Exit_Status_Supported_On_Target
:= Result
;
476 when FEL
=> Frontend_Layout_On_Target
:= Result
;
477 when FFO
=> Fractional_Fixed_Ops_On_Target
:= Result
;
478 when MOV
=> Machine_Overflows_On_Target
:= Result
;
479 when MRN
=> Machine_Rounds_On_Target
:= Result
;
480 when S64
=> Support_64_Bit_Divides_On_Target
:= Result
;
481 when SAG
=> Support_Aggregates_On_Target
:= Result
;
482 when SCA
=> Support_Composite_Assign_On_Target
:= Result
;
483 when SCC
=> Support_Composite_Compare_On_Target
:= Result
;
484 when SCD
=> Stack_Check_Default_On_Target
:= Result
;
485 when SCP
=> Stack_Check_Probes_On_Target
:= Result
;
486 when SLS
=> Support_Long_Shifts_On_Target
:= Result
;
487 when SSL
=> Suppress_Standard_Library_On_Target
:= Result
;
488 when SNZ
=> Signed_Zeros_On_Target
:= Result
;
489 when UAM
=> Use_Ada_Main_Program_Name_On_Target
:= Result
;
490 when VMS
=> OpenVMS_On_Target
:= Result
;
491 when ZCD
=> ZCX_By_Default_On_Target
:= Result
;
492 when ZCG
=> GCC_ZCX_Support_On_Target
:= Result
;
493 when ZCF
=> Front_End_ZCX_Support_On_Target
:= Result
;
500 goto Line_Loop_Continue
;
503 end loop Config_Param_Loop
;
506 -- Here after processing one line of System spec
508 <<Line_Loop_Continue
>>
510 while System_Text
(P
) /= CR
and then System_Text
(P
) /= LF
loop
512 exit when P
>= Source_Last
;
515 while System_Text
(P
) = CR
or else System_Text
(P
) = LF
loop
517 exit when P
>= Source_Last
;
520 if P
>= Source_Last
then
522 Write_Line
("fatal error, system.ads not formatted correctly");
527 -- Check no missing target parameter settings
529 for K
in Targparm_Tags_OK
loop
530 if not Targparm_Flags
(K
) then
533 ("fatal error: system.ads is incorrectly formatted");
534 Write_Str
("missing line for parameter: ");
536 for J
in Targparm_Str
(K
)'Range loop
537 Write_Char
(Targparm_Str
(K
).all (J
));
547 raise Unrecoverable_Error
;
549 end Get_Target_Parameters
;