Skip to content

Commit 75caf25

Browse files
committed
Add default body for some subprograms
and that to those that have identity-like type: A -> A. The default body is exactly that identity. And their name starts with "system".
1 parent c3c74d5 commit 75caf25

File tree

3 files changed

+34
-2
lines changed

3 files changed

+34
-2
lines changed

gnat2goto/driver/goto_utils.adb

Lines changed: 19 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -153,6 +153,7 @@ package body GOTO_Utils is
153153

154154
procedure New_Subprogram_Symbol_Entry (Subprog_Name : Symbol_Id;
155155
Subprog_Type : Irep;
156+
Subprog_Body : Irep;
156157
A_Symbol_Table : in out Symbol_Table)
157158
is
158159
Subprog_Symbol : Symbol;
@@ -162,7 +163,7 @@ package body GOTO_Utils is
162163
Subprog_Symbol.PrettyName := Subprog_Name;
163164
Subprog_Symbol.SymType := Subprog_Type;
164165
Subprog_Symbol.Mode := Intern ("C");
165-
Subprog_Symbol.Value := Make_Nil (No_Location);
166+
Subprog_Symbol.Value := Subprog_Body;
166167

167168
A_Symbol_Table.Insert (Subprog_Name, Subprog_Symbol);
168169
end New_Subprogram_Symbol_Entry;
@@ -363,6 +364,23 @@ package body GOTO_Utils is
363364
A_Symbol_Table => A_Symbol_Table);
364365
end Build_Function;
365366

367+
function Build_Identity_Body (Parameters : Irep) return Irep
368+
is
369+
Parameter_List : constant Irep_List := Get_Parameter (Parameters);
370+
First_Cursor : constant List_Cursor := List_First (Parameter_List);
371+
Body_Block : constant Irep :=
372+
Make_Code_Block (Source_Location => No_Location,
373+
I_Type => Make_Nil_Type);
374+
begin
375+
pragma Assert (List_Has_Element (Parameter_List, First_Cursor));
376+
Append_Op (Body_Block,
377+
Make_Code_Return (Return_Value =>
378+
Param_Symbol (List_Element (Parameter_List, First_Cursor)),
379+
Source_Location => No_Location,
380+
I_Type => Make_Nil_Type));
381+
return Body_Block;
382+
end Build_Identity_Body;
383+
366384
function Build_Index_Constant (Value : Int; Source_Loc : Source_Ptr)
367385
return Irep
368386
is

gnat2goto/driver/goto_utils.ads

Lines changed: 7 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -63,8 +63,10 @@ package GOTO_Utils is
6363

6464
procedure New_Subprogram_Symbol_Entry (Subprog_Name : Symbol_Id;
6565
Subprog_Type : Irep;
66+
Subprog_Body : Irep;
6667
A_Symbol_Table : in out Symbol_Table)
67-
with Pre => Kind (Subprog_Type) = I_Code_Type;
68+
with Pre => Kind (Subprog_Type) = I_Code_Type
69+
and Kind (Subprog_Body) in I_Nil | I_Code_Block;
6870
-- Insert the subprogram specification into the symbol table
6971

7072
procedure New_Type_Symbol_Entry (Type_Name : Symbol_Id; Type_Of_Type : Irep;
@@ -116,6 +118,10 @@ package GOTO_Utils is
116118
and then Kind (Func_Params) = I_Parameter_List
117119
and then Kind (FBody) in Class_Code);
118120

121+
function Build_Identity_Body (Parameters : Irep) return Irep
122+
with Pre => Kind (Parameters) = I_Parameter_List,
123+
Post => Kind (Build_Identity_Body'Result) = I_Code_Block;
124+
119125
function Build_Array_Size (Array_Comp : Irep) return Irep
120126
with Pre => Kind (Array_Comp) in Class_Expr,
121127
Post => Kind (Build_Array_Size'Result) = I_Op_Add;

gnat2goto/driver/tree_walk.adb

Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -5458,9 +5458,17 @@ package body Tree_Walk is
54585458
Do_Subprogram_Specification (N);
54595459
Subprog_Name : constant Symbol_Id :=
54605460
Intern (Unique_Name (Defining_Unit_Name (N)));
5461+
Default_Body : Irep := Make_Nil (Sloc (N));
54615462
begin
5463+
if List_Length (Parameter_Specifications (N)) = 1 and
5464+
not (Kind (Get_Return_Type (Subprog_Type)) = I_Void_Type) and
5465+
Is_Prefix ("system", Unique_Name (Defining_Unit_Name (N)))
5466+
then
5467+
Default_Body := Build_Identity_Body (Get_Parameters (Subprog_Type));
5468+
end if;
54625469
New_Subprogram_Symbol_Entry (Subprog_Name => Subprog_Name,
54635470
Subprog_Type => Subprog_Type,
5471+
Subprog_Body => Default_Body,
54645472
A_Symbol_Table => Global_Symbol_Table);
54655473
end Register_Subprogram_Specification;
54665474

0 commit comments

Comments
 (0)