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 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;
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;
Main_Kind : Node_Kind;
Back_End_Mode : Back_End.Back_End_Mode_Type;
begin
begin
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;
declare
use Sinput;
S : Source_File_Index;
N : Name_Id;
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;
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));
Restrict.Restrictions := Targparm.Restrictions_On_Target;
end;
if Targparm.Configurable_Run_Time_On_Target or Debug_Flag_YY then
Configurable_Run_Time_Mode := True;
end if;
if Debug_Flag_AA then
Back_Annotate_Rep_Info := True;
List_Representation_Info := 1;
List_Representation_Info_Mechanisms := True;
end if;
if (Verbose_Mode or Full_List)
and then (not Debug_Flag_7)
then
Write_Eol;
Write_Str ("GNAT ");
Write_Str (Gnat_Version_String);
Write_Eol;
Write_Str ("Copyright 1992-2005 Free Software Foundation, Inc.");
Write_Eol;
end if;
if Debug_Flag_8 then
Ttypes.Bytes_Big_Endian := not Ttypes.Bytes_Big_Endian;
end if;
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;
if Targparm.ZCX_By_Default_On_Target then
if Targparm.GCC_ZCX_Support_On_Target then
Exception_Mechanism := Back_End_ZCX_Exceptions;
else
Exception_Mechanism := Front_End_ZCX_Exceptions;
end if;
end if;
if Opt.Zero_Cost_Exceptions_Set then
if Opt.Zero_Cost_Exceptions_Val = False then
Exception_Mechanism := Front_End_Setjmp_Longjmp_Exceptions;
elsif Debug_Flag_XX then
Exception_Mechanism := Front_End_ZCX_Exceptions;
elsif Targparm.GCC_ZCX_Support_On_Target then
Exception_Mechanism := Back_End_ZCX_Exceptions;
elsif Targparm.Front_End_ZCX_Support_On_Target then
Exception_Mechanism := Front_End_ZCX_Exceptions;
else
Osint.Fail
("Zero Cost Exceptions not supported on this target");
end if;
end if;
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;
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;
Main_Unit_Node := Cunit (Main_Unit);
Main_Kind := Nkind (Unit (Main_Unit_Node));
if Operating_Mode /= Check_Syntax
and then
((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
Bad_Body : declare
Sname : Unit_Name_Type := Unit_Name (Main_Unit);
Src_Ind : Source_File_Index;
Fname : File_Name_Type;
procedure Bad_Body_Error (Msg : String);
procedure Bad_Body_Error (Msg : String) is
begin
Error_Msg_N (Msg, Main_Unit_Node);
Error_Msg_Name_1 := Fname;
Error_Msg_N
("remove incorrect body in file{!", Main_Unit_Node);
end Bad_Body_Error;
begin
Sname := Unit_Name (Main_Unit);
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);
if Src_Ind /= No_Source_File
and then Get_Expected_Unit_Type (Fname) = Expect_Body
and then not Source_File_Is_Subunit (Src_Ind)
then
Error_Msg_Name_1 := Sname;
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_Name_1 := Fname;
Error_Msg_N
("body in file{?! will be ignored", Main_Unit_Node);
else
if Nkind (Original_Node (Unit (Main_Unit_Node)))
in N_Generic_Instantiation
then
Bad_Body_Error
("generic instantiation for % does not allow a body");
elsif Main_Kind in N_Renaming_Declaration then
Bad_Body_Error
("renaming declaration for % does not allow a body!");
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 Bad_Body;
end if;
if Compilation_Errors then
Treepr.Tree_Dump;
Sem_Ch13.Validate_Unchecked_Conversions;
Errout.Finalize;
Namet.Finalize;
if Opt.Force_ALI_Tree_File then
Write_ALI (Object => False);
Tree_Gen;
end if;
Exit_Program (E_Errors);
end if;
Set_Generate_Code (Main_Unit);
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;
if Original_Operating_Mode = Check_Syntax then
Treepr.Tree_Dump;
Errout.Finalize;
Tree_Gen;
Namet.Finalize;
Exit_Program (E_Success);
elsif Original_Operating_Mode = Check_Semantics then
Back_End_Mode := Declarations_Only;
elsif Operating_Mode /= Generate_Code then
Back_End_Mode := Skip;
elsif Main_Kind = N_Subprogram_Body
and then not Subunits_Missing
then
Back_End_Mode := Generate_Object;
elsif Main_Kind = N_Package_Body
and then not Subunits_Missing
then
Back_End_Mode := Generate_Object;
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;
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;
elsif Main_Kind = N_Package_Renaming_Declaration
or else Main_Kind = N_Subprogram_Renaming_Declaration
then
Back_End_Mode := Generate_Object;
elsif Main_Kind in N_Generic_Renaming_Declaration then
Back_End_Mode := Generate_Object;
else
Back_End_Mode := Skip;
end if;
if Back_End_Mode = Skip then
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");
elsif Main_Kind = N_Package_Body and then GNAT_Mode then
Write_Str (" (predefined generic)");
Write_Eol;
Write_Str ("to check predefined generic");
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;
Sem_Ch13.Validate_Unchecked_Conversions;
Errout.Finalize;
Treepr.Tree_Dump;
Tree_Gen;
Write_ALI (Object => False);
Namet.Finalize;
Exit_Program (E_No_Code);
end if;
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 Hostparm.Java_VM)
then
Sem_Ch13.Validate_Unchecked_Conversions;
Errout.Finalize;
Write_ALI (Object => False);
Tree_Dump;
Tree_Gen;
Namet.Finalize;
return;
end if;
Lib.Writ.Ensure_System_Dependency;
Prepcomp.Add_Dependencies;
Atree.Lock;
Elists.Lock;
Fname.UF.Lock;
Inline.Lock;
Lib.Lock;
Nlists.Lock;
Sem.Lock;
Sinput.Lock;
Namet.Lock;
Stringt.Lock;
Back_End.Call_Back_End (Back_End_Mode);
Namet.Unlock;
Sem_Ch13.Validate_Unchecked_Conversions;
Errout.Finalize;
List_Rep_Info;
if Compilation_Errors then
Treepr.Tree_Dump;
Exit_Program (E_Errors);
end if;
Write_ALI (Object => (Back_End_Mode = Generate_Object));
Treepr.Tree_Dump;
Tree_Gen;
Namet.Finalize;
exception
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 =>
Comperr.Compiler_Abort ("Storage_Error");
end;
exception
when Unrecoverable_Error =>
Errout.Finalize;
Set_Standard_Error;
Write_Str ("compilation abandoned");
Write_Eol;
Set_Standard_Output;
Source_Dump;
Tree_Dump;
Exit_Program (E_Errors);
end Gnat1drv;