OpenCores
URL https://opencores.org/ocsvn/openrisc_me/openrisc_me/trunk

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [gnat1drv.adb] - Blame information for rev 310

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 281 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT COMPILER COMPONENTS                         --
4
--                                                                          --
5
--                             G N A T 1 D R V                              --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 1992-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 Atree;    use Atree;
27
with Back_End; use Back_End;
28
with Comperr;
29
with Csets;    use Csets;
30
with Debug;    use Debug;
31
with Elists;
32
with Errout;   use Errout;
33
with Fmap;
34
with Fname;    use Fname;
35
with Fname.UF; use Fname.UF;
36
with Frontend;
37
with Gnatvsn;  use Gnatvsn;
38
with Hostparm;
39
with Inline;
40
with Lib;      use Lib;
41
with Lib.Writ; use Lib.Writ;
42
with Lib.Xref;
43
with Namet;    use Namet;
44
with Nlists;
45
with Opt;      use Opt;
46
with Osint;    use Osint;
47
with Output;   use Output;
48
with Par_SCO;
49
with Prepcomp;
50
with Repinfo;  use Repinfo;
51
with Restrict;
52
with Rtsfind;
53
with SCOs;
54
with Sem;
55
with Sem_Ch8;
56
with Sem_Ch12;
57
with Sem_Ch13;
58
with Sem_Elim;
59
with Sem_Eval;
60
with Sem_Type;
61
with Sinfo;    use Sinfo;
62
with Sinput.L; use Sinput.L;
63
with Snames;
64
with Sprint;   use Sprint;
65
with Stringt;
66
with Stylesw;  use Stylesw;
67
with Targparm; use Targparm;
68
with Tree_Gen;
69
with Treepr;   use Treepr;
70
with Ttypes;
71
with Types;    use Types;
72
with Uintp;    use Uintp;
73
with Uname;    use Uname;
74
with Urealp;
75
with Usage;
76
with Validsw;  use Validsw;
77
 
78
with System.Assertions;
79
 
80
procedure Gnat1drv is
81
   Main_Unit_Node : Node_Id;
82
   --  Compilation unit node for main unit
83
 
84
   Main_Kind : Node_Kind;
85
   --  Kind of main compilation unit node
86
 
87
   Back_End_Mode : Back_End.Back_End_Mode_Type;
88
   --  Record back end mode
89
 
90
   procedure Adjust_Global_Switches;
91
   --  There are various interactions between front end switch settings,
92
   --  including debug switch settings and target dependent parameters.
93
   --  This procedure takes care of properly handling these interactions.
94
   --  We do it after scanning out all the switches, so that we are not
95
   --  depending on the order in which switches appear.
96
 
97
   procedure Check_Bad_Body;
98
   --  Called to check if the unit we are compiling has a bad body
99
 
100
   procedure Check_Rep_Info;
101
   --  Called when we are not generating code, to check if -gnatR was requested
102
   --  and if so, explain that we will not be honoring the request.
103
 
104
   procedure Check_Library_Items;
105
   --  For debugging -- checks the behavior of Walk_Library_Items
106
   pragma Warnings (Off, Check_Library_Items);
107
   --  In case the call below is commented out
108
 
109
   ----------------------------
110
   -- Adjust_Global_Switches --
111
   ----------------------------
112
 
113
   procedure Adjust_Global_Switches is
114
   begin
115
      --  Debug flag -gnatd.I is a synonym for Generate_SCIL and requires code
116
      --  generation.
117
 
118
      if Debug_Flag_Dot_II
119
        and then Operating_Mode = Generate_Code
120
      then
121
         Generate_SCIL := True;
122
      end if;
123
 
124
      --  Set ASIS mode if -gnatt and -gnatc are set
125
 
126
      if Operating_Mode = Check_Semantics and then Tree_Output then
127
         ASIS_Mode := True;
128
 
129
         --  Turn off inlining in ASIS mode, since ASIS cannot handle the extra
130
         --  information in the trees caused by inlining being active.
131
 
132
         --  More specifically, the tree seems to be malformed from the ASIS
133
         --  point of view if -gnatc and -gnatn appear together???
134
 
135
         Inline_Active := False;
136
 
137
         --  Turn off SCIL generation in ASIS mode, since SCIL requires front-
138
         --  end expansion.
139
 
140
         Generate_SCIL := False;
141
      end if;
142
 
143
      --  SCIL mode needs to disable front-end inlining since the generated
144
      --  trees (in particular order and consistency between specs compiled
145
      --  as part of a main unit or as part of a with-clause) are causing
146
      --  troubles.
147
 
148
      if Generate_SCIL then
149
         Front_End_Inlining := False;
150
      end if;
151
 
152
      --  Tune settings for optimal SCIL generation in CodePeer_Mode
