OSDN Git Service

2009-08-28 Sebastian Pop <sebastian.pop@amd.com>
[pf3gnuchains/gcc-fork.git] / gcc / ada / targparm.adb
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-2009, 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 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.          --
20 --                                                                          --
21 -- GNAT was originally developed  by the GNAT team at  New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
23 --                                                                          --
24 ------------------------------------------------------------------------------
25
26 with Csets;    use Csets;
27 with Opt;      use Opt;
28 with Osint;    use Osint;
29 with Output;   use Output;
30
31 package body Targparm is
32    use ASCII;
33
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.
37
38    --  The following array defines a tag name for each entry
39
40    type Targparm_Tags is
41      (AAM,  --   AAMP
42       ACR,  --   Always_Compatible_Rep
43       BDC,  --   Backend_Divide_Checks
44       BOC,  --   Backend_Overflow_Checks
45       CLA,  --   Command_Line_Args
46       CLI,  --   CLI (.NET)
47       CRT,  --   Configurable_Run_Times
48       D32,  --   Duration_32_Bits
49       DEN,  --   Denorm
50       EXS,  --   Exit_Status_Supported
51       FEL,  --   Frontend_Layout
52       FFO,  --   Fractional_Fixed_Ops
53       JVM,  --   JVM
54       MOV,  --   Machine_Overflows
55       MRN,  --   Machine_Rounds
56       PAS,  --   Preallocated_Stacks
57       RTX,  --   RTX_RTSS_Kernel_Module
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       SCL,  --   Stack_Check_Limits
64       SCP,  --   Stack_Check_Probes
65       SLS,  --   Support_Long_Shifts
66       SNZ,  --   Signed_Zeros
67       SSL,  --   Suppress_Standard_Library
68       UAM,  --   Use_Ada_Main_Program_Name
69       VMS,  --   OpenVMS
70       ZCD,  --   ZCX_By_Default
71       ZCG); --   GCC_ZCX_Support
72
73    Targparm_Flags : array (Targparm_Tags) of Boolean := (others => False);
74    --  Flag is set True if corresponding parameter is scanned
75
76    --  The following list of string constants gives the parameter names
77
78    AAM_Str : aliased constant Source_Buffer := "AAMP";
79    ACR_Str : aliased constant Source_Buffer := "Always_Compatible_Rep";
80    BDC_Str : aliased constant Source_Buffer := "Backend_Divide_Checks";
81    BOC_Str : aliased constant Source_Buffer := "Backend_Overflow_Checks";
82    CLA_Str : aliased constant Source_Buffer := "Command_Line_Args";
83    CLI_Str : aliased constant Source_Buffer := "CLI";
84    CRT_Str : aliased constant Source_Buffer := "Configurable_Run_Time";
85    D32_Str : aliased constant Source_Buffer := "Duration_32_Bits";
86    DEN_Str : aliased constant Source_Buffer := "Denorm";
87    EXS_Str : aliased constant Source_Buffer := "Exit_Status_Supported";
88    FEL_Str : aliased constant Source_Buffer := "Frontend_Layout";
89    FFO_Str : aliased constant Source_Buffer := "Fractional_Fixed_Ops";
90    JVM_Str : aliased constant Source_Buffer := "JVM";
91    MOV_Str : aliased constant Source_Buffer := "Machine_Overflows";
92    MRN_Str : aliased constant Source_Buffer := "Machine_Rounds";
93    PAS_Str : aliased constant Source_Buffer := "Preallocated_Stacks";
94    RTX_Str : aliased constant Source_Buffer := "RTX_RTSS_Kernel_Module";
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    SCL_Str : aliased constant Source_Buffer := "Stack_Check_Limits";
101    SCP_Str : aliased constant Source_Buffer := "Stack_Check_Probes";
102    SLS_Str : aliased constant Source_Buffer := "Support_Long_Shifts";
103    SNZ_Str : aliased constant Source_Buffer := "Signed_Zeros";
104    SSL_Str : aliased constant Source_Buffer := "Suppress_Standard_Library";
105    UAM_Str : aliased constant Source_Buffer := "Use_Ada_Main_Program_Name";
106    VMS_Str : aliased constant Source_Buffer := "OpenVMS";
107    ZCD_Str : aliased constant Source_Buffer := "ZCX_By_Default";
108    ZCG_Str : aliased constant Source_Buffer := "GCC_ZCX_Support";
109
110    --  The following defines a set of pointers to the above strings,
111    --  indexed by the tag values.
112
113    type Buffer_Ptr is access constant Source_Buffer;
114    Targparm_Str : constant array (Targparm_Tags) of Buffer_Ptr :=
115      (AAM_Str'Access,
116       ACR_Str'Access,
117       BDC_Str'Access,
118       BOC_Str'Access,
119       CLA_Str'Access,
120       CLI_Str'Access,
121       CRT_Str'Access,
122       D32_Str'Access,
123       DEN_Str'Access,
124       EXS_Str'Access,
125       FEL_Str'Access,
126       FFO_Str'Access,
127       JVM_Str'Access,
128       MOV_Str'Access,
129       MRN_Str'Access,
130       PAS_Str'Access,
131       RTX_Str'Access,
132       S64_Str'Access,
133       SAG_Str'Access,
134       SCA_Str'Access,
135       SCC_Str'Access,
136       SCD_Str'Access,
137       SCL_Str'Access,
138       SCP_Str'Access,
139       SLS_Str'Access,
140       SNZ_Str'Access,
141       SSL_Str'Access,
142       UAM_Str'Access,
143       VMS_Str'Access,
144       ZCD_Str'Access,
145       ZCG_Str'Access);
146
147    -----------------------
148    -- Local Subprograms --
149    -----------------------
150
151    procedure Set_Profile_Restrictions (P : Profile_Name);
152    --  Set Restrictions_On_Target for the given profile
153
154    ---------------------------
155    -- Get_Target_Parameters --
156    ---------------------------
157
158    --  Version which reads in system.ads
159
160    procedure Get_Target_Parameters is
161       Text : Source_Buffer_Ptr;
162       Hi   : Source_Ptr;
163
164    begin
165       if Parameters_Obtained then
166          return;
167       end if;
168
169       Name_Buffer (1 .. 10) := "system.ads";
170       Name_Len := 10;
171
172       Read_Source_File (Name_Find, Lo => 0, Hi => Hi, Src => Text);
173
174       if Text = null then
175          Write_Line ("fatal error, run-time library not installed correctly");
176          Write_Line ("cannot locate file system.ads");
177          raise Unrecoverable_Error;
178       end if;
179
180       Get_Target_Parameters
181         (System_Text  => Text,
182          Source_First => 0,
183          Source_Last  => Hi);
184    end Get_Target_Parameters;
185
186    --  Version where caller supplies system.ads text
187
188    procedure Get_Target_Parameters
189      (System_Text  : Source_Buffer_Ptr;
190       Source_First : Source_Ptr;
191       Source_Last  : Source_Ptr)
192    is
193       P : Source_Ptr;
194       --  Scans source buffer containing source of system.ads
195
196       Fatal : Boolean := False;
197       --  Set True if a fatal error is detected
198
199       Result : Boolean;
200       --  Records boolean from system line
201
202    begin
203       if Parameters_Obtained then
204          return;
205       else
206          Parameters_Obtained := True;
207       end if;
208
209       Opt.Address_Is_Private := False;
210
211       P := Source_First;
212       Line_Loop : while System_Text (P .. P + 10) /= "end System;" loop
213
214          --  Skip comments quickly
215
216          if System_Text (P) = '-' then
217             goto Line_Loop_Continue;
218
219          --  Test for type Address is private
220
221          elsif System_Text (P .. P + 26) = "   type Address is private;" then
222             Opt.Address_Is_Private := True;
223             P := P + 26;
224             goto Line_Loop_Continue;
225
226          --  Test for pragma Profile (Ravenscar);
227
228          elsif System_Text (P .. P + 26) =
229                  "pragma Profile (Ravenscar);"
230          then
231             Set_Profile_Restrictions (Ravenscar);
232             Opt.Task_Dispatching_Policy := 'F';
233             Opt.Locking_Policy          := 'C';
234             P := P + 27;
235             goto Line_Loop_Continue;
236
237          --  Test for pragma Profile (Restricted);
238
239          elsif System_Text (P .. P + 27) =
240                  "pragma Profile (Restricted);"
241          then
242             Set_Profile_Restrictions (Restricted);
243             P := P + 28;
244             goto Line_Loop_Continue;
245
246          --  Test for pragma Restrictions
247
248          elsif System_Text (P .. P + 20) = "pragma Restrictions (" then
249             P := P + 21;
250
251             Rloop : for K in All_Boolean_Restrictions loop
252                declare
253                   Rname : constant String := Restriction_Id'Image (K);
254
255                begin
256                   for J in Rname'Range loop
257                      if Fold_Upper (System_Text (P + Source_Ptr (J - 1)))
258                                                         /= Rname (J)
259                      then
260                         goto Rloop_Continue;
261                      end if;
262                   end loop;
263
264                   if System_Text (P + Rname'Length) = ')' then
265                      Restrictions_On_Target.Set (K) := True;
266                      goto Line_Loop_Continue;
267                   end if;
268                end;
269
270             <<Rloop_Continue>>
271                null;
272             end loop Rloop;
273
274             Ploop : for K in All_Parameter_Restrictions loop
275                declare
276                   Rname : constant String :=
277                             All_Parameter_Restrictions'Image (K);
278
279                   V : Natural;
280                   --  Accumulates value
281
282                begin
283                   for J in Rname'Range loop
284                      if Fold_Upper (System_Text (P + Source_Ptr (J - 1)))
285                                                         /= Rname (J)
286                      then
287                         goto Ploop_Continue;
288                      end if;
289                   end loop;
290
291                   if System_Text (P + Rname'Length .. P + Rname'Length + 3) =
292                                                       " => "
293                   then
294                      P := P + Rname'Length + 4;
295
296                      V := 0;
297                      loop
298                         if System_Text (P) in '0' .. '9' then
299                            declare
300                               pragma Unsuppress (Overflow_Check);
301
302                            begin
303                               --  Accumulate next digit
304
305                               V := 10 * V +
306                                    Character'Pos (System_Text (P)) -
307                                    Character'Pos ('0');
308
309                            exception
310                               --  On overflow, we just ignore the pragma since
311                               --  that is the standard handling in this case.
312
313                               when Constraint_Error =>
314                                  goto Line_Loop_Continue;
315                            end;
316
317                         elsif System_Text (P) = '_' then
318                            null;
319
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;
324
325                         else
326                            exit Ploop;
327                         end if;
328
329                         P := P + 1;
330                      end loop;
331
332                   else
333                      exit Ploop;
334                   end if;
335                end;
336
337             <<Ploop_Continue>>
338                null;
339             end loop Ploop;
340
341             Set_Standard_Error;
342             Write_Line
343                ("fatal error: system.ads is incorrectly formatted");
344             Write_Str ("unrecognized or incorrect restrictions pragma: ");
345
346             while System_Text (P) /= ')'
347                     and then
348                   System_Text (P) /= ASCII.LF
349             loop
350                Write_Char (System_Text (P));
351                P := P + 1;
352             end loop;
353
354             Write_Eol;
355             Fatal := True;
356             Set_Standard_Output;
357
358          --  Test for pragma Detect_Blocking;
359
360          elsif System_Text (P .. P + 22) = "pragma Detect_Blocking;" then
361             P := P + 23;
362             Opt.Detect_Blocking := True;
363             goto Line_Loop_Continue;
364
365          --  Discard_Names
366
367          elsif System_Text (P .. P + 20) = "pragma Discard_Names;" then
368             P := P + 21;
369             Opt.Global_Discard_Names := True;
370             goto Line_Loop_Continue;
371
372          --  Locking Policy
373
374          elsif System_Text (P .. P + 22) = "pragma Locking_Policy (" then
375             P := P + 23;
376             Opt.Locking_Policy := System_Text (P);
377             Opt.Locking_Policy_Sloc := System_Location;
378             goto Line_Loop_Continue;
379
380          --  Normalize_Scalars
381
382          elsif System_Text (P .. P + 24) = "pragma Normalize_Scalars;" then
383             P := P + 25;
384             Opt.Normalize_Scalars := True;
385             Opt.Init_Or_Norm_Scalars := True;
386             goto Line_Loop_Continue;
387
388          --  Polling (On)
389
390          elsif System_Text (P .. P + 19) = "pragma Polling (On);" then
391             P := P + 20;
392             Opt.Polling_Required := True;
393             goto Line_Loop_Continue;
394
395          --  Ignore pragma Pure (System)
396
397          elsif System_Text (P .. P + 20) = "pragma Pure (System);" then
398             P := P + 21;
399             goto Line_Loop_Continue;
400
401          --  Queuing Policy
402
403          elsif System_Text (P .. P + 22) = "pragma Queuing_Policy (" then
404             P := P + 23;
405             Opt.Queuing_Policy := System_Text (P);
406             Opt.Queuing_Policy_Sloc := System_Location;
407             goto Line_Loop_Continue;
408
409          --  Suppress_Exception_Locations
410
411          elsif System_Text (P .. P + 35) =
412                                    "pragma Suppress_Exception_Locations;"
413          then
414             P := P + 36;
415             Opt.Exception_Locations_Suppressed := True;
416             goto Line_Loop_Continue;
417
418          --  Task_Dispatching Policy
419
420          elsif System_Text (P .. P + 31) =
421                                    "pragma Task_Dispatching_Policy ("
422          then
423             P := P + 32;
424             Opt.Task_Dispatching_Policy := System_Text (P);
425             Opt.Task_Dispatching_Policy_Sloc := System_Location;
426             goto Line_Loop_Continue;
427
428          --  No other pragmas are permitted
429
430          elsif System_Text (P .. P + 6) = "pragma " then
431             Set_Standard_Error;
432             Write_Line ("unrecognized line in system.ads: ");
433
434             while System_Text (P) /= ')'
435               and then System_Text (P) /= ASCII.LF
436             loop
437                Write_Char (System_Text (P));
438                P := P + 1;
439             end loop;
440
441             Write_Eol;
442             Set_Standard_Output;
443             Fatal := True;
444
445          --  See if we have a Run_Time_Name
446
447          elsif System_Text (P .. P + 38) =
448                   "   Run_Time_Name : constant String := """
449          then
450             P := P + 39;
451
452             Name_Len := 0;
453             while System_Text (P) in 'A' .. 'Z'
454                     or else
455                   System_Text (P) in 'a' .. 'z'
456                     or else
457                   System_Text (P) in '0' .. '9'
458                     or else
459                   System_Text (P) = ' '
460                     or else
461                   System_Text (P) = '_'
462             loop
463                Add_Char_To_Name_Buffer (System_Text (P));
464                P := P + 1;
465             end loop;
466
467             if System_Text (P) /= '"'
468               or else System_Text (P + 1) /= ';'
469               or else (System_Text (P + 2) /= ASCII.LF
470                          and then
471                        System_Text (P + 2) /= ASCII.CR)
472             then
473                Set_Standard_Error;
474                Write_Line
475                  ("incorrectly formatted Run_Time_Name in system.ads");
476                Set_Standard_Output;
477                Fatal := True;
478
479             else
480                Run_Time_Name_On_Target := Name_Enter;
481             end if;
482
483             goto Line_Loop_Continue;
484
485          --  See if we have an Executable_Extension
486
487          elsif System_Text (P .. P + 45) =
488                   "   Executable_Extension : constant String := """
489          then
490             P := P + 46;
491
492             Name_Len := 0;
493             while System_Text (P) /= '"'
494               and then System_Text (P) /= ASCII.LF
495             loop
496                Add_Char_To_Name_Buffer (System_Text (P));
497                P := P + 1;
498             end loop;
499
500             if System_Text (P) /= '"' or else System_Text (P + 1) /= ';' then
501                Set_Standard_Error;
502                Write_Line
503                  ("incorrectly formatted Executable_Extension in system.ads");
504                Set_Standard_Output;
505                Fatal := True;
506
507             else
508                Executable_Extension_On_Target := Name_Enter;
509             end if;
510
511             goto Line_Loop_Continue;
512
513          --  Next see if we have a configuration parameter
514
515          else
516             Config_Param_Loop : for K in Targparm_Tags loop
517                if System_Text (P + 3 .. P + 2 + Targparm_Str (K)'Length) =
518                                                       Targparm_Str (K).all
519                then
520                   P := P + 3 + Targparm_Str (K)'Length;
521
522                   if Targparm_Flags (K) then
523                      Set_Standard_Error;
524                      Write_Line
525                        ("fatal error: system.ads is incorrectly formatted");
526                      Write_Str ("duplicate line for parameter: ");
527
528                      for J in Targparm_Str (K)'Range loop
529                         Write_Char (Targparm_Str (K).all (J));
530                      end loop;
531
532                      Write_Eol;
533                      Set_Standard_Output;
534                      Fatal := True;
535
536                   else
537                      Targparm_Flags (K) := True;
538                   end if;
539
540                   while System_Text (P) /= ':'
541                      or else System_Text (P + 1) /= '='
542                   loop
543                      P := P + 1;
544                   end loop;
545
546                   P := P + 2;
547
548                   while System_Text (P) = ' ' loop
549                      P := P + 1;
550                   end loop;
551
552                   Result := (System_Text (P) = 'T');
553
554                   case K is
555                      when AAM => AAMP_On_Target                      := Result;
556                      when ACR => Always_Compatible_Rep_On_Target     := Result;
557                      when BDC => Backend_Divide_Checks_On_Target     := Result;
558                      when BOC => Backend_Overflow_Checks_On_Target   := Result;
559                      when CLA => Command_Line_Args_On_Target         := Result;
560                      when CLI =>
561                         if Result then
562                            VM_Target := CLI_Target;
563                            Tagged_Type_Expansion := False;
564                         end if;
565
566                      when CRT => Configurable_Run_Time_On_Target     := Result;
567                      when D32 => Duration_32_Bits_On_Target          := Result;
568                      when DEN => Denorm_On_Target                    := Result;
569                      when EXS => Exit_Status_Supported_On_Target     := Result;
570                      when FEL => Frontend_Layout_On_Target           := Result;
571                      when FFO => Fractional_Fixed_Ops_On_Target      := Result;
572                      when JVM =>
573                         if Result then
574                            VM_Target := JVM_Target;
575                            Tagged_Type_Expansion := False;
576                         end if;
577
578                      when MOV => Machine_Overflows_On_Target         := Result;
579                      when MRN => Machine_Rounds_On_Target            := Result;
580                      when PAS => Preallocated_Stacks_On_Target       := Result;
581                      when RTX => RTX_RTSS_Kernel_Module_On_Target    := Result;
582                      when S64 => Support_64_Bit_Divides_On_Target    := Result;
583                      when SAG => Support_Aggregates_On_Target        := Result;
584                      when SCA => Support_Composite_Assign_On_Target  := Result;
585                      when SCC => Support_Composite_Compare_On_Target := Result;
586                      when SCD => Stack_Check_Default_On_Target       := Result;
587                      when SCL => Stack_Check_Limits_On_Target        := Result;
588                      when SCP => Stack_Check_Probes_On_Target        := Result;
589                      when SLS => Support_Long_Shifts_On_Target       := Result;
590                      when SSL => Suppress_Standard_Library_On_Target := Result;
591                      when SNZ => Signed_Zeros_On_Target              := Result;
592                      when UAM => Use_Ada_Main_Program_Name_On_Target := Result;
593                      when VMS => OpenVMS_On_Target                   := Result;
594                      when ZCD => ZCX_By_Default_On_Target            := Result;
595                      when ZCG => GCC_ZCX_Support_On_Target           := Result;
596
597                      goto Line_Loop_Continue;
598                   end case;
599
600                   --  Here we are seeing a parameter we do not understand. We
601                   --  simply ignore this (will happen when an old compiler is
602                   --  used to compile a newer version of GNAT which does not
603                   --  support the parameter).
604                end if;
605             end loop Config_Param_Loop;
606          end if;
607
608          --  Here after processing one line of System spec
609
610          <<Line_Loop_Continue>>
611
612          while System_Text (P) /= CR and then System_Text (P) /= LF loop
613             P := P + 1;
614             exit when P >= Source_Last;
615          end loop;
616
617          while System_Text (P) = CR or else System_Text (P) = LF loop
618             P := P + 1;
619             exit when P >= Source_Last;
620          end loop;
621
622          if P >= Source_Last then
623             Set_Standard_Error;
624             Write_Line ("fatal error, system.ads not formatted correctly");
625             Write_Line ("unexpected end of file");
626             Set_Standard_Output;
627             raise Unrecoverable_Error;
628          end if;
629       end loop Line_Loop;
630
631       --  Now that OpenVMS_On_Target has been given its definitive value,
632       --  change the multi-unit index character from '~' to '$' for OpenVMS.
633
634       if OpenVMS_On_Target then
635          Multi_Unit_Index_Character := '$';
636       end if;
637
638       if Fatal then
639          raise Unrecoverable_Error;
640       end if;
641    end Get_Target_Parameters;
642
643    ------------------------------
644    -- Set_Profile_Restrictions --
645    ------------------------------
646
647    procedure Set_Profile_Restrictions (P : Profile_Name) is
648       R : Restriction_Flags  renames Profile_Info (P).Set;
649       V : Restriction_Values renames Profile_Info (P).Value;
650    begin
651       for J in R'Range loop
652          if R (J) then
653             Restrictions_On_Target.Set (J) := True;
654
655             if J in All_Parameter_Restrictions then
656                Restrictions_On_Target.Value (J) := V (J);
657             end if;
658          end if;
659       end loop;
660    end Set_Profile_Restrictions;
661
662 end Targparm;