-- GHDL driver - print commands. -- 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 Ada.Characters.Latin_1; with Ada.Text_IO; use Ada.Text_IO; with GNAT.Directory_Operations; with GNAT.OS_Lib; use GNAT.OS_Lib; with Tables; with Types; use Types; with Flags; with Name_Table; use Name_Table; with Files_Map; with Libraries; with Errorout; use Errorout; with Vhdl.Errors; use Vhdl.Errors; with Vhdl.Utils; use Vhdl.Utils; with Vhdl.Tokens; with Vhdl.Scanner; with Vhdl.Parse; with Vhdl.Canon; with Version; with Vhdl.Xrefs; with Vhdl.Sem_Lib; use Vhdl.Sem_Lib; with Ghdlmain; use Ghdlmain; with Ghdllocal; use Ghdllocal; with Vhdl.Disp_Vhdl; with Vhdl.Elocations; package body Ghdlprint is type Html_Format_Type is (Html_2, Html_Css); Html_Format : Html_Format_Type := Html_2; procedure Put_Html (C : Character) is begin case C is when '>' => Put (">"); when '<' => Put ("<"); when '&' => Put ("&"); when others => Put (C); end case; end Put_Html; procedure Put_Html (S : String) is begin for I in S'Range loop Put_Html (S (I)); end loop; end Put_Html; package Nat_IO is new Ada.Text_IO.Integer_IO (Num => Natural); procedure Put_Nat (N : Natural) is begin Nat_IO.Put (N, Width => 0); end Put_Nat; type Filexref_Info_Type is record Output : String_Acc; Referenced : Boolean; end record; type Filexref_Info_Arr is array (Source_File_Entry range <>) of Filexref_Info_Type; type Filexref_Info_Arr_Acc is access Filexref_Info_Arr; Filexref_Info : Filexref_Info_Arr_Acc := null; -- If True, at least one xref is missing. Missing_Xref : Boolean := False; procedure PP_Html_File (File : Source_File_Entry) is use Flags; use Vhdl.Scanner; use Vhdl.Tokens; use Files_Map; use Ada.Characters.Latin_1; Line : Natural; Buf : File_Buffer_Acc; Prev_Tok : Token_Type; -- Current logical column number. Used to expand TABs. Col : Natural; -- Position just after the last token. Last_Tok : Source_Ptr; -- Position just before the current token. Bef_Tok : Source_Ptr; -- Position just after the current token. Aft_Tok : Source_Ptr; procedure Disp_Ln is N : Natural; Str : String (1 .. 5); begin case Html_Format is when Html_2 => Put (""); when Html_Css => Put (""); end case; N := Line; for I in reverse Str'Range loop if N = 0 then Str (I) := ' '; else Str (I) := Character'Val (48 + N mod 10); N := N / 10; end if; end loop; Put (Str); case Html_Format is when Html_2 => Put (""); when Html_Css => Put (""); end case; Put (" "); Col := 0; end Disp_Ln; procedure Disp_Spaces is C : Character; P : Source_Ptr; N_Col : Natural; begin P := Last_Tok; while P < Bef_Tok loop C := Buf (P); if C = HT then -- Expand TABS. N_Col := Col + Tab_Stop; N_Col := N_Col - N_Col mod Tab_Stop; while Col < N_Col loop Put (' '); Col := Col + 1; end loop; else Put (' '); Col := Col + 1; end if; P := P + 1; end loop; end Disp_Spaces; procedure Disp_Text is P : Source_Ptr; begin P := Bef_Tok; while P < Aft_Tok loop Put_Html (Buf (P)); Col := Col + 1; P := P + 1; end loop; end Disp_Text; procedure Disp_Reserved is begin Disp_Spaces; case Html_Format is when Html_2 => Put (""); Disp_Text; Put (""); when Html_Css => Put (""); Disp_Text; Put (""); end case; end Disp_Reserved; procedure Disp_Href (Loc : Location_Type) is L_File : Source_File_Entry; L_Pos : Source_Ptr; begin Location_To_File_Pos (Loc, L_File, L_Pos); Put (" href="""); if L_File /= File then -- External reference. if Filexref_Info (L_File).Output /= null then Put (Filexref_Info (L_File).Output.all); Put ("#"); Put_Nat (Natural (L_Pos)); else -- Reference to an unused file. Put ("index.html#f"); Put_Nat (Natural (L_File)); Filexref_Info (L_File).Referenced := True; end if; else -- Local reference. Put ("#"); Put_Nat (Natural (L_Pos)); end if; Put (""""); end Disp_Href; procedure Disp_Anchor (Loc : Location_Type) is L_File : Source_File_Entry; L_Pos : Source_Ptr; begin Put (" name="""); Location_To_File_Pos (Loc, L_File, L_Pos); Put_Nat (Natural (L_Pos)); Put (""""); end Disp_Anchor; procedure Disp_Identifier is use Vhdl.Xrefs; Ref : Xref; Decl : Iir; Bod : Iir; Loc : Location_Type; begin if Flags.Flag_Xref then Loc := File_Pos_To_Location (File, Bef_Tok); Ref := Find (Loc); if Ref = Bad_Xref then Disp_Spaces; Disp_Text; Warning_Msg_Sem (Warnid_Missing_Xref, Loc, "cannot find xref"); Missing_Xref := True; return; end if; else Disp_Spaces; Disp_Text; return; end if; case Get_Xref_Kind (Ref) is when Xref_Keyword => Disp_Reserved; when Xref_Decl => Disp_Spaces; Put (" Bod := Get_Subprogram_Body (Decl); when Iir_Kind_Package_Declaration => Bod := Get_Package_Body (Decl); when Iir_Kind_Type_Declaration => Decl := Get_Type (Decl); case Get_Kind (Decl) is when Iir_Kind_Protected_Type_Declaration => Bod := Get_Protected_Type_Body (Decl); when Iir_Kind_Incomplete_Type_Definition => Bod := Get_Type_Declarator (Decl); when others => Bod := Null_Iir; end case; when others => Bod := Null_Iir; end case; if Bod /= Null_Iir then Disp_Href (Get_Location (Bod)); end if; Put (">"); Disp_Text; Put (""); when Xref_Ref | Xref_End => Disp_Spaces; Decl := Get_Xref_Node (Ref); Loc := Get_Location (Decl); if Loc /= Location_Nil then Put (""); Disp_Text; Put (""); else -- This may happen for overload list, in use clauses. Disp_Text; end if; when Xref_Body => Disp_Spaces; Put (""); Disp_Text; Put (""); end case; end Disp_Identifier; procedure Disp_Attribute is use Vhdl.Xrefs; Ref : Xref; Decl : Iir; Loc : Location_Type; begin Disp_Spaces; if Flags.Flag_Xref then Loc := File_Pos_To_Location (File, Bef_Tok); Ref := Find (Loc); else Ref := Bad_Xref; end if; if Ref = Bad_Xref then case Html_Format is when Html_2 => Put (""); Disp_Text; Put (""); when Html_Css => Put (""); Disp_Text; Put (""); end case; else Decl := Get_Xref_Node (Ref); Loc := Get_Location (Decl); Put (""); Disp_Text; Put (""); end if; end Disp_Attribute; begin Vhdl.Scanner.Flag_Comment := True; Vhdl.Scanner.Flag_Newline := True; Set_File (File); Buf := Get_File_Source (File); Put_Line ("
"); Line := 1; Disp_Ln; Last_Tok := Source_Ptr_Org; Prev_Tok := Tok_Invalid; loop 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_Mod .. Tok_Parameter => Disp_Reserved; when Tok_Semi_Colon => Disp_Spaces; Disp_Text; when Tok_Across .. Tok_Tolerance => Disp_Reserved; when Tok_Psl_Default | Tok_Psl_Clock | Tok_Psl_Property | Tok_Psl_Sequence | Tok_Psl_Endpoint | Tok_Psl_Cover | Tok_Psl_Boolean | Tok_Psl_Const | Tok_Inf | Tok_Within | Tok_Abort | Tok_Before | Tok_Always | Tok_Never | Tok_Eventually | Tok_Next_A | Tok_Next_E | Tok_Next_Event | Tok_Next_Event_A | Tok_Next_Event_E => Disp_Spaces; Disp_Text; 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_Equal_Equal | Tok_Integer | Tok_Integer_Letter | 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 ("GHDL "); Put (Version.Ghdl_Ver); Put (' '); Put (Version.Ghdl_Release); 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 : 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 : Command_Chop; Args : Argument_List) is pragma Unreferenced (Cmd); use Ada.Characters.Latin_1; Files : Iir_Array (Args'Range); function Build_File_Name_Length (Lib : Iir) return Natural is Id : constant Name_Id := Get_Identifier (Lib); Len : Natural; Id1 : Name_Id; begin Len := Get_Name_Length (Id); case Get_Kind (Lib) is when Iir_Kind_Configuration_Declaration | Iir_Kind_Entity_Declaration | Iir_Kind_Package_Declaration | Iir_Kind_Package_Instantiation_Declaration => null; when Iir_Kind_Package_Body => Len := Len + 1 + 4; -- add -body when Iir_Kind_Architecture_Body => Id1 := Get_Entity_Identifier_Of_Architecture (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 : constant Name_Id := Get_Identifier (Lib); P : Natural; procedure Append (Str : String) is begin Res (P + 1 .. P + Str'Length) := Str; P := P + Str'Length; end Append; begin P := Res'First - 1; case Get_Kind (Lib) is when Iir_Kind_Configuration_Declaration | Iir_Kind_Entity_Declaration | Iir_Kind_Package_Declaration | Iir_Kind_Package_Instantiation_Declaration => Append (Image (Id)); when Iir_Kind_Package_Body => Append (Image (Id)); Append ("-body"); when Iir_Kind_Architecture_Body => Append (Image (Get_Entity_Identifier_Of_Architecture (Lib))); Append ("-"); Append (Image (Id)); when others => raise Internal_Error; 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; Flags.Flag_Elocations := 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 := Load_File_Name (Id); if Design_File = Null_Iir then raise Compile_Error; end if; Files (I) := Design_File; 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 Design_File := Files (I); 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 (Vhdl.Elocations.Get_End_Location (Lib), File_Entry, Lend); if Lend < First then raise Internal_Error; end if; -- 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 : 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 : Command_Lines; Args : Argument_List) is pragma Unreferenced (Cmd); use Vhdl.Scanner; use Vhdl.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 -- Load the file. Id := Get_Identifier (Args (I).all); Fe := Files_Map.Read_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); -- Scan the content, to compute the number of lines. loop 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 := File_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. if Eptr > Ptr then -- Avoid constraint error on conversion of nul array. declare subtype Conv_Subtype is String (1 .. Natural (Eptr - Ptr)); begin Put (Conv_Subtype (Buf (Ptr .. Eptr - 1))); end; end if; New_Line; end loop; end loop; end Perform_Action; -- Command Reprint. type Command_Reprint is new Command_Lib with null record; function Decode_Command (Cmd : Command_Reprint; Name : String) return Boolean; function Get_Short_Help (Cmd : Command_Reprint) return String; procedure Perform_Action (Cmd : Command_Reprint; Args : Argument_List); function Decode_Command (Cmd : Command_Reprint; Name : String) return Boolean is pragma Unreferenced (Cmd); begin return Name = "--reprint"; end Decode_Command; function Get_Short_Help (Cmd : Command_Reprint) return String is pragma Unreferenced (Cmd); begin return "--reprint [OPTS] FILEs Redisplay FILEs"; end Get_Short_Help; procedure Perform_Action (Cmd : Command_Reprint; Args : Argument_List) is pragma Unreferenced (Cmd); Design_File : Iir_Design_File; Unit : Iir; Id : Name_Id; Next_Unit : Iir; begin Setup_Libraries (True); -- Keep parenthesis during parse. Vhdl.Parse.Flag_Parse_Parenthesis := True; Vhdl.Canon.Canon_Flag_Concurrent_Stmts := False; Vhdl.Canon.Canon_Flag_Configurations := False; Vhdl.Canon.Canon_Flag_Specification_Lists := False; Vhdl.Canon.Canon_Flag_Associations := False; -- Parse all files. for I in Args'Range loop Id := Name_Table.Get_Identifier (Args (I).all); Design_File := Load_File_Name (Id); if Design_File = Null_Iir then raise Errorout.Compilation_Error; end if; Unit := Get_First_Design_Unit (Design_File); while Unit /= Null_Iir loop -- Analyze the design unit. Vhdl.Sem_Lib.Finish_Compilation (Unit, True); Next_Unit := Get_Chain (Unit); if Errorout.Nbr_Errors = 0 then Vhdl.Disp_Vhdl.Disp_Vhdl (Unit); Set_Chain (Unit, Null_Iir); Libraries.Add_Design_Unit_Into_Library (Unit); end if; Unit := Next_Unit; end loop; if Errorout.Nbr_Errors > 0 then raise Errorout.Compilation_Error; end if; end loop; end Perform_Action; -- Command compare tokens. type Command_Compare_Tokens is new Command_Lib with null record; function Decode_Command (Cmd : Command_Compare_Tokens; Name : String) return Boolean; function Get_Short_Help (Cmd : Command_Compare_Tokens) return String; procedure Perform_Action (Cmd : Command_Compare_Tokens; Args : Argument_List); function Decode_Command (Cmd : Command_Compare_Tokens; Name : String) return Boolean is pragma Unreferenced (Cmd); begin return Name = "--compare-tokens"; end Decode_Command; function Get_Short_Help (Cmd : Command_Compare_Tokens) return String is pragma Unreferenced (Cmd); begin return "--compare-tokens [OPTS] REF FILEs Compare FILEs with REF"; end Get_Short_Help; procedure Perform_Action (Cmd : Command_Compare_Tokens; Args : Argument_List) is pragma Unreferenced (Cmd); use Vhdl.Tokens; use Vhdl.Scanner; package Ref_Tokens is new Tables (Table_Component_Type => Token_Type, Table_Index_Type => Integer, Table_Low_Bound => 0, Table_Initial => 1024); Id : Name_Id; Fe : Source_File_Entry; Local_Id : Name_Id; Tok_Idx : Natural; begin if Args'Length < 1 then Error ("missing ref file"); raise Compile_Error; end if; Local_Id := Get_Identifier (""); for I in Args'Range loop -- Load the file. Id := Get_Identifier (Args (I).all); Fe := Files_Map.Read_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); if I = Args'First then -- Scan ref file loop Scan; Ref_Tokens.Append (Current_Token); exit when Current_Token = Tok_Eof; end loop; else -- Scan file Tok_Idx := Ref_Tokens.First; loop Scan; if Ref_Tokens.Table (Tok_Idx) /= Current_Token then Report_Msg (Msgid_Error, Errorout.Parse, No_Source_Coord, "token mismatch"); exit; end if; case Current_Token is when Tok_Eof => exit; when others => null; end case; Tok_Idx := Tok_Idx + 1; end loop; end if; Close_File; end loop; Ref_Tokens.Free; if Nbr_Errors /= 0 then raise Compilation_Error; end if; end Perform_Action; -- Command html. 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 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 : 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 : Command_PP_Html; Files : Argument_List) is pragma Unreferenced (Cmd); 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 ("