ghdlprint.adb

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

               declare
                  Filename : String (1 .. Len + 1);
                  Fd : File_Descriptor;

                  Wlen : Integer;
               begin
                  Build_File_Name (Lib, Filename);
                  Filename (Len + 1) := Character'Val (0);
                  Fd := Create_File (Filename, Binary);
                  if Fd = Invalid_FD then
                     Error
                       ("cannot create file '" & Filename (1 .. Len) & "'");
                     raise Compile_Error;
                  end if;
                  Wlen := Integer (Lend - First);
                  if Write (Fd, Buffer (First)'Address, Wlen) /= Wlen then
                     Error ("cannot write to '" & Filename (1 .. Len) & "'");
                     raise Compile_Error;
                  end if;
                  Close (Fd);
               end;
               First := Next;

               Unit := Get_Chain (Unit);
            end loop;
         end;
      end loop;
   end Perform_Action;

   --  Command --lines.
   type Command_Lines is new Command_Lib with null record;
   function Decode_Command (Cmd : Command_Lines; Name : String)
                           return Boolean;
   function Get_Short_Help (Cmd : Command_Lines) return String;
   procedure Perform_Action (Cmd : in out Command_Lines;
                             Args : Argument_List);

   function Decode_Command (Cmd : Command_Lines; Name : String)
                           return Boolean
   is
      pragma Unreferenced (Cmd);
   begin
      return Name = "--lines";
   end Decode_Command;

   function Get_Short_Help (Cmd : Command_Lines) return String
   is
      pragma Unreferenced (Cmd);
   begin
      return "--lines FILEs      Precede line with its number";
   end Get_Short_Help;

   procedure Perform_Action (Cmd : in out Command_Lines; Args : Argument_List)
   is
      pragma Unreferenced (Cmd);
      use Scan;
      use Tokens;
      use Files_Map;
      use Ada.Characters.Latin_1;

      Id : Name_Id;
      Fe : Source_File_Entry;
      Local_Id : Name_Id;
      Line : Natural;
      File : Source_File_Entry;
      Buf : File_Buffer_Acc;
      Ptr : Source_Ptr;
      Eptr : Source_Ptr;
      C : Character;
      N : Natural;
      Log : Natural;
      Str : String (1 .. 10);
   begin
      Local_Id := Get_Identifier ("");
      for I in Args'Range loop
         Id := Get_Identifier (Args (I).all);
         Fe := Files_Map.Load_Source_File (Local_Id, Id);
         if Fe = No_Source_File_Entry then
            Error ("cannot open file " & Args (I).all);
            raise Compile_Error;
         end if;
         Set_File (Fe);
         loop
            Scan.Scan;
            exit when Current_Token = Tok_Eof;
         end loop;
         File := Get_Current_Source_File;
         Line := Get_Current_Line;
         Close_File;

         --  Compute log10 of line.
         N := Line;
         Log := 0;
         loop
            N := N / 10;
            Log := Log + 1;
            exit when N = 0;
         end loop;

         --  Disp file name.
         Put (Args (I).all);
         Put (':');
         New_Line;

         Buf := Get_File_Source (File);
         for J in 1 .. Line loop
            Ptr := Line_To_Position (File, J);
            exit when Ptr = Source_Ptr_Bad;
            exit when Buf (Ptr) = Files_Map.EOT;

            --  Disp line number.
            N := J;
            for K in reverse 1 .. Log loop
               if N = 0 then
                  Str (K) := ' ';
               else
                  Str (K) := Character'Val (48 + N mod 10);
                  N := N / 10;
               end if;
            end loop;
            Put (Str (1 .. Log));
            Put (": ");

            --  Search for end of line (or end of file).
            Eptr := Ptr;
            loop
               C := Buf (Eptr);
               exit when C = Files_Map.EOT or C = LF or C = CR;
               Eptr := Eptr + 1;
            end loop;

            --  Disp line.
            Put (String (Buf (Ptr .. Eptr - 1)));
            New_Line;
         end loop;
      end loop;
   end Perform_Action;

   type Command_Html is abstract new Command_Lib with null record;

   procedure Decode_Option (Cmd : in out Command_Html;
                            Option : String;
                            Arg : String;
                            Res : out Option_Res);

   procedure Disp_Long_Help (Cmd : Command_Html);

   procedure Decode_Option (Cmd : in out Command_Html;
                            Option : String;
                            Arg : String;
                            Res : out Option_Res)
   is
   begin
      if Option = "--format=css" then
         Html_Format := Html_Css;
         Res := Option_Ok;
      elsif Option = "--format=html2" then
         Html_Format := Html_2;
         Res := Option_Ok;
      else
         Decode_Option (Command_Lib (Cmd), Option, Arg, Res);
      end if;
   end Decode_Option;

   procedure Disp_Long_Help (Cmd : Command_Html)
   is
      use Ada.Text_IO;
   begin
      Disp_Long_Help (Command_Lib (Cmd));
      Put_Line ("--format=html2  Use FONT attributes");
      Put_Line ("--format=css    Use ghdl.css file");
   end Disp_Long_Help;

   --  Command --pp_html.
   type Command_PP_Html is new Command_Html with null record;
   function Decode_Command (Cmd : Command_PP_Html; Name : String)
                           return Boolean;
   function Get_Short_Help (Cmd : Command_PP_Html) return String;
   procedure Perform_Action (Cmd : in out Command_PP_Html;
                             Files : Argument_List);

   function Decode_Command (Cmd : Command_PP_Html; Name : String)
                           return Boolean
   is
      pragma Unreferenced (Cmd);
   begin
      return Name = "--pp-html";
   end Decode_Command;

   function Get_Short_Help (Cmd : Command_PP_Html) return String
   is
      pragma Unreferenced (Cmd);
   begin
      return "--pp-html FILEs    Pretty-print FILEs in HTML";
   end Get_Short_Help;

   procedure Perform_Action (Cmd : in out Command_PP_Html;
                             Files : Argument_List)
   is
      pragma Unreferenced (Cmd);
      use Scan;
      use Tokens;
      use Files_Map;
      use Ada.Characters.Latin_1;

      Id : Name_Id;
      Fe : Source_File_Entry;
      Local_Id : Name_Id;
   begin
      Local_Id := Get_Identifier ("");
      Put_Html_Header;
      Put_Line ("  <title>");
      for I in Files'Range loop
         Put ("    ");
         Put_Line (Files (I).all);
      end loop;
      Put_Line ("  </title>");
      Put_Line ("</head>");
      New_Line;
      Put_Line ("<body>");

      for I in Files'Range loop
         Id := Get_Identifier (Files (I).all);
         Fe := Files_Map.Load_Source_File (Local_Id, Id);
         if Fe = No_Source_File_Entry then
            Error ("cannot open file " & Files (I).all);
            raise Compile_Error;
         end if;
         Put ("  <h1>");
         Put (Files (I).all);
         Put ("</h1>");
         New_Line;

         PP_Html_File (Fe);
      end loop;
      Put_Html_Foot;
   end Perform_Action;

   --  Command --xref-html.
   type Command_Xref_Html is new Command_Html with record
      Output_Dir : String_Access := null;
   end record;

   function Decode_Command (Cmd : Command_Xref_Html; Name : String)
                           return Boolean;
   function Get_Short_Help (Cmd : Command_Xref_Html) return String;
   procedure Decode_Option (Cmd : in out Command_Xref_Html;
                            Option : String;
                            Arg : String;
                            Res : out Option_Res);
   procedure Disp_Long_Help (Cmd : Command_Xref_Html);

   procedure Perform_Action (Cmd : in out Command_Xref_Html;
                             Files_Name : Argument_List);

   function Decode_Command (Cmd : Command_Xref_Html; Name : String)
                           return Boolean
   is
      pragma Unreferenced (Cmd);
   begin
      return Name = "--xref-html";
   end Decode_Command;

   function Get_Short_Help (Cmd : Command_Xref_Html) return String
   is
      pragma Unreferenced (Cmd);
   begin
      return "--xref-html FILEs  Display FILEs in HTML with xrefs";
   end Get_Short_Help;

   procedure Decode_Option (Cmd : in out Command_Xref_Html;
                            Option : String;
                            Arg : String;
                            Res : out Option_Res)
   is
   begin
      if Option = "-o" then
         if Arg = "" then
            Res := Option_Arg_Req;
         else
            Cmd.Output_Dir := new String'(Arg);
            Res := Option_Arg;
         end if;
      else
         Decode_Option (Command_Html (Cmd), Option, Arg, Res);
      end if;
   end Decode_Option;

   procedure Disp_Long_Help (Cmd : Command_Xref_Html)
   is
      use Ada.Text_IO;
   begin
      Disp_Long_Help (Command_Html (Cmd));
      Put_Line ("-o DIR          Put generated files into DIR (def: html/)");
      New_Line;
      Put_Line ("When format is css, the CSS file 'ghdl.css' "
                & "is never overwritten.");
   end Disp_Long_Help;

   procedure Analyze_Design_File_Units (File : Iir_Design_File)
   is
      Unit : Iir_Design_Unit;
   begin
      Unit := Get_First_Design_Unit (File);
      while Unit /= Null_Iir loop
         case Get_Date_State (Unit) is
            when Date_Extern
              | Date_Disk =>
               raise Internal_Error;
            when Date_Parse =>
               Libraries.Load_Design_Unit (Unit, Null_Iir);
            when Date_Analyze =>
               null;
         end case;
         Unit := Get_Chain (Unit);
      end loop;
   end Analyze_Design_File_Units;

   procedure Perform_Action
     (Cmd : in out Command_Xref_Html; Files_Name : Argument_List)
   is
      use GNAT.Directory_Operations;

      Id : Name_Id;
      File : Source_File_Entry;

      type File_Data is record
         Fe : Source_File_Entry;
         Design_File : Iir;
         Output : String_Acc;
      end record;
      type File_Data_Array is array (Files_Name'Range) of File_Data;

      Files : File_Data_Array;
      Output : File_Type;
      Prev_Output : File_Access;
   begin
      Xrefs.Init;
      Flags.Flag_Xref := True;

      --  Load work library.
      Setup_Libraries (True);

      if Cmd.Output_Dir = null then
         Cmd.Output_Dir := new String'("html");
      elsif Cmd.Output_Dir.all = "-" then
         Cmd.Output_Dir := null;
      end if;

      --  Try to create the directory.
      if Cmd.Output_Dir /= null
        and then not Is_Directory (Cmd.Output_Dir.all)
      then
         declare
         begin
            Make_Dir (Cmd.Output_Dir.all);
         exception
            when Directory_Error =>
               Error ("cannot create directory " & Cmd.Output_Dir.all);
               return;
         end;
      end if;

      --  Parse all files.
      for I in Files'Range loop
         Id := Get_Identifier (Files_Name (I).all);
         File := Files_Map.Load_Source_File (Libraries.Local_Directory, Id);
         if File = No_Source_File_Entry then
            Error ("cannot open " & Image (Id));
            return;
         end if;
         Files (I).Fe := File;
         Files (I).Design_File := Libraries.Load_File (File);
         if Files (I).Design_File = Null_Iir then
            return;
         end if;
         Files (I).Output := Create_Output_Filename
           (Base_Name (Files_Name (I).all), I);
         if Is_Regular_File (Files (I).Output.all) then
            --  Prevent overwrite.
            null;
         end if;
         --  Put units in library.
         Libraries.Add_Design_File_Into_Library (Files (I).Design_File);
      end loop;

      --  Analyze all files.
      for I in Files'Range loop
         Analyze_Design_File_Units (Files (I).Design_File);
      end loop;