153
 
154
      if CodePeer_Mode then
155
 
156
         --  Turn off inlining, confuses CodePeer output and gains nothing
157
 
158
         Front_End_Inlining := False;
159
         Inline_Active      := False;
160
 
161
         --  Turn off ASIS mode: incompatible with front-end expansion
162
 
163
         ASIS_Mode := False;
164
 
165
         --  Disable front-end optimizations, to keep the tree as close to the
166
         --  source code as possible, and also to avoid inconsistencies between
167
         --  trees when using different optimization switches.
168
 
169
         Optimization_Level := 0;
170
 
171
         --  Disable specific expansions for Restrictions pragmas to avoid
172
         --  tree inconsistencies between compilations with different pragmas
173
         --  that will cause different SCIL files to be generated for the
174
         --  same Ada spec.
175
 
176
         Treat_Restrictions_As_Warnings := True;
177
 
178
         --  Suppress overflow, division by zero and access checks since they
179
         --  are handled implicitly by CodePeer.
180
 
181
         --  Turn off dynamic elaboration checks: generates inconsistencies in
182
         --  trees between specs compiled as part of a main unit or as part of
183
         --  a with-clause.
184
 
185
         --  Turn off alignment checks: these cannot be proved statically by
186
         --  CodePeer and generate false positives.
187
 
188
         --  Enable all other language checks
189
 
190
         Suppress_Options :=
191
           (Access_Check      => True,
192
            Alignment_Check   => True,
193
            Division_Check    => True,
194
            Elaboration_Check => True,
195
            Overflow_Check    => True,
196
            others            => False);
197
         Enable_Overflow_Checks := False;
198
         Dynamic_Elaboration_Checks := False;
199
 
200
         --  Kill debug of generated code, since it messes up sloc values
201
 
202
         Debug_Generated_Code := False;
203
 
204
         --  Turn cross-referencing on in case it was disabled (by e.g. -gnatD)
205
         --  Do we really need to spend time generating xref in CodePeer
206
         --  mode??? Consider setting Xref_Active to False.
207
 
208
         Xref_Active := True;
209
 
210
         --  Polling mode forced off, since it generates confusing junk
211
 
212
         Polling_Required := False;
213
 
214
         --  Set operating mode to Generate_Code to benefit from full
215
         --  front-end expansion (e.g. generics).
216
 
217
         Operating_Mode := Generate_Code;
218
 
219
         --  We need SCIL generation of course
220
 
221
         Generate_SCIL := True;
222
 
223
         --  Enable assertions and debug pragmas, since they give CodePeer
224
         --  valuable extra information.
225
 
226
         Assertions_Enabled     := True;
227
         Debug_Pragmas_Enabled  := True;
228
 
229
         --  Suppress compiler warnings, since what we are interested in here
230
         --  is what CodePeer can find out. Also disable all simple value
231
         --  propagation. This is an optimization which is valuable for code
232
         --  optimization, and also for generation of compiler warnings, but
233
         --  these are being turned off anyway, and CodePeer understands
234
         --  things more clearly if references are not optimized in this way.
235
 
236
         Warning_Mode  := Suppress;
237
         Debug_Flag_MM := True;
238
 
239
         --  Set normal RM validity checking, and checking of IN OUT parameters
240
         --  (this might give CodePeer more useful checks to analyze, to be
241
         --  confirmed???). All other validity checking is turned off, since
242
         --  this can generate very complex trees that only confuse CodePeer
243
         --  and do not bring enough useful info.
244
 
245
         Reset_Validity_Check_Options;
246
         Validity_Check_Default       := True;
247
         Validity_Check_In_Out_Params := True;
248
         Validity_Check_In_Params     := True;
249
 
250
         --  Turn off style check options since we are not interested in any
251
         --  front-end warnings when we are getting CodePeer output.
252
 
253
         Reset_Style_Check_Options;
254
      end if;
255
 
256
      --  Set Configurable_Run_Time mode if system.ads flag set
257
 
258
      if Targparm.Configurable_Run_Time_On_Target or Debug_Flag_YY then
259
         Configurable_Run_Time_Mode := True;
260
      end if;
261
 
262
      --  Set -gnatR3m mode if debug flag A set
263
 
264
      if Debug_Flag_AA then
265
         Back_Annotate_Rep_Info := True;
266
         List_Representation_Info := 1;
267
         List_Representation_Info_Mechanisms := True;
268
      end if;
269
 
270
      --  Force Target_Strict_Alignment true if debug flag -gnatd.a is set
271
 
272
      if Debug_Flag_Dot_A then
273
         Ttypes.Target_Strict_Alignment := True;
274
      end if;
275
 
276
      --  Disable static allocation of dispatch tables if -gnatd.t or if layout
