ortho/debug and ortho/oread added

16 files changed, 6384 insertions, 4 deletions

diff --git a/README b/README
index 6d5e8f9a5..0a9dfae21 100644
--- a/README
+++ b/README
@@ -4,6 +4,9 @@ GHDL is free software.  See the file COPYING for copying permission.
 The manuals, and some of the runtime libraries, are under different
 terms; see the individual source files for details.
 
+### Creating a source tar. ###
+##############################
+
 GHDL requires GCC to be compiled.  The exact version of GCC is defined in
 ./translate/gcc/dist.sh, in the GCCVERSION= line.  Do not try to change the
 version, this may not compile or create a buggy compiler.
@@ -19,6 +22,9 @@ $ ./dist.sh sources
 # This generates a ghdl-VERSION.tar.bz2 file.
 
 
+### Compiling for development.  ###
+###################################
+
 These steps can make GHDL development hard.  You can avoid to compile GCC
 everytime.  To do this, edit ortho/gcc/Makefile and set two variables:
 AGCC_GCCSRC_DIR is the GCC sources directory, while AGCC_GCCOBJ_DIR is where
@@ -27,17 +33,34 @@ the GHDL back-end (ghdl1) in ./translate:
  $ make BE=gcc
 the GHDL driver in ./translate/ghdldrv:
  $ make ghdl_gcc
-the GHDL run-time (GRT) in ./translate/grt:
+the VHDL libraries:
+ $ cd translate/ghdldrv
+ $ make install.all
+and the GHDL run-time (GRT) in ./translate/grt:
  $ make
 To use this GRT, you must create two links in translate/lib:
  $ ln -s ../grt/grt.lst .
  $ ln -s ../grt/libgrt.a .
-You should also compile the VHDL libraries:
- $ cd translate/ghdldrv
- $ make install.all
 
 Once this is done, you can use the ghdl_gcc from translate/ghdldrv.
 
+### Compiling and using the debug back-end.  ###
+################################################
+
+Debugging GHDL outputs can be very difficuly with the GCC back-end, since you
+don't see the high level code generated by GHDL.  To help debugging the
+translator, I have written a debug back-end.  This back-end is used instead of
+the GCC back-end and displays pseudo-code (as well as declarations).  This
+pseudo-code can be then compiled with a reader.
+To compile it, go to ./translate:
+ $ make BE=debug
+This creates a ghdl1-debug.  Then go to ./ortho/oread and compile the reader:
+ $ make BE=gcc
+You can now use this chain by adding the '--post' option to the ghdl driver:
+ $ ghdl_gcc -a --post my_file.vhdl
+This creates an intermediate file my_file.on, which is then compiled by
+ oread-gcc.
+
 Tristan.
 
 
diff --git a/ortho/debug/Makefile b/ortho/debug/Makefile
new file mode 100644
index 000000000..8bb4ffc6b
--- /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 000000000..27faf9897
--- /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 000000000..1f8a028a4
--- /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 000000000..7da84d58c
--- /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 000000000..0e6a61682
--- /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 000000000..d54d542fd
--- /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 000000000..454c868e2
--- /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 000000000..9b00d0393
--- /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 000000000..c22b13075
--- /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 000000000..9ef2bd4a0
--- /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 000000000..2c641c335
--- /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 000000000..63bd769a4
--- /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 000000000..a6c9c51df
--- /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 000000000..c297af071
--- /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 000000000..8821ce9bc
--- /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;