1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
|
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T 1 D R V --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Atree; use Atree;
with Back_End; use Back_End;
with Comperr;
with Csets; use Csets;
with Debug; use Debug;
with Elists;
with Errout; use Errout;
with Fmap;
with Fname; use Fname;
with Fname.UF; use Fname.UF;
with Frontend;
with Gnatvsn; use Gnatvsn;
with Hostparm;
with Inline;
with Lib; use Lib;
with Lib.Writ; use Lib.Writ;
with Lib.Xref;
with Namet; use Namet;
with Nlists;
with Opt; use Opt;
with Osint; use Osint;
with Output; use Output;
with Prepcomp;
with Repinfo; use Repinfo;
with Restrict;
with Rtsfind;
with Sem;
with Sem_Ch8;
with Sem_Ch12;
with Sem_Ch13;
with Sem_Elim;
with Sem_Eval;
with Sem_Type;
with Sinfo; use Sinfo;
with Sinput.L; use Sinput.L;
with Snames;
with Sprint; use Sprint;
with Stringt;
with Targparm; use Targparm;
with Tree_Gen;
with Treepr; use Treepr;
with Ttypes;
with Types; use Types;
with Uintp; use Uintp;
with Uname; use Uname;
with Urealp;
with Usage;
with System.Assertions;
procedure Gnat1drv is
Main_Unit_Node : Node_Id;
-- Compilation unit node for main unit
Main_Kind : Node_Kind;
-- Kind of main compilation unit node
Back_End_Mode : Back_End.Back_End_Mode_Type;
-- Record back end mode
procedure Check_Bad_Body;
-- Called to check if the unit we are compiling has a bad body
procedure Check_Rep_Info;
-- Called when we are not generating code, to check if -gnatR was requested
-- and if so, explain that we will not be honoring the request.
--------------------
-- Check_Bad_Body --
--------------------
procedure Check_Bad_Body is
Sname : Unit_Name_Type;
Src_Ind : Source_File_Index;
Fname : File_Name_Type;
procedure Bad_Body_Error (Msg : String);
-- Issue message for bad body found
--------------------
-- Bad_Body_Error --
--------------------
procedure Bad_Body_Error (Msg : String) is
begin
Error_Msg_N (Msg, Main_Unit_Node);
Error_Msg_File_1 := Fname;
Error_Msg_N ("remove incorrect body in file{!", Main_Unit_Node);
end Bad_Body_Error;
-- Start of processing for Check_Bad_Body
begin
-- Nothing to do if we are only checking syntax, because we don't know
-- enough to know if we require or forbid a body in this case.
if Operating_Mode = Check_Syntax then
return;
end if;
-- Check for body not allowed
if (Main_Kind = N_Package_Declaration
and then not Body_Required (Main_Unit_Node))
or else (Main_Kind = N_Generic_Package_Declaration
and then not Body_Required (Main_Unit_Node))
or else Main_Kind = N_Package_Renaming_Declaration
or else Main_Kind = N_Subprogram_Renaming_Declaration
or else Nkind (Original_Node (Unit (Main_Unit_Node)))
in N_Generic_Instantiation
then
Sname := Unit_Name (Main_Unit);
-- If we do not already have a body name, then get the body name
-- (but how can we have a body name here ???)
if not Is_Body_Name (Sname) then
Sname := Get_Body_Name (Sname);
end if;
Fname := Get_File_Name (Sname, Subunit => False);
Src_Ind := Load_Source_File (Fname);
-- Case where body is present and it is not a subunit. Exclude
-- the subunit case, because it has nothing to do with the
-- package we are compiling. It is illegal for a child unit and a
-- subunit with the same expanded name (RM 10.2(9)) to appear
-- together in a partition, but there is nothing to stop a
-- compilation environment from having both, and the test here
-- simply allows that. If there is an attempt to include both in
-- a partition, this is diagnosed at bind time. In Ada 83 mode
-- this is not a warning case.
-- Note: if weird file names are being used, we can have
-- situation where the file name that supposedly contains body,
-- in fact contains a spec, or we can't tell what it contains.
-- Skip the error message in these cases.
-- Also ignore body that is nothing but pragma No_Body; (that's the
-- whole point of this pragma, to be used this way and to cause the
-- body file to be ignored in this context).
if Src_Ind /= No_Source_File
and then Get_Expected_Unit_Type (Fname) = Expect_Body
and then not Source_File_Is_Subunit (Src_Ind)
and then not Source_File_Is_No_Body (Src_Ind)
then
Errout.Finalize (Last_Call => False);
Error_Msg_Unit_1 := Sname;
-- Ada 83 case of a package body being ignored. This is not an
-- error as far as the Ada 83 RM is concerned, but it is almost
-- certainly not what is wanted so output a warning. Give this
-- message only if there were no errors, since otherwise it may
-- be incorrect (we may have misinterpreted a junk spec as not
-- needing a body when it really does).
if Main_Kind = N_Package_Declaration
and then Ada_Version = Ada_83
and then Operating_Mode = Generate_Code
and then Distribution_Stub_Mode /= Generate_Caller_Stub_Body
and then not Compilation_Errors
then
Error_Msg_N
("package $$ does not require a body?", Main_Unit_Node);
Error_Msg_File_1 := Fname;
Error_Msg_N ("body in file{? will be ignored", Main_Unit_Node);
-- Ada 95 cases of a body file present when no body is
-- permitted. This we consider to be an error.
else
-- For generic instantiations, we never allow a body
if Nkind (Original_Node (Unit (Main_Unit_Node)))
in N_Generic_Instantiation
then
Bad_Body_Error
("generic instantiation for $$ does not allow a body");
-- A library unit that is a renaming never allows a body
elsif Main_Kind in N_Renaming_Declaration then
Bad_Body_Error
("renaming declaration for $$ does not allow a body!");
-- Remaining cases are packages and generic packages. Here
-- we only do the test if there are no previous errors,
-- because if there are errors, they may lead us to
-- incorrectly believe that a package does not allow a body
-- when in fact it does.
elsif not Compilation_Errors then
if Main_Kind = N_Package_Declaration then
Bad_Body_Error
("package $$ does not allow a body!");
elsif Main_Kind = N_Generic_Package_Declaration then
Bad_Body_Error
("generic package $$ does not allow a body!");
end if;
end if;
end if;
end if;
end if;
end Check_Bad_Body;
--------------------
-- Check_Rep_Info --
--------------------
procedure Check_Rep_Info is
begin
if List_Representation_Info /= 0
or else List_Representation_Info_Mechanisms
then
Set_Standard_Error;
Write_Eol;
Write_Str
("cannot generate representation information, no code generated");
Write_Eol;
Write_Eol;
Set_Standard_Output;
end if;
end Check_Rep_Info;
-- Start of processing for Gnat1drv
begin
-- This inner block is set up to catch assertion errors and constraint
-- errors. Since the code for handling these errors can cause another
-- exception to be raised (namely Unrecoverable_Error), we need two
-- nested blocks, so that the outer one handles unrecoverable error.
begin
-- Lib.Initialize need to be called before Scan_Compiler_Arguments,
-- because it initializes a table filled by Scan_Compiler_Arguments.
Osint.Initialize;
Fmap.Reset_Tables;
Lib.Initialize;
Lib.Xref.Initialize;
Scan_Compiler_Arguments;
Osint.Add_Default_Search_Dirs;
Nlists.Initialize;
Sinput.Initialize;
Sem.Initialize;
Csets.Initialize;
Uintp.Initialize;
Urealp.Initialize;
Errout.Initialize;
Namet.Initialize;
Snames.Initialize;
Stringt.Initialize;
Inline.Initialize;
Sem_Ch8.Initialize;
Sem_Ch12.Initialize;
Sem_Ch13.Initialize;
Sem_Elim.Initialize;
Sem_Eval.Initialize;
Sem_Type.Init_Interp_Tables;
-- Acquire target parameters from system.ads (source of package System)
declare
use Sinput;
S : Source_File_Index;
N : File_Name_Type;
begin
Name_Buffer (1 .. 10) := "system.ads";
Name_Len := 10;
N := Name_Find;
S := Load_Source_File (N);
if S = No_Source_File then
Write_Line
("fatal error, run-time library not installed correctly");
Write_Line
("cannot locate file system.ads");
raise Unrecoverable_Error;
-- Remember source index of system.ads (which was read successfully)
else
System_Source_File_Index := S;
end if;
Targparm.Get_Target_Parameters
(System_Text => Source_Text (S),
Source_First => Source_First (S),
Source_Last => Source_Last (S));
-- Acquire configuration pragma information from Targparm
Restrict.Restrictions := Targparm.Restrictions_On_Target;
end;
-- Set Configurable_Run_Time mode if system.ads flag set
if Targparm.Configurable_Run_Time_On_Target or Debug_Flag_YY then
Configurable_Run_Time_Mode := True;
end if;
-- Set -gnatR3m mode if debug flag A set
if Debug_Flag_AA then
Back_Annotate_Rep_Info := True;
List_Representation_Info := 1;
List_Representation_Info_Mechanisms := True;
end if;
-- Force Target_Strict_Alignment true if debug flag -gnatd.a is set
if Debug_Flag_Dot_A then
Ttypes.Target_Strict_Alignment := True;
end if;
-- Disable static allocation of dispatch tables if -gnatd.t or if layout
-- is enabled. The front end's layout phase currently treats types that
-- have discriminant-dependent arrays as not being static even when a
-- discriminant constraint on the type is static, and this leads to
-- problems with subtypes of type Ada.Tags.Dispatch_Table_Wrapper. ???
if Debug_Flag_Dot_T or else Frontend_Layout_On_Target then
Static_Dispatch_Tables := False;
end if;
-- Output copyright notice if full list mode unless we have a list
-- file, in which case we defer this so that it is output in the file
if (Verbose_Mode or else (Full_List and then Full_List_File_Name = null))
and then not Debug_Flag_7
then
Write_Eol;
Write_Str ("GNAT ");
Write_Str (Gnat_Version_String);
Write_Eol;
Write_Str ("Copyright 1992-" &
Current_Year &
", Free Software Foundation, Inc.");
Write_Eol;
end if;
-- Before we do anything else, adjust certain global values for
-- debug switches which modify their normal natural settings.
if Debug_Flag_8 then
Ttypes.Bytes_Big_Endian := not Ttypes.Bytes_Big_Endian;
end if;
-- Deal with forcing OpenVMS switches Ture if debug flag M is set, but
-- record the setting of Targparm.Open_VMS_On_Target in True_VMS_Target
-- before doing this.
Opt.True_VMS_Target := Targparm.OpenVMS_On_Target;
if Debug_Flag_M then
Targparm.OpenVMS_On_Target := True;
Hostparm.OpenVMS := True;
end if;
if Debug_Flag_FF then
Targparm.Frontend_Layout_On_Target := True;
end if;
-- We take the default exception mechanism into account
if Targparm.ZCX_By_Default_On_Target then
if Targparm.GCC_ZCX_Support_On_Target then
Exception_Mechanism := Back_End_Exceptions;
else
Osint.Fail ("Zero Cost Exceptions not supported on this target");
end if;
end if;
-- Set proper status for overflow checks. We turn on overflow checks
-- if -gnatp was not specified, and either -gnato is set or the back
-- end takes care of overflow checks. Otherwise we suppress overflow
-- checks by default (since front end checks are expensive).
if not Opt.Suppress_Checks
and then (Opt.Enable_Overflow_Checks
or else
(Targparm.Backend_Divide_Checks_On_Target
and
Targparm.Backend_Overflow_Checks_On_Target))
then
Suppress_Options (Overflow_Check) := False;
else
Suppress_Options (Overflow_Check) := True;
end if;
-- Check we do not have more than one source file, this happens only in
-- the case where the driver is called directly, it cannot happen when
-- gnat1 is invoked from gcc in the normal case.
if Osint.Number_Of_Files /= 1 then
Usage;
Write_Eol;
Osint.Fail ("you must provide one source file");
elsif Usage_Requested then
Usage;
end if;
Original_Operating_Mode := Operating_Mode;
Frontend;
-- Exit with errors if the main source could not be parsed
if Sinput.Main_Source_File = No_Source_File then
Errout.Finalize (Last_Call => True);
Errout.Output_Messages;
Exit_Program (E_Errors);
end if;
Main_Unit_Node := Cunit (Main_Unit);
Main_Kind := Nkind (Unit (Main_Unit_Node));
Check_Bad_Body;
-- Exit if compilation errors detected
Errout.Finalize (Last_Call => False);
if Compilation_Errors then
Treepr.Tree_Dump;
Sem_Ch13.Validate_Unchecked_Conversions;
Sem_Ch13.Validate_Address_Clauses;
Errout.Output_Messages;
Namet.Finalize;
-- Generate ALI file if specially requested
if Opt.Force_ALI_Tree_File then
Write_ALI (Object => False);
Tree_Gen;
end if;
Errout.Finalize (Last_Call => True);
Exit_Program (E_Errors);
end if;
-- Set Generate_Code on main unit and its spec. We do this even if are
-- not generating code, since Lib-Writ uses this to determine which
-- units get written in the ali file.
Set_Generate_Code (Main_Unit);
-- If we have a corresponding spec, then we need object
-- code for the spec unit as well
if Nkind (Unit (Main_Unit_Node)) in N_Unit_Body
and then not Acts_As_Spec (Main_Unit_Node)
then
Set_Generate_Code
(Get_Cunit_Unit_Number (Library_Unit (Main_Unit_Node)));
end if;
-- Case of no code required to be generated, exit indicating no error
if Original_Operating_Mode = Check_Syntax then
Treepr.Tree_Dump;
Errout.Finalize (Last_Call => True);
Errout.Output_Messages;
Tree_Gen;
Namet.Finalize;
Check_Rep_Info;
-- Use a goto instead of calling Exit_Program so that finalization
-- occurs normally.
goto End_Of_Program;
elsif Original_Operating_Mode = Check_Semantics then
Back_End_Mode := Declarations_Only;
-- All remaining cases are cases in which the user requested that code
-- be generated (i.e. no -gnatc or -gnats switch was used). Check if
-- we can in fact satisfy this request.
-- Cannot generate code if someone has turned off code generation for
-- any reason at all. We will try to figure out a reason below.
elsif Operating_Mode /= Generate_Code then
Back_End_Mode := Skip;
-- We can generate code for a subprogram body unless there were missing
-- subunits. Note that we always generate code for all generic units (a
-- change from some previous versions of GNAT).
elsif Main_Kind = N_Subprogram_Body
and then not Subunits_Missing
then
Back_End_Mode := Generate_Object;
-- We can generate code for a package body unless there are subunits
-- missing (note that we always generate code for generic units, which
-- is a change from some earlier versions of GNAT).
elsif Main_Kind = N_Package_Body
and then not Subunits_Missing
then
Back_End_Mode := Generate_Object;
-- We can generate code for a package declaration or a subprogram
-- declaration only if it does not required a body.
elsif (Main_Kind = N_Package_Declaration
or else
Main_Kind = N_Subprogram_Declaration)
and then
(not Body_Required (Main_Unit_Node)
or else
Distribution_Stub_Mode = Generate_Caller_Stub_Body)
then
Back_End_Mode := Generate_Object;
-- We can generate code for a generic package declaration of a generic
-- subprogram declaration only if does not require a body.
elsif (Main_Kind = N_Generic_Package_Declaration
or else
Main_Kind = N_Generic_Subprogram_Declaration)
and then not Body_Required (Main_Unit_Node)
then
Back_End_Mode := Generate_Object;
-- Compilation units that are renamings do not require bodies,
-- so we can generate code for them.
elsif Main_Kind = N_Package_Renaming_Declaration
or else Main_Kind = N_Subprogram_Renaming_Declaration
then
Back_End_Mode := Generate_Object;
-- Compilation units that are generic renamings do not require bodies
-- so we can generate code for them.
elsif Main_Kind in N_Generic_Renaming_Declaration then
Back_End_Mode := Generate_Object;
-- In all other cases (specs which have bodies, generics, and bodies
-- where subunits are missing), we cannot generate code and we generate
-- a warning message. Note that generic instantiations are gone at this
-- stage since they have been replaced by their instances.
else
Back_End_Mode := Skip;
end if;
-- At this stage Call_Back_End is set to indicate if the backend should
-- be called to generate code. If it is not set, then code generation
-- has been turned off, even though code was requested by the original
-- command. This is not an error from the user point of view, but it is
-- an error from the point of view of the gcc driver, so we must exit
-- with an error status.
-- We generate an informative message (from the gcc point of view, it
-- is an error message, but from the users point of view this is not an
-- error, just a consequence of compiling something that cannot
-- generate code).
if Back_End_Mode = Skip then
Set_Standard_Error;
Write_Str ("cannot generate code for ");
Write_Str ("file ");
Write_Name (Unit_File_Name (Main_Unit));
if Subunits_Missing then
Write_Str (" (missing subunits)");
Write_Eol;
Write_Str ("to check parent unit");
elsif Main_Kind = N_Subunit then
Write_Str (" (subunit)");
Write_Eol;
Write_Str ("to check subunit");
elsif Main_Kind = N_Subprogram_Declaration then
Write_Str (" (subprogram spec)");
Write_Eol;
Write_Str ("to check subprogram spec");
-- Generic package body in GNAT implementation mode
elsif Main_Kind = N_Package_Body and then GNAT_Mode then
Write_Str (" (predefined generic)");
Write_Eol;
Write_Str ("to check predefined generic");
-- Only other case is a package spec
else
Write_Str (" (package spec)");
Write_Eol;
Write_Str ("to check package spec");
end if;
Write_Str (" for errors, use ");
if Hostparm.OpenVMS then
Write_Str ("/NOLOAD");
else
Write_Str ("-gnatc");
end if;
Write_Eol;
Set_Standard_Output;
Sem_Ch13.Validate_Unchecked_Conversions;
Sem_Ch13.Validate_Address_Clauses;
Errout.Finalize (Last_Call => True);
Errout.Output_Messages;
Treepr.Tree_Dump;
Tree_Gen;
Write_ALI (Object => False);
Namet.Finalize;
Check_Rep_Info;
-- Exit program with error indication, to kill object file
Exit_Program (E_No_Code);
end if;
-- In -gnatc mode, we only do annotation if -gnatt or -gnatR is also
-- set as indicated by Back_Annotate_Rep_Info being set to True.
-- We don't call for annotations on a subunit, because to process those
-- the back-end requires that the parent(s) be properly compiled.
-- Annotation is suppressed for targets where front-end layout is
-- enabled, because the front end determines representations.
-- Annotation is also suppressed in the case of compiling for
-- a VM, since representations are largely symbolic there.
if Back_End_Mode = Declarations_Only
and then (not Back_Annotate_Rep_Info
or else Main_Kind = N_Subunit
or else Targparm.Frontend_Layout_On_Target
or else Targparm.VM_Target /= No_VM)
then
Sem_Ch13.Validate_Unchecked_Conversions;
Sem_Ch13.Validate_Address_Clauses;
Errout.Finalize (Last_Call => True);
Errout.Output_Messages;
Write_ALI (Object => False);
Tree_Dump;
Tree_Gen;
Namet.Finalize;
Check_Rep_Info;
return;
end if;
-- Ensure that we properly register a dependency on system.ads, since
-- even if we do not semantically depend on this, Targparm has read
-- system parameters from the system.ads file.
Lib.Writ.Ensure_System_Dependency;
-- Add dependencies, if any, on preprocessing data file and on
-- preprocessing definition file(s).
Prepcomp.Add_Dependencies;
-- Back end needs to explicitly unlock tables it needs to touch
Atree.Lock;
Elists.Lock;
Fname.UF.Lock;
Inline.Lock;
Lib.Lock;
Nlists.Lock;
Sem.Lock;
Sinput.Lock;
Namet.Lock;
Stringt.Lock;
-- Here we call the back end to generate the output code
Generating_Code := True;
Back_End.Call_Back_End (Back_End_Mode);
-- Once the backend is complete, we unlock the names table. This call
-- allows a few extra entries, needed for example for the file name for
-- the library file output.
Namet.Unlock;
-- Validate unchecked conversions (using the values for size and
-- alignment annotated by the backend where possible).
Sem_Ch13.Validate_Unchecked_Conversions;
-- Validate address clauses (again using alignment values annotated
-- by the backend where possible).
Sem_Ch13.Validate_Address_Clauses;
-- Now we complete output of errors, rep info and the tree info. These
-- are delayed till now, since it is perfectly possible for gigi to
-- generate errors, modify the tree (in particular by setting flags
-- indicating that elaboration is required, and also to back annotate
-- representation information for List_Rep_Info.
Errout.Finalize (Last_Call => True);
Errout.Output_Messages;
List_Rep_Info;
-- Only write the library if the backend did not generate any error
-- messages. Otherwise signal errors to the driver program so that
-- there will be no attempt to generate an object file.
if Compilation_Errors then
Treepr.Tree_Dump;
Exit_Program (E_Errors);
end if;
Write_ALI (Object => (Back_End_Mode = Generate_Object));
-- Generate the ASIS tree after writing the ALI file, since in ASIS
-- mode, Write_ALI may in fact result in further tree decoration from
-- the original tree file. Note that we dump the tree just before
-- generating it, so that the dump will exactly reflect what is written
-- out.
Treepr.Tree_Dump;
Tree_Gen;
-- Finalize name table and we are all done
Namet.Finalize;
exception
-- Handle fatal internal compiler errors
when Rtsfind.RE_Not_Available =>
Comperr.Compiler_Abort ("RE_Not_Available");
when System.Assertions.Assert_Failure =>
Comperr.Compiler_Abort ("Assert_Failure");
when Constraint_Error =>
Comperr.Compiler_Abort ("Constraint_Error");
when Program_Error =>
Comperr.Compiler_Abort ("Program_Error");
when Storage_Error =>
-- Assume this is a bug. If it is real, the message will in any case
-- say Storage_Error, giving a strong hint!
Comperr.Compiler_Abort ("Storage_Error");
end;
<<End_Of_Program>>
null;
-- The outer exception handles an unrecoverable error
exception
when Unrecoverable_Error =>
Errout.Finalize (Last_Call => True);
Errout.Output_Messages;
Set_Standard_Error;
Write_Str ("compilation abandoned");
Write_Eol;
Set_Standard_Output;
Source_Dump;
Tree_Dump;
Exit_Program (E_Errors);
end Gnat1drv;
|