-- GHDL driver - local 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.Text_IO; use Ada.Text_IO;
with Ada.Command_Line; use Ada.Command_Line;
with GNAT.Directory_Operations;
with Types; use Types;
with Libraries;
with Std_Package;
with Flags;
with Name_Table;
with Std_Names;
with Back_End;
with Disp_Vhdl;
with Default_Pathes;
with Scanner;
with Sem;
with Canon;
with Errorout;
with Configuration;
with Files_Map;
with Post_Sems;
with Disp_Tree;
with Options;
with Iirs_Utils; use Iirs_Utils;
package body Ghdllocal is
-- Version of the IEEE library to use. This just change pathes.
type Ieee_Lib_Kind is (Lib_Standard, Lib_None, Lib_Synopsys, Lib_Mentor);
Flag_Ieee : Ieee_Lib_Kind;
Flag_Create_Default_Config : constant Boolean := True;
-- If TRUE, generate 32bits code on 64bits machines.
Flag_32bit : Boolean := False;
procedure Finish_Compilation
(Unit : Iir_Design_Unit; Main : Boolean := False)
is
use Errorout;
Config : Iir_Design_Unit;
Lib : Iir;
begin
if (Main or Flags.Dump_All) and then Flags.Dump_Parse then
Disp_Tree.Disp_Tree (Unit);
end if;
if Flags.Verbose then
Put_Line ("semantize " & Disp_Node (Get_Library_Unit (Unit)));
end if;
Sem.Semantic (Unit);
if (Main or Flags.Dump_All) and then Flags.Dump_Sem then
Disp_Tree.Disp_Tree (Unit);
end if;
if Errorout.Nbr_Errors > 0 then
raise Compilation_Error;
end if;
if (Main or Flags.List_All) and then Flags.List_Sem then
Disp_Vhdl.Disp_Vhdl (Unit);
end if;
Post_Sems.Post_Sem_Checks (Unit);
if Errorout.Nbr_Errors > 0 then
raise Compilation_Error;
end if;
if Flags.Flag_Elaborate
or else ((Main or Flags.List_All) and then Flags.List_Canon)
then
if Flags.Verbose then
Put_Line ("canonicalize " & Disp_Node (Get_Library_Unit (Unit)));
end if;
Canon.Canonicalize (Unit);
if (Main or Flags.List_All) and then Flags.List_Canon then
Disp_Vhdl.Disp_Vhdl (Unit);
end if;
end if;
if Flags.Flag_Elaborate then
if Flag_Create_Default_Config then
Lib := Get_Library_Unit (Unit);
if Get_Kind (Lib) = Iir_Kind_Architecture_Body then
Config := Canon.Create_Default_Configuration_Declaration (Lib);
Set_Default_Configuration_Declaration (Lib, Config);
end if;
end if;
end if;
end Finish_Compilation;
procedure Init (Cmd : in out Command_Lib)
is
pragma Unreferenced (Cmd);
begin
Options.Initialize;
Flag_Ieee := Lib_Standard;
Back_End.Finish_Compilation := Finish_Compilation'Access;
Flag_Verbose := False;
end Init;
procedure Decode_Option (Cmd : in out Command_Lib;
Option : String;
Arg : String;
Res : out Option_Res)
is
pragma Unreferenced (Cmd);
pragma Unreferenced (Arg);
Opt : constant String (1 .. Option'Length) := Option;
begin
Res := Option_Bad;
if Opt = "-v" and then Flag_Verbose = False then
Flag_Verbose := True;
Res := Option_Ok;
elsif Opt'Length > 9 and then Opt (1 .. 9) = "--PREFIX=" then
Switch_Prefix_Path := new String'(Opt (10 .. Opt'Last));
Res := Option_Ok;
elsif Opt = "--ieee=synopsys" then
Flag_Ieee := Lib_Synopsys;
Res := Option_Ok;
elsif Opt = "--ieee=mentor" then
Flag_Ieee := Lib_Mentor;
Res := Option_Ok;
elsif Opt = "--ieee=none" then
Flag_Ieee := Lib_None;
Res := Option_Ok;
elsif Opt = "--ieee=standard" then
Flag_Ieee := Lib_Standard;
Res := Option_Ok;
elsif Opt = "-m32" then
Flag_32bit := True;
Res := Option_Ok;
elsif Opt'Length >= 2
and then (Opt (2) = 'g' or Opt (2) = 'O')
then
-- Silently accept -g and -O.
Res := Option_Ok;
else
if Options.Parse_Option (Opt) then
Res := Option_Ok;
end if;
end if;
end Decode_Option;
procedure Disp_Long_Help (Cmd : Command_Lib)
is
pragma Unreferenced (Cmd);
procedure P (Str : String) renames Put_Line;
begin
P ("Main options (try --options-help for details):");
P (" --std=XX Use XX as VHDL standard (87,93c,93,00,02 or 08)");
P (" --work=NAME Set the name of the WORK library");
P (" -PDIR Add DIR in the library search path");
P (" --workdir=DIR Specify the directory of the WORK library");
P (" --PREFIX=DIR Specify installation prefix");
P (" --ieee=NAME Use NAME as ieee library, where name is:");
P (" standard: standard version (default)");
P (" synopsys, mentor: vendor version (not advised)");
P (" none: do not use a predefined ieee library");
end Disp_Long_Help;
function Is_Directory_Separator (C : Character) return Boolean is
begin
return C = '/' or else C = Directory_Separator;
end Is_Directory_Separator;
function Get_Basename_Pos (Pathname : String) return Natural is
begin
for I in reverse Pathname'Range loop
if Is_Directory_Separator (Pathname (I)) then
return I;
end if;
end loop;
return Pathname'First - 1;
end Get_Basename_Pos;
-- Simple lower case conversion, used to compare with "bin".
function To_Lower (S : String) return String
is
Res : String (S'Range);
C : Character;
begin
for I in S'Range loop
C := S (I);
if C >= 'A' and then C <= 'Z' then
C := Character'Val
(Character'Pos (C) - Character'Pos ('A') + Character'Pos ('a'));
end if;
Res (I) := C;
end loop;
return Res;
end To_Lower;
procedure Set_Prefix_From_Program_Path (Prog_Path : String)
is
Last : Natural;
begin
Last := Get_Basename_Pos (Prog_Path);
if Last < Prog_Path'First then
-- No directory in Prog_Path. This is not expected.
return;
end if;
declare
Pathname : String :=
Normalize_Pathname (Prog_Path (Last + 1 .. Prog_Path'Last),
Prog_Path (Prog_Path'First .. Last - 1));
Pos : Natural;
begin
-- Stop now in case of error.
if Pathname'Length = 0 then
return;
end if;
-- Skip executable name
Last := Get_Basename_Pos (Pathname);
if Last < Pathname'First then
return;
end if;
-- Simplify path:
-- /./ => /
-- // => /
Pos := Last - 1;
while Pos >= Pathname'First loop
if Is_Directory_Separator (Pathname (Pos)) then
if Is_Directory_Separator (Pathname (Pos + 1)) then
-- // => /
Pathname (Pos .. Last - 1) := Pathname (Pos + 1 .. Last);
Last := Last - 1;
elsif Pos + 2 <= Last
and then Pathname (Pos + 1) = '.'
and then Is_Directory_Separator (Pathname (Pos + 2))
then
-- /./ => /
Pathname (Pos .. Last - 2) := Pathname (Pos + 2 .. Last);
Last := Last - 2;
end if;
end if;
Pos := Pos - 1;
end loop;
-- Simplify path:
-- /xxx/../ => /
-- Do it forward as xxx/../../ must not be simplified as xxx/
-- This is done after the previous simplication to avoid to deal
-- with cases like /xxx//../ or /xxx/./../
Pos := Pathname'First;
while Pos <= Last - 3 loop
if Is_Directory_Separator (Pathname (Pos))
and then Pathname (Pos + 1) = '.'
and then Pathname (Pos + 2) = '.'
and then Is_Directory_Separator (Pathname (Pos + 3))
then
declare
Last_Dir : Natural;
Len : Natural;
begin
-- Search backward
Last_Dir := Pos;
loop
if Last_Dir = Pathname'First then
Last_Dir := Pos;
exit;
end if;
Last_Dir := Last_Dir - 1;
exit when Is_Directory_Separator (Pathname (Last_Dir));
end loop;
-- /xxxxxxxxxx/../
-- ^ ^
-- Last_Dir Pos
Len := Pos + 3 - Last_Dir;
Pathname (Last_Dir + 1 .. Last - Len) :=
Pathname (Pos + 4 .. Last);
Last := Last - Len;
Pos := Last_Dir;
end;
else
Pos := Pos + 1;
end if;
end loop;
-- Remove last '/'
Last := Last - 1;
-- Skip '/bin' directory if present
Pos := Get_Basename_Pos (Pathname (Pathname'First .. Last));
if Pos < Pathname'First then
return;
end if;
if To_Lower (Pathname (Pos + 1 .. Last)) = "bin" then
Last := Pos - 1;
end if;
Exec_Prefix := new String'(Pathname (Pathname'First .. Last));
end;
end Set_Prefix_From_Program_Path;
-- Extract Exec_Prefix from executable name.
procedure Set_Exec_Prefix
is
use GNAT.Directory_Operations;
Prog_Path : constant String := Ada.Command_Line.Command_Name;
Exec_Path : String_Access;
begin
-- If the command name is an absolute path, deduce prefix from it.
if Is_Absolute_Path (Prog_Path) then
Set_Prefix_From_Program_Path (Prog_Path);
return;
end if;
-- If the command name is a relative path, deduce prefix from it
-- and current path.
if Get_Basename_Pos (Prog_Path) >= Prog_Path'First then
if Is_Executable_File (Prog_Path) then
Set_Prefix_From_Program_Path
(Get_Current_Dir & Directory_Separator & Prog_Path);
end if;
return;
end if;
-- Look for program name on the path.
Exec_Path := Locate_Exec_On_Path (Prog_Path);
if Exec_Path /= null then
Set_Prefix_From_Program_Path (Exec_Path.all);
Free (Exec_Path);
end if;
end Set_Exec_Prefix;
function Get_Version_Path return String
is
use Flags;
begin
case Vhdl_Std is
when Vhdl_87 =>
return "v87";
when Vhdl_93c
| Vhdl_93
| Vhdl_00
| Vhdl_02 =>
return "v93";
when Vhdl_08 =>
return "v08";
end case;
end Get_Version_Path;
function Get_Machine_Path_Prefix return String is
begin
if Flag_32bit then
return Lib_Prefix_Path.all & "32";
else
return Lib_Prefix_Path.all;
end if;
end Get_Machine_Path_Prefix;
procedure Add_Library_Path (Name : String)
is
Path : constant String := Get_Machine_Path_Prefix & Directory_Separator
& Get_Version_Path & Directory_Separator & Name & Directory_Separator;
begin
if not Is_Directory (Path) then
Warning
("library " & Name & " does not exists for " & Get_Version_Path);
end if;
Libraries.Add_Library_Path (Path);
end Add_Library_Path;
procedure Setup_Libraries (Load : Boolean)
is
use Flags;
begin
-- Get environment variable.
Prefix_Env := GNAT.OS_Lib.Getenv ("GHDL_PREFIX");
if Prefix_Env = null or else Prefix_Env.all = "" then
Prefix_Env := null;
end if;
-- Compute Exec_Prefix.
Set_Exec_Prefix;
-- Set prefix path.
-- If not set by command line, try environment variable.
if Switch_Prefix_Path /= null then
Lib_Prefix_Path := Switch_Prefix_Path;
else
Lib_Prefix_Path := Prefix_Env;
end if;
-- Else try default path.
if Lib_Prefix_Path = null then
if Is_Absolute_Path (Default_Pathes.Lib_Prefix) then
Lib_Prefix_Path := new String'(Default_Pathes.Lib_Prefix);
else
if Exec_Prefix /= null then
Lib_Prefix_Path := new
String'(Exec_Prefix.all & Directory_Separator
& Default_Pathes.Lib_Prefix);
end if;
if Lib_Prefix_Path = null
or else not Is_Directory (Lib_Prefix_Path.all)
then
Free (Lib_Prefix_Path);
Lib_Prefix_Path := new
String'(Default_Pathes.Install_Prefix
& Directory_Separator
& Default_Pathes.Lib_Prefix);
end if;
end if;
else
-- Assume the user has set the correct path, so do not insert 32.
Flag_32bit := False;
end if;
-- Add pathes for predefined libraries.
if not Flags.Bootstrap then
Add_Library_Path ("std");
case Flag_Ieee is
when Lib_Standard =>
Add_Library_Path ("ieee");
when Lib_Synopsys =>
if Vhdl_Std >= Vhdl_08 then
Warning ("--ieee=synopsys is ignored for --std=08");
else
Add_Library_Path ("synopsys");
end if;
when Lib_Mentor =>
if Vhdl_Std >= Vhdl_08 then
Warning ("--ieee=mentor is ignored for --std=08");
else
Add_Library_Path ("mentor");
end if;
when Lib_None =>
null;
end case;
end if;
if Load then
Libraries.Load_Std_Library;
Libraries.Load_Work_Library;
end if;
end Setup_Libraries;
procedure Disp_Config_Prefixes is
begin
Put ("command line prefix (--PREFIX): ");
if Switch_Prefix_Path = null then
Put_Line ("(not set)");
else
Put_Line (Switch_Prefix_Path.all);
end if;
Put ("environment prefix (GHDL_PREFIX): ");
if Prefix_Env = null then
Put_Line ("(not set)");
else
Put_Line (Prefix_Env.all);
end if;
Setup_Libraries (False);
Put ("exec prefix (from program name): ");
if Exec_Prefix = null then
Put_Line ("(not found)");
else
Put_Line (Exec_Prefix.all);
end if;
New_Line;
Put_Line ("library prefix: " & Lib_Prefix_Path.all);
Put ("library directory: ");
Put_Line (Get_Machine_Path_Prefix);
end Disp_Config_Prefixes;
procedure Disp_Library_Unit (Unit : Iir)
is
use Name_Table;
Id : Name_Id;
begin
Id := Get_Identifier (Unit);
case Get_Kind (Unit) is
when Iir_Kind_Entity_Declaration =>
Put ("entity ");
when Iir_Kind_Architecture_Body =>
Put ("architecture ");
when Iir_Kind_Configuration_Declaration =>
Put ("configuration ");
when Iir_Kind_Package_Declaration =>
Put ("package ");
when Iir_Kind_Package_Instantiation_Declaration =>
Put ("package instance ");
when Iir_Kind_Package_Body =>
Put ("package body ");
when others =>
Put ("???");
return;
end case;
Image (Id);
Put (Nam_Buffer (1 .. Nam_Length));
case Get_Kind (Unit) is
when Iir_Kind_Architecture_Body =>
Put (" of ");
Image (Get_Entity_Identifier_Of_Architecture (Unit));
Put (Nam_Buffer (1 .. Nam_Length));
when Iir_Kind_Configuration_Declaration =>
if Id = Null_Identifier then
Put ("<default> of entity ");
Image (Get_Entity_Identifier_Of_Architecture (Unit));
Put (Nam_Buffer (1 .. Nam_Length));
end if;
when others =>
null;
end case;
end Disp_Library_Unit;
procedure Disp_Library (Name : Name_Id)
is
use Libraries;
Lib : Iir_Library_Declaration;
File : Iir_Design_File;
Unit : Iir;
begin
if Name = Std_Names.Name_Work then
Lib := Work_Library;
elsif Name = Std_Names.Name_Std then
Lib := Std_Library;
else
Lib := Get_Library (Name, Command_Line_Location);
end if;
-- Disp contents of files.
File := Get_Design_File_Chain (Lib);
while File /= Null_Iir loop
Unit := Get_First_Design_Unit (File);
while Unit /= Null_Iir loop
Disp_Library_Unit (Get_Library_Unit (Unit));
New_Line;
Unit := Get_Chain (Unit);
end loop;
File := Get_Chain (File);
end loop;
end Disp_Library;
-- Return FILENAME without the extension.
function Get_Base_Name (Filename : String; Remove_Dir : Boolean := True)
return String
is
First : Natural;
Last : Natural;
begin
First := Filename'First;
Last := Filename'Last;
for I in Filename'Range loop
if Filename (I) = '.' then
Last := I - 1;
elsif Remove_Dir and then Filename (I) = Directory_Separator then
First := I + 1;
Last := Filename'Last;
end if;
end loop;
return Filename (First .. Last);
end Get_Base_Name;
function Append_Suffix
(File : String; Suffix : String; In_Work : Boolean := True)
return String_Access
is
use Name_Table;
begin
if In_Work then
return new String'(Image (Libraries.Work_Directory)
& Get_Base_Name (File) & Suffix);
else
return new String'(File & Suffix);
end if;
end Append_Suffix;
-- Command Dir.
type Command_Dir is new Command_Lib with null record;
function Decode_Command (Cmd : Command_Dir; Name : String) return Boolean;
function Get_Short_Help (Cmd : Command_Dir) return String;
procedure Perform_Action (Cmd : in out Command_Dir; Args : Argument_List);
function Decode_Command (Cmd : Command_Dir; Name : String) return Boolean
is
pragma Unreferenced (Cmd);
begin
-- '-d' is for compatibility.
return Name = "-d" or else Name = "--dir";
end Decode_Command;
function Get_Short_Help (Cmd : Command_Dir) return String
is
pragma Unreferenced (Cmd);
begin
return "--dir [LIBs] Disp contents of the libraries";
end Get_Short_Help;
procedure Perform_Action (Cmd : in out Command_Dir; Args : Argument_List)
is
pragma Unreferenced (Cmd);
begin
Setup_Libraries (True);
if Args'Length = 0 then
Disp_Library (Std_Names.Name_Work);
else
for I in Args'Range loop
Disp_Library (Name_Table.Get_Identifier (Args (I).all));
end loop;
end if;
end Perform_Action;
-- Command Find.
type Command_Find is new Command_Lib with null record;
function Decode_Command (Cmd : Command_Find; Name : String) return Boolean;
function Get_Short_Help (Cmd : Command_Find) return String;
procedure Perform_Action (Cmd : in out Command_Find; Args : Argument_List);
function Decode_Command (Cmd : Command_Find; Name : String) return Boolean
is
pragma Unreferenced (Cmd);
begin
return Name = "-f";
end Decode_Command;
function Get_Short_Help (Cmd : Command_Find) return String
is
pragma Unreferenced (Cmd);
begin
return "-f FILEs Disp units in FILES";
end Get_Short_Help;
-- Return TRUE is UNIT can be at the apex of a design hierarchy.
function Is_Top_Entity (Unit : Iir) return Boolean
is
begin
if Get_Kind (Unit) /= Iir_Kind_Entity_Declaration then
return False;
end if;
if Get_Port_Chain (Unit) /= Null_Iir then
return False;
end if;
if Get_Generic_Chain (Unit) /= Null_Iir then
return False;
end if;
return True;
end Is_Top_Entity;
-- Disp contents design files FILES.
procedure Perform_Action (Cmd : in out Command_Find; Args : Argument_List)
is
pragma Unreferenced (Cmd);
use Name_Table;
Id : Name_Id;
Design_File : Iir_Design_File;
Unit : Iir;
Lib : Iir;
Flag_Add : constant Boolean := False;
begin
Flags.Bootstrap := True;
Libraries.Load_Std_Library;
Libraries.Load_Work_Library;
for I in Args'Range loop
Id := Get_Identifier (Args (I).all);
Design_File := Libraries.Load_File (Id);
if Design_File /= Null_Iir then
Unit := Get_First_Design_Unit (Design_File);
while Unit /= Null_Iir loop
Lib := Get_Library_Unit (Unit);
Disp_Library_Unit (Lib);
if Is_Top_Entity (Lib) then
Put (" **");
end if;
New_Line;
if Flag_Add then
Libraries.Add_Design_Unit_Into_Library (Unit);
end if;
Unit := Get_Chain (Unit);
end loop;
end if;
end loop;
if Flag_Add then
Libraries.Save_Work_Library;
end if;
end Perform_Action;
-- Command Import.
type Command_Import is new Command_Lib with null record;
function Decode_Command (Cmd : Command_Import; Name : String)
return Boolean;
function Get_Short_Help (Cmd : Command_Import) return String;
procedure Perform_Action (Cmd : in out Command_Import;
Args : Argument_List);
function Decode_Command (Cmd : Command_Import; Name : String)
return Boolean
is
pragma Unreferenced (Cmd);
begin
return Name = "-i";
end Decode_Command;
function Get_Short_Help (Cmd : Command_Import) return String
is
pragma Unreferenced (Cmd);
begin
return "-i [OPTS] FILEs Import units of FILEs";
end Get_Short_Help;
procedure Perform_Action (Cmd : in out Command_Import; Args : Argument_List)
is
pragma Unreferenced (Cmd);
Id : Name_Id;
Design_File : Iir_Design_File;
Unit : Iir;
Next_Unit : Iir;
Lib : Iir;
begin
Setup_Libraries (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
Unit := Get_First_Design_Unit (Design_File);
while Unit /= Null_Iir loop
if Flag_Verbose then
Lib := Get_Library_Unit (Unit);
Disp_Library_Unit (Lib);
if Is_Top_Entity (Lib) then
Put (" **");
end if;
New_Line;
end if;
Next_Unit := Get_Chain (Unit);
Set_Chain (Unit, Null_Iir);
Libraries.Add_Design_Unit_Into_Library (Unit);
Unit := Next_Unit;
end loop;
end if;
end loop;
-- Analyze all files.
if False then
Design_File := Get_Design_File_Chain (Libraries.Work_Library);
while Design_File /= Null_Iir loop
Unit := Get_First_Design_Unit (Design_File);
while Unit /= Null_Iir loop
case Get_Date (Unit) is
when Date_Valid
| Date_Analyzed =>
null;
when Date_Parsed =>
Back_End.Finish_Compilation (Unit, False);
when others =>
raise Internal_Error;
end case;
Unit := Get_Chain (Unit);
end loop;
Design_File := Get_Chain (Design_File);
end loop;
end if;
Libraries.Save_Work_Library;
exception
when Errorout.Compilation_Error =>
Error ("importation has failed due to compilation error");
raise;
end Perform_Action;
-- Command Check_Syntax.
type Command_Check_Syntax is new Command_Lib with null record;
function Decode_Command (Cmd : Command_Check_Syntax; Name : String)
return Boolean;
function Get_Short_Help (Cmd : Command_Check_Syntax) return String;
procedure Perform_Action (Cmd : in out Command_Check_Syntax;
Args : Argument_List);
function Decode_Command (Cmd : Command_Check_Syntax; Name : String)
return Boolean
is
pragma Unreferenced (Cmd);
begin
return Name = "-s";
end Decode_Command;
function Get_Short_Help (Cmd : Command_Check_Syntax) return String
is
pragma Unreferenced (Cmd);
begin
return "-s [OPTS] FILEs Check syntax of FILEs";
end Get_Short_Help;
procedure Analyze_One_File (File_Name : String)
is
Id : Name_Id;
Design_File : Iir_Design_File;
Unit : Iir;
Next_Unit : Iir;
begin
Id := Name_Table.Get_Identifier (File_Name);
if Flag_Verbose then
Put (File_Name);
Put_Line (":");
end if;
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
if Flag_Verbose then
Put (' ');
Disp_Library_Unit (Get_Library_Unit (Unit));
New_Line;
end if;
-- Sem, canon, annotate a design unit.
Back_End.Finish_Compilation (Unit, True);
Next_Unit := Get_Chain (Unit);
if Errorout.Nbr_Errors = 0 then
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 Analyze_One_File;
procedure Analyze_Files (Files : Argument_List; Save_Library : Boolean) is
begin
Setup_Libraries (True);
-- Parse all files.
for I in Files'Range loop
Analyze_One_File (Files (I).all);
end loop;
if Save_Library then
Libraries.Save_Work_Library;
end if;
end Analyze_Files;
procedure Perform_Action (Cmd : in out Command_Check_Syntax;
Args : Argument_List)
is
pragma Unreferenced (Cmd);
begin
Analyze_Files (Args, False);
end Perform_Action;
-- Command --clean: remove object files.
type Command_Clean is new Command_Lib with null record;
function Decode_Command (Cmd : Command_Clean; Name : String) return Boolean;
function Get_Short_Help (Cmd : Command_Clean) return String;
procedure Perform_Action (Cmd : in out Command_Clean; Args : Argument_List);
function Decode_Command (Cmd : Command_Clean; Name : String) return Boolean
is
pragma Unreferenced (Cmd);
begin
return Name = "--clean";
end Decode_Command;
function Get_Short_Help (Cmd : Command_Clean) return String
is
pragma Unreferenced (Cmd);
begin
return "--clean Remove generated files";
end Get_Short_Help;
procedure Delete (Str : String)
is
Status : Boolean;
begin
Delete_File (Str'Address, Status);
if Flag_Verbose and Status then
Put_Line ("delete " & Str (Str'First .. Str'Last - 1));
end if;
end Delete;
procedure Perform_Action (Cmd : in out Command_Clean; Args : Argument_List)
is
pragma Unreferenced (Cmd);
use Name_Table;
procedure Delete_Asm_Obj (Str : String) is
begin
Delete (Str & Get_Object_Suffix.all & Nul);
Delete (Str & Asm_Suffix & Nul);
end Delete_Asm_Obj;
procedure Delete_Top_Unit (Str : String) is
begin
-- Delete elaboration file
Delete_Asm_Obj (Image (Libraries.Work_Directory) & Elab_Prefix & Str);
-- Delete file list.
Delete (Image (Libraries.Work_Directory) & Str & List_Suffix & Nul);
-- Delete executable.
Delete (Str & Nul);
end Delete_Top_Unit;
File : Iir_Design_File;
Design_Unit : Iir_Design_Unit;
Lib_Unit : Iir;
Str : String_Access;
begin
if Args'Length /= 0 then
Error ("command '--clean' does not accept any argument");
raise Option_Error;
end if;
Flags.Bootstrap := True;
-- Load libraries.
Libraries.Load_Std_Library;
Libraries.Load_Work_Library;
File := Get_Design_File_Chain (Libraries.Work_Library);
while File /= Null_Iir loop
-- Delete compiled file.
Str := Append_Suffix (Image (Get_Design_File_Filename (File)), "");
Delete_Asm_Obj (Str.all);
Free (Str);
Design_Unit := Get_First_Design_Unit (File);
while Design_Unit /= Null_Iir loop
Lib_Unit := Get_Library_Unit (Design_Unit);
case Get_Kind (Lib_Unit) is
when Iir_Kind_Entity_Declaration
| Iir_Kind_Configuration_Declaration =>
Delete_Top_Unit (Image (Get_Identifier (Lib_Unit)));
when Iir_Kind_Architecture_Body =>
Delete_Top_Unit
(Image (Get_Entity_Identifier_Of_Architecture (Lib_Unit))
& '-'
& Image (Get_Identifier (Lib_Unit)));
when others =>
null;
end case;
Design_Unit := Get_Chain (Design_Unit);
end loop;
File := Get_Chain (File);
end loop;
end Perform_Action;
-- Command --remove: remove object file and library file.
type Command_Remove is new Command_Clean with null record;
function Decode_Command (Cmd : Command_Remove; Name : String)
return Boolean;
function Get_Short_Help (Cmd : Command_Remove) return String;
procedure Perform_Action (Cmd : in out Command_Remove;
Args : Argument_List);
function Decode_Command (Cmd : Command_Remove; Name : String) return Boolean
is
pragma Unreferenced (Cmd);
begin
return Name = "--remove";
end Decode_Command;
function Get_Short_Help (Cmd : Command_Remove) return String
is
pragma Unreferenced (Cmd);
begin
return "--remove Remove generated files and library file";
end Get_Short_Help;
procedure Perform_Action (Cmd : in out Command_Remove; Args : Argument_List)
is
use Name_Table;
begin
if Args'Length /= 0 then
Error ("command '--remove' does not accept any argument");
raise Option_Error;
end if;
Perform_Action (Command_Clean (Cmd), Args);
Delete (Image (Libraries.Work_Directory)
& Back_End.Library_To_File_Name (Libraries.Work_Library)
& Nul);
end Perform_Action;
-- Command --copy: copy work library to current directory.
type Command_Copy is new Command_Lib with null record;
function Decode_Command (Cmd : Command_Copy; Name : String) return Boolean;
function Get_Short_Help (Cmd : Command_Copy) return String;
procedure Perform_Action (Cmd : in out Command_Copy; Args : Argument_List);
function Decode_Command (Cmd : Command_Copy; Name : String) return Boolean
is
pragma Unreferenced (Cmd);
begin
return Name = "--copy";
end Decode_Command;
function Get_Short_Help (Cmd : Command_Copy) return String
is
pragma Unreferenced (Cmd);
begin
return "--copy Copy work library to current directory";
end Get_Short_Help;
procedure Perform_Action (Cmd : in out Command_Copy; Args : Argument_List)
is
pragma Unreferenced (Cmd);
use Name_Table;
use Libraries;
File : Iir_Design_File;
Dir : Name_Id;
begin
if Args'Length /= 0 then
Error ("command '--copy' does not accept any argument");
raise Option_Error;
end if;
Setup_Libraries (False);
Libraries.Load_Std_Library;
Dir := Work_Directory;
Work_Directory := Null_Identifier;
Libraries.Load_Work_Library;
Work_Directory := Dir;
Dir := Get_Library_Directory (Libraries.Work_Library);
if Dir = Name_Nil or else Dir = Files_Map.Get_Home_Directory then
Error ("cannot copy library on itself (use --remove first)");
raise Option_Error;
end if;
File := Get_Design_File_Chain (Libraries.Work_Library);
while File /= Null_Iir loop
-- Copy object files (if any).
declare
Basename : constant String :=
Get_Base_Name (Image (Get_Design_File_Filename (File)));
Src : String_Access;
Dst : String_Access;
Success : Boolean;
pragma Unreferenced (Success);
begin
Src := new String'(Image (Dir) & Basename & Get_Object_Suffix.all);
Dst := new String'(Basename & Get_Object_Suffix.all);
Copy_File (Src.all, Dst.all, Success, Overwrite, Full);
-- Be silent in case of error.
Free (Src);
Free (Dst);
end;
if Get_Design_File_Directory (File) = Name_Nil then
Set_Design_File_Directory (File, Dir);
end if;
File := Get_Chain (File);
end loop;
Libraries.Work_Directory := Name_Nil;
Libraries.Save_Work_Library;
end Perform_Action;
-- Command --disp-standard.
type Command_Disp_Standard is new Command_Lib with null record;
function Decode_Command (Cmd : Command_Disp_Standard; Name : String)
return Boolean;
function Get_Short_Help (Cmd : Command_Disp_Standard) return String;
procedure Perform_Action (Cmd : in out Command_Disp_Standard;
Args : Argument_List);
function Decode_Command (Cmd : Command_Disp_Standard; Name : String)
return Boolean
is
pragma Unreferenced (Cmd);
begin
return Name = "--disp-standard";
end Decode_Command;
function Get_Short_Help (Cmd : Command_Disp_Standard) return String
is
pragma Unreferenced (Cmd);
begin
return "--disp-standard Disp std.standard in pseudo-vhdl";
end Get_Short_Help;
procedure Perform_Action (Cmd : in out Command_Disp_Standard;
Args : Argument_List)
is
pragma Unreferenced (Cmd);
begin
if Args'Length /= 0 then
Error ("command '--disp-standard' does not accept any argument");
raise Option_Error;
end if;
Flags.Bootstrap := True;
Libraries.Load_Std_Library;
Disp_Vhdl.Disp_Vhdl (Std_Package.Std_Standard_Unit);
end Perform_Action;
procedure Load_All_Libraries_And_Files
is
use Files_Map;
use Libraries;
use Errorout;
procedure Extract_Library_Clauses (Unit : Iir_Design_Unit)
is
Lib1 : Iir_Library_Declaration;
pragma Unreferenced (Lib1);
Ctxt_Item : Iir;
begin
-- Extract library clauses.
Ctxt_Item := Get_Context_Items (Unit);
while Ctxt_Item /= Null_Iir loop
if Get_Kind (Ctxt_Item) = Iir_Kind_Library_Clause then
Lib1 := Get_Library (Get_Identifier (Ctxt_Item),
Get_Location (Ctxt_Item));
end if;
Ctxt_Item := Get_Chain (Ctxt_Item);
end loop;
end Extract_Library_Clauses;
Lib : Iir_Library_Declaration;
Fe : Source_File_Entry;
File, Next_File : Iir_Design_File;
Unit, Next_Unit : Iir_Design_Unit;
Design_File : Iir_Design_File;
Old_Work : Iir_Library_Declaration;
begin
Lib := Std_Library;
Lib := Get_Chain (Lib);
Old_Work := Work_Library;
while Lib /= Null_Iir loop
-- Design units are always put in the work library.
Work_Library := Lib;
File := Get_Design_File_Chain (Lib);
while File /= Null_Iir loop
Next_File := Get_Chain (File);
Fe := Load_Source_File (Get_Design_File_Directory (File),
Get_Design_File_Filename (File));
if Fe = No_Source_File_Entry then
-- FIXME: should remove all the design file from the library.
null;
elsif Is_Eq (Get_File_Checksum (Fe),
Get_File_Checksum (File))
then
-- File has not been modified.
-- Extract libraries.
-- Note: we can't parse it only, since we need to keep the
-- date.
Unit := Get_First_Design_Unit (File);
while Unit /= Null_Iir loop
Load_Parse_Design_Unit (Unit, Null_Iir);
Extract_Library_Clauses (Unit);
Unit := Get_Chain (Unit);
end loop;
else
-- File has been modified.
-- Parse it.
Design_File := Load_File (Fe);
-- Exit now in case of parse error.
if Design_File = Null_Iir
or else Nbr_Errors > 0
then
raise Compilation_Error;
end if;
Unit := Get_First_Design_Unit (Design_File);
while Unit /= Null_Iir loop
Extract_Library_Clauses (Unit);
Next_Unit := Get_Chain (Unit);
Set_Chain (Unit, Null_Iir);
Add_Design_Unit_Into_Library (Unit);
Unit := Next_Unit;
end loop;
end if;
File := Next_File;
end loop;
Lib := Get_Chain (Lib);
end loop;
Work_Library := Old_Work;
end Load_All_Libraries_And_Files;
-- Check the Elab_Flag is not set on design units of LIB.
procedure Check_No_Elab_Flag (Lib : Iir_Library_Declaration)
is
File : Iir_Design_File;
Unit : Iir_Design_Unit;
begin
File := Get_Design_File_Chain (Lib);
while File /= Null_Iir loop
Unit := Get_First_Design_Unit (File);
while Unit /= Null_Iir loop
if Get_Elab_Flag (Unit) then
raise Internal_Error;
end if;
Unit := Get_Chain (Unit);
end loop;
File := Get_Chain (File);
end loop;
end Check_No_Elab_Flag;
function Build_Dependence (Prim : String_Access; Sec : String_Access)
return Iir_List
is
procedure Build_Dependence_List (File : Iir_Design_File; List : Iir_List)
is
El : Iir_Design_File;
Depend_List : Iir_List;
begin
if Get_Elab_Flag (File) then
return;
end if;
Set_Elab_Flag (File, True);
Depend_List := Get_File_Dependence_List (File);
if Depend_List /= Null_Iir_List then
for I in Natural loop
El := Get_Nth_Element (Depend_List, I);
exit when El = Null_Iir;
Build_Dependence_List (El, List);
end loop;
end if;
Append_Element (List, File);
end Build_Dependence_List;
use Configuration;
use Name_Table;
Top : Iir;
Primary_Id : Name_Id;
Secondary_Id : Name_Id;
File : Iir_Design_File;
Unit : Iir;
Files_List : Iir_List;
begin
Check_No_Elab_Flag (Libraries.Work_Library);
Primary_Id := Get_Identifier (Prim.all);
if Sec /= null then
Secondary_Id := Get_Identifier (Sec.all);
else
Secondary_Id := Null_Identifier;
end if;
if True then
-- Load the world.
Load_All_Libraries_And_Files;
else
-- Re-parse modified files in order configure could find all design
-- units.
declare
use Files_Map;
Fe : Source_File_Entry;
Next_File : Iir_Design_File;
Design_File : Iir_Design_File;
begin
File := Get_Design_File_Chain (Libraries.Work_Library);
while File /= Null_Iir loop
Next_File := Get_Chain (File);
Fe := Load_Source_File (Get_Design_File_Directory (File),
Get_Design_File_Filename (File));
if Fe = No_Source_File_Entry then
-- FIXME: should remove all the design file from
-- the library.
null;
else
if not Is_Eq (Get_File_Checksum (Fe),
Get_File_Checksum (File))
then
-- FILE has been modified.
Design_File := Libraries.Load_File (Fe);
if Design_File /= Null_Iir then
Libraries.Add_Design_File_Into_Library (Design_File);
end if;
end if;
end if;
File := Next_File;
end loop;
end;
end if;
Flags.Flag_Elaborate := True;
Flags.Flag_Elaborate_With_Outdated := True;
Flag_Load_All_Design_Units := True;
Flag_Build_File_Dependence := True;
Top := Configure (Primary_Id, Secondary_Id);
if Top = Null_Iir then
-- Error during configuration (primary unit not found).
raise Option_Error;
end if;
-- Add unused design units (and their dependencies).
declare
N : Natural;
begin
N := Design_Units.First;
while N <= Design_Units.Last loop
Unit := Design_Units.Table (N);
N := N + 1;
File := Get_Design_File (Unit);
if not Get_Elab_Flag (File) then
Set_Elab_Flag (File, True);
Unit := Get_First_Design_Unit (File);
while Unit /= Null_Iir loop
if not Get_Elab_Flag (Unit) then
Add_Design_Unit (Unit, Null_Iir);
end if;
Unit := Get_Chain (Unit);
end loop;
end if;
end loop;
end;
-- Clear elab flag on design files (as it is used by below by
-- Build_Dependence_List).
for I in reverse Design_Units.First .. Design_Units.Last loop
Unit := Design_Units.Table (I);
File := Get_Design_File (Unit);
Set_Elab_Flag (File, False);
end loop;
-- Create a list of files, from the last to the first.
Files_List := Create_Iir_List;
for I in Design_Units.First .. Design_Units.Last loop
Unit := Design_Units.Table (I);
File := Get_Design_File (Unit);
Build_Dependence_List (File, Files_List);
end loop;
return Files_List;
end Build_Dependence;
function Source_File_Modified (File : Iir_Design_File) return Boolean
is
use Files_Map;
Fe : Source_File_Entry;
begin
-- 2) file has been modified.
Fe := Load_Source_File (Get_Design_File_Directory (File),
Get_Design_File_Filename (File));
if not Is_Eq (Get_File_Checksum (Fe),
Get_File_Checksum (File))
then
if Flag_Verbose then
Put_Line ("file " & Name_Table.Image (Get_File_Name (Fe))
& " has been modified");
end if;
return True;
else
return False;
end if;
end Source_File_Modified;
function Is_File_Outdated (File : Iir_Design_File) return Boolean
is
Unit : Iir;
Lib_Unit : Iir;
begin
Unit := Get_First_Design_Unit (File);
while Unit /= Null_Iir loop
Lib_Unit := Get_Library_Unit (Unit);
if Get_Kind (Lib_Unit) = Iir_Kind_Configuration_Declaration
and then Get_Identifier (Lib_Unit) = Null_Identifier
then
-- Do not consider default configurations (there is no user code
-- for them).
null;
elsif Get_Date (Unit) not in Date_Valid then
-- Unit not yet analyzed:
if Flag_Verbose then
Disp_Library_Unit (Get_Library_Unit (Unit));
Put_Line (" was not analyzed");
end if;
return True;
else
-- Check if one of the dependence is newer
declare
Depends : constant Iir_List := Get_Dependence_List (Unit);
Stamp : constant Time_Stamp_Id :=
Get_Analysis_Time_Stamp (File);
El : Iir;
Dep : Iir_Design_Unit;
Dep_File : Iir_Design_File;
begin
if Depends /= Null_Iir_List then
for I in Natural loop
El := Get_Nth_Element (Depends, I);
exit when El = Null_Iir;
Dep := Libraries.Find_Design_Unit (El);
if Dep = Null_Iir then
if Flag_Verbose then
Disp_Library_Unit (Unit);
Put (" depends on an unknown unit ");
Disp_Library_Unit (El);
New_Line;
end if;
return True;
end if;
Dep_File := Get_Design_File (Dep);
if Dep /= Std_Package.Std_Standard_Unit
and then
Files_Map.Is_Gt (Get_Analysis_Time_Stamp (Dep_File),
Stamp)
then
if Flag_Verbose then
Disp_Library_Unit (Get_Library_Unit (Unit));
Put (" depends on: ");
Disp_Library_Unit (Get_Library_Unit (Dep));
Put (" (more recently analyzed)");
New_Line;
end if;
return True;
end if;
end loop;
end if;
end;
end if;
Unit := Get_Chain (Unit);
end loop;
return False;
end Is_File_Outdated;
-- Convert NAME to lower cases, unless it is an extended identifier.
function Convert_Name (Name : String_Access) return String_Access
is
use Name_Table;
function Is_Bad_Unit_Name return Boolean is
begin
if Nam_Length = 0 then
return True;
end if;
-- Don't try to handle extended identifier.
if Nam_Buffer (1) = '\' then
return False;
end if;
-- Look for suspicious characters.
-- Do not try to be exhaustive as the correct check will be done
-- by convert_identifier.
for I in 1 .. Nam_Length loop
case Nam_Buffer (I) is
when '.' | '/' | '\' =>
return True;
when others =>
null;
end case;
end loop;
return False;
end Is_Bad_Unit_Name;
function Is_A_File_Name return Boolean is
begin
-- Check .vhd
if Nam_Length > 4
and then Nam_Buffer (Nam_Length - 3 .. Nam_Length) = ".vhd"
then
return True;
end if;
-- Check .vhdl
if Nam_Length > 5
and then Nam_Buffer (Nam_Length - 4 .. Nam_Length) = ".vhdl"
then
return True;
end if;
-- Check ../
if Nam_Length > 3
and then Nam_Buffer (1 .. 3) = "../"
then
return True;
end if;
-- Check ..\
if Nam_Length > 3
and then Nam_Buffer (1 .. 3) = "..\"
then
return True;
end if;
-- Should try to find the file ?
return False;
end Is_A_File_Name;
begin
Nam_Length := Name'Length;
Nam_Buffer (1 .. Nam_Length) := Name.all;
-- Try to identifier bad names (such as file names), so that
-- friendly message can be displayed.
if Is_Bad_Unit_Name then
Errorout.Error_Msg_Option_NR ("bad unit name '" & Name.all & "'");
if Is_A_File_Name then
Errorout.Error_Msg_Option_NR
("(a unit name is required instead of a filename)");
end if;
raise Option_Error;
end if;
Scanner.Convert_Identifier;
return new String'(Nam_Buffer (1 .. Nam_Length));
end Convert_Name;
procedure Extract_Elab_Unit
(Cmd_Name : String; Args : Argument_List; Next_Arg : out Natural)
is
begin
if Args'Length = 0 then
Error ("command '" & Cmd_Name & "' required an unit name");
raise Option_Error;
end if;
Prim_Name := Convert_Name (Args (Args'First));
Next_Arg := Args'First + 1;
Sec_Name := null;
if Args'Length >= 2 then
declare
Sec : constant String_Access := Args (Next_Arg);
begin
if Sec (Sec'First) /= '-' then
Sec_Name := Convert_Name (Sec);
Next_Arg := Args'First + 2;
end if;
end;
end if;
end Extract_Elab_Unit;
procedure Register_Commands is
begin
Register_Command (new Command_Import);
Register_Command (new Command_Check_Syntax);
Register_Command (new Command_Dir);
Register_Command (new Command_Find);
Register_Command (new Command_Clean);
Register_Command (new Command_Remove);
Register_Command (new Command_Copy);
Register_Command (new Command_Disp_Standard);
end Register_Commands;
end Ghdllocal;