From 3fddf1c59fd7a8fcd260bb9e05c611bef3dd141b Mon Sep 17 00:00:00 2001 From: Tristan Gingold Date: Wed, 5 Nov 2014 05:11:00 +0100 Subject: Move files and dirs from translate/ --- src/ghdldrv/Makefile | 193 ++++ src/ghdldrv/default_pathes.ads.in | 39 + src/ghdldrv/foreigns.adb | 64 ++ src/ghdldrv/foreigns.ads | 5 + src/ghdldrv/ghdl_gcc.adb | 34 + src/ghdldrv/ghdl_jit.adb | 35 + src/ghdldrv/ghdl_simul.adb | 33 + src/ghdldrv/ghdlcomp.adb | 757 +++++++++++++++ src/ghdldrv/ghdlcomp.ads | 67 ++ src/ghdldrv/ghdldrv.adb | 1818 +++++++++++++++++++++++++++++++++++++ src/ghdldrv/ghdldrv.ads | 25 + src/ghdldrv/ghdllocal.adb | 1415 +++++++++++++++++++++++++++++ src/ghdldrv/ghdllocal.ads | 116 +++ src/ghdldrv/ghdlmain.adb | 359 ++++++++ src/ghdldrv/ghdlmain.ads | 85 ++ src/ghdldrv/ghdlprint.adb | 1757 +++++++++++++++++++++++++++++++++++ src/ghdldrv/ghdlprint.ads | 20 + src/ghdldrv/ghdlrun.adb | 661 ++++++++++++++ src/ghdldrv/ghdlrun.ads | 20 + src/ghdldrv/ghdlsimul.adb | 209 +++++ src/ghdldrv/ghdlsimul.ads | 20 + src/ghdldrv/grtlink.ads | 39 + 22 files changed, 7771 insertions(+) create mode 100644 src/ghdldrv/Makefile create mode 100644 src/ghdldrv/default_pathes.ads.in create mode 100644 src/ghdldrv/foreigns.adb create mode 100644 src/ghdldrv/foreigns.ads create mode 100644 src/ghdldrv/ghdl_gcc.adb create mode 100644 src/ghdldrv/ghdl_jit.adb create mode 100644 src/ghdldrv/ghdl_simul.adb create mode 100644 src/ghdldrv/ghdlcomp.adb create mode 100644 src/ghdldrv/ghdlcomp.ads create mode 100644 src/ghdldrv/ghdldrv.adb create mode 100644 src/ghdldrv/ghdldrv.ads create mode 100644 src/ghdldrv/ghdllocal.adb create mode 100644 src/ghdldrv/ghdllocal.ads create mode 100644 src/ghdldrv/ghdlmain.adb create mode 100644 src/ghdldrv/ghdlmain.ads create mode 100644 src/ghdldrv/ghdlprint.adb create mode 100644 src/ghdldrv/ghdlprint.ads create mode 100644 src/ghdldrv/ghdlrun.adb create mode 100644 src/ghdldrv/ghdlrun.ads create mode 100644 src/ghdldrv/ghdlsimul.adb create mode 100644 src/ghdldrv/ghdlsimul.ads create mode 100644 src/ghdldrv/grtlink.ads (limited to 'src/ghdldrv') diff --git a/src/ghdldrv/Makefile b/src/ghdldrv/Makefile new file mode 100644 index 0000000..ebf23c2 --- /dev/null +++ b/src/ghdldrv/Makefile @@ -0,0 +1,193 @@ +# -*- 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/src/ghdldrv/default_pathes.ads.in b/src/ghdldrv/default_pathes.ads.in new file mode 100644 index 0000000..7f471a5 --- /dev/null +++ b/src/ghdldrv/default_pathes.ads.in @@ -0,0 +1,39 @@ +-- 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/src/ghdldrv/foreigns.adb b/src/ghdldrv/foreigns.adb new file mode 100644 index 0000000..15e3dd0 --- /dev/null +++ b/src/ghdldrv/foreigns.adb @@ -0,0 +1,64 @@ +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/src/ghdldrv/foreigns.ads b/src/ghdldrv/foreigns.ads new file mode 100644 index 0000000..5759ae4 --- /dev/null +++ b/src/ghdldrv/foreigns.ads @@ -0,0 +1,5 @@ +with System; use System; + +package Foreigns is + function Find_Foreign (Name : String) return Address; +end Foreigns; diff --git a/src/ghdldrv/ghdl_gcc.adb b/src/ghdldrv/ghdl_gcc.adb new file mode 100644 index 0000000..615a8c5 --- /dev/null +++ b/src/ghdldrv/ghdl_gcc.adb @@ -0,0 +1,34 @@ +-- 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/src/ghdldrv/ghdl_jit.adb b/src/ghdldrv/ghdl_jit.adb new file mode 100644 index 0000000..ba70874 --- /dev/null +++ b/src/ghdldrv/ghdl_jit.adb @@ -0,0 +1,35 @@ +-- 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/src/ghdldrv/ghdl_simul.adb b/src/ghdldrv/ghdl_simul.adb new file mode 100644 index 0000000..d4d0abd --- /dev/null +++ b/src/ghdldrv/ghdl_simul.adb @@ -0,0 +1,33 @@ +-- 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/src/ghdldrv/ghdlcomp.adb b/src/ghdldrv/ghdlcomp.adb new file mode 100644 index 0000000..ba755af --- /dev/null +++ b/src/ghdldrv/ghdlcomp.adb @@ -0,0 +1,757 @@ +-- 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/src/ghdldrv/ghdlcomp.ads b/src/ghdldrv/ghdlcomp.ads new file mode 100644 index 0000000..f803ca4 --- /dev/null +++ b/src/ghdldrv/ghdlcomp.ads @@ -0,0 +1,67 @@ +-- GHDL driver - compile commands. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with GNAT.OS_Lib; use GNAT.OS_Lib; + +package Ghdlcomp is + -- This procedure is called at start of commands which call + -- finish_compilation to generate code. + type Compile_Init_Acc is access procedure (Analyze_Only : Boolean); + + -- This procedure is called for elaboration. + -- CMD_NAME is the name of the command, used to report errors. + -- ARGS is the argument list, starting from the unit name to be elaborated. + -- The procedure should extract the unit. + -- OPT_ARG is the index of the first argument from ARGS to be used as + -- a run option. + type Compile_Elab_Acc is access procedure + (Cmd_Name : String; Args : Argument_List; Opt_Arg : out Natural); + + -- Use ARGS as run options. + -- Should do all the work. + type Set_Run_Options_Acc is access + procedure (Args : Argument_List); + + -- Run the simulation. + -- All the parameters were set through calling Compile_Elab and + -- Set_Run_Options. + type Run_Acc is access procedure; + + -- Called when an analysis/elaboration option is decoded. + -- Return True if OPTION is known (and do the side effects). + -- No parameters are allowed. + type Decode_Option_Acc is access function (Option : String) return Boolean; + + -- Disp help for options decoded by Decode_Option. + type Disp_Long_Help_Acc is access procedure; + + -- All the hooks gathered. + -- A record is used to be sure all hooks are set. + type Hooks_Type is record + Compile_Init : Compile_Init_Acc := null; + Compile_Elab : Compile_Elab_Acc := null; + Set_Run_Options : Set_Run_Options_Acc := null; + Run : Run_Acc := null; + Decode_Option : Decode_Option_Acc := null; + Disp_Long_Help : Disp_Long_Help_Acc := null; + end record; + + Hooks : Hooks_Type; + + -- Register commands. + procedure Register_Commands; +end Ghdlcomp; diff --git a/src/ghdldrv/ghdldrv.adb b/src/ghdldrv/ghdldrv.adb new file mode 100644 index 0000000..be905f1 --- /dev/null +++ b/src/ghdldrv/ghdldrv.adb @@ -0,0 +1,1818 @@ +-- 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/src/ghdldrv/ghdldrv.ads b/src/ghdldrv/ghdldrv.ads new file mode 100644 index 0000000..3e37b38 --- /dev/null +++ b/src/ghdldrv/ghdldrv.ads @@ -0,0 +1,25 @@ +-- 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/src/ghdldrv/ghdllocal.adb b/src/ghdldrv/ghdllocal.adb new file mode 100644 index 0000000..a1d94bd --- /dev/null +++ b/src/ghdldrv/ghdllocal.adb @@ -0,0 +1,1415 @@ +-- 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 (" 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/src/ghdldrv/ghdllocal.ads b/src/ghdldrv/ghdllocal.ads new file mode 100644 index 0000000..2c7018a --- /dev/null +++ b/src/ghdldrv/ghdllocal.ads @@ -0,0 +1,116 @@ +-- 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/src/ghdldrv/ghdlmain.adb b/src/ghdldrv/ghdlmain.adb new file mode 100644 index 0000000..45d9615 --- /dev/null +++ b/src/ghdldrv/ghdlmain.adb @@ -0,0 +1,359 @@ +-- 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/src/ghdldrv/ghdlmain.ads b/src/ghdldrv/ghdlmain.ads new file mode 100644 index 0000000..c01f1d6 --- /dev/null +++ b/src/ghdldrv/ghdlmain.ads @@ -0,0 +1,85 @@ +-- GHDL driver - main part. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with GNAT.OS_Lib; use GNAT.OS_Lib; +with Errorout; + +package Ghdlmain is + type Command_Type; + + type Command_Acc is access all Command_Type'Class; + + type Command_Type is abstract tagged record + Next : Command_Acc; + end record; + + -- Return TRUE iff CMD handle action ACTION. + function Decode_Command (Cmd : Command_Type; Name : String) return Boolean + is abstract; + + -- Initialize the command, before decoding actions. + procedure Init (Cmd : in out Command_Type); + + -- Option_OK: OPTION is handled. + -- Option_Bad: OPTION is unknown. + -- Option_Arg_Req: OPTION requires an argument. Must be set only when + -- ARG = "", the manager will recall Decode_Option. + -- Option_Arg: OPTION used the argument. + type Option_Res is + (Option_Bad, Option_Ok, Option_Arg, Option_Arg_Req, Option_End); + procedure Decode_Option (Cmd : in out Command_Type; + Option : String; + Arg : String; + Res : out Option_Res); + + -- Get a one-line help for the command. + function Get_Short_Help (Cmd : Command_Type) return String + is abstract; + + -- Disp detailled help. + procedure Disp_Long_Help (Cmd : Command_Type); + + -- Perform the action. + procedure Perform_Action (Cmd : in out Command_Type; Args : Argument_List) + is abstract; + + -- Register a command. + procedure Register_Command (Cmd : Command_Acc); + + -- Disp MSG on the standard output with the command name. + procedure Error (Msg : String); + + -- May be raise by perform_action if the arguments are bad. + Option_Error : exception renames Errorout.Option_Error; + + -- Action failed. + Compile_Error : exception; + + -- Exec failed: either the program was not found, or failed. + Exec_Error : exception; + + procedure Main; + + -- Additionnal one-line message displayed by the --version command, + -- if defined. + -- Used to customize. + type String_Cst_Acc is access constant String; + Version_String : String_Cst_Acc := null; + + -- Registers all commands in this package. + procedure Register_Commands; +end Ghdlmain; diff --git a/src/ghdldrv/ghdlprint.adb b/src/ghdldrv/ghdlprint.adb new file mode 100644 index 0000000..45e70e1 --- /dev/null +++ b/src/ghdldrv/ghdlprint.adb @@ -0,0 +1,1757 @@ +-- 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 (""); + when Html_Css => + Put (""); + 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 (""); + when Html_Css => + Put (""); + 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 (""); + Disp_Text; + Put (""); + when Html_Css => + Put (""); + Disp_Text; + Put (""); + 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 (" + 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 (""); + when Xref_Ref + | Xref_End => + Decl := Get_Xref_Node (Ref); + Loc := Get_Location (Decl); + if Loc /= Location_Nil then + Put (""); + Disp_Text; + Put (""); + else + -- This may happen for overload list, in use clauses. + Disp_Text; + end if; + when Xref_Body => + Put (""); + Disp_Text; + Put (""); + 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 (""); + Disp_Text; + Put (""); + when Html_Css => + Put (""); + Disp_Text; + Put (""); + end case; + else + Decl := Get_Xref_Node (Ref); + Loc := Get_Location (Decl); + Put (""); + Disp_Text; + Put (""); + end if; + end Disp_Attribute; + begin + Scanner.Flag_Comment := True; + Scanner.Flag_Newline := True; + + Set_File (File); + Buf := Get_File_Source (File); + + Put_Line ("
");
+      Line := 1;
+      Disp_Ln;
+      Last_Tok := Source_Ptr_Org;
+      Prev_Tok := Tok_Invalid;
+      loop
+         Scan;
+         Bef_Tok := Get_Token_Position;
+         Aft_Tok := Get_Position;
+         case Current_Token is
+            when Tok_Eof =>
+               exit;
+            when Tok_Newline =>
+               New_Line;
+               Line := Line + 1;
+               Disp_Ln;
+            when Tok_Comment =>
+               Disp_Spaces;
+               case Html_Format is
+                  when Html_2 =>
+                     Put ("");
+                     Disp_Text;
+                     Put ("");
+                  when Html_Css =>
+                     Put ("");
+                     Disp_Text;
+                     Put ("");
+               end case;
+            when Tok_Access .. Tok_Elsif
+              | Tok_Entity .. Tok_With
+              | Tok_Mod .. Tok_Rem
+              | Tok_And .. Tok_Not =>
+               Disp_Reserved;
+            when Tok_End =>
+               Disp_Reserved;
+            when Tok_Semi_Colon =>
+               Disp_Spaces;
+               Disp_Text;
+            when Tok_Xnor .. Tok_Ror =>
+               Disp_Reserved;
+            when Tok_Protected =>
+               Disp_Reserved;
+            when Tok_Across .. Tok_Tolerance =>
+               Disp_Reserved;
+            when Tok_Psl_Default
+              | Tok_Psl_Clock
+              | Tok_Psl_Property
+              | Tok_Psl_Sequence
+              | Tok_Psl_Endpoint
+              | Tok_Psl_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 ("");
+                     Disp_Text;
+                     Put ("");
+                  when Html_Css =>
+                     Put ("");
+                     Disp_Text;
+                     Put ("");
+               end case;
+            when Tok_Identifier =>
+               if Prev_Tok = Tok_Tick then
+                  Disp_Attribute;
+               else
+                  Disp_Identifier;
+               end if;
+            when Tok_Left_Paren .. Tok_Colon
+              | Tok_Comma .. Tok_Dot
+              | Tok_Equal_Equal
+              | Tok_Integer
+              | Tok_Real
+              | Tok_Equal .. Tok_Slash
+              | Tok_Invalid =>
+               Disp_Spaces;
+               Disp_Text;
+         end case;
+         Last_Tok := Aft_Tok;
+         Prev_Tok := Current_Token;
+      end loop;
+      Close_File;
+      New_Line;
+      Put_Line ("
"); + Put_Line ("
"); + end PP_Html_File; + + procedure Put_Html_Header + is + begin + Put (""); + Put_Line (" "); + case Html_Format is + when Html_2 => + null; + when Html_Css => + Put_Line (" "); + end case; + --Put_Line (""); + --Put_Line(""); + --Put_Line (""); + --Put_Line (""); + 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 ("

"); + Put ("This page was generated using "); + Put (""); + Put (Version.Ghdl_Release); + Put (", a program written by"); + Put (" Tristan Gingold"); + New_Line; + Put_Line ("

"); + Put_Line (""); + Put_Line (""); + end Put_Html_Foot; + + function Create_Output_Filename (Name : String; Num : Natural) + return String_Acc + is + -- Position of the extension. 0 if none. + Ext_Pos : Natural; + + Num_Str : String := Natural'Image (Num); + begin + -- Search for the extension. + Ext_Pos := 0; + for I in reverse Name'Range loop + exit when Name (I) = Directory_Separator; + if Name (I) = '.' then + Ext_Pos := I - 1; + exit; + end if; + end loop; + if Ext_Pos = 0 then + Ext_Pos := Name'Last; + end if; + Num_Str (1) := '.'; + return new String'(Name (Name'First .. Ext_Pos) & Num_Str & ".html"); + end Create_Output_Filename; + + -- Command --chop. + type Command_Chop is new Command_Lib with null record; + function Decode_Command (Cmd : Command_Chop; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Chop) return String; + procedure Perform_Action (Cmd : in out Command_Chop; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Chop; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "--chop"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Chop) return String + is + pragma Unreferenced (Cmd); + begin + return "--chop [OPTS] FILEs Chop FILEs"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_Chop; Args : Argument_List) + is + pragma Unreferenced (Cmd); + use Ada.Characters.Latin_1; + + function Build_File_Name_Length (Lib : Iir) return Natural + is + Id : constant Name_Id := Get_Identifier (Lib); + Len : Natural; + Id1 : Name_Id; + begin + Len := Get_Name_Length (Id); + case Get_Kind (Lib) is + when Iir_Kind_Configuration_Declaration + | Iir_Kind_Entity_Declaration + | Iir_Kind_Package_Declaration + | Iir_Kind_Package_Instantiation_Declaration => + null; + when Iir_Kind_Package_Body => + Len := Len + 1 + 4; -- add -body + when Iir_Kind_Architecture_Body => + Id1 := Get_Entity_Identifier_Of_Architecture (Lib); + Len := Len + 1 + Get_Name_Length (Id1); + when others => + Error_Kind ("build_file_name", Lib); + end case; + Len := Len + 1 + 4; -- add .vhdl + return Len; + end Build_File_Name_Length; + + procedure Build_File_Name (Lib : Iir; Res : out String) + is + Id : constant Name_Id := Get_Identifier (Lib); + P : Natural; + + procedure Append (Str : String) is + begin + Res (P + 1 .. P + Str'Length) := Str; + P := P + Str'Length; + end Append; + begin + P := Res'First - 1; + case Get_Kind (Lib) is + when Iir_Kind_Configuration_Declaration + | Iir_Kind_Entity_Declaration + | Iir_Kind_Package_Declaration + | Iir_Kind_Package_Instantiation_Declaration => + Image (Id); + Append (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 (" "); + for I in Files'Range loop + Put (" "); + Put_Line (Files (I).all); + end loop; + Put_Line (" "); + Put_Line (""); + New_Line; + Put_Line (""); + + 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 ("

"); + Put (Files (I).all); + Put ("

"); + 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 (" "); + Put_Html (Files_Name (I).all); + Put (""); + Put_Line (""); + New_Line; + Put_Line (""); + + Put ("

"); + Put_Html (Files_Name (I).all); + Put ("

"); + 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 (" Xrefs indexes"); + Put_Line (""); + New_Line; + Put_Line (""); + Put_Line ("

list of files:"); + Put_Line ("

"); + Put_Line ("
"); + + -- TODO: list of design units. + + Put_Line ("

list of files referenced but not available:"); + Put_Line ("

"); + 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/src/ghdldrv/ghdlprint.ads b/src/ghdldrv/ghdlprint.ads new file mode 100644 index 0000000..82c3e60 --- /dev/null +++ b/src/ghdldrv/ghdlprint.ads @@ -0,0 +1,20 @@ +-- 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/src/ghdldrv/ghdlrun.adb b/src/ghdldrv/ghdlrun.adb new file mode 100644 index 0000000..f623721 --- /dev/null +++ b/src/ghdldrv/ghdlrun.adb @@ -0,0 +1,661 @@ +-- 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/src/ghdldrv/ghdlrun.ads b/src/ghdldrv/ghdlrun.ads new file mode 100644 index 0000000..07095bd --- /dev/null +++ b/src/ghdldrv/ghdlrun.ads @@ -0,0 +1,20 @@ +-- GHDL driver - JIT commands. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +package Ghdlrun is + procedure Register_Commands; +end Ghdlrun; diff --git a/src/ghdldrv/ghdlsimul.adb b/src/ghdldrv/ghdlsimul.adb new file mode 100644 index 0000000..17cece7 --- /dev/null +++ b/src/ghdldrv/ghdlsimul.adb @@ -0,0 +1,209 @@ +-- 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/src/ghdldrv/ghdlsimul.ads b/src/ghdldrv/ghdlsimul.ads new file mode 100644 index 0000000..264cbf8 --- /dev/null +++ b/src/ghdldrv/ghdlsimul.ads @@ -0,0 +1,20 @@ +-- GHDL driver - simulator commands. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +package Ghdlsimul is + procedure Register_Commands; +end Ghdlsimul; diff --git a/src/ghdldrv/grtlink.ads b/src/ghdldrv/grtlink.ads new file mode 100644 index 0000000..4b3951e --- /dev/null +++ b/src/ghdldrv/grtlink.ads @@ -0,0 +1,39 @@ +-- 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; -- cgit