");
Line := 1;
Disp_Ln;
Last_Tok := Source_Ptr_Org;
Prev_Tok := Tok_Invalid;
loop
Scan.Scan;
Bef_Tok := Get_Token_Position;
Aft_Tok := Get_Position;
case Current_Token is
when Tok_Eof =>
exit;
when Tok_Newline =>
New_Line;
Line := Line + 1;
Disp_Ln;
when Tok_Comment =>
Disp_Spaces;
case Html_Format is
when Html_2 =>
Put ("");
Disp_Text;
Put ("");
when Html_Css =>
Put ("");
Disp_Text;
Put ("");
end case;
when Tok_Access .. Tok_Elsif
| Tok_Entity .. Tok_With
| Tok_Mod .. Tok_Rem
| Tok_And .. Tok_Not =>
Disp_Reserved;
when Tok_End =>
Disp_Reserved;
In_End := True;
when Tok_Semi_Colon =>
In_End := False;
Disp_Spaces;
Disp_Text;
when Tok_Xnor .. Tok_Ror =>
if Flags.Vhdl_Std > Vhdl_87 then
Disp_Reserved;
else
Disp_Identifier;
end if;
when Tok_Protected =>
if Flags.Vhdl_Std >= Vhdl_00 then
Disp_Reserved;
else
Disp_Identifier;
end if;
when Tok_String
| Tok_Bit_String
| Tok_Character =>
Disp_Spaces;
case Html_Format is
when Html_2 =>
Put ("");
Disp_Text;
Put ("");
when Html_Css =>
Put ("");
Disp_Text;
Put ("");
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 ("");
Put_Line (""); Put ("This page was generated using "); Put (""); Put (Version.Ghdl_Version); Put (", a program written by"); Put (" Tristan Gingold"); New_Line; Put_Line ("
"); Put_Line (""); Put_Line (""); 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); 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 ("list of files:"); Put_Line ("
list of files referenced but not available:"); Put_Line ("