diff options
Diffstat (limited to 'translate/ghdldrv')
| -rw-r--r-- | translate/ghdldrv/Makefile | 114 | ||||
| -rw-r--r-- | translate/ghdldrv/default_pathes.ads.in | 30 | ||||
| -rw-r--r-- | translate/ghdldrv/ghdl_gcc.adb | 33 | ||||
| -rw-r--r-- | translate/ghdldrv/ghdl_mcode.adb | 33 | ||||
| -rw-r--r-- | translate/ghdldrv/ghdl_simul.adb | 32 | ||||
| -rw-r--r-- | translate/ghdldrv/ghdlcomp.adb | 745 | ||||
| -rw-r--r-- | translate/ghdldrv/ghdlcomp.ads | 67 | ||||
| -rw-r--r-- | translate/ghdldrv/ghdldrv.adb | 1705 | ||||
| -rw-r--r-- | translate/ghdldrv/ghdldrv.ads | 20 | ||||
| -rw-r--r-- | translate/ghdldrv/ghdllocal.adb | 1052 | ||||
| -rw-r--r-- | translate/ghdldrv/ghdllocal.ads | 98 | ||||
| -rw-r--r-- | translate/ghdldrv/ghdlmain.adb | 355 | ||||
| -rw-r--r-- | translate/ghdldrv/ghdlmain.ads | 85 | ||||
| -rw-r--r-- | translate/ghdldrv/ghdlprint.adb | 1561 | ||||
| -rw-r--r-- | translate/ghdldrv/ghdlprint.ads | 22 | ||||
| -rw-r--r-- | translate/ghdldrv/ghdlrun.adb | 658 | ||||
| -rw-r--r-- | translate/ghdldrv/ghdlrun.ads | 20 | ||||
| -rw-r--r-- | translate/ghdldrv/ghdlsimul.adb | 142 | ||||
| -rw-r--r-- | translate/ghdldrv/ghdlsimul.ads | 20 |
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 (">"); + when '<' => + Put ("<"); + when '&' => + Put ("&"); + when others => + Put (C); + end case; + end Put_Html; + + procedure Put_Html (S : String) is + begin + for I in S'Range loop + Put_Html (S (I)); + end loop; + end Put_Html; + + package Nat_IO is new Ada.Text_IO.Integer_IO (Num => Natural); + procedure Put_Nat (N : Natural) is + begin + Nat_IO.Put (N, Width => 0); + end Put_Nat; + + type Filexref_Info_Type is record + Output : String_Acc; + Referenced : Boolean; + end record; + type Filexref_Info_Arr is array (Source_File_Entry range <>) + of Filexref_Info_Type; + type Filexref_Info_Arr_Acc is access Filexref_Info_Arr; + Filexref_Info : Filexref_Info_Arr_Acc := null; + + 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; |