--  Ortho code compiler.
--  Copyright (C) 2005 Tristan Gingold
--
--  GHDL is free software; you can redistribute it and/or modify it under
--  the terms of the GNU General Public License as published by the Free
--  Software Foundation; either version 2, or (at your option) any later
--  version.
--
--  GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
--  WARRANTY; without even the implied warranty of MERCHANTABILITY or
--  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
--  for more details.
--
--  You should have received a copy of the GNU General Public License
--  along with GCC; see the file COPYING.  If not, write to the Free
--  Software Foundation, 59 Temple Place - Suite 330, Boston, MA
--  02111-1307, USA.
with 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" or Opt.all = "--ghdl-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;
      pragma Unreferenced (L);
   begin
      L := Write (Standerr, Msg'Address, Msg'Length);
   end Puterr;

   procedure Puterr (N : Natural)
   is
      Str : constant 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_Elsif,
       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_Alignof : 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
      Kw : String (Str'Range);
      Ent : Syment_Acc;
   begin
      --  Convert to uppercase.
      for I in Str'Range loop
         pragma Assert (Str (I) in 'a' .. 'z');
         Kw (I) := Character'Val
           (Character'Pos ('A')
                 + Character'Pos (Str (I)) - Character'Pos ('a'));
      end loop;

      Ent := New_Symbol (Kw);
      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;
   function Parse_Constant_Address (Prefix : Node_Acc) return O_Cnode;
   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;

   procedure Parse_Expression (Expr_Type : Node_Acc;
                               Expr : out O_Enode;
                               Res_Type : out Node_Acc);
   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_Type.Decl_Dtype.Type_Onode,
                           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_Alignof (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_Alignof
        (Get_Decl (Token_Sym).Decl_Dtype.Type_Onode,
         Atype.Type_Onode);
      Next_Expect (Tok_Right_Paren);
      return Res;
   end Parse_Alignof;

   --  Parse a literal whose type is ATYPE.
   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
               Pfx : Node_Acc;
               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.
                  Pfx := Token_Sym.Name.Inter;
                  N := Pfx.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_Alignof then
                        Res := Parse_Alignof (N);
                     elsif Token_Sym = Id_Address
                       or Token_Sym = Id_Unchecked_Address
                       or Token_Sym = Id_Subprg_Addr
                     then
                        Res := Parse_Constant_Address (Pfx);
                     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
   --  Parse an expression starting with NAME.
   procedure Parse_Named_Expression
     (Atype : Node_Acc; Name : Node_Acc; Stop_At_All : Boolean;
                                         Res : out O_Enode;
                                         Res_Type : out Node_Acc)
   is
   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));
            Res_Type := Name.Decl_Dtype;
            Expect (Tok_Right_Brack);
            Next_Token;
         elsif Tok = Tok_Left_Paren then
            --  Typed expression (used for comparaison operators)
            Next_Token;
            Parse_Expression (Name.Decl_Dtype, Res, Res_Type);
            Expect (Tok_Right_Paren);
            Next_Token;
         elsif Tok = Tok_Ident then
            --  Attribute.
            if Token_Sym = Id_Conv then
               Next_Expect (Tok_Left_Paren);
               Next_Token;
               Parse_Expression (null, Res, Res_Type);
               --  Discard Res_Type.
               Expect (Tok_Right_Paren);
               Next_Token;
               Res_Type := Name.Decl_Dtype;
               Res := New_Convert_Ov (Res, Res_Type.Type_Onode);
               --  Fall-through.
            elsif Token_Sym = Id_Address
              or Token_Sym = Id_Unchecked_Address
              or Token_Sym = Id_Subprg_Addr
            then
               Res_Type := Name.Decl_Dtype;
               Res := Parse_Address (Name);
               --  Fall-through.
            elsif Token_Sym = Id_Sizeof then
               Res_Type := Name.Decl_Dtype;
               Res := New_Lit (Parse_Sizeof (Res_Type));
               Next_Token;
               return;
            elsif Token_Sym = Id_Alignof then
               Res_Type := Name.Decl_Dtype;
               Res := New_Lit (Parse_Alignof (Res_Type));
               Next_Token;
               return;
            elsif Token_Sym = Id_Alloca then
               Next_Expect (Tok_Left_Paren);
               Next_Token;
               Parse_Expression (null, Res, Res_Type);
               --  Discard Res_Type.
               Res_Type := Name.Decl_Dtype;
               Res := New_Alloca (Res_Type.Type_Onode, Res);
               Expect (Tok_Right_Paren);
               Next_Token;
               return;
            elsif Token_Sym = Id_Offsetof then
               Res_Type := Atype;
               Res := New_Lit (Parse_Offsetof (Res_Type));
               Next_Token;
               return;
            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);
            Res_Type := Name.Decl_Dtype;
            --  Fall-through.
         end;
      elsif Name.Kind = Node_Object
        or else Name.Kind = Decl_Param
      then
         --  Name.
         declare
            Lval : O_Lnode;
         begin
            Parse_Name (Name, Lval, Res_Type);
            Res := 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;
         end if;
         Next_Token;
         if Tok = Tok_All then
            if Res_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);
               Res_Type := Res_Type.Access_Dtype;
               Parse_Lvalue (N, Res_Type);
               Res := New_Value (N);
            end;
            return;
         else
            Parse_Error ("'.all' expected");
         end if;
      end if;
   end Parse_Named_Expression;

   procedure Parse_Primary_Expression (Atype : Node_Acc;
                                       Res : out O_Enode;
                                       Res_Type : out Node_Acc)
   is
   begin
      case Tok is
         when Tok_Num
           | Tok_Float_Num =>
            if Atype = null then
               Parse_Error ("numeric literal without type context");
            end if;
            Res_Type := Atype;
            Res := New_Lit (Parse_Typed_Literal (Atype));
         when Tok_Ident =>
            declare
               N : Node_Acc;
            begin
               N := Get_Decl (Token_Sym);
               Next_Token;
               Parse_Named_Expression (Atype, N, False, Res, Res_Type);
            end;
         when Tok_Left_Paren =>
            Next_Token;
            Parse_Expression (Atype, Res, Res_Type);
            Expect (Tok_Right_Paren);
            Next_Token;
         when others =>
            Parse_Error ("bad primary expression: " & Token_Type'Image (Tok));
      end case;
   end Parse_Primary_Expression;

   --  Parse '-' EXPR, 'not' EXPR, 'abs' EXPR or EXPR.
   procedure Parse_Unary_Expression (Atype : Node_Acc;
                                     Res : out O_Enode;
                                     Res_Type : out Node_Acc)
   is
   begin
      case Tok is
         when Tok_Minus =>
            Next_Token;
            Parse_Primary_Expression (Atype, Res, Res_Type);
            Res := New_Monadic_Op (ON_Neg_Ov, Res);
         when Tok_Not =>
            Next_Token;
            Parse_Unary_Expression (Atype, Res, Res_Type);
            Res := New_Monadic_Op (ON_Not, Res);
         when Tok_Abs =>
            Next_Token;
            Parse_Unary_Expression (Atype, Res, Res_Type);
            Res := New_Monadic_Op (ON_Abs_Ov, Res);
         when others =>
            Parse_Primary_Expression (Atype, Res, Res_Type);
      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;

   procedure Parse_Expression (Expr_Type : Node_Acc;
                               Expr : out O_Enode;
                               Res_Type : out Node_Acc)
   is
      Op_Type : Node_Acc;
      L : O_Enode;
      R : O_Enode;
      Op : ON_Op_Kind;
   begin
      if Expr_Type = null or else Expr_Type.Kind = Type_Boolean then
         --  The type of the expression isn't known, as this can be a
         --  comparaison operator.
         Op_Type := null;
      else
         Op_Type := Expr_Type;
      end if;
      Parse_Unary_Expression (Op_Type, L, Res_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 =>
            Expr := L;
            return;
      end case;
      if Op in ON_Compare_Op_Kind then
         Next_Token;
      end if;

      Parse_Unary_Expression (Res_Type, R, Res_Type);
      case Op is
         when ON_Dyadic_Op_Kind =>
            Expr := New_Dyadic_Op (Op, L, R);
         when ON_Compare_Op_Kind =>
            if Expr_Type = null then
               Parse_Error ("comparaison operator requires a type");
            end if;
            Expr := New_Compare_Op (Op, L, R, Expr_Type.Type_Onode);
            Res_Type := Expr_Type;
         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;
                  Res_Type : 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;
                  Parse_Expression (Bt.Array_Index, V, Res_Type);
                  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
               Parse_Named_Expression (null, Prefix, True, Val, N_Type);
               if N_Type /= Prefix.Decl_Dtype then
                  Parse_Error ("type doesn't match");
               end if;
               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;
      Expr : O_Enode;
      Expr_Type : 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;
         Parse_Expression (Param.Decl_Dtype, Expr, Expr_Type);
         New_Association (Constr, Expr);
         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;

   procedure Parse_Statement;

   --  Expect : next token
   --  Let: next token
   procedure Parse_Statements is
   begin
      loop
         exit when Tok = Tok_End;
         exit when Tok = Tok_Else;
         exit when Tok = Tok_When;
         Parse_Statement;
      end loop;
   end Parse_Statements;

   --  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;
               Cond : O_Enode;
               Cond_Type : Node_Acc;
            begin
               Next_Token;
               Parse_Expression (null, Cond, Cond_Type);
               Start_If_Stmt (If_Blk, Cond);
               Expect (Tok_Then);
               Next_Token;
               Parse_Statements;
               if Tok = Tok_Else then
                  Next_Token;
                  New_Else_Stmt (If_Blk);
                  Parse_Statements;
               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;
               Parse_Statements;
               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 =>
            declare
               Res : O_Enode;
               Res_Type : Node_Acc;
            begin
               Next_Token;
               if Tok /= Tok_Semicolon then
                  Parse_Expression (Current_Subprg.Decl_Dtype, Res, Res_Type);
                  New_Return_Stmt (Res);
                  if Tok /= Tok_Semicolon then
                     Parse_Error ("';' expected at end of return statement");
                  end if;
               else
                  New_Return_Stmt;
               end if;
               Next_Token;
            end;

         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;
                     Expr : O_Enode;
                     Expr_Type : Node_Acc;
                     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;
                     Parse_Expression (N_Type, Expr, Expr_Type);
                     New_Assign_Stmt (Name, Expr);
                     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;
               Choice : O_Enode;
               Choice_Type : Node_Acc;
            begin
               Next_Token;
               Parse_Expression (null, Choice, Choice_Type);
               Start_Case_Stmt (Case_Blk, Choice);
               Expect (Tok_Is);
               Next_Token;
               loop
                  exit when Tok = Tok_End;
                  Expect (Tok_When);
                  Next_Token;
                  Start_Choice (Case_Blk);
                  loop
                     if Tok = Tok_Default then
                        New_Default_Choice (Case_Blk);
                        Next_Token;
                     else
                        L := Parse_Typed_Literal (Choice_Type);
                        if Tok = Tok_Elipsis then
                           Next_Token;
                           New_Range_Choice
                             (Case_Blk, L, Parse_Typed_Literal (Choice_Type));
                        else
                           New_Expr_Choice (Case_Blk, L);
                        end if;
                     end if;
                     exit when Tok = Tok_Arrow;
                     Expect (Tok_Comma);
                     Next_Token;
                  end loop;
                  --  Skip '=>'.
                  Next_Token;
                  Finish_Choice (Case_Blk);
                  Parse_Statements;
               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.
      Parse_Statements;
      Expect (Tok_End);
      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);
      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
           | Type_Access =>
            --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
                  if Tok = Tok_Dot then
                     Next_Expect (Tok_Ident);
                     if Token_Sym /= Field.Field_Ident then
                        Parse_Error ("bad field name");
                     end if;
                     Next_Expect (Tok_Equal);
                     Next_Token;
                  end if;
                  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 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 ("elsif", Tok_Elsif);
      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_Alignof := New_Symbol ("alignof");
      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;