summaryrefslogtreecommitdiff
path: root/ortho
diff options
context:
space:
mode:
Diffstat (limited to 'ortho')
-rw-r--r--ortho/debug/Makefile29
-rw-r--r--ortho/debug/ortho_debug-disp.adb982
-rw-r--r--ortho/debug/ortho_debug-disp.ads12
-rw-r--r--ortho/debug/ortho_debug-main.adb133
-rw-r--r--ortho/debug/ortho_debug.adb1959
-rw-r--r--ortho/debug/ortho_debug.private.ads439
-rw-r--r--ortho/debug/ortho_debug_front.ads2
-rw-r--r--ortho/debug/ortho_ident.ads2
-rw-r--r--ortho/debug/ortho_ident_hash.adb54
-rw-r--r--ortho/debug/ortho_ident_hash.ads28
-rw-r--r--ortho/debug/ortho_ident_simple.adb26
-rw-r--r--ortho/debug/ortho_ident_simple.ads13
-rw-r--r--ortho/debug/ortho_nodes.ads3
-rw-r--r--ortho/oread/Makefile25
-rw-r--r--ortho/oread/ortho_front.adb2650
15 files changed, 6357 insertions, 0 deletions
diff --git a/ortho/debug/Makefile b/ortho/debug/Makefile
new file mode 100644
index 0000000..8bb4ffc
--- /dev/null
+++ b/ortho/debug/Makefile
@@ -0,0 +1,29 @@
+BE=debug
+ortho_srcdir=..
+
+orthobe_srcdir=$(ortho_srcdir)/$(BE)
+
+GNATMAKE=gnatmake
+CC=gcc
+CFLAGS=-g
+ALL_GNAT_FLAGS=-pipe -g -gnato -gnatwl -gnatf -gnaty3befhkmr -gnatwu
+GNATMAKE_FLAGS=-m $(ALL_GNAT_FLAGS) $(GNAT_FLAGS) -aI$(ortho_srcdir) -aI$(orthobe_srcdir) -aI.
+#LARGS=-largs -static
+SED=sed
+
+all: $(ortho_exec)
+
+
+$(ortho_exec): force $(orthobe_srcdir)/ortho_debug.ads
+ gnatmake -o $@ $(GNATMAKE_FLAGS) ortho_debug-main -bargs -E $(LARGS)
+
+clean:
+ $(RM) -f *.o *.ali *~ b~*.ad? ortho_nodes-main
+ $(RM) $(orthobe_srcdir)/ortho_debug.ads
+
+force:
+
+ORTHO_PACKAGE=Ortho_Debug
+ORTHO_BASENAME=$(orthobe_srcdir)/ortho_debug
+
+include $(ortho_srcdir)/Makefile.inc \ No newline at end of file
diff --git a/ortho/debug/ortho_debug-disp.adb b/ortho/debug/ortho_debug-disp.adb
new file mode 100644
index 0000000..27faf98
--- /dev/null
+++ b/ortho/debug/ortho_debug-disp.adb
@@ -0,0 +1,982 @@
+package body Ortho_Debug.Disp is
+ package Formated_Output is
+ use Interfaces.C_Streams;
+
+ type Disp_Context is limited private;
+
+ procedure Init_Context (File : FILEs);
+
+ -- Save the current context, and create a new one.
+ procedure Push_Context (File : FILEs; Prev_Ctx : out Disp_Context);
+
+ -- Restore a previous context, saved by Push_Context.
+ procedure Pop_Context (Prev_Ctx : Disp_Context);
+
+ procedure Put (Str : String);
+
+ procedure Put_Line (Str : String);
+
+ -- Add a tabulation.
+ -- Every new line will start at this tabulation.
+ procedure Add_Tab;
+
+ -- Removed a tabulation.
+ -- The next new line will start at the previous tabulation.
+ procedure Rem_Tab;
+
+ -- Flush the current output.
+ procedure Flush;
+
+ -- Return TRUE if the ident level is nul.
+ function Is_Top return Boolean;
+
+ procedure Put_Tab;
+
+ procedure New_Line;
+
+ procedure Put (C : Character);
+
+ procedure Put_Trim (Str : String);
+
+ procedure Set_Mark;
+ private
+ type Disp_Context is record
+ -- File where the info are written to.
+ File : FILEs;
+ -- Line number of the line to be written.
+ Lineno : Natural;
+ -- Buffer for the current line.
+ Line : String (1 .. 256);
+ -- Number of characters currently in the line.
+ Line_Len : Natural;
+
+ -- Current tabulation.
+ Tab : Natural;
+ -- Tabulation to be used for the next line.
+ Next_Tab : Natural;
+
+ Mark : Natural;
+ end record;
+ end Formated_Output;
+
+ package body Formated_Output is
+ -- The current context.
+ Ctx : Disp_Context;
+
+ procedure Init_Context (File : FILEs) is
+ begin
+ Ctx.File := File;
+ Ctx.Lineno := 1;
+ Ctx.Line_Len := 0;
+ Ctx.Tab := 0;
+ Ctx.Next_Tab := 0;
+ Ctx.Mark := 0;
+ end Init_Context;
+
+ procedure Push_Context (File : FILEs; Prev_Ctx : out Disp_Context)
+ is
+ begin
+ Prev_Ctx := Ctx;
+ Init_Context (File);
+ end Push_Context;
+
+ -- Restore a previous context, saved by Push_Context.
+ procedure Pop_Context (Prev_Ctx : Disp_Context) is
+ begin
+ Flush;
+ Ctx := Prev_Ctx;
+ end Pop_Context;
+
+ procedure Flush
+ is
+ Status : size_t;
+ Res : int;
+ begin
+ if Ctx.Line_Len > 0 then
+ Status := fwrite (Ctx.Line'Address, size_t (Ctx.Line_Len), 1,
+ Ctx.File);
+ Res := fputc (Character'Pos (ASCII.Lf), Ctx.File);
+ Ctx.Line_Len := 0;
+ end if;
+ Ctx.Mark := 0;
+ end Flush;
+
+ function Is_Top return Boolean is
+ begin
+ return Ctx.Tab = 0;
+ end Is_Top;
+
+ procedure Put_Tab is
+ begin
+ Ctx.Line (1 .. Ctx.Next_Tab) := (others => ' ');
+ Ctx.Line_Len := Ctx.Next_Tab;
+ Ctx.Next_Tab := Ctx.Tab + 2;
+ end Put_Tab;
+
+ procedure Put (Str : String) is
+ Saved : String (1 .. 80);
+ Len : Natural;
+ begin
+ if Ctx.Line_Len + Str'Length >= 80 then
+ if Ctx.Mark > 0 then
+ Len := Ctx.Line_Len - Ctx.Mark + 1;
+ Saved (1 .. Len) := Ctx.Line (Ctx.Mark .. Ctx.Line_Len);
+ Ctx.Line_Len := Ctx.Mark - 1;
+ Flush;
+ Put_Tab;
+ Ctx.Line (Ctx.Line_Len + 1 .. Ctx.Line_Len + Len) :=
+ Saved (1 .. Len);
+ Ctx.Line_Len := Ctx.Line_Len + Len;
+ else
+ Flush;
+ end if;
+ end if;
+ if Ctx.Line_Len = 0 then
+ Put_Tab;
+ end if;
+ Ctx.Line (Ctx.Line_Len + 1 .. Ctx.Line_Len + Str'Length) := Str;
+ Ctx.Line_Len := Ctx.Line_Len + Str'Length;
+ end Put;
+
+ procedure Put_Trim (Str : String) is
+ begin
+ for I in Str'Range loop
+ if Str (I) /= ' ' then
+ Put (Str (I .. Str'Last));
+ return;
+ end if;
+ end loop;
+ end Put_Trim;
+
+ procedure Put_Line (Str : String) is
+ begin
+ Put (Str);
+ Flush;
+ Ctx.Next_Tab := Ctx.Tab;
+ end Put_Line;
+
+ procedure New_Line
+ is
+ Status : int;
+ begin
+ if Ctx.Line_Len > 0 then
+ Flush;
+ else
+ Status := fputc (Character'Pos (ASCII.LF), Ctx.File);
+ end if;
+ Ctx.Next_Tab := Ctx.Tab;
+ end New_Line;
+
+ procedure Put (C : Character) is
+ S : String (1 .. 1) := (1 => C);
+ begin
+ Put (S);
+ end Put;
+
+ -- Add a tabulation.
+ -- Every new line will start at this tabulation.
+ procedure Add_Tab is
+ begin
+ Ctx.Tab := Ctx.Tab + 2;
+ Ctx.Next_Tab := Ctx.Tab;
+ end Add_Tab;
+
+ -- Removed a tabulation.
+ -- The next new line will start at the previous tabulation.
+ procedure Rem_Tab is
+ begin
+ Ctx.Tab := Ctx.Tab - 2;
+ Ctx.Next_Tab := Ctx.Tab;
+ end Rem_Tab;
+
+ procedure Set_Mark is
+ begin
+ Ctx.Mark := Ctx.Line_Len;
+ end Set_Mark;
+ end Formated_Output;
+
+ use Formated_Output;
+
+ procedure Init_Context (File : Interfaces.C_Streams.FILEs) is
+ begin
+ Formated_Output.Init_Context (File);
+ end Init_Context;
+
+ procedure Disp_Enode (E : O_Enode);
+ procedure Disp_Lnode (Node : O_Lnode);
+ procedure Disp_Snode (First, Last : O_Snode);
+ procedure Disp_Dnode (Decl : O_Dnode);
+ procedure Disp_Tnode (Atype : O_Tnode; Full : Boolean);
+
+ procedure Disp_Ident (Id : O_Ident) is
+ begin
+ Put (Get_String (Id));
+ end Disp_Ident;
+
+ procedure Disp_Tnode_Name (Atype : O_Tnode) is
+ begin
+ Disp_Tnode (Atype, False);
+ end Disp_Tnode_Name;
+
+ procedure Disp_Dnode_Name (Decl : O_Dnode) is
+ begin
+ Disp_Ident (Decl.Name);
+ end Disp_Dnode_Name;
+
+ procedure Disp_Loop_Name (Stmt : O_Snode) is
+ begin
+ Put ("loop" & Natural'Image (Stmt.Loop_Level));
+ end Disp_Loop_Name;
+
+ function Get_Enode_Name (Kind : OE_Kind) return String
+ is
+ begin
+ case Kind is
+-- when OE_Boolean_Lit =>
+-- return "boolean_lit";
+-- when OE_Unsigned_Lit =>
+-- return "unsigned_lit";
+-- when OE_Signed_Lit =>
+-- return "signed lit";
+-- when OE_Float_Lit =>
+-- return "float lit";
+-- when OE_Null_Lit =>
+-- return "null lit";
+-- when OE_Enum_Lit =>
+-- return "enum lit";
+
+-- when OE_Sizeof_Lit =>
+-- return "sizeof lit";
+-- when OE_Offsetof_Lit =>
+-- return "offsetof lit";
+-- when OE_Aggregate =>
+-- return "aggregate";
+-- when OE_Aggr_Element =>
+-- return "aggr_element";
+-- when OE_Union_Aggr =>
+-- return "union aggr";
+
+ when OE_Lit =>
+ return "lit";
+ when OE_Add_Ov =>
+ return "+#";
+ when OE_Sub_Ov =>
+ return "-#";
+ when OE_Mul_Ov =>
+ return "*#";
+ when OE_Div_Ov =>
+ return "/#";
+ when OE_Rem_Ov =>
+ return "rem#";
+ when OE_Mod_Ov =>
+ return "mod#";
+ when OE_Exp_Ov =>
+ return "**#";
+
+ when OE_And =>
+ return "and";
+ when OE_Or =>
+ return "or";
+ when OE_Xor =>
+ return "xor";
+ when OE_And_Then =>
+ return "and_then";
+ when OE_Or_Else =>
+ return "or_else";
+
+ when OE_Not =>
+ return "not";
+ when OE_Neg_Ov =>
+ return "-";
+ when OE_Abs_Ov =>
+ return "abs";
+
+ when OE_Eq =>
+ return "=";
+ when OE_Neq =>
+ return "/=";
+ when OE_Le =>
+ return "<=";
+ when OE_Lt =>
+ return "<";
+ when OE_Ge =>
+ return ">=";
+ when OE_Gt =>
+ return ">";
+
+ when OE_Function_Call =>
+ return "function call";
+ when OE_Convert_Ov =>
+ return "convert_ov";
+ when OE_Address =>
+ return "address";
+ when OE_Unchecked_Address =>
+ return "unchecked_address";
+-- when OE_Subprogram_Address =>
+-- return "subprg_address";
+ when OE_Alloca =>
+ return "alloca";
+ when OE_Value =>
+ return "value";
+ when OE_Nil =>
+ return "??";
+ end case;
+ end Get_Enode_Name;
+
+ function Get_Lnode_Name (Kind : OL_Kind) return String
+ is
+ begin
+ case Kind is
+ when OL_Obj =>
+ return "obj";
+ when OL_Indexed_Element =>
+ return "indexed_element";
+ when OL_Slice =>
+ return "slice";
+ when OL_Selected_Element =>
+ return "selected_element";
+ when OL_Access_Element =>
+ return "access_element";
+-- when OL_Param_Ref =>
+-- return "param_ref";
+-- when OL_Var_Ref =>
+-- return "var_ref";
+-- when OL_Const_Ref =>
+-- return "const_ref";
+ end case;
+ end Get_Lnode_Name;
+
+ procedure Disp_Enode_Name (Kind : OE_Kind) is
+ begin
+ Put (Get_Enode_Name (Kind));
+ end Disp_Enode_Name;
+
+ procedure Disp_Assoc_List (Head : O_Anode)
+ is
+ El : O_Anode;
+ begin
+ El := Head;
+ Put ("(");
+ if El /= null then
+ loop
+ Disp_Enode (El.Actual);
+ El := El.Next;
+ exit when El = null;
+ Put (", ");
+ end loop;
+ end if;
+ Put (")");
+ end Disp_Assoc_List;
+
+ function Image (Lit : Integer) return String
+ is
+ S : String := Integer'Image (Lit);
+ begin
+ if S (1) = ' ' then
+ return S (2 .. S'Length);
+ else
+ return S;
+ end if;
+ end Image;
+
+ procedure Disp_Lit (Lit_Type : O_Tnode; Str : String) is
+ begin
+ if False then
+ Put_Trim (Str);
+ else
+ Disp_Tnode_Name (Lit_Type);
+ Put ("'[");
+ Put_Trim (Str);
+ Put (']');
+ end if;
+ end Disp_Lit;
+
+ procedure Disp_Cnode (C : O_Cnode) is
+ begin
+ case C.Kind is
+ when OC_Unsigned_Lit =>
+ if False and then (C.U_Val >= Character'Pos(' ')
+ and C.U_Val <= Character'Pos ('~'))
+ then
+ Put (''');
+ Put (Character'Val (C.U_Val));
+ Put (''');
+ else
+ Disp_Lit (C.Ctype, Unsigned_64'Image (C.U_Val));
+ end if;
+ when OC_Signed_Lit =>
+ Disp_Lit (C.Ctype, Integer_64'Image (C.S_Val));
+ when OC_Float_Lit =>
+ Disp_Lit (C.Ctype, IEEE_Float_64'Image (C.F_Val));
+ when OC_Boolean_Lit =>
+ Disp_Lit (C.Ctype, Get_String (C.B_Id));
+ when OC_Null_Lit =>
+ Disp_Lit (C.Ctype, "null");
+ when OC_Enum_Lit =>
+ Disp_Lit (C.Ctype, Get_String (C.E_Name));
+ when OC_Sizeof_Lit =>
+ Disp_Tnode_Name (C.Ctype);
+ Put ("'sizeof (");
+ Disp_Tnode_Name (C.S_Type);
+ Put (")");
+ when OC_Offsetof_Lit =>
+ Disp_Tnode_Name (C.Ctype);
+ Put ("'offsetof (");
+ Disp_Tnode_Name (C.Off_Field.Parent);
+ Put (".");
+ Disp_Ident (C.Off_Field.Ident);
+ Put (")");
+ when OC_Aggregate =>
+ declare
+ El : O_Cnode;
+ Field : O_Fnode;
+ begin
+ Put ('{');
+ El := C.Aggr_Els;
+ if C.Ctype.Kind = ON_Record_Type then
+ Field := C.Ctype.Elements;
+ else
+ Field := null;
+ end if;
+ if El /= null then
+ loop
+ Set_Mark;
+ if Field /= null then
+ Put ('.');
+ Disp_Ident (Field.Ident);
+ Put (" = ");
+ Field := Field.Next;
+ end if;
+ Disp_Cnode (El.Aggr_Value);
+ El := El.Aggr_Next;
+ exit when El = null;
+ Put (", ");
+ end loop;
+ end if;
+ Put ('}');
+ end;
+ when OC_Aggr_Element =>
+ Disp_Cnode (C.Aggr_Value);
+ when OC_Union_Aggr =>
+ Put ('{');
+ Put ('.');
+ Disp_Ident (C.Uaggr_Field.Ident);
+ Put (" = ");
+ Disp_Cnode (C.Uaggr_Value);
+ Put ('}');
+ when OC_Address =>
+ Disp_Tnode_Name (C.Ctype);
+ Put ("'address (");
+ Disp_Dnode_Name (C.Decl);
+ Put (")");
+ when OC_Unchecked_Address =>
+ Disp_Tnode_Name (C.Ctype);
+ Put ("'unchecked_address (");
+ Disp_Dnode_Name (C.Decl);
+ Put (")");
+ when OC_Subprogram_Address =>
+ Disp_Tnode_Name (C.Ctype);
+ Put ("'subprg_addr (");
+ Disp_Dnode_Name (C.Decl);
+ Put (")");
+ end case;
+ end Disp_Cnode;
+
+ procedure Disp_Enode (E : O_Enode)
+ is
+ begin
+ case E.Kind is
+ when OE_Lit =>
+ Disp_Cnode (E.Lit);
+ when OE_Dyadic_Expr_Kind =>
+ Put ("(");
+ Disp_Enode (E.Left);
+ Put (' ');
+ Disp_Enode_Name (E.Kind);
+ Put (' ');
+ Disp_Enode (E.Right);
+ Put (')');
+ when OE_Compare_Expr_Kind =>
+ Disp_Tnode_Name (E.Rtype);
+ Put ("'(");
+ Disp_Enode (E.Left);
+ Put (' ');
+ Disp_Enode_Name (E.Kind);
+ Put (' ');
+ Disp_Enode (E.Right);
+ Put (')');
+ when OE_Monadic_Expr_Kind =>
+ Disp_Enode_Name (E.Kind);
+ if E.Kind /= OE_Neg_Ov then
+ Put (' ');
+ end if;
+ Disp_Enode (E.Operand);
+ when OE_Address =>
+ Disp_Tnode_Name (E.Rtype);
+ Put ("'address (");
+ Disp_Lnode (E.Lvalue);
+ Put (")");
+ when OE_Unchecked_Address =>
+ Disp_Tnode_Name (E.Rtype);
+ Put ("'unchecked_address (");
+ Disp_Lnode (E.Lvalue);
+ Put (")");
+ when OE_Convert_Ov =>
+ Disp_Tnode_Name (E.Rtype);
+ Put ("'conv (");
+ Disp_Enode (E.Conv);
+ Put (')');
+ when OE_Function_Call =>
+ Disp_Dnode_Name (E.Func);
+ Put (' ');
+ Disp_Assoc_List (E.Assoc);
+ when OE_Alloca =>
+ Disp_Tnode_Name (E.Rtype);
+ Put ("'alloca (");
+ Disp_Enode (E.A_Size);
+ Put (')');
+ when OE_Value =>
+ Disp_Lnode (E.Value);
+ when OE_Nil =>
+ null;
+ end case;
+ end Disp_Enode;
+
+ procedure Disp_Lnode (Node : O_Lnode) is
+ begin
+ case Node.Kind is
+ when OL_Obj =>
+ Disp_Dnode_Name (Node.Obj);
+ when OL_Access_Element =>
+ Disp_Enode (Node.Acc_Base);
+ Put (".all");
+ when OL_Indexed_Element =>
+ Disp_Lnode (Node.Array_Base);
+ Put ('[');
+ Disp_Enode (Node.Index);
+ Put (']');
+ when OL_Slice =>
+ Disp_Lnode (Node.Slice_Base);
+ Put ('[');
+ Disp_Enode (Node.Slice_Index);
+ Put ("...]");
+ when OL_Selected_Element =>
+ Disp_Lnode (Node.Rec_Base);
+ Put ('.');
+ Disp_Ident (Node.Rec_El.Ident);
+-- when OL_Var_Ref
+-- | OL_Const_Ref
+-- | OL_Param_Ref =>
+-- Disp_Dnode_Name (Node.Decl);
+ end case;
+ end Disp_Lnode;
+
+ procedure Disp_Fnodes (First : O_Fnode)
+ is
+ El : O_Fnode;
+ begin
+ Add_Tab;
+ El := First;
+ while El /= null loop
+ Disp_Ident (El.Ident);
+ Put (": ");
+ Disp_Tnode (El.Ftype, False);
+ Put_Line ("; ");
+ El := El.Next;
+ end loop;
+ Rem_Tab;
+ end Disp_Fnodes;
+
+ procedure Disp_Tnode (Atype : O_Tnode; Full : Boolean) is
+ begin
+ if not Full and Atype.Decl /= null then
+ Disp_Ident (Atype.Decl.Name);
+ return;
+ end if;
+ case Atype.Kind is
+ when ON_Boolean_Type =>
+ Put ("boolean {");
+ Disp_Ident (Atype.False_N.B_Id);
+ Put (", ");
+ Disp_Ident (Atype.True_N.B_Id);
+ Put ("}");
+ when ON_Unsigned_Type =>
+ Put ("unsigned (");
+ Put_Trim (Unsigned_32'Image (8 * Atype.Size));
+ Put (")");
+ when ON_Signed_Type =>
+ Put ("signed (");
+ Put_Trim (Unsigned_32'Image (8 * Atype.Size));
+ Put (")");
+ when ON_Float_Type =>
+ Put ("float");
+ when ON_Enum_Type =>
+ declare
+ El : O_Cnode;
+ begin
+ Put ("enum {");
+ El := Atype.Literals;
+ while El /= O_Cnode_Null loop
+ Set_Mark;
+ Disp_Ident (El.E_Name);
+ Put (" = ");
+ Put (Image (El.E_Val));
+ El := El.E_Next;
+ exit when El = O_Cnode_Null;
+ Put (", ");
+ end loop;
+ Put ("}");
+ end;
+ when ON_Array_Type =>
+ Put ("array [");
+ Disp_Tnode (Atype.Index_Type, False);
+ Put ("] of ");
+ Disp_Tnode (Atype.El_Type, False);
+ when ON_Access_Type =>
+ Put ("access ");
+ if Atype.D_Type /= O_Tnode_Null then
+ Disp_Tnode (Atype.D_Type, False);
+ end if;
+ when ON_Record_Type =>
+ Put_Line ("record ");
+ Disp_Fnodes (Atype.Elements);
+ Put ("end record");
+ when ON_Union_Type =>
+ Put_Line ("union ");
+ Disp_Fnodes (Atype.Elements);
+ Put ("end union");
+ when ON_Array_Sub_Type =>
+ Put ("subarray ");
+ Disp_Tnode_Name (Atype.Base_Type);
+ Put ("[");
+ Disp_Cnode (Atype.Length);
+ Put ("]");
+ end case;
+ end Disp_Tnode;
+
+ procedure Disp_Storage_Name (Storage : O_Storage) is
+ begin
+ case Storage is
+ when O_Storage_External =>
+ Put ("external");
+ when O_Storage_Public =>
+ Put ("public");
+ when O_Storage_Private =>
+ Put ("private");
+ when O_Storage_Local =>
+ Put ("local");
+ end case;
+ end Disp_Storage_Name;
+
+ procedure Disp_Decls (Decls : O_Dnode)
+ is
+ El : O_Dnode;
+ begin
+ El := Decls;
+ while El /= null loop
+ Disp_Dnode (El);
+ El := El.Next;
+ if Is_Top then
+ -- NOTE: some declaration does not disp anything, so there may be
+ -- double new line.
+ New_Line;
+ end if;
+ end loop;
+ end Disp_Decls;
+
+ procedure Disp_Function_Decl (Decl : O_Dnode) is
+ begin
+ Disp_Storage_Name (Decl.Storage);
+ Put (" ");
+ if Decl.Dtype = null then
+ Put ("procedure ");
+ else
+ Put ("function ");
+ end if;
+ Disp_Ident (Decl.Name);
+ Put_Line (" (");
+ Add_Tab;
+ declare
+ El : O_Dnode;
+ begin
+ El := Decl.Interfaces;
+ if El /= null then
+ loop
+ Disp_Dnode (El);
+ El := El.Next;
+ exit when El = null;
+ Put_Line (";");
+ end loop;
+ end if;
+ Put (")");
+ end;
+ if Decl.Dtype /= null then
+ New_Line;
+ Put ("return ");
+ Disp_Tnode (Decl.Dtype, False);
+ end if;
+ Rem_Tab;
+ end Disp_Function_Decl;
+
+ procedure Disp_Dnode (Decl : O_Dnode) is
+ begin
+ case Decl.Kind is
+ when ON_Type_Decl =>
+ Put ("type ");
+ Disp_Ident (Decl.Name);
+ Put (" is ");
+ if not Decl.Dtype.Uncomplete then
+ Disp_Tnode (Decl.Dtype, True);
+ else
+ case Decl.Dtype.Kind is
+ when ON_Record_Type =>
+ Put ("record");
+ when ON_Access_Type =>
+ Put ("access");
+ when others =>
+ raise Program_Error;
+ end case;
+ end if;
+ Put_Line (";");
+ when ON_Completed_Type_Decl =>
+ Put ("type ");
+ Disp_Ident (Decl.Name);
+ Put (" is ");
+ Disp_Tnode (Decl.Dtype, True);
+ Put_Line (";");
+ when ON_Const_Decl =>
+ Disp_Storage_Name (Decl.Storage);
+ Put (" ");
+ Put ("constant ");
+ Disp_Ident (Decl.Name);
+ Put (" : ");
+ Disp_Tnode_Name (Decl.Dtype);
+ Put_Line (";");
+ when ON_Const_Value =>
+ Put ("constant ");
+ Disp_Ident (Decl.Name);
+ Put (" := ");
+ Disp_Cnode (Decl.Value);
+ Put_Line (";");
+ when ON_Var_Decl =>
+ Disp_Storage_Name (Decl.Storage);
+ Put (" ");
+ Put ("var ");
+ Disp_Ident (Decl.Name);
+ Put (" : ");
+ Disp_Tnode_Name (Decl.Dtype);
+ Put_Line (";");
+ when ON_Function_Decl =>
+ if Decl.Next = null or Decl.Next /= Decl.Func_Body then
+ -- This is a forward/external declaration.
+ Disp_Function_Decl (Decl);
+ Put_Line (";");
+ end if;
+ when ON_Function_Body =>
+ Disp_Function_Decl (Decl.Func_Decl);
+ New_Line;
+ Disp_Snode (Decl.Func_Stmt, Decl.Func_Stmt);
+ when ON_Interface_Decl =>
+ Disp_Ident (Decl.Name);
+ Put (": ");
+ Disp_Tnode (Decl.Dtype, False);
+ when ON_Debug_Line_Decl =>
+ Put_Line ("--#" & Natural'Image (Decl.Line));
+ when ON_Debug_Comment_Decl =>
+ Put_Line ("-- " & Decl.Comment.all);
+ when ON_Debug_Filename_Decl =>
+ Put_Line ("--F " & Decl.Filename.all);
+ end case;
+ end Disp_Dnode;
+
+ procedure Disp_Snode (First : O_Snode; Last : O_Snode) is
+ Stmt : O_Snode;
+ begin
+ Stmt := First;
+ loop
+ --if Stmt.Kind = ON_Elsif_Stmt or Stmt.Kind = ON_When_Stmt then
+ -- Put_Indent (Tab - 1);
+ --else
+ -- Put_Indent (Tab);
+ --end if;
+ case Stmt.Kind is
+ when ON_Declare_Stmt =>
+ Put_Line ("declare");
+ Add_Tab;
+ Disp_Decls (Stmt.Decls);
+ Rem_Tab;
+ Put_Line ("begin");
+ Add_Tab;
+ if Stmt.Stmts /= null then
+ Disp_Snode (Stmt.Stmts, null);
+ end if;
+ Rem_Tab;
+ Put_Line ("end;");
+ when ON_Assign_Stmt =>
+ Disp_Lnode (Stmt.Target);
+ Put (" := ");
+ Disp_Enode (Stmt.Value);
+ Put_Line (";");
+ when ON_Return_Stmt =>
+ Put ("return ");
+ if Stmt.Ret_Val /= null then
+ Disp_Enode (Stmt.Ret_Val);
+ end if;
+ Put_Line (";");
+ when ON_If_Stmt =>
+ Add_Tab;
+ Disp_Snode (Stmt.Next, Stmt.If_Last);
+ Stmt := Stmt.If_Last;
+ Rem_Tab;
+ Put_Line ("end if;");
+ when ON_Elsif_Stmt =>
+ Rem_Tab;
+ if Stmt.Cond = null then
+ Put_Line ("else");
+ else
+ if First = Stmt then
+ Put ("if ");
+ else
+ Put ("elsif ");
+ end if;
+ Disp_Enode (Stmt.Cond);
+ Put_Line (" then");
+ end if;
+ Add_Tab;
+ when ON_Loop_Stmt =>
+ Disp_Loop_Name (Stmt);
+ Put_Line (":");
+ Add_Tab;
+ Disp_Snode (Stmt.Next, Stmt.Loop_Last);
+ Stmt := Stmt.Loop_Last;
+ Rem_Tab;
+ Put_Line ("end loop;");
+ when ON_Exit_Stmt =>
+ Put ("exit ");
+ Disp_Loop_Name (Stmt.Loop_Id);
+ Put_Line (";");
+ when ON_Next_Stmt =>
+ Put ("next ");
+ Disp_Loop_Name (Stmt.Loop_Id);
+ Put_Line (";");
+ when ON_Case_Stmt =>
+ Put ("case ");
+ Disp_Enode (Stmt.Selector);
+ Put_Line (" is");
+ Add_Tab;
+ Disp_Snode (Stmt.Next, Stmt.Case_Last);
+ Stmt := Stmt.Case_Last;
+ Rem_Tab;
+ Put_Line ("end case;");
+ when ON_When_Stmt =>
+ declare
+ Choice: O_Choice;
+ begin
+ Rem_Tab;
+ Choice := Stmt.Choice_List;
+ while Choice /= null loop
+ Put ("when ");
+ case Choice.Kind is
+ when ON_Choice_Expr =>
+ Disp_Cnode (Choice.Expr);
+ when ON_Choice_Range =>
+ Disp_Cnode (Choice.Low);
+ Put (" ... ");
+ Disp_Cnode (Choice.High);
+ when ON_Choice_Default =>
+ Put ("default");
+ end case;
+ Put_Line (" =>");
+ Choice := Choice.Next;
+ end loop;
+ Add_Tab;
+ end;
+ when ON_Call_Stmt =>
+ Disp_Dnode_Name (Stmt.Proc);
+ Put (' ');
+ Disp_Assoc_List (Stmt.Assoc);
+ Put_Line (";");
+ when ON_Debug_Line_Stmt =>
+ Put_Line ("--#" & Natural'Image (Stmt.Line));
+ when ON_Debug_Comment_Stmt =>
+ Put_Line ("-- " & Stmt.Comment.all);
+ end case;
+ exit when Stmt = Last;
+ Stmt := Stmt.Next;
+ exit when Stmt = null and Last = null;
+ end loop;
+ end Disp_Snode;
+
+ procedure Disp_Ortho (Decls : O_Snode) is
+ begin
+ Disp_Decls (Decls.Decls);
+ Flush;
+ end Disp_Ortho;
+
+ procedure Disp_Tnode_Decl (N : O_Tnode) is
+ begin
+ Disp_Ident (N.Decl.Name);
+ Put (" : ");
+ Disp_Tnode (N, True);
+ end Disp_Tnode_Decl;
+
+ procedure Debug_Tnode (N : O_Tnode)
+ is
+ Ctx : Disp_Context;
+ begin
+ Push_Context (Interfaces.C_Streams.stdout, Ctx);
+ Disp_Tnode_Decl (N);
+ Pop_Context (Ctx);
+ end Debug_Tnode;
+
+ procedure Debug_Enode (N : O_Enode)
+ is
+ Ctx : Disp_Context;
+ begin
+ Push_Context (Interfaces.C_Streams.stdout, Ctx);
+ Disp_Enode (N);
+ Put (" : ");
+ Disp_Tnode_Decl (N.Rtype);
+ Pop_Context (Ctx);
+ end Debug_Enode;
+
+ procedure Debug_Fnode (N : O_Fnode)
+ is
+ Ctx : Disp_Context;
+ begin
+ Push_Context (Interfaces.C_Streams.stdout, Ctx);
+ Disp_Ident (N.Ident);
+ Put (": ");
+ Disp_Tnode (N.Ftype, False);
+ Pop_Context (Ctx);
+ end Debug_Fnode;
+
+ procedure Debug_Dnode (N : O_Dnode)
+ is
+ Ctx : Disp_Context;
+ begin
+ Push_Context (Interfaces.C_Streams.stdout, Ctx);
+ Disp_Dnode (N);
+ Pop_Context (Ctx);
+ end Debug_Dnode;
+
+ procedure Debug_Lnode (N : O_Lnode)
+ is
+ Ctx : Disp_Context;
+ begin
+ Push_Context (Interfaces.C_Streams.stdout, Ctx);
+ Disp_Lnode (N);
+ Put (" : ");
+ Disp_Tnode_Decl (N.Rtype);
+ Pop_Context (Ctx);
+ end Debug_Lnode;
+
+ procedure Debug_Snode (N : O_Snode)
+ is
+ Ctx : Disp_Context;
+ begin
+ Push_Context (Interfaces.C_Streams.stdout, Ctx);
+ Disp_Snode (N, null);
+ Pop_Context (Ctx);
+ end Debug_Snode;
+end Ortho_Debug.Disp;
diff --git a/ortho/debug/ortho_debug-disp.ads b/ortho/debug/ortho_debug-disp.ads
new file mode 100644
index 0000000..1f8a028
--- /dev/null
+++ b/ortho/debug/ortho_debug-disp.ads
@@ -0,0 +1,12 @@
+with Interfaces.C_Streams;
+
+package Ortho_Debug.Disp is
+ -- Initialize the current context.
+ -- Must be called before any use of the DISP_* subprograms.
+ procedure Init_Context (File : Interfaces.C_Streams.FILEs);
+
+ -- Disp nodes in a pseudo-language.
+ procedure Disp_Ortho (Decls : O_Snode);
+
+private
+end Ortho_Debug.Disp;
diff --git a/ortho/debug/ortho_debug-main.adb b/ortho/debug/ortho_debug-main.adb
new file mode 100644
index 0000000..7da84d5
--- /dev/null
+++ b/ortho/debug/ortho_debug-main.adb
@@ -0,0 +1,133 @@
+with Ada.Command_Line; use Ada.Command_Line;
+with Ada.Unchecked_Deallocation;
+with Ada.Text_IO; use Ada.Text_IO;
+with Ortho_Debug; use Ortho_Debug;
+with Ortho_Debug_Front; use Ortho_Debug_Front;
+with Ortho_Debug.Disp;
+with System; use System;
+with Interfaces.C_Streams; use Interfaces.C_Streams;
+
+procedure Ortho_Debug.Main is
+ -- Do not output the ortho code.
+ Flag_Silent : Boolean := False;
+
+ -- Force output, even in case of crash.
+ Flag_Force : Boolean := False;
+
+ I : Natural;
+ Argc : Natural;
+ Arg : String_Acc;
+ Opt : String_Acc;
+ Res : Natural;
+ File : String_Acc;
+ Output : FILEs;
+ R : Boolean;
+
+ procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation
+ (Name => String_Acc, Object => String);
+begin
+ Ortho_Debug_Front.Init;
+ Output := NULL_Stream;
+
+ Set_Exit_Status (Failure);
+
+ -- Decode options.
+ Argc := Argument_Count;
+ I := 1;
+ loop
+ exit when I > Argc;
+ exit when Argument (I) (1) /= '-';
+ if Argument (I) = "--silent" or else Argument (I) = "-quiet" then
+ Flag_Silent := True;
+ I := I + 1;
+ elsif Argument (I) = "--force" then
+ Flag_Force := True;
+ I := I + 1;
+ elsif Argument (I)'Length >= 2 and then Argument (I)(2) = 'g' then
+ -- Skip -g[XXX] flags.
+ I := I + 1;
+ elsif Argument (I) = "-o" and then I + 1 <= Argc then
+ -- TODO: write the output to the file ?
+ if Output /= NULL_Stream then
+ Put_Line (Command_Name & ": only one output allowed");
+ return;
+ end if;
+ declare
+ Name : String := Argument (I + 1) & ASCII.Nul;
+ Mode : String := 'w' & ASCII.Nul;
+ begin
+ Output := fopen (Name'Address, Mode'Address);
+ if Output = NULL_Stream then
+ Put_Line (Command_Name & ": cannot open " & Argument (I + 1));
+ return;
+ end if;
+ end;
+ I := I + 2;
+ else
+ Opt := new String'(Argument (I));
+ if I < Argc then
+ Arg := new String'(Argument (I + 1));
+ else
+ Arg := null;
+ end if;
+ Res := Ortho_Debug_Front.Decode_Option (Opt, Arg);
+ Unchecked_Deallocation (Opt);
+ Unchecked_Deallocation (Arg);
+ if Res = 0 then
+ Put_Line (Argument (I) & ": unknown option");
+ return;
+ else
+ I := I + Res;
+ end if;
+ end if;
+ end loop;
+
+ -- Initialize tree.
+ begin
+ Ortho_Debug.Init;
+
+ if I <= Argc then
+ R := True;
+ for J in I .. Argc loop
+ File := new String'(Argument (J));
+ R := R and Ortho_Debug_Front.Parse (File);
+ Unchecked_Deallocation (File);
+ end loop;
+ else
+ R := Ortho_Debug_Front.Parse (null);
+ end if;
+ Ortho_Debug.Finish;
+ exception
+ when others =>
+ if not Flag_Force then
+ raise;
+ else
+ R := False;
+ end if;
+ end;
+
+ -- Write down the result.
+ if (R and (Output /= NULL_Stream or not Flag_Silent))
+ or Flag_Force
+ then
+ if Output = NULL_Stream then
+ Ortho_Debug.Disp.Init_Context (stdout);
+ else
+ Ortho_Debug.Disp.Init_Context (Output);
+ end if;
+ Ortho_Debug.Disp.Disp_Ortho (Ortho_Debug.Top);
+ if Output /= NULL_Stream then
+ declare
+ Status : int;
+ begin
+ Status := fclose (Output);
+ end;
+ end if;
+ end if;
+
+ if R then
+ Set_Exit_Status (Success);
+ else
+ Set_Exit_Status (Failure);
+ end if;
+end Ortho_Debug.Main;
diff --git a/ortho/debug/ortho_debug.adb b/ortho/debug/ortho_debug.adb
new file mode 100644
index 0000000..0e6a616
--- /dev/null
+++ b/ortho/debug/ortho_debug.adb
@@ -0,0 +1,1959 @@
+with Ada.Unchecked_Deallocation;
+
+package body Ortho_Debug is
+ -- Metrics:
+ -- Alignment and size for an address.
+ Metric_Access_Align : constant Natural := 2;
+ Metric_Access_Size : constant Unsigned_32 := 4;
+
+ type ON_Op_To_OE_Type is array (ON_Op_Kind) of OE_Kind;
+ ON_Op_To_OE : constant ON_Op_To_OE_Type :=
+ (
+ ON_Nil => OE_Nil,
+
+ -- Dyadic operations.
+ ON_Add_Ov => OE_Add_Ov,
+ ON_Sub_Ov => OE_Sub_Ov,
+ ON_Mul_Ov => OE_Mul_Ov,
+ ON_Div_Ov => OE_Div_Ov,
+ ON_Rem_Ov => OE_Rem_Ov,
+ ON_Mod_Ov => OE_Mod_Ov,
+
+ -- Binary operations.
+ ON_And => OE_And,
+ ON_Or => OE_Or,
+ ON_Xor => OE_Xor,
+ ON_And_Then => OE_And_Then,
+ ON_Or_Else => OE_Or_Else,
+
+ -- Monadic operations.
+ ON_Not => OE_Not,
+ ON_Neg_Ov => OE_Neg_Ov,
+ ON_Abs_Ov => OE_Abs_Ov,
+
+ -- Comparaisons
+ ON_Eq => OE_Eq,
+ ON_Neq => OE_Neq,
+ ON_Le => OE_Le,
+ ON_Lt => OE_Lt,
+ ON_Ge => OE_Ge,
+ ON_Gt => OE_Gt
+ );
+
+ type Decl_Scope_Type is record
+ -- Declarations are chained.
+ Parent : O_Snode;
+ Last_Decl : O_Dnode;
+ Last_Stmt : O_Snode;
+
+ -- If this scope corresponds to a function, PREV_FUNCTION contains
+ -- the previous function.
+ Prev_Function : O_Dnode;
+
+ -- Declaration scopes are chained.
+ Prev : Decl_Scope_Acc;
+ end record;
+
+ type Stmt_Kind is
+ (Stmt_Function, Stmt_Declare, Stmt_If, Stmt_Loop, Stmt_Case);
+ type Stmt_Scope_Type (Kind : Stmt_Kind);
+ type Stmt_Scope_Acc is access Stmt_Scope_Type;
+ type Stmt_Scope_Type (Kind : Stmt_Kind) is record
+ -- Statement which created this scope.
+ Parent : O_Snode;
+ -- Previous (parent) scope.
+ Prev : Stmt_Scope_Acc;
+ case Kind is
+ when Stmt_Function =>
+ Prev_Function : Stmt_Scope_Acc;
+ -- Declaration for the function.
+ Decl : O_Dnode;
+ when Stmt_Declare =>
+ null;
+ when Stmt_If =>
+ Last_Elsif : O_Snode;
+ when Stmt_Loop =>
+ null;
+ when Stmt_Case =>
+ Last_Branch : O_Snode;
+ Last_Choice : O_Choice;
+ Case_Type : O_Tnode;
+ end case;
+ end record;
+ subtype Stmt_Function_Scope_Type is Stmt_Scope_Type (Stmt_Function);
+ subtype Stmt_Declare_Scope_Type is Stmt_Scope_Type (Stmt_Declare);
+ subtype Stmt_If_Scope_Type is Stmt_Scope_Type (Stmt_If);
+ subtype Stmt_Loop_Scope_Type is Stmt_Scope_Type (Stmt_Loop);
+ subtype Stmt_Case_Scope_Type is Stmt_Scope_Type (Stmt_Case);
+
+ Current_Stmt_Scope : Stmt_Scope_Acc := null;
+ Current_Function : Stmt_Scope_Acc := null;
+ Current_Decl_Scope : Decl_Scope_Acc := null;
+ Current_Loop_Level : Natural := 0;
+
+ procedure Push_Decl_Scope (Parent : O_Snode)
+ is
+ Res : Decl_Scope_Acc;
+ begin
+ Res := new Decl_Scope_Type'(Parent => Parent,
+ Last_Decl => null,
+ Last_Stmt => null,
+ Prev_Function => null,
+ Prev => Current_Decl_Scope);
+ Parent.Alive := True;
+ Current_Decl_Scope := Res;
+ end Push_Decl_Scope;
+
+ procedure Pop_Decl_Scope
+ is
+ procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation
+ (Object => Decl_Scope_Type, Name => Decl_Scope_Acc);
+ Old : Decl_Scope_Acc;
+ begin
+ Old := Current_Decl_Scope;
+ Old.Parent.Alive := False;
+ Current_Decl_Scope := Old.Prev;
+ Unchecked_Deallocation (Old);
+ end Pop_Decl_Scope;
+
+ procedure Add_Decl (El : O_Dnode; Check_Dup : Boolean := True) is
+ begin
+ if Current_Decl_Scope = null then
+ -- Not yet initialized, or after compilation.
+ raise Program_Error;
+ end if;
+
+ -- Note: this requires an hashed ident table.
+ -- Use ortho_ident_hash.
+ if False and then Check_Dup
+ and then not Is_Nul (El.Name)
+ then
+ -- Check the name is not already defined.
+ declare
+ E : O_Dnode;
+ begin
+ E := Current_Decl_Scope.Parent.Decls;
+ while E /= O_Dnode_Null loop
+ if Is_Equal (E.Name, El.Name) then
+ raise Syntax_Error;
+ end if;
+ E := E.Next;
+ end loop;
+ end;
+ end if;
+
+ if Current_Decl_Scope.Last_Decl = null then
+ if Current_Decl_Scope.Parent.Kind = ON_Declare_Stmt then
+ Current_Decl_Scope.Parent.Decls := El;
+ else
+ raise Type_Error;
+ end if;
+ else
+ Current_Decl_Scope.Last_Decl.Next := El;
+ end if;
+ El.Next := null;
+ Current_Decl_Scope.Last_Decl := El;
+ end Add_Decl;
+
+ procedure Add_Stmt (Stmt : O_Snode)
+ is
+ begin
+ if Current_Decl_Scope = null or Current_Function = null then
+ -- You are adding a statement at the global level, ie not inside
+ -- a function.
+ raise Syntax_Error;
+ end if;
+
+ Stmt.Next := null;
+ if Current_Decl_Scope.Last_Stmt = null then
+ if Current_Decl_Scope.Parent.Kind = ON_Declare_Stmt then
+ Current_Decl_Scope.Parent.Stmts := Stmt;
+ else
+ raise Syntax_Error;
+ end if;
+ else
+ Current_Decl_Scope.Last_Stmt.Next := Stmt;
+ end if;
+ Current_Decl_Scope.Last_Stmt := Stmt;
+ end Add_Stmt;
+
+ procedure Push_Stmt_Scope (Scope : Stmt_Scope_Acc)
+ is
+ begin
+ if Scope.Prev /= Current_Stmt_Scope then
+ -- SCOPE was badly initialized.
+ raise Program_Error;
+ end if;
+ Current_Stmt_Scope := Scope;
+ end Push_Stmt_Scope;
+
+ procedure Pop_Stmt_Scope (Kind : Stmt_Kind)
+ is
+ procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation
+ (Object => Stmt_Scope_Type, Name => Stmt_Scope_Acc);
+ Old : Stmt_Scope_Acc;
+ begin
+ Old := Current_Stmt_Scope;
+ if Old.Kind /= Kind then
+ raise Syntax_Error;
+ end if;
+ --Old.Parent.Last_Stmt := Current_Decl_Scope.Last_Stmt;
+ Current_Stmt_Scope := Old.Prev;
+ Unchecked_Deallocation (Old);
+ end Pop_Stmt_Scope;
+
+ -- Check declaration DECL is reachable, ie its scope is in the current
+ -- stack of scopes.
+ procedure Check_Scope (Decl : O_Dnode)
+ is
+ Res : Boolean;
+ begin
+ case Decl.Kind is
+ when ON_Interface_Decl =>
+ Res := Decl.Func_Scope.Alive;
+ when others =>
+ Res := Decl.Scope.Alive;
+ end case;
+ if not Res then
+ raise Syntax_Error;
+ end if;
+ end Check_Scope;
+
+ -- Raise SYNTAX_ERROR if OBJ is not at a constant address.
+-- procedure Check_Const_Address (Obj : O_Lnode) is
+-- begin
+-- case Obj.Kind is
+-- when OL_Const_Ref
+-- | OL_Var_Ref =>
+-- case Obj.Decl.Storage is
+-- when O_Storage_External
+-- | O_Storage_Public
+-- | O_Storage_Private =>
+-- null;
+-- when O_Storage_Local =>
+-- raise Syntax_Error;
+-- end case;
+-- when others =>
+-- -- FIXME: constant indexed element, selected element maybe
+-- -- of const address.
+-- raise Syntax_Error;
+-- end case;
+-- end Check_Const_Address;
+
+ procedure Check_Type (T1, T2 : O_Tnode) is
+ begin
+ if T1 = T2 then
+ return;
+ end if;
+ if T1.Kind = ON_Array_Sub_Type and then T2.Kind = ON_Array_Sub_Type
+ and then T1.Base_Type = T2.Base_Type
+ and then T1.Length.all = T2.Length.all
+ then
+ return;
+ end if;
+ raise Type_Error;
+ end Check_Type;
+
+ procedure Check_Ref (N : O_Enode) is
+ begin
+ if N.Ref then
+ -- Already referenced.
+ raise Syntax_Error;
+ end if;
+ N.Ref := True;
+ end Check_Ref;
+
+ procedure Check_Ref (N : O_Lnode) is
+ begin
+ if N.Ref then
+ raise Syntax_Error;
+ end if;
+ N.Ref := True;
+ end Check_Ref;
+
+ procedure Check_Complete_Type (T : O_Tnode) is
+ begin
+ if not T.Complete then
+ -- Uncomplete type cannot be used here (since its size is required,
+ -- for example).
+ raise Syntax_Error;
+ end if;
+ end Check_Complete_Type;
+
+ function New_Dyadic_Op (Kind : ON_Dyadic_Op_Kind; Left, Right : O_Enode)
+ return O_Enode
+ is
+ K : constant OE_Kind := ON_Op_To_OE (Kind);
+ Res : O_Enode;
+ begin
+ Check_Type (Left.Rtype, Right.Rtype);
+ Check_Ref (Left);
+ Check_Ref (Right);
+ Res := new O_Enode_Type (K);
+ Res.Rtype := Left.Rtype;
+ Res.Ref := False;
+ Res.Left := Left;
+ Res.Right := Right;
+ return Res;
+ end New_Dyadic_Op;
+
+ function New_Monadic_Op (Kind : ON_Monadic_Op_Kind; Operand : O_Enode)
+ return O_Enode
+ is
+ Res : O_Enode;
+ begin
+ Check_Ref (Operand);
+ Res := new O_Enode_Type (ON_Op_To_OE (Kind));
+ Res.Ref := False;
+ Res.Operand := Operand;
+ Res.Rtype := Operand.Rtype;
+ return Res;
+ end New_Monadic_Op;
+
+ function New_Compare_Op
+ (Kind : ON_Compare_Op_Kind; Left, Right : O_Enode; Ntype : O_Tnode)
+ return O_Enode
+ is
+ Res : O_Enode;
+ begin
+ if Ntype.Kind /= ON_Boolean_Type then
+ raise Type_Error;
+ end if;
+ if Left.Rtype /= Right.Rtype then
+ raise Type_Error;
+ end if;
+ Check_Ref (Left);
+ Check_Ref (Right);
+ Res := new O_Enode_Type (ON_Op_To_OE (Kind));
+ Res.Ref := False;
+ Res.Left := Left;
+ Res.Right := Right;
+ Res.Rtype := Ntype;
+ return Res;
+ end New_Compare_Op;
+
+
+ function New_Signed_Literal (Ltype : O_Tnode; Value : Integer_64)
+ return O_Cnode
+ is
+ subtype O_Cnode_Signed_Lit is O_Cnode_Type (OC_Signed_Lit);
+ begin
+ if Ltype.Kind = ON_Signed_Type then
+ return new O_Cnode_Signed_Lit'(Kind => OC_Signed_Lit,
+ Ctype => Ltype,
+ Ref => False,
+ S_Val => Value);
+ else
+ raise Type_Error;
+ end if;
+ end New_Signed_Literal;
+
+ function New_Unsigned_Literal (Ltype : O_Tnode; Value : Unsigned_64)
+ return O_Cnode
+ is
+ subtype O_Cnode_Unsigned_Lit is O_Cnode_Type (OC_Unsigned_Lit);
+ begin
+ if Ltype.Kind = ON_Unsigned_Type then
+ return new O_Cnode_Unsigned_Lit'(Kind => OC_Unsigned_Lit,
+ Ctype => Ltype,
+ Ref => False,
+ U_Val => Value);
+ else
+ raise Type_Error;
+ end if;
+ end New_Unsigned_Literal;
+
+ function New_Float_Literal (Ltype : O_Tnode; Value : IEEE_Float_64)
+ return O_Cnode
+ is
+ subtype O_Cnode_Float_Lit is O_Cnode_Type (OC_Float_Lit);
+ begin
+ if Ltype.Kind = ON_Float_Type then
+ return new O_Cnode_Float_Lit'(Kind => OC_Float_Lit,
+ Ctype => Ltype,
+ Ref => False,
+ F_Val => Value);
+ else
+ raise Type_Error;
+ end if;
+ end New_Float_Literal;
+
+ function New_Null_Access (Ltype : O_Tnode) return O_Cnode
+ is
+ subtype O_Cnode_Null_Lit_Type is O_Cnode_Type (OC_Null_Lit);
+ begin
+ if Ltype.Kind /= ON_Access_Type then
+ raise Type_Error;
+ end if;
+ return new O_Cnode_Null_Lit_Type'(Kind => OC_Null_Lit,
+ Ctype => Ltype,
+ Ref => False);
+ end New_Null_Access;
+
+ function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode
+ is
+ subtype O_Cnode_Sizeof_Type is O_Cnode_Type (OC_Sizeof_Lit);
+ begin
+ if Rtype.Kind /= ON_Unsigned_Type then
+ raise Type_Error;
+ end if;
+ Check_Complete_Type (Atype);
+ if Atype.Kind = ON_Array_Type then
+ raise Type_Error;
+ end if;
+ return new O_Cnode_Sizeof_Type'(Kind => OC_Sizeof_Lit,
+ Ctype => Rtype,
+ Ref => False,
+ S_Type => Atype);
+ end New_Sizeof;
+
+ function New_Offsetof (Field : O_Fnode; Rtype : O_Tnode) return O_Cnode
+ is
+ subtype O_Cnode_Offsetof_Type is O_Cnode_Type (OC_Offsetof_Lit);
+ begin
+ if Rtype.Kind /= ON_Unsigned_Type then
+ raise Type_Error;
+ end if;
+ return new O_Cnode_Offsetof_Type'(Kind => OC_Offsetof_Lit,
+ Ctype => Rtype,
+ Ref => False,
+ Off_Field => Field);
+ end New_Offsetof;
+
+ function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode
+ is
+ subtype O_Enode_Alloca_Type is O_Enode_Type (OE_Alloca);
+ Res : O_Enode;
+ begin
+ if Rtype.Kind /= ON_Access_Type then
+ raise Type_Error;
+ end if;
+ if Size.Rtype.Kind /= ON_Unsigned_Type then
+ raise Type_Error;
+ end if;
+ Res := new O_Enode_Alloca_Type'(Kind => OE_Alloca,
+ Rtype => Rtype,
+ Ref => False,
+ A_Size => Size);
+ return Res;
+ end New_Alloca;
+
+ procedure Check_Constrained_Type (Atype : O_Tnode) is
+ begin
+ case Atype.Kind is
+ when ON_Array_Type =>
+ raise Type_Error;
+ when ON_Unsigned_Type
+ | ON_Signed_Type
+ | ON_Boolean_Type
+ | ON_Record_Type
+ | ON_Union_Type
+ | ON_Access_Type
+ | ON_Float_Type
+ | ON_Array_Sub_Type
+ | ON_Enum_Type =>
+ null;
+ end case;
+ end Check_Constrained_Type;
+
+ procedure New_Completed_Type_Decl (Atype : O_Tnode)
+ is
+ N : O_Dnode;
+ begin
+ if Atype.Decl = null then
+ -- The uncompleted type must have been declared.
+ raise Type_Error;
+ end if;
+ N := new O_Dnode_Type (ON_Completed_Type_Decl);
+ N.Name := Atype.Decl.Name;
+ N.Dtype := Atype;
+ Add_Decl (N, False);
+ end New_Completed_Type_Decl;
+
+ procedure New_Uncomplete_Record_Type (Res : out O_Tnode)
+ is
+ subtype O_Tnode_Record_Type is O_Tnode_Type (ON_Record_Type);
+ begin
+ Res := new O_Tnode_Record_Type'(Kind => ON_Record_Type,
+ Decl => O_Dnode_Null,
+ Align => 0,
+ Size => 0,
+ Uncomplete => True,
+ Complete => False,
+ Elements => O_Fnode_Null);
+ end New_Uncomplete_Record_Type;
+
+ procedure Start_Uncomplete_Record_Type (Res : O_Tnode;
+ Elements : out O_Element_List) is
+ begin
+ if not Res.Uncomplete then
+ -- RES record type is not an uncomplete record type.
+ raise Syntax_Error;
+ end if;
+ if Res.Elements /= O_Fnode_Null then
+ -- RES record type already has elements...
+ raise Syntax_Error;
+ end if;
+ Elements.Res := Res;
+ Elements.Last := null;
+ end Start_Uncomplete_Record_Type;
+
+ procedure Start_Record_Type (Elements : out O_Element_List)
+ is
+ subtype O_Tnode_Record_Type is O_Tnode_Type (ON_Record_Type);
+ begin
+ Elements.Res := new O_Tnode_Record_Type'(Kind => ON_Record_Type,
+ Decl => O_Dnode_Null,
+ Align => 0,
+ Size => 0,
+ Uncomplete => False,
+ Complete => False,
+ Elements => O_Fnode_Null);
+ Elements.Last := null;
+ end Start_Record_Type;
+
+ function Align_Size (Size : Unsigned_32; Align : Natural)
+ return Unsigned_32
+ is
+ M : Unsigned_32;
+ begin
+ M := (2 ** Align) - 1;
+ return (Size + M) and (not M);
+ end Align_Size;
+
+ procedure New_Record_Field
+ (Elements : in out O_Element_List;
+ El : out O_Fnode;
+ Ident : O_Ident; Etype : O_Tnode)
+ is
+ begin
+ Check_Complete_Type (Etype);
+ Check_Constrained_Type (Etype);
+ -- The alignment of a structure is the max alignment of its field.
+ if Etype.Align > Elements.Res.Align then
+ Elements.Res.Align := Etype.Align;
+ end if;
+ -- Align the current size for the new field.
+ Elements.Res.Size := Align_Size (Elements.Res.Size, Etype.Align);
+ El := new O_Fnode_Type'(Parent => Elements.Res,
+ Next => null,
+ Ident => Ident,
+ Ftype => Etype,
+ Offset => Elements.Res.Size);
+ -- Add the size of the field.
+ Elements.Res.Size := Elements.Res.Size + Etype.Size;
+ if Elements.Last = null then
+ Elements.Res.Elements := El;
+ else
+ Elements.Last.Next := El;
+ end if;
+ Elements.Last := El;
+ end New_Record_Field;
+
+ procedure Finish_Record_Type
+ (Elements : in out O_Element_List; Res : out O_Tnode) is
+ begin
+ -- Align the structure.
+ Res := Elements.Res;
+ Res.Size := Align_Size (Res.Size, Res.Align);
+ if Res.Uncomplete then
+ New_Completed_Type_Decl (Res);
+ end if;
+ Res.Complete := True;
+ end Finish_Record_Type;
+
+ procedure Start_Union_Type (Elements : out O_Element_List)
+ is
+ subtype O_Tnode_Union_Type is O_Tnode_Type (ON_Union_Type);
+ begin
+ Elements.Res := new O_Tnode_Union_Type'(Kind => ON_Union_Type,
+ Decl => O_Dnode_Null,
+ Align => 0,
+ Size => 0,
+ Uncomplete => False,
+ Complete => False,
+ Elements => O_Fnode_Null);
+ Elements.Last := null;
+ end Start_Union_Type;
+
+ procedure New_Union_Field
+ (Elements : in out O_Element_List;
+ El : out O_Fnode;
+ Ident : O_Ident; Etype : O_Tnode)
+ is
+ begin
+ New_Record_Field (Elements, El, Ident, Etype);
+ end New_Union_Field;
+
+ procedure Finish_Union_Type
+ (Elements : in out O_Element_List; Res : out O_Tnode) is
+ begin
+ -- Align the structure.
+ Res := Elements.Res;
+ Res.Size := Align_Size (Res.Size, Res.Align);
+ Res.Complete := True;
+ end Finish_Union_Type;
+
+ function New_Access_Type (Dtype : O_Tnode) return O_Tnode
+ is
+ subtype O_Tnode_Access is O_Tnode_Type (ON_Access_Type);
+ Res : O_Tnode;
+ begin
+ if Dtype /= O_Tnode_Null
+ and then Dtype.Kind = ON_Array_Sub_Type
+ then
+ -- Access to sub array are not allowed, use access to array.
+ raise Type_Error;
+ end if;
+ Res := new O_Tnode_Access'(Kind => ON_Access_Type,
+ Decl => O_Dnode_Null,
+ Align => Metric_Access_Align,
+ Size => Metric_Access_Size,
+ Uncomplete => Dtype = O_Tnode_Null,
+ Complete => True,
+ D_Type => Dtype);
+ return Res;
+ end New_Access_Type;
+
+ procedure Finish_Access_Type (Atype : O_Tnode; Dtype : O_Tnode)
+ is
+ begin
+ if Dtype.Kind = ON_Array_Sub_Type then
+ -- Access to sub array are not allowed, use access to array.
+ raise Type_Error;
+ end if;
+ if Atype.D_Type /= O_Tnode_Null
+ or Atype.Uncomplete = False
+ then
+ -- Type already completed.
+ raise Syntax_Error;
+ end if;
+ Atype.D_Type := Dtype;
+ New_Completed_Type_Decl (Atype);
+ end Finish_Access_Type;
+
+ function New_Array_Type (El_Type : O_Tnode; Index_Type : O_Tnode)
+ return O_Tnode
+ is
+ subtype O_Tnode_Array is O_Tnode_Type (ON_Array_Type);
+ begin
+ Check_Constrained_Type (El_Type);
+ Check_Complete_Type (El_Type);
+ return new O_Tnode_Array'(Kind => ON_Array_Type,
+ Decl => O_Dnode_Null,
+ Align => El_Type.Align,
+ Size => 0,
+ Uncomplete => False,
+ Complete => True,
+ El_Type => El_Type,
+ Index_Type => Index_Type);
+ end New_Array_Type;
+
+ function New_Constrained_Array_Type (Atype : O_Tnode; Length : O_Cnode)
+ return O_Tnode
+ is
+ subtype O_Tnode_Sub_Array is O_Tnode_Type (ON_Array_Sub_Type);
+ Size : Unsigned_32;
+ begin
+ if Atype.Kind /= ON_Array_Type then
+ raise Type_Error;
+ end if;
+ Size := Unsigned_32 (Length.U_Val) * Atype.El_Type.Size;
+ return new O_Tnode_Sub_Array'(Kind => ON_Array_Sub_Type,
+ Decl => O_Dnode_Null,
+ Align => Atype.Align,
+ Size => Size,
+ Uncomplete => False,
+ Complete => True,
+ Base_Type => Atype,
+ Length => Length);
+ end New_Constrained_Array_Type;
+
+ function Get_Scalar_Pow (Bit_Size : Natural) return Natural is
+ begin
+ if Bit_Size <= 8 then
+ return 0;
+ elsif Bit_Size <= 32 then
+ return 2;
+ elsif Bit_Size <= 64 then
+ return 3;
+ else
+ raise Type_Error;
+ end if;
+ end Get_Scalar_Pow;
+
+ function New_Unsigned_Type (Size : Natural) return O_Tnode
+ is
+ subtype O_Tnode_Unsigned is O_Tnode_Type (ON_Unsigned_Type);
+ Align : Natural;
+ begin
+ Align := Get_Scalar_Pow (Size);
+ return new O_Tnode_Unsigned'(Kind => ON_Unsigned_Type,
+ Decl => O_Dnode_Null,
+ Align => Align,
+ Size => 2 ** Align,
+ Uncomplete => False,
+ Complete => True);
+ end New_Unsigned_Type;
+
+ function New_Signed_Type (Size : Natural) return O_Tnode
+ is
+ subtype O_Tnode_Signed is O_Tnode_Type (ON_Signed_Type);
+ Align : Natural;
+ begin
+ Align := Get_Scalar_Pow (Size);
+ return new O_Tnode_Signed'(Kind => ON_Signed_Type,
+ Decl => O_Dnode_Null,
+ Align => Align,
+ Size => 2 ** Align,
+ Uncomplete => False,
+ Complete => True);
+ end New_Signed_Type;
+
+ function New_Float_Type return O_Tnode
+ is
+ subtype O_Tnode_Float is O_Tnode_Type (ON_Float_Type);
+ begin
+ return new O_Tnode_Float'(Kind => ON_Float_Type,
+ Decl => O_Dnode_Null,
+ Align => 0,
+ Size => 1,
+ Uncomplete => False,
+ Complete => True);
+ end New_Float_Type;
+
+ procedure New_Boolean_Type (Res : out O_Tnode;
+ False_Id : O_Ident;
+ False_E : out O_Cnode;
+ True_Id : O_Ident;
+ True_E : out O_Cnode)
+ is
+ subtype O_Tnode_Boolean is O_Tnode_Type (ON_Boolean_Type);
+ subtype O_Cnode_Boolean_Lit is O_Cnode_Type (OC_Boolean_Lit);
+ begin
+ Res := new O_Tnode_Boolean'(Kind => ON_Boolean_Type,
+ Decl => O_Dnode_Null,
+ Align => 0,
+ Size => 1,
+ Uncomplete => False,
+ Complete => True,
+ True_N => O_Cnode_Null,
+ False_N => O_Cnode_Null);
+ True_E := new O_Cnode_Boolean_Lit'(Kind => OC_Boolean_Lit,
+ Ctype => Res,
+ Ref => False,
+ B_Val => True,
+ B_Id => True_Id);
+ False_E := new O_Cnode_Boolean_Lit'(Kind => OC_Boolean_Lit,
+ Ctype => Res,
+ Ref => False,
+ B_Val => False,
+ B_Id => False_Id);
+ Res.True_N := True_E;
+ Res.False_N := False_E;
+ end New_Boolean_Type;
+
+ procedure Start_Enum_Type (List : out O_Enum_List; Size : Natural)
+ is
+ subtype O_Tnode_Enum is O_Tnode_Type (ON_Enum_Type);
+ Res : O_Tnode;
+ Align : Natural;
+ begin
+ Align := Get_Scalar_Pow (Size);
+ Res := new O_Tnode_Enum'(Kind => ON_Enum_Type,
+ Decl => O_Dnode_Null,
+ Align => Align,
+ Size => 2 ** Align,
+ Uncomplete => False,
+ Complete => False,
+ Nbr => 0,
+ Literals => O_Cnode_Null);
+ List.Res := Res;
+ List.Last := O_Cnode_Null;
+ end Start_Enum_Type;
+
+ procedure New_Enum_Literal (List : in out O_Enum_List;
+ Ident : O_Ident;
+ Res : out O_Cnode)
+ is
+ subtype O_Cnode_Enum_Lit is O_Cnode_Type (OC_Enum_Lit);
+ begin
+ Res := new O_Cnode_Enum_Lit'(Kind => OC_Enum_Lit,
+ Ctype => List.Res,
+ Ref => False,
+ E_Val => List.Res.Nbr,
+ E_Name => Ident,
+ E_Next => O_Cnode_Null);
+ -- Link it.
+ if List.Last = O_Cnode_Null then
+ List.Res.Literals := Res;
+ else
+ List.Last.E_Next := Res;
+ end if;
+ List.Last := Res;
+
+ List.Res.Nbr := List.Res.Nbr + 1;
+ end New_Enum_Literal;
+
+ procedure Finish_Enum_Type (List : in out O_Enum_List; Res : out O_Tnode) is
+ begin
+ Res := List.Res;
+ Res.Complete := True;
+ end Finish_Enum_Type;
+
+ function Get_Base_Type (Atype : O_Tnode) return O_Tnode
+ is
+ begin
+ case Atype.Kind is
+ when ON_Array_Sub_Type =>
+ return Atype.Base_Type;
+ when others =>
+ return Atype;
+ end case;
+ end Get_Base_Type;
+
+
+ procedure Start_Record_Aggr (List : out O_Record_Aggr_List; Atype : O_Tnode)
+ is
+ subtype O_Cnode_Aggregate is O_Cnode_Type (OC_Aggregate);
+ Res : O_Cnode;
+ begin
+ if Atype.Kind /= ON_Record_Type then
+ raise Type_Error;
+ end if;
+ Check_Complete_Type (Atype);
+ Res := new O_Cnode_Aggregate'(Kind => OC_Aggregate,
+ Ctype => Atype,
+ Ref => False,
+ Aggr_Els => null);
+ List.Res := Res;
+ List.Last := null;
+ List.Field := Atype.Elements;
+ end Start_Record_Aggr;
+
+ procedure New_Record_Aggr_El (List : in out O_Record_Aggr_List;
+ Value : O_Cnode)
+ is
+ subtype O_Cnode_Aggrel_Type is O_Cnode_Type (OC_Aggr_Element);
+ El : O_Cnode;
+ begin
+ if List.Field = O_Fnode_Null then
+ -- No more element in the aggregate.
+ raise Syntax_Error;
+ end if;
+ Check_Type (Value.Ctype, List.Field.Ftype);
+ El := new O_Cnode_Aggrel_Type'(Kind => OC_Aggr_Element,
+ Ctype => Value.Ctype,
+ Ref => False,
+ Aggr_Value => Value,
+ Aggr_Next => null);
+ if List.Last = null then
+ List.Res.Aggr_Els := El;
+ else
+ List.Last.Aggr_Next := El;
+ end if;
+ List.Last := El;
+ List.Field := List.Field.Next;
+ end New_Record_Aggr_El;
+
+ procedure Finish_Record_Aggr
+ (List : in out O_Record_Aggr_List; Res : out O_Cnode)
+ is
+ begin
+ if List.Field /= null then
+ -- Not enough elements in aggregate.
+ raise Type_Error;
+ end if;
+ Res := List.Res;
+ end Finish_Record_Aggr;
+
+ procedure Start_Array_Aggr (List : out O_Array_Aggr_List; Atype : O_Tnode)
+ is
+ subtype O_Cnode_Aggregate is O_Cnode_Type (OC_Aggregate);
+ Res : O_Cnode;
+ begin
+ if Atype.Kind /= ON_Array_Sub_Type then
+ raise Type_Error;
+ end if;
+ Check_Complete_Type (Atype);
+ Res := new O_Cnode_Aggregate'(Kind => OC_Aggregate,
+ Ctype => Atype,
+ Ref => False,
+ Aggr_Els => null);
+ List.Res := Res;
+ List.Last := null;
+ List.El_Type := Atype.Base_Type.El_Type;
+ end Start_Array_Aggr;
+
+ procedure New_Array_Aggr_El (List : in out O_Array_Aggr_List;
+ Value : O_Cnode)
+ is
+ subtype O_Cnode_Aggrel_Type is O_Cnode_Type (OC_Aggr_Element);
+ El : O_Cnode;
+ begin
+ Check_Type (Value.Ctype, List.El_Type);
+ El := new O_Cnode_Aggrel_Type'(Kind => OC_Aggr_Element,
+ Ctype => Value.Ctype,
+ Ref => False,
+ Aggr_Value => Value,
+ Aggr_Next => null);
+ if List.Last = null then
+ List.Res.Aggr_Els := El;
+ else
+ List.Last.Aggr_Next := El;
+ end if;
+ List.Last := El;
+ end New_Array_Aggr_El;
+
+ procedure Finish_Array_Aggr
+ (List : in out O_Array_Aggr_List; Res : out O_Cnode) is
+ begin
+ Res := List.Res;
+ end Finish_Array_Aggr;
+
+ function New_Union_Aggr (Atype : O_Tnode; Field : O_Fnode; Value : O_Cnode)
+ return O_Cnode
+ is
+ subtype O_Cnode_Union_Aggr is O_Cnode_Type (OC_Union_Aggr);
+ Res : O_Cnode;
+ begin
+ if Atype.Kind /= ON_Union_Type then
+ raise Type_Error;
+ end if;
+ Check_Type (Value.Ctype, Field.Ftype);
+
+ Res := new O_Cnode_Union_Aggr'(Kind => OC_Union_Aggr,
+ Ctype => Atype,
+ Ref => False,
+ Uaggr_Field => Field,
+ Uaggr_Value => Value);
+ return Res;
+ end New_Union_Aggr;
+
+ function New_Obj (Obj : O_Dnode) return O_Lnode
+ is
+ subtype O_Lnode_Obj is O_Lnode_Type (OL_Obj);
+ begin
+ case Obj.Kind is
+ when ON_Const_Decl
+ | ON_Var_Decl
+ | ON_Interface_Decl =>
+ null;
+ when others =>
+ raise Program_Error;
+ end case;
+ Check_Scope (Obj);
+ return new O_Lnode_Obj'(Kind => OL_Obj,
+ Rtype => Obj.Dtype,
+ Ref => False,
+ Obj => Obj);
+ end New_Obj;
+
+ function New_Indexed_Element (Arr : O_Lnode; Index : O_Enode)
+ return O_Lnode
+ is
+ subtype O_Lnode_Indexed is O_Lnode_Type (OL_Indexed_Element);
+ Res : O_Lnode;
+ Rtype : O_Tnode;
+ begin
+ case Arr.Rtype.Kind is
+ when ON_Array_Type =>
+ Rtype := Arr.Rtype.El_Type;
+ when ON_Array_Sub_Type =>
+ Rtype := Arr.Rtype.Base_Type.El_Type;
+ when others =>
+ raise Type_Error;
+ end case;
+ Check_Ref (Arr);
+ Res := new O_Lnode_Indexed'(Kind => OL_Indexed_Element,
+ Rtype => Get_Base_Type (Arr.Rtype).El_Type,
+ Ref => False,
+ Array_Base => Arr,
+ Index => Index);
+ return Res;
+ end New_Indexed_Element;
+
+ function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode)
+ return O_Lnode
+ is
+ subtype O_Lnode_Slice is O_Lnode_Type (OL_Slice);
+ Res : O_Lnode;
+ begin
+ if Res_Type.Kind /= ON_Array_Type
+ and then Res_Type.Kind /= ON_Array_Sub_Type
+ then
+ raise Type_Error;
+ end if;
+ Check_Ref (Arr);
+ Check_Ref (Index);
+ -- FIXME: check type.
+ Res := new O_Lnode_Slice'(Kind => OL_Slice,
+ Rtype => Res_Type,
+ Ref => False,
+ Slice_Base => Arr,
+ Slice_Index => Index);
+ return Res;
+ end New_Slice;
+
+ function New_Selected_Element (Rec : O_Lnode; El : O_Fnode)
+ return O_Lnode
+ is
+ subtype O_Lnode_Selected_Element is O_Lnode_Type (OL_Selected_Element);
+ begin
+ if Rec.Rtype.Kind /= ON_Record_Type then
+ raise Type_Error;
+ end if;
+ if Rec.Rtype /= El.Parent then
+ raise Type_Error;
+ end if;
+ Check_Ref (Rec);
+ return new O_Lnode_Selected_Element'(Kind => OL_Selected_Element,
+ Rtype => El.Ftype,
+ Ref => False,
+ Rec_Base => Rec,
+ Rec_El => El);
+ end New_Selected_Element;
+
+ function New_Access_Element (Acc : O_Enode) return O_Lnode
+ is
+ subtype O_Lnode_Access_Element is O_Lnode_Type (OL_Access_Element);
+ begin
+ if Acc.Rtype.Kind /= ON_Access_Type then
+ raise Type_Error;
+ end if;
+ Check_Ref (Acc);
+ return new O_Lnode_Access_Element'(Kind => OL_Access_Element,
+ Rtype => Acc.Rtype.D_Type,
+ Ref => False,
+ Acc_Base => Acc);
+ end New_Access_Element;
+
+ function Check_Conv (Source : ON_Type_Kind; Target : ON_Type_Kind)
+ return Boolean
+ is
+ type Conv_Array is array (ON_Type_Kind, ON_Type_Kind) of Boolean;
+ T : constant Boolean := True;
+ F : constant Boolean := False;
+ Conv_Allowed : constant Conv_Array :=
+ (ON_Boolean_Type => (T, F, T, T, F, F, F, F, F, F),
+ ON_Enum_Type => (F, F, T, T, F, F, F, F, F, F),
+ ON_Unsigned_Type => (T, T, T, T, F, F, F, F, F, F),
+ ON_Signed_Type => (T, T, T, T, T, F, F, F, F, F),
+ ON_Float_Type => (F, F, F, T, T, F, F, F, F, F),
+ ON_Array_Type => (F, F, F, F, F, F, T, F, F, F),
+ ON_Array_Sub_Type =>(F, F, F, F, F, T, T, F, F, F),
+ ON_Record_Type => (F, F, F, F, F, F, F, F, F, F),
+ ON_Union_Type => (F, F, F, F, F, F, F, F, F, F),
+ ON_Access_Type => (F, F, F, F, F, F, F, F, F, T));
+ begin
+ if Source = Target then
+ return True;
+ else
+ return Conv_Allowed (Source, Target);
+ end if;
+ end Check_Conv;
+
+ function New_Convert_Ov (Val : O_Enode; Rtype : O_Tnode) return O_Enode
+ is
+ subtype O_Enode_Convert is O_Enode_Type (OE_Convert_Ov);
+ Res : O_Enode;
+ begin
+ Check_Ref (Val);
+ if not Check_Conv (Val.Rtype.Kind, Rtype.Kind) then
+ raise Type_Error;
+ end if;
+ Res := new O_Enode_Convert'(Kind => OE_Convert_Ov,
+ Rtype => Rtype,
+ Ref => False,
+ Conv => Val);
+ return Res;
+ end New_Convert_Ov;
+
+ function New_Unchecked_Address (Lvalue : O_Lnode; Atype : O_Tnode)
+ return O_Enode
+ is
+ subtype O_Enode_Address is O_Enode_Type (OE_Unchecked_Address);
+ begin
+ Check_Ref (Lvalue);
+ if Atype.Kind /= ON_Access_Type then
+ -- An address is of type access.
+ raise Type_Error;
+ end if;
+ return new O_Enode_Address'(Kind => OE_Unchecked_Address,
+ Rtype => Atype,
+ Ref => False,
+ Lvalue => Lvalue);
+ end New_Unchecked_Address;
+
+ function New_Address (Lvalue : O_Lnode; Atype : O_Tnode) return O_Enode
+ is
+ subtype O_Enode_Address is O_Enode_Type (OE_Address);
+ begin
+ Check_Ref (Lvalue);
+ if Atype.Kind /= ON_Access_Type then
+ -- An address is of type access.
+ raise Type_Error;
+ end if;
+ if Get_Base_Type (Lvalue.Rtype) /= Get_Base_Type (Atype.D_Type) then
+ raise Type_Error;
+ end if;
+ return new O_Enode_Address'(Kind => OE_Address,
+ Rtype => Atype,
+ Ref => False,
+ Lvalue => Lvalue);
+ end New_Address;
+
+ function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode)
+ return O_Cnode
+ is
+ subtype O_Cnode_Address is O_Cnode_Type (OC_Unchecked_Address);
+ begin
+ Check_Scope (Decl);
+ if Atype.Kind /= ON_Access_Type then
+ -- An address is of type access.
+ raise Type_Error;
+ end if;
+ return new O_Cnode_Address'(Kind => OC_Unchecked_Address,
+ Ctype => Atype,
+ Ref => False,
+ Decl => Decl);
+ end New_Global_Unchecked_Address;
+
+ function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) return O_Cnode
+ is
+ subtype O_Cnode_Address is O_Cnode_Type (OC_Address);
+ begin
+ Check_Scope (Decl);
+ if Atype.Kind /= ON_Access_Type then
+ -- An address is of type access.
+ raise Type_Error;
+ end if;
+ if Get_Base_Type (Decl.Dtype) /= Get_Base_Type (Atype.D_Type) then
+ raise Type_Error;
+ end if;
+ return new O_Cnode_Address'(Kind => OC_Address,
+ Ctype => Atype,
+ Ref => False,
+ Decl => Decl);
+ end New_Global_Address;
+
+ function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode)
+ return O_Cnode
+ is
+ subtype O_Cnode_Subprg_Address is O_Cnode_Type (OC_Subprogram_Address);
+ begin
+ if Atype.Kind /= ON_Access_Type then
+ -- An address is of type access.
+ raise Type_Error;
+ end if;
+ return new O_Cnode_Subprg_Address'(Kind => OC_Subprogram_Address,
+ Ctype => Atype,
+ Ref => False,
+ Decl => Subprg);
+ end New_Subprogram_Address;
+
+ -- Raise TYPE_ERROR is ATYPE is a composite type.
+ procedure Check_Not_Composite (Atype : O_Tnode) is
+ begin
+ case Atype.Kind is
+ when ON_Boolean_Type
+ | ON_Unsigned_Type
+ | ON_Signed_Type
+ | ON_Float_Type
+ | ON_Enum_Type
+ | ON_Access_Type=>
+ return;
+ when ON_Array_Type
+ | ON_Record_Type
+ | ON_Union_Type
+ | ON_Array_Sub_Type =>
+ raise Type_Error;
+ end case;
+ end Check_Not_Composite;
+
+ function New_Value (Lvalue : O_Lnode) return O_Enode is
+ subtype O_Enode_Value is O_Enode_Type (OE_Value);
+ begin
+ Check_Not_Composite (Lvalue.Rtype);
+ Check_Ref (Lvalue);
+ return new O_Enode_Value'(Kind => OE_Value,
+ Rtype => Lvalue.Rtype,
+ Ref => False,
+ Value => Lvalue);
+ end New_Value;
+
+ function New_Obj_Value (Obj : O_Dnode) return O_Enode is
+ begin
+ return New_Value (New_Obj (Obj));
+ end New_Obj_Value;
+
+ function New_Lit (Lit : O_Cnode) return O_Enode is
+ subtype O_Enode_Lit is O_Enode_Type (OE_Lit);
+ begin
+ Check_Not_Composite (Lit.Ctype);
+ return new O_Enode_Lit'(Kind => OE_Lit,
+ Rtype => Lit.Ctype,
+ Ref => False,
+ Lit => Lit);
+ end New_Lit;
+
+ ---------------------
+ -- Declarations. --
+ ---------------------
+
+ procedure New_Debug_Filename_Decl (Filename : String)
+ is
+ subtype O_Dnode_Filename_Decl is O_Dnode_Type (ON_Debug_Filename_Decl);
+ N : O_Dnode;
+ begin
+ N := new O_Dnode_Filename_Decl;
+ N.Filename := new String'(Filename);
+ Add_Decl (N, False);
+ end New_Debug_Filename_Decl;
+
+ procedure New_Debug_Line_Decl (Line : Natural)
+ is
+ subtype O_Dnode_Line_Decl is O_Dnode (ON_Debug_Line_Decl);
+ N : O_Dnode_Line_Decl;
+ begin
+ N := new O_Dnode_Type (ON_Debug_Line_Decl);
+ N.Line := Line;
+ Add_Decl (N, False);
+ end New_Debug_Line_Decl;
+
+ procedure New_Debug_Comment_Decl (Comment : String)
+ is
+ subtype O_Dnode_Comment_Decl is O_Dnode (ON_Debug_Comment_Decl);
+ N : O_Dnode_Comment_Decl;
+ begin
+ N := new O_Dnode_Type (ON_Debug_Comment_Decl);
+ N.Comment := new String'(Comment);
+ Add_Decl (N, False);
+ end New_Debug_Comment_Decl;
+
+ procedure New_Type_Decl (Ident : O_Ident; Atype : O_Tnode)
+ is
+ N : O_Dnode;
+ begin
+ if Atype.Decl /= null then
+ -- Type was already declared.
+ raise Type_Error;
+ end if;
+ N := new O_Dnode_Type (ON_Type_Decl);
+ N.Name := Ident;
+ N.Dtype := Atype;
+ Atype.Decl := N;
+ Add_Decl (N);
+ end New_Type_Decl;
+
+ procedure Check_Object_Storage (Storage : O_Storage) is
+ begin
+ if Current_Function /= null then
+ -- Inside a subprogram.
+ case Storage is
+ when O_Storage_Public =>
+ -- Cannot create public variables inside a subprogram.
+ raise Syntax_Error;
+ when O_Storage_Private
+ | O_Storage_Local
+ | O_Storage_External =>
+ null;
+ end case;
+ else
+ -- Global scope.
+ case Storage is
+ when O_Storage_Public
+ | O_Storage_Private
+ | O_Storage_External =>
+ null;
+ when O_Storage_Local =>
+ -- Cannot create a local variables outside a subprogram.
+ raise Syntax_Error;
+ end case;
+ end if;
+ end Check_Object_Storage;
+
+ procedure New_Const_Decl
+ (Res : out O_Dnode;
+ Ident : O_Ident;
+ Storage : O_Storage;
+ Atype : O_Tnode)
+ is
+ subtype O_Dnode_Const is O_Dnode_Type (ON_Const_Decl);
+ begin
+ Check_Complete_Type (Atype);
+ if Storage = O_Storage_Local then
+ -- A constant cannot be local.
+ raise Syntax_Error;
+ end if;
+ Check_Object_Storage (Storage);
+ Res := new O_Dnode_Const'(Kind => ON_Const_Decl,
+ Name => Ident,
+ Next => null,
+ Dtype => Atype,
+ Storage => Storage,
+ Scope => Current_Decl_Scope.Parent,
+ Lineno => 0,
+ Const_Value => O_Dnode_Null);
+ Add_Decl (Res);
+ end New_Const_Decl;
+
+ procedure Start_Const_Value (Const : in out O_Dnode)
+ is
+ subtype O_Dnode_Const_Value is O_Dnode_Type (ON_Const_Value);
+ N : O_Dnode;
+ begin
+ if Const.Const_Value /= O_Dnode_Null then
+ -- Constant already has a value.
+ raise Syntax_Error;
+ end if;
+
+ if Const.Storage = O_Storage_External then
+ -- An external constant must not have a value.
+ raise Syntax_Error;
+ end if;
+
+ -- FIXME: check scope is the same.
+
+ N := new O_Dnode_Const_Value'(Kind => ON_Const_Value,
+ Name => Const.Name,
+ Next => null,
+ Dtype => Const.Dtype,
+ Storage => Const.Storage,
+ Scope => Current_Decl_Scope.Parent,
+ Lineno => 0,
+ Const_Decl => Const,
+ Value => O_Cnode_Null);
+ Const.Const_Value := N;
+ Add_Decl (N, False);
+ end Start_Const_Value;
+
+ procedure Finish_Const_Value (Const : in out O_Dnode; Val : O_Cnode)
+ is
+ begin
+ if Const.Const_Value = O_Dnode_Null then
+ -- Start_Const_Value not called.
+ raise Syntax_Error;
+ end if;
+ if Const.Const_Value.Value /= O_Cnode_Null then
+ -- Finish_Const_Value already called.
+ raise Syntax_Error;
+ end if;
+ if Val = O_Cnode_Null then
+ -- No value or bad type.
+ raise Type_Error;
+ end if;
+ Check_Type (Val.Ctype, Const.Dtype);
+ Const.Const_Value.Value := Val;
+ end Finish_Const_Value;
+
+ procedure New_Var_Decl
+ (Res : out O_Dnode;
+ Ident : O_Ident;
+ Storage : O_Storage;
+ Atype : O_Tnode)
+ is
+ subtype O_Dnode_Var is O_Dnode_Type (ON_Var_Decl);
+ begin
+ Check_Complete_Type (Atype);
+ Check_Object_Storage (Storage);
+ Res := new O_Dnode_Var'(Kind => ON_Var_Decl,
+ Name => Ident,
+ Next => null,
+ Dtype => Atype,
+ Storage => Storage,
+ Lineno => 0,
+ Scope => Current_Decl_Scope.Parent);
+ Add_Decl (Res);
+ end New_Var_Decl;
+
+ procedure Start_Subprogram_Decl_1
+ (Interfaces : out O_Inter_List;
+ Ident : O_Ident;
+ Storage : O_Storage;
+ Rtype : O_Tnode)
+ is
+ subtype O_Dnode_Function is O_Dnode_Type (ON_Function_Decl);
+ N : O_Dnode;
+ begin
+ N := new O_Dnode_Function'(Kind => ON_Function_Decl,
+ Next => null,
+ Name => Ident,
+ Dtype => Rtype,
+ Storage => Storage,
+ Scope => Current_Decl_Scope.Parent,
+ Lineno => 0,
+ Interfaces => null,
+ Func_Body => null,
+ Alive => False);
+ Add_Decl (N);
+ Interfaces.Func := N;
+ Interfaces.Last := null;
+ end Start_Subprogram_Decl_1;
+
+ procedure Start_Function_Decl
+ (Interfaces : out O_Inter_List;
+ Ident : O_Ident;
+ Storage : O_Storage;
+ Rtype : O_Tnode)
+ is
+ begin
+ Check_Not_Composite (Rtype);
+ Check_Complete_Type (Rtype);
+ Start_Subprogram_Decl_1 (Interfaces, Ident, Storage, Rtype);
+ end Start_Function_Decl;
+
+ procedure Start_Procedure_Decl
+ (Interfaces : out O_Inter_List;
+ Ident : O_Ident;
+ Storage : O_Storage) is
+ begin
+ Start_Subprogram_Decl_1 (Interfaces, Ident, Storage, null);
+ end Start_Procedure_Decl;
+
+ procedure New_Interface_Decl
+ (Interfaces : in out O_Inter_List;
+ Res : out O_Dnode;
+ Ident : O_Ident;
+ Atype : O_Tnode)
+ is
+ subtype O_Dnode_Interface is O_Dnode_Type (ON_Interface_Decl);
+ begin
+ Check_Not_Composite (Atype);
+ Check_Complete_Type (Atype);
+ Res := new O_Dnode_Interface'(Kind => ON_Interface_Decl,
+ Next => null,
+ Name => Ident,
+ Dtype => Atype,
+ Storage => O_Storage_Private,
+ Scope => Current_Decl_Scope.Parent,
+ Lineno => 0,
+ Func_Scope => Interfaces.Func);
+ if Interfaces.Last = null then
+ Interfaces.Func.Interfaces := Res;
+ else
+ Interfaces.Last.Next := Res;
+ end if;
+ Interfaces.Last := Res;
+ end New_Interface_Decl;
+
+ procedure Finish_Subprogram_Decl
+ (Interfaces : in out O_Inter_List; Res : out O_Dnode)
+ is
+ begin
+ Res := Interfaces.Func;
+ end Finish_Subprogram_Decl;
+
+ procedure Start_Subprogram_Body (Func : O_Dnode)
+ is
+ B : O_Dnode;
+ S : O_Snode;
+ begin
+ if Func.Func_Body /= null then
+ -- Function was already declared.
+ raise Syntax_Error;
+ end if;
+ S := new O_Snode_Type (ON_Declare_Stmt);
+ S.all := O_Snode_Type'(Kind => ON_Declare_Stmt,
+ Next => null,
+ Decls => null,
+ Stmts => null,
+ Lineno => 0,
+ Alive => True);
+ B := new O_Dnode_Type (ON_Function_Body);
+ B.all := O_Dnode_Type'(ON_Function_Body,
+ Name => Func.Name,
+ Dtype => Func.Dtype,
+ Storage => Func.Storage,
+ Scope => Current_Decl_Scope.Parent,
+ Lineno => 0,
+ Func_Decl => Func,
+ Func_Stmt => S,
+ Next => null);
+ Add_Decl (B, False);
+ Func.Func_Body := B;
+ Push_Decl_Scope (S);
+ Push_Stmt_Scope
+ (new Stmt_Function_Scope_Type'(Kind => Stmt_Function,
+ Parent => S,
+ Prev => Current_Stmt_Scope,
+ Prev_Function => Current_Function,
+ Decl => Func));
+ Current_Function := Current_Stmt_Scope;
+ Func.Alive := True;
+ end Start_Subprogram_Body;
+
+ procedure Finish_Subprogram_Body is
+ begin
+ Pop_Decl_Scope;
+ if Current_Function.Kind /= Stmt_Function then
+ -- Internal error.
+ raise Syntax_Error;
+ end if;
+ Current_Function.Decl.Alive := False;
+ Current_Function := Current_Function.Prev_Function;
+ Pop_Stmt_Scope (Stmt_Function);
+ end Finish_Subprogram_Body;
+
+ -------------------
+ -- Statements. --
+ -------------------
+
+ procedure New_Debug_Line_Stmt (Line : Natural)
+ is
+ subtype O_Snode_Line_Stmt is O_Snode_Type (ON_Debug_Line_Stmt);
+ begin
+ Add_Stmt (new O_Snode_Line_Stmt'(Kind => ON_Debug_Line_Stmt,
+ Next => null,
+ Lineno => 0,
+ Line => Line));
+ end New_Debug_Line_Stmt;
+
+ procedure New_Debug_Comment_Stmt (Comment : String)
+ is
+ subtype O_Snode_Comment_Stmt is O_Snode_Type (ON_Debug_Comment_Stmt);
+ begin
+ Add_Stmt (new O_Snode_Comment_Stmt'(Kind => ON_Debug_Comment_Stmt,
+ Next => null,
+ Lineno => 0,
+ Comment => new String'(Comment)));
+ end New_Debug_Comment_Stmt;
+
+ procedure Start_Declare_Stmt
+ is
+ N : O_Snode;
+ begin
+ N := new O_Snode_Type (ON_Declare_Stmt);
+ Add_Stmt (N);
+ Push_Decl_Scope (N);
+ Push_Stmt_Scope
+ (new Stmt_Declare_Scope_Type'(Kind => Stmt_Declare,
+ Parent => N,
+ Prev => Current_Stmt_Scope));
+ end Start_Declare_Stmt;
+
+ procedure Finish_Declare_Stmt is
+ begin
+ Pop_Decl_Scope;
+ Pop_Stmt_Scope (Stmt_Declare);
+ end Finish_Declare_Stmt;
+
+ procedure New_Assign_Stmt (Target : O_Lnode; Value : O_Enode)
+ is
+ N : O_Snode;
+ begin
+ Check_Type (Target.Rtype, Value.Rtype);
+ Check_Not_Composite (Target.Rtype);
+ Check_Ref (Target);
+ Check_Ref (Value);
+ N := new O_Snode_Type (ON_Assign_Stmt);
+ N.all := O_Snode_Type'(Kind => ON_Assign_Stmt,
+ Next => null,
+ Lineno => 0,
+ Target => Target,
+ Value => Value);
+ Add_Stmt (N);
+ end New_Assign_Stmt;
+
+ procedure New_Return_Stmt_1 (Value : O_Enode)
+ is
+ subtype O_Snode_Return_Stmt is O_Snode_Type (ON_Return_Stmt);
+ N : O_Snode;
+ begin
+ N := new O_Snode_Return_Stmt'(Kind => ON_Return_Stmt,
+ Next => null,
+ Lineno => 0,
+ Ret_Val => Value);
+ Add_Stmt (N);
+ end New_Return_Stmt_1;
+
+ procedure New_Return_Stmt (Value : O_Enode)
+ is
+ begin
+ if Current_Function = null
+ or else Current_Function.Decl.Dtype = O_Tnode_Null
+ then
+ -- Either not in a function or in a procedure.
+ raise Syntax_Error;
+ end if;
+ Check_Type (Value.Rtype, Current_Function.Decl.Dtype);
+ Check_Ref (Value);
+ New_Return_Stmt_1 (Value);
+ end New_Return_Stmt;
+
+ procedure New_Return_Stmt is
+ begin
+ if Current_Function = null
+ or else Current_Function.Decl.Dtype /= O_Tnode_Null
+ then
+ -- Not in a procedure.
+ raise Syntax_Error;
+ end if;
+ New_Return_Stmt_1 (null);
+ end New_Return_Stmt;
+
+ procedure Start_Association (Assocs : out O_Assoc_List; Subprg : O_Dnode)
+ is
+ begin
+ Check_Scope (Subprg);
+ Assocs.Subprg := Subprg;
+ Assocs.Interfaces := Subprg.Interfaces;
+ Assocs.First := null;
+ Assocs.Last := null;
+ end Start_Association;
+
+ procedure New_Association (Assocs : in out O_Assoc_List; Val : O_Enode)
+ is
+ N : O_Anode;
+ begin
+ Check_Type (Assocs.Interfaces.Dtype, Val.Rtype);
+ Assocs.Interfaces := Assocs.Interfaces.Next;
+ Check_Ref (Val);
+ N := new O_Anode_Type'(Next => null, Formal => null, Actual => Val);
+ if Assocs.Last = null then
+ Assocs.First := N;
+ else
+ Assocs.Last.Next := N;
+ end if;
+ Assocs.Last := N;
+ end New_Association;
+
+ function New_Function_Call (Assocs : O_Assoc_List) return O_Enode
+ is
+ subtype O_Enode_Call is O_Enode_Type (OE_Function_Call);
+ Res : O_Enode;
+ begin
+ if Assocs.Interfaces /= null then
+ -- Not enough arguments.
+ raise Syntax_Error;
+ end if;
+ if Assocs.Subprg.Dtype = null then
+ -- This is a procedure.
+ raise Syntax_Error;
+ end if;
+
+ Res := new O_Enode_Call'(Kind => OE_Function_Call,
+ Rtype => Assocs.Subprg.Dtype,
+ Ref => False,
+ Func => Assocs.Subprg,
+ Assoc => Assocs.First);
+ return Res;
+ end New_Function_Call;
+
+ procedure New_Procedure_Call (Assocs : in out O_Assoc_List)
+ is
+ N : O_Snode;
+ begin
+ if Assocs.Interfaces /= null then
+ -- Not enough arguments.
+ raise Syntax_Error;
+ end if;
+ if Assocs.Subprg.Dtype /= null then
+ -- This is a function.
+ raise Syntax_Error;
+ end if;
+ N := new O_Snode_Type (ON_Call_Stmt);
+ N.Proc := Assocs.Subprg;
+ N.Assoc := Assocs.First;
+ Add_Stmt (N);
+ end New_Procedure_Call;
+
+ procedure Start_If_Stmt (Block : in out O_If_Block; Cond : O_Enode)
+ is
+ subtype O_Snode_If is O_Snode_Type (ON_If_Stmt);
+ N : O_Snode;
+ begin
+ -- Note: no checks are performed here, since they are done in
+ -- new_elsif_stmt.
+ N := new O_Snode_If'(Kind => ON_If_Stmt,
+ Next => null,
+ Lineno => 0,
+ Elsifs => null,
+ If_Last => null);
+ Add_Stmt (N);
+ Push_Stmt_Scope (new Stmt_If_Scope_Type'(Kind => Stmt_If,
+ Parent => N,
+ Prev => Current_Stmt_Scope,
+ Last_Elsif => null));
+ New_Elsif_Stmt (Block, Cond);
+ end Start_If_Stmt;
+
+ procedure New_Elsif_Stmt (Block : in out O_If_Block; Cond : O_Enode)
+ is
+ pragma Unreferenced (Block);
+ N : O_Snode;
+ begin
+ if Cond /= null then
+ if Cond.Rtype.Kind /= ON_Boolean_Type then
+ raise Type_Error;
+ end if;
+ Check_Ref (Cond);
+ end if;
+ N := new O_Snode_Type (ON_Elsif_Stmt);
+ N.all := O_Snode_Type'(Kind => ON_Elsif_Stmt,
+ Next => null,
+ Lineno => 0,
+ Cond => Cond,
+ Next_Elsif => null);
+ if Current_Stmt_Scope.Kind /= Stmt_If then
+ raise Syntax_Error;
+ end if;
+ Add_Stmt (N);
+ if Current_Stmt_Scope.Last_Elsif = null then
+ Current_Stmt_Scope.Parent.Elsifs := N;
+ else
+ -- Check for double 'else'
+ if Current_Stmt_Scope.Last_Elsif.Cond = null then
+ raise Syntax_Error;
+ end if;
+ Current_Stmt_Scope.Last_Elsif.Next_Elsif := N;
+ end if;
+ Current_Stmt_Scope.Last_Elsif := N;
+ end New_Elsif_Stmt;
+
+ procedure New_Else_Stmt (Block : in out O_If_Block) is
+ begin
+ New_Elsif_Stmt (Block, null);
+ end New_Else_Stmt;
+
+ procedure Finish_If_Stmt (Block : in out O_If_Block)
+ is
+ pragma Unreferenced (Block);
+ Parent : O_Snode;
+ begin
+ Parent := Current_Stmt_Scope.Parent;
+ Pop_Stmt_Scope (Stmt_If);
+ Parent.If_Last := Current_Decl_Scope.Last_Stmt;
+ end Finish_If_Stmt;
+
+ procedure Start_Loop_Stmt (Label : out O_Snode)
+ is
+ subtype O_Snode_Loop_Type is O_Snode_Type (ON_Loop_Stmt);
+ begin
+ Current_Loop_Level := Current_Loop_Level + 1;
+ Label := new O_Snode_Loop_Type'(Kind => ON_Loop_Stmt,
+ Next => null,
+ Lineno => 0,
+ Loop_Last => null,
+ Loop_Level => Current_Loop_Level);
+ Add_Stmt (Label);
+ Push_Stmt_Scope (new Stmt_Loop_Scope_Type'(Kind => Stmt_Loop,
+ Parent => Label,
+ Prev => Current_Stmt_Scope));
+ end Start_Loop_Stmt;
+
+ procedure Finish_Loop_Stmt (Label : in out O_Snode)
+ is
+ pragma Unreferenced (Label);
+ Parent : O_Snode;
+ begin
+ Parent := Current_Stmt_Scope.Parent;
+ Pop_Stmt_Scope (Stmt_Loop);
+ Parent.Loop_Last := Current_Decl_Scope.Last_Stmt;
+ Current_Loop_Level := Current_Loop_Level - 1;
+ end Finish_Loop_Stmt;
+
+ procedure New_Exit_Next_Stmt (Kind : ON_Stmt_Kind; L : O_Snode)
+ is
+ N : O_Snode;
+ begin
+ N := new O_Snode_Type (Kind);
+ N.Next := null;
+ N.Loop_Id := L;
+ Add_Stmt (N);
+ end New_Exit_Next_Stmt;
+
+ procedure New_Exit_Stmt (L : O_Snode) is
+ begin
+ New_Exit_Next_Stmt (ON_Exit_Stmt, L);
+ end New_Exit_Stmt;
+
+ procedure New_Next_Stmt (L : O_Snode) is
+ begin
+ New_Exit_Next_Stmt (ON_Next_Stmt, L);
+ end New_Next_Stmt;
+
+ procedure Start_Case_Stmt (Block : in out O_Case_Block; Value : O_Enode)
+ is
+ pragma Unreferenced (Block);
+ subtype O_Snode_Case_Type is O_Snode_Type (ON_Case_Stmt);
+ N : O_Snode;
+ begin
+ case Value.Rtype.Kind is
+ when ON_Boolean_Type
+ | ON_Unsigned_Type
+ | ON_Signed_Type
+ | ON_Enum_Type =>
+ null;
+ when others =>
+ raise Type_Error;
+ end case;
+ Check_Ref (Value);
+ N := new O_Snode_Case_Type'(Kind => ON_Case_Stmt,
+ Next => null,
+ Lineno => 0,
+ Case_Last => null,
+ Selector => Value,
+ Branches => null);
+ Add_Stmt (N);
+ Push_Stmt_Scope (new Stmt_Case_Scope_Type'(Kind => Stmt_Case,
+ Parent => N,
+ Prev => Current_Stmt_Scope,
+ Last_Branch => null,
+ Last_Choice => null,
+ Case_Type => Value.Rtype));
+ end Start_Case_Stmt;
+
+ procedure Start_Choice (Block : in out O_Case_Block)
+ is
+ pragma Unreferenced (Block);
+ N : O_Snode;
+ begin
+ if Current_Stmt_Scope.Kind /= Stmt_Case then
+ -- You are adding a branch outside a case statment.
+ raise Syntax_Error;
+ end if;
+ if Current_Stmt_Scope.Last_Choice /= null then
+ -- You are creating branch while the previous one was not finished.
+ raise Syntax_Error;
+ end if;
+
+ N := new O_Snode_Type (ON_When_Stmt);
+ N.all := O_Snode_Type'(Kind => ON_When_Stmt,
+ Next => null,
+ Lineno => 0,
+ Choice_List => null,
+ Next_Branch => null);
+ if Current_Stmt_Scope.Last_Branch = null then
+ Current_Stmt_Scope.Parent.Branches := N;
+ else
+ Current_Stmt_Scope.Last_Branch.Next_Branch := N;
+ end if;
+ Current_Stmt_Scope.Last_Branch := N;
+ Current_Stmt_Scope.Last_Choice := null;
+ Add_Stmt (N);
+ end Start_Choice;
+
+ procedure Add_Choice (Block : in out O_Case_Block; Choice : O_Choice)
+ is
+ pragma Unreferenced (Block);
+ begin
+ if Current_Stmt_Scope.Kind /= Stmt_Case then
+ -- You are adding a choice not inside a case statement.
+ raise Syntax_Error;
+ end if;
+ if Current_Stmt_Scope.Last_Branch = null then
+ -- You are not inside a branch.
+ raise Syntax_Error;
+ end if;
+ if Current_Stmt_Scope.Last_Choice = null then
+ if Current_Stmt_Scope.Last_Branch.Choice_List /= null then
+ -- The branch was already closed.
+ raise Syntax_Error;
+ end if;
+ Current_Stmt_Scope.Last_Branch.Choice_List := Choice;
+ else
+ Current_Stmt_Scope.Last_Choice.Next := Choice;
+ end if;
+ Current_Stmt_Scope.Last_Choice := Choice;
+ end Add_Choice;
+
+ procedure New_Expr_Choice (Block : in out O_Case_Block; Expr : O_Cnode)
+ is
+ N : O_Choice;
+ begin
+ if Current_Stmt_Scope.Kind /= Stmt_Case then
+ -- You are creating a choice not inside a case statement.
+ raise Syntax_Error;
+ end if;
+ if Current_Stmt_Scope.Case_Type /= Expr.Ctype then
+ -- Expr type is not the same as choice type.
+ raise Type_Error;
+ end if;
+
+ N := new O_Choice_Type (ON_Choice_Expr);
+ N.all := O_Choice_Type'(Kind => ON_Choice_Expr,
+ Next => null,
+ Expr => Expr);
+ Add_Choice (Block, N);
+ end New_Expr_Choice;
+
+ procedure New_Range_Choice (Block : in out O_Case_Block;
+ Low, High : O_Cnode)
+ is
+ N : O_Choice;
+ begin
+ if Current_Stmt_Scope.Kind /= Stmt_Case then
+ -- You are creating a choice not inside a case statement.
+ raise Syntax_Error;
+ end if;
+ if Current_Stmt_Scope.Case_Type /= Low.Ctype
+ or Current_Stmt_Scope.Case_Type /= High.Ctype
+ then
+ -- Low/High type is not the same as choice type.
+ raise Type_Error;
+ end if;
+
+ N := new O_Choice_Type (ON_Choice_Range);
+ N.all := O_Choice_Type'(Kind => ON_Choice_Range,
+ Next => null,
+ Low => Low,
+ High => High);
+ Add_Choice (Block, N);
+ end New_Range_Choice;
+
+ procedure New_Default_Choice (Block : in out O_Case_Block)
+ is
+ N : O_Choice;
+ begin
+ if Current_Stmt_Scope.Kind /= Stmt_Case then
+ -- You are creating a choice not inside a case statement.
+ raise Syntax_Error;
+ end if;
+
+ N := new O_Choice_Type (ON_Choice_Default);
+ N.all := O_Choice_Type'(Kind => ON_Choice_Default,
+ Next => null);
+ Add_Choice (Block, N);
+ end New_Default_Choice;
+
+ procedure Finish_Choice (Block : in out O_Case_Block)
+ is
+ pragma Unreferenced (Block);
+ begin
+ if Current_Stmt_Scope.Kind /= Stmt_Case then
+ -- You are adding a choice not inside a case statement.
+ raise Syntax_Error;
+ end if;
+ if Current_Stmt_Scope.Last_Branch = null then
+ -- You are not inside a branch.
+ raise Syntax_Error;
+ end if;
+ if Current_Stmt_Scope.Last_Choice = null then
+ -- The branch is empty or you are not inside a branch.
+ raise Syntax_Error;
+ end if;
+ Current_Stmt_Scope.Last_Choice := null;
+ end Finish_Choice;
+
+ procedure Finish_Case_Stmt (Block : in out O_Case_Block)
+ is
+ pragma Unreferenced (Block);
+ Parent : O_Snode;
+ begin
+ Parent := Current_Stmt_Scope.Parent;
+ Pop_Stmt_Scope (Stmt_Case);
+ Parent.Case_Last := Current_Decl_Scope.Last_Stmt;
+ end Finish_Case_Stmt;
+
+ procedure Init is
+ begin
+ Top := new O_Snode_Type (ON_Declare_Stmt);
+ Push_Decl_Scope (Top);
+ end Init;
+
+ procedure Finish is
+ begin
+ Pop_Decl_Scope;
+ end Finish;
+end Ortho_Debug;
diff --git a/ortho/debug/ortho_debug.private.ads b/ortho/debug/ortho_debug.private.ads
new file mode 100644
index 0000000..d54d542
--- /dev/null
+++ b/ortho/debug/ortho_debug.private.ads
@@ -0,0 +1,439 @@
+with Ortho_Ident;
+use Ortho_Ident;
+
+package Ortho_Debug is
+ type O_Enode is private;
+ type O_Cnode is private;
+ type O_Lnode is private;
+ -- A node for a type.
+ type O_Tnode_Type (<>) is private;
+ type O_Tnode is access O_Tnode_Type;
+ -- A node for a statement.
+ type O_Snode_Type (<>) is private;
+ type O_Snode is access O_Snode_Type;
+ -- A node for a function.
+ type O_Dnode_Type (<>) is private;
+ type O_Dnode is access O_Dnode_Type;
+ -- A node for a record element.
+ type O_Fnode_Type is private;
+ type O_Fnode is access O_Fnode_Type;
+
+ procedure Init;
+ procedure Finish;
+ Top : O_Snode;
+private
+ type Str_Acc is access String;
+
+ type Decl_Scope_Type;
+ type Decl_Scope_Acc is access Decl_Scope_Type;
+
+ type On_Decl_Kind is
+ (ON_Type_Decl, ON_Completed_Type_Decl,
+ ON_Const_Decl, ON_Var_Decl, ON_Interface_Decl,
+ ON_Function_Decl, ON_Function_Body,
+ ON_Const_Value,
+ ON_Debug_Line_Decl, ON_Debug_Comment_Decl, ON_Debug_Filename_Decl);
+ O_Dnode_Null : constant O_Dnode := null;
+ type O_Dnode_Type (Kind : On_Decl_Kind) is record
+ Next : O_Dnode;
+ Name : O_Ident;
+ Dtype : O_Tnode;
+ Storage : O_Storage;
+ -- Declare statement in which the declaration appears.
+ Scope : O_Snode;
+ -- Line number, for regen.
+ Lineno : Natural;
+ case Kind is
+ when ON_Type_Decl =>
+ null;
+ when ON_Completed_Type_Decl =>
+ null;
+ when ON_Const_Decl =>
+ Const_Value : O_Dnode;
+ when ON_Const_Value =>
+ Const_Decl : O_Dnode;
+ Value : O_Cnode;
+ when ON_Var_Decl =>
+ null;
+ when ON_Function_Decl =>
+ Interfaces : O_Dnode;
+ Func_Body : O_Dnode;
+ Alive : Boolean;
+ when ON_Function_Body =>
+ Func_Decl : O_Dnode;
+ Func_Stmt : O_Snode;
+ when ON_Interface_Decl =>
+ Func_Scope : O_Dnode;
+ when ON_Debug_Line_Decl =>
+ Line : Natural;
+ when ON_Debug_Comment_Decl =>
+ Comment : Str_Acc;
+ when ON_Debug_Filename_Decl =>
+ Filename : Str_Acc;
+ end case;
+ end record;
+
+ O_Fnode_Null : constant O_Fnode := null;
+ type O_Fnode_Type is record
+ -- Record type.
+ Parent : O_Tnode;
+ -- Next field in the record.
+ Next : O_Fnode;
+ -- Name of the record field.
+ Ident : O_Ident;
+ -- Type of the record field.
+ Ftype : O_Tnode;
+ -- Offset in the field.
+ Offset : Unsigned_32;
+ end record;
+
+ type O_Anode_Type;
+ type O_Anode is access O_Anode_Type;
+ type O_Anode_Type is record
+ Next : O_Anode;
+ Formal : O_Dnode;
+ Actual : O_Enode;
+ end record;
+
+ type OC_Kind is
+ (
+ OC_Boolean_Lit,
+ OC_Unsigned_Lit,
+ OC_Signed_Lit,
+ OC_Float_Lit,
+ OC_Enum_Lit,
+ OC_Null_Lit,
+ OC_Sizeof_Lit,
+ OC_Offsetof_Lit,
+ OC_Aggregate,
+ OC_Aggr_Element,
+ OC_Union_Aggr,
+ OC_Address,
+ OC_Unchecked_Address,
+ OC_Subprogram_Address
+ );
+ type O_Cnode_Type (Kind : OC_Kind) is record
+ -- Type of the constant.
+ Ctype : O_Tnode;
+ -- True if referenced.
+ Ref : Boolean;
+ case Kind is
+ when OC_Unsigned_Lit =>
+ U_Val : Unsigned_64;
+ when OC_Signed_Lit =>
+ S_Val : Integer_64;
+ when OC_Float_Lit =>
+ F_Val : IEEE_Float_64;
+ when OC_Boolean_Lit =>
+ B_Val : Boolean;
+ B_Id : O_Ident;
+ when OC_Enum_Lit =>
+ E_Val : Integer;
+ E_Next : O_Cnode;
+ E_Name : O_Ident;
+ when OC_Null_Lit =>
+ null;
+ when OC_Sizeof_Lit =>
+ S_Type : O_Tnode;
+ when OC_Offsetof_Lit =>
+ Off_Field : O_Fnode;
+ when OC_Aggregate =>
+ Aggr_Els : O_Cnode;
+ when OC_Union_Aggr =>
+ Uaggr_Field : O_Fnode;
+ Uaggr_Value : O_Cnode;
+ when OC_Aggr_Element =>
+ Aggr_Value : O_Cnode;
+ Aggr_Next : O_Cnode;
+ when OC_Address
+ | OC_Unchecked_Address
+ | OC_Subprogram_Address =>
+ Decl : O_Dnode;
+ end case;
+ end record;
+
+ type O_Cnode is access O_Cnode_Type;
+ O_Cnode_Null : constant O_Cnode := null;
+
+ type OE_Kind is
+ (
+ -- Literals.
+ OE_Lit,
+
+ -- Dyadic operations.
+ OE_Add_Ov, -- OE_Dyadic_Op_Kind
+ OE_Sub_Ov, -- OE_Dyadic_Op_Kind
+ OE_Mul_Ov, -- OE_Dyadic_Op_Kind
+ OE_Div_Ov, -- OE_Dyadic_Op_Kind
+ OE_Rem_Ov, -- OE_Dyadic_Op_Kind
+ OE_Mod_Ov, -- OE_Dyadic_Op_Kind
+ OE_Exp_Ov, -- OE_Dyadic_Op_Kind
+
+ -- Binary operations.
+ OE_And, -- OE_Dyadic_Op_Kind
+ OE_Or, -- OE_Dyadic_Op_Kind
+ OE_Xor, -- OE_Dyadic_Op_Kind
+ OE_And_Then, -- OE_Dyadic_Op_Kind
+ OE_Or_Else, -- OE_Dyadic_Op_Kind
+
+ -- Monadic operations.
+ OE_Not, -- OE_Monadic_Op_Kind
+ OE_Neg_Ov, -- OE_Monadic_Op_Kind
+ OE_Abs_Ov, -- OE_Monadic_Op_Kind
+
+ -- Comparaisons
+ OE_Eq, -- OE_Compare_Op_Kind
+ OE_Neq, -- OE_Compare_Op_Kind
+ OE_Le, -- OE_Compare_Op_Kind
+ OE_Lt, -- OE_Compare_Op_Kind
+ OE_Ge, -- OE_Compare_Op_Kind
+ OE_Gt, -- OE_Compare_Op_Kind
+
+ -- Misc.
+ OE_Convert_Ov,
+ OE_Address,
+ OE_Unchecked_Address,
+ OE_Alloca,
+ OE_Function_Call,
+
+ OE_Value,
+ OE_Nil
+ );
+
+ subtype OE_Dyadic_Expr_Kind is OE_Kind range OE_Add_Ov .. OE_Or_Else;
+ subtype OE_Monadic_Expr_Kind is OE_Kind range OE_Not .. OE_Abs_Ov;
+ subtype OE_Compare_Expr_Kind is OE_Kind range OE_Eq .. OE_Gt;
+
+ type O_Enode_Type (Kind : OE_Kind);
+ type O_Enode is access O_Enode_Type;
+ O_Enode_Null : constant O_Enode := null;
+
+ type O_Enode_Type (Kind : OE_Kind) is record
+ -- Type of the result.
+ Rtype : O_Tnode;
+ -- True if referenced.
+ Ref : Boolean;
+ case Kind is
+ when OE_Dyadic_Expr_Kind
+ | OE_Compare_Expr_Kind =>
+ Left : O_Enode;
+ Right : O_Enode;
+ when OE_Monadic_Expr_Kind =>
+ Operand : O_Enode;
+ when OE_Lit =>
+ Lit : O_Cnode;
+ when OE_Address
+ | OE_Unchecked_Address =>
+ Lvalue : O_Lnode;
+ when OE_Convert_Ov =>
+ Conv : O_Enode;
+ when OE_Function_Call =>
+ Func : O_Dnode;
+ Assoc : O_Anode;
+ when OE_Value =>
+ Value : O_Lnode;
+ when OE_Alloca =>
+ A_Size : O_Enode;
+ when OE_Nil =>
+ null;
+ end case;
+ end record;
+ type O_Enode_Array is array (Natural range <>) of O_Enode;
+ type O_Enode_Array_Acc is access O_Enode_Array;
+
+ type OL_Kind is
+ (
+ -- Name.
+ OL_Obj,
+ OL_Indexed_Element,
+ OL_Slice,
+ OL_Selected_Element,
+ OL_Access_Element
+
+ -- Variable, constant, parameter reference.
+ -- This allows to read/write a declaration.
+ --OL_Var_Ref,
+ --OL_Const_Ref,
+ --OL_Param_Ref
+ );
+
+ type O_Lnode_Type (Kind : OL_Kind);
+ type O_Lnode is access O_Lnode_Type;
+ O_Lnode_Null : constant O_Lnode := null;
+
+ type O_Lnode_Type (Kind : OL_Kind) is record
+ -- Type of the result.
+ Rtype : O_Tnode;
+ -- True if referenced.
+ Ref : Boolean;
+ case Kind is
+ when OL_Obj =>
+ Obj : O_Dnode;
+ when OL_Indexed_Element =>
+ Array_Base : O_Lnode;
+ Index : O_Enode;
+ when OL_Slice =>
+ Slice_Base : O_Lnode;
+ Slice_Index : O_Enode;
+ when OL_Selected_Element =>
+ Rec_Base : O_Lnode;
+ Rec_El : O_Fnode;
+ when OL_Access_Element =>
+ Acc_Base : O_Enode;
+-- when OL_Var_Ref
+-- | OL_Const_Ref
+-- | OL_Param_Ref =>
+-- Decl : O_Dnode;
+ end case;
+ end record;
+
+ O_Tnode_Null : constant O_Tnode := null;
+ type ON_Type_Kind is
+ (ON_Boolean_Type, ON_Enum_Type,
+ ON_Unsigned_Type, ON_Signed_Type, ON_Float_Type, ON_Array_Type,
+ ON_Array_Sub_Type, ON_Record_Type, ON_Union_Type, ON_Access_Type);
+ type O_Tnode_Type (Kind : ON_Type_Kind) is record
+ Decl : O_Dnode;
+ -- Alignment, in power of 2.
+ Align : Natural;
+ -- Size in bytes.
+ Size : Unsigned_32;
+ -- True if the type was first created as an uncomplete type.
+ Uncomplete : Boolean;
+ -- True if the type is complete.
+ Complete : Boolean;
+ case Kind is
+ when ON_Boolean_Type =>
+ True_N : O_Cnode;
+ False_N : O_Cnode;
+ when ON_Unsigned_Type
+ | ON_Signed_Type =>
+ null;
+ when ON_Float_Type =>
+ null;
+ when ON_Enum_Type =>
+ Nbr : Natural;
+ Literals: O_Cnode;
+ when ON_Array_Type =>
+ El_Type : O_Tnode;
+ Index_Type : O_Tnode;
+ when ON_Access_Type =>
+ D_Type : O_Tnode;
+ when ON_Record_Type
+ | ON_Union_Type =>
+ Elements : O_Fnode;
+ when ON_Array_Sub_Type =>
+ Length : O_Cnode;
+ Base_Type : O_Tnode;
+ end case;
+ end record;
+
+ type ON_Choice_Kind is (ON_Choice_Expr, ON_Choice_Range, ON_Choice_Default);
+ type O_Choice_Type (Kind : ON_Choice_Kind);
+ type O_Choice is access O_Choice_Type;
+ type O_Choice_Type (Kind : ON_Choice_Kind) is record
+ Next : O_Choice;
+ case Kind is
+ when ON_Choice_Expr =>
+ Expr : O_Cnode;
+ when ON_Choice_Range =>
+ Low, High : O_Cnode;
+ when ON_Choice_Default =>
+ null;
+ end case;
+ end record;
+
+ O_Snode_Null : constant O_Snode := null;
+ type ON_Stmt_Kind is
+ (ON_Declare_Stmt, ON_Assign_Stmt, ON_Return_Stmt, ON_If_Stmt,
+ ON_Elsif_Stmt, ON_Loop_Stmt, ON_Exit_Stmt, ON_Next_Stmt,
+ ON_Case_Stmt, ON_When_Stmt, ON_Call_Stmt,
+ ON_Debug_Line_Stmt, ON_Debug_Comment_Stmt);
+ type O_Snode_Type (Kind : ON_Stmt_Kind) is record
+ Next : O_Snode;
+ Lineno : Natural;
+ case Kind is
+ when ON_Declare_Stmt =>
+ Decls : O_Dnode;
+ Stmts : O_Snode;
+ -- True if the statement is currently open.
+ Alive : Boolean;
+ when ON_Assign_Stmt =>
+ Target : O_Lnode;
+ Value : O_Enode;
+ when ON_Return_Stmt =>
+ Ret_Val : O_Enode;
+ when ON_If_Stmt =>
+ Elsifs : O_Snode;
+ If_Last : O_Snode;
+ when ON_Elsif_Stmt =>
+ Cond : O_Enode;
+ Next_Elsif : O_Snode;
+ when ON_Loop_Stmt =>
+ Loop_Last : O_Snode;
+ Loop_Level : Natural;
+ when ON_Exit_Stmt
+ | ON_Next_Stmt =>
+ Loop_Id : O_Snode;
+ when ON_Case_Stmt =>
+ Selector : O_Enode;
+ Branches : O_Snode;
+ Case_Last : O_Snode;
+ when ON_When_Stmt =>
+ Choice_List : O_Choice;
+ Next_Branch : O_Snode;
+ when ON_Call_Stmt =>
+ Proc : O_Dnode;
+ Assoc : O_Anode;
+ when ON_Debug_Line_Stmt =>
+ Line : Natural;
+ when ON_Debug_Comment_Stmt =>
+ Comment : Str_Acc;
+ end case;
+ end record;
+
+ type O_Inter_List is record
+ Func : O_Dnode;
+ Last : O_Dnode;
+ end record;
+
+ type O_Element_List is record
+ -- The type definition.
+ Res : O_Tnode;
+ -- The last element added.
+ Last : O_Fnode;
+ end record;
+
+ type O_Record_Aggr_List is record
+ Res : O_Cnode;
+ Last : O_Cnode;
+ Field : O_Fnode;
+ end record;
+
+ type O_Array_Aggr_List is record
+ Res : O_Cnode;
+ Last : O_Cnode;
+ El_Type : O_Tnode;
+ end record;
+
+ type O_Assoc_List is record
+ Subprg : O_Dnode;
+ Interfaces : O_Dnode;
+ First, Last : O_Anode;
+ end record;
+
+ type O_Enum_List is record
+ -- The type built.
+ Res : O_Tnode;
+
+ -- the chain of declarations.
+ Last : O_Cnode;
+ end record;
+ type O_Case_Block is record
+ null;
+ end record;
+
+ type O_If_Block is record
+ null;
+ end record;
+end Ortho_Debug;
diff --git a/ortho/debug/ortho_debug_front.ads b/ortho/debug/ortho_debug_front.ads
new file mode 100644
index 0000000..454c868
--- /dev/null
+++ b/ortho/debug/ortho_debug_front.ads
@@ -0,0 +1,2 @@
+with Ortho_Front;
+package Ortho_Debug_Front renames Ortho_Front;
diff --git a/ortho/debug/ortho_ident.ads b/ortho/debug/ortho_ident.ads
new file mode 100644
index 0000000..9b00d03
--- /dev/null
+++ b/ortho/debug/ortho_ident.ads
@@ -0,0 +1,2 @@
+with Ortho_Ident_Simple;
+package Ortho_Ident renames Ortho_Ident_Simple;
diff --git a/ortho/debug/ortho_ident_hash.adb b/ortho/debug/ortho_ident_hash.adb
new file mode 100644
index 0000000..c22b130
--- /dev/null
+++ b/ortho/debug/ortho_ident_hash.adb
@@ -0,0 +1,54 @@
+package body Ortho_Ident_Hash is
+ type O_Ident_Array is array (Hash_Type range <>) of O_Ident;
+ Hash_Max : constant Hash_Type := 511;
+ Symtable : O_Ident_Array (0 .. Hash_Max - 1) := (others => null);
+
+ function Get_Identifier (Str : String) return O_Ident
+ is
+ Hash : Hash_Type;
+ Ent : Hash_Type;
+ Res : O_Ident;
+ begin
+ -- 1. Compute Hash.
+ Hash := 0;
+ for I in Str'Range loop
+ Hash := Hash * 31 + Character'Pos (Str (I));
+ end loop;
+
+ -- 2. Search.
+ Ent := Hash mod Hash_Max;
+ Res := Symtable (Ent);
+ while Res /= null loop
+ if Res.Hash = Hash and then Res.Ident.all = Str then
+ return Res;
+ end if;
+ Res := Res.Next;
+ end loop;
+
+ -- Not found: add.
+ Res := new Ident_Type'(Hash => Hash,
+ Ident => new String'(Str),
+ Next => Symtable (Ent));
+ Symtable (Ent) := Res;
+ return Res;
+ end Get_Identifier;
+
+ function Get_String (Id : O_Ident) return String is
+ begin
+ if Id = null then
+ return "?ANON?";
+ else
+ return Id.Ident.all;
+ end if;
+ end Get_String;
+
+ function Is_Nul (Id : O_Ident) return Boolean is
+ begin
+ return Id = null;
+ end Is_Nul;
+
+ function Is_Equal (Id : O_Ident; Str : String) return Boolean is
+ begin
+ return Id.Ident.all = Str;
+ end Is_Equal;
+end Ortho_Ident_Hash;
diff --git a/ortho/debug/ortho_ident_hash.ads b/ortho/debug/ortho_ident_hash.ads
new file mode 100644
index 0000000..9ef2bd4
--- /dev/null
+++ b/ortho/debug/ortho_ident_hash.ads
@@ -0,0 +1,28 @@
+package Ortho_Ident_Hash is
+ type O_Ident is private;
+ O_Ident_Nul : constant O_Ident;
+
+ function Get_Identifier (Str : String) return O_Ident;
+ function Get_String (Id : O_Ident) return String;
+ function Is_Equal (L, R : O_Ident) return Boolean renames "=";
+ function Is_Equal (Id : O_Ident; Str : String) return Boolean;
+ function Is_Nul (Id : O_Ident) return Boolean;
+private
+ type Hash_Type is mod 2**32;
+
+ type String_Acc is access constant String;
+
+ -- Symbol table.
+ type Ident_Type;
+ type O_Ident is access Ident_Type;
+ type Ident_type is record
+ -- The hash for the symbol.
+ Hash : Hash_Type;
+ -- Identification of the symbol.
+ Ident : String_Acc;
+ -- Next symbol with the same collision.
+ Next : O_Ident;
+ end record;
+
+ O_Ident_Nul : constant O_Ident := null;
+end Ortho_Ident_Hash;
diff --git a/ortho/debug/ortho_ident_simple.adb b/ortho/debug/ortho_ident_simple.adb
new file mode 100644
index 0000000..2c641c3
--- /dev/null
+++ b/ortho/debug/ortho_ident_simple.adb
@@ -0,0 +1,26 @@
+package body Ortho_Ident_Simple is
+ function Get_Identifier (Str : String) return O_Ident
+ is
+ begin
+ return new String'(Str);
+ end Get_Identifier;
+
+ function Get_String (Id : O_Ident) return String is
+ begin
+ if Id = null then
+ return "?ANON?";
+ else
+ return Id.all;
+ end if;
+ end Get_String;
+
+ function Is_Nul (Id : O_Ident) return Boolean is
+ begin
+ return Id = null;
+ end Is_Nul;
+
+ function Is_Equal (Id : O_Ident; Str : String) return Boolean is
+ begin
+ return Id.all = Str;
+ end Is_Equal;
+end Ortho_Ident_Simple;
diff --git a/ortho/debug/ortho_ident_simple.ads b/ortho/debug/ortho_ident_simple.ads
new file mode 100644
index 0000000..63bd769
--- /dev/null
+++ b/ortho/debug/ortho_ident_simple.ads
@@ -0,0 +1,13 @@
+package Ortho_Ident_Simple is
+ type O_Ident is private;
+ O_Ident_Nul : constant O_Ident;
+
+ function Get_Identifier (Str : String) return O_Ident;
+ function Get_String (Id : O_Ident) return String;
+ function Is_Equal (L, R : O_Ident) return Boolean renames "=";
+ function Is_Equal (Id : O_Ident; Str : String) return Boolean;
+ function Is_Nul (Id : O_Ident) return Boolean;
+private
+ type O_Ident is access String;
+ O_Ident_Nul : constant O_Ident := null;
+end Ortho_Ident_Simple;
diff --git a/ortho/debug/ortho_nodes.ads b/ortho/debug/ortho_nodes.ads
new file mode 100644
index 0000000..a6c9c51
--- /dev/null
+++ b/ortho/debug/ortho_nodes.ads
@@ -0,0 +1,3 @@
+with Ortho_Debug;
+
+package Ortho_Nodes renames Ortho_Debug;
diff --git a/ortho/oread/Makefile b/ortho/oread/Makefile
new file mode 100644
index 0000000..c297af0
--- /dev/null
+++ b/ortho/oread/Makefile
@@ -0,0 +1,25 @@
+BE = gcc
+ortho_srcdir=..
+BACK_END=$(ortho_srcdir)/$(BE)
+ortho_exec=oread-$(BE)
+all: $(ortho_exec)
+
+test: test.s
+ $(CC) -o $@ $^
+
+test.s: $(ortho_exec)
+ ./$(ortho_exec) test
+
+$(ortho_exec): force
+ $(MAKE) -f $(BACK_END)/Makefile ortho_exec=$(ortho_exec)
+
+clean:
+ $(MAKE) -f $(BACK_END)/Makefile clean
+ $(RM) -f oread *.o *~
+
+distclean: clean
+ $(MAKE) -f $(BACK_END)/Makefile distclean
+
+force:
+
+.PHONY: force
diff --git a/ortho/oread/ortho_front.adb b/ortho/oread/ortho_front.adb
new file mode 100644
index 0000000..8821ce9
--- /dev/null
+++ b/ortho/oread/ortho_front.adb
@@ -0,0 +1,2650 @@
+with Ada.Unchecked_Deallocation;
+with Ortho_Nodes; use Ortho_Nodes;
+with Ortho_Ident; use Ortho_Ident;
+with Ada.Characters.Latin_1; use Ada.Characters.Latin_1;
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+with Interfaces; use Interfaces;
+with Ada.Exceptions;
+--with GNAT.Debug_Pools;
+
+-- TODO:
+-- uncomplete type: check for type redefinition
+
+package body Ortho_Front is
+ -- If true, emit line number before each statement.
+ -- If flase, keep line number indication in the source file.
+ Flag_Renumber : Boolean := True;
+
+ procedure Init is
+ begin
+ null;
+ end Init;
+
+ function Decode_Option (Opt : String_Acc; Arg : String_Acc) return Natural
+ is
+ pragma Unreferenced (Arg);
+ begin
+ if Opt.all = "-r" then
+ Flag_Renumber := True;
+ return 1;
+ else
+ return 0;
+ end if;
+ end Decode_Option;
+
+ -- File buffer.
+ File_Name : String_Acc;
+ Buf : String (1 .. 2048 + 1);
+ Buf_Len : Natural;
+ Pos : Natural;
+ Lineno : Natural;
+
+ Fd : File_Descriptor;
+
+ Error : exception;
+
+ procedure Puterr (Msg : String)
+ is
+ L : Integer;
+ begin
+ L := Write (Standerr, Msg'Address, Msg'Length);
+ end Puterr;
+
+ procedure Puterr (N : Natural)
+ is
+ Str : String := Natural'Image (N);
+ begin
+ Puterr (Str (Str'First + 1 .. Str'Last));
+ end Puterr;
+
+ procedure Newline_Err is
+ begin
+ Puterr ((1 => LF));
+ end Newline_Err;
+
+ procedure Scan_Error (Msg : String) is
+ begin
+ Puterr (File_Name.all);
+ Puterr (":");
+ Puterr (Lineno);
+ Puterr (": ");
+ Puterr (Msg);
+ Newline_Err;
+ raise Error;
+ end Scan_Error;
+
+ procedure Parse_Error (Msg : String);
+ pragma No_Return (Parse_Error);
+
+ procedure Parse_Error (Msg : String) is
+ begin
+ Puterr (File_Name.all);
+ Puterr (":");
+ Puterr (Lineno);
+ Puterr (": ");
+ Puterr (Msg);
+ Newline_Err;
+ raise Error;
+ end Parse_Error;
+
+
+-- Uniq_Num : Natural := 0;
+
+-- function Get_Uniq_Id return O_Ident
+-- is
+-- Str : String (1 .. 8);
+-- V : Natural;
+-- begin
+-- V := Uniq_Num;
+-- Uniq_Num := Uniq_Num + 1;
+-- Str (1) := 'L';
+-- Str (2) := '.';
+-- for I in reverse 3 .. Str'Last loop
+-- Str (I) := Character'Val ((V mod 10) + Character'Pos('0'));
+-- V := V / 10;
+-- end loop;
+-- return Get_Identifier (Str);
+-- end Get_Uniq_Id;
+
+ -- Get the next character.
+ -- Return NUL on end of file.
+ function Get_Char return Character
+ is
+ Res : Character;
+ begin
+ if Buf (Pos) = NUL then
+ -- Read line.
+ Buf_Len := Read (Fd, Buf'Address, Buf'Length - 1);
+ if Buf_Len <= 0 then
+ -- End of file.
+ return NUL;
+ end if;
+ Pos := 1;
+ Buf (Buf_Len + 1) := NUL;
+ end if;
+
+ Res := Buf (Pos);
+ Pos := Pos + 1;
+ return Res;
+ end Get_Char;
+
+ procedure Unget_Char is
+ begin
+ if Pos = Buf'First then
+ raise Program_Error;
+ end if;
+ Pos := Pos - 1;
+ end Unget_Char;
+
+ type Token_Type is
+ (Tok_Eof,
+ Tok_Line_Number, Tok_File_Name, Tok_Comment,
+ Tok_Ident, Tok_Num, Tok_String, Tok_Float_Num,
+ Tok_Plus, Tok_Minus,
+ Tok_Star, Tok_Div, Tok_Mod, Tok_Rem,
+ Tok_Sharp,
+ Tok_Not, Tok_Abs,
+ Tok_Or, Tok_And, Tok_Xor,
+ Tok_Equal, Tok_Not_Equal,
+ Tok_Greater, Tok_Greater_Eq,
+ Tok_Less, Tok_Less_Eq,
+ Tok_Colon, Tok_Semicolon,
+ Tok_Comma, Tok_Dot, Tok_Tick, Tok_Arob, Tok_Elipsis,
+ Tok_Assign,
+ Tok_Left_Paren, Tok_Right_Paren,
+ Tok_Left_Brace, Tok_Right_Brace,
+ Tok_Left_Brack, Tok_Right_Brack,
+ Tok_Unsigned, Tok_Signed, Tok_Float,
+ Tok_Array, Tok_Subarray,
+ Tok_Access, Tok_Record, Tok_Union,
+ Tok_Boolean, Tok_Enum,
+ Tok_If, Tok_Then, Tok_Else,
+ Tok_Loop, Tok_Exit, Tok_Next,
+ Tok_Is, Tok_Of, Tok_All,
+ Tok_Return,
+ Tok_Type,
+ Tok_External, Tok_Private, Tok_Public, Tok_Local,
+ Tok_Procedure, Tok_Function,
+ Tok_Constant, Tok_Var,
+ Tok_Declare, Tok_Begin, Tok_End,
+ Tok_Case, Tok_When, Tok_Default, Tok_Arrow,
+ Tok_Null);
+
+ type Hash_Type is new Unsigned_32;
+
+ type Name_Type;
+ type Name_Acc is access Name_Type;
+
+ -- Symbol table.
+ type Syment_Type;
+ type Syment_Acc is access Syment_Type;
+ type Syment_type is record
+ -- The hash for the symbol.
+ Hash : Hash_Type;
+ -- Identification of the symbol.
+ Ident : O_Ident;
+ -- Next symbol with the same collision.
+ Next : Syment_Acc;
+ -- Meaning of the symbol.
+ Name : Name_Acc;
+ end record;
+
+ -- Well known identifiers (used for attributes).
+ Id_Address : Syment_Acc;
+ Id_Unchecked_Address : Syment_Acc;
+ Id_Subprg_Addr : Syment_Acc;
+ Id_Conv : Syment_Acc;
+ Id_Sizeof : Syment_Acc;
+ Id_Alloca : Syment_Acc;
+ Id_Offsetof : Syment_Acc;
+
+ Token_Number : Unsigned_64;
+ Token_Float : IEEE_Float_64;
+ Token_Ident : String (1 .. 256);
+ Token_Idlen : Natural;
+ Token_Hash : Hash_Type;
+ Token_Sym : Syment_Acc;
+
+ -- The symbol table.
+ type Syment_Acc_Array is array (Hash_Type range <>) of Syment_Acc;
+ Hash_Max : constant Hash_Type := 511;
+ Symtable : Syment_Acc_Array (0 .. Hash_Max - 1) := (others => null);
+
+ type Node_Kind is (Decl_Keyword, Decl_Type, Decl_Param,
+ Node_Function, Node_Procedure, Node_Object, Node_Field,
+ Node_Lit,
+ Type_Boolean, Type_Enum,
+ Type_Unsigned, Type_Signed, Type_Float,
+ Type_Array, Type_Subarray,
+ Type_Access, Type_Record, Type_Union);
+ subtype Nodes_Subprogram is Node_Kind range Node_Function .. Node_Procedure;
+
+ type Node (<>);
+ type Node_Acc is access Node;
+ type Node (Kind : Node_Kind) is record
+ case Kind is
+ when Decl_Keyword =>
+ -- Keyword.
+ -- A keyword is not a declaration since the identifier has only
+ -- one meaning (the keyword).
+ Keyword : Token_Type;
+ when Decl_Type
+ | Decl_Param
+ | Node_Function
+ | Node_Procedure
+ | Node_Object
+ | Node_Lit =>
+ -- Declarations
+ -- All declarations but NODE_PROCEDURE have a type.
+ Decl_Dtype : Node_Acc;
+ Decl_Storage : O_Storage;
+ case Kind is
+ when Decl_Type =>
+ -- Type declaration.
+ null;
+ when Decl_Param =>
+ -- Parameter identifier.
+ Param_Name : Syment_Acc;
+ -- Parameter ortho node.
+ Param_Node : O_Dnode;
+ -- Next parameter of the parameters list.
+ Param_Next : Node_Acc;
+ when Node_Procedure
+ | Node_Function =>
+ -- Subprogram symbol name.
+ Subprg_Name : Syment_Acc;
+ -- List of parameters.
+ Subprg_Params : Node_Acc;
+ -- Subprogram ortho node.
+ Subprg_Node : O_Dnode;
+ when Node_Object =>
+ -- Name of the object (constant, variable).
+ Obj_Name : O_Ident;
+ -- Ortho node of the object.
+ Obj_Node : O_Dnode;
+ when Node_Lit =>
+ -- Name of the literal.
+ Lit_Name : O_Ident;
+ -- Enum literal
+ Lit_Cnode : O_Cnode;
+ -- Next literal for the type.
+ Lit_Next : Node_Acc;
+ when others =>
+ null;
+ end case;
+ when Node_Field =>
+ -- Record field.
+ Field_Ident : Syment_Acc;
+ Field_Fnode : O_Fnode;
+ Field_Type : Node_Acc;
+ Field_Next : Node_Acc;
+ when Type_Signed
+ | Type_Unsigned
+ | Type_Float
+ | Type_Array
+ | Type_Subarray
+ | Type_Record
+ | Type_Union
+ | Type_Access
+ | Type_Boolean
+ | Type_Enum =>
+ -- Ortho node type.
+ Type_Onode : O_Tnode;
+ case Kind is
+ when Type_Array =>
+ Array_Index : Node_Acc;
+ Array_Element : Node_Acc;
+ when Type_Subarray =>
+ Subarray_Base : Node_Acc;
+ --Subarray_Length : Natural;
+ when Type_Access =>
+ Access_Dtype : Node_Acc;
+ when Type_Record
+ | Type_Union =>
+ Record_Union_Fields : Node_Acc;
+ when Type_Enum
+ | Type_Boolean =>
+ Enum_Lits : Node_Acc;
+ when Type_Float =>
+ null;
+ when others =>
+ null;
+ end case;
+ end case;
+ end record;
+
+ type Scope_Type;
+ type Scope_Acc is access Scope_Type;
+
+ type Name_Type is record
+ -- Current interpretation of the symbol.
+ Inter : Node_Acc;
+ -- Next declaration in the current scope.
+ Next : Syment_Acc;
+ -- Interpretation in a previous scope.
+ Up : Name_Acc;
+ -- Current scope.
+ Scope : Scope_Acc;
+ end record;
+
+ type Scope_Type is record
+ -- Simply linked list of names.
+ Names : Syment_Acc;
+ -- Previous scope.
+ Prev : Scope_Acc;
+ end record;
+
+ -- Return the current declaration for symbol SYM.
+ function Get_Decl (Sym : Syment_Acc) return Node_Acc;
+ pragma Inline (Get_Decl);
+
+ procedure Scan_Char (C : Character)
+ is
+ R : Character;
+ begin
+
+ if C = '\' then
+ R := Get_Char;
+ case R is
+ when 'n' =>
+ R := LF;
+ when 'r' =>
+ R := CR;
+ when ''' =>
+ R := ''';
+ when '"' => -- "
+ R := '"'; -- "
+ when others =>
+ Scan_Error ("bad character sequence \" & R);
+ end case;
+ else
+ R := C;
+ end if;
+ Token_Idlen := Token_Idlen + 1;
+ Token_Ident (Token_Idlen) := R;
+ end Scan_Char;
+
+ function Get_Hash (Str : String) return Hash_Type
+ is
+ Res : Hash_Type;
+ begin
+ Res := 0;
+ for I in Str'Range loop
+ Res := Res * 31 + Character'Pos (Str (I));
+ end loop;
+ return Res;
+ end Get_Hash;
+
+ -- Previous token.
+ Tok_Previous : Token_Type;
+
+ function Scan_Number (First_Char : Character) return Token_Type
+ is
+ function To_Digit (C : Character) return Integer is
+ begin
+ case C is
+ when '0' .. '9' =>
+ return Character'Pos (C) - Character'Pos ('0');
+ when 'A' .. 'F' =>
+ return Character'Pos (C) - Character'Pos ('A') + 10;
+ when 'a' .. 'f' =>
+ return Character'Pos (C) - Character'Pos ('a') + 10;
+ when others =>
+ return -1;
+ end case;
+ end To_Digit;
+
+ function Is_Digit (C : Character) return Boolean is
+ begin
+ case C is
+ when '0' .. '9'
+ | 'A' .. 'F'
+ | 'a' .. 'f' =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Is_Digit;
+
+ After_Point : Integer;
+ C : Character;
+ Exp : Integer;
+ Exp_Neg : Boolean;
+ Base : Unsigned_64;
+ begin
+ Token_Number := 0;
+ C := First_Char;
+ loop
+ Token_Number := Token_Number * 10 + Unsigned_64 (To_Digit (C));
+ C := Get_Char;
+ exit when not Is_Digit (C);
+ end loop;
+ if C = '#' then
+ Base := Token_Number;
+ Token_Number := 0;
+ C := Get_Char;
+ loop
+ Token_Number := Token_Number * Base + Unsigned_64 (To_Digit (C));
+ C := Get_Char;
+ exit when C = '#';
+ end loop;
+ return Tok_Num;
+ end if;
+ if C = '.' then
+ -- A real number.
+ After_Point := 0;
+ Token_Float := IEEE_Float_64 (Token_Number);
+ loop
+ C := Get_Char;
+ exit when C not in '0' .. '9';
+ Token_Float := Token_Float * 10.0 + IEEE_Float_64 (To_Digit (C));
+ After_Point := After_Point + 1;
+ end loop;
+ if C = 'e' or C = 'E' then
+ Exp := 0;
+ C := Get_Char;
+ Exp_Neg := False;
+ if C = '-' then
+ Exp_Neg := True;
+ C := Get_Char;
+ elsif C = '+' then
+ C := Get_Char;
+ elsif not Is_Digit (C) then
+ Scan_Error ("digit expected");
+ end if;
+ while Is_Digit (C) loop
+ Exp := Exp * 10 + To_Digit (C);
+ C := Get_Char;
+ end loop;
+ if Exp_Neg then
+ Exp := -Exp;
+ end if;
+ Exp := Exp - After_Point;
+ else
+ Exp := - After_Point;
+ end if;
+ Unget_Char;
+ Token_Float := Token_Float * 10.0 ** Exp;
+ if Token_Float > IEEE_Float_64'Last then
+ Token_Float := IEEE_Float_64'Last;
+ end if;
+ return Tok_Float_Num;
+ else
+ Unget_Char;
+ return Tok_Num;
+ end if;
+ end Scan_Number;
+
+ procedure Scan_Comment
+ is
+ C : Character;
+ begin
+ Token_Idlen := 0;
+ loop
+ C := Get_Char;
+ exit when C = CR or C = LF;
+ Token_Idlen := Token_Idlen + 1;
+ Token_Ident (Token_Idlen) := C;
+ end loop;
+ Unget_Char;
+ end Scan_Comment;
+
+ -- Get the next token.
+ function Get_Token return Token_Type
+ is
+ C : Character;
+ begin
+ loop
+
+ C := Get_Char;
+ << Again >> null;
+ case C is
+ when NUL =>
+ return Tok_Eof;
+ when ' ' | HT =>
+ null;
+ when LF =>
+ Lineno := Lineno + 1;
+ C := Get_Char;
+ if C /= CR then
+ goto Again;
+ end if;
+ when CR =>
+ Lineno := Lineno + 1;
+ C := Get_Char;
+ if C /= LF then
+ goto Again;
+ end if;
+ when '+' =>
+ return Tok_Plus;
+ when '-' =>
+ C := Get_Char;
+ if C = '-' then
+ C := Get_Char;
+ if C = '#' then
+ return Tok_Line_Number;
+ elsif C = 'F' then
+ Scan_Comment;
+ return Tok_File_Name;
+ elsif C = ' ' then
+ Scan_Comment;
+ return Tok_Comment;
+ else
+ Scan_Error ("bad comment");
+ end if;
+ else
+ Unget_Char;
+ return Tok_Minus;
+ end if;
+ when '/' =>
+ C := Get_Char;
+ if C = '=' then
+ return Tok_Not_Equal;
+ else
+ Unget_Char;
+ return Tok_Div;
+ end if;
+ when '*' =>
+ return Tok_Star;
+ when '#' =>
+ return Tok_Sharp;
+ when '=' =>
+ C := Get_Char;
+ if C = '>' then
+ return Tok_Arrow;
+ else
+ Unget_Char;
+ return Tok_Equal;
+ end if;
+ when '>' =>
+ C := Get_Char;
+ if C = '=' then
+ return Tok_Greater_Eq;
+ else
+ Unget_Char;
+ return Tok_Greater;
+ end if;
+ when '(' =>
+ return Tok_Left_Paren;
+ when ')' =>
+ return Tok_Right_Paren;
+ when '{' =>
+ return Tok_Left_Brace;
+ when '}' =>
+ return Tok_Right_Brace;
+ when '[' =>
+ return Tok_Left_Brack;
+ when ']' =>
+ return Tok_Right_Brack;
+ when '<' =>
+ C := Get_Char;
+ if C = '=' then
+ return Tok_Less_Eq;
+ else
+ Unget_Char;
+ return Tok_Less;
+ end if;
+ when ':' =>
+ C := Get_Char;
+ if C = '=' then
+ return Tok_Assign;
+ else
+ Unget_Char;
+ return Tok_Colon;
+ end if;
+ when '.' =>
+ C := Get_Char;
+ if C = '.' then
+ C := Get_Char;
+ if C = '.' then
+ return Tok_Elipsis;
+ else
+ Scan_Error ("'...' expected");
+ end if;
+ else
+ Unget_Char;
+ return Tok_Dot;
+ end if;
+ when ';' =>
+ return Tok_Semicolon;
+ when ',' =>
+ return Tok_Comma;
+ when '@' =>
+ return Tok_Arob;
+ when ''' =>
+ if Tok_Previous = Tok_Ident then
+ return Tok_Tick;
+ else
+ Token_Number := Character'Pos (Get_Char);
+ C := Get_Char;
+ if C /= ''' then
+ Scan_Error ("ending single quote expected");
+ end if;
+ return Tok_Num;
+ end if;
+ when '"' => -- "
+ -- Eat double quote.
+ C := Get_Char;
+ Token_Idlen := 0;
+ loop
+ Scan_Char (C);
+ C := Get_Char;
+ exit when C = '"'; -- "
+ end loop;
+ return Tok_String;
+ when '0' .. '9' =>
+ return Scan_Number (C);
+ when 'a' .. 'z'
+ | 'A' .. 'Z'
+ | '_' =>
+ Token_Idlen := 0;
+ Token_Hash := 0;
+ loop
+ Token_Idlen := Token_Idlen + 1;
+ Token_Ident (Token_Idlen) := C;
+ Token_Hash := Token_Hash * 31 + Character'Pos (C);
+ C := Get_Char;
+ exit when (C < 'A' or C > 'Z')
+ and (C < 'a' or C > 'z')
+ and (C < '0' or C > '9')
+ and (C /= '_');
+ end loop;
+ Unget_Char;
+ declare
+ H : Hash_Type;
+ S : Syment_Acc;
+ N : Node_Acc;
+ begin
+ H := Token_Hash mod Hash_Max;
+ S := Symtable (H);
+ while S /= null loop
+ if S.Hash = Token_Hash
+ and then Is_Equal (S.Ident,
+ Token_Ident (1 .. Token_Idlen))
+ then
+ -- This identifier is known.
+ Token_Sym := S;
+
+ -- It may be a keyword.
+ if S.Name /= null then
+ N := Get_Decl (S);
+ if N.Kind = Decl_Keyword then
+ return N.Keyword;
+ end if;
+ end if;
+
+ return Tok_Ident;
+ end if;
+ S := S.Next;
+ end loop;
+ Symtable (H) := new Syment_Type'
+ (Hash => Token_Hash,
+ Ident => Get_Identifier (Token_Ident (1 .. Token_Idlen)),
+ Next => Symtable (H),
+ Name => null);
+ Token_Sym := Symtable (H);
+ return Tok_Ident;
+ end;
+ when others =>
+ Scan_Error ("Bad character:"
+ & Integer'Image (Character'Pos (C))
+ & C);
+ return Tok_Eof;
+ end case;
+ end loop;
+ end Get_Token;
+
+ -- The current token.
+ Tok : Token_Type;
+
+ procedure Next_Token is
+ begin
+ Tok_Previous := Tok;
+ Tok := Get_Token;
+ end Next_Token;
+
+ procedure Expect (T : Token_Type; Msg : String := "") is
+ begin
+ if Tok /= T then
+ if Msg'Length = 0 then
+ case T is
+ when Tok_Left_Brace =>
+ Parse_Error ("'{' expected");
+ when others =>
+ if Tok = Tok_Ident then
+ Parse_Error
+ (Token_Type'Image (T) & " expected, found '" &
+ Token_Ident (1 .. Token_Idlen) & "'");
+ else
+ Parse_Error (Token_Type'Image (T) & " expected, found "
+ & Token_Type'Image (Tok));
+ end if;
+ end case;
+ else
+ Parse_Error (Msg);
+ end if;
+ end if;
+ end Expect;
+
+ procedure Next_Expect (T : Token_Type; Msg : String := "") is
+ begin
+ Next_Token;
+ Expect (T, Msg);
+ end Next_Expect;
+
+ -- Scopes and identifiers.
+
+
+ -- Current scope.
+ Scope : Scope_Acc := null;
+
+ -- Add a declaration for symbol SYM in the current scope.
+ -- INTER defines the meaning of the declaration.
+ -- There must be at most one declaration for a symbol in the current scope,
+ -- i.e. a symbol cannot be redefined.
+ procedure Add_Decl (Sym : Syment_Acc; Inter : Node_Acc);
+
+ -- Return TRUE iff SYM is already defined in the current scope.
+ function Is_Defined (Sym : Syment_Acc) return Boolean;
+
+ -- Create new scope.
+ procedure Push_Scope;
+
+ -- Close the current scope. Symbols defined in the scope regain their
+ -- previous declaration.
+ procedure Pop_Scope;
+
+
+ procedure Push_Scope
+ is
+ Nscope : Scope_Acc;
+ begin
+ Nscope := new Scope_Type'(Names => null, Prev => Scope);
+ Scope := Nscope;
+ end Push_Scope;
+
+ procedure Pop_Scope
+ is
+ procedure Free is new Ada.Unchecked_Deallocation
+ (Object => Name_Type, Name => Name_Acc);
+
+ procedure Free is new Ada.Unchecked_Deallocation
+ (Object => Scope_Type, Name => Scope_Acc);
+
+ Sym : Syment_Acc;
+ N_Sym : Syment_Acc;
+ Name : Name_Acc;
+ Old_Scope : Scope_Acc;
+ begin
+ Sym := Scope.Names;
+ while Sym /= null loop
+ Name := Sym.Name;
+ -- Check.
+ if Name.Scope /= Scope then
+ raise Program_Error;
+ end if;
+
+ -- Set the interpretation of this symbol.
+ Sym.Name := Name.Up;
+
+ N_Sym := Name.Next;
+
+ Free (Name);
+ Sym := N_Sym;
+ end loop;
+
+ -- Free scope.
+ Old_Scope := Scope;
+ Scope := Scope.Prev;
+ Free (Old_Scope);
+ end Pop_Scope;
+
+ function Is_Defined (Sym : Syment_Acc) return Boolean is
+ begin
+ if Sym.Name /= null
+ and then Sym.Name.Scope = Scope
+ then
+ return True;
+ else
+ return False;
+ end if;
+ end Is_Defined;
+
+ function New_Symbol (Str : String) return Syment_Acc
+ is
+ Ent : Syment_Acc;
+ H : Hash_Type;
+ begin
+ Ent := new Syment_Type'(Hash => Get_Hash (Str),
+ Ident => Get_Identifier (Str),
+ Next => null,
+ Name => null);
+ H := Ent.Hash mod Hash_Max;
+ Ent.Next := Symtable (H);
+ Symtable (H) := Ent;
+ return Ent;
+ end New_Symbol;
+
+ procedure Add_Keyword (Str : String; Token : Token_Type)
+ is
+ Ent : Syment_Acc;
+ begin
+ Ent := New_Symbol (Str);
+ if Ent.Name /= null
+ or else Scope /= null
+ then
+ -- Redefinition of a keyword.
+ raise Program_Error;
+ end if;
+ Ent.Name := new Name_Type'(Inter => new Node'(Kind => Decl_Keyword,
+ Keyword => Token),
+ Next => null,
+ Up => null,
+ Scope => null);
+ end Add_Keyword;
+
+ procedure Add_Decl (Sym : Syment_Acc; Inter : Node_Acc)
+ is
+ Name : Name_Acc;
+ Prev : Node_Acc;
+ begin
+ Name := Sym.Name;
+ if Name /= null and then Name.Scope = Scope then
+ Prev := Name.Inter;
+ if Prev.Kind = Inter.Kind
+ and then Prev.Decl_Dtype = Inter.Decl_Dtype
+ and then Prev.Decl_Storage = O_Storage_External
+ and then Inter.Decl_Storage = O_Storage_Public
+ then
+ -- Redefinition
+ Name.Inter := Inter;
+ return;
+ end if;
+ Parse_Error ("redefinition of " & Get_String (Sym.Ident));
+ end if;
+ Name := new Name_Type'(Inter => Inter,
+ Next => Scope.Names,
+ Up => Sym.Name,
+ Scope => Scope);
+ Sym.Name := Name;
+ Scope.Names := Sym;
+ end Add_Decl;
+
+ function Get_Decl (Sym : Syment_Acc) return Node_Acc is
+ begin
+ if Sym.Name = null then
+ Parse_Error ("undefined identifier " & Get_String (Sym.Ident));
+ else
+ return Sym.Name.Inter;
+ end if;
+ end Get_Decl;
+
+ function Parse_Constant_Value (Atype : Node_Acc) return O_Cnode;
+ function Parse_Address (Prefix : Node_Acc) return O_Enode;
+ procedure Parse_Declaration;
+ procedure Parse_Compound_Statement;
+
+ function Parse_Type return Node_Acc;
+
+ procedure Parse_Fields (Aggr_Type : Node_Acc;
+ Constr : in out O_Element_List)
+ is
+ F_Type : Node_Acc;
+ F : Syment_Acc;
+ Last_Field : Node_Acc;
+ Field : Node_Acc;
+ begin
+ Last_Field := null;
+ loop
+ exit when Tok = Tok_End;
+
+ if Tok /= Tok_Ident then
+ Parse_Error ("field name expected");
+ end if;
+ F := Token_Sym;
+ Next_Expect (Tok_Colon, "':' expected");
+ Next_Token;
+ F_Type := Parse_Type;
+ Field := new Node'(Kind => Node_Field,
+ Field_Ident => F,
+ Field_Fnode => O_Fnode_Null,
+ Field_Type => F_Type,
+ Field_Next => null);
+ case Aggr_Type.Kind is
+ when Type_Record =>
+ New_Record_Field (Constr, Field.Field_Fnode, F.Ident,
+ F_Type.Type_Onode);
+ when Type_Union =>
+ New_Union_Field (Constr, Field.Field_Fnode, F.Ident,
+ F_Type.Type_Onode);
+ when others =>
+ raise Program_Error;
+ end case;
+ if Last_Field = null then
+ Aggr_Type.Record_Union_Fields := Field;
+ else
+ Last_Field.Field_Next := Field;
+ end if;
+ Last_Field := Field;
+ Expect (Tok_Semicolon, "';' expected");
+ Next_Token;
+ end loop;
+ end Parse_Fields;
+
+ procedure Parse_Record_Type (Def : Node_Acc)
+ is
+ Constr : O_Element_List;
+ begin
+ if Def.Type_Onode = O_Tnode_Null then
+ Start_Record_Type (Constr);
+ else
+ Start_Uncomplete_Record_Type (Def.Type_Onode, Constr);
+ end if;
+ Parse_Fields (Def, Constr);
+ Next_Expect (Tok_Record, "end record expected");
+ Finish_Record_Type (Constr, Def.Type_Onode);
+ end Parse_Record_Type;
+
+ procedure Parse_Union_Type (Def : Node_Acc)
+ is
+ Constr : O_Element_List;
+ begin
+ Start_Union_Type (Constr);
+ Parse_Fields (Def, Constr);
+ Next_Expect (Tok_Union, "end union expected");
+ Finish_Union_Type (Constr, Def.Type_Onode);
+ end Parse_Union_Type;
+
+ function Parse_Type return Node_Acc
+ is
+ Res : Node_Acc;
+ T : Token_Type;
+ begin
+ T := Tok;
+ case T is
+ when Tok_Unsigned
+ | Tok_Signed =>
+ Next_Expect (Tok_Left_Paren, "'(' expected");
+ Next_Expect (Tok_Num, "number expected");
+ case T is
+ when Tok_Unsigned =>
+ Res := new Node'
+ (Kind => Type_Unsigned,
+ Type_Onode => New_Unsigned_Type (Natural
+ (Token_Number)));
+ when Tok_Signed =>
+ Res := new Node'
+ (Kind => Type_Signed,
+ Type_Onode => New_Signed_Type (Natural
+ (Token_Number)));
+ when others =>
+ raise Program_Error;
+ end case;
+ Next_Expect (Tok_Right_Paren, "')' expected");
+ when Tok_Float =>
+ Res := new Node'(Kind => Type_Float,
+ Type_Onode => New_Float_Type);
+ when Tok_Array =>
+ declare
+ Index_Node : Node_Acc;
+ El_Node : Node_Acc;
+ begin
+ Next_Expect (Tok_Left_Brack, "'[' expected");
+ Next_Token;
+ Index_Node := Parse_Type;
+ Expect (Tok_Right_Brack, "']' expected");
+ Next_Expect (Tok_Of, "'of' expected");
+ Next_Token;
+ El_Node := Parse_Type;
+ Res := new Node'
+ (Kind => Type_Array,
+ Type_Onode => New_Array_Type (El_Node.Type_Onode,
+ Index_Node.Type_Onode),
+ Array_Index => Index_Node,
+ Array_Element => El_Node);
+ end;
+ return Res;
+ when Tok_Subarray =>
+ declare
+ Base_Node : Node_Acc;
+ Res_Type : O_Tnode;
+ begin
+ Next_Token;
+ Base_Node := Parse_Type;
+ Expect (Tok_Left_Brack);
+ Next_Token;
+ Res_Type := New_Constrained_Array_Type
+ (Base_Node.Type_Onode,
+ Parse_Constant_Value (Base_Node.Array_Index));
+ Expect (Tok_Right_Brack);
+ Next_Token;
+ Res := new Node' (Kind => Type_Subarray,
+ Type_Onode => Res_Type,
+ Subarray_Base => Base_Node);
+ return Res;
+ end;
+ when Tok_Ident =>
+ declare
+ Inter : Node_Acc;
+ begin
+ Inter := Get_Decl (Token_Sym);
+ if Inter = null then
+ Parse_Error ("undefined type name symbol "
+ & Get_String (Token_Sym.Ident));
+ end if;
+ if Inter.Kind /= Decl_Type then
+ Parse_Error ("type declarator expected");
+ end if;
+ Res := Inter.Decl_Dtype;
+ end;
+ when Tok_Access =>
+ declare
+ Dtype : Node_Acc;
+ begin
+ Next_Token;
+ if Tok = Tok_Semicolon then
+ Res := new Node'
+ (Kind => Type_Access,
+ Type_Onode => New_Access_Type (O_Tnode_Null),
+ Access_Dtype => null);
+ else
+ Dtype := Parse_Type;
+ Res := new Node'
+ (Kind => Type_Access,
+ Type_Onode => New_Access_Type (Dtype.Type_Onode),
+ Access_Dtype => Dtype);
+ end if;
+ return Res;
+ end;
+ when Tok_Record =>
+ Next_Token;
+ if Tok = Tok_Semicolon then
+ -- Uncomplete record type.
+ Res := new Node'(Kind => Type_Record,
+ Type_Onode => O_Tnode_Null,
+ Record_Union_Fields => null);
+ New_Uncomplete_Record_Type (Res.Type_Onode);
+ return Res;
+ end if;
+
+ Res := new Node'(Kind => Type_Record,
+ Type_Onode => O_Tnode_Null,
+ Record_Union_Fields => null);
+ Parse_Record_Type (Res);
+ when Tok_Union =>
+ Next_Token;
+ Res := new Node'(Kind => Type_Union,
+ Type_Onode => O_Tnode_Null,
+ Record_Union_Fields => null);
+ Parse_Union_Type (Res);
+
+ when Tok_Boolean =>
+ declare
+ False_Lit, True_Lit : Node_Acc;
+ begin
+ Res := new Node'(Kind => Type_Boolean,
+ Type_Onode => O_Tnode_Null,
+ Enum_Lits => null);
+ Next_Expect (Tok_Left_Brace, "'{' expected");
+ Next_Expect (Tok_Ident, "identifier expected");
+ False_Lit := new Node'(Kind => Node_Lit,
+ Decl_Dtype => Res,
+ Decl_Storage => O_Storage_Public,
+ Lit_Name => Token_Sym.Ident,
+ Lit_Cnode => O_Cnode_Null,
+ Lit_Next => null);
+ Next_Expect (Tok_Comma, "',' expected");
+ Next_Expect (Tok_Ident, "identifier expected");
+ True_Lit := new Node'(Kind => Node_Lit,
+ Decl_Dtype => Res,
+ Decl_Storage => O_Storage_Public,
+ Lit_Name => Token_Sym.Ident,
+ Lit_Cnode => O_Cnode_Null,
+ Lit_Next => null);
+ Next_Expect (Tok_Right_Brace, "'}' expected");
+ False_Lit.Lit_Next := True_Lit;
+ Res.Enum_Lits := False_Lit;
+ New_Boolean_Type (Res.Type_Onode,
+ False_Lit.Lit_Name, False_Lit.Lit_Cnode,
+ True_Lit.Lit_Name, True_Lit.Lit_Cnode);
+ end;
+ when Tok_Enum =>
+ declare
+ List : O_Enum_List;
+ Lit : Node_Acc;
+ Last_Lit : Node_Acc;
+ begin
+ Res := new Node'(Kind => Type_Enum,
+ Type_Onode => O_Tnode_Null,
+ Enum_Lits => null);
+ Last_Lit := null;
+ Push_Scope;
+ Next_Expect (Tok_Left_Brace);
+ Next_Token;
+ -- FIXME: set a size to the enum.
+ Start_Enum_Type (List, 8);
+ loop
+ Expect (Tok_Ident);
+ Lit := new Node'(Kind => Node_Lit,
+ Decl_Dtype => Res,
+ Decl_Storage => O_Storage_Public,
+ Lit_Name => Token_Sym.Ident,
+ Lit_Cnode => O_Cnode_Null,
+ Lit_Next => null);
+ Add_Decl (Token_Sym, Lit);
+ New_Enum_Literal (List, Lit.Lit_Name, Lit.Lit_Cnode);
+ if Last_Lit = null then
+ Res.Enum_Lits := Lit;
+ else
+ Last_Lit.Lit_Next := Lit;
+ end if;
+ Last_Lit := Lit;
+ Next_Expect (Tok_Equal);
+ Next_Expect (Tok_Num);
+ Next_Token;
+ exit when Tok = Tok_Right_Brace;
+ Expect (Tok_Comma);
+ Next_Token;
+ end loop;
+ Finish_Enum_Type (List, Res.Type_Onode);
+ Pop_Scope;
+ end;
+ when others =>
+ Parse_Error ("bad type " & Token_Type'Image (Tok));
+ return null;
+ end case;
+ Next_Token;
+ return Res;
+ end Parse_Type;
+
+ procedure Parse_Type_Completion (Decl : Node_Acc)
+ is
+ begin
+ case Tok is
+ when Tok_Record =>
+ Next_Token;
+ Parse_Record_Type (Decl.Decl_Dtype);
+ Next_Token;
+ when Tok_Access =>
+ Next_Token;
+ declare
+ Dtype : Node_Acc;
+ begin
+ Dtype := Parse_Type;
+ Decl.Decl_Dtype.Access_Dtype := Dtype;
+ Finish_Access_Type (Decl.Decl_Dtype.Type_Onode,
+ Dtype.Type_Onode);
+ end;
+ when others =>
+ Parse_Error ("'access' or 'record' expected");
+ end case;
+ end Parse_Type_Completion;
+
+-- procedure Parse_Declaration;
+
+ function Parse_Unary_Expression (Atype : Node_Acc) return O_Enode;
+ function Parse_Expression (Expr_Type : Node_Acc) return O_Enode;
+ procedure Parse_Name (Prefix : Node_Acc;
+ Name : out O_Lnode; N_Type : out Node_Acc);
+ procedure Parse_Lvalue (N : in out O_Lnode; N_Type : in out Node_Acc);
+
+ -- Expect: '('
+ -- Let: next token.
+ procedure Parse_Association (Constr : in out O_Assoc_List;
+ Decl : Node_Acc);
+
+ function Find_Field_By_Name (Aggr_Type : Node_Acc) return Node_Acc
+ is
+ Field : Node_Acc;
+ begin
+ Field := Aggr_Type.Record_Union_Fields;
+ while Field /= null loop
+ exit when Field.Field_Ident = Token_Sym;
+ Field := Field.Field_Next;
+ end loop;
+ if Field = null then
+ Parse_Error ("no such field name");
+ end if;
+ return Field;
+ end Find_Field_By_Name;
+
+ -- expect: offsetof id.
+ function Parse_Offsetof (Atype : Node_Acc) return O_Cnode
+ is
+ Rec_Type : Node_Acc;
+ Rec_Field : Node_Acc;
+ begin
+ Next_Expect (Tok_Left_Paren);
+ Next_Expect (Tok_Ident);
+ Rec_Type := Get_Decl (Token_Sym);
+ if Rec_Type.Kind /= Decl_Type
+ or else Rec_Type.Decl_Dtype.Kind /= Type_Record
+ then
+ Parse_Error ("type name expected");
+ end if;
+ Next_Expect (Tok_Dot);
+ Next_Expect (Tok_Ident);
+ Rec_Field := Find_Field_By_Name (Rec_Type.Decl_Dtype);
+ Next_Expect (Tok_Right_Paren);
+ return New_Offsetof (Rec_Field.Field_Fnode,
+ Atype.Type_Onode);
+ end Parse_Offsetof;
+
+ function Parse_Sizeof (Atype : Node_Acc) return O_Cnode
+ is
+ Res : O_Cnode;
+ begin
+ Next_Expect (Tok_Left_Paren);
+ Next_Token;
+ if Tok /= Tok_Ident then
+ Parse_Error ("type name expected");
+ end if;
+ Res := New_Sizeof
+ (Get_Decl (Token_Sym).Decl_Dtype.Type_Onode,
+ Atype.Type_Onode);
+ Next_Expect (Tok_Right_Paren);
+ return Res;
+ end Parse_Sizeof;
+
+ function Parse_Typed_Literal (Atype : Node_Acc) return O_Cnode
+ is
+ Res : O_Cnode;
+ begin
+ case Tok is
+ when Tok_Num =>
+ case Atype.Kind is
+ when Type_Signed =>
+ Res := New_Signed_Literal
+ (Atype.Type_Onode, Integer_64 (Token_Number));
+ when Type_Unsigned =>
+ Res := New_Unsigned_Literal
+ (Atype.Type_Onode, Token_Number);
+ when others =>
+ Parse_Error ("bad type for integer literal");
+ end case;
+ when Tok_Minus =>
+ Next_Token;
+ case Tok is
+ when Tok_Num =>
+ declare
+ V : Integer_64;
+ begin
+ if Token_Number = Unsigned_64 (Integer_64'Last) + 1 then
+ V := Integer_64'First;
+ else
+ V := -Integer_64 (Token_Number);
+ end if;
+ Res := New_Signed_Literal (Atype.Type_Onode, V);
+ end;
+ when Tok_Float_Num =>
+ Res := New_Float_Literal (Atype.Type_Onode, -Token_Float);
+ when others =>
+ Parse_Error ("bad token after '-'");
+ end case;
+ when Tok_Float_Num =>
+ Res := New_Float_Literal (Atype.Type_Onode, Token_Float);
+ when Tok_Ident =>
+ declare
+ N : Node_Acc;
+ begin
+ -- Note: we don't use get_decl, since the name can be a literal
+ -- name, which is not directly visible.
+ if Token_Sym.Name /= null
+ and then Token_Sym.Name.Inter.Kind = Decl_Type
+ then
+ -- A typed expression.
+ N := Token_Sym.Name.Inter.Decl_Dtype;
+ if Atype /= null and then N /= Atype then
+ Parse_Error ("type mismatch");
+ end if;
+ Next_Expect (Tok_Tick);
+ Next_Token;
+ if Tok = Tok_Left_Brack then
+ Next_Token;
+ Res := Parse_Typed_Literal (N);
+ Expect (Tok_Right_Brack);
+ elsif Tok = Tok_Ident then
+ if Token_Sym = Id_Offsetof then
+ Res := Parse_Offsetof (N);
+ elsif Token_Sym = Id_Sizeof then
+ Res := Parse_Sizeof (N);
+ elsif Token_Sym = Id_Conv then
+ Next_Expect (Tok_Left_Paren);
+ Next_Token;
+ Res := Parse_Typed_Literal (N);
+ Expect (Tok_Right_Paren);
+ else
+ Parse_Error ("offsetof or sizeof attributes expected");
+ end if;
+ else
+ Parse_Error ("'[' or attribute expected");
+ end if;
+ else
+ if Atype.Kind /= Type_Enum
+ and then Atype.Kind /= Type_Boolean
+ then
+ Parse_Error ("name allowed only for enumeration");
+ end if;
+ N := Atype.Enum_Lits;
+ while N /= null loop
+ if Is_Equal (N.Lit_Name, Token_Sym.Ident) then
+ Res := N.Lit_Cnode;
+ exit;
+ end if;
+ N := N.Lit_Next;
+ end loop;
+ if N = null then
+ Parse_Error ("no matching literal");
+ return O_Cnode_Null;
+ end if;
+ end if;
+ end;
+ when Tok_Null =>
+ Res := New_Null_Access (Atype.Type_Onode);
+ when others =>
+ Parse_Error ("bad primary expression: " & Token_Type'Image (Tok));
+ return O_Cnode_Null;
+ end case;
+ Next_Token;
+ return Res;
+ end Parse_Typed_Literal;
+
+ -- expect: next token
+ function Parse_Named_Expression
+ (Atype : Node_Acc; Name : Node_Acc; Stop_At_All : Boolean)
+ return O_Enode
+ is
+ Res : O_Enode;
+ R_Type : Node_Acc;
+ begin
+ if Tok = Tok_Tick then
+ Next_Token;
+ if Tok = Tok_Left_Brack then
+ -- Typed literal.
+ Next_Token;
+ Res := New_Lit (Parse_Typed_Literal (Name.Decl_Dtype));
+ Expect (Tok_Right_Brack);
+ Next_Token;
+ return Res;
+ elsif Tok = Tok_Left_Paren then
+ -- Typed expression.
+ Next_Token;
+ Res := Parse_Expression (Name.Decl_Dtype);
+ Expect (Tok_Right_Paren);
+ Next_Token;
+ return Res;
+ elsif Tok = Tok_Ident then
+ -- Attribute.
+ if Token_Sym = Id_Conv then
+ Next_Expect (Tok_Left_Paren);
+ Next_Token;
+ Res := Parse_Expression (null);
+ Expect (Tok_Right_Paren);
+ Next_Token;
+ R_Type := Name.Decl_Dtype;
+ Res := New_Convert_Ov (Res, R_Type.Type_Onode);
+ -- Fall-through.
+ elsif Token_Sym = Id_Address
+ or Token_Sym = Id_Unchecked_Address
+ or Token_Sym = Id_Subprg_Addr
+ then
+ R_Type := Name.Decl_Dtype;
+ Res := Parse_Address (Name);
+ -- Fall-through.
+ elsif Token_Sym = Id_Sizeof then
+ Res := New_Lit (Parse_Sizeof (Name.Decl_Dtype));
+ Next_Token;
+ return Res;
+ elsif Token_Sym = Id_Alloca then
+ Next_Expect (Tok_Left_Paren);
+ Next_Token;
+ Res := New_Alloca
+ (Name.Decl_Dtype.Type_Onode,
+ Parse_Expression (null));
+ Expect (Tok_Right_Paren);
+ Next_Token;
+ return Res;
+ elsif Token_Sym = Id_Offsetof then
+ Res := New_Lit (Parse_Offsetof (Atype));
+ Next_Token;
+ return Res;
+ else
+ Parse_Error ("unknown attribute name");
+ end if;
+ -- Fall-through.
+ else
+ Parse_Error ("typed expression expected");
+ end if;
+ elsif Tok = Tok_Left_Paren then
+ if Name.Kind /= Node_Function then
+ Parse_Error ("function name expected");
+ end if;
+ declare
+ Constr : O_Assoc_List;
+ begin
+ Parse_Association (Constr, Name);
+ Res := New_Function_Call (Constr);
+ R_Type := Name.Decl_Dtype;
+ -- Fall-through.
+ end;
+ elsif Name.Kind = Node_Object
+ or else Name.Kind = Decl_Param
+ then
+ -- Name.
+ declare
+ Lval : O_Lnode;
+ L_Type : Node_Acc;
+ begin
+ Parse_Name (Name, Lval, L_Type);
+ return New_Value (Lval);
+ end;
+ else
+ Parse_Error ("bad ident expression: "
+ & Token_Type'Image (Tok));
+ end if;
+
+ -- Continue.
+ -- R_TYPE and RES must be set.
+ if Tok = Tok_Dot then
+ if Stop_At_All then
+ return Res;
+ end if;
+ Next_Token;
+ if Tok = Tok_All then
+ if R_Type.Kind /= Type_Access then
+ Parse_Error ("type of prefix is not an access");
+ end if;
+ declare
+ N : O_Lnode;
+ begin
+ Next_Token;
+ N := New_Access_Element (Res);
+ R_Type := R_Type.Access_Dtype;
+ Parse_Lvalue (N, R_Type);
+ Res := New_Value (N);
+ end;
+ return Res;
+ else
+ Parse_Error ("'.all' expected");
+ end if;
+ else
+ return Res;
+ end if;
+ end Parse_Named_Expression;
+
+ function Parse_Primary_Expression (Atype : Node_Acc) return O_Enode
+ is
+ Res : O_Enode;
+ begin
+ case Tok is
+ when Tok_Num
+ | Tok_Float_Num =>
+ return New_Lit (Parse_Typed_Literal (Atype));
+ when Tok_Ident =>
+ declare
+ N : Node_Acc;
+ begin
+ N := Get_Decl (Token_Sym);
+ Next_Token;
+ return Parse_Named_Expression (Atype, N, False);
+ end;
+ when Tok_Left_Paren =>
+ Next_Token;
+ Res := Parse_Expression (Atype);
+ Expect (Tok_Right_Paren);
+ Next_Token;
+ return Res;
+-- when Tok_Ident =>
+-- declare
+-- Inter : Node_Acc;
+-- begin
+-- Inter := Token_Sym.Inter;
+-- while Inter /= null loop
+-- case Inter.Kind is
+-- when Inter_Var
+-- | Inter_Param =>
+-- Res := New_Value (Inter.Object_Node);
+-- Next_Token;
+-- return Res;
+-- when Inter_Subprg =>
+-- return Parse_Function_Call (Inter);
+-- when Inter_Keyword =>
+-- raise Program_Error;
+-- end case;
+-- Inter := Inter.Next;
+-- end loop;
+-- Parse_Error ("undefined name " & Get_String (Token_Sym.Ident));
+-- return O_Enode_Null;
+-- end;
+ when others =>
+ Parse_Error ("bad primary expression: " & Token_Type'Image (Tok));
+ return O_Enode_Null;
+ end case;
+ end Parse_Primary_Expression;
+
+ function Parse_Unary_Expression (Atype : Node_Acc) return O_Enode
+ is
+ Operand : O_Enode;
+ begin
+ case Tok is
+ when Tok_Minus =>
+ Next_Token;
+ case Tok is
+-- when Tok_Float_Num =>
+-- Operand := New_Float_Literal (Atype.Type_Onode,
+-- -Token_Float);
+-- Next_Token;
+-- return Operand;
+-- when Tok_Num =>
+-- Operand := New_Signed_Literal (Atype.Type_Onode,
+-- -Integer_64 (Token_Number));
+-- Next_Token;
+-- return Operand;
+ when others =>
+ Operand := Parse_Primary_Expression (Atype);
+ return New_Monadic_Op (ON_Neg_Ov, Operand);
+ end case;
+ when Tok_Not =>
+ Next_Token;
+ Operand := Parse_Unary_Expression (Atype);
+ return New_Monadic_Op (ON_Not, Operand);
+ when Tok_Abs =>
+ Next_Token;
+ Operand := Parse_Unary_Expression (Atype);
+ return New_Monadic_Op (ON_Abs_Ov, Operand);
+ when others =>
+ return Parse_Primary_Expression (Atype);
+ end case;
+ end Parse_Unary_Expression;
+
+ function Check_Sharp (Op_Ov : ON_Op_Kind) return ON_Op_Kind is
+ begin
+ Next_Expect (Tok_Sharp);
+ Next_Token;
+ return Op_Ov;
+ end Check_Sharp;
+
+ function Parse_Expression (Expr_Type : Node_Acc) return O_Enode
+ is
+ L : O_Enode;
+ R : O_Enode;
+ Op : ON_Op_Kind;
+ begin
+ L := Parse_Unary_Expression (Expr_Type);
+ case Tok is
+ when Tok_Div =>
+ Op := Check_Sharp (ON_Div_Ov);
+ when Tok_Plus =>
+ Op := Check_Sharp (ON_Add_Ov);
+ when Tok_Minus =>
+ Op := Check_Sharp (ON_Sub_Ov);
+ when Tok_Star =>
+ Op := Check_Sharp (ON_Mul_Ov);
+ when Tok_Mod =>
+ Op := Check_Sharp (ON_Mod_Ov);
+ when Tok_Rem =>
+ Op := Check_Sharp (ON_Rem_Ov);
+
+ when Tok_Equal =>
+ Op := ON_Eq;
+ when Tok_Not_Equal =>
+ Op := ON_Neq;
+ when Tok_Greater =>
+ Op := ON_Gt;
+ when Tok_Greater_Eq =>
+ Op := ON_Ge;
+ when Tok_Less =>
+ Op := ON_Lt;
+ when Tok_Less_Eq =>
+ Op := ON_Le;
+
+ when Tok_Or =>
+ Op := ON_Or;
+ Next_Token;
+ when Tok_And =>
+ Op := ON_And;
+ Next_Token;
+ when Tok_Xor =>
+ Op := ON_Xor;
+ Next_Token;
+
+ when others =>
+ return L;
+ end case;
+ if Op in ON_Compare_Op_Kind then
+ Next_Token;
+ end if;
+
+ R := Parse_Unary_Expression (Expr_Type);
+ case Op is
+ when ON_Dyadic_Op_Kind =>
+ return New_Dyadic_Op (Op, L, R);
+ when ON_Compare_Op_Kind =>
+ return New_Compare_Op (Op, L, R, Expr_Type.Type_Onode);
+ when others =>
+ raise Program_Error;
+ end case;
+ end Parse_Expression;
+
+ -- Expect and leave: next token
+ procedure Parse_Lvalue (N : in out O_Lnode; N_Type : in out Node_Acc)
+ is
+ begin
+ loop
+ case Tok is
+ when Tok_Dot =>
+ Next_Token;
+ if Tok = Tok_All then
+ if N_Type.Kind /= Type_Access then
+ Parse_Error ("type of prefix is not an access");
+ end if;
+ N := New_Access_Element (New_Value (N));
+ N_Type := N_Type.Access_Dtype;
+ Next_Token;
+ elsif Tok = Tok_Ident then
+ if N_Type.Kind /= Type_Record and N_Type.Kind /= Type_Union
+ then
+ Parse_Error
+ ("type of prefix is neither a record nor an union");
+ end if;
+ declare
+ Field : Node_Acc;
+ begin
+ Field := Find_Field_By_Name (N_Type);
+ N := New_Selected_Element (N, Field.Field_Fnode);
+ N_Type := Field.Field_Type;
+ Next_Token;
+ end;
+ else
+ Parse_Error
+ ("'.' must be followed by 'all' or a field name");
+ end if;
+ when Tok_Left_Brack =>
+ declare
+ V : O_Enode;
+ Bt : Node_Acc;
+ begin
+ Next_Token;
+ if N_Type.Kind = Type_Subarray then
+ Bt := N_Type.Subarray_Base;
+ else
+ Bt := N_Type;
+ end if;
+ if Bt.Kind /= Type_Array then
+ Parse_Error ("type of prefix is not an array");
+ end if;
+ V := Parse_Expression (Bt.Array_Index);
+ if Tok = Tok_Elipsis then
+ N := New_Slice (N, Bt.Type_Onode, V);
+ Next_Token;
+ else
+ N := New_Indexed_Element (N, V);
+ N_Type := Bt.Array_Element;
+ end if;
+ Expect (Tok_Right_Brack);
+ Next_Token;
+ end;
+ when others =>
+ return;
+ end case;
+ end loop;
+ end Parse_Lvalue;
+
+ procedure Parse_Name (Prefix : Node_Acc;
+ Name : out O_Lnode; N_Type : out Node_Acc)
+ is
+ begin
+ case Prefix.Kind is
+ when Decl_Param =>
+ Name := New_Obj (Prefix.Param_Node);
+ N_Type := Prefix.Decl_Dtype;
+ when Node_Object =>
+ Name := New_Obj (Prefix.Obj_Node);
+ N_Type := Prefix.Decl_Dtype;
+ when Decl_Type =>
+ declare
+ Val : O_Enode;
+ begin
+ Val := Parse_Named_Expression (null, Prefix, True);
+ N_Type := Prefix.Decl_Dtype;
+ if Tok = Tok_Dot then
+ Next_Token;
+ if Tok = Tok_All then
+ if N_Type.Kind /= Type_Access then
+ Parse_Error ("type of prefix is not an access");
+ end if;
+ Name := New_Access_Element (Val);
+ N_Type := N_Type.Access_Dtype;
+ Next_Token;
+ else
+ Parse_Error ("'.all' expected");
+ end if;
+ else
+ Parse_Error ("name expected");
+ end if;
+ end;
+ when others =>
+ Parse_Error ("invalid name");
+ end case;
+ Parse_Lvalue (Name, N_Type);
+ end Parse_Name;
+
+ -- Expect: '('
+ -- Let: next token.
+ procedure Parse_Association (Constr : in out O_Assoc_List; Decl : Node_Acc)
+ is
+ Param : Node_Acc;
+ begin
+ Start_Association (Constr, Decl.Subprg_Node);
+ if Tok /= Tok_Left_Paren then
+ Parse_Error ("'(' expected for a subprogram call");
+ end if;
+ Next_Token;
+ Param := Decl.Subprg_Params;
+ while Tok /= Tok_Right_Paren loop
+ if Param = null then
+ Parse_Error ("too many parameters");
+ end if;
+ New_Association (Constr, Parse_Expression (Param.Decl_Dtype));
+ Param := Param.Param_Next;
+ exit when Tok /= Tok_Comma;
+ Next_Token;
+ end loop;
+ if Param /= null then
+ Parse_Error ("missing parameters");
+ end if;
+ if Tok /= Tok_Right_Paren then
+ Parse_Error ("')' expected to finish a subprogram call, found "
+ & Token_Type'Image (Tok));
+ end if;
+ Next_Token;
+ end Parse_Association;
+
+ type Loop_Info;
+ type Loop_Info_Acc is access Loop_Info;
+ type Loop_Info is record
+ Num : Natural;
+ Blk : O_Snode;
+ Prev : Loop_Info_Acc;
+ end record;
+ procedure Free is new Ada.Unchecked_Deallocation
+ (Name => Loop_Info_Acc, Object => Loop_Info);
+
+ Loop_Stack : Loop_Info_Acc := null;
+
+ function Find_Loop (N : Natural) return Loop_Info_Acc
+ is
+ Res : Loop_Info_Acc;
+ begin
+ Res := Loop_Stack;
+ while Res /= null loop
+ if Res.Num = N then
+ return Res;
+ end if;
+ Res := Res.Prev;
+ end loop;
+ return null;
+ end Find_Loop;
+
+ Current_Subprg : Node_Acc := null;
+
+ -- Expect : next token
+ -- Let: next token
+ procedure Parse_Statement is
+ begin
+ if Flag_Renumber then
+ New_Debug_Line_Stmt (Lineno);
+ end if;
+
+ case Tok is
+ when Tok_Comment =>
+ Next_Token;
+
+ when Tok_Declare =>
+ Start_Declare_Stmt;
+ Parse_Compound_Statement;
+ Expect (Tok_Semicolon);
+ Next_Token;
+ Finish_Declare_Stmt;
+
+ when Tok_Line_Number =>
+ Next_Expect (Tok_Num);
+ if Flag_Renumber = False then
+ New_Debug_Line_Stmt (Natural (Token_Number));
+ end if;
+ Next_Token;
+
+ when Tok_If =>
+ declare
+ If_Blk : O_If_Block;
+ begin
+ Next_Token;
+ Start_If_Stmt (If_Blk, Parse_Expression (null));
+ Expect (Tok_Then);
+ Next_Token;
+ loop
+ exit when Tok = Tok_Else or Tok = Tok_End;
+ pragma Warnings (Off);
+ Parse_Statement;
+ pragma Warnings (On);
+ end loop;
+ if Tok = Tok_Else then
+ Next_Token;
+ New_Else_Stmt (If_Blk);
+ loop
+ exit when Tok = Tok_End;
+ pragma Warnings (Off);
+ Parse_Statement;
+ pragma Warnings (On);
+ end loop;
+ end if;
+ Finish_If_Stmt (If_Blk);
+ Expect (Tok_End);
+ Next_Expect (Tok_If);
+ Next_Expect (Tok_Semicolon);
+ Next_Token;
+ end;
+
+ when Tok_Loop =>
+ declare
+ Info : Loop_Info_Acc;
+ Num : Natural;
+ begin
+ Next_Expect (Tok_Num);
+ Num := Natural (Token_Number);
+ if Find_Loop (Num) /= null then
+ Parse_Error ("loop label already defined");
+ end if;
+ Info := new Loop_Info;
+ Info.Num := Num;
+ Info.Prev := Loop_Stack;
+ Loop_Stack := Info;
+ Start_Loop_Stmt (Info.Blk);
+ Next_Expect (Tok_Colon);
+ Next_Token;
+ while Tok /= Tok_End loop
+ pragma Warnings (Off);
+ Parse_Statement;
+ pragma Warnings (On);
+ end loop;
+ Finish_Loop_Stmt (Info.Blk);
+ Next_Expect (Tok_Loop);
+ Next_Expect (Tok_Semicolon);
+ Loop_Stack := Info.Prev;
+ Free (Info);
+ Next_Token;
+ end;
+
+ when Tok_Exit
+ | Tok_Next =>
+ declare
+ Label : Loop_Info_Acc;
+ Etok : Token_Type;
+ begin
+ Etok := Tok;
+ Next_Expect (Tok_Loop);
+ Next_Expect (Tok_Num);
+ Label := Find_Loop (Natural (Token_Number));
+ if Label = null then
+ Parse_Error ("no such loop");
+ end if;
+ if Etok = Tok_Exit then
+ New_Exit_Stmt (Label.Blk);
+ else
+ New_Next_Stmt (Label.Blk);
+ end if;
+ Next_Expect (Tok_Semicolon);
+ Next_Token;
+ end;
+
+ when Tok_Return =>
+ Next_Token;
+ if Tok /= Tok_Semicolon then
+ New_Return_Stmt (Parse_Expression (Current_Subprg.Decl_Dtype));
+ if Tok /= Tok_Semicolon then
+ Parse_Error ("';' expected at end of return statement");
+ end if;
+ else
+ New_Return_Stmt;
+ end if;
+ Next_Token;
+
+ when Tok_Ident =>
+ -- This is either a procedure call or an assignment.
+ declare
+ Inter : Node_Acc;
+ begin
+ Inter := Get_Decl (Token_Sym);
+ Next_Token;
+ if Tok = Tok_Left_Paren then
+ -- A procedure call.
+ declare
+ Constr : O_Assoc_List;
+ begin
+ Parse_Association (Constr, Inter);
+ New_Procedure_Call (Constr);
+ if Tok /= Tok_Semicolon then
+ Parse_Error ("';' expected after call");
+ end if;
+ Next_Token;
+ return;
+ end;
+ else
+ -- An assignment.
+ declare
+ Name : O_Lnode;
+ N_Type : Node_Acc;
+ begin
+ Parse_Name (Inter, Name, N_Type);
+ if Tok /= Tok_Assign then
+ Parse_Error ("`:=' expected after a variable");
+ end if;
+ Next_Token;
+ New_Assign_Stmt (Name, Parse_Expression (N_Type));
+ if Tok /= Tok_Semicolon then
+ Parse_Error ("';' expected at end of assignment");
+ end if;
+ Next_Token;
+ return;
+ end;
+ end if;
+ end;
+
+ when Tok_Case =>
+ declare
+ Case_Blk : O_Case_Block;
+ L : O_Cnode;
+ begin
+ Next_Token;
+ Start_Case_Stmt (Case_Blk, Parse_Expression (null));
+ Expect (Tok_Is);
+ Next_Token;
+ loop
+ exit when Tok = Tok_End;
+ Expect (Tok_When);
+ Start_Choice (Case_Blk);
+ Next_Token;
+ if Tok = Tok_Default then
+ New_Default_Choice (Case_Blk);
+ Next_Token;
+ else
+ L := Parse_Typed_Literal (null);
+ if Tok = Tok_Elipsis then
+ Next_Token;
+ New_Range_Choice
+ (Case_Blk, L, Parse_Typed_Literal (null));
+ else
+ New_Expr_Choice (Case_Blk, L);
+ end if;
+ end if;
+ Finish_Choice (Case_Blk);
+ Expect (Tok_Arrow);
+ Next_Token;
+ loop
+ exit when Tok = Tok_End or Tok = Tok_When;
+ pragma Warnings (Off);
+ Parse_Statement;
+ pragma Warnings (On);
+ end loop;
+ end loop;
+ Finish_Case_Stmt (Case_Blk);
+ Expect (Tok_End);
+ Next_Expect (Tok_Case);
+ Next_Expect (Tok_Semicolon);
+ Next_Token;
+ end;
+ when others =>
+ Parse_Error ("bad statement: " & Token_Type'Image (Tok));
+ end case;
+ end Parse_Statement;
+
+ procedure Parse_Compound_Statement is
+ begin
+ if Tok /= Tok_Declare then
+ Parse_Error ("'declare' expected to start a statements block");
+ end if;
+ Next_Token;
+
+ Push_Scope;
+
+ -- Parse declarations.
+ while Tok /= Tok_Begin loop
+ Parse_Declaration;
+ end loop;
+ Next_Token;
+
+ -- Parse statements.
+ while Tok /= Tok_End loop
+ Parse_Statement;
+ end loop;
+ Next_Token;
+
+ Pop_Scope;
+ end Parse_Compound_Statement;
+
+ -- Parse (P1 : T1; P2: T2; ...)
+ function Parse_Parameter_List return Node_Acc
+ is
+ First, Last : Node_Acc;
+ P : Node_Acc;
+ begin
+ Expect (Tok_Left_Paren);
+ Next_Token;
+ if Tok = Tok_Right_Paren then
+ Next_Token;
+ return null;
+ end if;
+ First := null;
+ Last := null;
+ loop
+ Expect (Tok_Ident);
+ P := new Node'(Kind => Decl_Param,
+ Decl_Dtype => null,
+ Decl_Storage => O_Storage_Public,
+ Param_Node => O_Dnode_Null,
+ Param_Name => Token_Sym,
+ Param_Next => null);
+ -- Link
+ if Last = null then
+ First := P;
+ else
+ Last.Param_Next := P;
+ end if;
+ Last := P;
+ Next_Expect (Tok_Colon);
+ Next_Token;
+ P.Decl_Dtype := Parse_Type;
+ exit when Tok = Tok_Right_Paren;
+ Expect (Tok_Semicolon);
+ Next_Token;
+ end loop;
+ Next_Token;
+ return First;
+ end Parse_Parameter_List;
+
+ procedure Create_Interface_List (Constr : in out O_Inter_List;
+ First_Inter : Node_Acc)
+ is
+ Inter : Node_Acc;
+ begin
+ Inter := First_Inter;
+ while Inter /= null loop
+ New_Interface_Decl (Constr, Inter.Param_Node, Inter.Param_Name.Ident,
+ Inter.Decl_Dtype.Type_Onode);
+ Inter := Inter.Param_Next;
+ end loop;
+ end Create_Interface_List;
+
+ procedure Check_Parameter_List (List : Node_Acc)
+ is
+ Param : Node_Acc;
+ begin
+ Next_Expect (Tok_Left_Paren);
+ Next_Token;
+ Param := List;
+ while Tok /= Tok_Right_Paren loop
+ if Param = null then
+ Parse_Error ("subprogram redefined with more parameters");
+ end if;
+ Expect (Tok_Ident);
+ if Token_Sym /= Param.Param_Name then
+ Parse_Error ("subprogram redefined with different parameter name");
+ end if;
+ Next_Expect (Tok_Colon);
+ Next_Token;
+ if Parse_Type /= Param.Decl_Dtype then
+ Parse_Error ("subprogram redefined with different parameter type");
+ end if;
+ Param := Param.Param_Next;
+ exit when Tok = Tok_Right_Paren;
+ Expect (Tok_Semicolon);
+ Next_Token;
+ end loop;
+ Expect (Tok_Right_Paren);
+ Next_Token;
+ if Param /= null then
+ Parse_Error ("subprogram redefined with less parameters");
+ end if;
+ end Check_Parameter_List;
+
+ procedure Parse_Subprogram_Body (Subprg : Node_Acc)
+ is
+ Param : Node_Acc;
+ Prev_Subprg : Node_Acc;
+ begin
+ Prev_Subprg := Current_Subprg;
+ Current_Subprg := Subprg;
+
+ Start_Subprogram_Body (Subprg.Subprg_Node);
+ Push_Scope;
+
+ -- Put parameters in the current scope.
+ Param := Subprg.Subprg_Params;
+ while Param /= null loop
+ Add_Decl (Param.Param_Name, Param);
+ Param := Param.Param_Next;
+ end loop;
+
+ Parse_Compound_Statement;
+
+ Pop_Scope;
+ Finish_Subprogram_Body;
+
+ Current_Subprg := Prev_Subprg;
+ end Parse_Subprogram_Body;
+
+ procedure Parse_Function_Definition (Storage : O_Storage)
+ is
+ Constr : O_Inter_List;
+ Sym : Syment_Acc;
+ N : Node_Acc;
+ begin
+ Expect (Tok_Function);
+ Next_Expect (Tok_Ident);
+ Sym := Token_Sym;
+ if Sym.Name /= null then
+ N := Get_Decl (Sym);
+ Check_Parameter_List (N.Subprg_Params);
+ Expect (Tok_Return);
+ Next_Expect (Tok_Ident);
+ Next_Token;
+ else
+ N := new Node'(Kind => Node_Function,
+ Decl_Dtype => null,
+ Decl_Storage => Storage,
+ Subprg_Node => O_Dnode_Null,
+ Subprg_Name => Sym,
+ Subprg_Params => null);
+ Next_Token;
+ N.Subprg_Params := Parse_Parameter_List;
+ Expect (Tok_Return);
+ Next_Token;
+ N.Decl_Dtype := Parse_Type;
+
+ Start_Function_Decl (Constr, N.Subprg_Name.Ident, Storage,
+ N.Decl_Dtype.Type_Onode);
+ Create_Interface_List (Constr, N.Subprg_Params);
+ Finish_Subprogram_Decl (Constr, N.Subprg_Node);
+
+ Add_Decl (Sym, N);
+ end if;
+
+ if Tok = Tok_Declare then
+ Parse_Subprogram_Body (N);
+ end if;
+ end Parse_Function_Definition;
+
+ procedure Parse_Procedure_Definition (Storage : O_Storage)
+ is
+ Constr : O_Inter_List;
+ Sym : Syment_Acc;
+ N : Node_Acc;
+ begin
+ Expect (Tok_Procedure);
+ Next_Expect (Tok_Ident);
+ Sym := Token_Sym;
+ if Sym.Name /= null then
+ N := Get_Decl (Sym);
+ Check_Parameter_List (N.Subprg_Params);
+ else
+ N := new Node'(Kind => Node_Procedure,
+ Decl_Dtype => null,
+ Decl_Storage => Storage,
+ Subprg_Node => O_Dnode_Null,
+ Subprg_Name => Sym,
+ Subprg_Params => null);
+ Next_Token;
+ N.Subprg_Params := Parse_Parameter_List;
+
+ Start_Procedure_Decl (Constr, N.Subprg_Name.Ident, Storage);
+ Create_Interface_List (Constr, N.Subprg_Params);
+ Finish_Subprogram_Decl (Constr, N.Subprg_Node);
+
+ Add_Decl (Sym, N);
+ end if;
+
+ if Tok = Tok_Declare then
+ Parse_Subprogram_Body (N);
+ end if;
+ end Parse_Procedure_Definition;
+
+ function Parse_Address (Prefix : Node_Acc) return O_Enode
+ is
+ Pfx : Node_Acc;
+ N : O_Lnode;
+ N_Type : Node_Acc;
+ Res : O_Enode;
+ Attr : Syment_Acc;
+ T : O_Tnode;
+ begin
+ Attr := Token_Sym;
+ Next_Expect (Tok_Left_Paren);
+ Next_Expect (Tok_Ident);
+ Pfx := Get_Decl (Token_Sym);
+ T := Prefix.Decl_Dtype.Type_Onode;
+ if Attr = Id_Subprg_Addr then
+ Expect (Tok_Ident);
+ Pfx := Get_Decl (Token_Sym);
+ if Pfx.Kind not in Nodes_Subprogram then
+ Parse_Error ("subprogram identifier expected");
+ end if;
+ Res := New_Lit (New_Subprogram_Address (Pfx.Subprg_Node, T));
+ Next_Token;
+ else
+ Next_Token;
+ Parse_Name (Pfx, N, N_Type);
+ if Attr = Id_Address then
+ Res := New_Address (N, T);
+ elsif Attr = Id_Unchecked_Address then
+ Res := New_Unchecked_Address (N, T);
+ else
+ Parse_Error ("address attribute expected");
+ end if;
+ end if;
+ Expect (Tok_Right_Paren);
+ Next_Token;
+ return Res;
+ end Parse_Address;
+
+ function Parse_Constant_Address (Prefix : Node_Acc) return O_Cnode
+ is
+ Pfx : Node_Acc;
+ Res : O_Cnode;
+ Attr : Syment_Acc;
+ T : O_Tnode;
+ begin
+ Attr := Token_Sym;
+ Next_Expect (Tok_Left_Paren);
+ Next_Expect (Tok_Ident);
+ Pfx := Get_Decl (Token_Sym);
+ T := Prefix.Decl_Dtype.Type_Onode;
+ if Attr = Id_Subprg_Addr then
+ Expect (Tok_Ident);
+ Pfx := Get_Decl (Token_Sym);
+ if Pfx.Kind not in Nodes_Subprogram then
+ Parse_Error ("subprogram identifier expected");
+ end if;
+ Res := New_Subprogram_Address (Pfx.Subprg_Node, T);
+ Next_Token;
+ else
+ Next_Token;
+ if Attr = Id_Address then
+ Res := New_Global_Address (Pfx.Obj_Node, T);
+ elsif Attr = Id_Unchecked_Address then
+ Res := New_Global_Unchecked_Address (Pfx.Obj_Node, T);
+ else
+ Parse_Error ("address attribute expected");
+ end if;
+ end if;
+ Expect (Tok_Right_Paren);
+ Next_Token;
+ return Res;
+ end Parse_Constant_Address;
+
+ function Parse_Constant_Value (Atype : Node_Acc) return O_Cnode
+ is
+ Res : O_Cnode;
+ begin
+ case Atype.Kind is
+ when Type_Subarray =>
+ declare
+ Constr : O_Array_Aggr_List;
+ El : Node_Acc;
+ begin
+ Expect (Tok_Left_Brace);
+ Next_Token;
+ Start_Array_Aggr (Constr, Atype.Type_Onode);
+ El := Atype.Subarray_Base.Array_Element;
+ for I in Natural loop
+ exit when Tok = Tok_Right_Brace;
+ if I /= 0 then
+ Expect (Tok_Comma);
+ Next_Token;
+ end if;
+ New_Array_Aggr_El (Constr, Parse_Constant_Value (El));
+ end loop;
+ Finish_Array_Aggr (Constr, Res);
+ Next_Token;
+ return Res;
+ end;
+ when Type_Unsigned
+ | Type_Signed
+ | Type_Enum
+ | Type_Float
+ | Type_Boolean =>
+ --return Parse_Primary_Expression (Atype);
+ return Parse_Typed_Literal (Atype);
+ when Type_Record =>
+ declare
+ Constr : O_Record_Aggr_List;
+ Field : Node_Acc;
+ begin
+ Expect (Tok_Left_Brace);
+ Next_Token;
+ Start_Record_Aggr (Constr, Atype.Type_Onode);
+ Field := Atype.Record_Union_Fields;
+ while Field /= null loop
+ Expect (Tok_Dot);
+ Next_Expect (Tok_Ident);
+ if Token_Sym /= Field.Field_Ident then
+ Parse_Error ("bad field name");
+ end if;
+ Next_Expect (Tok_Equal);
+ Next_Token;
+ New_Record_Aggr_El
+ (Constr, Parse_Constant_Value (Field.Field_Type));
+ Field := Field.Field_Next;
+ if Field /= null then
+ Expect (Tok_Comma);
+ Next_Token;
+ end if;
+ end loop;
+ Finish_Record_Aggr (Constr, Res);
+ Expect (Tok_Right_Brace);
+ Next_Token;
+ return Res;
+ end;
+ when Type_Union =>
+ declare
+ Field : Node_Acc;
+ begin
+ Expect (Tok_Left_Brace);
+ Next_Token;
+ Expect (Tok_Dot);
+ Next_Expect (Tok_Ident);
+ Field := Find_Field_By_Name (Atype);
+ Next_Expect (Tok_Equal);
+ Next_Token;
+ Res := New_Union_Aggr
+ (Atype.Type_Onode, Field.Field_Fnode,
+ Parse_Constant_Value (Field.Field_Type));
+ Expect (Tok_Right_Brace);
+ Next_Token;
+ return Res;
+ end;
+ when Type_Access =>
+ -- The only way to initialize an access is either NULL
+ -- or 'Address.
+ if Tok = Tok_Null then
+ Res := New_Null_Access (Atype.Type_Onode);
+ Next_Token;
+ return Res;
+ end if;
+
+ if Tok /= Tok_Ident then
+ Parse_Error ("identifier expected for access literal");
+ end if;
+
+ declare
+ T : Node_Acc;
+ begin
+ T := Get_Decl (Token_Sym);
+ Next_Expect (Tok_Tick);
+ Next_Token;
+ if Tok = Tok_Left_Brack then
+ if T.Kind /= Decl_Type
+ or else T.Decl_Dtype.Kind /= Type_Access
+ then
+ Parse_Error ("name is not an access type name");
+ end if;
+ Next_Expect (Tok_Null);
+ Next_Expect (Tok_Right_Brack);
+ Next_Token;
+ return New_Null_Access (Atype.Type_Onode);
+ else
+ Expect (Tok_Ident);
+ return Parse_Constant_Address (T);
+ end if;
+ end;
+ when others =>
+ raise Program_Error;
+ end case;
+ end Parse_Constant_Value;
+
+ procedure Parse_Constant_Declaration (Storage : O_Storage)
+ is
+ N : Node_Acc;
+ Sym : Syment_Acc;
+ --Val : O_Cnode;
+ begin
+ Expect (Tok_Constant);
+ Next_Expect (Tok_Ident);
+ Sym := Token_Sym;
+ N := new Node'(Kind => Node_Object,
+ Decl_Dtype => null,
+ Decl_Storage => Storage,
+ Obj_Name => Sym.Ident,
+ Obj_Node => O_Dnode_Null);
+ Next_Expect (Tok_Colon);
+ Next_Token;
+ N.Decl_Dtype := Parse_Type;
+ New_Const_Decl (N.Obj_Node, Sym.Ident, Storage, N.Decl_Dtype.Type_Onode);
+ Add_Decl (Sym, N);
+
+-- if Storage /= O_Storage_External then
+-- Expect (Tok_Assign);
+-- Next_Token;
+-- Start_Const_Value (N.Obj_Node);
+-- Val := Parse_Constant_Value (N.Decl_Dtype);
+-- Finish_Const_Value (N.Obj_Node, Val);
+-- end if;
+ end Parse_Constant_Declaration;
+
+ procedure Parse_Constant_Value_Declaration
+ is
+ N : Node_Acc;
+ Val : O_Cnode;
+ begin
+ Next_Expect (Tok_Ident);
+ N := Get_Decl (Token_Sym);
+ if N.Kind /= Node_Object then
+ Parse_Error ("name of a constant expected");
+ end if;
+ -- FIXME: should check storage,
+ -- should check the object is a constant,
+ -- should check the object has no value.
+ Next_Expect (Tok_Assign);
+ Next_Token;
+ Start_Const_Value (N.Obj_Node);
+ Val := Parse_Constant_Value (N.Decl_Dtype);
+ Finish_Const_Value (N.Obj_Node, Val);
+ end Parse_Constant_Value_Declaration;
+
+ procedure Parse_Var_Declaration (Storage : O_Storage)
+ is
+ N : Node_Acc;
+ Sym : Syment_Acc;
+ begin
+ Expect (Tok_Var);
+ Next_Expect (Tok_Ident);
+ Sym := Token_Sym;
+ N := new Node'(Kind => Node_Object,
+ Decl_Dtype => null,
+ Decl_Storage => Storage,
+ Obj_Name => Sym.Ident,
+ Obj_Node => O_Dnode_Null);
+ Next_Expect (Tok_Colon);
+ Next_Token;
+ N.Decl_Dtype := Parse_Type;
+ New_Var_Decl (N.Obj_Node, Sym.Ident, Storage, N.Decl_Dtype.Type_Onode);
+ Add_Decl (Sym, N);
+ end Parse_Var_Declaration;
+
+ procedure Parse_Stored_Decl (Storage : O_Storage)
+ is
+ begin
+ Next_Token;
+ if Tok = Tok_Function then
+ Parse_Function_Definition (Storage);
+ elsif Tok = Tok_Procedure then
+ Parse_Procedure_Definition (Storage);
+ elsif Tok = Tok_Constant then
+ Parse_Constant_Declaration (Storage);
+ elsif Tok = Tok_Var then
+ Parse_Var_Declaration (Storage);
+ else
+ Parse_Error ("function declaration expected");
+ end if;
+ end Parse_Stored_Decl;
+
+ procedure Parse_Declaration
+ is
+ Inter : Node_Acc;
+ S : Syment_Acc;
+ begin
+ if Flag_Renumber then
+ New_Debug_Line_Decl (Lineno);
+ end if;
+
+ case Tok is
+ when Tok_Type =>
+ Next_Token;
+ if Tok /= Tok_Ident then
+ Parse_Error ("identifier for type expected");
+ end if;
+ S := Token_Sym;
+ Next_Expect (Tok_Is);
+ Next_Token;
+ if Is_Defined (S) then
+ Parse_Type_Completion (Get_Decl (S));
+ else
+ Inter := new Node'(Kind => Decl_Type,
+ Decl_Storage => O_Storage_Public,
+ Decl_Dtype => Parse_Type);
+ Add_Decl (S, Inter);
+ New_Type_Decl (S.Ident, Inter.Decl_Dtype.Type_Onode);
+ end if;
+ when Tok_External =>
+ Parse_Stored_Decl (O_Storage_External);
+ when Tok_Private =>
+ Parse_Stored_Decl (O_Storage_Private);
+ when Tok_Public =>
+ Parse_Stored_Decl (O_Storage_Public);
+ when Tok_Local =>
+ Parse_Stored_Decl (O_Storage_Local);
+ when Tok_Constant =>
+ Parse_Constant_Value_Declaration;
+ when Tok_Comment =>
+ New_Debug_Comment_Decl (Token_Ident (1 .. Token_Idlen));
+ Next_Token;
+ return;
+ when Tok_File_Name =>
+ if Flag_Renumber = False then
+ New_Debug_Filename_Decl (Token_Ident (1 .. Token_Idlen));
+ end if;
+ Next_Token;
+ return;
+ when others =>
+ Parse_Error ("declaration expected");
+ end case;
+ Expect (Tok_Semicolon);
+ Next_Token;
+ end Parse_Declaration;
+
+-- procedure Put (Str : String)
+-- is
+-- L : Integer;
+-- begin
+-- L := Write (Standout, Str'Address, Str'Length);
+-- end Put;
+
+ function Parse (Filename : String_Acc) return Boolean
+ is
+ begin
+ -- Initialize symbol table.
+ Add_Keyword ("type", Tok_Type);
+ Add_Keyword ("return", Tok_Return);
+ Add_Keyword ("if", Tok_If);
+ Add_Keyword ("then", Tok_Then);
+ Add_Keyword ("else", Tok_Else);
+ Add_Keyword ("loop", Tok_Loop);
+ Add_Keyword ("exit", Tok_Exit);
+ Add_Keyword ("next", Tok_Next);
+ Add_Keyword ("signed", Tok_Signed);
+ Add_Keyword ("unsigned", Tok_Unsigned);
+ Add_Keyword ("float", Tok_Float);
+ Add_Keyword ("is", Tok_Is);
+ Add_Keyword ("of", Tok_Of);
+ Add_Keyword ("all", Tok_All);
+ Add_Keyword ("not", Tok_Not);
+ Add_Keyword ("abs", Tok_Abs);
+ Add_Keyword ("or", Tok_Or);
+ Add_Keyword ("and", Tok_And);
+ Add_Keyword ("xor", Tok_Xor);
+ Add_Keyword ("mod", Tok_Mod);
+ Add_Keyword ("rem", Tok_Rem);
+ Add_Keyword ("array", Tok_Array);
+ Add_Keyword ("access", Tok_Access);
+ Add_Keyword ("record", Tok_Record);
+ Add_Keyword ("union", Tok_Union);
+ Add_Keyword ("end", Tok_End);
+ Add_Keyword ("boolean", Tok_Boolean);
+ Add_Keyword ("enum", Tok_Enum);
+ Add_Keyword ("external", Tok_External);
+ Add_Keyword ("private", Tok_Private);
+ Add_Keyword ("public", Tok_Public);
+ Add_Keyword ("local", Tok_Local);
+ Add_Keyword ("procedure", Tok_Procedure);
+ Add_Keyword ("function", Tok_Function);
+ Add_Keyword ("constant", Tok_Constant);
+ Add_Keyword ("var", Tok_Var);
+ Add_Keyword ("subarray", Tok_Subarray);
+ Add_Keyword ("declare", Tok_Declare);
+ Add_Keyword ("begin", Tok_Begin);
+ Add_Keyword ("end", Tok_End);
+ Add_Keyword ("null", Tok_Null);
+ Add_Keyword ("case", Tok_Case);
+ Add_Keyword ("when", Tok_When);
+ Add_Keyword ("default", Tok_Default);
+
+ Id_Address := New_Symbol ("address");
+ Id_Unchecked_Address := New_Symbol ("unchecked_address");
+ Id_Subprg_Addr := New_Symbol ("subprg_addr");
+ Id_Conv := New_Symbol ("conv");
+ Id_Sizeof := New_Symbol ("sizeof");
+ Id_Alloca := New_Symbol ("alloca");
+ Id_Offsetof := New_Symbol ("offsetof");
+
+ -- Initialize the scanner.
+ Buf (1) := NUL;
+ Pos := 1;
+ Lineno := 1;
+ if Filename = null then
+ Fd := Standin;
+ File_Name := new String'("*stdin*");
+ else
+ declare
+ Name : String (1 .. Filename'Length + 1);
+ --("C:\cygwin\home\tgingold\src\ortho\x86\tests\olang\ex2.ol",
+ begin
+ Name (1 .. Filename'Length) := Filename.all;
+ Name (Name'Last) := NUL;
+ File_Name := Filename;
+ Fd := Open_Read (Name'Address, Text);
+ if Fd = Invalid_FD then
+ Puterr ("cannot open '" & Filename.all & ''');
+ Newline_Err;
+ return False;
+ end if;
+ end;
+ end if;
+
+ New_Debug_Filename_Decl (File_Name.all);
+
+ Push_Scope;
+ Next_Token;
+ while Tok /= Tok_Eof loop
+ Parse_Declaration;
+ end loop;
+ Pop_Scope;
+
+ if Fd /= Standin then
+ Close (Fd);
+ end if;
+ return True;
+ exception
+ when E : others =>
+ Puterr (Ada.Exceptions.Exception_Information (E));
+ raise;
+ end Parse;
+end Ortho_Front;
generated by cgit (git 2.34.1) at 2024-12-21 11:36:31 +0000