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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [gnat1drv.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

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