aboutsummaryrefslogtreecommitdiffstats
path: root/translate
diff options
context:
space:
mode:
authorgingold <gingold@b72b5c32-5f01-0410-b925-b5c7b92870f7>2005-12-18 14:46:45 +0000
committergingold <gingold@b72b5c32-5f01-0410-b925-b5c7b92870f7>2005-12-18 14:46:45 +0000
commitcb45d7c240f4aabbd1dd716dd8bf7ab5b2107ff2 (patch)
treea5162922d12f8508b931c31014370056c35682b3 /translate
parent4ed054ad8c1877c1bd620014cfe8a36979c5aa54 (diff)
downloadghdl-cb45d7c240f4aabbd1dd716dd8bf7ab5b2107ff2.tar.gz
ghdl-cb45d7c240f4aabbd1dd716dd8bf7ab5b2107ff2.tar.bz2
ghdl-cb45d7c240f4aabbd1dd716dd8bf7ab5b2107ff2.zip
ghdl 0.21 is out
Diffstat (limited to 'translate')
-rw-r--r--translate/gcc/Makefile.in2
-rw-r--r--translate/gcc/dist-common.sh4
-rw-r--r--translate/ghdldrv/Makefile1
-rw-r--r--translate/ghdldrv/ghdlrun.adb3
-rw-r--r--translate/grt/config/pthread.c21
-rw-r--r--translate/grt/config/win32.c6
-rw-r--r--translate/grt/grt-disp_rti.adb390
-rw-r--r--translate/grt/grt-disp_rti.ads18
-rw-r--r--translate/grt/grt-disp_tree.adb448
-rw-r--r--translate/grt/grt-disp_tree.ads20
-rw-r--r--translate/grt/grt-main.adb32
-rw-r--r--translate/grt/grt-main.ads5
-rw-r--r--translate/grt/grt-modules.adb39
-rw-r--r--translate/grt/grt-modules.ads22
-rw-r--r--translate/grt/grt-options.adb17
-rw-r--r--translate/grt/grt-options.ads13
-rw-r--r--translate/grt/grt-processes.adb1
-rw-r--r--translate/grt/grt-rtis_utils.adb4
18 files changed, 608 insertions, 438 deletions
diff --git a/translate/gcc/Makefile.in b/translate/gcc/Makefile.in
index 863e43039..9f47e58a9 100644
--- a/translate/gcc/Makefile.in
+++ b/translate/gcc/Makefile.in
@@ -233,7 +233,7 @@ install-ghdllib: ghdllib grt.lst $(STD93_SRCS) $(STD87_SRCS) \
$(MKDIR) $(DESTDIR)$(VHDL_LIB_DIR)/lib
$(INSTALL_DATA) libgrt.a $(DESTDIR)$(VHDL_LIB_DIR)/lib/libgrt.a
$(INSTALL_DATA) grt.lst $(DESTDIR)$(VHDL_LIB_DIR)/lib/grt.lst
- $(INSTALL_DATA) grt.ver $(DESTDIR)$(VHDL_LIB_DIR)/lib/grt.ver
+ $(INSTALL_DATA) $(GRTSRCDIR)/grt.ver $(DESTDIR)$(VHDL_LIB_DIR)/lib/grt.ver
# Install VHDL sources.
$(MKDIR) $(DESTDIR)$(VHDL_LIB_DIR)/src
$(MKDIR) $(DESTDIR)$(VHDL_LIB_DIR)/src/std
diff --git a/translate/gcc/dist-common.sh b/translate/gcc/dist-common.sh
index 442e81dbb..e74ba9281 100644
--- a/translate/gcc/dist-common.sh
+++ b/translate/gcc/dist-common.sh
@@ -160,6 +160,8 @@ grt-disp.adb
grt-disp.ads
grt-disp_rti.adb
grt-disp_rti.ads
+grt-disp_tree.adb
+grt-disp_tree.ads
grt-disp_signals.adb
grt-disp_signals.ads
grt-errors.adb
@@ -176,6 +178,8 @@ grt-lib.adb
grt-lib.ads
grt-main.adb
grt-main.ads
+grt-modules.ads
+grt-modules.adb
grt-names.adb
grt-names.ads
grt-options.adb
diff --git a/translate/ghdldrv/Makefile b/translate/ghdldrv/Makefile
index 2549362cd..41e19a439 100644
--- a/translate/ghdldrv/Makefile
+++ b/translate/ghdldrv/Makefile
@@ -35,6 +35,7 @@ target=i686-pc-linux-gnu
GRTSRCDIR=../grt
include $(GRTSRCDIR)/Makefile.inc
+ghdl_mcode: GRT_FLAGS+=-DWITH_GNAT_RUN_TIME
ghdl_mcode: default_pathes.ads $(GRT_ADD_OBJS) mmap_binding.o force
gnatmake -aI../../ortho/mcode $(GNATFLAGS) ghdl_mcode $(GNAT_BARGS) -largs mmap_binding.o $(GNAT_LARGS) $(GRT_ADD_OBJS) $(subst @,$(GRTSRCDIR),$(GRT_EXTRA_LIB))
diff --git a/translate/ghdldrv/ghdlrun.adb b/translate/ghdldrv/ghdlrun.adb
index 55be418fe..5adaeba5d 100644
--- a/translate/ghdldrv/ghdlrun.adb
+++ b/translate/ghdldrv/ghdlrun.adb
@@ -57,6 +57,7 @@ with Files_Map;
with Name_Table;
with Grt.Main;
+with Grt.Modules;
with Grt.Lib;
with Grt.Processes;
with Grt.Rtis;
@@ -643,7 +644,7 @@ package body Ghdlrun is
end if;
Put_Line ("These options can only be placed at [RUNOPTS]");
-- Register modules, since they add commands.
- Grt.Main.Register_Modules;
+ Grt.Modules.Register_Modules;
-- Bypass usual help header.
Grt.Options.Argc := 0;
Grt.Options.Help;
diff --git a/translate/grt/config/pthread.c b/translate/grt/config/pthread.c
index f611bb615..f0cee39b1 100644
--- a/translate/grt/config/pthread.c
+++ b/translate/grt/config/pthread.c
@@ -42,9 +42,9 @@ typedef struct
} Stack_Type_t, *Stack_Type;
Stack_Type_t main_stack_context;
-extern Stack_Type grt_stack_main_stack;
+extern void grt_set_main_stack (Stack_Type_t *stack);
-//------------------------------------------------------------------------------
+//----------------------------------------------------------------------------
void grt_stack_init(void)
// Initialize the stacks package.
// This may adjust stack sizes.
@@ -58,10 +58,10 @@ void grt_stack_init(void)
// lock the mutex, as we are currently running
pthread_mutex_lock(&(main_stack_context.mutex));
- grt_stack_main_stack= &main_stack_context;
+ grt_set_main_stack (&main_stack_context);
}
-//------------------------------------------------------------------------------
+//----------------------------------------------------------------------------
static void* grt_stack_loop(void* pv_myStack)
{
Stack_Type myStack= (Stack_Type)pv_myStack;
@@ -84,7 +84,7 @@ static void* grt_stack_loop(void* pv_myStack)
return 0;
}
-//------------------------------------------------------------------------------
+//----------------------------------------------------------------------------
Stack_Type grt_stack_create(void* Func, void* Arg)
// Create a new stack, which on first execution will call FUNC with
// an argument ARG.
@@ -115,7 +115,7 @@ Stack_Type grt_stack_create(void* Func, void* Arg)
return newStack;
}
-//------------------------------------------------------------------------------
+//----------------------------------------------------------------------------
void grt_stack_switch(Stack_Type To, Stack_Type From)
// Resume stack TO and save the current context to the stack pointed by
// CUR.
@@ -134,14 +134,16 @@ void grt_stack_switch(Stack_Type To, Stack_Type From)
pthread_mutex_lock(&(From->mutex));
}
-//------------------------------------------------------------------------------
+//----------------------------------------------------------------------------
void grt_stack_delete(Stack_Type Stack)
// Delete stack STACK, which must not be currently executed.
// => procedure Stack_Delete (Stack : Stack_Type);
{ INFO("grt_stack_delete\n");
}
-//------------------------------------------------------------------------------
+//----------------------------------------------------------------------------
+
+#ifndef WITH_GNAT_RUN_TIME
void __gnat_raise_storage_error(void)
{
abort ();
@@ -151,7 +153,8 @@ void __gnat_raise_program_error(void)
{
abort ();
}
+#endif /* WITH_GNAT_RUN_TIME */
-//------------------------------------------------------------------------------
+//----------------------------------------------------------------------------
// end of file
diff --git a/translate/grt/config/win32.c b/translate/grt/config/win32.c
index 6c55f7b8a..80ea2703a 100644
--- a/translate/grt/config/win32.c
+++ b/translate/grt/config/win32.c
@@ -148,7 +148,8 @@ void grt_stack_delete(Stack_Type Stack)
{ INFO("grt_stack_delete\n");
}
-//------------------------------------------------------------------------------
+//----------------------------------------------------------------------------
+#ifndef WITH_GNAT_RUN_TIME
void __gnat_raise_storage_error(void)
{
abort ();
@@ -158,7 +159,8 @@ void __gnat_raise_program_error(void)
{
abort ();
}
+#endif
-//------------------------------------------------------------------------------
+//----------------------------------------------------------------------------
// end of file
diff --git a/translate/grt/grt-disp_rti.adb b/translate/grt/grt-disp_rti.adb
index 28ad75db5..e9ac3e60d 100644
--- a/translate/grt/grt-disp_rti.adb
+++ b/translate/grt/grt-disp_rti.adb
@@ -15,14 +15,10 @@
-- 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;
-with Grt.Rtis; use Grt.Rtis;
-with Grt.Stdio; use Grt.Stdio;
with Grt.Astdio; use Grt.Astdio;
-with Grt.Types; use Grt.Types;
with Grt.Errors; use Grt.Errors;
with Grt.Rtis_Addr; use Grt.Rtis_Addr;
-with Grt.Options; use Grt.Options;
+with Grt.Hooks; use Grt.Hooks;
package body Grt.Disp_Rti is
procedure Disp_Kind (Kind : Ghdl_Rtik);
@@ -119,12 +115,6 @@ package body Grt.Disp_Rti is
-- end case;
-- end Get_Scalar_Type_Kind;
- procedure Disp_Value (Stream : FILEs;
- Rti : Ghdl_Rti_Access;
- Ctxt : Rti_Context;
- Obj : in out Address;
- Is_Sig : Boolean);
-
procedure Disp_Array_Value_1 (Stream : FILEs;
El_Rti : Ghdl_Rti_Access;
Ctxt : Rti_Context;
@@ -989,10 +979,16 @@ package body Grt.Disp_Rti is
end case;
end Disp_Rti;
+ Disp_Rti_Flag : Boolean := False;
+
procedure Disp_All
is
Ctxt : Rti_Context;
begin
+ if not Disp_Rti_Flag then
+ return;
+ end if;
+
Put ("DISP_RTI.Disp_All: ");
Disp_Kind (Ghdl_Rti_Top_Ptr.Common.Kind);
New_Line;
@@ -1006,364 +1002,34 @@ package body Grt.Disp_Rti is
--Disp_Hierarchy;
end Disp_All;
- -- Get next interesting child.
- procedure Get_Tree_Child (Parent : Ghdl_Rtin_Block_Acc;
- Index : in out Ghdl_Index_Type;
- Child : out Ghdl_Rti_Access)
- is
- begin
- -- Exit if no more children.
- while Index < Parent.Nbr_Child loop
- Child := Parent.Children (Index);
- Index := Index + 1;
- case Child.Kind is
- when Ghdl_Rtik_Package
- | Ghdl_Rtik_Entity
- | Ghdl_Rtik_Architecture
- | Ghdl_Rtik_Block
- | Ghdl_Rtik_For_Generate
- | Ghdl_Rtik_If_Generate
- | Ghdl_Rtik_Instance =>
- return;
- when Ghdl_Rtik_Signal
- | Ghdl_Rtik_Port
- | Ghdl_Rtik_Guard =>
- if Disp_Tree >= Disp_Tree_Port then
- return;
- end if;
- when Ghdl_Rtik_Process =>
- if Disp_Tree >= Disp_Tree_Proc then
- return;
- end if;
- when others =>
- null;
- end case;
- end loop;
- Child := null;
- end Get_Tree_Child;
-
- procedure Disp_Tree_Child (Rti : Ghdl_Rti_Access; Ctxt : Rti_Context)
+ function Disp_Rti_Option (Opt : String) return Boolean
is
begin
- case Rti.Kind is
- when Ghdl_Rtik_Entity
- | Ghdl_Rtik_Process
- | Ghdl_Rtik_Architecture
- | Ghdl_Rtik_Block
- | Ghdl_Rtik_If_Generate =>
- declare
- Blk : Ghdl_Rtin_Block_Acc := To_Ghdl_Rtin_Block_Acc (Rti);
- begin
- Disp_Name (Blk.Name);
- end;
- when Ghdl_Rtik_Package_Body
- | Ghdl_Rtik_Package =>
- declare
- Blk : Ghdl_Rtin_Block_Acc;
- Lib : Ghdl_Rtin_Type_Scalar_Acc;
- begin
- Blk := To_Ghdl_Rtin_Block_Acc (Rti);
- if Rti.Kind = Ghdl_Rtik_Package_Body then
- Blk := To_Ghdl_Rtin_Block_Acc (Blk.Parent);
- end if;
- Lib := To_Ghdl_Rtin_Type_Scalar_Acc (Blk.Parent);
- Disp_Name (Lib.Name);
- Put ('.');
- Disp_Name (Blk.Name);
- end;
- when Ghdl_Rtik_For_Generate =>
- declare
- Blk : Ghdl_Rtin_Block_Acc := To_Ghdl_Rtin_Block_Acc (Rti);
- Iter : Ghdl_Rtin_Object_Acc;
- Addr : Address;
- begin
- Disp_Name (Blk.Name);
- Iter := To_Ghdl_Rtin_Object_Acc (Blk.Children (0));
- Addr := Loc_To_Addr (Iter.Common.Depth, Iter.Loc, Ctxt);
- Put ('(');
- Disp_Value (stdout, Iter.Obj_Type, Ctxt, Addr, False);
- Put (')');
- end;
- when Ghdl_Rtik_Signal
- | Ghdl_Rtik_Port
- | Ghdl_Rtik_Guard
- | Ghdl_Rtik_Iterator =>
- Disp_Name (To_Ghdl_Rtin_Object_Acc (Rti).Name);
- when Ghdl_Rtik_Instance =>
- Disp_Name (To_Ghdl_Rtin_Instance_Acc (Rti).Name);
- when others =>
- null;
- end case;
-
- case Rti.Kind is
- when Ghdl_Rtik_Package
- | Ghdl_Rtik_Package_Body =>
- Put (" [package]");
- when Ghdl_Rtik_Entity =>
- Put (" [entity]");
- when Ghdl_Rtik_Architecture =>
- Put (" [arch]");
- when Ghdl_Rtik_Process =>
- Put (" [process]");
- when Ghdl_Rtik_Block =>
- Put (" [block]");
- when Ghdl_Rtik_For_Generate =>
- Put (" [for-generate]");
- when Ghdl_Rtik_If_Generate =>
- Put (" [if-generate ");
- if Ctxt.Base = Null_Address then
- Put ("false]");
- else
- Put ("true]");
- end if;
- when Ghdl_Rtik_Signal =>
- Put (" [signal]");
- when Ghdl_Rtik_Port =>
- Put (" [port ");
- case Rti.Mode and Ghdl_Rti_Signal_Mode_Mask is
- when Ghdl_Rti_Signal_Mode_In =>
- Put ("in");
- when Ghdl_Rti_Signal_Mode_Out =>
- Put ("out");
- when Ghdl_Rti_Signal_Mode_Inout =>
- Put ("inout");
- when Ghdl_Rti_Signal_Mode_Buffer =>
- Put ("buffer");
- when Ghdl_Rti_Signal_Mode_Linkage =>
- Put ("linkage");
- when others =>
- Put ("?");
- end case;
- Put ("]");
- when Ghdl_Rtik_Guard =>
- Put (" [guard]");
- when Ghdl_Rtik_Iterator =>
- Put (" [iterator]");
- when Ghdl_Rtik_Instance =>
- Put (" [instance]");
- when others =>
- null;
- end case;
- end Disp_Tree_Child;
-
- procedure Disp_Tree_Block
- (Blk : Ghdl_Rtin_Block_Acc; Ctxt : Rti_Context; Pfx : String);
+ if Opt = "--dump-rti" then
+ Disp_Rti_Flag := True;
+ return True;
+ else
+ return False;
+ end if;
+ end Disp_Rti_Option;
- procedure Disp_Tree_Block1
- (Blk : Ghdl_Rtin_Block_Acc; Ctxt : Rti_Context; Pfx : String)
+ procedure Disp_Rti_Help
is
- Child : Ghdl_Rti_Access;
- Child2 : Ghdl_Rti_Access;
- Index : Ghdl_Index_Type;
-
- procedure Disp_Header (Nctxt : Rti_Context;
- Force_Cont : Boolean := False)
- is
- begin
- Put (Pfx);
-
- if Blk.Common.Kind /= Ghdl_Rtik_Entity
- and Child2 = null
- and Force_Cont = False
- then
- Put ("`-");
- else
- Put ("+-");
- end if;
-
- Disp_Tree_Child (Child, Nctxt);
- New_Line;
- end Disp_Header;
-
- procedure Disp_Sub_Block
- (Sub_Blk : Ghdl_Rtin_Block_Acc; Nctxt : Rti_Context)
- is
- Npfx : String (1 .. Pfx'Length + 2);
- begin
- Npfx (1 .. Pfx'Length) := Pfx;
- Npfx (Pfx'Length + 2) := ' ';
- if Child2 = null then
- Npfx (Pfx'Length + 1) := ' ';
- else
- Npfx (Pfx'Length + 1) := '|';
- end if;
- Disp_Tree_Block (Sub_Blk, Nctxt, Npfx);
- end Disp_Sub_Block;
-
+ procedure P (Str : String) renames Put_Line;
begin
- Index := 0;
- Get_Tree_Child (Blk, Index, Child);
- while Child /= null loop
- Get_Tree_Child (Blk, Index, Child2);
+ P (" --dump-rti dump Run Time Information");
+ end Disp_Rti_Help;
- case Child.Kind is
- when Ghdl_Rtik_Process
- | Ghdl_Rtik_Block =>
- declare
- Nblk : Ghdl_Rtin_Block_Acc := To_Ghdl_Rtin_Block_Acc (Child);
- Nctxt : Rti_Context;
- begin
- Nctxt := (Base => Ctxt.Base + Nblk.Loc.Off,
- Block => Child);
- Disp_Header (Nctxt, False);
- Disp_Sub_Block (Nblk, Nctxt);
- end;
- when Ghdl_Rtik_For_Generate =>
- declare
- Nblk : Ghdl_Rtin_Block_Acc := To_Ghdl_Rtin_Block_Acc (Child);
- Nctxt : Rti_Context;
- Length : Ghdl_Index_Type;
- Old_Child2 : Ghdl_Rti_Access;
- begin
- Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Nblk.Loc.Off).all,
- Block => Child);
- Length := Get_For_Generate_Length (Nblk, Ctxt);
- Disp_Header (Nctxt, Length > 1);
- Old_Child2 := Child2;
- if Length > 1 then
- Child2 := Child;
- end if;
- for I in 1 .. Length loop
- Disp_Sub_Block (Nblk, Nctxt);
- if I /= Length then
- Nctxt.Base := Nctxt.Base + Nblk.Size;
- if I = Length - 1 then
- Child2 := Old_Child2;
- end if;
- Disp_Header (Nctxt);
- end if;
- end loop;
- Child2 := Old_Child2;
- end;
- when Ghdl_Rtik_If_Generate =>
- declare
- Nblk : Ghdl_Rtin_Block_Acc := To_Ghdl_Rtin_Block_Acc (Child);
- Nctxt : Rti_Context;
- begin
- Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Nblk.Loc.Off).all,
- Block => Child);
- Disp_Header (Nctxt);
- if Nctxt.Base /= Null_Address then
- Disp_Sub_Block (Nblk, Nctxt);
- end if;
- end;
- when Ghdl_Rtik_Instance =>
- declare
- Inst : Ghdl_Rtin_Instance_Acc;
- Sub_Ctxt : Rti_Context;
- Sub_Blk : Ghdl_Rtin_Block_Acc;
- Npfx : String (1 .. Pfx'Length + 4);
- Comp : Ghdl_Rtin_Component_Acc;
- Ch : Ghdl_Rti_Access;
- begin
- Disp_Header (Ctxt);
- Inst := To_Ghdl_Rtin_Instance_Acc (Child);
- Get_Instance_Context (Inst, Ctxt, Sub_Ctxt);
- Sub_Blk := To_Ghdl_Rtin_Block_Acc (Sub_Ctxt.Block);
- if Inst.Instance.Kind = Ghdl_Rtik_Component
- and then Disp_Tree >= Disp_Tree_Port
- then
- -- Disp generics and ports of the component.
- Comp := To_Ghdl_Rtin_Component_Acc (Inst.Instance);
- for I in 1 .. Comp.Nbr_Child loop
- Ch := Comp.Children (I - 1);
- if Ch.Kind = Ghdl_Rtik_Port then
- -- Disp only port (and not generics).
- Put (Pfx);
- if Child2 = null then
- Put (" ");
- else
- Put ("| ");
- end if;
- if I = Comp.Nbr_Child and then Sub_Blk = null then
- Put ("`-");
- else
- Put ("+-");
- end if;
- Disp_Tree_Child (Ch, Sub_Ctxt);
- New_Line;
- end if;
- end loop;
- end if;
- if Sub_Blk /= null then
- Npfx (1 .. Pfx'Length) := Pfx;
- if Child2 = null then
- Npfx (Pfx'Length + 1) := ' ';
- else
- Npfx (Pfx'Length + 1) := '|';
- end if;
- Npfx (Pfx'Length + 2) := ' ';
- Npfx (Pfx'Length + 3) := '`';
- Npfx (Pfx'Length + 4) := '-';
- Put (Npfx);
- Disp_Tree_Child (Sub_Blk.Parent, Sub_Ctxt);
- New_Line;
- Npfx (Pfx'Length + 3) := ' ';
- Npfx (Pfx'Length + 4) := ' ';
- Disp_Tree_Block (Sub_Blk, Sub_Ctxt, Npfx);
- end if;
- end;
- when others =>
- Disp_Header (Ctxt);
- end case;
-
- Child := Child2;
- end loop;
- end Disp_Tree_Block1;
+ Disp_Rti_Hooks : aliased constant Hooks_Type :=
+ (Option => Disp_Rti_Option'Access,
+ Help => Disp_Rti_Help'Access,
+ Init => null,
+ Start => Disp_All'Access,
+ Finish => null);
- procedure Disp_Tree_Block
- (Blk : Ghdl_Rtin_Block_Acc; Ctxt : Rti_Context; Pfx : String)
- is
+ procedure Register is
begin
- case Blk.Common.Kind is
- when Ghdl_Rtik_Architecture =>
- declare
- Npfx : String (1 .. Pfx'Length + 2);
- Nctxt : Rti_Context;
- begin
- -- The entity.
- Nctxt := (Base => Ctxt.Base,
- Block => Blk.Parent);
- Disp_Tree_Block1
- (To_Ghdl_Rtin_Block_Acc (Blk.Parent), Nctxt, Pfx);
- -- Then the architecture.
- Put (Pfx);
- Put ("`-");
- Disp_Tree_Child (To_Ghdl_Rti_Access (Blk), Ctxt);
- New_Line;
- Npfx (1 .. Pfx'Length) := Pfx;
- Npfx (Pfx'Length + 1) := ' ';
- Npfx (Pfx'Length + 2) := ' ';
- Disp_Tree_Block1 (Blk, Ctxt, Npfx);
- end;
- when Ghdl_Rtik_Package_Body =>
- Disp_Tree_Block1
- (To_Ghdl_Rtin_Block_Acc (Blk.Parent), Ctxt, Pfx);
- when others =>
- Disp_Tree_Block1 (Blk, Ctxt, Pfx);
- end case;
- end Disp_Tree_Block;
-
- procedure Disp_Hierarchy
- is
- Ctxt : Rti_Context;
- Parent : Ghdl_Rtin_Block_Acc;
- Child : Ghdl_Rti_Access;
- begin
- Ctxt := Get_Top_Context;
- Parent := To_Ghdl_Rtin_Block_Acc (Ctxt.Block);
-
- Disp_Tree_Child (Parent.Parent, Ctxt);
- New_Line;
- Disp_Tree_Block (Parent, Ctxt, "");
+ Register_Hooks (Disp_Rti_Hooks'Access);
+ end Register;
- for I in 1 .. Ghdl_Rti_Top_Ptr.Nbr_Child loop
- Child := Ghdl_Rti_Top_Ptr.Children (I - 1);
- Ctxt := (Base => Null_Address,
- Block => Child);
- Disp_Tree_Child (Child, Ctxt);
- New_Line;
- Disp_Tree_Block (To_Ghdl_Rtin_Block_Acc (Child), Ctxt, "");
- end loop;
- end Disp_Hierarchy;
end Grt.Disp_Rti;
diff --git a/translate/grt/grt-disp_rti.ads b/translate/grt/grt-disp_rti.ads
index 890c5e1ff..fc13e22ff 100644
--- a/translate/grt/grt-disp_rti.ads
+++ b/translate/grt/grt-disp_rti.ads
@@ -15,8 +15,22 @@
-- 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;
+with Grt.Types; use Grt.Types;
+with Grt.Stdio; use Grt.Stdio;
+with Grt.Rtis; use Grt.Rtis;
+with Grt.Rtis_Addr; use Grt.Rtis_Addr;
+
package Grt.Disp_Rti is
- procedure Disp_All;
+ -- Disp NAME. If NAME is null, then disp <anonymous>.
+ procedure Disp_Name (Name : Ghdl_C_String);
+
+ -- Disp a value.
+ procedure Disp_Value (Stream : FILEs;
+ Rti : Ghdl_Rti_Access;
+ Ctxt : Rti_Context;
+ Obj : in out Address;
+ Is_Sig : Boolean);
- procedure Disp_Hierarchy;
+ procedure Register;
end Grt.Disp_Rti;
diff --git a/translate/grt/grt-disp_tree.adb b/translate/grt/grt-disp_tree.adb
new file mode 100644
index 000000000..e4f55f3d1
--- /dev/null
+++ b/translate/grt/grt-disp_tree.adb
@@ -0,0 +1,448 @@
+-- GHDL Run Time (GRT) - Tree displayer.
+-- 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 System; use System;
+with Grt.Disp_Rti; use Grt.Disp_Rti;
+with Grt.Rtis; use Grt.Rtis;
+with Grt.Stdio; use Grt.Stdio;
+with Grt.Astdio; use Grt.Astdio;
+with Grt.Types; use Grt.Types;
+with Grt.Errors; use Grt.Errors;
+with Grt.Rtis_Addr; use Grt.Rtis_Addr;
+with Grt.Hooks; use Grt.Hooks;
+
+package body Grt.Disp_Tree is
+ -- Set by --disp-tree, to display the design hierarchy.
+ type Disp_Tree_Kind is
+ (
+ Disp_Tree_None, -- Do not disp tree.
+ Disp_Tree_Inst, -- Disp entities, arch, package, blocks, components.
+ Disp_Tree_Proc, -- As above plus processes
+ Disp_Tree_Port -- As above plus ports and signals.
+ );
+ Disp_Tree_Flag : Disp_Tree_Kind := Disp_Tree_None;
+
+
+ -- Get next interesting child.
+ procedure Get_Tree_Child (Parent : Ghdl_Rtin_Block_Acc;
+ Index : in out Ghdl_Index_Type;
+ Child : out Ghdl_Rti_Access)
+ is
+ begin
+ -- Exit if no more children.
+ while Index < Parent.Nbr_Child loop
+ Child := Parent.Children (Index);
+ Index := Index + 1;
+ case Child.Kind is
+ when Ghdl_Rtik_Package
+ | Ghdl_Rtik_Entity
+ | Ghdl_Rtik_Architecture
+ | Ghdl_Rtik_Block
+ | Ghdl_Rtik_For_Generate
+ | Ghdl_Rtik_If_Generate
+ | Ghdl_Rtik_Instance =>
+ return;
+ when Ghdl_Rtik_Signal
+ | Ghdl_Rtik_Port
+ | Ghdl_Rtik_Guard =>
+ if Disp_Tree_Flag >= Disp_Tree_Port then
+ return;
+ end if;
+ when Ghdl_Rtik_Process =>
+ if Disp_Tree_Flag >= Disp_Tree_Proc then
+ return;
+ end if;
+ when others =>
+ null;
+ end case;
+ end loop;
+ Child := null;
+ end Get_Tree_Child;
+
+ procedure Disp_Tree_Child (Rti : Ghdl_Rti_Access; Ctxt : Rti_Context)
+ is
+ begin
+ case Rti.Kind is
+ when Ghdl_Rtik_Entity
+ | Ghdl_Rtik_Process
+ | Ghdl_Rtik_Architecture
+ | Ghdl_Rtik_Block
+ | Ghdl_Rtik_If_Generate =>
+ declare
+ Blk : Ghdl_Rtin_Block_Acc := To_Ghdl_Rtin_Block_Acc (Rti);
+ begin
+ Disp_Name (Blk.Name);
+ end;
+ when Ghdl_Rtik_Package_Body
+ | Ghdl_Rtik_Package =>
+ declare
+ Blk : Ghdl_Rtin_Block_Acc;
+ Lib : Ghdl_Rtin_Type_Scalar_Acc;
+ begin
+ Blk := To_Ghdl_Rtin_Block_Acc (Rti);
+ if Rti.Kind = Ghdl_Rtik_Package_Body then
+ Blk := To_Ghdl_Rtin_Block_Acc (Blk.Parent);
+ end if;
+ Lib := To_Ghdl_Rtin_Type_Scalar_Acc (Blk.Parent);
+ Disp_Name (Lib.Name);
+ Put ('.');
+ Disp_Name (Blk.Name);
+ end;
+ when Ghdl_Rtik_For_Generate =>
+ declare
+ Blk : Ghdl_Rtin_Block_Acc := To_Ghdl_Rtin_Block_Acc (Rti);
+ Iter : Ghdl_Rtin_Object_Acc;
+ Addr : Address;
+ begin
+ Disp_Name (Blk.Name);
+ Iter := To_Ghdl_Rtin_Object_Acc (Blk.Children (0));
+ Addr := Loc_To_Addr (Iter.Common.Depth, Iter.Loc, Ctxt);
+ Put ('(');
+ Disp_Value (stdout, Iter.Obj_Type, Ctxt, Addr, False);
+ Put (')');
+ end;
+ when Ghdl_Rtik_Signal
+ | Ghdl_Rtik_Port
+ | Ghdl_Rtik_Guard
+ | Ghdl_Rtik_Iterator =>
+ Disp_Name (To_Ghdl_Rtin_Object_Acc (Rti).Name);
+ when Ghdl_Rtik_Instance =>
+ Disp_Name (To_Ghdl_Rtin_Instance_Acc (Rti).Name);
+ when others =>
+ null;
+ end case;
+
+ case Rti.Kind is
+ when Ghdl_Rtik_Package
+ | Ghdl_Rtik_Package_Body =>
+ Put (" [package]");
+ when Ghdl_Rtik_Entity =>
+ Put (" [entity]");
+ when Ghdl_Rtik_Architecture =>
+ Put (" [arch]");
+ when Ghdl_Rtik_Process =>
+ Put (" [process]");
+ when Ghdl_Rtik_Block =>
+ Put (" [block]");
+ when Ghdl_Rtik_For_Generate =>
+ Put (" [for-generate]");
+ when Ghdl_Rtik_If_Generate =>
+ Put (" [if-generate ");
+ if Ctxt.Base = Null_Address then
+ Put ("false]");
+ else
+ Put ("true]");
+ end if;
+ when Ghdl_Rtik_Signal =>
+ Put (" [signal]");
+ when Ghdl_Rtik_Port =>
+ Put (" [port ");
+ case Rti.Mode and Ghdl_Rti_Signal_Mode_Mask is
+ when Ghdl_Rti_Signal_Mode_In =>
+ Put ("in");
+ when Ghdl_Rti_Signal_Mode_Out =>
+ Put ("out");
+ when Ghdl_Rti_Signal_Mode_Inout =>
+ Put ("inout");
+ when Ghdl_Rti_Signal_Mode_Buffer =>
+ Put ("buffer");
+ when Ghdl_Rti_Signal_Mode_Linkage =>
+ Put ("linkage");
+ when others =>
+ Put ("?");
+ end case;
+ Put ("]");
+ when Ghdl_Rtik_Guard =>
+ Put (" [guard]");
+ when Ghdl_Rtik_Iterator =>
+ Put (" [iterator]");
+ when Ghdl_Rtik_Instance =>
+ Put (" [instance]");
+ when others =>
+ null;
+ end case;
+ end Disp_Tree_Child;
+
+ procedure Disp_Tree_Block
+ (Blk : Ghdl_Rtin_Block_Acc; Ctxt : Rti_Context; Pfx : String);
+
+ procedure Disp_Tree_Block1
+ (Blk : Ghdl_Rtin_Block_Acc; Ctxt : Rti_Context; Pfx : String)
+ is
+ Child : Ghdl_Rti_Access;
+ Child2 : Ghdl_Rti_Access;
+ Index : Ghdl_Index_Type;
+
+ procedure Disp_Header (Nctxt : Rti_Context;
+ Force_Cont : Boolean := False)
+ is
+ begin
+ Put (Pfx);
+
+ if Blk.Common.Kind /= Ghdl_Rtik_Entity
+ and Child2 = null
+ and Force_Cont = False
+ then
+ Put ("`-");
+ else
+ Put ("+-");
+ end if;
+
+ Disp_Tree_Child (Child, Nctxt);
+ New_Line;
+ end Disp_Header;
+
+ procedure Disp_Sub_Block
+ (Sub_Blk : Ghdl_Rtin_Block_Acc; Nctxt : Rti_Context)
+ is
+ Npfx : String (1 .. Pfx'Length + 2);
+ begin
+ Npfx (1 .. Pfx'Length) := Pfx;
+ Npfx (Pfx'Length + 2) := ' ';
+ if Child2 = null then
+ Npfx (Pfx'Length + 1) := ' ';
+ else
+ Npfx (Pfx'Length + 1) := '|';
+ end if;
+ Disp_Tree_Block (Sub_Blk, Nctxt, Npfx);
+ end Disp_Sub_Block;
+
+ begin
+ Index := 0;
+ Get_Tree_Child (Blk, Index, Child);
+ while Child /= null loop
+ Get_Tree_Child (Blk, Index, Child2);
+
+ case Child.Kind is
+ when Ghdl_Rtik_Process
+ | Ghdl_Rtik_Block =>
+ declare
+ Nblk : Ghdl_Rtin_Block_Acc := To_Ghdl_Rtin_Block_Acc (Child);
+ Nctxt : Rti_Context;
+ begin
+ Nctxt := (Base => Ctxt.Base + Nblk.Loc.Off,
+ Block => Child);
+ Disp_Header (Nctxt, False);
+ Disp_Sub_Block (Nblk, Nctxt);
+ end;
+ when Ghdl_Rtik_For_Generate =>
+ declare
+ Nblk : Ghdl_Rtin_Block_Acc := To_Ghdl_Rtin_Block_Acc (Child);
+ Nctxt : Rti_Context;
+ Length : Ghdl_Index_Type;
+ Old_Child2 : Ghdl_Rti_Access;
+ begin
+ Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Nblk.Loc.Off).all,
+ Block => Child);
+ Length := Get_For_Generate_Length (Nblk, Ctxt);
+ Disp_Header (Nctxt, Length > 1);
+ Old_Child2 := Child2;
+ if Length > 1 then
+ Child2 := Child;
+ end if;
+ for I in 1 .. Length loop
+ Disp_Sub_Block (Nblk, Nctxt);
+ if I /= Length then
+ Nctxt.Base := Nctxt.Base + Nblk.Size;
+ if I = Length - 1 then
+ Child2 := Old_Child2;
+ end if;
+ Disp_Header (Nctxt);
+ end if;
+ end loop;
+ Child2 := Old_Child2;
+ end;
+ when Ghdl_Rtik_If_Generate =>
+ declare
+ Nblk : Ghdl_Rtin_Block_Acc := To_Ghdl_Rtin_Block_Acc (Child);
+ Nctxt : Rti_Context;
+ begin
+ Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Nblk.Loc.Off).all,
+ Block => Child);
+ Disp_Header (Nctxt);
+ if Nctxt.Base /= Null_Address then
+ Disp_Sub_Block (Nblk, Nctxt);
+ end if;
+ end;
+ when Ghdl_Rtik_Instance =>
+ declare
+ Inst : Ghdl_Rtin_Instance_Acc;
+ Sub_Ctxt : Rti_Context;
+ Sub_Blk : Ghdl_Rtin_Block_Acc;
+ Npfx : String (1 .. Pfx'Length + 4);
+ Comp : Ghdl_Rtin_Component_Acc;
+ Ch : Ghdl_Rti_Access;
+ begin
+ Disp_Header (Ctxt);
+ Inst := To_Ghdl_Rtin_Instance_Acc (Child);
+ Get_Instance_Context (Inst, Ctxt, Sub_Ctxt);
+ Sub_Blk := To_Ghdl_Rtin_Block_Acc (Sub_Ctxt.Block);
+ if Inst.Instance.Kind = Ghdl_Rtik_Component
+ and then Disp_Tree_Flag >= Disp_Tree_Port
+ then
+ -- Disp generics and ports of the component.
+ Comp := To_Ghdl_Rtin_Component_Acc (Inst.Instance);
+ for I in 1 .. Comp.Nbr_Child loop
+ Ch := Comp.Children (I - 1);
+ if Ch.Kind = Ghdl_Rtik_Port then
+ -- Disp only port (and not generics).
+ Put (Pfx);
+ if Child2 = null then
+ Put (" ");
+ else
+ Put ("| ");
+ end if;
+ if I = Comp.Nbr_Child and then Sub_Blk = null then
+ Put ("`-");
+ else
+ Put ("+-");
+ end if;
+ Disp_Tree_Child (Ch, Sub_Ctxt);
+ New_Line;
+ end if;
+ end loop;
+ end if;
+ if Sub_Blk /= null then
+ Npfx (1 .. Pfx'Length) := Pfx;
+ if Child2 = null then
+ Npfx (Pfx'Length + 1) := ' ';
+ else
+ Npfx (Pfx'Length + 1) := '|';
+ end if;
+ Npfx (Pfx'Length + 2) := ' ';
+ Npfx (Pfx'Length + 3) := '`';
+ Npfx (Pfx'Length + 4) := '-';
+ Put (Npfx);
+ Disp_Tree_Child (Sub_Blk.Parent, Sub_Ctxt);
+ New_Line;
+ Npfx (Pfx'Length + 3) := ' ';
+ Npfx (Pfx'Length + 4) := ' ';
+ Disp_Tree_Block (Sub_Blk, Sub_Ctxt, Npfx);
+ end if;
+ end;
+ when others =>
+ Disp_Header (Ctxt);
+ end case;
+
+ Child := Child2;
+ end loop;
+ end Disp_Tree_Block1;
+
+ procedure Disp_Tree_Block
+ (Blk : Ghdl_Rtin_Block_Acc; Ctxt : Rti_Context; Pfx : String)
+ is
+ begin
+ case Blk.Common.Kind is
+ when Ghdl_Rtik_Architecture =>
+ declare
+ Npfx : String (1 .. Pfx'Length + 2);
+ Nctxt : Rti_Context;
+ begin
+ -- The entity.
+ Nctxt := (Base => Ctxt.Base,
+ Block => Blk.Parent);
+ Disp_Tree_Block1
+ (To_Ghdl_Rtin_Block_Acc (Blk.Parent), Nctxt, Pfx);
+ -- Then the architecture.
+ Put (Pfx);
+ Put ("`-");
+ Disp_Tree_Child (To_Ghdl_Rti_Access (Blk), Ctxt);
+ New_Line;
+ Npfx (1 .. Pfx'Length) := Pfx;
+ Npfx (Pfx'Length + 1) := ' ';
+ Npfx (Pfx'Length + 2) := ' ';
+ Disp_Tree_Block1 (Blk, Ctxt, Npfx);
+ end;
+ when Ghdl_Rtik_Package_Body =>
+ Disp_Tree_Block1
+ (To_Ghdl_Rtin_Block_Acc (Blk.Parent), Ctxt, Pfx);
+ when others =>
+ Disp_Tree_Block1 (Blk, Ctxt, Pfx);
+ end case;
+ end Disp_Tree_Block;
+
+ procedure Disp_Hierarchy
+ is
+ Ctxt : Rti_Context;
+ Parent : Ghdl_Rtin_Block_Acc;
+ Child : Ghdl_Rti_Access;
+ begin
+ if Disp_Tree_Flag = Disp_Tree_None then
+ return;
+ end if;
+
+ Ctxt := Get_Top_Context;
+ Parent := To_Ghdl_Rtin_Block_Acc (Ctxt.Block);
+
+ Disp_Tree_Child (Parent.Parent, Ctxt);
+ New_Line;
+ Disp_Tree_Block (Parent, Ctxt, "");
+
+ for I in 1 .. Ghdl_Rti_Top_Ptr.Nbr_Child loop
+ Child := Ghdl_Rti_Top_Ptr.Children (I - 1);
+ Ctxt := (Base => Null_Address,
+ Block => Child);
+ Disp_Tree_Child (Child, Ctxt);
+ New_Line;
+ Disp_Tree_Block (To_Ghdl_Rtin_Block_Acc (Child), Ctxt, "");
+ end loop;
+ end Disp_Hierarchy;
+
+ function Disp_Tree_Option (Opt : String) return Boolean
+ is
+ begin
+ if Opt'Length >= 11 and then Opt (1 .. 11) = "--disp-tree" then
+ if Opt'Length = 11 then
+ Disp_Tree_Flag := Disp_Tree_Port;
+ elsif Opt (12 .. Opt'Last) = "=port" then
+ Disp_Tree_Flag := Disp_Tree_Port;
+ elsif Opt (12 .. Opt'Last) = "=proc" then
+ Disp_Tree_Flag := Disp_Tree_Proc;
+ elsif Opt (12 .. Opt'Last) = "=inst" then
+ Disp_Tree_Flag := Disp_Tree_Inst;
+ elsif Opt (12 .. Opt'Last) = "=none" then
+ Disp_Tree_Flag := Disp_Tree_None;
+ else
+ Error ("bad argument for --disp-tree option, try --help");
+ end if;
+ return True;
+ else
+ return False;
+ end if;
+ end Disp_Tree_Option;
+
+ procedure Disp_Tree_Help
+ is
+ procedure P (Str : String) renames Put_Line;
+ begin
+ P (" --disp-tree[=KIND] disp the design hierarchy after elaboration");
+ P (" KIND is inst, proc, port (default)");
+ end Disp_Tree_Help;
+
+ Disp_Tree_Hooks : aliased constant Hooks_Type :=
+ (Option => Disp_Tree_Option'Access,
+ Help => Disp_Tree_Help'Access,
+ Init => null,
+ Start => Disp_Hierarchy'Access,
+ Finish => null);
+
+ procedure Register is
+ begin
+ Register_Hooks (Disp_Tree_Hooks'Access);
+ end Register;
+
+end Grt.Disp_Tree;
diff --git a/translate/grt/grt-disp_tree.ads b/translate/grt/grt-disp_tree.ads
new file mode 100644
index 000000000..574626eb9
--- /dev/null
+++ b/translate/grt/grt-disp_tree.ads
@@ -0,0 +1,20 @@
+-- GHDL Run Time (GRT) - RTI dumper.
+-- 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 Grt.Disp_Tree is
+ procedure Register;
+end Grt.Disp_Tree;
diff --git a/translate/grt/grt-main.adb b/translate/grt/grt-main.adb
index 28bd8b045..86a388cd6 100644
--- a/translate/grt/grt-main.adb
+++ b/translate/grt/grt-main.adb
@@ -18,21 +18,18 @@
with System.Storage_Elements; -- Work around GNAT bug.
with Grt.Types; use Grt.Types;
with Grt.Errors;
-with Grt.Vcd;
-with Grt.Vcdz;
-with Grt.Vpi;
-with Grt.Waves;
with Grt.Stacks;
with Grt.Processes;
with Grt.Signals;
with Grt.Options; use Grt.Options;
-with Grt.Disp_Rti;
with Grt.Stats;
with Grt.Hooks;
with Grt.Disp_Signals;
with Grt.Disp;
+with Grt.Modules;
-- The following packages are not referenced in this package.
+-- These are subprograms called only from GHDL generated code.
-- They are with'ed in order to be present in the binary.
pragma Warnings (Off);
with Grt.Files;
@@ -42,7 +39,6 @@ with Grt.Shadow_Ieee;
with Grt.Images;
with Grt.Values;
with Grt.Names;
-with Grt.Vital_Annotate;
pragma Warnings (On);
package body Grt.Main is
@@ -81,23 +77,15 @@ package body Grt.Main is
end if;
end Check_Flag_String;
- procedure Register_Modules is
- begin
- -- List of modules to be registered.
- Grt.Vcd.Register;
- Grt.Vcdz.Register;
- Grt.Waves.Register;
- Grt.Vpi.Register;
- Grt.Vital_Annotate.Register;
- end Register_Modules;
-
procedure Run
is
use Grt.Errors;
Stop : Boolean;
Status : Integer;
begin
- Register_Modules;
+ -- Register modules.
+ -- They may insert hooks.
+ Grt.Modules.Register_Modules;
-- If the time resolution is to be set by the user, select a default
-- resolution. Options may override it.
@@ -105,8 +93,10 @@ package body Grt.Main is
Set_Time_Resolution ('n');
end if;
+ -- Decode options.
Grt.Options.Decode (Stop);
+ -- Check coherency between GRT and GHDL generated code.
Check_Flag_String;
-- Early stop (for options such as --help).
@@ -138,15 +128,9 @@ package body Grt.Main is
Stats.Start_Order;
end if;
- if Disp_Tree /= Disp_Tree_None then
- Grt.Disp_Rti.Disp_Hierarchy;
- end if;
+ Grt.Hooks.Call_Start_Hooks;
if not Flag_No_Run then
- if Grt.Options.Flag_Dump_Rti then
- Grt.Disp_Rti.Disp_All;
- end if;
-
Grt.Signals.Order_All_Signals;
if Grt.Options.Disp_Signals_Map then
diff --git a/translate/grt/grt-main.ads b/translate/grt/grt-main.ads
index c62fe0067..15c669e8f 100644
--- a/translate/grt/grt-main.ads
+++ b/translate/grt/grt-main.ads
@@ -17,11 +17,6 @@
-- 02111-1307, USA.
package Grt.Main is
- -- Register modules.
- -- This is automatically called by RUN.
- -- Do not call this procedure.
- procedure Register_Modules;
-
-- Elaborate and simulate the design.
procedure Run;
end Grt.Main;
diff --git a/translate/grt/grt-modules.adb b/translate/grt/grt-modules.adb
new file mode 100644
index 000000000..6fe8eea32
--- /dev/null
+++ b/translate/grt/grt-modules.adb
@@ -0,0 +1,39 @@
+-- GHDL Run Time (GRT) - Modules.
+-- Copyright (C) 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 System.Storage_Elements; -- Work around GNAT bug.
+with Grt.Vcd;
+with Grt.Vcdz;
+with Grt.Vpi;
+with Grt.Waves;
+with Grt.Vital_Annotate;
+with Grt.Disp_Tree;
+with Grt.Disp_Rti;
+
+package body Grt.Modules is
+ procedure Register_Modules is
+ begin
+ -- List of modules to be registered.
+ Grt.Disp_Tree.Register;
+ Grt.Vcd.Register;
+ Grt.Vcdz.Register;
+ Grt.Waves.Register;
+ Grt.Vpi.Register;
+ Grt.Vital_Annotate.Register;
+ Grt.Disp_Rti.Register;
+ end Register_Modules;
+end Grt.Modules;
diff --git a/translate/grt/grt-modules.ads b/translate/grt/grt-modules.ads
new file mode 100644
index 000000000..2148597cf
--- /dev/null
+++ b/translate/grt/grt-modules.ads
@@ -0,0 +1,22 @@
+-- GHDL Run Time (GRT) - Modules.
+-- Copyright (C) 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 Grt.Modules is
+ -- Register optional modules.
+ procedure Register_Modules;
+end Grt.Modules;
diff --git a/translate/grt/grt-options.adb b/translate/grt/grt-options.adb
index 15b56d469..140f088b9 100644
--- a/translate/grt/grt-options.adb
+++ b/translate/grt/grt-options.adb
@@ -169,7 +169,6 @@ package body Grt.Options is
P (" --disp-sig-types disp signal types");
P (" --disp-signals-map disp map bw declared sigs and internal sigs");
P (" --disp-signals-table disp internal signals");
- P (" --dump-rti dump Run Time Information");
P (" --checks do internal checks after each process run");
P (" --activity=LEVEL watch activity of LEVEL signals");
P (" LEVEL is all, min (default) or none (unsafe)");
@@ -260,20 +259,6 @@ package body Grt.Options is
elsif Argument = "--help" or else Argument = "-h" then
Help;
Stop := True;
- elsif Len >= 11 and then Argument (1 .. 11) = "--disp-tree" then
- if Len = 11 then
- Disp_Tree := Disp_Tree_Port;
- elsif Argument (12 .. Len) = "=port" then
- Disp_Tree := Disp_Tree_Port;
- elsif Argument (12 .. Len) = "=proc" then
- Disp_Tree := Disp_Tree_Proc;
- elsif Argument (12 .. Len) = "=inst" then
- Disp_Tree := Disp_Tree_Inst;
- elsif Argument (12 .. Len) = "=none" then
- Disp_Tree := Disp_Tree_None;
- else
- Error ("bad argument for --disp-tree option, try --help");
- end if;
elsif Argument = "--disp-time" then
Disp_Time := True;
elsif Argument = "--trace-signals" then
@@ -294,8 +279,6 @@ package body Grt.Options is
Disp_Signals_Map := True;
elsif Argument = "--disp-signals-table" then
Disp_Signals_Table := True;
- elsif Argument = "--dump-rti" then
- Flag_Dump_Rti := True;
elsif Argument = "--stats" then
Flag_Stats := True;
elsif Argument = "--no-run" then
diff --git a/translate/grt/grt-options.ads b/translate/grt/grt-options.ads
index 756fe5dd6..7e2c17b10 100644
--- a/translate/grt/grt-options.ads
+++ b/translate/grt/grt-options.ads
@@ -56,16 +56,6 @@ package Grt.Options is
-- If STOP is true, there nothing must happen (set by --help).
procedure Decode (Stop : out Boolean);
- -- Set by --disp-tree, to display the design hierarchy.
- type Disp_Tree_Kind is
- (
- Disp_Tree_None, -- Do not disp tree.
- Disp_Tree_Inst, -- Disp entities, arch, package, blocks, components.
- Disp_Tree_Proc, -- As above plus processes
- Disp_Tree_Port -- As above plus ports and signals.
- );
- Disp_Tree : Disp_Tree_Kind := Disp_Tree_None;
-
-- Set by --disp-time (and --trace-signals, --trace-processes) to display
-- time and deltas.
Disp_Time : Boolean := False;
@@ -108,9 +98,6 @@ package Grt.Options is
-- The maximum stack size for non-sensitized processes.
Stack_Max_Size : Natural := 128 * 1024;
- -- If set, dump rtis.
- Flag_Dump_Rti : Boolean := False;
-
-- Set by --no-run
-- If set, do not simulate, only elaborate.
Flag_No_Run : Boolean := False;
diff --git a/translate/grt/grt-processes.adb b/translate/grt/grt-processes.adb
index 1bb0be854..54eb28bf5 100644
--- a/translate/grt/grt-processes.adb
+++ b/translate/grt/grt-processes.adb
@@ -806,7 +806,6 @@ package body Grt.Processes is
new Process_Id_Array (1 .. Nbr_Non_Postponed_Processes);
Postponed_Resume_Process_Table :=
new Process_Id_Array (1 .. Nbr_Postponed_Processes);
- Grt.Hooks.Call_Start_Hooks;
Status := Run_Through_Longjump (Initialization_Phase'Access);
if Status /= Run_Resumed then
diff --git a/translate/grt/grt-rtis_utils.adb b/translate/grt/grt-rtis_utils.adb
index 62cd407e8..9754adac8 100644
--- a/translate/grt/grt-rtis_utils.adb
+++ b/translate/grt/grt-rtis_utils.adb
@@ -94,7 +94,9 @@ package body Grt.Rtis_Utils is
Obj := To_Ghdl_Rtin_Instance_Acc (Child);
Get_Instance_Context (Obj, Ctxt, Nctxt);
- Res := Traverse_Instance (Nctxt);
+ if Nctxt /= Null_Context then
+ Res := Traverse_Instance (Nctxt);
+ end if;
end;
end if;
when Ghdl_Rtik_Package