277
      --  is enabled. The front end's layout phase currently treats types that
278
      --  have discriminant-dependent arrays as not being static even when a
279
      --  discriminant constraint on the type is static, and this leads to
280
      --  problems with subtypes of type Ada.Tags.Dispatch_Table_Wrapper. ???
281
 
282
      if Debug_Flag_Dot_T or else Frontend_Layout_On_Target then
283
         Static_Dispatch_Tables := False;
284
      end if;
285
 
286
      --  Flip endian mode if -gnatd8 set
287
 
288
      if Debug_Flag_8 then
289
         Ttypes.Bytes_Big_Endian := not Ttypes.Bytes_Big_Endian;
290
      end if;
291
 
292
      --  Deal with forcing OpenVMS switches True if debug flag M is set, but
293
      --  record the setting of Targparm.Open_VMS_On_Target in True_VMS_Target
294
      --  before doing this, so we know if we are in real OpenVMS or not!
295
 
296
      Opt.True_VMS_Target := Targparm.OpenVMS_On_Target;
297
 
298
      if Debug_Flag_M then
299
         Targparm.OpenVMS_On_Target := True;
300
         Hostparm.OpenVMS := True;
301
      end if;
302
 
303
      --  Activate front end layout if debug flag -gnatdF is set
304
 
305
      if Debug_Flag_FF then
306
         Targparm.Frontend_Layout_On_Target := True;
307
      end if;
308
 
309
      --  Set and check exception mechnism
310
 
311
      if Targparm.ZCX_By_Default_On_Target then
312
         if Targparm.GCC_ZCX_Support_On_Target then
313
            Exception_Mechanism := Back_End_Exceptions;
314
         else
315
            Osint.Fail ("Zero Cost Exceptions not supported on this target");
316
         end if;
317
      end if;
318
 
319
      --  Set proper status for overflow checks. We turn on overflow checks
320
      --  if -gnatp was not specified, and either -gnato is set or the back
321
      --  end takes care of overflow checks. Otherwise we suppress overflow
322
      --  checks by default (since front end checks are expensive).
323
 
324
      if not Opt.Suppress_Checks
325
        and then (Opt.Enable_Overflow_Checks
326
                    or else
327
                      (Targparm.Backend_Divide_Checks_On_Target
328
                        and
329
                       Targparm.Backend_Overflow_Checks_On_Target))
330
      then
331
         Suppress_Options (Overflow_Check) := False;
332
      else
333
         Suppress_Options (Overflow_Check) := True;
334
      end if;
335
   end Adjust_Global_Switches;
336
 
337
   --------------------
338
   -- Check_Bad_Body --
339
   --------------------
340
 
341
   procedure Check_Bad_Body is
342
      Sname   : Unit_Name_Type;
343
      Src_Ind : Source_File_Index;
344
      Fname   : File_Name_Type;
345
 
346
      procedure Bad_Body_Error (Msg : String);
347
      --  Issue message for bad body found
348
 
349
      --------------------
350
      -- Bad_Body_Error --
351
      --------------------
352
 
353
      procedure Bad_Body_Error (Msg : String) is
354
      begin
355
         Error_Msg_N (Msg, Main_Unit_Node);
356
         Error_Msg_File_1 := Fname;
357
         Error_Msg_N ("remove incorrect body in file{!", Main_Unit_Node);
358
      end Bad_Body_Error;
359
 
360
      --  Start of processing for Check_Bad_Body
361
 
362
   begin
363
      --  Nothing to do if we are only checking syntax, because we don't know
364
      --  enough to know if we require or forbid a body in this case.
365
 
366
      if Operating_Mode = Check_Syntax then
367
         return;
368
      end if;
369
 
370
      --  Check for body not allowed
371
 
372
      if (Main_Kind = N_Package_Declaration
373
           and then not Body_Required (Main_Unit_Node))
374
        or else (Main_Kind = N_Generic_Package_Declaration
375
                  and then not Body_Required (Main_Unit_Node))
376
        or else Main_Kind = N_Package_Renaming_Declaration
377
        or else Main_Kind = N_Subprogram_Renaming_Declaration
378
        or else Nkind (Original_Node (Unit (Main_Unit_Node)))
379
                         in N_Generic_Instantiation
380
      then
381
         Sname := Unit_Name (Main_Unit);
382
 
383
         --  If we do not already have a body name, then get the body name
384
         --  (but how can we have a body name here ???)
385
 
386
         if not Is_Body_Name (Sname) then
387
            Sname := Get_Body_Name (Sname);
388
         end if;
389
 
390
         Fname := Get_File_Name (Sname, Subunit => False);
391
         Src_Ind := Load_Source_File (Fname);
392
 
