diff options
Diffstat (limited to 'translate/ghdldrv')
| -rw-r--r-- | translate/ghdldrv/Makefile | 193 | ||||
| -rw-r--r-- | translate/ghdldrv/default_pathes.ads.in | 39 | ||||
| -rw-r--r-- | translate/ghdldrv/foreigns.adb | 64 | ||||
| -rw-r--r-- | translate/ghdldrv/foreigns.ads | 5 | ||||
| -rw-r--r-- | translate/ghdldrv/ghdl_gcc.adb | 34 | ||||
| -rw-r--r-- | translate/ghdldrv/ghdl_jit.adb | 35 | ||||
| -rw-r--r-- | translate/ghdldrv/ghdl_simul.adb | 33 | ||||
| -rw-r--r-- | translate/ghdldrv/ghdlcomp.adb | 757 | ||||
| -rw-r--r-- | translate/ghdldrv/ghdlcomp.ads | 67 | ||||
| -rw-r--r-- | translate/ghdldrv/ghdldrv.adb | 1818 | ||||
| -rw-r--r-- | translate/ghdldrv/ghdldrv.ads | 25 | ||||
| -rw-r--r-- | translate/ghdldrv/ghdllocal.adb | 1415 | ||||
| -rw-r--r-- | translate/ghdldrv/ghdllocal.ads | 116 | ||||
| -rw-r--r-- | translate/ghdldrv/ghdlmain.adb | 359 | ||||
| -rw-r--r-- | translate/ghdldrv/ghdlmain.ads | 85 | ||||
| -rw-r--r-- | translate/ghdldrv/ghdlprint.adb | 1757 | ||||
| -rw-r--r-- | translate/ghdldrv/ghdlprint.ads | 20 | ||||
| -rw-r--r-- | translate/ghdldrv/ghdlrun.adb | 661 | ||||
| -rw-r--r-- | translate/ghdldrv/ghdlrun.ads | 20 | ||||
| -rw-r--r-- | translate/ghdldrv/ghdlsimul.adb | 209 | ||||
| -rw-r--r-- | translate/ghdldrv/ghdlsimul.ads | 20 | ||||
| -rw-r--r-- | translate/ghdldrv/grtlink.ads | 39 |
22 files changed, 0 insertions, 7771 deletions
diff --git a/translate/ghdldrv/Makefile b/translate/ghdldrv/Makefile deleted file mode 100644 index ebf23c2..0000000 --- a/translate/ghdldrv/Makefile +++ /dev/null @@ -1,193 +0,0 @@ -# -*- 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 -gnatwael -aI../.. -aI.. -aI../../psl -aI../grt -aO.. -g -gnatf -gnat05 -GRT_FLAGS=-g -LIB_CFLAGS=-g -O2 -GNATMAKE=gnatmake -CC=gcc - -# 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 - -# Coverage -#GNATFLAGS+=-fprofile-arcs -ftest-coverage - -GNAT_BARGS=-bargs -E - -LLVM_CONFIG=llvm-config - -#GNAT_LARGS= -static -all: ghdl_mcode - -target=i686-pc-linux-gnu -#target=x86_64-pc-linux-gnu -#target=i686-apple-darwin -#target=x86_64-apple-darwin -#target=i386-pc-mingw32 -GRTSRCDIR=../grt -include $(GRTSRCDIR)/Makefile.inc - -ifeq ($(filter-out i%86 linux,$(arch) $(osys)),) - ORTHO_X86_FLAGS=Flags_Linux -endif -ifeq ($(filter-out i%86 darwin%,$(arch) $(osys)),) - ORTHO_X86_FLAGS=Flags_Macosx -endif -ifeq ($(filter-out i%86 mingw32%,$(arch) $(osys)),) - ORTHO_X86_FLAGS=Flags_Windows -endif -ifdef ORTHO_X86_FLAGS - ORTHO_DEPS=ortho_code-x86-flags.ads -endif - -ortho_code-x86-flags.ads: - echo "with Ortho_Code.X86.$(ORTHO_X86_FLAGS);" > $@ - echo "package Ortho_Code.X86.Flags renames Ortho_Code.X86.$(ORTHO_X86_FLAGS);" >> $@ - -ghdl_mcode: GRT_FLAGS+=-DWITH_GNAT_RUN_TIME -ghdl_mcode: default_pathes.ads $(GRT_ADD_OBJS) $(ORTHO_DEPS) memsegs_c.o chkstk.o force - $(GNATMAKE) -o $@ -aI../../ortho/mcode -aI../../ortho $(GNATFLAGS) ghdl_jit.adb $(GNAT_BARGS) -largs memsegs_c.o chkstk.o $(GNAT_LARGS) $(GRT_ADD_OBJS) $(subst @,$(GRTSRCDIR),$(GRT_EXTRA_LIB)) - -memsegs_c.o: ../../ortho/mcode/memsegs_c.c - $(CC) -c -g -o $@ $< - -ghdl_llvm_jit: GRT_FLAGS+=-DWITH_GNAT_RUN_TIME -ghdl_llvm_jit: default_pathes.ads $(GRT_ADD_OBJS) $(ORTHO_DEPS) llvm-cbindings.o force - $(GNATMAKE) -o $@ -aI../../ortho/llvm -aI../../ortho $(GNATFLAGS) ghdl_jit.adb $(GNAT_BARGS) -largs llvm-cbindings.o $(GNAT_LARGS) $(GRT_ADD_OBJS) $(subst @,$(GRTSRCDIR),$(GRT_EXTRA_LIB)) `$(LLVM_CONFIG) --ldflags --libs --system-libs` -lc++ - -llvm-cbindings.o: ../../ortho/llvm/llvm-cbindings.cpp - $(CXX) -c -m64 `$(LLVM_CONFIG) --includedir --cxxflags` -g -o $@ $< - -ghdl_simul: default_pathes.ads $(GRT_ADD_OBJS) force - $(GNATMAKE) -aI../../simulate $(GNATFLAGS) ghdl_simul $(GNAT_BARGS) -largs $(GNAT_LARGS) $(GRT_ADD_OBJS) $(subst @,$(GRTSRCDIR),$(GRT_EXTRA_LIB)) - -ghdl_gcc: default_pathes.ads force - $(GNATMAKE) $(GNATFLAGS) ghdl_gcc $(GNAT_BARGS) -largs $(GNAT_LARGS) - -ghdl_llvm: default_pathes.ads force - $(GNATMAKE) $(GNATFLAGS) ghdl_llvm $(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%@COMPILER_LLVM@%$$curdir/ghdl1-llvm%" \ - -e "s%@POST_PROCESSOR@%$$curdir/../ortho/oread/oread-gcc%" \ - -e "s%@INSTALL_PREFIX@%%" \ - -e "s%@LIB_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 - -LIB87_DIR:=../lib/v87 -LIB93_DIR:=../lib/v93 -LIB08_DIR:=../lib/v08 - -LIBSRC_DIR:=../../libraries -REL_DIR:=../.. -GHDL=ghdl -ANALYZE:=../../../ghdldrv/$(GHDL) -a $(LIB_CFLAGS) -LN=ln -s -CP=cp - -$(LIB87_DIR) $(LIB93_DIR) $(LIB08_DIR): - [ -d ../lib ] || mkdir ../lib - [ -d $@ ] || mkdir $@ - -include ../../libraries/Makefile.inc - -GHDL1=../ghdl1-gcc -$(LIB93_DIR)/std/std_standard.o: $(GHDL1) -ifeq ($(GHDL),ghdl_llvm) - $(GHDL1) --std=93 -quiet $(LIB_CFLAGS) -c -o $@ --compile-standard -else - $(GHDL1) --std=93 -quiet $(LIB_CFLAGS) -o std_standard.s \ - --compile-standard - $(CC) -c -o $@ std_standard.s - $(RM) std_standard.s -endif - -$(LIB87_DIR)/std/std_standard.o: $(GHDL1) -ifeq ($(GHDL),ghdl_llvm) - $(GHDL1) --std=87 -quiet $(LIB_CFLAGS) -c -o $@ --compile-standard -else - $(GHDL1) --std=87 -quiet $(LIB_CFLAGS) -o std_standard.s \ - --compile-standard - $(CC) -c -o $@ std_standard.s - $(RM) std_standard.s -endif - -$(LIB08_DIR)/std/std_standard.o: $(GHDL1) -ifeq ($(GHDL),ghdl_llvm) - $(GHDL1) --std=08 -quiet $(LIB_CFLAGS) -c -o $@ --compile-standard -else - $(GHDL1) --std=08 -quiet $(LIB_CFLAGS) -o std_standard.s \ - --compile-standard - $(CC) -c -o $@ std_standard.s - $(RM) std_standard.s -endif - -install.v93: std.v93 ieee.v93 synopsys.v93 mentor.v93 -install.v87: std.v87 ieee.v87 synopsys.v87 -install.v08: std.v08 ieee.v08 - -install.standard: $(LIB93_DIR)/std/std_standard.o \ - $(LIB87_DIR)/std/std_standard.o \ - $(LIB08_DIR)/std/std_standard.o - -grt.links: - cd ../lib; ln -sf $(GRTSRCDIR)/grt.lst .; ln -sf $(GRTSRCDIR)/libgrt.a .; ln -sf $(GRTSRCDIR)/grt.ver . - -install.all: install.v87 install.v93 install.v08 - -install.gcc: - $(MAKE) GHDL=ghdl_gcc install.all - $(MAKE) GHDL1=../ghdl1-gcc install.standard - -install.mcode: - $(MAKE) GHDL=ghdl_mcode install.all - -install.simul: - $(MAKE) GHDL=ghdl_simul install.all - -install.llvm: - $(MAKE) GHDL=ghdl_llvm install.all - $(MAKE) GHDL1=../ghdl1-llvm install.standard - -clean: force - $(RM) -f *.o *.ali ghdl_gcc ghdl_mcode ghdl_llvm ghdl_llvm_jit - $(RM) -f b~*.ad? *~ default_pathes.ads ghdl_simul - $(RM) -rf ../lib - -clean-c: force - $(RM) -f memsegs_c.o chkstk.o linux.o times.o grt-cbinding.o grt-cvpi.o - -force: - -.PHONY: force clean diff --git a/translate/ghdldrv/default_pathes.ads.in b/translate/ghdldrv/default_pathes.ads.in deleted file mode 100644 index 7f471a5..0000000 --- a/translate/ghdldrv/default_pathes.ads.in +++ /dev/null @@ -1,39 +0,0 @@ --- 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 - - -- Accept long lines. - pragma Style_Checks ("M999"); - - Install_Prefix : constant String := - "@INSTALL_PREFIX@"; - Lib_Prefix : constant String := - "@LIB_PREFIX@"; - - Compiler_Gcc : constant String := - "@COMPILER_GCC@"; - Compiler_Mcode : constant String := - "@COMPILER_MCODE@"; - Compiler_Llvm : constant String := - "@COMPILER_LLVM@"; - Compiler_Debug : constant String := - "@COMPILER_DEBUG@"; - Post_Processor : constant String := - "@POST_PROCESSOR@"; -end Default_Pathes; diff --git a/translate/ghdldrv/foreigns.adb b/translate/ghdldrv/foreigns.adb deleted file mode 100644 index 15e3dd0..0000000 --- a/translate/ghdldrv/foreigns.adb +++ /dev/null @@ -1,64 +0,0 @@ -with Interfaces.C; use Interfaces.C; - -package body Foreigns is - function Sin (Arg : double) return double; - pragma Import (C, Sin); - - function Log (Arg : double) return double; - pragma Import (C, Log); - - function Exp (Arg : double) return double; - pragma Import (C, Exp); - - function Sqrt (Arg : double) return double; - pragma Import (C, Sqrt); - - function Asin (Arg : double) return double; - pragma Import (C, Asin); - - function Acos (Arg : double) return double; - pragma Import (C, Acos); - - function Asinh (Arg : double) return double; - pragma Import (C, Asinh); - - function Acosh (Arg : double) return double; - pragma Import (C, Acosh); - - function Atanh (X : double) return double; - pragma Import (C, Atanh); - - function Atan2 (X, Y : double) return double; - pragma Import (C, Atan2); - - type String_Cacc is access constant String; - type Foreign_Record is record - Name : String_Cacc; - Addr : Address; - end record; - - - Foreign_Arr : constant array (Natural range <>) of Foreign_Record := - ( - (new String'("sin"), Sin'Address), - (new String'("log"), Log'Address), - (new String'("exp"), Exp'Address), - (new String'("sqrt"), Sqrt'Address), - (new String'("asin"), Asin'Address), - (new String'("acos"), Acos'Address), - (new String'("asinh"), Asinh'Address), - (new String'("acosh"), Acosh'Address), - (new String'("atanh"), Atanh'Address), - (new String'("atan2"), Atan2'Address) - ); - - function Find_Foreign (Name : String) return Address is - begin - for I in Foreign_Arr'Range loop - if Foreign_Arr(I).Name.all = Name then - return Foreign_Arr(I).Addr; - end if; - end loop; - return Null_Address; - end Find_Foreign; -end Foreigns; diff --git a/translate/ghdldrv/foreigns.ads b/translate/ghdldrv/foreigns.ads deleted file mode 100644 index 5759ae4..0000000 --- a/translate/ghdldrv/foreigns.ads +++ /dev/null @@ -1,5 +0,0 @@ -with System; use System; - -package Foreigns is - function Find_Foreign (Name : String) return Address; -end Foreigns; diff --git a/translate/ghdldrv/ghdl_gcc.adb b/translate/ghdldrv/ghdl_gcc.adb deleted file mode 100644 index 615a8c5..0000000 --- a/translate/ghdldrv/ghdl_gcc.adb +++ /dev/null @@ -1,34 +0,0 @@ --- 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'("GCC back-end code generator"); - Ghdldrv.Compile_Kind := Ghdldrv.Compile_Gcc; - Ghdldrv.Register_Commands; - Ghdllocal.Register_Commands; - Ghdlprint.Register_Commands; - Ghdlmain.Register_Commands; - Ghdlmain.Main; -end Ghdl_Gcc; diff --git a/translate/ghdldrv/ghdl_jit.adb b/translate/ghdldrv/ghdl_jit.adb deleted file mode 100644 index ba70874..0000000 --- a/translate/ghdldrv/ghdl_jit.adb +++ /dev/null @@ -1,35 +0,0 @@ --- GHDL driver for jit. --- Copyright (C) 2002-2014 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; -with Ortho_Jit; - -procedure Ghdl_Jit is -begin - -- Manual elaboration so that the order is known (because it is the order - -- used to display help). - Ghdlmain.Version_String := - new String'(Ortho_Jit.Get_Jit_Name & " code generator"); - Ghdlrun.Register_Commands; - Ghdllocal.Register_Commands; - Ghdlprint.Register_Commands; - Ghdlmain.Register_Commands; - Ghdlmain.Main; -end Ghdl_Jit; diff --git a/translate/ghdldrv/ghdl_simul.adb b/translate/ghdldrv/ghdl_simul.adb deleted file mode 100644 index d4d0abd..0000000 --- a/translate/ghdldrv/ghdl_simul.adb +++ /dev/null @@ -1,33 +0,0 @@ --- 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). - Ghdlmain.Version_String := new String'("interpretation"); - 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 deleted file mode 100644 index ba755af..0000000 --- a/translate/ghdldrv/ghdlcomp.adb +++ /dev/null @@ -1,757 +0,0 @@ --- 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 Nodes_GC; -with Flags; -with Back_End; -with Sem; -with Name_Table; -with Errorout; use Errorout; -with Libraries; -with Std_Package; -with Files_Map; -with Version; -with Default_Pathes; - -package body Ghdlcomp is - - Flag_Expect_Failure : Boolean := False; - - Flag_Debug_Nodes_Leak : Boolean := False; - -- If True, detect unreferenced nodes at the end of analysis. - - -- 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 Option = "--debug-nodes-leak" then - Flag_Debug_Nodes_Leak := 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; - 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 : constant 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; - end Perform_Action; - - -- Command -a - 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); - 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; - - Free_Iir (Design_File); - - -- 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; - - if Errorout.Nbr_Errors > 0 then - raise Compilation_Error; - end if; - end if; - end loop; - - if Flag_Expect_Failure then - raise Compilation_Error; - end if; - - if Flag_Debug_Nodes_Leak then - Nodes_GC.Report_Unreferenced; - 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; - 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; - 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; - - Put ("command line prefix (--PREFIX): "); - if Prefix_Path = null then - Put_Line ("(not set)"); - else - Put_Line (Prefix_Path.all); - end if; - Setup_Libraries (False); - - Put ("environment prefix (GHDL_PREFIX): "); - if Prefix_Env = null then - Put_Line ("(not set)"); - else - Put_Line (Prefix_Env.all); - end if; - - Put_Line ("default prefix: " & Default_Pathes.Prefix); - Put_Line ("actual prefix: " & Prefix_Path.all); - Put_Line ("command_name: " & Ada.Command_Line.Command_Name); - 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_Comp 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; - exception - when Compilation_Error => - if Flag_Expect_Failure then - return; - else - raise; - end if; - 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_Release); - 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 : constant 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 deleted file mode 100644 index f803ca4..0000000 --- a/translate/ghdldrv/ghdlcomp.ads +++ /dev/null @@ -1,67 +0,0 @@ --- 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 deleted file mode 100644 index be905f1..0000000 --- a/translate/ghdldrv/ghdldrv.adb +++ /dev/null @@ -1,1818 +0,0 @@ --- 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 Errorout; -with Version; -with Options; - -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 : constant String_Access := new String'("-o"); - - -- "-c" string. - Dash_c : constant String_Access := new String'("-c"); - - -- "-quiet" option. - Dash_Quiet : constant String_Access := new String'("-quiet"); - - -- 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; - elsif Status > 127 then - Error ("executable killed by a signal"); - raise Exec_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_Llvm - | Compile_Mcode => - null; - end case; - - -- Create obj file (may not be used, but the condition isn't simple). - Obj_File := Append_Suffix (File, Get_Object_Suffix.all); - - -- Compile. - declare - P : Natural; - Nbr_Args : constant 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. - case Compile_Kind is - when Compile_Gcc => - if not Flag_Not_Quiet then - P := P + 1; - Args (P) := Dash_Quiet; - end if; - when Compile_Llvm => - P := P + 1; - Args (P) := Dash_c; - when Compile_Debug - | Compile_Mcode => - null; - end case; - - 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 - | Compile_Llvm => - 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 : constant 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 : constant 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); - - Link_Obj_Suffix : String_Access; - - -- 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 lib_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; - - -- Replace the first '@' with the machine path. - function Substitute (Str : String) return String - is - begin - for I in Str'Range loop - if Str (I) = '@' then - return Str (Str'First .. I - 1) - & Get_Machine_Path_Prefix - & Str (I + 1 .. Str'Last); - end if; - end loop; - return Str; - end Substitute; - - 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); - raise Compile_Error; - 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 To_Obj then - File := new String'(Dir (1 .. Dir_Len) - & Get_Base_Name (Line (1 .. L)) - & Link_Obj_Suffix.all); - else - File := new String'(Substitute (Line (1 .. L))); - 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; - - 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; - - 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; - - -- Set the compiler command according to the configuration (and swicthes). - 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); - when Compile_Llvm => - Compiler_Cmd := new String'(Default_Pathes.Compiler_Llvm); - 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; - - function Locate_Exec_Tool (Toolname : String) return String_Access is - begin - if Is_Absolute_Path (Toolname) then - if Is_Executable_File (Toolname) then - return new String'(Toolname); - end if; - else - -- Try from install prefix - if Exec_Prefix /= null then - declare - Path : constant String := - Exec_Prefix.all & Directory_Separator & Toolname; - begin - if Is_Executable_File (Path) then - return new String'(Path); - end if; - end; - end if; - - -- Try configured prefix - declare - Path : constant String := - Default_Pathes.Install_Prefix & Directory_Separator & Toolname; - begin - if Is_Executable_File (Path) then - return new String'(Path); - end if; - end; - end if; - - -- Search the basename on path. - declare - Pos : constant Natural := Get_Basename_Pos (Toolname); - begin - if Pos = 0 then - return Locate_Exec_On_Path (Toolname); - else - return Locate_Exec_On_Path (Toolname (Pos .. Toolname'Last)); - end if; - end; - end Locate_Exec_Tool; - - procedure Locate_Tools is - begin - Compiler_Path := Locate_Exec_Tool (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_Tool (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; - end Locate_Tools; - - procedure Setup_Compiler (Load : Boolean) - is - use Libraries; - begin - Set_Tools_Name; - Setup_Libraries (Load); - Locate_Tools; - 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; - 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; - Opt : constant String (1 .. Option'Length) := Option; - begin - Res := Option_Bad; - if Opt = "-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 Opt'Length > 8 and then Opt (1 .. 8) = "--GHDL1=" then - Compiler_Cmd := new String'(Opt (9 .. Opt'Last)); - Res := Option_Ok; - elsif Opt = "-S" then - Flag_Asm := True; - Res := Option_Ok; - elsif Opt = "--post" then - Compile_Kind := Compile_Debug; - Res := Option_Ok; - elsif Opt = "--mcode" then - Compile_Kind := Compile_Mcode; - Res := Option_Ok; - elsif Opt = "--llvm" then - Compile_Kind := Compile_Llvm; - Res := Option_Ok; - elsif Opt = "-o" then - if Arg'Length = 0 then - Res := Option_Arg_Req; - else - Output_File := new String'(Arg); - Res := Option_Arg; - end if; - elsif Opt = "-m32" then - Add_Argument (Compiler_Args, new String'("-m32")); - Add_Argument (Assembler_Args, new String'("--32")); - Add_Argument (Linker_Args, new String'("-m32")); - Decode_Option (Command_Lib (Cmd), Opt, Arg, Res); - elsif Opt'Length > 4 - and then Opt (2) = 'W' and then Opt (4) = ',' - then - if Opt (3) = 'c' then - Add_Arguments (Compiler_Args, Opt); - elsif Opt (3) = 'a' then - Add_Arguments (Assembler_Args, Opt); - elsif Opt (3) = 'p' then - Add_Arguments (Postproc_Args, Opt); - elsif Opt (3) = 'l' then - Add_Arguments (Linker_Args, Opt); - else - Error ("unknown tool name in '-W" & Opt (3) & ",' option"); - raise Option_Error; - end if; - Res := Option_Ok; - elsif Opt'Length >= 2 and then Opt (2) = 'g' then - -- Debugging option. - Str := new String'(Opt); - Add_Argument (Compiler_Args, Str); - Add_Argument (Linker_Args, Str); - Res := Option_Ok; - elsif Opt = "-Q" then - Flag_Not_Quiet := True; - Res := Option_Ok; - elsif Opt = "--expect-failure" then - Add_Argument (Compiler_Args, new String'(Opt)); - Flag_Expect_Failure := True; - Res := Option_Ok; - elsif Opt = "-C" then - -- Translate -C into --mb-comments, as gcc already has a definition - -- for -C. Done before Flags.Parse_Option. - Add_Argument (Compiler_Args, new String'("--mb-comments")); - Res := Option_Ok; - elsif Options.Parse_Option (Opt) then - Add_Argument (Compiler_Args, new String'(Opt)); - Res := Option_Ok; - elsif Opt'Length >= 2 - and then (Opt (2) = 'O' or Opt (2) = 'f') - then - -- Optimization option. - -- This is put after Flags.Parse_Option, since it may catch -fxxx - -- options. - Add_Argument (Compiler_Args, new String'(Opt)); - Res := Option_Ok; - else - Decode_Option (Command_Lib (Cmd), Opt, Arg, Res); - end if; - end Decode_Option; - - procedure Disp_Long_Help (Cmd : Command_Comp) is - 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 (" -m32 Generate 32bit code on 64bit machines"); - 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" or else Name = "--disp-config"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_Dispconfig) return String - is - pragma Unreferenced (Cmd); - begin - return "--disp-config Disp tools path"; - end Get_Short_Help; - - procedure Perform_Action (Cmd : in out Command_Dispconfig; - Args : Argument_List) - is - 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_Line ("Pathes at configuration:"); - 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); - Put_Line ("default lib prefix: " & Default_Pathes.Lib_Prefix); - - New_Line; - - Put ("command line prefix (--PREFIX): "); - if Switch_Prefix_Path = null then - Put_Line ("(not set)"); - else - Put_Line (Switch_Prefix_Path.all); - end if; - - Put ("environment prefix (GHDL_PREFIX): "); - if Prefix_Env = null then - Put_Line ("(not set)"); - else - Put_Line (Prefix_Env.all); - end if; - - Setup_Libraries (False); - - Put ("exec prefix (from program name): "); - if Exec_Prefix = null then - Put_Line ("(not found)"); - else - Put_Line (Exec_Prefix.all); - end if; - - New_Line; - - Put_Line ("library prefix: " & Lib_Prefix_Path.all); - Put ("library directory: "); - Put_Line (Get_Machine_Path_Prefix); - 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); - - New_Line; - - 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 .. Files'Length + 2); - Index : Natural; - begin - Comp_List (1) := new String'("--anaelab"); - Comp_List (2) := Unit_Name; - Index := 3; - for I in Files'Range loop - Comp_List (Index) := new String'("--ghdl-source=" & Files (I).all); - Index := Index + 1; - end loop; - Do_Compile (Comp_List, Elab_Name.all); - Free (Comp_List (1)); - for I in 3 .. Comp_List'Last loop - Free (Comp_List (I)); - end loop; - end Bind_Anaelab; - - procedure Link (Add_Std : Boolean; - Disp_Only : Boolean) - is - Last_File : Natural; - begin - Link_Obj_Suffix := Get_Object_Suffix; - - -- read files list - if Filelist_Name /= null then - Add_File_List (Filelist_Name.all, True); - end if; - Last_File := Filelist.Last; - Add_File_List (Get_Machine_Path_Prefix & "grt" & List_Suffix, False); - - -- call the linker - declare - P : Natural; - Nbr_Args : constant 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, Link_Obj_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'(Get_Machine_Path_Prefix - & Get_Version_Path & Directory_Separator - & "std" & Directory_Separator - & "std_standard" & Link_Obj_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; - pragma Unreferenced (Success); - 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 - Flags.Flag_Whole_Analyze := True; - 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 (human 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; - exception - when Errorout.Compilation_Error => - if Flag_Expect_Failure then - return; - else - raise; - 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_Release); - 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 : constant 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 deleted file mode 100644 index 3e37b38..0000000 --- a/translate/ghdldrv/ghdldrv.ads +++ /dev/null @@ -1,25 +0,0 @@ --- 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 - -- Compiler to use. - type Compile_Kind_Type is - (Compile_Mcode, Compile_Llvm, Compile_Gcc, Compile_Debug); - Compile_Kind : Compile_Kind_Type := Compile_Gcc; - - procedure Register_Commands; -end Ghdldrv; diff --git a/translate/ghdldrv/ghdllocal.adb b/translate/ghdldrv/ghdllocal.adb deleted file mode 100644 index a1d94bd..0000000 --- a/translate/ghdldrv/ghdllocal.adb +++ /dev/null @@ -1,1415 +0,0 @@ --- 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 Ada.Command_Line; use Ada.Command_Line; -with GNAT.Directory_Operations; -with Types; use Types; -with Libraries; -with Std_Package; -with Flags; -with Name_Table; -with Std_Names; -with Back_End; -with Disp_Vhdl; -with Default_Pathes; -with Scanner; -with Sem; -with Canon; -with Errorout; -with Configuration; -with Files_Map; -with Post_Sems; -with Disp_Tree; -with Options; -with Iirs_Utils; use Iirs_Utils; - -package body Ghdllocal is - -- Version of the IEEE library to use. This just change pathes. - type Ieee_Lib_Kind is (Lib_Standard, Lib_None, Lib_Synopsys, Lib_Mentor); - Flag_Ieee : Ieee_Lib_Kind; - - Flag_Create_Default_Config : constant Boolean := True; - - -- If TRUE, generate 32bits code on 64bits machines. - Flag_32bit : Boolean := False; - - procedure Finish_Compilation - (Unit : Iir_Design_Unit; Main : Boolean := False) - is - use Errorout; - use Ada.Text_IO; - Config : Iir_Design_Unit; - Lib : Iir; - begin - if (Main or Flags.Dump_All) and then Flags.Dump_Parse then - Disp_Tree.Disp_Tree (Unit); - end if; - - if Flags.Verbose then - Put_Line ("semantize " & Disp_Node (Get_Library_Unit (Unit))); - end if; - - Sem.Semantic (Unit); - - if (Main or Flags.Dump_All) and then Flags.Dump_Sem then - Disp_Tree.Disp_Tree (Unit); - end if; - - if Errorout.Nbr_Errors > 0 then - raise Compilation_Error; - end if; - - if (Main or Flags.List_All) and then Flags.List_Sem then - Disp_Vhdl.Disp_Vhdl (Unit); - end if; - - Post_Sems.Post_Sem_Checks (Unit); - - if Errorout.Nbr_Errors > 0 then - raise Compilation_Error; - end if; - - if Flags.Flag_Elaborate 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_Body then - Config := Canon.Create_Default_Configuration_Declaration (Lib); - Set_Default_Configuration_Declaration (Lib, Config); - end if; - end if; - end if; - end Finish_Compilation; - - procedure Init (Cmd : in out Command_Lib) - is - pragma Unreferenced (Cmd); - begin - Options.Initialize; - Flag_Ieee := Lib_Standard; - Back_End.Finish_Compilation := Finish_Compilation'Access; - Flag_Verbose := False; - end Init; - - procedure Decode_Option (Cmd : in out Command_Lib; - Option : String; - Arg : String; - Res : out Option_Res) - is - pragma Unreferenced (Cmd); - pragma Unreferenced (Arg); - Opt : constant String (1 .. Option'Length) := Option; - begin - Res := Option_Bad; - if Opt = "-v" and then Flag_Verbose = False then - Flag_Verbose := True; - Res := Option_Ok; - elsif Opt'Length > 9 and then Opt (1 .. 9) = "--PREFIX=" then - Switch_Prefix_Path := new String'(Opt (10 .. Opt'Last)); - Res := Option_Ok; - elsif Opt = "--ieee=synopsys" then - Flag_Ieee := Lib_Synopsys; - Res := Option_Ok; - elsif Opt = "--ieee=mentor" then - Flag_Ieee := Lib_Mentor; - Res := Option_Ok; - elsif Opt = "--ieee=none" then - Flag_Ieee := Lib_None; - Res := Option_Ok; - elsif Opt = "--ieee=standard" then - Flag_Ieee := Lib_Standard; - Res := Option_Ok; - elsif Opt = "-m32" then - Flag_32bit := True; - Res := Option_Ok; - elsif Opt'Length >= 2 - and then (Opt (2) = 'g' or Opt (2) = 'O') - then - -- Silently accept -g and -O. - Res := Option_Ok; - else - if Options.Parse_Option (Opt) then - Res := Option_Ok; - end if; - end if; - end Decode_Option; - - procedure Disp_Long_Help (Cmd : Command_Lib) - is - pragma Unreferenced (Cmd); - use Ada.Text_IO; - procedure P (Str : String) renames Put_Line; - begin - P ("Main options (try --options-help for details):"); - P (" --std=XX Use XX as VHDL standard (87,93c,93,00 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 (not advised)"); - P (" none: do not use a predefined ieee library"); - end Disp_Long_Help; - - function Is_Directory_Separator (C : Character) return Boolean is - begin - return C = '/' or else C = Directory_Separator; - end Is_Directory_Separator; - - function Get_Basename_Pos (Pathname : String) return Natural is - begin - for I in reverse Pathname'Range loop - if Is_Directory_Separator (Pathname (I)) then - return I; - end if; - end loop; - return 0; - end Get_Basename_Pos; - - procedure Set_Prefix_From_Program_Path (Prog_Path : String) - is - Dir_Pos : Natural; - begin - Dir_Pos := Get_Basename_Pos (Prog_Path); - if Dir_Pos = 0 then - -- No directory in Prog_Path. This is not expected. - return; - end if; - - declare - Pathname : String := - Normalize_Pathname (Prog_Path (Dir_Pos + 1 .. Prog_Path'Last), - Prog_Path (Prog_Path'First .. Dir_Pos - 1)); - Pos : Natural; - begin - -- Stop now in case of error. - if Pathname'Length = 0 then - return; - end if; - - -- Skip executable name - Dir_Pos := Get_Basename_Pos (Pathname); - if Dir_Pos = 0 then - return; - end if; - - -- Simplify path: - -- /./ => / - -- // => / - Pos := Dir_Pos - 1; - while Pos >= Pathname'First loop - if Is_Directory_Separator (Pathname (Pos)) then - if Is_Directory_Separator (Pathname (Pos + 1)) then - -- // => / - Pathname (Pos .. Dir_Pos - 1) := - Pathname (Pos + 1 .. Dir_Pos); - Dir_Pos := Dir_Pos - 1; - elsif Pos + 2 <= Dir_Pos - and then Pathname (Pos + 1) = '.' - and then Is_Directory_Separator (Pathname (Pos + 2)) - then - -- /./ => / - Pathname (Pos .. Dir_Pos - 2) := - Pathname (Pos + 2 .. Dir_Pos); - Dir_Pos := Dir_Pos - 2; - end if; - end if; - Pos := Pos - 1; - end loop; - - -- Simplify path: - -- /xxx/../ => / - -- This is done after the previous simplication to avoid to deal - -- with cases like /xxx//../ or /xxx/./../ - Pos := Dir_Pos - 3; - while Pos >= Pathname'First loop - if Is_Directory_Separator (Pathname (Pos)) - and then Pathname (Pos + 1) = '.' - and then Pathname (Pos + 2) = '.' - and then Is_Directory_Separator (Pathname (Pos + 3)) - then - declare - Pos2 : constant Natural := - Get_Basename_Pos (Pathname (Pathname'First .. Pos - 1)); - -- /xxxxxxxxxx/../ - -- ^ ^ - -- Pos2 Pos - Len : Natural; - begin - if Pos2 = 0 then - -- Shouldn't happen. - return; - end if; - Len := Pos + 3 - Pos2; - Pathname (Pos2 + 1 .. Dir_Pos - Len) := - Pathname (Pos + 4 .. Dir_Pos); - Dir_Pos := Dir_Pos - Len; - if Pos2 < Pathname'First + 3 then - exit; - end if; - Pos := Pos2 - 3; - end; - else - Pos := Pos - 1; - end if; - end loop; - - -- Remove last '/' - Dir_Pos := Dir_Pos - 1; - - -- Skip directory. - Dir_Pos := Get_Basename_Pos (Pathname (Pathname'First .. Dir_Pos)); - if Dir_Pos = 0 then - return; - end if; - - Exec_Prefix := new String'(Pathname (Pathname'First .. Dir_Pos - 1)); - end; - end Set_Prefix_From_Program_Path; - - -- Extract Exec_Prefix from executable name. - procedure Set_Exec_Prefix - is - use GNAT.Directory_Operations; - Prog_Path : constant String := Ada.Command_Line.Command_Name; - Exec_Path : String_Access; - begin - -- If the command name is an absolute path, deduce prefix from it. - if Is_Absolute_Path (Prog_Path) then - Set_Prefix_From_Program_Path (Prog_Path); - return; - end if; - - -- If the command name is a relative path, deduce prefix from it - -- and current path. - if Get_Basename_Pos (Prog_Path) /= 0 then - if Is_Executable_File (Prog_Path) then - Set_Prefix_From_Program_Path - (Get_Current_Dir & Directory_Separator & Prog_Path); - end if; - return; - end if; - - -- Look for program name on the path. - Exec_Path := Locate_Exec_On_Path (Prog_Path); - if Exec_Path /= null then - Set_Prefix_From_Program_Path (Exec_Path.all); - Free (Exec_Path); - end if; - end Set_Exec_Prefix; - - function Get_Version_Path return String - is - use Flags; - begin - case Vhdl_Std is - when Vhdl_87 => - return "v87"; - when Vhdl_93c - | Vhdl_93 - | Vhdl_00 - | Vhdl_02 => - return "v93"; - when Vhdl_08 => - return "v08"; - end case; - end Get_Version_Path; - - function Get_Machine_Path_Prefix return String is - begin - if Flag_32bit then - return Lib_Prefix_Path.all & "32"; - else - return Lib_Prefix_Path.all; - end if; - end Get_Machine_Path_Prefix; - - procedure Add_Library_Path (Name : String) - is - begin - Libraries.Add_Library_Path - (Get_Machine_Path_Prefix & Directory_Separator - & Get_Version_Path & Directory_Separator - & Name & Directory_Separator); - end Add_Library_Path; - - procedure Setup_Libraries (Load : Boolean) - is - begin - -- Get environment variable. - Prefix_Env := GNAT.OS_Lib.Getenv ("GHDL_PREFIX"); - if Prefix_Env = null or else Prefix_Env.all = "" then - Prefix_Env := null; - end if; - - -- Compute Exec_Prefix. - Set_Exec_Prefix; - - -- Set prefix path. - -- If not set by command line, try environment variable. - if Switch_Prefix_Path /= null then - Lib_Prefix_Path := Switch_Prefix_Path; - else - Lib_Prefix_Path := Prefix_Env; - end if; - -- Else try default path. - if Lib_Prefix_Path = null then - if Is_Absolute_Path (Default_Pathes.Lib_Prefix) then - Lib_Prefix_Path := new String'(Default_Pathes.Lib_Prefix); - else - if Exec_Prefix /= null then - Lib_Prefix_Path := new - String'(Exec_Prefix.all & Directory_Separator - & Default_Pathes.Lib_Prefix); - end if; - if Lib_Prefix_Path = null - or else not Is_Directory (Lib_Prefix_Path.all) - then - Free (Lib_Prefix_Path); - Lib_Prefix_Path := new - String'(Default_Pathes.Install_Prefix - & Directory_Separator - & Default_Pathes.Lib_Prefix); - end if; - end if; - else - -- Assume the user has set the correct path, so do not insert 32. - Flag_32bit := False; - end if; - - -- Add pathes for predefined libraries. - if not Flags.Bootstrap then - Add_Library_Path ("std"); - case Flag_Ieee is - when Lib_Standard => - Add_Library_Path ("ieee"); - when Lib_Synopsys => - 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_Body => - Put ("architecture "); - when Iir_Kind_Configuration_Declaration => - Put ("configuration "); - when Iir_Kind_Package_Declaration => - Put ("package "); - when Iir_Kind_Package_Instantiation_Declaration => - Put ("package instance "); - when Iir_Kind_Package_Body => - Put ("package body "); - when others => - Put ("???"); - return; - end case; - Image (Id); - Put (Name_Buffer (1 .. Name_Length)); - case Get_Kind (Unit) is - when Iir_Kind_Architecture_Body => - Put (" of "); - Image (Get_Entity_Identifier_Of_Architecture (Unit)); - Put (Name_Buffer (1 .. Name_Length)); - when Iir_Kind_Configuration_Declaration => - if Id = Null_Identifier then - Put ("<default> of entity "); - Image (Get_Entity_Identifier_Of_Architecture (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 : constant 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 : constant Boolean := False; - begin - Flags.Bootstrap := True; - Libraries.Load_Std_Library; - Libraries.Load_Work_Library; - - for I in Args'Range loop - Id := Get_Identifier (Args (I).all); - Design_File := Libraries.Load_File (Id); - if Design_File /= Null_Iir then - Unit := Get_First_Design_Unit (Design_File); - while Unit /= Null_Iir loop - Lib := Get_Library_Unit (Unit); - Disp_Library_Unit (Lib); - if Is_Top_Entity (Lib) then - Put (" **"); - end if; - New_Line; - if Flag_Add then - Libraries.Add_Design_Unit_Into_Library (Unit); - end if; - Unit := Get_Chain (Unit); - end loop; - end if; - end loop; - if Flag_Add then - Libraries.Save_Work_Library; - end if; - end Perform_Action; - - -- Command Import. - type Command_Import is new Command_Lib with null record; - function Decode_Command (Cmd : Command_Import; Name : String) - return Boolean; - function Get_Short_Help (Cmd : Command_Import) return String; - procedure Perform_Action (Cmd : in out Command_Import; - Args : Argument_List); - - function Decode_Command (Cmd : Command_Import; Name : String) - return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "-i"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_Import) return String - is - pragma Unreferenced (Cmd); - begin - return "-i [OPTS] FILEs Import units of FILEs"; - end Get_Short_Help; - - procedure Perform_Action (Cmd : in out Command_Import; Args : Argument_List) - is - pragma Unreferenced (Cmd); - 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"); - raise; - end Perform_Action; - - -- Command Check_Syntax. - type Command_Check_Syntax is new Command_Lib with null record; - function Decode_Command (Cmd : Command_Check_Syntax; Name : String) - return Boolean; - function Get_Short_Help (Cmd : Command_Check_Syntax) return String; - procedure Perform_Action (Cmd : in out Command_Check_Syntax; - Args : Argument_List); - - function Decode_Command (Cmd : Command_Check_Syntax; Name : String) - return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "-s"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_Check_Syntax) return String - is - pragma Unreferenced (Cmd); - begin - return "-s [OPTS] FILEs Check syntax of FILEs"; - end Get_Short_Help; - - procedure Analyze_One_File (File_Name : String) - is - use Ada.Text_IO; - Id : Name_Id; - Design_File : Iir_Design_File; - Unit : Iir; - Next_Unit : Iir; - begin - Id := Name_Table.Get_Identifier (File_Name); - if Flag_Verbose then - Put (File_Name); - Put_Line (":"); - end if; - Design_File := Libraries.Load_File (Id); - if Design_File = Null_Iir then - raise Errorout.Compilation_Error; - end if; - - Unit := Get_First_Design_Unit (Design_File); - while Unit /= Null_Iir loop - if Flag_Verbose then - Put (' '); - Disp_Library_Unit (Get_Library_Unit (Unit)); - New_Line; - end if; - -- Sem, canon, annotate a design unit. - Back_End.Finish_Compilation (Unit, True); - - Next_Unit := Get_Chain (Unit); - if Errorout.Nbr_Errors = 0 then - Set_Chain (Unit, Null_Iir); - Libraries.Add_Design_Unit_Into_Library (Unit); - end if; - - Unit := Next_Unit; - end loop; - - if Errorout.Nbr_Errors > 0 then - raise Errorout.Compilation_Error; - end if; - end Analyze_One_File; - - procedure Analyze_Files (Files : Argument_List; Save_Library : Boolean) is - begin - Setup_Libraries (True); - - -- Parse all files. - for I in Files'Range loop - Analyze_One_File (Files (I).all); - end loop; - - if Save_Library then - Libraries.Save_Work_Library; - end if; - end Analyze_Files; - - procedure Perform_Action (Cmd : in out Command_Check_Syntax; - Args : Argument_List) - is - pragma Unreferenced (Cmd); - begin - Analyze_Files (Args, False); - end Perform_Action; - - -- Command --clean: remove object files. - type Command_Clean is new Command_Lib with null record; - function Decode_Command (Cmd : Command_Clean; Name : String) return Boolean; - function Get_Short_Help (Cmd : Command_Clean) return String; - procedure Perform_Action (Cmd : in out Command_Clean; Args : Argument_List); - - function Decode_Command (Cmd : Command_Clean; Name : String) return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "--clean"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_Clean) return String - is - pragma Unreferenced (Cmd); - begin - return "--clean Remove generated files"; - end Get_Short_Help; - - procedure Delete (Str : String) - is - 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 Name_Table; - - procedure Delete_Asm_Obj (Str : String) is - begin - Delete (Str & Get_Object_Suffix.all & Nul); - Delete (Str & Asm_Suffix & Nul); - end Delete_Asm_Obj; - - procedure Delete_Top_Unit (Str : String) is - begin - -- Delete elaboration file - Delete_Asm_Obj (Image (Libraries.Work_Directory) & Elab_Prefix & Str); - - -- Delete file list. - Delete (Image (Libraries.Work_Directory) & Str & List_Suffix & Nul); - - -- Delete executable. - Delete (Str & Nul); - end Delete_Top_Unit; - - File : Iir_Design_File; - Design_Unit : Iir_Design_Unit; - Lib_Unit : Iir; - Str : String_Access; - begin - if Args'Length /= 0 then - Error ("command '--clean' does not accept any argument"); - raise Option_Error; - end if; - - Flags.Bootstrap := True; - -- Load libraries. - Libraries.Load_Std_Library; - Libraries.Load_Work_Library; - - File := Get_Design_File_Chain (Libraries.Work_Library); - while File /= Null_Iir loop - -- Delete compiled file. - Str := Append_Suffix (Image (Get_Design_File_Filename (File)), ""); - Delete_Asm_Obj (Str.all); - Free (Str); - - Design_Unit := Get_First_Design_Unit (File); - while Design_Unit /= Null_Iir loop - Lib_Unit := Get_Library_Unit (Design_Unit); - case Get_Kind (Lib_Unit) is - when Iir_Kind_Entity_Declaration - | Iir_Kind_Configuration_Declaration => - Delete_Top_Unit (Image (Get_Identifier (Lib_Unit))); - when Iir_Kind_Architecture_Body => - Delete_Top_Unit - (Image (Get_Entity_Identifier_Of_Architecture (Lib_Unit)) - & '-' - & Image (Get_Identifier (Lib_Unit))); - when others => - null; - end case; - Design_Unit := Get_Chain (Design_Unit); - end loop; - File := Get_Chain (File); - end loop; - end Perform_Action; - - -- Command --remove: remove object file and library file. - type Command_Remove is new Command_Clean with null record; - function Decode_Command (Cmd : Command_Remove; Name : String) - return Boolean; - function Get_Short_Help (Cmd : Command_Remove) return String; - procedure Perform_Action (Cmd : in out Command_Remove; - Args : Argument_List); - - function Decode_Command (Cmd : Command_Remove; Name : String) return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "--remove"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_Remove) return String - is - pragma Unreferenced (Cmd); - begin - return "--remove Remove generated files and library file"; - end Get_Short_Help; - - procedure Perform_Action (Cmd : in out Command_Remove; Args : Argument_List) - is - use Name_Table; - begin - if Args'Length /= 0 then - Error ("command '--remove' does not accept any argument"); - raise Option_Error; - end if; - Perform_Action (Command_Clean (Cmd), Args); - Delete (Image (Libraries.Work_Directory) - & Back_End.Library_To_File_Name (Libraries.Work_Library) - & Nul); - end Perform_Action; - - -- Command --copy: copy work library to current directory. - type Command_Copy is new Command_Lib with null record; - function Decode_Command (Cmd : Command_Copy; Name : String) return Boolean; - function Get_Short_Help (Cmd : Command_Copy) return String; - procedure Perform_Action (Cmd : in out Command_Copy; Args : Argument_List); - - function Decode_Command (Cmd : Command_Copy; Name : String) return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "--copy"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_Copy) return String - is - pragma Unreferenced (Cmd); - begin - return "--copy Copy work library to current directory"; - end Get_Short_Help; - - procedure Perform_Action (Cmd : in out Command_Copy; Args : Argument_List) - is - pragma Unreferenced (Cmd); - use Name_Table; - use Libraries; - - File : Iir_Design_File; - Dir : Name_Id; - begin - if Args'Length /= 0 then - Error ("command '--copy' does not accept any argument"); - raise Option_Error; - end if; - - Setup_Libraries (False); - Libraries.Load_Std_Library; - Dir := Work_Directory; - Work_Directory := Null_Identifier; - Libraries.Load_Work_Library; - Work_Directory := Dir; - - Dir := Get_Library_Directory (Libraries.Work_Library); - if Dir = Name_Nil or else Dir = Files_Map.Get_Home_Directory then - Error ("cannot copy library on itself (use --remove first)"); - raise Option_Error; - end if; - - File := Get_Design_File_Chain (Libraries.Work_Library); - while File /= Null_Iir loop - -- Copy object files (if any). - declare - Basename : constant String := - Get_Base_Name (Image (Get_Design_File_Filename (File))); - Src : String_Access; - Dst : String_Access; - Success : Boolean; - pragma Unreferenced (Success); - begin - Src := new String'(Image (Dir) & Basename & Get_Object_Suffix.all); - Dst := new String'(Basename & Get_Object_Suffix.all); - Copy_File (Src.all, Dst.all, Success, Overwrite, Full); - -- Be silent in case of error. - Free (Src); - Free (Dst); - end; - if Get_Design_File_Directory (File) = Name_Nil then - Set_Design_File_Directory (File, Dir); - end if; - - File := Get_Chain (File); - end loop; - Libraries.Work_Directory := Name_Nil; - Libraries.Save_Work_Library; - end Perform_Action; - - -- Command --disp-standard. - type Command_Disp_Standard is new Command_Lib with null record; - function Decode_Command (Cmd : Command_Disp_Standard; Name : String) - return Boolean; - function Get_Short_Help (Cmd : Command_Disp_Standard) return String; - procedure Perform_Action (Cmd : in out Command_Disp_Standard; - Args : Argument_List); - - function Decode_Command (Cmd : Command_Disp_Standard; Name : String) - return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "--disp-standard"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_Disp_Standard) return String - is - pragma Unreferenced (Cmd); - begin - return "--disp-standard Disp std.standard in pseudo-vhdl"; - end Get_Short_Help; - - procedure Perform_Action (Cmd : in out Command_Disp_Standard; - Args : Argument_List) - is - pragma Unreferenced (Cmd); - begin - if Args'Length /= 0 then - Error ("command '--disp-standard' does not accept any argument"); - raise Option_Error; - end if; - Flags.Bootstrap := True; - Libraries.Load_Std_Library; - Disp_Vhdl.Disp_Vhdl (Std_Package.Std_Standard_Unit); - end Perform_Action; - - procedure Load_All_Libraries_And_Files - is - use Files_Map; - use Libraries; - use Errorout; - - procedure Extract_Library_Clauses (Unit : Iir_Design_Unit) - is - Lib1 : Iir_Library_Declaration; - pragma Unreferenced (Lib1); - Ctxt_Item : Iir; - begin - -- Extract library clauses. - Ctxt_Item := Get_Context_Items (Unit); - while Ctxt_Item /= Null_Iir loop - if Get_Kind (Ctxt_Item) = Iir_Kind_Library_Clause then - Lib1 := Get_Library (Get_Identifier (Ctxt_Item), - Get_Location (Ctxt_Item)); - end if; - Ctxt_Item := Get_Chain (Ctxt_Item); - end loop; - end Extract_Library_Clauses; - - Lib : Iir_Library_Declaration; - Fe : Source_File_Entry; - File, Next_File : Iir_Design_File; - Unit, Next_Unit : Iir_Design_Unit; - Design_File : Iir_Design_File; - - Old_Work : Iir_Library_Declaration; - begin - Lib := Std_Library; - Lib := Get_Chain (Lib); - Old_Work := Work_Library; - while Lib /= Null_Iir loop - -- Design units are always put in the work library. - Work_Library := Lib; - - File := Get_Design_File_Chain (Lib); - while File /= Null_Iir loop - Next_File := Get_Chain (File); - Fe := Load_Source_File (Get_Design_File_Directory (File), - Get_Design_File_Filename (File)); - if Fe = No_Source_File_Entry then - -- FIXME: should remove all the design file from the library. - null; - elsif Is_Eq (Get_File_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; - - function Is_Bad_Unit_Name return Boolean is - begin - if Name_Length = 0 then - return True; - end if; - -- Don't try to handle extended identifier. - if Name_Buffer (1) = '\' then - return False; - end if; - -- Look for suspicious characters. - -- Do not try to be exhaustive as the correct check will be done - -- by convert_identifier. - for I in 1 .. Name_Length loop - case Name_Buffer (I) is - when '.' | '/' | '\' => - return True; - when others => - null; - end case; - end loop; - return False; - end Is_Bad_Unit_Name; - - function Is_A_File_Name return Boolean is - begin - -- Check .vhd - if Name_Length > 4 - and then Name_Buffer (Name_Length - 3 .. Name_Length) = ".vhd" - then - return True; - end if; - -- Check .vhdl - if Name_Length > 5 - and then Name_Buffer (Name_Length - 4 .. Name_Length) = ".vhdl" - then - return True; - end if; - -- Check ../ - if Name_Length > 3 - and then Name_Buffer (1 .. 3) = "../" - then - return True; - end if; - -- Check ..\ - if Name_Length > 3 - and then Name_Buffer (1 .. 3) = "..\" - then - return True; - end if; - -- Should try to find the file ? - return False; - end Is_A_File_Name; - begin - Name_Length := Name'Length; - Name_Buffer (1 .. Name_Length) := Name.all; - - -- Try to identifier bad names (such as file names), so that - -- friendly message can be displayed. - if Is_Bad_Unit_Name then - Errorout.Error_Msg_Option_NR ("bad unit name '" & Name.all & "'"); - if Is_A_File_Name then - Errorout.Error_Msg_Option_NR - ("(a unit name is required instead of a filename)"); - end if; - raise Option_Error; - end if; - Scanner.Convert_Identifier; - return new String'(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 : constant String_Access := Args (Next_Arg); - begin - if Sec (Sec'First) /= '-' then - Sec_Name := Convert_Name (Sec); - Next_Arg := Args'First + 2; - end if; - end; - end if; - end Extract_Elab_Unit; - - procedure Register_Commands is - begin - Register_Command (new Command_Import); - Register_Command (new Command_Check_Syntax); - Register_Command (new Command_Dir); - Register_Command (new Command_Find); - Register_Command (new Command_Clean); - Register_Command (new Command_Remove); - Register_Command (new Command_Copy); - Register_Command (new Command_Disp_Standard); - end Register_Commands; -end Ghdllocal; diff --git a/translate/ghdldrv/ghdllocal.ads b/translate/ghdldrv/ghdllocal.ads deleted file mode 100644 index 2c7018a..0000000 --- a/translate/ghdldrv/ghdllocal.ads +++ /dev/null @@ -1,116 +0,0 @@ --- 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); - - -- Value of --PREFIX - Switch_Prefix_Path : String_Access := null; - - -- getenv ("GHDL_PREFIX"). Set by Setup_Libraries. - Prefix_Env : String_Access := null; - - -- Installation prefix (deduced from executable path). - Exec_Prefix : String_Access; - - -- Path prefix for libraries. - Lib_Prefix_Path : String_Access := null; - - -- Set with -v option. - Flag_Verbose : Boolean := False; - - -- Suffix for asm files. - Asm_Suffix : constant String := ".s"; - - -- Suffix for llvm byte-code files. - Llvm_Suffix : constant String := ".bc"; - - -- 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~"; - - Nul : constant Character := Character'Val (0); - - -- Return FILENAME without the extension. - function Get_Base_Name (Filename : String; Remove_Dir : Boolean := True) - return String; - - -- Get the position of the last directory separator or 0 if none. - function Get_Basename_Pos (Pathname : String) return Natural; - - 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; - - -- Get Prefix_Path, but with 32 added if -m32 is requested - function Get_Machine_Path_Prefix 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 deleted file mode 100644 index 45d9615..0000000 --- a/translate/ghdldrv/ghdlmain.adb +++ /dev/null @@ -1,359 +0,0 @@ --- GHDL driver - main part. --- Copyright (C) 2002 - 2010 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 Bug; -with Options; - -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,"); - Put_Line (" run your program with the --help option."); - Put_Line ("Also see --options-help for analyzer options."); - New_Line; - Put_Line ("Please, refer to the GHDL manual for more information."); - Put_Line ("Report bugs on http://gna.org/projects/ghdl"); - 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 analyzer 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; - Options.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_Release); - Put_Line (" Compiled with " & Bug.Get_Gnat_Version); - if Version_String /= null then - Put (" "); - Put (Version_String.all); - end if; - New_Line; - Put_Line ("Written by Tristan Gingold."); - New_Line; - -- Display copyright. Assume 80 cols terminal. - Put_Line ("Copyright (C) 2003 - 2014 Tristan Gingold."); - Put_Line ("GHDL is free software, covered by the " - & "GNU General Public License. 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 : constant 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_Version); - Register_Command (new Command_Option_Help); - end Register_Commands; -end Ghdlmain; - diff --git a/translate/ghdldrv/ghdlmain.ads b/translate/ghdldrv/ghdlmain.ads deleted file mode 100644 index c01f1d6..0000000 --- a/translate/ghdldrv/ghdlmain.ads +++ /dev/null @@ -1,85 +0,0 @@ --- 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 deleted file mode 100644 index 45e70e1..0000000 --- a/translate/ghdldrv/ghdlprint.adb +++ /dev/null @@ -1,1757 +0,0 @@ --- 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 GNAT.Table; -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 Iirs_Utils; use Iirs_Utils; -with Tokens; -with Scanner; -with Parse; -with Version; -with Xrefs; -with Ghdlmain; use Ghdlmain; -with Ghdllocal; use Ghdllocal; -with Disp_Vhdl; -with Back_End; - -package body Ghdlprint is - type Html_Format_Type is (Html_2, Html_Css); - Html_Format : Html_Format_Type := Html_2; - - procedure Put_Html (C : Character) is - begin - case C is - when '>' => - Put (">"); - when '<' => - Put ("<"); - when '&' => - Put ("&"); - when others => - Put (C); - end case; - end Put_Html; - - procedure Put_Html (S : String) is - begin - for I in S'Range loop - Put_Html (S (I)); - end loop; - end Put_Html; - - package Nat_IO is new Ada.Text_IO.Integer_IO (Num => Natural); - procedure Put_Nat (N : Natural) is - begin - Nat_IO.Put (N, Width => 0); - end Put_Nat; - - type Filexref_Info_Type is record - Output : String_Acc; - Referenced : Boolean; - end record; - type Filexref_Info_Arr is array (Source_File_Entry range <>) - of Filexref_Info_Type; - type Filexref_Info_Arr_Acc is access Filexref_Info_Arr; - Filexref_Info : Filexref_Info_Arr_Acc := null; - - -- If True, at least one xref is missing. - Missing_Xref : Boolean := False; - - procedure PP_Html_File (File : Source_File_Entry) - is - use Flags; - use Scanner; - use Tokens; - use Files_Map; - use Ada.Characters.Latin_1; - - Line : Natural; - Buf : File_Buffer_Acc; - Prev_Tok : Token_Type; - - -- Current logical column number. Used to expand TABs. - Col : Natural; - - -- Position just after the last token. - Last_Tok : Source_Ptr; - - -- Position just before the current token. - Bef_Tok : Source_Ptr; - - -- Position just after the current token. - Aft_Tok : Source_Ptr; - - procedure Disp_Ln - is - N : Natural; - Str : String (1 .. 5); - begin - case Html_Format is - when Html_2 => - Put ("<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); - Missing_Xref := True; - 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 - Scanner.Flag_Comment := True; - Scanner.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; - 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; - when Tok_Semi_Colon => - Disp_Spaces; - Disp_Text; - when Tok_Xnor .. Tok_Ror => - Disp_Reserved; - when Tok_Protected => - Disp_Reserved; - when Tok_Across .. Tok_Tolerance => - Disp_Reserved; - when Tok_Psl_Default - | Tok_Psl_Clock - | Tok_Psl_Property - | Tok_Psl_Sequence - | Tok_Psl_Endpoint - | Tok_Psl_Assert - | Tok_Psl_Cover - | Tok_Psl_Boolean - | Tok_Psl_Const - | Tok_Inf - | Tok_Within - | Tok_Abort - | Tok_Before - | Tok_Always - | Tok_Never - | Tok_Eventually - | Tok_Next_A - | Tok_Next_E - | Tok_Next_Event - | Tok_Next_Event_A - | Tok_Next_Event_E => - Disp_Spaces; - Disp_Text; - when Tok_String - | Tok_Bit_String - | Tok_Character => - Disp_Spaces; - case Html_Format is - when Html_2 => - Put ("<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_Equal_Equal - | 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_Release); - 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 - Id : constant Name_Id := Get_Identifier (Lib); - Len : Natural; - Id1 : Name_Id; - begin - Len := Get_Name_Length (Id); - case Get_Kind (Lib) is - when Iir_Kind_Configuration_Declaration - | Iir_Kind_Entity_Declaration - | Iir_Kind_Package_Declaration - | Iir_Kind_Package_Instantiation_Declaration => - null; - when Iir_Kind_Package_Body => - Len := Len + 1 + 4; -- add -body - when Iir_Kind_Architecture_Body => - Id1 := Get_Entity_Identifier_Of_Architecture (Lib); - Len := Len + 1 + Get_Name_Length (Id1); - when others => - Error_Kind ("build_file_name", Lib); - end case; - Len := Len + 1 + 4; -- add .vhdl - return Len; - end Build_File_Name_Length; - - procedure Build_File_Name (Lib : Iir; Res : out String) - is - Id : constant Name_Id := Get_Identifier (Lib); - P : Natural; - - procedure Append (Str : String) is - begin - Res (P + 1 .. P + Str'Length) := Str; - P := P + Str'Length; - end Append; - begin - P := Res'First - 1; - case Get_Kind (Lib) is - when Iir_Kind_Configuration_Declaration - | Iir_Kind_Entity_Declaration - | Iir_Kind_Package_Declaration - | Iir_Kind_Package_Instantiation_Declaration => - Image (Id); - Append (Name_Buffer (1 .. Name_Length)); - when Iir_Kind_Package_Body => - Image (Id); - Append (Name_Buffer (1 .. Name_Length)); - Append ("-body"); - when Iir_Kind_Architecture_Body => - Image (Get_Entity_Identifier_Of_Architecture (Lib)); - Append (Name_Buffer (1 .. Name_Length)); - Append ("-"); - Image (Id); - Append (Name_Buffer (1 .. Name_Length)); - when others => - raise Internal_Error; - end case; - Append (".vhdl"); - end Build_File_Name; - - -- Scan source file BUF+START until end of line. - -- Return line kind to KIND and position of next line to NEXT. - type Line_Type is (Line_Blank, Line_Comment, Line_Text); - procedure Find_Eol (Buf : File_Buffer_Acc; - Start : Source_Ptr; - Next : out Source_Ptr; - Kind : out Line_Type) - is - P : Source_Ptr; - begin - P := Start; - - Kind := Line_Blank; - - -- Skip blanks. - while Buf (P) = ' ' or Buf (P) = HT loop - P := P + 1; - end loop; - - -- Skip comment if any. - if Buf (P) = '-' and Buf (P + 1) = '-' then - Kind := Line_Comment; - P := P + 2; - elsif Buf (P) /= CR and Buf (P) /= LF and Buf (P) /= EOT then - Kind := Line_Text; - end if; - - -- Skip until end of line. - while Buf (P) /= CR and Buf (P) /= LF and Buf (P) /= EOT loop - P := P + 1; - end loop; - - if Buf (P) = CR then - P := P + 1; - if Buf (P) = LF then - P := P + 1; - end if; - elsif Buf (P) = LF then - P := P + 1; - if Buf (P) = CR then - P := P + 1; - end if; - end if; - - Next := P; - end Find_Eol; - - Id : Name_Id; - Design_File : Iir_Design_File; - Unit : Iir; - Lib : Iir; - Len : Natural; - begin - Flags.Bootstrap := True; - -- Load word library. - Libraries.Load_Std_Library; - Libraries.Load_Work_Library; - - -- First loop: parse source file, check destination file does not - -- exist. - for I in Args'Range loop - Id := Get_Identifier (Args (I).all); - Design_File := Libraries.Load_File (Id); - if Design_File = Null_Iir then - raise Compile_Error; - end if; - Unit := Get_First_Design_Unit (Design_File); - while Unit /= Null_Iir loop - Lib := Get_Library_Unit (Unit); - Len := Build_File_Name_Length (Lib); - declare - Filename : String (1 .. Len + 1); - begin - Build_File_Name (Lib, Filename); - Filename (Len + 1) := Ghdllocal.Nul; - if Is_Regular_File (Filename) then - Error ("file '" & Filename (1 .. Len) & "' already exists"); - raise Compile_Error; - end if; - Put (Filename (1 .. Len)); - Put (" (for "); - Disp_Library_Unit (Lib); - Put (")"); - New_Line; - end; - Unit := Get_Chain (Unit); - end loop; - end loop; - - -- Second loop: do the real work. - for I in Args'Range loop - Id := Get_Identifier (Args (I).all); - Design_File := Libraries.Load_File (Id); - Unit := Get_First_Design_Unit (Design_File); - declare - use Files_Map; - - File_Entry : Source_File_Entry; - Buffer : File_Buffer_Acc; - - Start : Source_Ptr; - Lend : Source_Ptr; - First : Source_Ptr; - Next : Source_Ptr; - Kind : Line_Type; - begin - -- A design_file must have at least one design unit. - if Unit = Null_Iir then - raise Compile_Error; - end if; - - Location_To_File_Pos - (Get_Location (Unit), File_Entry, Start); - Buffer := Get_File_Source (File_Entry); - - First := Source_Ptr_Org; - if Get_Chain (Unit) /= Null_Iir then - -- If there is only one unit, then the whole file is written. - -- First last blank line. - Next := Source_Ptr_Org; - loop - Start := Next; - Find_Eol (Buffer, Start, Next, Kind); - exit when Kind = Line_Text; - if Kind = Line_Blank then - First := Next; - end if; - end loop; - - -- FIXME: write header. - end if; - - while Unit /= Null_Iir loop - Lib := Get_Library_Unit (Unit); - - Location_To_File_Pos - (Get_End_Location (Unit), File_Entry, Lend); - if Lend < First then - raise Internal_Error; - end if; - - Location_To_File_Pos - (Get_End_Location (Unit), File_Entry, Lend); - -- Find the ';'. - while Buffer (Lend) /= ';' loop - Lend := Lend + 1; - end loop; - Lend := Lend + 1; - -- Find end of line. - Find_Eol (Buffer, Lend, Next, Kind); - if Kind = Line_Text then - -- There is another unit on the same line. - Next := Lend; - -- Skip blanks. - while Buffer (Next) = ' ' or Buffer (Next) = HT loop - Next := Next + 1; - end loop; - else - -- Find first blank line. - loop - Start := Next; - Find_Eol (Buffer, Start, Next, Kind); - exit when Kind /= Line_Comment; - end loop; - if Kind = Line_Text then - -- There is not blank lines. - -- All the comments are supposed to belong to the next - -- unit. - Find_Eol (Buffer, Lend, Next, Kind); - Lend := Next; - else - Lend := Start; - end if; - end if; - - if Get_Chain (Unit) = Null_Iir then - -- Last unit. - -- Put the end of the file in it. - Lend := Get_File_Length (File_Entry); - end if; - - -- FIXME: file with only one unit. - -- FIXME: set extension. - Len := Build_File_Name_Length (Lib); - declare - Filename : String (1 .. Len + 1); - Fd : File_Descriptor; - - Wlen : Integer; - begin - Build_File_Name (Lib, Filename); - Filename (Len + 1) := Character'Val (0); - Fd := Create_File (Filename, Binary); - if Fd = Invalid_FD then - Error - ("cannot create file '" & Filename (1 .. Len) & "'"); - raise Compile_Error; - end if; - Wlen := Integer (Lend - First); - if Write (Fd, Buffer (First)'Address, Wlen) /= Wlen then - Error ("cannot write to '" & Filename (1 .. Len) & "'"); - raise Compile_Error; - end if; - Close (Fd); - end; - First := Next; - - Unit := Get_Chain (Unit); - end loop; - end; - end loop; - end Perform_Action; - - -- Command --lines. - type Command_Lines is new Command_Lib with null record; - function Decode_Command (Cmd : Command_Lines; Name : String) - return Boolean; - function Get_Short_Help (Cmd : Command_Lines) return String; - procedure Perform_Action (Cmd : in out Command_Lines; - Args : Argument_List); - - function Decode_Command (Cmd : Command_Lines; Name : String) - return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "--lines"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_Lines) return String - is - pragma Unreferenced (Cmd); - begin - return "--lines FILEs Precede line with its number"; - end Get_Short_Help; - - procedure Perform_Action (Cmd : in out Command_Lines; Args : Argument_List) - is - pragma Unreferenced (Cmd); - use Scanner; - use Tokens; - use Files_Map; - use Ada.Characters.Latin_1; - - Id : Name_Id; - Fe : Source_File_Entry; - Local_Id : Name_Id; - Line : Natural; - File : Source_File_Entry; - Buf : File_Buffer_Acc; - Ptr : Source_Ptr; - Eptr : Source_Ptr; - C : Character; - N : Natural; - Log : Natural; - Str : String (1 .. 10); - begin - Local_Id := Get_Identifier (""); - for I in Args'Range loop - -- Load the file. - Id := Get_Identifier (Args (I).all); - Fe := Files_Map.Load_Source_File (Local_Id, Id); - if Fe = No_Source_File_Entry then - Error ("cannot open file " & Args (I).all); - raise Compile_Error; - end if; - Set_File (Fe); - - -- Scan the content, to compute the number of lines. - loop - Scan; - exit when Current_Token = Tok_Eof; - end loop; - File := Get_Current_Source_File; - Line := Get_Current_Line; - Close_File; - - -- Compute log10 of line. - N := Line; - Log := 0; - loop - N := N / 10; - Log := Log + 1; - exit when N = 0; - end loop; - - -- Disp file name. - Put (Args (I).all); - Put (':'); - New_Line; - - Buf := Get_File_Source (File); - for J in 1 .. Line loop - Ptr := Line_To_Position (File, J); - exit when Ptr = Source_Ptr_Bad; - exit when Buf (Ptr) = Files_Map.EOT; - - -- Disp line number. - N := J; - for K in reverse 1 .. Log loop - if N = 0 then - Str (K) := ' '; - else - Str (K) := Character'Val (48 + N mod 10); - N := N / 10; - end if; - end loop; - Put (Str (1 .. Log)); - Put (": "); - - -- Search for end of line (or end of file). - Eptr := Ptr; - loop - C := Buf (Eptr); - exit when C = Files_Map.EOT or C = LF or C = CR; - Eptr := Eptr + 1; - end loop; - - -- Disp line. - if Eptr > Ptr then - -- Avoid constraint error on conversion of nul array. - Put (String (Buf (Ptr .. Eptr - 1))); - end if; - New_Line; - end loop; - end loop; - end Perform_Action; - - -- Command Reprint. - type Command_Reprint is new Command_Lib with null record; - function Decode_Command (Cmd : Command_Reprint; Name : String) - return Boolean; - function Get_Short_Help (Cmd : Command_Reprint) return String; - procedure Perform_Action (Cmd : in out Command_Reprint; - Args : Argument_List); - - function Decode_Command (Cmd : Command_Reprint; Name : String) - return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "--reprint"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_Reprint) return String - is - pragma Unreferenced (Cmd); - begin - return "--reprint [OPTS] FILEs Redisplay FILEs"; - end Get_Short_Help; - - procedure Perform_Action (Cmd : in out Command_Reprint; - Args : Argument_List) - is - pragma Unreferenced (Cmd); - Design_File : Iir_Design_File; - Unit : Iir; - - Id : Name_Id; - Next_Unit : Iir; - begin - Setup_Libraries (True); - Parse.Flag_Parse_Parenthesis := True; - - -- Parse all files. - for I in Args'Range loop - Id := Name_Table.Get_Identifier (Args (I).all); - Design_File := Libraries.Load_File (Id); - if Design_File = Null_Iir then - raise Errorout.Compilation_Error; - end if; - - Unit := Get_First_Design_Unit (Design_File); - while Unit /= Null_Iir loop - -- Analyze the design unit. - Back_End.Finish_Compilation (Unit, True); - - Next_Unit := Get_Chain (Unit); - if Errorout.Nbr_Errors = 0 then - Disp_Vhdl.Disp_Vhdl (Unit); - Set_Chain (Unit, Null_Iir); - Libraries.Add_Design_Unit_Into_Library (Unit); - end if; - - Unit := Next_Unit; - end loop; - - if Errorout.Nbr_Errors > 0 then - raise Errorout.Compilation_Error; - end if; - end loop; - end Perform_Action; - - -- Command compare tokens. - type Command_Compare_Tokens is new Command_Lib with null record; - function Decode_Command (Cmd : Command_Compare_Tokens; Name : String) - return Boolean; - function Get_Short_Help (Cmd : Command_Compare_Tokens) return String; - procedure Perform_Action (Cmd : in out Command_Compare_Tokens; - Args : Argument_List); - - function Decode_Command (Cmd : Command_Compare_Tokens; Name : String) - return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "--compare-tokens"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_Compare_Tokens) return String - is - pragma Unreferenced (Cmd); - begin - return "--compare-tokens [OPTS] REF FILEs Compare FILEs with REF"; - end Get_Short_Help; - - procedure Perform_Action (Cmd : in out Command_Compare_Tokens; - Args : Argument_List) - is - pragma Unreferenced (Cmd); - use Tokens; - use Scanner; - - package Ref_Tokens is new GNAT.Table - (Table_Component_Type => Token_Type, - Table_Index_Type => Integer, - Table_Low_Bound => 0, - Table_Initial => 1024, - Table_Increment => 100); - - Id : Name_Id; - Fe : Source_File_Entry; - Local_Id : Name_Id; - Tok_Idx : Natural; - begin - if Args'Length < 1 then - Error ("missing ref file"); - raise Compile_Error; - end if; - - Local_Id := Get_Identifier (""); - - for I in Args'Range loop - -- Load the file. - Id := Get_Identifier (Args (I).all); - Fe := Files_Map.Load_Source_File (Local_Id, Id); - if Fe = No_Source_File_Entry then - Error ("cannot open file " & Args (I).all); - raise Compile_Error; - end if; - Set_File (Fe); - - if I = Args'First then - -- Scan ref file - loop - Scan; - Ref_Tokens.Append (Current_Token); - exit when Current_Token = Tok_Eof; - end loop; - else - -- Scane file - Tok_Idx := Ref_Tokens.First; - loop - Scan; - if Ref_Tokens.Table (Tok_Idx) /= Current_Token then - Error_Msg_Parse ("token mismatch"); - exit; - end if; - case Current_Token is - when Tok_Eof => - exit; - when others => - null; - end case; - Tok_Idx := Tok_Idx + 1; - end loop; - end if; - Close_File; - end loop; - - Ref_Tokens.Free; - - if Nbr_Errors /= 0 then - raise Compilation_Error; - end if; - end Perform_Action; - - -- Command html. - type Command_Html is abstract new Command_Lib with null record; - - procedure Decode_Option (Cmd : in out Command_Html; - Option : String; - Arg : String; - Res : out Option_Res); - - procedure Disp_Long_Help (Cmd : Command_Html); - - procedure Decode_Option (Cmd : in out Command_Html; - Option : String; - Arg : String; - Res : out Option_Res) - is - begin - if Option = "--format=css" then - Html_Format := Html_Css; - Res := Option_Ok; - elsif Option = "--format=html2" then - Html_Format := Html_2; - Res := Option_Ok; - else - Decode_Option (Command_Lib (Cmd), Option, Arg, Res); - end if; - end Decode_Option; - - procedure Disp_Long_Help (Cmd : Command_Html) is - begin - Disp_Long_Help (Command_Lib (Cmd)); - Put_Line ("--format=html2 Use FONT attributes"); - Put_Line ("--format=css Use ghdl.css file"); - end Disp_Long_Help; - - -- Command --pp-html. - type Command_PP_Html is new Command_Html with null record; - function Decode_Command (Cmd : Command_PP_Html; Name : String) - return Boolean; - function Get_Short_Help (Cmd : Command_PP_Html) return String; - procedure Perform_Action (Cmd : in out Command_PP_Html; - Files : Argument_List); - - function Decode_Command (Cmd : Command_PP_Html; Name : String) - return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "--pp-html"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_PP_Html) return String - is - pragma Unreferenced (Cmd); - begin - return "--pp-html FILEs Pretty-print FILEs in HTML"; - end Get_Short_Help; - - procedure Perform_Action (Cmd : in out Command_PP_Html; - Files : Argument_List) - is - pragma Unreferenced (Cmd); - use Scanner; - use Tokens; - use Files_Map; - use Ada.Characters.Latin_1; - - Id : Name_Id; - Fe : Source_File_Entry; - Local_Id : Name_Id; - begin - Local_Id := Get_Identifier (""); - Put_Html_Header; - Put_Line (" <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; - Check_Missing : Boolean := False; - 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; - elsif Option = "--check-missing" then - Cmd.Check_Missing := True; - Res := Option_Ok; - else - Decode_Option (Command_Html (Cmd), Option, Arg, Res); - end if; - end Decode_Option; - - procedure Disp_Long_Help (Cmd : Command_Xref_Html) is - begin - Disp_Long_Help (Command_Html (Cmd)); - Put_Line ("-o DIR Put generated files into DIR (def: html/)"); - Put_Line ("--check-missing Fail if a reference is missing"); - 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; - 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; - - 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 : constant 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; - - if Missing_Xref and Cmd.Check_Missing then - Error ("missing xrefs"); - raise Compile_Error; - 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; - Dir : Name_Id; - 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: "); - Dir := Get_Source_File_Directory (Cur_File); - if Dir /= Null_Identifier then - Image (Dir); - Put (Name_Buffer (1 .. Name_Length)); - end if; - 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_Body => - 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_Interface_Signal_Declaration => - C := 's'; - when Iir_Kind_Signal_Declaration => - C := 'S'; - when Iir_Kind_Interface_Constant_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'); - 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_Reprint); - Register_Command (new Command_Compare_Tokens); - 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 deleted file mode 100644 index 82c3e60..0000000 --- a/translate/ghdldrv/ghdlprint.ads +++ /dev/null @@ -1,20 +0,0 @@ --- 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 deleted file mode 100644 index f623721..0000000 --- a/translate/ghdldrv/ghdlrun.adb +++ /dev/null @@ -1,661 +0,0 @@ --- 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 Ortho_Jit; -with Ortho_Nodes; use Ortho_Nodes; -with Interfaces; -with System; use System; -with Trans_Decls; -with Iirs; use Iirs; -with Flags; -with Errorout; use Errorout; -with Libraries; -with Canon; -with Trans_Be; -with Translation; -with Ieee.Std_Logic_1164; - -with Lists; -with Str_Table; -with Nodes; -with Files_Map; -with Name_Table; - -with Grt.Main; -with Grt.Modules; -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 Grt.Std_Logic_1164; - -with Ghdlcomp; -with Foreigns; -with Grtlink; - -package body Ghdlrun is - procedure Foreign_Hook (Decl : Iir; - Info : Translation.Foreign_Info_Type; - Ortho : O_Dnode); - - procedure Compile_Init (Analyze_Only : Boolean) is - begin - if Analyze_Only then - return; - end if; - - Translation.Foreign_Hook := Foreign_Hook'Access; - - -- FIXME: add a flag to force unnesting. - -- Translation.Flag_Unnest_Subprograms := True; - - -- The design is always analyzed in whole. - Flags.Flag_Whole_Analyze := True; - - Setup_Libraries (False); - Libraries.Load_Std_Library; - - Ortho_Jit.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; - 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; - - procedure Ghdl_Elaborate; - pragma Export (C, Ghdl_Elaborate, "__ghdl_ELABORATE"); - - type Elaborate_Acc is access procedure; - pragma Convention (C, Elaborate_Acc); - 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; - - procedure Def (Decl : O_Dnode; Addr : Address) - renames Ortho_Jit.Set_Address; - - procedure Foreign_Hook (Decl : Iir; - Info : Translation.Foreign_Info_Type; - Ortho : O_Dnode) - is - use Translation; - Res : Address; - begin - case Info.Kind is - when Foreign_Vhpidirect => - declare - Name : constant String := - Name_Table.Name_Buffer (Info.Subprg_First - .. Info.Subprg_Last); - begin - Res := Foreigns.Find_Foreign (Name); - if Res /= Null_Address then - Def (Ortho, Res); - else - Error_Msg_Sem ("unknown foreign VHPIDIRECT '" & Name & "'", - Decl); - end if; - end; - when Foreign_Intrinsic => - Name_Table.Image (Get_Identifier (Decl)); - declare - Name : constant String := - Name_Table.Name_Buffer (1 .. Name_Table.Name_Length); - begin - if Name = "untruncated_text_read" then - Def (Ortho, Grt.Files.Ghdl_Untruncated_Text_Read'Address); - elsif Name = "control_simulation" then - Def (Ortho, Grt.Lib.Ghdl_Control_Simulation'Address); - elsif Name = "get_resolution_limit" then - Def (Ortho, Grt.Lib.Ghdl_Get_Resolution_Limit'Address); - else - Error_Msg_Sem ("unknown foreign intrinsic '" & Name & "'", - Decl); - end if; - end; - when Foreign_Unknown => - null; - end case; - end Foreign_Hook; - - procedure Run - is - 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; - - Def (Trans_Decls.Ghdl_Memcpy, - Grt.Lib.Ghdl_Memcpy'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_Std_Ulogic_To_Boolean_Array, - Grt.Lib.Ghdl_Std_Ulogic_To_Boolean_Array'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_Ieee_Assert_Failed, - Grt.Lib.Ghdl_Ieee_Assert_Failed'Address); - Def (Trans_Decls.Ghdl_Psl_Assert_Failed, - Grt.Lib.Ghdl_Psl_Assert_Failed'Address); - Def (Trans_Decls.Ghdl_Psl_Cover, - Grt.Lib.Ghdl_Psl_Cover'Address); - Def (Trans_Decls.Ghdl_Psl_Cover_Failed, - Grt.Lib.Ghdl_Psl_Cover_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_Finalize_Register, - Grt.Processes.Ghdl_Finalize_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_Direct_Driver, - Grt.Signals.Ghdl_Signal_Add_Direct_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_B1, - Grt.Signals.Ghdl_Signal_Driving_Value_B1'Address); - Def (Trans_Decls.Ghdl_Signal_Driving_Value_E8, - Grt.Signals.Ghdl_Signal_Driving_Value_E8'Address); - Def (Trans_Decls.Ghdl_Signal_Driving_Value_E32, - Grt.Signals.Ghdl_Signal_Driving_Value_E32'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_Next_Assign_Error, - Grt.Signals.Ghdl_Signal_Next_Assign_Error'Address); - - Def (Trans_Decls.Ghdl_Signal_Start_Assign_Null, - Grt.Signals.Ghdl_Signal_Start_Assign_Null'Address); - - Def (Trans_Decls.Ghdl_Signal_Direct_Assign, - Grt.Signals.Ghdl_Signal_Direct_Assign'Address); - - Def (Trans_Decls.Ghdl_Create_Signal_B1, - Grt.Signals.Ghdl_Create_Signal_B1'Address); - Def (Trans_Decls.Ghdl_Signal_Init_B1, - Grt.Signals.Ghdl_Signal_Init_B1'Address); - Def (Trans_Decls.Ghdl_Signal_Simple_Assign_B1, - Grt.Signals.Ghdl_Signal_Simple_Assign_B1'Address); - Def (Trans_Decls.Ghdl_Signal_Start_Assign_B1, - Grt.Signals.Ghdl_Signal_Start_Assign_B1'Address); - Def (Trans_Decls.Ghdl_Signal_Next_Assign_B1, - Grt.Signals.Ghdl_Signal_Next_Assign_B1'Address); - Def (Trans_Decls.Ghdl_Signal_Associate_B1, - Grt.Signals.Ghdl_Signal_Associate_B1'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_E32, - Grt.Signals.Ghdl_Create_Signal_E32'Address); - Def (Trans_Decls.Ghdl_Signal_Init_E32, - Grt.Signals.Ghdl_Signal_Init_E32'Address); - Def (Trans_Decls.Ghdl_Signal_Simple_Assign_E32, - Grt.Signals.Ghdl_Signal_Simple_Assign_E32'Address); - Def (Trans_Decls.Ghdl_Signal_Start_Assign_E32, - Grt.Signals.Ghdl_Signal_Start_Assign_E32'Address); - Def (Trans_Decls.Ghdl_Signal_Next_Assign_E32, - Grt.Signals.Ghdl_Signal_Next_Assign_E32'Address); - Def (Trans_Decls.Ghdl_Signal_Associate_E32, - Grt.Signals.Ghdl_Signal_Associate_E32'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_Add_Package, - Grt.Rtis.Ghdl_Rti_Add_Package'Address); - Def (Trans_Decls.Ghdl_Rti_Add_Top, - Grt.Rtis.Ghdl_Rti_Add_Top'Address); - - 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_File_Open_Status, - Grt.Files.Ghdl_Text_File_Open_Status'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_Elaborate, - Grt.Files.Ghdl_File_Elaborate'Address); - Def (Trans_Decls.Ghdl_File_Finalize, - Grt.Files.Ghdl_File_Finalize'Address); - Def (Trans_Decls.Ghdl_File_Open, - Grt.Files.Ghdl_File_Open'Address); - Def (Trans_Decls.Ghdl_File_Open_Status, - Grt.Files.Ghdl_File_Open_Status'Address); - Def (Trans_Decls.Ghdl_File_Close, - Grt.Files.Ghdl_File_Close'Address); - Def (Trans_Decls.Ghdl_File_Flush, - Grt.Files.Ghdl_File_Flush'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_B1, - Grt.Images.Ghdl_Image_B1'Address); - Def (Trans_Decls.Ghdl_Image_E8, - Grt.Images.Ghdl_Image_E8'Address); - Def (Trans_Decls.Ghdl_Image_E32, - Grt.Images.Ghdl_Image_E32'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_B1, - Grt.Values.Ghdl_Value_B1'Address); - Def (Trans_Decls.Ghdl_Value_E8, - Grt.Values.Ghdl_Value_E8'Address); - Def (Trans_Decls.Ghdl_Value_E32, - Grt.Values.Ghdl_Value_E32'Address); - Def (Trans_Decls.Ghdl_Value_I32, - Grt.Values.Ghdl_Value_I32'Address); - Def (Trans_Decls.Ghdl_Value_F64, - Grt.Values.Ghdl_Value_F64'Address); - Def (Trans_Decls.Ghdl_Value_P32, - Grt.Values.Ghdl_Value_P32'Address); - Def (Trans_Decls.Ghdl_Value_P64, - Grt.Values.Ghdl_Value_P64'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); - - Def (Trans_Decls.Ghdl_Std_Ulogic_Match_Eq, - Grt.Std_Logic_1164.Ghdl_Std_Ulogic_Match_Eq'Address); - Def (Trans_Decls.Ghdl_Std_Ulogic_Match_Ne, - Grt.Std_Logic_1164.Ghdl_Std_Ulogic_Match_Ne'Address); - Def (Trans_Decls.Ghdl_Std_Ulogic_Match_Lt, - Grt.Std_Logic_1164.Ghdl_Std_Ulogic_Match_Lt'Address); - Def (Trans_Decls.Ghdl_Std_Ulogic_Match_Le, - Grt.Std_Logic_1164.Ghdl_Std_Ulogic_Match_Le'Address); - - Def (Trans_Decls.Ghdl_Std_Ulogic_Array_Match_Eq, - Grt.Std_Logic_1164.Ghdl_Std_Ulogic_Array_Match_Eq'Address); - Def (Trans_Decls.Ghdl_Std_Ulogic_Array_Match_Ne, - Grt.Std_Logic_1164.Ghdl_Std_Ulogic_Array_Match_Ne'Address); - - Def (Trans_Decls.Ghdl_To_String_I32, - Grt.Images.Ghdl_To_String_I32'Address); - Def (Trans_Decls.Ghdl_To_String_F64, - Grt.Images.Ghdl_To_String_F64'Address); - Def (Trans_Decls.Ghdl_To_String_F64_Digits, - Grt.Images.Ghdl_To_String_F64_Digits'Address); - Def (Trans_Decls.Ghdl_To_String_F64_Format, - Grt.Images.Ghdl_To_String_F64_Format'Address); - Def (Trans_Decls.Ghdl_To_String_B1, - Grt.Images.Ghdl_To_String_B1'Address); - Def (Trans_Decls.Ghdl_To_String_E8, - Grt.Images.Ghdl_To_String_E8'Address); - Def (Trans_Decls.Ghdl_To_String_E32, - Grt.Images.Ghdl_To_String_E32'Address); - Def (Trans_Decls.Ghdl_To_String_Char, - Grt.Images.Ghdl_To_String_Char'Address); - Def (Trans_Decls.Ghdl_To_String_P32, - Grt.Images.Ghdl_To_String_P32'Address); - Def (Trans_Decls.Ghdl_To_String_P64, - Grt.Images.Ghdl_To_String_P64'Address); - Def (Trans_Decls.Ghdl_Time_To_String_Unit, - Grt.Images.Ghdl_Time_To_String_Unit'Address); - Def (Trans_Decls.Ghdl_BV_To_Ostring, - Grt.Images.Ghdl_BV_To_Ostring'Address); - Def (Trans_Decls.Ghdl_BV_To_Hstring, - Grt.Images.Ghdl_BV_To_Hstring'Address); - Def (Trans_Decls.Ghdl_Array_Char_To_String_B1, - Grt.Images.Ghdl_Array_Char_To_String_B1'Address); - Def (Trans_Decls.Ghdl_Array_Char_To_String_E8, - Grt.Images.Ghdl_Array_Char_To_String_E8'Address); - Def (Trans_Decls.Ghdl_Array_Char_To_String_E32, - Grt.Images.Ghdl_Array_Char_To_String_E32'Address); - - Ortho_Jit.Link (Err); - if Err then - raise Compile_Error; - end if; - - Grtlink.Std_Standard_Boolean_RTI_Ptr := - Ortho_Jit.Get_Address (Trans_Decls.Std_Standard_Boolean_Rti); - Grtlink.Std_Standard_Bit_RTI_Ptr := - Ortho_Jit.Get_Address (Trans_Decls.Std_Standard_Bit_Rti); - if Ieee.Std_Logic_1164.Resolved /= Null_Iir then - Decl := Translation.Get_Resolv_Ortho_Decl - (Ieee.Std_Logic_1164.Resolved); - if Decl /= O_Dnode_Null then - Grtlink.Ieee_Std_Logic_1164_Resolved_Resolv_Ptr := - Ortho_Jit.Get_Address (Decl); - end if; - end if; - - Grtlink.Flag_String := Flags.Flag_String; - - Elaborate_Proc := - Conv (Ortho_Jit.Get_Address (Trans_Decls.Ghdl_Elaborate)); - - Ortho_Jit.Finish; - - Translation.Finalize; - Lists.Initialize; - Str_Table.Initialize; - Nodes.Initialize; - Files_Map.Initialize; - Name_Table.Initialize; - - if Flag_Verbose then - Ada.Text_IO.Put_Line ("Starting simulation"); - end if; - - Grt.Main.Run; - --V := Ghdl_Main (1, Gnat_Argv); - end Run; - - - -- 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.Modules.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, - Ortho_Jit.Decode_Option'Access, - Ortho_Jit.Disp_Help'Access); - Ghdlcomp.Register_Commands; - Register_Command (new Command_Run_Help); - Trans_Be.Register_Translation_Back_End; - end Register_Commands; -end Ghdlrun; diff --git a/translate/ghdldrv/ghdlrun.ads b/translate/ghdldrv/ghdlrun.ads deleted file mode 100644 index 07095bd..0000000 --- a/translate/ghdldrv/ghdlrun.ads +++ /dev/null @@ -1,20 +0,0 @@ --- 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 deleted file mode 100644 index 17cece7..0000000 --- a/translate/ghdldrv/ghdlsimul.adb +++ /dev/null @@ -1,209 +0,0 @@ --- 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 Ada.Text_IO; -with Ada.Command_Line; - -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 Libraries; -with Canon; -with Configuration; -with Iirs_Utils; -with Annotations; -with Elaboration; -with Sim_Be; -with Simulation; -with Execution; - -with Ghdlcomp; - -with Grt.Vpi; -pragma Unreferenced (Grt.Vpi); -with Grt.Types; -with Grt.Options; -with Grtlink; - -package body Ghdlsimul is - - -- FIXME: reuse simulation.top_config - Top_Conf : Iir; - - 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; - Canon.Canon_Flag_Sequentials_Stmts := True; - Canon.Canon_Flag_Expressions := True; - Canon.Canon_Flag_All_Sensitivity := True; - end Compile_Init; - - procedure Compile_Elab - (Cmd_Name : String; Args : Argument_List; Opt_Arg : out Natural) - is - use Name_Table; - use Types; - - First_Id : Name_Id; - Sec_Id : Name_Id; - 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; - - 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); - if Top_Conf = Null_Iir then - raise Compilation_Error; - end if; - - -- Check (and possibly abandon) if entity can be at the top of the - -- hierarchy. - declare - Conf_Unit : constant Iir := Get_Library_Unit (Top_Conf); - Arch : constant Iir := - Get_Block_Specification (Get_Block_Configuration (Conf_Unit)); - Entity : constant Iir := Iirs_Utils.Get_Entity (Arch); - begin - Configuration.Check_Entity_Declaration_Top (Entity); - if Nbr_Errors > 0 then - raise Compilation_Error; - end if; - end; - end Compile_Elab; - - -- Set options. - procedure Set_Run_Options (Args : Argument_List) - is - use Grt.Options; - use Types; - Arg : String_Access; - Status : Decode_Option_Status; - Argv0 : String_Acc; - begin - -- Set progname (used for grt error messages) - Argv0 := new String'(Ada.Command_Line.Command_Name & ASCII.Nul); - Grt.Options.Progname := Grt.Types.To_Ghdl_C_String (Argv0.all'Address); - - 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 - Decode_Option (Arg.all, Status); - pragma Assert (Status = Decode_Option_Ok); - elsif Arg.all = "--trace-elab" then - Elaboration.Trace_Elaboration := True; - elsif Arg.all = "--trace-drivers" then - Elaboration.Trace_Drivers := True; - elsif Arg.all = "--trace-annotation" then - Annotations.Trace_Annotation := True; - elsif Arg.all = "--trace-simu" then - Simulation.Trace_Simulation := True; - elsif Arg.all = "--trace-stmt" then - Execution.Trace_Statements := True; - elsif Arg.all = "--stats" then - Simulation.Disp_Stats := True; - elsif Arg.all = "-i" then - Simulation.Flag_Interractive := True; - else - Decode_Option (Arg.all, Status); - case Status is - when Decode_Option_Last => - exit; - when Decode_Option_Help => - -- FIXME: is that correct ? - exit; - when Decode_Option_Ok => - null; - end case; - -- Ghdlmain.Error ("unknown run options '" & Arg.all & "'"); - -- raise Option_Error; - end if; - end loop; - end Set_Run_Options; - - procedure Run is - begin - Grtlink.Flag_String := Flags.Flag_String; - - Simulation.Simulation_Entity (Top_Conf); - end Run; - - function Decode_Option (Option : String) return Boolean - is - begin - if Option = "--debug" then - Simulation.Flag_Debugger := True; - else - return False; - end if; - return True; - end Decode_Option; - - procedure Disp_Long_Help - is - use Ada.Text_IO; - begin - Put_Line (" --debug Run with debugger"); - 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 deleted file mode 100644 index 264cbf8..0000000 --- a/translate/ghdldrv/ghdlsimul.ads +++ /dev/null @@ -1,20 +0,0 @@ --- 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; diff --git a/translate/ghdldrv/grtlink.ads b/translate/ghdldrv/grtlink.ads deleted file mode 100644 index 4b3951e..0000000 --- a/translate/ghdldrv/grtlink.ads +++ /dev/null @@ -1,39 +0,0 @@ --- GHDL driver - shared variables with grt. --- Copyright (C) 2011 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 System; use System; - -package Grtlink is - - Flag_String : String (1 .. 5); - pragma Export (C, Flag_String, "__ghdl_flag_string"); - - 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"); - -end Grtlink; |