diff options
Diffstat (limited to 'src')
112 files changed, 1924 insertions, 366 deletions
diff --git a/src/ghdldrv/default_pathes.ads.in b/src/ghdldrv/default_pathes.ads.in index a7c3d15f7..8b0801e13 100644 --- a/src/ghdldrv/default_pathes.ads.in +++ b/src/ghdldrv/default_pathes.ads.in @@ -39,4 +39,5 @@ package Default_Pathes is Shared_Library_Extension : constant String := "@SOEXT@"; + Default_Pie : constant Boolean := "@default_pie@" = String'("yes"); end Default_Pathes; diff --git a/src/ghdldrv/ghdldrv.adb b/src/ghdldrv/ghdldrv.adb index 082d1db57..ae8e510f3 100644 --- a/src/ghdldrv/ghdldrv.adb +++ b/src/ghdldrv/ghdldrv.adb @@ -41,8 +41,8 @@ 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"; + Assembler_Cmd : String_Access := null; + Linker_Cmd : String_Access := null; -- Path of the tools. Compiler_Path : String_Access; @@ -63,6 +63,9 @@ package body Ghdldrv is -- "-quiet" option. Dash_Quiet : constant String_Access := new String'("-quiet"); + -- "-fpic" option. + Dash_Fpic : constant String_Access := new String'("-fpic"); + -- True if --post is present. Flag_Postprocess : Boolean := False; @@ -162,7 +165,7 @@ package body Ghdldrv is declare P : Natural; Nbr_Args : constant Natural := - Last (Compiler_Args) + Options'Length + 4; + Last (Compiler_Args) + Options'Length + 5; Args : Argument_List (1 .. Nbr_Args); begin P := 0; @@ -191,6 +194,20 @@ package body Ghdldrv is end case; end if; + -- Add -fpic for gcc/llvm. + if not Flag_Postprocess + and then Default_Pathes.Default_Pie + then + case Backend is + when Backend_Gcc + | Backend_Llvm => + P := P + 1; + Args (P) := Dash_Fpic; + when Backend_Mcode => + null; + end case; + end if; + -- Object file (or assembly file). Args (P + 1) := Dash_o; if Flag_Postprocess then @@ -409,7 +426,7 @@ package body Ghdldrv is raise Option_Error; end Tool_Not_Found; - -- Set the compiler command according to the configuration (and swicthes). + -- Set the compiler command according to the configuration (and switches). procedure Set_Tools_Name is begin -- Set tools name. @@ -430,6 +447,12 @@ package body Ghdldrv is if Post_Processor_Cmd = null then Post_Processor_Cmd := new String'(Default_Pathes.Post_Processor); end if; + if Assembler_Cmd = null then + Assembler_Cmd := new String'("as"); + end if; + if Linker_Cmd = null then + Linker_Cmd := new String'("gcc"); + end if; end Set_Tools_Name; function Locate_Exec_Tool (Toolname : String) return String_Access is @@ -489,9 +512,9 @@ package body Ghdldrv is -- Assembler. case Backend is when Backend_Gcc => - Assembler_Path := Locate_Exec_On_Path (Assembler_Cmd); + Assembler_Path := Locate_Exec_On_Path (Assembler_Cmd.all); if Assembler_Path = null and not Flag_Asm then - Tool_Not_Found (Assembler_Cmd); + Tool_Not_Found (Assembler_Cmd.all); end if; when Backend_Llvm | Backend_Mcode => @@ -499,9 +522,9 @@ package body Ghdldrv is end case; -- Linker. - Linker_Path := Locate_Exec_On_Path (Linker_Cmd); + Linker_Path := Locate_Exec_On_Path (Linker_Cmd.all); if Linker_Path = null then - Tool_Not_Found (Linker_Cmd); + Tool_Not_Found (Linker_Cmd.all); end if; end Locate_Tools; @@ -570,6 +593,12 @@ package body Ghdldrv is elsif Opt'Length > 8 and then Opt (1 .. 8) = "--GHDL1=" then Compiler_Cmd := new String'(Opt (9 .. Opt'Last)); Res := Option_Ok; + elsif Opt'Length > 5 and then Opt (1 .. 5) = "--AS=" then + Assembler_Cmd := new String'(Opt (6 .. Opt'Last)); + Res := Option_Ok; + elsif Opt'Length > 7 and then Opt (1 .. 7) = "--LINK=" then + Linker_Cmd := new String'(Opt (8 .. Opt'Last)); + Res := Option_Ok; elsif Opt = "-S" then Flag_Asm := True; Res := Option_Ok; @@ -649,6 +678,8 @@ package body Ghdldrv is Disp_Long_Help (Command_Lib (Cmd)); Put_Line (" -v Be verbose"); Put_Line (" --GHDL1=PATH Set the path of the ghdl1 compiler"); + Put_Line (" --AS=as Use as for the assembler"); + Put_Line (" --LINK=gcc Use gcc for the linker driver"); 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"); @@ -705,13 +736,13 @@ package body Ghdldrv is case Backend is when Backend_Gcc => Put ("assembler command: "); - Put_Line (Assembler_Cmd); + Put_Line (Assembler_Cmd.all); when Backend_Llvm | Backend_Mcode => null; end case; Put ("linker command: "); - Put_Line (Linker_Cmd); + Put_Line (Linker_Cmd.all); Put_Line ("default lib prefix: " & Default_Pathes.Lib_Prefix); New_Line; diff --git a/src/grt/grt-vpi.adb b/src/grt/grt-vpi.adb index 7b62dae65..adabc6a87 100644 --- a/src/grt/grt-vpi.adb +++ b/src/grt/grt-vpi.adb @@ -1330,18 +1330,26 @@ package body Grt.Vpi is return Res; end vpi_register_cb; -------------------------------------------------------------------------------- --- * * * V P I d u m m i e s * * * * * * * * * * * * * * * * * * * * * * -------------------------------------------------------------------------------- - -- int vpi_free_object(vpiHandle ref) function vpi_free_object (aRef: vpiHandle) return integer is - pragma Unreferenced (aRef); + Ref_Copy : vpiHandle; begin + if Flag_Trace then + Trace_Start ("vpi_free_object ("); + Trace (aRef); + Trace (")"); + Trace_Newline; + end if; + Ref_Copy := aRef; + Free(Ref_Copy); return 1; end vpi_free_object; +------------------------------------------------------------------------------- +-- * * * V P I d u m m i e s * * * * * * * * * * * * * * * * * * * * * * +------------------------------------------------------------------------------- + -- int vpi_get_vlog_info(p_vpi_vlog_info vlog_info_p) function vpi_get_vlog_info (info : p_vpi_vlog_info) return integer is begin diff --git a/src/libraries.adb b/src/libraries.adb index 40764e56b..3f737f466 100644 --- a/src/libraries.adb +++ b/src/libraries.adb @@ -23,8 +23,6 @@ with System; with Errorout; use Errorout; with Scanner; with Iirs_Utils; use Iirs_Utils; -with Iir_Chains; -with Nodes_Meta; with Parse; with Name_Table; use Name_Table; with Str_Table; @@ -1551,8 +1549,9 @@ package body Libraries is procedure Finish_Compilation (Unit : Iir_Design_Unit; Main : Boolean := False) is - Lib_Unit : constant Iir := Get_Library_Unit (Unit); + Lib_Unit : Iir; begin + Lib_Unit := Get_Library_Unit (Unit); if (Main or Flags.Dump_All) and then Flags.Dump_Parse then Disp_Tree.Disp_Tree (Unit); end if; @@ -1603,23 +1602,6 @@ package body Libraries is Canon.Canonicalize (Unit); - -- FIXME: for Main only ? - if Get_Kind (Lib_Unit) = Iir_Kind_Package_Declaration - and then not Get_Need_Body (Lib_Unit) - and then Get_Need_Instance_Bodies (Lib_Unit) - then - -- Create the bodies for instances - Set_Package_Instantiation_Bodies_Chain - (Lib_Unit, Canon.Create_Instantiation_Bodies (Lib_Unit, Lib_Unit)); - elsif Get_Kind (Lib_Unit) = Iir_Kind_Package_Body - and then Get_Need_Instance_Bodies (Get_Package (Lib_Unit)) - then - Iir_Chains.Append_Chain - (Lib_Unit, Nodes_Meta.Field_Declaration_Chain, - Canon.Create_Instantiation_Bodies (Get_Package (Lib_Unit), - Lib_Unit)); - end if; - if (Main or Flags.Dump_All) and then Flags.Dump_Canon then Disp_Tree.Disp_Tree (Unit); end if; diff --git a/src/ortho/llvm-nodebug/ortho_code_main35.adb b/src/ortho/llvm-nodebug/ortho_code_main35.adb index 61b836369..bb5458b49 100644 --- a/src/ortho/llvm-nodebug/ortho_code_main35.adb +++ b/src/ortho/llvm-nodebug/ortho_code_main35.adb @@ -62,7 +62,7 @@ procedure Ortho_Code_Main35 is CPU : constant Cstring := Empty_Cstring; Features : constant Cstring := Empty_Cstring; - Reloc : constant RelocMode := RelocDefault; + Reloc : RelocMode := RelocDefault; function To_String (C : Cstring) return String is function Strlen (C : Cstring) return Natural; @@ -117,6 +117,10 @@ begin Optimization := CodeGenLevelDefault; elsif Arg = "-O3" then Optimization := CodeGenLevelAggressive; + elsif Arg = "-fpic" or Arg = "-fPIC" then + Reloc := RelocPIC; + elsif Arg = "-fno-pic" then + Reloc := RelocStatic; elsif Arg = "--emit-llvm" then Output_Kind := Output_Llvm; elsif Arg = "--emit-bc" then diff --git a/src/ortho/llvm-nodebug/ortho_code_main39.adb b/src/ortho/llvm-nodebug/ortho_code_main39.adb index d1e84b6e3..11e52220e 100644 --- a/src/ortho/llvm-nodebug/ortho_code_main39.adb +++ b/src/ortho/llvm-nodebug/ortho_code_main39.adb @@ -62,7 +62,7 @@ procedure Ortho_Code_Main39 is CPU : constant Cstring := Empty_Cstring; Features : constant Cstring := Empty_Cstring; - Reloc : constant RelocMode := RelocDefault; + Reloc : RelocMode := RelocDefault; function To_String (C : Cstring) return String is function Strlen (C : Cstring) return Natural; @@ -117,6 +117,10 @@ begin Optimization := CodeGenLevelDefault; elsif Arg = "-O3" then Optimization := CodeGenLevelAggressive; + elsif Arg = "-fpic" or Arg = "-fPIC" then + Reloc := RelocPIC; + elsif Arg = "-fno-pic" then + Reloc := RelocStatic; elsif Arg = "--emit-llvm" then Output_Kind := Output_Llvm; elsif Arg = "--emit-bc" then diff --git a/src/ortho/llvm/ortho_code_main.adb b/src/ortho/llvm/ortho_code_main.adb index 5558a8bbe..56c869ad1 100644 --- a/src/ortho/llvm/ortho_code_main.adb +++ b/src/ortho/llvm/ortho_code_main.adb @@ -70,7 +70,7 @@ procedure Ortho_Code_Main is CPU : constant Cstring := Empty_Cstring; Features : constant Cstring := Empty_Cstring; - Reloc : constant RelocMode := RelocDefault; + Reloc : RelocMode := RelocDefault; function To_String (C : Cstring) return String is function Strlen (C : Cstring) return Natural; @@ -125,6 +125,10 @@ begin Optimization := CodeGenLevelDefault; elsif Arg = "-O3" then Optimization := CodeGenLevelAggressive; + elsif Arg = "-fpic" or Arg = "-fPIC" then + Reloc := RelocPIC; + elsif Arg = "-fno-pic" then + Reloc := RelocStatic; elsif Arg = "--emit-llvm" then Output_Kind := Output_Llvm; elsif Arg = "--emit-bc" then diff --git a/src/ortho/oread/tests/acc.on b/src/ortho/oread/tests/acc.on new file mode 100644 index 000000000..aa6773325 --- /dev/null +++ b/src/ortho/oread/tests/acc.on @@ -0,0 +1,5 @@ +type __ghdl_file_index is unsigned (32); + +type __ghdl_file_index_ptr is access __ghdl_file_index; + +public var acc1 : __ghdl_file_index_ptr; diff --git a/src/ortho/oread/tests/acc2.on b/src/ortho/oread/tests/acc2.on new file mode 100644 index 000000000..faf786282 --- /dev/null +++ b/src/ortho/oread/tests/acc2.on @@ -0,0 +1,15 @@ +type __ghdl_file_index_ptr is access; + +type __ghdl_file_index is unsigned (32); + +type __ghdl_file_index_ptr is access __ghdl_file_index; + +public var acc1 : __ghdl_file_index_ptr; + +public function Get () return __ghdl_file_index +declare +begin + -- return __ghdl_file_index'[0]; + return acc1.all; +end; + diff --git a/src/ortho/oread/tests/acc3.on b/src/ortho/oread/tests/acc3.on new file mode 100644 index 000000000..00cecad68 --- /dev/null +++ b/src/ortho/oread/tests/acc3.on @@ -0,0 +1,18 @@ +type index_ptr1 is access; + +type index is unsigned (32); + +type index_ptr1 is access index; + +type index_ptr2 is access index; + +public var acc1 : index_ptr1; + +public function Get () return index +declare + local var acc2 : index_ptr2; +begin + acc2 := index_ptr2'conv(acc1); + return acc2.all; +end; + diff --git a/src/ortho/oread/tests/align1.on b/src/ortho/oread/tests/align1.on new file mode 100644 index 000000000..f32039cbc --- /dev/null +++ b/src/ortho/oread/tests/align1.on @@ -0,0 +1,9 @@ +-- internal declarations, part 1 + +type __ghdl_size_type is unsigned (32); + +type __ghdl_index_type is unsigned (32); + +public constant align1 : __ghdl_size_type; + +constant align1 := __ghdl_size_type'alignof (__ghdl_index_type); diff --git a/src/ortho/oread/tests/arg1.on b/src/ortho/oread/tests/arg1.on new file mode 100644 index 000000000..d67c15622 --- /dev/null +++ b/src/ortho/oread/tests/arg1.on @@ -0,0 +1,7 @@ +type __ghdl_integer is signed (32); + +public function test_arg (v : __ghdl_integer) return __ghdl_integer +declare +begin + return v; +end; diff --git a/src/ortho/oread/tests/arr1.on b/src/ortho/oread/tests/arr1.on new file mode 100644 index 000000000..49ea69c53 --- /dev/null +++ b/src/ortho/oread/tests/arr1.on @@ -0,0 +1,5 @@ +type __ghdl_index_type is unsigned (32); + +type __ghdl_char is unsigned (8); + +type __ghdl_chararray is array [__ghdl_index_type] of __ghdl_char; diff --git a/src/ortho/oread/tests/arraggr1.on b/src/ortho/oread/tests/arraggr1.on new file mode 100644 index 000000000..1c1313103 --- /dev/null +++ b/src/ortho/oread/tests/arraggr1.on @@ -0,0 +1,12 @@ +type __ghdl_index_type is unsigned (32); + +type __ghdl_char is unsigned (8); + +type __ghdl_chararray is array [__ghdl_index_type] of __ghdl_char; + +private constant _UI00000000 : subarray __ghdl_chararray[__ghdl_index_type'[10] + ]; + +constant _UI00000000 := {__ghdl_char'[110], __ghdl_char'[101], + __ghdl_char'[115], __ghdl_char'[116], __ghdl_char'[49], __ghdl_char'[46], + __ghdl_char'[118], __ghdl_char'[104], __ghdl_char'[100], __ghdl_char'[0]}; diff --git a/src/ortho/oread/tests/asgn_acc.on b/src/ortho/oread/tests/asgn_acc.on new file mode 100644 index 000000000..01559c081 --- /dev/null +++ b/src/ortho/oread/tests/asgn_acc.on @@ -0,0 +1,13 @@ +TYPE int32 IS SIGNED (32); +TYPE int32_acc IS ACCESS int32; +PRIVATE CONSTANT zero_i32 : int32 := 0; + +PRIVATE PROCEDURE call_arg_addr () +DECLARE +BEGIN +DECLARE + LOCAL VAR ap : int32_acc; +BEGIN + ap := int32_acc'address (zero_i32); +END; +END;
\ No newline at end of file diff --git a/src/ortho/oread/tests/bool.on b/src/ortho/oread/tests/bool.on new file mode 100644 index 000000000..c1f3e424d --- /dev/null +++ b/src/ortho/oread/tests/bool.on @@ -0,0 +1 @@ +type __ghdl_bool_type is boolean {false, true}; diff --git a/src/ortho/oread/tests/bug_mcode1.on b/src/ortho/oread/tests/bug_mcode1.on new file mode 100644 index 000000000..bd9737119 --- /dev/null +++ b/src/ortho/oread/tests/bug_mcode1.on @@ -0,0 +1,41 @@ +TYPE __ghdl_index_type IS UNSIGNED (32); + +-- package std.standard + +TYPE std__standard__integer__BT IS SIGNED (32); + +TYPE std__standard__real__BT IS FLOAT; + +-- package declaration math_real + +EXTERNAL FUNCTION ieee__math_real__ceil (x: std__standard__real__BT) + RETURN std__standard__real__BT; + +--F /Users/gingold/devel/vhdl-testsuite/OSVVM_2014_01/src/CoveragePkg.vhd + +TYPE work__coveragepkg__covptype__covbinbasetemptype IS RECORD + action: std__standard__integer__BT; + action2: std__standard__integer__BT; + count: std__standard__integer__BT; + atleast: std__standard__integer__BT; +END RECORD; + +TYPE work__coveragepkg__covptype__covbintemptype__BASE IS ARRAY [ + __ghdl_index_type] OF work__coveragepkg__covptype__covbinbasetemptype; + +TYPE work__coveragepkg__covptype__covbintemptype__ARR IS SUBARRAY + work__coveragepkg__covptype__covbintemptype__BASE[2]; + +PRIVATE FUNCTION work__coveragepkg__covptype__calcweightO1 () + RETURN std__standard__integer__BT +DECLARE + LOCAL VAR RESULT : std__standard__integer__BT; + LOCAL VAR x : std__standard__real__BT; + LOCAL VAR b : work__coveragepkg__covptype__covbintemptype__ARR; + LOCAL VAR T2_8 : __ghdl_index_type; +BEGIN + RESULT := ( (std__standard__integer__BT + 'conv (ieee__math_real__ceil (x)) -# b[T2_8].count)); + RETURN RESULT; +END; + diff --git a/src/ortho/oread/tests/conv.on b/src/ortho/oread/tests/conv.on new file mode 100644 index 000000000..1b07fc5fe --- /dev/null +++ b/src/ortho/oread/tests/conv.on @@ -0,0 +1,40 @@ +TYPE float64 IS FLOAT; +TYPE int32 IS SIGNED (32); +TYPE int64 IS SIGNED (64); + +PUBLIC FUNCTION to_int32 (a : float64) RETURN int32 +DECLARE +BEGIN + RETURN int32'conv(a); +END; + +PUBLIC FUNCTION fp_to_int32 (a : float64) RETURN int64 +DECLARE +BEGIN + RETURN int64'conv(a); +END; + +PUBLIC FUNCTION to_fp64 (a : int32) RETURN float64 +DECLARE +BEGIN + RETURN float64'conv(a); +END; + +PUBLIC FUNCTION conv2 (a : int32) RETURN int32 +DECLARE +BEGIN + RETURN to_int32 (to_fp64 (a)); +END; + +PUBLIC FUNCTION to_int64 (a : int32) RETURN int64 +DECLARE +BEGIN + RETURN int64'conv(a); +END; + +-- Test spill +PUBLIC FUNCTION spill1 (a : int32) RETURN int64 +DECLARE +BEGIN + RETURN int64'conv(a) +# to_int64 (a); +END; diff --git a/src/ortho/oread/tests/enum1.on b/src/ortho/oread/tests/enum1.on new file mode 100644 index 000000000..87dc75cab --- /dev/null +++ b/src/ortho/oread/tests/enum1.on @@ -0,0 +1,4 @@ +type __ghdl_compare_type is enum {lt = 0, eq = 1, gt = 2}; + +public constant en1 : __ghdl_compare_type; +constant en1 := __ghdl_compare_type'[eq];
\ No newline at end of file diff --git a/src/ortho/oread/tests/fabs.on b/src/ortho/oread/tests/fabs.on new file mode 100644 index 000000000..90f19a36f --- /dev/null +++ b/src/ortho/oread/tests/fabs.on @@ -0,0 +1,38 @@ +TYPE float64 IS FLOAT; + +PUBLIC FUNCTION fadd (a : float64; b : float64) RETURN float64 +DECLARE +BEGIN + RETURN a +# b; +END; + +PUBLIC FUNCTION fsub (a : float64; b : float64) RETURN float64 +DECLARE +BEGIN + RETURN a -# b; +END; + +PUBLIC FUNCTION fmul (a : float64; b : float64) RETURN float64 +DECLARE +BEGIN + RETURN a *# b; +END; + +PUBLIC FUNCTION fdiv (a : float64; b : float64) RETURN float64 +DECLARE +BEGIN + RETURN a /# b; +END; + +PUBLIC FUNCTION fneg (a : float64) RETURN float64 +DECLARE +BEGIN + RETURN -a; +END; + +PUBLIC FUNCTION fabs (a : float64) RETURN float64 +DECLARE +BEGIN + RETURN ABS a; +END; + diff --git a/src/ortho/oread/tests/fdiv.on b/src/ortho/oread/tests/fdiv.on new file mode 100644 index 000000000..197316e65 --- /dev/null +++ b/src/ortho/oread/tests/fdiv.on @@ -0,0 +1,17 @@ +TYPE float64 IS FLOAT; +TYPE int32 IS SIGNED (32); +TYPE int64 IS SIGNED (64); + +PUBLIC FUNCTION fdiv (a : int64; b : int64) RETURN float64 +DECLARE +BEGIN + RETURN float64'conv(a) /# float64'conv (b); +END; + +TYPE char IS UNSIGNED(8); + +PUBLIC FUNCTION add (a : char; b : char) RETURN int32 +DECLARE +BEGIN + RETURN int32'conv(a) +# int32'conv(b); +END; diff --git a/src/ortho/oread/tests/fops.on b/src/ortho/oread/tests/fops.on new file mode 100644 index 000000000..74cd6f2aa --- /dev/null +++ b/src/ortho/oread/tests/fops.on @@ -0,0 +1,104 @@ +TYPE float64 IS FLOAT; +TYPE bool IS BOOLEAN {false, true}; +TYPE int32 IS SIGNED (32); + +PUBLIC FUNCTION fadd (a : float64; b : float64) RETURN float64 +DECLARE +BEGIN + RETURN a +# b; +END; + +PUBLIC FUNCTION fsub (a : float64; b : float64) RETURN float64 +DECLARE +BEGIN + RETURN a -# b; +END; + +PUBLIC FUNCTION fmul (a : float64; b : float64) RETURN float64 +DECLARE +BEGIN + RETURN a *# b; +END; + +PUBLIC FUNCTION fdiv (a : float64; b : float64) RETURN float64 +DECLARE +BEGIN + RETURN a /# b; +END; + +PUBLIC FUNCTION fneg (a : float64) RETURN float64 +DECLARE +BEGIN + RETURN -a; +END; + +PUBLIC FUNCTION fabs (a : float64) RETURN float64 +DECLARE +BEGIN + RETURN ABS a; +END; + +PUBLIC FUNCTION fcall1 (a : float64; b : float64) RETURN float64 +DECLARE +BEGIN + RETURN fadd (fmul (a, b), fneg (b)); +END; + +PUBLIC FUNCTION fgt (a : float64; b : float64) RETURN bool +DECLARE +BEGIN + RETURN bool'(a >= b); +END; + +PUBLIC FUNCTION mainint () RETURN int32 +DECLARE + LOCAL VAR l : int32; + LOCAL VAR r : int32; +BEGIN + l:= 1; + r := 2; + IF bool'(l < r) THEN + RETURN int32'(0); + ELSE + RETURN int32'(1); + END IF; +END; + +PRIVATE CONSTANT fone : float64; +CONSTANT fone := 1.0; + +-- Return 0 in case of error. +PUBLIC FUNCTION main () RETURN int32 +DECLARE + LOCAL VAR lf : float64; + LOCAL VAR rf : float64; +BEGIN + lf := 1.0; + rf := 2.0; + IF bool'(lf >= rf) THEN + RETURN int32'(0); + END IF; + lf := fadd (lf, fone); + IF bool'(lf /= rf) THEN + RETURN int32'(0); + END IF; + + lf := fone; + lf := -lf; + IF bool'(lf > 0.0) THEN + RETURN int32'(0); + END IF; + + lf := ABS lf; + IF bool'(lf /= fone) THEN + RETURN int32'(0); + END IF; + + lf := 2.0; + IF bool'(fdiv (lf, fone) /= lf) THEN + RETURN int32'(0); + END IF; + + RETURN int32'(1); +END; + diff --git a/src/ortho/oread/tests/fp_add.on b/src/ortho/oread/tests/fp_add.on new file mode 100644 index 000000000..949f370de --- /dev/null +++ b/src/ortho/oread/tests/fp_add.on @@ -0,0 +1,13 @@ +TYPE float IS FLOAT; + +PRIVATE FUNCTION add_float (a : float; b : float) RETURN float +DECLARE +BEGIN + RETURN a +# b; +END; + +PRIVATE FUNCTION add3_float (a : float; b : float; c : float) RETURN float +DECLARE +BEGIN + RETURN add_float (a, add_float (b, c)); +END; diff --git a/src/ortho/oread/tests/if1.on b/src/ortho/oread/tests/if1.on new file mode 100644 index 000000000..16d9b9835 --- /dev/null +++ b/src/ortho/oread/tests/if1.on @@ -0,0 +1,12 @@ +type __ghdl_bool_type is boolean {false, true}; +type __ghdl_integer is signed (32); + +public function test_arg (v : __ghdl_bool_type) return __ghdl_integer +declare +begin + if v then + return __ghdl_integer'[1]; + else + return __ghdl_integer'[0]; + end if; +end; diff --git a/src/ortho/oread/tests/if2.on b/src/ortho/oread/tests/if2.on new file mode 100644 index 000000000..0c38be4b6 --- /dev/null +++ b/src/ortho/oread/tests/if2.on @@ -0,0 +1,11 @@ +type __ghdl_bool_type is boolean {false, true}; +type __ghdl_integer is signed (32); + +public function test_arg (v : __ghdl_bool_type) return __ghdl_integer +declare +begin + if v then + return __ghdl_integer'[1]; + end if; + return __ghdl_integer'[0]; +end; diff --git a/src/ortho/oread/tests/if3.on b/src/ortho/oread/tests/if3.on new file mode 100644 index 000000000..95e5149a1 --- /dev/null +++ b/src/ortho/oread/tests/if3.on @@ -0,0 +1,18 @@ +type __ghdl_bool_type is boolean {false, true}; +type __ghdl_integer is signed (32); + +public function test_arg (v : __ghdl_bool_type) return __ghdl_integer +declare + local var r : __ghdl_integer; +begin + r := __ghdl_integer'[0]; + if v then + declare + local var w : __ghdl_integer; + begin + w := __ghdl_integer'[1]; + r := w; + end; + end if; + return r; +end; diff --git a/src/ortho/oread/tests/if4.on b/src/ortho/oread/tests/if4.on new file mode 100644 index 000000000..33857165e --- /dev/null +++ b/src/ortho/oread/tests/if4.on @@ -0,0 +1,39 @@ +type __ghdl_bool_type is boolean {false, true}; +type __ghdl_integer is signed (32); + +public function test_arg (b1 : __ghdl_bool_type; + b2 : __ghdl_bool_type; + b3 : __ghdl_bool_type) return __ghdl_integer +declare + local var r : __ghdl_integer; +begin + r := __ghdl_integer'[0]; + if b1 then + if b2 then + declare + local var w : __ghdl_integer; + begin + w := __ghdl_integer'[1]; + r := w; + end; + else + if b3 then + declare + local var w : __ghdl_integer; + begin + w := __ghdl_integer'[2]; + r := w; + end; + else + end if; + end if; + else + declare + local var w : __ghdl_integer; + begin + w := __ghdl_integer'[3]; + r := w; + end; + end if; + return r; +end; diff --git a/src/ortho/oread/tests/local1.on b/src/ortho/oread/tests/local1.on new file mode 100644 index 000000000..1c985a2a5 --- /dev/null +++ b/src/ortho/oread/tests/local1.on @@ -0,0 +1,9 @@ +type __ghdl_integer is signed (32); + +public function test_arg (v : __ghdl_integer) return __ghdl_integer +declare + local var w : __ghdl_integer; +begin + w := v; + return w; +end; diff --git a/src/ortho/oread/tests/local2.on b/src/ortho/oread/tests/local2.on new file mode 100644 index 000000000..e06cdb8ea --- /dev/null +++ b/src/ortho/oread/tests/local2.on @@ -0,0 +1,15 @@ +type __ghdl_integer is signed (32); + +public function test_arg (v : __ghdl_integer) return __ghdl_integer +declare + local var w : __ghdl_integer; +begin + w := v; + declare + local var z : __ghdl_integer; + begin + z := v +# w; + w := z; + end; + return w; +end; diff --git a/src/ortho/oread/tests/local3.on b/src/ortho/oread/tests/local3.on new file mode 100644 index 000000000..034bd1846 --- /dev/null +++ b/src/ortho/oread/tests/local3.on @@ -0,0 +1,33 @@ +type __ghdl_integer is signed (32); + +public function test_arg (v : __ghdl_integer) return __ghdl_integer +declare + local var w : __ghdl_integer; +begin + w := v; + declare + local var b1 : __ghdl_integer; + begin + b1 := w; + w := b1; + declare + local var b2 : __ghdl_integer; + begin + b2 := w; + w := b2; + end; + declare + local var b3 : __ghdl_integer; + begin + b3 := w; + w := b3; + end; + end; + declare + local var b4 : __ghdl_integer; + begin + b4 := w; + w := b4; + end; + return w; +end; diff --git a/src/ortho/oread/tests/ra1.on b/src/ortho/oread/tests/ra1.on new file mode 100644 index 000000000..0f5300e66 --- /dev/null +++ b/src/ortho/oread/tests/ra1.on @@ -0,0 +1,8 @@ +TYPE int32 IS SIGNED (32); +TYPE char IS UNSIGNED(8); + +PUBLIC FUNCTION add (a : char; b : char) RETURN int32 +DECLARE +BEGIN + RETURN int32'conv(a) +# int32'conv(b); +END; diff --git a/src/ortho/oread/tests/ra2.on b/src/ortho/oread/tests/ra2.on new file mode 100644 index 000000000..57c6a631a --- /dev/null +++ b/src/ortho/oread/tests/ra2.on @@ -0,0 +1,16 @@ +TYPE float64 IS FLOAT; +TYPE int32 IS SIGNED (32); +TYPE int64 IS SIGNED (64); + +PUBLIC FUNCTION to_int64 (a : int32) RETURN int64 +DECLARE +BEGIN + RETURN int64'conv(a); +END; + +-- Test spill +PUBLIC FUNCTION spill1 (a : int32) RETURN int64 +DECLARE +BEGIN + RETURN int64'conv(a) +# to_int64 (a); +END; diff --git a/src/ortho/oread/tests/ra3.on b/src/ortho/oread/tests/ra3.on new file mode 100644 index 000000000..e135bc83a --- /dev/null +++ b/src/ortho/oread/tests/ra3.on @@ -0,0 +1,9 @@ +TYPE float64 IS FLOAT; +TYPE int32 IS SIGNED (32); +TYPE int64 IS SIGNED (64); + +PUBLIC FUNCTION div (a : int32; b : int32) RETURN float64 +DECLARE +BEGIN + RETURN float64'conv (a /# int32'(1)) /# float64'conv (b /# int32'(1)); +END; diff --git a/src/ortho/oread/tests/repro1.on b/src/ortho/oread/tests/repro1.on new file mode 100644 index 000000000..a26bd387f --- /dev/null +++ b/src/ortho/oread/tests/repro1.on @@ -0,0 +1,21 @@ +TYPE int32 IS SIGNED (32); +TYPE uns32 IS UNSIGNED (32); +TYPE char8 IS UNSIGNED (8); + +TYPE string8 IS ARRAY [uns32] OF char8; +TYPE string_acc IS ACCESS string8; + +TYPE bool IS BOOLEAN {false, true}; + +PRIVATE PROCEDURE puts (s : string_acc); + +PRIVATE PROCEDURE puti32 (n : int32) +DECLARE + TYPE str8x11 IS SUBARRAY string8[11]; + LOCAL VAR s : str8x11; + LOCAL VAR i : uns32; +BEGIN + i := 9; + s[10] := 0; + puts(string_acc'address(s[i...])); +END; diff --git a/src/ortho/oread/tests/ret1.on b/src/ortho/oread/tests/ret1.on new file mode 100644 index 000000000..02137048c --- /dev/null +++ b/src/ortho/oread/tests/ret1.on @@ -0,0 +1,7 @@ +type __ghdl_integer is signed (32); + +public function test_assign () return __ghdl_integer +declare +begin + return __ghdl_integer'[5]; +end; diff --git a/src/ortho/oread/tests/ret2.on b/src/ortho/oread/tests/ret2.on new file mode 100644 index 000000000..5850b5537 --- /dev/null +++ b/src/ortho/oread/tests/ret2.on @@ -0,0 +1,7 @@ +type __ghdl_index_type is unsigned (32); + +public procedure test_ret () +declare +begin + return; +end; diff --git a/src/ortho/oread/tests/ret3.on b/src/ortho/oread/tests/ret3.on new file mode 100644 index 000000000..1a415b086 --- /dev/null +++ b/src/ortho/oread/tests/ret3.on @@ -0,0 +1,8 @@ +type __ghdl_index_type is unsigned (32); + +public procedure test_ret () +declare +begin + return; + return; +end; diff --git a/src/ortho/oread/tests/ret4.on b/src/ortho/oread/tests/ret4.on new file mode 100644 index 000000000..267511479 --- /dev/null +++ b/src/ortho/oread/tests/ret4.on @@ -0,0 +1,8 @@ +type __ghdl_integer is signed (32); + +public function test_assign () return __ghdl_integer +declare +begin + return __ghdl_integer'[5]; + return __ghdl_integer'[4]; +end; diff --git a/src/ortho/oread/tests/run_case1.on b/src/ortho/oread/tests/run_case1.on new file mode 100644 index 000000000..d457e59ba --- /dev/null +++ b/src/ortho/oread/tests/run_case1.on @@ -0,0 +1,13 @@ +type __ghdl_index_type is unsigned (32); +type __ghdl_bool_type is boolean {false, true}; + +public function main (a : __ghdl_index_type) return __ghdl_index_type +declare +begin + case a is + when 1 => + return 2; + when default => + return 0; + end case; +end; diff --git a/src/ortho/oread/tests/run_case2.on b/src/ortho/oread/tests/run_case2.on new file mode 100644 index 000000000..6707f4f96 --- /dev/null +++ b/src/ortho/oread/tests/run_case2.on @@ -0,0 +1,15 @@ +type __ghdl_index_type is unsigned (32); +type __ghdl_bool_type is boolean {false, true}; + +public function main (a : __ghdl_index_type) return __ghdl_index_type +declare +begin + case a is + when 1 => + return 2; + when 3 ... 5 => + return 1; + when default => + return 0; + end case; +end; diff --git a/src/ortho/oread/tests/run_case3.on b/src/ortho/oread/tests/run_case3.on new file mode 100644 index 000000000..ff5d5beee --- /dev/null +++ b/src/ortho/oread/tests/run_case3.on @@ -0,0 +1,15 @@ +type __ghdl_index_type is unsigned (32); +type __ghdl_bool_type is boolean {false, true}; + +public function main (a : __ghdl_index_type) return __ghdl_index_type +declare +begin + case a is + when 1, 2, 7 => + return 2; + when 3 ... 5 => + return 1; + when default => + return 0; + end case; +end; diff --git a/src/ortho/oread/tests/run_case4.on b/src/ortho/oread/tests/run_case4.on new file mode 100644 index 000000000..ea19b62a5 --- /dev/null +++ b/src/ortho/oread/tests/run_case4.on @@ -0,0 +1,15 @@ +type __ghdl_index_type is unsigned (32); +type __ghdl_bool_type is boolean {false, true}; + +public function main (a : __ghdl_index_type) return __ghdl_index_type +declare +begin + case a is + when 1, 2, 7 => + when 3 ... 5 => + return 1; + when default => + return 0; + end case; + return 4; +end; diff --git a/src/ortho/oread/tests/run_case5.on b/src/ortho/oread/tests/run_case5.on new file mode 100644 index 000000000..6391bb315 --- /dev/null +++ b/src/ortho/oread/tests/run_case5.on @@ -0,0 +1,13 @@ +type __ghdl_index_type is unsigned (32); +type __ghdl_bool_type is boolean {false, true}; + +public function main (a : __ghdl_index_type) return __ghdl_index_type +declare +begin + case __ghdl_bool_type'(a > 10) is + when __ghdl_bool_type'[true] => + when __ghdl_bool_type'[false] => + return 1; + end case; + return 4; +end; diff --git a/src/ortho/oread/tests/run_case6.on b/src/ortho/oread/tests/run_case6.on new file mode 100644 index 000000000..3e33ff6f4 --- /dev/null +++ b/src/ortho/oread/tests/run_case6.on @@ -0,0 +1,19 @@ +type __ghdl_index_type is unsigned (32); +type __ghdl_bool_type is boolean {false, true}; + +public function main (a : __ghdl_index_type) return __ghdl_index_type +declare + local var b : __ghdl_index_type; +begin + case a is + when 10 ... 15 => + case __ghdl_bool_type'(a > 10) is + when __ghdl_bool_type'[true] => + b := 5; + when __ghdl_bool_type'[false] => + end case; + when default => + return 4; + end case; + return 5; +end; diff --git a/src/ortho/oread/tests/run_case7.on b/src/ortho/oread/tests/run_case7.on new file mode 100644 index 000000000..708029c22 --- /dev/null +++ b/src/ortho/oread/tests/run_case7.on @@ -0,0 +1,14 @@ +type __ghdl_index_type is unsigned (32); +type __ghdl_bool_type is boolean {false, true}; + +public function main (a : __ghdl_index_type) return __ghdl_index_type +declare + local var b : __ghdl_index_type; +begin + case __ghdl_bool_type'(a > 10) is + when __ghdl_bool_type'[true] => + b := 5; + when __ghdl_bool_type'[false] => + end case; + return 5; +end; diff --git a/src/ortho/oread/tests/run_declare.on b/src/ortho/oread/tests/run_declare.on new file mode 100644 index 000000000..b0af18c9f --- /dev/null +++ b/src/ortho/oread/tests/run_declare.on @@ -0,0 +1,16 @@ +type __ghdl_int is unsigned (32); + +public function main (a : __ghdl_int) return __ghdl_int +declare + local var b : __ghdl_int; + local var z : __ghdl_int; +begin + b := a; + declare + local var c : __ghdl_int; + begin + c := b; + z := c; + end; + return z +# 1; +end; diff --git a/src/ortho/oread/tests/run_declare2.on b/src/ortho/oread/tests/run_declare2.on new file mode 100644 index 000000000..ae38b660d --- /dev/null +++ b/src/ortho/oread/tests/run_declare2.on @@ -0,0 +1,21 @@ +type __ghdl_int is unsigned (32); + +public function main (a : __ghdl_int) return __ghdl_int +declare + local var b : __ghdl_int; + local var z : __ghdl_int; +begin + b := a; + declare + local var c : __ghdl_int; + begin + c := b; + end; + declare + local var d : __ghdl_int; + begin + d := b; + z := d; + end; + return z +# 1; +end; diff --git a/src/ortho/oread/tests/run_declare3.c b/src/ortho/oread/tests/run_declare3.c new file mode 100644 index 000000000..cccfdb7cb --- /dev/null +++ b/src/ortho/oread/tests/run_declare3.c @@ -0,0 +1,17 @@ +int main1 (int a) +{ + int b; + int z; + + b = a; + + { + int g; + int c; + + c = b; + g = c; + z = g + c; + } + return z + 1; +} diff --git a/src/ortho/oread/tests/run_declare3.on b/src/ortho/oread/tests/run_declare3.on new file mode 100644 index 000000000..85684a249 --- /dev/null +++ b/src/ortho/oread/tests/run_declare3.on @@ -0,0 +1,18 @@ +type __ghdl_int is unsigned (32); + +public function main (a : __ghdl_int) return __ghdl_int +declare + local var b : __ghdl_int; + local var z : __ghdl_int; +begin + b := a; + declare + local var g : __ghdl_int; + local var c : __ghdl_int; + begin + c := b; + g := c; + z := g +# c; + end; + return z +# 1; +end; diff --git a/src/ortho/oread/tests/run_func1.on b/src/ortho/oread/tests/run_func1.on new file mode 100644 index 000000000..d0ea4e876 --- /dev/null +++ b/src/ortho/oread/tests/run_func1.on @@ -0,0 +1,16 @@ +TYPE __ghdl_index_type IS UNSIGNED (32); + +PUBLIC FUNCTION inc (a : __ghdl_index_type) RETURN __ghdl_index_type; + +PUBLIC FUNCTION inc (a : __ghdl_index_type) RETURN __ghdl_index_type +DECLARE +BEGIN + RETURN a +# 1; +END; + +PUBLIC FUNCTION main (a : __ghdl_index_type) RETURN __ghdl_index_type +DECLARE +BEGIN + RETURN inc (a); +END; + diff --git a/src/ortho/oread/tests/run_gvar.on b/src/ortho/oread/tests/run_gvar.on new file mode 100644 index 000000000..4efa46bca --- /dev/null +++ b/src/ortho/oread/tests/run_gvar.on @@ -0,0 +1,10 @@ +TYPE __ghdl_index_type IS UNSIGNED (32); + +PUBLIC VAR v : __ghdl_index_type; + +PUBLIC FUNCTION main (a : __ghdl_index_type) RETURN __ghdl_index_type +DECLARE +BEGIN + v := a; + RETURN v +# 1; +END; diff --git a/src/ortho/oread/tests/run_id.on b/src/ortho/oread/tests/run_id.on new file mode 100644 index 000000000..81581bf3a --- /dev/null +++ b/src/ortho/oread/tests/run_id.on @@ -0,0 +1,7 @@ +TYPE __ghdl_index_type IS UNSIGNED (32); + +PUBLIC FUNCTION main (a : __ghdl_index_type) RETURN __ghdl_index_type +DECLARE +BEGIN + RETURN a; +END; diff --git a/src/ortho/oread/tests/run_idx.on b/src/ortho/oread/tests/run_idx.on new file mode 100644 index 000000000..9e12acbd7 --- /dev/null +++ b/src/ortho/oread/tests/run_idx.on @@ -0,0 +1,17 @@ +type __ghdl_index_type is unsigned (32); +type __ghdl_bool_type is boolean {false, true}; + +type __ghdl_char is unsigned (8); + +type __ghdl_chararray is array [__ghdl_index_type] of __ghdl_index_type; + +private constant TAB : subarray __ghdl_chararray[__ghdl_index_type'[10] + ]; + +constant TAB := {65, 66, 67, 68, 69, 48, 49, 50, 51, 52 }; + +public function main (a : __ghdl_index_type) return __ghdl_index_type +declare +begin + return TAB[a]; +end; diff --git a/src/ortho/oread/tests/run_if.on b/src/ortho/oread/tests/run_if.on new file mode 100644 index 000000000..d9ea8484a --- /dev/null +++ b/src/ortho/oread/tests/run_if.on @@ -0,0 +1,12 @@ +type __ghdl_index_type is unsigned (32); +type __ghdl_bool_type is boolean {false, true}; + +public function main (a : __ghdl_index_type) return __ghdl_index_type +declare +begin + if __ghdl_bool_type'(a > 5) then + return a +# 1; + else + return a -# 1; + end if; +end; diff --git a/src/ortho/oread/tests/run_neg.on b/src/ortho/oread/tests/run_neg.on new file mode 100644 index 000000000..d7ec2dcc0 --- /dev/null +++ b/src/ortho/oread/tests/run_neg.on @@ -0,0 +1,7 @@ +type __ghdl_index_type is signed (32); + +public function main (a : __ghdl_index_type) return __ghdl_index_type +declare +begin + return -a; +end; diff --git a/src/ortho/oread/tests/run_not.on b/src/ortho/oread/tests/run_not.on new file mode 100644 index 000000000..61480c362 --- /dev/null +++ b/src/ortho/oread/tests/run_not.on @@ -0,0 +1,7 @@ +TYPE __ghdl_index_type IS UNSIGNED (32); + +PUBLIC FUNCTION main (a : __ghdl_index_type) RETURN __ghdl_index_type +DECLARE +BEGIN + RETURN NOT a; +END; diff --git a/src/ortho/oread/tests/run_plus.on b/src/ortho/oread/tests/run_plus.on new file mode 100644 index 000000000..0465df200 --- /dev/null +++ b/src/ortho/oread/tests/run_plus.on @@ -0,0 +1,7 @@ +TYPE __ghdl_index_type IS UNSIGNED (32); + +PUBLIC FUNCTION main (a : __ghdl_index_type) RETURN __ghdl_index_type +DECLARE +BEGIN + RETURN a +# 1; +END; diff --git a/src/ortho/oread/tests/run_plus64.on b/src/ortho/oread/tests/run_plus64.on new file mode 100644 index 000000000..beea5a932 --- /dev/null +++ b/src/ortho/oread/tests/run_plus64.on @@ -0,0 +1,7 @@ +TYPE __ghdl_index_type IS UNSIGNED (64); + +PUBLIC FUNCTION main (a : __ghdl_index_type) RETURN __ghdl_index_type +DECLARE +BEGIN + RETURN a +# 1; +END; diff --git a/src/ortho/oread/tests/size1.on b/src/ortho/oread/tests/size1.on new file mode 100644 index 000000000..8ac5aeca1 --- /dev/null +++ b/src/ortho/oread/tests/size1.on @@ -0,0 +1,9 @@ +-- internal declarations, part 1 + +type __ghdl_size_type is unsigned (32); + +type __ghdl_index_type is unsigned (32); + +public constant size1 : __ghdl_size_type; + +constant size1 := __ghdl_size_type'sizeof (__ghdl_index_type); diff --git a/src/ortho/oread/tests/smod.on b/src/ortho/oread/tests/smod.on new file mode 100644 index 000000000..152f69c73 --- /dev/null +++ b/src/ortho/oread/tests/smod.on @@ -0,0 +1,32 @@ +type int is signed (32); + +public function smod (a : int; b : int) return int +declare +begin + return a mod# b; +end; + +public function do_m3_m3 () return int +declare +begin + return -3 mod# -3; +end; + +public function do_m3_m2 () return int +declare +begin + return -3 mod# -2; +end; + +public function do_11_5 () return int +declare +begin + return 11 mod# 5; +end; + +public function do_m11_5 () return int +declare +begin + return -11 mod# 5; +end; + diff --git a/src/ortho/oread/tests/struct1.on b/src/ortho/oread/tests/struct1.on new file mode 100644 index 000000000..f6a0ad86b --- /dev/null +++ b/src/ortho/oread/tests/struct1.on @@ -0,0 +1,16 @@ +TYPE __ghdl_index_type IS UNSIGNED (32); + +TYPE __ghdl_char IS UNSIGNED (8); + +TYPE __ghdl_chararray IS ARRAY [__ghdl_index_type] OF __ghdl_char; + +TYPE __ghdl_char_ptr IS ACCESS __ghdl_chararray; + +TYPE __ghdl_char_ptr_array IS ARRAY [__ghdl_index_type] OF __ghdl_char_ptr; + +TYPE __ghdl_str_len IS RECORD + len: __ghdl_index_type; + str: __ghdl_char_ptr; +END RECORD; + +PUBLIC VAR var1 : __ghdl_str_len; diff --git a/src/ortho/oread/tests/struct2.on b/src/ortho/oread/tests/struct2.on new file mode 100644 index 000000000..70200cd12 --- /dev/null +++ b/src/ortho/oread/tests/struct2.on @@ -0,0 +1,25 @@ +type __ghdl_rti_u8 is unsigned (8); + +type __ghdl_rti_common is record + mode: __ghdl_rti_u8; +end record; + +type __ghdl_rti_access is access __ghdl_rti_common; + +type __ghdl_component_link_type is record; + +type __ghdl_component_link_acc is access __ghdl_component_link_type; + +type __ghdl_entity_link_type is record + rti: __ghdl_rti_access; + parent: __ghdl_component_link_acc; +end record; + +type __ghdl_entity_link_acc is access __ghdl_entity_link_type; + +type __ghdl_component_link_type is record + stmt: __ghdl_rti_access; +end record; + +public var var1 : __ghdl_component_link_type; +public var var2 : __ghdl_component_link_acc; diff --git a/src/ortho/oread/tests/struct3.on b/src/ortho/oread/tests/struct3.on new file mode 100644 index 000000000..b4dc6586d --- /dev/null +++ b/src/ortho/oread/tests/struct3.on @@ -0,0 +1,41 @@ +type __ghdl_rtik is enum {__ghdl_rtik_top = 0, __ghdl_rtik_library = 1, + __ghdl_rtik_package = 2, __ghdl_rtik_package_body = 3, + __ghdl_rtik_entity = 4, __ghdl_rtik_architecture = 5, + __ghdl_rtik_process = 6, __ghdl_rtik_block = 7, + __ghdl_rtik_if_generate = 8, __ghdl_rtik_for_generate = 9, + __ghdl_rtik_instance = 10, __ghdl_rtik_constant = 11, + __ghdl_rtik_iterator = 12, __ghdl_rtik_variable = 13, + __ghdl_rtik_signal = 14, __ghdl_rtik_file = 15, __ghdl_rtik_port = 16, + __ghdl_rtik_generic = 17, __ghdl_rtik_alias = 18, __ghdl_rtik_guard = 19, + __ghdl_rtik_component = 20, __ghdl_rtik_attribute = 21, + __ghdl_rtik_type_b2 = 22, __ghdl_rtik_type_e8 = 23, + __ghdl_rtik_type_e32 = 24, __ghdl_rtik_type_i32 = 25, + __ghdl_rtik_type_i64 = 26, __ghdl_rtik_type_f64 = 27, + __ghdl_rtik_type_p32 = 28, __ghdl_rtik_type_p64 = 29, + __ghdl_rtik_type_access = 30, __ghdl_rtik_type_array = 31, + __ghdl_rtik_type_record = 32, __ghdl_rtik_type_file = 33, + __ghdl_rtik_subtype_scalar = 34, __ghdl_rtik_subtype_array = 35, + __ghdl_rtik_subtype_unconstrained_array = 36, + __ghdl_rtik_subtype_record = 37, __ghdl_rtik_subtype_access = 38, + __ghdl_rtik_type_protected = 39, __ghdl_rtik_element = 40, + __ghdl_rtik_unit64 = 41, __ghdl_rtik_unitptr = 42, + __ghdl_rtik_attribute_transaction = 43, __ghdl_rtik_attribute_quiet = 44, + __ghdl_rtik_attribute_stable = 45, __ghdl_rtik_psl_assert = 46, + __ghdl_rtik_error = 47}; + +type __ghdl_rti_depth is unsigned (8); + +type __ghdl_rti_u8 is unsigned (8); + +type __ghdl_rti_common is record + kind: __ghdl_rtik; + depth: __ghdl_rti_depth; + mode: __ghdl_rti_u8; + max_depth: __ghdl_rti_depth; +end record; + +type __ghdl_rti_access is access __ghdl_rti_common; + +public var st3p : __ghdl_rti_access; + +public var st3 : __ghdl_rti_common; diff --git a/src/ortho/oread/tests/struct4.on b/src/ortho/oread/tests/struct4.on new file mode 100644 index 000000000..6b027185d --- /dev/null +++ b/src/ortho/oread/tests/struct4.on @@ -0,0 +1,10 @@ +TYPE __ghdl_index_type IS UNSIGNED (32); + +TYPE __ghdl_char IS UNSIGNED (8); + +TYPE struct4 IS RECORD + i: __ghdl_index_type; + c : __ghdl_char; +END RECORD; + +PUBLIC VAR var1 : struct4; diff --git a/src/ortho/oread/tests/struct5.on b/src/ortho/oread/tests/struct5.on new file mode 100644 index 000000000..31661d368 --- /dev/null +++ b/src/ortho/oread/tests/struct5.on @@ -0,0 +1,10 @@ +TYPE __ghdl_index_type IS UNSIGNED (32); + +TYPE __ghdl_char IS UNSIGNED (8); + +TYPE struct5 IS RECORD + c : __ghdl_char; + i: __ghdl_index_type; +END RECORD; + +PUBLIC VAR var1 : struct5; diff --git a/src/ortho/oread/tests/struct6.on b/src/ortho/oread/tests/struct6.on new file mode 100644 index 000000000..7cb5e4619 --- /dev/null +++ b/src/ortho/oread/tests/struct6.on @@ -0,0 +1,18 @@ +TYPE float IS FLOAT; + +TYPE __ghdl_index_type IS UNSIGNED (32); + +TYPE __ghdl_char IS UNSIGNED (8); + +TYPE struct6 IS RECORD + f : float; + i: __ghdl_char; +END RECORD; + +PUBLIC VAR var1 : struct6; + +TYPE struct6_arr IS ARRAY [__ghdl_index_type] OF struct6; + +TYPE struct6x2 IS SUBARRAY struct6_arr[2]; + +PUBLIC VAR var2 : struct6x2;
\ No newline at end of file diff --git a/src/ortho/oread/tests/struct7.on b/src/ortho/oread/tests/struct7.on new file mode 100644 index 000000000..9654bc755 --- /dev/null +++ b/src/ortho/oread/tests/struct7.on @@ -0,0 +1,14 @@ +TYPE float IS FLOAT; + +TYPE __ghdl_index_type IS UNSIGNED (32); + +TYPE __ghdl_char IS UNSIGNED (8); +TYPE string IS ARRAY [__ghdl_index_type] OF __ghdl_char; +TYPE str7 IS SUBARRAY string[7]; + +TYPE struct7 IS RECORD + f : float; + s : str7; +END RECORD; + +PUBLIC VAR var1 : struct7; diff --git a/src/ortho/oread/tests/structref1.on b/src/ortho/oread/tests/structref1.on new file mode 100644 index 000000000..dfa903abe --- /dev/null +++ b/src/ortho/oread/tests/structref1.on @@ -0,0 +1,22 @@ +type __ghdl_index_type is unsigned (32); + +type __ghdl_char is unsigned (8); + +type __ghdl_chararray is array [__ghdl_index_type] of __ghdl_char; + +type __ghdl_char_ptr is access __ghdl_chararray; + +type __ghdl_char_ptr_array is array [__ghdl_index_type] of __ghdl_char_ptr; + +type __ghdl_str_len is record + len: __ghdl_index_type; + str: __ghdl_char_ptr; +end record; + +public var var1 : __ghdl_str_len; + +public function get_len () return __ghdl_index_type +declare +begin + return var1.len; +end; diff --git a/src/ortho/oread/tests/structref2.on b/src/ortho/oread/tests/structref2.on new file mode 100644 index 000000000..1090fe799 --- /dev/null +++ b/src/ortho/oread/tests/structref2.on @@ -0,0 +1,22 @@ +type __ghdl_index_type is unsigned (32); + +type __ghdl_char is unsigned (8); + +type __ghdl_chararray is array [__ghdl_index_type] of __ghdl_char; + +type __ghdl_char_ptr is access __ghdl_chararray; + +type __ghdl_char_ptr_array is array [__ghdl_index_type] of __ghdl_char_ptr; + +type __ghdl_str_len is record + str: __ghdl_char_ptr; + len: __ghdl_index_type; +end record; + +public var var1 : __ghdl_str_len; + +public function get_len () return __ghdl_index_type +declare +begin + return var1.len; +end; diff --git a/src/ortho/oread/tests/test_alloca.on b/src/ortho/oread/tests/test_alloca.on new file mode 100644 index 000000000..1b402c07c --- /dev/null +++ b/src/ortho/oread/tests/test_alloca.on @@ -0,0 +1,22 @@ +type __ghdl_size_type is unsigned (32); + +type __ghdl_index_type is unsigned (32); + +type __ghdl_integer is signed (32); + +type integer_array is array[__ghdl_index_type] of __ghdl_integer; +type integer_arr_ptr is access integer_array; + +public procedure test_alloca () +declare + local var len : __ghdl_size_type; +begin + len := __ghdl_size_type'[16]; + declare + local var ptr : integer_arr_ptr; + begin + ptr := integer_arr_ptr'alloca (len); + end; + len := __ghdl_size_type'[0]; +end; + diff --git a/src/ortho/oread/tests/test_alloca1.on b/src/ortho/oread/tests/test_alloca1.on new file mode 100644 index 000000000..06d4a2d71 --- /dev/null +++ b/src/ortho/oread/tests/test_alloca1.on @@ -0,0 +1,20 @@ +type __ghdl_size_type is unsigned (32); + +type __ghdl_index_type is unsigned (32); + +type __ghdl_integer is signed (32); + +type integer_array is array[__ghdl_index_type] of __ghdl_integer; +type integer_arr_ptr is access integer_array; + +public procedure test_alloca () +declare + local var len : __ghdl_size_type; + local var ptr : integer_arr_ptr; +begin + len := __ghdl_size_type'[16]; + ptr := integer_arr_ptr'alloca (len); + len := __ghdl_size_type'[0]; + return; +end; + diff --git a/src/ortho/oread/tests/test_assign.on b/src/ortho/oread/tests/test_assign.on new file mode 100644 index 000000000..f52091e53 --- /dev/null +++ b/src/ortho/oread/tests/test_assign.on @@ -0,0 +1,19 @@ +TYPE __ghdl_size_type IS UNSIGNED (32); + +TYPE __ghdl_index_type IS UNSIGNED (32); + +TYPE __ghdl_integer IS SIGNED (32); + +PUBLIC VAR gbl : __ghdl_integer; + +PUBLIC PROCEDURE test_assign () +DECLARE +BEGIN + gbl := __ghdl_integer'[5]; +END; + +PUBLIC PROCEDURE main () +DECLARE +BEGIN + test_assign (); +END; diff --git a/src/ortho/oread/tests/test_assign64.on b/src/ortho/oread/tests/test_assign64.on new file mode 100644 index 000000000..89e3c3996 --- /dev/null +++ b/src/ortho/oread/tests/test_assign64.on @@ -0,0 +1,22 @@ +TYPE __ghdl_integer IS SIGNED (64); + +PUBLIC VAR gbl : __ghdl_integer; + +PUBLIC PROCEDURE test_assign (v : __ghdl_integer) +DECLARE +BEGIN + gbl := __ghdl_integer'[123456] -# v; +END; + +PUBLIC PROCEDURE test_assign2 (v : __ghdl_integer) +DECLARE +BEGIN + gbl := __ghdl_integer'[891234567890] +# v; +END; + +PUBLIC PROCEDURE main () +DECLARE +BEGIN + test_assign (12); + test_assign (5); +END; diff --git a/src/ortho/oread/tests/test_dup.on b/src/ortho/oread/tests/test_dup.on new file mode 100644 index 000000000..82a85f8a2 --- /dev/null +++ b/src/ortho/oread/tests/test_dup.on @@ -0,0 +1,19 @@ +type __ghdl_size_type is unsigned (32); + +type __ghdl_index_type is unsigned (32); + +type __ghdl_integer is signed (32); + +type integer_array is array[__ghdl_index_type] of __ghdl_integer; +type integer_arr_ptr is access integer_array; + +public procedure test_alloca () +declare +begin +end; + +public procedure test_alloca () +declare +begin +end; + diff --git a/src/ortho/oread/tests/test_incomp.on b/src/ortho/oread/tests/test_incomp.on new file mode 100644 index 000000000..3cd631562 --- /dev/null +++ b/src/ortho/oread/tests/test_incomp.on @@ -0,0 +1,17 @@ +type int is signed (32); +type bool is boolean { false, true }; + +type incomp_ptr is access; +type rec is record + nxt : incomp_ptr; + val : int; +end record; + +type incomp_ptr is access rec; + +public function eq (l : incomp_ptr; r : incomp_ptr) return bool +declare +begin + return bool'(l.all.val = r.all.val); +end; + diff --git a/src/ortho/oread/tests/test_init.on b/src/ortho/oread/tests/test_init.on new file mode 100644 index 000000000..b631e16e5 --- /dev/null +++ b/src/ortho/oread/tests/test_init.on @@ -0,0 +1,36 @@ +TYPE __ghdl_size_type IS UNSIGNED (32); + +TYPE __ghdl_index_type IS UNSIGNED (32); + +TYPE __ghdl_char IS UNSIGNED (8); + +TYPE __ghdl_chararray IS ARRAY [__ghdl_index_type] OF __ghdl_char; + +TYPE __ghdl_char_ptr IS ACCESS __ghdl_chararray; + +TYPE __ghdl_str_len IS RECORD + len: __ghdl_index_type; + str: __ghdl_char_ptr; +END RECORD; + +PRIVATE VAR c : __ghdl_str_len; + +CONSTANT c := __ghdl_str_len'[DEFAULT]; + +PUBLIC VAR c2 : __ghdl_str_len; + +CONSTANT c2 := { __ghdl_index_type'[1], __ghdl_char_ptr'[DEFAULT]}; + + + +TYPE rec1_type IS RECORD; + +TYPE rec1_acc IS ACCESS rec1_type; + +TYPE rec1_type IS RECORD + len: __ghdl_index_type; +END RECORD; + +PRIVATE VAR c3 : rec1_type; + +CONSTANT c3 := rec1_type'[DEFAULT]; diff --git a/src/ortho/oread/tests/test_init2.on b/src/ortho/oread/tests/test_init2.on new file mode 100644 index 000000000..cb80c7a92 --- /dev/null +++ b/src/ortho/oread/tests/test_init2.on @@ -0,0 +1,18 @@ +TYPE std__standard__bit IS BOOLEAN {C_0, C_1}; + +--F /Users/gingold/devel/ghdl-updates.git/testsuite/gna/simple1/simple1.vhdl + +-- architecture behav + +TYPE work__simple1__ARCH__behav__INSTTYPE IS RECORD; + +TYPE work__simple1__ARCH__behav__INSTPTR IS ACCESS + work__simple1__ARCH__behav__INSTTYPE; + +TYPE work__simple1__ARCH__behav__INSTTYPE IS RECORD + s_VAL: std__standard__bit; +END RECORD; + +PRIVATE CONSTANT INST000001 : work__simple1__ARCH__behav__INSTTYPE; + +-- CONSTANT INST000001 := { std__standard__bit'[C_0]}; diff --git a/src/ortho/oread/tests/test_init3.on b/src/ortho/oread/tests/test_init3.on new file mode 100644 index 000000000..40bf75782 --- /dev/null +++ b/src/ortho/oread/tests/test_init3.on @@ -0,0 +1,24 @@ +TYPE std__standard__bit IS BOOLEAN {C_0, C_1}; + +--F /Users/gingold/devel/ghdl-updates.git/testsuite/gna/simple1/simple1.vhdl + +-- architecture behav + +TYPE work__simple1__ARCH__behav__INSTTYPE IS RECORD; + +TYPE work__simple1__ARCH__behav__INSTPTR IS ACCESS + work__simple1__ARCH__behav__INSTTYPE; + +PRIVATE VAR v_acc : work__simple1__ARCH__behav__INSTPTR; + +TYPE work__simple1__ARCH__behav__INSTTYPE IS RECORD + s_VAL: std__standard__bit; +END RECORD; +-- f : work__simple1__ARCH__behav__INSTPTR; + + +PRIVATE VAR v_inst : work__simple1__ARCH__behav__INSTTYPE; + +PRIVATE CONSTANT INST000001 : work__simple1__ARCH__behav__INSTTYPE; + +CONSTANT INST000001 := { std__standard__bit'[C_0]}; diff --git a/src/ortho/oread/tests/test_varglb.on b/src/ortho/oread/tests/test_varglb.on new file mode 100644 index 000000000..50d97b739 --- /dev/null +++ b/src/ortho/oread/tests/test_varglb.on @@ -0,0 +1,7 @@ +type __ghdl_size_type is unsigned (32); + +type __ghdl_index_type is unsigned (32); + +type __ghdl_integer is signed (32); + +public var gbl : __ghdl_integer; diff --git a/src/ortho/oread/tests/type1.on b/src/ortho/oread/tests/type1.on new file mode 100644 index 000000000..9e6732665 --- /dev/null +++ b/src/ortho/oread/tests/type1.on @@ -0,0 +1,5 @@ +-- internal declarations, part 1 + +type __ghdl_size_type is unsigned (32); + +type __ghdl_index_type is unsigned (32); diff --git a/src/ortho/oread/tests/unaggr1.on b/src/ortho/oread/tests/unaggr1.on new file mode 100644 index 000000000..ab14f53d4 --- /dev/null +++ b/src/ortho/oread/tests/unaggr1.on @@ -0,0 +1,16 @@ +type __ghdl_index_type is unsigned (32); + +type __ghdl_char is unsigned (8); + +type __ghdl_ptr is access __ghdl_char; + +type __ghdl_rti_loc is union + offset: __ghdl_char; + address: __ghdl_ptr; +end union; + +public constant var1 : __ghdl_rti_loc; +constant var1 := {.address = __ghdl_ptr'[null]}; + +public constant var2 : __ghdl_rti_loc; +constant var2 := {.offset = __ghdl_char'[0]}; diff --git a/src/ortho/oread/tests/union1.on b/src/ortho/oread/tests/union1.on new file mode 100644 index 000000000..a01d42758 --- /dev/null +++ b/src/ortho/oread/tests/union1.on @@ -0,0 +1,12 @@ +TYPE __ghdl_index_type IS UNSIGNED (32); + +TYPE __ghdl_char IS UNSIGNED (8); + +TYPE __ghdl_ptr IS ACCESS __ghdl_char; + +TYPE __ghdl_rti_loc IS UNION + offset: __ghdl_char; + address: __ghdl_ptr; +END UNION; + +PUBLIC VAR var1 : __ghdl_rti_loc; diff --git a/src/ortho/oread/tests/union2.on b/src/ortho/oread/tests/union2.on new file mode 100644 index 000000000..6c8177987 --- /dev/null +++ b/src/ortho/oread/tests/union2.on @@ -0,0 +1,14 @@ +TYPE __ghdl_index_type IS UNSIGNED (32); + +TYPE __ghdl_char IS UNSIGNED (8); + +TYPE __ghdl_ptr IS ACCESS __ghdl_char; + +TYPE __ghdl_rti_loc IS UNION + S0: RECORD + offset: __ghdl_char; + address: __ghdl_ptr; + END RECORD; +END UNION; + +PUBLIC VAR var1 : __ghdl_rti_loc; diff --git a/src/ortho/oread/tests/union3.on b/src/ortho/oread/tests/union3.on new file mode 100644 index 000000000..afad26d27 --- /dev/null +++ b/src/ortho/oread/tests/union3.on @@ -0,0 +1,27 @@ +TYPE __ghdl_index_type IS UNSIGNED (32); + +TYPE __ghdl_char IS UNSIGNED (8); + +TYPE __ghdl_ptr IS ACCESS __ghdl_char; + +TYPE __ghdl_rti_loc IS UNION + offset: __ghdl_char; + address: __ghdl_ptr; +END UNION; + +TYPE rec1 IS RECORD + f1: __ghdl_char; + f2: __ghdl_rti_loc; + f3: __ghdl_index_type; +END RECORD; + +PUBLIC VAR var1 : rec1; + +PUBLIC FUNCTION main (a : __ghdl_index_type) RETURN __ghdl_index_type +DECLARE +BEGIN + var1.f3 := 3; + var1.f1 := 1; + var1.f2.offset := 2; + RETURN 0; +END; diff --git a/src/ortho/oread/tests/var1.on b/src/ortho/oread/tests/var1.on new file mode 100644 index 000000000..7f3e9fc18 --- /dev/null +++ b/src/ortho/oread/tests/var1.on @@ -0,0 +1,8 @@ +-- internal declarations, part 1 + +TYPE __ghdl_size_type IS UNSIGNED (32); + +TYPE __ghdl_index_type IS UNSIGNED (32); + +PUBLIC CONSTANT size1 : __ghdl_size_type; +CONSTANT size1 := __ghdl_size_type'[2];
\ No newline at end of file diff --git a/src/ortho/oread/tests/var2.on b/src/ortho/oread/tests/var2.on new file mode 100644 index 000000000..b82073a63 --- /dev/null +++ b/src/ortho/oread/tests/var2.on @@ -0,0 +1,5 @@ +-- internal declarations, part 1 + +TYPE __ghdl_size_type IS UNSIGNED (32); + +PUBLIC VAR size1 : __ghdl_size_type; diff --git a/src/ortho/oread/tests/var_signed.on b/src/ortho/oread/tests/var_signed.on new file mode 100644 index 000000000..2acca3af6 --- /dev/null +++ b/src/ortho/oread/tests/var_signed.on @@ -0,0 +1,5 @@ +-- internal declarations, part 1 + +TYPE integer IS SIGNED (32); + +PUBLIC VAR v1 : integer; diff --git a/src/ortho/oread/tests/vla.on b/src/ortho/oread/tests/vla.on new file mode 100644 index 000000000..eb516f218 --- /dev/null +++ b/src/ortho/oread/tests/vla.on @@ -0,0 +1,9 @@ +type __ghdl_int is signed (32); + +public function vla (a : __ghdl_int) return __ghdl_int +declare + local var b : __ghdl_int; +begin + b := a; + return b; +end; diff --git a/src/vhdl/canon.adb b/src/vhdl/canon.adb index a23bbeb3f..577ff9e8f 100644 --- a/src/vhdl/canon.adb +++ b/src/vhdl/canon.adb @@ -2592,6 +2592,7 @@ package body Canon is function Canon_Package_Instantiation_Declaration (Decl : Iir) return Iir is Pkg : constant Iir := Get_Uninstantiated_Package_Decl (Decl); + Bod : Iir; begin -- Canon map aspect. Set_Generic_Map_Aspect_Chain @@ -2600,79 +2601,25 @@ package body Canon is (Get_Generic_Chain (Decl), Get_Generic_Map_Aspect_Chain (Decl), Decl)); - if Get_Macro_Expanded_Flag (Pkg) then - declare - New_Decl : Iir; - New_Hdr : Iir; - begin - -- Replace package instantiation by the macro-expanded - -- generic-mapped package. - -- Use move semantics. - -- FIXME: adjust Parent. - New_Decl := Create_Iir (Iir_Kind_Package_Declaration); - Location_Copy (New_Decl, Decl); - Set_Parent (New_Decl, Get_Parent (Decl)); - Set_Identifier (New_Decl, Get_Identifier (Decl)); - Set_Need_Body (New_Decl, Get_Need_Body (Pkg)); - - New_Hdr := Create_Iir (Iir_Kind_Package_Header); - Set_Package_Header (New_Decl, New_Hdr); - Location_Copy (New_Hdr, Get_Package_Header (Pkg)); - Set_Generic_Chain (New_Hdr, Get_Generic_Chain (Decl)); - Set_Generic_Map_Aspect_Chain - (New_Hdr, Get_Generic_Map_Aspect_Chain (Decl)); - Set_Generic_Chain (Decl, Null_Iir); - Set_Generic_Map_Aspect_Chain (Decl, Null_Iir); - - Set_Declaration_Chain (New_Decl, Get_Declaration_Chain (Decl)); - Set_Declaration_Chain (Decl, Null_Iir); - Set_Chain (New_Decl, Get_Chain (Decl)); - Set_Chain (Decl, Null_Iir); - - Set_Package_Origin (New_Decl, Decl); - return New_Decl; - end; - else - return Decl; + -- Generate the body now. + -- Note: according to the LRM, if the instantiation occurs within a + -- package, the body of the instance should be appended to the package + -- body. + -- FIXME: generate only if generating code for this unit. + if Get_Macro_Expanded_Flag (Pkg) + and then Get_Need_Body (Pkg) + then + Bod := Sem_Inst.Instantiate_Package_Body (Decl); + Set_Parent (Bod, Get_Parent (Decl)); + Set_Package_Body (Decl, Bod); end if; - end Canon_Package_Instantiation_Declaration; - - function Create_Instantiation_Bodies - (Decl : Iir_Package_Declaration; Parent : Iir) return Iir - is - First, Last : Iir; - El : Iir; - Bod : Iir; - begin - First := Null_Iir; - Last := Null_Iir; -- Kill the warning - El := Get_Declaration_Chain (Decl); - while Is_Valid (El) loop - if Get_Kind (El) = Iir_Kind_Package_Declaration - and then Get_Need_Body (El) - and then Get_Package_Origin (El) /= Null_Iir - then - Bod := Sem_Inst.Instantiate_Package_Body (El); - Set_Parent (Bod, Parent); - -- Append. - if First = Null_Iir then - First := Bod; - else - Set_Chain (Last, Bod); - end if; - Last := Bod; - end if; - El := Get_Chain (El); - end loop; - return First; - end Create_Instantiation_Bodies; + return Decl; + end Canon_Package_Instantiation_Declaration; - function Canon_Declaration (Top : Iir_Design_Unit; - Decl : Iir; - Parent : Iir; - Decl_Parent : Iir) - return Iir + function Canon_Declaration + (Top : Iir_Design_Unit; Decl : Iir; Parent : Iir; Decl_Parent : Iir) + return Iir is Stmts : Iir; begin diff --git a/src/vhdl/canon.ads b/src/vhdl/canon.ads index 40ce5088f..45e7db6a5 100644 --- a/src/vhdl/canon.ads +++ b/src/vhdl/canon.ads @@ -61,11 +61,6 @@ package Canon is (Arch : Iir_Architecture_Body) return Iir_Design_Unit; - -- Macro-expand package bodies for instantiations in DECL. Return the - -- chain of bodies (the parent of each body is set to PARENT). - function Create_Instantiation_Bodies - (Decl : Iir_Package_Declaration; Parent : Iir) return Iir; - -- Canonicalize a subprogram call. procedure Canon_Subprogram_Call (Call : Iir); diff --git a/src/vhdl/disp_tree.adb b/src/vhdl/disp_tree.adb index ecfc93ba4..92cfff293 100644 --- a/src/vhdl/disp_tree.adb +++ b/src/vhdl/disp_tree.adb @@ -452,6 +452,8 @@ package body Disp_Tree is Ndepth := Depth - 1; when Attr_Of_Ref => Ndepth := 0; + when Attr_Ref => + Ndepth := 0; when Attr_Of_Maybe_Ref => if Get_Is_Ref (N) then Ndepth := 0; diff --git a/src/vhdl/disp_vhdl.adb b/src/vhdl/disp_vhdl.adb index 291214af6..c00565515 100644 --- a/src/vhdl/disp_vhdl.adb +++ b/src/vhdl/disp_vhdl.adb @@ -2335,7 +2335,18 @@ package body Disp_Vhdl is end if; Formal := Get_Formal (El); if Formal /= Null_Iir then - Disp_Expression (Formal); + case Get_Kind (El) is + when Iir_Kind_Association_Element_Package + | Iir_Kind_Association_Element_Type + | Iir_Kind_Association_Element_Subprogram => + Disp_Name (Formal); + when Iir_Kind_Association_Element_By_Expression + | Iir_Kind_Association_Element_By_Individual + | Iir_Kind_Association_Element_Open => + Disp_Expression (Formal); + when others => + raise Internal_Error; + end case; if Conv /= Null_Iir then Put (")"); end if; @@ -2346,7 +2357,8 @@ package body Disp_Vhdl is when Iir_Kind_Association_Element_Open => Put ("open"); when Iir_Kind_Association_Element_Package - | Iir_Kind_Association_Element_Type => + | Iir_Kind_Association_Element_Type + | Iir_Kind_Association_Element_Subprogram => Disp_Name (Get_Actual (El)); when others => Conv := Get_In_Conversion (El); diff --git a/src/vhdl/errorout.adb b/src/vhdl/errorout.adb index 7119563cc..c5c5d9b1f 100644 --- a/src/vhdl/errorout.adb +++ b/src/vhdl/errorout.adb @@ -1259,9 +1259,11 @@ package body Errorout is case Get_Kind (Subprg) is when Iir_Kind_Enumeration_Literal => Append (Res, "enumeration literal "); - when Iir_Kind_Function_Declaration => + when Iir_Kind_Function_Declaration + | Iir_Kind_Interface_Function_Declaration => Append (Res, "function "); - when Iir_Kind_Procedure_Declaration => + when Iir_Kind_Procedure_Declaration + | Iir_Kind_Interface_Procedure_Declaration => Append (Res, "procedure "); when others => Error_Kind ("disp_subprg", Subprg); @@ -1289,8 +1291,8 @@ package body Errorout is Append (Res, " ["); case Get_Kind (Subprg) is - when Iir_Kind_Function_Declaration - | Iir_Kind_Procedure_Declaration => + when Iir_Kinds_Subprogram_Declaration + | Iir_Kinds_Interface_Subprogram_Declaration => declare El : Iir; begin @@ -1308,6 +1310,7 @@ package body Errorout is case Get_Kind (Subprg) is when Iir_Kind_Function_Declaration + | Iir_Kind_Interface_Function_Declaration | Iir_Kind_Enumeration_Literal => Append (Res, " return "); Append_Type (Get_Return_Type (Subprg)); diff --git a/src/vhdl/iirs.adb b/src/vhdl/iirs.adb index a5a12a742..219d21734 100644 --- a/src/vhdl/iirs.adb +++ b/src/vhdl/iirs.adb @@ -1776,23 +1776,6 @@ package body Iirs is Set_Field5 (Pkg, Decl); end Set_Package_Body; - function Get_Package_Instantiation_Bodies_Chain (Pkg : Iir) return Iir is - begin - pragma Assert (Pkg /= Null_Iir); - pragma Assert (Has_Package_Instantiation_Bodies_Chain (Get_Kind (Pkg)), - "no field Package_Instantiation_Bodies_Chain"); - return Get_Field8 (Pkg); - end Get_Package_Instantiation_Bodies_Chain; - - procedure Set_Package_Instantiation_Bodies_Chain (Pkg : Iir; Chain : Iir) - is - begin - pragma Assert (Pkg /= Null_Iir); - pragma Assert (Has_Package_Instantiation_Bodies_Chain (Get_Kind (Pkg)), - "no field Package_Instantiation_Bodies_Chain"); - Set_Field8 (Pkg, Chain); - end Set_Package_Instantiation_Bodies_Chain; - function Get_Need_Body (Decl : Iir_Package_Declaration) return Boolean is begin pragma Assert (Decl /= Null_Iir); @@ -4741,7 +4724,7 @@ package body Iirs is pragma Assert (Target /= Null_Iir); pragma Assert (Has_Actual_Type (Get_Kind (Target)), "no field Actual_Type"); - return Get_Field3 (Target); + return Get_Field5 (Target); end Get_Actual_Type; procedure Set_Actual_Type (Target : Iir; Atype : Iir) is @@ -4749,7 +4732,7 @@ package body Iirs is pragma Assert (Target /= Null_Iir); pragma Assert (Has_Actual_Type (Get_Kind (Target)), "no field Actual_Type"); - Set_Field3 (Target, Atype); + Set_Field5 (Target, Atype); end Set_Actual_Type; function Get_Actual_Type_Definition (Target : Iir) return Iir is @@ -4757,7 +4740,7 @@ package body Iirs is pragma Assert (Target /= Null_Iir); pragma Assert (Has_Actual_Type_Definition (Get_Kind (Target)), "no field Actual_Type_Definition"); - return Get_Field5 (Target); + return Get_Field3 (Target); end Get_Actual_Type_Definition; procedure Set_Actual_Type_Definition (Target : Iir; Atype : Iir) is @@ -4765,7 +4748,7 @@ package body Iirs is pragma Assert (Target /= Null_Iir); pragma Assert (Has_Actual_Type_Definition (Get_Kind (Target)), "no field Actual_Type_Definition"); - Set_Field5 (Target, Atype); + Set_Field3 (Target, Atype); end Set_Actual_Type_Definition; function Get_Association_Chain (Target : Iir) return Iir is diff --git a/src/vhdl/iirs.ads b/src/vhdl/iirs.ads index 4e0cbfd57..380ae998a 100644 --- a/src/vhdl/iirs.ads +++ b/src/vhdl/iirs.ads @@ -452,10 +452,11 @@ package Iirs is -- -- Owner of Actual_Type if needed. -- Only for Iir_Kind_Association_Element_By_Individual: - -- Get/Set_Actual_Type_Definition (Field5) + -- Get/Set_Actual_Type_Definition (Field3) -- -- Only for Iir_Kind_Association_Element_By_Individual: - -- Get/Set_Actual_Type (Field3) + -- Only for Iir_Kind_Association_Element_Type: + -- Get/Set_Actual_Type (Field5) -- -- Get/Set the whole association flag (true if the formal is associated in -- whole and not individually, see LRM93 4.3.2.2) @@ -883,10 +884,6 @@ package Iirs is -- -- Get/Set_Package_Origin (Field7) -- - -- Chain of bodies for package instantiation. Present only in certain - -- conditions. - -- Get/Set_Package_Instantiation_Bodies_Chain (Field8) - -- -- If true, the package need a body. -- Get/Set_Need_Body (Flag1) -- @@ -896,10 +893,10 @@ package Iirs is -- type. -- Get/Set_Macro_Expanded_Flag (Flag2) -- - -- True if the package declaration has the package has at least one - -- package instantiation declaration whose uninstantiated declaration - -- needs both a body and macro-expansion. In that case, the instantiation - -- needs macro-expansion of their body. + -- True if the package declaration at least one package instantiation + -- declaration whose uninstantiated declaration needs both a body and + -- macro-expansion. In that case, the instantiation needs macro-expansion + -- of their body. -- Get/Set_Need_Instance_Bodies (Flag3) -- -- Get/Set_Visible_Flag (Flag4) @@ -4719,6 +4716,11 @@ package Iirs is Iir_Predefined_None .. Iir_Predefined_Functions'Last; + -- Explicit known subprograms (from ieee) + subtype Iir_Predefined_IEEE_Explicit is Iir_Predefined_Functions range + Iir_Predefined_Functions'Succ (Iir_Predefined_None) .. + Iir_Predefined_Functions'Last; + -- Staticness as defined by LRM93 6.1 and 7.4 type Iir_Staticness is (Unknown, None, Globally, Locally); @@ -6008,10 +6010,6 @@ package Iirs is function Get_Package_Body (Pkg : Iir) return Iir; procedure Set_Package_Body (Pkg : Iir; Decl : Iir); - -- Field: Field8 Chain - function Get_Package_Instantiation_Bodies_Chain (Pkg : Iir) return Iir; - procedure Set_Package_Instantiation_Bodies_Chain (Pkg : Iir; Chain : Iir); - -- Field: Flag1 function Get_Need_Body (Decl : Iir_Package_Declaration) return Boolean; procedure Set_Need_Body (Decl : Iir_Package_Declaration; Flag : Boolean); @@ -6929,11 +6927,11 @@ package Iirs is -- Unless the formal is an unconstrained array type, this is the same as -- the formal type. -- Subtype indiciation for a type association. - -- Field: Field3 Ref + -- Field: Field5 Ref function Get_Actual_Type (Target : Iir) return Iir; procedure Set_Actual_Type (Target : Iir; Atype : Iir); - -- Field: Field5 + -- Field: Field3 function Get_Actual_Type_Definition (Target : Iir) return Iir; procedure Set_Actual_Type_Definition (Target : Iir; Atype : Iir); diff --git a/src/vhdl/iirs_utils.adb b/src/vhdl/iirs_utils.adb index 5495e6057..99ce824e9 100644 --- a/src/vhdl/iirs_utils.adb +++ b/src/vhdl/iirs_utils.adb @@ -376,7 +376,8 @@ package body Iirs_Utils is El := Formal; loop case Get_Kind (El) is - when Iir_Kind_Simple_Name => + when Iir_Kind_Simple_Name + | Iir_Kind_Operator_Symbol => return Get_Named_Entity (El); when Iir_Kinds_Interface_Declaration => return El; @@ -425,7 +426,8 @@ package body Iirs_Utils is if Formal /= Null_Iir then -- Strip denoting name case Get_Kind (Formal) is - when Iir_Kind_Simple_Name => + when Iir_Kind_Simple_Name + | Iir_Kind_Operator_Symbol => return Get_Named_Entity (Formal); when Iir_Kinds_Interface_Declaration => -- Shouldn't happen. diff --git a/src/vhdl/nodes_meta.adb b/src/vhdl/nodes_meta.adb index 67a25689b..65917b4aa 100644 --- a/src/vhdl/nodes_meta.adb +++ b/src/vhdl/nodes_meta.adb @@ -93,7 +93,6 @@ package body Nodes_Meta is Field_Entity_Name => Type_Iir, Field_Package => Type_Iir, Field_Package_Body => Type_Iir, - Field_Package_Instantiation_Bodies_Chain => Type_Iir, Field_Need_Body => Type_Boolean, Field_Macro_Expanded_Flag => Type_Boolean, Field_Need_Instance_Bodies => Type_Boolean, @@ -500,8 +499,6 @@ package body Nodes_Meta is return "package"; when Field_Package_Body => return "package_body"; - when Field_Package_Instantiation_Bodies_Chain => - return "package_instantiation_bodies_chain"; when Field_Need_Body => return "need_body"; when Field_Macro_Expanded_Flag => @@ -1690,8 +1687,6 @@ package body Nodes_Meta is return Attr_Ref; when Field_Package_Body => return Attr_Forward_Ref; - when Field_Package_Instantiation_Bodies_Chain => - return Attr_Chain; when Field_Need_Body => return Attr_None; when Field_Macro_Expanded_Flag => @@ -2345,6 +2340,7 @@ package body Nodes_Meta is Field_Chain, Field_Actual, Field_Subprogram_Association_Chain, + Field_Actual_Type, -- Iir_Kind_Association_Element_Subprogram Field_Whole_Association_Flag, Field_Collapse_Signal_Flag, @@ -2764,7 +2760,6 @@ package body Nodes_Meta is Field_Attribute_Value_Chain, Field_Package_Body, Field_Package_Origin, - Field_Package_Instantiation_Bodies_Chain, -- Iir_Kind_Package_Instantiation_Declaration Field_Identifier, Field_Visible_Flag, @@ -4352,61 +4347,61 @@ package body Nodes_Meta is Iir_Kind_Association_Element_By_Individual => 111, Iir_Kind_Association_Element_Open => 116, Iir_Kind_Association_Element_Package => 121, - Iir_Kind_Association_Element_Type => 127, - Iir_Kind_Association_Element_Subprogram => 132, - Iir_Kind_Choice_By_Others => 137, - Iir_Kind_Choice_By_Expression => 144, - Iir_Kind_Choice_By_Range => 151, - Iir_Kind_Choice_By_None => 156, - Iir_Kind_Choice_By_Name => 162, - Iir_Kind_Entity_Aspect_Entity => 164, - Iir_Kind_Entity_Aspect_Configuration => 165, - Iir_Kind_Entity_Aspect_Open => 165, - Iir_Kind_Block_Configuration => 171, - Iir_Kind_Block_Header => 175, - Iir_Kind_Component_Configuration => 182, - Iir_Kind_Binding_Indication => 186, - Iir_Kind_Entity_Class => 188, - Iir_Kind_Attribute_Value => 196, - Iir_Kind_Signature => 199, - Iir_Kind_Aggregate_Info => 206, - Iir_Kind_Procedure_Call => 210, - Iir_Kind_Record_Element_Constraint => 216, - Iir_Kind_Array_Element_Resolution => 218, - Iir_Kind_Record_Resolution => 219, - Iir_Kind_Record_Element_Resolution => 222, - Iir_Kind_Attribute_Specification => 230, - Iir_Kind_Disconnection_Specification => 236, - Iir_Kind_Configuration_Specification => 242, - Iir_Kind_Access_Type_Definition => 250, - Iir_Kind_Incomplete_Type_Definition => 258, - Iir_Kind_Interface_Type_Definition => 265, - Iir_Kind_File_Type_Definition => 272, - Iir_Kind_Protected_Type_Declaration => 281, - Iir_Kind_Record_Type_Definition => 291, - Iir_Kind_Array_Type_Definition => 303, - Iir_Kind_Array_Subtype_Definition => 318, - Iir_Kind_Record_Subtype_Definition => 329, - Iir_Kind_Access_Subtype_Definition => 337, - Iir_Kind_Physical_Subtype_Definition => 347, - Iir_Kind_Floating_Subtype_Definition => 358, - Iir_Kind_Integer_Subtype_Definition => 368, - Iir_Kind_Enumeration_Subtype_Definition => 378, - Iir_Kind_Enumeration_Type_Definition => 388, - Iir_Kind_Integer_Type_Definition => 396, - Iir_Kind_Floating_Type_Definition => 404, - Iir_Kind_Physical_Type_Definition => 415, - Iir_Kind_Range_Expression => 423, - Iir_Kind_Protected_Type_Body => 430, - Iir_Kind_Wildcard_Type_Definition => 435, - Iir_Kind_Subtype_Definition => 440, - Iir_Kind_Scalar_Nature_Definition => 444, - Iir_Kind_Overload_List => 445, - Iir_Kind_Type_Declaration => 452, - Iir_Kind_Anonymous_Type_Declaration => 458, - Iir_Kind_Subtype_Declaration => 465, - Iir_Kind_Nature_Declaration => 471, - Iir_Kind_Subnature_Declaration => 477, + Iir_Kind_Association_Element_Type => 128, + Iir_Kind_Association_Element_Subprogram => 133, + Iir_Kind_Choice_By_Others => 138, + Iir_Kind_Choice_By_Expression => 145, + Iir_Kind_Choice_By_Range => 152, + Iir_Kind_Choice_By_None => 157, + Iir_Kind_Choice_By_Name => 163, + Iir_Kind_Entity_Aspect_Entity => 165, + Iir_Kind_Entity_Aspect_Configuration => 166, + Iir_Kind_Entity_Aspect_Open => 166, + Iir_Kind_Block_Configuration => 172, + Iir_Kind_Block_Header => 176, + Iir_Kind_Component_Configuration => 183, + Iir_Kind_Binding_Indication => 187, + Iir_Kind_Entity_Class => 189, + Iir_Kind_Attribute_Value => 197, + Iir_Kind_Signature => 200, + Iir_Kind_Aggregate_Info => 207, + Iir_Kind_Procedure_Call => 211, + Iir_Kind_Record_Element_Constraint => 217, + Iir_Kind_Array_Element_Resolution => 219, + Iir_Kind_Record_Resolution => 220, + Iir_Kind_Record_Element_Resolution => 223, + Iir_Kind_Attribute_Specification => 231, + Iir_Kind_Disconnection_Specification => 237, + Iir_Kind_Configuration_Specification => 243, + Iir_Kind_Access_Type_Definition => 251, + Iir_Kind_Incomplete_Type_Definition => 259, + Iir_Kind_Interface_Type_Definition => 266, + Iir_Kind_File_Type_Definition => 273, + Iir_Kind_Protected_Type_Declaration => 282, + Iir_Kind_Record_Type_Definition => 292, + Iir_Kind_Array_Type_Definition => 304, + Iir_Kind_Array_Subtype_Definition => 319, + Iir_Kind_Record_Subtype_Definition => 330, + Iir_Kind_Access_Subtype_Definition => 338, + Iir_Kind_Physical_Subtype_Definition => 348, + Iir_Kind_Floating_Subtype_Definition => 359, + Iir_Kind_Integer_Subtype_Definition => 369, + Iir_Kind_Enumeration_Subtype_Definition => 379, + Iir_Kind_Enumeration_Type_Definition => 389, + Iir_Kind_Integer_Type_Definition => 397, + Iir_Kind_Floating_Type_Definition => 405, + Iir_Kind_Physical_Type_Definition => 416, + Iir_Kind_Range_Expression => 424, + Iir_Kind_Protected_Type_Body => 431, + Iir_Kind_Wildcard_Type_Definition => 436, + Iir_Kind_Subtype_Definition => 441, + Iir_Kind_Scalar_Nature_Definition => 445, + Iir_Kind_Overload_List => 446, + Iir_Kind_Type_Declaration => 453, + Iir_Kind_Anonymous_Type_Declaration => 459, + Iir_Kind_Subtype_Declaration => 466, + Iir_Kind_Nature_Declaration => 472, + Iir_Kind_Subnature_Declaration => 478, Iir_Kind_Package_Declaration => 492, Iir_Kind_Package_Instantiation_Declaration => 505, Iir_Kind_Package_Body => 513, @@ -5018,8 +5013,6 @@ package body Nodes_Meta is return Get_Package (N); when Field_Package_Body => return Get_Package_Body (N); - when Field_Package_Instantiation_Bodies_Chain => - return Get_Package_Instantiation_Bodies_Chain (N); when Field_Block_Configuration => return Get_Block_Configuration (N); when Field_Concurrent_Statement_Chain => @@ -5418,8 +5411,6 @@ package body Nodes_Meta is Set_Package (N, V); when Field_Package_Body => Set_Package_Body (N, V); - when Field_Package_Instantiation_Bodies_Chain => - Set_Package_Instantiation_Bodies_Chain (N, V); when Field_Block_Configuration => Set_Block_Configuration (N, V); when Field_Concurrent_Statement_Chain => @@ -7047,12 +7038,6 @@ package body Nodes_Meta is end case; end Has_Package_Body; - function Has_Package_Instantiation_Bodies_Chain (K : Iir_Kind) - return Boolean is - begin - return K = Iir_Kind_Package_Declaration; - end Has_Package_Instantiation_Bodies_Chain; - function Has_Need_Body (K : Iir_Kind) return Boolean is begin return K = Iir_Kind_Package_Declaration; @@ -9802,7 +9787,13 @@ package body Nodes_Meta is function Has_Actual_Type (K : Iir_Kind) return Boolean is begin - return K = Iir_Kind_Association_Element_By_Individual; + case K is + when Iir_Kind_Association_Element_By_Individual + | Iir_Kind_Association_Element_Type => + return True; + when others => + return False; + end case; end Has_Actual_Type; function Has_Actual_Type_Definition (K : Iir_Kind) return Boolean is diff --git a/src/vhdl/nodes_meta.ads b/src/vhdl/nodes_meta.ads index ddd23ed79..0400f4025 100644 --- a/src/vhdl/nodes_meta.ads +++ b/src/vhdl/nodes_meta.ads @@ -133,7 +133,6 @@ package Nodes_Meta is Field_Entity_Name, Field_Package, Field_Package_Body, - Field_Package_Instantiation_Bodies_Chain, Field_Need_Body, Field_Macro_Expanded_Flag, Field_Need_Instance_Bodies, @@ -640,8 +639,6 @@ package Nodes_Meta is function Has_Entity_Name (K : Iir_Kind) return Boolean; function Has_Package (K : Iir_Kind) return Boolean; function Has_Package_Body (K : Iir_Kind) return Boolean; - function Has_Package_Instantiation_Bodies_Chain (K : Iir_Kind) - return Boolean; function Has_Need_Body (K : Iir_Kind) return Boolean; function Has_Macro_Expanded_Flag (K : Iir_Kind) return Boolean; function Has_Need_Instance_Bodies (K : Iir_Kind) return Boolean; diff --git a/src/vhdl/parse.adb b/src/vhdl/parse.adb index 99c459027..31af2556d 100644 --- a/src/vhdl/parse.adb +++ b/src/vhdl/parse.adb @@ -3162,7 +3162,7 @@ package body Parse is Set_Minus_Terminal (First, Parse_Name); end if; when others => - Error_Msg_Parse ("missign type or across/throught aspect " + Error_Msg_Parse ("missing type or across/throught aspect " & "in quantity declaration"); Eat_Tokens_Until_Semi_Colon; raise Expect_Error; @@ -3271,7 +3271,7 @@ package body Parse is if Current_Token /= Tok_Comma then case Current_Token is when Tok_Assign => - Error_Msg_Parse ("missign type in " & Disp_Name (Kind)); + Error_Msg_Parse ("missing type in " & Disp_Name (Kind)); exit; when others => Error_Msg_Parse @@ -6642,23 +6642,27 @@ package body Parse is return Res; end Parse_Process_Statement; - procedure Check_Formal_Form (Formal : Iir) is + function Check_Formal_Form (Formal : Iir) return Iir is begin if Formal = Null_Iir then - return; + return Formal; end if; case Get_Kind (Formal) is when Iir_Kind_Simple_Name | Iir_Kind_Slice_Name | Iir_Kind_Selected_Name => - null; + return Formal; when Iir_Kind_Parenthesis_Name => -- Could be an indexed name, so nothing to check within the -- parenthesis. - null; + return Formal; + when Iir_Kind_String_Literal8 => + -- Operator designator + return String_To_Operator_Symbol (Formal); when others => - Error_Msg_Parse (+Formal, "incorrect formal name"); + Error_Msg_Parse (+Formal, "incorrect formal name ignored"); + return Null_Iir; end case; end Check_Formal_Form; @@ -6736,10 +6740,8 @@ package body Parse is end if; when Tok_Double_Arrow => - Formal := Actual; - -- Check that FORMAL is a name and not an expression. - Check_Formal_Form (Formal); + Formal := Check_Formal_Form (Actual); -- Skip '=>' Scan; @@ -6805,8 +6807,13 @@ package body Parse is function Parse_Generic_Map_Aspect return Iir is begin Expect (Tok_Generic); + + -- Skip 'generic'. Scan_Expect (Tok_Map); + + -- Skip 'map'. Scan; + return Parse_Association_List_In_Parenthesis; end Parse_Generic_Map_Aspect; @@ -8539,6 +8546,10 @@ package body Parse is if Current_Token = Tok_Generic then Set_Generic_Map_Aspect_Chain (Res, Parse_Generic_Map_Aspect); + elsif Current_Token = Tok_Left_Paren then + Error_Msg_Parse ("missing 'generic map'"); + Set_Generic_Map_Aspect_Chain + (Res, Parse_Association_List_In_Parenthesis); end if; Expect (Tok_Semi_Colon); diff --git a/src/vhdl/parse.ads b/src/vhdl/parse.ads index ea7c56cf0..41f22a3fd 100644 --- a/src/vhdl/parse.ads +++ b/src/vhdl/parse.ads @@ -36,6 +36,10 @@ package Parse is Len : Nat32; Loc : Location_Type) return Name_Id; + -- Convert string literal STR to an operator symbol. + -- Emit an error message if the string is not an operator name. + function String_To_Operator_Symbol (Str : Iir) return Iir; + -- Parse a single design unit. -- The scanner must have been initialized, however, the current_token -- shouldn't have been set. diff --git a/src/vhdl/scanner.adb b/src/vhdl/scanner.adb index 40fe9a4e7..d9039fcc6 100644 --- a/src/vhdl/scanner.adb +++ b/src/vhdl/scanner.adb @@ -905,13 +905,60 @@ package body Scanner is end if; end if; end; - end if; - if Vhdl_Std > Vhdl_87 and then C = '\' then + elsif Vhdl_Std > Vhdl_87 and then C = '\' then -- Start of extended identifier. Cannot follow an identifier. Error_Separator; end if; - when Invalid - | Format_Effector + + when Invalid => + -- Improve error message for use of UTF-8 quote marks. + -- It's possible because in the sequence of UTF-8 bytes for the + -- quote marks, there are invalid character (in the 128-160 + -- range). + if C = Character'Val (16#80#) + and then Nam_Buffer (Len) = Character'Val (16#e2#) + and then (Source (Pos + 1) = Character'Val (16#98#) + or else Source (Pos + 1) = Character'Val (16#99#)) + then + -- UTF-8 left or right single quote mark. + if Len > 1 then + -- The first byte (0xe2) is part of the identifier. An + -- error will be detected as the next byte (0x80) is + -- invalid. Remove the first byte from the identifier, and + -- let's catch the error later. + Nam_Length := Len - 1; + Pos := Pos - 1; + else + Error_Msg_Scan ("invalid use of UTF8 character for '"); + Pos := Pos + 2; + + -- Distinguish between character literal and tick. Don't + -- care about possible invalid character literal, as in any + -- case we have already emitted an error message. + if Current_Context.Prev_Token /= Tok_Identifier + and then Current_Context.Prev_Token /= Tok_Character + and then + (Source (Pos + 1) = ''' + or else + (Source (Pos + 1) = Character'Val (16#e2#) + and then Source (Pos + 2) = Character'Val (16#80#) + and then Source (Pos + 3) = Character'Val (16#99#))) + then + Current_Token := Tok_Character; + Current_Context.Identifier := + Name_Table.Get_Identifier (Source (Pos)); + if Source (Pos + 1) = ''' then + Pos := Pos + 2; + else + Pos := Pos + 4; + end if; + else + Current_Token := Tok_Tick; + end if; + return; + end if; + end if; + when Format_Effector | Space_Character => null; end case; diff --git a/src/vhdl/sem.adb b/src/vhdl/sem.adb index 1664d67e1..39916bb76 100644 --- a/src/vhdl/sem.adb +++ b/src/vhdl/sem.adb @@ -1479,6 +1479,12 @@ package body Sem is when Iir_Kinds_Monadic_Operator => return Are_Trees_Equal (Get_Operand (Left), Get_Operand (Right)); + when Iir_Kind_Function_Call => + return Are_Trees_Equal (Get_Prefix (Left), Get_Prefix (Right)) + and then + Are_Trees_Chain_Equal (Get_Parameter_Association_Chain (Left), + Get_Parameter_Association_Chain (Right)); + when Iir_Kind_Access_Type_Definition | Iir_Kind_Record_Type_Definition | Iir_Kind_Array_Type_Definition @@ -2867,9 +2873,14 @@ package body Sem is -- FIXME: unless the parent is a package declaration library unit, the -- design unit depends on the body. - if Get_Need_Body (Pkg) then - Bod := Libraries.Load_Secondary_Unit - (Get_Design_Unit (Pkg), Null_Identifier, Decl); + if Get_Need_Body (Pkg) and then not Is_Nested_Package (Pkg) then + Bod := Get_Package_Body (Pkg); + if Is_Null (Bod) then + Bod := Libraries.Load_Secondary_Unit + (Get_Design_Unit (Pkg), Null_Identifier, Decl); + else + Bod := Get_Design_Unit (Bod); + end if; if Is_Null (Bod) then Error_Msg_Sem (+Decl, "cannot find package body of %n", +Pkg); else diff --git a/src/vhdl/sem_assocs.adb b/src/vhdl/sem_assocs.adb index af573ae3b..b85050ff3 100644 --- a/src/vhdl/sem_assocs.adb +++ b/src/vhdl/sem_assocs.adb @@ -20,6 +20,7 @@ with Errorout; use Errorout; with Flags; use Flags; with Types; use Types; with Iirs_Utils; use Iirs_Utils; +with Parse; with Std_Names; with Sem_Names; use Sem_Names; with Sem_Types; @@ -33,20 +34,61 @@ package body Sem_Assocs is return Iir is N_Assoc : Iir; + Actual : Iir; begin + Actual := Get_Actual (Assoc); case Get_Kind (Inter) is when Iir_Kind_Interface_Package_Declaration => N_Assoc := Create_Iir (Iir_Kind_Association_Element_Package); when Iir_Kind_Interface_Type_Declaration => N_Assoc := Create_Iir (Iir_Kind_Association_Element_Type); + if Get_Kind (Actual) = Iir_Kind_Parenthesis_Name then + -- Convert parenthesis name to array subtype. + declare + N_Actual : Iir; + Sub_Assoc : Iir; + Indexes : Iir_List; + Old : Iir; + begin + N_Actual := Create_Iir (Iir_Kind_Array_Subtype_Definition); + Location_Copy (N_Actual, Actual); + Set_Subtype_Type_Mark (N_Actual, Get_Prefix (Actual)); + Sub_Assoc := Get_Association_Chain (Actual); + Indexes := Create_Iir_List; + Set_Index_Constraint_List (N_Actual, Indexes); + while Is_Valid (Sub_Assoc) loop + if Get_Kind (Sub_Assoc) + /= Iir_Kind_Association_Element_By_Expression + then + Error_Msg_Sem + (+Sub_Assoc, "index constraint must be a range"); + else + if Get_Formal (Sub_Assoc) /= Null_Iir then + Error_Msg_Sem + (+Sub_Assoc, "formal part not allowed"); + end if; + Append_Element (Indexes, Get_Actual (Sub_Assoc)); + end if; + Old := Sub_Assoc; + Sub_Assoc := Get_Chain (Sub_Assoc); + Free_Iir (Old); + end loop; + Old := Actual; + Free_Iir (Old); + Actual := N_Actual; + end; + end if; when Iir_Kinds_Interface_Subprogram_Declaration => N_Assoc := Create_Iir (Iir_Kind_Association_Element_Subprogram); + if Get_Kind (Actual) = Iir_Kind_String_Literal8 then + Actual := Parse.String_To_Operator_Symbol (Actual); + end if; when others => Error_Kind ("rewrite_non_object_association", Inter); end case; Location_Copy (N_Assoc, Assoc); Set_Formal (N_Assoc, Get_Formal (Assoc)); - Set_Actual (N_Assoc, Get_Actual (Assoc)); + Set_Actual (N_Assoc, Actual); Set_Chain (N_Assoc, Get_Chain (Assoc)); Set_Whole_Association_Flag (N_Assoc, True); Free_Iir (Assoc); @@ -69,18 +111,20 @@ package body Sem_Assocs is Res := Null_Iir; -- Common case: only objects in interfaces. - while Inter /= Null_Iir loop + while Is_Valid (Inter) loop exit when Get_Kind (Inter) not in Iir_Kinds_Interface_Object_Declaration; Inter := Get_Chain (Inter); end loop; - if Inter = Null_Iir then + if Is_Null (Inter) then + -- Only interface object, nothing to to. return Assoc_Chain; end if; + Inter := Inter_Chain; loop -- Don't try to detect errors. - if Assoc = Null_Iir then + if Is_Null (Assoc) then return Res; end if; @@ -97,7 +141,8 @@ package body Sem_Assocs is Assoc := Rewrite_Non_Object_Association (Assoc, Inter); end if; else - if Get_Kind (Formal) = Iir_Kind_Simple_Name then + if Kind_In (Formal, Iir_Kind_Simple_Name, Iir_Kind_Operator_Symbol) + then -- A candidate. Search the corresponding interface. Inter := Find_Name_In_Chain (Inter_Chain, Get_Identifier (Formal)); @@ -120,6 +165,9 @@ package body Sem_Assocs is end if; Prev_Assoc := Assoc; Assoc := Get_Chain (Assoc); + if Is_Valid (Inter) then + Inter := Get_Chain (Inter); + end if; end loop; end Extract_Non_Object_Association; @@ -1288,7 +1336,8 @@ package body Sem_Assocs is Formal_Type : Iir; begin case Get_Kind (Formal) is - when Iir_Kind_Simple_Name => + when Iir_Kind_Simple_Name + | Iir_Kind_Operator_Symbol => -- Certainly the most common case: FORMAL_NAME => VAL. -- It is also the easiest. So, handle it completly now. if Get_Identifier (Formal) = Get_Identifier (Inter) then @@ -1522,7 +1571,7 @@ package body Sem_Assocs is -- Can be associated only once Match := Fully_Compatible; else - if Get_Kind (Formal) = Iir_Kind_Simple_Name + if Kind_In (Formal, Iir_Kind_Simple_Name, Iir_Kind_Operator_Symbol) and then Get_Identifier (Formal) = Get_Identifier (Inter) then Match := Fully_Compatible; @@ -1537,7 +1586,6 @@ package body Sem_Assocs is Formal : constant Iir := Get_Formal (Assoc); begin if Formal /= Null_Iir then - pragma Assert (Get_Kind (Formal) = Iir_Kind_Simple_Name); pragma Assert (Get_Identifier (Formal) = Get_Identifier (Inter)); Set_Named_Entity (Formal, Inter); Set_Base_Name (Formal, Inter); @@ -1610,14 +1658,12 @@ package body Sem_Assocs is end Sem_Association_Package; -- Create an implicit association_element_subprogram for the declaration - -- of function ID for ACTUAL (a name of a type). + -- of function ID for ACTUAL_Type (a type/subtype definition). function Sem_Implicit_Operator_Association - (Id : Name_Id; Actual : Iir) return Iir + (Id : Name_Id; Actual_Type : Iir; Actual_Name : Iir) return Iir is use Sem_Scopes; - Atype : constant Iir := Get_Type (Actual); - -- Return TRUE if DECL is a function declaration with a comparaison -- operator profile. function Has_Comparaison_Profile (Decl : Iir) return Boolean @@ -1641,7 +1687,8 @@ package body Sem_Assocs is if Inter = Null_Iir then return False; end if; - if Get_Base_Type (Get_Type (Inter)) /= Get_Base_Type (Atype) then + if Get_Base_Type (Get_Type (Inter)) /= Get_Base_Type (Actual_Type) + then return False; end if; Inter := Get_Chain (Inter); @@ -1661,16 +1708,17 @@ package body Sem_Assocs is Decl := Get_Declaration (Interp); if Has_Comparaison_Profile (Decl) then Res := Create_Iir (Iir_Kind_Association_Element_Subprogram); - Location_Copy (Res, Actual); - Set_Actual (Res, Build_Simple_Name (Decl, Get_Location (Actual))); + Location_Copy (Res, Actual_Name); + Set_Actual + (Res, Build_Simple_Name (Decl, Get_Location (Actual_Name))); Set_Use_Flag (Decl, True); return Res; end if; Interp := Get_Next_Interpretation (Interp); end loop; - Error_Msg_Sem (+Actual, "cannot find a %i declaration for type %i", - (+Id, +Actual)); + Error_Msg_Sem (+Actual_Name, "cannot find a %i declaration for type %i", + (+Id, +Actual_Name)); return Null_Iir; end Sem_Implicit_Operator_Association; @@ -1681,6 +1729,7 @@ package body Sem_Assocs is is Inter_Def : constant Iir := Get_Type (Inter); Actual : Iir; + Actual_Type : Iir; Op_Eq, Op_Neq : Iir; begin if not Finish then @@ -1701,15 +1750,21 @@ package body Sem_Assocs is -- Set type association for analysis of reference to this interface. pragma Assert (Is_Null (Get_Associated_Type (Inter_Def))); - Set_Associated_Type (Inter_Def, Get_Type (Actual)); + if Get_Kind (Actual) in Iir_Kinds_Subtype_Definition then + Actual_Type := Actual; + else + Actual_Type := Get_Type (Actual); + end if; + Set_Actual_Type (Assoc, Actual_Type); + Set_Associated_Type (Inter_Def, Actual_Type); -- FIXME: it is not clear at all from the LRM how the implicit -- associations are done... Op_Eq := Sem_Implicit_Operator_Association - (Std_Names.Name_Op_Equality, Actual); + (Std_Names.Name_Op_Equality, Actual_Type, Actual); if Op_Eq /= Null_Iir then Op_Neq := Sem_Implicit_Operator_Association - (Std_Names.Name_Op_Inequality, Actual); + (Std_Names.Name_Op_Inequality, Actual_Type, Actual); Set_Chain (Op_Eq, Op_Neq); Set_Subprogram_Association_Chain (Assoc, Op_Eq); end if; @@ -1838,11 +1893,11 @@ package body Sem_Assocs is end if; when Iir_Kind_Overload_List => declare - First_Error : Boolean; + Nbr_Errors : Natural; List : Iir_List; El, R : Iir; begin - First_Error := True; + Nbr_Errors := 0; R := Null_Iir; List := Get_Overload_List (Res); for I in Natural loop @@ -1852,18 +1907,18 @@ package body Sem_Assocs is if Is_Null (R) then R := El; else - if First_Error then + if Nbr_Errors = 0 then Error_Msg_Sem (+Assoc, "many possible actual subprogram for %n:", +Inter); Error_Msg_Sem (+Assoc, " %n declared at %l", (+R, + R)); - First_Error := False; else Error_Msg_Sem (+Assoc, " %n declared at %l", (+El, +El)); end if; + Nbr_Errors := Nbr_Errors + 1; end if; end if; end loop; @@ -1881,7 +1936,7 @@ package body Sem_Assocs is end loop; end if; return; - elsif First_Error then + elsif Nbr_Errors > 0 then return; end if; Free_Overload_List (Res); @@ -1892,6 +1947,7 @@ package body Sem_Assocs is end case; Set_Named_Entity (Actual, Res); + Xrefs.Xref_Name (Actual); Set_Use_Flag (Res, True); end Sem_Association_Subprogram; diff --git a/src/vhdl/sem_decls.adb b/src/vhdl/sem_decls.adb index 9fac6d50e..e75092a33 100644 --- a/src/vhdl/sem_decls.adb +++ b/src/vhdl/sem_decls.adb @@ -444,6 +444,7 @@ package body Sem_Decls is Set_Return_Type (Operation, Return_Type); Set_Identifier (Operation, Name); Set_Visible_Flag (Operation, True); + Set_Pure_Flag (Operation, True); Compute_Subprogram_Hash (Operation); return Operation; end Create_Implicit_Interface_Function; @@ -489,6 +490,7 @@ package body Sem_Decls is procedure Sem_Interface_Subprogram_Declaration (Inter : Iir) is begin Sem_Subprogram_Specification (Inter); + Xref_Decl (Inter); end Sem_Interface_Subprogram_Declaration; procedure Sem_Interface_Chain (Interface_Chain: Iir; diff --git a/src/vhdl/sem_expr.adb b/src/vhdl/sem_expr.adb index 9807fc24a..545d3937a 100644 --- a/src/vhdl/sem_expr.adb +++ b/src/vhdl/sem_expr.adb @@ -967,8 +967,7 @@ package body Sem_Expr is -- Check purity rules when SUBPRG calls CALLEE. -- Both SUBPRG and CALLEE are subprogram declarations. -- Update purity_state/impure_depth of SUBPRG if it is a procedure. - procedure Sem_Call_Purity_Check (Subprg : Iir; Callee : Iir; Loc : Iir) - is + procedure Sem_Call_Purity_Check (Subprg : Iir; Callee : Iir; Loc : Iir) is begin if Callee = Subprg then return; @@ -991,7 +990,8 @@ package body Sem_Expr is end case; case Get_Kind (Callee) is - when Iir_Kind_Function_Declaration => + when Iir_Kind_Function_Declaration + | Iir_Kind_Interface_Function_Declaration => if Get_Pure_Flag (Callee) then -- Pure functions may be called anywhere. return; diff --git a/src/vhdl/sem_inst.adb b/src/vhdl/sem_inst.adb index 147073063..bbe5ad4d7 100644 --- a/src/vhdl/sem_inst.adb +++ b/src/vhdl/sem_inst.adb @@ -21,6 +21,7 @@ with Types; use Types; with Files_Map; with Iirs_Utils; use Iirs_Utils; with Errorout; use Errorout; +with Sem; package body Sem_Inst is -- Table of origin. This is an extension of vhdl nodes to track the @@ -573,7 +574,7 @@ package body Sem_Inst is when Iir_Kind_Interface_Type_Declaration => Set_Type (Res, Get_Type (Inter)); when Iir_Kinds_Interface_Subprogram_Declaration => - null; + Sem.Compute_Subprogram_Hash (Res); when others => Error_Kind ("instantiate_generic_chain", Res); end case; @@ -740,7 +741,8 @@ package body Sem_Inst is if Is_Valid (Formal) then loop case Get_Kind (Formal) is - when Iir_Kind_Simple_Name => + when Iir_Kind_Simple_Name + | Iir_Kind_Operator_Symbol => Set_Named_Entity (Formal, Get_Instance (Get_Named_Entity (Formal))); exit; @@ -782,7 +784,7 @@ package body Sem_Inst is declare Inter_Type_Def : constant Iir := Get_Type (Get_Association_Interface (Assoc, Inter)); - Actual_Type : constant Iir := Get_Type (Get_Actual (Assoc)); + Actual_Type : constant Iir := Get_Actual_Type (Assoc); begin Set_Instance (Inter_Type_Def, Actual_Type); end; @@ -861,8 +863,7 @@ package body Sem_Inst is function Instantiate_Package_Body (Inst : Iir) return Iir is - Inst_Decl : constant Iir := Get_Package_Origin (Inst); - Pkg : constant Iir := Get_Uninstantiated_Package_Decl (Inst_Decl); + Pkg : constant Iir := Get_Uninstantiated_Package_Decl (Inst); Prev_Instance_File : constant Source_File_Entry := Instance_File; Mark : constant Instance_Index_Type := Prev_Instance_Table.Last; Res : Iir; @@ -877,7 +878,6 @@ package body Sem_Inst is Set_Instance (Pkg, Inst); declare Pkg_Hdr : constant Iir := Get_Package_Header (Pkg); - Inst_Hdr : constant Iir := Get_Package_Header (Inst); Pkg_El : Iir; Inst_El : Iir; Inter_El : Iir; @@ -886,7 +886,7 @@ package body Sem_Inst is -- In the body, references to interface object are redirected to the -- instantiated interface objects. Pkg_El := Get_Generic_Chain (Pkg_Hdr); - Inst_El := Get_Generic_Chain (Inst_Hdr); + Inst_El := Get_Generic_Chain (Inst); while Is_Valid (Pkg_El) loop if Get_Kind (Pkg_El) in Iir_Kinds_Interface_Object_Declaration then Set_Instance (Pkg_El, Inst_El); @@ -897,8 +897,8 @@ package body Sem_Inst is -- In the body, references to interface type are substitued to the -- mapped type. - Inst_El := Get_Generic_Map_Aspect_Chain (Inst_Hdr); - Inter_El := Get_Generic_Chain (Inst_Hdr); + Inst_El := Get_Generic_Map_Aspect_Chain (Inst); + Inter_El := Get_Generic_Chain (Inst); while Is_Valid (Inst_El) loop case Get_Kind (Inst_El) is when Iir_Kind_Association_Element_Type => diff --git a/src/vhdl/sem_names.adb b/src/vhdl/sem_names.adb index 26672b385..0d03b8d4f 100644 --- a/src/vhdl/sem_names.adb +++ b/src/vhdl/sem_names.adb @@ -386,7 +386,13 @@ package body Sem_Names is | Iir_Kind_For_Generate_Statement => null; when Iir_Kind_Package_Declaration => - null; + declare + Header : constant Iir := Get_Package_Header (Decl); + begin + if Is_Valid (Header) then + Iterator_Decl_Chain (Get_Generic_Chain (Header), Id); + end if; + end; when Iir_Kind_Package_Instantiation_Declaration | Iir_Kind_Interface_Package_Declaration => Iterator_Decl_Chain (Get_Generic_Chain (Decl), Id); @@ -2116,6 +2122,7 @@ package body Sem_Names is -- LRM93 §6.3 -- This form of expanded name is only allowed within the -- construct itself. + -- FIXME: LRM08 12.3 Visibility h) if not Kind_In (Prefix, Iir_Kind_Package_Declaration, Iir_Kind_Package_Instantiation_Declaration) @@ -2645,7 +2652,8 @@ package body Sem_Names is when Iir_Kind_Procedure_Declaration | Iir_Kind_Interface_Procedure_Declaration => - Error_Msg_Sem (+Name, "function name is a procedure"); + Error_Msg_Sem (+Name, "cannot call %n in an expression", + +Prefix); when Iir_Kinds_Process_Statement | Iir_Kind_Component_Declaration diff --git a/src/vhdl/translate/trans-chap2.adb b/src/vhdl/translate/trans-chap2.adb index 015bca20d..6ed07c180 100644 --- a/src/vhdl/translate/trans-chap2.adb +++ b/src/vhdl/translate/trans-chap2.adb @@ -755,21 +755,19 @@ package body Trans.Chap2 is Pop_Instance_Factory (Info.Package_Body_Scope'Access); end Pop_Package_Instance_Factory; - procedure Translate_Package_Declaration (Decl : Iir_Package_Declaration) + -- Translate a package declaration or a macro-expanded package + -- instantiation. HEADER is the node containing generic and generic_map. + procedure Translate_Package (Decl : Iir; Header : Iir) is Is_Nested : constant Boolean := Is_Nested_Package (Decl); - Header : constant Iir := Get_Package_Header (Decl); + Is_Uninstantiated : constant Boolean := + Get_Kind (Decl) = Iir_Kind_Package_Declaration + and then Is_Uninstantiated_Package (Decl); Mark : Id_Mark_Type; Info : Ortho_Info_Acc; Interface_List : O_Inter_List; Prev_Subprg_Instance : Subprgs.Subprg_Instance_Stack; - Bod : Iir; begin - -- Skip uninstantiated package that have to be macro-expanded. - if Get_Macro_Expanded_Flag (Decl) then - return; - end if; - Info := Add_Info (Decl, Kind_Package); if Is_Nested then @@ -777,7 +775,7 @@ package body Trans.Chap2 is end if; -- Translate declarations. - if Is_Uninstantiated_Package (Decl) then + if Is_Uninstantiated then -- Create an instance for the spec. Push_Instance_Factory (Info.Package_Spec_Scope'Access); Chap4.Translate_Generic_Chain (Header); @@ -806,10 +804,6 @@ package body Trans.Chap2 is Chap4.Translate_Generic_Chain (Header); end if; Chap4.Translate_Declaration_Chain (Decl); - Bod := Get_Package_Instantiation_Bodies_Chain (Decl); - if Is_Valid (Bod) then - Chap4.Translate_Declaration_Chain (Bod); - end if; if not Is_Nested then Info.Package_Elab_Var := Create_Var (Create_Var_Identifier ("ELABORATED"), Ghdl_Bool_Type); @@ -821,10 +815,6 @@ package body Trans.Chap2 is -- For nested package, this will be translated when translating -- subprograms. Chap4.Translate_Declaration_Chain_Subprograms (Decl); - Bod := Get_Package_Instantiation_Bodies_Chain (Decl); - if Is_Valid (Bod) then - Chap4.Translate_Declaration_Chain_Subprograms (Bod); - end if; end if; -- Declare elaborator for the body. @@ -837,7 +827,7 @@ package body Trans.Chap2 is (Interface_List, Info.Package_Elab_Body_Subprg); end if; - if Is_Uninstantiated_Package (Decl) then + if Is_Uninstantiated then Subprgs.Pop_Subprg_Instance (Wki_Instance, Prev_Subprg_Instance); -- The spec elaborator has a spec instance argument. @@ -862,16 +852,16 @@ package body Trans.Chap2 is if Global_Storage = O_Storage_Public then -- Create elaboration procedure for the spec - Elab_Package (Decl); + Elab_Package (Decl, Header); end if; end if; - if Is_Uninstantiated_Package (Decl) then + if Is_Uninstantiated then Subprgs.Pop_Subprg_Instance (Wki_Instance, Prev_Subprg_Instance); end if; Save_Local_Identifier (Info.Package_Local_Id); - if Is_Uninstantiated_Package (Decl) + if Is_Uninstantiated and then not Get_Need_Body (Decl) and then Get_Package_Body (Decl) = Null_Iir then @@ -884,18 +874,58 @@ package body Trans.Chap2 is if Is_Nested then Pop_Identifier_Prefix (Mark); end if; + end Translate_Package; + + procedure Translate_Package_Declaration (Decl : Iir_Package_Declaration) + is + El : Iir; + Bod : Iir; + begin + -- Skip uninstantiated package that have to be macro-expanded. + if Get_Macro_Expanded_Flag (Decl) then + return; + end if; + + Translate_Package (Decl, Get_Package_Header (Decl)); + + if Global_Storage = O_Storage_Public then + -- If there are package instances declared that were macro-expanded + -- and if the package has (possibly) no body, translate the bodies + -- of the instances. + if Get_Need_Instance_Bodies (Decl) +-- and not Get_Need_Body (Decl) + then + El := Get_Declaration_Chain (Decl); + while Is_Valid (El) loop + if Get_Kind (El) = Iir_Kind_Package_Instantiation_Declaration + then + Bod := Get_Package_Body (El); + if Is_Valid (Bod) then + Translate_Package_Body (Bod); + end if; + end if; + El := Get_Chain (El); + end loop; + end if; + end if; end Translate_Package_Declaration; procedure Translate_Package_Body (Bod : Iir_Package_Body) is Is_Nested : constant Boolean := Is_Nested_Package (Bod); Spec : constant Iir_Package_Declaration := Get_Package (Bod); + + -- True if the package spec is a package declaration. It could be a + -- package instantiation declaration. + Is_Spec_Decl : constant Boolean := + Get_Kind (Spec) = Iir_Kind_Package_Declaration; + Info : constant Ortho_Info_Acc := Get_Info (Spec); Prev_Storage : constant O_Storage := Global_Storage; Prev_Subprg_Instance : Subprgs.Subprg_Instance_Stack; Mark : Id_Mark_Type; begin - if Get_Macro_Expanded_Flag (Spec) then + if Is_Spec_Decl and then Get_Macro_Expanded_Flag (Spec) then return; end if; @@ -904,7 +934,7 @@ package body Trans.Chap2 is end if; -- Translate declarations. - if Is_Uninstantiated_Package (Spec) then + if Is_Spec_Decl and then Is_Uninstantiated_Package (Spec) then Push_Package_Instance_Factory (Spec); -- Translate the specifications. @@ -921,7 +951,7 @@ package body Trans.Chap2 is return; end if; - if not Is_Uninstantiated_Package (Spec) then + if not (Is_Spec_Decl and then Is_Uninstantiated_Package (Spec)) then Restore_Local_Identifier (Info.Package_Local_Id); Chap4.Translate_Declaration_Chain (Bod); @@ -935,7 +965,7 @@ package body Trans.Chap2 is Rtis.Generate_Unit (Bod); end if; - if Is_Uninstantiated_Package (Spec) then + if Is_Spec_Decl and then Is_Uninstantiated_Package (Spec) then -- Add access to the specs. Subprgs.Push_Subprg_Instance (Info.Package_Body_Scope'Access, Info.Package_Body_Ptr_Type, @@ -945,13 +975,13 @@ package body Trans.Chap2 is Info.Package_Body_Scope'Access); end if; - if not Is_Nested then + if not Is_Nested or else not Is_Spec_Decl then -- Translate subprograms. For nested package, this has to be called -- when translating subprograms. Chap4.Translate_Declaration_Chain_Subprograms (Bod); end if; - if Is_Uninstantiated_Package (Spec) then + if Is_Spec_Decl and then Is_Uninstantiated_Package (Spec) then Clear_Scope (Info.Package_Spec_Scope); Subprgs.Pop_Subprg_Instance (Wki_Instance, Prev_Subprg_Instance); end if; @@ -967,7 +997,8 @@ package body Trans.Chap2 is end if; end Translate_Package_Body; - procedure Elab_Package (Spec : Iir_Package_Declaration) + -- Elaborate a package or a package instantiation. + procedure Elab_Package (Spec : Iir; Header : Iir) is Is_Nested : constant Boolean := Is_Nested_Package (Spec); Info : constant Ortho_Info_Acc := Get_Info (Spec); @@ -982,8 +1013,8 @@ package body Trans.Chap2 is Elab_Dependence (Get_Design_Unit (Spec)); - if not Is_Uninstantiated_Package (Spec) - and then Get_Kind (Get_Parent (Spec)) = Iir_Kind_Design_Unit + if not (Get_Kind (Spec) = Iir_Kind_Package_Declaration + and then Is_Uninstantiated_Package (Spec)) then -- Register the top level package. This is done dynamically, as -- we know only during elaboration that the design depends on a @@ -999,9 +1030,11 @@ package body Trans.Chap2 is Open_Temp; end if; - if Is_Generic_Mapped_Package (Spec) then + if Is_Valid (Header) + and then Is_Valid (Get_Generic_Map_Aspect_Chain (Header)) + then Chap5.Elab_Generic_Map_Aspect - (Get_Package_Header (Spec), Get_Package_Header (Spec), + (Header, Header, (Info.Package_Spec_Scope'Access, Info.Package_Spec_Scope)); end if; Chap4.Elab_Declaration_Chain (Spec, Final); @@ -1017,16 +1050,23 @@ package body Trans.Chap2 is procedure Elab_Package_Body (Spec : Iir_Package_Declaration; Bod : Iir) is + Is_Spec_Decl : constant Boolean := + Get_Kind (Spec) = Iir_Kind_Package_Declaration; + Info : constant Ortho_Info_Acc := Get_Info (Spec); If_Blk : O_If_Block; Constr : O_Assoc_List; Final : Boolean; begin + if Is_Spec_Decl and then Get_Macro_Expanded_Flag (Spec) then + return; + end if; + Start_Subprogram_Body (Info.Package_Elab_Body_Subprg); Push_Local_Factory; Subprgs.Start_Subprg_Instance_Use (Info.Package_Elab_Body_Instance); - if Is_Uninstantiated_Package (Spec) then + if Is_Spec_Decl and then Is_Uninstantiated_Package (Spec) then Set_Scope_Via_Field (Info.Package_Spec_Scope, Info.Package_Spec_Field, Info.Package_Body_Scope'Access); @@ -1053,7 +1093,7 @@ package body Trans.Chap2 is Close_Temp; end if; - if Is_Uninstantiated_Package (Spec) then + if Is_Spec_Decl and then Is_Uninstantiated_Package (Spec) then Clear_Scope (Info.Package_Spec_Scope); end if; @@ -1346,8 +1386,25 @@ package body Trans.Chap2 is Info : Ortho_Info_Acc; Interface_List : O_Inter_List; begin - -- Canon must have replaced instatiation by generic-mapped packages. - pragma Assert (not Get_Macro_Expanded_Flag (Spec)); + if Get_Macro_Expanded_Flag (Spec) then + -- Macro-expanded instantiations are translated like a package. + Translate_Package (Inst, Inst); + + -- For top-level package, generate code for the body. + if Global_Storage = O_Storage_Public + and then not Is_Nested_Package (Inst) + then + declare + Bod : constant Iir := Get_Package_Body (Inst); + begin + if Is_Valid (Bod) then + Translate_Package_Body (Bod); + end if; + end; + end if; + + return; + end if; Instantiate_Info_Package (Inst); Info := Get_Info (Inst); @@ -1402,6 +1459,11 @@ package body Trans.Chap2 is Info : constant Ortho_Info_Acc := Get_Info (Inst); Constr : O_Assoc_List; begin + if Get_Macro_Expanded_Flag (Spec) then + Elab_Package (Inst, Inst); + return; + end if; + Set_Scope_Via_Var (Pkg_Info.Package_Body_Scope, Info.Package_Instance_Body_Var); @@ -1423,22 +1485,12 @@ package body Trans.Chap2 is Clear_Scope (Pkg_Info.Package_Body_Scope); end Elab_Package_Instantiation_Declaration; - procedure Elab_Dependence_Package (Pkg : Iir_Package_Declaration) + procedure Elab_Dependence_Package (Pkg : Iir) is Info : Ortho_Info_Acc; If_Blk : O_If_Block; Constr : O_Assoc_List; begin - -- Std.Standard is pre-elaborated. - if Pkg = Standard_Package then - return; - end if; - - -- Nothing to do for uninstantiated package. - if Is_Uninstantiated_Package (Pkg) then - return; - end if; - -- Call the package elaborator only if not already elaborated. Info := Get_Info (Pkg); Start_If_Stmt @@ -1451,13 +1503,36 @@ package body Trans.Chap2 is Finish_If_Stmt (If_Blk); end Elab_Dependence_Package; - procedure Elab_Dependence_Package_Instantiation (Pkg : Iir) - is - Info : constant Ortho_Info_Acc := Get_Info (Pkg); - Constr : O_Assoc_List; + procedure Elab_Dependence_Package_Declaration + (Pkg : Iir_Package_Declaration) is begin - Start_Association (Constr, Info.Package_Instance_Elab_Subprg); - New_Procedure_Call (Constr); + -- Std.Standard is pre-elaborated. + if Pkg = Standard_Package then + return; + end if; + + -- Nothing to do for uninstantiated package. + if Is_Uninstantiated_Package (Pkg) then + return; + end if; + + Elab_Dependence_Package (Pkg); + end Elab_Dependence_Package_Declaration; + + procedure Elab_Dependence_Package_Instantiation (Pkg : Iir) is + begin + if Get_Macro_Expanded_Flag (Get_Uninstantiated_Package_Decl (Pkg)) then + -- Handled as a normal package + Elab_Dependence_Package (Pkg); + else + declare + Info : constant Ortho_Info_Acc := Get_Info (Pkg); + Constr : O_Assoc_List; + begin + Start_Association (Constr, Info.Package_Instance_Elab_Subprg); + New_Procedure_Call (Constr); + end; + end if; end Elab_Dependence_Package_Instantiation; procedure Elab_Dependence (Design_Unit: Iir_Design_Unit) @@ -1475,7 +1550,7 @@ package body Trans.Chap2 is Library_Unit := Get_Library_Unit (Design); case Get_Kind (Library_Unit) is when Iir_Kind_Package_Declaration => - Elab_Dependence_Package (Library_Unit); + Elab_Dependence_Package_Declaration (Library_Unit); when Iir_Kind_Package_Instantiation_Declaration => Elab_Dependence_Package_Instantiation (Library_Unit); when Iir_Kind_Entity_Declaration => diff --git a/src/vhdl/translate/trans-chap2.ads b/src/vhdl/translate/trans-chap2.ads index 74247d6e1..4d81c2bf6 100644 --- a/src/vhdl/translate/trans-chap2.ads +++ b/src/vhdl/translate/trans-chap2.ads @@ -35,7 +35,7 @@ package Trans.Chap2 is procedure Translate_Package_Body (Bod : Iir_Package_Body); procedure Translate_Package_Instantiation_Declaration (Inst : Iir); - procedure Elab_Package (Spec : Iir_Package_Declaration); + procedure Elab_Package (Spec : Iir; Header : Iir); procedure Elab_Package_Body (Spec : Iir_Package_Declaration; Bod : Iir); procedure Elab_Package_Instantiation_Declaration (Inst : Iir); diff --git a/src/vhdl/translate/trans-chap4.adb b/src/vhdl/translate/trans-chap4.adb index 14d04d486..ba5853935 100644 --- a/src/vhdl/translate/trans-chap4.adb +++ b/src/vhdl/translate/trans-chap4.adb @@ -2388,6 +2388,18 @@ package body Trans.Chap4 is Translate_Declaration_Chain_Subprograms (El); Pop_Identifier_Prefix (Mark); end; + when Iir_Kind_Package_Instantiation_Declaration => + if Get_Macro_Expanded_Flag + (Get_Uninstantiated_Package_Decl (El)) + then + declare + Mark : Id_Mark_Type; + begin + Push_Identifier_Prefix (Mark, Get_Identifier (El)); + Translate_Declaration_Chain_Subprograms (El); + Pop_Identifier_Prefix (Mark); + end; + end if; when others => null; end case; @@ -2485,7 +2497,7 @@ package body Trans.Chap4 is null; when Iir_Kind_Package_Declaration => - Chap2.Elab_Package (Decl); + Chap2.Elab_Package (Decl, Get_Package_Header (Decl)); -- FIXME: finalizer when Iir_Kind_Package_Body => declare diff --git a/src/vhdl/translate/trans-rtis.adb b/src/vhdl/translate/trans-rtis.adb index 77c12a358..7623b5032 100644 --- a/src/vhdl/translate/trans-rtis.adb +++ b/src/vhdl/translate/trans-rtis.adb @@ -2302,24 +2302,30 @@ package body Trans.Rtis is | Iir_Kind_Group_Declaration => null; when Iir_Kind_Package_Declaration => - declare - Mark : Id_Mark_Type; - begin - Push_Identifier_Prefix (Mark, Get_Identifier (Decl)); - Generate_Block (Decl, Parent_Rti); - Pop_Identifier_Prefix (Mark); - end; + if Get_Info (Decl) /= null then + -- Do not generate RTIs for untranslated packages. + declare + Mark : Id_Mark_Type; + begin + Push_Identifier_Prefix (Mark, Get_Identifier (Decl)); + Generate_Block (Decl, Parent_Rti); + Pop_Identifier_Prefix (Mark); + end; + end if; when Iir_Kind_Package_Body => - declare - Mark : Id_Mark_Type; - Mark1 : Id_Mark_Type; - begin - Push_Identifier_Prefix (Mark, Get_Identifier (Decl)); - Push_Identifier_Prefix (Mark1, "BODY"); - Generate_Block (Decl, Parent_Rti); - Pop_Identifier_Prefix (Mark1); - Pop_Identifier_Prefix (Mark); - end; + if Get_Info (Get_Package (Decl)) /= null then + -- Do not generate RTIs for untranslated packages. + declare + Mark : Id_Mark_Type; + Mark1 : Id_Mark_Type; + begin + Push_Identifier_Prefix (Mark, Get_Identifier (Decl)); + Push_Identifier_Prefix (Mark1, "BODY"); + Generate_Block (Decl, Parent_Rti); + Pop_Identifier_Prefix (Mark1); + Pop_Identifier_Prefix (Mark); + end; + end if; when Iir_Kind_Package_Instantiation_Declaration => -- FIXME: todo @@ -2600,7 +2606,8 @@ package body Trans.Rtis is Field_Off := O_Cnode_Null; case Get_Kind (Blk) is - when Iir_Kind_Package_Declaration => + when Iir_Kind_Package_Declaration + | Iir_Kind_Package_Instantiation_Declaration => Kind := Ghdl_Rtik_Package; Generate_Declaration_Chain (Get_Declaration_Chain (Blk), Rti); when Iir_Kind_Package_Body => @@ -2741,7 +2748,8 @@ package body Trans.Rtis is when Iir_Kind_Process_Statement | Iir_Kind_Sensitized_Process_Statement => Info.Process_Rti_Const := Rti; - when Iir_Kind_Package_Declaration => + when Iir_Kind_Package_Declaration + | Iir_Kind_Package_Instantiation_Declaration => Info.Package_Rti_Const := Rti; when Iir_Kind_Package_Body => -- Replace package declaration RTI with the body one. @@ -2855,8 +2863,9 @@ package body Trans.Rtis is -- Compute parent RTI. case Get_Kind (Lib_Unit) is when Iir_Kind_Package_Declaration - | Iir_Kind_Entity_Declaration - | Iir_Kind_Configuration_Declaration => + | Iir_Kind_Entity_Declaration + | Iir_Kind_Configuration_Declaration + | Iir_Kind_Package_Instantiation_Declaration => -- The library. declare Lib : Iir_Library_Declaration; diff --git a/src/vhdl/translate/translation.adb b/src/vhdl/translate/translation.adb index 1a4703f95..bc69661bb 100644 --- a/src/vhdl/translate/translation.adb +++ b/src/vhdl/translate/translation.adb @@ -289,6 +289,12 @@ package body Translation is New_Debug_Comment_Decl ("package declaration " & Image_Identifier (Lib_Unit)); Chap2.Translate_Package_Declaration (Lib_Unit); + if Get_Package_Origin (Lib_Unit) /= Null_Iir + and then Get_Package_Body (Lib_Unit) /= Null_Iir + then + -- Corresponding body for package instantiation. + Chap2.Translate_Package_Body (Get_Package_Body (Lib_Unit)); + end if; when Iir_Kind_Package_Body => New_Debug_Comment_Decl ("package body " & Image_Identifier (Lib_Unit)); |