393
         --  Case where body is present and it is not a subunit. Exclude
394
         --  the subunit case, because it has nothing to do with the
395
         --  package we are compiling. It is illegal for a child unit and a
396
         --  subunit with the same expanded name (RM 10.2(9)) to appear
397
         --  together in a partition, but there is nothing to stop a
398
         --  compilation environment from having both, and the test here
399
         --  simply allows that. If there is an attempt to include both in
400
         --  a partition, this is diagnosed at bind time. In Ada 83 mode
401
         --  this is not a warning case.
402
 
403
         --  Note: if weird file names are being used, we can have
404
         --  situation where the file name that supposedly contains body,
405
         --  in fact contains a spec, or we can't tell what it contains.
406
         --  Skip the error message in these cases.
407
 
408
         --  Also ignore body that is nothing but pragma No_Body; (that's the
409
         --  whole point of this pragma, to be used this way and to cause the
410
         --  body file to be ignored in this context).
411
 
412
         if Src_Ind /= No_Source_File
413
           and then Get_Expected_Unit_Type (Fname) = Expect_Body
414
           and then not Source_File_Is_Subunit (Src_Ind)
415
           and then not Source_File_Is_No_Body (Src_Ind)
416
         then
417
            Errout.Finalize (Last_Call => False);
418
 
419
            Error_Msg_Unit_1 := Sname;
420
 
421
            --  Ada 83 case of a package body being ignored. This is not an
422
            --  error as far as the Ada 83 RM is concerned, but it is almost
423
            --  certainly not what is wanted so output a warning. Give this
424
            --  message only if there were no errors, since otherwise it may
425
            --  be incorrect (we may have misinterpreted a junk spec as not
426
            --  needing a body when it really does).
427
 
428
            if Main_Kind = N_Package_Declaration
429
              and then Ada_Version = Ada_83
430
              and then Operating_Mode = Generate_Code
431
              and then Distribution_Stub_Mode /= Generate_Caller_Stub_Body
432
              and then not Compilation_Errors
433
            then
434
               Error_Msg_N
435
                 ("package $$ does not require a body?", Main_Unit_Node);
436
               Error_Msg_File_1 := Fname;
437
               Error_Msg_N ("body in file{? will be ignored", Main_Unit_Node);
438
 
439
               --  Ada 95 cases of a body file present when no body is
440
               --  permitted. This we consider to be an error.
441
 
442
            else
443
               --  For generic instantiations, we never allow a body
444
 
445
               if Nkind (Original_Node (Unit (Main_Unit_Node)))
446
               in N_Generic_Instantiation
447
               then
448
                  Bad_Body_Error
449
                    ("generic instantiation for $$ does not allow a body");
450
 
451
                  --  A library unit that is a renaming never allows a body
452
 
453
               elsif Main_Kind in N_Renaming_Declaration then
454
                  Bad_Body_Error
455
                    ("renaming declaration for $$ does not allow a body!");
456
 
457
                  --  Remaining cases are packages and generic packages. Here
458
                  --  we only do the test if there are no previous errors,
459
                  --  because if there are errors, they may lead us to
460
                  --  incorrectly believe that a package does not allow a body
461
                  --  when in fact it does.
462
 
463
               elsif not Compilation_Errors then
464
                  if Main_Kind = N_Package_Declaration then
465
                     Bad_Body_Error
466
                       ("package $$ does not allow a body!");
467
 
468
                  elsif Main_Kind = N_Generic_Package_Declaration then
469
                     Bad_Body_Error
470
                       ("generic package $$ does not allow a body!");
471
                  end if;
472
               end if;
473
 
474
            end if;
475
         end if;
476
      end if;
477
   end Check_Bad_Body;
478
 
479
   -------------------------
480
   -- Check_Library_Items --
481
   -------------------------
482
 
483
   --  Walk_Library_Items has plenty of assertions, so all we need to do is
484
   --  call it, just for these assertions, not actually doing anything else.
485
 
486
   procedure Check_Library_Items is
487
 
488
      procedure Action (Item : Node_Id);
489
      --  Action passed to Walk_Library_Items to do nothing
490
 
491
      ------------
492
      -- Action --
493
      ------------
494
 
495
      procedure Action (Item : Node_Id) is
496
      begin
497
         null;
498
      end Action;
499
 
500
      procedure Walk is new Sem.Walk_Library_Items (Action);
501
 
502
   --  Start of processing for Check_Library_Items
503
 
504
   begin
505
      Walk;
506
   end Check_Library_Items;
507
 
508
   --------------------
509
   -- Check_Rep_Info --
510
   --------------------
511
 
512
   procedure Check_Rep_Info is
513
   begin
514
      if List_Representation_Info /= 0
515
        or else List_Representation_Info_Mechanisms
