diff --git a/gnat2goto/driver/driver.adb b/gnat2goto/driver/driver.adb index 7ad30a020..9a5cab1b6 100644 --- a/gnat2goto/driver/driver.adb +++ b/gnat2goto/driver/driver.adb @@ -89,9 +89,6 @@ package body Driver is procedure Translate_Compilation_Unit (GNAT_Root : Node_Id) is pragma Assert (Nkind (GNAT_Root) = N_Compilation_Unit); - Add_Start : Boolean; - Program_Symbol : constant Symbol := Do_Compilation_Unit (GNAT_Root, - Add_Start); Void_Type : constant Irep := New_Irep (I_Void_Type); @@ -103,7 +100,17 @@ package body Driver is Initial_Call : constant Irep := New_Irep (I_Code_Function_Call); Initial_Call_Args : constant Irep := New_Irep (I_Argument_List); + Add_Start : Boolean; + Program_Symbol : constant Symbol := Do_Compilation_Unit (GNAT_Root, + Add_Start); + + Sym_Tab_File : File_Type; + Base_Name : constant String := + File_Name_Without_Suffix + (Get_Name_String (Unit_File_Name (Main_Unit))); begin + Create (Sym_Tab_File, Out_File, Base_Name & ".json_symtab"); + -- Gather local symbols and put them in the symtab declare Local_Symbols : Symbol_Table; @@ -130,127 +137,122 @@ package body Driver is end; if not Add_Start then - Put_Line (Create (SymbolTable2Json (Global_Symbol_Table)).Write); - return; - end if; - - Initialize_CProver_Internal_Variables (Start_Body); - declare - Program_Expr : constant Irep := New_Irep (I_Symbol_Expr); - Program_Type : constant Irep := Program_Symbol.SymType; - Program_Return_Type : constant Irep := Get_Return_Type (Program_Type); - Program_Args : constant Irep_List := - Get_Parameter (Get_Parameters (Program_Type)); - begin - - -- Generate a simple _start function that calls the entry point + Put_Line (Sym_Tab_File, + Create (SymbolTable2Json (Global_Symbol_Table)).Write); + else + Initialize_CProver_Internal_Variables (Start_Body); declare - C : List_Cursor := List_First (Program_Args); + Program_Expr : constant Irep := New_Irep (I_Symbol_Expr); + Program_Type : constant Irep := Program_Symbol.SymType; + Program_Return_Type : constant Irep := + Get_Return_Type (Program_Type); + Program_Args : constant Irep_List := + Get_Parameter (Get_Parameters (Program_Type)); begin - while List_Has_Element (Program_Args, C) loop - -- For each argument, declare and nondet-initialise a parameter - -- local and add it to the call argument list. - declare - Arg : constant Irep := List_Element (Program_Args, C); - Arg_Type : constant Irep := Get_Type (Arg); - Arg_Id : constant Symbol_Id := - Intern ("input_" & Get_Identifier (Arg)); - Arg_Symbol : Symbol; - - Arg_Symbol_Expr : constant Irep := New_Irep (I_Symbol_Expr); - Arg_Decl : constant Irep := New_Irep (I_Code_Decl); - Arg_Nondet : constant Irep := - New_Irep (I_Side_Effect_Expr_Nondet); - Arg_Assign : constant Irep := New_Irep (I_Code_Assign); - - begin - Arg_Symbol.Name := Arg_Id; - Arg_Symbol.PrettyName := Arg_Id; - Arg_Symbol.BaseName := Arg_Id; - Arg_Symbol.Mode := Intern ("C"); - Arg_Symbol.SymType := Arg_Type; - Arg_Symbol.IsStateVar := True; - Arg_Symbol.IsLValue := True; - Arg_Symbol.IsAuxiliary := True; - Global_Symbol_Table.Insert (Arg_Id, Arg_Symbol); - - Set_Identifier (Arg_Symbol_Expr, Unintern (Arg_Id)); - Set_Type (Arg_Symbol_Expr, Arg_Type); - Set_Symbol (Arg_Decl, Arg_Symbol_Expr); - Append_Op (Start_Body, Arg_Decl); - - Set_Type (Arg_Nondet, Arg_Type); - Set_Lhs (Arg_Assign, Arg_Symbol_Expr); - Set_Rhs (Arg_Assign, Arg_Nondet); - - Append_Op (Start_Body, Arg_Assign); - - Append_Argument (Initial_Call_Args, Arg_Symbol_Expr); - end; - C := List_Next (Program_Args, C); - end loop; - end; - Set_Arguments (Initial_Call, Initial_Call_Args); - - -- Catch the call's return value if it has one - if Kind (Program_Return_Type) /= I_Empty then + -- Generate a simple _start function that calls the entry point declare - Return_Symbol : Symbol; - - Return_Expr : constant Irep := New_Irep (I_Symbol_Expr); - Return_Decl : constant Irep := New_Irep (I_Code_Decl); - Return_Id : constant Symbol_Id := Intern ("return'"); + C : List_Cursor := List_First (Program_Args); begin - Return_Symbol.Name := Return_Id; - Return_Symbol.BaseName := Return_Id; - Return_Symbol.PrettyName := Return_Id; - Return_Symbol.Mode := Intern ("C"); - Return_Symbol.SymType := Program_Return_Type; - Global_Symbol_Table.Insert (Return_Id, Return_Symbol); - - Set_Identifier (Return_Expr, Unintern (Return_Id)); - Set_Type (Return_Expr, Return_Symbol.SymType); - Set_Lhs (Initial_Call, Return_Expr); - Set_Symbol (Return_Decl, Return_Expr); - Append_Op (Start_Body, Return_Decl); + while List_Has_Element (Program_Args, C) loop + -- For each argument, declare and nondet-initialise a + -- parameter local and add it to the call argument list. + declare + Arg : constant Irep := + List_Element (Program_Args, C); + Arg_Type : constant Irep := Get_Type (Arg); + Arg_Id : constant Symbol_Id := + Intern ("input_" & Get_Identifier (Arg)); + Arg_Symbol : Symbol; + + Arg_Symbol_Expr : constant Irep := + New_Irep (I_Symbol_Expr); + Arg_Decl : constant Irep := + New_Irep (I_Code_Decl); + Arg_Nondet : constant Irep := + New_Irep (I_Side_Effect_Expr_Nondet); + Arg_Assign : constant Irep := + New_Irep (I_Code_Assign); + + begin + Arg_Symbol.Name := Arg_Id; + Arg_Symbol.PrettyName := Arg_Id; + Arg_Symbol.BaseName := Arg_Id; + Arg_Symbol.Mode := Intern ("C"); + Arg_Symbol.SymType := Arg_Type; + Arg_Symbol.IsStateVar := True; + Arg_Symbol.IsLValue := True; + Arg_Symbol.IsAuxiliary := True; + Global_Symbol_Table.Insert (Arg_Id, Arg_Symbol); + + Set_Identifier (Arg_Symbol_Expr, Unintern (Arg_Id)); + Set_Type (Arg_Symbol_Expr, Arg_Type); + + Set_Symbol (Arg_Decl, Arg_Symbol_Expr); + Append_Op (Start_Body, Arg_Decl); + + Set_Type (Arg_Nondet, Arg_Type); + Set_Lhs (Arg_Assign, Arg_Symbol_Expr); + Set_Rhs (Arg_Assign, Arg_Nondet); + + Append_Op (Start_Body, Arg_Assign); + + Append_Argument (Initial_Call_Args, Arg_Symbol_Expr); + end; + C := List_Next (Program_Args, C); + end loop; end; - end if; + Set_Arguments (Initial_Call, Initial_Call_Args); - Set_Identifier (Program_Expr, Unintern (Program_Symbol.Name)); - Set_Type (Program_Expr, Program_Symbol.SymType); + -- Catch the call's return value if it has one + if Kind (Program_Return_Type) /= I_Empty then + declare + Return_Symbol : Symbol; - Set_Function (Initial_Call, Program_Expr); - end; + Return_Expr : constant Irep := New_Irep (I_Symbol_Expr); + Return_Decl : constant Irep := New_Irep (I_Code_Decl); + Return_Id : constant Symbol_Id := Intern ("return'"); + begin + Return_Symbol.Name := Return_Id; + Return_Symbol.BaseName := Return_Id; + Return_Symbol.PrettyName := Return_Id; + Return_Symbol.Mode := Intern ("C"); + Return_Symbol.SymType := Program_Return_Type; + Global_Symbol_Table.Insert (Return_Id, Return_Symbol); + + Set_Identifier (Return_Expr, Unintern (Return_Id)); + Set_Type (Return_Expr, Return_Symbol.SymType); + Set_Lhs (Initial_Call, Return_Expr); + Set_Symbol (Return_Decl, Return_Expr); + Append_Op (Start_Body, Return_Decl); + end; + end if; - Append_Op (Start_Body, Initial_Call); + Set_Identifier (Program_Expr, Unintern (Program_Symbol.Name)); + Set_Type (Program_Expr, Program_Symbol.SymType); - Start_Symbol.Name := Start_Name; - Start_Symbol.PrettyName := Start_Name; - Start_Symbol.BaseName := Start_Name; + Set_Function (Initial_Call, Program_Expr); + end; - Set_Return_Type (Start_Type, Void_Type); + Append_Op (Start_Body, Initial_Call); - Start_Symbol.SymType := Start_Type; - Start_Symbol.Value := Start_Body; - Start_Symbol.Mode := Intern ("C"); + Start_Symbol.Name := Start_Name; + Start_Symbol.PrettyName := Start_Name; + Start_Symbol.BaseName := Start_Name; - Global_Symbol_Table.Insert (Start_Name, Start_Symbol); + Set_Return_Type (Start_Type, Void_Type); - declare - Sym_Tab_File : File_Type; - Base_Name : constant String := - File_Name_Without_Suffix - (Get_Name_String (Unit_File_Name (Main_Unit))); + Start_Symbol.SymType := Start_Type; + Start_Symbol.Value := Start_Body; + Start_Symbol.Mode := Intern ("C"); - begin - Create (Sym_Tab_File, Out_File, Base_Name & ".json_symtab"); + Global_Symbol_Table.Insert (Start_Name, Start_Symbol); Put_Line (Sym_Tab_File, Create (SymbolTable2Json (Global_Symbol_Table)).Write); + end if; - Close (Sym_Tab_File); - end; + Close (Sym_Tab_File); end Translate_Compilation_Unit; function Is_Back_End_Switch (Switch : String) return Boolean is diff --git a/gnat2goto/driver/tree_walk.adb b/gnat2goto/driver/tree_walk.adb index 2fb275258..3db31a4aa 100644 --- a/gnat2goto/driver/tree_walk.adb +++ b/gnat2goto/driver/tree_walk.adb @@ -1,6 +1,9 @@ +with Uname; use Uname; + with Einfo; use Einfo; with Namet; use Namet; with Nlists; use Nlists; +with Sem; with Sem_Util; use Sem_Util; with Sem_Aux; use Sem_Aux; with Snames; use Snames; @@ -167,14 +170,7 @@ package body Tree_Walk is procedure Do_Object_Declaration (N : Node_Id; Block : Irep) with Pre => Nkind (N) = N_Object_Declaration - and then Kind (Block) = I_Code_Block; - - procedure Do_Pragma (N : Node_Id; Block : Irep) - with Pre => Nkind (N) = N_Pragma - and then Kind (Block) = I_Code_Block; -- FIXME: what about decls? - - function Do_Op_Concat (N : Node_Id) return Irep - with Pre => Nkind (N) = N_Op_Concat; + and then Kind (Block) = I_Code_Block; function Do_Operator_Simple (N : Node_Id) return Irep with Pre => Nkind (N) in N_Op, @@ -183,10 +179,23 @@ package body Tree_Walk is function Do_Operator_General (N : Node_Id) return Irep with Pre => Nkind (N) in N_Op; + function Do_Op_Concat (N : Node_Id) return Irep + with Pre => Nkind (N) = N_Op_Concat; + + procedure Do_Package_Declaration (N : Node_Id) + with Pre => Nkind (N) = N_Package_Declaration; + + procedure Do_Package_Specification (N : Node_Id) + with Pre => Nkind (N) = N_Package_Specification; + + procedure Do_Pragma (N : Node_Id; Block : Irep) + with Pre => Nkind (N) = N_Pragma + and then Kind (Block) = I_Code_Block; -- FIXME: what about decls? + function Do_Procedure_Call_Statement (N : Node_Id) return Irep with Pre => Nkind (N) = N_Procedure_Call_Statement, Post => Kind (Do_Procedure_Call_Statement'Result) = - I_Code_Function_Call; + I_Code_Function_Call; function Do_Range_Constraint (N : Node_Id; Underlying : Irep) return Irep; @@ -255,6 +264,16 @@ package body Tree_Walk is Post => Kind (Do_Unconstrained_Array_Definition'Result) = I_Struct_Type; + procedure Do_Withed_Unit_Spec (N : Node_Id); + -- Enters the specification of the withed unit, N, into the symbol table + + procedure Do_Withed_Units_Specs is new Sem.Walk_Library_Items + (Action => Do_Withed_Unit_Spec); + -- Traverses tree applying the procedure Do_With_Unit_Spec to all nodes + -- which are specifications of library units withed by the GNAT_Root unit + -- (that is, the body being compiled). + -- It starts with the unit Standard and finishes with GNAT_Root + function Find_Record_Variant (Variant_Part : Node_Id; Actual_Disc : Node_Id) return Node_Id with Pre => Nkind (Variant_Part) = N_Variant_Part, @@ -331,13 +350,41 @@ package body Tree_Walk is Old_Type : Entity_Id; New_Type : Entity_Id) return Irep; + type Construct is (Declaration, Statement); + + procedure Warn_Unhandled_Construct (C : Construct; Mess : String); + + procedure Process_Declaration (N : Node_Id; Block : Irep); +-- with Pre => Nkind (N) in N_Declaration or else +-- Nkind (N) in N_Number_Declaration or else +-- Nkind (N) in N_Later_Decl_Item or else +-- Nkind (N) in N_Pragma or else +-- Nkind (N) in N_Exception_Declaration or else +-- Nkind (N) in N_Freeze_Entity; +-- Precondition commented out because full extend of declrations not yet known + -- Handles both a basic declaration and a declarative item. + + procedure Process_Declarations (L : List_Id; Block : Irep); + -- Processes the declarations and is used for both a package specification + -- where only basic declarations are allowed (no subprogram bodies etc.) + -- and declarative parts where such declaratios are allowed. + -- The Gnat front end will check that only allowed declarations are used + -- where only basic declarations permitted. + -- Process_Declarations is a procedure rather than a function like its + -- sister Process_Statements because the Irep (an I_Code_Block) has to be + -- extended in package_specifications when it has private declarations. + procedure Process_Statement (N : Node_Id; Block : Irep) with Pre => Kind (Block) = I_Code_Block; - -- Process statement or declaration + -- Process statement function Process_Statements (L : List_Id) return Irep with Post => Kind (Process_Statements'Result) = I_Code_Block; - -- Process list of statements or declarations + -- Process list of statements + + procedure Register_Subprogram_Specification (N : Node_Id) + with Pre => Nkind (N) in N_Subprogram_Specification; + -- Insert the subprogram specification into the symbol table procedure Remove_Entity_Substitution (E : Entity_Id); @@ -377,6 +424,7 @@ package body Tree_Walk is Report_Unhandled_Node_Empty (N, Fun_Name, Message); return I_Empty; end Report_Unhandled_Node_Kind; + ----------------------------- -- Add_Entity_Substitution -- ----------------------------- @@ -1103,24 +1151,26 @@ package body Tree_Walk is U : constant Node_Id := Unit (N); Unit_Symbol : Symbol; begin + -- Insert all all specifications of all withed units including the + -- specification of the given compilation unit into the symbol table. + Do_Withed_Units_Specs; + case Nkind (U) is when N_Subprogram_Body => declare - Unit_Type : constant Irep := - Do_Subprogram_Specification (Specification (U)); Unit_Name : constant Symbol_Id := Intern (Unique_Name (Unique_Defining_Entity (U))); begin - -- Register the symbol *before* we compile the body, for - -- recursive calls. - Unit_Symbol.Name := Unit_Name; - Unit_Symbol.PrettyName := Unit_Name; - Unit_Symbol.BaseName := Unit_Name; - Unit_Symbol.Mode := Intern ("C"); - Unit_Symbol.SymType := Unit_Type; - Global_Symbol_Table.Insert (Unit_Name, Unit_Symbol); - - Unit_Symbol.Value := Do_Subprogram_Or_Block (U); + -- The specification of the subprogram body has already + -- been inserted into the symbol table by the call to + -- Do_Withed_Unit_Specs. + pragma Assert (Global_Symbol_Table.Contains (Unit_Name)); + Unit_Symbol := Global_Symbol_Table (Unit_Name); + + -- Now compile the body of the subprogram + Unit_Symbol.Value := Do_Subprogram_Or_Block (U); + + -- and update the symbol table entry for this subprogram. Global_Symbol_Table.Replace (Unit_Name, Unit_Symbol); Add_Start := True; end; @@ -2106,106 +2156,6 @@ package body Tree_Walk is return Loop_Wrapper; end Do_Loop_Statement; - --------------- - -- Do_Pragma -- - --------------- - - procedure Do_Pragma (N : Node_Id; Block : Irep) is - - -------------------------------- - -- Do_Pragma_Assert_or_Assume -- - -------------------------------- - - -- Handle pragmas that result in a simple assert or assume statement in - -- the resulting goto program - procedure Do_Pragma_Assert_or_Assume - (N_Orig : Node_Id; Block : Irep); - - procedure Do_Pragma_Assert_or_Assume - (N_Orig : Node_Id; Block : Irep) - is - - Which : constant Pragma_Id := Get_Pragma_Id (N_Orig); - A_Irep : constant Irep := New_Irep - (if Which in Pragma_Assert | Pragma_Loop_Invariant - then I_Code_Assert else I_Code_Assume); - - -- To be set by iterator: - Check : Irep := Ireps.Empty; - - ---------------- - -- Handle_Arg -- - ---------------- - - procedure Handle_Arg - (Arg_Pos : Positive; Arg_Name : Name_Id; Expr : Node_Id); - - procedure Handle_Arg - (Arg_Pos : Positive; Arg_Name : Name_Id; Expr : Node_Id) is - begin - - if Arg_Name = Name_Check - or else (Arg_Name = No_Name and then Arg_Pos = 1) - then - Check := Do_Expression (Expr); - elsif Arg_Name = Name_Message - or else (Arg_Name = No_Name and then Arg_Pos = 2) - then - null; -- ignore, since assert irep has no msg - else - Report_Unhandled_Node_Empty (N, "Do_Pragma_Assert_or_Assume", - "Unknown arg name"); - end if; - end Handle_Arg; - - procedure Iterate_Args is new - Iterate_Pragma_Parameters (Handle_Arg => Handle_Arg); - - begin - Iterate_Args (N_Orig); - if Check = Ireps.Empty then - Report_Unhandled_Node_Empty (N, "Do_Pragma_Assert_or_Assume", - "Unassigned arg name"); - end if; - - if Which in Pragma_Assert | Pragma_Loop_Invariant then - Set_Assertion (A_Irep, Check); - else - Set_Assumption (A_Irep, Check); - end if; - Set_Source_Location (A_Irep, Sloc (N)); - Append_Op (Block, A_Irep); - end Do_Pragma_Assert_or_Assume; - - N_Orig : Node_Id; - - begin - if not Present (Original_Node (N)) then - Report_Unhandled_Node_Empty (N, "Do_Pragma", - "Original node not present"); - end if; - N_Orig := Original_Node (N); - if Pragma_Name (N_Orig) in Name_Assert | Name_Assume | - Name_Loop_Invariant - then - Do_Pragma_Assert_or_Assume (N_Orig, Block); - -- Ignore here. Rather look for those when we process a node. - elsif Pragma_Name (N_Orig) in Name_Annotate then - null; - -- The following pragmas are currently unimplemented, we ignore them - -- here - elsif Pragma_Name (N_Orig) in Name_SPARK_Mode | Name_Global | - Name_Postcondition | Name_Refined_State | Name_Refined_Global | - Name_Precondition - then - Report_Unhandled_Node_Empty (N, "Do_Pragma_Assert_or_Assume", - "Unsupported pragma"); - else - Report_Unhandled_Node_Empty (N, "Do_Pragma_Assert_or_Assume", - "Unknown"); - end if; - end Do_Pragma; - --------------------------- -- Do_Object_Declaration -- --------------------------- @@ -2891,6 +2841,131 @@ package body Tree_Walk is return Ret; end Do_Operator_Simple; + ---------------------------- + -- Do_Package_Declaration -- + ---------------------------- + + procedure Do_Package_Declaration (N : Node_Id) is + begin + Do_Package_Specification (Specification (N)); + end Do_Package_Declaration; + + ---------------------------- + -- Do_Package_Specification -- + ---------------------------- + + procedure Do_Package_Specification (N : Node_Id) is + Package_Decs : constant Irep := New_Irep (I_Code_Block); + begin + Set_Source_Location (Package_Decs, Sloc (N)); + if Present (Visible_Declarations (N)) then + Process_Declarations (Visible_Declarations (N), Package_Decs); + end if; + if Present (Private_Declarations (N)) then + Process_Declarations (Private_Declarations (N), Package_Decs); + end if; + end Do_Package_Specification; + + --------------- + -- Do_Pragma -- + --------------- + + procedure Do_Pragma (N : Node_Id; Block : Irep) is + + -------------------------------- + -- Do_Pragma_Assert_or_Assume -- + -------------------------------- + + -- Handle pragmas that result in a simple assert or assume statement in + -- the resulting goto program + procedure Do_Pragma_Assert_or_Assume + (N_Orig : Node_Id; Block : Irep); + + procedure Do_Pragma_Assert_or_Assume + (N_Orig : Node_Id; Block : Irep) + is + + Which : constant Pragma_Id := Get_Pragma_Id (N_Orig); + A_Irep : constant Irep := New_Irep + (if Which in Pragma_Assert | Pragma_Loop_Invariant + then I_Code_Assert else I_Code_Assume); + + -- To be set by iterator: + Check : Irep := Ireps.Empty; + + ---------------- + -- Handle_Arg -- + ---------------- + + procedure Handle_Arg + (Arg_Pos : Positive; Arg_Name : Name_Id; Expr : Node_Id); + + procedure Handle_Arg + (Arg_Pos : Positive; Arg_Name : Name_Id; Expr : Node_Id) is + begin + + if Arg_Name = Name_Check + or else (Arg_Name = No_Name and then Arg_Pos = 1) + then + Check := Do_Expression (Expr); + elsif Arg_Name = Name_Message + or else (Arg_Name = No_Name and then Arg_Pos = 2) + then + null; -- ignore, since assert irep has no msg + else + Report_Unhandled_Node_Empty (N, "Do_Pragma_Assert_or_Assume", + "Unknown arg name"); + end if; + end Handle_Arg; + + procedure Iterate_Args is new + Iterate_Pragma_Parameters (Handle_Arg => Handle_Arg); + + begin + Iterate_Args (N_Orig); + if Check = Ireps.Empty then + Report_Unhandled_Node_Empty (N, "Do_Pragma_Assert_or_Assume", + "Unassigned arg name"); + end if; + + if Which in Pragma_Assert | Pragma_Loop_Invariant then + Set_Assertion (A_Irep, Check); + else + Set_Assumption (A_Irep, Check); + end if; + Set_Source_Location (A_Irep, Sloc (N)); + Append_Op (Block, A_Irep); + end Do_Pragma_Assert_or_Assume; + + N_Orig : Node_Id; + + begin + if not Present (Original_Node (N)) then + Report_Unhandled_Node_Empty (N, "Do_Pragma", + "Original node not present"); + end if; + N_Orig := Original_Node (N); + if Pragma_Name (N_Orig) in Name_Assert | Name_Assume | + Name_Loop_Invariant + then + Do_Pragma_Assert_or_Assume (N_Orig, Block); + -- Ignore here. Rather look for those when we process a node. + elsif Pragma_Name (N_Orig) in Name_Annotate then + null; + -- The following pragmas are currently unimplemented, we ignore them + -- here + elsif Pragma_Name (N_Orig) in Name_SPARK_Mode | Name_Global | + Name_Postcondition | Name_Refined_State | Name_Refined_Global | + Name_Precondition + then + Report_Unhandled_Node_Empty (N, "Do_Pragma_Assert_or_Assume", + "Unsupported pragma"); + else + Report_Unhandled_Node_Empty (N, "Do_Pragma_Assert_or_Assume", + "Unknown"); + end if; + end Do_Pragma; + --------------------------------- -- Do_Procedure_Call_Statement -- --------------------------------- @@ -3334,27 +3409,22 @@ package body Tree_Walk is Proc_Symbol : Symbol; begin if not Global_Symbol_Table.Contains (Proc_Name) then - Put_Line (Standard_Error, "Warning: Subprogram " & - Unintern (Proc_Name) & " not in symbol table"); - declare - Proc_Type : constant Irep := - Do_Subprogram_Specification (Specification (N)); - New_Proc_Symbol : Symbol; - begin - New_Proc_Symbol.Name := Proc_Name; - New_Proc_Symbol.BaseName := Proc_Name; - New_Proc_Symbol.PrettyName := Proc_Name; - New_Proc_Symbol.SymType := Proc_Type; - New_Proc_Symbol.Mode := Intern ("C"); - - Global_Symbol_Table.Insert (Proc_Name, New_Proc_Symbol); - end; + -- A subprogram body does not have to have a separate declaration + -- so it may not be in the symbol table. + -- The subprogram specification of the subprogram body is used to + -- populate the symbol table instead. + Register_Subprogram_Specification (Specification (N)); end if; + -- Todo aspect_specification + -- Now the subprogram should registered in the stmbol table + -- whether a separate declaration was provided or not. if not Global_Symbol_Table.Contains (Proc_Name) then Report_Unhandled_Node_Empty (N, "Do_Subprogram_Body", "Proc name not in symbol table"); end if; Proc_Symbol := Global_Symbol_Table (Proc_Name); + + -- Compile the subprogram body and update its entry in the symbol table. Proc_Symbol.Value := Proc_Body; Global_Symbol_Table.Replace (Proc_Name, Proc_Symbol); end Do_Subprogram_Body; @@ -3364,23 +3434,9 @@ package body Tree_Walk is ------------------------------- procedure Do_Subprogram_Declaration (N : Node_Id) is - Proc_Type : constant Irep := - Do_Subprogram_Specification (Specification (N)); - - Proc_Name : constant Symbol_Id := Intern - (Unique_Name (Defining_Unit_Name (Specification (N)))); - -- take from spec, because body could be absent (null procedure) - - Proc_Symbol : Symbol; - begin - Proc_Symbol.Name := Proc_Name; - Proc_Symbol.BaseName := Proc_Name; - Proc_Symbol.PrettyName := Proc_Name; - Proc_Symbol.SymType := Proc_Type; - Proc_Symbol.Mode := Intern ("C"); - - Global_Symbol_Table.Insert (Proc_Name, Proc_Symbol); + Register_Subprogram_Specification (Specification (N)); + -- Todo Aspect specifications end Do_Subprogram_Declaration; ---------------------------- @@ -3390,18 +3446,18 @@ package body Tree_Walk is function Do_Subprogram_Or_Block (N : Node_Id) return Irep is Decls : constant List_Id := Declarations (N); HSS : constant Node_Id := Handled_Statement_Sequence (N); - Decls_Rep : Irep; + Reps : constant Irep := New_Irep (I_Code_Block); begin - Decls_Rep := (if Present (Decls) - then Process_Statements (Decls) - else New_Irep (I_Code_Block)); + if Present (Decls) then + Process_Declarations (Decls, Reps); + end if; - Set_Source_Location (Decls_Rep, Sloc (N)); + Set_Source_Location (Reps, Sloc (N)); if Present (HSS) then - Process_Statement (HSS, Decls_Rep); + Process_Statement (HSS, Reps); end if; - return Decls_Rep; + return Reps; end Do_Subprogram_Or_Block; -------------------------------- @@ -3660,6 +3716,54 @@ package body Tree_Walk is end Do_Unconstrained_Array_Definition; + ------------------------- + -- Do_Withed_Unit_Spec -- + ------------------------- + + procedure Do_Withed_Unit_Spec (N : Node_Id) is + Unit_Name : constant String := Get_Name_String (Get_Unit_Name (N)); + begin + if Defining_Entity (N) = Stand.Standard_Standard or else + Unit_Name = "system%s" + then + null; + -- At the moment Standard or System are not processed - to be done + else + + case Nkind (N) is + when N_Subprogram_Body => + if Acts_As_Spec (N) then + -- The unit is a withed library unit which subprogram body + -- that has no separate declaration, or, + -- it is the subprogram body of the compilation unit being + -- compiled and it has no separate declaration. + -- Obtain the subprogram specification from the body + -- and insert it into the symbol table. + Register_Subprogram_Specification (Specification (N)); + else + null; + end if; + when N_Subprogram_Declaration => + -- The unit is withed library unit that is a subprogram + -- declaration, or, + -- it is the declaration of the compilation unit body being + -- compiled. + -- Do_Subprogram_Declaration enters the specification of the + -- subprogram into the symbol table. + Do_Subprogram_Declaration (N); + when N_Package_Declaration => + Do_Package_Declaration (N); + when N_Package_Body => + null; + when others => + Put_Line (Standard_Error, + "This type of library_unit is not yet handled"); + end case; + + end if; + + end Do_Withed_Unit_Spec; + ------------------------- -- Find_Record_Variant -- ------------------------- @@ -4259,81 +4363,247 @@ package body Tree_Walk is end; end Maybe_Make_Typecast; + -------------------------------- + -- Warn_Unhandled_Construct -- + -------------------------------- + + procedure Warn_Unhandled_Construct (C : Construct; Mess : String) is + S : constant String := + (case C is + when Declaration => " declarations ", + when Statement => " statements ") & "unhandled"; + begin + Put_Line (Standard_Error, "Warning: " & Mess & S); + end Warn_Unhandled_Construct; + + -------------------------- + -- Process_Declaration -- + -------------------------- + + procedure Process_Declaration (N : Node_Id; Block : Irep) is + begin + -- Deal with the declaration + + case Nkind (N) is + + -- basic_declarations -- + + when N_Full_Type_Declaration => + Do_Full_Type_Declaration (N); + + when N_Subtype_Declaration => + Do_Subtype_Declaration (N); + + when N_Object_Declaration => + Do_Object_Declaration (N, Block); + + when N_Number_Declaration => + Warn_Unhandled_Construct (Declaration, "Number"); + + when N_Subprogram_Declaration => + Do_Subprogram_Declaration (N); + + when N_Abstract_Subprogram_Declaration => + Warn_Unhandled_Construct + (Declaration, "Abstract subprogram"); + + when N_Package_Declaration => + Warn_Unhandled_Construct (Declaration, "Package"); + + when N_Renaming_Declaration => + Warn_Unhandled_Construct (Declaration, "Renaming"); + + when N_Exception_Declaration => + Warn_Unhandled_Construct (Declaration, "Exception"); + + when N_Generic_Declaration => + Warn_Unhandled_Construct (Declaration, "Generic"); + + when N_Generic_Instantiation => + Warn_Unhandled_Construct (Declaration, "Generic instantiation"); + + -- basic_declarative_items -- + + when N_Representation_Clause => + Warn_Unhandled_Construct (Declaration, "Representation clause"); + + when N_Use_Package_Clause => + Warn_Unhandled_Construct (Declaration, "Use package clause"); + + when N_Use_Type_Clause => + Warn_Unhandled_Construct (Declaration, "Use type clause"); + + -- remaining declarative items -- + + -- proper_body -- + + when N_Subprogram_Body => + Do_Subprogram_Body (N); + + when N_Package_Body => + Warn_Unhandled_Construct (Declaration, "Package body"); + + when N_Task_Body => + Warn_Unhandled_Construct (Declaration, "Task body"); + + when N_Protected_Body => + Warn_Unhandled_Construct (Declaration, "Protected body"); + + -- body_stub -- + + when N_Subprogram_Body_Stub => + Warn_Unhandled_Construct (Declaration, "Subprogram body stub"); + + when N_Package_Body_Stub => + Warn_Unhandled_Construct (Declaration, "Package body stub"); + + when N_Task_Body_Stub => + Warn_Unhandled_Construct (Declaration, "Task body stub"); + + when N_Protected_Body_Stub => + Warn_Unhandled_Construct (Declaration, "Protected body stub"); + + -- Pragmas may appear in declarations -- + + when N_Pragma => + Warn_Unhandled_Construct (Declaration, "Pragmas in"); + + -- Every code lable is implicitly declared in -- + -- the closest surrounding block -- + + when N_Implicit_Label_Declaration => + -- Ignore for now, as I guess an implicit label can't be + -- referenced. + -- Yes it can: this is the declaration of the name it appears + -- the declaritve section but is used on a statement. + null; + + -- Not sure the nex two should be here -- + when N_Itype_Reference => + Do_Itype_Reference (N); + + when N_Freeze_Entity => + -- Ignore, nothing to generate + null; + + when others => + Report_Unhandled_Node_Empty (N, "Process_Declaration", + "Unknown declaration kind"); + + end case; + + end Process_Declaration; + + -------------------------- + -- Process_Declarations -- + -------------------------- + + procedure Process_Declarations (L : List_Id; Block : Irep) is + Decl : Node_Id := First (L); + begin + while Present (Decl) loop + Process_Declaration (Decl, Block); + Next (Decl); + end loop; + + end Process_Declarations; + ------------------------- -- Process_Statement -- ------------------------- procedure Process_Statement (N : Node_Id; Block : Irep) is - procedure Warn_Unhandled_Statement (M : String); - procedure Warn_Unhandled_Statement (M : String) is - begin - Put_Line (Standard_Error, "Warning: " & M & "statements unhandled"); - end Warn_Unhandled_Statement; begin -- Deal with the statement case Nkind (N) is + -- Simple statements -- + when N_Null_Statement => + null; + when N_Assignment_Statement => Append_Op (Block, Do_Assignment_Statement (N)); + when N_Exit_Statement => + Append_Op (Block, Do_Exit_Statement (N)); + + when N_Goto_Statement => + Warn_Unhandled_Construct (Statement, "goto"); + when N_Procedure_Call_Statement => Append_Op (Block, Do_Procedure_Call_Statement (N)); when N_Simple_Return_Statement => Append_Op (Block, Do_Simple_Return_Statement (N)); - when N_Object_Declaration => - Do_Object_Declaration (N, Block); + when N_Entry_Call_Statement => + Warn_Unhandled_Construct (Statement, "entry_call"); - when N_Handled_Sequence_Of_Statements => - Append_Op (Block, Do_Handled_Sequence_Of_Statements (N)); + when N_Requeue_Statement => + Warn_Unhandled_Construct (Statement, "requeue"); + + when N_Delay_Statement => + Warn_Unhandled_Construct (Statement, "delay"); + + when N_Abort_Statement => + Warn_Unhandled_Construct (Statement, "abort"); + + when N_Raise_Statement => + Warn_Unhandled_Construct (Statement, "raise"); + + when N_Code_Statement => + Warn_Unhandled_Construct (Statement, "code"); + + -- Compound statements when N_If_Statement => Append_Op (Block, Do_If_Statement (N)); - when N_Implicit_Label_Declaration => - -- Ignore for now, as I guess an implicit label can't be - -- referenced. - null; + when N_Case_Statement => + Warn_Unhandled_Construct (Statement, "case"); when N_Loop_Statement => Append_Op (Block, Do_Loop_Statement (N)); - when N_Full_Type_Declaration => - Do_Full_Type_Declaration (N); + when N_Block_Statement => + Warn_Unhandled_Construct (Statement, "block"); - when N_Subtype_Declaration => - Do_Subtype_Declaration (N); + when N_Handled_Sequence_Of_Statements => -- this seems incorrct + -- It should be block_statement + Append_Op (Block, Do_Handled_Sequence_Of_Statements (N)); - when N_Freeze_Entity => - -- Ignore, nothing to generate - null; + when N_Extended_Return_Statement => + Warn_Unhandled_Construct (Statement, "extended_return"); - when N_Itype_Reference => - Do_Itype_Reference (N); + when N_Accept_Statement => + Warn_Unhandled_Construct (Statement, "accept"); - when N_Subprogram_Declaration => - Do_Subprogram_Declaration (N); + -- Select statements -- - when N_Subprogram_Body => - Do_Subprogram_Body (N); + when N_Selective_Accept => + Warn_Unhandled_Construct (Statement, "selective_accept"); - when N_Null_Statement => - null; + when N_Timed_Entry_Call => + Warn_Unhandled_Construct (Statement, "timed_entry_call"); - when N_Exit_Statement => - Append_Op (Block, Do_Exit_Statement (N)); + when N_Conditional_Entry_Call => + Warn_Unhandled_Construct (Statement, "conditional_entry_call"); + + when N_Asynchronous_Select => + Warn_Unhandled_Construct (Statement, "asychronous select"); + + -- Pragmas may placed in sequences of statements -- when N_Pragma => Do_Pragma (N, Block); - when N_Raise_Statement => - Warn_Unhandled_Statement ("Raise"); - - when N_Number_Declaration => - Warn_Unhandled_Statement ("Number declaration"); + -- Not sure the nex two should be here - + -- should they be in declarations? -- +-- when N_Itype_Reference => +-- Do_Itype_Reference (N); - when N_Case_Statement => - Warn_Unhandled_Statement ("Case"); +-- when N_Freeze_Entity => +-- -- Ignore, nothing to generate +-- null; when others => Report_Unhandled_Node_Empty (N, "Process_Statement", @@ -4371,6 +4641,29 @@ package body Tree_Walk is return Reps; end Process_Statements; + --------------------------------------- + -- Register_Subprogram_Specification -- + --------------------------------------- + + procedure Register_Subprogram_Specification (N : Node_Id) is + Subprog_Type : constant Irep := + Do_Subprogram_Specification (N); + Subprog_Name : constant Symbol_Id := + Intern (Unique_Name (Defining_Unit_Name (N))); + + Subprog_Symbol : Symbol; + + begin + Subprog_Symbol.Name := Subprog_Name; + Subprog_Symbol.BaseName := Subprog_Name; + Subprog_Symbol.PrettyName := Subprog_Name; + Subprog_Symbol.SymType := Subprog_Type; + Subprog_Symbol.Mode := Intern ("C"); + Subprog_Symbol.Value := Make_Nil (Sloc (N)); + + Global_Symbol_Table.Insert (Subprog_Name, Subprog_Symbol); + end Register_Subprogram_Specification; + procedure Remove_Entity_Substitution (E : Entity_Id) is begin Identifier_Substitution_Map.Delete (E); diff --git a/testsuite/gnat2goto/tests/long_integer/test_long_integer.adb b/testsuite/gnat2goto/tests/long_integer/test_long_integer.adb index 795bb6ca0..c145999d6 100644 --- a/testsuite/gnat2goto/tests/long_integer/test_long_integer.adb +++ b/testsuite/gnat2goto/tests/long_integer/test_long_integer.adb @@ -1,4 +1,3 @@ -with Ada.Text_IO; procedure Test_Long_Integer is x: Long_Long_Integer := 1152921504606846976; begin