aboutsummaryrefslogtreecommitdiffstats
path: root/src/ghdldrv
diff options
context:
space:
mode:
authorTristan Gingold <tgingold@free.fr>2014-11-05 05:11:00 +0100
committerTristan Gingold <tgingold@free.fr>2014-11-05 05:11:00 +0100
commit3fddf1c59fd7a8fcd260bb9e05c611bef3dd141b (patch)
treecbfe6d75f8e09db8b98f335406fb6ecb2fce3e0c /src/ghdldrv
parent0a088b311ed2fcebc542f8a2e42d09e2e3c9311c (diff)
downloadghdl-3fddf1c59fd7a8fcd260bb9e05c611bef3dd141b.tar.gz
ghdl-3fddf1c59fd7a8fcd260bb9e05c611bef3dd141b.tar.bz2
ghdl-3fddf1c59fd7a8fcd260bb9e05c611bef3dd141b.zip
Move files and dirs from translate/
Diffstat (limited to 'src/ghdldrv')
-rw-r--r--src/ghdldrv/Makefile193
-rw-r--r--src/ghdldrv/default_pathes.ads.in39
-rw-r--r--src/ghdldrv/foreigns.adb64
-rw-r--r--src/ghdldrv/foreigns.ads5
-rw-r--r--src/ghdldrv/ghdl_gcc.adb34
-rw-r--r--src/ghdldrv/ghdl_jit.adb35
-rw-r--r--src/ghdldrv/ghdl_simul.adb33
-rw-r--r--src/ghdldrv/ghdlcomp.adb757
-rw-r--r--src/ghdldrv/ghdlcomp.ads67
-rw-r--r--src/ghdldrv/ghdldrv.adb1818
-rw-r--r--src/ghdldrv/ghdldrv.ads25
-rw-r--r--src/ghdldrv/ghdllocal.adb1415
-rw-r--r--src/ghdldrv/ghdllocal.ads116
-rw-r--r--src/ghdldrv/ghdlmain.adb359
-rw-r--r--src/ghdldrv/ghdlmain.ads85
-rw-r--r--src/ghdldrv/ghdlprint.adb1757
-rw-r--r--src/ghdldrv/ghdlprint.ads20
-rw-r--r--src/ghdldrv/ghdlrun.adb661
-rw-r--r--src/ghdldrv/ghdlrun.ads20
-rw-r--r--src/ghdldrv/ghdlsimul.adb209
-rw-r--r--src/ghdldrv/ghdlsimul.ads20
-rw-r--r--src/ghdldrv/grtlink.ads39
22 files changed, 7771 insertions, 0 deletions
diff --git a/src/ghdldrv/Makefile b/src/ghdldrv/Makefile
new file mode 100644
index 000000000..ebf23c2d1
--- /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 000000000..7f471a5ed
--- /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 000000000..15e3dd009
--- /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 000000000..5759ae4f5
--- /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 000000000..615a8c5d6
--- /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 000000000..ba7087492
--- /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 000000000..d4d0abd7a
--- /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 000000000..ba755af8a
--- /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 000000000..f803ca4fa
--- /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 000000000..be905f1af
--- /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 000000000..3e37b38f1
--- /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 000000000..a1d94bd77
--- /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 ("<default> of entity ");
+ Image (Get_Entity_Identifier_Of_Architecture (Unit));
+ Put (Name_Buffer (1 .. Name_Length));
+ end if;
+ when others =>
+ null;
+ end case;
+ end Disp_Library_Unit;
+
+ procedure Disp_Library (Name : Name_Id)
+ is
+ use Ada.Text_IO;
+ use Libraries;
+ Lib : Iir_Library_Declaration;
+ File : Iir_Design_File;
+ Unit : Iir;
+ begin
+ if Name = Std_Names.Name_Work then
+ Lib := Work_Library;
+ elsif Name = Std_Names.Name_Std then
+ Lib := Std_Library;
+ else
+ Lib := Get_Library (Name, Command_Line_Location);
+ end if;
+
+ -- Disp contents of files.
+ File := Get_Design_File_Chain (Lib);
+ while File /= Null_Iir loop
+ Unit := Get_First_Design_Unit (File);
+ while Unit /= Null_Iir loop
+ Disp_Library_Unit (Get_Library_Unit (Unit));
+ New_Line;
+ Unit := Get_Chain (Unit);
+ end loop;
+ File := Get_Chain (File);
+ end loop;
+ end Disp_Library;
+
+ -- Return FILENAME without the extension.
+ function Get_Base_Name (Filename : String; Remove_Dir : Boolean := True)
+ return String
+ is
+ First : Natural;
+ Last : Natural;
+ begin
+ First := Filename'First;
+ Last := Filename'Last;
+ for I in Filename'Range loop
+ if Filename (I) = '.' then
+ Last := I - 1;
+ elsif Remove_Dir and then Filename (I) = Directory_Separator then
+ First := I + 1;
+ Last := Filename'Last;
+ end if;
+ end loop;
+ return Filename (First .. Last);
+ end Get_Base_Name;
+
+ function Append_Suffix (File : String; Suffix : String) return String_Access
+ is
+ use Name_Table;
+ Basename : constant String := Get_Base_Name (File);
+ begin
+ Image (Libraries.Work_Directory);
+ Name_Buffer (Name_Length + 1 .. Name_Length + Basename'Length) :=
+ Basename;
+ Name_Length := Name_Length + Basename'Length;
+ Name_Buffer (Name_Length + 1 .. Name_Length + Suffix'Length) := Suffix;
+ Name_Length := Name_Length + Suffix'Length;
+ return new String'(Name_Buffer (1 .. Name_Length));
+ end Append_Suffix;
+
+
+ -- Command Dir.
+ type Command_Dir is new Command_Lib with null record;
+ function Decode_Command (Cmd : Command_Dir; Name : String) return Boolean;
+ function Get_Short_Help (Cmd : Command_Dir) return String;
+ procedure Perform_Action (Cmd : in out Command_Dir; Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Dir; Name : String) return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "-d" or else Name = "--dir";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Dir) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "-d or --dir Disp contents of the work library";
+ end Get_Short_Help;
+
+ procedure Perform_Action (Cmd : in out Command_Dir; Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ if Args'Length /= 0 then
+ Error ("command '-d' does not accept any argument");
+ raise Option_Error;
+ end if;
+
+ Flags.Bootstrap := True;
+ -- Load word library.
+ Libraries.Load_Std_Library;
+ Libraries.Load_Work_Library;
+
+ Disp_Library (Std_Names.Name_Work);
+
+-- else
+-- for L in Libs'Range loop
+-- Id := Get_Identifier (Libs (L).all);
+-- Disp_Library (Id);
+-- end loop;
+-- end if;
+ end Perform_Action;
+
+ -- Command Find.
+ type Command_Find is new Command_Lib with null record;
+ function Decode_Command (Cmd : Command_Find; Name : String) return Boolean;
+ function Get_Short_Help (Cmd : Command_Find) return String;
+ procedure Perform_Action (Cmd : in out Command_Find; Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Find; Name : String) return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "-f";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Find) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "-f FILEs Disp units in FILES";
+ end Get_Short_Help;
+
+ -- Return TRUE is UNIT can be at the apex of a design hierarchy.
+ function Is_Top_Entity (Unit : Iir) return Boolean
+ is
+ begin
+ if Get_Kind (Unit) /= Iir_Kind_Entity_Declaration then
+ return False;
+ end if;
+ if Get_Port_Chain (Unit) /= Null_Iir then
+ return False;
+ end if;
+ if Get_Generic_Chain (Unit) /= Null_Iir then
+ return False;
+ end if;
+ return True;
+ end Is_Top_Entity;
+
+ -- Disp contents design files FILES.
+ procedure Perform_Action (Cmd : in out Command_Find; Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+
+ use Ada.Text_IO;
+ use Name_Table;
+ Id : Name_Id;
+ Design_File : Iir_Design_File;
+ Unit : Iir;
+ Lib : Iir;
+ Flag_Add : constant Boolean := False;
+ begin
+ Flags.Bootstrap := True;
+ Libraries.Load_Std_Library;
+ Libraries.Load_Work_Library;
+
+ for I in Args'Range loop
+ Id := Get_Identifier (Args (I).all);
+ Design_File := Libraries.Load_File (Id);
+ if Design_File /= Null_Iir then
+ Unit := Get_First_Design_Unit (Design_File);
+ while Unit /= Null_Iir loop
+ Lib := Get_Library_Unit (Unit);
+ Disp_Library_Unit (Lib);
+ if Is_Top_Entity (Lib) then
+ Put (" **");
+ end if;
+ New_Line;
+ if Flag_Add then
+ Libraries.Add_Design_Unit_Into_Library (Unit);
+ end if;
+ Unit := Get_Chain (Unit);
+ end loop;
+ end if;
+ end loop;
+ if Flag_Add then
+ Libraries.Save_Work_Library;
+ end if;
+ end Perform_Action;
+
+ -- Command Import.
+ type Command_Import is new Command_Lib with null record;
+ function Decode_Command (Cmd : Command_Import; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Import) return String;
+ procedure Perform_Action (Cmd : in out Command_Import;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Import; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "-i";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Import) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "-i [OPTS] FILEs Import units of FILEs";
+ end Get_Short_Help;
+
+ procedure Perform_Action (Cmd : in out Command_Import; Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ use Ada.Text_IO;
+ Id : Name_Id;
+ Design_File : Iir_Design_File;
+ Unit : Iir;
+ Next_Unit : Iir;
+ Lib : Iir;
+ begin
+ Setup_Libraries (True);
+
+ -- Parse all files.
+ for I in Args'Range loop
+ Id := Name_Table.Get_Identifier (Args (I).all);
+ Design_File := Libraries.Load_File (Id);
+ if Design_File /= Null_Iir then
+ Unit := Get_First_Design_Unit (Design_File);
+ while Unit /= Null_Iir loop
+ if Flag_Verbose then
+ Lib := Get_Library_Unit (Unit);
+ Disp_Library_Unit (Lib);
+ if Is_Top_Entity (Lib) then
+ Put (" **");
+ end if;
+ New_Line;
+ end if;
+ Next_Unit := Get_Chain (Unit);
+ Set_Chain (Unit, Null_Iir);
+ Libraries.Add_Design_Unit_Into_Library (Unit);
+ Unit := Next_Unit;
+ end loop;
+ end if;
+ end loop;
+
+ -- Analyze all files.
+ if False then
+ Design_File := Get_Design_File_Chain (Libraries.Work_Library);
+ while Design_File /= Null_Iir loop
+ Unit := Get_First_Design_Unit (Design_File);
+ while Unit /= Null_Iir loop
+ case Get_Date (Unit) is
+ when Date_Valid
+ | Date_Analyzed =>
+ null;
+ when Date_Parsed =>
+ Back_End.Finish_Compilation (Unit, False);
+ when others =>
+ raise Internal_Error;
+ end case;
+ Unit := Get_Chain (Unit);
+ end loop;
+ Design_File := Get_Chain (Design_File);
+ end loop;
+ end if;
+
+ Libraries.Save_Work_Library;
+ exception
+ when Errorout.Compilation_Error =>
+ Error ("importation has failed due to compilation error");
+ raise;
+ end Perform_Action;
+
+ -- Command Check_Syntax.
+ type Command_Check_Syntax is new Command_Lib with null record;
+ function Decode_Command (Cmd : Command_Check_Syntax; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Check_Syntax) return String;
+ procedure Perform_Action (Cmd : in out Command_Check_Syntax;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Check_Syntax; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "-s";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Check_Syntax) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "-s [OPTS] FILEs Check syntax of FILEs";
+ end Get_Short_Help;
+
+ procedure Analyze_One_File (File_Name : String)
+ is
+ use Ada.Text_IO;
+ Id : Name_Id;
+ Design_File : Iir_Design_File;
+ Unit : Iir;
+ Next_Unit : Iir;
+ begin
+ Id := Name_Table.Get_Identifier (File_Name);
+ if Flag_Verbose then
+ Put (File_Name);
+ Put_Line (":");
+ end if;
+ Design_File := Libraries.Load_File (Id);
+ if Design_File = Null_Iir then
+ raise Errorout.Compilation_Error;
+ end if;
+
+ Unit := Get_First_Design_Unit (Design_File);
+ while Unit /= Null_Iir loop
+ if Flag_Verbose then
+ Put (' ');
+ Disp_Library_Unit (Get_Library_Unit (Unit));
+ New_Line;
+ end if;
+ -- Sem, canon, annotate a design unit.
+ Back_End.Finish_Compilation (Unit, True);
+
+ Next_Unit := Get_Chain (Unit);
+ if Errorout.Nbr_Errors = 0 then
+ Set_Chain (Unit, Null_Iir);
+ Libraries.Add_Design_Unit_Into_Library (Unit);
+ end if;
+
+ Unit := Next_Unit;
+ end loop;
+
+ if Errorout.Nbr_Errors > 0 then
+ raise Errorout.Compilation_Error;
+ end if;
+ end Analyze_One_File;
+
+ procedure Analyze_Files (Files : Argument_List; Save_Library : Boolean) is
+ begin
+ Setup_Libraries (True);
+
+ -- Parse all files.
+ for I in Files'Range loop
+ Analyze_One_File (Files (I).all);
+ end loop;
+
+ if Save_Library then
+ Libraries.Save_Work_Library;
+ end if;
+ end Analyze_Files;
+
+ procedure Perform_Action (Cmd : in out Command_Check_Syntax;
+ Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ Analyze_Files (Args, False);
+ end Perform_Action;
+
+ -- Command --clean: remove object files.
+ type Command_Clean is new Command_Lib with null record;
+ function Decode_Command (Cmd : Command_Clean; Name : String) return Boolean;
+ function Get_Short_Help (Cmd : Command_Clean) return String;
+ procedure Perform_Action (Cmd : in out Command_Clean; Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Clean; Name : String) return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "--clean";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Clean) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "--clean Remove generated files";
+ end Get_Short_Help;
+
+ procedure Delete (Str : String)
+ is
+ use Ada.Text_IO;
+ Status : Boolean;
+ begin
+ Delete_File (Str'Address, Status);
+ if Flag_Verbose and Status then
+ Put_Line ("delete " & Str (Str'First .. Str'Last - 1));
+ end if;
+ end Delete;
+
+ procedure Perform_Action (Cmd : in out Command_Clean; Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ use Name_Table;
+
+ procedure Delete_Asm_Obj (Str : String) is
+ begin
+ Delete (Str & Get_Object_Suffix.all & Nul);
+ Delete (Str & Asm_Suffix & Nul);
+ end Delete_Asm_Obj;
+
+ procedure Delete_Top_Unit (Str : String) is
+ begin
+ -- Delete elaboration file
+ Delete_Asm_Obj (Image (Libraries.Work_Directory) & Elab_Prefix & Str);
+
+ -- Delete file list.
+ Delete (Image (Libraries.Work_Directory) & Str & List_Suffix & Nul);
+
+ -- Delete executable.
+ Delete (Str & Nul);
+ end Delete_Top_Unit;
+
+ File : Iir_Design_File;
+ Design_Unit : Iir_Design_Unit;
+ Lib_Unit : Iir;
+ Str : String_Access;
+ begin
+ if Args'Length /= 0 then
+ Error ("command '--clean' does not accept any argument");
+ raise Option_Error;
+ end if;
+
+ Flags.Bootstrap := True;
+ -- Load libraries.
+ Libraries.Load_Std_Library;
+ Libraries.Load_Work_Library;
+
+ File := Get_Design_File_Chain (Libraries.Work_Library);
+ while File /= Null_Iir loop
+ -- Delete compiled file.
+ Str := Append_Suffix (Image (Get_Design_File_Filename (File)), "");
+ Delete_Asm_Obj (Str.all);
+ Free (Str);
+
+ Design_Unit := Get_First_Design_Unit (File);
+ while Design_Unit /= Null_Iir loop
+ Lib_Unit := Get_Library_Unit (Design_Unit);
+ case Get_Kind (Lib_Unit) is
+ when Iir_Kind_Entity_Declaration
+ | Iir_Kind_Configuration_Declaration =>
+ Delete_Top_Unit (Image (Get_Identifier (Lib_Unit)));
+ when Iir_Kind_Architecture_Body =>
+ Delete_Top_Unit
+ (Image (Get_Entity_Identifier_Of_Architecture (Lib_Unit))
+ & '-'
+ & Image (Get_Identifier (Lib_Unit)));
+ when others =>
+ null;
+ end case;
+ Design_Unit := Get_Chain (Design_Unit);
+ end loop;
+ File := Get_Chain (File);
+ end loop;
+ end Perform_Action;
+
+ -- Command --remove: remove object file and library file.
+ type Command_Remove is new Command_Clean with null record;
+ function Decode_Command (Cmd : Command_Remove; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Remove) return String;
+ procedure Perform_Action (Cmd : in out Command_Remove;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Remove; Name : String) return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "--remove";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Remove) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "--remove Remove generated files and library file";
+ end Get_Short_Help;
+
+ procedure Perform_Action (Cmd : in out Command_Remove; Args : Argument_List)
+ is
+ use Name_Table;
+ begin
+ if Args'Length /= 0 then
+ Error ("command '--remove' does not accept any argument");
+ raise Option_Error;
+ end if;
+ Perform_Action (Command_Clean (Cmd), Args);
+ Delete (Image (Libraries.Work_Directory)
+ & Back_End.Library_To_File_Name (Libraries.Work_Library)
+ & Nul);
+ end Perform_Action;
+
+ -- Command --copy: copy work library to current directory.
+ type Command_Copy is new Command_Lib with null record;
+ function Decode_Command (Cmd : Command_Copy; Name : String) return Boolean;
+ function Get_Short_Help (Cmd : Command_Copy) return String;
+ procedure Perform_Action (Cmd : in out Command_Copy; Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Copy; Name : String) return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "--copy";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Copy) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "--copy Copy work library to current directory";
+ end Get_Short_Help;
+
+ procedure Perform_Action (Cmd : in out Command_Copy; Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ use Name_Table;
+ use Libraries;
+
+ File : Iir_Design_File;
+ Dir : Name_Id;
+ begin
+ if Args'Length /= 0 then
+ Error ("command '--copy' does not accept any argument");
+ raise Option_Error;
+ end if;
+
+ Setup_Libraries (False);
+ Libraries.Load_Std_Library;
+ Dir := Work_Directory;
+ Work_Directory := Null_Identifier;
+ Libraries.Load_Work_Library;
+ Work_Directory := Dir;
+
+ Dir := Get_Library_Directory (Libraries.Work_Library);
+ if Dir = Name_Nil or else Dir = Files_Map.Get_Home_Directory then
+ Error ("cannot copy library on itself (use --remove first)");
+ raise Option_Error;
+ end if;
+
+ File := Get_Design_File_Chain (Libraries.Work_Library);
+ while File /= Null_Iir loop
+ -- Copy object files (if any).
+ declare
+ Basename : constant String :=
+ Get_Base_Name (Image (Get_Design_File_Filename (File)));
+ Src : String_Access;
+ Dst : String_Access;
+ Success : Boolean;
+ pragma Unreferenced (Success);
+ begin
+ Src := new String'(Image (Dir) & Basename & Get_Object_Suffix.all);
+ Dst := new String'(Basename & Get_Object_Suffix.all);
+ Copy_File (Src.all, Dst.all, Success, Overwrite, Full);
+ -- Be silent in case of error.
+ Free (Src);
+ Free (Dst);
+ end;
+ if Get_Design_File_Directory (File) = Name_Nil then
+ Set_Design_File_Directory (File, Dir);
+ end if;
+
+ File := Get_Chain (File);
+ end loop;
+ Libraries.Work_Directory := Name_Nil;
+ Libraries.Save_Work_Library;
+ end Perform_Action;
+
+ -- Command --disp-standard.
+ type Command_Disp_Standard is new Command_Lib with null record;
+ function Decode_Command (Cmd : Command_Disp_Standard; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Disp_Standard) return String;
+ procedure Perform_Action (Cmd : in out Command_Disp_Standard;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Disp_Standard; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "--disp-standard";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Disp_Standard) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "--disp-standard Disp std.standard in pseudo-vhdl";
+ end Get_Short_Help;
+
+ procedure Perform_Action (Cmd : in out Command_Disp_Standard;
+ Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ if Args'Length /= 0 then
+ Error ("command '--disp-standard' does not accept any argument");
+ raise Option_Error;
+ end if;
+ Flags.Bootstrap := True;
+ Libraries.Load_Std_Library;
+ Disp_Vhdl.Disp_Vhdl (Std_Package.Std_Standard_Unit);
+ end Perform_Action;
+
+ procedure Load_All_Libraries_And_Files
+ is
+ use Files_Map;
+ use Libraries;
+ use Errorout;
+
+ procedure Extract_Library_Clauses (Unit : Iir_Design_Unit)
+ is
+ Lib1 : Iir_Library_Declaration;
+ pragma Unreferenced (Lib1);
+ Ctxt_Item : Iir;
+ begin
+ -- Extract library clauses.
+ Ctxt_Item := Get_Context_Items (Unit);
+ while Ctxt_Item /= Null_Iir loop
+ if Get_Kind (Ctxt_Item) = Iir_Kind_Library_Clause then
+ Lib1 := Get_Library (Get_Identifier (Ctxt_Item),
+ Get_Location (Ctxt_Item));
+ end if;
+ Ctxt_Item := Get_Chain (Ctxt_Item);
+ end loop;
+ end Extract_Library_Clauses;
+
+ Lib : Iir_Library_Declaration;
+ Fe : Source_File_Entry;
+ File, Next_File : Iir_Design_File;
+ Unit, Next_Unit : Iir_Design_Unit;
+ Design_File : Iir_Design_File;
+
+ Old_Work : Iir_Library_Declaration;
+ begin
+ Lib := Std_Library;
+ Lib := Get_Chain (Lib);
+ Old_Work := Work_Library;
+ while Lib /= Null_Iir loop
+ -- Design units are always put in the work library.
+ Work_Library := Lib;
+
+ File := Get_Design_File_Chain (Lib);
+ while File /= Null_Iir loop
+ Next_File := Get_Chain (File);
+ Fe := Load_Source_File (Get_Design_File_Directory (File),
+ Get_Design_File_Filename (File));
+ if Fe = No_Source_File_Entry then
+ -- FIXME: should remove all the design file from the library.
+ null;
+ elsif Is_Eq (Get_File_Time_Stamp (Fe),
+ Get_File_Time_Stamp (File))
+ then
+ -- File has not been modified.
+ -- Extract libraries.
+ -- Note: we can't parse it only, since we need to keep the
+ -- date.
+ Unit := Get_First_Design_Unit (File);
+ while Unit /= Null_Iir loop
+ Load_Parse_Design_Unit (Unit, Null_Iir);
+ Extract_Library_Clauses (Unit);
+ Unit := Get_Chain (Unit);
+ end loop;
+ else
+ -- File has been modified.
+ -- Parse it.
+ Design_File := Load_File (Fe);
+
+ -- Exit now in case of parse error.
+ if Design_File = Null_Iir
+ or else Nbr_Errors > 0
+ then
+ raise Compilation_Error;
+ end if;
+
+ Unit := Get_First_Design_Unit (Design_File);
+ while Unit /= Null_Iir loop
+ Extract_Library_Clauses (Unit);
+
+ Next_Unit := Get_Chain (Unit);
+ Set_Chain (Unit, Null_Iir);
+ Add_Design_Unit_Into_Library (Unit);
+ Unit := Next_Unit;
+ end loop;
+ end if;
+ File := Next_File;
+ end loop;
+ Lib := Get_Chain (Lib);
+ end loop;
+ Work_Library := Old_Work;
+ end Load_All_Libraries_And_Files;
+
+ procedure Check_No_Elab_Flag (Lib : Iir_Library_Declaration)
+ is
+ File : Iir_Design_File;
+ Unit : Iir_Design_Unit;
+ begin
+ File := Get_Design_File_Chain (Lib);
+ while File /= Null_Iir loop
+ Unit := Get_First_Design_Unit (File);
+ while Unit /= Null_Iir loop
+ if Get_Elab_Flag (Unit) then
+ raise Internal_Error;
+ end if;
+ Unit := Get_Chain (Unit);
+ end loop;
+ File := Get_Chain (File);
+ end loop;
+ end Check_No_Elab_Flag;
+
+ function Build_Dependence (Prim : String_Access; Sec : String_Access)
+ return Iir_List
+ is
+ procedure Build_Dependence_List (File : Iir_Design_File; List : Iir_List)
+ is
+ El : Iir_Design_File;
+ Depend_List : Iir_List;
+ begin
+ if Get_Elab_Flag (File) then
+ return;
+ end if;
+
+ Set_Elab_Flag (File, True);
+ Depend_List := Get_File_Dependence_List (File);
+ if Depend_List /= Null_Iir_List then
+ for I in Natural loop
+ El := Get_Nth_Element (Depend_List, I);
+ exit when El = Null_Iir;
+ Build_Dependence_List (El, List);
+ end loop;
+ end if;
+ Append_Element (List, File);
+ end Build_Dependence_List;
+
+ use Configuration;
+ use Name_Table;
+
+ Top : Iir;
+ Primary_Id : Name_Id;
+ Secondary_Id : Name_Id;
+
+ File : Iir_Design_File;
+ Unit : Iir;
+
+ Files_List : Iir_List;
+ begin
+ Check_No_Elab_Flag (Libraries.Work_Library);
+
+ Primary_Id := Get_Identifier (Prim.all);
+ if Sec /= null then
+ Secondary_Id := Get_Identifier (Sec.all);
+ else
+ Secondary_Id := Null_Identifier;
+ end if;
+
+ if True then
+ Load_All_Libraries_And_Files;
+ else
+ -- Re-parse modified files in order configure could find all design
+ -- units.
+ declare
+ use Files_Map;
+ Fe : Source_File_Entry;
+ Next_File : Iir_Design_File;
+ Design_File : Iir_Design_File;
+ begin
+ File := Get_Design_File_Chain (Libraries.Work_Library);
+ while File /= Null_Iir loop
+ Next_File := Get_Chain (File);
+ Fe := Load_Source_File (Get_Design_File_Directory (File),
+ Get_Design_File_Filename (File));
+ if Fe = No_Source_File_Entry then
+ -- FIXME: should remove all the design file from
+ -- the library.
+ null;
+ else
+ if not Is_Eq (Get_File_Time_Stamp (Fe),
+ Get_File_Time_Stamp (File))
+ then
+ -- FILE has been modified.
+ Design_File := Libraries.Load_File (Fe);
+ if Design_File /= Null_Iir then
+ Libraries.Add_Design_File_Into_Library (Design_File);
+ end if;
+ end if;
+ end if;
+ File := Next_File;
+ end loop;
+ end;
+ end if;
+
+ Flags.Flag_Elaborate := True;
+ Flags.Flag_Elaborate_With_Outdated := True;
+ Flag_Load_All_Design_Units := True;
+ Flag_Build_File_Dependence := True;
+
+ Top := Configure (Primary_Id, Secondary_Id);
+ if Top = Null_Iir then
+ --Error ("cannot find primary unit " & Prim.all);
+ raise Option_Error;
+ end if;
+
+ -- Add unused design units.
+ declare
+ N : Natural;
+ begin
+ N := Design_Units.First;
+ while N <= Design_Units.Last loop
+ Unit := Design_Units.Table (N);
+ N := N + 1;
+ File := Get_Design_File (Unit);
+ if not Get_Elab_Flag (File) then
+ Set_Elab_Flag (File, True);
+ Unit := Get_First_Design_Unit (File);
+ while Unit /= Null_Iir loop
+ if not Get_Elab_Flag (Unit) then
+ Add_Design_Unit (Unit, Null_Iir);
+ end if;
+ Unit := Get_Chain (Unit);
+ end loop;
+ end if;
+ end loop;
+ end;
+
+ -- Clear elab flag on design files.
+ for I in reverse Design_Units.First .. Design_Units.Last loop
+ Unit := Design_Units.Table (I);
+ File := Get_Design_File (Unit);
+ Set_Elab_Flag (File, False);
+ end loop;
+
+ -- Create a list of files, from the last to the first.
+ Files_List := Create_Iir_List;
+ for I in Design_Units.First .. Design_Units.Last loop
+ Unit := Design_Units.Table (I);
+ File := Get_Design_File (Unit);
+ Build_Dependence_List (File, Files_List);
+ end loop;
+
+ return Files_List;
+ end Build_Dependence;
+
+ -- Convert NAME to lower cases, unless it is an extended identifier.
+ function Convert_Name (Name : String_Access) return String_Access
+ is
+ use Name_Table;
+
+ function Is_Bad_Unit_Name return Boolean is
+ begin
+ if Name_Length = 0 then
+ return True;
+ end if;
+ -- Don't try to handle extended identifier.
+ if Name_Buffer (1) = '\' then
+ return False;
+ end if;
+ -- Look for suspicious characters.
+ -- Do not try to be exhaustive as the correct check will be done
+ -- by convert_identifier.
+ for I in 1 .. Name_Length loop
+ case Name_Buffer (I) is
+ when '.' | '/' | '\' =>
+ return True;
+ when others =>
+ null;
+ end case;
+ end loop;
+ return False;
+ end Is_Bad_Unit_Name;
+
+ function Is_A_File_Name return Boolean is
+ begin
+ -- Check .vhd
+ if Name_Length > 4
+ and then Name_Buffer (Name_Length - 3 .. Name_Length) = ".vhd"
+ then
+ return True;
+ end if;
+ -- Check .vhdl
+ if Name_Length > 5
+ and then Name_Buffer (Name_Length - 4 .. Name_Length) = ".vhdl"
+ then
+ return True;
+ end if;
+ -- Check ../
+ if Name_Length > 3
+ and then Name_Buffer (1 .. 3) = "../"
+ then
+ return True;
+ end if;
+ -- Check ..\
+ if Name_Length > 3
+ and then Name_Buffer (1 .. 3) = "..\"
+ then
+ return True;
+ end if;
+ -- Should try to find the file ?
+ return False;
+ end Is_A_File_Name;
+ begin
+ Name_Length := Name'Length;
+ Name_Buffer (1 .. Name_Length) := Name.all;
+
+ -- Try to identifier bad names (such as file names), so that
+ -- friendly message can be displayed.
+ if Is_Bad_Unit_Name then
+ Errorout.Error_Msg_Option_NR ("bad unit name '" & Name.all & "'");
+ if Is_A_File_Name then
+ Errorout.Error_Msg_Option_NR
+ ("(a unit name is required instead of a filename)");
+ end if;
+ raise Option_Error;
+ end if;
+ Scanner.Convert_Identifier;
+ return new String'(Name_Buffer (1 .. Name_Length));
+ end Convert_Name;
+
+ procedure Extract_Elab_Unit
+ (Cmd_Name : String; Args : Argument_List; Next_Arg : out Natural)
+ is
+ begin
+ if Args'Length = 0 then
+ Error ("command '" & Cmd_Name & "' required an unit name");
+ raise Option_Error;
+ end if;
+
+ Prim_Name := Convert_Name (Args (Args'First));
+ Next_Arg := Args'First + 1;
+ Sec_Name := null;
+
+ if Args'Length >= 2 then
+ declare
+ Sec : constant String_Access := Args (Next_Arg);
+ begin
+ if Sec (Sec'First) /= '-' then
+ Sec_Name := Convert_Name (Sec);
+ Next_Arg := Args'First + 2;
+ end if;
+ end;
+ end if;
+ end Extract_Elab_Unit;
+
+ procedure Register_Commands is
+ begin
+ Register_Command (new Command_Import);
+ Register_Command (new Command_Check_Syntax);
+ Register_Command (new Command_Dir);
+ Register_Command (new Command_Find);
+ Register_Command (new Command_Clean);
+ Register_Command (new Command_Remove);
+ Register_Command (new Command_Copy);
+ Register_Command (new Command_Disp_Standard);
+ end Register_Commands;
+end Ghdllocal;
diff --git a/src/ghdldrv/ghdllocal.ads b/src/ghdldrv/ghdllocal.ads
new file mode 100644
index 000000000..2c7018adc
--- /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 000000000..45d9615f9
--- /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 000000000..c01f1d63e
--- /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 000000000..45e70e118
--- /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 ("&gt;");
+ when '<' =>
+ Put ("&lt;");
+ when '&' =>
+ Put ("&amp;");
+ when others =>
+ Put (C);
+ end case;
+ end Put_Html;
+
+ procedure Put_Html (S : String) is
+ begin
+ for I in S'Range loop
+ Put_Html (S (I));
+ end loop;
+ end Put_Html;
+
+ package Nat_IO is new Ada.Text_IO.Integer_IO (Num => Natural);
+ procedure Put_Nat (N : Natural) is
+ begin
+ Nat_IO.Put (N, Width => 0);
+ end Put_Nat;
+
+ type Filexref_Info_Type is record
+ Output : String_Acc;
+ Referenced : Boolean;
+ end record;
+ type Filexref_Info_Arr is array (Source_File_Entry range <>)
+ of Filexref_Info_Type;
+ type Filexref_Info_Arr_Acc is access Filexref_Info_Arr;
+ Filexref_Info : Filexref_Info_Arr_Acc := null;
+
+ -- If True, at least one xref is missing.
+ Missing_Xref : Boolean := False;
+
+ procedure PP_Html_File (File : Source_File_Entry)
+ is
+ use Flags;
+ use Scanner;
+ use Tokens;
+ use Files_Map;
+ use Ada.Characters.Latin_1;
+
+ Line : Natural;
+ Buf : File_Buffer_Acc;
+ Prev_Tok : Token_Type;
+
+ -- Current logical column number. Used to expand TABs.
+ Col : Natural;
+
+ -- Position just after the last token.
+ Last_Tok : Source_Ptr;
+
+ -- Position just before the current token.
+ Bef_Tok : Source_Ptr;
+
+ -- Position just after the current token.
+ Aft_Tok : Source_Ptr;
+
+ procedure Disp_Ln
+ is
+ N : Natural;
+ Str : String (1 .. 5);
+ begin
+ case Html_Format is
+ when Html_2 =>
+ Put ("<font size=-1>");
+ when Html_Css =>
+ Put ("<i>");
+ end case;
+ N := Line;
+ for I in reverse Str'Range loop
+ if N = 0 then
+ Str (I) := ' ';
+ else
+ Str (I) := Character'Val (48 + N mod 10);
+ N := N / 10;
+ end if;
+ end loop;
+ Put (Str);
+ case Html_Format is
+ when Html_2 =>
+ Put ("</font>");
+ when Html_Css =>
+ Put ("</i>");
+ end case;
+ Put (" ");
+ Col := 0;
+ end Disp_Ln;
+
+ procedure Disp_Spaces
+ is
+ C : Character;
+ P : Source_Ptr;
+ N_Col : Natural;
+ begin
+ P := Last_Tok;
+ while P < Bef_Tok loop
+ C := Buf (P);
+ if C = HT then
+ -- Expand TABS.
+ N_Col := Col + 8;
+ N_Col := N_Col - N_Col mod 8;
+ while Col < N_Col loop
+ Put (' ');
+ Col := Col + 1;
+ end loop;
+ else
+ Put (' ');
+ Col := Col + 1;
+ end if;
+ P := P + 1;
+ end loop;
+ end Disp_Spaces;
+
+ procedure Disp_Text
+ is
+ P : Source_Ptr;
+ begin
+ P := Bef_Tok;
+ while P < Aft_Tok loop
+ Put_Html (Buf (P));
+ Col := Col + 1;
+ P := P + 1;
+ end loop;
+ end Disp_Text;
+
+ procedure Disp_Reserved is
+ begin
+ Disp_Spaces;
+ case Html_Format is
+ when Html_2 =>
+ Put ("<font color=red>");
+ Disp_Text;
+ Put ("</font>");
+ when Html_Css =>
+ Put ("<em>");
+ Disp_Text;
+ Put ("</em>");
+ end case;
+ end Disp_Reserved;
+
+ procedure Disp_Href (Loc : Location_Type)
+ is
+ L_File : Source_File_Entry;
+ L_Pos : Source_Ptr;
+ begin
+ Location_To_File_Pos (Loc, L_File, L_Pos);
+ Put (" href=""");
+ if L_File /= File then
+ -- External reference.
+ if Filexref_Info (L_File).Output /= null then
+ Put (Filexref_Info (L_File).Output.all);
+ Put ("#");
+ Put_Nat (Natural (L_Pos));
+ else
+ -- Reference to an unused file.
+ Put ("index.html#f");
+ Put_Nat (Natural (L_File));
+ Filexref_Info (L_File).Referenced := True;
+ end if;
+ else
+ -- Local reference.
+ Put ("#");
+ Put_Nat (Natural (L_Pos));
+ end if;
+ Put ("""");
+ end Disp_Href;
+
+ procedure Disp_Anchor (Loc : Location_Type)
+ is
+ L_File : Source_File_Entry;
+ L_Pos : Source_Ptr;
+ begin
+ Put (" name=""");
+ Location_To_File_Pos (Loc, L_File, L_Pos);
+ Put_Nat (Natural (L_Pos));
+ Put ("""");
+ end Disp_Anchor;
+
+ procedure Disp_Identifier
+ is
+ use Xrefs;
+ Ref : Xref;
+ Decl : Iir;
+ Bod : Iir;
+ Loc : Location_Type;
+ begin
+ Disp_Spaces;
+ if Flags.Flag_Xref then
+ Loc := File_Pos_To_Location (File, Bef_Tok);
+ Ref := Find (Loc);
+ if Ref = Bad_Xref then
+ Disp_Text;
+ Warning_Msg_Sem ("cannot find xref", Loc);
+ Missing_Xref := True;
+ return;
+ end if;
+ else
+ Disp_Text;
+ return;
+ end if;
+ case Get_Xref_Kind (Ref) is
+ when Xref_Decl =>
+ Put ("<a");
+ Disp_Anchor (Loc);
+ Decl := Get_Xref_Node (Ref);
+ case Get_Kind (Decl) is
+ when Iir_Kind_Function_Declaration
+ | Iir_Kind_Procedure_Declaration =>
+ Bod := Get_Subprogram_Body (Decl);
+ when Iir_Kind_Package_Declaration =>
+ Bod := Get_Package_Body (Decl);
+ when Iir_Kind_Type_Declaration =>
+ Decl := Get_Type (Decl);
+ case Get_Kind (Decl) is
+ when Iir_Kind_Protected_Type_Declaration =>
+ Bod := Get_Protected_Type_Body (Decl);
+ when Iir_Kind_Incomplete_Type_Definition =>
+ Bod := Get_Type_Declarator (Decl);
+ when others =>
+ Bod := Null_Iir;
+ end case;
+ when others =>
+ Bod := Null_Iir;
+ end case;
+ if Bod /= Null_Iir then
+ Disp_Href (Get_Location (Bod));
+ end if;
+ Put (">");
+ Disp_Text;
+ Put ("</a>");
+ when Xref_Ref
+ | Xref_End =>
+ Decl := Get_Xref_Node (Ref);
+ Loc := Get_Location (Decl);
+ if Loc /= Location_Nil then
+ Put ("<a");
+ Disp_Href (Loc);
+ Put (">");
+ Disp_Text;
+ Put ("</a>");
+ else
+ -- This may happen for overload list, in use clauses.
+ Disp_Text;
+ end if;
+ when Xref_Body =>
+ Put ("<a");
+ Disp_Anchor (Loc);
+ Disp_Href (Get_Location (Get_Xref_Node (Ref)));
+ Put (">");
+ Disp_Text;
+ Put ("</a>");
+ end case;
+ end Disp_Identifier;
+
+ procedure Disp_Attribute
+ is
+ use Xrefs;
+ Ref : Xref;
+ Decl : Iir;
+ Loc : Location_Type;
+ begin
+ Disp_Spaces;
+ if Flags.Flag_Xref then
+ Loc := File_Pos_To_Location (File, Bef_Tok);
+ Ref := Find (Loc);
+ else
+ Ref := Bad_Xref;
+ end if;
+ if Ref = Bad_Xref then
+ case Html_Format is
+ when Html_2 =>
+ Put ("<font color=orange>");
+ Disp_Text;
+ Put ("</font>");
+ when Html_Css =>
+ Put ("<var>");
+ Disp_Text;
+ Put ("</var>");
+ end case;
+ else
+ Decl := Get_Xref_Node (Ref);
+ Loc := Get_Location (Decl);
+ Put ("<a");
+ Disp_Href (Loc);
+ Put (">");
+ Disp_Text;
+ Put ("</a>");
+ end if;
+ end Disp_Attribute;
+ begin
+ Scanner.Flag_Comment := True;
+ Scanner.Flag_Newline := True;
+
+ Set_File (File);
+ Buf := Get_File_Source (File);
+
+ Put_Line ("<pre>");
+ Line := 1;
+ Disp_Ln;
+ Last_Tok := Source_Ptr_Org;
+ Prev_Tok := Tok_Invalid;
+ loop
+ Scan;
+ Bef_Tok := Get_Token_Position;
+ Aft_Tok := Get_Position;
+ case Current_Token is
+ when Tok_Eof =>
+ exit;
+ when Tok_Newline =>
+ New_Line;
+ Line := Line + 1;
+ Disp_Ln;
+ when Tok_Comment =>
+ Disp_Spaces;
+ case Html_Format is
+ when Html_2 =>
+ Put ("<font color=green>");
+ Disp_Text;
+ Put ("</font>");
+ when Html_Css =>
+ Put ("<tt>");
+ Disp_Text;
+ Put ("</tt>");
+ end case;
+ when Tok_Access .. Tok_Elsif
+ | Tok_Entity .. Tok_With
+ | Tok_Mod .. Tok_Rem
+ | Tok_And .. Tok_Not =>
+ Disp_Reserved;
+ when Tok_End =>
+ Disp_Reserved;
+ when Tok_Semi_Colon =>
+ Disp_Spaces;
+ Disp_Text;
+ when Tok_Xnor .. Tok_Ror =>
+ Disp_Reserved;
+ when Tok_Protected =>
+ Disp_Reserved;
+ when Tok_Across .. Tok_Tolerance =>
+ Disp_Reserved;
+ when Tok_Psl_Default
+ | Tok_Psl_Clock
+ | Tok_Psl_Property
+ | Tok_Psl_Sequence
+ | Tok_Psl_Endpoint
+ | Tok_Psl_Assert
+ | Tok_Psl_Cover
+ | Tok_Psl_Boolean
+ | Tok_Psl_Const
+ | Tok_Inf
+ | Tok_Within
+ | Tok_Abort
+ | Tok_Before
+ | Tok_Always
+ | Tok_Never
+ | Tok_Eventually
+ | Tok_Next_A
+ | Tok_Next_E
+ | Tok_Next_Event
+ | Tok_Next_Event_A
+ | Tok_Next_Event_E =>
+ Disp_Spaces;
+ Disp_Text;
+ when Tok_String
+ | Tok_Bit_String
+ | Tok_Character =>
+ Disp_Spaces;
+ case Html_Format is
+ when Html_2 =>
+ Put ("<font color=blue>");
+ Disp_Text;
+ Put ("</font>");
+ when Html_Css =>
+ Put ("<kbd>");
+ Disp_Text;
+ Put ("</kbd>");
+ end case;
+ when Tok_Identifier =>
+ if Prev_Tok = Tok_Tick then
+ Disp_Attribute;
+ else
+ Disp_Identifier;
+ end if;
+ when Tok_Left_Paren .. Tok_Colon
+ | Tok_Comma .. Tok_Dot
+ | Tok_Equal_Equal
+ | Tok_Integer
+ | Tok_Real
+ | Tok_Equal .. Tok_Slash
+ | Tok_Invalid =>
+ Disp_Spaces;
+ Disp_Text;
+ end case;
+ Last_Tok := Aft_Tok;
+ Prev_Tok := Current_Token;
+ end loop;
+ Close_File;
+ New_Line;
+ Put_Line ("</pre>");
+ Put_Line ("<hr/>");
+ end PP_Html_File;
+
+ procedure Put_Html_Header
+ is
+ begin
+ Put ("<html>");
+ Put_Line (" <head>");
+ case Html_Format is
+ when Html_2 =>
+ null;
+ when Html_Css =>
+ Put_Line (" <link rel=stylesheet type=""text/css""");
+ Put_Line (" href=""ghdl.css"" title=""default""/>");
+ end case;
+ --Put_Line ("<?xml version=""1.0"" encoding=""utf-8"" ?>");
+ --Put_Line("<!DOCTYPE html PUBLIC ""-//W3C//DTD XHTML 1.0 Strict//EN""");
+ --Put_Line ("""http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"">");
+ --Put_Line ("<html xmlns=""http://www.w3.org/1999/xhtml"""
+ -- & " xml:lang=""en"">");
+ --Put_Line ("<head>");
+ end Put_Html_Header;
+
+ procedure Put_Css is
+ begin
+ Put_Line ("/* EM is used for reserved words */");
+ Put_Line ("EM { color : red; font-style: normal }");
+ New_Line;
+ Put_Line ("/* TT is used for comments */");
+ Put_Line ("TT { color : green; font-style: normal }");
+ New_Line;
+ Put_Line ("/* KBD is used for literals and strings */");
+ Put_Line ("KBD { color : blue; font-style: normal }");
+ New_Line;
+ Put_Line ("/* I is used for line numbers */");
+ Put_Line ("I { color : gray; font-size: 50% }");
+ New_Line;
+ Put_Line ("/* VAR is used for attributes name */");
+ Put_Line ("VAR { color : orange; font-style: normal }");
+ New_Line;
+ Put_Line ("/* A is used for identifiers. */");
+ Put_Line ("A { color: blue; font-style: normal;");
+ Put_Line (" text-decoration: none }");
+ end Put_Css;
+
+ procedure Put_Html_Foot
+ is
+ begin
+ Put_Line ("<p>");
+ Put ("<small>This page was generated using ");
+ Put ("<a href=""http://ghdl.free.fr"">");
+ Put (Version.Ghdl_Release);
+ Put ("</a>, a program written by");
+ Put (" Tristan Gingold");
+ New_Line;
+ Put_Line ("</p>");
+ Put_Line ("</body>");
+ Put_Line ("</html>");
+ end Put_Html_Foot;
+
+ function Create_Output_Filename (Name : String; Num : Natural)
+ return String_Acc
+ is
+ -- Position of the extension. 0 if none.
+ Ext_Pos : Natural;
+
+ Num_Str : String := Natural'Image (Num);
+ begin
+ -- Search for the extension.
+ Ext_Pos := 0;
+ for I in reverse Name'Range loop
+ exit when Name (I) = Directory_Separator;
+ if Name (I) = '.' then
+ Ext_Pos := I - 1;
+ exit;
+ end if;
+ end loop;
+ if Ext_Pos = 0 then
+ Ext_Pos := Name'Last;
+ end if;
+ Num_Str (1) := '.';
+ return new String'(Name (Name'First .. Ext_Pos) & Num_Str & ".html");
+ end Create_Output_Filename;
+
+ -- Command --chop.
+ type Command_Chop is new Command_Lib with null record;
+ function Decode_Command (Cmd : Command_Chop; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Chop) return String;
+ procedure Perform_Action (Cmd : in out Command_Chop;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Chop; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "--chop";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Chop) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "--chop [OPTS] FILEs Chop FILEs";
+ end Get_Short_Help;
+
+ procedure Perform_Action (Cmd : in out Command_Chop; Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ use Ada.Characters.Latin_1;
+
+ function Build_File_Name_Length (Lib : Iir) return Natural
+ is
+ Id : constant Name_Id := Get_Identifier (Lib);
+ Len : Natural;
+ Id1 : Name_Id;
+ begin
+ Len := Get_Name_Length (Id);
+ case Get_Kind (Lib) is
+ when Iir_Kind_Configuration_Declaration
+ | Iir_Kind_Entity_Declaration
+ | Iir_Kind_Package_Declaration
+ | Iir_Kind_Package_Instantiation_Declaration =>
+ null;
+ when Iir_Kind_Package_Body =>
+ Len := Len + 1 + 4; -- add -body
+ when Iir_Kind_Architecture_Body =>
+ Id1 := Get_Entity_Identifier_Of_Architecture (Lib);
+ Len := Len + 1 + Get_Name_Length (Id1);
+ when others =>
+ Error_Kind ("build_file_name", Lib);
+ end case;
+ Len := Len + 1 + 4; -- add .vhdl
+ return Len;
+ end Build_File_Name_Length;
+
+ procedure Build_File_Name (Lib : Iir; Res : out String)
+ is
+ Id : constant Name_Id := Get_Identifier (Lib);
+ P : Natural;
+
+ procedure Append (Str : String) is
+ begin
+ Res (P + 1 .. P + Str'Length) := Str;
+ P := P + Str'Length;
+ end Append;
+ begin
+ P := Res'First - 1;
+ case Get_Kind (Lib) is
+ when Iir_Kind_Configuration_Declaration
+ | Iir_Kind_Entity_Declaration
+ | Iir_Kind_Package_Declaration
+ | Iir_Kind_Package_Instantiation_Declaration =>
+ Image (Id);
+ Append (Name_Buffer (1 .. Name_Length));
+ when Iir_Kind_Package_Body =>
+ Image (Id);
+ Append (Name_Buffer (1 .. Name_Length));
+ Append ("-body");
+ when Iir_Kind_Architecture_Body =>
+ Image (Get_Entity_Identifier_Of_Architecture (Lib));
+ Append (Name_Buffer (1 .. Name_Length));
+ Append ("-");
+ Image (Id);
+ Append (Name_Buffer (1 .. Name_Length));
+ when others =>
+ raise Internal_Error;
+ end case;
+ Append (".vhdl");
+ end Build_File_Name;
+
+ -- Scan source file BUF+START until end of line.
+ -- Return line kind to KIND and position of next line to NEXT.
+ type Line_Type is (Line_Blank, Line_Comment, Line_Text);
+ procedure Find_Eol (Buf : File_Buffer_Acc;
+ Start : Source_Ptr;
+ Next : out Source_Ptr;
+ Kind : out Line_Type)
+ is
+ P : Source_Ptr;
+ begin
+ P := Start;
+
+ Kind := Line_Blank;
+
+ -- Skip blanks.
+ while Buf (P) = ' ' or Buf (P) = HT loop
+ P := P + 1;
+ end loop;
+
+ -- Skip comment if any.
+ if Buf (P) = '-' and Buf (P + 1) = '-' then
+ Kind := Line_Comment;
+ P := P + 2;
+ elsif Buf (P) /= CR and Buf (P) /= LF and Buf (P) /= EOT then
+ Kind := Line_Text;
+ end if;
+
+ -- Skip until end of line.
+ while Buf (P) /= CR and Buf (P) /= LF and Buf (P) /= EOT loop
+ P := P + 1;
+ end loop;
+
+ if Buf (P) = CR then
+ P := P + 1;
+ if Buf (P) = LF then
+ P := P + 1;
+ end if;
+ elsif Buf (P) = LF then
+ P := P + 1;
+ if Buf (P) = CR then
+ P := P + 1;
+ end if;
+ end if;
+
+ Next := P;
+ end Find_Eol;
+
+ Id : Name_Id;
+ Design_File : Iir_Design_File;
+ Unit : Iir;
+ Lib : Iir;
+ Len : Natural;
+ begin
+ Flags.Bootstrap := True;
+ -- Load word library.
+ Libraries.Load_Std_Library;
+ Libraries.Load_Work_Library;
+
+ -- First loop: parse source file, check destination file does not
+ -- exist.
+ for I in Args'Range loop
+ Id := Get_Identifier (Args (I).all);
+ Design_File := Libraries.Load_File (Id);
+ if Design_File = Null_Iir then
+ raise Compile_Error;
+ end if;
+ Unit := Get_First_Design_Unit (Design_File);
+ while Unit /= Null_Iir loop
+ Lib := Get_Library_Unit (Unit);
+ Len := Build_File_Name_Length (Lib);
+ declare
+ Filename : String (1 .. Len + 1);
+ begin
+ Build_File_Name (Lib, Filename);
+ Filename (Len + 1) := Ghdllocal.Nul;
+ if Is_Regular_File (Filename) then
+ Error ("file '" & Filename (1 .. Len) & "' already exists");
+ raise Compile_Error;
+ end if;
+ Put (Filename (1 .. Len));
+ Put (" (for ");
+ Disp_Library_Unit (Lib);
+ Put (")");
+ New_Line;
+ end;
+ Unit := Get_Chain (Unit);
+ end loop;
+ end loop;
+
+ -- Second loop: do the real work.
+ for I in Args'Range loop
+ Id := Get_Identifier (Args (I).all);
+ Design_File := Libraries.Load_File (Id);
+ Unit := Get_First_Design_Unit (Design_File);
+ declare
+ use Files_Map;
+
+ File_Entry : Source_File_Entry;
+ Buffer : File_Buffer_Acc;
+
+ Start : Source_Ptr;
+ Lend : Source_Ptr;
+ First : Source_Ptr;
+ Next : Source_Ptr;
+ Kind : Line_Type;
+ begin
+ -- A design_file must have at least one design unit.
+ if Unit = Null_Iir then
+ raise Compile_Error;
+ end if;
+
+ Location_To_File_Pos
+ (Get_Location (Unit), File_Entry, Start);
+ Buffer := Get_File_Source (File_Entry);
+
+ First := Source_Ptr_Org;
+ if Get_Chain (Unit) /= Null_Iir then
+ -- If there is only one unit, then the whole file is written.
+ -- First last blank line.
+ Next := Source_Ptr_Org;
+ loop
+ Start := Next;
+ Find_Eol (Buffer, Start, Next, Kind);
+ exit when Kind = Line_Text;
+ if Kind = Line_Blank then
+ First := Next;
+ end if;
+ end loop;
+
+ -- FIXME: write header.
+ end if;
+
+ while Unit /= Null_Iir loop
+ Lib := Get_Library_Unit (Unit);
+
+ Location_To_File_Pos
+ (Get_End_Location (Unit), File_Entry, Lend);
+ if Lend < First then
+ raise Internal_Error;
+ end if;
+
+ Location_To_File_Pos
+ (Get_End_Location (Unit), File_Entry, Lend);
+ -- Find the ';'.
+ while Buffer (Lend) /= ';' loop
+ Lend := Lend + 1;
+ end loop;
+ Lend := Lend + 1;
+ -- Find end of line.
+ Find_Eol (Buffer, Lend, Next, Kind);
+ if Kind = Line_Text then
+ -- There is another unit on the same line.
+ Next := Lend;
+ -- Skip blanks.
+ while Buffer (Next) = ' ' or Buffer (Next) = HT loop
+ Next := Next + 1;
+ end loop;
+ else
+ -- Find first blank line.
+ loop
+ Start := Next;
+ Find_Eol (Buffer, Start, Next, Kind);
+ exit when Kind /= Line_Comment;
+ end loop;
+ if Kind = Line_Text then
+ -- There is not blank lines.
+ -- All the comments are supposed to belong to the next
+ -- unit.
+ Find_Eol (Buffer, Lend, Next, Kind);
+ Lend := Next;
+ else
+ Lend := Start;
+ end if;
+ end if;
+
+ if Get_Chain (Unit) = Null_Iir then
+ -- Last unit.
+ -- Put the end of the file in it.
+ Lend := Get_File_Length (File_Entry);
+ end if;
+
+ -- FIXME: file with only one unit.
+ -- FIXME: set extension.
+ Len := Build_File_Name_Length (Lib);
+ declare
+ Filename : String (1 .. Len + 1);
+ Fd : File_Descriptor;
+
+ Wlen : Integer;
+ begin
+ Build_File_Name (Lib, Filename);
+ Filename (Len + 1) := Character'Val (0);
+ Fd := Create_File (Filename, Binary);
+ if Fd = Invalid_FD then
+ Error
+ ("cannot create file '" & Filename (1 .. Len) & "'");
+ raise Compile_Error;
+ end if;
+ Wlen := Integer (Lend - First);
+ if Write (Fd, Buffer (First)'Address, Wlen) /= Wlen then
+ Error ("cannot write to '" & Filename (1 .. Len) & "'");
+ raise Compile_Error;
+ end if;
+ Close (Fd);
+ end;
+ First := Next;
+
+ Unit := Get_Chain (Unit);
+ end loop;
+ end;
+ end loop;
+ end Perform_Action;
+
+ -- Command --lines.
+ type Command_Lines is new Command_Lib with null record;
+ function Decode_Command (Cmd : Command_Lines; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Lines) return String;
+ procedure Perform_Action (Cmd : in out Command_Lines;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Lines; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "--lines";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Lines) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "--lines FILEs Precede line with its number";
+ end Get_Short_Help;
+
+ procedure Perform_Action (Cmd : in out Command_Lines; Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ use Scanner;
+ use Tokens;
+ use Files_Map;
+ use Ada.Characters.Latin_1;
+
+ Id : Name_Id;
+ Fe : Source_File_Entry;
+ Local_Id : Name_Id;
+ Line : Natural;
+ File : Source_File_Entry;
+ Buf : File_Buffer_Acc;
+ Ptr : Source_Ptr;
+ Eptr : Source_Ptr;
+ C : Character;
+ N : Natural;
+ Log : Natural;
+ Str : String (1 .. 10);
+ begin
+ Local_Id := Get_Identifier ("");
+ for I in Args'Range loop
+ -- Load the file.
+ Id := Get_Identifier (Args (I).all);
+ Fe := Files_Map.Load_Source_File (Local_Id, Id);
+ if Fe = No_Source_File_Entry then
+ Error ("cannot open file " & Args (I).all);
+ raise Compile_Error;
+ end if;
+ Set_File (Fe);
+
+ -- Scan the content, to compute the number of lines.
+ loop
+ Scan;
+ exit when Current_Token = Tok_Eof;
+ end loop;
+ File := Get_Current_Source_File;
+ Line := Get_Current_Line;
+ Close_File;
+
+ -- Compute log10 of line.
+ N := Line;
+ Log := 0;
+ loop
+ N := N / 10;
+ Log := Log + 1;
+ exit when N = 0;
+ end loop;
+
+ -- Disp file name.
+ Put (Args (I).all);
+ Put (':');
+ New_Line;
+
+ Buf := Get_File_Source (File);
+ for J in 1 .. Line loop
+ Ptr := Line_To_Position (File, J);
+ exit when Ptr = Source_Ptr_Bad;
+ exit when Buf (Ptr) = Files_Map.EOT;
+
+ -- Disp line number.
+ N := J;
+ for K in reverse 1 .. Log loop
+ if N = 0 then
+ Str (K) := ' ';
+ else
+ Str (K) := Character'Val (48 + N mod 10);
+ N := N / 10;
+ end if;
+ end loop;
+ Put (Str (1 .. Log));
+ Put (": ");
+
+ -- Search for end of line (or end of file).
+ Eptr := Ptr;
+ loop
+ C := Buf (Eptr);
+ exit when C = Files_Map.EOT or C = LF or C = CR;
+ Eptr := Eptr + 1;
+ end loop;
+
+ -- Disp line.
+ if Eptr > Ptr then
+ -- Avoid constraint error on conversion of nul array.
+ Put (String (Buf (Ptr .. Eptr - 1)));
+ end if;
+ New_Line;
+ end loop;
+ end loop;
+ end Perform_Action;
+
+ -- Command Reprint.
+ type Command_Reprint is new Command_Lib with null record;
+ function Decode_Command (Cmd : Command_Reprint; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Reprint) return String;
+ procedure Perform_Action (Cmd : in out Command_Reprint;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Reprint; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "--reprint";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Reprint) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "--reprint [OPTS] FILEs Redisplay FILEs";
+ end Get_Short_Help;
+
+ procedure Perform_Action (Cmd : in out Command_Reprint;
+ Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ Design_File : Iir_Design_File;
+ Unit : Iir;
+
+ Id : Name_Id;
+ Next_Unit : Iir;
+ begin
+ Setup_Libraries (True);
+ Parse.Flag_Parse_Parenthesis := True;
+
+ -- Parse all files.
+ for I in Args'Range loop
+ Id := Name_Table.Get_Identifier (Args (I).all);
+ Design_File := Libraries.Load_File (Id);
+ if Design_File = Null_Iir then
+ raise Errorout.Compilation_Error;
+ end if;
+
+ Unit := Get_First_Design_Unit (Design_File);
+ while Unit /= Null_Iir loop
+ -- Analyze the design unit.
+ Back_End.Finish_Compilation (Unit, True);
+
+ Next_Unit := Get_Chain (Unit);
+ if Errorout.Nbr_Errors = 0 then
+ Disp_Vhdl.Disp_Vhdl (Unit);
+ Set_Chain (Unit, Null_Iir);
+ Libraries.Add_Design_Unit_Into_Library (Unit);
+ end if;
+
+ Unit := Next_Unit;
+ end loop;
+
+ if Errorout.Nbr_Errors > 0 then
+ raise Errorout.Compilation_Error;
+ end if;
+ end loop;
+ end Perform_Action;
+
+ -- Command compare tokens.
+ type Command_Compare_Tokens is new Command_Lib with null record;
+ function Decode_Command (Cmd : Command_Compare_Tokens; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Compare_Tokens) return String;
+ procedure Perform_Action (Cmd : in out Command_Compare_Tokens;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Compare_Tokens; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "--compare-tokens";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Compare_Tokens) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "--compare-tokens [OPTS] REF FILEs Compare FILEs with REF";
+ end Get_Short_Help;
+
+ procedure Perform_Action (Cmd : in out Command_Compare_Tokens;
+ Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ use Tokens;
+ use Scanner;
+
+ package Ref_Tokens is new GNAT.Table
+ (Table_Component_Type => Token_Type,
+ Table_Index_Type => Integer,
+ Table_Low_Bound => 0,
+ Table_Initial => 1024,
+ Table_Increment => 100);
+
+ Id : Name_Id;
+ Fe : Source_File_Entry;
+ Local_Id : Name_Id;
+ Tok_Idx : Natural;
+ begin
+ if Args'Length < 1 then
+ Error ("missing ref file");
+ raise Compile_Error;
+ end if;
+
+ Local_Id := Get_Identifier ("");
+
+ for I in Args'Range loop
+ -- Load the file.
+ Id := Get_Identifier (Args (I).all);
+ Fe := Files_Map.Load_Source_File (Local_Id, Id);
+ if Fe = No_Source_File_Entry then
+ Error ("cannot open file " & Args (I).all);
+ raise Compile_Error;
+ end if;
+ Set_File (Fe);
+
+ if I = Args'First then
+ -- Scan ref file
+ loop
+ Scan;
+ Ref_Tokens.Append (Current_Token);
+ exit when Current_Token = Tok_Eof;
+ end loop;
+ else
+ -- Scane file
+ Tok_Idx := Ref_Tokens.First;
+ loop
+ Scan;
+ if Ref_Tokens.Table (Tok_Idx) /= Current_Token then
+ Error_Msg_Parse ("token mismatch");
+ exit;
+ end if;
+ case Current_Token is
+ when Tok_Eof =>
+ exit;
+ when others =>
+ null;
+ end case;
+ Tok_Idx := Tok_Idx + 1;
+ end loop;
+ end if;
+ Close_File;
+ end loop;
+
+ Ref_Tokens.Free;
+
+ if Nbr_Errors /= 0 then
+ raise Compilation_Error;
+ end if;
+ end Perform_Action;
+
+ -- Command html.
+ type Command_Html is abstract new Command_Lib with null record;
+
+ procedure Decode_Option (Cmd : in out Command_Html;
+ Option : String;
+ Arg : String;
+ Res : out Option_Res);
+
+ procedure Disp_Long_Help (Cmd : Command_Html);
+
+ procedure Decode_Option (Cmd : in out Command_Html;
+ Option : String;
+ Arg : String;
+ Res : out Option_Res)
+ is
+ begin
+ if Option = "--format=css" then
+ Html_Format := Html_Css;
+ Res := Option_Ok;
+ elsif Option = "--format=html2" then
+ Html_Format := Html_2;
+ Res := Option_Ok;
+ else
+ Decode_Option (Command_Lib (Cmd), Option, Arg, Res);
+ end if;
+ end Decode_Option;
+
+ procedure Disp_Long_Help (Cmd : Command_Html) is
+ begin
+ Disp_Long_Help (Command_Lib (Cmd));
+ Put_Line ("--format=html2 Use FONT attributes");
+ Put_Line ("--format=css Use ghdl.css file");
+ end Disp_Long_Help;
+
+ -- Command --pp-html.
+ type Command_PP_Html is new Command_Html with null record;
+ function Decode_Command (Cmd : Command_PP_Html; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_PP_Html) return String;
+ procedure Perform_Action (Cmd : in out Command_PP_Html;
+ Files : Argument_List);
+
+ function Decode_Command (Cmd : Command_PP_Html; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "--pp-html";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_PP_Html) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "--pp-html FILEs Pretty-print FILEs in HTML";
+ end Get_Short_Help;
+
+ procedure Perform_Action (Cmd : in out Command_PP_Html;
+ Files : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ use Scanner;
+ use Tokens;
+ use Files_Map;
+ use Ada.Characters.Latin_1;
+
+ Id : Name_Id;
+ Fe : Source_File_Entry;
+ Local_Id : Name_Id;
+ begin
+ Local_Id := Get_Identifier ("");
+ Put_Html_Header;
+ Put_Line (" <title>");
+ for I in Files'Range loop
+ Put (" ");
+ Put_Line (Files (I).all);
+ end loop;
+ Put_Line (" </title>");
+ Put_Line ("</head>");
+ New_Line;
+ Put_Line ("<body>");
+
+ for I in Files'Range loop
+ Id := Get_Identifier (Files (I).all);
+ Fe := Files_Map.Load_Source_File (Local_Id, Id);
+ if Fe = No_Source_File_Entry then
+ Error ("cannot open file " & Files (I).all);
+ raise Compile_Error;
+ end if;
+ Put (" <h1>");
+ Put (Files (I).all);
+ Put ("</h1>");
+ New_Line;
+
+ PP_Html_File (Fe);
+ end loop;
+ Put_Html_Foot;
+ end Perform_Action;
+
+ -- Command --xref-html.
+ type Command_Xref_Html is new Command_Html with record
+ Output_Dir : String_Access := null;
+ Check_Missing : Boolean := False;
+ end record;
+
+ function Decode_Command (Cmd : Command_Xref_Html; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Xref_Html) return String;
+ procedure Decode_Option (Cmd : in out Command_Xref_Html;
+ Option : String;
+ Arg : String;
+ Res : out Option_Res);
+ procedure Disp_Long_Help (Cmd : Command_Xref_Html);
+
+ procedure Perform_Action (Cmd : in out Command_Xref_Html;
+ Files_Name : Argument_List);
+
+ function Decode_Command (Cmd : Command_Xref_Html; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "--xref-html";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Xref_Html) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "--xref-html FILEs Display FILEs in HTML with xrefs";
+ end Get_Short_Help;
+
+ procedure Decode_Option (Cmd : in out Command_Xref_Html;
+ Option : String;
+ Arg : String;
+ Res : out Option_Res)
+ is
+ begin
+ if Option = "-o" then
+ if Arg = "" then
+ Res := Option_Arg_Req;
+ else
+ Cmd.Output_Dir := new String'(Arg);
+ Res := Option_Arg;
+ end if;
+ elsif Option = "--check-missing" then
+ Cmd.Check_Missing := True;
+ Res := Option_Ok;
+ else
+ Decode_Option (Command_Html (Cmd), Option, Arg, Res);
+ end if;
+ end Decode_Option;
+
+ procedure Disp_Long_Help (Cmd : Command_Xref_Html) is
+ begin
+ Disp_Long_Help (Command_Html (Cmd));
+ Put_Line ("-o DIR Put generated files into DIR (def: html/)");
+ Put_Line ("--check-missing Fail if a reference is missing");
+ New_Line;
+ Put_Line ("When format is css, the CSS file 'ghdl.css' "
+ & "is never overwritten.");
+ end Disp_Long_Help;
+
+ procedure Analyze_Design_File_Units (File : Iir_Design_File)
+ is
+ Unit : Iir_Design_Unit;
+ begin
+ Unit := Get_First_Design_Unit (File);
+ while Unit /= Null_Iir loop
+ case Get_Date_State (Unit) is
+ when Date_Extern
+ | Date_Disk =>
+ raise Internal_Error;
+ when Date_Parse =>
+ Libraries.Load_Design_Unit (Unit, Null_Iir);
+ when Date_Analyze =>
+ null;
+ end case;
+ Unit := Get_Chain (Unit);
+ end loop;
+ end Analyze_Design_File_Units;
+
+ procedure Perform_Action
+ (Cmd : in out Command_Xref_Html; Files_Name : Argument_List)
+ is
+ use GNAT.Directory_Operations;
+
+ Id : Name_Id;
+ File : Source_File_Entry;
+
+ type File_Data is record
+ Fe : Source_File_Entry;
+ Design_File : Iir;
+ Output : String_Acc;
+ end record;
+ type File_Data_Array is array (Files_Name'Range) of File_Data;
+
+ Files : File_Data_Array;
+ Output : File_Type;
+ begin
+ Xrefs.Init;
+ Flags.Flag_Xref := True;
+
+ -- Load work library.
+ Setup_Libraries (True);
+
+ if Cmd.Output_Dir = null then
+ Cmd.Output_Dir := new String'("html");
+ elsif Cmd.Output_Dir.all = "-" then
+ Cmd.Output_Dir := null;
+ end if;
+
+ -- Try to create the directory.
+ if Cmd.Output_Dir /= null
+ and then not Is_Directory (Cmd.Output_Dir.all)
+ then
+ declare
+ begin
+ Make_Dir (Cmd.Output_Dir.all);
+ exception
+ when Directory_Error =>
+ Error ("cannot create directory " & Cmd.Output_Dir.all);
+ return;
+ end;
+ end if;
+
+ -- Parse all files.
+ for I in Files'Range loop
+ Id := Get_Identifier (Files_Name (I).all);
+ File := Files_Map.Load_Source_File (Libraries.Local_Directory, Id);
+ if File = No_Source_File_Entry then
+ Error ("cannot open " & Image (Id));
+ return;
+ end if;
+ Files (I).Fe := File;
+ Files (I).Design_File := Libraries.Load_File (File);
+ if Files (I).Design_File = Null_Iir then
+ return;
+ end if;
+ Files (I).Output := Create_Output_Filename
+ (Base_Name (Files_Name (I).all), I);
+ if Is_Regular_File (Files (I).Output.all) then
+ -- Prevent overwrite.
+ null;
+ end if;
+ -- Put units in library.
+ Libraries.Add_Design_File_Into_Library (Files (I).Design_File);
+ end loop;
+
+ -- Analyze all files.
+ for I in Files'Range loop
+ Analyze_Design_File_Units (Files (I).Design_File);
+ end loop;
+
+ Xrefs.Sort_By_Location;
+
+ if False then
+ for I in 1 .. Xrefs.Get_Last_Xref loop
+ declare
+ use Xrefs;
+
+ procedure Put_Loc (L : Location_Type)
+ is
+ use Files_Map;
+
+ L_File : Source_File_Entry;
+ L_Pos : Source_Ptr;
+ begin
+ Files_Map.Location_To_File_Pos (L, L_File, L_Pos);
+ Put_Nat (Natural (L_File));
+ --Image (Get_File_Name (L_File));
+ --Put (Name_Buffer (1 .. Name_Length));
+ Put (":");
+ Put_Nat (Natural (L_Pos));
+ end Put_Loc;
+ begin
+ Put_Loc (Get_Xref_Location (I));
+ case Get_Xref_Kind (I) is
+ when Xref_Decl =>
+ Put (" decl ");
+ Put (Image (Get_Identifier (Get_Xref_Node (I))));
+ when Xref_Ref =>
+ Put (" use ");
+ Put_Loc (Get_Location (Get_Xref_Node (I)));
+ when Xref_End =>
+ Put (" end ");
+ when Xref_Body =>
+ Put (" body ");
+ end case;
+ New_Line;
+ end;
+ end loop;
+ end if;
+
+ -- Create filexref_info.
+ Filexref_Info := new Filexref_Info_Arr
+ (No_Source_File_Entry .. Files_Map.Get_Last_Source_File_Entry);
+ Filexref_Info.all := (others => (Output => null,
+ Referenced => False));
+ for I in Files'Range loop
+ Filexref_Info (Files (I).Fe).Output := Files (I).Output;
+ end loop;
+
+ for I in Files'Range loop
+ if Cmd.Output_Dir /= null then
+ Create (Output, Out_File,
+ Cmd.Output_Dir.all & Directory_Separator
+ & Files (I).Output.all);
+
+ Set_Output (Output);
+ end if;
+
+ Put_Html_Header;
+ Put_Line (" <title>");
+ Put_Html (Files_Name (I).all);
+ Put ("</title>");
+ Put_Line ("</head>");
+ New_Line;
+ Put_Line ("<body>");
+
+ Put ("<h1>");
+ Put_Html (Files_Name (I).all);
+ Put ("</h1>");
+ New_Line;
+
+ PP_Html_File (Files (I).Fe);
+ Put_Html_Foot;
+
+ if Cmd.Output_Dir /= null then
+ Close (Output);
+ end if;
+ end loop;
+
+ -- Create indexes.
+ if Cmd.Output_Dir /= null then
+ Create (Output, Out_File,
+ Cmd.Output_Dir.all & Directory_Separator & "index.html");
+ Set_Output (Output);
+
+ Put_Html_Header;
+ Put_Line (" <title>Xrefs indexes</title>");
+ Put_Line ("</head>");
+ New_Line;
+ Put_Line ("<body>");
+ Put_Line ("<p>list of files:");
+ Put_Line ("<ul>");
+ for I in Files'Range loop
+ Put ("<li>");
+ Put ("<a href=""");
+ Put (Files (I).Output.all);
+ Put (""">");
+ Put_Html (Files_Name (I).all);
+ Put ("</a>");
+ Put ("</li>");
+ New_Line;
+ end loop;
+ Put_Line ("</ul></p>");
+ Put_Line ("<hr>");
+
+ -- TODO: list of design units.
+
+ Put_Line ("<p>list of files referenced but not available:");
+ Put_Line ("<ul>");
+ for I in No_Source_File_Entry + 1 .. Filexref_Info'Last loop
+ if Filexref_Info (I).Output = null
+ and then Filexref_Info (I).Referenced
+ then
+ Put ("<li><a name=""f");
+ Put_Nat (Natural (I));
+ Put (""">");
+ Put_Html (Image (Files_Map.Get_File_Name (I)));
+ Put ("</a></li>");
+ New_Line;
+ end if;
+ end loop;
+ Put_Line ("</ul></p><hr>");
+ Put_Html_Foot;
+
+ Close (Output);
+ end if;
+
+ if Html_Format = Html_Css
+ and then Cmd.Output_Dir /= null
+ then
+ declare
+ Css_Filename : constant String :=
+ Cmd.Output_Dir.all & Directory_Separator & "ghdl.css";
+ begin
+ if not Is_Regular_File (Css_Filename & Nul) then
+ Create (Output, Out_File, Css_Filename);
+ Set_Output (Output);
+ Put_Css;
+ Close (Output);
+ end if;
+ end;
+ end if;
+
+ if Missing_Xref and Cmd.Check_Missing then
+ Error ("missing xrefs");
+ raise Compile_Error;
+ end if;
+ exception
+ when Compilation_Error =>
+ Error ("xrefs has failed due to compilation error");
+ end Perform_Action;
+
+
+ -- Command --xref
+ type Command_Xref is new Command_Lib with null record;
+
+ function Decode_Command (Cmd : Command_Xref; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Xref) return String;
+
+ procedure Perform_Action (Cmd : in out Command_Xref;
+ Files_Name : Argument_List);
+
+ function Decode_Command (Cmd : Command_Xref; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "--xref";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Xref) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "--xref FILEs Generate xrefs";
+ end Get_Short_Help;
+
+ procedure Perform_Action
+ (Cmd : in out Command_Xref; Files_Name : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+
+ use Files_Map;
+
+ Id : Name_Id;
+ File : Source_File_Entry;
+
+ type File_Data is record
+ Fe : Source_File_Entry;
+ Design_File : Iir;
+ end record;
+ type File_Data_Array is array (Files_Name'Range) of File_Data;
+
+ Files : File_Data_Array;
+ begin
+ -- Load work library.
+ Setup_Libraries (True);
+
+ Xrefs.Init;
+ Flags.Flag_Xref := True;
+
+ -- Parse all files.
+ for I in Files'Range loop
+ Id := Get_Identifier (Files_Name (I).all);
+ File := Load_Source_File (Libraries.Local_Directory, Id);
+ if File = No_Source_File_Entry then
+ Error ("cannot open " & Image (Id));
+ return;
+ end if;
+ Files (I).Fe := File;
+ Files (I).Design_File := Libraries.Load_File (File);
+ if Files (I).Design_File = Null_Iir then
+ return;
+ end if;
+ -- Put units in library.
+ -- Note: design_units stay while design_file get empty.
+ Libraries.Add_Design_File_Into_Library (Files (I).Design_File);
+ end loop;
+
+ -- Analyze all files.
+ for I in Files'Range loop
+ Analyze_Design_File_Units (Files (I).Design_File);
+ end loop;
+
+ Xrefs.Fix_End_Xrefs;
+ Xrefs.Sort_By_Node_Location;
+
+ for F in Files'Range loop
+
+ Put ("GHDL-XREF V0");
+
+ declare
+ use Xrefs;
+
+ Cur_Decl : Iir;
+ Cur_File : Source_File_Entry;
+
+ procedure Emit_Loc (Loc : Location_Type; C : Character)
+ is
+ L_File : Source_File_Entry;
+ L_Pos : Source_Ptr;
+ L_Line : Natural;
+ L_Off : Natural;
+ begin
+ Location_To_Coord (Loc, L_File, L_Pos, L_Line, L_Off);
+ --Put_Nat (Natural (L_File));
+ --Put (':');
+ Put_Nat (L_Line);
+ Put (C);
+ Put_Nat (L_Off);
+ end Emit_Loc;
+
+ procedure Emit_Decl (N : Iir)
+ is
+ Loc : Location_Type;
+ Loc_File : Source_File_Entry;
+ Loc_Pos : Source_Ptr;
+ C : Character;
+ Dir : Name_Id;
+ begin
+ New_Line;
+ Cur_Decl := N;
+ Loc := Get_Location (N);
+ Location_To_File_Pos (Loc, Loc_File, Loc_Pos);
+ if Loc_File /= Cur_File then
+ Cur_File := Loc_File;
+ Put ("XFILE: ");
+ Dir := Get_Source_File_Directory (Cur_File);
+ if Dir /= Null_Identifier then
+ Image (Dir);
+ Put (Name_Buffer (1 .. Name_Length));
+ end if;
+ Image (Get_File_Name (Cur_File));
+ Put (Name_Buffer (1 .. Name_Length));
+ New_Line;
+ end if;
+
+ -- Letters:
+ -- b d fgh jk no qr uvwxyz
+ -- D H JK MNO QR U WXYZ
+ case Get_Kind (N) is
+ when Iir_Kind_Type_Declaration =>
+ C := 'T';
+ when Iir_Kind_Subtype_Declaration =>
+ C := 't';
+ when Iir_Kind_Entity_Declaration =>
+ C := 'E';
+ when Iir_Kind_Architecture_Body =>
+ C := 'A';
+ when Iir_Kind_Library_Declaration =>
+ C := 'L';
+ when Iir_Kind_Package_Declaration =>
+ C := 'P';
+ when Iir_Kind_Package_Body =>
+ C := 'B';
+ when Iir_Kind_Function_Declaration =>
+ C := 'F';
+ when Iir_Kind_Procedure_Declaration =>
+ C := 'p';
+ when Iir_Kind_Interface_Signal_Declaration =>
+ C := 's';
+ when Iir_Kind_Signal_Declaration =>
+ C := 'S';
+ when Iir_Kind_Interface_Constant_Declaration =>
+ C := 'c';
+ when Iir_Kind_Constant_Declaration =>
+ C := 'C';
+ when Iir_Kind_Variable_Declaration =>
+ C := 'V';
+ when Iir_Kind_Element_Declaration =>
+ C := 'e';
+ when Iir_Kind_Iterator_Declaration =>
+ C := 'i';
+ when Iir_Kind_Attribute_Declaration =>
+ C := 'a';
+ when Iir_Kind_Enumeration_Literal =>
+ C := 'l';
+ when Iir_Kind_Component_Declaration =>
+ C := 'm';
+ when Iir_Kind_Component_Instantiation_Statement =>
+ C := 'I';
+ when Iir_Kind_Generate_Statement =>
+ C := 'G';
+ when others =>
+ C := '?';
+ end case;
+ Emit_Loc (Loc, C);
+ --Disp_Tree.Disp_Iir_Address (N);
+ Put (' ');
+ case Get_Kind (N) is
+ when Iir_Kind_Function_Body
+ | Iir_Kind_Procedure_Body =>
+ null;
+ when others =>
+ Image (Get_Identifier (N));
+ Put (Name_Buffer (1 .. Name_Length));
+ end case;
+ end Emit_Decl;
+
+ procedure Emit_Ref (R : Xref; T : Character)
+ is
+ N : Iir;
+ begin
+ N := Get_Xref_Node (R);
+ if N /= Cur_Decl then
+ Emit_Decl (N);
+ end if;
+ Put (' ');
+ Emit_Loc (Get_Xref_Location (R), T);
+ end Emit_Ref;
+
+ Loc : Location_Type;
+ Loc_File : Source_File_Entry;
+ Loc_Pos : Source_Ptr;
+ begin
+ Cur_Decl := Null_Iir;
+ Cur_File := No_Source_File_Entry;
+
+ for I in First_Xref .. Get_Last_Xref loop
+ Loc := Get_Xref_Location (I);
+ Location_To_File_Pos (Loc, Loc_File, Loc_Pos);
+ if Loc_File = Files (F).Fe then
+ -- This is a local location.
+ case Get_Xref_Kind (I) is
+ when Xref_Decl =>
+ Emit_Decl (Get_Xref_Node (I));
+ when Xref_End =>
+ Emit_Ref (I, 'e');
+ when Xref_Ref =>
+ Emit_Ref (I, 'r');
+ when Xref_Body =>
+ Emit_Ref (I, 'b');
+ end case;
+ end if;
+ end loop;
+ New_Line;
+ end;
+ end loop;
+ exception
+ when Compilation_Error =>
+ Error ("xrefs has failed due to compilation error");
+ end Perform_Action;
+
+ procedure Register_Commands is
+ begin
+ Register_Command (new Command_Chop);
+ Register_Command (new Command_Lines);
+ Register_Command (new Command_Reprint);
+ Register_Command (new Command_Compare_Tokens);
+ Register_Command (new Command_PP_Html);
+ Register_Command (new Command_Xref_Html);
+ Register_Command (new Command_Xref);
+ end Register_Commands;
+end Ghdlprint;
diff --git a/src/ghdldrv/ghdlprint.ads b/src/ghdldrv/ghdlprint.ads
new file mode 100644
index 000000000..82c3e6072
--- /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 000000000..f6237214e
--- /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 000000000..07095bd5d
--- /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 000000000..17cece726
--- /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 000000000..264cbf8c6
--- /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 000000000..4b3951e78
--- /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;