grt-sdf.adb

vhdl集成电路设计软件.需要用gcc-4.0.2版本编译.

--  GHDL Run Time (GRT) - SDF parser.
--  Copyright (C) 2002, 2003, 2004, 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 System.Storage_Elements; --  Work around GNAT bug.
with Grt.Types; use Grt.Types;
with Grt.Stdio; use Grt.Stdio;
with Grt.C; use Grt.C;
with Grt.Errors; use Grt.Errors;
with Ada.Characters.Latin_1;
with Ada.Unchecked_Deallocation;
with Grt.Vital_Annotate;

package body Grt.Sdf is
   EOT : constant Character := Character'Val (4);

   type Sdf_Token_Type is
     (
      Tok_Oparen, -- (
      Tok_Cparen, -- )
      Tok_Qstring,
      Tok_Identifier,
      Tok_Rnumber,
      Tok_Dnumber,
      Tok_Div, -- /
      Tok_Dot, -- .
      Tok_Cln, -- :

      Tok_Error,
      Tok_Eof
     );

   type Sdf_Context_Acc is access Sdf_Context_Type;
   procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation
     (Name => Sdf_Context_Acc, Object => Sdf_Context_Type);

   Sdf_Context : Sdf_Context_Acc;

   --  Current data read from the file.
   Buf : String_Access (1 .. Buf_Size) := null;

   --  Length of the buffer, including the EOT.
   Buf_Len : Natural;
   Pos : Natural;
   Line_Start : Integer;

   Sdf_Stream : FILEs := NULL_Stream;
   Sdf_Filename : String_Access := null;
   Sdf_Line : Natural;

   function Open_Sdf (Filename : String) return Boolean
   is
      N_Filename : String (1 .. Filename'Length + 1);
      Mode : constant String := "rt" & NUL;
   begin
      N_Filename (1 .. Filename'Length) := Filename;
      N_Filename (N_Filename'Last) := NUL;
      Sdf_Stream := fopen (N_Filename'Address, Mode'Address);
      if Sdf_Stream = NULL_Stream then
         Error_C ("cannot open SDF file '");
         Error_C (Filename);
         Error_E ("'");
         return False;
      end if;
      Sdf_Context := new Sdf_Context_Type;

      Sdf_Context.Version := Sdf_Version_Unknown;

      --  Set the timescale to 1 ns.
      Sdf_Context.Timescale := 1000;

      Buf := new String (1 .. Buf_Size);
      Buf_Len := 1;
      Buf (1) := EOT;
      Sdf_Line := 1;
      Sdf_Filename := new String'(Filename);
      Pos := 1;
      Line_Start := 1;
      return True;
   end Open_Sdf;

   procedure Close_Sdf
   is
   begin
      fclose (Sdf_Stream);
      Sdf_Stream := NULL_Stream;
      Unchecked_Deallocation (Sdf_Context);
      Unchecked_Deallocation (Buf);
   end Close_Sdf;

   procedure Read_Sdf
   is
      Res : size_t;
   begin
      Res := fread (Buf (Pos)'Address, 1, size_t (Read_Size), Sdf_Stream);
      Line_Start := Line_Start - Buf_Len + Pos;
      Buf_Len := Pos + Natural (Res);
      Buf (Buf_Len) := EOT;
   end Read_Sdf;


   Ident_Start : Natural;
   Ident_End : Natural;

   procedure Read_Append
   is
      Len : Natural;
   begin
      Len := Pos - Ident_Start;
      if Ident_Start = 1 or Len >= 1024 then
         Error_C ("SDF line ");
         Error_C (Sdf_Line);
         Error_E (" is too long");
         return;
      end if;
      Buf (1 .. Len) := Buf (Ident_Start .. Ident_Start + Len - 1);
      Pos := Len + 1;
      Ident_Start := 1;
      Read_Sdf;
   end Read_Append;

   procedure Error_Sdf (Msg : String) is
   begin
      Error_C (Sdf_Filename.all);
      Error_C (":");
      Error_C (Sdf_Line);
      Error_C (":");
      Error_C (Pos - Line_Start);
      Error_C (": ");
      Error_E (Msg);
   end Error_Sdf;

   procedure Error_Bad_Character is
   begin
      Error_Sdf ("bad character in SDF file");
   end Error_Bad_Character;

   procedure Scan_Identifier
   is
   begin
      Ident_Start := Pos;
      loop
         Pos := Pos + 1;
         case Buf (Pos) is
            when 'a' .. 'z'
              | 'A' .. 'Z'
              | '0' .. '9'
              | '_' =>
               null;
            when '\' =>
               Error_Sdf ("escape character not handled");
               Ident_End := Pos - 1;
               return;
            when EOT =>
               Read_Append;
               Pos := Pos - 1;
            when others =>
               Ident_End := Pos - 1;
               return;
         end case;
      end loop;
   end Scan_Identifier;

   function Ident_Length return Natural is
   begin
      return Ident_End - Ident_Start + 1;
   end Ident_Length;

   function Is_Ident (Str : String) return Boolean
   is
   begin
      if Ident_Length /= Str'Length then
         return False;
      end if;
      return Buf (Ident_Start .. Ident_End) = Str;
   end Is_Ident;

   procedure Scan_Qstring
   is
   begin
      Ident_Start := Pos + 1;
      loop
         Pos := Pos + 1;
         case Buf (Pos) is
            when EOT =>
               Read_Append;
            when NUL .. Character'Val (3)
              | Character'Val (5) .. Character'Val (31)
              | Character'Val (127) .. Character'Val (255) =>
               Error_Bad_Character;
            when ' '
              | '!'
              | '#' .. '~' =>
               null;
            when '"' => -- "
               Ident_End := Pos - 1;
               Pos := Pos + 1;
               exit;
         end case;
      end loop;
   end Scan_Qstring;

   Scan_Int : Integer;
   Scan_Exp : Integer;

   function Scan_Number return Sdf_Token_Type
   is
      Has_Dot : Boolean;
   begin
      Has_Dot := False;
      Scan_Int := 0;
      Scan_Exp := 0;
      loop
         case Buf (Pos) is
            when '0' .. '9' =>
               Scan_Int := Scan_Int * 10
                 + Character'Pos (Buf (Pos)) - Character'Pos ('0');
               if Has_Dot then
                  Scan_Exp := Scan_Exp - 1;
               end if;
               Pos := Pos + 1;
            when '.' =>
               if Has_Dot then
                  Error_Bad_Character;
                  return Tok_Error;
               else
                  Has_Dot := True;
               end if;
               Pos := Pos + 1;
            when EOT =>
               if Pos /= Buf_Len then
                  Error_Bad_Character;
                  return Tok_Error;
               end if;
               Pos := 1;
               Read_Sdf;
               exit when Buf_Len = 1;
            when others =>
               exit;
         end case;
      end loop;
      if Has_Dot then
         return Tok_Rnumber;
      else
         return Tok_Dnumber;
      end if;
   end Scan_Number;

   procedure Refill_Buf is
   begin
      Buf (1 .. Buf_Len - Pos) := Buf (Pos .. Buf_Len - 1);
      Pos := Buf_Len - Pos + 1;
      Read_Sdf;
      Pos := 1;
   end Refill_Buf;

   function Get_Token return Sdf_Token_Type
   is
      use Ada.Characters.Latin_1;
   begin
      --  Fast blanks skipping.
      while Buf (Pos) = ' ' loop
         Pos := Pos + 1;
      end loop;

      loop
         --  Be sure there is at least 4 characters.
         if Pos + 4 >= Buf_Len then
            Refill_Buf;
         end if;

         case Buf (Pos) is
            when EOT =>
               if Pos /= Buf_Len then
                  Error_Bad_Character;
                  return Tok_Error;
               end if;
               Pos := 1;
               Read_Sdf;
               if Buf_Len = 1 then
                  return Tok_Eof;
               end if;
            when LF =>
               Pos := Pos + 1;
               if Buf (Pos) = CR then
                  Pos := Pos + 1;
               end if;
               Line_Start := Pos;
               Sdf_Line := Sdf_Line + 1;
            when CR =>
               Pos := Pos + 1;
               if Buf (Pos) = LF then
                  Pos := Pos + 1;
               end if;
               Line_Start := Pos;
               Sdf_Line := Sdf_Line + 1;
            when '"' => -- "
               Scan_Qstring;
               return Tok_Qstring;
            when ' '
              | HT =>
               Pos := Pos + 1;
            when '/' =>
               Pos := Pos + 1;
               return Tok_Div;
            when '.' =>
               Pos := Pos + 1;
               return Tok_Dot;
            when ':' =>
               Pos := Pos + 1;
               return Tok_Cln;
            when '(' =>
               Pos := Pos + 1;
               return Tok_Oparen;
            when ')' =>
               Pos := Pos + 1;
               return Tok_Cparen;
            when 'a' .. 'z'
              | 'A' .. 'Z' =>
               Scan_Identifier;
               return Tok_Identifier;
            when '0' .. '9' =>
               return Scan_Number;
            when others =>
               Error_Bad_Character;
               return Tok_Error;
         end case;
      end loop;
   end Get_Token;

   function Is_White_Space (C : Character) return Boolean
   is
      use Ada.Characters.Latin_1;
   begin
      case C is
         when ' '
           | HT
           | CR
           | LF =>
            return True;
         when others =>
            return False;
      end case;
   end Is_White_Space;

   function Get_Edge_Token return Edge_Type
   is
      use Ada.Characters.Latin_1;
   begin
      loop
         --  Be sure there is at least 4 characters.
         if Pos + 4 >= Buf_Len then
            Refill_Buf;
         end if;

         case Buf (Pos) is
            when EOT =>
               if Pos /= Buf_Len then
                  exit;
               end if;
               Pos := 1;
               Read_Sdf;
               if Buf_Len = 1 then
                  exit;
               end if;
            when LF =>
               Pos := Pos + 1;
               if Buf (Pos) = CR then
                  Pos := Pos + 1;
               end if;
               Line_Start := Pos;
               Sdf_Line := Sdf_Line + 1;
            when CR =>
               Pos := Pos + 1;
               if Buf (Pos) = LF then
                  Pos := Pos + 1;
               end if;
               Line_Start := Pos;
               Sdf_Line := Sdf_Line + 1;
            when ' '
              | HT =>
               Pos := Pos + 1;
            when '0' =>
               if Is_White_Space (Buf (Pos + 2)) then
                  if Buf (Pos + 1) = 'z' then
                     Pos := Pos + 2;
                     return Edge_0z;
                  elsif Buf (Pos + 1) = '1' then
                     Pos := Pos + 2;
                     return Edge_01;
                  end if;
               end if;
               exit;
            when '1' =>
               if Is_White_Space (Buf (Pos + 2)) then
                  if Buf (Pos + 1) = 'z' then
                     Pos := Pos + 2;
                     return Edge_1z;
                  elsif Buf (Pos + 1) = '0' then
                     Pos := Pos + 2;
                     return Edge_10;
                  end if;
               end if;
               exit;
            when 'z' =>
               if Is_White_Space (Buf (Pos + 2)) then
                  if Buf (Pos + 1) = '0' then
                     Pos := Pos + 2;
                     return Edge_Z0;
                  elsif Buf (Pos + 1) = '1' then
                     Pos := Pos + 2;
                     return Edge_Z1;
                  end if;
               end if;
               exit;
            when 'p' =>
               Scan_Identifier;
               if Is_Ident ("posedge") then
                  return Edge_Posedge;
               else
                  exit;
               end if;
            when 'n' =>
               Scan_Identifier;
               if Is_Ident ("negedge") then
                  return Edge_Negedge;
               else
                  exit;
               end if;
            when others =>
               exit;
         end case;