📄 ghdlprint.adb
字号:
when Tok_String | Tok_Bit_String | Tok_Character => Disp_Spaces; case Html_Format is when Html_2 => Put ("<font color=blue>"); Disp_Text; Put ("</font>"); when Html_Css => Put ("<kbd>"); Disp_Text; Put ("</kbd>"); end case; when Tok_Identifier => if Prev_Tok = Tok_Tick then Disp_Attribute; else Disp_Identifier; end if; when Tok_Left_Paren .. Tok_Colon | Tok_Comma .. Tok_Dot | Tok_Integer | Tok_Real | Tok_Equal .. Tok_Slash | Tok_Invalid => Disp_Spaces; Disp_Text; end case; Last_Tok := Aft_Tok; Prev_Tok := Current_Token; end loop; Close_File; New_Line; Put_Line ("</pre>"); Put_Line ("<hr/>"); end PP_Html_File; procedure Put_Html_Header is begin Put ("<html>"); Put_Line (" <head>"); case Html_Format is when Html_2 => null; when Html_Css => Put_Line (" <link rel=stylesheet type=""text/css"""); Put_Line (" href=""ghdl.css"" title=""default""/>"); end case; --Put_Line ("<?xml version=""1.0"" encoding=""utf-8"" ?>"); --Put_Line("<!DOCTYPE html PUBLIC ""-//W3C//DTD XHTML 1.0 Strict//EN"""); --Put_Line ("""http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"">"); --Put_Line ("<html xmlns=""http://www.w3.org/1999/xhtml""" -- & " xml:lang=""en"">"); --Put_Line ("<head>"); end Put_Html_Header; procedure Put_Css is begin Put_Line ("/* EM is used for reserved words */"); Put_Line ("EM { color : red; font-style: normal }"); New_Line; Put_Line ("/* TT is used for comments */"); Put_Line ("TT { color : green; font-style: normal }"); New_Line; Put_Line ("/* KBD is used for literals and strings */"); Put_Line ("KBD { color : blue; font-style: normal }"); New_Line; Put_Line ("/* I is used for line numbers */"); Put_Line ("I { color : gray; font-size: 50% }"); New_Line; Put_Line ("/* VAR is used for attributes name */"); Put_Line ("VAR { color : orange; font-style: normal }"); New_Line; Put_Line ("/* A is used for identifiers. */"); Put_Line ("A { color: blue; font-style: normal;"); Put_Line (" text-decoration: none }"); end Put_Css; procedure Put_Html_Foot is begin Put_Line ("<p>"); Put ("<small>This page was generated using "); Put ("<a href=""http://ghdl.free.fr"">"); Put (Version.Ghdl_Version); Put ("</a>, a program written by"); Put (" Tristan Gingold"); New_Line; Put_Line ("</p>"); Put_Line ("</body>"); Put_Line ("</html>"); end Put_Html_Foot; function Create_Output_Filename (Name : String; Num : Natural) return String_Acc is -- Position of the extension. 0 if none. Ext_Pos : Natural; Num_Str : String := Natural'Image (Num); begin -- Search for the extension. Ext_Pos := 0; for I in reverse Name'Range loop exit when Name (I) = Directory_Separator; if Name (I) = '.' then Ext_Pos := I - 1; exit; end if; end loop; if Ext_Pos = 0 then Ext_Pos := Name'Last; end if; Num_Str (1) := '.'; return new String'(Name (Name'First .. Ext_Pos) & Num_Str & ".html"); end Create_Output_Filename; -- Command --chop. type Command_Chop is new Command_Lib with null record; function Decode_Command (Cmd : Command_Chop; Name : String) return Boolean; function Get_Short_Help (Cmd : Command_Chop) return String; procedure Perform_Action (Cmd : in out Command_Chop; Args : Argument_List); function Decode_Command (Cmd : Command_Chop; Name : String) return Boolean is pragma Unreferenced (Cmd); begin return Name = "--chop"; end Decode_Command; function Get_Short_Help (Cmd : Command_Chop) return String is pragma Unreferenced (Cmd); begin return "--chop [OPTS] FILEs Chop FILEs"; end Get_Short_Help; procedure Perform_Action (Cmd : in out Command_Chop; Args : Argument_List) is pragma Unreferenced (Cmd); use Ada.Characters.Latin_1; function Build_File_Name_Length (Lib : Iir) return Natural is Len : Natural; Id : Name_Id; Id1 : Name_Id; begin Id := Get_Identifier (Lib); Len := Get_Name_Length (Id); case Get_Kind (Lib) is when Iir_Kind_Configuration_Declaration | Iir_Kind_Entity_Declaration | Iir_Kind_Package_Declaration => null; when Iir_Kind_Package_Body => Len := Len + 1 + 4; -- add -body when Iir_Kind_Architecture_Declaration => Id1 := Get_Identifier (Get_Entity (Lib)); Len := Len + 1 + Get_Name_Length (Id1); when others => Error_Kind ("build_file_name", Lib); end case; Len := Len + 1 + 4; -- add .vhdl return Len; end Build_File_Name_Length; procedure Build_File_Name (Lib : Iir; Res : out String) is Id : Name_Id; P : Natural; procedure Append (Str : String) is begin Res (P + 1 .. P + Str'Length) := Str; P := P + Str'Length; end Append; begin Id := Get_Identifier (Lib); P := Res'First - 1; case Get_Kind (Lib) is when Iir_Kind_Configuration_Declaration | Iir_Kind_Entity_Declaration | Iir_Kind_Package_Declaration => Image (Id); Append (Name_Buffer (1 .. Name_Length)); when Iir_Kind_Package_Body => Image (Id); Append (Name_Buffer (1 .. Name_Length)); Append ("-body"); when Iir_Kind_Architecture_Declaration => Image (Get_Identifier (Get_Entity (Lib))); Append (Name_Buffer (1 .. Name_Length)); Append ("-"); Image (Id); Append (Name_Buffer (1 .. Name_Length)); when others => null; end case; Append (".vhdl"); end Build_File_Name; -- Scan source file BUF+START until end of line. -- Return line kind to KIND and position of next line to NEXT. type Line_Type is (Line_Blank, Line_Comment, Line_Text); procedure Find_Eol (Buf : File_Buffer_Acc; Start : Source_Ptr; Next : out Source_Ptr; Kind : out Line_Type) is P : Source_Ptr; begin P := Start; Kind := Line_Blank; -- Skip blanks. while Buf (P) = ' ' or Buf (P) = HT loop P := P + 1; end loop; -- Skip comment if any. if Buf (P) = '-' and Buf (P + 1) = '-' then Kind := Line_Comment; P := P + 2; elsif Buf (P) /= CR and Buf (P) /= LF and Buf (P) /= EOT then Kind := Line_Text; end if; -- Skip until end of line. while Buf (P) /= CR and Buf (P) /= LF and Buf (P) /= EOT loop P := P + 1; end loop; if Buf (P) = CR then P := P + 1; if Buf (P) = LF then P := P + 1; end if; elsif Buf (P) = LF then P := P + 1; if Buf (P) = CR then P := P + 1; end if; end if; Next := P; end Find_Eol; Id : Name_Id; Design_File : Iir_Design_File; Unit : Iir; Lib : Iir; Len : Natural; begin Flags.Bootstrap := True; -- Load word library. Libraries.Load_Std_Library; Libraries.Load_Work_Library; -- First loop: parse source file, check destination file does not -- exist. for I in Args'Range loop Id := Get_Identifier (Args (I).all); Design_File := Libraries.Load_File (Id); if Design_File = Null_Iir then raise Compile_Error; end if; Unit := Get_First_Design_Unit (Design_File); while Unit /= Null_Iir loop Lib := Get_Library_Unit (Unit); Len := Build_File_Name_Length (Lib); declare Filename : String (1 .. Len + 1); begin Build_File_Name (Lib, Filename); Filename (Len + 1) := Ghdllocal.Nul; if Is_Regular_File (Filename) then Error ("file '" & Filename (1 .. Len) & "' already exists"); raise Compile_Error; end if; Put (Filename (1 .. Len)); Put (" (for "); Disp_Library_Unit (Lib); Put (")"); New_Line; end; Unit := Get_Chain (Unit); end loop; end loop; -- Second loop: do the real work. for I in Args'Range loop Id := Get_Identifier (Args (I).all); Design_File := Libraries.Load_File (Id); Unit := Get_First_Design_Unit (Design_File); declare use Files_Map; File_Entry : Source_File_Entry; Buffer : File_Buffer_Acc; Start : Source_Ptr; Lend : Source_Ptr; First : Source_Ptr; Next : Source_Ptr; Kind : Line_Type; begin -- A design_file must have at least one design unit. if Unit = Null_Iir then raise Compile_Error; end if; Location_To_File_Pos (Get_Location (Unit), File_Entry, Start); Buffer := Get_File_Source (File_Entry); First := Source_Ptr_Org; if Get_Chain (Unit) /= Null_Iir then -- If there is only one unit, then the whole file is written. -- First last blank line. Next := Source_Ptr_Org; loop Start := Next; Find_Eol (Buffer, Start, Next, Kind); exit when Kind = Line_Text; if Kind = Line_Blank then First := Next; end if; end loop; -- FIXME: write header. end if; while Unit /= Null_Iir loop Lib := Get_Library_Unit (Unit); Location_To_File_Pos (Get_End_Location (Unit), File_Entry, Lend); if Lend < First then raise Internal_Error; end if; Location_To_File_Pos (Get_End_Location (Unit), File_Entry, Lend); -- Find the ';'. while Buffer (Lend) /= ';' loop Lend := Lend + 1; end loop; Lend := Lend + 1; -- Find end of line. Find_Eol (Buffer, Lend, Next, Kind); if Kind = Line_Text then -- There is another unit on the same line. Next := Lend; -- Skip blanks. while Buffer (Next) = ' ' or Buffer (Next) = HT loop Next := Next + 1; end loop; else -- Find first blank line. loop Start := Next; Find_Eol (Buffer, Start, Next, Kind); exit when Kind /= Line_Comment; end loop; if Kind = Line_Text then -- There is not blank lines. -- All the comments are supposed to belong to the next -- unit. Find_Eol (Buffer, Lend, Next, Kind); Lend := Next; else Lend := Start; end if; end if; if Get_Chain (Unit) = Null_Iir then -- Last unit. -- Put the end of the file in it. Lend := Get_File_Length (File_Entry); end if; -- FIXME: file with only one unit. -- FIXME: set extension. Len := Build_File_Name_Length (Lib);⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -