summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ortho/mcode/Makefile1
-rw-r--r--ortho/mcode/disa_x86.adb154
-rw-r--r--ortho/mcode/ortho_code-consts.adb50
-rw-r--r--ortho/mcode/ortho_code-consts.ads9
-rw-r--r--ortho/mcode/ortho_code-decls.adb60
-rw-r--r--ortho/mcode/ortho_code-decls.ads8
-rw-r--r--ortho/mcode/ortho_code-disps.adb26
-rw-r--r--ortho/mcode/ortho_code-disps.ads1
-rw-r--r--ortho/mcode/ortho_code-dwarf.adb4
-rw-r--r--ortho/mcode/ortho_code-exprs.adb98
-rw-r--r--ortho/mcode/ortho_code-exprs.ads19
-rw-r--r--ortho/mcode/ortho_code-types.adb228
-rw-r--r--ortho/mcode/ortho_code-types.ads30
-rw-r--r--ortho/mcode/ortho_code-x86-abi.adb11
-rw-r--r--ortho/mcode/ortho_code-x86-abi.ads5
-rw-r--r--ortho/mcode/ortho_code-x86-emits.adb39
-rw-r--r--ortho/mcode/ortho_code-x86-insns.adb131
-rw-r--r--ortho/mcode/ortho_code-x86.ads23
-rw-r--r--ortho/mcode/ortho_code_main.adb7
-rw-r--r--ortho/mcode/ortho_ident.adb14
-rw-r--r--ortho/mcode/ortho_ident.ads4
-rw-r--r--ortho/mcode/ortho_mcode.adb14
-rw-r--r--ortho/mcode/ortho_mcode.ads9
23 files changed, 681 insertions, 264 deletions
diff --git a/ortho/mcode/Makefile b/ortho/mcode/Makefile
index 182397a..3b5a596 100644
--- a/ortho/mcode/Makefile
+++ b/ortho/mcode/Makefile
@@ -1,5 +1,6 @@
ortho_srcdir=..
GNAT_FLAGS=-gnaty3befhkmr -gnata -gnatf -gnatwlcru
+CC=gcc
all: $(ortho_exec)
diff --git a/ortho/mcode/disa_x86.adb b/ortho/mcode/disa_x86.adb
index 0653ce7..1d2d485 100644
--- a/ortho/mcode/disa_x86.adb
+++ b/ortho/mcode/disa_x86.adb
@@ -27,68 +27,83 @@ package body Disa_X86 is
use Bv_Addr2acc;
type Cstring_Acc is access constant String;
- type Index_Type is new Natural;
- type Names_Type is array (Index_Type range <>) of Cstring_Acc;
- N_None : constant Index_Type := 0;
- N_Push : constant Index_Type := 1;
- N_Pop : constant Index_Type := 2;
- N_Ret : constant Index_Type := 3;
- N_Mov : constant Index_Type := 4;
- N_Add : constant Index_Type := 5;
- N_Or : constant Index_Type := 6;
- N_Adc : constant Index_Type := 7;
- N_Sbb : constant Index_Type := 8;
- N_And : constant Index_Type := 9;
- N_Sub : constant Index_Type := 10;
- N_Xor : constant Index_Type := 11;
- N_Cmp : constant Index_Type := 12;
- N_Into : constant Index_Type := 13;
- N_Jmp : constant Index_Type := 14;
- N_Jcc : constant Index_Type := 15;
- N_Setcc : constant Index_Type := 16;
- N_Call : constant Index_Type := 17;
- N_Int : constant Index_Type := 18;
- N_Cdq : constant Index_Type := 19;
- N_Imul : constant Index_Type := 20;
- N_Mul : constant Index_Type := 21;
- N_Leave : constant Index_Type := 22;
- N_Test : constant Index_Type := 23;
- N_Lea : constant Index_Type := 24;
- N_O : constant Index_Type := 25;
- N_No : constant Index_Type := 26;
- N_B : constant Index_Type := 27;
- N_AE : constant Index_Type := 28;
- N_E : constant Index_Type := 29;
- N_Ne : constant Index_Type := 30;
- N_Be : constant Index_Type := 31;
- N_A : constant Index_Type := 32;
- N_S : constant Index_Type := 33;
- N_Ns : constant Index_Type := 34;
- N_P : constant Index_Type := 35;
- N_Np : constant Index_Type := 36;
- N_L : constant Index_Type := 37;
- N_Ge : constant Index_Type := 38;
- N_Le : constant Index_Type := 39;
- N_G : constant Index_Type := 40;
- N_Not : constant Index_Type := 41;
- N_Neg : constant Index_Type := 42;
- N_Cbw : constant Index_Type := 43;
- N_Div : constant Index_Type := 44;
- N_Idiv : constant Index_Type := 45;
- N_Movsx : constant Index_Type := 46;
- N_Movzx : constant Index_Type := 47;
- N_Nop : constant Index_Type := 48;
- N_Hlt : constant Index_Type := 49;
- N_Inc : constant Index_Type := 50;
- N_Dec : constant Index_Type := 51;
- N_Rol : constant Index_Type := 52;
- N_Ror : constant Index_Type := 53;
- N_Rcl : constant Index_Type := 54;
- N_Rcr : constant Index_Type := 55;
- N_Shl : constant Index_Type := 56;
- N_Shr : constant Index_Type := 57;
- N_Sar : constant Index_Type := 58;
+ type Index_Type is
+ (
+ N_None,
+ N_Push,
+ N_Pop,
+ N_Ret,
+ N_Mov,
+ N_Add,
+ N_Or,
+ N_Adc,
+ N_Sbb,
+ N_And,
+ N_Sub,
+ N_Xor,
+ N_Cmp,
+ N_Into,
+ N_Jmp,
+ N_Jcc,
+ N_Setcc,
+ N_Call,
+ N_Int,
+ N_Cdq,
+ N_Imul,
+ N_Mul,
+ N_Leave,
+ N_Test,
+ N_Lea,
+ N_O,
+ N_No,
+ N_B,
+ N_AE,
+ N_E,
+ N_Ne,
+ N_Be,
+ N_A,
+ N_S,
+ N_Ns,
+ N_P,
+ N_Np,
+ N_L,
+ N_Ge,
+ N_Le,
+ N_G,
+ N_Not,
+ N_Neg,
+ N_Cbw,
+ N_Div,
+ N_Idiv,
+ N_Movsx,
+ N_Movzx,
+ N_Nop,
+ N_Hlt,
+ N_Inc,
+ N_Dec,
+ N_Rol,
+ N_Ror,
+ N_Rcl,
+ N_Rcr,
+ N_Shl,
+ N_Shr,
+ N_Sar,
+ N_Fadd,
+ N_Fmul,
+ N_Fcom,
+ N_Fcomp,
+ N_Fsub,
+ N_Fsubr,
+ N_Fdiv,
+ N_Fdivr,
+
+ G_1,
+ G_2,
+ G_3,
+ G_5
+ );
+ type Names_Type is array (Index_Type range <>) of Cstring_Acc;
subtype S is String;
Names : constant Names_Type :=
(N_None => new S'("none"),
@@ -149,14 +164,18 @@ package body Disa_X86 is
N_Rcr => new S'("rcr"),
N_Shl => new S'("shl"),
N_Shr => new S'("shr"),
- N_Sar => new S'("sar")
+ N_Sar => new S'("sar"),
+ N_Fadd => new S'("fadd"),
+ N_Fmul => new S'("fmul"),
+ N_Fcom => new S'("fcom"),
+ N_Fcomp => new S'("fcomp"),
+ N_Fsub => new S'("fsub"),
+ N_Fsubr => new S'("fsubr"),
+ N_Fdiv => new S'("fdiv"),
+ N_Fdivr => new S'("fdivr")
);
- G_1 : constant Index_Type := 128;
- G_2 : constant Index_Type := 129;
- G_3 : constant Index_Type := 130;
- G_5 : constant Index_Type := 131;
-- Format of an instruction.
-- MODRM_SRC_8 : modrm byte follow, and modrm is source, witdh = 8bits
@@ -545,7 +564,8 @@ package body Disa_X86 is
L : constant Natural := Lo;
begin
Add_Name (Name);
- Add_Name (N_O + Byte'Pos (B and 16#0f#));
+ Add_Name (Index_Type'Val (Index_Type'Pos (N_O)
+ + Byte'Pos (B and 16#0f#)));
Name_Align (L);
end Add_Cond_Opcode;
diff --git a/ortho/mcode/ortho_code-consts.adb b/ortho/mcode/ortho_code-consts.adb
index 2d3535d..dcd7d28 100644
--- a/ortho/mcode/ortho_code-consts.adb
+++ b/ortho/mcode/ortho_code-consts.adb
@@ -59,6 +59,11 @@ package body Ortho_Code.Consts is
Pad : Int32;
end record;
+ type Cnode_Union is record
+ El : O_Cnode;
+ Field : O_Fnode;
+ end record;
+
package Cnodes is new GNAT.Table
(Table_Component_Type => Cnode_Common,
Table_Index_Type => O_Cnode,
@@ -92,6 +97,14 @@ package body Ortho_Code.Consts is
return To_Cnode_Signed (Cnodes.Table (Cst + 1)).Val;
end Get_Const_I64;
+ function Get_Const_F64 (Cst : O_Cnode) return IEEE_Float_64
+ is
+ function To_Cnode_Float is new Ada.Unchecked_Conversion
+ (Cnode_Common, Cnode_Float);
+ begin
+ return To_Cnode_Float (Cnodes.Table (Cst + 1)).Val;
+ end Get_Const_F64;
+
function To_Cnode_Common is new Ada.Unchecked_Conversion
(Source => Cnode_Signed, Target => Cnode_Common);
@@ -172,13 +185,13 @@ package body Ortho_Code.Consts is
return To_Int32 (Uns32 (Shift_Right (V, 32) and 16#Ffff_Ffff#));
end Get_Const_High;
- function To_Cnode_Common is new Ada.Unchecked_Conversion
- (Source => Cnode_Float, Target => Cnode_Common);
-
function New_Float_Literal (Ltype : O_Tnode; Value : IEEE_Float_64)
return O_Cnode
is
Res : O_Cnode;
+
+ function To_Cnode_Common is new Ada.Unchecked_Conversion
+ (Source => Cnode_Float, Target => Cnode_Common);
begin
Cnodes.Append (Cnode_Common'(Kind => OC_Float,
Lit_Type => Ltype));
@@ -384,12 +397,36 @@ package body Ortho_Code.Consts is
function New_Union_Aggr (Atype : O_Tnode; Field : O_Fnode; Value : O_Cnode)
return O_Cnode
is
- pragma Unreferenced (Atype);
- pragma Unreferenced (Field);
+ function To_Cnode_Common is new Ada.Unchecked_Conversion
+ (Source => Cnode_Union, Target => Cnode_Common);
+
+ Res : O_Cnode;
begin
- return Value;
+ if Debug.Flag_Debug_Hli then
+ Cnodes.Append (Cnode_Common'(Kind => OC_Union,
+ Lit_Type => Atype));
+ Res := Cnodes.Last;
+ Cnodes.Append (To_Cnode_Common (Cnode_Union'(El => Value,
+ Field => Field)));
+ return Res;
+ else
+ return Value;
+ end if;
end New_Union_Aggr;
+ function To_Cnode_Union is new Ada.Unchecked_Conversion
+ (Source => Cnode_Common, Target => Cnode_Union);
+
+ function Get_Const_Union_Field (Cst : O_Cnode) return O_Fnode is
+ begin
+ return To_Cnode_Union (Cnodes.Table (Cst + 1)).Field;
+ end Get_Const_Union_Field;
+
+ function Get_Const_Union_Value (Cst : O_Cnode) return O_Cnode is
+ begin
+ return To_Cnode_Union (Cnodes.Table (Cst + 1)).El;
+ end Get_Const_Union_Value;
+
function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode
is
function To_Cnode_Common is new Ada.Unchecked_Conversion
@@ -440,6 +477,7 @@ package body Ortho_Code.Consts is
L := To_Cnode_Enum (Cnodes.Table (Cst + 1)).Val;
when OC_Array
| OC_Record
+ | OC_Union
| OC_Sizeof
| OC_Address
| OC_Subprg_Address =>
diff --git a/ortho/mcode/ortho_code-consts.ads b/ortho/mcode/ortho_code-consts.ads
index d83b916..a97c93e 100644
--- a/ortho/mcode/ortho_code-consts.ads
+++ b/ortho/mcode/ortho_code-consts.ads
@@ -19,7 +19,8 @@ with Interfaces; use Interfaces;
package Ortho_Code.Consts is
type OC_Kind is (OC_Signed, OC_Unsigned, OC_Float, OC_Lit, OC_Null,
- OC_Array, OC_Record, OC_Subprg_Address, OC_Address,
+ OC_Array, OC_Record, OC_Union,
+ OC_Subprg_Address, OC_Address,
OC_Sizeof);
function Get_Const_Kind (Cst : O_Cnode) return OC_Kind;
@@ -36,6 +37,8 @@ package Ortho_Code.Consts is
function Get_Const_U64 (Cst : O_Cnode) return Unsigned_64;
function Get_Const_I64 (Cst : O_Cnode) return Integer_64;
+ function Get_Const_F64 (Cst : O_Cnode) return IEEE_Float_64;
+
-- Get the low and high part of a constant.
function Get_Const_Low (Cst : O_Cnode) return Uns32;
function Get_Const_High (Cst : O_Cnode) return Uns32;
@@ -46,6 +49,10 @@ package Ortho_Code.Consts is
function Get_Const_Aggr_Length (Cst : O_Cnode) return Int32;
function Get_Const_Aggr_Element (Cst : O_Cnode; N : Int32) return O_Cnode;
+ -- Only available in HLI.
+ function Get_Const_Union_Field (Cst : O_Cnode) return O_Fnode;
+ function Get_Const_Union_Value (Cst : O_Cnode) return O_Cnode;
+
-- Declaration for an address.
function Get_Const_Decl (Cst : O_Cnode) return O_Dnode;
diff --git a/ortho/mcode/ortho_code-decls.adb b/ortho/mcode/ortho_code-decls.adb
index 741d2cc..fcbf0b0 100644
--- a/ortho/mcode/ortho_code-decls.adb
+++ b/ortho/mcode/ortho_code-decls.adb
@@ -70,6 +70,10 @@ package body Ortho_Code.Decls is
-- For const: the value.
-- For subprg: size of pushed arguments.
Info2 : Int32;
+ when OD_Subprg_Ext =>
+ -- Chain of interfaces.
+ Subprg_Inter : O_Dnode;
+
when OD_Block =>
-- Last declaration of this block.
Last : O_Dnode;
@@ -94,6 +98,8 @@ package body Ortho_Code.Decls is
end case;
end record;
+ Use_Subprg_Ext : constant Boolean := False;
+
pragma Pack (Dnode_Common);
package Dnodes is new GNAT.Table
@@ -154,6 +160,13 @@ package body Ortho_Code.Decls is
return Get_Block_Last (Decl) + 1;
when OD_Body =>
return Get_Block_Last (Decl + 1) + 1;
+ when OD_Function
+ | OD_Procedure =>
+ if Use_Subprg_Ext then
+ return Decl + 2;
+ else
+ return Decl + 1;
+ end if;
when others =>
return Decl + 1;
end case;
@@ -231,8 +244,14 @@ package body Ortho_Code.Decls is
function Get_Subprg_Interfaces (Decl : O_Dnode) return O_Dnode
is
- Res : constant O_Dnode := Decl + 1;
+ Res : O_Dnode;
begin
+ if Use_Subprg_Ext then
+ Res := Decl + 2;
+ else
+ Res := Decl + 1;
+ end if;
+
if Get_Decl_Kind (Res) = OD_Interface then
return Res;
else
@@ -384,24 +403,15 @@ package body Ortho_Code.Decls is
Static_Chain_Id := Ortho_Ident.Get_Identifier ("STATIC_CHAIN");
end if;
- Dnodes.Append (Dnode_Common'(Kind => OD_Interface,
- Storage => O_Storage_Local,
- Depth => Cur_Depth + 1,
- Reg => R_Nil,
- Id => Static_Chain_Id,
- Dtype => O_Tnode_Ptr,
- Ref => 0,
- Info2 => 0,
- others => False));
- Res := Dnodes.Last;
- New_Interface (Res, Interfaces.Abi);
+ New_Interface_Decl (Interfaces, Res, Static_Chain_Id, O_Tnode_Ptr);
end Add_Static_Chain;
procedure Start_Subprogram_Decl (Interfaces : out O_Inter_List)
is
Storage : O_Storage;
+ Decl : constant O_Dnode := Dnodes.Last;
begin
- Storage := Get_Decl_Storage (Dnodes.Last);
+ Storage := Get_Decl_Storage (Decl);
if Cur_Depth /= O_Toplevel then
case Storage is
when O_Storage_External
@@ -411,11 +421,20 @@ package body Ortho_Code.Decls is
raise Syntax_Error;
when O_Storage_Private =>
Storage := O_Storage_Local;
- Set_Decl_Storage (Dnodes.Last, Storage);
+ Set_Decl_Storage (Decl, Storage);
end case;
end if;
- Start_Subprogram (Dnodes.Last, Interfaces.Abi);
- Interfaces.Decl := Dnodes.Last;
+ if Use_Subprg_Ext then
+ Dnodes.Append (Dnode_Common'(Kind => OD_Subprg_Ext,
+ Storage => Storage,
+ Depth => Cur_Depth,
+ Reg => R_Nil,
+ Subprg_Inter => O_Dnode_Null,
+ others => False));
+ end if;
+
+ Start_Subprogram (Decl, Interfaces.Abi);
+ Interfaces.Decl := Decl;
if Storage = O_Storage_Local then
Add_Static_Chain (Interfaces);
end if;
@@ -674,6 +693,8 @@ package body Ortho_Code.Decls is
when OD_Block =>
Put ("block until ");
Put (Int32 (Get_Block_Last (Decl)), 0);
+ when OD_Subprg_Ext =>
+ Put ("Subprg_Ext");
-- when others =>
-- Put (OD_Kind'Image (Get_Decl_Kind (Decl)));
end case;
@@ -727,6 +748,13 @@ package body Ortho_Code.Decls is
Disp_Decls (1, Dnodes.First, Dnodes.Last);
end Disp_All_Decls;
+ procedure Debug_Decl (Decl : O_Dnode) is
+ begin
+ Disp_Decl (1, Decl);
+ end Debug_Decl;
+
+ pragma Unreferenced (Debug_Decl);
+
procedure Disp_Stats
is
use Ada.Text_IO;
diff --git a/ortho/mcode/ortho_code-decls.ads b/ortho/mcode/ortho_code-decls.ads
index 1c8b451..ad18892 100644
--- a/ortho/mcode/ortho_code-decls.ads
+++ b/ortho/mcode/ortho_code-decls.ads
@@ -21,8 +21,16 @@ package Ortho_Code.Decls is
-- Kind of a declaration.
type OD_Kind is (OD_Type,
OD_Const, OD_Const_Val,
+
+ -- Global and local variables.
OD_Var, OD_Local,
+
+ -- Subprograms.
OD_Function, OD_Procedure,
+
+ -- Additional node for a subprogram. Internal use only.
+ OD_Subprg_Ext,
+
OD_Interface,
OD_Body,
OD_Block);
diff --git a/ortho/mcode/ortho_code-disps.adb b/ortho/mcode/ortho_code-disps.adb
index 2f29414..9e8ac12 100644
--- a/ortho/mcode/ortho_code-disps.adb
+++ b/ortho/mcode/ortho_code-disps.adb
@@ -27,7 +27,6 @@ with Interfaces;
package body Ortho_Code.Disps is
procedure Disp_Subprg (Ident : Natural; S_Entry : O_Enode);
procedure Disp_Expr (Expr : O_Enode);
- procedure Disp_Type (Atype : O_Tnode; Force : Boolean := False);
procedure Disp_Indent (Indent : Natural)
is
@@ -180,6 +179,13 @@ package body Ortho_Code.Disps is
end loop;
Put ('}');
end;
+ when OC_Union =>
+ Put ('{');
+ Put ('.');
+ Disp_Ident (Types.Get_Field_Ident (Get_Const_Union_Field (Lit)));
+ Put ('=');
+ Disp_Lit (Get_Const_Union_Value (Lit));
+ Put ('}');
when others =>
Put ("*lit " & OC_Kind'Image (Get_Const_Kind (Lit)) & '*');
end case;
@@ -432,6 +438,9 @@ package body Ortho_Code.Disps is
end loop;
Put ('}');
end;
+ when OT_Complete =>
+ Put ("-- complete: ");
+ Disp_Type (Get_Type_Complete_Type (Atype));
end case;
end Disp_Type;
@@ -544,7 +553,7 @@ package body Ortho_Code.Disps is
-- Disp_Decl_Name (Get_Body_Decl (Decl));
New_Line;
Disp_Subprg (Indent, Get_Body_Stmt (Decl));
- when OD_Block =>
+ when OD_Block | OD_Subprg_Ext =>
null;
end case;
if Nl then
@@ -587,7 +596,7 @@ package body Ortho_Code.Disps is
Put_Line ("end;");
when OE_Line =>
Disp_Indent (Indent);
- Put_Line ("#line" & Int32'Image (Get_Expr_Line_Number (Stmt)));
+ Put_Line ("--#" & Int32'Image (Get_Expr_Line_Number (Stmt)));
when OE_BB =>
Disp_Indent (Indent);
Put_Line ("# BB" & Int32'Image (Get_BB_Number (Stmt)));
@@ -648,16 +657,9 @@ package body Ortho_Code.Disps is
Put (" then");
New_Line;
Indent := Indent + 1;
- when OE_Elsif =>
+ when OE_Else =>
Disp_Indent (Indent - 1);
- Expr := Get_Expr_Operand (Stmt);
- if Expr /= O_Enode_Null then
- Put ("elsif ");
- Disp_Expr (Expr);
- Put (" then");
- else
- Put ("else");
- end if;
+ Put ("else");
New_Line;
when OE_Endif =>
Indent := Indent - 1;
diff --git a/ortho/mcode/ortho_code-disps.ads b/ortho/mcode/ortho_code-disps.ads
index fdd648f..5ae4d86 100644
--- a/ortho/mcode/ortho_code-disps.ads
+++ b/ortho/mcode/ortho_code-disps.ads
@@ -19,6 +19,7 @@ with Ortho_Code.Exprs; use Ortho_Code.Exprs;
package Ortho_Code.Disps is
procedure Disp_Subprg (Subprg : Subprogram_Data_Acc);
+ procedure Disp_Type (Atype : O_Tnode; Force : Boolean := False);
procedure Init;
procedure Finish;
end Ortho_Code.Disps;
diff --git a/ortho/mcode/ortho_code-dwarf.adb b/ortho/mcode/ortho_code-dwarf.adb
index 6816199..a82d635 100644
--- a/ortho/mcode/ortho_code-dwarf.adb
+++ b/ortho/mcode/ortho_code-dwarf.adb
@@ -1012,6 +1012,8 @@ package body Ortho_Code.Dwarf is
Nbr := Nbr - 1;
end loop;
end;
+ when OT_Complete =>
+ null;
end case;
Set_Current_Section (Info_Sect);
@@ -1039,6 +1041,8 @@ package body Ortho_Code.Dwarf is
when OT_Enum
| OT_Boolean =>
Emit_Enum_Type (Atype, Decl);
+ when OT_Complete =>
+ null;
end case;
end Emit_Type;
diff --git a/ortho/mcode/ortho_code-exprs.adb b/ortho/mcode/ortho_code-exprs.adb
index e47c75e..a98facf 100644
--- a/ortho/mcode/ortho_code-exprs.adb
+++ b/ortho/mcode/ortho_code-exprs.adb
@@ -22,7 +22,7 @@ with Ortho_Code.Types; use Ortho_Code.Types;
with Ortho_Code.Consts; use Ortho_Code.Consts;
with Ortho_Code.Decls; use Ortho_Code.Decls;
with Ortho_Code.Debug; use Ortho_Code.Debug;
-with Ortho_Code.Abi;
+with Ortho_Code.Abi; use Ortho_Code.Abi;
with Ortho_Code.Disps;
with Ortho_Code.Opts;
with Ortho_Code.Flags;
@@ -263,6 +263,16 @@ package body Ortho_Code.Exprs is
return Int32 (Enodes.Table (Stmt).Arg2);
end Get_BB_Number;
+ function Get_Loop_Level (Stmt : O_Enode) return Int32 is
+ begin
+ return Int32 (Enodes.Table (Stmt).Arg1);
+ end Get_Loop_Level;
+
+ procedure Set_Loop_Level (Stmt : O_Enode; Level : Int32) is
+ begin
+ Enodes.Table (Stmt).Arg1 := O_Enode (Level);
+ end Set_Loop_Level;
+
procedure Set_Case_Branch (C : O_Enode; Branch : O_Enode) is
begin
Enodes.Table (C).Arg2 := Branch;
@@ -698,6 +708,7 @@ package body Ortho_Code.Exprs is
O_Enode (Get_Const_Decl (Lit)), O_Enode_Null);
when OC_Array
| OC_Record
+ | OC_Union
| OC_Sizeof =>
raise Syntax_Error;
end case;
@@ -717,8 +728,10 @@ package body Ortho_Code.Exprs is
Subprg := Cur_Subprg;
Res := O_Enode_Null;
loop
+ -- The static chain is the first interface of the subprogram.
Res := New_Enode (OE_Addrl, Abi.Mode_Ptr, O_Tnode_Ptr,
- O_Enode (Subprg.D_Decl + 1), Res);
+ O_Enode (Get_Subprg_Interfaces (Subprg.D_Decl)),
+ Res);
Res := New_Enode (OE_Indir, O_Tnode_Ptr, Res, O_Enode_Null);
Cur_Depth := Cur_Depth - 1;
if Cur_Depth = Depth then
@@ -1047,6 +1060,7 @@ package body Ortho_Code.Exprs is
is
Save_Var : O_Dnode;
Stmt : O_Enode;
+ St_Type : O_Tnode;
begin
if Flag_Debug_Assert then
Check_Ref (Size);
@@ -1060,11 +1074,16 @@ package body Ortho_Code.Exprs is
if not Get_Block_Has_Alloca (Cur_Block) then
Set_Block_Has_Alloca (Cur_Block, True);
+ if Stack_Ptr_Type /= O_Tnode_Null then
+ St_Type := Stack_Ptr_Type;
+ else
+ St_Type := Rtype;
+ end if;
-- Add a decl.
- New_Var_Decl (Save_Var, O_Ident_Nul, O_Storage_Local, Rtype);
+ New_Var_Decl (Save_Var, O_Ident_Nul, O_Storage_Local, St_Type);
-- Add insn to save stack ptr.
- Stmt := New_Enode (OE_Asgn, Rtype,
- New_Stack (Rtype),
+ Stmt := New_Enode (OE_Asgn, St_Type,
+ New_Stack (St_Type),
O_Enode (New_Obj (Save_Var)));
if Cur_Block = Last_Stmt then
Set_Stmt_Link (Last_Stmt, Stmt);
@@ -1212,7 +1231,7 @@ package body Ortho_Code.Exprs is
New_Enode_Stmt (OE_Ret, Get_Type_Mode (V_Type), Value, O_Enode_Null);
if not Flag_Debug_Hli then
- New_Allocb_Jump (Cur_Subprg.Exit_Label);
+ Emit_Jmp (OE_Jump, O_Enode_Null, Cur_Subprg.Exit_Label);
end if;
end New_Return_Stmt;
@@ -1225,7 +1244,7 @@ package body Ortho_Code.Exprs is
end if;
if not Flag_Debug_Hli then
- New_Allocb_Jump (Cur_Subprg.Exit_Label);
+ Emit_Jmp (OE_Jump, O_Enode_Null, Cur_Subprg.Exit_Label);
else
New_Enode_Stmt (OE_Ret, Mode_Nil, O_Enode_Null, O_Enode_Null);
end if;
@@ -1242,7 +1261,7 @@ package body Ortho_Code.Exprs is
Check_Ref (Cond);
end if;
- if Flag_Debug_Hli then
+ if not Flag_Lower_Stmt then
New_Enode_Stmt (OE_If, Cond, O_Enode_Null);
Block := (Label_End => O_Enode_Null,
Label_Next => Last_Stmt);
@@ -1254,36 +1273,10 @@ package body Ortho_Code.Exprs is
end if;
end Start_If_Stmt;
- procedure New_Elsif_Stmt (Block : in out O_If_Block; Cond : O_Enode) is
- begin
- if Flag_Debug_Assert then
- if Get_Expr_Mode (Cond) /= Mode_B2 then
- -- COND must be a boolean.
- raise Syntax_Error;
- end if;
- Check_Ref (Cond);
- end if;
-
- if Flag_Debug_Hli then
- New_Enode_Stmt (OE_Elsif, Cond, O_Enode_Null);
- Block.Label_Next := Last_Stmt;
- else
- if Block.Label_End = O_Enode_Null then
- Block.Label_End := New_Label;
- end if;
- Emit_Jmp (OE_Jump, O_Enode_Null, Block.Label_End);
- Start_BB;
- Link_Stmt (Block.Label_Next);
- Block.Label_Next := New_Label;
- Emit_Jmp (OE_Jump_F, Cond, Block.Label_Next);
- Start_BB;
- end if;
- end New_Elsif_Stmt;
-
procedure New_Else_Stmt (Block : in out O_If_Block) is
begin
- if Flag_Debug_Hli then
- New_Enode_Stmt (OE_Elsif, O_Enode_Null, O_Enode_Null);
+ if not Flag_Lower_Stmt then
+ New_Enode_Stmt (OE_Else, O_Enode_Null, O_Enode_Null);
else
if Block.Label_End = O_Enode_Null then
Block.Label_End := New_Label;
@@ -1297,7 +1290,7 @@ package body Ortho_Code.Exprs is
procedure Finish_If_Stmt (Block : in out O_If_Block) is
begin
- if Flag_Debug_Hli then
+ if not Flag_Lower_Stmt then
New_Enode_Stmt (OE_Endif, O_Enode_Null, O_Enode_Null);
else
-- Create a badic-block after the IF.
@@ -1313,7 +1306,7 @@ package body Ortho_Code.Exprs is
procedure Start_Loop_Stmt (Label : out O_Snode) is
begin
- if Flag_Debug_Hli then
+ if not Flag_Lower_Stmt then
New_Enode_Stmt (OE_Loop, O_Enode_Null, O_Enode_Null);
Label := (Label_Start => Last_Stmt,
Label_End => O_Enode_Null);
@@ -1329,7 +1322,7 @@ package body Ortho_Code.Exprs is
procedure Finish_Loop_Stmt (Label : in out O_Snode)
is
begin
- if Flag_Debug_Hli then
+ if not Flag_Lower_Stmt then
New_Enode_Stmt (OE_Eloop, Label.Label_Start, O_Enode_Null);
else
Emit_Jmp (OE_Jump, O_Enode_Null, Label.Label_Start);
@@ -1338,11 +1331,10 @@ package body Ortho_Code.Exprs is
end if;
end Finish_Loop_Stmt;
-
procedure New_Exit_Stmt (L : O_Snode)
is
begin
- if Flag_Debug_Hli then
+ if not Flag_Lower_Stmt then
New_Enode_Stmt (OE_Exit, O_Enode_Null, L.Label_Start);
else
New_Allocb_Jump (L.Label_End);
@@ -1352,7 +1344,7 @@ package body Ortho_Code.Exprs is
procedure New_Next_Stmt (L : O_Snode)
is
begin
- if Flag_Debug_Hli then
+ if not Flag_Lower_Stmt then
New_Enode_Stmt (OE_Next, O_Enode_Null, L.Label_Start);
else
New_Allocb_Jump (L.Label_Start);
@@ -1543,18 +1535,18 @@ package body Ortho_Code.Exprs is
New_Enode_Stmt (OE_Line, O_Enode (Line), O_Enode_Null);
end New_Debug_Line_Stmt;
- procedure Disp_Enode (Indent : Natural; N : O_Enode)
+ procedure Debug_Expr (N : O_Enode)
is
use Ada.Text_IO;
use Ortho_Code.Debug.Int32_IO;
+ Indent : constant Count := Col;
begin
- Set_Col (Count (Indent));
Put (Int32 (N), 0);
- Set_Col (Count (Indent + 7));
+ Set_Col (Indent + 7);
Disp_Mode (Get_Expr_Mode (N));
Put (" ");
Put (OE_Kind'Image (Get_Expr_Kind (N)));
- Set_Col (Count (Indent + 25));
+ Set_Col (Indent + 26);
-- Put (Abi.Image_Insn (Get_Expr_Insn (N)));
-- Put (" ");
Put (Abi.Image_Reg (Get_Expr_Reg (N)));
@@ -1563,10 +1555,11 @@ package body Ortho_Code.Exprs is
Put (Int32 (Enodes.Table (N).Arg2), 7);
Put (Enodes.Table (N).Info, 7);
New_Line;
- end Disp_Enode;
+ end Debug_Expr;
procedure Disp_Subprg_Body (Indent : Natural; Subprg : O_Enode)
is
+ use Ada.Text_IO;
N : O_Enode;
N_Indent : Natural;
begin
@@ -1575,7 +1568,8 @@ package body Ortho_Code.Exprs is
raise Program_Error;
end if;
-- Display the entry.
- Disp_Enode (Indent, N);
+ Set_Col (Count (Indent));
+ Debug_Expr (N);
-- Display the subprogram, binding.
N_Indent := Indent;-- + 1;
N := N + 1;
@@ -1584,10 +1578,12 @@ package body Ortho_Code.Exprs is
when OE_Entry =>
N := Get_Entry_Leave (N) + 1;
when OE_Leave =>
- Disp_Enode (Indent, N);
+ Set_Col (Count (Indent));
+ Debug_Expr (N);
exit;
when others =>
- Disp_Enode (N_Indent, N);
+ Set_Col (Count (N_Indent));
+ Debug_Expr (N);
case Get_Expr_Kind (N) is
when OE_Beg =>
Disp_Block (N_Indent + 2,
@@ -1606,7 +1602,7 @@ package body Ortho_Code.Exprs is
procedure Disp_All_Enode is
begin
for I in Enodes.First .. Enodes.Last loop
- Disp_Enode (1, I);
+ Debug_Expr (I);
end loop;
end Disp_All_Enode;
diff --git a/ortho/mcode/ortho_code-exprs.ads b/ortho/mcode/ortho_code-exprs.ads
index 0ac6cee..5c7da61 100644
--- a/ortho/mcode/ortho_code-exprs.ads
+++ b/ortho/mcode/ortho_code-exprs.ads
@@ -149,12 +149,14 @@ package Ortho_Code.Exprs is
OE_Case_End,
-- ARG1: the condition
- -- ARG2: the elsif/endif chain
+ -- ARG2: the else/endif
OE_If,
- OE_Elsif,
+ OE_Else,
OE_Endif,
+ -- ARG1: loop level.
OE_Loop,
+ -- ARG1: loop.
OE_Eloop,
-- ARG2: loop.
OE_Next,
@@ -258,6 +260,10 @@ package Ortho_Code.Exprs is
First_Subprg : Subprogram_Data_Acc := null;
Last_Subprg : Subprogram_Data_Acc := null;
+ -- Type of the stack pointer - for OE_Get_Stack and OE_Set_Stack.
+ -- Can be set by back-ends.
+ Stack_Ptr_Type : O_Tnode := O_Tnode_Null;
+
-- Create a new node.
-- Should be used only by back-end to add internal nodes.
function New_Enode (Kind : OE_Kind;
@@ -301,7 +307,7 @@ package Ortho_Code.Exprs is
-- For OE_Lit: get the literal.
function Get_Expr_Lit (Lit : O_Enode) return O_Cnode;
- -- Type of a OE_Conv/OE_Nop/OE_Typed
+ -- Type of a OE_Conv/OE_Nop/OE_Typed/OE_Alloca
-- Used only for display/debugging purposes.
function Get_Conv_Type (Enode : O_Enode) return O_Tnode;
@@ -380,6 +386,11 @@ package Ortho_Code.Exprs is
-- Get the basic block label (uniq number).
function Get_BB_Number (Stmt : O_Enode) return Int32;
+ -- For OE_Loop, set loop level (an integer).
+ -- Reserved for back-end in HLI mode only.
+ function Get_Loop_Level (Stmt : O_Enode) return Int32;
+ procedure Set_Loop_Level (Stmt : O_Enode; Level : Int32);
+
-- Start a subprogram body.
-- Note: the declaration may have an external storage, in this case it
-- becomes public.
@@ -488,8 +499,6 @@ package Ortho_Code.Exprs is
-- Build an IF statement.
procedure Start_If_Stmt (Block : out O_If_Block; Cond : O_Enode);
- -- COND is NULL for the final else statement.
- procedure New_Elsif_Stmt (Block : in out O_If_Block; Cond : O_Enode);
procedure New_Else_Stmt (Block : in out O_If_Block);
procedure Finish_If_Stmt (Block : in out O_If_Block);
diff --git a/ortho/mcode/ortho_code-types.adb b/ortho/mcode/ortho_code-types.adb
index 004b15c..63e6770 100644
--- a/ortho/mcode/ortho_code-types.adb
+++ b/ortho/mcode/ortho_code-types.adb
@@ -21,6 +21,7 @@ with GNAT.Table;
with Ortho_Code.Consts; use Ortho_Code.Consts;
with Ortho_Code.Debug;
with Ortho_Code.Abi; use Ortho_Code.Abi;
+with Ortho_Ident;
package body Ortho_Code.Types is
type Bool_Array is array (Natural range <>) of Boolean;
@@ -30,10 +31,13 @@ package body Ortho_Code.Types is
Kind : OT_Kind; -- 4 bits.
Mode : Mode_Type; -- 4 bits.
Align : Small_Natural; -- 2 bits.
- Pad0 : Bool_Array (0 .. 21);
+ Deferred : Boolean; -- 1 bit (True if the type was incomplete at first)
+ Flag1 : Boolean;
+ Pad0 : Bool_Array (0 .. 19);
Size : Uns32;
end record;
pragma Pack (Tnode_Common);
+ for Tnode_Common'Size use 64;
type Tnode_Access is record
Dtype : O_Tnode;
@@ -111,6 +115,21 @@ package body Ortho_Code.Types is
return Tnodes.Table (Atype).Mode;
end Get_Type_Mode;
+ function Get_Type_Deferred (Atype : O_Tnode) return Boolean is
+ begin
+ return Tnodes.Table (Atype).Deferred;
+ end Get_Type_Deferred;
+
+ function Get_Type_Flag1 (Atype : O_Tnode) return Boolean is
+ begin
+ return Tnodes.Table (Atype).Flag1;
+ end Get_Type_Flag1;
+
+ procedure Set_Type_Flag1 (Atype : O_Tnode; Flag : Boolean) is
+ begin
+ Tnodes.Table (Atype).Flag1 := Flag;
+ end Set_Type_Flag1;
+
function To_Tnode_Access is new Ada.Unchecked_Conversion
(Source => Tnode_Common, Target => Tnode_Access);
@@ -202,6 +221,11 @@ package body Ortho_Code.Types is
return Fnodes.Table (Field).Offset;
end Get_Field_Offset;
+ procedure Set_Field_Offset (Field : O_Fnode; Offset : Uns32) is
+ begin
+ Fnodes.Table (Field).Offset := Offset;
+ end Set_Field_Offset;
+
function Get_Field_Type (Field : O_Fnode) return O_Tnode is
begin
return Fnodes.Table (Field).Ftype;
@@ -214,7 +238,7 @@ package body Ortho_Code.Types is
function Get_Field_Chain (Field : O_Fnode) return O_Fnode is
begin
- return Field + 1;
+ return Fnodes.Table (Field).Next;
end Get_Field_Chain;
function New_Unsigned_Type (Size : Natural) return O_Tnode
@@ -239,10 +263,12 @@ package body Ortho_Code.Types is
raise Program_Error;
end case;
Tnodes.Append (Tnode_Common'(Kind => OT_Unsigned,
- Mode => Mode,
- Align => Mode_Align (Mode),
- Pad0 => (others => False),
- Size => Sz));
+ Mode => Mode,
+ Align => Mode_Align (Mode),
+ Deferred => False,
+ Flag1 => False,
+ Pad0 => (others => False),
+ Size => Sz));
return Tnodes.Last;
end New_Unsigned_Type;
@@ -268,20 +294,24 @@ package body Ortho_Code.Types is
raise Program_Error;
end case;
Tnodes.Append (Tnode_Common'(Kind => OT_Signed,
- Mode => Mode,
- Align => Mode_Align (Mode),
- Pad0 => (others => False),
- Size => Sz));
+ Mode => Mode,
+ Align => Mode_Align (Mode),
+ Deferred => False,
+ Flag1 => False,
+ Pad0 => (others => False),
+ Size => Sz));
return Tnodes.Last;
end New_Signed_Type;
function New_Float_Type return O_Tnode is
begin
Tnodes.Append (Tnode_Common'(Kind => OT_Float,
- Mode => Mode_F64,
- Align => Mode_Align (Mode_F64),
- Pad0 => (others => False),
- Size => 8));
+ Mode => Mode_F64,
+ Align => Mode_Align (Mode_F64),
+ Deferred => False,
+ Flag1 => False,
+ Pad0 => (others => False),
+ Size => 8));
return Tnodes.Last;
end New_Float_Type;
@@ -310,10 +340,12 @@ package body Ortho_Code.Types is
raise Program_Error;
end case;
Tnodes.Append (Tnode_Common'(Kind => OT_Enum,
- Mode => Mode,
- Align => Mode_Align (Mode),
- Pad0 => (others => False),
- Size => Sz));
+ Mode => Mode,
+ Align => Mode_Align (Mode),
+ Deferred => False,
+ Flag1 => False,
+ Pad0 => (others => False),
+ Size => Sz));
List := (Res => Tnodes.Last,
First => O_Cnode_Null,
Last => O_Cnode_Null,
@@ -353,10 +385,12 @@ package body Ortho_Code.Types is
is
begin
Tnodes.Append (Tnode_Common'(Kind => OT_Boolean,
- Mode => Mode_B2,
- Align => 0,
- Pad0 => (others => False),
- Size => 1));
+ Mode => Mode_B2,
+ Align => 0,
+ Deferred => False,
+ Flag1 => False,
+ Pad0 => (others => False),
+ Size => 1));
Res := Tnodes.Last;
False_E := New_Named_Literal (Res, False_Id, 0, O_Cnode_Null);
True_E := New_Named_Literal (Res, True_Id, 1, False_E);
@@ -373,13 +407,15 @@ package body Ortho_Code.Types is
Res : O_Tnode;
begin
Tnodes.Append (Tnode_Common'(Kind => OT_Ucarray,
- Mode => Mode_Blk,
- Align => Get_Type_Align (El_Type),
- Pad0 => (others => False),
- Size => 0));
+ Mode => Mode_Blk,
+ Align => Get_Type_Align (El_Type),
+ Deferred => False,
+ Flag1 => False,
+ Pad0 => (others => False),
+ Size => 0));
Res := Tnodes.Last;
Tnodes.Append (To_Tnode_Common (Tnode_Array'(Element_Type => El_Type,
- Index_Type => Index_Type)));
+ Index_Type => Index_Type)));
return Res;
end New_Array_Type;
@@ -394,16 +430,34 @@ package body Ortho_Code.Types is
begin
Size := Get_Type_Size (Get_Type_Array_Element (Atype));
Tnodes.Append (Tnode_Common'(Kind => OT_Subarray,
- Mode => Mode_Blk,
- Align => Get_Type_Align (Atype),
- Pad0 => (others => False),
- Size => Size * Length));
+ Mode => Mode_Blk,
+ Align => Get_Type_Align (Atype),
+ Deferred => False,
+ Flag1 => False,
+ Pad0 => (others => False),
+ Size => Size * Length));
Res := Tnodes.Last;
Tnodes.Append (To_Tnode_Common (Tnode_Subarray'(Base_Type => Atype,
- Length => Length)));
+ Length => Length)));
return Res;
end New_Constrained_Array_Type;
+ procedure Create_Completer (Atype : O_Tnode) is
+ begin
+ Tnodes.Append (Tnode_Common'(Kind => OT_Complete,
+ Mode => Mode_Nil,
+ Align => 0,
+ Deferred => False,
+ Flag1 => False,
+ Pad0 => (others => False),
+ Size => To_Uns32 (Int32 (Atype))));
+ end Create_Completer;
+
+ function Get_Type_Complete_Type (Atype : O_Tnode) return O_Tnode is
+ begin
+ return O_Tnode (To_Int32 (Tnodes.Table (Atype).Size));
+ end Get_Type_Complete_Type;
+
function To_Tnode_Common is new Ada.Unchecked_Conversion
(Source => Tnode_Access, Target => Tnode_Common);
@@ -412,13 +466,15 @@ package body Ortho_Code.Types is
Res : O_Tnode;
begin
Tnodes.Append (Tnode_Common'(Kind => OT_Access,
- Mode => Mode_P32,
- Align => Mode_Align (Mode_P32),
- Pad0 => (others => False),
- Size => 4));
+ Mode => Mode_P32,
+ Align => Mode_Align (Mode_P32),
+ Deferred => Dtype = O_Tnode_Null,
+ Flag1 => False,
+ Pad0 => (others => False),
+ Size => 4));
Res := Tnodes.Last;
Tnodes.Append (To_Tnode_Common (Tnode_Access'(Dtype => Dtype,
- Pad => 0)));
+ Pad => 0)));
return Res;
end New_Access_Type;
@@ -430,31 +486,36 @@ package body Ortho_Code.Types is
Tnodes.Table (Atype + 1) :=
To_Tnode_Common (Tnode_Access'(Dtype => Dtype,
Pad => 0));
+ if Flag_Type_Completer then
+ Create_Completer (Atype);
+ end if;
end Finish_Access_Type;
function To_Tnode_Common is new Ada.Unchecked_Conversion
(Source => Tnode_Record, Target => Tnode_Common);
- function Create_Record_Type return O_Tnode
+ function Create_Record_Type (Deferred : Boolean) return O_Tnode
is
Res : O_Tnode;
begin
Tnodes.Append (Tnode_Common'(Kind => OT_Record,
- Mode => Mode_Blk,
- Align => 0,
- Pad0 => (others => False),
- Size => 0));
+ Mode => Mode_Blk,
+ Align => 0,
+ Deferred => Deferred,
+ Flag1 => False,
+ Pad0 => (others => False),
+ Size => 0));
Res := Tnodes.Last;
Tnodes.Append (To_Tnode_Common (Tnode_Record'(Fields => O_Fnode_Null,
- Nbr_Fields => 0)));
+ Nbr_Fields => 0)));
return Res;
end Create_Record_Type;
procedure Start_Record_Type (Elements : out O_Element_List)
is
begin
- Elements := (Res => Create_Record_Type,
+ Elements := (Res => Create_Record_Type (False),
First_Field => O_Fnode_Null,
Last_Field => O_Fnode_Null,
Off => 0,
@@ -464,7 +525,7 @@ package body Ortho_Code.Types is
procedure New_Uncomplete_Record_Type (Res : out O_Tnode) is
begin
- Res := Create_Record_Type;
+ Res := Create_Record_Type (True);
end New_Uncomplete_Record_Type;
procedure Start_Uncomplete_Record_Type (Res : O_Tnode;
@@ -562,16 +623,23 @@ package body Ortho_Code.Types is
(Tnode_Record'(Fields => Elements.First_Field,
Nbr_Fields => Elements.Nbr));
Res := Elements.Res;
+ if Flag_Type_Completer
+ and then Tnodes.Table (Elements.Res).Deferred
+ then
+ Create_Completer (Elements.Res);
+ end if;
end Finish_Record_Type;
procedure Start_Union_Type (Elements : out O_Element_List)
is
begin
Tnodes.Append (Tnode_Common'(Kind => OT_Union,
- Mode => Mode_Blk,
- Align => 0,
- Pad0 => (others => False),
- Size => 0));
+ Mode => Mode_Blk,
+ Align => 0,
+ Deferred => False,
+ Flag1 => False,
+ Pad0 => (others => False),
+ Size => 0));
Elements := (Res => Tnodes.Last,
First_Field => O_Fnode_Null,
Last_Field => O_Fnode_Null,
@@ -620,7 +688,7 @@ package body Ortho_Code.Types is
return Get_Type_Ucarray_Element (Base);
end Get_Type_Array_Element;
- procedure Disp_Type (Atype : O_Tnode)
+ procedure Debug_Type (Atype : O_Tnode)
is
use Ortho_Code.Debug.Int32_IO;
use Ada.Text_IO;
@@ -632,6 +700,10 @@ package body Ortho_Code.Types is
Put (OT_Kind'Image (Get_Type_Kind (Atype)));
Put (" ");
Put (Mode_Type'Image (Get_Type_Mode (Atype)));
+ Put (" D=");
+ Put (Boolean'Image (Get_Type_Deferred (Atype)));
+ Put (" F1=");
+ Put (Boolean'Image (Get_Type_Flag1 (Atype)));
New_Line;
case Kind is
when OT_Boolean =>
@@ -640,11 +712,63 @@ package body Ortho_Code.Types is
Put (", true: ");
Put (Int32 (Get_Type_Bool_True (Atype)));
New_Line;
+ when OT_Access =>
+ Put (" acc_type: ");
+ Put (Int32 (Get_Type_Access_Type (Atype)));
+ New_Line;
+ when OT_Record =>
+ Put (" fields: ");
+ Put (Int32 (Get_Type_Record_Fields (Atype)));
+ Put (", nbr_fields: ");
+ Put (To_Int32 (Get_Type_Record_Nbr_Fields (Atype)));
+ New_Line;
when others =>
null;
end case;
- end Disp_Type;
- pragma Unreferenced (Disp_Type);
+ end Debug_Type;
+
+ procedure Debug_Field (Field : O_Fnode)
+ is
+ use Ortho_Code.Debug.Int32_IO;
+ use Ada.Text_IO;
+ begin
+ Put (Int32 (Field), 3);
+ Put (" ");
+ Put (" Offset=");
+ Put (To_Int32 (Get_Field_Offset (Field)), 0);
+ Put (", Ident=");
+ Put (Ortho_Ident.Get_String (Get_Field_Ident (Field)));
+ Put (", Type=");
+ Put (Int32 (Get_Field_Type (Field)), 0);
+ Put (", Chain=");
+ Put (Int32 (Get_Field_Chain (Field)), 0);
+ New_Line;
+ end Debug_Field;
+
+ function Get_Type_Limit return O_Tnode is
+ begin
+ return Tnodes.Last;
+ end Get_Type_Limit;
+
+ function Get_Type_Next (Atype : O_Tnode) return O_Tnode is
+ begin
+ case Tnodes.Table (Atype).Kind is
+ when OT_Unsigned
+ | OT_Signed
+ | OT_Float =>
+ return Atype + 1;
+ when OT_Boolean
+ | OT_Enum
+ | OT_Ucarray
+ | OT_Subarray
+ | OT_Access
+ | OT_Record
+ | OT_Union =>
+ return Atype + 2;
+ when OT_Complete =>
+ return Atype + 1;
+ end case;
+ end Get_Type_Next;
procedure Mark (M : out Mark_Type) is
begin
diff --git a/ortho/mcode/ortho_code-types.ads b/ortho/mcode/ortho_code-types.ads
index e64055e..73a493e 100644
--- a/ortho/mcode/ortho_code-types.ads
+++ b/ortho/mcode/ortho_code-types.ads
@@ -18,7 +18,11 @@
package Ortho_Code.Types is
type OT_Kind is (OT_Unsigned, OT_Signed, OT_Boolean, OT_Enum, OT_Float,
OT_Ucarray, OT_Subarray, OT_Access,
- OT_Record, OT_Union);
+ OT_Record, OT_Union,
+
+ -- Type completion. Mark the completion of a type.
+ -- Optionnal.
+ OT_Complete);
-- Kind of ATYPE.
function Get_Type_Kind (Atype : O_Tnode) return OT_Kind;
@@ -35,6 +39,15 @@ package Ortho_Code.Types is
type Mode_Align_Array is array (Mode_Type) of Small_Natural;
function Get_Type_Align (Atype : O_Tnode) return Small_Natural;
+ -- Return true is the type was incomplete at creation.
+ -- (it may - or not - have been completed later).
+ function Get_Type_Deferred (Atype : O_Tnode) return Boolean;
+
+ -- A back-end reserved flag.
+ -- Initialized to False.
+ function Get_Type_Flag1 (Atype : O_Tnode) return Boolean;
+ procedure Set_Type_Flag1 (Atype : O_Tnode; Flag : Boolean);
+
-- Align OFF on ATYPE.
function Do_Align (Off : Uns32; Atype : O_Tnode) return Uns32;
function Do_Align (Off : Uns32; Mode : Mode_Type) return Uns32;
@@ -79,6 +92,7 @@ package Ortho_Code.Types is
-- Get the offset of FIELD in its record/union.
function Get_Field_Offset (Field : O_Fnode) return Uns32;
+ procedure Set_Field_Offset (Field : O_Fnode; Offset : Uns32);
-- Get the type of FIELD.
function Get_Field_Type (Field : O_Fnode) return O_Tnode;
@@ -89,6 +103,9 @@ package Ortho_Code.Types is
-- Get the next field.
function Get_Field_Chain (Field : O_Fnode) return O_Fnode;
+ -- Get the type that was completed.
+ function Get_Type_Complete_Type (Atype : O_Tnode) return O_Tnode;
+
-- Build a scalar type; size may be 8, 16, 32 or 64.
function New_Unsigned_Type (Size : Natural) return O_Tnode;
function New_Signed_Type (Size : Natural) return O_Tnode;
@@ -168,6 +185,15 @@ package Ortho_Code.Types is
-- Type of an element of a ucarray or constrained array.
function Get_Type_Array_Element (Atype : O_Tnode) return O_Tnode;
+ -- Get a type number limit (an O_Tnode is a number).
+ -- There is no type whose number is beyond this limit.
+ -- Note: the limit may not be a type!
+ function Get_Type_Limit return O_Tnode;
+
+ -- Get the type which follows ATYPE.
+ -- User has to check that the result is valid (ie not beyond limit).
+ function Get_Type_Next (Atype : O_Tnode) return O_Tnode;
+
procedure Disp_Stats;
-- Free all the memory used.
@@ -177,6 +203,8 @@ package Ortho_Code.Types is
procedure Mark (M : out Mark_Type);
procedure Release (M : Mark_Type);
+ procedure Debug_Type (Atype : O_Tnode);
+ procedure Debug_Field (Field : O_Fnode);
private
type O_Enum_List is record
Res : O_Tnode;
diff --git a/ortho/mcode/ortho_code-x86-abi.adb b/ortho/mcode/ortho_code-x86-abi.adb
index ff766b0..56c5543 100644
--- a/ortho/mcode/ortho_code-x86-abi.adb
+++ b/ortho/mcode/ortho_code-x86-abi.adb
@@ -263,7 +263,8 @@ package body Ortho_Code.X86.Abi is
| Regs_R64
| R_Any64
| Regs_Cc
- | Regs_Fp =>
+ | Regs_Fp
+ | Regs_Xmm =>
Disp_Reg (Stmt);
when R_Spill =>
Disp_Reg (Stmt);
@@ -703,6 +704,14 @@ package body Ortho_Code.X86.Abi is
return "ult?";
when R_Slt =>
return "slt?";
+ when R_Xmm0 =>
+ return "xmm0";
+ when R_Xmm1 =>
+ return "xmm1";
+ when R_Xmm2 =>
+ return "xmm2";
+ when R_Xmm3 =>
+ return "xmm3";
when others =>
return "????";
end case;
diff --git a/ortho/mcode/ortho_code-x86-abi.ads b/ortho/mcode/ortho_code-x86-abi.ads
index eb3b5a1..11768dc 100644
--- a/ortho/mcode/ortho_code-x86-abi.ads
+++ b/ortho/mcode/ortho_code-x86-abi.ads
@@ -34,6 +34,11 @@ package Ortho_Code.X86.Abi is
Mode_Ptr : constant Mode_Type := Mode_P32;
+ Flag_Type_Completer : constant Boolean := False;
+ Flag_Lower_Stmt : constant Boolean := True;
+
+ Flag_Sse2 : Boolean := False;
+
-- Procedures to layout a subprogram declaration.
procedure Start_Subprogram (Subprg : O_Dnode; Abi : out O_Abi_Subprg);
procedure New_Interface (Inter : O_Dnode; Abi : in out O_Abi_Subprg);
diff --git a/ortho/mcode/ortho_code-x86-emits.adb b/ortho/mcode/ortho_code-x86-emits.adb
index 059711a..4a90401 100644
--- a/ortho/mcode/ortho_code-x86-emits.adb
+++ b/ortho/mcode/ortho_code-x86-emits.adb
@@ -253,6 +253,12 @@ package body Ortho_Code.X86.Emits is
end To_Reg32;
pragma Inline (To_Reg32);
+ function To_Reg_Xmm (R : O_Reg) return Byte is
+ begin
+ return O_Reg'Pos (R) - O_Reg'Pos (R_Xmm0);
+ end To_Reg_Xmm;
+ pragma Inline (To_Reg_Xmm);
+
function To_Reg32 (R : O_Reg; Sz : Insn_Size) return Byte is
begin
case Sz is
@@ -509,6 +515,7 @@ package body Ortho_Code.X86.Emits is
procedure Emit_Load_Fp (Stmt : O_Enode; Sz : Fp_Size)
is
Sym : Symbol;
+ R : O_Reg;
begin
Set_Current_Section (Sect_Rodata);
Gen_Pow_Align (3);
@@ -521,11 +528,30 @@ package body Ortho_Code.X86.Emits is
end if;
Set_Current_Section (Sect_Text);
- Start_Insn;
- Gen_B8 (2#11011_001# + Fp_Size_To_Mf (Sz));
- Gen_B8 (2#00_000_101#);
- Gen_X86_32 (Sym, 0);
- End_Insn;
+ R := Get_Expr_Reg (Stmt);
+ case R is
+ when R_St0 =>
+ Start_Insn;
+ Gen_B8 (2#11011_001# + Fp_Size_To_Mf (Sz));
+ Gen_B8 (2#00_000_101#);
+ Gen_X86_32 (Sym, 0);
+ End_Insn;
+ when Regs_Xmm =>
+ Start_Insn;
+ case Sz is
+ when Fp_32 =>
+ Gen_B8 (16#F3#);
+ when Fp_64 =>
+ Gen_B8 (16#F2#);
+ end case;
+ Gen_B8 (16#0f#);
+ Gen_B8 (16#10#);
+ Gen_B8 (2#00_000_101# + To_Reg_Xmm (R) * 2#1_000#);
+ Gen_X86_32 (Sym, 0);
+ End_Insn;
+ when others =>
+ raise Program_Error;
+ end case;
end Emit_Load_Fp;
procedure Emit_Load_Fp_Mem (Stmt : O_Enode; Sz : Fp_Size)
@@ -2217,7 +2243,8 @@ package body Ortho_Code.X86.Emits is
Emit_Const (E);
end loop;
end;
- when OC_Sizeof =>
+ when OC_Sizeof
+ | OC_Union =>
raise Program_Error;
end case;
end Emit_Const;
diff --git a/ortho/mcode/ortho_code-x86-insns.adb b/ortho/mcode/ortho_code-x86-insns.adb
index 819e670..4021a99 100644
--- a/ortho/mcode/ortho_code-x86-insns.adb
+++ b/ortho/mcode/ortho_code-x86-insns.adb
@@ -50,7 +50,11 @@ package body Ortho_Code.X86.Insns is
return R_Any64;
when Mode_F32
| Mode_F64 =>
- return R_St0;
+ if Abi.Flag_Sse2 then
+ return R_Any_Xmm;
+ else
+ return R_St0;
+ end if;
when Mode_P64
| Mode_X1
| Mode_Nil
@@ -107,7 +111,8 @@ package body Ortho_Code.X86.Insns is
| OD_Function
| OD_Procedure
| OD_Interface
- | OD_Body =>
+ | OD_Body
+ | OD_Subprg_Ext =>
null;
when OD_Block =>
Decl := Get_Block_Last (Decl);
@@ -165,6 +170,7 @@ package body Ortho_Code.X86.Insns is
end case;
end Reverse_Cc;
+ -- Get the register in which a result of MODE is returned.
function Get_Call_Register (Mode : Mode_Type) return O_Reg is
begin
case Mode is
@@ -178,7 +184,13 @@ package body Ortho_Code.X86.Insns is
return R_Edx_Eax;
when Mode_F32
| Mode_F64 =>
- return R_St0;
+ if Abi.Flag_Sse2 and True then
+ -- Note: this shouldn't be enabled as the svr4 ABI specifies
+ -- ST0.
+ return R_Xmm0;
+ else
+ return R_St0;
+ end if;
when Mode_Nil =>
return R_None;
when Mode_X1
@@ -293,6 +305,7 @@ package body Ortho_Code.X86.Insns is
Used => False);
type Reg32_Info_Array is array (Regs_R32) of Reg_Info_Type;
Regs : Reg32_Info_Array := (others => Init_Reg_Info);
+
Reg_Cc : Reg_Info_Type := Init_Reg_Info;
type Fp_Stack_Type is mod 8;
@@ -300,14 +313,15 @@ package body Ortho_Code.X86.Insns is
Fp_Top : Fp_Stack_Type := 0;
Fp_Regs : RegFp_Info_Array;
+ type Reg_Xmm_Info_Array is array (Regs_Xmm) of Reg_Info_Type;
+ Info_Regs_Xmm : Reg_Xmm_Info_Array := (others => Init_Reg_Info);
function Reg_Used (Reg : Regs_R32) return Boolean is
begin
return Regs (Reg).Used;
end Reg_Used;
-
- procedure Dump_Reg_Info (Reg : Regs_R32)
+ procedure Dump_Reg32_Info (Reg : Regs_R32)
is
use Ada.Text_IO;
use Ortho_Code.Debug.Int32_IO;
@@ -323,7 +337,7 @@ package body Ortho_Code.X86.Insns is
--Put (", link: ");
--Put (Image_Reg (Regs (Reg).Link));
New_Line;
- end Dump_Reg_Info;
+ end Dump_Reg32_Info;
procedure Dump_Regs
is
@@ -337,7 +351,7 @@ package body Ortho_Code.X86.Insns is
-- New_Line;
for I in Regs_R32 loop
- Dump_Reg_Info (I);
+ Dump_Reg32_Info (I);
end loop;
for I in Fp_Stack_Type loop
Put ("fp" & Fp_Stack_Type'Image (I));
@@ -367,6 +381,8 @@ package body Ortho_Code.X86.Insns is
end Error_Reg;
pragma No_Return (Error_Reg);
+ -- Free_XX
+ -- Mark a register as unused.
procedure Free_R32 (Reg : O_Reg) is
begin
if Regs (Reg).Num = O_Free then
@@ -392,6 +408,15 @@ package body Ortho_Code.X86.Insns is
Reg_Cc.Num := O_Free;
end Free_Cc;
+ procedure Free_Xmm (Reg : O_Reg) is
+ begin
+ if Info_Regs_Xmm (Reg).Num = O_Free then
+ raise Program_Error;
+ end if;
+ Info_Regs_Xmm (Reg).Num := O_Free;
+ end Free_Xmm;
+
+ -- Allocate a stack slot for spilling.
procedure Alloc_Spill (N : O_Enode)
is
Mode : Mode_Type;
@@ -406,19 +431,16 @@ package body Ortho_Code.X86.Insns is
Set_Spill_Info (N, -Int32 (Stack_Offset));
end Alloc_Spill;
- procedure Spill_R32 (Reg : Regs_R32)
+ -- Insert a spill statement after ORIG: will save register(s) allocated by
+ -- ORIG.
+ -- Return the register(s) spilt (There might be several registers if
+ -- ORIG uses a R64 register).
+ function Insert_Spill (Orig : O_Enode) return O_Reg
is
N : O_Enode;
- Orig : O_Enode;
Mode : Mode_Type;
Reg_Orig : O_Reg;
begin
- if Regs (Reg).Num = O_Free then
- -- This register was not allocated.
- raise Program_Error;
- end if;
- Orig := Regs (Reg).Stmt;
-
-- Add a spill statement.
Mode := Get_Expr_Mode (Orig);
N := New_Enode (OE_Spill, Mode, O_Tnode_Null, Orig, O_Enode_Null);
@@ -437,6 +459,19 @@ package body Ortho_Code.X86.Insns is
Reg_Orig := Get_Expr_Reg (Orig);
Set_Expr_Reg (N, Reg_Orig);
Set_Expr_Reg (Orig, R_Spill);
+ return Reg_Orig;
+ end Insert_Spill;
+
+ procedure Spill_R32 (Reg : Regs_R32)
+ is
+ Reg_Orig : O_Reg;
+ begin
+ if Regs (Reg).Num = O_Free then
+ -- This register was not allocated.
+ raise Program_Error;
+ end if;
+
+ Reg_Orig := Insert_Spill (Regs (Reg).Stmt);
-- Free the register.
case Reg_Orig is
@@ -503,6 +538,40 @@ package body Ortho_Code.X86.Insns is
Reg_Cc := (Num => Num, Stmt => Stmt, Used => True);
end Alloc_Cc;
+ procedure Spill_Xmm (Reg : Regs_Xmm)
+ is
+ Reg_Orig : O_Reg;
+ begin
+ if Info_Regs_Xmm (Reg).Num = O_Free then
+ -- This register was not allocated.
+ raise Program_Error;
+ end if;
+
+ Reg_Orig := Insert_Spill (Info_Regs_Xmm (Reg).Stmt);
+
+ -- Free the register.
+ if Reg_Orig /= Reg then
+ raise Program_Error;
+ end if;
+ Free_Xmm (Reg);
+ end Spill_Xmm;
+
+ procedure Alloc_Xmm (Reg : Regs_Xmm; Stmt : O_Enode; Num : O_Inum) is
+ begin
+ if Info_Regs_Xmm (Reg).Num /= O_Free then
+ Spill_Xmm (Reg);
+ end if;
+ Info_Regs_Xmm (Reg) := (Num => Num, Stmt => Stmt, Used => True);
+ end Alloc_Xmm;
+
+ procedure Clobber_Xmm (Reg : Regs_Xmm) is
+ begin
+ if Info_Regs_Xmm (Reg).Num /= O_Free then
+ Spill_Xmm (Reg);
+ end if;
+ end Clobber_Xmm;
+ pragma Unreferenced (Clobber_Xmm);
+
function Alloc_Reg (Reg : O_Reg; Stmt : O_Enode; Num : O_Inum) return O_Reg
is
Best_Reg : O_Reg;
@@ -518,6 +587,9 @@ package body Ortho_Code.X86.Insns is
when R_St0 =>
Alloc_Fp (Stmt);
return Reg;
+ when Regs_Xmm =>
+ Alloc_Xmm (Reg, Stmt, Num);
+ return Reg;
when R_Any32 =>
Best_Num := O_Inum'Last;
Best_Reg := R_None;
@@ -573,6 +645,20 @@ package body Ortho_Code.X86.Insns is
Alloc_R64 (Best_Reg, Stmt, Num);
return Best_Reg;
end;
+ when R_Any_Xmm =>
+ Best_Num := O_Inum'Last;
+ Best_Reg := R_None;
+ for I in Regs_X86_Xmm loop
+ if Info_Regs_Xmm (I).Num = O_Free then
+ Alloc_Xmm (I, Stmt, Num);
+ return I;
+ elsif Info_Regs_Xmm (I).Num <= Best_Num then
+ Best_Reg := I;
+ Best_Num := Info_Regs_Xmm (I).Num;
+ end if;
+ end loop;
+ Alloc_Xmm (Best_Reg, Stmt, Num);
+ return Best_Reg;
when others =>
Error_Reg ("alloc_reg: unknown reg", O_Enode_Null, Reg);
raise Program_Error;
@@ -649,6 +735,8 @@ package body Ortho_Code.X86.Insns is
return Expr;
when R_St0 =>
return Expr;
+ when Regs_Xmm =>
+ return Expr;
when R_Mem =>
if Get_Expr_Kind (Expr) = OE_Indir then
Set_Expr_Operand (Expr,
@@ -732,6 +820,8 @@ package body Ortho_Code.X86.Insns is
null;
when R_St0 =>
Free_Fp;
+ when Regs_Xmm =>
+ Free_Xmm (R);
when Regs_R64 =>
Free_R32 (Get_R64_High (R));
Free_R32 (Get_R64_Low (R));
@@ -1103,8 +1193,7 @@ package body Ortho_Code.X86.Insns is
Link_Stmt (Stmt);
when R_Any_Cc =>
Num := Get_Insn_Num;
- Set_Expr_Reg
- (Stmt, Alloc_Reg (R_Any8, Stmt, Num));
+ Set_Expr_Reg (Stmt, Alloc_Reg (R_Any8, Stmt, Num));
Link_Stmt (Stmt);
Free_Insn_Regs (Stmt);
Right := Insert_Move (Stmt, R_Ne);
@@ -1121,8 +1210,12 @@ package body Ortho_Code.X86.Insns is
| R_Rm
| R_St0 =>
Num := Get_Insn_Num;
- Set_Expr_Reg
- (Stmt, Alloc_Reg (R_St0, Stmt, Num));
+ if Reg = R_St0 or not Abi.Flag_Sse2 then
+ Reg1 := R_St0;
+ else
+ Reg1 := R_Any_Xmm;
+ end if;
+ Set_Expr_Reg (Stmt, Alloc_Reg (Reg1, Stmt, Num));
Link_Stmt (Stmt);
when others =>
raise Program_Error;
diff --git a/ortho/mcode/ortho_code-x86.ads b/ortho/mcode/ortho_code-x86.ads
index 235f1c1..24be1eb 100644
--- a/ortho/mcode/ortho_code-x86.ads
+++ b/ortho/mcode/ortho_code-x86.ads
@@ -113,6 +113,29 @@ package Ortho_Code.X86 is
subtype Regs_R64 is O_Reg range R_Edx_Eax .. R_Esi_Edi;
+ R_Any_Xmm : constant O_Reg := 79;
+
+ R_Xmm0 : constant O_Reg := 80;
+ R_Xmm1 : constant O_Reg := R_Xmm0 + 1;
+ R_Xmm2 : constant O_Reg := R_Xmm0 + 2;
+ R_Xmm3 : constant O_Reg := R_Xmm0 + 3;
+ R_Xmm4 : constant O_Reg := R_Xmm0 + 4;
+ R_Xmm5 : constant O_Reg := R_Xmm0 + 5;
+ R_Xmm6 : constant O_Reg := R_Xmm0 + 6;
+ R_Xmm7 : constant O_Reg := R_Xmm0 + 7;
+ R_Xmm8 : constant O_Reg := R_Xmm0 + 8;
+ R_Xmm9 : constant O_Reg := R_Xmm0 + 9;
+ R_Xmm10 : constant O_Reg := R_Xmm0 + 10;
+ R_Xmm11 : constant O_Reg := R_Xmm0 + 11;
+ R_Xmm12 : constant O_Reg := R_Xmm0 + 12;
+ R_Xmm13 : constant O_Reg := R_Xmm0 + 13;
+ R_Xmm14 : constant O_Reg := R_Xmm0 + 14;
+ R_Xmm15 : constant O_Reg := R_Xmm0 + 15;
+
+ subtype Regs_X86_64_Xmm is O_Reg range R_Xmm0 .. R_Xmm15;
+ subtype Regs_X86_Xmm is O_Reg range R_Xmm0 .. R_Xmm7;
+ subtype Regs_Xmm is O_Reg range R_Xmm0 .. R_Xmm15;
+
function Get_R64_High (Reg : Regs_R64) return Regs_R32;
function Get_R64_Low (Reg : Regs_R64) return Regs_R32;
diff --git a/ortho/mcode/ortho_code_main.adb b/ortho/mcode/ortho_code_main.adb
index 7744b88..7454d8f 100644
--- a/ortho/mcode/ortho_code_main.adb
+++ b/ortho/mcode/ortho_code_main.adb
@@ -25,11 +25,9 @@ with Ortho_Code.Debug;
with Ortho_Mcode; use Ortho_Mcode;
with Ortho_Front; use Ortho_Front;
with Ortho_Code.Flags; use Ortho_Code.Flags;
-with Binary_File;
with Binary_File.Elf;
with Binary_File.Coff;
with Binary_File.Memory;
-with Interfaces;
procedure Ortho_Code_Main
is
@@ -165,14 +163,11 @@ begin
end if;
elsif Exec_Func /= null then
declare
- use Binary_File;
- use Interfaces;
- use Ada.Text_IO;
Sym : Symbol;
type Func_Acc is access function return Integer;
function Conv is new Ada.Unchecked_Conversion
- (Source => Unsigned_32, Target => Func_Acc);
+ (Source => Pc_Type, Target => Func_Acc);
F : Func_Acc;
V : Integer;
Err : Boolean;
diff --git a/ortho/mcode/ortho_ident.adb b/ortho/mcode/ortho_ident.adb
index 034aeae..0893b75 100644
--- a/ortho/mcode/ortho_ident.adb
+++ b/ortho/mcode/ortho_ident.adb
@@ -37,10 +37,11 @@ package body Ortho_Ident is
is
Start : Natural;
begin
- Start := Strs.Allocate (Str'Length);
+ Start := Strs.Allocate (Str'Length + 1);
for I in Str'Range loop
Strs.Table (Start + I - Str'First) := Str (I);
end loop;
+ Strs.Table (Start + Str'Length) := ASCII.Nul;
Ids.Append (Start);
return Ids.Last;
end Get_Identifier;
@@ -57,9 +58,9 @@ package body Ortho_Ident is
begin
Start := Ids.Table (Id);
if Id = Ids.Last then
- return Strs.Last - Start + 1;
+ return Strs.Last - Start + 1 - 1;
else
- return Ids.Table (Id + 1) - Start;
+ return Ids.Table (Id + 1) - 1 - Start;
end if;
end Get_String_Length;
@@ -69,11 +70,16 @@ package body Ortho_Ident is
Start : constant Natural := Ids.Table (Id);
begin
for I in Res'Range loop
- Res (I) := Strs.Table (Start + I - 1);
+ Res (I) := Strs.Table (Start + I - Res'First);
end loop;
return Res;
end Get_String;
+ function Get_Cstring (Id : O_Ident) return System.Address is
+ begin
+ return Strs.Table (Ids.Table (Id))'Address;
+ end Get_Cstring;
+
function Is_Equal (Id : O_Ident; Str : String) return Boolean
is
Start : constant Natural := Ids.Table (Id);
diff --git a/ortho/mcode/ortho_ident.ads b/ortho/mcode/ortho_ident.ads
index fcf39b2..cdc42fc 100644
--- a/ortho/mcode/ortho_ident.ads
+++ b/ortho/mcode/ortho_ident.ads
@@ -15,6 +15,7 @@
-- along with GCC; see the file COPYING. If not, write to the Free
-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-- 02111-1307, USA.
+with System;
with Ortho_Code; use Ortho_Code;
package Ortho_Ident is
@@ -27,6 +28,9 @@ package Ortho_Ident is
function Get_String (Id : O_Ident) return String;
function Get_String_Length (Id : O_Ident) return Natural;
+ -- Note: the address is valid until the next call to get_identifier.
+ function Get_Cstring (Id : O_Ident) return System.Address;
+
O_Ident_Nul : constant O_Ident := Ortho_Code.O_Ident_Nul;
procedure Disp_Stats;
diff --git a/ortho/mcode/ortho_mcode.adb b/ortho/mcode/ortho_mcode.adb
index e774483..f9335fa 100644
--- a/ortho/mcode/ortho_mcode.adb
+++ b/ortho/mcode/ortho_mcode.adb
@@ -19,7 +19,7 @@ with Ada.Text_IO;
with Ortho_Code.Debug;
with Ortho_Code.Sysdeps;
with Ortho_Ident;
-with Binary_File;
+-- with Binary_File;
package body Ortho_Mcode is
procedure New_Debug_Line_Decl (Line : Natural)
@@ -43,16 +43,6 @@ package body Ortho_Mcode is
null;
end New_Debug_Comment_Stmt;
- procedure Start_Declare_Stmt is
- begin
- Ortho_Code.Exprs.Start_Declare_Stmt;
- end Start_Declare_Stmt;
-
- procedure Finish_Declare_Stmt is
- begin
- Ortho_Code.Exprs.Finish_Declare_Stmt;
- end Finish_Declare_Stmt;
-
procedure Start_Const_Value (Const : in out O_Dnode)
is
pragma Unreferenced (Const);
@@ -111,7 +101,7 @@ package body Ortho_Mcode is
Ortho_Code.Types.Disp_Stats;
Ortho_Code.Consts.Disp_Stats;
Ortho_Ident.Disp_Stats;
- Binary_File.Disp_Stats;
+ -- Binary_File.Disp_Stats;
end if;
end Finish;
diff --git a/ortho/mcode/ortho_mcode.ads b/ortho/mcode/ortho_mcode.ads
index d408d56..9ea4c89 100644
--- a/ortho/mcode/ortho_mcode.ads
+++ b/ortho/mcode/ortho_mcode.ads
@@ -443,8 +443,10 @@ package Ortho_Mcode is
procedure New_Debug_Comment_Stmt (Comment : String);
-- Start a declarative region.
- procedure Start_Declare_Stmt;
- procedure Finish_Declare_Stmt;
+ procedure Start_Declare_Stmt renames
+ Ortho_Code.Exprs.Start_Declare_Stmt;
+ procedure Finish_Declare_Stmt renames
+ Ortho_Code.Exprs.Finish_Declare_Stmt;
-- Create a function call or a procedure call.
procedure Start_Association (Assocs : out O_Assoc_List; Subprg : O_Dnode)
@@ -471,9 +473,6 @@ package Ortho_Mcode is
-- Build an IF statement.
procedure Start_If_Stmt (Block : out O_If_Block; Cond : O_Enode)
renames Ortho_Code.Exprs.Start_If_Stmt;
- -- COND is NULL for the final else statement.
- procedure New_Elsif_Stmt (Block : in out O_If_Block; Cond : O_Enode)
- renames Ortho_Code.Exprs.New_Elsif_Stmt;
procedure New_Else_Stmt (Block : in out O_If_Block)
renames Ortho_Code.Exprs.New_Else_Stmt;
procedure Finish_If_Stmt (Block : in out O_If_Block)
generated by cgit (git 2.34.1) at 2024-12-21 04:06:42 +0000