516
      then
517
         Set_Standard_Error;
518
         Write_Eol;
519
         Write_Str
520
           ("cannot generate representation information, no code generated");
521
         Write_Eol;
522
         Write_Eol;
523
         Set_Standard_Output;
524
      end if;
525
   end Check_Rep_Info;
526
 
527
--  Start of processing for Gnat1drv
528
 
529
begin
530
   --  This inner block is set up to catch assertion errors and constraint
531
   --  errors. Since the code for handling these errors can cause another
532
   --  exception to be raised (namely Unrecoverable_Error), we need two
533
   --  nested blocks, so that the outer one handles unrecoverable error.
534
 
535
   begin
536
      --  Initialize all packages. For the most part, these initialization
537
      --  calls can be made in any order. Exceptions are as follows:
538
 
539
      --  Lib.Initialize need to be called before Scan_Compiler_Arguments,
540
      --  because it initializes a table filled by Scan_Compiler_Arguments.
541
 
542
      Osint.Initialize;
543
      Fmap.Reset_Tables;
544
      Lib.Initialize;
545
      Lib.Xref.Initialize;
546
      Scan_Compiler_Arguments;
547
      Osint.Add_Default_Search_Dirs;
548
 
549
      Nlists.Initialize;
550
      Sinput.Initialize;
551
      Sem.Initialize;
552
      Csets.Initialize;
553
      Uintp.Initialize;
554
      Urealp.Initialize;
555
      Errout.Initialize;
556
      Namet.Initialize;
557
      SCOs.Initialize;
558
      Snames.Initialize;
559
      Stringt.Initialize;
560
      Inline.Initialize;
561
      Par_SCO.Initialize;
562
      Sem_Ch8.Initialize;
563
      Sem_Ch12.Initialize;
564
      Sem_Ch13.Initialize;
565
      Sem_Elim.Initialize;
566
      Sem_Eval.Initialize;
567
      Sem_Type.Init_Interp_Tables;
568
 
569
      --  Acquire target parameters from system.ads (source of package System)
570
 
571
      declare
572
         use Sinput;
573
 
574
         S : Source_File_Index;
575
         N : File_Name_Type;
576
 
577
      begin
578
         Name_Buffer (1 .. 10) := "system.ads";
579
         Name_Len := 10;
580
         N := Name_Find;
581
         S := Load_Source_File (N);
582
 
583
         if S = No_Source_File then
584
            Write_Line
585
              ("fatal error, run-time library not installed correctly");
586
            Write_Line
587
              ("cannot locate file system.ads");
588
            raise Unrecoverable_Error;
589
 
590
         --  Remember source index of system.ads (which was read successfully)
591
 
592
         else
593
            System_Source_File_Index := S;
594
         end if;
595
 
596
         Targparm.Get_Target_Parameters
597
           (System_Text  => Source_Text  (S),
598
            Source_First => Source_First (S),
599
            Source_Last  => Source_Last  (S));
600
 
601
         --  Acquire configuration pragma information from Targparm
602
 
603
         Restrict.Restrictions := Targparm.Restrictions_On_Target;
604
      end;
605
 
606
      Adjust_Global_Switches;
607
 
608
      --  Output copyright notice if full list mode unless we have a list
609
      --  file, in which case we defer this so that it is output in the file
610
 
611
      if (Verbose_Mode or else (Full_List and then Full_List_File_Name = null))
612
        and then not Debug_Flag_7
613
      then
614
         Write_Eol;
615
         Write_Str ("GNAT ");
616
         Write_Str (Gnat_Version_String);
617
         Write_Eol;
618
         Write_Str ("Copyright 1992-" &
619
                    Current_Year &
620
                    ", Free Software Foundation, Inc.");
621
         Write_Eol;
622
      end if;
623
 
624
      --  Check we do not have more than one source file, this happens only in
625
      --  the case where the driver is called directly, it cannot happen when
626
      --  gnat1 is invoked from gcc in the normal case.
627
 
628
      if Osint.Number_Of_Files /= 1 then
629
         Usage;
630
         Write_Eol;
631
         Osint.Fail ("you must provide one source file");
632
 
633
      elsif Usage_Requested then
634
         Usage;
635
      end if;
636
 
637
      Original_Operating_Mode := Operating_Mode;
638
      Frontend;
639
 
640
      --  Exit with errors if the main source could not be parsed
641
 
642
      if Sinput.Main_Source_File = No_Source_File then
643
         Errout.Finalize (Last_Call => True);
644
         Errout.Output_Messages;
645
         Exit_Program (E_Errors);
646
      end if;
647
 
648
      Main_Unit_Node := Cunit (Main_Unit);
649
      Main_Kind := Nkind (Unit (Main_Unit_Node));
