summaryrefslogtreecommitdiff
path: root/translate/ghdldrv
diff options
context:
space:
mode:
authorgingold2005-09-24 05:10:24 +0000
committergingold2005-09-24 05:10:24 +0000
commit977ff5e02c6d2f9bfdabcf8b4e98b81e2d83e849 (patch)
tree7bcf8e7aff40a8b54d4af83e90cccd73568e77bb /translate/ghdldrv
downloadghdl-977ff5e02c6d2f9bfdabcf8b4e98b81e2d83e849.tar.gz
ghdl-977ff5e02c6d2f9bfdabcf8b4e98b81e2d83e849.tar.bz2
ghdl-977ff5e02c6d2f9bfdabcf8b4e98b81e2d83e849.zip
First import from sources
Diffstat (limited to 'translate/ghdldrv')
-rw-r--r--translate/ghdldrv/Makefile114
-rw-r--r--translate/ghdldrv/default_pathes.ads.in30
-rw-r--r--translate/ghdldrv/ghdl_gcc.adb33
-rw-r--r--translate/ghdldrv/ghdl_mcode.adb33
-rw-r--r--translate/ghdldrv/ghdl_simul.adb32
-rw-r--r--translate/ghdldrv/ghdlcomp.adb745
-rw-r--r--translate/ghdldrv/ghdlcomp.ads67
-rw-r--r--translate/ghdldrv/ghdldrv.adb1705
-rw-r--r--translate/ghdldrv/ghdldrv.ads20
-rw-r--r--translate/ghdldrv/ghdllocal.adb1052
-rw-r--r--translate/ghdldrv/ghdllocal.ads98
-rw-r--r--translate/ghdldrv/ghdlmain.adb355
-rw-r--r--translate/ghdldrv/ghdlmain.ads85
-rw-r--r--translate/ghdldrv/ghdlprint.adb1561
-rw-r--r--translate/ghdldrv/ghdlprint.ads22
-rw-r--r--translate/ghdldrv/ghdlrun.adb658
-rw-r--r--translate/ghdldrv/ghdlrun.ads20
-rw-r--r--translate/ghdldrv/ghdlsimul.adb142
-rw-r--r--translate/ghdldrv/ghdlsimul.ads20
19 files changed, 6792 insertions, 0 deletions
diff --git a/translate/ghdldrv/Makefile b/translate/ghdldrv/Makefile
new file mode 100644
index 0000000..dc1b07d
--- /dev/null
+++ b/translate/ghdldrv/Makefile
@@ -0,0 +1,114 @@
+# -*- Makefile -*- for the GHDL drivers.
+# 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.
+GNATFLAGS=-gnaty3befhkmr -gnata -gnatwu -gnatwl -aI../.. -aI.. -aI../grt -aO.. -g -gnatf
+GRT_FLAGS=-g
+
+# Optimize, do not forget to use MODE=--genfast for iirs.adb.
+#GNATFLAGS+=-O -gnatn
+#GRT_FLAGS+=-O
+
+# Profiling.
+#GNATFLAGS+=-pg -gnatn -O
+#GRT_FLAGS+=-pg -O
+
+GNAT_BARGS=-bargs -E
+
+#GNAT_LARGS= -static
+all: ghdl_mcode
+
+target=i686-pc-linux-gnu
+GRTSRCDIR=../grt
+include $(GRTSRCDIR)/Makefile.inc
+
+ghdl_mcode: default_pathes.ads $(GRT_ADD_OBJS) mmap_binding.o force
+ gnatmake -aI../../ortho/mcode $(GNATFLAGS) ghdl_mcode $(GNAT_BARGS) -largs mmap_binding.o $(GNAT_LARGS) $(GRT_ADD_OBJS) $(GRT_EXTRA_LIB)
+
+mmap_binding.o: ../../ortho/mcode/mmap_binding.c
+ $(CC) -c -g -o $@ $<
+
+ghdl_gcc: default_pathes.ads force
+ gnatmake $(GNATFLAGS) ghdl_gcc $(GNAT_BARGS) -largs $(GNAT_LARGS)
+
+ghdl_simul: default_pathes.ads force
+ gnatmake -aI../../simulate $(GNATFLAGS) ghdl_simul $(GNAT_BARGS) -largs $(GNAT_LARGS)
+
+default_pathes.ads: default_pathes.ads.in Makefile
+ curdir=`cd ..; pwd`; \
+ sed -e "s%@COMPILER_GCC@%$$curdir/ghdl1-gcc%" \
+ -e "s%@COMPILER_DEBUG@%$$curdir/ghdl1-debug%" \
+ -e "s%@COMPILER_MCODE@%$$curdir/ghdl1-mcode%" \
+ -e "s%@POST_PROCESSOR@%$$curdir/../ortho/oread/oread-gcc%" \
+ -e "s%@PREFIX@%$$curdir/lib/%" < $< > $@
+
+bootstrap.old: force
+ $(RM) ../../libraries/std-obj87.cf
+ $(MAKE) -C ../../libraries EXT=obj \
+ ANALYSE="$(PWD)/ghdl -a -g" std-obj87.cf
+ $(RM) ../../libraries/std-obj93.cf
+ $(MAKE) -C ../../libraries EXT=obj \
+ ANALYSE="$(PWD)/ghdl -a -g" std-obj93.cf
+
+LIB_CFLAGS=-g -O2
+
+LIB93_DIR:=../lib/v93
+LIB87_DIR:=../lib/v87
+LIBSRC_DIR:=../../libraries
+REL_DIR:=../..
+ANALYZE:=../../../ghdldrv/ghdl -a $(LIB_CFLAGS)
+LN=ln -s
+CP=cp
+
+$(LIB87_DIR):
+ [ -d ../lib ] || mkdir ../lib
+ [ -d $(LIB87_DIR) ] || mkdir $(LIB87_DIR)
+
+$(LIB93_DIR):
+ [ -d ../lib ] || mkdir ../lib
+ [ -d $(LIB93_DIR) ] || mkdir $(LIB93_DIR)
+
+include ../../libraries/Makefile.inc
+
+GHDL1=../ghdl1-gcc
+$(LIB87_DIR)/std/std_standard.o: $(GHDL1)
+ $(GHDL1) --std=87 -quiet $(LIB_CFLAGS) -o std_standard.s \
+ --compile-standard
+ $(CC) -c -o $@ std_standard.s
+ $(RM) std_standard.s
+
+$(LIB93_DIR)/std/std_standard.o: $(GHDL1)
+ $(GHDL1) --std=93 -quiet $(LIB_CFLAGS) -o std_standard.s \
+ --compile-standard
+ $(CC) -c -o $@ std_standard.s
+ $(RM) std_standard.s
+
+install.v93: std.v93 ieee.v93 synopsys.v93 mentor.v93
+install.v87: std.v87 ieee.v87 synopsys.v87
+
+install.standard: $(LIB93_DIR)/std/std_standard.o \
+ $(LIB87_DIR)/std/std_standard.o
+
+install.all: install.v87 install.v93 install.standard
+install.mcode: install.v87 install.v93
+
+clean: force
+ $(RM) -f *.o *.ali ghdl_gcc ghdl_mcode
+ $(RM) -f b~*.ad? *~ default_pathes.ads
+
+force:
+
+.PHONY: force clean
diff --git a/translate/ghdldrv/default_pathes.ads.in b/translate/ghdldrv/default_pathes.ads.in
new file mode 100644
index 0000000..3808595
--- /dev/null
+++ b/translate/ghdldrv/default_pathes.ads.in
@@ -0,0 +1,30 @@
+-- GHDL driver pathes -*- ada -*-.
+-- 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.
+
+package Default_Pathes is
+ Compiler_Mcode : constant String :=
+ "@COMPILER_MCODE@";
+ Compiler_Gcc : constant String :=
+ "@COMPILER_GCC@";
+ Compiler_Debug : constant String :=
+ "@COMPILER_DEBUG@";
+ Post_Processor : constant String :=
+ "@POST_PROCESSOR@";
+ Prefix : constant String :=
+ "@PREFIX@";
+end Default_Pathes;
diff --git a/translate/ghdldrv/ghdl_gcc.adb b/translate/ghdldrv/ghdl_gcc.adb
new file mode 100644
index 0000000..5edb6bf
--- /dev/null
+++ b/translate/ghdldrv/ghdl_gcc.adb
@@ -0,0 +1,33 @@
+-- GHDL driver for gcc.
+-- 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 Ghdlmain;
+with Ghdllocal;
+with Ghdldrv;
+with Ghdlprint;
+
+procedure Ghdl_Gcc is
+begin
+ -- Manual elaboration so that the order is known (because it is the order
+ -- used to display help).
+ Ghdlmain.Version_String := new String'("(Use the GCC back-end.)");
+ Ghdldrv.Register_Commands;
+ Ghdllocal.Register_Commands;
+ Ghdlprint.Register_Commands;
+ Ghdlmain.Register_Commands;
+ Ghdlmain.Main;
+end Ghdl_Gcc;
diff --git a/translate/ghdldrv/ghdl_mcode.adb b/translate/ghdldrv/ghdl_mcode.adb
new file mode 100644
index 0000000..3506856
--- /dev/null
+++ b/translate/ghdldrv/ghdl_mcode.adb
@@ -0,0 +1,33 @@
+-- GHDL driver for mcode/jit.
+-- 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 Ghdlmain;
+with Ghdllocal;
+with Ghdlprint;
+with Ghdlrun;
+
+procedure Ghdl_Mcode is
+begin
+ -- Manual elaboration so that the order is known (because it is the order
+ -- used to display help).
+ Ghdlmain.Version_String := new String'("(Use the mcode code generator.)");
+ Ghdlrun.Register_Commands;
+ Ghdllocal.Register_Commands;
+ Ghdlprint.Register_Commands;
+ Ghdlmain.Register_Commands;
+ Ghdlmain.Main;
+end Ghdl_Mcode;
diff --git a/translate/ghdldrv/ghdl_simul.adb b/translate/ghdldrv/ghdl_simul.adb
new file mode 100644
index 0000000..757feb2
--- /dev/null
+++ b/translate/ghdldrv/ghdl_simul.adb
@@ -0,0 +1,32 @@
+-- GHDL driver for simulator.
+-- 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 Ghdlmain;
+with Ghdllocal;
+with Ghdlprint;
+with Ghdlsimul;
+
+procedure Ghdl_Simul is
+begin
+ -- Manual elaboration so that the order is known (because it is the order
+ -- used to display help).
+ Ghdlsimul.Register_Commands;
+ Ghdllocal.Register_Commands;
+ Ghdlprint.Register_Commands;
+ Ghdlmain.Register_Commands;
+ Ghdlmain.Main;
+end Ghdl_Simul;
diff --git a/translate/ghdldrv/ghdlcomp.adb b/translate/ghdldrv/ghdlcomp.adb
new file mode 100644
index 0000000..93e40bb
--- /dev/null
+++ b/translate/ghdldrv/ghdlcomp.adb
@@ -0,0 +1,745 @@
+-- GHDL driver - compile 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 Ghdlmain; use Ghdlmain;
+with Ghdllocal; use Ghdllocal;
+
+with Ada.Command_Line;
+with Ada.Characters.Latin_1;
+with Ada.Text_IO;
+
+with Types;
+with Iirs; use Iirs;
+with Flags;
+with Back_End;
+with Sem;
+with Name_Table;
+with Errorout; use Errorout;
+with Libraries;
+with Std_Package;
+with Files_Map;
+with Version;
+
+package body Ghdlcomp is
+
+ Flag_Expect_Failure : Boolean := False;
+
+ -- Commands which use the mcode compiler.
+ type Command_Comp is abstract new Command_Lib with null record;
+ procedure Decode_Option (Cmd : in out Command_Comp;
+ Option : String;
+ Arg : String;
+ Res : out Option_Res);
+ procedure Disp_Long_Help (Cmd : Command_Comp);
+
+ procedure Decode_Option (Cmd : in out Command_Comp;
+ Option : String;
+ Arg : String;
+ Res : out Option_Res)
+ is
+ begin
+ if Option = "--expect-failure" then
+ Flag_Expect_Failure := True;
+ Res := Option_Ok;
+ elsif Hooks.Decode_Option.all (Option) then
+ Res := Option_Ok;
+ else
+ Decode_Option (Command_Lib (Cmd), Option, Arg, Res);
+ end if;
+ end Decode_Option;
+
+
+ procedure Disp_Long_Help (Cmd : Command_Comp)
+ is
+ use Ada.Text_IO;
+ begin
+ Disp_Long_Help (Command_Lib (Cmd));
+ Hooks.Disp_Long_Help.all;
+ Put_Line (" --expect-failure Expect analysis/elaboration failure");
+ end Disp_Long_Help;
+
+ -- Command -r
+ type Command_Run is new Command_Comp with null record;
+ function Decode_Command (Cmd : Command_Run; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Run) return String;
+
+ procedure Perform_Action (Cmd : in out Command_Run;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Run; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "-r" or Name = "--elab-run";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Run) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "-r,--elab-run [OPTS] UNIT [ARCH] [RUNOPTS] Run UNIT";
+ end Get_Short_Help;
+
+
+ procedure Perform_Action (Cmd : in out Command_Run;
+ Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ Opt_Arg : Natural;
+ begin
+ begin
+ Hooks.Compile_Init.all (False);
+
+ Libraries.Load_Work_Library (False);
+ Flags.Flag_Elaborate_With_Outdated := False;
+ Flags.Flag_Only_Elab_Warnings := True;
+
+ Hooks.Compile_Elab.all ("-r", Args, Opt_Arg);
+ exception
+ when Compilation_Error =>
+ if Flag_Expect_Failure then
+ return;
+ else
+ raise;
+ end if;
+ end;
+ Hooks.Set_Run_Options (Args (Opt_Arg .. Args'Last));
+ Hooks.Run.all;
+ exception
+ when Errorout.Option_Error =>
+ raise;
+ end Perform_Action;
+
+
+ -- Command -c xx -r
+ type Command_Compile is new Command_Comp with null record;
+ function Decode_Command (Cmd : Command_Compile; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Compile) return String;
+ procedure Decode_Option (Cmd : in out Command_Compile;
+ Option : String;
+ Arg : String;
+ Res : out Option_Res);
+ procedure Perform_Action (Cmd : in out Command_Compile;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Compile; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "-c";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Compile) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "-c [OPTS] FILEs -r UNIT [ARCH] [RUNOPTS] "
+ & "Compile, elaborate and run UNIT";
+ end Get_Short_Help;
+
+ procedure Decode_Option (Cmd : in out Command_Compile;
+ Option : String;
+ Arg : String;
+ Res : out Option_Res)
+ is
+ begin
+ if Option = "-r" or else Option = "-e" then
+ Res := Option_End;
+ else
+ Decode_Option (Command_Comp (Cmd), Option, Arg, Res);
+ end if;
+ end Decode_Option;
+
+ procedure Perform_Action (Cmd : in out Command_Compile;
+ Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ Elab_Arg : Natural;
+ Run_Arg : Natural;
+ begin
+ begin
+ Hooks.Compile_Init.all (False);
+
+ Flags.Flag_Elaborate_With_Outdated := True;
+ Flags.Flag_Only_Elab_Warnings := False;
+
+ if Args'Length > 1 and then
+ (Args (Args'First).all = "-r" or else Args (Args'First).all = "-e")
+ then
+ -- If there is no files, then load the work library.
+ Libraries.Load_Work_Library (False);
+ -- Also, load all libraries and files, so that every design unit
+ -- is known.
+ Load_All_Libraries_And_Files;
+ Elab_Arg := Args'First + 1;
+ else
+ -- If there is at least one file, do not load the work library.
+ Libraries.Load_Work_Library (True);
+ Elab_Arg := Natural'Last;
+ for I in Args'Range loop
+ declare
+ Arg : String := Args (I).all;
+ Res : Iir_Design_File;
+ Design : Iir;
+ Next_Design : Iir;
+ begin
+ if Arg = "-r" or else Arg = "-e" then
+ Elab_Arg := I + 1;
+ exit;
+ else
+ Res := Libraries.Load_File
+ (Name_Table.Get_Identifier (Arg));
+ if Errorout.Nbr_Errors > 0 then
+ raise Compilation_Error;
+ end if;
+
+ -- Put units into library.
+ Design := Get_First_Design_Unit (Res);
+ while not Is_Null (Design) loop
+ Next_Design := Get_Chain (Design);
+ Set_Chain (Design, Null_Iir);
+ Libraries.Add_Design_Unit_Into_Library (Design);
+ Design := Next_Design;
+ end loop;
+ end if;
+ end;
+ end loop;
+ if Elab_Arg = Natural'Last then
+ Libraries.Save_Work_Library;
+ return;
+ end if;
+ end if;
+
+ Hooks.Compile_Elab.all ("-c", Args (Elab_Arg .. Args'Last), Run_Arg);
+ exception
+ when Compilation_Error =>
+ if Flag_Expect_Failure then
+ return;
+ else
+ raise;
+ end if;
+ end;
+ if Args (Elab_Arg - 1).all = "-r" then
+ Hooks.Set_Run_Options (Args (Run_Arg .. Args'Last));
+ Hooks.Run.all;
+ else
+ if Run_Arg <= Args'Last then
+ Error_Msg_Option ("options after unit are ignored");
+ end if;
+ end if;
+ exception
+ when Errorout.Option_Error =>
+ raise;
+ end Perform_Action;
+
+ -- Command -a
+ type Command_Analyze is new Command_Lib with null record;
+ function Decode_Command (Cmd : Command_Analyze; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Analyze) return String;
+ procedure Decode_Option (Cmd : in out Command_Analyze;
+ Option : String;
+ Arg : String;
+ Res : out Option_Res);
+
+ procedure Perform_Action (Cmd : in out Command_Analyze;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Analyze; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "-a";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Analyze) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "-a [OPTS] FILEs Analyze FILEs";
+ end Get_Short_Help;
+
+ procedure Decode_Option (Cmd : in out Command_Analyze;
+ Option : String;
+ Arg : String;
+ Res : out Option_Res)
+ is
+ begin
+ if Option = "--expect-failure" then
+ Flag_Expect_Failure := True;
+ Res := Option_Ok;
+ else
+ Decode_Option (Command_Lib (Cmd), Option, Arg, Res);
+ end if;
+ end Decode_Option;
+
+ procedure Perform_Action (Cmd : in out Command_Analyze;
+ Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ use Types;
+ Id : Name_Id;
+ Design_File : Iir_Design_File;
+ New_Design_File : Iir_Design_File;
+ Unit : Iir;
+ Next_Unit : Iir;
+ begin
+ Setup_Libraries (True);
+
+ Hooks.Compile_Init.all (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 Errorout.Nbr_Errors > 0 then
+ raise Compilation_Error;
+ end if;
+
+ if False then
+ -- Speed up analysis: remove all previous designs.
+ -- However, this is not in the LRM...
+ Libraries.Purge_Design_File (Design_File);
+ end if;
+
+ if Design_File /= Null_Iir then
+ Unit := Get_First_Design_Unit (Design_File);
+ while Unit /= Null_Iir loop
+ 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);
+ New_Design_File := Get_Design_File (Unit);
+ end if;
+
+ Unit := Next_Unit;
+ end loop;
+
+ if Errorout.Nbr_Errors > 0 then
+ raise Compilation_Error;
+ end if;
+
+ -- Do late analysis checks.
+ Unit := Get_First_Design_Unit (New_Design_File);
+ while Unit /= Null_Iir loop
+ Sem.Sem_Analysis_Checks_List
+ (Unit, Flags.Warn_Delayed_Checks);
+ Unit := Get_Chain (Unit);
+ end loop;
+ end if;
+ end loop;
+
+ if Flag_Expect_Failure then
+ raise Compilation_Error;
+ end if;
+
+ Libraries.Save_Work_Library;
+ exception
+ when Compilation_Error =>
+ if Flag_Expect_Failure and Errorout.Nbr_Errors /= 0 then
+ return;
+ else
+ raise;
+ end if;
+ when Errorout.Option_Error =>
+ raise;
+ end Perform_Action;
+
+ -- Command -e
+ type Command_Elab is new Command_Lib with null record;
+ function Decode_Command (Cmd : Command_Elab; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Elab) return String;
+ procedure Decode_Option (Cmd : in out Command_Elab;
+ Option : String;
+ Arg : String;
+ Res : out Option_Res);
+
+ procedure Perform_Action (Cmd : in out Command_Elab;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Elab; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "-e";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Elab) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "-e [OPTS] UNIT [ARCH] Elaborate UNIT";
+ end Get_Short_Help;
+
+ procedure Decode_Option (Cmd : in out Command_Elab;
+ Option : String;
+ Arg : String;
+ Res : out Option_Res)
+ is
+ begin
+ if Option = "--expect-failure" then
+ Flag_Expect_Failure := True;
+ Res := Option_Ok;
+ elsif Option = "-o" then
+ if Arg'Length = 0 then
+ Res := Option_Arg_Req;
+ else
+ -- Silently accepted.
+ Res := Option_Arg;
+ end if;
+ --elsif Option'Length >= 4 and then Option (1 .. 4) = "-Wl," then
+ -- Res := Option_Ok;
+ else
+ Decode_Option (Command_Lib (Cmd), Option, Arg, Res);
+ end if;
+ end Decode_Option;
+
+ procedure Perform_Action (Cmd : in out Command_Elab;
+ Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ Run_Arg : Natural;
+ begin
+ Hooks.Compile_Init.all (False);
+
+ Libraries.Load_Work_Library (False);
+ Flags.Flag_Elaborate_With_Outdated := False;
+ Flags.Flag_Only_Elab_Warnings := True;
+
+ Hooks.Compile_Elab.all ("-e", Args, Run_Arg);
+ if Run_Arg <= Args'Last then
+ Error_Msg_Option ("options after unit are ignored");
+ end if;
+ if Flag_Expect_Failure then
+ raise Compilation_Error;
+ end if;
+ exception
+ when Compilation_Error =>
+ if Flag_Expect_Failure and then Errorout.Nbr_Errors > 0 then
+ return;
+ else
+ raise;
+ end if;
+ when Errorout.Option_Error =>
+ raise;
+ end Perform_Action;
+
+ -- Command dispconfig.
+ type Command_Dispconfig is new Command_Lib with null record;
+ function Decode_Command (Cmd : Command_Dispconfig; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Dispconfig) return String;
+ procedure Perform_Action (Cmd : in out Command_Dispconfig;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Dispconfig; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "--dispconfig";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Dispconfig) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "--dispconfig Disp tools path";
+ end Get_Short_Help;
+
+ procedure Perform_Action (Cmd : in out Command_Dispconfig;
+ Args : Argument_List)
+ is
+ use Ada.Text_IO;
+ use Libraries;
+ pragma Unreferenced (Cmd);
+ begin
+ if Args'Length /= 0 then
+ Error ("--dispconfig does not accept any argument");
+ raise Errorout.Option_Error;
+ end if;
+
+ Setup_Libraries (False);
+ Put ("library directory: ");
+ Put_Line (Prefix_Path.all);
+ Put_Line ("default library pathes:");
+ for I in 2 .. Get_Nbr_Pathes loop
+ Put (' ');
+ Put_Line (Name_Table.Image (Get_Path (I)));
+ end loop;
+ end Perform_Action;
+
+ -- Command Make.
+ type Command_Make is new Command_Lib with null record;
+ function Decode_Command (Cmd : Command_Make; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Make) return String;
+ procedure Perform_Action (Cmd : in out Command_Make;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Make; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "-m";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Make) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "-m [OPTS] UNIT [ARCH] Make UNIT";
+ end Get_Short_Help;
+
+ procedure Perform_Action (Cmd : in out Command_Make; Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ use Types;
+
+ Files_List : Iir_List;
+ File : Iir_Design_File;
+
+ Next_Arg : Natural;
+ Date : Date_Type;
+ Unit : Iir_Design_Unit;
+ begin
+ Extract_Elab_Unit ("-m", Args, Next_Arg);
+ Setup_Libraries (True);
+
+ -- Create list of files.
+ Files_List := Build_Dependence (Prim_Name, Sec_Name);
+
+ Date := Get_Date (Libraries.Work_Library);
+ for I in Natural loop
+ File := Get_Nth_Element (Files_List, I);
+ exit when File = Null_Iir;
+
+ if Get_Library (File) = Libraries.Work_Library then
+ -- Mark this file as analyzed.
+ Set_Analysis_Time_Stamp (File, Files_Map.Get_Os_Time_Stamp);
+
+ Unit := Get_First_Design_Unit (File);
+ while Unit /= Null_Iir loop
+ if Get_Date (Unit) = Date_Analyzed
+ or else Get_Date (Unit) in Date_Valid
+ then
+ Date := Date + 1;
+ Set_Date (Unit, Date);
+ end if;
+ Unit := Get_Chain (Unit);
+ end loop;
+ end if;
+ end loop;
+ Set_Date (Libraries.Work_Library, Date);
+ Libraries.Save_Work_Library;
+ end Perform_Action;
+
+ -- Command Gen_Makefile.
+ type Command_Gen_Makefile is new Command_Lib with null record;
+ function Decode_Command (Cmd : Command_Gen_Makefile; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Gen_Makefile) return String;
+ procedure Perform_Action (Cmd : in out Command_Gen_Makefile;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Gen_Makefile; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "--gen-makefile";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Gen_Makefile) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "--gen-makefile [OPTS] UNIT [ARCH] Generate a Makefile for UNIT";
+ end Get_Short_Help;
+
+ function Is_Makeable_File (File : Iir_Design_File) return Boolean is
+ begin
+ if File = Std_Package.Std_Standard_File then
+ return False;
+ end if;
+ return True;
+ end Is_Makeable_File;
+
+ procedure Perform_Action (Cmd : in out Command_Gen_Makefile;
+ Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ use Types;
+ use Ada.Text_IO;
+ use Ada.Command_Line;
+ use Name_Table;
+
+ HT : constant Character := Ada.Characters.Latin_1.HT;
+ Files_List : Iir_List;
+ File : Iir_Design_File;
+
+ Lib : Iir_Library_Declaration;
+ Dir_Id : Name_Id;
+
+ Next_Arg : Natural;
+ begin
+ Extract_Elab_Unit ("--gen-makefile", Args, Next_Arg);
+ Setup_Libraries (True);
+ Files_List := Build_Dependence (Prim_Name, Sec_Name);
+
+ Put_Line ("# Makefile automatically generated by ghdl");
+ Put ("# Version: ");
+ Put (Version.Ghdl_Version);
+ Put (" - ");
+ if Version_String /= null then
+ Put (Version_String.all);
+ end if;
+ New_Line;
+ Put_Line ("# Command used to generate this makefile:");
+ Put ("# ");
+ Put (Command_Name);
+ for I in 1 .. Argument_Count loop
+ Put (' ');
+ Put (Argument (I));
+ end loop;
+ New_Line;
+
+ New_Line;
+
+ Put ("GHDL=");
+ Put_Line (Command_Name);
+
+ -- Extract options for command line.
+ Put ("GHDLFLAGS=");
+ for I in 2 .. Argument_Count loop
+ declare
+ Arg : String := Argument (I);
+ begin
+ if Arg (1) = '-' then
+ if (Arg'Length > 10 and then Arg (1 .. 10) = "--workdir=")
+ or else (Arg'Length > 7 and then Arg (1 .. 7) = "--ieee=")
+ or else (Arg'Length > 6 and then Arg (1 .. 6) = "--std=")
+ or else (Arg'Length > 7 and then Arg (1 .. 7) = "--work=")
+ or else (Arg'Length > 2 and then Arg (1 .. 2) = "-P")
+ then
+ Put (" ");
+ Put (Arg);
+ end if;
+ end if;
+ end;
+ end loop;
+ New_Line;
+
+ Put ("GHDLRUNFLAGS=");
+ for I in Next_Arg .. Args'Last loop
+ Put (' ');
+ Put (Args (I).all);
+ end loop;
+ New_Line;
+ New_Line;
+
+ Put_Line ("# Default target : elaborate");
+ Put_Line ("all : elab");
+ New_Line;
+
+ Put_Line ("# Elaborate target. Almost useless");
+ Put_Line ("elab : force");
+ Put (HT & "$(GHDL) -c $(GHDLFLAGS) -e ");
+ Put (Prim_Name.all);
+ if Sec_Name /= null then
+ Put (' ');
+ Put (Sec_Name.all);
+ end if;
+ New_Line;
+ New_Line;
+
+ Put_Line ("# Run target");
+ Put_Line ("run : force");
+ Put (HT & "$(GHDL) -c $(GHDLFLAGS) -r ");
+ Put (Prim_Name.all);
+ if Sec_Name /= null then
+ Put (' ');
+ Put (Sec_Name.all);
+ end if;
+ Put (" $(GHDLRUNFLAGS)");
+ New_Line;
+ New_Line;
+
+ Put_Line ("# Targets to analyze libraries");
+ Put_Line ("init: force");
+ for I in Natural loop
+ File := Get_Nth_Element (Files_List, I);
+ exit when File = Null_Iir;
+ Dir_Id := Get_Design_File_Directory (File);
+ if not Is_Makeable_File (File) then
+ -- Builtin file.
+ null;
+ elsif Dir_Id /= Files_Map.Get_Home_Directory then
+ -- Not locally built file.
+ Put (HT & "# ");
+ Put (Image (Dir_Id));
+ Put (Image (Get_Design_File_Filename (File)));
+ New_Line;
+ else
+
+ Put (HT & "$(GHDL) -a $(GHDLFLAGS)");
+ Lib := Get_Library (File);
+ if Lib /= Libraries.Work_Library then
+ -- Overwrite some options.
+ Put (" --work=");
+ Put (Image (Get_Identifier (Lib)));
+ Dir_Id := Get_Library_Directory (Lib);
+ Put (" --workdir=");
+ if Dir_Id = Libraries.Local_Directory then
+ Put (".");
+ else
+ Put (Image (Dir_Id));
+ end if;
+ end if;
+ Put (' ');
+ Put (Image (Get_Design_File_Filename (File)));
+ New_Line;
+ end if;
+ end loop;
+ New_Line;
+
+ Put_Line ("force:");
+ end Perform_Action;
+
+ procedure Register_Commands is
+ begin
+ Register_Command (new Command_Analyze);
+ Register_Command (new Command_Elab);
+ Register_Command (new Command_Run);
+ Register_Command (new Command_Compile);
+ Register_Command (new Command_Make);
+ Register_Command (new Command_Gen_Makefile);
+ Register_Command (new Command_Dispconfig);
+ end Register_Commands;
+
+end Ghdlcomp;
diff --git a/translate/ghdldrv/ghdlcomp.ads b/translate/ghdldrv/ghdlcomp.ads
new file mode 100644
index 0000000..f803ca4
--- /dev/null
+++ b/translate/ghdldrv/ghdlcomp.ads
@@ -0,0 +1,67 @@
+-- GHDL driver - compile 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 GNAT.OS_Lib; use GNAT.OS_Lib;
+
+package Ghdlcomp is
+ -- This procedure is called at start of commands which call
+ -- finish_compilation to generate code.
+ type Compile_Init_Acc is access procedure (Analyze_Only : Boolean);
+
+ -- This procedure is called for elaboration.
+ -- CMD_NAME is the name of the command, used to report errors.
+ -- ARGS is the argument list, starting from the unit name to be elaborated.
+ -- The procedure should extract the unit.
+ -- OPT_ARG is the index of the first argument from ARGS to be used as
+ -- a run option.
+ type Compile_Elab_Acc is access procedure
+ (Cmd_Name : String; Args : Argument_List; Opt_Arg : out Natural);
+
+ -- Use ARGS as run options.
+ -- Should do all the work.
+ type Set_Run_Options_Acc is access
+ procedure (Args : Argument_List);
+
+ -- Run the simulation.
+ -- All the parameters were set through calling Compile_Elab and
+ -- Set_Run_Options.
+ type Run_Acc is access procedure;
+
+ -- Called when an analysis/elaboration option is decoded.
+ -- Return True if OPTION is known (and do the side effects).
+ -- No parameters are allowed.
+ type Decode_Option_Acc is access function (Option : String) return Boolean;
+
+ -- Disp help for options decoded by Decode_Option.
+ type Disp_Long_Help_Acc is access procedure;
+
+ -- All the hooks gathered.
+ -- A record is used to be sure all hooks are set.
+ type Hooks_Type is record
+ Compile_Init : Compile_Init_Acc := null;
+ Compile_Elab : Compile_Elab_Acc := null;
+ Set_Run_Options : Set_Run_Options_Acc := null;
+ Run : Run_Acc := null;
+ Decode_Option : Decode_Option_Acc := null;
+ Disp_Long_Help : Disp_Long_Help_Acc := null;
+ end record;
+
+ Hooks : Hooks_Type;
+
+ -- Register commands.
+ procedure Register_Commands;
+end Ghdlcomp;
diff --git a/translate/ghdldrv/ghdldrv.adb b/translate/ghdldrv/ghdldrv.adb
new file mode 100644
index 0000000..d863f61
--- /dev/null
+++ b/translate/ghdldrv/ghdldrv.adb
@@ -0,0 +1,1705 @@
+-- GHDL driver - commands invoking gcc.
+-- 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.Command_Line; use Ada.Command_Line;
+with Ada.Text_IO; use Ada.Text_IO;
+with Ada.Characters.Latin_1;
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+with GNAT.Table;
+with GNAT.Dynamic_Tables;
+with Libraries;
+with Name_Table; use Name_Table;
+with Std_Package;
+with Types; use Types;
+with Iirs; use Iirs;
+with Files_Map;
+with Flags;
+with Configuration;
+--with Disp_Tree;
+with Default_Pathes;
+with Interfaces.C_Streams;
+with System;
+with Ghdlmain; use Ghdlmain;
+with Ghdllocal; use Ghdllocal;
+with Version;
+
+package body Ghdldrv is
+ -- Name of the tools used.
+ Compiler_Cmd : String_Access := null;
+ Post_Processor_Cmd : String_Access := null;
+ Assembler_Cmd : constant String := "as";
+ Linker_Cmd : constant String := "gcc";
+
+ -- Path of the tools.
+ Compiler_Path : String_Access;
+ Post_Processor_Path : String_Access;
+ Assembler_Path : String_Access;
+ Linker_Path : String_Access;
+
+ -- Set by the '-o' option: the output filename. If the option is not
+ -- present, then null.
+ Output_File : String_Access;
+
+ -- "-o" string.
+ Dash_O : String_Access;
+
+ -- "-S" string.
+ Dash_S : String_Access;
+
+ -- "-quiet" option.
+ Dash_Quiet : String_Access;
+
+ type Compile_Kind_Type is (Compile_Mcode, Compile_Gcc, Compile_Debug);
+ Compile_Kind : Compile_Kind_Type := Compile_Gcc;
+
+ -- If set, do not assmble
+ Flag_Asm : Boolean;
+
+ -- If true, executed commands are displayed.
+ Flag_Disp_Commands : Boolean;
+
+ -- Flag not quiet
+ Flag_Not_Quiet : Boolean;
+
+ -- True if failure expected.
+ Flag_Expect_Failure : Boolean;
+
+ -- Argument table for the tools.
+ -- Each table low bound is 1 so that the length of a table is equal to
+ -- the last bound.
+ package Argument_Table_Pkg is new GNAT.Dynamic_Tables
+ (Table_Component_Type => String_Access,
+ Table_Index_Type => Integer,
+ Table_Low_Bound => 1,
+ Table_Initial => 4,
+ Table_Increment => 100);
+ use Argument_Table_Pkg;
+
+ -- Arguments for tools.
+ Compiler_Args : Argument_Table_Pkg.Instance;
+ Postproc_Args : Argument_Table_Pkg.Instance;
+ Assembler_Args : Argument_Table_Pkg.Instance;
+ Linker_Args : Argument_Table_Pkg.Instance;
+
+ -- Display the program spawned in Flag_Disp_Commands is TRUE.
+ -- Raise COMPILE_ERROR in case of failure.
+ procedure My_Spawn (Program_Name : String; Args : Argument_List)
+ is
+ Status : Integer;
+ begin
+ if Flag_Disp_Commands then
+ Put (Program_Name);
+ for I in Args'Range loop
+ Put (' ');
+ Put (Args (I).all);
+ end loop;
+ New_Line;
+ end if;
+ Status := Spawn (Program_Name, Args);
+ if Status = 0 then
+ return;
+ elsif Status = 1 then
+ Error ("compilation error");
+ raise Compile_Error;
+ else
+ Error ("exec error");
+ raise Exec_Error;
+ end if;
+ end My_Spawn;
+
+ -- Compile FILE with additional argument OPTS.
+ procedure Do_Compile (Options : Argument_List; File : String)
+ is
+ Obj_File : String_Access;
+ Asm_File : String_Access;
+ Post_File : String_Access;
+ Success : Boolean;
+ begin
+ -- Create post file.
+ case Compile_Kind is
+ when Compile_Debug =>
+ Post_File := Append_Suffix (File, Post_Suffix);
+ when others =>
+ null;
+ end case;
+
+ -- Create asm file.
+ case Compile_Kind is
+ when Compile_Gcc
+ | Compile_Debug =>
+ Asm_File := Append_Suffix (File, Asm_Suffix);
+ when Compile_Mcode =>
+ null;
+ end case;
+
+ -- Create obj file.
+ if Compile_Kind = Compile_Mcode or else not Flag_Asm
+ then
+ Obj_File := Append_Suffix (File, Get_Object_Suffix.all);
+ end if;
+
+ -- Compile.
+ declare
+ P : Natural;
+ Nbr_Args : Natural := Last (Compiler_Args) + Options'Length + 4;
+ Args : Argument_List (1 .. Nbr_Args);
+ begin
+ P := 0;
+ for I in First .. Last (Compiler_Args) loop
+ P := P + 1;
+ Args (P) := Compiler_Args.Table (I);
+ end loop;
+ for I in Options'Range loop
+ P := P + 1;
+ Args (P) := Options (I);
+ end loop;
+
+ -- Add -quiet.
+ if not Flag_Not_Quiet then
+ P := P + 1;
+ Args (P) := Dash_Quiet;
+ end if;
+
+ Args (P + 1) := Dash_O;
+ case Compile_Kind is
+ when Compile_Debug =>
+ Args (P + 2) := Post_File;
+ when Compile_Gcc =>
+ Args (P + 2) := Asm_File;
+ when Compile_Mcode =>
+ Args (P + 2) := Obj_File;
+ end case;
+ Args (P + 3) := new String'(File);
+
+ My_Spawn (Compiler_Path.all, Args (1 .. P + 3));
+ Free (Args (P + 3));
+ exception
+ when Compile_Error =>
+ -- Delete temporary file in case of error.
+ Delete_File (Args (P + 2).all, Success);
+ -- FIXME: delete object file too ?
+ raise;
+ end;
+
+ -- Post-process.
+ if Compile_Kind = Compile_Debug then
+ declare
+ P : Natural;
+ Nbr_Args : Natural := Last (Postproc_Args) + 4;
+ Args : Argument_List (1 .. Nbr_Args);
+ begin
+ P := 0;
+ for I in First .. Last (Postproc_Args) loop
+ P := P + 1;
+ Args (P) := Postproc_Args.Table (I);
+ end loop;
+
+ if not Flag_Not_Quiet then
+ P := P + 1;
+ Args (P) := Dash_Quiet;
+ end if;
+
+ Args (P + 1) := Dash_O;
+ Args (P + 2) := Asm_File;
+ Args (P + 3) := Post_File;
+ My_Spawn (Post_Processor_Path.all, Args (1 .. P + 3));
+ end;
+
+ Free (Post_File);
+ end if;
+
+ -- Assemble.
+ if Compile_Kind >= Compile_Gcc then
+ if Flag_Expect_Failure then
+ Delete_File (Asm_File.all, Success);
+ elsif not Flag_Asm then
+ declare
+ P : Natural;
+ Nbr_Args : Natural := Last (Assembler_Args) + 4;
+ Args : Argument_List (1 .. Nbr_Args);
+ Success : Boolean;
+ begin
+ P := 0;
+ for I in First .. Last (Assembler_Args) loop
+ P := P + 1;
+ Args (P) := Assembler_Args.Table (I);
+ end loop;
+
+ Args (P + 1) := Dash_O;
+ Args (P + 2) := Obj_File;
+ Args (P + 3) := Asm_File;
+ My_Spawn (Assembler_Path.all, Args (1 .. P + 3));
+ Delete_File (Asm_File.all, Success);
+ end;
+ end if;
+ end if;
+
+ Free (Asm_File);
+ Free (Obj_File);
+ end Do_Compile;
+
+ package Filelist is new GNAT.Table
+ (Table_Component_Type => String_Access,
+ Table_Index_Type => Natural,
+ Table_Low_Bound => 1,
+ Table_Initial => 16,
+ Table_Increment => 100);
+
+ -- Read a list of files from file FILENAME.
+ -- Lines starting with a '#' are ignored (comments)
+ -- Lines starting with a '>' are directory lines
+ -- If first character of a line is a '@', it is replaced with
+ -- the prefix_path.
+ -- If TO_OBJ is true, then each file is converted to an object file name
+ -- (suffix is replaced by the object file extension).
+ procedure Add_File_List (Filename : String; To_Obj : Boolean)
+ is
+ use Interfaces.C_Streams;
+ use System;
+ use Ada.Characters.Latin_1;
+
+ Dir : String (1 .. max_path_len);
+ Dir_Len : Natural;
+ Line : String (1 .. max_path_len);
+ Stream : Interfaces.C_Streams.FILEs;
+ Mode : constant String := "rt" & Ghdllocal.Nul;
+ L : Natural;
+ File : String_Access;
+ begin
+ Line (1 .. Filename'Length) := Filename;
+ Line (Filename'Length + 1) := Ghdllocal.Nul;
+ Stream := fopen (Line'Address, Mode'Address);
+ if Stream = NULL_Stream then
+ Error ("cannot open " & Filename);
+ return;
+ end if;
+ Dir_Len := 0;
+ loop
+ exit when fgets (Line'Address, Line'Length, Stream) = NULL_Stream;
+ if Line (1) /= '#' then
+ -- Compute string length.
+ L := 0;
+ while Line (L + 1) /= Ghdllocal.Nul loop
+ L := L + 1;
+ end loop;
+
+ -- Remove trailing NL.
+ while L > 0 and then (Line (L) = LF or Line (L) = CR) loop
+ L := L - 1;
+ end loop;
+
+ if Line (1) = '>' then
+ Dir_Len := L - 1;
+ Dir (1 .. Dir_Len) := Line (2 .. L);
+ else
+ if Line (1) = '@' then
+ File := new String'(Prefix_Path.all & Line (2 .. L));
+ else
+ if To_Obj then
+ File := new String'(Dir (1 .. Dir_Len)
+ & Get_Base_Name (Line (1 .. L))
+ & Get_Object_Suffix.all);
+ else
+ File := new String'(Line (1 .. L));
+ end if;
+ end if;
+
+ Filelist.Increment_Last;
+ Filelist.Table (Filelist.Last) := File;
+
+ Dir_Len := 0;
+ end if;
+ end if;
+ end loop;
+ if fclose (Stream) /= 0 then
+ Error ("cannot close " & Filename);
+ end if;
+ end Add_File_List;
+
+ function Get_Object_Filename (File : Iir_Design_File) return String
+ is
+ Dir : Name_Id;
+ Name : Name_Id;
+ begin
+ Dir := Get_Library_Directory (Get_Library (File));
+ Name := Get_Design_File_Filename (File);
+ return Image (Dir) & Get_Base_Name (Image (Name))
+ & Get_Object_Suffix.all;
+ end Get_Object_Filename;
+
+ Last_Stamp : Time_Stamp_Id;
+ Last_Stamp_File : Iir;
+
+ function Is_File_Outdated (Design_File : Iir_Design_File) return Boolean
+ is
+ use Files_Map;
+
+ Dir : Name_Id;
+ Name : Name_Id;
+
+ File : Source_File_Entry;
+ begin
+ -- Std.Standard is never outdated.
+ if Design_File = Std_Package.Std_Standard_File then
+ return False;
+ end if;
+
+ Dir := Get_Library_Directory (Get_Library (Design_File));
+ Name := Get_Design_File_Filename (Design_File);
+ declare
+ Obj_Pathname : String := Get_Object_Filename (Design_File) & Nul;
+ Stamp : Time_Stamp_Id;
+ begin
+ Stamp := Get_File_Time_Stamp (Obj_Pathname'Address);
+
+ -- If the object file does not exist, recompile the file.
+ if Stamp = Null_Time_Stamp then
+ if Flag_Verbose then
+ Put_Line ("no object file for " & Image (Name));
+ end if;
+ return True;
+ end if;
+
+ -- Keep the time stamp of the most recently analyzed unit.
+ if Last_Stamp = Null_Time_Stamp
+ or else Is_Gt (Stamp, Last_Stamp)
+ then
+ Last_Stamp := Stamp;
+ Last_Stamp_File := Design_File;
+ end if;
+ end;
+
+ -- 2) file has been modified.
+ File := Load_Source_File (Get_Design_File_Directory (Design_File),
+ Get_Design_File_Filename (Design_File));
+ if not Is_Eq (Get_File_Time_Stamp (File),
+ Get_File_Time_Stamp (Design_File))
+ then
+ if Flag_Verbose then
+ Put_Line ("file " & Image (Get_File_Name (File))
+ & " has been modified");
+ end if;
+ return True;
+ end if;
+
+ return False;
+ end Is_File_Outdated;
+
+ function Is_Unit_Outdated (Unit : Iir_Design_Unit) return Boolean
+ is
+ Design_File : Iir_Design_File;
+ begin
+ -- Std.Standard is never outdated.
+ if Unit = Std_Package.Std_Standard_Unit then
+ return False;
+ end if;
+
+ Design_File := Get_Design_File (Unit);
+
+ -- 1) not yet analyzed:
+ if Get_Date (Unit) not in Date_Valid then
+ if Flag_Verbose then
+ Disp_Library_Unit (Get_Library_Unit (Unit));
+ Put_Line (" was not analyzed");
+ end if;
+ return True;
+ end if;
+
+ -- 3) the object file does not exist.
+ -- Already checked.
+
+ -- 4) one of the dependence is newer
+ declare
+ Depends : Iir_List;
+ El : Iir;
+ Dep : Iir_Design_Unit;
+ Stamp : Time_Stamp_Id;
+ Dep_File : Iir_Design_File;
+ begin
+ Depends := Get_Dependence_List (Unit);
+ Stamp := Get_Analysis_Time_Stamp (Design_File);
+ 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;
+
+ return False;
+ end Is_Unit_Outdated;
+
+ procedure Add_Argument (Inst : in out Instance; Arg : String_Access)
+ is
+ begin
+ Increment_Last (Inst);
+ Inst.Table (Last (Inst)) := Arg;
+ end Add_Argument;
+
+ -- Convert option "-Wx,OPTIONS" to arguments for tool X.
+ procedure Add_Arguments (Inst : in out Instance; Opt : String) is
+ begin
+ Add_Argument (Inst, new String'(Opt (Opt'First + 4 .. Opt'Last)));
+ end Add_Arguments;
+
+ procedure Tool_Not_Found (Name : String) is
+ begin
+ Error ("installation problem: " & Name & " not found");
+ raise Option_Error;
+ end Tool_Not_Found;
+
+ procedure Set_Tools_Name
+ is
+ begin
+ -- Set tools name.
+ if Compiler_Cmd = null then
+ case Compile_Kind is
+ when Compile_Debug =>
+ Compiler_Cmd := new String'(Default_Pathes.Compiler_Debug);
+ when Compile_Gcc =>
+ Compiler_Cmd := new String'(Default_Pathes.Compiler_Gcc);
+ when Compile_Mcode =>
+ Compiler_Cmd := new String'(Default_Pathes.Compiler_Mcode);
+ end case;
+ end if;
+ if Post_Processor_Cmd = null then
+ Post_Processor_Cmd := new String'(Default_Pathes.Post_Processor);
+ end if;
+ end Set_Tools_Name;
+
+ procedure Locate_Tools
+ is
+ begin
+ Compiler_Path := Locate_Exec_On_Path (Compiler_Cmd.all);
+ if Compiler_Path = null then
+ Tool_Not_Found (Compiler_Cmd.all);
+ end if;
+ if Compile_Kind >= Compile_Debug then
+ Post_Processor_Path := Locate_Exec_On_Path (Post_Processor_Cmd.all);
+ if Post_Processor_Path = null then
+ Tool_Not_Found (Post_Processor_Cmd.all);
+ end if;
+ end if;
+ if Compile_Kind >= Compile_Gcc then
+ Assembler_Path := Locate_Exec_On_Path (Assembler_Cmd);
+ if Assembler_Path = null and not Flag_Asm then
+ Tool_Not_Found (Assembler_Cmd);
+ end if;
+ end if;
+ Linker_Path := Locate_Exec_On_Path (Linker_Cmd);
+ if Linker_Path = null then
+ Tool_Not_Found (Linker_Cmd);
+ end if;
+ Dash_O := new String'("-o");
+ Dash_S := new String'("-S");
+ Dash_Quiet := new String'("-quiet");
+ end Locate_Tools;
+
+ procedure Setup_Compiler (Load : Boolean)
+ is
+ use Libraries;
+ begin
+ Set_Tools_Name;
+ Locate_Tools;
+ Setup_Libraries (Load);
+ for I in 2 .. Get_Nbr_Pathes loop
+ Add_Argument (Compiler_Args,
+ new String'("-P" & Image (Get_Path (I))));
+ end loop;
+ end Setup_Compiler;
+
+ type Command_Comp is abstract new Command_Lib with null record;
+
+ -- Setup GHDL.
+ procedure Init (Cmd : in out Command_Comp);
+
+ -- Handle:
+ -- all ghdl flags.
+ -- some GCC flags.
+ procedure Decode_Option (Cmd : in out Command_Comp;
+ Option : String;
+ Arg : String;
+ Res : out Option_Res);
+
+ procedure Disp_Long_Help (Cmd : Command_Comp);
+
+ procedure Init (Cmd : in out Command_Comp)
+ is
+ begin
+ -- Init options.
+ Flag_Not_Quiet := False;
+ Flag_Disp_Commands := False;
+ Flag_Asm := False;
+ Compile_Kind := Compile_Gcc;
+ Flag_Expect_Failure := False;
+ Output_File := null;
+
+ -- Initialize argument tables.
+ Init (Compiler_Args);
+ Init (Postproc_Args);
+ Init (Assembler_Args);
+ Init (Linker_Args);
+ Init (Command_Lib (Cmd));
+ end Init;
+
+ procedure Decode_Option (Cmd : in out Command_Comp;
+ Option : String;
+ Arg : String;
+ Res : out Option_Res)
+ is
+ Str : String_Access;
+ begin
+ Res := Option_Bad;
+ if Option = "-v" and then Flag_Verbose = False then
+ -- Note: this is also decoded for command_lib, but we set
+ -- Flag_Disp_Commands too.
+ Flag_Verbose := True;
+ --Flags.Verbose := True;
+ Flag_Disp_Commands := True;
+ Res := Option_Ok;
+ elsif Option'Length > 8 and then Option (1 .. 8) = "--GHDL1=" then
+ Compiler_Cmd := new String'(Option (9 .. Option'Last));
+ Res := Option_Ok;
+ elsif Option = "-S" then
+ Flag_Asm := True;
+ Res := Option_Ok;
+ elsif Option = "--post" then
+ Compile_Kind := Compile_Debug;
+ Res := Option_Ok;
+ elsif Option = "--mcode" then
+ Compile_Kind := Compile_Mcode;
+ Res := Option_Ok;
+ elsif Option = "-o" then
+ if Arg'Length = 0 then
+ Res := Option_Arg_Req;
+ else
+ Output_File := new String'(Arg);
+ Res := Option_Arg;
+ end if;
+ elsif Option'Length > 4
+ and then Option (2) = 'W' and then Option (4) = ','
+ then
+ if Option (3) = 'c' then
+ Add_Arguments (Compiler_Args, Option);
+ elsif Option (3) = 'a' then
+ Add_Arguments (Assembler_Args, Option);
+ elsif Option (3) = 'p' then
+ Add_Arguments (Postproc_Args, Option);
+ elsif Option (3) = 'l' then
+ Add_Arguments (Linker_Args, Option);
+ else
+ Error
+ ("unknown tool name in '-W" & Option (3) & ",' option");
+ raise Option_Error;
+ end if;
+ Res := Option_Ok;
+ elsif Option'Length >= 2 and then Option (2) = 'g' then
+ -- Debugging option.
+ Str := new String'(Option);
+ Add_Argument (Compiler_Args, Str);
+ Add_Argument (Linker_Args, Str);
+ Res := Option_Ok;
+ elsif Option'Length >= 2
+ and then (Option (2) = 'O' or Option (2) = 'f')
+ then
+ -- Optimization option.
+ Add_Argument (Compiler_Args, new String'(Option));
+ Res := Option_Ok;
+ elsif Option = "-Q" then
+ Flag_Not_Quiet := True;
+ Res := Option_Ok;
+ elsif Option = "--expect-failure" then
+ Add_Argument (Compiler_Args, new String'(Option));
+ Flag_Expect_Failure := True;
+ Res := Option_Ok;
+ elsif Flags.Parse_Option (Option) then
+ Add_Argument (Compiler_Args, new String'(Option));
+ Res := Option_Ok;
+ else
+ Decode_Option (Command_Lib (Cmd), Option, Arg, Res);
+ end if;
+ end Decode_Option;
+
+ procedure Disp_Long_Help (Cmd : Command_Comp)
+ is
+ use Ada.Text_IO;
+ begin
+ Disp_Long_Help (Command_Lib (Cmd));
+ Put_Line (" -v Be verbose");
+ Put_Line (" --GHDL1=PATH Set the path of the ghdl1 compiler");
+ Put_Line (" -S Do not assemble");
+ Put_Line (" -o FILE Set the name of the output file");
+ Put_Line (" -WX,OPTION Pass OPTION to X, where X is one of");
+ Put_Line (" c: compiler, a: assembler, l: linker");
+ Put_Line (" -g[XX] Pass debugging option to the compiler");
+ Put_Line (" -O[XX]/-f[XX] Pass optimization option to the compiler");
+ Put_Line (" -Q Do not add -quiet option to compiler");
+ Put_Line (" --expect-failure Expect analysis/elaboration failure");
+ end Disp_Long_Help;
+
+ -- Command dispconfig.
+ type Command_Dispconfig is new Command_Comp with null record;
+ function Decode_Command (Cmd : Command_Dispconfig; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Dispconfig) return String;
+ procedure Perform_Action (Cmd : in out Command_Dispconfig;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Dispconfig; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "--dispconfig";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Dispconfig) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "--dispconfig Disp tools path";
+ end Get_Short_Help;
+
+ procedure Perform_Action (Cmd : in out Command_Dispconfig;
+ Args : Argument_List)
+ is
+ use Ada.Text_IO;
+ use Libraries;
+ pragma Unreferenced (Cmd);
+ begin
+ if Args'Length /= 0 then
+ Error ("--dispconfig does not accept any argument");
+ raise Option_Error;
+ end if;
+
+ Set_Tools_Name;
+ Put ("compiler command: ");
+ Put_Line (Compiler_Cmd.all);
+ if Compile_Kind >= Compile_Debug then
+ Put ("post-processor command: ");
+ Put_Line (Post_Processor_Cmd.all);
+ end if;
+ if Compile_Kind >= Compile_Gcc then
+ Put ("assembler command: ");
+ Put_Line (Assembler_Cmd);
+ end if;
+ Put ("linker command: ");
+ Put_Line (Linker_Cmd);
+ Setup_Libraries (False);
+ Put ("library directory: ");
+ Put_Line (Prefix_Path.all);
+ Locate_Tools;
+ Put ("compiler path: ");
+ Put_Line (Compiler_Path.all);
+ if Compile_Kind >= Compile_Debug then
+ Put ("post-processor path: ");
+ Put_Line (Post_Processor_Path.all);
+ end if;
+ if Compile_Kind >= Compile_Gcc then
+ Put ("assembler path: ");
+ Put_Line (Assembler_Path.all);
+ end if;
+ Put ("linker path: ");
+ Put_Line (Linker_Path.all);
+ Put_Line ("default library pathes:");
+ for I in 2 .. Get_Nbr_Pathes loop
+ Put (' ');
+ Put_Line (Image (Get_Path (I)));
+ end loop;
+ end Perform_Action;
+
+ -- Command Analyze.
+ type Command_Analyze is new Command_Comp with null record;
+ function Decode_Command (Cmd : Command_Analyze; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Analyze) return String;
+ procedure Perform_Action (Cmd : in out Command_Analyze;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Analyze; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "-a";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Analyze) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "-a [OPTS] FILEs Analyze FILEs";
+ end Get_Short_Help;
+
+ procedure Perform_Action (Cmd : in out Command_Analyze;
+ Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ Nil_Opt : Argument_List (2 .. 1);
+ begin
+ if Args'Length = 0 then
+ Error ("no file to analyze");
+ raise Option_Error;
+ end if;
+ Setup_Compiler (False);
+
+ for I in Args'Range loop
+ Do_Compile (Nil_Opt, Args (I).all);
+ end loop;
+ end Perform_Action;
+
+ -- Elaboration.
+
+ Base_Name : String_Access;
+ Elab_Name : String_Access;
+ Filelist_Name : String_Access;
+ Unit_Name : String_Access;
+
+ procedure Set_Elab_Units (Cmd_Name : String;
+ Args : Argument_List;
+ Run_Arg : out Natural)
+ is
+ begin
+ Extract_Elab_Unit (Cmd_Name, Args, Run_Arg);
+ if Sec_Name = null then
+ Base_Name := Prim_Name;
+ Unit_Name := Prim_Name;
+ else
+ Base_Name := new String'(Prim_Name.all & '-' & Sec_Name.all);
+ Unit_Name := new String'(Prim_Name.all & '(' & Sec_Name.all & ')');
+ end if;
+
+ Elab_Name := new String'(Elab_Prefix & Base_Name.all);
+ Filelist_Name := null;
+
+ if Output_File = null then
+ Output_File := new String'(Base_Name.all);
+ end if;
+ end Set_Elab_Units;
+
+ procedure Set_Elab_Units (Cmd_Name : String; Args : Argument_List)
+ is
+ Next_Arg : Natural;
+ begin
+ Set_Elab_Units (Cmd_Name, Args, Next_Arg);
+ if Next_Arg <= Args'Last then
+ Error ("too many unit names for command '" & Cmd_Name & "'");
+ raise Option_Error;
+ end if;
+ end Set_Elab_Units;
+
+ procedure Bind
+ is
+ Comp_List : Argument_List (1 .. 4);
+ begin
+ Filelist_Name := new String'(Elab_Name.all & List_Suffix);
+
+ Comp_List (1) := new String'("--elab");
+ Comp_List (2) := Unit_Name;
+ Comp_List (3) := new String'("-l");
+ Comp_List (4) := Filelist_Name;
+ Do_Compile (Comp_List, Elab_Name.all);
+ Free (Comp_List (3));
+ Free (Comp_List (1));
+ end Bind;
+
+ procedure Bind_Anaelab (Files : Argument_List)
+ is
+ Comp_List : Argument_List (1 .. 2 * Files'Length + 2);
+ Flag_C : String_Access;
+ Index : Natural;
+ begin
+ Comp_List (1) := new String'("--anaelab");
+ Comp_List (2) := Unit_Name;
+ Flag_C := new String'("-c");
+ Index := 3;
+ for I in Files'Range loop
+ Comp_List (Index) := Flag_C;
+ Comp_List (Index + 1) := Files (I);
+ Index := Index + 2;
+ end loop;
+ Do_Compile (Comp_List, Elab_Name.all);
+ Free (Flag_C);
+ Free (Comp_List (1));
+ end Bind_Anaelab;
+
+ procedure Link (Add_Std : Boolean;
+ Disp_Only : Boolean)
+ is
+ Last_File : Natural;
+ begin
+ -- read files list
+ if Filelist_Name /= null then
+ Add_File_List (Filelist_Name.all, True);
+ end if;
+ Last_File := Filelist.Last;
+ Add_File_List (Prefix_Path.all & "grt" & List_Suffix, False);
+
+ -- call the linker
+ declare
+ P : Natural;
+ Nbr_Args : Natural := Last (Linker_Args) + Filelist.Last + 4;
+ Args : Argument_List (1 .. Nbr_Args);
+ Obj_File : String_Access;
+ Std_File : String_Access;
+ begin
+ Obj_File := Append_Suffix
+ (Elab_Name.all, Get_Object_Suffix.all);
+ P := 0;
+ Args (P + 1) := Dash_O;
+ Args (P + 2) := Output_File;
+ Args (P + 3) := Obj_File;
+ P := P + 3;
+ if Add_Std then
+ Std_File := new
+ String'(Prefix_Path.all
+ & Get_Version_Path & Directory_Separator
+ & "std" & Directory_Separator
+ & "std_standard" & Get_Object_Suffix.all);
+ P := P + 1;
+ Args (P) := Std_File;
+ else
+ Std_File := null;
+ end if;
+
+ -- Object files of the design.
+ for I in Filelist.First .. Last_File loop
+ P := P + 1;
+ Args (P) := Filelist.Table (I);
+ end loop;
+ -- User added options.
+ for I in First .. Last (Linker_Args) loop
+ P := P + 1;
+ Args (P) := Linker_Args.Table (I);
+ end loop;
+ -- GRT files (should be the last one, since it contains an
+ -- optional main).
+ for I in Last_File + 1 .. Filelist.Last loop
+ P := P + 1;
+ Args (P) := Filelist.Table (I);
+ end loop;
+
+ if Disp_Only then
+ for I in 3 .. P loop
+ Put_Line (Args (I).all);
+ end loop;
+ else
+ My_Spawn (Linker_Path.all, Args (1 .. P));
+ end if;
+
+ Free (Obj_File);
+ Free (Std_File);
+ end;
+
+ for I in Filelist.First .. Filelist.Last loop
+ Free (Filelist.Table (I));
+ end loop;
+ end Link;
+
+ -- Command Elab.
+ type Command_Elab is new Command_Comp with null record;
+ function Decode_Command (Cmd : Command_Elab; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Elab) return String;
+ procedure Perform_Action (Cmd : in out Command_Elab;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Elab; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "-e";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Elab) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "-e [OPTS] UNIT [ARCH] Elaborate UNIT";
+ end Get_Short_Help;
+
+ procedure Perform_Action (Cmd : in out Command_Elab; Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ Success : Boolean;
+ begin
+ Set_Elab_Units ("-e", Args);
+ Setup_Compiler (False);
+
+ Bind;
+ if not Flag_Expect_Failure then
+ Link (Add_Std => True, Disp_Only => False);
+ end if;
+ Delete_File (Filelist_Name.all, Success);
+ end Perform_Action;
+
+ -- Command Run.
+ type Command_Run is new Command_Comp with null record;
+ function Decode_Command (Cmd : Command_Run; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Run) return String;
+ procedure Perform_Action (Cmd : in out Command_Run;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Run; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "-r";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Run) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "-r UNIT [ARCH] [OPTS] Run UNIT";
+ end Get_Short_Help;
+
+ procedure Perform_Action (Cmd : in out Command_Run; Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ Opt_Arg : Natural;
+ begin
+ Extract_Elab_Unit ("-r", Args, Opt_Arg);
+ if Sec_Name = null then
+ Base_Name := Prim_Name;
+ else
+ Base_Name := new String'(Prim_Name.all & '-' & Sec_Name.all);
+ end if;
+ if not Is_Regular_File (Base_Name.all & Nul) then
+ Error ("file '" & Base_Name.all & "' does not exists");
+ Error ("Please elaborate your design.");
+ raise Exec_Error;
+ end if;
+ My_Spawn ('.' & Directory_Separator & Base_Name.all,
+ Args (Opt_Arg .. Args'Last));
+ end Perform_Action;
+
+ -- Command Elab_Run.
+ type Command_Elab_Run is new Command_Comp with null record;
+ function Decode_Command (Cmd : Command_Elab_Run; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Elab_Run) return String;
+ procedure Perform_Action (Cmd : in out Command_Elab_Run;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Elab_Run; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "--elab-run";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Elab_Run) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "--elab-run [OPTS] UNIT [ARCH] [OPTS] Elaborate and run UNIT";
+ end Get_Short_Help;
+
+ procedure Perform_Action (Cmd : in out Command_Elab_Run;
+ Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ Success : Boolean;
+ Run_Arg : Natural;
+ begin
+ Set_Elab_Units ("-elab-run", Args, Run_Arg);
+ Setup_Compiler (False);
+
+ Bind;
+ if Flag_Expect_Failure then
+ Delete_File (Filelist_Name.all, Success);
+ else
+ Link (Add_Std => True, Disp_Only => False);
+ Delete_File (Filelist_Name.all, Success);
+ My_Spawn ('.' & Directory_Separator & Output_File.all,
+ Args (Run_Arg .. Args'Last));
+ end if;
+ end Perform_Action;
+
+ -- Command Bind.
+ type Command_Bind is new Command_Comp with null record;
+ function Decode_Command (Cmd : Command_Bind; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Bind) return String;
+ procedure Perform_Action (Cmd : in out Command_Bind;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Bind; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "--bind";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Bind) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "--bind [OPTS] UNIT [ARCH] Bind UNIT";
+ end Get_Short_Help;
+
+ procedure Perform_Action (Cmd : in out Command_Bind; Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ Set_Elab_Units ("--bind", Args);
+ Setup_Compiler (False);
+
+ Bind;
+ end Perform_Action;
+
+ -- Command Link.
+ type Command_Link is new Command_Comp with null record;
+ function Decode_Command (Cmd : Command_Link; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Link) return String;
+ procedure Perform_Action (Cmd : in out Command_Link; Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Link; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "--link";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Link) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "--link [OPTS] UNIT [ARCH] Link UNIT";
+ end Get_Short_Help;
+
+ procedure Perform_Action (Cmd : in out Command_Link; Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ Set_Elab_Units ("--link", Args);
+ Setup_Compiler (False);
+
+ Filelist_Name := new String'(Elab_Name.all & List_Suffix);
+ Link (Add_Std => True, Disp_Only => False);
+ end Perform_Action;
+
+
+ -- Command List_Link.
+ type Command_List_Link is new Command_Comp with null record;
+ function Decode_Command (Cmd : Command_List_Link; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_List_Link) return String;
+ procedure Perform_Action (Cmd : in out Command_List_Link;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_List_Link; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "--list-link";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_List_Link) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "--list-link [OPTS] UNIT [ARCH] List objects file to link UNIT";
+ end Get_Short_Help;
+
+ procedure Perform_Action (Cmd : in out Command_List_Link;
+ Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ Set_Elab_Units ("--list-link", Args);
+ Setup_Compiler (False);
+
+ Filelist_Name := new String'(Elab_Name.all & List_Suffix);
+ Link (Add_Std => True, Disp_Only => True);
+ end Perform_Action;
+
+
+ -- Command analyze and elaborate
+ type Command_Anaelab is new Command_Comp with null record;
+ function Decode_Command (Cmd : Command_Anaelab; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Anaelab) return String;
+ procedure Decode_Option (Cmd : in out Command_Anaelab;
+ Option : String;
+ Arg : String;
+ Res : out Option_Res);
+
+ procedure Perform_Action (Cmd : in out Command_Anaelab;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Anaelab; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "-c";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Anaelab) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "-c [OPTS] FILEs -e UNIT [ARCH] "
+ & "Generate whole code to elab UNIT from FILEs";
+ end Get_Short_Help;
+
+ procedure Decode_Option (Cmd : in out Command_Anaelab;
+ Option : String;
+ Arg : String;
+ Res : out Option_Res)
+ is
+ begin
+ if Option = "-e" then
+ Res := Option_End;
+ return;
+ else
+ Decode_Option (Command_Comp (Cmd), Option, Arg, Res);
+ end if;
+ end Decode_Option;
+
+ procedure Perform_Action (Cmd : in out Command_Anaelab;
+ Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ Elab_Index : Integer;
+ begin
+ Elab_Index := -1;
+ for I in Args'Range loop
+ if Args (I).all = "-e" then
+ Elab_Index := I;
+ exit;
+ end if;
+ end loop;
+ if Elab_Index < 0 then
+ Analyze_Files (Args, True);
+ else
+ Set_Elab_Units ("-c", Args (Elab_Index + 1 .. Args'Last));
+ Setup_Compiler (False);
+
+ Bind_Anaelab (Args (Args'First .. Elab_Index - 1));
+ Link (Add_Std => False, Disp_Only => False);
+ end if;
+ end Perform_Action;
+
+ -- Command Make.
+ type Command_Make is new Command_Comp with record
+ -- Disp dependences during make.
+ Flag_Depend_Unit : Boolean;
+
+ -- Force recompilation of units in work library.
+ Flag_Force : Boolean;
+ end record;
+
+ function Decode_Command (Cmd : Command_Make; Name : String)
+ return Boolean;
+ procedure Init (Cmd : in out Command_Make);
+ procedure Decode_Option (Cmd : in out Command_Make;
+ Option : String;
+ Arg : String;
+ Res : out Option_Res);
+
+ function Get_Short_Help (Cmd : Command_Make) return String;
+ procedure Disp_Long_Help (Cmd : Command_Make);
+
+ procedure Perform_Action (Cmd : in out Command_Make;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Make; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "-m";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Make) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "-m [OPTS] UNIT [ARCH] Make UNIT";
+ end Get_Short_Help;
+
+ procedure Disp_Long_Help (Cmd : Command_Make)
+ is
+ begin
+ Disp_Long_Help (Command_Comp (Cmd));
+ Put_Line (" -f Force recompilation of work units");
+ Put_Line (" -Mu Disp unit dependences (humna format)");
+ end Disp_Long_Help;
+
+ procedure Init (Cmd : in out Command_Make) is
+ begin
+ Init (Command_Comp (Cmd));
+ Cmd.Flag_Depend_Unit := False;
+ Cmd.Flag_Force := False;
+ end Init;
+
+
+ procedure Decode_Option (Cmd : in out Command_Make;
+ Option : String;
+ Arg : String;
+ Res : out Option_Res)
+ is
+ begin
+ if Option = "-Mu" then
+ Cmd.Flag_Depend_Unit := True;
+ Res := Option_Ok;
+ elsif Option = "-f" then
+ Cmd.Flag_Force := True;
+ Res := Option_Ok;
+ else
+ Decode_Option (Command_Comp (Cmd), Option, Arg, Res);
+ end if;
+ end Decode_Option;
+
+ procedure Perform_Action (Cmd : in out Command_Make; Args : Argument_List)
+ is
+ use Configuration;
+
+ File : Iir_Design_File;
+ Unit : Iir;
+ Lib_Unit : Iir;
+ Lib : Iir_Library_Declaration;
+ In_Work : Boolean;
+
+ Files_List : Iir_List;
+
+ -- Set when a design file has been compiled.
+ Has_Compiled : Boolean;
+
+ Need_Analyze : Boolean;
+
+ Need_Elaboration : Boolean;
+
+ Stamp : Time_Stamp_Id;
+ File_Id : Name_Id;
+
+ Nil_Args : Argument_List (2 .. 1);
+ Success : Boolean;
+ begin
+ Set_Elab_Units ("-m", Args);
+ Setup_Compiler (True);
+
+ -- Create list of files.
+ Files_List := Build_Dependence (Prim_Name, Sec_Name);
+
+ if Cmd.Flag_Depend_Unit then
+ Put_Line ("Units analysis order:");
+ for I in Design_Units.First .. Design_Units.Last loop
+ Unit := Design_Units.Table (I);
+ Put (" ");
+ Disp_Library_Unit (Get_Library_Unit (Unit));
+ New_Line;
+-- Put (" file: ");
+-- File := Get_Design_File (Unit);
+-- Image (Get_Design_File_Filename (File));
+-- Put_Line (Name_Buffer (1 .. Name_Length));
+ end loop;
+ end if;
+ if Cmd.Flag_Depend_Unit then
+ Put_Line ("File analysis order:");
+ for I in Natural loop
+ File := Get_Nth_Element (Files_List, I);
+ exit when File = Null_Iir;
+ Image (Get_Design_File_Filename (File));
+ Put (" ");
+ Put (Name_Buffer (1 .. Name_Length));
+ if Flag_Verbose then
+ Put_Line (":");
+ declare
+ Dep_List : Iir_List;
+ Dep_File : Iir;
+ begin
+ Dep_List := Get_File_Dependence_List (File);
+ if Dep_List /= Null_Iir_List then
+ for J in Natural loop
+ Dep_File := Get_Nth_Element (Dep_List, J);
+ exit when Dep_File = Null_Iir;
+ Image (Get_Design_File_Filename (Dep_File));
+ Put (" ");
+ Put_Line (Name_Buffer (1 .. Name_Length));
+ end loop;
+ end if;
+ end;
+ else
+ New_Line;
+ end if;
+ end loop;
+ end if;
+
+ Has_Compiled := False;
+ Last_Stamp := Null_Time_Stamp;
+
+ for I in Natural loop
+ File := Get_Nth_Element (Files_List, I);
+ exit when File = Null_Iir;
+
+ Need_Analyze := False;
+ if Is_File_Outdated (File) then
+ Need_Analyze := True;
+ else
+ Unit := Get_First_Design_Unit (File);
+ while Unit /= Null_Iir loop
+ Lib_Unit := Get_Library_Unit (Unit);
+ if not (Get_Kind (Lib_Unit) = Iir_Kind_Configuration_Declaration
+ and then Get_Identifier (Lib_Unit) = Null_Identifier)
+ then
+ if Is_Unit_Outdated (Unit) then
+ Need_Analyze := True;
+ exit;
+ end if;
+ end if;
+ Unit := Get_Chain (Unit);
+ end loop;
+ end if;
+
+ Lib := Get_Library (File);
+ In_Work := Lib = Libraries.Work_Library;
+
+ if Need_Analyze or else (Cmd.Flag_Force and In_Work) then
+ File_Id := Get_Design_File_Filename (File);
+ if not Flag_Verbose then
+ Put ("analyze ");
+ Put (Image (File_Id));
+ --Disp_Library_Unit (Get_Library_Unit (Unit));
+ New_Line;
+ end if;
+
+ if In_Work then
+ Do_Compile (Nil_Args, Image (File_Id));
+ else
+ declare
+ use Libraries;
+ Lib_Args : Argument_List (1 .. 2);
+ Prev_Workdir : Name_Id;
+ begin
+ Prev_Workdir := Work_Directory;
+
+ -- Must be set, since used to build the object filename.
+ Work_Directory := Get_Library_Directory (Lib);
+
+ -- Always overwrite --work and --workdir.
+ Lib_Args (1) := new String'
+ ("--work=" & Image (Get_Identifier (Lib)));
+ if Work_Directory = Libraries.Local_Directory then
+ Lib_Args (2) := new String'("--workdir=.");
+ else
+ Lib_Args (2) := new String'
+ ("--workdir=" & Image (Work_Directory));
+ end if;
+ Do_Compile (Lib_Args, Image (File_Id));
+
+ Work_Directory := Prev_Workdir;
+
+ Free (Lib_Args (1));
+ Free (Lib_Args (2));
+ end;
+ end if;
+
+ Has_Compiled := True;
+ -- Set the analysis time stamp since the file has just been
+ -- analyzed.
+ Set_Analysis_Time_Stamp (File, Files_Map.Get_Os_Time_Stamp);
+ end if;
+ end loop;
+
+ Need_Elaboration := False;
+ -- Elaboration.
+ -- if libgrt is more recent than the executable (FIXME).
+ if Has_Compiled then
+ if Flag_Verbose then
+ Put_Line ("link due to a file compilation");
+ end if;
+ Need_Elaboration := True;
+ else
+ declare
+ Exec_File : String := Output_File.all & Nul;
+ begin
+ Stamp := Files_Map.Get_File_Time_Stamp (Exec_File'Address);
+ end;
+
+ if Stamp = Null_Time_Stamp then
+ if Flag_Verbose then
+ Put_Line ("link due to no binary file");
+ end if;
+ Need_Elaboration := True;
+ else
+ if Files_Map.Is_Gt (Last_Stamp, Stamp) then
+ -- if a file is more recent than the executable.
+ if Flag_Verbose then
+ Put ("link due to outdated binary file: ");
+ Put (Image (Get_Design_File_Filename (Last_Stamp_File)));
+ Put (" (");
+ Put (Files_Map.Get_Time_Stamp_String (Last_Stamp));
+ Put (" > ");
+ Put (Files_Map.Get_Time_Stamp_String (Stamp));
+ Put (")");
+ New_Line;
+ end if;
+ Need_Elaboration := True;
+ end if;
+ end if;
+ end if;
+ if Need_Elaboration then
+ if not Flag_Verbose then
+ Put ("elaborate ");
+ Put (Prim_Name.all);
+ --Disp_Library_Unit (Get_Library_Unit (Unit));
+ New_Line;
+ end if;
+ Bind;
+ Link (Add_Std => True, Disp_Only => False);
+ Delete_File (Filelist_Name.all, Success);
+ end if;
+ end Perform_Action;
+
+ -- Command Gen_Makefile.
+ type Command_Gen_Makefile is new Command_Comp with null record;
+ function Decode_Command (Cmd : Command_Gen_Makefile; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Gen_Makefile) return String;
+ procedure Perform_Action (Cmd : in out Command_Gen_Makefile;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Gen_Makefile; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "--gen-makefile";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Gen_Makefile) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "--gen-makefile [OPTS] UNIT [ARCH] Generate a Makefile for UNIT";
+ end Get_Short_Help;
+
+ function Is_Makeable_File (File : Iir_Design_File) return Boolean is
+ begin
+ if File = Std_Package.Std_Standard_File then
+ return False;
+ end if;
+ return True;
+ end Is_Makeable_File;
+
+ procedure Perform_Action (Cmd : in out Command_Gen_Makefile;
+ Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+
+ HT : constant Character := Ada.Characters.Latin_1.HT;
+ Files_List : Iir_List;
+ File : Iir_Design_File;
+
+ Lib : Iir_Library_Declaration;
+ Dir_Id : Name_Id;
+
+ Dep_List : Iir_List;
+ Dep_File : Iir;
+ begin
+ Set_Elab_Units ("--gen-makefile", Args);
+ Setup_Libraries (True);
+ Files_List := Build_Dependence (Prim_Name, Sec_Name);
+
+ Put_Line ("# Makefile automatically generated by ghdl");
+ Put ("# Version: ");
+ Put (Version.Ghdl_Version);
+ Put (" - ");
+ if Version_String /= null then
+ Put (Version_String.all);
+ end if;
+ New_Line;
+ Put_Line ("# Command used to generate this makefile:");
+ Put ("# ");
+ Put (Command_Name);
+ for I in 1 .. Argument_Count loop
+ Put (' ');
+ Put (Argument (I));
+ end loop;
+ New_Line;
+
+ New_Line;
+
+ Put ("GHDL=");
+ Put_Line (Command_Name);
+
+ -- Extract options for command line.
+ Put ("GHDLFLAGS=");
+ for I in 2 .. Argument_Count loop
+ declare
+ Arg : String := Argument (I);
+ begin
+ if Arg (1) = '-' then
+ if (Arg'Length > 10 and then Arg (1 .. 10) = "--workdir=")
+ or else (Arg'Length > 7 and then Arg (1 .. 7) = "--ieee=")
+ or else (Arg'Length > 6 and then Arg (1 .. 6) = "--std=")
+ or else (Arg'Length > 7 and then Arg (1 .. 7) = "--work=")
+ or else (Arg'Length > 2 and then Arg (1 .. 2) = "-P")
+ then
+ Put (" ");
+ Put (Arg);
+ end if;
+ end if;
+ end;
+ end loop;
+ New_Line;
+
+ New_Line;
+
+ Put_Line ("# Default target");
+ Put ("all: ");
+ Put_Line (Base_Name.all);
+ New_Line;
+
+ Put_Line ("# Elaboration target");
+ Put (Base_Name.all);
+ Put (":");
+ for I in Natural loop
+ File := Get_Nth_Element (Files_List, I);
+ exit when File = Null_Iir;
+ if Is_Makeable_File (File) then
+ Put (" ");
+ Put (Get_Object_Filename (File));
+ end if;
+ end loop;
+ New_Line;
+ Put_Line (HT & "$(GHDL) -e $(GHDLFLAGS) $@");
+ New_Line;
+
+ Put_Line ("# Run target");
+ Put_Line ("run: " & Base_Name.all);
+ Put_Line (HT & "$(GHDL) -r " & Base_Name.all & " $(GHDLRUNFLAGS)");
+ New_Line;
+
+ Put_Line ("# Targets to analyze files");
+ for I in Natural loop
+ File := Get_Nth_Element (Files_List, I);
+ exit when File = Null_Iir;
+ Dir_Id := Get_Design_File_Directory (File);
+ if not Is_Makeable_File (File) then
+ -- Builtin file.
+ null;
+ else
+ Put (Get_Object_Filename (File));
+ Put (": ");
+ if Dir_Id /= Files_Map.Get_Home_Directory then
+ Put (Image (Dir_Id));
+ Put (Image (Get_Design_File_Filename (File)));
+ New_Line;
+
+ Put_Line
+ (HT & "@echo ""This file was not locally built ($<)""");
+ Put_Line (HT & "exit 1");
+ else
+ Put (Image (Get_Design_File_Filename (File)));
+ New_Line;
+
+ Put (HT & "$(GHDL) -a $(GHDLFLAGS)");
+ Lib := Get_Library (File);
+ if Lib /= Libraries.Work_Library then
+ -- Overwrite some options.
+ Put (" --work=");
+ Put (Image (Get_Identifier (Lib)));
+ Dir_Id := Get_Library_Directory (Lib);
+ Put (" --workdir=");
+ if Dir_Id = Libraries.Local_Directory then
+ Put (".");
+ else
+ Put (Image (Dir_Id));
+ end if;
+ end if;
+ Put_Line (" $<");
+ end if;
+ end if;
+ end loop;
+ New_Line;
+
+ Put_Line ("# Files dependences");
+ for I in Natural loop
+ File := Get_Nth_Element (Files_List, I);
+ exit when File = Null_Iir;
+ if Is_Makeable_File (File) then
+ Put (Get_Object_Filename (File));
+ Put (": ");
+ Dep_List := Get_File_Dependence_List (File);
+ if Dep_List /= Null_Iir_List then
+ for J in Natural loop
+ Dep_File := Get_Nth_Element (Dep_List, J);
+ exit when Dep_File = Null_Iir;
+ if Dep_File /= File and then Is_Makeable_File (Dep_File)
+ then
+ Put (" ");
+ Put (Get_Object_Filename (Dep_File));
+ end if;
+ end loop;
+ end if;
+ New_Line;
+ end if;
+ end loop;
+ end Perform_Action;
+
+ procedure Register_Commands is
+ begin
+ Register_Command (new Command_Analyze);
+ Register_Command (new Command_Elab);
+ Register_Command (new Command_Run);
+ Register_Command (new Command_Elab_Run);
+ Register_Command (new Command_Bind);
+ Register_Command (new Command_Link);
+ Register_Command (new Command_List_Link);
+ Register_Command (new Command_Anaelab);
+ Register_Command (new Command_Make);
+ Register_Command (new Command_Gen_Makefile);
+ Register_Command (new Command_Dispconfig);
+ end Register_Commands;
+end Ghdldrv;
diff --git a/translate/ghdldrv/ghdldrv.ads b/translate/ghdldrv/ghdldrv.ads
new file mode 100644
index 0000000..05b0856
--- /dev/null
+++ b/translate/ghdldrv/ghdldrv.ads
@@ -0,0 +1,20 @@
+-- GHDL driver - commands invoking gcc.
+-- 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.
+package Ghdldrv is
+ procedure Register_Commands;
+end Ghdldrv;
diff --git a/translate/ghdldrv/ghdllocal.adb b/translate/ghdldrv/ghdllocal.adb
new file mode 100644
index 0000000..3abd555
--- /dev/null
+++ b/translate/ghdldrv/ghdllocal.adb
@@ -0,0 +1,1052 @@
+-- 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;
+with Ghdlmain;
+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 Scan;
+with Sem;
+with Canon;
+with Errorout;
+with Configuration;
+with Files_Map;
+with Post_Sems;
+with Disp_Tree;
+
+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 : Boolean := True;
+
+ procedure Finish_Compilation
+ (Unit : Iir_Design_Unit; Main : Boolean := False)
+ is
+ use Errorout;
+ use Ada.Text_IO;
+ Config : Iir_Design_Unit;
+ Lib : Iir;
+ begin
+ 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;
+
+ Post_Sems.Post_Sem_Checks (Unit);
+
+ if Errorout.Nbr_Errors > 0 then
+ raise Compilation_Error;
+ end if;
+
+ if Flags.Flag_Elaborate then
+ if Flags.Verbose then
+ Put_Line ("canonicalize " & Disp_Node (Get_Library_Unit (Unit)));
+ end if;
+
+ Canon.Canonicalize (Unit);
+
+ if Flag_Create_Default_Config then
+ Lib := Get_Library_Unit (Unit);
+ if Get_Kind (Lib) = Iir_Kind_Architecture_Declaration 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
+ Std_Names.Std_Names_Initialize;
+ Libraries.Init_Pathes;
+ 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);
+ begin
+ Res := Option_Bad;
+ if Option = "-v" and then Flag_Verbose = False then
+ Flag_Verbose := True;
+ Res := Option_Ok;
+ elsif Option'Length > 9 and then Option (1 .. 9) = "--PREFIX=" then
+ Prefix_Path := new String'(Option (10 .. Option'Last));
+ Res := Option_Ok;
+ elsif Option = "--ieee=synopsys" then
+ Flag_Ieee := Lib_Synopsys;
+ Res := Option_Ok;
+ elsif Option = "--ieee=mentor" then
+ Flag_Ieee := Lib_Mentor;
+ Res := Option_Ok;
+ elsif Option = "--ieee=none" then
+ Flag_Ieee := Lib_None;
+ Res := Option_Ok;
+ elsif Option = "--ieee=standard" then
+ Flag_Ieee := Lib_Standard;
+ Res := Option_Ok;
+ elsif Option'Length >= 2
+ and then (Option (2) = 'g' or Option (2) = 'O')
+ then
+ -- Silently accept -g and -O.
+ Res := Option_Ok;
+ else
+ if Flags.Parse_Option (Option) then
+ Res := Option_Ok;
+ end if;
+ end if;
+ end Decode_Option;
+
+ procedure Disp_Long_Help (Cmd : Command_Lib)
+ is
+ pragma Unreferenced (Cmd);
+ use Ada.Text_IO;
+ procedure P (Str : String) renames Put_Line;
+ begin
+ P ("Options:");
+ P (" --std=XX Use XX as VHDL standard (87,93c,93,00 or 02)");
+ 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 (bad)");
+ P (" none: do not use a predefined ieee library");
+ end Disp_Long_Help;
+
+ function Get_Version_Path return String is
+ begin
+ case Flags.Vhdl_Std is
+ when Vhdl_87 =>
+ return "v87";
+ when Vhdl_93c
+ | Vhdl_93
+ | Vhdl_00
+ | Vhdl_02 =>
+ return "v93";
+ end case;
+ end Get_Version_Path;
+
+ procedure Add_Library_Path (Name : String)
+ is
+ begin
+ Libraries.Add_Library_Path
+ (Prefix_Path.all & Get_Version_Path & Directory_Separator
+ & Name & Directory_Separator);
+ end Add_Library_Path;
+
+ procedure Setup_Libraries (Load : Boolean)
+ is
+ begin
+ if Prefix_Path = null then
+ Prefix_Path := new String'(Default_Pathes.Prefix);
+ 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 =>
+ Add_Library_Path ("synopsys");
+ when Lib_Mentor =>
+ Add_Library_Path ("mentor");
+ 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_Library_Unit (Unit : Iir)
+ is
+ use Ada.Text_IO;
+ 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_Declaration =>
+ Put ("architecture ");
+ when Iir_Kind_Configuration_Declaration =>
+ Put ("configuration ");
+ when Iir_Kind_Package_Declaration =>
+ Put ("package ");
+ when Iir_Kind_Package_Body =>
+ Put ("package body ");
+ when others =>
+ Put ("???");
+ return;
+ end case;
+ Image (Id);
+ Put (Name_Buffer (1 .. Name_Length));
+ case Get_Kind (Unit) is
+ when Iir_Kind_Architecture_Declaration =>
+ Put (" of ");
+ Image (Get_Identifier (Get_Entity (Unit)));
+ Put (Name_Buffer (1 .. Name_Length));
+ when Iir_Kind_Configuration_Declaration =>
+ if Id = Null_Identifier then
+ Put ("<default> of entity ");
+ Image (Get_Identifier (Get_Library_Unit (Get_Entity (Unit))));
+ Put (Name_Buffer (1 .. Name_Length));
+ end if;
+ when others =>
+ null;
+ end case;
+ end Disp_Library_Unit;
+
+ procedure Disp_Library (Name : Name_Id)
+ is
+ use Ada.Text_IO;
+ 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) return String_Access
+ is
+ use Name_Table;
+ Basename : String := Get_Base_Name (File);
+ begin
+ Image (Libraries.Work_Directory);
+ Name_Buffer (Name_Length + 1 .. Name_Length + Basename'Length) :=
+ Basename;
+ Name_Length := Name_Length + Basename'Length;
+ Name_Buffer (Name_Length + 1 .. Name_Length + Suffix'Length) := Suffix;
+ Name_Length := Name_Length + Suffix'Length;
+ return new String'(Name_Buffer (1 .. Name_Length));
+ 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
+ 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 "-d or --dir Disp contents of the work library";
+ end Get_Short_Help;
+
+ procedure Perform_Action (Cmd : in out Command_Dir; Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ if Args'Length /= 0 then
+ Error ("command '-d' does not accept any argument");
+ raise Option_Error;
+ end if;
+
+ Flags.Bootstrap := True;
+ -- Load word library.
+ Libraries.Load_Std_Library;
+ Libraries.Load_Work_Library;
+
+ Disp_Library (Std_Names.Name_Work);
+
+-- else
+-- for L in Libs'Range loop
+-- Id := Get_Identifier (Libs (L).all);
+-- Disp_Library (Id);
+-- 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 Ada.Text_IO;
+ use Name_Table;
+ Id : Name_Id;
+ Design_File : Iir_Design_File;
+ Unit : Iir;
+ Lib : Iir;
+ Flag_Add : 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);
+ use Ada.Text_IO;
+ 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");
+ 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_Files (Files : Argument_List; Save_Library : Boolean)
+ is
+ use Ada.Text_IO;
+ Id : Name_Id;
+ Design_File : Iir_Design_File;
+ Unit : Iir;
+ Next_Unit : Iir;
+ begin
+ Setup_Libraries (True);
+
+ -- Parse all files.
+ for I in Files'Range loop
+ Id := Name_Table.Get_Identifier (Files (I).all);
+ if Flag_Verbose then
+ Put (Files (I).all);
+ Put_Line (":");
+ end if;
+ 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
+ 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 if;
+ 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.
+ 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
+ use GNAT.OS_Lib;
+ use Ada.Text_IO;
+ 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 GNAT.OS_Lib;
+ 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;
+ Ent_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_Declaration =>
+ Ent_Unit := Get_Entity (Lib_Unit);
+ Delete_Top_Unit (Image (Get_Identifier (Ent_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;
+
+ 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 --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;
+ 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_Time_Stamp (Fe),
+ Get_File_Time_Stamp (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;
+
+ 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_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_Time_Stamp (Fe),
+ Get_File_Time_Stamp (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 ("cannot find primary unit " & Prim.all);
+ raise Option_Error;
+ end if;
+
+ -- Add unused design units.
+ 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.
+ 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;
+
+ -- Convert NAME to lower cases, unless it is an extended identifier.
+ function Convert_Name (Name : String_Access) return String_Access
+ is
+ use Name_Table;
+ begin
+ Name_Length := Name'Length;
+ Name_Buffer (1 .. Name_Length) := Name.all;
+ Scan.Convert_Identifier;
+ return new String'(Name_Buffer (1 .. Name_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 : 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_Disp_Standard);
+ end Register_Commands;
+end Ghdllocal;
diff --git a/translate/ghdldrv/ghdllocal.ads b/translate/ghdldrv/ghdllocal.ads
new file mode 100644
index 0000000..e1c2baa
--- /dev/null
+++ b/translate/ghdldrv/ghdllocal.ads
@@ -0,0 +1,98 @@
+-- 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 GNAT.OS_Lib; use GNAT.OS_Lib;
+with Ghdlmain; use Ghdlmain;
+with Iirs; use Iirs;
+
+package Ghdllocal is
+ type Command_Lib is abstract new Command_Type with null record;
+
+ -- Setup GHDL.
+ procedure Init (Cmd : in out Command_Lib);
+
+ -- Handle:
+ -- --std=xx, --work=xx, -Pxxx, --workdir=x, --ieee=x, -Px, and -v
+ procedure Decode_Option (Cmd : in out Command_Lib;
+ Option : String;
+ Arg : String;
+ Res : out Option_Res);
+
+ -- Disp detailled help.
+ procedure Disp_Long_Help (Cmd : Command_Lib);
+
+ -- Set with -v option.
+ Flag_Verbose : Boolean := False;
+
+ -- Suffix for asm files.
+ Asm_Suffix : constant String := ".s";
+
+ -- Suffix for post files.
+ Post_Suffix : constant String := ".on";
+
+ -- Suffix for list files.
+ List_Suffix : constant String := ".lst";
+
+ -- Prefix for elab files.
+ Elab_Prefix : constant String := "e~";
+
+ -- Path prefix for libraries.
+ Prefix_Path : String_Access := null;
+
+ Nul : constant Character := Character'Val (0);
+
+ -- Return FILENAME without the extension.
+ function Get_Base_Name (Filename : String; Remove_Dir : Boolean := True)
+ return String;
+
+ function Append_Suffix (File : String; Suffix : String)
+ return String_Access;
+
+ -- Return TRUE is UNIT can be at the apex of a design hierarchy.
+ function Is_Top_Entity (Unit : Iir) return Boolean;
+
+ -- Display the name of library unit UNIT.
+ procedure Disp_Library_Unit (Unit : Iir);
+
+ -- Translate vhdl version into a path element.
+ -- Used to search Std and IEEE libraries.
+ function Get_Version_Path return String;
+
+ -- Setup standard libaries path. If LOAD is true, then load them now.
+ procedure Setup_Libraries (Load : Boolean);
+
+ -- Setup library, analyze FILES, and if SAVE_LIBRARY is set save the
+ -- work library only
+ procedure Analyze_Files (Files : Argument_List; Save_Library : Boolean);
+
+ -- Load and parse all libraries and files, starting from the work library.
+ -- The work library must already be loaded.
+ -- Raise errorout.compilation_error in case of error (parse error).
+ procedure Load_All_Libraries_And_Files;
+
+ function Build_Dependence (Prim : String_Access; Sec : String_Access)
+ return Iir_List;
+
+ Prim_Name : String_Access;
+ Sec_Name : String_Access;
+
+ -- Set PRIM_NAME and SEC_NAME.
+ procedure Extract_Elab_Unit
+ (Cmd_Name : String; Args : Argument_List; Next_Arg : out Natural);
+
+ procedure Register_Commands;
+end Ghdllocal;
diff --git a/translate/ghdldrv/ghdlmain.adb b/translate/ghdldrv/ghdlmain.adb
new file mode 100644
index 0000000..bd2462f
--- /dev/null
+++ b/translate/ghdldrv/ghdlmain.adb
@@ -0,0 +1,355 @@
+-- GHDL driver - main part.
+-- 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;
+with Ada.Command_Line;
+with Version;
+with Flags;
+with Bug;
+with Errorout;
+
+package body Ghdlmain is
+ procedure Init (Cmd : in out Command_Type)
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ null;
+ end Init;
+
+ procedure Decode_Option (Cmd : in out Command_Type;
+ Option : String;
+ Arg : String;
+ Res : out Option_Res)
+ is
+ pragma Unreferenced (Cmd);
+ pragma Unreferenced (Option);
+ pragma Unreferenced (Arg);
+ begin
+ Res := Option_Bad;
+ end Decode_Option;
+
+ procedure Disp_Long_Help (Cmd : Command_Type)
+ is
+ pragma Unreferenced (Cmd);
+ use Ada.Text_IO;
+ begin
+ Put_Line ("This command does not accept options.");
+ end Disp_Long_Help;
+
+ First_Cmd : Command_Acc := null;
+ Last_Cmd : Command_Acc := null;
+
+ procedure Register_Command (Cmd : Command_Acc) is
+ begin
+ if First_Cmd = null then
+ First_Cmd := Cmd;
+ else
+ Last_Cmd.Next := Cmd;
+ end if;
+ Last_Cmd := Cmd;
+ end Register_Command;
+
+ -- Find the command.
+ function Find_Command (Action : String) return Command_Acc
+ is
+ Cmd : Command_Acc;
+ begin
+ Cmd := First_Cmd;
+ while Cmd /= null loop
+ if Decode_Command (Cmd.all, Action) then
+ return Cmd;
+ end if;
+ Cmd := Cmd.Next;
+ end loop;
+ return null;
+ end Find_Command;
+
+ -- Command help.
+ type Command_Help is new Command_Type with null record;
+ function Decode_Command (Cmd : Command_Help; Name : String) return Boolean;
+ procedure Decode_Option (Cmd : in out Command_Help;
+ Option : String;
+ Arg : String;
+ Res : out Option_Res);
+
+ function Get_Short_Help (Cmd : Command_Help) return String;
+ procedure Perform_Action (Cmd : in out Command_Help; Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Help; Name : String) return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "-h" or else Name = "--help";
+ end Decode_Command;
+
+ procedure Decode_Option (Cmd : in out Command_Help;
+ Option : String;
+ Arg : String;
+ Res : out Option_Res)
+ is
+ pragma Unreferenced (Cmd);
+ pragma Unreferenced (Option);
+ pragma Unreferenced (Arg);
+ begin
+ Res := Option_End;
+ end Decode_Option;
+
+ function Get_Short_Help (Cmd : Command_Help) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "-h or --help [CMD] Disp this help or [help on CMD]";
+ end Get_Short_Help;
+
+ procedure Perform_Action (Cmd : in out Command_Help; Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+
+ use Ada.Text_IO;
+ use Ada.Command_Line;
+ C : Command_Acc;
+ begin
+ if Args'Length = 0 then
+ Put_Line ("usage: " & Command_Name & " COMMAND [OPTIONS] ...");
+ Put_Line ("COMMAND is one of:");
+ C := First_Cmd;
+ while C /= null loop
+ Put_Line (Get_Short_Help (C.all));
+ C := C.Next;
+ end loop;
+ New_Line;
+ Put_Line
+ ("To display the options of a GHDL program, run your program");
+ Put_Line (" with the --help option.");
+ Put_Line ("Please, refer to the GHDL manual for more information.");
+ Put_Line ("Report bugs to <ghdl@free.fr>.");
+ elsif Args'Length = 1 then
+ C := Find_Command (Args (1).all);
+ if C = null then
+ Error ("Command '" & Args (1).all & "' is unknown.");
+ raise Option_Error;
+ end if;
+ Put_Line (Get_Short_Help (C.all));
+ Disp_Long_Help (C.all);
+ else
+ Error ("Command '--help' accepts at most one argument.");
+ raise Option_Error;
+ end if;
+ end Perform_Action;
+
+ -- Command options help.
+ type Command_Option_Help is new Command_Type with null record;
+ function Decode_Command (Cmd : Command_Option_Help; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Option_Help) return String;
+ procedure Perform_Action (Cmd : in out Command_Option_Help;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Option_Help; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "--options-help";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Option_Help) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "--options-help Disp help for compiler options";
+ end Get_Short_Help;
+
+ procedure Perform_Action (Cmd : in out Command_Option_Help;
+ Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ if Args'Length /= 0 then
+ Error
+ ("warning: command '--option-help' does not accept any argument");
+ end if;
+ Flags.Disp_Options_Help;
+ end Perform_Action;
+
+ -- Command Version
+ type Command_Version is new Command_Type with null record;
+ function Decode_Command (Cmd : Command_Version; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Version) return String;
+ procedure Perform_Action (Cmd : in out Command_Version;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Version; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "-v" or Name = "--version";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Version) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "-v or --version Disp ghdl version";
+ end Get_Short_Help;
+
+ procedure Perform_Action (Cmd : in out Command_Version;
+ Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ use Ada.Text_IO;
+ begin
+ Put_Line (Version.Ghdl_Version);
+ if Version_String /= null then
+ Put_Line (Version_String.all);
+ end if;
+ Put_Line ("Written by Tristan Gingold.");
+ New_Line;
+ Put_Line ("Copyright (C) 2003, 2004, 2005 Tristan Gingold.");
+ Put_Line ("This is free software; see the source for copying conditions."
+ & " There is NO");
+ Put_Line ("warranty; not even for MERCHANTABILITY or FITNESS FOR A "
+ & "PARTICULAR PURPOSE.");
+ if Args'Length /= 0 then
+ Error ("warning: command '--version' does not accept any argument");
+ end if;
+ end Perform_Action;
+
+ -- Disp MSG on the standard output with the command name.
+ procedure Error (Msg : String)
+ is
+ use Ada.Command_Line;
+ use Ada.Text_IO;
+ begin
+ Put (Standard_Error, Command_Name);
+ Put (Standard_Error, ": ");
+ Put_Line (Standard_Error, Msg);
+ --Has_Error := True;
+ end Error;
+
+ procedure Main
+ is
+ use Ada.Command_Line;
+ Cmd : Command_Acc;
+ Arg_Index : Natural;
+ First_Arg : Natural;
+
+ begin
+ if Argument_Count = 0 then
+ Error ("missing command, try " & Command_Name & " --help");
+ raise Option_Error;
+ end if;
+
+ Cmd := Find_Command (Argument (1));
+ if Cmd = null then
+ Error ("unknown command '" & Argument (1) & "', try --help");
+ raise Option_Error;
+ end if;
+
+ Init (Cmd.all);
+
+ -- decode options.
+
+ First_Arg := 0;
+ Arg_Index := 2;
+ while Arg_Index <= Argument_Count loop
+ declare
+ Arg : String := Argument (Arg_Index);
+ Res : Option_Res;
+ begin
+ if Arg (1) = '-' then
+ -- Argument is an option.
+
+ if First_Arg > 0 then
+ Error ("options after file");
+ raise Option_Error;
+ end if;
+
+ Decode_Option (Cmd.all, Arg, "", Res);
+ case Res is
+ when Option_Bad =>
+ Error ("unknown option '" & Arg & "' for command '"
+ & Argument (1) & "'");
+ raise Option_Error;
+ when Option_Ok =>
+ Arg_Index := Arg_Index + 1;
+ when Option_Arg_Req =>
+ if Arg_Index + 1 > Argument_Count then
+ Error ("option '" & Arg & "' requires an argument");
+ raise Option_Error;
+ end if;
+ Decode_Option
+ (Cmd.all, Arg, Argument (Arg_Index + 1), Res);
+ if Res /= Option_Arg then
+ raise Program_Error;
+ end if;
+ Arg_Index := Arg_Index + 2;
+ when Option_Arg =>
+ raise Program_Error;
+ when Option_End =>
+ First_Arg := Arg_Index;
+ exit;
+ end case;
+ else
+ First_Arg := Arg_Index;
+ exit;
+ end if;
+ end;
+ end loop;
+
+ if First_Arg = 0 then
+ First_Arg := Argument_Count + 1;
+ end if;
+
+ declare
+ Args : Argument_List (1 .. Argument_Count - First_Arg + 1);
+ begin
+ for I in Args'Range loop
+ Args (I) := new String'(Argument (First_Arg + I - 1));
+ end loop;
+ Perform_Action (Cmd.all, Args);
+ for I in Args'Range loop
+ Free (Args (I));
+ end loop;
+ end;
+ --if Flags.Dump_Stats then
+ -- Name_Table.Disp_Stats;
+ -- Iirs.Disp_Stats;
+ --end if;
+ Set_Exit_Status (Success);
+ exception
+ when Option_Error
+ | Compile_Error
+ | Errorout.Compilation_Error =>
+ Set_Exit_Status (Failure);
+ when Exec_Error =>
+ Set_Exit_Status (3);
+ when E: others =>
+ Bug.Disp_Bug_Box (E);
+ Set_Exit_Status (2);
+ end Main;
+
+ procedure Register_Commands is
+ begin
+ Register_Command (new Command_Help);
+ Register_Command (new Command_Option_Help);
+ Register_Command (new Command_Version);
+ end Register_Commands;
+end Ghdlmain;
+
diff --git a/translate/ghdldrv/ghdlmain.ads b/translate/ghdldrv/ghdlmain.ads
new file mode 100644
index 0000000..c01f1d6
--- /dev/null
+++ b/translate/ghdldrv/ghdlmain.ads
@@ -0,0 +1,85 @@
+-- GHDL driver - main part.
+-- 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 GNAT.OS_Lib; use GNAT.OS_Lib;
+with Errorout;
+
+package Ghdlmain is
+ type Command_Type;
+
+ type Command_Acc is access all Command_Type'Class;
+
+ type Command_Type is abstract tagged record
+ Next : Command_Acc;
+ end record;
+
+ -- Return TRUE iff CMD handle action ACTION.
+ function Decode_Command (Cmd : Command_Type; Name : String) return Boolean
+ is abstract;
+
+ -- Initialize the command, before decoding actions.
+ procedure Init (Cmd : in out Command_Type);
+
+ -- Option_OK: OPTION is handled.
+ -- Option_Bad: OPTION is unknown.
+ -- Option_Arg_Req: OPTION requires an argument. Must be set only when
+ -- ARG = "", the manager will recall Decode_Option.
+ -- Option_Arg: OPTION used the argument.
+ type Option_Res is
+ (Option_Bad, Option_Ok, Option_Arg, Option_Arg_Req, Option_End);
+ procedure Decode_Option (Cmd : in out Command_Type;
+ Option : String;
+ Arg : String;
+ Res : out Option_Res);
+
+ -- Get a one-line help for the command.
+ function Get_Short_Help (Cmd : Command_Type) return String
+ is abstract;
+
+ -- Disp detailled help.
+ procedure Disp_Long_Help (Cmd : Command_Type);
+
+ -- Perform the action.
+ procedure Perform_Action (Cmd : in out Command_Type; Args : Argument_List)
+ is abstract;
+
+ -- Register a command.
+ procedure Register_Command (Cmd : Command_Acc);
+
+ -- Disp MSG on the standard output with the command name.
+ procedure Error (Msg : String);
+
+ -- May be raise by perform_action if the arguments are bad.
+ Option_Error : exception renames Errorout.Option_Error;
+
+ -- Action failed.
+ Compile_Error : exception;
+
+ -- Exec failed: either the program was not found, or failed.
+ Exec_Error : exception;
+
+ procedure Main;
+
+ -- Additionnal one-line message displayed by the --version command,
+ -- if defined.
+ -- Used to customize.
+ type String_Cst_Acc is access constant String;
+ Version_String : String_Cst_Acc := null;
+
+ -- Registers all commands in this package.
+ procedure Register_Commands;
+end Ghdlmain;
diff --git a/translate/ghdldrv/ghdlprint.adb b/translate/ghdldrv/ghdlprint.adb
new file mode 100644
index 0000000..d9de2df
--- /dev/null
+++ b/translate/ghdldrv/ghdlprint.adb
@@ -0,0 +1,1561 @@
+-- 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 Types; use Types;
+with Flags;
+with Name_Table; use Name_Table;
+with Files_Map;
+with Libraries;
+with Errorout; use Errorout;
+with Iirs; use Iirs;
+with Tokens;
+with Scan;
+with Version;
+with Xrefs;
+with Ghdlmain; use Ghdlmain;
+with Ghdllocal; use Ghdllocal;
+
+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 ("&gt;");
+ when '<' =>
+ Put ("&lt;");
+ when '&' =>
+ Put ("&amp;");
+ 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;
+
+ procedure PP_Html_File (File : Source_File_Entry)
+ is
+ use Scan;
+ use Tokens;
+ use Files_Map;
+ use Ada.Characters.Latin_1;
+
+ Line : Natural;
+ Buf : File_Buffer_Acc;
+ Prev_Tok : Token_Type;
+
+ -- True if tokens are between 'end' and ';'
+ In_End : Boolean := False;
+
+ -- 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 ("<font size=-1>");
+ when Html_Css =>
+ Put ("<i>");
+ 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 ("</font>");
+ when Html_Css =>
+ Put ("</i>");
+ 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 + 8;
+ N_Col := N_Col - N_Col mod 8;
+ 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 ("<font color=red>");
+ Disp_Text;
+ Put ("</font>");
+ when Html_Css =>
+ Put ("<em>");
+ Disp_Text;
+ Put ("</em>");
+ 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 Xrefs;
+ Ref : Xref;
+ Decl : Iir;
+ Bod : Iir;
+ Loc : Location_Type;
+ begin
+ Disp_Spaces;
+ if Flags.Flag_Xref then
+ Loc := File_Pos_To_Location (File, Bef_Tok);
+ Ref := Find (Loc);
+ if Ref = Bad_Xref then
+ Disp_Text;
+ Warning_Msg_Sem ("cannot find xref", Loc);
+ return;
+ end if;
+ else
+ Disp_Text;
+ return;
+ end if;
+ case Get_Xref_Kind (Ref) is
+ when Xref_Decl =>
+ Put ("<a");
+ Disp_Anchor (Loc);
+ Decl := Get_Xref_Node (Ref);
+ case Get_Kind (Decl) is
+ when Iir_Kind_Function_Declaration
+ | Iir_Kind_Procedure_Declaration =>
+ 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 ("</a>");
+ when Xref_Ref
+ | Xref_End =>
+ Decl := Get_Xref_Node (Ref);
+ Loc := Get_Location (Decl);
+ if Loc /= Location_Nil then
+ Put ("<a");
+ Disp_Href (Loc);
+ Put (">");
+ Disp_Text;
+ Put ("</a>");
+ else
+ -- This may happen for overload list, in use clauses.
+ Disp_Text;
+ end if;
+ when Xref_Body =>
+ Put ("<a");
+ Disp_Anchor (Loc);
+ Disp_Href (Get_Location (Get_Xref_Node (Ref)));
+ Put (">");
+ Disp_Text;
+ Put ("</a>");
+ end case;
+ end Disp_Identifier;
+
+ procedure Disp_Attribute
+ is
+ use 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 ("<font color=orange>");
+ Disp_Text;
+ Put ("</font>");
+ when Html_Css =>
+ Put ("<var>");
+ Disp_Text;
+ Put ("</var>");
+ end case;
+ else
+ Decl := Get_Xref_Node (Ref);
+ Loc := Get_Location (Decl);
+ Put ("<a");
+ Disp_Href (Loc);
+ Put (">");
+ Disp_Text;
+ Put ("</a>");
+ end if;
+ end Disp_Attribute;
+ begin
+ Scan.Flag_Comment := True;
+ Scan.Flag_Newline := True;
+
+ Set_File (File);
+ Buf := Get_File_Source (File);
+
+ Put_Line ("<pre>");
+ 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 ("<font color=green>");
+ Disp_Text;
+ Put ("</font>");
+ when Html_Css =>
+ Put ("<tt>");
+ Disp_Text;
+ Put ("</tt>");
+ 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 ("<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);
+ 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 (" <title>");
+ for I in Files'Range loop
+ Put (" ");
+ Put_Line (Files (I).all);
+ end loop;
+ Put_Line (" </title>");
+ Put_Line ("</head>");
+ New_Line;
+ Put_Line ("<body>");
+
+ for I in Files'Range loop
+ Id := Get_Identifier (Files (I).all);
+ Fe := Files_Map.Load_Source_File (Local_Id, Id);
+ if Fe = No_Source_File_Entry then
+ Error ("cannot open file " & Files (I).all);
+ raise Compile_Error;
+ end if;
+ Put (" <h1>");
+ Put (Files (I).all);
+ Put ("</h1>");
+ New_Line;
+
+ PP_Html_File (Fe);
+ end loop;
+ Put_Html_Foot;
+ end Perform_Action;
+
+ -- Command --xref-html.
+ type Command_Xref_Html is new Command_Html with record
+ Output_Dir : String_Access := null;
+ end record;
+
+ function Decode_Command (Cmd : Command_Xref_Html; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Xref_Html) return String;
+ procedure Decode_Option (Cmd : in out Command_Xref_Html;
+ Option : String;
+ Arg : String;
+ Res : out Option_Res);
+ procedure Disp_Long_Help (Cmd : Command_Xref_Html);
+
+ procedure Perform_Action (Cmd : in out Command_Xref_Html;
+ Files_Name : Argument_List);
+
+ function Decode_Command (Cmd : Command_Xref_Html; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "--xref-html";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Xref_Html) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "--xref-html FILEs Display FILEs in HTML with xrefs";
+ end Get_Short_Help;
+
+ procedure Decode_Option (Cmd : in out Command_Xref_Html;
+ Option : String;
+ Arg : String;
+ Res : out Option_Res)
+ is
+ begin
+ if Option = "-o" then
+ if Arg = "" then
+ Res := Option_Arg_Req;
+ else
+ Cmd.Output_Dir := new String'(Arg);
+ Res := Option_Arg;
+ end if;
+ else
+ Decode_Option (Command_Html (Cmd), Option, Arg, Res);
+ end if;
+ end Decode_Option;
+
+ procedure Disp_Long_Help (Cmd : Command_Xref_Html)
+ is
+ use Ada.Text_IO;
+ begin
+ Disp_Long_Help (Command_Html (Cmd));
+ Put_Line ("-o DIR Put generated files into DIR (def: html/)");
+ New_Line;
+ Put_Line ("When format is css, the CSS file 'ghdl.css' "
+ & "is never overwritten.");
+ end Disp_Long_Help;
+
+ procedure Analyze_Design_File_Units (File : Iir_Design_File)
+ is
+ Unit : Iir_Design_Unit;
+ begin
+ Unit := Get_First_Design_Unit (File);
+ while Unit /= Null_Iir loop
+ case Get_Date_State (Unit) is
+ when Date_Extern
+ | Date_Disk =>
+ raise Internal_Error;
+ when Date_Parse =>
+ Libraries.Load_Design_Unit (Unit, Null_Iir);
+ when Date_Analyze =>
+ null;
+ end case;
+ Unit := Get_Chain (Unit);
+ end loop;
+ end Analyze_Design_File_Units;
+
+ procedure Perform_Action
+ (Cmd : in out Command_Xref_Html; Files_Name : Argument_List)
+ is
+ use GNAT.Directory_Operations;
+
+ Id : Name_Id;
+ File : Source_File_Entry;
+
+ type File_Data is record
+ Fe : Source_File_Entry;
+ Design_File : Iir;
+ Output : String_Acc;
+ end record;
+ type File_Data_Array is array (Files_Name'Range) of File_Data;
+
+ Files : File_Data_Array;
+ Output : File_Type;
+ Prev_Output : File_Access;
+ begin
+ Xrefs.Init;
+ Flags.Flag_Xref := True;
+
+ -- Load work library.
+ Setup_Libraries (True);
+
+ if Cmd.Output_Dir = null then
+ Cmd.Output_Dir := new String'("html");
+ elsif Cmd.Output_Dir.all = "-" then
+ Cmd.Output_Dir := null;
+ end if;
+
+ -- Try to create the directory.
+ if Cmd.Output_Dir /= null
+ and then not Is_Directory (Cmd.Output_Dir.all)
+ then
+ declare
+ begin
+ Make_Dir (Cmd.Output_Dir.all);
+ exception
+ when Directory_Error =>
+ Error ("cannot create directory " & Cmd.Output_Dir.all);
+ return;
+ end;
+ end if;
+
+ -- Parse all files.
+ for I in Files'Range loop
+ Id := Get_Identifier (Files_Name (I).all);
+ File := Files_Map.Load_Source_File (Libraries.Local_Directory, Id);
+ if File = No_Source_File_Entry then
+ Error ("cannot open " & Image (Id));
+ return;
+ end if;
+ Files (I).Fe := File;
+ Files (I).Design_File := Libraries.Load_File (File);
+ if Files (I).Design_File = Null_Iir then
+ return;
+ end if;
+ Files (I).Output := Create_Output_Filename
+ (Base_Name (Files_Name (I).all), I);
+ if Is_Regular_File (Files (I).Output.all) then
+ -- Prevent overwrite.
+ null;
+ end if;
+ -- Put units in library.
+ Libraries.Add_Design_File_Into_Library (Files (I).Design_File);
+ end loop;
+
+ -- Analyze all files.
+ for I in Files'Range loop
+ Analyze_Design_File_Units (Files (I).Design_File);
+ end loop;
+
+ Xrefs.Sort_By_Location;
+
+ if False then
+ for I in 1 .. Xrefs.Get_Last_Xref loop
+ declare
+ use Xrefs;
+
+ procedure Put_Loc (L : Location_Type)
+ is
+ use Files_Map;
+
+ L_File : Source_File_Entry;
+ L_Pos : Source_Ptr;
+ begin
+ Files_Map.Location_To_File_Pos (L, L_File, L_Pos);
+ Put_Nat (Natural (L_File));
+ --Image (Get_File_Name (L_File));
+ --Put (Name_Buffer (1 .. Name_Length));
+ Put (":");
+ Put_Nat (Natural (L_Pos));
+ end Put_Loc;
+ begin
+ Put_Loc (Get_Xref_Location (I));
+ case Get_Xref_Kind (I) is
+ when Xref_Decl =>
+ Put (" decl ");
+ Put (Image (Get_Identifier (Get_Xref_Node (I))));
+ when Xref_Ref =>
+ Put (" use ");
+ Put_Loc (Get_Location (Get_Xref_Node (I)));
+ when Xref_End =>
+ Put (" end ");
+ when Xref_Body =>
+ Put (" body ");
+ end case;
+ New_Line;
+ end;
+ end loop;
+ end if;
+
+ -- Create filexref_info.
+ Filexref_Info := new Filexref_Info_Arr
+ (No_Source_File_Entry .. Files_Map.Get_Last_Source_File_Entry);
+ Filexref_Info.all := (others => (Output => null,
+ Referenced => False));
+ for I in Files'Range loop
+ Filexref_Info (Files (I).Fe).Output := Files (I).Output;
+ end loop;
+
+ Prev_Output := Current_Input;
+
+ for I in Files'Range loop
+ if Cmd.Output_Dir /= null then
+ Create (Output, Out_File,
+ Cmd.Output_Dir.all & Directory_Separator
+ & Files (I).Output.all);
+
+ Set_Output (Output);
+ end if;
+
+ Put_Html_Header;
+ Put_Line (" <title>");
+ Put_Html (Files_Name (I).all);
+ Put ("</title>");
+ Put_Line ("</head>");
+ New_Line;
+ Put_Line ("<body>");
+
+ Put ("<h1>");
+ Put_Html (Files_Name (I).all);
+ Put ("</h1>");
+ New_Line;
+
+ PP_Html_File (Files (I).Fe);
+ Put_Html_Foot;
+
+ if Cmd.Output_Dir /= null then
+ Close (Output);
+ end if;
+ end loop;
+
+ -- Create indexes.
+ if Cmd.Output_Dir /= null then
+ Create (Output, Out_File,
+ Cmd.Output_Dir.all & Directory_Separator & "index.html");
+ Set_Output (Output);
+
+ Put_Html_Header;
+ Put_Line (" <title>Xrefs indexes</title>");
+ Put_Line ("</head>");
+ New_Line;
+ Put_Line ("<body>");
+ Put_Line ("<p>list of files:");
+ Put_Line ("<ul>");
+ for I in Files'Range loop
+ Put ("<li>");
+ Put ("<a href=""");
+ Put (Files (I).Output.all);
+ Put (""">");
+ Put_Html (Files_Name (I).all);
+ Put ("</a>");
+ Put ("</li>");
+ New_Line;
+ end loop;
+ Put_Line ("</ul></p>");
+ Put_Line ("<hr>");
+
+ -- TODO: list of design units.
+
+ Put_Line ("<p>list of files referenced but not available:");
+ Put_Line ("<ul>");
+ for I in No_Source_File_Entry + 1 .. Filexref_Info'Last loop
+ if Filexref_Info (I).Output = null
+ and then Filexref_Info (I).Referenced
+ then
+ Put ("<li><a name=""f");
+ Put_Nat (Natural (I));
+ Put (""">");
+ Put_Html (Image (Files_Map.Get_File_Name (I)));
+ Put ("</a></li>");
+ New_Line;
+ end if;
+ end loop;
+ Put_Line ("</ul></p><hr>");
+ Put_Html_Foot;
+
+ Close (Output);
+ end if;
+
+ if Html_Format = Html_Css
+ and then Cmd.Output_Dir /= null
+ then
+ declare
+ Css_Filename : String :=
+ Cmd.Output_Dir.all & Directory_Separator & "ghdl.css";
+ begin
+ if not Is_Regular_File (Css_Filename & Nul) then
+ Create (Output, Out_File, Css_Filename);
+ Set_Output (Output);
+ Put_Css;
+ Close (Output);
+ end if;
+ end;
+ end if;
+ exception
+ when Compilation_Error =>
+ Error ("xrefs has failed due to compilation error");
+ end Perform_Action;
+
+
+ -- Command --xref
+ type Command_Xref is new Command_Lib with null record;
+
+ function Decode_Command (Cmd : Command_Xref; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Xref) return String;
+
+ procedure Perform_Action (Cmd : in out Command_Xref;
+ Files_Name : Argument_List);
+
+ function Decode_Command (Cmd : Command_Xref; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "--xref";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Xref) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "--xref FILEs Generate xrefs";
+ end Get_Short_Help;
+
+ procedure Perform_Action
+ (Cmd : in out Command_Xref; Files_Name : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+
+ use Files_Map;
+
+ Id : Name_Id;
+ File : Source_File_Entry;
+
+ type File_Data is record
+ Fe : Source_File_Entry;
+ Design_File : Iir;
+ end record;
+ type File_Data_Array is array (Files_Name'Range) of File_Data;
+
+ Files : File_Data_Array;
+ begin
+ -- Load work library.
+ Setup_Libraries (True);
+
+ Xrefs.Init;
+ Flags.Flag_Xref := True;
+
+ -- Parse all files.
+ for I in Files'Range loop
+ Id := Get_Identifier (Files_Name (I).all);
+ File := Load_Source_File (Libraries.Local_Directory, Id);
+ if File = No_Source_File_Entry then
+ Error ("cannot open " & Image (Id));
+ return;
+ end if;
+ Files (I).Fe := File;
+ Files (I).Design_File := Libraries.Load_File (File);
+ if Files (I).Design_File = Null_Iir then
+ return;
+ end if;
+ -- Put units in library.
+ -- Note: design_units stay while design_file get empty.
+ Libraries.Add_Design_File_Into_Library (Files (I).Design_File);
+ end loop;
+
+ -- Analyze all files.
+ for I in Files'Range loop
+ Analyze_Design_File_Units (Files (I).Design_File);
+ end loop;
+
+ Xrefs.Fix_End_Xrefs;
+ Xrefs.Sort_By_Node_Location;
+
+ for F in Files'Range loop
+
+ Put ("GHDL-XREF V0");
+
+ declare
+ use Xrefs;
+
+ Cur_Decl : Iir;
+ Cur_File : Source_File_Entry;
+
+ procedure Emit_Loc (Loc : Location_Type; C : Character)
+ is
+ L_File : Source_File_Entry;
+ L_Pos : Source_Ptr;
+ L_Line : Natural;
+ L_Off : Natural;
+ begin
+ Location_To_Coord (Loc, L_File, L_Pos, L_Line, L_Off);
+ --Put_Nat (Natural (L_File));
+ --Put (':');
+ Put_Nat (L_Line);
+ Put (C);
+ Put_Nat (L_Off);
+ end Emit_Loc;
+
+ procedure Emit_Decl (N : Iir)
+ is
+ Loc : Location_Type;
+ Loc_File : Source_File_Entry;
+ Loc_Pos : Source_Ptr;
+ C : Character;
+ begin
+ New_Line;
+ Cur_Decl := N;
+ Loc := Get_Location (N);
+ Location_To_File_Pos (Loc, Loc_File, Loc_Pos);
+ if Loc_File /= Cur_File then
+ Cur_File := Loc_File;
+ Put ("XFILE: ");
+ Image (Get_Source_File_Directory (Cur_File));
+ Put (Name_Buffer (1 .. Name_Length));
+ Image (Get_File_Name (Cur_File));
+ Put (Name_Buffer (1 .. Name_Length));
+ New_Line;
+ end if;
+
+ -- Letters:
+ -- b d fgh jk no qr uvwxyz
+ -- D H JK MNO QR U WXYZ
+ case Get_Kind (N) is
+ when Iir_Kind_Type_Declaration =>
+ C := 'T';
+ when Iir_Kind_Subtype_Declaration =>
+ C := 't';
+ when Iir_Kind_Entity_Declaration =>
+ C := 'E';
+ when Iir_Kind_Architecture_Declaration =>
+ C := 'A';
+ when Iir_Kind_Library_Declaration =>
+ C := 'L';
+ when Iir_Kind_Package_Declaration =>
+ C := 'P';
+ when Iir_Kind_Package_Body =>
+ C := 'B';
+ when Iir_Kind_Function_Declaration =>
+ C := 'F';
+ when Iir_Kind_Procedure_Declaration =>
+ C := 'p';
+ when Iir_Kind_Signal_Interface_Declaration =>
+ C := 's';
+ when Iir_Kind_Signal_Declaration =>
+ C := 'S';
+ when Iir_Kind_Constant_Interface_Declaration =>
+ C := 'c';
+ when Iir_Kind_Constant_Declaration =>
+ C := 'C';
+ when Iir_Kind_Variable_Declaration =>
+ C := 'V';
+ when Iir_Kind_Element_Declaration =>
+ C := 'e';
+ when Iir_Kind_Iterator_Declaration =>
+ C := 'i';
+ when Iir_Kind_Attribute_Declaration =>
+ C := 'a';
+ when Iir_Kind_Enumeration_Literal =>
+ C := 'l';
+ when Iir_Kind_Component_Declaration =>
+ C := 'm';
+ when Iir_Kind_Component_Instantiation_Statement =>
+ C := 'I';
+ when Iir_Kind_Generate_Statement =>
+ C := 'G';
+ when others =>
+ C := '?';
+ end case;
+ Emit_Loc (Loc, C);
+ --Disp_Tree.Disp_Iir_Address (N);
+ Put (' ');
+ case Get_Kind (N) is
+ when Iir_Kind_Function_Body
+ | Iir_Kind_Procedure_Body =>
+ null;
+ when others =>
+ Image (Get_Identifier (N));
+ Put (Name_Buffer (1 .. Name_Length));
+ end case;
+ end Emit_Decl;
+
+ procedure Emit_Ref (R : Xref; T : Character)
+ is
+ N : Iir;
+ begin
+ N := Get_Xref_Node (R);
+ if N /= Cur_Decl then
+ Emit_Decl (N);
+ end if;
+ Put (' ');
+ Emit_Loc (Get_Xref_Location (R), T);
+ end Emit_Ref;
+
+ Loc : Location_Type;
+ Loc_File : Source_File_Entry;
+ Loc_Pos : Source_Ptr;
+ begin
+ Cur_Decl := Null_Iir;
+ Cur_File := No_Source_File_Entry;
+
+ for I in First_Xref .. Get_Last_Xref loop
+ Loc := Get_Xref_Location (I);
+ Location_To_File_Pos (Loc, Loc_File, Loc_Pos);
+ if Loc_File = Files (F).Fe then
+ -- This is a local location.
+ case Get_Xref_Kind (I) is
+ when Xref_Decl =>
+ Emit_Decl (Get_Xref_Node (I));
+ when Xref_End =>
+ Emit_Ref (I, 'e');
+ when Xref_Ref =>
+ Emit_Ref (I, 'r');
+ when Xref_Body =>
+ Emit_Ref (I, 'b');
+ when others =>
+ null;
+ end case;
+ end if;
+ end loop;
+ New_Line;
+ end;
+ end loop;
+ exception
+ when Compilation_Error =>
+ Error ("xrefs has failed due to compilation error");
+ end Perform_Action;
+
+ procedure Register_Commands is
+ begin
+ Register_Command (new Command_Chop);
+ Register_Command (new Command_Lines);
+ Register_Command (new Command_PP_Html);
+ Register_Command (new Command_Xref_Html);
+ Register_Command (new Command_Xref);
+ end Register_Commands;
+end Ghdlprint;
diff --git a/translate/ghdldrv/ghdlprint.ads b/translate/ghdldrv/ghdlprint.ads
new file mode 100644
index 0000000..e52bc00
--- /dev/null
+++ b/translate/ghdldrv/ghdlprint.ads
@@ -0,0 +1,22 @@
+-- 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.
+package Ghdlprint is
+ procedure Register_Commands;
+end Ghdlprint;
+
+
diff --git a/translate/ghdldrv/ghdlrun.adb b/translate/ghdldrv/ghdlrun.adb
new file mode 100644
index 0000000..df64ebc
--- /dev/null
+++ b/translate/ghdldrv/ghdlrun.adb
@@ -0,0 +1,658 @@
+-- GHDL driver - JIT 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 Interfaces.C;
+
+with Ghdlmain; use Ghdlmain;
+with Ghdllocal; use Ghdllocal;
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+
+with Ada.Unchecked_Conversion;
+with Ada.Command_Line;
+with Ada.Text_IO;
+
+with Binary_File; use Binary_File;
+with Binary_File.Memory;
+with Ortho_Mcode; use Ortho_Mcode;
+with Ortho_Code.Flags; use Ortho_Code.Flags;
+with Binary_File;
+with Interfaces;
+with System; use System;
+with Trans_Decls;
+with Ortho_Code.Binary;
+with Ortho_Code.Debug;
+with Ortho_Code.X86.Emits;
+with Types;
+with Iirs; use Iirs;
+with Flags;
+with Back_End;
+with Errorout; use Errorout;
+with Libraries;
+with Canon;
+with Trans_Be;
+with Translation;
+with Std_Names;
+with Ieee.Std_Logic_1164;
+
+with Binary_File.Elf;
+
+with Lists;
+with Str_Table;
+with Nodes;
+with Files_Map;
+with Name_Table;
+
+with Grt.Main;
+with Grt.Lib;
+with Grt.Processes;
+with Grt.Rtis;
+with Grt.Files;
+with Grt.Signals;
+with Grt.Options;
+with Grt.Types;
+with Grt.Images;
+with Grt.Values;
+with Grt.Names;
+
+with Ghdlcomp;
+
+package body Ghdlrun is
+ Snap_Filename : String_Access := null;
+
+ procedure Compile_Init (Analyze_Only : Boolean) is
+ begin
+ Back_End.Sem_Foreign := Trans_Be.Sem_Foreign'Access;
+
+ if Analyze_Only then
+ return;
+ end if;
+
+ -- Initialize.
+ Back_End.Finish_Compilation := Trans_Be.Finish_Compilation'Access;
+
+ Setup_Libraries (False);
+ Libraries.Load_Std_Library;
+
+ Ortho_Mcode.Init;
+
+ Translation.Initialize;
+ Canon.Canon_Flag_Add_Labels := True;
+ end Compile_Init;
+
+ procedure Compile_Elab
+ (Cmd_Name : String; Args : Argument_List; Opt_Arg : out Natural)
+ is
+ begin
+ Extract_Elab_Unit (Cmd_Name, Args, Opt_Arg);
+ if Sec_Name = null then
+ Sec_Name := new String'("");
+ end if;
+
+ Flags.Flag_Elaborate := True;
+ Translation.Chap12.Elaborate (Prim_Name.all, Sec_Name.all, "", True);
+
+ if Errorout.Nbr_Errors > 0 then
+ -- This may happen (bad entity for example).
+ raise Compilation_Error;
+ end if;
+
+ Ortho_Mcode.Finish;
+ end Compile_Elab;
+
+ -- Set options.
+ -- This is a little bit over-kill: from C to Ada and then again to C...
+ procedure Set_Run_Options (Args : Argument_List)
+ is
+ use Interfaces.C;
+ use Grt.Options;
+ use Grt.Types;
+
+ function Malloc (Size : size_t) return Argv_Type;
+ pragma Import (C, Malloc);
+
+ function Strdup (Str : String) return Ghdl_C_String;
+ pragma Import (C, Strdup);
+-- is
+-- T : Grt.Types.String_Access;
+-- begin
+-- T := new String'(Str & Ghdllocal.Nul);
+-- return To_Ghdl_C_String (T.all'Address);
+-- end Strdup;
+ begin
+ Argc := 1 + Args'Length;
+ Argv := Malloc
+ (size_t (Argc * (Ghdl_C_String'Size / System.Storage_Unit)));
+ Argv (0) := Strdup (Ada.Command_Line.Command_Name & Ghdllocal.Nul);
+ Progname := Argv (0);
+ for I in Args'Range loop
+ Argv (1 + I - Args'First) := Strdup (Args (I).all & Ghdllocal.Nul);
+ end loop;
+ end Set_Run_Options;
+
+ -- Toplevel function, defined by grt.
+ Flag_String : String (1 .. 5);
+ pragma Export (C, Flag_String, "__ghdl_flag_string");
+
+ procedure Ghdl_Elaborate;
+ pragma Export (C, Ghdl_Elaborate, "__ghdl_ELABORATE");
+
+ type Elaborate_Acc is access procedure;
+ Elaborate_Proc : Elaborate_Acc := null;
+
+ procedure Ghdl_Elaborate is
+ begin
+ --Ada.Text_IO.Put_Line (Standard_Error, "ghdl_elaborate");
+ Elaborate_Proc.all;
+ end Ghdl_Elaborate;
+
+ Std_Standard_Bit_RTI_Ptr : Address := Null_Address;
+
+ Std_Standard_Boolean_RTI_Ptr : Address := Null_Address;
+
+ pragma Export (C, Std_Standard_Bit_RTI_Ptr,
+ "std__standard__bit__RTI_ptr");
+
+ pragma Export (C, Std_Standard_Boolean_RTI_Ptr,
+ "std__standard__boolean__RTI_ptr");
+
+ Ieee_Std_Logic_1164_Resolved_Resolv_Ptr : Address := Null_Address;
+ pragma Export (C, Ieee_Std_Logic_1164_Resolved_Resolv_Ptr,
+ "ieee__std_logic_1164__resolved_RESOLV_ptr");
+
+ -- From GCC.
+ function Divdi3 (A, B : Long_Integer) return Long_Integer;
+ pragma Import (C, Divdi3, "__divdi3");
+
+ function Muldi3 (A, B : Long_Integer) return Long_Integer;
+ pragma Import (C, Muldi3, "__muldi3");
+
+ function Find_Untruncated_Text_Read return O_Dnode
+ is
+ use Types;
+ use Std_Names;
+ File, Unit, Lib, Decl : Iir;
+ begin
+ if Libraries.Std_Library = Null_Iir then
+ return O_Dnode_Null;
+ end if;
+ File := Get_Design_File_Chain (Libraries.Std_Library);
+ L1 : loop
+ if File = Null_Iir then
+ return O_Dnode_Null;
+ end if;
+ Unit := Get_First_Design_Unit (File);
+ while Unit /= Null_Iir loop
+ Lib := Get_Library_Unit (Unit);
+ if Get_Kind (Lib) = Iir_Kind_Package_Body
+ and then Get_Identifier (Lib) = Name_Textio
+ then
+ exit L1;
+ end if;
+ Unit := Get_Chain (Unit);
+ end loop;
+ File := Get_Chain (File);
+ end loop L1;
+
+ Decl := Get_Declaration_Chain (Lib);
+ while Decl /= Null_Iir loop
+ if Get_Kind (Decl) = Iir_Kind_Procedure_Declaration
+ and then Get_Identifier (Decl) = Name_Untruncated_Text_Read
+ then
+ if not Get_Foreign_Flag (Decl) then
+ raise Program_Error;
+ end if;
+ return Translation.Get_Ortho_Decl (Decl);
+ end if;
+ Decl := Get_Chain (Decl);
+ end loop;
+ return O_Dnode_Null;
+ end Find_Untruncated_Text_Read;
+
+ procedure Def (Decl : O_Dnode; Addr : Address)
+ is
+ use Ortho_Code.Binary;
+ begin
+ Binary_File.Memory.Set_Symbol_Address (Get_Decl_Symbol (Decl), Addr);
+ end Def;
+
+ function Get_Address (Decl : O_Dnode) return Address
+ is
+ use Interfaces;
+ use Ortho_Code.Binary;
+
+ function Conv is new Ada.Unchecked_Conversion
+ (Source => Unsigned_32, Target => Address);
+ begin
+ return Conv (Get_Symbol_Vaddr (Get_Decl_Symbol (Decl)));
+ end Get_Address;
+
+ procedure Run
+ is
+ use Binary_File;
+ use Interfaces;
+ use Ortho_Code.Binary;
+
+ function Conv is new Ada.Unchecked_Conversion
+ (Source => Address, Target => Elaborate_Acc);
+ Err : Boolean;
+ Decl : O_Dnode;
+ begin
+ if Flag_Verbose then
+ Ada.Text_IO.Put_Line ("Linking in memory");
+ end if;
+
+ if Ortho_Code.Debug.Flag_Debug_Hli then
+ -- Can't generate code in HLI.
+ raise Compile_Error;
+ end if;
+
+ Binary_File.Memory.Write_Memory_Init;
+
+ Def (Trans_Decls.Ghdl_Memcpy,
+ Grt.Lib.Ghdl_Memcpy'Address);
+ Def (Trans_Decls.Ghdl_Bound_Check_Failed_L0,
+ Grt.Lib.Ghdl_Bound_Check_Failed_L0'Address);
+ Def (Trans_Decls.Ghdl_Bound_Check_Failed_L1,
+ Grt.Lib.Ghdl_Bound_Check_Failed_L1'Address);
+ Def (Trans_Decls.Ghdl_Malloc0,
+ Grt.Lib.Ghdl_Malloc0'Address);
+ Def (Trans_Decls.Ghdl_Assert_Default_Report,
+ Grt.Lib.Ghdl_Assert_Default_Report'Address);
+
+ Def (Trans_Decls.Ghdl_Report,
+ Grt.Lib.Ghdl_Report'Address);
+ Def (Trans_Decls.Ghdl_Assert_Failed,
+ Grt.Lib.Ghdl_Assert_Failed'Address);
+ Def (Trans_Decls.Ghdl_Program_Error,
+ Grt.Lib.Ghdl_Program_Error'Address);
+ Def (Trans_Decls.Ghdl_Malloc,
+ Grt.Lib.Ghdl_Malloc'Address);
+ Def (Trans_Decls.Ghdl_Deallocate,
+ Grt.Lib.Ghdl_Deallocate'Address);
+ Def (Trans_Decls.Ghdl_Real_Exp,
+ Grt.Lib.Ghdl_Real_Exp'Address);
+ Def (Trans_Decls.Ghdl_Integer_Exp,
+ Grt.Lib.Ghdl_Integer_Exp'Address);
+
+ Def (Trans_Decls.Ghdl_Sensitized_Process_Register,
+ Grt.Processes.Ghdl_Sensitized_Process_Register'Address);
+ Def (Trans_Decls.Ghdl_Process_Register,
+ Grt.Processes.Ghdl_Process_Register'Address);
+ Def (Trans_Decls.Ghdl_Postponed_Sensitized_Process_Register,
+ Grt.Processes.Ghdl_Postponed_Sensitized_Process_Register'Address);
+ Def (Trans_Decls.Ghdl_Postponed_Process_Register,
+ Grt.Processes.Ghdl_Postponed_Process_Register'Address);
+ Def (Trans_Decls.Ghdl_Stack2_Allocate,
+ Grt.Processes.Ghdl_Stack2_Allocate'Address);
+ Def (Trans_Decls.Ghdl_Stack2_Mark,
+ Grt.Processes.Ghdl_Stack2_Mark'Address);
+ Def (Trans_Decls.Ghdl_Stack2_Release,
+ Grt.Processes.Ghdl_Stack2_Release'Address);
+ Def (Trans_Decls.Ghdl_Process_Wait_Exit,
+ Grt.Processes.Ghdl_Process_Wait_Exit'Address);
+ Def (Trans_Decls.Ghdl_Process_Wait_Suspend,
+ Grt.Processes.Ghdl_Process_Wait_Suspend'Address);
+ Def (Trans_Decls.Ghdl_Process_Wait_Timeout,
+ Grt.Processes.Ghdl_Process_Wait_Timeout'Address);
+ Def (Trans_Decls.Ghdl_Process_Wait_Set_Timeout,
+ Grt.Processes.Ghdl_Process_Wait_Set_Timeout'Address);
+ Def (Trans_Decls.Ghdl_Process_Wait_Add_Sensitivity,
+ Grt.Processes.Ghdl_Process_Wait_Add_Sensitivity'Address);
+ Def (Trans_Decls.Ghdl_Process_Wait_Close,
+ Grt.Processes.Ghdl_Process_Wait_Close'Address);
+
+ Def (Trans_Decls.Ghdl_Process_Add_Sensitivity,
+ Grt.Processes.Ghdl_Process_Add_Sensitivity'Address);
+
+ Def (Trans_Decls.Ghdl_Now,
+ Grt.Types.Current_Time'Address);
+
+ Def (Trans_Decls.Ghdl_Process_Add_Driver,
+ Grt.Signals.Ghdl_Process_Add_Driver'Address);
+ Def (Trans_Decls.Ghdl_Signal_Add_Source,
+ Grt.Signals.Ghdl_Signal_Add_Source'Address);
+ Def (Trans_Decls.Ghdl_Signal_In_Conversion,
+ Grt.Signals.Ghdl_Signal_In_Conversion'Address);
+ Def (Trans_Decls.Ghdl_Signal_Out_Conversion,
+ Grt.Signals.Ghdl_Signal_Out_Conversion'Address);
+ Def (Trans_Decls.Ghdl_Signal_Effective_Value,
+ Grt.Signals.Ghdl_Signal_Effective_Value'Address);
+ Def (Trans_Decls.Ghdl_Signal_Create_Resolution,
+ Grt.Signals.Ghdl_Signal_Create_Resolution'Address);
+
+ Def (Trans_Decls.Ghdl_Signal_Disconnect,
+ Grt.Signals.Ghdl_Signal_Disconnect'Address);
+ Def (Trans_Decls.Ghdl_Signal_Set_Disconnect,
+ Grt.Signals.Ghdl_Signal_Set_Disconnect'Address);
+ Def (Trans_Decls.Ghdl_Signal_Merge_Rti,
+ Grt.Signals.Ghdl_Signal_Merge_Rti'Address);
+ Def (Trans_Decls.Ghdl_Signal_Name_Rti,
+ Grt.Signals.Ghdl_Signal_Name_Rti'Address);
+ Def (Trans_Decls.Ghdl_Signal_Read_Port,
+ Grt.Signals.Ghdl_Signal_Read_Port'Address);
+ Def (Trans_Decls.Ghdl_Signal_Read_Driver,
+ Grt.Signals.Ghdl_Signal_Read_Driver'Address);
+
+ Def (Trans_Decls.Ghdl_Signal_Driving,
+ Grt.Signals.Ghdl_Signal_Driving'Address);
+ Def (Trans_Decls.Ghdl_Signal_Driving_Value_B2,
+ Grt.Signals.Ghdl_Signal_Driving_Value_B2'Address);
+ Def (Trans_Decls.Ghdl_Signal_Driving_Value_E8,
+ Grt.Signals.Ghdl_Signal_Driving_Value_E8'Address);
+ Def (Trans_Decls.Ghdl_Signal_Driving_Value_I32,
+ Grt.Signals.Ghdl_Signal_Driving_Value_I32'Address);
+ Def (Trans_Decls.Ghdl_Signal_Driving_Value_I64,
+ Grt.Signals.Ghdl_Signal_Driving_Value_I64'Address);
+ Def (Trans_Decls.Ghdl_Signal_Driving_Value_F64,
+ Grt.Signals.Ghdl_Signal_Driving_Value_F64'Address);
+
+ Def (Trans_Decls.Ghdl_Signal_Create_Guard,
+ Grt.Signals.Ghdl_Signal_Create_Guard'Address);
+ Def (Trans_Decls.Ghdl_Signal_Guard_Dependence,
+ Grt.Signals.Ghdl_Signal_Guard_Dependence'Address);
+
+ Def (Trans_Decls.Ghdl_Signal_Simple_Assign_Error,
+ Grt.Signals.Ghdl_Signal_Simple_Assign_Error'Address);
+ Def (Trans_Decls.Ghdl_Signal_Start_Assign_Error,
+ Grt.Signals.Ghdl_Signal_Start_Assign_Error'Address);
+
+ Def (Trans_Decls.Ghdl_Signal_Start_Assign_Null,
+ Grt.Signals.Ghdl_Signal_Start_Assign_Null'Address);
+
+ Def (Trans_Decls.Ghdl_Create_Signal_B2,
+ Grt.Signals.Ghdl_Create_Signal_B2'Address);
+ Def (Trans_Decls.Ghdl_Signal_Init_B2,
+ Grt.Signals.Ghdl_Signal_Init_B2'Address);
+ Def (Trans_Decls.Ghdl_Signal_Simple_Assign_B2,
+ Grt.Signals.Ghdl_Signal_Simple_Assign_B2'Address);
+ Def (Trans_Decls.Ghdl_Signal_Start_Assign_B2,
+ Grt.Signals.Ghdl_Signal_Start_Assign_B2'Address);
+ Def (Trans_Decls.Ghdl_Signal_Next_Assign_B2,
+ Grt.Signals.Ghdl_Signal_Next_Assign_B2'Address);
+ Def (Trans_Decls.Ghdl_Signal_Associate_B2,
+ Grt.Signals.Ghdl_Signal_Associate_B2'Address);
+
+ Def (Trans_Decls.Ghdl_Create_Signal_E8,
+ Grt.Signals.Ghdl_Create_Signal_E8'Address);
+ Def (Trans_Decls.Ghdl_Signal_Init_E8,
+ Grt.Signals.Ghdl_Signal_Init_E8'Address);
+ Def (Trans_Decls.Ghdl_Signal_Simple_Assign_E8,
+ Grt.Signals.Ghdl_Signal_Simple_Assign_E8'Address);
+ Def (Trans_Decls.Ghdl_Signal_Start_Assign_E8,
+ Grt.Signals.Ghdl_Signal_Start_Assign_E8'Address);
+ Def (Trans_Decls.Ghdl_Signal_Next_Assign_E8,
+ Grt.Signals.Ghdl_Signal_Next_Assign_E8'Address);
+ Def (Trans_Decls.Ghdl_Signal_Associate_E8,
+ Grt.Signals.Ghdl_Signal_Associate_E8'Address);
+
+ Def (Trans_Decls.Ghdl_Create_Signal_I32,
+ Grt.Signals.Ghdl_Create_Signal_I32'Address);
+ Def (Trans_Decls.Ghdl_Signal_Init_I32,
+ Grt.Signals.Ghdl_Signal_Init_I32'Address);
+ Def (Trans_Decls.Ghdl_Signal_Simple_Assign_I32,
+ Grt.Signals.Ghdl_Signal_Simple_Assign_I32'Address);
+ Def (Trans_Decls.Ghdl_Signal_Start_Assign_I32,
+ Grt.Signals.Ghdl_Signal_Start_Assign_I32'Address);
+ Def (Trans_Decls.Ghdl_Signal_Next_Assign_I32,
+ Grt.Signals.Ghdl_Signal_Next_Assign_I32'Address);
+ Def (Trans_Decls.Ghdl_Signal_Associate_I32,
+ Grt.Signals.Ghdl_Signal_Associate_I32'Address);
+
+ Def (Trans_Decls.Ghdl_Create_Signal_I64,
+ Grt.Signals.Ghdl_Create_Signal_I64'Address);
+ Def (Trans_Decls.Ghdl_Signal_Init_I64,
+ Grt.Signals.Ghdl_Signal_Init_I64'Address);
+ Def (Trans_Decls.Ghdl_Signal_Simple_Assign_I64,
+ Grt.Signals.Ghdl_Signal_Simple_Assign_I64'Address);
+ Def (Trans_Decls.Ghdl_Signal_Start_Assign_I64,
+ Grt.Signals.Ghdl_Signal_Start_Assign_I64'Address);
+ Def (Trans_Decls.Ghdl_Signal_Next_Assign_I64,
+ Grt.Signals.Ghdl_Signal_Next_Assign_I64'Address);
+ Def (Trans_Decls.Ghdl_Signal_Associate_I64,
+ Grt.Signals.Ghdl_Signal_Associate_I64'Address);
+
+ Def (Trans_Decls.Ghdl_Create_Signal_F64,
+ Grt.Signals.Ghdl_Create_Signal_F64'Address);
+ Def (Trans_Decls.Ghdl_Signal_Init_F64,
+ Grt.Signals.Ghdl_Signal_Init_F64'Address);
+ Def (Trans_Decls.Ghdl_Signal_Simple_Assign_F64,
+ Grt.Signals.Ghdl_Signal_Simple_Assign_F64'Address);
+ Def (Trans_Decls.Ghdl_Signal_Start_Assign_F64,
+ Grt.Signals.Ghdl_Signal_Start_Assign_F64'Address);
+ Def (Trans_Decls.Ghdl_Signal_Next_Assign_F64,
+ Grt.Signals.Ghdl_Signal_Next_Assign_F64'Address);
+ Def (Trans_Decls.Ghdl_Signal_Associate_F64,
+ Grt.Signals.Ghdl_Signal_Associate_F64'Address);
+
+ Def (Trans_Decls.Ghdl_Signal_Attribute_Register_Prefix,
+ Grt.Signals.Ghdl_Signal_Attribute_Register_Prefix'Address);
+ Def (Trans_Decls.Ghdl_Create_Stable_Signal,
+ Grt.Signals.Ghdl_Create_Stable_Signal'Address);
+ Def (Trans_Decls.Ghdl_Create_Quiet_Signal,
+ Grt.Signals.Ghdl_Create_Quiet_Signal'Address);
+ Def (Trans_Decls.Ghdl_Create_Transaction_Signal,
+ Grt.Signals.Ghdl_Create_Transaction_Signal'Address);
+ Def (Trans_Decls.Ghdl_Create_Delayed_Signal,
+ Grt.Signals.Ghdl_Create_Delayed_Signal'Address);
+
+ Def (Trans_Decls.Ghdl_Rti_Top_Instance,
+ Grt.Rtis.Ghdl_Rti_Top_Instance'Address);
+ Def (Trans_Decls.Ghdl_Rti_Top_Ptr,
+ Grt.Rtis.Ghdl_Rti_Top_Ptr'Address);
+ Std_Standard_Boolean_RTI_Ptr :=
+ Get_Address (Trans_Decls.Std_Standard_Boolean_Rti);
+ Std_Standard_Bit_RTI_Ptr :=
+ Get_Address (Trans_Decls.Std_Standard_Bit_Rti);
+ if Ieee.Std_Logic_1164.Resolved /= Null_Iir then
+ Ieee_Std_Logic_1164_Resolved_Resolv_Ptr := Get_Address
+ (Translation.Get_Resolv_Ortho_Decl (Ieee.Std_Logic_1164.Resolved));
+ end if;
+
+ Def (Trans_Decls.Ghdl_Protected_Enter,
+ Grt.Processes.Ghdl_Protected_Enter'Address);
+ Def (Trans_Decls.Ghdl_Protected_Leave,
+ Grt.Processes.Ghdl_Protected_Leave'Address);
+ Def (Trans_Decls.Ghdl_Protected_Init,
+ Grt.Processes.Ghdl_Protected_Init'Address);
+ Def (Trans_Decls.Ghdl_Protected_Fini,
+ Grt.Processes.Ghdl_Protected_Fini'Address);
+
+ Def (Trans_Decls.Ghdl_Text_File_Elaborate,
+ Grt.Files.Ghdl_Text_File_Elaborate'Address);
+ Def (Trans_Decls.Ghdl_Text_File_Finalize,
+ Grt.Files.Ghdl_Text_File_Finalize'Address);
+ Def (Trans_Decls.Ghdl_Text_File_Open,
+ Grt.Files.Ghdl_Text_File_Open'Address);
+ Def (Trans_Decls.Ghdl_Text_Write,
+ Grt.Files.Ghdl_Text_Write'Address);
+ Def (Trans_Decls.Ghdl_Text_Read_Length,
+ Grt.Files.Ghdl_Text_Read_Length'Address);
+ Def (Trans_Decls.Ghdl_Text_File_Close,
+ Grt.Files.Ghdl_Text_File_Close'Address);
+ Def (Trans_Decls.Ghdl_File_Close,
+ Grt.Files.Ghdl_File_Close'Address);
+ Def (Trans_Decls.Ghdl_File_Elaborate,
+ Grt.Files.Ghdl_File_Elaborate'Address);
+ Def (Trans_Decls.Ghdl_File_Open,
+ Grt.Files.Ghdl_File_Open'Address);
+ Def (Trans_Decls.Ghdl_Write_Scalar,
+ Grt.Files.Ghdl_Write_Scalar'Address);
+ Def (Trans_Decls.Ghdl_Read_Scalar,
+ Grt.Files.Ghdl_Read_Scalar'Address);
+
+ Def (Trans_Decls.Ghdl_File_Endfile,
+ Grt.Files.Ghdl_File_Endfile'Address);
+
+ Def (Trans_Decls.Ghdl_Image_B2,
+ Grt.Images.Ghdl_Image_B2'Address);
+ Def (Trans_Decls.Ghdl_Image_E8,
+ Grt.Images.Ghdl_Image_E8'Address);
+ Def (Trans_Decls.Ghdl_Image_I32,
+ Grt.Images.Ghdl_Image_I32'Address);
+ Def (Trans_Decls.Ghdl_Image_F64,
+ Grt.Images.Ghdl_Image_F64'Address);
+ Def (Trans_Decls.Ghdl_Image_P64,
+ Grt.Images.Ghdl_Image_P64'Address);
+ Def (Trans_Decls.Ghdl_Image_P32,
+ Grt.Images.Ghdl_Image_P32'Address);
+
+ Def (Trans_Decls.Ghdl_Value_I32,
+ Grt.Values.Ghdl_Value_I32'Address);
+
+ Def (Trans_Decls.Ghdl_Get_Path_Name,
+ Grt.Names.Ghdl_Get_Path_Name'Address);
+ Def (Trans_Decls.Ghdl_Get_Instance_Name,
+ Grt.Names.Ghdl_Get_Instance_Name'Address);
+
+ Binary_File.Memory.Set_Symbol_Address
+ (Ortho_Code.X86.Emits.Intrinsics_Symbol
+ (Ortho_Code.X86.Intrinsic_Mul_Ov_I64),
+ Muldi3'Address);
+ Binary_File.Memory.Set_Symbol_Address
+ (Ortho_Code.X86.Emits.Intrinsics_Symbol
+ (Ortho_Code.X86.Intrinsic_Div_Ov_I64),
+ Divdi3'Address);
+
+ -- Find untruncated_text_read, if any.
+ Decl := Find_Untruncated_Text_Read;
+ if Decl /= O_Dnode_Null then
+ Def (Decl, Grt.Files.Ghdl_Untruncated_Text_Read'Address);
+ end if;
+
+ Binary_File.Memory.Write_Memory_Relocate (Err);
+ if Err then
+ raise Compile_Error;
+ end if;
+
+ Flag_String := Flags.Flag_String;
+
+ Elaborate_Proc := Conv (Get_Address (Trans_Decls.Ghdl_Elaborate));
+
+ if Snap_Filename /= null then
+ declare
+ Fd : File_Descriptor;
+ begin
+ Fd := Create_File (Snap_Filename.all, Binary);
+ if Fd = Invalid_FD then
+ Error_Msg_Option ("can't open '" & Snap_Filename.all & "'");
+ else
+ Binary_File.Elf.Write_Elf (Fd);
+ Close (Fd);
+ end if;
+ end;
+ end if;
+
+ -- Free all the memory.
+ Ortho_Mcode.Free_All;
+
+ Translation.Finalize;
+ Lists.Initialize;
+ Str_Table.Initialize;
+ Nodes.Initialize;
+ Files_Map.Initialize;
+ Name_Table.Initialize;
+ Binary_File.Finish;
+
+ if Flag_Verbose then
+ Ada.Text_IO.Put_Line ("Starting simulation");
+ end if;
+
+ Grt.Main.Run;
+ --V := Ghdl_Main (1, Gnat_Argv);
+ end Run;
+
+ function Decode_Option (Option : String) return Boolean
+ is
+ begin
+ if Option = "-g" then
+ Flag_Debug := Debug_Dwarf;
+ return True;
+ elsif Option'Length > 5 and then Option (1 .. 5) = "--be-" then
+ Ortho_Code.Debug.Set_Be_Flag (Option);
+ return True;
+ elsif Option'Length > 7 and then Option (1 .. 7) = "--snap=" then
+ Snap_Filename := new String'(Option (8 .. Option'Last));
+ return True;
+ else
+ return False;
+ end if;
+ end Decode_Option;
+
+ procedure Disp_Long_Help
+ is
+ use Ada.Text_IO;
+ begin
+ Put_Line (" -g Generate debugging informations");
+ Put_Line (" --debug-be=X Set X internal debugging flags");
+ Put_Line (" --snap=FILE Write memory snapshot to FILE");
+ end Disp_Long_Help;
+
+
+ -- Command run help.
+ type Command_Run_Help is new Command_Type with null record;
+ function Decode_Command (Cmd : Command_Run_Help; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Run_Help) return String;
+ procedure Perform_Action (Cmd : in out Command_Run_Help;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Run_Help; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "--run-help";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Run_Help) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "--run-help Disp help for RUNOPTS options";
+ end Get_Short_Help;
+
+ procedure Perform_Action (Cmd : in out Command_Run_Help;
+ Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ use Ada.Text_IO;
+ begin
+ if Args'Length /= 0 then
+ Error
+ ("warning: command '--run-help' does not accept any argument");
+ end if;
+ Put_Line ("These options can only be placed at [RUNOPTS]");
+ -- Register modules, since they add commands.
+ Grt.Main.Register_Modules;
+ -- Bypass usual help header.
+ Grt.Options.Argc := 0;
+ Grt.Options.Help;
+ end Perform_Action;
+
+ procedure Register_Commands
+ is
+ begin
+ Ghdlcomp.Hooks := (Compile_Init'Access,
+ Compile_Elab'Access,
+ Set_Run_Options'Access,
+ Run'Access,
+ Decode_Option'Access,
+ Disp_Long_Help'Access);
+ Ghdlcomp.Register_Commands;
+ Register_Command (new Command_Run_Help);
+ end Register_Commands;
+end Ghdlrun;
diff --git a/translate/ghdldrv/ghdlrun.ads b/translate/ghdldrv/ghdlrun.ads
new file mode 100644
index 0000000..07095bd
--- /dev/null
+++ b/translate/ghdldrv/ghdlrun.ads
@@ -0,0 +1,20 @@
+-- GHDL driver - JIT 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.
+package Ghdlrun is
+ procedure Register_Commands;
+end Ghdlrun;
diff --git a/translate/ghdldrv/ghdlsimul.adb b/translate/ghdldrv/ghdlsimul.adb
new file mode 100644
index 0000000..506b2ed
--- /dev/null
+++ b/translate/ghdldrv/ghdlsimul.adb
@@ -0,0 +1,142 @@
+-- GHDL driver - simulator 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 Ghdllocal; use Ghdllocal;
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+
+with Types;
+with Iirs; use Iirs;
+with Flags;
+with Back_End;
+with Name_Table;
+with Errorout; use Errorout;
+with Std_Package;
+with Canon;
+with Configuration;
+with Annotations;
+with Elaboration;
+with Sim_Be;
+with Simulation;
+
+with Ghdlcomp;
+
+package body Ghdlsimul is
+
+ Flag_Expect_Failure : Boolean := False;
+
+ procedure Compile_Init (Analyze_Only : Boolean) is
+ begin
+ if Analyze_Only then
+ return;
+ end if;
+
+ -- Initialize.
+ Back_End.Finish_Compilation := Sim_Be.Finish_Compilation'Access;
+ Back_End.Sem_Foreign := null;
+
+ Setup_Libraries (False);
+ Libraries.Load_Std_Library;
+
+ -- Here, time_base can be set.
+ Annotations.Annotate (Std_Package.Std_Standard_Unit);
+
+ Canon.Canon_Flag_Add_Labels := True;
+ end Compile_Init;
+
+ procedure Compile_Elab
+ (Cmd_Name : String; Args : Argument_List; Opt_Arg : out Natural)
+ is
+ begin
+ Extract_Elab_Unit (Cmd_Name, Args, Opt_Arg);
+
+ Flags.Flag_Elaborate := True;
+ -- Translation.Chap12.Elaborate (Prim_Name.all, Sec_Name.all, "", True);
+
+ if Errorout.Nbr_Errors > 0 then
+ -- This may happen (bad entity for example).
+ raise Compilation_Error;
+ end if;
+ end Compile_Elab;
+
+ -- Set options.
+ -- This is a little bit over-kill: from C to Ada and then again to C...
+ procedure Set_Run_Options (Args : Argument_List)
+ is
+ Arg : String_Access;
+ begin
+ for I in Args'Range loop
+ Arg := Args (I);
+ if Arg.all = "--disp-tree" then
+ Simulation.Disp_Tree := True;
+ elsif Arg.all = "--expect-failure" then
+ Flag_Expect_Failure := True;
+ elsif Arg.all = "--trace-elab" then
+ Elaboration.Trace_Elaboration := True;
+ elsif Arg.all = "--trace-simu" then
+ Simulation.Trace_Simulation := True;
+ else
+ null;
+ end if;
+ end loop;
+ end Set_Run_Options;
+
+ procedure Run
+ is
+ use Name_Table;
+ use Types;
+
+ First_Id : Name_Id;
+ Sec_Id : Name_Id;
+ Top_Conf : Iir;
+ begin
+ First_Id := Get_Identifier (Prim_Name.all);
+ if Sec_Name = null then
+ Sec_Id := Null_Identifier;
+ else
+ Sec_Id := Get_Identifier (Sec_Name.all);
+ end if;
+ Top_Conf := Configuration.Configure (First_Id, Sec_Id);
+
+ Simulation.Simulation_Entity (Top_Conf);
+ end Run;
+
+ function Decode_Option (Option : String) return Boolean
+ is
+ pragma Unreferenced (Option);
+ begin
+ return False;
+ end Decode_Option;
+
+ procedure Disp_Long_Help
+ is
+ begin
+ null;
+ end Disp_Long_Help;
+
+
+ procedure Register_Commands
+ is
+ begin
+ Ghdlcomp.Hooks := (Compile_Init'Access,
+ Compile_Elab'Access,
+ Set_Run_Options'Access,
+ Run'Access,
+ Decode_Option'Access,
+ Disp_Long_Help'Access);
+ Ghdlcomp.Register_Commands;
+ end Register_Commands;
+end Ghdlsimul;
diff --git a/translate/ghdldrv/ghdlsimul.ads b/translate/ghdldrv/ghdlsimul.ads
new file mode 100644
index 0000000..264cbf8
--- /dev/null
+++ b/translate/ghdldrv/ghdlsimul.ads
@@ -0,0 +1,20 @@
+-- GHDL driver - simulator 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.
+package Ghdlsimul is
+ procedure Register_Commands;
+end Ghdlsimul;