");
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_Access .. Tok_Elsif
| Tok_Entity .. Tok_With
| Tok_Mod .. Tok_Rem
| Tok_And .. Tok_Not =>
Disp_Reserved;
when Tok_End =>
Disp_Reserved;
when Tok_Semi_Colon =>
Disp_Spaces;
Disp_Text;
when Tok_Xnor .. Tok_Ror =>
Disp_Reserved;
when Tok_Protected =>
Disp_Reserved;
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 (""); 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 : 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 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 => Image (Id); Append (Nam_Buffer (1 .. Nam_Length)); when Iir_Kind_Package_Body => Image (Id); Append (Nam_Buffer (1 .. Nam_Length)); Append ("-body"); when Iir_Kind_Architecture_Body => Image (Get_Entity_Identifier_Of_Architecture (Lib)); Append (Nam_Buffer (1 .. Nam_Length)); Append ("-"); Image (Id); Append (Nam_Buffer (1 .. Nam_Length)); 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; -- 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 Scanner; 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 -- Load the file. 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); -- 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 := 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. Put (String (Buf (Ptr .. Eptr - 1))); 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 : in out 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 : in out 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); Parse.Flag_Parse_Parenthesis := True; -- Parse all files. for I in Args'Range loop Id := Name_Table.Get_Identifier (Args (I).all); Design_File := Libraries.Load_File (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. Back_End.Finish_Compilation (Unit, True); Next_Unit := Get_Chain (Unit); if Errorout.Nbr_Errors = 0 then 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 : in out 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 : in out Command_Compare_Tokens; Args : Argument_List) is pragma Unreferenced (Cmd); use Tokens; use Scanner; package Ref_Tokens is new GNAT.Table (Table_Component_Type => Token_Type, Table_Index_Type => Integer, Table_Low_Bound => 0, Table_Initial => 1024, Table_Increment => 100); 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.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); 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 Error_Msg_Parse ("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 : 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 Scanner; 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 ("