650
      Check_Bad_Body;
651
 
652
      --  Exit if compilation errors detected
653
 
654
      Errout.Finalize (Last_Call => False);
655
 
656
      if Compilation_Errors then
657
         Treepr.Tree_Dump;
658
         Sem_Ch13.Validate_Unchecked_Conversions;
659
         Sem_Ch13.Validate_Address_Clauses;
660
         Errout.Output_Messages;
661
         Namet.Finalize;
662
 
663
         --  Generate ALI file if specially requested
664
 
665
         if Opt.Force_ALI_Tree_File then
666
            Write_ALI (Object => False);
667
            Tree_Gen;
668
         end if;
669
 
670
         Errout.Finalize (Last_Call => True);
671
         Exit_Program (E_Errors);
672
      end if;
673
 
674
      --  Set Generate_Code on main unit and its spec. We do this even if are
675
      --  not generating code, since Lib-Writ uses this to determine which
676
      --  units get written in the ali file.
677
 
678
      Set_Generate_Code (Main_Unit);
679
 
680
      --  If we have a corresponding spec, and it comes from source
681
      --  or it is not a generated spec for a child subprogram body,
682
      --  then we need object code for the spec unit as well.
683
 
684
      if Nkind (Unit (Main_Unit_Node)) in N_Unit_Body
685
        and then not Acts_As_Spec (Main_Unit_Node)
686
      then
687
         if Nkind (Unit (Main_Unit_Node)) = N_Subprogram_Body
688
           and then not Comes_From_Source (Library_Unit (Main_Unit_Node))
689
         then
690
            null;
691
         else
692
            Set_Generate_Code
693
              (Get_Cunit_Unit_Number (Library_Unit (Main_Unit_Node)));
694
         end if;
695
      end if;
696
 
697
      --  Case of no code required to be generated, exit indicating no error
698
 
699
      if Original_Operating_Mode = Check_Syntax then
700
         Treepr.Tree_Dump;
701
         Errout.Finalize (Last_Call => True);
702
         Errout.Output_Messages;
703
         Tree_Gen;
704
         Namet.Finalize;
705
         Check_Rep_Info;
706
 
707
         --  Use a goto instead of calling Exit_Program so that finalization
708
         --  occurs normally.
709
 
710
         goto End_Of_Program;
711
 
712
      elsif Original_Operating_Mode = Check_Semantics then
713
         Back_End_Mode := Declarations_Only;
714
 
715
      --  All remaining cases are cases in which the user requested that code
716
      --  be generated (i.e. no -gnatc or -gnats switch was used). Check if
717
      --  we can in fact satisfy this request.
718
 
719
      --  Cannot generate code if someone has turned off code generation for
720
      --  any reason at all. We will try to figure out a reason below.
721
 
722
      elsif Operating_Mode /= Generate_Code then
723
         Back_End_Mode := Skip;
724
 
725
      --  We can generate code for a subprogram body unless there were missing
726
      --  subunits. Note that we always generate code for all generic units (a
727
      --  change from some previous versions of GNAT).
728
 
729
      elsif Main_Kind = N_Subprogram_Body
730
        and then not Subunits_Missing
731
      then
732
         Back_End_Mode := Generate_Object;
733
 
734
      --  We can generate code for a package body unless there are subunits
735
      --  missing (note that we always generate code for generic units, which
736
      --  is a change from some earlier versions of GNAT).
737
 
738
      elsif Main_Kind = N_Package_Body
739
        and then not Subunits_Missing
740
      then
741
         Back_End_Mode := Generate_Object;
742
 
743
      --  We can generate code for a package declaration or a subprogram
744
      --  declaration only if it does not required a body.
745
 
746
      elsif (Main_Kind = N_Package_Declaration
747
               or else
748
             Main_Kind = N_Subprogram_Declaration)
749
        and then
750
          (not Body_Required (Main_Unit_Node)
751
             or else
752
           Distribution_Stub_Mode = Generate_Caller_Stub_Body)
753
      then
754
         Back_End_Mode := Generate_Object;
755
 
756
      --  We can generate code for a generic package declaration of a generic
757
      --  subprogram declaration only if does not require a body.
758
 
759
      elsif (Main_Kind = N_Generic_Package_Declaration
760
               or else
761
             Main_Kind = N_Generic_Subprogram_Declaration)
762
        and then not Body_Required (Main_Unit_Node)
763
      then
764
         Back_End_Mode := Generate_Object;
765
 
766
      --  Compilation units that are renamings do not require bodies,
767
      --  so we can generate code for them.
768
 
769
      elsif Main_Kind = N_Package_Renaming_Declaration
770
        or else Main_Kind = N_Subprogram_Renaming_Declaration
771
      then
772
         Back_End_Mode := Generate_Object;
773
 
774
      --  Compilation units that are generic renamings do not require bodies
775
      --  so we can generate code for them.
776
 
777
      elsif Main_Kind in N_Generic_Renaming_Declaration then
778
         Back_End_Mode := Generate_Object;
779
 
780
      --  It's not an error to generate SCIL for e.g. a spec which has a body
781
 
782
      elsif CodePeer_Mode then
783
         Back_End_Mode := Generate_Object;
784
 
785
      --  In all other cases (specs which have bodies, generics, and bodies
786
      --  where subunits are missing), we cannot generate code and we generate
787
      --  a warning message. Note that generic instantiations are gone at this
788
      --  stage since they have been replaced by their instances.
789
 
790
      else
791
         Back_End_Mode := Skip;
792
      end if;
793
 
794
      --  At this stage Back_End_Mode is set to indicate if the backend should
795
      --  be called to generate code. If it is Skip, then code generation has
796
      --  been turned off, even though code was requested by the original
797
      --  command. This is not an error from the user point of view, but it is
798
      --  an error from the point of view of the gcc driver, so we must exit
799
      --  with an error status.
800
 
801
      --  We generate an informative message (from the gcc point of view, it
802
      --  is an error message, but from the users point of view this is not an
803
      --  error, just a consequence of compiling something that cannot
804
      --  generate code).
805
 
806
      if Back_End_Mode = Skip then
807
         Set_Standard_Error;
808
         Write_Str ("cannot generate code for ");
809
         Write_Str ("file ");
810
         Write_Name (Unit_File_Name (Main_Unit));
811
 
812
         if Subunits_Missing then
813
            Write_Str (" (missing subunits)");
814
            Write_Eol;
815
            Write_Str ("to check parent unit");
816
 
817
         elsif Main_Kind = N_Subunit then
818
            Write_Str (" (subunit)");
819
            Write_Eol;
820
            Write_Str ("to check subunit");
821
 
822
         elsif Main_Kind = N_Subprogram_Declaration then
823
            Write_Str (" (subprogram spec)");
824
            Write_Eol;
825
            Write_Str ("to check subprogram spec");
826
 
827
         --  Generic package body in GNAT implementation mode
828
 
829
         elsif Main_Kind = N_Package_Body and then GNAT_Mode then
830
            Write_Str (" (predefined generic)");
831
            Write_Eol;
832
            Write_Str ("to check predefined generic");
833
 
834
         --  Only other case is a package spec
835
 
836
         else
837
            Write_Str (" (package spec)");
838
            Write_Eol;
839
            Write_Str ("to check package spec");
840
         end if;
841
 
842
         Write_Str (" for errors, use ");
843
 
844
         if Hostparm.OpenVMS then
845
            Write_Str ("/NOLOAD");
846
         else
847
            Write_Str ("-gnatc");
848
         end if;
849
 
850
         Write_Eol;
851
         Set_Standard_Output;
852
 
853
         Sem_Ch13.Validate_Unchecked_Conversions;
854
         Sem_Ch13.Validate_Address_Clauses;
855
         Errout.Finalize (Last_Call => True);
856
         Errout.Output_Messages;
857
         Treepr.Tree_Dump;
858
         Tree_Gen;
859
         Write_ALI (Object => False);
860
         Namet.Finalize;
861
         Check_Rep_Info;
862
 
863
         --  Exit program with error indication, to kill object file
864
 
865
         Exit_Program (E_No_Code);
866
      end if;
867
 
868
      --  In -gnatc mode, we only do annotation if -gnatt or -gnatR is also
869
      --  set as indicated by Back_Annotate_Rep_Info being set to True.
870
 
871
      --  We don't call for annotations on a subunit, because to process those
872
      --  the back-end requires that the parent(s) be properly compiled.
873
 
874
      --  Annotation is suppressed for targets where front-end layout is
875
      --  enabled, because the front end determines representations.
876
 
877
      --  Annotation is also suppressed in the case of compiling for
878
      --  a VM, since representations are largely symbolic there.
879
 
880
      if Back_End_Mode = Declarations_Only
881
        and then (not (Back_Annotate_Rep_Info or Generate_SCIL)
882
                   or else Main_Kind = N_Subunit
883
                   or else Targparm.Frontend_Layout_On_Target
884
                   or else Targparm.VM_Target /= No_VM)
885
      then
886
         Sem_Ch13.Validate_Unchecked_Conversions;
887
         Sem_Ch13.Validate_Address_Clauses;
888
         Errout.Finalize (Last_Call => True);
889
         Errout.Output_Messages;
890
         Write_ALI (Object => False);
891
         Tree_Dump;
892
         Tree_Gen;
893
         Namet.Finalize;
894
         Check_Rep_Info;
895
         return;
896
      end if;
897
 
898
      --  Ensure that we properly register a dependency on system.ads, since
899
      --  even if we do not semantically depend on this, Targparm has read
900
      --  system parameters from the system.ads file.
901
 
902
      Lib.Writ.Ensure_System_Dependency;
903
 
904
      --  Add dependencies, if any, on preprocessing data file and on
905
      --  preprocessing definition file(s).
906
 
907
      Prepcomp.Add_Dependencies;
908
 
909
      --  Back end needs to explicitly unlock tables it needs to touch
910
 
911
      Atree.Lock;
912
      Elists.Lock;
913
      Fname.UF.Lock;
914
      Inline.Lock;
915
      Lib.Lock;
916
      Nlists.Lock;
917
      Sem.Lock;
918
      Sinput.Lock;
919
      Namet.Lock;
920
      Stringt.Lock;
921
 
922
      --  ???Check_Library_Items under control of a debug flag, because it
923
      --  currently does not work if the -gnatn switch (back end inlining) is
924
      --  used.
925
 
926
      if Debug_Flag_Dot_WW then
927
         Check_Library_Items;
928
      end if;
929
 
930
      --  Here we call the back end to generate the output code
931
 
932
      Generating_Code := True;
933
      Back_End.Call_Back_End (Back_End_Mode);
934
 
935
      --  Once the backend is complete, we unlock the names table. This call
936
      --  allows a few extra entries, needed for example for the file name for
937
      --  the library file output.
938
 
939
      Namet.Unlock;
940
 
941
      --  Validate unchecked conversions (using the values for size and
942
      --  alignment annotated by the backend where possible).
943
 
944
      Sem_Ch13.Validate_Unchecked_Conversions;
945
 
946
      --  Validate address clauses (again using alignment values annotated
947
      --  by the backend where possible).
948
 
949
      Sem_Ch13.Validate_Address_Clauses;
950
 
951
      --  Now we complete output of errors, rep info and the tree info. These
952
      --  are delayed till now, since it is perfectly possible for gigi to
953
      --  generate errors, modify the tree (in particular by setting flags
954
      --  indicating that elaboration is required, and also to back annotate
955
      --  representation information for List_Rep_Info.
956
 
957
      Errout.Finalize (Last_Call => True);
958
      Errout.Output_Messages;
959
      List_Rep_Info;
960
 
961
      --  Only write the library if the backend did not generate any error
962
      --  messages. Otherwise signal errors to the driver program so that
963
      --  there will be no attempt to generate an object file.
964
 
965
      if Compilation_Errors then
966
         Treepr.Tree_Dump;
967
         Exit_Program (E_Errors);
968
      end if;
969
 
970
      Write_ALI (Object => (Back_End_Mode = Generate_Object));
971
 
972
      --  Generate the ASIS tree after writing the ALI file, since in ASIS
973
      --  mode, Write_ALI may in fact result in further tree decoration from
974
      --  the original tree file. Note that we dump the tree just before
975
      --  generating it, so that the dump will exactly reflect what is written
976
      --  out.
977
 
978
      Treepr.Tree_Dump;
979
      Tree_Gen;
980
 
981
      --  Finalize name table and we are all done
982
 
983
      Namet.Finalize;
984
 
985
   exception
986
      --  Handle fatal internal compiler errors
987
 
988
      when Rtsfind.RE_Not_Available =>
989
         Comperr.Compiler_Abort ("RE_Not_Available");
990
 
991
      when System.Assertions.Assert_Failure =>
992
         Comperr.Compiler_Abort ("Assert_Failure");
993
 
994
      when Constraint_Error =>
995
         Comperr.Compiler_Abort ("Constraint_Error");
996
 
997
      when Program_Error =>
998
         Comperr.Compiler_Abort ("Program_Error");
999
 
1000
      when Storage_Error =>
1001
 
1002
         --  Assume this is a bug. If it is real, the message will in any case
1003
         --  say Storage_Error, giving a strong hint!
1004
 
1005
         Comperr.Compiler_Abort ("Storage_Error");
1006
   end;
1007
 
1008
   <<End_Of_Program>>
1009
   null;
1010
 
1011
   --  The outer exception handles an unrecoverable error
1012
 
1013
exception
1014
   when Unrecoverable_Error =>
1015
      Errout.Finalize (Last_Call => True);
1016
      Errout.Output_Messages;
1017
 
1018
      Set_Standard_Error;
1019
      Write_Str ("compilation abandoned");
1020
      Write_Eol;
1021
 
1022
      Set_Standard_Output;
1023
      Source_Dump;
1024
      Tree_Dump;
1025
      Exit_Program (E_Errors);
1026
 
1027
end Gnat1drv;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.