diff options
138 files changed, 12581 insertions, 1043 deletions
@@ -3,7 +3,7 @@ break __gnat_raise_nodefer_with_msg define pt -call disp_tree ($arg0, 0, 0) +call disp_tree.disp_tree ($arg0, 0, 0) end document pt @@ -23,6 +23,9 @@ with Sem; with Std_Names; with Iir_Chains; use Iir_Chains; with Flags; use Flags; +with PSL.Nodes; +with PSL.Rewrites; +with PSL.Build; package body Canon is -- Canonicalize a list of declarations. LIST can be null. @@ -1408,18 +1411,23 @@ package body Canon is El := Get_Concurrent_Statement_Chain (Parent); while El /= Null_Iir loop -- Add a label if required. - if Canon_Flag_Add_Labels - and then Get_Label (El) = Null_Identifier - then - declare - Str : String := Natural'Image (Proc_Num); - begin - -- Note: the label starts with a capitalized letter, to avoid - -- any clash with user's identifiers. - Str (1) := 'P'; - Set_Label (El, Name_Table.Get_Identifier (Str)); - end; - Proc_Num := Proc_Num + 1; + if Canon_Flag_Add_Labels then + case Get_Kind (El) is + when Iir_Kind_Psl_Declaration => + null; + when others => + if Get_Label (El) = Null_Identifier then + declare + Str : String := Natural'Image (Proc_Num); + begin + -- Note: the label starts with a capitalized letter, + -- to avoid any clash with user's identifiers. + Str (1) := 'P'; + Set_Label (El, Name_Table.Get_Identifier (Str)); + end; + Proc_Num := Proc_Num + 1; + end if; + end case; end if; case Get_Kind (El) is @@ -1582,6 +1590,50 @@ package body Canon is Canon_Concurrent_Stmts (Top, El); end; + when Iir_Kind_Psl_Assert_Statement => + declare + use PSL.Nodes; + Prop : PSL_Node; + Fa : PSL_NFA; + begin + Prop := Get_Psl_Property (El); + Prop := PSL.Rewrites.Rewrite_Property (Prop); + Set_Psl_Property (El, Prop); + -- Generate the NFA. + Fa := PSL.Build.Build_FA (Prop); + Set_PSL_NFA (El, Fa); + end; + + when Iir_Kind_Psl_Default_Clock => + null; + when Iir_Kind_Psl_Declaration => + declare + use PSL.Nodes; + Decl : PSL_Node; + Prop : PSL_Node; + Fa : PSL_NFA; + begin + Decl := Get_Psl_Declaration (El); + case Get_Kind (Decl) is + when N_Property_Declaration => + Prop := Get_Property (Decl); + Prop := PSL.Rewrites.Rewrite_Property (Prop); + Set_Property (Decl, Prop); + if Get_Parameter_List (Decl) = Null_Node then + -- Generate the NFA. + Fa := PSL.Build.Build_FA (Prop); + Set_PSL_NFA (El, Fa); + end if; + when N_Sequence_Declaration + | N_Endpoint_Declaration => + Prop := Get_Sequence (Decl); + Prop := PSL.Rewrites.Rewrite_SERE (Prop); + Set_Sequence (Decl, Prop); + when others => + Error_Kind ("canon psl_declaration", Decl); + end case; + end; + when others => Error_Kind ("canon_concurrent_stmts", El); end case; @@ -2342,7 +2394,10 @@ package body Canon is end if; end; when Iir_Kind_Sensitized_Process_Statement - | Iir_Kind_Process_Statement => + | Iir_Kind_Process_Statement + | Iir_Kind_Psl_Assert_Statement + | Iir_Kind_Psl_Default_Clock + | Iir_Kind_Psl_Declaration => null; when others => Error_Kind ("canon_block_configuration(3)", El); diff --git a/canon_psl.adb b/canon_psl.adb new file mode 100644 index 000000000..1e1d8de18 --- /dev/null +++ b/canon_psl.adb @@ -0,0 +1,43 @@ +-- Canonicalization pass for PSL. +-- Copyright (C) 2009 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with PSL.Nodes; use PSL.Nodes; +with PSL.Errors; use PSL.Errors; +with Canon; use Canon; +with Iirs_Utils; use Iirs_Utils; + +package body Canon_PSL is + -- Version of Canon.Canon_Extract_Sensitivity for PSL nodes. + procedure Canon_Extract_Sensitivity + (Expr: PSL_Node; Sensitivity_List: Iir_List) + is + begin + case Get_Kind (Expr) is + when N_HDL_Expr => + Canon_Extract_Sensitivity (Get_HDL_Node (Expr), Sensitivity_List); + when N_And_Bool + | N_Or_Bool => + Canon_Extract_Sensitivity (Get_Left (Expr), Sensitivity_List); + Canon_Extract_Sensitivity (Get_Right (Expr), Sensitivity_List); + when N_Not_Bool => + Canon_Extract_Sensitivity (Get_Boolean (Expr), Sensitivity_List); + when others => + Error_Kind ("PSL.Canon_extract_Sensitivity", Expr); + end case; + end Canon_Extract_Sensitivity; +end Canon_PSL; diff --git a/canon_psl.ads b/canon_psl.ads new file mode 100644 index 000000000..3a8c501ac --- /dev/null +++ b/canon_psl.ads @@ -0,0 +1,26 @@ +-- Canonicalization pass for PSL. +-- Copyright (C) 2009 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Types; use Types; +with Iirs; use Iirs; + +package Canon_PSL is + -- Version of Canon.Canon_Extract_Sensitivity for PSL nodes. + procedure Canon_Extract_Sensitivity + (Expr: PSL_Node; Sensitivity_List: Iir_List); +end Canon_PSL; diff --git a/configuration.adb b/configuration.adb index f5d177fb1..678f8a47d 100644 --- a/configuration.adb +++ b/configuration.adb @@ -217,7 +217,10 @@ package body Configuration is | Iir_Kind_Block_Statement => Add_Design_Concurrent_Stmts (Stmt); when Iir_Kind_Process_Statement - | Iir_Kind_Sensitized_Process_Statement => + | Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Psl_Assert_Statement + | Iir_Kind_Psl_Default_Clock + | Iir_Kind_Psl_Declaration => null; when others => Error_Kind ("add_design_concurrent_stmts(2)", Stmt); diff --git a/disp_tree.adb b/disp_tree.adb index 6ad16d7af..12c91d3b3 100644 --- a/disp_tree.adb +++ b/disp_tree.adb @@ -16,12 +16,12 @@ -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA -- 02111-1307, USA. with Ada.Text_IO; use Ada.Text_IO; -with Types; use Types; with Name_Table; with Iirs_Utils; use Iirs_Utils; with Tokens; with Errorout; with Files_Map; +with PSL.Dump_Tree; package body Disp_Tree is procedure Disp_Tab (Tab: Natural) is @@ -288,6 +288,11 @@ package body Disp_Tree is when Iir_Kind_Group_Declaration => Put ("group_declaration"); Disp_Identifier (Tree); + when Iir_Kind_Psl_Declaration => + Put ("psl declaration"); + Disp_Identifier (Tree); + when Iir_Kind_Psl_Expression => + Put ("psl expression"); when Iir_Kind_Enumeration_Type_Definition => Put ("enumeration_type_definition"); @@ -1008,6 +1013,12 @@ package body Disp_Tree is end if; Header ("type:"); Disp_Tree (Get_Type (Tree), Ntab, True); + when Iir_Kind_Psl_Declaration => + if Flat_Decl then + return; + end if; + when Iir_Kind_Psl_Expression => + return; when Iir_Kind_Function_Declaration | Iir_Kind_Procedure_Declaration => if Flat_Decl then @@ -1411,6 +1422,12 @@ package body Disp_Tree is Disp_Tree (Get_Severity_Expression (Tree), Ntab); Header ("attribute_value_chain:"); Disp_Tree_Flat_Chain (Get_Attribute_Value_Chain (Tree), Ntab); + when Iir_Kind_Psl_Assert_Statement => + Header ("attribute_value_chain:"); + Disp_Tree_Flat_Chain (Get_Attribute_Value_Chain (Tree), Ntab); + PSL.Dump_Tree.Dump_Tree (Get_Psl_Property (Tree), True); + when Iir_Kind_Psl_Default_Clock => + null; when Iir_Kind_Sensitized_Process_Statement | Iir_Kind_Process_Statement => @@ -1802,8 +1819,9 @@ package body Disp_Tree is Header ("origin:"); Disp_Tree (Get_Literal_Origin (Tree), Ntab, True); when Iir_Kind_Bit_String_Literal => - Header ("base:" & Base_Type'Image (Get_Bit_String_Base (Tree))); + Header ("base: " & Base_Type'Image (Get_Bit_String_Base (Tree))); Header ("value: """ & Iirs_Utils.Image_String_Lit (Tree) & """"); + Header ("len:" & Int32'Image (Get_String_Length (Tree))); Header ("type:"); Disp_Tree_Flat (Get_Type (Tree), Ntab); when Iir_Kind_Character_Literal => @@ -1850,4 +1868,9 @@ package body Disp_Tree is null; end case; end Disp_Tree; + + procedure Disp_Tree_For_Psl (N : Int32) is + begin + Disp_Tree_Flat (Iir (N), 1); + end Disp_Tree_For_Psl; end Disp_Tree; diff --git a/disp_tree.ads b/disp_tree.ads index f1bdf9bea..63720ee2b 100644 --- a/disp_tree.ads +++ b/disp_tree.ads @@ -1,5 +1,5 @@ -- Node displaying (for debugging). --- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- Copyright (C) 2002, 2003, 2004, 2005, 2009 Tristan Gingold -- -- GHDL is free software; you can redistribute it and/or modify it under -- the terms of the GNU General Public License as published by the Free @@ -15,6 +15,7 @@ -- along with GHDL; see the file COPYING. If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA -- 02111-1307, USA. +with Types; use Types; with Iirs; use Iirs; package Disp_Tree is @@ -27,4 +28,5 @@ package Disp_Tree is Tab: Natural := 0; Flat_Decl: Boolean := false); + procedure Disp_Tree_For_Psl (N : Int32); end Disp_Tree; diff --git a/disp_vhdl.adb b/disp_vhdl.adb index 57132fbc2..98851aefa 100644 --- a/disp_vhdl.adb +++ b/disp_vhdl.adb @@ -28,6 +28,9 @@ with Iirs_Utils; use Iirs_Utils; with Name_Table; with Std_Names; with Tokens; +with PSL.Nodes; +with PSL.Prints; +with PSL.NFAs; package body Disp_Vhdl is @@ -62,6 +65,7 @@ package body Disp_Vhdl is (Block: Iir_Block_Configuration; Indent: Count); procedure Disp_Subprogram_Declaration (Subprg: Iir); procedure Disp_Binding_Indication (Bind : Iir; Indent : Count); + procedure Disp_Subtype_Indication (Def : Iir; Full_Decl : Boolean := False); procedure Disp_Ident (Id: Name_Id) is begin @@ -182,7 +186,8 @@ package body Disp_Vhdl is end if; Disp_Expression (Get_Right_Limit (Decl)); else - Disp_Name_Of (Get_Type_Declarator (Decl)); + Disp_Subtype_Indication (Decl); + -- Disp_Name_Of (Get_Type_Declarator (Decl)); end if; end Disp_Range; @@ -228,18 +233,20 @@ package body Disp_Vhdl is is Decl: Iir; begin - Decl := Get_Resolution_Function (Def); - if Decl /= Null_Iir then - Disp_Name (Decl); - else - case Get_Kind (Def) is - when Iir_Kind_Array_Subtype_Definition => - Put ('('); - Inner (Get_Element_Subtype (Def)); - Put (')'); - when others => - Error_Kind ("disp_resolution_function", Def); - end case; + if Get_Kind (Def) in Iir_Kinds_Subtype_Definition then + Decl := Get_Resolution_Function (Def); + if Decl /= Null_Iir then + Disp_Name (Decl); + else + case Get_Kind (Def) is + when Iir_Kind_Array_Subtype_Definition => + Put ('('); + Inner (Get_Element_Subtype (Def)); + Put (')'); + when others => + Error_Kind ("disp_resolution_function", Def); + end case; + end if; end if; end Inner; @@ -1025,6 +1032,7 @@ package body Disp_Vhdl is Disp_Sequential_Statements (Get_Sequential_Statement_Chain (Subprg)); Set_Col (Indent); Put_Line ("end;"); + New_Line; end Disp_Subprogram_Body; procedure Disp_Instantiation_List (Insts: Iir_List) is @@ -1825,11 +1833,11 @@ package body Disp_Vhdl is procedure Disp_String_Literal (Str : Iir) is Ptr : String_Fat_Acc; - Len : Natural; + Len : Int32; begin Ptr := Get_String_Fat_Acc (Str); Len := Get_String_Length (Str); - Put (Ptr (1 .. Len)); + Put (String (Ptr (1 .. Len))); end Disp_String_Literal; procedure Disp_Expression (Expr: Iir) @@ -2030,7 +2038,7 @@ package body Disp_Vhdl is Put (""); return; when Iir_Kind_Selected_Name => - Disp_Name (Expr); + Disp_Expression (Get_Named_Entity (Expr)); when Iir_Kinds_Type_And_Subtype_Definition => Disp_Type (Expr); @@ -2048,6 +2056,17 @@ package body Disp_Vhdl is end case; end Disp_Expression; + procedure Disp_PSL_HDL_Expr (N : PSL.Nodes.HDL_Node) is + begin + Disp_Expression (Iir (N)); + end Disp_PSL_HDL_Expr; + + procedure Disp_Psl_Expression (Expr : PSL_Node) is + begin + PSL.Prints.HDL_Expr_Printer := Disp_PSL_HDL_Expr'Access; + PSL.Prints.Print_Property (Expr); + end Disp_Psl_Expression; + procedure Disp_Block_Header (Header : Iir_Block_Header; Indent: Count) is Chain : Iir; @@ -2137,6 +2156,51 @@ package body Disp_Vhdl is Put_Line ("end generate;"); end Disp_Generate_Statement; + procedure Disp_Psl_Default_Clock (Stmt : Iir) is + begin + Put ("--psl default clock is "); + Disp_Psl_Expression (Get_Psl_Boolean (Stmt)); + Put_Line (";"); + end Disp_Psl_Default_Clock; + + procedure Disp_Psl_Assert_Statement (Stmt : Iir) + is + use PSL.NFAs; + use PSL.Nodes; + + procedure Disp_State (S : NFA_State) is + Str : constant String := Int32'Image (Get_State_Label (S)); + begin + Put (Str (2 .. Str'Last)); + end Disp_State; + + N : NFA; + S : NFA_State; + E : NFA_Edge; + begin + Put ("--psl assert "); + Disp_Psl_Expression (Get_Psl_Property (Stmt)); + Put_Line (";"); + N := Get_PSL_NFA (Stmt); + if True and then N /= No_NFA then + S := Get_First_State (N); + while S /= No_State loop + E := Get_First_Src_Edge (S); + while E /= No_Edge loop + Put ("-- "); + Disp_State (S); + Put (" -> "); + Disp_State (Get_Edge_Dest (E)); + Put (": "); + Disp_Psl_Expression (Get_Edge_Expr (E)); + New_Line; + E := Get_Next_Src_Edge (E); + end loop; + S := Get_Next_State (S); + end loop; + end if; + end Disp_Psl_Assert_Statement; + procedure Disp_Concurrent_Statement (Stmt: Iir) is begin case Get_Kind (Stmt) is @@ -2157,6 +2221,10 @@ package body Disp_Vhdl is Disp_Block_Statement (Stmt); when Iir_Kind_Generate_Statement => Disp_Generate_Statement (Stmt); + when Iir_Kind_Psl_Default_Clock => + Disp_Psl_Default_Clock (Stmt); + when Iir_Kind_Psl_Assert_Statement => + Disp_Psl_Assert_Statement (Stmt); when others => Error_Kind ("disp_concurrent_statement", Stmt); end case; diff --git a/doc/ghdl.html b/doc/ghdl.html index 2c9680753..e5b203f0b 100644 --- a/doc/ghdl.html +++ b/doc/ghdl.html @@ -3,7 +3,7 @@ <title>GHDL guide</title> <meta http-equiv="Content-Type" content="text/html"> <meta name="description" content="GHDL guide"> -<meta name="generator" content="makeinfo 4.8"> +<meta name="generator" content="makeinfo 4.11"> <link title="Top" rel="top" href="#Top"> <link href="http://www.gnu.org/software/texinfo/" rel="generator-home" title="Texinfo Homepage"> <meta http-equiv="Content-Style-Type" content="text/css"> @@ -65,6 +65,7 @@ <li><a href="#Directory-command">3.6.1 Directory command</a> <li><a href="#Clean-command">3.6.2 Clean command</a> <li><a href="#Remove-command">3.6.3 Remove command</a> +<li><a href="#Copy-command">3.6.4 Copy command</a> </li></ul> <li><a href="#Cross_002dreference-command">3.7 Cross-reference command</a> <li><a href="#File-commands">3.8 File commands</a> @@ -83,8 +84,9 @@ </li></ul> <li><a href="#Installation-Directory">3.10 Installation Directory</a> <li><a href="#IEEE-library-pitfalls">3.11 IEEE library pitfalls</a> +<li><a href="#IEEE-math-packages">3.12 IEEE math packages</a> </li></ul> -<li><a name="toc_Simulation-and-run-time" href="#Simulation-and-run-time">4 Simulation and run time</a> +<li><a name="toc_Simulation-and-runtime" href="#Simulation-and-runtime">4 Simulation and runtime</a> <ul> <li><a href="#Simulation-options">4.1 Simulation options</a> <li><a href="#Debugging-VHDL-programs">4.2 Debugging VHDL programs</a> @@ -151,7 +153,7 @@ or any later version published by the Free Software Foundation. <li><a accesskey="1" href="#Introduction">Introduction</a>: What is GHDL, what is VHDL <li><a accesskey="2" href="#Starting-with-GHDL">Starting with GHDL</a>: Build a VHDL program with GHDL <li><a accesskey="3" href="#Invoking-GHDL">Invoking GHDL</a> -<li><a accesskey="4" href="#Simulation-and-run-time">Simulation and run time</a> +<li><a accesskey="4" href="#Simulation-and-runtime">Simulation and runtime</a> <li><a accesskey="5" href="#GHDL-implementation-of-VHDL">GHDL implementation of VHDL</a> <li><a accesskey="6" href="#GHDL-implementation-of-VITAL">GHDL implementation of VITAL</a> <li><a accesskey="7" href="#Flaws-and-bugs-report">Flaws and bugs report</a> @@ -256,7 +258,7 @@ an internal code generator. viewer: you cannot see signal waves. You can still check with a test bench. The current version can produce a <code>VCD</code> file which can be viewed with a wave viewer, as well as <code>ghw</code> files to be viewed by -`<samp><span class="samp">gtkwave</span></samp>'. +‘<samp><span class="samp">gtkwave</span></samp>’. <p><code>GHDL</code> aims at implementing <code>VHDL</code> as defined by IEEE 1076. It supports most of the 1987 standard and most features added by the @@ -322,15 +324,15 @@ file in VHDL terms. <pre class="smallexample"> $ ghdl -a hello.vhdl </pre> <p>This command creates or updates a file <samp><span class="file">work-obj93.cf</span></samp>, which -describes the library `<samp><span class="samp">work</span></samp>'. On GNU/Linux, this command generates a +describes the library ‘<samp><span class="samp">work</span></samp>’. On GNU/Linux, this command generates a file <samp><span class="file">hello.o</span></samp>, which is the object file corresponding to your VHDL program. The object file is not created on Windows. <p>Then, you have to build an executable file. <pre class="smallexample"> $ ghdl -e hello_world </pre> - <p>The `<samp><span class="samp">-e</span></samp>' option means <dfn>elaborate</dfn>. With this option, <code>GHDL</code> -creates code in order to elaborate a design, with the `<samp><span class="samp">hello</span></samp>' + <p>The ‘<samp><span class="samp">-e</span></samp>’ option means <dfn>elaborate</dfn>. With this option, <code>GHDL</code> +creates code in order to elaborate a design, with the ‘<samp><span class="samp">hello</span></samp>’ entity at the top of the hierarchy. <p>On GNU/Linux, the result is an executable program called <samp><span class="file">hello</span></samp> @@ -379,7 +381,7 @@ a full adder described in the <samp><span class="file">adder.vhdl</span></samp> <p>You can analyze this design file: <pre class="smallexample"> $ ghdl -a adder.vhdl </pre> - <p>You can try to execute the `<samp><span class="samp">adder</span></samp>' design, but this is useless, + <p>You can try to execute the ‘<samp><span class="samp">adder</span></samp>’ design, but this is useless, since nothing externally visible will happen. In order to check this full adder, a testbench has to be run. This testbench is very simple, since the adder is also simple: it checks exhaustively all @@ -465,7 +467,7 @@ design and dump a waveform file: <pre class="smallexample"> $ gtkwave adder.vcd </pre> <p>See <a href="#Simulation-options">Simulation options</a>, for more details on the <samp><span class="option">--vcd</span></samp> option and -other run time options. +other runtime options. <div class="node"> <p><hr> @@ -490,14 +492,14 @@ GNU General Public License. A copy is kept on <pre class="smallexample"> $ tar zxvf dlx.tar.gz </pre> <p>In order not to pollute the sources with the library, it is a good idea -to create a <samp><span class="file">work/</span></samp> subdirectory for the `<samp><span class="samp">WORK</span></samp>' library. To +to create a <samp><span class="file">work/</span></samp> subdirectory for the ‘<samp><span class="samp">WORK</span></samp>’ library. To any GHDL commands, we will add the <samp><span class="option">--workdir=work</span></samp> option, so that all files generated by the compiler (except the executable) will be placed in this directory. <pre class="smallexample"> $ cd dlx $ mkdir work </pre> - <p>We will run the `<samp><span class="samp">dlx_test_behaviour</span></samp>' design. We need to analyze + <p>We will run the ‘<samp><span class="samp">dlx_test_behaviour</span></samp>’ design. We need to analyze all the design units for the design hierarchy, in the correct order. GHDL provides an easy way to do this, by importing the sources: <pre class="smallexample"> $ ghdl -i --workdir=work *.vhdl @@ -539,24 +541,24 @@ stop when an assertion above or equal a certain severity level occurs: <ul> <li>clean the design library with the GHDL command: <pre class="smallexample"> $ ghdl --clean --workdir=work - </pre> +</pre> <p>This removes the executable and all the object files. If you want to rebuild the design at this point, just do the make command as shown above. <li>remove the design library with the GHDL command: <pre class="smallexample"> $ ghdl --remove --workdir=work - </pre> +</pre> <p>This removes the executable, all the object files and the library file. If you want to rebuild the design, you have to import the sources again, and to make the design. <li>remove the <samp><span class="file">work/</span></samp> directory: <pre class="smallexample"> $ rm -rf work - </pre> +</pre> <p>Only the executable is kept. If you want to rebuild the design, create the <samp><span class="file">work/</span></samp> directory, import the sources, and make the design. </ul> <p>Sometimes, a design does not fully follow the VHDL standards. For example it -uses the badly engineered `<samp><span class="samp">std_logic_unsigned</span></samp>' package. GHDL supports +uses the badly engineered ‘<samp><span class="samp">std_logic_unsigned</span></samp>’ package. GHDL supports this VHDL dialect through some options: <pre class="smallexample"> --ieee=synopsys -fexplicit </pre> @@ -565,7 +567,7 @@ this VHDL dialect through some options: <div class="node"> <p><hr> <a name="Invoking-GHDL"></a> -Next: <a rel="next" accesskey="n" href="#Simulation-and-run-time">Simulation and run time</a>, +Next: <a rel="next" accesskey="n" href="#Simulation-and-runtime">Simulation and runtime</a>, Previous: <a rel="previous" accesskey="p" href="#Starting-with-GHDL">Starting with GHDL</a>, Up: <a rel="up" accesskey="u" href="#Top">Top</a> @@ -579,7 +581,7 @@ Up: <a rel="up" accesskey="u" href="#Top">Top</a> <pre class="smallexample"> $ ghdl <var>command</var> [<var>options<small class="dots">...</small></var>] </pre> <p>The GHDL program has several commands. The first argument selects -the commands. The options are used to slighly modify the action. +the commands. The options are used to slightly modify the action. <p>No options are allowed before the command. Except for the run commands, no options are allowed after a filename or a unit name. @@ -596,6 +598,7 @@ no options are allowed after a filename or a unit name. <li><a accesskey="9" href="#Misc-commands">Misc commands</a> <li><a href="#Installation-Directory">Installation Directory</a> <li><a href="#IEEE-library-pitfalls">IEEE library pitfalls</a> +<li><a href="#IEEE-math-packages">IEEE math packages</a> </ul> <div class="node"> @@ -641,7 +644,7 @@ Up: <a rel="up" accesskey="u" href="#Building-commands">Building commands</ </pre> <p>The <dfn>analysis</dfn> command compiles one or more files, and creates an object file for each source file. The analysis command is selected with -<var>-a</var> switch. Any argument starting with a dash is a option, the +<var>-a</var> switch. Any argument starting with a dash is an option, the others are filenames. No options are allowed after a filename argument. GHDL analyzes each filename in the given order, and stops the analysis in case of error (the following files are not analyzed). @@ -669,7 +672,7 @@ Up: <a rel="up" accesskey="u" href="#Building-commands">Building commands</ </pre> <p>On GNU/Linux the <dfn>elaboration</dfn> command creates an executable containing the code of the <code>VHDL</code> sources, the elaboration code -and simulation code to execute a design hiearachy. On Windows this +and simulation code to execute a design hierarchy. On Windows this command elaborates the design but does not generate anything. <p>The elaboration command is selected with <var>-e</var> switch, and must be @@ -682,28 +685,28 @@ followed by either: </ul> <p>Name of the units must be a simple name, without any dot. You can -select the name of the `<samp><span class="samp">WORK</span></samp>' library with the <samp><span class="option">--work=NAME</span></samp> +select the name of the ‘<samp><span class="samp">WORK</span></samp>’ library with the <samp><span class="option">--work=NAME</span></samp> option, as described in <a href="#GHDL-options">GHDL options</a>. <p>See <a href="#Top-entity">Top entity</a>, for the restrictions on the root design of a hierarchy. - <p>On GNU/Linux the file name of the executable is the name of the + <p>On GNU/Linux the filename of the executable is the name of the primary unit, or for the later case, the concatenation of the name of the primary unit, a dash, and the name of the secondary unit (or architecture). On Windows there is no executable generated. - <p>The <samp><span class="option">-o</span></samp> followed by a file name can override the default -executable file name. + <p>The <samp><span class="option">-o</span></samp> followed by a filename can override the default +executable filename. <p>For the elaboration command, <code>GHDL</code> re-analyzes all the configurations, entities, architectures and package declarations, and creates the default configurations and the default binding indications according to the LRM rules. It also generates the list of objects files required for the executable. Then, it links all these files with the -run time library. +runtime library. - <p>The actual elaboration is performed at run-time. + <p>The actual elaboration is performed at runtime. <p>On Windows this command can be skipped because it is also done by the run command. @@ -724,24 +727,24 @@ Up: <a rel="up" accesskey="u" href="#Building-commands">Building commands</ <pre class="smallexample"> $ ghdl -r [<var>options</var>] <var>primary_unit</var> [<var>secondary_unit</var>] [<var>simulation_options</var>] </pre> - <p>The options and arguments are the same as the See <a href="#Elaboration-command">Elaboration command</a>. + <p>The options and arguments are the same as for the elaboration command, see <a href="#Elaboration-command">Elaboration command</a>. - <p>On GNU/Linux this command simply build the filename of the executable -and execute it. Options are ignored. You may also directly execute + <p>On GNU/Linux this command simply determines the filename of the executable +and executes it. Options are ignored. You may also directly execute the program. <p>This command exists for three reasons: <ul> <li>You don't have to create the executable program name. -<li>It is coherent with the `<samp><span class="samp">-a</span></samp>' and `<samp><span class="samp">-e</span></samp>' commands. +<li>It is coherent with the ‘<samp><span class="samp">-a</span></samp>’ and ‘<samp><span class="samp">-e</span></samp>’ commands. <li>It works with the Windows implementation, where the code is generated in memory. </ul> - <p>On Windows this command elaborate and launch the simulation. As a consequence + <p>On Windows this command elaborates and launches the simulation. As a consequence you must use the same options used during analysis. - <p>See <a href="#Simulation-and-run-time">Simulation and run time</a>, for details on options. + <p>See <a href="#Simulation-and-runtime">Simulation and runtime</a>, for details on options. <div class="node"> <p><hr> @@ -800,7 +803,7 @@ Up: <a rel="up" accesskey="u" href="#Building-commands">Building commands</ </pre> <p>This performs only the second stage of the elaboration command: the executable is created by linking the files of the object files list. -This command is available only for completness. The elaboration command is +This command is available only for completeness. The elaboration command is equivalent to the bind command followed by the link command. <div class="node"> @@ -814,7 +817,7 @@ Up: <a rel="up" accesskey="u" href="#Building-commands">Building commands</ <h4 class="subsection">3.1.7 List link command</h4> -<p><a name="index-g_t_0040option_007b_002d_002dlist_002dlink_007d-command-13"></a>Disp files which will be linked. +<p><a name="index-g_t_0040option_007b_002d_002dlist_002dlink_007d-command-13"></a>Display files which will be linked. <pre class="smallexample"> $ ghdl --list-link <var>primary_unit</var> [<var>secondary_unit</var>] </pre> @@ -822,7 +825,7 @@ Up: <a rel="up" accesskey="u" href="#Building-commands">Building commands</ <p>This command may be used only after a bind command. GHDL displays all the files which will be linked to create an executable. This command is -intended to add object files in a link of an foreign program. +intended to add object files in a link of a foreign program. <div class="node"> <p><hr> @@ -852,7 +855,7 @@ Up: <a rel="up" accesskey="u" href="#Building-commands">Building commands</ <h4 class="subsection">3.1.9 Analyze and elaborate command</h4> -<p><a name="index-Analyze-and-elaborate-command-16"></a><a name="index-g_t_0040option_007b_002dc_007d-command-17"></a>Analyze files and elaborate in the same time. +<p><a name="index-Analyze-and-elaborate-command-16"></a><a name="index-g_t_0040option_007b_002dc_007d-command-17"></a>Analyze files and elaborate them at the same time. <p>On GNU/Linux: <pre class="smallexample"> $ ghdl -c [<var>options</var>] <var>file</var>... -e <var>primary_unit</var> [<var>secondary_unit</var>] @@ -860,7 +863,7 @@ Up: <a rel="up" accesskey="u" href="#Building-commands">Building commands</ <p>On Windows: <pre class="smallexample"> $ ghdl -c [<var>options</var>] <var>file</var>... -r <var>primary_unit</var> [<var>secondary_unit</var>] </pre> - <p>This command combines analyze and elaboration: <var>file</var>s are analyzed and + <p>This command combines analysis and elaboration: <var>file</var>s are analyzed and the unit is then elaborated. However, code is only generated during the elaboration. On Windows the simulation is launched. @@ -868,11 +871,11 @@ elaboration. On Windows the simulation is launched. drives the analysis. Therefore, there is no analysis order, and you don't need to care about it. - <p>All the units of the files are put into the `<samp><span class="samp">work</span></samp>' library. But, the + <p>All the units of the files are put into the ‘<samp><span class="samp">work</span></samp>’ library. But, the work library is neither read from disk nor saved. Therefore, you must give -all the files of the `<samp><span class="samp">work</span></samp>' library your design needs. +all the files of the ‘<samp><span class="samp">work</span></samp>’ library your design needs. - <p>The advantages over the traditionnal approach (analyze and then elaborate) are: + <p>The advantages over the traditional approach (analyze and then elaborate) are: <ul> <li>The compilation cycle is achieved in one command. <li>Since the files are only parsed once, the compilation cycle may be faster. @@ -882,12 +885,12 @@ do not generate code. </ul> However, you should know that currently most of the time is spent in code generation and the analyze and elaborate command generate code for all units -needed, even units of `<samp><span class="samp">std</span></samp>' and `<samp><span class="samp">ieee</span></samp>' libraries. Therefore, +needed, even units of ‘<samp><span class="samp">std</span></samp>’ and ‘<samp><span class="samp">ieee</span></samp>’ libraries. Therefore, according to the design, the time for this command may be higher than the time for the analyze command followed by the elaborate command. <p>This command is still experimental. In case of problems, you should go back -to the traditionnal way. +to the traditional way. <!-- node-name, next, previous, up --> <div class="node"> @@ -909,93 +912,96 @@ begin with <samp><span class="option">-O</span></samp> or <samp><span class="opt manual for details. <dl> -<dt><code>--work=</code><var>NAME</var><dd><a name="index-g_t_0040option_007b_002d_002dwork_007d-switch-22"></a><a name="index-WORK-library-23"></a>Specify the name of the `<samp><span class="samp">WORK</span></samp>' library. Analyzed units are always -placed in the library logically named `<samp><span class="samp">WORK</span></samp>'. With this option, +<dt><code>--work=</code><var>NAME</var><dd><a name="index-g_t_0040option_007b_002d_002dwork_007d-switch-22"></a><a name="index-WORK-library-23"></a>Specify the name of the ‘<samp><span class="samp">WORK</span></samp>’ library. Analyzed units are always +placed in the library logically named ‘<samp><span class="samp">WORK</span></samp>’. With this option, you can set its name. By default, the name is <var>work</var>. - <p><code>GHDL</code> checks `<samp><span class="samp">WORK</span></samp>' is a valid identifier. Although being -more or less supported, the `<samp><span class="samp">WORK</span></samp>' identifier should not be an + <p><code>GHDL</code> checks whether ‘<samp><span class="samp">WORK</span></samp>’ is a valid identifier. Although being +more or less supported, the ‘<samp><span class="samp">WORK</span></samp>’ identifier should not be an extended identifier, since the filesystem may prevent it from correctly working (due to case sensitivity or forbidden characters in filenames). - <p><code>VHDL</code> rules forbides you to add units in the `<samp><span class="samp">std</span></samp>' library. -Furthermode, you should not put units in the `<samp><span class="samp">ieee</span></samp>' library. + <p><code>VHDL</code> rules forbid you to add units to the ‘<samp><span class="samp">std</span></samp>’ library. +Furthermore, you should not put units in the ‘<samp><span class="samp">ieee</span></samp>’ library. - <br><dt><code>--workdir=</code><var>PATH</var><dd><a name="index-g_t_0040option_007b_002d_002dworkdir_007d-switch-24"></a>Specify the directory where the `<samp><span class="samp">WORK</span></samp>' library is. When this -option is not present, the `<samp><span class="samp">WORK</span></samp>' library is in the current + <br><dt><code>--workdir=</code><var>DIR</var><dd><a name="index-g_t_0040option_007b_002d_002dworkdir_007d-switch-24"></a>Specify the directory where the ‘<samp><span class="samp">WORK</span></samp>’ library is located. When this +option is not present, the ‘<samp><span class="samp">WORK</span></samp>’ library is in the current directory. The object files created by the compiler are always placed -in the same directory as the `<samp><span class="samp">WORK</span></samp>' library. +in the same directory as the ‘<samp><span class="samp">WORK</span></samp>’ library. + + <p>Use option <samp><span class="option">-P</span></samp> to specify where libraries other than ‘<samp><span class="samp">WORK</span></samp>’ +are placed. - <br><dt><code>--std=</code><var>STD</var><dd><a name="index-g_t_0040option_007b_002d_002dstd_007d-switch-25"></a>Specify the standard to use. By default, the standard is `<samp><span class="samp">93c</span></samp>', which + <br><dt><code>--std=</code><var>STD</var><dd><a name="index-g_t_0040option_007b_002d_002dstd_007d-switch-25"></a>Specify the standard to use. By default, the standard is ‘<samp><span class="samp">93c</span></samp>’, which means VHDL-93 accepting VHDL-87 syntax. For details on <var>STD</var> values see <a href="#VHDL-standards">VHDL standards</a>. <br><dt><code>--ieee=</code><var>VER</var><dd><a name="index-g_t_0040option_007b_002d_002dieee_007d-switch-26"></a><a name="index-ieee-library-27"></a><a name="index-synopsys-library-28"></a><a name="index-mentor-library-29"></a>Select the <code>IEEE</code> library to use. <var>VER</var> must be one of: <dl> -<dt>`<samp><span class="samp">none</span></samp>'<dd>Do not supply an <code>IEEE</code> library. Any library clause with the `<samp><span class="samp">IEEE</span></samp>' +<dt>‘<samp><span class="samp">none</span></samp>’<dd>Do not supply an <code>IEEE</code> library. Any library clause with the ‘<samp><span class="samp">IEEE</span></samp>’ identifier will fail, unless you have created by your own a library with the <code>IEEE</code> name. - <br><dt>`<samp><span class="samp">standard</span></samp>'<dd>Supply an <code>IEEE</code> library containing only packages defined by + <br><dt>‘<samp><span class="samp">standard</span></samp>’<dd>Supply an <code>IEEE</code> library containing only packages defined by <span class="sc">ieee</span> standards. Currently, there are the multivalue logic system -packages `<samp><span class="samp">std_logic_1164</span></samp>' defined by IEEE 1164, the synthesis -packages , `<samp><span class="samp">numeric_bit</span></samp>' and `<samp><span class="samp">numeric_std</span></samp>' defined by IEEE -1076.3, and the <span class="sc">vital</span> packages `<samp><span class="samp">vital_timing</span></samp>' and -`<samp><span class="samp">vital_primitives</span></samp>', defined by IEEE 1076.4. The version of these +packages ‘<samp><span class="samp">std_logic_1164</span></samp>’ defined by IEEE 1164, the synthesis +packages , ‘<samp><span class="samp">numeric_bit</span></samp>’ and ‘<samp><span class="samp">numeric_std</span></samp>’ defined by IEEE +1076.3, and the <span class="sc">vital</span> packages ‘<samp><span class="samp">vital_timing</span></samp>’ and +‘<samp><span class="samp">vital_primitives</span></samp>’, defined by IEEE 1076.4. The version of these packages is defined by the VHDL standard used. See <a href="#VITAL-packages">VITAL packages</a>, for more details. - <br><dt>`<samp><span class="samp">synopsys</span></samp>'<dd>Supply the former packages and the following additionnal packages: -`<samp><span class="samp">std_logic_arith</span></samp>', `<samp><span class="samp">std_logic_signed</span></samp>', -`<samp><span class="samp">std_logic_unsigned</span></samp>', `<samp><span class="samp">std_logic_textio</span></samp>'. + <br><dt>‘<samp><span class="samp">synopsys</span></samp>’<dd>Supply the former packages and the following additional packages: +‘<samp><span class="samp">std_logic_arith</span></samp>’, ‘<samp><span class="samp">std_logic_signed</span></samp>’, +‘<samp><span class="samp">std_logic_unsigned</span></samp>’, ‘<samp><span class="samp">std_logic_textio</span></samp>’. <!-- @samp{std_logic_misc}. --> These packages were created by some companies, and are popular. However they are not standard packages, and have been placed in the <code>IEEE</code> -library without the <span class="sc">ieee</span> permission. +library without the permission from the <span class="sc">ieee</span>. - <br><dt>`<samp><span class="samp">mentor</span></samp>'<dd>Supply the standardr packages and the following additionnal package: -`<samp><span class="samp">std_logic_arith</span></samp>'. The package is a slight variation on a definitly + <br><dt>‘<samp><span class="samp">mentor</span></samp>’<dd>Supply the standard packages and the following additional package: +‘<samp><span class="samp">std_logic_arith</span></samp>’. The package is a slight variation of a definitely not standard but widely mis-used package. </dl> <p>To avoid errors, you must use the same <code>IEEE</code> library for all units of your design, and during elaboration. - <br><dt><code>-P</code><var>PATH</var><dd><a name="index-g_t_0040option_007b_002dP_007d-switch-30"></a>Add <var>PATH</var> to the end of the list of directories to be searched for + <br><dt><code>-P</code><var>DIRECTORY</var><dd><a name="index-g_t_0040option_007b_002dP_007d-switch-30"></a>Add <var>DIRECTORY</var> to the end of the list of directories to be searched for library files. <p>The <code>WORK</code> library is always searched in the path specified by the -<samp><span class="option">--workdir=</span></samp> option, or in the current directory if the later +<samp><span class="option">--workdir=</span></samp> option, or in the current directory if the latter option is not specified. <br><dt><code>-fexplicit</code><dd><a name="index-g_t_0040option_007b_002dfexplicit_007d-switch-31"></a>When two operators are overloaded, give preference to the explicit declaration. -This may be used to avoid the most common pitfall of the `<samp><span class="samp">std_logic_arith</span></samp>' +This may be used to avoid the most common pitfall of the ‘<samp><span class="samp">std_logic_arith</span></samp>’ package. See <a href="#IEEE-library-pitfalls">IEEE library pitfalls</a>, for an example. <p>This option is not set by default. I don't think this option is a good feature, because it breaks the encapsulation rule. When set, an -operator can be silently overriden in another package. You'd better to fix -your design and use the `<samp><span class="samp">numeric_std</span></samp>' package. +operator can be silently overridden in another package. You'd better to fix +your design and use the ‘<samp><span class="samp">numeric_std</span></samp>’ package. <br><dt><code>--no-vital-checks</code><br><dt><code>--vital-checks</code><dd><a name="index-g_t_0040option_007b_002d_002dno_002dvital_002dchecks_007d-switch-32"></a><a name="index-g_t_0040option_007b_002d_002dvital_002dchecks_007d-switch-33"></a>Disable or enable checks of restriction on VITAL units. Checks are enabled by default. <p>Checks are performed only when a design unit is decorated by a VITAL attribute. -The VITAL attributes are `<samp><span class="samp">VITAL_Level0</span></samp>' and `<samp><span class="samp">VITAL_Level1</span></samp>', both -declared in the `<samp><span class="samp">ieee.VITAL_Timing</span></samp>' package. +The VITAL attributes are ‘<samp><span class="samp">VITAL_Level0</span></samp>’ and ‘<samp><span class="samp">VITAL_Level1</span></samp>’, both +declared in the ‘<samp><span class="samp">ieee.VITAL_Timing</span></samp>’ package. <p>Currently, VITAL checks are only partially implemented. See <a href="#VHDL-restrictions-for-VITAL">VHDL restrictions for VITAL</a>, for more details. - <br><dt><code>--syn-binding</code><dd><a name="index-g_t_0040option_007b_002d_002dsyn_002dbinding_007d-switch-34"></a>Use synthetizer rules for component binding. During elaboration, if a + <br><dt><code>--syn-binding</code><dd><a name="index-g_t_0040option_007b_002d_002dsyn_002dbinding_007d-switch-34"></a>Use synthesizer rules for component binding. During elaboration, if a component is not bound to an entity using VHDL LRM rules, try to find in any known library an entity whose name is the same as the component name. - <p>This rule is known as synthetizer rule. + <p>This rule is known as synthesizer rule. <p>There are two key points: normal VHDL LRM rules are tried first and -entities are search only in known library. A known library is a +entities are searched only in known library. A known library is a library which has been named in your design. <p>This option is only useful during elaboration. @@ -1025,7 +1031,7 @@ Up: <a rel="up" accesskey="u" href="#Invoking-GHDL">Invoking GHDL</a> <p>These options are only available on GNU/Linux. <p>For many commands, <code>GHDL</code> acts as a driver: it invokes programs to perform -the command. You can pass arbritrary options to these programs. +the command. You can pass arbitrary options to these programs. <p>Both the compiler and the linker are in fact GCC programs. See <a href="gcc.html#Invoking-GCC">GCC options</a>, for details on GCC options. @@ -1050,7 +1056,7 @@ Up: <a rel="up" accesskey="u" href="#Invoking-GHDL">Invoking GHDL</a> <!-- node-name, next, previous, up --> <h3 class="section">3.4 GHDL warnings</h3> -<p>Some contructions are not erroneous but dubious. Warnings are diagnostic +<p>Some constructions are not erroneous but dubious. Warnings are diagnostic messages that report such constructions. Some warnings are reported only during analysis, others during elaboration. @@ -1058,10 +1064,10 @@ during analysis, others during elaboration. instead of <samp><span class="option">--warn-XXX</span></samp>. <dl> -<dt><code>--warn-reserved</code><dd><a name="index-g_t_0040option_007b_002d_002dwarn_002dreserved_007d-switch-40"></a>Emit a warning if an identifier is a reserved word in a latter VHDL standard. +<dt><code>--warn-reserved</code><dd><a name="index-g_t_0040option_007b_002d_002dwarn_002dreserved_007d-switch-40"></a>Emit a warning if an identifier is a reserved word in a later VHDL standard. <br><dt><code>--warn-default-binding</code><dd><a name="index-g_t_0040option_007b_002d_002dwarn_002ddefault_002dbinding_007d-switch-41"></a>During analyze, warns if a component instantiation has neither -configuration specification nor default binding. This may be usefull if you +configuration specification nor default binding. This may be useful if you want to detect during analyze possibly unbound component if you don't use configuration. See <a href="#VHDL-standards">VHDL standards</a>, for more details about default binding rules. @@ -1074,7 +1080,7 @@ binding rules are somewhat complex and an unbound component is most often unexpected. <p>However, warnings are even emitted if a component instantiation is -inside a generate statement. As a consequence, if you use conditionnal +inside a generate statement. As a consequence, if you use the conditional generate statement to select a component according to the implementation, you will certainly get warnings. @@ -1116,8 +1122,8 @@ Up: <a rel="up" accesskey="u" href="#Invoking-GHDL">Invoking GHDL</a> <!-- node-name, next, previous, up --> <h3 class="section">3.5 Rebuilding commands</h3> -<p>Analyzing and elaborating a design consisting in severals files can be tricky, -due to dependences. GHDL has a few commands to rebuild a design. +<p>Analyzing and elaborating a design consisting in several files can be tricky, +due to dependencies. GHDL has a few commands to rebuild a design. <ul class="menu"> <li><a accesskey="1" href="#Import-command">Import command</a> @@ -1137,7 +1143,7 @@ Up: <a rel="up" accesskey="u" href="#Rebuilding-commands">Rebuilding comman <!-- node-name, next, previous, up --> <h4 class="subsection">3.5.1 Import command</h4> -<p><a name="index-importing-files-50"></a><a name="index-g_t_0040option_007b_002di_007d-coomand-51"></a>Add files in the work design library. +<p><a name="index-importing-files-50"></a><a name="index-g_t_0040option_007b_002di_007d-command-51"></a>Add files in the work design library. <pre class="smallexample"> $ ghdl -i [<var>options</var>] <var>file</var>... </pre> @@ -1151,14 +1157,14 @@ an entity name or a configuration name. <p>Since the files are parsed, there must be correct files. However, since they are not analyzed, many errors are tolerated by this command. - <p>Note that all the files are added in the work library. If you have many + <p>Note that all the files are added to the work library. If you have many libraries, you must use the command for each library. <!-- Due to the LRM rules, there may be many analysis orders, producing --> <!-- different results. For example, if an entity has several architectures, --> <!-- the last architecture analyzed is the default one in default binding --> <!-- indications. --> -<p>See <a href="#Make-command">Make command</a>, to actually build the design. + <p>See <a href="#Make-command">Make command</a>, to actually build the design. <div class="node"> <p><hr> @@ -1187,7 +1193,7 @@ recursive. <p>With the <samp><span class="option">-f</span></samp> (force) option, GHDL analyzes all the units of the work library needed to create the design hierarchy. Not outdated units -are recompiled. This is useful if you want to compile a design hierarch +are recompiled. This is useful if you want to compile a design hierarchy with new compilation flags (for example, to add the <samp><span class="option">-g</span></samp> debugging option). @@ -1207,10 +1213,10 @@ that GHDL knows in which file these units are. <p>The make command imports files which have been modified. Then, a design hierarchy is internally built as if no units are outdated. Then, all outdated -design units, using the dependences of the design hierarchy, are analyzed. +design units, using the dependencies of the design hierarchy, are analyzed. If necessary, the design hierarchy is elaborated. - <p>This is not perfect, since defaults architecture (the most recently + <p>This is not perfect, since the default architecture (the most recently analyzed one) may change while outdated design files are analyzed. In such a case, re-run the make command of GHDL. @@ -1252,6 +1258,7 @@ Up: <a rel="up" accesskey="u" href="#Invoking-GHDL">Invoking GHDL</a> <li><a accesskey="1" href="#Directory-command">Directory command</a> <li><a accesskey="2" href="#Clean-command">Clean command</a> <li><a accesskey="3" href="#Remove-command">Remove command</a> +<li><a accesskey="4" href="#Copy-command">Copy command</a> </ul> <div class="node"> @@ -1299,6 +1306,7 @@ clean up. <div class="node"> <p><hr> <a name="Remove-command"></a> +Next: <a rel="next" accesskey="n" href="#Copy-command">Copy command</a>, Previous: <a rel="previous" accesskey="p" href="#Clean-command">Clean command</a>, Up: <a rel="up" accesskey="u" href="#Library-commands">Library commands</a> @@ -1316,6 +1324,25 @@ known anymore by GHDL. <div class="node"> <p><hr> +<a name="Copy-command"></a> +Previous: <a rel="previous" accesskey="p" href="#Remove-command">Remove command</a>, +Up: <a rel="up" accesskey="u" href="#Library-commands">Library commands</a> + +</div> + +<h4 class="subsection">3.6.4 Copy command</h4> + +<p><a name="index-copying-library-61"></a><a name="index-g_t_0040option_007b_002d_002dcopy_007d-command-62"></a>Make a local copy of an existing library. + +<pre class="smallexample"> $ ghdl --copy --work=<var>name</var> [<var>options</var>] +</pre> + <p>Make a local copy of an existing library. This is very useful if you want to +add unit to the ‘<samp><span class="samp">ieee</span></samp>’ library: +<pre class="example"> $ ghdl --copy --work=ieee --ieee=synopsys + $ ghdl -a --work=ieee numeric_unsigned.vhd +</pre> + <div class="node"> +<p><hr> <a name="Cross-reference-command"></a> <a name="Cross_002dreference-command"></a> Next: <a rel="next" accesskey="n" href="#File-commands">File commands</a>, @@ -1335,19 +1362,19 @@ Up: <a rel="up" accesskey="u" href="#Invoking-GHDL">Invoking GHDL</a> line, with syntax highlighting and full cross-reference: every identifier is a link to its declaration. Besides, an index of the files is created too. - <p>The set of <var>file</var> are analyzed, and then, if the analyze is + <p>The set of <var>file</var> are analyzed, and then, if the analysis is successful, html files are generated in the directory specified by the <samp><span class="option">-o </span><var>dir</var></samp> option, or <samp><span class="file">html/</span></samp> directory by default. <p>If the <samp><span class="option">--format=html2</span></samp> is specified, then the generated html files follow the HTML 2.0 standard, and colours are specified with -`<samp><span class="samp"><FONT></span></samp>' tags. However, colours are hard-coded. +‘<samp><span class="samp"><FONT></span></samp>’ tags. However, colours are hard-coded. <p>If the <samp><span class="option">--format=css</span></samp> is specified, then the generated html files follow the HTML 4.0 standard, and use the CSS-1 file <samp><span class="file">ghdl.css</span></samp> to specify colours. This file is generated only if it does not already exist (it is never overwritten) and can be customized by the user to change colours or -appearance. Refer to a generated file and its comments for more informations. +appearance. Refer to a generated file and its comments for more information. <div class="node"> <p><hr> @@ -1361,7 +1388,7 @@ Up: <a rel="up" accesskey="u" href="#Invoking-GHDL">Invoking GHDL</a> <!-- node-name, next, previous, up --> <h3 class="section">3.8 File commands</h3> -<p>The following commands act on one or severals files. They do not analysis +<p>The following commands act on one or several files. They do not analyze files, therefore, they work even if a file has semantic errors. <ul class="menu"> @@ -1383,7 +1410,7 @@ Up: <a rel="up" accesskey="u" href="#File-commands">File commands</a> <!-- node-name, next, previous, up --> <h4 class="subsection">3.8.1 Pretty print command</h4> -<p><a name="index-g_t_0040option_007b_002d_002dpp_002dhtml_007d-command-61"></a><a name="index-pretty-printing-62"></a><a name="index-vhdl-to-html-63"></a> +<p><a name="index-g_t_0040option_007b_002d_002dpp_002dhtml_007d-command-63"></a><a name="index-pretty-printing-64"></a><a name="index-vhdl-to-html-65"></a> Generate HTML on standard output from VHDL. <pre class="smallexample"> $ ghdl --pp-html [<var>options</var>] <var>file</var>... @@ -1391,14 +1418,14 @@ Generate HTML on standard output from VHDL. <p>The files are just scanned and an html file, with syntax highlighting is generated on standard output. - <p>Since the files are not even parsed, erroneous files or uncomplete designs + <p>Since the files are not even parsed, erroneous files or incomplete designs can be pretty printed. <p>The style of the html file can be modified with the <samp><span class="option">--format=</span></samp> option. By default or when the <samp><span class="option">--format=html2</span></samp> option is specified, the output -is an HTML 2.0 file, with colours set throught `<samp><span class="samp"><FONT></span></samp>' tags. When the +is an HTML 2.0 file, with colours set through ‘<samp><span class="samp"><FONT></span></samp>’ tags. When the <samp><span class="option">--format=css</span></samp> option is specified, the output is an HTML 4.0 file, -with colours set through a CSS file, whose name is `<samp><span class="samp">ghdl.css</span></samp>'. +with colours set through a CSS file, whose name is ‘<samp><span class="samp">ghdl.css</span></samp>’. See <a href="#Cross_002dreference-command">Cross-reference command</a>, for more details about this CSS file. <div class="node"> @@ -1413,7 +1440,7 @@ Up: <a rel="up" accesskey="u" href="#File-commands">File commands</a> <!-- node-name, next, previous, up --> <h4 class="subsection">3.8.2 Find command</h4> -<p><a name="index-g_t_0040option_007b_002df_007d-command-64"></a>Display the name of the design units in files. +<p><a name="index-g_t_0040option_007b_002df_007d-command-66"></a>Display the name of the design units in files. <pre class="smallexample"> $ ghdl -f <var>file</var>... </pre> @@ -1433,19 +1460,19 @@ Up: <a rel="up" accesskey="u" href="#File-commands">File commands</a> <!-- node-name, next, previous, up --> <h4 class="subsection">3.8.3 Chop command</h4> -<p><a name="index-g_t_0040option_007b_002d_002dchop_007d-command-65"></a>Chop (or split) files at design unit. +<p><a name="index-g_t_0040option_007b_002d_002dchop_007d-command-67"></a>Chop (or split) files at design unit. <pre class="smallexample"> $ ghdl --chop <var>files</var> </pre> <p><code>GHDL</code> reads files, and writes a file in the current directory for every design unit. - <p>The file name of a design unit is build according to the unit. For an + <p>The filename of a design unit is build according to the unit. For an entity declaration, a package declaration or a configuration the file name is <samp><span class="file">NAME.vhdl</span></samp>, where <var>NAME</var> is the name of the design -unit. For a package body, the file name is <samp><span class="file">NAME-body.vhdl</span></samp>. +unit. For a package body, the filename is <samp><span class="file">NAME-body.vhdl</span></samp>. Finally, for an architecture <var>ARCH</var> of an entity <var>ENTITY</var>, the -file name is <samp><span class="file">ENTITY-ARCH.vhdl</span></samp>. +filename is <samp><span class="file">ENTITY-ARCH.vhdl</span></samp>. <p>Since the input files are parsed, this command aborts in case of syntax error. The command aborts too if a file to be written already exists. @@ -1467,7 +1494,7 @@ Up: <a rel="up" accesskey="u" href="#File-commands">File commands</a> <!-- node-name, next, previous, up --> <h4 class="subsection">3.8.4 Lines command</h4> -<p><a name="index-g_t_0040option_007b_002d_002dlines_007d-command-66"></a>Display on the standard output lines of files preceded by line number. +<p><a name="index-g_t_0040option_007b_002d_002dlines_007d-command-68"></a>Display on the standard output lines of files preceded by line number. <pre class="smallexample"> $ ghdl --lines <var>files</var> </pre> @@ -1503,8 +1530,8 @@ Up: <a rel="up" accesskey="u" href="#Misc-commands">Misc commands</a> <h4 class="subsection">3.9.1 Help command</h4> -<p><a name="index-g_t_0040option_007b_002dh_007d-command-67"></a><a name="index-g_t_0040option_007b_002d_002dhelp_007d-command-68"></a>Display (on the standard output) a short description of the all the commands -available. If the help switch is followed by an command switch, then options +<p><a name="index-g_t_0040option_007b_002dh_007d-command-69"></a><a name="index-g_t_0040option_007b_002d_002dhelp_007d-command-70"></a>Display (on the standard output) a short description of the all the commands +available. If the help switch is followed by a command switch, then options for this later command are displayed. <pre class="smallexample"> $ ghdl --help @@ -1523,7 +1550,7 @@ Up: <a rel="up" accesskey="u" href="#Misc-commands">Misc commands</a> <!-- node-name, next, previous, up --> <h4 class="subsection">3.9.2 Dispconfig command</h4> -<p><a name="index-g_t_0040option_007b_002d_002ddispconfig_007d-command-69"></a><a name="index-display-configuration-70"></a>Display the program pathes and options used by GHDL. +<p><a name="index-g_t_0040option_007b_002d_002ddispconfig_007d-command-71"></a><a name="index-display-configuration-72"></a>Display the program paths and options used by GHDL. <pre class="smallexample"> $ ghdl --dispconfig [<var>options</var>] </pre> @@ -1541,7 +1568,7 @@ Up: <a rel="up" accesskey="u" href="#Misc-commands">Misc commands</a> <!-- node-name, next, previous, up --> <h4 class="subsection">3.9.3 Disp standard command</h4> -<p><a name="index-g_t_0040option_007b_002d_002ddisp_002dstandard_007d-command-71"></a><a name="index-display-_0040samp_007bstd_002estandard_007d-72"></a>Display the `<samp><span class="samp">std.standard</span></samp>' package: +<p><a name="index-g_t_0040option_007b_002d_002ddisp_002dstandard_007d-command-73"></a><a name="index-display-_0040samp_007bstd_002estandard_007d-74"></a>Display the ‘<samp><span class="samp">std.standard</span></samp>’ package: <pre class="smallexample"> $ ghdl --disp-standard [<var>options</var>] </pre> @@ -1556,7 +1583,7 @@ Up: <a rel="up" accesskey="u" href="#Misc-commands">Misc commands</a> <!-- node-name, next, previous, up --> <h4 class="subsection">3.9.4 Version command</h4> -<p><a name="index-g_t_0040option_007b_002d_002dversion_007d-command-73"></a><a name="index-version-74"></a>Display the <code>GHDL</code> version and exit. +<p><a name="index-g_t_0040option_007b_002d_002dversion_007d-command-75"></a><a name="index-version-76"></a>Display the <code>GHDL</code> version and exit. <pre class="smallexample"> $ ghdl --version </pre> @@ -1581,8 +1608,8 @@ which is (in priority order): <li>the <var>GHDL_PREFIX</var> environment variable - <li>a built-in default path. It is an hard-coded path on GNU/Linux and the -value of the `<samp><span class="samp">HKLM\Software\Ghdl\Install_Dir</span></samp>' registry entry on Windows. + <li>a built-in default path. It is a hard-coded path on GNU/Linux and the +value of the ‘<samp><span class="samp">HKLM\Software\Ghdl\Install_Dir</span></samp>’ registry entry on Windows. </ol> <p>You should use the <samp><span class="option">--dispconfig</span></samp> command (see <a href="#Dispconfig-command">Dispconfig command</a> for details) to disp and debug installation problems. @@ -1590,6 +1617,7 @@ value of the `<samp><span class="samp">HKLM\Software\Ghdl\Install_Dir</span></sa <div class="node"> <p><hr> <a name="IEEE-library-pitfalls"></a> +Next: <a rel="next" accesskey="n" href="#IEEE-math-packages">IEEE math packages</a>, Previous: <a rel="previous" accesskey="p" href="#Installation-Directory">Installation Directory</a>, Up: <a rel="up" accesskey="u" href="#Invoking-GHDL">Invoking GHDL</a> @@ -1600,14 +1628,14 @@ Up: <a rel="up" accesskey="u" href="#Invoking-GHDL">Invoking GHDL</a> <p>When you use options <samp><span class="option">--ieee=synopsys</span></samp> or <samp><span class="option">--ieee=mentor</span></samp>, the <code>IEEE</code> library contains non standard packages such as -`<samp><span class="samp">std_logic_arith</span></samp>'. <!-- FIXME: ref --> +‘<samp><span class="samp">std_logic_arith</span></samp>’. <!-- FIXME: ref --> <p>These packages are not standard because there are not described by an IEEE standard, even if they have been put in the <code>IEEE</code> library. Furthermore, -they are not really de-facto standard, because there a slight differences +they are not really de-facto standard, because there are slight differences between the packages of Mentor and those of Synopsys. - <p>Furthermore, since they are not well-thought, their use have pitfalls. For + <p>Furthermore, since they are not well-thought, their use has pitfalls. For example, this description has error during compilation: <pre class="example"> library ieee; use ieee.std_logic_1164.all; @@ -1656,10 +1684,10 @@ have been split for readability): <p>Indeed, the <code>"="</code> operator is defined in both packages, and both are visible at the place it is used. The first declaration is an implicit one, which occurs when the <code>std_logic_vector</code> type is -declared and is a element to element comparaison, the second one is an -explicit declared function, with the semantic of an unsigned comparaison. +declared and is an element to element comparison, the second one is an +explicit declared function, with the semantic of an unsigned comparison. - <p>With some analyser, the explicit declaration has priority on the implicit + <p>With some analyser, the explicit declaration has priority over the implicit declaration, and this design can be analyzed without error. However, this is not the rule given by the VHDL LRM, and since GHDL follows these rules, it emits an error. @@ -1692,7 +1720,7 @@ See <a href="#GHDL-options">GHDL options</a>, for more details. end fixed_bad; </pre> <p>It is better to only use the standard packages defined by IEEE, which -provides the same functionnalities: +provides the same functionalities: <pre class="example"> library ieee; use ieee.numeric_std.all; @@ -1718,7 +1746,51 @@ provides the same functionnalities: </pre> <div class="node"> <p><hr> -<a name="Simulation-and-run-time"></a> +<a name="IEEE-math-packages"></a> +Previous: <a rel="previous" accesskey="p" href="#IEEE-library-pitfalls">IEEE library pitfalls</a>, +Up: <a rel="up" accesskey="u" href="#Invoking-GHDL">Invoking GHDL</a> + +</div> + +<!-- node-name, next, previous, up --> +<h3 class="section">3.12 IEEE math packages</h3> + +<p><a name="index-Math_005fReal-77"></a><a name="index-Math_005fComplex-78"></a> +The ‘<samp><span class="samp">ieee</span></samp>’ math packages (‘<samp><span class="samp">math_real</span></samp>’ and +‘<samp><span class="samp">math_complex</span></samp>’) provided with <code>GHDL</code> are not fully compliant with +the <code>IEEE</code> standard. They are based on an early draft which can be +redistributed contrary to the final version of the package. + + <p>This is unfortunate and may generate errors as some declarations are missing +or have slightly changed. + + <p>If you have bought the standard from ‘<samp><span class="samp">ieee</span></samp>’ then you can download +the sources of the packages from +<a href="http://standards.ieee.org/downloads/1076/1076.2-1996">http://standards.ieee.org/downloads/1076/1076.2-1996</a> +(unrestricted access). You'd better to just download +<samp><span class="file">math_real.vhdl</span></samp>, <samp><span class="file">math_real-body.vhdl</span></samp>, +<samp><span class="file">math_complex.vhdl</span></samp> and <samp><span class="file">math_complex-body.vhdl</span></samp>. The other files +are not necessary: the ‘<samp><span class="samp">std_logic_1164</span></samp>’ package has to be updated for +<code>VHDL</code> 1993 (the <code>xnor</code> functions are commented out). + + <p>If you want to replace math packages for the standard version of the +<code>ieee</code> library, do: +<pre class="smallexample"> $ cp math_real.vhdl math_real-body.vhdl <samp><span class="file">ieee_install_dir</span></samp> + $ cp math_complex.vhdl math_complex-body.vhdl <samp><span class="file">ieee_install_dir</span></samp> + $ cd <samp><span class="file">ieee_install_dir</span></samp> + $ ghdl -a --work=ieee math_real.vhdl math_real-body.vhdl + $ ghdl -a --work=ieee math_complex.vhdl math_complex-body.vhdl +</pre> + <p>(Replace <samp><span class="file">ieee_install_dir</span></samp> by the location of the <code>ieee</code> library as +displayed by ‘<samp><span class="samp">ghdl -dispconfig</span></samp>’). + + <p>You can repeat this for the ‘<samp><span class="samp">synopsys</span></samp>’ version of the <code>ieee</code> library. + + <p>Don't forget that the math packages are only defined for the 1993 standard. + +<div class="node"> +<p><hr> +<a name="Simulation-and-runtime"></a> Next: <a rel="next" accesskey="n" href="#GHDL-implementation-of-VHDL">GHDL implementation of VHDL</a>, Previous: <a rel="previous" accesskey="p" href="#Invoking-GHDL">Invoking GHDL</a>, Up: <a rel="up" accesskey="u" href="#Top">Top</a> @@ -1726,7 +1798,7 @@ Up: <a rel="up" accesskey="u" href="#Top">Top</a> </div> <!-- node-name, next, previous, up --> -<h2 class="chapter">4 Simulation and run time</h2> +<h2 class="chapter">4 Simulation and runtime</h2> <ul class="menu"> <li><a accesskey="1" href="#Simulation-options">Simulation options</a> @@ -1737,8 +1809,8 @@ Up: <a rel="up" accesskey="u" href="#Top">Top</a> <p><hr> <a name="Simulation-options"></a> Next: <a rel="next" accesskey="n" href="#Debugging-VHDL-programs">Debugging VHDL programs</a>, -Previous: <a rel="previous" accesskey="p" href="#Simulation-and-run-time">Simulation and run time</a>, -Up: <a rel="up" accesskey="u" href="#Simulation-and-run-time">Simulation and run time</a> +Previous: <a rel="previous" accesskey="p" href="#Simulation-and-runtime">Simulation and runtime</a>, +Up: <a rel="up" accesskey="u" href="#Simulation-and-runtime">Simulation and runtime</a> </div> @@ -1746,42 +1818,50 @@ Up: <a rel="up" accesskey="u" href="#Simulation-and-run-time">Simulation an <h3 class="section">4.1 Simulation options</h3> <p>In most system environments, it is possible to pass options while -invoking a program. Contrary to most programming language, there is no +invoking a program. Contrary to most programming languages, there is no standard method in VHDL to obtain the arguments or to set the exit status. <p>In GHDL, it is impossible to pass parameters to your design. A later version could do it through the generics interfaces of the top entity. - <p>However, the GHDL run time behaviour can be modified with some options; for + <p>However, the GHDL runtime behaviour can be modified with some options; for example, it is possible to stop simulation after a certain time. - <p>The exit status of the simulation is `<samp><span class="samp">EXIT_SUCCESS</span></samp>' (0) if the -simulation completes, or `<samp><span class="samp">EXIT_FAILURE</span></samp>' (1) in case of error + <p>The exit status of the simulation is ‘<samp><span class="samp">EXIT_SUCCESS</span></samp>’ (0) if the +simulation completes, or ‘<samp><span class="samp">EXIT_FAILURE</span></samp>’ (1) in case of error (assertion failure, overflow or any constraint error). <p>Here is the list of the most useful options. Some debugging options are -also available, but not described here. The `<samp><span class="samp">--help</span></samp>' options lists +also available, but not described here. The ‘<samp><span class="samp">--help</span></samp>’ options lists all options available, including the debugging one. <dl> -<dt><code>--assert-level=</code><var>LEVEL</var><dd><a name="index-g_t_0040option_007b_002d_002dassert_002dlevel_007d-option-75"></a>Select the assertion level at which an assertion violation stops the +<dt><code>--assert-level=</code><var>LEVEL</var><dd><a name="index-g_t_0040option_007b_002d_002dassert_002dlevel_007d-option-79"></a>Select the assertion level at which an assertion violation stops the simulation. <var>LEVEL</var> is the name from the <code>severity_level</code> enumerated type defined in the <code>standard</code> package or the -`<samp><span class="samp">none</span></samp>' name. +‘<samp><span class="samp">none</span></samp>’ name. - <p>By default, only assertion violation of severity level `<samp><span class="samp">failure</span></samp>' + <p>By default, only assertion violation of severity level ‘<samp><span class="samp">failure</span></samp>’ stops the simulation. - <p>For example, if <var>LEVEL</var> was `<samp><span class="samp">warning</span></samp>', any assertion violation -with severity level `<samp><span class="samp">warning</span></samp>', `<samp><span class="samp">error</span></samp>' or `<samp><span class="samp">failure</span></samp>' would -stop simulation, but the assertion violation at the `<samp><span class="samp">note</span></samp>' severity + <p>For example, if <var>LEVEL</var> was ‘<samp><span class="samp">warning</span></samp>’, any assertion violation +with severity level ‘<samp><span class="samp">warning</span></samp>’, ‘<samp><span class="samp">error</span></samp>’ or ‘<samp><span class="samp">failure</span></samp>’ would +stop simulation, but the assertion violation at the ‘<samp><span class="samp">note</span></samp>’ severity level would only display a message. - <p>`<samp><span class="samp">--assert-level=none</span></samp>' prevents any assertion violation to stop + <p>‘<samp><span class="samp">--assert-level=none</span></samp>’ prevents any assertion violation to stop simulation. - <br><dt><code>--stop-time=</code><var>TIME</var><dd><a name="index-g_t_0040option_007b_002d_002dstop_002dtime_007d-option-76"></a>Stop the simulation after <var>TIME</var>. <var>TIME</var> is expressed as a time + <br><dt><code>--ieee-asserts=</code><var>POLICY</var><dd><a name="index-g_t_0040option_007b_002d_002dieee_002dasserts_007d-option-80"></a>Select how the assertions from ‘<samp><span class="samp">ieee</span></samp>’ units are +handled. <var>POLICY</var> can be ‘<samp><span class="samp">enable</span></samp>’ (the default), +‘<samp><span class="samp">disable</span></samp>’ which disables all assertion from ‘<samp><span class="samp">ieee</span></samp>’ packages +and ‘<samp><span class="samp">disable-at-0</span></samp>’ which disables only at start of simulation. + + <p>This option can be useful to avoid assertion message from +‘<samp><span class="samp">ieee.numeric_std</span></samp>’ (and other ‘<samp><span class="samp">ieee</span></samp>’ packages). + + <br><dt><code>--stop-time=</code><var>TIME</var><dd><a name="index-g_t_0040option_007b_002d_002dstop_002dtime_007d-option-81"></a>Stop the simulation after <var>TIME</var>. <var>TIME</var> is expressed as a time value, <em>without</em> any space. The time is the simulation time, not the real clock time. @@ -1789,36 +1869,36 @@ the real clock time. <pre class="smallexample"> $ ./my_design --stop-time=10ns $ ./my_design --stop-time=ps - </pre> - <br><dt><code>--stop-delta=</code><var>N</var><dd><a name="index-g_t_0040option_007b_002d_002dstop_002ddelta_007d-option-77"></a>Stop the simulation after <var>N</var> delta cycles in the same current time. +</pre> + <br><dt><code>--stop-delta=</code><var>N</var><dd><a name="index-g_t_0040option_007b_002d_002dstop_002ddelta_007d-option-82"></a>Stop the simulation after <var>N</var> delta cycles in the same current time. <!-- Delta cycles is a simulation technic used by VHDL to --> - <br><dt><code>--disp-time</code><dd><a name="index-g_t_0040option_007b_002d_002ddisp_002dtime_007d-option-78"></a><a name="index-display-time-79"></a>Display the time and delta cycle number as simulation advances. + <br><dt><code>--disp-time</code><dd><a name="index-g_t_0040option_007b_002d_002ddisp_002dtime_007d-option-83"></a><a name="index-display-time-84"></a>Display the time and delta cycle number as simulation advances. - <br><dt><code>--disp-tree[</code><var>=KIND</var><code>]</code><dd><a name="index-g_t_0040option_007b_002d_002ddisp_002dtree_007d-option-80"></a><a name="index-display-design-hierarchy-81"></a>Display the design hierarchy as a tree of instantiated design entities. + <br><dt><code>--disp-tree[</code><var>=KIND</var><code>]</code><dd><a name="index-g_t_0040option_007b_002d_002ddisp_002dtree_007d-option-85"></a><a name="index-display-design-hierarchy-86"></a>Display the design hierarchy as a tree of instantiated design entities. This may be useful to understand the structure of a complex design. <var>KIND</var> is optional, but if set must be one of: <dl> -<dt>`<samp><span class="samp">none</span></samp>'<dd>Do not display hierarchy. Same as if the option was not present. -<br><dt>`<samp><span class="samp">inst</span></samp>'<dd>Display entities, architectures, instances, blocks and generates statements. -<br><dt>`<samp><span class="samp">proc</span></samp>'<dd>Like `<samp><span class="samp">inst</span></samp>' but also display processes. -<br><dt>`<samp><span class="samp">port</span></samp>'<dd>Like `<samp><span class="samp">proc</span></samp>' but display ports and signals too. +<dt>‘<samp><span class="samp">none</span></samp>’<dd>Do not display hierarchy. Same as if the option was not present. +<br><dt>‘<samp><span class="samp">inst</span></samp>’<dd>Display entities, architectures, instances, blocks and generates statements. +<br><dt>‘<samp><span class="samp">proc</span></samp>’<dd>Like ‘<samp><span class="samp">inst</span></samp>’ but also display processes. +<br><dt>‘<samp><span class="samp">port</span></samp>’<dd>Like ‘<samp><span class="samp">proc</span></samp>’ but display ports and signals too. </dl> If <var>KIND</var> is not specified, the hierarchy is displayed with the -`<samp><span class="samp">port</span></samp>' mode. +‘<samp><span class="samp">port</span></samp>’ mode. - <br><dt><code>--no-run</code><dd><a name="index-g_t_0040option_007b_002d_002dno_002drun_007d-option-82"></a>Do not simulate, only elaborate. This may be used with + <br><dt><code>--no-run</code><dd><a name="index-g_t_0040option_007b_002d_002dno_002drun_007d-option-87"></a>Do not simulate, only elaborate. This may be used with <samp><span class="option">--disp-tree</span></samp> to display the tree without simulating the whole design. - <br><dt><code>--vcd=</code><var>FILENAME</var><br><dt><code>--vcdgz=</code><var>FILENAME</var><dd><a name="index-g_t_0040option_007b_002d_002dvcd_007d-option-83"></a><a name="index-g_t_0040option_007b_002d_002dvcdgz_007d-option-84"></a><a name="index-vcd-85"></a><a name="index-value-change-dump-86"></a><a name="index-dump-of-signals-87"></a><samp><span class="option">--vcd</span></samp> dumps into the VCD file <var>FILENAME</var> the signal -values before each non-delta cycle. If <var>FILENAME</var> is `<samp><span class="samp">-</span></samp>', + <br><dt><code>--vcd=</code><var>FILENAME</var><br><dt><code>--vcdgz=</code><var>FILENAME</var><dd><a name="index-g_t_0040option_007b_002d_002dvcd_007d-option-88"></a><a name="index-g_t_0040option_007b_002d_002dvcdgz_007d-option-89"></a><a name="index-vcd-90"></a><a name="index-value-change-dump-91"></a><a name="index-dump-of-signals-92"></a><samp><span class="option">--vcd</span></samp> dumps into the VCD file <var>FILENAME</var> the signal +values before each non-delta cycle. If <var>FILENAME</var> is ‘<samp><span class="samp">-</span></samp>’, then the standard output is used, otherwise a file is created or overwritten. <p>The <samp><span class="option">--vcdgz</span></samp> option is the same as the <samp><span class="option">--vcd</span></samp> option, but the output is compressed using the <code>zlib</code> (<code>gzip</code> -compression). However, you can't use the `<samp><span class="samp">-</span></samp>' filename. +compression). However, you can't use the ‘<samp><span class="samp">-</span></samp>’ filename. Furthermore, only one VCD file can be written. <p><dfn>VCD</dfn> (value change dump) is a file format defined @@ -1827,17 +1907,17 @@ by the <code>verilog</code> standard and used by virtually any wave viewer. <p>Since it comes from <code>verilog</code>, only a few VHDL types can be dumped. GHDL dumps only signals whose base type is of the following: <ul> -<li>types defined in the `<samp><span class="samp">std.standard</span></samp>' package: +<li>types defined in the ‘<samp><span class="samp">std.standard</span></samp>’ package: <ul> -<li>`<samp><span class="samp">bit</span></samp>' -<li>`<samp><span class="samp">bit_vector</span></samp>' +<li>‘<samp><span class="samp">bit</span></samp>’ +<li>‘<samp><span class="samp">bit_vector</span></samp>’ </ul> - <li>types defined in the `<samp><span class="samp">ieee.std_logic_1164</span></samp>' package: + <li>types defined in the ‘<samp><span class="samp">ieee.std_logic_1164</span></samp>’ package: <ul> -<li>`<samp><span class="samp">std_ulogic</span></samp>' -<li>`<samp><span class="samp">std_logic</span></samp>' (because it is a subtype of `<samp><span class="samp">std_ulogic</span></samp>') -<li>`<samp><span class="samp">std_ulogic_vector</span></samp>' -<li>`<samp><span class="samp">std_logic_vector</span></samp>' +<li>‘<samp><span class="samp">std_ulogic</span></samp>’ +<li>‘<samp><span class="samp">std_logic</span></samp>’ (because it is a subtype of ‘<samp><span class="samp">std_ulogic</span></samp>’) +<li>‘<samp><span class="samp">std_ulogic_vector</span></samp>’ +<li>‘<samp><span class="samp">std_logic_vector</span></samp>’ </ul> <li>any integer type </ul> @@ -1851,11 +1931,11 @@ dumped, which can generate big files. format supporting VHDL types. If you are aware of such a free format, please mail me (see <a href="#Reporting-bugs">Reporting bugs</a>). - <br><dt><code>--wave=</code><var>FILENAME</var><dd><a name="index-g_t_0040option_007b_002d_002dwave_007d-option-88"></a>Write the waveforms into a <code>ghw</code> (GHdl Waveform) file. Currently, all + <br><dt><code>--wave=</code><var>FILENAME</var><dd><a name="index-g_t_0040option_007b_002d_002dwave_007d-option-93"></a>Write the waveforms into a <code>ghw</code> (GHdl Waveform) file. Currently, all the signals are dumped into the waveform file, you cannot select a hierarchy of signals to be dumped. - <p>The format of this file was defined by myself and is not yet completly fixed. + <p>The format of this file was defined by myself and is not yet completely fixed. It may change slightly. <p>There is a patch against <code>gtkwave 1.3.72</code> on the ghdl website at @@ -1863,9 +1943,9 @@ It may change slightly. <p>Contrary to VCD files, any VHDL type can be dumped into a GHW file. - <br><dt><code>--sdf=</code><var>PATH</var><code>=</code><var>FILENAME</var><br><dt><code>--sdf=min=</code><var>PATH</var><code>=</code><var>FILENAME</var><br><dt><code>--sdf=typ=</code><var>PATH</var><code>=</code><var>FILENAME</var><br><dt><code>--sdf=max=</code><var>PATH</var><code>=</code><var>FILENAME</var><dd><a name="index-g_t_0040option_007b_002d_002dsdf_007d-option-89"></a>Do VITAL annotation on <var>PATH</var> with SDF file <var>FILENAME</var>. + <br><dt><code>--sdf=</code><var>PATH</var><code>=</code><var>FILENAME</var><br><dt><code>--sdf=min=</code><var>PATH</var><code>=</code><var>FILENAME</var><br><dt><code>--sdf=typ=</code><var>PATH</var><code>=</code><var>FILENAME</var><br><dt><code>--sdf=max=</code><var>PATH</var><code>=</code><var>FILENAME</var><dd><a name="index-g_t_0040option_007b_002d_002dsdf_007d-option-94"></a>Do VITAL annotation on <var>PATH</var> with SDF file <var>FILENAME</var>. - <p><var>PATH</var> is a path of instances, separated with `<samp><span class="samp">.</span></samp>' or `<samp><span class="samp">/</span></samp>'. + <p><var>PATH</var> is a path of instances, separated with ‘<samp><span class="samp">.</span></samp>’ or ‘<samp><span class="samp">/</span></samp>’. Any separator can be used. Instances are component instantiation labels, generate labels or block labels. Currently, you cannot use an indexed name. @@ -1876,14 +1956,14 @@ the annotator use the typical delay. <p>See <a href="#Backannotation">Backannotation</a>, for more details. - <br><dt><code>--stack-max-size=</code><var>SIZE</var><dd><a name="index-g_t_0040option_007b_002d_002dstack_002dmax_002dsize_007d-option-90"></a>Set the maximum size in bytes of the non-sensitized processes stacks. + <br><dt><code>--stack-max-size=</code><var>SIZE</var><dd><a name="index-g_t_0040option_007b_002d_002dstack_002dmax_002dsize_007d-option-95"></a>Set the maximum size in bytes of the non-sensitized processes stacks. - <p>If the value <var>SIZE</var> is followed (without any space) by the `<samp><span class="samp">k</span></samp>', -`<samp><span class="samp">K</span></samp>', `<samp><span class="samp">kb</span></samp>', `<samp><span class="samp">Kb</span></samp>', `<samp><span class="samp">ko</span></samp>' or `<samp><span class="samp">Ko</span></samp>' multiplier, then + <p>If the value <var>SIZE</var> is followed (without any space) by the ‘<samp><span class="samp">k</span></samp>’, +‘<samp><span class="samp">K</span></samp>’, ‘<samp><span class="samp">kb</span></samp>’, ‘<samp><span class="samp">Kb</span></samp>’, ‘<samp><span class="samp">ko</span></samp>’ or ‘<samp><span class="samp">Ko</span></samp>’ multiplier, then the size is the numeric value multiplied by 1024. - <p>If the value <var>SIZE</var> is followed (without any space) by the `<samp><span class="samp">m</span></samp>', -`<samp><span class="samp">M</span></samp>', `<samp><span class="samp">mb</span></samp>', `<samp><span class="samp">Mb</span></samp>', `<samp><span class="samp">mo</span></samp>' or `<samp><span class="samp">Mo</span></samp>' multiplier, then + <p>If the value <var>SIZE</var> is followed (without any space) by the ‘<samp><span class="samp">m</span></samp>’, +‘<samp><span class="samp">M</span></samp>’, ‘<samp><span class="samp">mb</span></samp>’, ‘<samp><span class="samp">Mb</span></samp>’, ‘<samp><span class="samp">mo</span></samp>’ or ‘<samp><span class="samp">Mo</span></samp>’ multiplier, then the size is the numeric value multiplied by 1024 * 1024 = 1048576. <p>Each non-sensitized process has its own stack, while the sensitized processes @@ -1893,27 +1973,27 @@ operating system. <p>Using too small stacks may result in simulation failure due to lack of memory. Using too big stacks may reduce the maximum number of processes. - <br><dt><code>--stack-size=</code><var>SIZE</var><dd><a name="index-g_t_0040option_007b_002d_002dstack_002dsize_007d-option-91"></a>Set the initial size in bytes of the non-sensitized processes stack. + <br><dt><code>--stack-size=</code><var>SIZE</var><dd><a name="index-g_t_0040option_007b_002d_002dstack_002dsize_007d-option-96"></a>Set the initial size in bytes of the non-sensitized processes stack. The <var>SIZE</var> value has the same format as the previous option. <p>The stack of the non-sensitized processes grows until reaching the maximum size limit. - <br><dt><code>--help</code><dd>Display a short description of the options accepted by the run time library. + <br><dt><code>--help</code><dd>Display a short description of the options accepted by the runtime library. </dl> <div class="node"> <p><hr> <a name="Debugging-VHDL-programs"></a> Previous: <a rel="previous" accesskey="p" href="#Simulation-options">Simulation options</a>, -Up: <a rel="up" accesskey="u" href="#Simulation-and-run-time">Simulation and run time</a> +Up: <a rel="up" accesskey="u" href="#Simulation-and-runtime">Simulation and runtime</a> </div> <!-- node-name, next, previous, up --> <h3 class="section">4.2 Debugging VHDL programs</h3> -<p><a name="index-debugging-92"></a><a name="index-g_t_0040code_007b_005f_005fghdl_005ffatal_007d-93"></a>Debugging VHDL programs usign <code>GDB</code> is possible only on GNU/Linux systems. +<p><a name="index-debugging-97"></a><a name="index-g_t_0040code_007b_005f_005fghdl_005ffatal_007d-98"></a>Debugging VHDL programs using <code>GDB</code> is possible only on GNU/Linux systems. <p><code>GDB</code> is a general purpose debugger for programs compiled by <code>GCC</code>. Currently, there is no VHDL support for <code>GDB</code>. It may be difficult @@ -1921,9 +2001,9 @@ to inspect variables or signals in <code>GDB</code>, however, <code>GDB</code> i still able to display the stack frame in case of error or to set a breakpoint at a specified line. - <p><code>GDB</code> can be useful to precisely catch a run-time error, such as indexing + <p><code>GDB</code> can be useful to precisely catch a runtime error, such as indexing an array beyond its bounds. All error check subprograms call the -<code>__ghdl_fatal</code> procedure. Therefore, to catch run-time error, set +<code>__ghdl_fatal</code> procedure. Therefore, to catch runtime error, set a breakpoint like this: <pre class="smallexample"> (gdb) break __ghdl_fatal </pre> @@ -1934,7 +2014,7 @@ display the stack frames. <p><hr> <a name="GHDL-implementation-of-VHDL"></a> Next: <a rel="next" accesskey="n" href="#GHDL-implementation-of-VITAL">GHDL implementation of VITAL</a>, -Previous: <a rel="previous" accesskey="p" href="#Simulation-and-run-time">Simulation and run time</a>, +Previous: <a rel="previous" accesskey="p" href="#Simulation-and-runtime">Simulation and runtime</a>, Up: <a rel="up" accesskey="u" href="#Top">Top</a> </div> @@ -1967,7 +2047,7 @@ Up: <a rel="up" accesskey="u" href="#GHDL-implementation-of-VHDL">GHDL impl <!-- node-name, next, previous, up --> <h3 class="section">5.1 VHDL standards</h3> -<p><a name="index-VHDL-standards-94"></a><a name="index-IEEE-1076-95"></a><a name="index-IEEE-1076a-96"></a><a name="index-g_t1076-97"></a><a name="index-g_t1076a-98"></a><a name="index-v87-99"></a><a name="index-v93-100"></a><a name="index-v93c-101"></a><a name="index-v00-102"></a><a name="index-v02-103"></a>This is very unfortunate, but there are many versions of the VHDL language. +<p><a name="index-VHDL-standards-99"></a><a name="index-IEEE-1076-100"></a><a name="index-IEEE-1076a-101"></a><a name="index-g_t1076-102"></a><a name="index-g_t1076a-103"></a><a name="index-v87-104"></a><a name="index-v93-105"></a><a name="index-v93c-106"></a><a name="index-v00-107"></a><a name="index-v02-108"></a>This is very unfortunate, but there are many versions of the VHDL language. <p>The VHDL language was first standardized in 1987 by IEEE as IEEE 1076-1987, and is commonly referred as VHDL-87. This is certainly the most important version, @@ -1979,7 +2059,7 @@ to give reasonable ways of interpreting the unclear portions of the standard. <p>VHDL was revised in 1993 by IEEE as IEEE 1076-1993. This revision is still well-known. - <p>Unfortunatly, VHDL-93 is not fully compatible with VHDL-87, ie some perfectly + <p>Unfortunately, VHDL-93 is not fully compatible with VHDL-87, i.e. some perfectly valid VHDL-87 programs are invalid VHDL-93 programs. Here are some of the reasons: @@ -2001,28 +2081,28 @@ before). <p>Minors corrections were added by the 2002 revision of the VHDL standard. This revision is not fully backward compatible with VHDL-00 since, for example, -the value of the <code>'instance_name</code> attribute has slighly changed. +the value of the <code>'instance_name</code> attribute has slightly changed. <p>You can select the VHDL standard expected by GHDL with the -`<samp><span class="samp">--std=VER</span></samp>' option, where <var>VER</var> is one of the left column of the +‘<samp><span class="samp">--std=VER</span></samp>’ option, where <var>VER</var> is one of the left column of the table below: <dl> -<dt>`<samp><span class="samp">87</span></samp>'<dd>Select VHDL-87 standard as defined by IEEE 1076-1987. LRM bugs corrected by +<dt>‘<samp><span class="samp">87</span></samp>’<dd>Select VHDL-87 standard as defined by IEEE 1076-1987. LRM bugs corrected by later revisions are taken into account. -<br><dt>`<samp><span class="samp">93</span></samp>'<dd>Select VHDL-93; VHDL-87 file declarations are not accepted. -<br><dt>`<samp><span class="samp">93c</span></samp>'<dd>Select VHDL-93 standard with relaxed rules: +<br><dt>‘<samp><span class="samp">93</span></samp>’<dd>Select VHDL-93; VHDL-87 file declarations are not accepted. +<br><dt>‘<samp><span class="samp">93c</span></samp>’<dd>Select VHDL-93 standard with relaxed rules: <ul> <li>VHDL-87 file declarations are accepted; <li>default binding indication rules of VHDL-02 are used. Default binding rules -are often used, but they are particulary obscure before VHDL-02. +are often used, but they are particularly obscure before VHDL-02. </ul> - <br><dt>`<samp><span class="samp">00</span></samp>'<dd>Select VHDL-2000 standard, which adds protected types. -<br><dt>`<samp><span class="samp">02</span></samp>'<dd>Select VHDL-2002 standard (partially implemented). + <br><dt>‘<samp><span class="samp">00</span></samp>’<dd>Select VHDL-2000 standard, which adds protected types. +<br><dt>‘<samp><span class="samp">02</span></samp>’<dd>Select VHDL-2002 standard (partially implemented). </dl> <p>You cannot mix VHDL-87 and VHDL-93 units. A design hierarchy must have been -completly analyzed using either the 87 or the 93 version of the VHDL standard. +completely analyzed using either the 87 or the 93 version of the VHDL standard. <div class="node"> <p><hr> @@ -2048,7 +2128,7 @@ GHDL may contain one or more design units. <p>It is common to have several design units in a design file. <p>GHDL does not impose any restriction on the name of a design file -(except that the file name may not contain any control character or +(except that the filename may not contain any control character or spaces). <p>GHDL do not keep a binary representation of the design units analyzed like @@ -2069,17 +2149,17 @@ Up: <a rel="up" accesskey="u" href="#GHDL-implementation-of-VHDL">GHDL impl <h3 class="section">5.3 Library database</h3> <p>Each design unit analyzed is placed into a design library. By default, -the name of this design library is `<samp><span class="samp">work</span></samp>'; however, this can be +the name of this design library is ‘<samp><span class="samp">work</span></samp>’; however, this can be changed with the <samp><span class="option">--work=NAME</span></samp> option of GHDL. <p>To keep the list of design units in a design library, GHDL creates -library files. The name of these files is `<samp><span class="samp">NAME-objVER.cf</span></samp>', where +library files. The name of these files is ‘<samp><span class="samp">NAME-objVER.cf</span></samp>’, where <var>NAME</var> is the name of the library, and <var>VER</var> the VHDL version (87 or 93) used to analyze the design units. <p>You don't have to know how to read a library file. You can display it using the <samp><span class="option">-d</span></samp> of <code>ghdl</code>. The file contains the name of the -design units, as well as the location and the dependences. +design units, as well as the location and the dependencies. <p>The format may change with the next version of GHDL. @@ -2095,16 +2175,16 @@ Up: <a rel="up" accesskey="u" href="#GHDL-implementation-of-VHDL">GHDL impl <!-- node-name, next, previous, up --> <h3 class="section">5.4 VHDL files format</h3> -<p><a name="index-file-format-104"></a><a name="index-logical-name-105"></a>VHDL has features to handle files. +<p><a name="index-file-format-109"></a><a name="index-logical-name-110"></a>VHDL has features to handle files. - <p>GHDL associates a file logical name (the VHDL file name) to an operating -system file name. The logical name `<samp><span class="samp">STD_INPUT</span></samp>' is associated to -the standard input as defined by `<samp><span class="samp">stdin</span></samp>' stream of the C library, -while the logical name `<samp><span class="samp">STD_OUTPUT</span></samp>' is associated to the standard -output, as defined by the `<samp><span class="samp">stdout</span></samp>' stream of the C library. Other -logical name are directly mapped to a file name as defined by the first -(`<samp><span class="samp">path</span></samp>') argument of the `<samp><span class="samp">fopen</span></samp>' function of the C library. -For a binary file, the `<samp><span class="samp">b</span></samp>' character is appended to the mode argument + <p>GHDL associates a file logical name (the VHDL filename) to an operating +system filename. The logical name ‘<samp><span class="samp">STD_INPUT</span></samp>’ is associated to +the standard input as defined by ‘<samp><span class="samp">stdin</span></samp>’ stream of the C library, +while the logical name ‘<samp><span class="samp">STD_OUTPUT</span></samp>’ is associated to the standard +output, as defined by the ‘<samp><span class="samp">stdout</span></samp>’ stream of the C library. Other +logical name are directly mapped to a filename as defined by the first +(‘<samp><span class="samp">path</span></samp>’) argument of the ‘<samp><span class="samp">fopen</span></samp>’ function of the C library. +For a binary file, the ‘<samp><span class="samp">b</span></samp>’ character is appended to the mode argument (binary mode). <p>If multiple file objects are associated with the same external file, a stream @@ -2118,9 +2198,9 @@ may restrict the maximum number of file open at the same time. documentation. <!-- tell more about possible errors. --> -<p>There are two kinds of files: binary or text files. + <p>There are two kinds of files: binary or text files. - <p>Text files are files of type `<samp><span class="samp">std.textio.text</span></samp>'. The format is the + <p>Text files are files of type ‘<samp><span class="samp">std.textio.text</span></samp>’. The format is the same as the format of any ascii file. In VHDL-87, only the first 128 characters (7 bits) are allowed, since the character type has only 128 literals. The end of line is system dependent. Note that the stdio @@ -2191,12 +2271,12 @@ compiled because lines such as: variable Read_A_Write_B : memory_collision_type := Read_A_Write_B; </pre> <p>(there are 6 such lines). -According to VHDL visibility rules, `<samp><span class="samp">Write_A_Write_B</span></samp>' cannot be used +According to VHDL visibility rules, ‘<samp><span class="samp">Write_A_Write_B</span></samp>’ cannot be used while it is defined. This is very logical because it prevents from silly declarations such as <pre class="smallexample"> constant k : natural := 2 * k; </pre> - <p>This files must be modified. Fortunatly, in the example the variables + <p>This files must be modified. Fortunately, in the example the variables are never written. So it is enough to remove them. <div class="node"> @@ -2212,17 +2292,17 @@ Up: <a rel="up" accesskey="u" href="#GHDL-implementation-of-VHDL">GHDL impl <!-- node-name, next, previous, up --> <h3 class="section">5.7 Using ieee.math_real or ieee.math_complex</h3> -<p><a name="index-math_005freal-106"></a><a name="index-math_005fcomplex-107"></a>Contrary to other `<samp><span class="samp">ieee</span></samp>' libraries, the math packages sources are not +<p><a name="index-math_005freal-111"></a><a name="index-math_005fcomplex-112"></a>Contrary to other ‘<samp><span class="samp">ieee</span></samp>’ libraries, the math packages sources are not freely available. The sources provided with GHDL are based on an early draft and use the C libraries. As a consequence, you should link your design -with the `<samp><span class="samp">libm.a</span></samp>' library using the <samp><span class="option">-Wl,</span></samp> option like: +with the ‘<samp><span class="samp">libm.a</span></samp>’ library using the <samp><span class="option">-Wl,</span></samp> option like: <pre class="smallexample"> $ ghdl -e -Wl,-lm my_design </pre> <p>Please, refer to your system manual for more details. - <p>Please also note that the `<samp><span class="samp">ieee</span></samp>' libraries are not the same as the drafts. + <p>Please also note that the ‘<samp><span class="samp">ieee</span></samp>’ libraries are not the same as the drafts. - <p>If you really need the `<samp><span class="samp">ieee</span></samp>' math libraries, they are available on the + <p>If you really need the ‘<samp><span class="samp">ieee</span></samp>’ math libraries, they are available on the web, but they cannot be included in GHDL. <div class="node"> @@ -2236,7 +2316,7 @@ Up: <a rel="up" accesskey="u" href="#GHDL-implementation-of-VHDL">GHDL impl <!-- node-name, next, previous, up --> <h3 class="section">5.8 Interfacing to other languages</h3> -<p><a name="index-interfacing-108"></a><a name="index-other-languages-109"></a><a name="index-foreign-110"></a><a name="index-VHPI-111"></a><a name="index-VHPIDIRECT-112"></a>Interfacing with foreign languages is possible only on GNU/Linux systems. +<p><a name="index-interfacing-113"></a><a name="index-other-languages-114"></a><a name="index-foreign-115"></a><a name="index-VHPI-116"></a><a name="index-VHPIDIRECT-117"></a>Interfacing with foreign languages is possible only on GNU/Linux systems. <p>You can define a subprogram in a foreign language (such as <code>C</code> or <code>Ada</code>) and import it in a VHDL design. @@ -2260,10 +2340,10 @@ attribute. In this example, the <code>sin</code> function is imported: </pre> <p>A subprogram is made foreign if the <var>foreign</var> attribute decorates it. This attribute is declared in the 1993 revision of the -`<samp><span class="samp">std.standard</span></samp>' package. Therefore, you cannot use this feature in +‘<samp><span class="samp">std.standard</span></samp>’ package. Therefore, you cannot use this feature in VHDL 1987. - <p>The decoration is achived through an attribute specification. The + <p>The decoration is achieved through an attribute specification. The attribute specification must be in the same declarative part as the subprogram and must be after it. This is a general rule for specifications. The value of the specification must be a locally static string. @@ -2271,7 +2351,7 @@ The value of the specification must be a locally static string. <p>Even when a subprogram is foreign, its body must be present. However, since it won't be called, you can made it empty or simply but an assertion. - <p>The value of the attribute must start with `<samp><span class="samp">VHPIDIRECT </span></samp>' (an + <p>The value of the attribute must start with ‘<samp><span class="samp">VHPIDIRECT </span></samp>’ (an upper-case keyword followed by one or more blanks). The linkage name of the subprogram follows. @@ -2296,15 +2376,15 @@ Up: <a rel="up" accesskey="u" href="#Interfacing-to-other-languages">Interf <p>Any subprogram can be imported. GHDL puts no restrictions on foreign subprograms. However, the representation of a type or of an interface in a -foreign language may be obscur. Most of non-composite types are easily imported: +foreign language may be obscure. Most of non-composite types are easily imported: <dl> -<dt>`<samp><span class="samp">integer types</span></samp>'<dd>They are represented on a 32 bits word. This generally corresponds to +<dt>‘<samp><span class="samp">integer types</span></samp>’<dd>They are represented on a 32 bits word. This generally corresponds to <code>int</code> for <code>C</code> or <code>Integer</code> for <code>Ada</code>. -<br><dt>`<samp><span class="samp">physical types</span></samp>'<dd>They are represented on a 64 bits word. This generally corresponds to the +<br><dt>‘<samp><span class="samp">physical types</span></samp>’<dd>They are represented on a 64 bits word. This generally corresponds to the <code>long long</code> for <code>C</code> or <code>Long_Long_Integer</code> for <code>Ada</code>. -<br><dt>`<samp><span class="samp">floating point types</span></samp>'<dd>They are represented on a 64 bits floating point word. This generally +<br><dt>‘<samp><span class="samp">floating point types</span></samp>’<dd>They are represented on a 64 bits floating point word. This generally corresponds to <code>double</code> for <code>C</code> or <code>Long_Float</code> for <code>Ada</code>. -<br><dt>`<samp><span class="samp">enumeration types</span></samp>'<dd>They are represented on 8 bits or 32 bits word, if the number of literals is +<br><dt>‘<samp><span class="samp">enumeration types</span></samp>’<dd>They are represented on 8 bits or 32 bits word, if the number of literals is greater than 256. There is no corresponding C types, since arguments are not promoted. </dl> @@ -2325,7 +2405,7 @@ length is the number of elements, and are passed by reference to subprograms. <p>Unconstrained array are represented by a fat pointer. Do not use unconstrained arrays in foreign subprograms. - <p>Accesses to an unconstrained array is a fat pointer. Other accesses corresponds a an address and are passed to a subprogram like other non-composite types. + <p>Accesses to an unconstrained array is a fat pointer. Other accesses correspond to an address and are passed to a subprogram like other non-composite types. <p>Files are represented by a 32 bits word, which corresponds to an index in a table. @@ -2341,7 +2421,7 @@ Up: <a rel="up" accesskey="u" href="#Interfacing-to-other-languages">Interf <h4 class="subsection">5.8.3 Linking with foreign object files</h4> -<p>You may add additionnal files or options during the link using the +<p>You may add additional files or options during the link using the <samp><span class="option">-Wl,</span></samp> of <code>GHDL</code>, as described in <a href="#Elaboration-command">Elaboration command</a>. For example: @@ -2363,8 +2443,8 @@ Up: <a rel="up" accesskey="u" href="#Interfacing-to-other-languages">Interf <h4 class="subsection">5.8.4 Starting a simulation from a foreign program</h4> -<p>You main run your design from an external program. You just have to call -the `<samp><span class="samp">ghdl_main</span></samp>' function which can be defined: +<p>You may run your design from an external program. You just have to call +the ‘<samp><span class="samp">ghdl_main</span></samp>’ function which can be defined: <p>in C: <pre class="smallexample"> extern int ghdl_main (int argc, char **argv); @@ -2400,7 +2480,7 @@ suppose there is only one design file, <samp><span class="file">design.vhdl</spa <pre class="smallexample"> $ ghdl -a design.vhdl </pre> <p>Then, bind your design. In this example, we suppose the entity at the -design apex is `<samp><span class="samp">design</span></samp>'. +design apex is ‘<samp><span class="samp">design</span></samp>’. <pre class="smallexample"> $ ghdl --bind design </pre> <p>Finally, compile, bind your <code>Ada</code> program at link it with your <code>VHDL</code> @@ -2426,15 +2506,15 @@ each release. </blockquote> <p>The simulator kernel of <code>GHDL</code> named <dfn>GRT</dfn> is written in -<code>Ada95</code> and contains a very light and slighly adapted version +<code>Ada95</code> and contains a very light and slightly adapted version of <code>VHPI</code>. Since it is an <code>Ada</code> implementation it is called <dfn>AVHPI</dfn>. Although being tough, you may interface to <code>AVHPI</code>. <p>For using <code>AVHPI</code>, you need the sources of <code>GHDL</code> and to recompile them (at least the <code>GRT</code> library). This library is usually compiled with a <code>No_Run_Time</code> pragma, so that the user does not need to install the -<code>GNAT</code> run time library. However, you certainly want to use the usual -run time library and want to avoid this pragma. For this, reset the +<code>GNAT</code> runtime library. However, you certainly want to use the usual +runtime library and want to avoid this pragma. For this, reset the <var>GRT_PRAGMA_FLAG</var> variable. <pre class="smallexample"> $ make GRT_PRAGMA_FLAG= grt-all </pre> @@ -2505,7 +2585,7 @@ Up: <a rel="up" accesskey="u" href="#Top">Top</a> <!-- node-name, next, previous, up --> <h2 class="chapter">6 GHDL implementation of VITAL</h2> -<p><a name="index-VITAL-113"></a><a name="index-IEEE-1076_002e4-114"></a><a name="index-g_t1076_002e4-115"></a>This chapter describes how VITAL is implemented in GHDL. Support of VITAL is +<p><a name="index-VITAL-118"></a><a name="index-IEEE-1076_002e4-119"></a><a name="index-g_t1076_002e4-120"></a>This chapter describes how VITAL is implemented in GHDL. Support of VITAL is really in a preliminary stage. Do not expect too much of it as now. <ul class="menu"> @@ -2536,7 +2616,7 @@ packages are used with other standards. This choice is based on the requirements of VITAL: VITAL 1995 requires the models follow the VHDL 1987 standard, while VITAL 2000 requires the models follow VHDL 1993. - <p>The VITAL 2000 packages were slighly modified so that they conform to + <p>The VITAL 2000 packages were slightly modified so that they conform to the VHDL 1993 standard (a few functions are made pure and a few one impure). @@ -2582,7 +2662,7 @@ Up: <a rel="up" accesskey="u" href="#GHDL-implementation-of-VITAL">GHDL imp <!-- node-name, next, previous, up --> <h3 class="section">6.3 Backannotation</h3> -<p><a name="index-SDF-116"></a><dfn>Backannotation</dfn> is the process of setting VITAL generics with timing +<p><a name="index-SDF-121"></a><dfn>Backannotation</dfn> is the process of setting VITAL generics with timing information provided by an external files. <p>The external files must be SDF (Standard Delay Format) files. GHDL @@ -2592,11 +2672,11 @@ used, provided no features added by the next version are used. <p>Hierarchical instance names are not supported. However you can use a list of instances. If there is no instance, the top entity will be annotated and the celltype must be the name of the top entity. If there is at least one -instance, the last instance name must be a component instantiation labe, and +instance, the last instance name must be a component instantiation label, and the celltype must be the name of the component declaration instantiated. <p>Instances being annotated are not required to be VITAL compliant. However -generics being annotated must follow rules of VITAL (eg, type must be a +generics being annotated must follow rules of VITAL (e.g., type must be a suitable vital delay type). <p>Currently, only timing constraints applying on a timing generic of type @@ -2615,9 +2695,9 @@ Up: <a rel="up" accesskey="u" href="#GHDL-implementation-of-VITAL">GHDL imp <!-- node-name, next, previous, up --> <h3 class="section">6.4 Negative constraint calculation</h3> -<p>Negative constraint delay adjustement are necessary to handle negative +<p>Negative constraint delay adjustment are necessary to handle negative constraint such as a negative setup time. This step is defined in the VITAL -standard and should occurs after backannotation. +standard and should occur after backannotation. <p>GHDL does not do negative constraint calculation. It fails to handle models with negative constraint. I hope to be able to add this phase soon. @@ -2659,10 +2739,10 @@ Up: <a rel="up" accesskey="u" href="#Flaws-and-bugs-report">Flaws and bugs <p>Here is the non-exhaustive list of flaws: <ul> -<li>So far, <code>GHDL</code> has been compiled and tested only on `<samp><span class="samp">i386-linux</span></samp>' systems. +<li>So far, <code>GHDL</code> has been compiled and tested only on ‘<samp><span class="samp">i386-linux</span></samp>’ systems. <li>Overflow detection is not yet implemented. -<li>Some contraint checks are missing. -<li>VHDL-93 is not completly implemented. +<li>Some constraint checks are missing. +<li>VHDL-93 is not completely implemented. <li>There are no checks for elaboration order. <li>This list is not exhaustive. <li><small class="dots">...</small> @@ -2688,7 +2768,7 @@ email to <a href="mailto:ghdl@free.fr">ghdl@free.fr</a>. <p>If the compiler crashes, this is a bug. Reliable tools never crash. <p>If your compiled VHDL executable crashes, this may be a bug at -run time or the code produced may be wrong. However, since VHDL +runtime or the code produced may be wrong. However, since VHDL has a notion of pointers, an erroneous VHDL program (using invalid pointers for example) may crash. @@ -2712,7 +2792,7 @@ Again, rewriting part of it is a good way to improve it. <p>If you send a <code>VHDL</code> file producing a bug, it is a good idea to try to make it as short as possible. It is also a good idea to make it -looking like a test: write a comment which explains wether the file +looking like a test: write a comment which explains whether the file should compile, and if yes, whether or not it should run successfully. In the latter case, an assert statement should finish the test; the severity level note indicates success, while a severity level failure @@ -2722,7 +2802,7 @@ indicates failure. reproduce the problem. This includes: <ul> -<li>the version of <code>GHDL</code> (you can get it with `<samp><span class="samp">ghdl --version</span></samp>'). +<li>the version of <code>GHDL</code> (you can get it with ‘<samp><span class="samp">ghdl --version</span></samp>’). <li>the operating system <li>whether you have built <code>GHDL</code> from sources or used the binary distribution. @@ -2771,12 +2851,12 @@ Up: <a rel="up" accesskey="u" href="#Top">Top</a> <!-- node-name, next, previous, up --> <h2 class="chapter">8 Copyrights</h2> -<p>The GHDL front-end, the `<samp><span class="samp">std.textio</span></samp>' package and the run-time +<p>The GHDL front-end, the ‘<samp><span class="samp">std.textio</span></samp>’ package and the runtime library (grt) are copyrighted Tristan Gingold, come with <em>absolutely no warranty</em>, and are distributed under the conditions of the General Public License. - <p>The `<samp><span class="samp">ieee.numeric_bit</span></samp>' and `<samp><span class="samp">ieee.numeric_std</span></samp>' packages are + <p>The ‘<samp><span class="samp">ieee.numeric_bit</span></samp>’ and ‘<samp><span class="samp">ieee.numeric_std</span></samp>’ packages are copyrighted by the IEEE. The source files may be distributed without change, except as permitted by the standard. <!-- FIXME: this sounds strange --> @@ -2784,33 +2864,33 @@ This source file may not be sold or distributed for profit. See the source file and the IEEE 1076.3 standard for more information. - <p>The `<samp><span class="samp">ieee.std_logic_1164</span></samp>' package is copyrighted by the IEEE. See + <p>The ‘<samp><span class="samp">ieee.std_logic_1164</span></samp>’ package is copyrighted by the IEEE. See source file and the IEEE 1164 standard for more information. - <p>The `<samp><span class="samp">ieee.VITAL_Primitives</span></samp>', `<samp><span class="samp">ieee.VITAL_Timing</span></samp>' and -`<samp><span class="samp">ieee.VITAL_Memory</span></samp>' packages are copyrighted by IEEE. See source + <p>The ‘<samp><span class="samp">ieee.VITAL_Primitives</span></samp>’, ‘<samp><span class="samp">ieee.VITAL_Timing</span></samp>’ and +‘<samp><span class="samp">ieee.VITAL_Memory</span></samp>’ packages are copyrighted by IEEE. See source file and the IEEE 1076.4 standards for more information. - <p>The `<samp><span class="samp">ieee.Math_Real</span></samp>' and `<samp><span class="samp">ieee.Math_Complex</span></samp>' packages are + <p>The ‘<samp><span class="samp">ieee.Math_Real</span></samp>’ and ‘<samp><span class="samp">ieee.Math_Complex</span></samp>’ packages are copyrighted by IEEE. These are draft versions which may used and distributed without restriction. These packages cannot be sold or distributed for profit. See source files for more information. - <p>The packages `<samp><span class="samp">std_logic_arith</span></samp>', <!-- @samp{std_logic_misc}, --> -`<samp><span class="samp">std_logic_signed</span></samp>', `<samp><span class="samp">std_logic_unsigned</span></samp>' and -`<samp><span class="samp">std_logic_textio</span></samp>' contained in the `<samp><span class="samp">synopsys</span></samp>' directory are + <p>The packages ‘<samp><span class="samp">std_logic_arith</span></samp>’, <!-- @samp{std_logic_misc}, --> +‘<samp><span class="samp">std_logic_signed</span></samp>’, ‘<samp><span class="samp">std_logic_unsigned</span></samp>’ and +‘<samp><span class="samp">std_logic_textio</span></samp>’ contained in the ‘<samp><span class="samp">synopsys</span></samp>’ directory are copyrighted by Synopsys, Inc. The source files may be used and distributed without restriction provided that the copyright statements are not removed from the files and that any derivative work contains the copyright notice. See the source files for more information. - <p>The package `<samp><span class="samp">std_logic_arith</span></samp>' contained in the `<samp><span class="samp">mentor</span></samp>' + <p>The package ‘<samp><span class="samp">std_logic_arith</span></samp>’ contained in the ‘<samp><span class="samp">mentor</span></samp>’ directory is copyrighted by Mentor Graphics. The source files may be distributed in whole without restriction provided that the copyright statement is not removed from the file and that any derivative work contains this copyright notice. See the source files for more information. - <p>As a consequence of the run-time copyright, you may not be allowed to + <p>As a consequence of the runtime copyright, you may not be allowed to distribute an executable produced by <code>GHDL</code> without the VHDL sources. To my mind, this is not a real restriction, since there is no points in distributing VHDL executable. Please, send a comment @@ -2827,37 +2907,39 @@ Up: <a rel="up" accesskey="u" href="#Top">Top</a> <h2 class="unnumbered">Index</h2> <ul class="index-cp" compact> -<li><a href="#index-g_t_0040option_007b_002d_002dassert_002dlevel_007d-option-75"><samp><span class="option">--assert-level</span></samp> option</a>: <a href="#Simulation-options">Simulation options</a></li> +<li><a href="#index-g_t_0040option_007b_002d_002dassert_002dlevel_007d-option-79"><samp><span class="option">--assert-level</span></samp> option</a>: <a href="#Simulation-options">Simulation options</a></li> <li><a href="#index-g_t_0040option_007b_002d_002dbind_007d-command-10"><samp><span class="option">--bind</span></samp> command</a>: <a href="#Bind-command">Bind command</a></li> -<li><a href="#index-g_t_0040option_007b_002d_002dchop_007d-command-65"><samp><span class="option">--chop</span></samp> command</a>: <a href="#Chop-command">Chop command</a></li> +<li><a href="#index-g_t_0040option_007b_002d_002dchop_007d-command-67"><samp><span class="option">--chop</span></samp> command</a>: <a href="#Chop-command">Chop command</a></li> <li><a href="#index-g_t_0040option_007b_002d_002dclean_007d-command-58"><samp><span class="option">--clean</span></samp> command</a>: <a href="#Clean-command">Clean command</a></li> -<li><a href="#index-g_t_0040option_007b_002d_002ddisp_002dstandard_007d-command-71"><samp><span class="option">--disp-standard</span></samp> command</a>: <a href="#Disp-standard-command">Disp standard command</a></li> -<li><a href="#index-g_t_0040option_007b_002d_002ddisp_002dtime_007d-option-78"><samp><span class="option">--disp-time</span></samp> option</a>: <a href="#Simulation-options">Simulation options</a></li> -<li><a href="#index-g_t_0040option_007b_002d_002ddisp_002dtree_007d-option-80"><samp><span class="option">--disp-tree</span></samp> option</a>: <a href="#Simulation-options">Simulation options</a></li> -<li><a href="#index-g_t_0040option_007b_002d_002ddispconfig_007d-command-69"><samp><span class="option">--dispconfig</span></samp> command</a>: <a href="#Dispconfig-command">Dispconfig command</a></li> +<li><a href="#index-g_t_0040option_007b_002d_002dcopy_007d-command-62"><samp><span class="option">--copy</span></samp> command</a>: <a href="#Copy-command">Copy command</a></li> +<li><a href="#index-g_t_0040option_007b_002d_002ddisp_002dstandard_007d-command-73"><samp><span class="option">--disp-standard</span></samp> command</a>: <a href="#Disp-standard-command">Disp standard command</a></li> +<li><a href="#index-g_t_0040option_007b_002d_002ddisp_002dtime_007d-option-83"><samp><span class="option">--disp-time</span></samp> option</a>: <a href="#Simulation-options">Simulation options</a></li> +<li><a href="#index-g_t_0040option_007b_002d_002ddisp_002dtree_007d-option-85"><samp><span class="option">--disp-tree</span></samp> option</a>: <a href="#Simulation-options">Simulation options</a></li> +<li><a href="#index-g_t_0040option_007b_002d_002ddispconfig_007d-command-71"><samp><span class="option">--dispconfig</span></samp> command</a>: <a href="#Dispconfig-command">Dispconfig command</a></li> <li><a href="#index-g_t_0040option_007b_002d_002delab_002drun_007d-command-8"><samp><span class="option">--elab-run</span></samp> command</a>: <a href="#Elaborate-and-run-command">Elaborate and run command</a></li> <li><a href="#index-g_t_0040option_007b_002d_002dgen_002dmakefile_007d-command-54"><samp><span class="option">--gen-makefile</span></samp> command</a>: <a href="#Generate-Makefile-command">Generate Makefile command</a></li> <li><a href="#index-g_t_0040option_007b_002d_002dGHLD1_007d-switch-36"><samp><span class="option">--GHLD1</span></samp> switch</a>: <a href="#GHDL-options">GHDL options</a></li> -<li><a href="#index-g_t_0040option_007b_002d_002dhelp_007d-command-68"><samp><span class="option">--help</span></samp> command</a>: <a href="#Help-command">Help command</a></li> +<li><a href="#index-g_t_0040option_007b_002d_002dhelp_007d-command-70"><samp><span class="option">--help</span></samp> command</a>: <a href="#Help-command">Help command</a></li> <li><a href="#index-g_t_0040option_007b_002d_002dieee_007d-switch-26"><samp><span class="option">--ieee</span></samp> switch</a>: <a href="#GHDL-options">GHDL options</a></li> -<li><a href="#index-g_t_0040option_007b_002d_002dlines_007d-command-66"><samp><span class="option">--lines</span></samp> command</a>: <a href="#Lines-command">Lines command</a></li> +<li><a href="#index-g_t_0040option_007b_002d_002dieee_002dasserts_007d-option-80"><samp><span class="option">--ieee-asserts</span></samp> option</a>: <a href="#Simulation-options">Simulation options</a></li> +<li><a href="#index-g_t_0040option_007b_002d_002dlines_007d-command-68"><samp><span class="option">--lines</span></samp> command</a>: <a href="#Lines-command">Lines command</a></li> <li><a href="#index-g_t_0040option_007b_002d_002dlink_007d-command-12"><samp><span class="option">--link</span></samp> command</a>: <a href="#Link-command">Link command</a></li> <li><a href="#index-g_t_0040option_007b_002d_002dlist_002dlink_007d-command-13"><samp><span class="option">--list-link</span></samp> command</a>: <a href="#List-link-command">List link command</a></li> -<li><a href="#index-g_t_0040option_007b_002d_002dno_002drun_007d-option-82"><samp><span class="option">--no-run</span></samp> option</a>: <a href="#Simulation-options">Simulation options</a></li> +<li><a href="#index-g_t_0040option_007b_002d_002dno_002drun_007d-option-87"><samp><span class="option">--no-run</span></samp> option</a>: <a href="#Simulation-options">Simulation options</a></li> <li><a href="#index-g_t_0040option_007b_002d_002dno_002dvital_002dchecks_007d-switch-32"><samp><span class="option">--no-vital-checks</span></samp> switch</a>: <a href="#GHDL-options">GHDL options</a></li> -<li><a href="#index-g_t_0040option_007b_002d_002dpp_002dhtml_007d-command-61"><samp><span class="option">--pp-html</span></samp> command</a>: <a href="#Pretty-print-command">Pretty print command</a></li> +<li><a href="#index-g_t_0040option_007b_002d_002dpp_002dhtml_007d-command-63"><samp><span class="option">--pp-html</span></samp> command</a>: <a href="#Pretty-print-command">Pretty print command</a></li> <li><a href="#index-g_t_0040option_007b_002d_002dPREFIX_007d-switch-35"><samp><span class="option">--PREFIX</span></samp> switch</a>: <a href="#GHDL-options">GHDL options</a></li> <li><a href="#index-g_t_0040option_007b_002d_002dremove_007d-command-60"><samp><span class="option">--remove</span></samp> command</a>: <a href="#Remove-command">Remove command</a></li> -<li><a href="#index-g_t_0040option_007b_002d_002dsdf_007d-option-89"><samp><span class="option">--sdf</span></samp> option</a>: <a href="#Simulation-options">Simulation options</a></li> -<li><a href="#index-g_t_0040option_007b_002d_002dstack_002dmax_002dsize_007d-option-90"><samp><span class="option">--stack-max-size</span></samp> option</a>: <a href="#Simulation-options">Simulation options</a></li> -<li><a href="#index-g_t_0040option_007b_002d_002dstack_002dsize_007d-option-91"><samp><span class="option">--stack-size</span></samp> option</a>: <a href="#Simulation-options">Simulation options</a></li> +<li><a href="#index-g_t_0040option_007b_002d_002dsdf_007d-option-94"><samp><span class="option">--sdf</span></samp> option</a>: <a href="#Simulation-options">Simulation options</a></li> +<li><a href="#index-g_t_0040option_007b_002d_002dstack_002dmax_002dsize_007d-option-95"><samp><span class="option">--stack-max-size</span></samp> option</a>: <a href="#Simulation-options">Simulation options</a></li> +<li><a href="#index-g_t_0040option_007b_002d_002dstack_002dsize_007d-option-96"><samp><span class="option">--stack-size</span></samp> option</a>: <a href="#Simulation-options">Simulation options</a></li> <li><a href="#index-g_t_0040option_007b_002d_002dstd_007d-switch-25"><samp><span class="option">--std</span></samp> switch</a>: <a href="#GHDL-options">GHDL options</a></li> -<li><a href="#index-g_t_0040option_007b_002d_002dstop_002ddelta_007d-option-77"><samp><span class="option">--stop-delta</span></samp> option</a>: <a href="#Simulation-options">Simulation options</a></li> -<li><a href="#index-g_t_0040option_007b_002d_002dstop_002dtime_007d-option-76"><samp><span class="option">--stop-time</span></samp> option</a>: <a href="#Simulation-options">Simulation options</a></li> +<li><a href="#index-g_t_0040option_007b_002d_002dstop_002ddelta_007d-option-82"><samp><span class="option">--stop-delta</span></samp> option</a>: <a href="#Simulation-options">Simulation options</a></li> +<li><a href="#index-g_t_0040option_007b_002d_002dstop_002dtime_007d-option-81"><samp><span class="option">--stop-time</span></samp> option</a>: <a href="#Simulation-options">Simulation options</a></li> <li><a href="#index-g_t_0040option_007b_002d_002dsyn_002dbinding_007d-switch-34"><samp><span class="option">--syn-binding</span></samp> switch</a>: <a href="#GHDL-options">GHDL options</a></li> -<li><a href="#index-g_t_0040option_007b_002d_002dvcd_007d-option-83"><samp><span class="option">--vcd</span></samp> option</a>: <a href="#Simulation-options">Simulation options</a></li> -<li><a href="#index-g_t_0040option_007b_002d_002dvcdgz_007d-option-84"><samp><span class="option">--vcdgz</span></samp> option</a>: <a href="#Simulation-options">Simulation options</a></li> -<li><a href="#index-g_t_0040option_007b_002d_002dversion_007d-command-73"><samp><span class="option">--version</span></samp> command</a>: <a href="#Version-command">Version command</a></li> +<li><a href="#index-g_t_0040option_007b_002d_002dvcd_007d-option-88"><samp><span class="option">--vcd</span></samp> option</a>: <a href="#Simulation-options">Simulation options</a></li> +<li><a href="#index-g_t_0040option_007b_002d_002dvcdgz_007d-option-89"><samp><span class="option">--vcdgz</span></samp> option</a>: <a href="#Simulation-options">Simulation options</a></li> +<li><a href="#index-g_t_0040option_007b_002d_002dversion_007d-command-75"><samp><span class="option">--version</span></samp> command</a>: <a href="#Version-command">Version command</a></li> <li><a href="#index-g_t_0040option_007b_002d_002dvital_002dchecks_007d-switch-33"><samp><span class="option">--vital-checks</span></samp> switch</a>: <a href="#GHDL-options">GHDL options</a></li> <li><a href="#index-g_t_0040option_007b_002d_002dwarn_002dbinding_007d-switch-42"><samp><span class="option">--warn-binding</span></samp> switch</a>: <a href="#GHDL-warnings">GHDL warnings</a></li> <li><a href="#index-g_t_0040option_007b_002d_002dwarn_002dbody_007d-switch-46"><samp><span class="option">--warn-body</span></samp> switch</a>: <a href="#GHDL-warnings">GHDL warnings</a></li> @@ -2869,17 +2951,17 @@ Up: <a rel="up" accesskey="u" href="#Top">Top</a> <li><a href="#index-g_t_0040option_007b_002d_002dwarn_002dspecs_007d-switch-47"><samp><span class="option">--warn-specs</span></samp> switch</a>: <a href="#GHDL-warnings">GHDL warnings</a></li> <li><a href="#index-g_t_0040option_007b_002d_002dwarn_002dunused_007d-switch-48"><samp><span class="option">--warn-unused</span></samp> switch</a>: <a href="#GHDL-warnings">GHDL warnings</a></li> <li><a href="#index-g_t_0040option_007b_002d_002dwarn_002dvital_002dgeneric_007d-switch-44"><samp><span class="option">--warn-vital-generic</span></samp> switch</a>: <a href="#GHDL-warnings">GHDL warnings</a></li> -<li><a href="#index-g_t_0040option_007b_002d_002dwave_007d-option-88"><samp><span class="option">--wave</span></samp> option</a>: <a href="#Simulation-options">Simulation options</a></li> +<li><a href="#index-g_t_0040option_007b_002d_002dwave_007d-option-93"><samp><span class="option">--wave</span></samp> option</a>: <a href="#Simulation-options">Simulation options</a></li> <li><a href="#index-g_t_0040option_007b_002d_002dwork_007d-switch-22"><samp><span class="option">--work</span></samp> switch</a>: <a href="#GHDL-options">GHDL options</a></li> <li><a href="#index-g_t_0040option_007b_002d_002dworkdir_007d-switch-24"><samp><span class="option">--workdir</span></samp> switch</a>: <a href="#GHDL-options">GHDL options</a></li> <li><a href="#index-g_t_0040option_007b_002da_007d-command-2"><samp><span class="option">-a</span></samp> command</a>: <a href="#Analysis-command">Analysis command</a></li> <li><a href="#index-g_t_0040option_007b_002dc_007d-command-17"><samp><span class="option">-c</span></samp> command</a>: <a href="#Analyze-and-elaborate-command">Analyze and elaborate command</a></li> <li><a href="#index-g_t_0040option_007b_002dd_007d-command-56"><samp><span class="option">-d</span></samp> command</a>: <a href="#Directory-command">Directory command</a></li> <li><a href="#index-g_t_0040option_007b_002de_007d-command-4"><samp><span class="option">-e</span></samp> command</a>: <a href="#Elaboration-command">Elaboration command</a></li> -<li><a href="#index-g_t_0040option_007b_002df_007d-command-64"><samp><span class="option">-f</span></samp> command</a>: <a href="#Find-command">Find command</a></li> +<li><a href="#index-g_t_0040option_007b_002df_007d-command-66"><samp><span class="option">-f</span></samp> command</a>: <a href="#Find-command">Find command</a></li> <li><a href="#index-g_t_0040option_007b_002dfexplicit_007d-switch-31"><samp><span class="option">-fexplicit</span></samp> switch</a>: <a href="#GHDL-options">GHDL options</a></li> -<li><a href="#index-g_t_0040option_007b_002dh_007d-command-67"><samp><span class="option">-h</span></samp> command</a>: <a href="#Help-command">Help command</a></li> -<li><a href="#index-g_t_0040option_007b_002di_007d-coomand-51"><samp><span class="option">-i</span></samp> coomand</a>: <a href="#Import-command">Import command</a></li> +<li><a href="#index-g_t_0040option_007b_002dh_007d-command-69"><samp><span class="option">-h</span></samp> command</a>: <a href="#Help-command">Help command</a></li> +<li><a href="#index-g_t_0040option_007b_002di_007d-command-51"><samp><span class="option">-i</span></samp> command</a>: <a href="#Import-command">Import command</a></li> <li><a href="#index-g_t_0040option_007b_002dm_007d-command-53"><samp><span class="option">-m</span></samp> command</a>: <a href="#Make-command">Make command</a></li> <li><a href="#index-g_t_0040option_007b_002dP_007d-switch-30"><samp><span class="option">-P</span></samp> switch</a>: <a href="#GHDL-options">GHDL options</a></li> <li><a href="#index-g_t_0040option_007b_002dr_007d-command-6"><samp><span class="option">-r</span></samp> command</a>: <a href="#Run-command">Run command</a></li> @@ -2887,61 +2969,64 @@ Up: <a rel="up" accesskey="u" href="#Top">Top</a> <li><a href="#index-g_t_0040option_007b_002dW_007d-switch-37"><samp><span class="option">-W</span></samp> switch</a>: <a href="#Passing-options-to-other-programs">Passing options to other programs</a></li> <li><a href="#index-g_t_0040option_007b_002dWa_007d-switch-38"><samp><span class="option">-Wa</span></samp> switch</a>: <a href="#Passing-options-to-other-programs">Passing options to other programs</a></li> <li><a href="#index-g_t_0040option_007b_002dWl_007d-switch-39"><samp><span class="option">-Wl</span></samp> switch</a>: <a href="#Passing-options-to-other-programs">Passing options to other programs</a></li> -<li><a href="#index-g_t1076-97">1076</a>: <a href="#VHDL-standards">VHDL standards</a></li> +<li><a href="#index-g_t1076-102">1076</a>: <a href="#VHDL-standards">VHDL standards</a></li> <li><a href="#index-g_t1076_002e3-21">1076.3</a>: <a href="#GHDL-options">GHDL options</a></li> -<li><a href="#index-g_t1076_002e4-115">1076.4</a>: <a href="#GHDL-implementation-of-VITAL">GHDL implementation of VITAL</a></li> -<li><a href="#index-g_t1076a-98">1076a</a>: <a href="#VHDL-standards">VHDL standards</a></li> +<li><a href="#index-g_t1076_002e4-120">1076.4</a>: <a href="#GHDL-implementation-of-VITAL">GHDL implementation of VITAL</a></li> +<li><a href="#index-g_t1076a-103">1076a</a>: <a href="#VHDL-standards">VHDL standards</a></li> <li><a href="#index-g_t1164-19">1164</a>: <a href="#GHDL-options">GHDL options</a></li> -<li><a href="#index-g_t_0040code_007b_005f_005fghdl_005ffatal_007d-93"><code>__ghdl_fatal</code></a>: <a href="#Debugging-VHDL-programs">Debugging VHDL programs</a></li> +<li><a href="#index-g_t_0040code_007b_005f_005fghdl_005ffatal_007d-98"><code>__ghdl_fatal</code></a>: <a href="#Debugging-VHDL-programs">Debugging VHDL programs</a></li> <li><a href="#index-analysis-1">analysis</a>: <a href="#Analysis-command">Analysis command</a></li> <li><a href="#index-Analyze-and-elaborate-command-16">Analyze and elaborate command</a>: <a href="#Analyze-and-elaborate-command">Analyze and elaborate command</a></li> <li><a href="#index-binding-9">binding</a>: <a href="#Bind-command">Bind command</a></li> <li><a href="#index-checking-syntax-14">checking syntax</a>: <a href="#Check-syntax-command">Check syntax command</a></li> <li><a href="#index-cleaning-57">cleaning</a>: <a href="#Clean-command">Clean command</a></li> <li><a href="#index-cleaning-all-59">cleaning all</a>: <a href="#Remove-command">Remove command</a></li> -<li><a href="#index-debugging-92">debugging</a>: <a href="#Debugging-VHDL-programs">Debugging VHDL programs</a></li> -<li><a href="#index-display-configuration-70">display configuration</a>: <a href="#Dispconfig-command">Dispconfig command</a></li> -<li><a href="#index-display-design-hierarchy-81">display design hierarchy</a>: <a href="#Simulation-options">Simulation options</a></li> -<li><a href="#index-display-_0040samp_007bstd_002estandard_007d-72">display `<samp><span class="samp">std.standard</span></samp>'</a>: <a href="#Disp-standard-command">Disp standard command</a></li> -<li><a href="#index-display-time-79">display time</a>: <a href="#Simulation-options">Simulation options</a></li> +<li><a href="#index-copying-library-61">copying library</a>: <a href="#Copy-command">Copy command</a></li> +<li><a href="#index-debugging-97">debugging</a>: <a href="#Debugging-VHDL-programs">Debugging VHDL programs</a></li> +<li><a href="#index-display-configuration-72">display configuration</a>: <a href="#Dispconfig-command">Dispconfig command</a></li> +<li><a href="#index-display-design-hierarchy-86">display design hierarchy</a>: <a href="#Simulation-options">Simulation options</a></li> +<li><a href="#index-display-_0040samp_007bstd_002estandard_007d-74">display ‘<samp><span class="samp">std.standard</span></samp>’</a>: <a href="#Disp-standard-command">Disp standard command</a></li> +<li><a href="#index-display-time-84">display time</a>: <a href="#Simulation-options">Simulation options</a></li> <li><a href="#index-displaying-library-55">displaying library</a>: <a href="#Directory-command">Directory command</a></li> -<li><a href="#index-dump-of-signals-87">dump of signals</a>: <a href="#Simulation-options">Simulation options</a></li> +<li><a href="#index-dump-of-signals-92">dump of signals</a>: <a href="#Simulation-options">Simulation options</a></li> <li><a href="#index-elaborate-and-run-7">elaborate and run</a>: <a href="#Elaborate-and-run-command">Elaborate and run command</a></li> <li><a href="#index-elaboration-3">elaboration</a>: <a href="#Elaboration-command">Elaboration command</a></li> -<li><a href="#index-file-format-104">file format</a>: <a href="#VHDL-files-format">VHDL files format</a></li> -<li><a href="#index-foreign-110">foreign</a>: <a href="#Interfacing-to-other-languages">Interfacing to other languages</a></li> -<li><a href="#index-IEEE-1076-95">IEEE 1076</a>: <a href="#VHDL-standards">VHDL standards</a></li> +<li><a href="#index-file-format-109">file format</a>: <a href="#VHDL-files-format">VHDL files format</a></li> +<li><a href="#index-foreign-115">foreign</a>: <a href="#Interfacing-to-other-languages">Interfacing to other languages</a></li> +<li><a href="#index-IEEE-1076-100">IEEE 1076</a>: <a href="#VHDL-standards">VHDL standards</a></li> <li><a href="#index-IEEE-1076_002e3-20">IEEE 1076.3</a>: <a href="#GHDL-options">GHDL options</a></li> -<li><a href="#index-IEEE-1076_002e4-114">IEEE 1076.4</a>: <a href="#GHDL-implementation-of-VITAL">GHDL implementation of VITAL</a></li> -<li><a href="#index-IEEE-1076a-96">IEEE 1076a</a>: <a href="#VHDL-standards">VHDL standards</a></li> +<li><a href="#index-IEEE-1076_002e4-119">IEEE 1076.4</a>: <a href="#GHDL-implementation-of-VITAL">GHDL implementation of VITAL</a></li> +<li><a href="#index-IEEE-1076a-101">IEEE 1076a</a>: <a href="#VHDL-standards">VHDL standards</a></li> <li><a href="#index-IEEE-1164-18">IEEE 1164</a>: <a href="#GHDL-options">GHDL options</a></li> <li><a href="#index-ieee-library-27">ieee library</a>: <a href="#GHDL-options">GHDL options</a></li> <li><a href="#index-importing-files-50">importing files</a>: <a href="#Import-command">Import command</a></li> -<li><a href="#index-interfacing-108">interfacing</a>: <a href="#Interfacing-to-other-languages">Interfacing to other languages</a></li> +<li><a href="#index-interfacing-113">interfacing</a>: <a href="#Interfacing-to-other-languages">Interfacing to other languages</a></li> <li><a href="#index-linking-11">linking</a>: <a href="#Link-command">Link command</a></li> -<li><a href="#index-logical-name-105">logical name</a>: <a href="#VHDL-files-format">VHDL files format</a></li> +<li><a href="#index-logical-name-110">logical name</a>: <a href="#VHDL-files-format">VHDL files format</a></li> <li><a href="#index-make-52">make</a>: <a href="#Make-command">Make command</a></li> -<li><a href="#index-math_005fcomplex-107">math_complex</a>: <a href="#Using-ieee_002emath_005freal-or-ieee_002emath_005fcomplex">Using ieee.math_real or ieee.math_complex</a></li> -<li><a href="#index-math_005freal-106">math_real</a>: <a href="#Using-ieee_002emath_005freal-or-ieee_002emath_005fcomplex">Using ieee.math_real or ieee.math_complex</a></li> +<li><a href="#index-math_005fcomplex-112">math_complex</a>: <a href="#Using-ieee_002emath_005freal-or-ieee_002emath_005fcomplex">Using ieee.math_real or ieee.math_complex</a></li> +<li><a href="#index-Math_005fComplex-78">Math_Complex</a>: <a href="#IEEE-math-packages">IEEE math packages</a></li> +<li><a href="#index-math_005freal-111">math_real</a>: <a href="#Using-ieee_002emath_005freal-or-ieee_002emath_005fcomplex">Using ieee.math_real or ieee.math_complex</a></li> +<li><a href="#index-Math_005fReal-77">Math_Real</a>: <a href="#IEEE-math-packages">IEEE math packages</a></li> <li><a href="#index-mentor-library-29">mentor library</a>: <a href="#GHDL-options">GHDL options</a></li> -<li><a href="#index-other-languages-109">other languages</a>: <a href="#Interfacing-to-other-languages">Interfacing to other languages</a></li> -<li><a href="#index-pretty-printing-62">pretty printing</a>: <a href="#Pretty-print-command">Pretty print command</a></li> +<li><a href="#index-other-languages-114">other languages</a>: <a href="#Interfacing-to-other-languages">Interfacing to other languages</a></li> +<li><a href="#index-pretty-printing-64">pretty printing</a>: <a href="#Pretty-print-command">Pretty print command</a></li> <li><a href="#index-run-5">run</a>: <a href="#Run-command">Run command</a></li> -<li><a href="#index-SDF-116">SDF</a>: <a href="#Backannotation">Backannotation</a></li> +<li><a href="#index-SDF-121">SDF</a>: <a href="#Backannotation">Backannotation</a></li> <li><a href="#index-synopsys-library-28">synopsys library</a>: <a href="#GHDL-options">GHDL options</a></li> -<li><a href="#index-v00-102">v00</a>: <a href="#VHDL-standards">VHDL standards</a></li> -<li><a href="#index-v02-103">v02</a>: <a href="#VHDL-standards">VHDL standards</a></li> -<li><a href="#index-v87-99">v87</a>: <a href="#VHDL-standards">VHDL standards</a></li> -<li><a href="#index-v93-100">v93</a>: <a href="#VHDL-standards">VHDL standards</a></li> -<li><a href="#index-v93c-101">v93c</a>: <a href="#VHDL-standards">VHDL standards</a></li> -<li><a href="#index-value-change-dump-86">value change dump</a>: <a href="#Simulation-options">Simulation options</a></li> -<li><a href="#index-vcd-85">vcd</a>: <a href="#Simulation-options">Simulation options</a></li> -<li><a href="#index-version-74">version</a>: <a href="#Version-command">Version command</a></li> -<li><a href="#index-VHDL-standards-94">VHDL standards</a>: <a href="#VHDL-standards">VHDL standards</a></li> -<li><a href="#index-vhdl-to-html-63">vhdl to html</a>: <a href="#Pretty-print-command">Pretty print command</a></li> -<li><a href="#index-VHPI-111">VHPI</a>: <a href="#Interfacing-to-other-languages">Interfacing to other languages</a></li> -<li><a href="#index-VHPIDIRECT-112">VHPIDIRECT</a>: <a href="#Interfacing-to-other-languages">Interfacing to other languages</a></li> -<li><a href="#index-VITAL-113">VITAL</a>: <a href="#GHDL-implementation-of-VITAL">GHDL implementation of VITAL</a></li> +<li><a href="#index-v00-107">v00</a>: <a href="#VHDL-standards">VHDL standards</a></li> +<li><a href="#index-v02-108">v02</a>: <a href="#VHDL-standards">VHDL standards</a></li> +<li><a href="#index-v87-104">v87</a>: <a href="#VHDL-standards">VHDL standards</a></li> +<li><a href="#index-v93-105">v93</a>: <a href="#VHDL-standards">VHDL standards</a></li> +<li><a href="#index-v93c-106">v93c</a>: <a href="#VHDL-standards">VHDL standards</a></li> +<li><a href="#index-value-change-dump-91">value change dump</a>: <a href="#Simulation-options">Simulation options</a></li> +<li><a href="#index-vcd-90">vcd</a>: <a href="#Simulation-options">Simulation options</a></li> +<li><a href="#index-version-76">version</a>: <a href="#Version-command">Version command</a></li> +<li><a href="#index-VHDL-standards-99">VHDL standards</a>: <a href="#VHDL-standards">VHDL standards</a></li> +<li><a href="#index-vhdl-to-html-65">vhdl to html</a>: <a href="#Pretty-print-command">Pretty print command</a></li> +<li><a href="#index-VHPI-116">VHPI</a>: <a href="#Interfacing-to-other-languages">Interfacing to other languages</a></li> +<li><a href="#index-VHPIDIRECT-117">VHPIDIRECT</a>: <a href="#Interfacing-to-other-languages">Interfacing to other languages</a></li> +<li><a href="#index-VITAL-118">VITAL</a>: <a href="#GHDL-implementation-of-VITAL">GHDL implementation of VITAL</a></li> <li><a href="#index-WORK-library-23">WORK library</a>: <a href="#GHDL-options">GHDL options</a></li> </ul></body></html> diff --git a/doc/ghdl.texi b/doc/ghdl.texi index 885cc9e22..eed41f110 100644 --- a/doc/ghdl.texi +++ b/doc/ghdl.texi @@ -11,12 +11,12 @@ @titlepage @title GHDL guide @subtitle GHDL, a VHDL compiler -@subtitle For GHDL version 0.28 (Sokcho edition) +@subtitle For GHDL version 0.29 (Sokcho edition) @author Tristan Gingold @c The following two commands start the copyright page. @page @vskip 0pt plus 1filll -Copyright @copyright{} 2002-2009 Tristan Gingold. +Copyright @copyright{} 2002-2010 Tristan Gingold. Permission is granted to copy, distribute and/or modify this document under the terms of the GNU Free Documentation License, Version 1.1 or @@ -88,7 +88,7 @@ or any later version published by the Free Software Foundation. * Introduction:: What is GHDL, what is VHDL * Starting with GHDL:: Build a VHDL program with GHDL * Invoking GHDL:: -* Simulation and runtime:: +* Simulation and runtime:: * GHDL implementation of VHDL:: * GHDL implementation of VITAL:: * Flaws and bugs report:: @@ -874,6 +874,11 @@ good feature, because it breaks the encapsulation rule. When set, an operator can be silently overridden in another package. You'd better to fix your design and use the @samp{numeric_std} package. +@item -fpsl +@cindex @option{-fpsl} switch +Enable parsing of PSL assertions within comments. @xref{PSL implementation}, +for more details. + @item --no-vital-checks @item --vital-checks @cindex @option{--no-vital-checks} switch @@ -1138,6 +1143,7 @@ GHDL has a few commands which act on a library. * Directory command:: * Clean command:: * Remove command:: +* Copy command:: @end menu @node Directory command, Clean command, Library commands, Library commands @@ -1172,7 +1178,7 @@ have created. Source files are not removed. There is no short command line form for this option to prevent accidental clean up. -@node Remove command, , Clean command, Library commands +@node Remove command, Copy command, Clean command, Library commands @subsection Remove command @cindex cleaning all @cindex @option{--remove} command @@ -1186,6 +1192,23 @@ There is no short command line form for this option to prevent accidental clean up. Note that after removing a design library, the files are not known anymore by GHDL. +@node Copy command, , Remove command, Library commands +@subsection Copy command +@cindex copying library +@cindex @option{--copy} command +Make a local copy of an existing library. + +@smallexample +$ ghdl --copy --work=@var{name} [@var{options}] +@end smallexample + +Make a local copy of an existing library. This is very useful if you want to +add unit to the @samp{ieee} library: +@example +$ ghdl --copy --work=ieee --ieee=synopsys +$ ghdl -a --work=ieee numeric_unsigned.vhd +@end example + @node Cross-reference command, File commands, Library commands, Invoking GHDL @comment node-name, next, previous, up @section Cross-reference command @@ -1814,6 +1837,7 @@ This chapter describes several implementation defined aspect of VHDL in GHDL. @menu * VHDL standards:: +* PSL implementation:: * Source representation:: * Library database:: * VHDL files format:: @@ -1823,7 +1847,7 @@ This chapter describes several implementation defined aspect of VHDL in GHDL. * Interfacing to other languages:: @end menu -@node VHDL standards, Source representation, GHDL implementation of VHDL, GHDL implementation of VHDL +@node VHDL standards, PSL implementation, GHDL implementation of VHDL, GHDL implementation of VHDL @comment node-name, next, previous, up @section VHDL standards @cindex VHDL standards @@ -1904,7 +1928,41 @@ Select VHDL-2002 standard (partially implemented). You cannot mix VHDL-87 and VHDL-93 units. A design hierarchy must have been completely analyzed using either the 87 or the 93 version of the VHDL standard. -@node Source representation, Library database, VHDL standards, GHDL implementation of VHDL +@node PSL implementation, Source representation, VHDL standards, GHDL implementation of VHDL +@comment node-name, next, previous, up +@section PSL implementation +GHDL understands embedded PSL annotations in VHDL files, but in separate files. + +As PSL annotations are embedded within comments, you must analyze and elaborate +your design with option @option{-fpsl} to enable PSL annotations. + +A PSL assertion statement must appear within a comment that starts +with the @code{psl} keyword. The keyword must be followed (on the +same line) by a PSL keyword such as @code{assert} or @code{default}. +To continue a PSL statement on the next line, just start a new comment. + +A PSL statement is considered as a concurrent statement, and therefore is +allowed only where processes are. + +All PSL assertions must be clocked (GHDL doesn't support unclocked assertion). +Furthermore only one clock per assertion is allowed. + +You can either use a default clock like this: +@example + -- psl default clock is rising_edge (CLK); + -- psl assert always + -- a -> eventually! b; +@end example +or use a clocked expression (note the use of parenthesis): +@example + -- psl assert (always a -> next[3](b)) @@rising_edge (clk); +@end example + +Of course only the simple subset of PSL is allowed. + +Currently the built-in functions are not implemented. + +@node Source representation, Library database, PSL implementation, GHDL implementation of VHDL @comment node-name, next, previous, up @section Source representation According to the VHDL standard, design units (i.e. entities, diff --git a/errorout.adb b/errorout.adb index 2ddc42686..3332de2ab 100644 --- a/errorout.adb +++ b/errorout.adb @@ -25,6 +25,7 @@ with Files_Map; use Files_Map; with Ada.Strings.Unbounded; with Std_Names; with Flags; +with PSL.Nodes; package body Errorout is procedure Put (Str : String) @@ -64,7 +65,7 @@ package body Errorout is procedure Error_Kind (Msg : String; An_Iir : Iir) is begin - Put_Line (Msg & ": can't handle " + Put_Line (Msg & ": cannot handle " & Iir_Kind'Image (Get_Kind (An_Iir)) & " (" & Disp_Location (An_Iir) & ')'); raise Internal_Error; @@ -72,11 +73,19 @@ package body Errorout is procedure Error_Kind (Msg : String; Def : Iir_Predefined_Functions) is begin - Put_Line (Msg & ": can't handle " + Put_Line (Msg & ": cannot handle " & Iir_Predefined_Functions'Image (Def)); raise Internal_Error; end Error_Kind; + procedure Error_Kind (Msg : String; N : PSL_Node) is + begin + Put (Msg); + Put (": cannot handle "); + Put_Line (PSL.Nodes.Nkind'Image (PSL.Nodes.Get_Kind (N))); + raise Internal_Error; + end Error_Kind; + -- Disp an error, prepended with program name. -- This is used for errors before initialisation, such as bad option or -- bad filename. @@ -142,6 +151,11 @@ package body Errorout is Disp_Location (Get_Location_Safe (An_Iir)); end Disp_Iir_Location; + procedure Disp_PSL_Location (N : PSL_Node) is + begin + Disp_Location (PSL.Nodes.Get_Location (N)); + end Disp_PSL_Location; + procedure Warning_Msg (Msg: String) is begin Put ("warning: "); @@ -268,6 +282,17 @@ package body Errorout is Put_Line (Msg); end Error_Msg_Sem; + procedure Error_Msg_Sem (Msg: String; Loc: PSL_Node) is + use PSL.Nodes; + begin + Nbr_Errors := Nbr_Errors + 1; + if Loc /= Null_Node then + Disp_PSL_Location (Loc); + Put (' '); + end if; + Put_Line (Msg); + end Error_Msg_Sem; + procedure Error_Msg_Sem (Msg: String; Loc : Location_Type) is begin Nbr_Errors := Nbr_Errors + 1; @@ -533,6 +558,8 @@ package body Errorout is return "selected element"; when Iir_Kind_Selected_By_All_Name => return ".all name"; + when Iir_Kind_Psl_Expression => + return "PSL instantiation"; when Iir_Kind_Constant_Interface_Declaration => case Get_Kind (Get_Parent (Node)) is @@ -660,6 +687,9 @@ package body Errorout is when Iir_Kind_Generate_Statement => return "generate statement"; + when Iir_Kind_Psl_Declaration => + return Disp_Identifier (Node, "PSL declaration"); + when Iir_Kind_Attribute_Declaration => return Disp_Identifier (Node, "attribute"); when Iir_Kind_Attribute_Specification => @@ -762,6 +792,10 @@ package body Errorout is (Node, "concurrent selected signal assignment"); when Iir_Kind_Concurrent_Assertion_Statement => return Disp_Label (Node, "concurrent assertion"); + when Iir_Kind_Psl_Assert_Statement => + return Disp_Label (Node, "PSL assertion"); + when Iir_Kind_Psl_Default_Clock => + return "PSL default clock"; when Iir_Kind_If_Statement => return Disp_Label (Node, "if statement"); diff --git a/errorout.ads b/errorout.ads index f75374b69..2d8365c3a 100644 --- a/errorout.ads +++ b/errorout.ads @@ -33,6 +33,7 @@ package Errorout is --procedure Error_Kind (Msg: String; Kind: Iir_Kind); procedure Error_Kind (Msg: String; An_Iir: in Iir); procedure Error_Kind (Msg: String; Def : Iir_Predefined_Functions); + procedure Error_Kind (Msg : String; N : PSL_Node); pragma No_Return (Error_Kind); -- Raise when an assertion of failure severity error fails. @@ -75,6 +76,7 @@ package Errorout is -- Disp a message during semantic analysis. -- an_iir is used for location and current token. procedure Error_Msg_Sem (Msg: String; Loc: Iir); + procedure Error_Msg_Sem (Msg: String; Loc: PSL_Node); procedure Error_Msg_Sem (Msg: String; Loc: Location_Type); -- Disp a message during elaboration. diff --git a/evaluation.adb b/evaluation.adb index c54015385..571dcadf0 100644 --- a/evaluation.adb +++ b/evaluation.adb @@ -271,6 +271,8 @@ package body Evaluation is Index_Constraint : Iir; Constraint : Iir; begin + -- The left limit must be locally static in order to compute the right + -- limit. if Get_Type_Staticness (A_Type) /= Locally then raise Internal_Error; end if; @@ -356,7 +358,7 @@ package body Evaluation is function Eval_String_Literal (Str : Iir) return Iir is Ptr : String_Fat_Acc; - Len : Natural; + Len : Nat32; begin case Get_Kind (Str) is when Iir_Kind_String_Literal => @@ -497,7 +499,7 @@ package body Evaluation is use Str_Table; L_Str : constant String_Fat_Acc := Get_String_Fat_Acc (Left); R_Str : constant String_Fat_Acc := Get_String_Fat_Acc (Right); - Len : Natural; + Len : Nat32; Id : String_Id; begin Len := Get_String_Length (Left); @@ -595,7 +597,7 @@ package body Evaluation is Iir_Predefined_Functions'Image (Func)); end case; Finish; - return Build_String (Id, Nat32 (Len), Left); + return Build_String (Id, Len, Left); end if; end Eval_Dyadic_Bit_Array_Operator; @@ -2246,4 +2248,106 @@ package body Evaluation is -- end; -- end if; end Eval_Simple_Name; + + + function Compare_String_Literals (L, R : Iir) return Compare_Type + is + type Str_Info is record + El : Iir; + Ptr : String_Fat_Acc; + Len : Nat32; + Lit_0 : Iir; + Lit_1 : Iir; + List : Iir_List; + end record; + + Literal_List : Iir_List; + + -- Fill Res from EL. This is used to speed up Lt and Eq operations. + procedure Get_Info (Expr : Iir; Res : out Str_Info) is + begin + case Get_Kind (Expr) is + when Iir_Kind_Simple_Aggregate => + Res := Str_Info'(El => Expr, + Ptr => null, + Len => 0, + Lit_0 | Lit_1 => Null_Iir, + List => Get_Simple_Aggregate_List (Expr)); + Res.Len := Nat32 (Get_Nbr_Elements (Res.List)); + when Iir_Kind_Bit_String_Literal => + Res := Str_Info'(El => Expr, + Ptr => Get_String_Fat_Acc (Expr), + Len => Get_String_Length (Expr), + Lit_0 => Get_Bit_String_0 (Expr), + Lit_1 => Get_Bit_String_1 (Expr), + List => Null_Iir_List); + when Iir_Kind_String_Literal => + Res := Str_Info'(El => Expr, + Ptr => Get_String_Fat_Acc (Expr), + Len => Get_String_Length (Expr), + Lit_0 | Lit_1 => Null_Iir, + List => Null_Iir_List); + when others => + Error_Kind ("sem_string_choice_range.get_info", Expr); + end case; + end Get_Info; + + -- Return the position of element IDX of STR. + function Get_Pos (Str : Str_Info; Idx : Nat32) return Iir_Int32 + is + S : Iir; + C : Character; + begin + case Get_Kind (Str.El) is + when Iir_Kind_Simple_Aggregate => + S := Get_Nth_Element (Str.List, Natural (Idx)); + when Iir_Kind_String_Literal => + C := Str.Ptr (Idx + 1); + -- FIXME: build a table from character to position. + -- This linear search is O(n)! + S := Find_Name_In_List (Literal_List, + Name_Table.Get_Identifier (C)); + when Iir_Kind_Bit_String_Literal => + C := Str.Ptr (Idx + 1); + case C is + when '0' => + S := Str.Lit_0; + when '1' => + S := Str.Lit_1; + when others => + raise Internal_Error; + end case; + when others => + Error_Kind ("sem_string_choice_range.get_pos", Str.El); + end case; + return Get_Enum_Pos (S); + end Get_Pos; + + L_Info, R_Info : Str_Info; + L_Pos, R_Pos : Iir_Int32; + begin + Get_Info (L, L_Info); + Get_Info (R, R_Info); + + if L_Info.Len /= R_Info.Len then + raise Internal_Error; + end if; + + Literal_List := Get_Enumeration_Literal_List + (Get_Base_Type (Get_Element_Subtype (Get_Type (L)))); + + for I in 0 .. L_Info.Len - 1 loop + L_Pos := Get_Pos (L_Info, I); + R_Pos := Get_Pos (R_Info, I); + if L_Pos /= R_Pos then + if L_Pos < R_Pos then + return Compare_Lt; + else + return Compare_Gt; + end if; + end if; + end loop; + return Compare_Eq; + end Compare_String_Literals; + end Evaluation; diff --git a/evaluation.ads b/evaluation.ads index 282a7522a..7a4df00bb 100644 --- a/evaluation.ads +++ b/evaluation.ads @@ -100,4 +100,8 @@ package Evaluation is -- or operator sumbol of ID, using the same format as SIMPLE_NAME -- attribute. procedure Eval_Simple_Name (Id : Name_Id); + + -- Compare two string literals (of same length). + type Compare_Type is (Compare_Lt, Compare_Eq, Compare_Gt); + function Compare_String_Literals (L, R : Iir) return Compare_Type; end Evaluation; diff --git a/files_map.adb b/files_map.adb index c73ffbe6c..c6525bd65 100644 --- a/files_map.adb +++ b/files_map.adb @@ -880,8 +880,8 @@ package body Files_Map is if Ts = Null_Time_Stamp then return "NULL_TS"; else - return Str_Table.Get_String_Fat_Acc (String_Id (Ts)) - (1 .. Time_Stamp_String'Length); + return String (Str_Table.Get_String_Fat_Acc (String_Id (Ts)) + (1 .. Time_Stamp_String'Length)); end if; end Get_Time_Stamp_String; @@ -311,6 +311,18 @@ package body Iirs is function Int32_To_Iir is new Ada.Unchecked_Conversion (Source => Int32, Target => Iir); + function Iir_To_PSL_Node is new Ada.Unchecked_Conversion + (Source => Iir, Target => PSL_Node); + + function PSL_Node_To_Iir is new Ada.Unchecked_Conversion + (Source => PSL_Node, Target => Iir); + + function Iir_To_PSL_NFA is new Ada.Unchecked_Conversion + (Source => Iir, Target => PSL_NFA); + + function PSL_NFA_To_Iir is new Ada.Unchecked_Conversion + (Source => PSL_NFA, Target => Iir); + -- Subprograms function Get_Format (Kind : Iir_Kind) return Format_Type is begin @@ -419,6 +431,8 @@ package body Iirs is | Iir_Kind_Selected_Element | Iir_Kind_Dereference | Iir_Kind_Implicit_Dereference + | Iir_Kind_Psl_Expression + | Iir_Kind_Psl_Default_Clock | Iir_Kind_Concurrent_Procedure_Call_Statement | Iir_Kind_Null_Statement | Iir_Kind_Variable_Assignment_Statement @@ -488,6 +502,7 @@ package body Iirs is | Iir_Kind_Unit_Declaration | Iir_Kind_Library_Declaration | Iir_Kind_Component_Declaration + | Iir_Kind_Psl_Declaration | Iir_Kind_Function_Declaration | Iir_Kind_Implicit_Function_Declaration | Iir_Kind_Implicit_Procedure_Declaration @@ -508,6 +523,7 @@ package body Iirs is | Iir_Kind_Concurrent_Conditional_Signal_Assignment | Iir_Kind_Concurrent_Selected_Signal_Assignment | Iir_Kind_Concurrent_Assertion_Statement + | Iir_Kind_Psl_Assert_Statement | Iir_Kind_Block_Statement | Iir_Kind_Generate_Statement | Iir_Kind_Component_Instantiation_Statement @@ -1842,6 +1858,7 @@ package body Iirs is | Iir_Kind_Concurrent_Conditional_Signal_Assignment | Iir_Kind_Concurrent_Selected_Signal_Assignment | Iir_Kind_Concurrent_Assertion_Statement + | Iir_Kind_Psl_Assert_Statement | Iir_Kind_Concurrent_Procedure_Call_Statement | Iir_Kind_Block_Statement | Iir_Kind_Generate_Statement @@ -2096,6 +2113,7 @@ package body Iirs is | Iir_Kind_Group_Template_Declaration | Iir_Kind_Group_Declaration | Iir_Kind_Non_Object_Alias_Declaration + | Iir_Kind_Psl_Declaration | Iir_Kind_Function_Body | Iir_Kind_Function_Declaration | Iir_Kind_Implicit_Function_Declaration @@ -2117,6 +2135,8 @@ package body Iirs is | Iir_Kind_Concurrent_Conditional_Signal_Assignment | Iir_Kind_Concurrent_Selected_Signal_Assignment | Iir_Kind_Concurrent_Assertion_Statement + | Iir_Kind_Psl_Default_Clock + | Iir_Kind_Psl_Assert_Statement | Iir_Kind_Concurrent_Procedure_Call_Statement | Iir_Kind_Block_Statement | Iir_Kind_Generate_Statement @@ -2281,6 +2301,7 @@ package body Iirs is | Iir_Kind_Selected_Element | Iir_Kind_Dereference | Iir_Kind_Implicit_Dereference + | Iir_Kind_Psl_Expression | Iir_Kind_Return_Statement | Iir_Kind_Simple_Name | Iir_Kind_Slice_Name @@ -3332,6 +3353,7 @@ package body Iirs is | Iir_Kind_Group_Declaration | Iir_Kind_Element_Declaration | Iir_Kind_Non_Object_Alias_Declaration + | Iir_Kind_Psl_Declaration | Iir_Kind_Function_Declaration | Iir_Kind_Implicit_Function_Declaration | Iir_Kind_Implicit_Procedure_Declaration @@ -3353,6 +3375,8 @@ package body Iirs is | Iir_Kind_Concurrent_Conditional_Signal_Assignment | Iir_Kind_Concurrent_Selected_Signal_Assignment | Iir_Kind_Concurrent_Assertion_Statement + | Iir_Kind_Psl_Default_Clock + | Iir_Kind_Psl_Assert_Statement | Iir_Kind_Concurrent_Procedure_Call_Statement | Iir_Kind_Block_Statement | Iir_Kind_Generate_Statement @@ -3398,6 +3422,8 @@ package body Iirs is | Iir_Kind_Concurrent_Conditional_Signal_Assignment | Iir_Kind_Concurrent_Selected_Signal_Assignment | Iir_Kind_Concurrent_Assertion_Statement + | Iir_Kind_Psl_Default_Clock + | Iir_Kind_Psl_Assert_Statement | Iir_Kind_Concurrent_Procedure_Call_Statement | Iir_Kind_Block_Statement | Iir_Kind_Generate_Statement @@ -3449,6 +3475,7 @@ package body Iirs is | Iir_Kind_Group_Declaration | Iir_Kind_Element_Declaration | Iir_Kind_Non_Object_Alias_Declaration + | Iir_Kind_Psl_Declaration | Iir_Kind_Function_Declaration | Iir_Kind_Implicit_Function_Declaration | Iir_Kind_Implicit_Procedure_Declaration @@ -3470,6 +3497,7 @@ package body Iirs is | Iir_Kind_Concurrent_Conditional_Signal_Assignment | Iir_Kind_Concurrent_Selected_Signal_Assignment | Iir_Kind_Concurrent_Assertion_Statement + | Iir_Kind_Psl_Assert_Statement | Iir_Kind_Concurrent_Procedure_Call_Statement | Iir_Kind_Block_Statement | Iir_Kind_Generate_Statement @@ -4508,6 +4536,7 @@ package body Iirs is begin case Get_Kind (Target) is when Iir_Kind_Concurrent_Assertion_Statement + | Iir_Kind_Psl_Assert_Statement | Iir_Kind_Assertion_Statement | Iir_Kind_Report_Statement => null; @@ -4532,6 +4561,7 @@ package body Iirs is begin case Get_Kind (Target) is when Iir_Kind_Concurrent_Assertion_Statement + | Iir_Kind_Psl_Assert_Statement | Iir_Kind_Assertion_Statement | Iir_Kind_Report_Statement => null; @@ -5069,6 +5099,7 @@ package body Iirs is | Iir_Kind_Group_Template_Declaration | Iir_Kind_Group_Declaration | Iir_Kind_Non_Object_Alias_Declaration + | Iir_Kind_Psl_Declaration | Iir_Kind_Function_Body | Iir_Kind_Function_Declaration | Iir_Kind_Implicit_Function_Declaration @@ -5092,6 +5123,8 @@ package body Iirs is | Iir_Kind_Concurrent_Conditional_Signal_Assignment | Iir_Kind_Concurrent_Selected_Signal_Assignment | Iir_Kind_Concurrent_Assertion_Statement + | Iir_Kind_Psl_Default_Clock + | Iir_Kind_Psl_Assert_Statement | Iir_Kind_Concurrent_Procedure_Call_Statement | Iir_Kind_Block_Statement | Iir_Kind_Generate_Statement @@ -6718,6 +6751,7 @@ package body Iirs is | Iir_Kind_Group_Template_Declaration | Iir_Kind_Group_Declaration | Iir_Kind_Non_Object_Alias_Declaration + | Iir_Kind_Psl_Declaration | Iir_Kind_Function_Declaration | Iir_Kind_Implicit_Function_Declaration | Iir_Kind_Implicit_Procedure_Declaration @@ -6751,4 +6785,138 @@ package body Iirs is Set_Flag6 (Decl, Val); end Set_Use_Flag; + procedure Check_Kind_For_Psl_Property (Target : Iir) is + begin + case Get_Kind (Target) is + when Iir_Kind_Psl_Assert_Statement => + null; + when others => + Failed ("Psl_Property", Target); + end case; + end Check_Kind_For_Psl_Property; + + function Get_Psl_Property (Decl : Iir) return PSL_Node is + begin + Check_Kind_For_Psl_Property (Decl); + return Iir_To_PSL_Node (Get_Field1 (Decl)); + end Get_Psl_Property; + + procedure Set_Psl_Property (Decl : Iir; Prop : PSL_Node) is + begin + Check_Kind_For_Psl_Property (Decl); + Set_Field1 (Decl, PSL_Node_To_Iir (Prop)); + end Set_Psl_Property; + + procedure Check_Kind_For_Psl_Declaration (Target : Iir) is + begin + case Get_Kind (Target) is + when Iir_Kind_Psl_Declaration => + null; + when others => + Failed ("Psl_Declaration", Target); + end case; + end Check_Kind_For_Psl_Declaration; + + function Get_Psl_Declaration (Decl : Iir) return PSL_Node is + begin + Check_Kind_For_Psl_Declaration (Decl); + return Iir_To_PSL_Node (Get_Field1 (Decl)); + end Get_Psl_Declaration; + + procedure Set_Psl_Declaration (Decl : Iir; Prop : PSL_Node) is + begin + Check_Kind_For_Psl_Declaration (Decl); + Set_Field1 (Decl, PSL_Node_To_Iir (Prop)); + end Set_Psl_Declaration; + + procedure Check_Kind_For_Psl_Expression (Target : Iir) is + begin + case Get_Kind (Target) is + when Iir_Kind_Psl_Expression => + null; + when others => + Failed ("Psl_Expression", Target); + end case; + end Check_Kind_For_Psl_Expression; + + function Get_Psl_Expression (Decl : Iir) return PSL_Node is + begin + Check_Kind_For_Psl_Expression (Decl); + return Iir_To_PSL_Node (Get_Field3 (Decl)); + end Get_Psl_Expression; + + procedure Set_Psl_Expression (Decl : Iir; Prop : PSL_Node) is + begin + Check_Kind_For_Psl_Expression (Decl); + Set_Field3 (Decl, PSL_Node_To_Iir (Prop)); + end Set_Psl_Expression; + + procedure Check_Kind_For_Psl_Boolean (Target : Iir) is + begin + case Get_Kind (Target) is + when Iir_Kind_Psl_Default_Clock => + null; + when others => + Failed ("Psl_Boolean", Target); + end case; + end Check_Kind_For_Psl_Boolean; + + function Get_Psl_Boolean (N : Iir) return PSL_Node is + begin + Check_Kind_For_Psl_Boolean (N); + return Iir_To_PSL_Node (Get_Field1 (N)); + end Get_Psl_Boolean; + + procedure Set_Psl_Boolean (N : Iir; Bool : PSL_Node) is + begin + Check_Kind_For_Psl_Boolean (N); + Set_Field1 (N, PSL_Node_To_Iir (Bool)); + end Set_Psl_Boolean; + + procedure Check_Kind_For_PSL_Clock (Target : Iir) is + begin + case Get_Kind (Target) is + when Iir_Kind_Psl_Declaration + | Iir_Kind_Psl_Assert_Statement => + null; + when others => + Failed ("PSL_Clock", Target); + end case; + end Check_Kind_For_PSL_Clock; + + function Get_PSL_Clock (N : Iir) return PSL_Node is + begin + Check_Kind_For_PSL_Clock (N); + return Iir_To_PSL_Node (Get_Field7 (N)); + end Get_PSL_Clock; + + procedure Set_PSL_Clock (N : Iir; Clock : PSL_Node) is + begin + Check_Kind_For_PSL_Clock (N); + Set_Field7 (N, PSL_Node_To_Iir (Clock)); + end Set_PSL_Clock; + + procedure Check_Kind_For_PSL_NFA (Target : Iir) is + begin + case Get_Kind (Target) is + when Iir_Kind_Psl_Declaration + | Iir_Kind_Psl_Assert_Statement => + null; + when others => + Failed ("PSL_NFA", Target); + end case; + end Check_Kind_For_PSL_NFA; + + function Get_PSL_NFA (N : Iir) return PSL_NFA is + begin + Check_Kind_For_PSL_NFA (N); + return Iir_To_PSL_NFA (Get_Field8 (N)); + end Get_PSL_NFA; + + procedure Set_PSL_NFA (N : Iir; Fa : PSL_NFA) is + begin + Check_Kind_For_PSL_NFA (N); + Set_Field8 (N, PSL_NFA_To_Iir (Fa)); + end Set_PSL_NFA; + end Iirs; diff --git a/iirs.adb.in b/iirs.adb.in index cba22aebd..6ed1c4dfb 100644 --- a/iirs.adb.in +++ b/iirs.adb.in @@ -311,5 +311,17 @@ package body Iirs is function Int32_To_Iir is new Ada.Unchecked_Conversion (Source => Int32, Target => Iir); + function Iir_To_PSL_Node is new Ada.Unchecked_Conversion + (Source => Iir, Target => PSL_Node); + + function PSL_Node_To_Iir is new Ada.Unchecked_Conversion + (Source => PSL_Node, Target => Iir); + + function Iir_To_PSL_NFA is new Ada.Unchecked_Conversion + (Source => Iir, Target => PSL_NFA); + + function PSL_NFA_To_Iir is new Ada.Unchecked_Conversion + (Source => PSL_NFA, Target => Iir); + -- Subprograms end Iirs; @@ -212,9 +212,6 @@ package Iirs is -- Iir_Kind_String_Literal (Short) -- Iir_Kind_Bit_String_Literal (Medium) -- - -- Type of the literal. Note: for a (bit_)string_literal, the type must be - -- computed during semantization. Roughly speaking, this is possible since - -- integer type range constraint are locally static. -- Get/Set_Type (Field1) -- -- Used for computed literals. Literal_Origin contains the expression whose @@ -223,6 +220,8 @@ package Iirs is -- -- Get/Set_String_Id (Field3) -- + -- As bit-strings are expanded to '0'/'1' strings, this is the number of + -- characters. -- Get/Set_String_Length (Field0) -- -- For bit string only: @@ -579,6 +578,12 @@ package Iirs is -- -- Get/Set_Name_Staticness (State2) + -- Iir_Kind_Psl_Expression (Short) + -- + -- Get/Set_Type (Field1) + -- + -- Get/Set_Psl_Expression (Field3) + -- Iir_Kind_Signature (Short) -- -- Get/Set_Return_Type (Field1) @@ -1237,6 +1242,26 @@ package Iirs is -- -- Get/Set_Use_Flag (Flag6) + -- Iir_Kind_Psl_Declaration (Medium) + -- + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Psl_Declaration (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Identifier (Field3) + -- + -- Valid only for property declaration. + -- Get/Set_PSL_Clock (Field7) + -- + -- Valid only for property declaration without parameters. + -- Get/Set_PSL_NFA (Field8) + -- + -- Get/Set_Visible_Flag (Flag4) + -- + -- Get/Set_Use_Flag (Flag6) + -- Iir_Kind_Use_Clause (Short) -- -- Get/Set_Parent (Field0) @@ -1732,6 +1757,40 @@ package Iirs is -- -- Get/Set_Visible_Flag (Flag4) + -- Iir_Kind_Psl_Default_Clock (Short) + -- + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Psl_Boolean (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Label (Field3) + -- Get/Set_Identifier (Alias Field3) + + -- Iir_Kind_Psl_Assert_Statement (Medium) + -- + -- Get/Set_Parent (Field0) + -- + -- Get/Set_Psl_Property (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Label (Field3) + -- Get/Set_Identifier (Alias Field3) + -- + -- Get/Set_Attribute_Value_Chain (Field4) + -- + -- Get/Set_Severity_Expression (Field5) + -- + -- Get/Set_Report_Expression (Field6) + -- + -- Get/Set_PSL_Clock (Field7) + -- + -- Get/Set_PSL_NFA (Field8) + -- + -- Get/Set_Visible_Flag (Flag4) + -- Iir_Kind_Component_Instantiation_Statement (Medium) -- -- Get/Set_Parent (Field0) @@ -2561,6 +2620,8 @@ package Iirs is Iir_Kind_Element_Declaration, Iir_Kind_Non_Object_Alias_Declaration, + Iir_Kind_Psl_Declaration, + Iir_Kind_Function_Body, Iir_Kind_Function_Declaration, Iir_Kind_Implicit_Function_Declaration, @@ -2621,6 +2682,7 @@ package Iirs is Iir_Kind_Selected_Element, Iir_Kind_Dereference, Iir_Kind_Implicit_Dereference, + Iir_Kind_Psl_Expression, -- Concurrent statements. Iir_Kind_Sensitized_Process_Statement, @@ -2628,6 +2690,8 @@ package Iirs is Iir_Kind_Concurrent_Conditional_Signal_Assignment, Iir_Kind_Concurrent_Selected_Signal_Assignment, Iir_Kind_Concurrent_Assertion_Statement, + Iir_Kind_Psl_Default_Clock, + Iir_Kind_Psl_Assert_Statement, Iir_Kind_Concurrent_Procedure_Call_Statement, Iir_Kind_Block_Statement, Iir_Kind_Generate_Statement, @@ -3332,6 +3396,8 @@ package Iirs is --Iir_Kind_Concurrent_Conditional_Signal_Assignment --Iir_Kind_Concurrent_Selected_Signal_Assignment --Iir_Kind_Concurrent_Assertion_Statement + --Iir_Kind_Psl_Default_Clock + --Iir_Kind_Psl_Assert_Statement --Iir_Kind_Concurrent_Procedure_Call_Statement --Iir_Kind_Block_Statement --Iir_Kind_Generate_Statement @@ -3387,6 +3453,7 @@ package Iirs is --Iir_Kind_Group_Declaration --Iir_Kind_Element_Declaration --Iir_Kind_Non_Object_Alias_Declaration + --Iir_Kind_Psl_Declaration --Iir_Kind_Function_Body --Iir_Kind_Function_Declaration --Iir_Kind_Implicit_Function_Declaration @@ -5032,4 +5099,28 @@ package Iirs is -- Field: Flag6 function Get_Use_Flag (Decl : Iir) return Boolean; procedure Set_Use_Flag (Decl : Iir; Val : Boolean); + + -- Field: Field1 (uc) + function Get_Psl_Property (Decl : Iir) return PSL_Node; + procedure Set_Psl_Property (Decl : Iir; Prop : PSL_Node); + + -- Field: Field1 (uc) + function Get_Psl_Declaration (Decl : Iir) return PSL_Node; + procedure Set_Psl_Declaration (Decl : Iir; Prop : PSL_Node); + + -- Field: Field3 (uc) + function Get_Psl_Expression (Decl : Iir) return PSL_Node; + procedure Set_Psl_Expression (Decl : Iir; Prop : PSL_Node); + + -- Field: Field1 (uc) + function Get_Psl_Boolean (N : Iir) return PSL_Node; + procedure Set_Psl_Boolean (N : Iir; Bool : PSL_Node); + + -- Field: Field7 (uc) + function Get_PSL_Clock (N : Iir) return PSL_Node; + procedure Set_PSL_Clock (N : Iir; Clock : PSL_Node); + + -- Field: Field8 (uc) + function Get_PSL_NFA (N : Iir) return PSL_NFA; + procedure Set_PSL_NFA (N : Iir; Fa : PSL_NFA); end Iirs; diff --git a/iirs_utils.adb b/iirs_utils.adb index 46e51ccfa..904b42120 100644 --- a/iirs_utils.adb +++ b/iirs_utils.adb @@ -22,6 +22,7 @@ with Name_Table; with Str_Table; with Std_Names; use Std_Names; with Flags; use Flags; +with PSL.Nodes; package body Iirs_Utils is -- Transform the current token into an iir literal. @@ -322,11 +323,6 @@ package body Iirs_Utils is return Str_Table.Get_String_Fat_Acc (Get_String_Id (Str)); end Get_String_Fat_Acc; - function Get_String_Length (Str : Iir) return Natural is - begin - return Natural (Nat32'(Get_String_Length (Str))); - end Get_String_Length; - -- Get identifier of NODE as a string. function Image_Identifier (Node : Iir) return String is begin @@ -336,11 +332,11 @@ package body Iirs_Utils is function Image_String_Lit (Str : Iir) return String is Ptr : String_Fat_Acc; - Len : Natural; + Len : Nat32; begin Ptr := Get_String_Fat_Acc (Str); Len := Get_String_Length (Str); - return Ptr (1 .. Len); + return String (Ptr (1 .. Len)); end Image_String_Lit; procedure Create_Range_Constraint_For_Enumeration_Type @@ -838,4 +834,9 @@ package body Iirs_Utils is end case; end loop; end Is_Signal_Object; + + function Get_HDL_Node (N : PSL_Node) return Iir is + begin + return Iir (PSL.Nodes.Get_HDL_Node (N)); + end Get_HDL_Node; end Iirs_Utils; diff --git a/iirs_utils.ads b/iirs_utils.ads index fce466c61..abbed3aa0 100644 --- a/iirs_utils.ads +++ b/iirs_utils.ads @@ -29,9 +29,7 @@ package Iirs_Utils is -- Easier function for string literals. function Get_String_Fat_Acc (Str : Iir) return String_Fat_Acc; - function Get_String_Length (Str : Iir) return Natural; pragma Inline (Get_String_Fat_Acc); - pragma Inline (Get_String_Length); -- Find LIT in the list of identifiers or characters LIST. -- Return the literal (whose name is LIT) or null_iir if not found. @@ -155,5 +153,7 @@ package Iirs_Utils is -- Return TRUE if the base name of NAME is a signal object. function Is_Signal_Object (Name: Iir) return Boolean; + -- IIR wrapper around Get_HDL_Node. + function Get_HDL_Node (N : PSL_Node) return Iir; end Iirs_Utils; diff --git a/iirs_walk.adb b/iirs_walk.adb index 6cb5d3f69..1af0e66ec 100644 --- a/iirs_walk.adb +++ b/iirs_walk.adb @@ -1,3 +1,21 @@ +-- Walk in iirs nodes. +-- Copyright (C) 2009 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + package body Iirs_Walk is function Walk_Chain (Chain : Iir; Cb : Walk_Cb) return Walk_Status is diff --git a/iirs_walk.ads b/iirs_walk.ads index cfa6e9637..4c098f7d5 100644 --- a/iirs_walk.ads +++ b/iirs_walk.ads @@ -1,3 +1,21 @@ +-- Walk in iirs nodes. +-- Copyright (C) 2009 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + with Iirs; use Iirs; package Iirs_Walk is diff --git a/libraries.adb b/libraries.adb index e70a88a1a..4d5743923 100644 --- a/libraries.adb +++ b/libraries.adb @@ -49,7 +49,6 @@ package body Libraries is -- Initialize pathes table. -- Set the local path. - Name_Nil : Name_Id; procedure Init_Pathes is begin @@ -298,15 +297,15 @@ package body Libraries is function String_To_Name_Id return Name_Id is - Len : Natural; + Len : Int32; Ptr : String_Fat_Acc; begin - Len := Natural (Current_String_Length); + Len := Current_String_Length; Ptr := Str_Table.Get_String_Fat_Acc (Current_String_Id); for I in 1 .. Len loop - Name_Table.Name_Buffer (I) := Ptr (I); + Name_Table.Name_Buffer (Natural (I)) := Ptr (I); end loop; - Name_Table.Name_Length := Len; + Name_Table.Name_Length := Natural (Len); -- FIXME: should remove last string. return Get_Identifier; end String_To_Name_Id; diff --git a/libraries.ads b/libraries.ads index 18b1c5d57..34ae69830 100644 --- a/libraries.ads +++ b/libraries.ads @@ -55,6 +55,10 @@ package Libraries is -- Local (current) directory. Local_Directory : Name_Id; + -- Correspond to "" (empty identifier). Used to denote current directory + -- for library directories. + Name_Nil : Name_Id; + -- Initialize library pathes table. -- Set the local path. procedure Init_Pathes; diff --git a/libraries/vital2000/prmtvs_b.vhdl b/libraries/vital2000/prmtvs_b.vhdl index c015e62d5..dcfc92b20 100644 --- a/libraries/vital2000/prmtvs_b.vhdl +++ b/libraries/vital2000/prmtvs_b.vhdl @@ -1,6 +1,6 @@ ------------------------------------------------------------------------------- -- Title : Standard VITAL_Primitives Package --- : $Revision: 600 $ +-- : $Revision$ -- : -- Library : VITAL -- : diff --git a/libraries/vital2000/prmtvs_p.vhdl b/libraries/vital2000/prmtvs_p.vhdl index 764ac449a..857899e34 100644 --- a/libraries/vital2000/prmtvs_p.vhdl +++ b/libraries/vital2000/prmtvs_p.vhdl @@ -1,6 +1,6 @@ -- ----------------------------------------------------------------------------- -- Title : Standard VITAL_Primitives Package --- : $Revision: 598 $ +-- : $Revision$ -- : -- Library : This package shall be compiled into a library -- : symbolically named IEEE. diff --git a/libraries/vital2000/timing_b.vhdl b/libraries/vital2000/timing_b.vhdl index 28bf52095..cf6f6f5b3 100644 --- a/libraries/vital2000/timing_b.vhdl +++ b/libraries/vital2000/timing_b.vhdl @@ -1,6 +1,6 @@ ------------------------------------------------------------------------------- -- Title : Standard VITAL TIMING Package --- : $Revision: 598 $ +-- : $Revision$ -- Library : VITAL -- : -- Developers : IEEE DASC Timing Working Group (TWG), PAR 1076.4 diff --git a/libraries/vital2000/timing_p.vhdl b/libraries/vital2000/timing_p.vhdl index e18c8c24a..bbeb66fc0 100644 --- a/libraries/vital2000/timing_p.vhdl +++ b/libraries/vital2000/timing_p.vhdl @@ -1,6 +1,6 @@ ------------------------------------------------------------------------------- -- Title : Standard VITAL TIMING Package --- : $Revision: 598 $ +-- : $Revision$ -- : -- Library : This package shall be compiled into a library -- : symbolically named IEEE. diff --git a/libraries/vital95/vital_primitives.vhdl b/libraries/vital95/vital_primitives.vhdl index d0da36ba0..5d6dfe62b 100644 --- a/libraries/vital95/vital_primitives.vhdl +++ b/libraries/vital95/vital_primitives.vhdl @@ -1,6 +1,6 @@ -- ----------------------------------------------------------------------------- -- Title : Standard VITAL_Primitives Package --- : $Revision: 597 $ +-- : $Revision$ -- : -- Library : This package shall be compiled into a library -- : symbolically named IEEE. diff --git a/libraries/vital95/vital_primitives_body.vhdl b/libraries/vital95/vital_primitives_body.vhdl index 25e834189..f8f66366c 100644 --- a/libraries/vital95/vital_primitives_body.vhdl +++ b/libraries/vital95/vital_primitives_body.vhdl @@ -1,6 +1,6 @@ ------------------------------------------------------------------------------- -- Title : Standard VITAL_Primitives Package --- : $Revision: 597 $ +-- : $Revision$ -- : -- Library : VITAL -- : diff --git a/libraries/vital95/vital_timing.vhdl b/libraries/vital95/vital_timing.vhdl index 1fe5a9e24..abfedaf1a 100644 --- a/libraries/vital95/vital_timing.vhdl +++ b/libraries/vital95/vital_timing.vhdl @@ -1,6 +1,6 @@ ------------------------------------------------------------------------------- -- Title : Standard VITAL TIMING Package --- : $Revision: 597 $ +-- : $Revision$ -- : -- Library : This package shall be compiled into a library -- : symbolically named IEEE. diff --git a/libraries/vital95/vital_timing_body.vhdl b/libraries/vital95/vital_timing_body.vhdl index 09eb75565..49998bdb5 100644 --- a/libraries/vital95/vital_timing_body.vhdl +++ b/libraries/vital95/vital_timing_body.vhdl @@ -1,6 +1,6 @@ ------------------------------------------------------------------------------- -- Title : Standard VITAL TIMING Package --- : $Revision: 597 $ +-- : $Revision$ -- Library : VITAL -- : -- Developers : IEEE DASC Timing Working Group (TWG), PAR 1076.4 diff --git a/options.adb b/options.adb index 80eeadb2d..e95456f9c 100644 --- a/options.adb +++ b/options.adb @@ -18,11 +18,23 @@ with Ada.Text_IO; use Ada.Text_IO; with Name_Table; with Libraries; +with Std_Names; +with PSL.Nodes; +with PSL.Dump_Tree; +with Disp_Tree; with Scan; with Back_End; use Back_End; with Flags; use Flags; package body Options is + procedure Initialize is + begin + Std_Names.Std_Names_Initialize; + Libraries.Init_Pathes; + PSL.Nodes.Init; + PSL.Dump_Tree.Dump_Hdl_Node := Disp_Tree.Disp_Tree_For_Psl'Access; + end Initialize; + function Option_Warning (Opt: String; Val : Boolean) return Boolean is begin -- if Opt = "undriven" then @@ -106,6 +118,9 @@ package body Options is Flag_Vital_Checks := False; elsif Opt = "--vital-checks" then Flag_Vital_Checks := True; + elsif Opt = "-fpsl" then + Scan.Flag_Psl_Comment := True; + Scan.Flag_Comment_Keyword := True; elsif Opt = "-dp" then Dump_Parse := True; elsif Opt = "-ds" then @@ -196,11 +211,12 @@ package body Options is -- P (" --assert-level=LEVEL set the level which stop the"); -- P (" simulation. LEVEL is note, warning, error,"); -- P (" failure or none"); - P ("Illegal extensions:"); + P ("Extensions:"); P (" -fexplicit give priority to explicitly declared operator"); P (" -C --mb-comments allow multi-bytes chars in a comment"); P (" --bootstrap allow --work=std"); P (" --syn-binding use synthesis default binding rule"); + P (" -fpsl parse psl in comments"); P ("Compilation list:"); P (" -ls after semantics"); P (" -lc after canon"); diff --git a/options.ads b/options.ads index d9dc890cd..24a844b59 100644 --- a/options.ads +++ b/options.ads @@ -24,4 +24,7 @@ package Options is -- Disp help about these options. procedure Disp_Options_Help; + + -- Front-end intialization. + procedure Initialize; end Options; diff --git a/ortho/debug/ortho_debug-disp.adb b/ortho/debug/ortho_debug-disp.adb index b97ff50e5..be75122e3 100644 --- a/ortho/debug/ortho_debug-disp.adb +++ b/ortho/debug/ortho_debug-disp.adb @@ -125,10 +125,18 @@ package body Ortho_Debug.Disp is return Ctx.Tab = 0; end Is_Top; - procedure Put_Tab is + procedure Put_Tab + is + Tab : Natural := Ctx.Next_Tab; + Max_Tab : constant Natural := 40; begin - Ctx.Line (1 .. Ctx.Next_Tab) := (others => ' '); - Ctx.Line_Len := Ctx.Next_Tab; + if Tab > Max_Tab then + -- Limit indentation length, to limit line length. + Tab := Max_Tab; + end if; + + Ctx.Line (1 .. Tab) := (others => ' '); + Ctx.Line_Len := Tab; Ctx.Next_Tab := Ctx.Tab + 2; end Put_Tab; diff --git a/ortho/gcc/Makefile b/ortho/gcc/Makefile index 09ae08c93..c8eba1392 100644 --- a/ortho/gcc/Makefile +++ b/ortho/gcc/Makefile @@ -15,7 +15,8 @@ include $(orthobe_srcdir)/Makefile.inc ORTHO_BASENAME=$(orthobe_srcdir)/ortho_gcc ORTHO_PACKAGE=Ortho_Gcc -LIBFLAGS=$(HOME)/dist/mpfr-2.3.1/.libs/libmpfr.a $(HOME)/dist/gmp-4.2.2/.libs/libgmp.a +#LIBFLAGS=$(HOME)/dist/mpfr-2.3.1/.libs/libmpfr.a $(HOME)/dist/gmp-4.2.2/.libs/libgmp.a +LIBFLAGS=-lmpfr -lgmp $(ortho_exec): $(AGCC_DEPS) $(ORTHO_BASENAME).ads force $(GNATMAKE) -m -o $@ -g -aI$(ortho_srcdir) \ diff --git a/ortho/gcc/lang.opt b/ortho/gcc/lang.opt index 980fef7bf..eb6395999 100644 --- a/ortho/gcc/lang.opt +++ b/ortho/gcc/lang.opt @@ -65,6 +65,10 @@ fexplicit vhdl Explicit function declarations override implicit one in use +fpsl +vhdl +Allow PSL asserts in comments + -no-direct-drivers vhdl Disable direct drivers optimization @@ -83,4 +87,4 @@ Allow any character in comments -mb-comments vhdl -Allow any character in comments
\ No newline at end of file +Allow any character in comments diff --git a/ortho/mcode/binary_file-memory.adb b/ortho/mcode/binary_file-memory.adb index 4d5f74024..a37af9cb7 100644 --- a/ortho/mcode/binary_file-memory.adb +++ b/ortho/mcode/binary_file-memory.adb @@ -57,7 +57,9 @@ package body Binary_File.Memory is --Sect.Data := new Byte_Array (1 .. 0); end if; end if; - if Sect.Data_Max > 0 and Sect /= Sect_Abs then + if Sect.Data_Max > 0 + and (Sect /= Sect_Abs and Sect.Flags /= Section_Debug) + then Sect.Vaddr := To_Pc_Type (Sect.Data (0)'Address); end if; Sect := Sect.Next; diff --git a/ortho/mcode/binary_file.ads b/ortho/mcode/binary_file.ads index f81292678..1a2bf588d 100644 --- a/ortho/mcode/binary_file.ads +++ b/ortho/mcode/binary_file.ads @@ -33,6 +33,7 @@ package Binary_File is Section_Write : constant Section_Flags; Section_Zero : constant Section_Flags; Section_Strtab : constant Section_Flags; + Section_Debug : constant Section_Flags; type Byte is new Unsigned_8; @@ -218,6 +219,7 @@ private Section_Write : constant Section_Flags := 2#0000_0100#; Section_Zero : constant Section_Flags := 2#0000_1000#; Section_Strtab : constant Section_Flags := 2#0001_0000#; + Section_Debug : constant Section_Flags := 2#0010_0000#; Section_None : constant Section_Flags := 2#0000_0000#; -- Scope of a symbol: diff --git a/ortho/mcode/ortho_code-dwarf.adb b/ortho/mcode/ortho_code-dwarf.adb index a82d63526..14215d37a 100644 --- a/ortho/mcode/ortho_code-dwarf.adb +++ b/ortho/mcode/ortho_code-dwarf.adb @@ -280,7 +280,7 @@ package body Ortho_Code.Dwarf is Set_Symbol_Pc (Orig_Sym, False); End_Sym := Create_Local_Symbol; - Create_Section (Line1_Sect, ".debug_line-1", Section_None); + Create_Section (Line1_Sect, ".debug_line-1", Section_Debug); Set_Current_Section (Line1_Sect); -- Write Address. @@ -291,14 +291,14 @@ package body Ortho_Code.Dwarf is Line_Last := 1; - Create_Section (Line_Sect, ".debug_line", Section_None); + Create_Section (Line_Sect, ".debug_line", Section_Debug); Set_Section_Info (Line_Sect, null, 0, 0); Set_Current_Section (Line_Sect); Line_Sym := Create_Local_Symbol; Set_Symbol_Pc (Line_Sym, False); -- Abbrevs. - Create_Section (Abbrev_Sect, ".debug_abbrev", Section_None); + Create_Section (Abbrev_Sect, ".debug_abbrev", Section_Debug); Set_Section_Info (Abbrev_Sect, null, 0, 0); Set_Current_Section (Abbrev_Sect); @@ -318,7 +318,7 @@ package body Ortho_Code.Dwarf is Abbrev_Last := 1; -- Info. - Create_Section (Info_Sect, ".debug_info", Section_None); + Create_Section (Info_Sect, ".debug_info", Section_Debug); Set_Section_Info (Info_Sect, null, 0, 0); Set_Current_Section (Info_Sect); Info_Sym := Create_Local_Symbol; @@ -340,13 +340,14 @@ package body Ortho_Code.Dwarf is procedure Emit_Decl (Decl : O_Dnode); + -- Next node to be emitted. Last_Decl : O_Dnode := O_Dnode_First; procedure Emit_Decls_Until (Last : O_Dnode) is use Ortho_Code.Decls; begin - while Last_Decl <= Last loop + while Last_Decl < Last loop Emit_Decl (Last_Decl); Last_Decl := Get_Decl_Chain (Last_Decl); end loop; @@ -355,11 +356,16 @@ package body Ortho_Code.Dwarf is procedure Finish is Length : Pc_Type; + Last : O_Dnode; begin Set_Symbol_Pc (End_Sym, False); Length := Get_Current_Pc; - Emit_Decls_Until (Decls.Get_Decl_Last); + Last := Decls.Get_Decl_Last; + Emit_Decls_Until (Last); + if Last_Decl <= Last then + Emit_Decl (Last); + end if; -- Finish abbrevs. Set_Current_Section (Abbrev_Sect); @@ -449,7 +455,7 @@ package body Ortho_Code.Dwarf is Patch_32 (0, Unsigned_32 (Get_Current_Pc - 4)); -- Aranges - Create_Section (Aranges_Sect, ".debug_aranges", Section_None); + Create_Section (Aranges_Sect, ".debug_aranges", Section_Debug); Set_Section_Info (Aranges_Sect, null, 0, 0); Set_Current_Section (Aranges_Sect); @@ -1325,6 +1331,8 @@ package body Ortho_Code.Dwarf is procedure Emit_Subprg (Bod : O_Dnode) is begin Emit_Decls_Until (Bod); + Emit_Decl (Bod); + Last_Decl := Decls.Get_Decl_Chain (Bod); end Emit_Subprg; procedure Mark (M : out Mark_Type) is diff --git a/ortho/mcode/ortho_code-dwarf.ads b/ortho/mcode/ortho_code-dwarf.ads index bdd07eb16..c120bcfe1 100644 --- a/ortho/mcode/ortho_code-dwarf.ads +++ b/ortho/mcode/ortho_code-dwarf.ads @@ -22,6 +22,9 @@ package Ortho_Code.Dwarf is -- For a body. procedure Emit_Subprg (Bod : O_Dnode); + -- Emit all debug info until but not including LAST. + procedure Emit_Decls_Until (Last : O_Dnode); + -- For a line in a subprogram. procedure Set_Line_Stmt (Line : Int32); procedure Set_Filename (Dir : String; File : String); diff --git a/ortho/mcode/ortho_code-x86-abi.adb b/ortho/mcode/ortho_code-x86-abi.adb index 56c5543ce..a915f9235 100644 --- a/ortho/mcode/ortho_code-x86-abi.adb +++ b/ortho/mcode/ortho_code-x86-abi.adb @@ -87,7 +87,6 @@ package body Ortho_Code.X86.Abi is Mark (Decls_Mark); Consts.Mark (Consts_Mark); Mark (Types_Mark); - Dwarf.Mark (Dwarf_Mark); end if; end Start_Body; @@ -114,6 +113,15 @@ package body Ortho_Code.X86.Abi is Emits.Emit_Subprg (Subprg); + if Get_Decl_Depth (Subprg.D_Decl) = O_Toplevel + and then Flag_Debug = Debug_Dwarf + then + Dwarf.Emit_Decls_Until (Subprg.D_Body); + if not Debug.Flag_Debug_Keep then + Dwarf.Mark (Dwarf_Mark); + end if; + end if; + -- Recurse on nested subprograms. Child := Subprg.First_Child; while Child /= null loop diff --git a/ortho/mcode/ortho_code-x86-insns.adb b/ortho/mcode/ortho_code-x86-insns.adb index 4021a994c..d3ea79233 100644 --- a/ortho/mcode/ortho_code-x86-insns.adb +++ b/ortho/mcode/ortho_code-x86-insns.adb @@ -1799,6 +1799,7 @@ package body Ortho_Code.X86.Insns is when R_Irm | R_Rm | R_Ir + | R_Sib | R_Any32 | Regs_R32 | R_Any64 @@ -24,6 +24,7 @@ with Iirs_Utils; use Iirs_Utils; with Errorout; use Errorout; with Std_Names; use Std_Names; with Flags; use Flags; +with Parse_Psl; with Name_Table; with Str_Table; with Xrefs; @@ -60,8 +61,7 @@ package body Parse is function Parse_Configuration_Item return Iir; function Parse_Block_Configuration return Iir_Block_Configuration; procedure Parse_Concurrent_Statements (Parent : Iir); - function Parse_Expression return Iir_Expression; - function Parse_Subprogram_Declaration return Iir; + function Parse_Subprogram_Declaration (Parent : Iir) return Iir; function Parse_Subtype_Indication (Name : Iir := Null_Iir) return Iir; procedure Parse_Component_Specification (Res : Iir); function Parse_Binding_Indication return Iir_Binding_Indication; @@ -440,14 +440,14 @@ package body Parse is procedure Bad_Operator_Symbol is begin - Error_Msg_Parse ("""" & Str (1 .. Natural (Len)) + Error_Msg_Parse ("""" & String (Str (1 .. Len)) & """ is not an operator symbol", Loc); end Bad_Operator_Symbol; procedure Check_Vhdl93 is begin if Flags.Vhdl_Std = Vhdl_87 then - Error_Msg_Parse ("""" & Str (1 .. Natural (Len)) + Error_Msg_Parse ("""" & String (Str (1 .. Len)) & """ is not a vhdl87 operator symbol", Loc); end if; end Check_Vhdl93; @@ -2803,7 +2803,7 @@ package body Parse is | Tok_Procedure | Tok_Pure | Tok_Impure => - Decl := Parse_Subprogram_Declaration; + Decl := Parse_Subprogram_Declaration (Parent); when Tok_Alias => Decl := Parse_Alias_Declaration; when Tok_Component => @@ -2981,7 +2981,7 @@ package body Parse is -- [ §7.3.2 ] -- choices ::= choice { | choice } -- - -- Leave tok_arrow as current token. + -- Leave tok_double_arrow as current token. function Parse_Choices (Expr: Iir) return Iir is First, Last : Iir; @@ -3032,7 +3032,7 @@ package body Parse is Expr := Parse_Expression; case Current_Token is when Tok_Comma - | Tok_Arrow + | Tok_Double_Arrow | Tok_Bar => -- This is really an aggregate null; @@ -3065,7 +3065,7 @@ package body Parse is loop if Current_Token = Tok_Others then Assoc := Parse_A_Choice (Null_Iir); - Expect (Tok_Arrow); + Expect (Tok_Double_Arrow); Scan.Scan; Expr := Parse_Expression; else @@ -3082,7 +3082,7 @@ package body Parse is Location_Copy (Assoc, Expr); when others => Assoc := Parse_Choices (Expr); - Expect (Tok_Arrow); + Expect (Tok_Double_Arrow); Scan.Scan; Expr := Parse_Expression; end case; @@ -3409,21 +3409,16 @@ package body Parse is return Res; end Parse_Shift_Expression; - -- precond : next token + -- precond : next token (relational_operator) -- postcond: next token -- -- [ §7.1 ] - -- relation ::= shift_expression [ relational_operator shift_expression ] - -- - -- [ §7.2 ] - -- relational_operator ::= = | /= | < | <= | > | >= - function Parse_Relation return Iir_Expression is + -- relational_operator shift_expression + function Parse_Relation_Rhs (Left : Iir) return Iir + is Res, Tmp: Iir_Expression; begin - Tmp := Parse_Shift_Expression; - if Current_Token not in Token_Relational_Operator_Type then - return Tmp; - end if; + Tmp := Left; -- This loop is just to handle errors such as a = b = c. loop @@ -3453,6 +3448,26 @@ package body Parse is Tmp := Res; end loop; return Res; + end Parse_Relation_Rhs; + + -- precond : next token + -- postcond: next token + -- + -- [ §7.1 ] + -- relation ::= shift_expression [ relational_operator shift_expression ] + -- + -- [ §7.2 ] + -- relational_operator ::= = | /= | < | <= | > | >= + function Parse_Relation return Iir + is + Tmp: Iir; + begin + Tmp := Parse_Shift_Expression; + if Current_Token not in Token_Relational_Operator_Type then + return Tmp; + end if; + + return Parse_Relation_Rhs (Tmp); end Parse_Relation; -- precond : next token @@ -3465,13 +3480,14 @@ package body Parse is -- | relation [ NAND relation } -- | relation [ NOR relation } -- | relation { XNOR relation } - function Parse_Expression return Iir_Expression is - Res, Tmp: Iir_Expression; + function Parse_Expression_Rhs (Left : Iir) return Iir + is + Res, Tmp: Iir; -- OP_TOKEN contains the operator combinaison. Op_Token: Token_Type; begin - Tmp := Parse_Relation; + Tmp := Left; Op_Token := Tok_Invalid; loop case Current_Token is @@ -3528,6 +3544,13 @@ package body Parse is Set_Right (Res, Parse_Relation); Tmp := Res; end loop; + end Parse_Expression_Rhs; + + -- precond : next token + -- postcond: next token + function Parse_Expression return Iir_Expression is + begin + return Parse_Expression_Rhs (Parse_Relation); end Parse_Expression; -- precond : next token @@ -4263,12 +4286,12 @@ package body Parse is while Current_Token /= Tok_End loop Expect (Tok_When); Scan.Scan; - if Current_Token = Tok_Arrow then + if Current_Token = Tok_Double_Arrow then Error_Msg_Parse ("missing expression in alternative"); else Assoc := Parse_Choices (Null_Iir); end if; - Expect (Tok_Arrow); + Expect (Tok_Double_Arrow); Scan.Scan; Set_Associated (Assoc, Parse_Sequential_Statements (Stmt)); @@ -4334,7 +4357,7 @@ package body Parse is -- -- [ §2.1 ] -- operator_symbol ::= string_literal - function Parse_Subprogram_Declaration return Iir + function Parse_Subprogram_Declaration (Parent : Iir) return Iir is Subprg: Iir; Subprg_Body : Iir; @@ -4438,6 +4461,9 @@ package body Parse is Set_Subprogram_Specification (Subprg_Body, Subprg); Set_Chain (Subprg, Subprg_Body); + if Get_Kind (Parent) = Iir_Kind_Package_Declaration then + Error_Msg_Parse ("subprogram body not allowed in package spec"); + end if; Expect (Tok_Is); Scan.Scan; Parse_Declarative_Part (Subprg_Body); @@ -4642,7 +4668,7 @@ package body Parse is if Nbr_Assocs /= 1 then Error_Msg_Parse ("multi-dimensional slice is forbidden"); end if; - when Tok_Arrow => + when Tok_Double_Arrow => Formal := Actual; Scan.Scan; if Current_Token /= Tok_Open then @@ -5014,6 +5040,56 @@ package body Parse is end case; end Parse_Concurrent_Assignment; + function Parse_Psl_Default_Clock return Iir + is + Res : Iir; + begin + Res := Create_Iir (Iir_Kind_Psl_Default_Clock); + Scan.Flag_Psl := True; + Scan_Expect (Tok_Psl_Clock); + Scan_Expect (Tok_Is); + Scan.Scan; + Set_Psl_Boolean (Res, Parse_Psl.Parse_Psl_Boolean); + Expect (Tok_Semi_Colon); + Scan.Flag_Scan_In_Comment := False; + Scan.Flag_Psl := False; + return Res; + end Parse_Psl_Default_Clock; + + function Parse_Psl_Declaration return Iir + is + Tok : constant Token_Type := Current_Token; + Res : Iir; + begin + Res := Create_Iir (Iir_Kind_Psl_Declaration); + Scan.Scan; + if Current_Token /= Tok_Identifier then + Error_Msg_Parse ("property name expected here"); + else + Set_Identifier (Res, Current_Identifier); + end if; + Scan.Flag_Psl := True; + Set_Psl_Declaration (Res, Parse_Psl.Parse_Psl_Declaration (Tok)); + Expect (Tok_Semi_Colon); + Scan.Flag_Scan_In_Comment := False; + Scan.Flag_Psl := False; + return Res; + end Parse_Psl_Declaration; + + function Parse_Psl_Assert_Statement return Iir + is + Res : Iir; + begin + Res := Create_Iir (Iir_Kind_Psl_Assert_Statement); + Scan.Flag_Psl := True; + Scan.Scan; + Set_Psl_Property (Res, Parse_Psl.Parse_Psl_Property); + Expect (Tok_Semi_Colon); + Scan.Flag_Scan_In_Comment := False; + Scan.Flag_Psl := False; + return Res; + end Parse_Psl_Assert_Statement; + procedure Parse_Concurrent_Statements (Parent : Iir) is Last_Stmt : Iir; @@ -5023,6 +5099,14 @@ package body Parse is Postponed : Boolean; Loc : Location_Type; Target : Iir; + + procedure Postponed_Not_Allowed is + begin + if Postponed then + Error_Msg_Parse ("'postponed' not allowed here"); + Postponed := False; + end if; + end Postponed_Not_Allowed; begin -- begin was just parsed. Last_Stmt := Null_Iir; @@ -5062,6 +5146,7 @@ package body Parse is case Current_Token is when Tok_End => + Postponed_Not_Allowed; if Label /= Null_Identifier then Error_Msg_Parse ("no label is allowed before the 'end' keyword"); @@ -5095,11 +5180,7 @@ package body Parse is when Tok_With => Stmt := Parse_Selected_Signal_Assignment; when Tok_Block => - if Postponed then - Error_Msg_Parse - ("'postponed' is not allowed before 'block'"); - Postponed := False; - end if; + Postponed_Not_Allowed; Stmt := Parse_Block_Statement (Label, Loc); when Tok_If | Tok_For => @@ -5115,17 +5196,24 @@ package body Parse is when Tok_Component | Tok_Entity | Tok_Configuration => - if Postponed then - Error_Msg_Parse ("'postponed' not allowed before " & - "an instantiation statement"); - Postponed := False; - end if; + Postponed_Not_Allowed; declare Unit : Iir; begin Unit := Parse_Instantiated_Unit; Stmt := Parse_Component_Instantiation (Unit); end; + when Tok_Psl_Default => + Postponed_Not_Allowed; + Stmt := Parse_Psl_Default_Clock; + when Tok_Psl_Property + | Tok_Psl_Sequence + | Tok_Psl_Endpoint => + Postponed_Not_Allowed; + Stmt := Parse_Psl_Declaration; + when Tok_Psl_Assert => + Postponed_Not_Allowed; + Stmt := Parse_Psl_Assert_Statement; when others => -- FIXME: improve message: -- instead of 'unexpected token 'signal' in conc stmt list' @@ -5139,7 +5227,9 @@ package body Parse is -- stmt can be null in case of error. if Stmt /= Null_Iir then Set_Location (Stmt, Loc); - Set_Label (Stmt, Label); + if Label /= Null_Identifier then + Set_Label (Stmt, Label); + end if; Set_Parent (Stmt, Parent); if Postponed then Set_Postponed_Flag (Stmt, True); @@ -18,6 +18,14 @@ with Iirs; use Iirs; package Parse is + -- Parse an expression. + -- (Used by PSL). + function Parse_Expression return Iir; + function Parse_Expression_Rhs (Left : Iir) return Iir; + + -- Parse an relationnal operator and its rhs. + function Parse_Relation_Rhs (Left : 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/parse_psl.adb b/parse_psl.adb new file mode 100644 index 000000000..ab5df9620 --- /dev/null +++ b/parse_psl.adb @@ -0,0 +1,669 @@ +-- VHDL PSL parser. +-- Copyright (C) 2009 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with PSL.Nodes; use PSL.Nodes; +with Iirs; +with Scan; use Scan; +with PSL.Errors; use PSL.Errors; +with PSL.Priorities; use PSL.Priorities; +with Parse; + +package body Parse_Psl is + procedure Scan renames Scan.Scan; + + function Create_Node_Loc (K : Nkind) return Node is + Res : Node; + begin + Res := PSL.Nodes.Create_Node (K); + Set_Location (Res, Get_Token_Location); + return Res; + end Create_Node_Loc; + + function Parse_Number return Node is + Res : Node; + begin + if Current_Token = Tok_Integer then + Res := Create_Node_Loc (N_Number); + -- FIXME: handle overflow. + Set_Value (Res, Uns32 (Current_Iir_Int64)); + Scan; + return Res; + elsif Current_Token = Tok_Inf then + -- FIXME: create node + Scan; + return Null_Node; + else + Error_Msg_Parse ("number expected"); + return Null_Node; + end if; + end Parse_Number; + + procedure Parse_Count (N : Node) is + begin + Set_Low_Bound (N, Parse_Number); + if Current_Token = Tok_To then + Scan; + Set_High_Bound (N, Parse_Number); + end if; + end Parse_Count; + + function Psl_To_Vhdl (N : Node) return Iirs.Iir + is + use Iirs; + Res : Iir; + begin + case Get_Kind (N) is + when N_HDL_Expr => + Res := Iirs.Iir (Get_HDL_Node (N)); + Free_Node (N); + return Res; + when others => + Error_Kind ("psl_to_vhdl", N); + end case; + end Psl_To_Vhdl; + + function Vhdl_To_Psl (N : Iirs.Iir) return Node + is + Res : Node; + begin + Res := Create_Node_Loc (N_HDL_Expr); + Set_Location (Res, Iirs.Get_Location (N)); + Set_HDL_Node (Res, Int32 (N)); + return Res; + end Vhdl_To_Psl; + + function Parse_FL_Property (Prio : Priority) return Node; + function Parse_Sequence return Node; + + function Parse_Parenthesis_Boolean return Node; + function Parse_Boolean (Parent_Prio : Priority) return Node; + + function Parse_Unary_Boolean return Node is + begin + return Vhdl_To_Psl (Parse.Parse_Expression); + end Parse_Unary_Boolean; + + function Parse_Boolean_Rhs (Parent_Prio : Priority; Left : Node) return Node + is + Kind : Nkind; + Prio : Priority; + Res : Node; + Tmp : Node; + begin + Res := Left; + loop + case Current_Token is + when Tok_And => + Kind := N_And_Bool; + Prio := Prio_Seq_And; + when Tok_Or => + Kind := N_Or_Bool; + Prio := Prio_Seq_Or; + when others => + return Res; + end case; + if Parent_Prio >= Prio then + return Res; + end if; + Tmp := Create_Node_Loc (Kind); + Scan; + Set_Left (Tmp, Res); + Res := Tmp; + Tmp := Parse_Boolean (Prio); + Set_Right (Res, Tmp); + end loop; + end Parse_Boolean_Rhs; + + function Parse_Boolean (Parent_Prio : Priority) return Node + is + begin + return Parse_Boolean_Rhs (Parent_Prio, Parse_Unary_Boolean); + end Parse_Boolean; + + function Parse_Psl_Boolean return PSL_Node is + begin + return Parse_Boolean (Prio_Lowest); + end Parse_Psl_Boolean; + + function Parse_Parenthesis_Boolean return Node is + Res : Node; + begin + if Current_Token /= Tok_Left_Paren then + Error_Msg_Parse ("'(' expected before boolean expression"); + return Null_Node; + else + Scan; + Res := Parse_Psl_Boolean; + if Current_Token = Tok_Right_Paren then + Scan; + else + Error_Msg_Parse ("missing matching ')' for boolean expression"); + end if; + return Res; + end if; + end Parse_Parenthesis_Boolean; + + function Parse_SERE (Prio : Priority) return Node is + Left, Res : Node; + Kind : Nkind; + Op_Prio : Priority; + begin + Left := Parse_Sequence; -- FIXME: allow boolean; + loop + case Current_Token is + when Tok_Semi_Colon => + Kind := N_Concat_SERE; + Op_Prio := Prio_Seq_Concat; + when Tok_Colon => + Kind := N_Fusion_SERE; + Op_Prio := Prio_Seq_Fusion; + when Tok_Within => + Kind := N_Within_SERE; + Op_Prio := Prio_Seq_Within; + when Tok_Ampersand => + -- For non-length matching and, the operator is '&'. + Kind := N_And_Seq; + Op_Prio := Prio_Seq_And; + when Tok_And_And => + Kind := N_Match_And_Seq; + Op_Prio := Prio_Seq_And; + when Tok_Bar => + Kind := N_Or_Seq; + Op_Prio := Prio_Seq_Or; +-- when Tok_Bar_Bar => +-- Res := Create_Node_Loc (N_Or_Bool); +-- Scan; +-- Set_Left (Res, Left); +-- Set_Right (Res, Parse_Boolean (Prio_Seq_Or)); +-- return Res; + when others => + return Left; + end case; + if Prio >= Op_Prio then + return Left; + end if; + Res := Create_Node_Loc (Kind); + Scan; + Set_Left (Res, Left); + Set_Right (Res, Parse_SERE (Op_Prio)); + Left := Res; + end loop; + end Parse_SERE; + + -- precond: '{' + function Parse_Braced_SERE return Node is + Res : Node; + begin + if Current_Token /= Tok_Left_Curly then + raise Program_Error; + end if; + Res := Create_Node_Loc (N_Braced_SERE); + Scan; + Set_SERE (Res, Parse_SERE (Prio_Lowest)); + if Current_Token /= Tok_Right_Curly then + Error_Msg_Parse ("missing '}' after braced SERE"); + else + Scan; + end if; + return Res; + end Parse_Braced_SERE; + + -- Parse [ Count ] ']' + function Parse_Maybe_Count (Kind : Nkind; Seq : Node) return Node is + N : Node; + begin + N := Create_Node_Loc (Kind); + Set_Sequence (N, Seq); + Scan; + if Current_Token /= Tok_Right_Bracket then + Parse_Count (N); + end if; + if Current_Token /= Tok_Right_Bracket then + Error_Msg_Parse ("missing ']'"); + else + Scan; + end if; + return N; + end Parse_Maybe_Count; + + procedure Parse_Bracket_Range (N : Node) is + begin + if Current_Token /= Tok_Left_Bracket then + Error_Msg_Parse ("'[' expected"); + else + Scan; + Set_Low_Bound (N, Parse_Number); + if Current_Token /= Tok_To then + Error_Msg_Parse ("'to' expected in range after left bound"); + else + Scan; + Set_High_Bound (N, Parse_Number); + end if; + if Current_Token /= Tok_Right_Bracket then + Error_Msg_Parse ("']' expected after range"); + else + Scan; + end if; + end if; + end Parse_Bracket_Range; + + function Parse_Bracket_Number return Node is + Res : Node; + begin + if Current_Token /= Tok_Left_Bracket then + Error_Msg_Parse ("'[' expected"); + return Null_Node; + else + Scan; + Res := Parse_Number; + if Current_Token /= Tok_Right_Bracket then + Error_Msg_Parse ("']' expected after range"); + else + Scan; + end if; + return Res; + end if; + end Parse_Bracket_Number; + + function Parse_Sequence return Node is + Res, N : Node; + begin + case Current_Token is + when Tok_Left_Curly => + Res := Parse_Braced_SERE; + when Tok_Brack_Star => + return Parse_Maybe_Count (N_Star_Repeat_Seq, Null_Node); + when Tok_Left_Paren => + Res := Parse_Parenthesis_Boolean; + if Current_Token = Tok_Or + or else Current_Token = Tok_And + then + Res := Parse_Boolean_Rhs (Prio_Lowest, Res); + end if; + when Tok_Brack_Plus_Brack => + Res := Create_Node_Loc (N_Plus_Repeat_Seq); + Scan; + return Res; + when others => + -- Repeated_SERE + Res := Parse_Unary_Boolean; + end case; + loop + case Current_Token is + when Tok_Brack_Star => + Res := Parse_Maybe_Count (N_Star_Repeat_Seq, Res); + when Tok_Brack_Plus_Brack => + N := Create_Node_Loc (N_Plus_Repeat_Seq); + Set_Sequence (N, Res); + Scan; + Res := N; + when Tok_Brack_Arrow => + Res := Parse_Maybe_Count (N_Goto_Repeat_Seq, Res); + when Tok_Brack_Equal => + N := Create_Node_Loc (N_Equal_Repeat_Seq); + Set_Sequence (N, Res); + Scan; + Parse_Count (N); + if Current_Token /= Tok_Right_Bracket then + Error_Msg_Parse ("missing ']'"); + else + Scan; + end if; + Res := N; + when others => + return Res; + end case; + end loop; + end Parse_Sequence; + + -- precond: '(' + -- postcond: next token + function Parse_Parenthesis_FL_Property return Node is + Res : Node; + Loc : Location_Type; + begin + Loc := Get_Token_Location; + if Current_Token /= Tok_Left_Paren then + Error_Msg_Parse ("'(' expected around property"); + return Parse_FL_Property (Prio_Lowest); + else + Scan; + Res := Parse_FL_Property (Prio_Lowest); + if Current_Token /= Tok_Right_Paren then + Error_Msg_Parse ("missing matching ')' for '(' at line " + & Get_Location_Str (Loc, False)); + else + Scan; + end if; + return Res; + end if; + end Parse_Parenthesis_FL_Property; + + -- Parse [ '!' ] '[' finite_Range ']' '(' FL_Property ')' + function Parse_Range_Property (K : Nkind) return Node is + Res : Node; + begin + Res := Create_Node_Loc (K); + Set_Strong_Flag (Res, Scan_Exclam_Mark); + Scan; + Parse_Bracket_Range (Res); + Set_Property (Res, Parse_Parenthesis_FL_Property); + return Res; + end Parse_Range_Property; + + -- Parse [ '!' ] '(' Boolean ')' '[' Range ']' '(' FL_Property ')' + function Parse_Boolean_Range_Property (K : Nkind) return Node is + Res : Node; + begin + Res := Create_Node_Loc (K); + Set_Strong_Flag (Res, Scan_Exclam_Mark); + Scan; + Set_Boolean (Res, Parse_Parenthesis_Boolean); + Parse_Bracket_Range (Res); + Set_Property (Res, Parse_Parenthesis_FL_Property); + return Res; + end Parse_Boolean_Range_Property; + + function Parse_FL_Property_1 return Node + is + Res : Node; + Tmp : Node; + begin + case Current_Token is + when Tok_Always => + Res := Create_Node_Loc (N_Always); + Scan; + Set_Property (Res, Parse_FL_Property (Prio_FL_Invariance)); + when Tok_Never => + Res := Create_Node_Loc (N_Never); + Scan; + Set_Property (Res, Parse_FL_Property (Prio_FL_Invariance)); + when Tok_Eventually => + Res := Create_Node_Loc (N_Eventually); + if not Scan_Exclam_Mark then + Error_Msg_Parse ("'eventually' must be followed by '!'"); + end if; + Scan; + Set_Property (Res, Parse_FL_Property (Prio_FL_Occurence)); + when Tok_Next => + Res := Create_Node_Loc (N_Next); + Scan; + if Current_Token = Tok_Left_Bracket then + Set_Number (Res, Parse_Bracket_Number); + Set_Property (Res, Parse_Parenthesis_FL_Property); + else + Set_Property (Res, Parse_FL_Property (Prio_FL_Occurence)); + end if; + when Tok_Next_A => + Res := Parse_Range_Property (N_Next_A); + when Tok_Next_E => + Res := Parse_Range_Property (N_Next_E); + when Tok_Next_Event => + Res := Create_Node_Loc (N_Next_Event); + Scan; + Set_Boolean (Res, Parse_Parenthesis_Boolean); + if Current_Token = Tok_Left_Bracket then + Set_Number (Res, Parse_Bracket_Number); + end if; + Set_Property (Res, Parse_Parenthesis_FL_Property); + when Tok_Next_Event_A => + Res := Parse_Boolean_Range_Property (N_Next_Event_A); + when Tok_Next_Event_E => + Res := Parse_Boolean_Range_Property (N_Next_Event_E); + when Tok_Left_Paren => + return Parse_Parenthesis_FL_Property; + when Tok_Left_Curly => + Res := Parse_Sequence; + if Get_Kind (Res) = N_Braced_SERE + and then Current_Token = Tok_Left_Paren + then + -- FIXME: must check that RES is really a sequence + -- (and not a SERE). + Tmp := Create_Node_Loc (N_Overlap_Imp_Seq); + Set_Sequence (Tmp, Res); + Set_Property (Tmp, Parse_Parenthesis_FL_Property); + Res := Tmp; + end if; + when others => + Res := Parse_Sequence; + end case; + return Res; + end Parse_FL_Property_1; + + function Parse_St_Binary_FL_Property (K : Nkind; Left : Node) return Node is + Res : Node; + begin + Res := Create_Node_Loc (K); + Set_Strong_Flag (Res, Scan_Exclam_Mark); + Set_Inclusive_Flag (Res, Scan_Underscore); + Scan; + Set_Left (Res, Left); + Set_Right (Res, Parse_FL_Property (Prio_FL_Bounding)); + return Res; + end Parse_St_Binary_FL_Property; + + function Parse_Binary_FL_Property (K : Nkind; Left : Node; Prio : Priority) + return Node + is + Res : Node; + begin + Res := Create_Node_Loc (K); + Scan; + Set_Left (Res, Left); + Set_Right (Res, Parse_FL_Property (Prio)); + return Res; + end Parse_Binary_FL_Property; + + function Parse_FL_Property (Prio : Priority) return Node + is + Res : Node; + N : Node; + begin + Res := Parse_FL_Property_1; + loop + case Current_Token is + when Tok_Minus_Greater => + if Prio > Prio_Bool_Imp then + return Res; + end if; + N := Create_Node_Loc (N_Log_Imp_Prop); + Set_Left (N, Res); + Scan; + Set_Right (N, Parse_FL_Property (Prio_Bool_Imp)); + Res := N; + when Tok_Bar_Arrow => + if Prio > Prio_Seq_Imp then + return Res; + end if; + N := Create_Node_Loc (N_Overlap_Imp_Seq); + Set_Sequence (N, Res); + Scan; + Set_Property (N, Parse_FL_Property (Prio_Seq_Imp)); + Res := N; + when Tok_Bar_Double_Arrow => + if Prio > Prio_Seq_Imp then + return Res; + end if; + N := Create_Node_Loc (N_Imp_Seq); + Set_Sequence (N, Res); + Scan; + Set_Property (N, Parse_FL_Property (Prio_Seq_Imp)); + Res := N; + when Tok_Abort => + if Prio > Prio_FL_Abort then + return Res; + end if; + N := Create_Node_Loc (N_Abort); + Set_Property (N, Res); + Scan; + Set_Boolean (N, Parse_Boolean (Prio_Lowest)); + -- Left associative. + return N; + when Tok_Exclam_Mark => + N := Create_Node_Loc (N_Strong); + Set_Property (N, Res); + Scan; + Res := N; + when Tok_Until => + if Prio > Prio_FL_Bounding then + return Res; + end if; + Res := Parse_St_Binary_FL_Property (N_Until, Res); + when Tok_Before => + if Prio > Prio_FL_Bounding then + return Res; + end if; + Res := Parse_St_Binary_FL_Property (N_Before, Res); + when Tok_Or => + if Prio > Prio_Seq_Or then + return Res; + end if; + Res := Parse_Binary_FL_Property (N_Or_Prop, Res, Prio_Seq_Or); + when Tok_And => + if Prio > Prio_Seq_And then + return Res; + end if; + Res := Parse_Binary_FL_Property (N_And_Prop, Res, Prio_Seq_And); + when Token_Relational_Operator_Type => + return Vhdl_To_Psl + (Parse.Parse_Relation_Rhs (Psl_To_Vhdl (Res))); + when Tok_Colon + | Tok_Bar + | Tok_Ampersand + | Tok_And_And => + Error_Msg_Parse ("SERE operator '" & Image (Current_Token) + & "' is not allowed in property"); + Scan; + N := Parse_FL_Property (Prio_Lowest); + return Res; + when Tok_Arobase => + if Prio > Prio_Clock_Event then + return Res; + end if; + N := Create_Node_Loc (N_Clock_Event); + Set_Property (N, Res); + Scan; + Set_Boolean (N, Parse_Boolean (Prio_Clock_Event)); + Res := N; + when others => + return Res; + end case; + end loop; + end Parse_FL_Property; + + function Parse_Psl_Property return PSL_Node is + begin + return Parse_FL_Property (Prio_Lowest); + end Parse_Psl_Property; + + -- precond: identifier + -- postcond: ';' + -- + -- 6.2.4.1 Property declaration + -- + -- Property_Declaration ::= + -- PROPERTY psl_identifier [ ( Formal_Parameter_List ) ] DEF_SYM + -- property ; + function Parse_Psl_Declaration (Tok : Token_Type) return PSL_Node + is + Res : Node; + Param : Node; + Last_Param : Node; + Pkind : Nkind; + Kind : Nkind; + begin + case Tok is + when Tok_Psl_Property => + Kind := N_Property_Declaration; + when Tok_Psl_Sequence => + Kind := N_Sequence_Declaration; + when Tok_Psl_Endpoint => + Kind := N_Endpoint_Declaration; + when others => + raise Internal_Error; + end case; + Res := Create_Node_Loc (Kind); + if Current_Token = Tok_Identifier then + Set_Identifier (Res, Current_Identifier); + Scan; + end if; + + -- Formal parameter list. + if Current_Token = Tok_Left_Paren then + Last_Param := Null_Node; + loop + -- precond: '(' or ';'. + Scan; + case Current_Token is + when Tok_Psl_Const => + Pkind := N_Const_Parameter; + when Tok_Psl_Boolean => + Pkind := N_Boolean_Parameter; + when Tok_Psl_Property => + Pkind := N_Property_Parameter; + when Tok_Psl_Sequence => + Pkind := N_Sequence_Parameter; + when others => + Error_Msg_Parse ("parameter type expected"); + end case; + + -- Formal parameters. + loop + -- precond: parameter_type or ',' + Scan; + Param := Create_Node_Loc (Pkind); + if Current_Token /= Tok_Identifier then + Error_Msg_Parse ("identifier for parameter expected"); + else + Set_Identifier (Param, Current_Identifier); + end if; + if Last_Param = Null_Node then + Set_Parameter_List (Res, Param); + else + Set_Chain (Last_Param, Param); + end if; + Last_Param := Param; + Scan; + exit when Current_Token /= Tok_Comma; + end loop; + exit when Current_Token = Tok_Right_Paren; + if Current_Token /= Tok_Semi_Colon then + Error_Msg_Parse ("';' expected between formal parameter"); + end if; + + end loop; + Scan; + end if; + + if Current_Token /= Tok_Is then + Error_Msg_Parse ("'is' expected after identifier"); + else + Scan; + end if; + case Kind is + when N_Property_Declaration => + Set_Property (Res, Parse_Psl_Property); + when N_Sequence_Declaration + | N_Endpoint_Declaration => + Set_Sequence (Res, Parse_Sequence); + when others => + raise Internal_Error; + end case; + return Res; + end Parse_Psl_Declaration; +end Parse_Psl; diff --git a/parse_psl.ads b/parse_psl.ads new file mode 100644 index 000000000..62869feb8 --- /dev/null +++ b/parse_psl.ads @@ -0,0 +1,26 @@ +-- VHDL PSL parser. +-- Copyright (C) 2009 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Types; use Types; +with Tokens; use Tokens; + +package Parse_Psl is + function Parse_Psl_Property return PSL_Node; + function Parse_Psl_Boolean return PSL_Node; + function Parse_Psl_Declaration (Tok : Token_Type) return PSL_Node; +end Parse_Psl; diff --git a/psl-errors.ads b/psl-errors.ads new file mode 100644 index 000000000..e99bb7de6 --- /dev/null +++ b/psl-errors.ads @@ -0,0 +1,3 @@ +with Errorout; + +package PSL.Errors renames Errorout; diff --git a/psl/psl-build.adb b/psl/psl-build.adb new file mode 100644 index 000000000..c3e47baa6 --- /dev/null +++ b/psl/psl-build.adb @@ -0,0 +1,1009 @@ +with GNAT.Table; +with Ada.Text_IO; use Ada.Text_IO; +with Types; use Types; +with PSL.Errors; use PSL.Errors; +with PSL.CSE; use PSL.CSE; +with PSL.QM; +with PSL.Disp_NFAs; use PSL.Disp_NFAs; +with PSL.Optimize; use PSL.Optimize; +with PSL.NFAs.Utils; +with PSL.Prints; +with PSL.NFAs; use PSL.NFAs; + +package body PSL.Build is + function Build_SERE_FA (N : Node) return NFA; + + + package Intersection is + function Build_Inter (L, R : NFA; Match_Len : Boolean) return NFA; + end Intersection; + + package body Intersection is + + type Stack_Entry_Id is new Natural; + No_Stack_Entry : constant Stack_Entry_Id := 0; + type Stack_Entry is record + L, R : NFA_State; + Res : NFA_State; + Next_Unhandled : Stack_Entry_Id; + end record; + + package Stackt is new GNAT.Table + (Table_Component_Type => Stack_Entry, + Table_Index_Type => Stack_Entry_Id, + Table_Low_Bound => 1, + Table_Initial => 128, + Table_Increment => 100); + + First_Unhandled : Stack_Entry_Id; + + procedure Init_Stack is + begin + Stackt.Init; + First_Unhandled := No_Stack_Entry; + end Init_Stack; + + function Not_Empty return Boolean is + begin + return First_Unhandled /= No_Stack_Entry; + end Not_Empty; + + procedure Pop_State (L, R : out NFA_State) is + begin + L := Stackt.Table (First_Unhandled).L; + R := Stackt.Table (First_Unhandled).R; + First_Unhandled := Stackt.Table (First_Unhandled).Next_Unhandled; + end Pop_State; + + function Get_State (N : NFA; L, R : NFA_State) return NFA_State + is + Res : NFA_State; + begin + for I in Stackt.First .. Stackt.Last loop + if Stackt.Table (I).L = L + and then Stackt.Table (I).R = R + then + return Stackt.Table (I).Res; + end if; + end loop; + Res := Add_State (N); + Stackt.Append ((L => L, R => R, Res => Res, + Next_Unhandled => First_Unhandled)); + First_Unhandled := Stackt.Last; + return Res; + end Get_State; + + function Build_Inter (L, R : NFA; Match_Len : Boolean) return NFA + is + Start_L, Start_R : NFA_State; + Final_L, Final_R : NFA_State; + S_L, S_R : NFA_State; + E_L, E_R : NFA_Edge; + Res : NFA; + Start : NFA_State; + Extra_L, Extra_R : NFA_Edge; + begin + Start_L := Get_Start_State (L); + Start_R := Get_Start_State (R); + Final_R := Get_Final_State (R); + Final_L := Get_Final_State (L); + + if False then + Disp_Body (L); + Disp_Body (R); + Put ("//start state: "); + Disp_State (Start_L); + Put (","); + Disp_State (Start_R); + New_Line; + end if; + + if Match_Len then + Extra_L := No_Edge; + Extra_R := No_Edge; + else + Extra_L := Add_Edge (Final_L, Final_L, True_Node); + Extra_R := Add_Edge (Final_R, Final_R, True_Node); + end if; + + Res := Create_NFA; + Init_Stack; + Start := Get_State (Res, Start_L, Start_R); + Set_Start_State (Res, Start); + + while Not_Empty loop + Pop_State (S_L, S_R); + + if False then + Put ("//poped state: "); + Disp_State (S_L); + Put (","); + Disp_State (S_R); + New_Line; + end if; + + E_L := Get_First_Src_Edge (S_L); + while E_L /= No_Edge loop + E_R := Get_First_Src_Edge (S_R); + while E_R /= No_Edge loop + if not (E_L = Extra_L and E_R = Extra_R) then + Add_Edge (Get_State (Res, S_L, S_R), + Get_State (Res, + Get_Edge_Dest (E_L), + Get_Edge_Dest (E_R)), + Build_Bool_And (Get_Edge_Expr (E_L), + Get_Edge_Expr (E_R))); + end if; + E_R := Get_Next_Src_Edge (E_R); + end loop; + E_L := Get_Next_Src_Edge (E_L); + end loop; + end loop; + Set_Final_State (Res, Get_State (Res, Final_L, Final_R)); + Remove_Unreachable_States (Res); + + if not Match_Len then + Remove_Edge (Extra_L); + Remove_Edge (Extra_R); + end if; + + -- FIXME: free L and R. + return Res; + end Build_Inter; + end Intersection; + + -- All edges from A are duplicated using B as a source. + -- Handle epsilon-edges. + procedure Duplicate_Src_Edges (N : NFA; A, B : NFA_State) + is + pragma Unreferenced (N); + E : NFA_Edge; + Expr : Node; + Dest : NFA_State; + begin + pragma Assert (A /= B); + E := Get_First_Src_Edge (A); + while E /= No_Edge loop + Expr := Get_Edge_Expr (E); + Dest := Get_Edge_Dest (E); + if Expr /= Null_Node then + Add_Edge (B, Dest, Expr); + end if; + E := Get_Next_Src_Edge (E); + end loop; + end Duplicate_Src_Edges; + + -- All edges to A are duplicated using B as a destination. + -- Handle epsilon-edges. + procedure Duplicate_Dest_Edges (N : NFA; A, B : NFA_State) + is + pragma Unreferenced (N); + E : NFA_Edge; + Expr : Node; + Src : NFA_State; + begin + pragma Assert (A /= B); + E := Get_First_Dest_Edge (A); + while E /= No_Edge loop + Expr := Get_Edge_Expr (E); + Src := Get_Edge_Src (E); + if Expr /= Null_Node then + Add_Edge (Src, B, Expr); + end if; + E := Get_Next_Dest_Edge (E); + end loop; + end Duplicate_Dest_Edges; + + procedure Remove_Epsilon_Edge (N : NFA; S, D : NFA_State) is + begin + if Get_First_Src_Edge (S) = No_Edge then + -- No edge from S. + -- Move edges to S to D. + Redest_Edges (S, D); + Remove_Unconnected_State (N, S); + if Get_Start_State (N) = S then + Set_Start_State (N, D); + end if; + elsif Get_First_Dest_Edge (D) = No_Edge then + -- No edge to D. + -- Move edges from D to S. + Resource_Edges (D, S); + Remove_Unconnected_State (N, D); + if Get_Final_State (N) = D then + Set_Final_State (N, S); + end if; + else + Duplicate_Dest_Edges (N, S, D); + Duplicate_Src_Edges (N, D, S); + Remove_Identical_Src_Edges (S); + end if; + end Remove_Epsilon_Edge; + + procedure Remove_Epsilon (N : NFA; + E : NFA_Edge) is + S : constant NFA_State := Get_Edge_Src (E); + D : constant NFA_State := Get_Edge_Dest (E); + begin + Remove_Edge (E); + + Remove_Epsilon_Edge (N, S, D); + end Remove_Epsilon; + + function Build_Concat (L, R : NFA) return NFA + is + Start_L, Start_R : NFA_State; + Final_L, Final_R : NFA_State; + Eps_L, Eps_R : Boolean; + E_L, E_R : NFA_Edge; + begin + Start_L := Get_Start_State (L); + Start_R := Get_Start_State (R); + Final_R := Get_Final_State (R); + Final_L := Get_Final_State (L); + Eps_L := Get_Epsilon_NFA (L); + Eps_R := Get_Epsilon_NFA (R); + + Merge_NFA (L, R); + + Set_Start_State (L, Start_L); + Set_Final_State (L, Final_R); + Set_Epsilon_NFA (L, False); + + if Eps_L then + E_L := Add_Edge (Start_L, Final_L, Null_Node); + end if; + + if Eps_R then + E_R := Add_Edge (Start_R, Final_R, Null_Node); + end if; + + Remove_Epsilon_Edge (L, Final_L, Start_R); + + if Eps_L then + Remove_Epsilon (L, E_L); + end if; + if Eps_R then + Remove_Epsilon (L, E_R); + end if; + + if (Start_L = Final_L or else Eps_L) + and then (Start_R = Final_R or else Eps_R) + then + Set_Epsilon_NFA (L, True); + end if; + + Remove_Identical_Src_Edges (Final_L); + Remove_Identical_Dest_Edges (Start_R); + + return L; + end Build_Concat; + + function Build_Or (L, R : NFA) return NFA + is + Start_L, Start_R : NFA_State; + Final_L, Final_R : NFA_State; + Eps : Boolean; + Start, Final : NFA_State; + E_S_L, E_S_R, E_L_F, E_R_F : NFA_Edge; + begin + Start_L := Get_Start_State (L); + Start_R := Get_Start_State (R); + Final_R := Get_Final_State (R); + Final_L := Get_Final_State (L); + Eps := Get_Epsilon_NFA (L) or Get_Epsilon_NFA (R); + + -- Optimize [*0] | R. + if Start_L = Final_L + and then Get_First_Src_Edge (Start_L) = No_Edge + then + if Start_R /= Final_R then + Set_Epsilon_NFA (R, True); + end if; + -- FIXME + -- delete_NFA (L); + return R; + end if; + + Merge_NFA (L, R); + + -- Use Thompson construction. + Start := Add_State (L); + Set_Start_State (L, Start); + E_S_L := Add_Edge (Start, Start_L, Null_Node); + E_S_R := Add_Edge (Start, Start_R, Null_Node); + + Final := Add_State (L); + Set_Final_State (L, Final); + E_L_F := Add_Edge (Final_L, Final, Null_Node); + E_R_F := Add_Edge (Final_R, Final, Null_Node); + + Set_Epsilon_NFA (L, Eps); + + Remove_Epsilon (L, E_S_L); + Remove_Epsilon (L, E_S_R); + Remove_Epsilon (L, E_L_F); + Remove_Epsilon (L, E_R_F); + + return L; + end Build_Or; + + function Build_Fusion (L, R : NFA) return NFA + is + Start_R : NFA_State; + Final_L, Final_R, S_L : NFA_State; + E_L : NFA_Edge; + E_R : NFA_Edge; + N_L, Expr : Node; + begin + Start_R := Get_Start_State (R); + Final_R := Get_Final_State (R); + Final_L := Get_Final_State (L); + + Merge_NFA (L, R); + + E_L := Get_First_Dest_Edge (Final_L); + while E_L /= No_Edge loop + S_L := Get_Edge_Src (E_L); + N_L := Get_Edge_Expr (E_L); + + E_R := Get_First_Src_Edge (Start_R); + while E_R /= No_Edge loop + Expr := Build_Bool_And (N_L, Get_Edge_Expr (E_R)); + Expr := PSL.QM.Reduce (Expr); + if Expr /= False_Node then + Add_Edge (S_L, Get_Edge_Dest (E_R), Expr); + end if; + E_R := Get_Next_Src_Edge (E_R); + end loop; + Remove_Identical_Src_Edges (S_L); + E_L := Get_Next_Dest_Edge (E_L); + end loop; + + Set_Final_State (L, Final_R); + + Set_Epsilon_NFA (L, False); + + if Get_First_Src_Edge (Final_L) = No_Edge then + Remove_State (L, Final_L); + end if; + if Get_First_Dest_Edge (Start_R) = No_Edge then + Remove_State (L, Start_R); + end if; + + return L; + end Build_Fusion; + + function Build_Star_Repeat (N : Node) return NFA is + Res : NFA; + Start, Final, S : NFA_State; + Seq : Node; + begin + Seq := Get_Sequence (N); + if Seq = Null_Node then + -- Epsilon. + Res := Create_NFA; + S := Add_State (Res); + Set_Start_State (Res, S); + Set_Final_State (Res, S); + return Res; + end if; + Res := Build_SERE_FA (Seq); + Start := Get_Start_State (Res); + Final := Get_Final_State (Res); + Redest_Edges (Final, Start); + Set_Final_State (Res, Start); + Remove_Unconnected_State (Res, Final); + Set_Epsilon_NFA (Res, False); + return Res; + end Build_Star_Repeat; + + function Build_Plus_Repeat (N : Node) return NFA is + Res : NFA; + Start, Final : NFA_State; + T : NFA_Edge; + begin + Res := Build_SERE_FA (Get_Sequence (N)); + Start := Get_Start_State (Res); + Final := Get_Final_State (Res); + T := Get_First_Dest_Edge (Final); + while T /= No_Edge loop + Add_Edge (Get_Edge_Src (T), Start, Get_Edge_Expr (T)); + T := Get_Next_Src_Edge (T); + end loop; + return Res; + end Build_Plus_Repeat; + + -- Association actual to formals, so that when a formal is referenced, the + -- actual can be used instead. + procedure Assoc_Instance (Decl : Node; Instance : Node) + is + Formal : Node; + Actual : Node; + begin + -- Temporary associates actuals to formals. + Formal := Get_Parameter_List (Decl); + Actual := Get_Association_Chain (Instance); + while Formal /= Null_Node loop + if Actual = Null_Node then + -- Not enough actual. + raise Internal_Error; + end if; + if Get_Actual (Formal) /= Null_Node then + -- Recursion + raise Internal_Error; + end if; + Set_Actual (Formal, Get_Actual (Actual)); + Formal := Get_Chain (Formal); + Actual := Get_Chain (Actual); + end loop; + if Actual /= Null_Node then + -- Too many actual. + raise Internal_Error; + end if; + end Assoc_Instance; + + procedure Unassoc_Instance (Decl : Node) + is + Formal : Node; + begin + -- Remove temporary association. + Formal := Get_Parameter_List (Decl); + while Formal /= Null_Node loop + Set_Actual (Formal, Null_Node); + Formal := Get_Chain (Formal); + end loop; + end Unassoc_Instance; + + function Build_SERE_FA (N : Node) return NFA + is + Res : NFA; + S1, S2 : NFA_State; + begin + case Get_Kind (N) is + when N_Booleans => + Res := Create_NFA; + S1 := Add_State (Res); + S2 := Add_State (Res); + Set_Start_State (Res, S1); + Set_Final_State (Res, S2); + if N /= False_Node then + Add_Edge (S1, S2, N); + end if; + return Res; + when N_Braced_SERE => + return Build_SERE_FA (Get_SERE (N)); + when N_Concat_SERE => + return Build_Concat (Build_SERE_FA (Get_Left (N)), + Build_SERE_FA (Get_Right (N))); + when N_Fusion_SERE => + return Build_Fusion (Build_SERE_FA (Get_Left (N)), + Build_SERE_FA (Get_Right (N))); + when N_Match_And_Seq => + return Intersection.Build_Inter (Build_SERE_FA (Get_Left (N)), + Build_SERE_FA (Get_Right (N)), + True); + when N_And_Seq => + return Intersection.Build_Inter (Build_SERE_FA (Get_Left (N)), + Build_SERE_FA (Get_Right (N)), + False); + when N_Or_Prop + | N_Or_Seq => + return Build_Or (Build_SERE_FA (Get_Left (N)), + Build_SERE_FA (Get_Right (N))); + when N_Star_Repeat_Seq => + return Build_Star_Repeat (N); + when N_Plus_Repeat_Seq => + return Build_Plus_Repeat (N); + when N_Sequence_Instance + | N_Endpoint_Instance => + declare + Decl : Node; + begin + Decl := Get_Declaration (N); + Assoc_Instance (Decl, N); + Res := Build_SERE_FA (Get_Sequence (Decl)); + Unassoc_Instance (Decl); + return Res; + end; + when N_Boolean_Parameter + | N_Sequence_Parameter => + declare + Actual : constant Node := Get_Actual (N); + begin + if Actual = Null_Node then + raise Internal_Error; + end if; + return Build_SERE_FA (Actual); + end; + when others => + Error_Kind ("build_sere_fa", N); + end case; + end Build_SERE_FA; + + function Count_Edges (S : NFA_State) return Natural + is + Res : Natural; + E : NFA_Edge; + begin + Res := 0; + E := Get_First_Src_Edge (S); + while E /= No_Edge loop + Res := Res + 1; + E := Get_Next_Src_Edge (E); + end loop; + return Res; + end Count_Edges; + + type Count_Vector is array (Natural range <>) of Natural; + + procedure Count_All_Edges (N : NFA; Res : out Count_Vector) + is + S : NFA_State; + begin + S := Get_First_State (N); + while S /= No_State loop + Res (Natural (Get_State_Label (S))) := Count_Edges (S); + S := Get_Next_State (S); + end loop; + end Count_All_Edges; + + pragma Unreferenced (Count_All_Edges); + + package Determinize is + -- Create a new NFA that reaches its final state only when N fails + -- (ie when the final state is not reached). + function Determinize (N : NFA) return NFA; + end Determinize; + + package body Determinize is + -- In all the comments N stands for the initial NFA (ie the NFA to + -- determinize). + + use Prints; + + Flag_Trace : constant Boolean := False; + Last_Label : Int32 := 0; + + -- The tree associates a set of states in N to *an* uniq set in the + -- result NFA. + -- + -- As the NFA is labelized, each node represent a state in N, and has + -- two branches: one for state is present and one for state is absent. + -- + -- The leaves contain the state in the result NFA. + -- + -- The leaves are chained to create a stack of state to handle. + -- + -- The root of the tree is node Start_Tree_Id and represent the start + -- state of N. + type Deter_Tree_Id is new Natural; + No_Tree_Id : constant Deter_Tree_Id := 0; + Start_Tree_Id : constant Deter_Tree_Id := 1; + + -- List of unhanded leaves. + Deter_Head : Deter_Tree_Id; + + type Deter_Tree_Id_Bool_Array is array (Boolean) of Deter_Tree_Id; + + -- Node in the tree. + type Deter_Tree_Entry is record + Parent : Deter_Tree_Id; + + -- For non-leaf: + Child : Deter_Tree_Id_Bool_Array; + + -- For leaf: + Link : Deter_Tree_Id; + State : NFA_State; + -- + value ? + end record; + + package Detert is new GNAT.Table + (Table_Component_Type => Deter_Tree_Entry, + Table_Index_Type => Deter_Tree_Id, + Table_Low_Bound => 1, + Table_Initial => 128, + Table_Increment => 100); + + type Bool_Vector is array (Natural range <>) of Boolean; + pragma Pack (Bool_Vector); + + -- Convert a set of states in N to a state in the result NFA. + -- The set is represented by a vector of boolean. An element of the + -- vector is true iff the corresponding state is present. + function Add_Vector (V : Bool_Vector; N : NFA) return NFA_State + is + E : Deter_Tree_Id; + Added : Boolean; + Res : NFA_State; + begin + E := Start_Tree_Id; + Added := False; + for I in V'Range loop + if Detert.Table (E).Child (V (I)) = No_Tree_Id then + Detert.Append ((Child => (No_Tree_Id, No_Tree_Id), + Parent => E, + Link => No_Tree_Id, + State => No_State)); + Detert.Table (E).Child (V (I)) := Detert.Last; + E := Detert.Last; + Added := True; + else + E := Detert.Table (E).Child (V (I)); + Added := False; + end if; + end loop; + if Added then + -- Create the new state. + Res := Add_State (N); + Detert.Table (E).State := Res; + + if Flag_Trace then + Set_State_Label (Res, Last_Label); + Put ("Result state" & Int32'Image (Last_Label) & " for"); + for I in V'Range loop + if V (I) then + Put (Natural'Image (I)); + end if; + end loop; + New_Line; + Last_Label := Last_Label + 1; + end if; + + -- Put it to the list of states to be handled. + Detert.Table (E).Link := Deter_Head; + Deter_Head := E; + + return Res; + else + return Detert.Table (E).State; + end if; + end Add_Vector; + + -- Return true iff the stack is empty (ie all the states have been + -- handled). + function Stack_Empty return Boolean is + begin + return Deter_Head = No_Tree_Id; + end Stack_Empty; + + -- Get an element from the stack. + -- Extract the state in the result NFA. + -- Rebuild the set of states in N (ie rebuild the vector of states). + procedure Stack_Pop (V : out Bool_Vector; S : out NFA_State) + is + L, P : Deter_Tree_Id; + begin + L := Deter_Head; + pragma Assert (L /= No_Tree_Id); + S := Detert.Table (L).State; + Deter_Head := Detert.Table (L).Link; + + for I in reverse V'Range loop + pragma Assert (L /= Start_Tree_Id); + P := Detert.Table (L).Parent; + if L = Detert.Table (P).Child (True) then + V (I) := True; + elsif L = Detert.Table (P).Child (False) then + V (I) := False; + else + raise Program_Error; + end if; + L := P; + end loop; + pragma Assert (L = Start_Tree_Id); + end Stack_Pop; + + type State_Vector is array (Natural range <>) of Natural; + type Expr_Vector is array (Natural range <>) of Node; + + procedure Build_Arcs (N : NFA; + State : NFA_State; + States : State_Vector; + Exprs : Expr_Vector; + Expr : Node; + V : Bool_Vector) + is + begin + if Expr = False_Node then + return; + end if; + + if States'Length = 0 then + declare + Reduced_Expr : constant Node := PSL.QM.Reduce (Expr); + --Reduced_Expr : constant Node := Expr; + S : NFA_State; + begin + if Reduced_Expr = False_Node then + return; + end if; + S := Add_Vector (V, N); + Add_Edge (State, S, Reduced_Expr); + if Flag_Trace then + Put (" Add edge"); + Put (Int32'Image (Get_State_Label (State))); + Put (" to"); + Put (Int32'Image (Get_State_Label (S))); + Put (", expr="); + Dump_Expr (Expr); + Put (", reduced="); + Dump_Expr (Reduced_Expr); + New_Line; + end if; + end; + else + declare + N_States : State_Vector renames + States (States'First + 1 .. States'Last); + N_V : Bool_Vector (V'Range) := V; + S : constant Natural := States (States'First); + E : constant Node := Exprs (S); + begin + N_V (S) := True; + if Expr = Null_Node then + Build_Arcs (N, State, N_States, Exprs, E, N_V); + Build_Arcs (N, State, N_States, Exprs, + Build_Bool_Not (E), V); + else + Build_Arcs (N, State, N_States, Exprs, + Build_Bool_And (E, Expr), N_V); + Build_Arcs (N, State, N_States, Exprs, + Build_Bool_And (Build_Bool_Not (E), Expr), V); + end if; + end; + end if; + end Build_Arcs; + + function Determinize_1 (N : NFA; Nbr_States : Natural) return NFA + is + Final : Natural; + V : Bool_Vector (0 .. Nbr_States - 1); + Exprs : Expr_Vector (0 .. Nbr_States - 1); + S : NFA_State; + E : NFA_Edge; + D : Natural; + Edge_Expr : Node; + Expr : Node; + Nbr_Dest : Natural; + States : State_Vector (0 .. Nbr_States - 1); + Res : NFA; + State : NFA_State; + begin + Final := Natural (Get_State_Label (Get_Final_State (N))); + + -- FIXME: handle epsilon or final = start -> create an empty NFA. + + -- Initialize the tree. + Res := Create_NFA; + Detert.Init; + Detert.Append ((Child => (No_Tree_Id, No_Tree_Id), + Parent => No_Tree_Id, + Link => No_Tree_Id, + State => No_State)); + pragma Assert (Detert.Last = Start_Tree_Id); + Deter_Head := No_Tree_Id; + + -- Put the initial state in the tree and in the stack. + -- FIXME: ok, we know that its label is 0. + V := (0 => True, others => False); + State := Add_Vector (V, Res); + Set_Start_State (Res, State); + + -- The failure state. As there is nothing to do with this + -- state, remove it from the stack. + V := (others => False); + State := Add_Vector (V, Res); + Set_Final_State (Res, State); + Stack_Pop (V, State); + + -- Iterate on states in the result NFA that haven't yet been handled. + while not Stack_Empty loop + Stack_Pop (V, State); + + if Flag_Trace then + Put_Line ("Handle result state" + & Int32'Image (Get_State_Label (State))); + end if; + + -- Build edges vector. + Exprs := (others => Null_Node); + Expr := Null_Node; + + S := Get_First_State (N); + Nbr_Dest := 0; + while S /= No_State loop + if V (Natural (Get_State_Label (S))) then + E := Get_First_Src_Edge (S); + while E /= No_Edge loop + D := Natural (Get_State_Label (Get_Edge_Dest (E))); + Edge_Expr := Get_Edge_Expr (E); + + if False and Flag_Trace then + Put_Line (" edge" & Int32'Image (Get_State_Label (S)) + & " to" & Natural'Image (D)); + end if; + + if D = Final then + Edge_Expr := Build_Bool_Not (Edge_Expr); + if Expr = Null_Node then + Expr := Edge_Expr; + else + Expr := Build_Bool_And (Expr, Edge_Expr); + end if; + else + if Exprs (D) = Null_Node then + Exprs (D) := Edge_Expr; + States (Nbr_Dest) := D; + Nbr_Dest := Nbr_Dest + 1; + else + Exprs (D) := Build_Bool_Or (Exprs (D), + Edge_Expr); + end if; + end if; + E := Get_Next_Src_Edge (E); + end loop; + end if; + S := Get_Next_State (S); + end loop; + + if Flag_Trace then + Put (" Final: expr="); + Print_Expr (Expr); + New_Line; + for I in 0 .. Nbr_Dest - 1 loop + Put (" Dest"); + Put (Natural'Image (States (I))); + Put (" expr="); + Print_Expr (Exprs (States (I))); + New_Line; + end loop; + end if; + + -- Build arcs. + if not (Nbr_Dest = 0 and Expr = Null_Node) then + Build_Arcs (Res, State, + States (0 .. Nbr_Dest - 1), Exprs, Expr, + Bool_Vector'(0 .. Nbr_States - 1 => False)); + end if; + end loop; + + --Remove_Unreachable_States (Res); + return Res; + end Determinize_1; + + function Determinize (N : NFA) return NFA + is + Nbr_States : Natural; + begin + Labelize_States (N, Nbr_States); + + if Flag_Trace then + Put_Line ("NFA to determinize:"); + Disp_NFA (N); + Last_Label := 0; + end if; + + return Determinize_1 (N, Nbr_States); + end Determinize; + end Determinize; + + function Build_Initial_Rep (N : NFA) return NFA + is + S : constant NFA_State := Get_Start_State (N); + begin + Add_Edge (S, S, True_Node); + return N; + end Build_Initial_Rep; + + procedure Build_Strong (N : NFA) + is + S : NFA_State; + Final : constant NFA_State := Get_Final_State (N); + begin + S := Get_First_State (N); + while S /= No_State loop + -- FIXME. + if S /= Final then + Add_Edge (S, Final, EOS_Node); + end if; + S := Get_Next_State (S); + end loop; + end Build_Strong; + + procedure Build_Abort (N : NFA; Expr : Node) + is + S : NFA_State; + E : NFA_Edge; + Not_Expr : Node; + begin + Not_Expr := Build_Bool_Not (Expr); + S := Get_First_State (N); + while S /= No_State loop + E := Get_First_Src_Edge (S); + while E /= No_Edge loop + Set_Edge_Expr (E, Build_Bool_And (Not_Expr, Get_Edge_Expr (E))); + E := Get_Next_Src_Edge (E); + end loop; + S := Get_Next_State (S); + end loop; + end Build_Abort; + + function Build_Property_FA (N : Node) return NFA + is + L, R : NFA; + begin + case Get_Kind (N) is + when N_Sequences + | N_Booleans => + -- Build A(S) or A(B) + R := Build_SERE_FA (N); + return Determinize.Determinize (R); + when N_Strong => + R := Build_Property_FA (Get_Property (N)); + Build_Strong (R); + return R; + when N_Imp_Seq => + -- R |=> P --> {R; TRUE} |-> P + L := Build_SERE_FA (Get_Sequence (N)); + R := Build_Property_FA (Get_Property (N)); + return Build_Concat (L, R); + when N_Overlap_Imp_Seq => + -- S |-> P is defined as Ac(S) : A(P) + L := Build_SERE_FA (Get_Sequence (N)); + R := Build_Property_FA (Get_Property (N)); + return Build_Fusion (L, R); + when N_Log_Imp_Prop => + -- B -> P --> {B} |-> P --> Ac(B) : A(P) + L := Build_SERE_FA (Get_Left (N)); + R := Build_Property_FA (Get_Right (N)); + return Build_Fusion (L, R); + when N_And_Prop => + -- P1 && P2 --> A(P1) | A(P2) + L := Build_Property_FA (Get_Left (N)); + R := Build_Property_FA (Get_Right (N)); + return Build_Or (L, R); + when N_Never => + R := Build_SERE_FA (Get_Property (N)); + return Build_Initial_Rep (R); + when N_Always => + R := Build_Property_FA (Get_Property (N)); + return Build_Initial_Rep (R); + when N_Abort => + R := Build_Property_FA (Get_Property (N)); + Build_Abort (R, Get_Boolean (N)); + return R; + when N_Property_Instance => + declare + Decl : Node; + begin + Decl := Get_Declaration (N); + Assoc_Instance (Decl, N); + R := Build_Property_FA (Get_Property (Decl)); + Unassoc_Instance (Decl); + return R; + end; + when others => + Error_Kind ("build_property_fa", N); + end case; + end Build_Property_FA; + + function Build_FA (N : Node) return NFA + is + use PSL.NFAs.Utils; + Res : NFA; + begin + Res := Build_Property_FA (N); + if Optimize_Final then + pragma Debug (Check_NFA (Res)); + + Remove_Unreachable_States (Res); + Remove_Simple_Prefix (Res); + Merge_Identical_States (Res); + Merge_Edges (Res); + end if; + -- Clear the QM table. + PSL.QM.Reset; + return Res; + end Build_FA; +end PSL.Build; diff --git a/psl/psl-build.ads b/psl/psl-build.ads new file mode 100644 index 000000000..d0ca26a39 --- /dev/null +++ b/psl/psl-build.ads @@ -0,0 +1,7 @@ +with PSL.Nodes; use PSL.Nodes; + +package PSL.Build is + Optimize_Final : Boolean := True; + + function Build_FA (N : Node) return NFA; +end PSL.Build; diff --git a/psl/psl-cse.adb b/psl/psl-cse.adb new file mode 100644 index 000000000..5d6f3df13 --- /dev/null +++ b/psl/psl-cse.adb @@ -0,0 +1,201 @@ +with Ada.Text_IO; +with PSL.Prints; +with Types; use Types; + +package body PSL.CSE is + function Is_X_And_Not_X (A, B : Node) return Boolean is + begin + return (Get_Kind (A) = N_Not_Bool + and then Get_Boolean (A) = B) + or else (Get_Kind (B) = N_Not_Bool + and then Get_Boolean (B) = A); + end Is_X_And_Not_X; + + type Hash_Table_Type is array (Uns32 range 0 .. 128) of Node; + Hash_Table : Hash_Table_Type := (others => Null_Node); + + function Compute_Hash (L, R : Node; Op : Uns32) return Uns32 + is + begin + return Shift_Left (Get_Hash (L), 12) + xor Shift_Left (Get_Hash (R), 2) + xor Op; + end Compute_Hash; + + function Compute_Hash (L: Node; Op : Uns32) return Uns32 + is + begin + return Shift_Left (Get_Hash (L), 2) xor Op; + end Compute_Hash; + + procedure Dump_Hash_Table (Level : Natural := 0) + is + use Ada.Text_IO; + Cnt : Natural; + Total : Natural; + N : Node; + begin + Total := 0; + for I in Hash_Table_Type'Range loop + Cnt := 0; + N := Hash_Table (I); + while N /= Null_Node loop + Cnt := Cnt + 1; + N := Get_Hash_Link (N); + end loop; + Put_Line ("Hash_table(" & Uns32'Image (I) + & "):" & Natural'Image (Cnt)); + Total := Total + Cnt; + if Level > 0 then + Cnt := 0; + N := Hash_Table (I); + while N /= Null_Node loop + Put (Uns32'Image (Get_Hash (N))); + if Level > 1 then + Put (": "); + PSL.Prints.Dump_Expr (N); + New_Line; + end if; + Cnt := Cnt + 1; + N := Get_Hash_Link (N); + end loop; + if Level = 1 and then Cnt > 0 then + New_Line; + end if; + end if; + end loop; + Put_Line ("Total:" & Natural'Image (Total)); + end Dump_Hash_Table; + + function Build_Bool_And (L, R : Node) return Node + is + R1 : Node; + Res : Node; + Hash : Uns32; + Head, H : Node; + begin + if L = True_Node then + return R; + elsif R = True_Node then + return L; + elsif L = False_Node or else R = False_Node then + return False_Node; + elsif L = R then + return L; + elsif Is_X_And_Not_X (L, R) then + return False_Node; + end if; + + -- More simple optimizations. + if Get_Kind (R) = N_And_Bool then + R1 := Get_Left (R); + if L = R1 then + return R; + elsif Is_X_And_Not_X (L, R1) then + return False_Node; + end if; + end if; + + Hash := Compute_Hash (L, R, 2); + Head := Hash_Table (Hash mod Hash_Table'Length); + H := Head; + while H /= Null_Node loop + if Get_Hash (H) = Hash + and then Get_Kind (H) = N_And_Bool + and then Get_Left (H) = L + and then Get_Right (H) = R + then + return H; + end if; + H := Get_Hash_Link (H); + end loop; + + Res := Create_Node (N_And_Bool); + Set_Left (Res, L); + Set_Right (Res, R); + Set_Hash_Link (Res, Head); + Set_Hash (Res, Hash); + Hash_Table (Hash mod Hash_Table'Length) := Res; + return Res; + end Build_Bool_And; + + function Build_Bool_Or (L, R : Node) return Node + is + Res : Node; + Hash : Uns32; + Head, H : Node; + begin + if L = True_Node then + return L; + elsif R = True_Node then + return R; + elsif L = False_Node then + return R; + elsif R = False_Node then + return L; + elsif L = R then + return L; + elsif Is_X_And_Not_X (L, R) then + return True_Node; + end if; + + Hash := Compute_Hash (L, R, 3); + Head := Hash_Table (Hash mod Hash_Table'Length); + H := Head; + while H /= Null_Node loop + if Get_Hash (H) = Hash + and then Get_Kind (H) = N_Or_Bool + and then Get_Left (H) = L + and then Get_Right (H) = R + then + return H; + end if; + H := Get_Hash_Link (H); + end loop; + + Res := Create_Node (N_Or_Bool); + Set_Left (Res, L); + Set_Right (Res, R); + Set_Hash_Link (Res, Head); + Set_Hash (Res, Hash); + Hash_Table (Hash mod Hash_Table'Length) := Res; + return Res; + end Build_Bool_Or; + + function Build_Bool_Not (N : Node) return Node is + Res : Node; + Hash : Uns32; + Head : Node; + H : Node; + begin + if N = True_Node then + return False_Node; + elsif N = False_Node then + return True_Node; + elsif Get_Kind (N) = N_Not_Bool then + return Get_Boolean (N); + end if; + + -- Find in hash table. + Hash := Compute_Hash (N, 1); + Head := Hash_Table (Hash mod Hash_Table'Length); + H := Head; + while H /= Null_Node loop + if Get_Hash (H) = Hash + and then Get_Kind (H) = N_Not_Bool + and then Get_Boolean (H) = N + then + return H; + end if; + H := Get_Hash_Link (H); + end loop; + + Res := Create_Node (N_Not_Bool); + Set_Boolean (Res, N); + Set_Hash_Link (Res, Head); + Set_Hash (Res, Hash); + Hash_Table (Hash mod Hash_Table'Length) := Res; + + return Res; + end Build_Bool_Not; +end PSL.CSE; diff --git a/psl/psl-cse.ads b/psl/psl-cse.ads new file mode 100644 index 000000000..e40b0eeb2 --- /dev/null +++ b/psl/psl-cse.ads @@ -0,0 +1,10 @@ +with PSL.Nodes; use PSL.Nodes; + +package PSL.CSE is + -- Build boolean expressions while trying to make the node uniq. + function Build_Bool_And (L, R : Node) return Node; + function Build_Bool_Or (L, R : Node) return Node; + function Build_Bool_Not (N : Node) return Node; + + procedure Dump_Hash_Table (Level : Natural := 0); +end PSL.CSE; diff --git a/psl/psl-disp_nfas.adb b/psl/psl-disp_nfas.adb new file mode 100644 index 000000000..c8f1532b9 --- /dev/null +++ b/psl/psl-disp_nfas.adb @@ -0,0 +1,111 @@ +with Ada.Text_IO; use Ada.Text_IO; +with Types; use Types; +with PSL.Prints; use PSL.Prints; + +package body PSL.Disp_NFAs is + procedure Disp_State (S : NFA_State) is + Str : constant String := Int32'Image (Get_State_Label (S)); + begin + Put (Str (2 .. Str'Last)); + end Disp_State; + + procedure Disp_Head (Name : String) is + begin + Put ("digraph "); + Put (Name); + Put_Line (" {"); + Put_Line (" rankdir=LR;"); + end Disp_Head; + + procedure Disp_Tail is + begin + Put_Line ("}"); + end Disp_Tail; + + procedure Disp_Body (N : NFA) is + S, F : NFA_State; + T : NFA_Edge; + begin + S := Get_Start_State (N); + F := Get_Final_State (N); + if S /= No_State then + if S = F then + Put (" node [shape = doublecircle, style = bold];"); + else + Put (" node [shape = circle, style = bold];"); + end if; + Put (" /* Start: */ "); + Disp_State (S); + Put_Line (";"); + end if; + if F /= No_State and then F /= S then + Put (" node [shape = doublecircle, style = solid];"); + Put (" /* Final: */ "); + Disp_State (F); + Put_Line (";"); + end if; + Put_Line (" node [shape = circle, style = solid];"); + + if Get_Epsilon_NFA (N) then + Put (" "); + Disp_State (Get_Start_State (N)); + Put (" -> "); + Disp_State (Get_Final_State (N)); + Put_Line (" [ label = ""*""]"); + end if; + + S := Get_First_State (N); + while S /= No_State loop + T := Get_First_Src_Edge (S); + if T = No_Edge then + if Get_First_Dest_Edge (S) = No_Edge then + Put (" "); + Disp_State (S); + Put_Line (";"); + end if; + else + loop + Put (" "); + Disp_State (S); + Put (" -> "); + Disp_State (Get_Edge_Dest (T)); + Put (" [ label = """); + Print_Expr (Get_Edge_Expr (T)); + Put ('"'); + if True then + Put (" /* Node ="); + Put (Node'Image (Get_Edge_Expr (T))); + Put (" */"); + end if; + if True then + Put (" /* Edge ="); + Put (NFA_Edge'Image (T)); + Put (" */"); + end if; + Put_Line (" ];"); + + T := Get_Next_Src_Edge (T); + exit when T = No_Edge; + end loop; + end if; + S := Get_Next_State (S); + end loop; + end Disp_Body; + + procedure Disp_NFA (N : NFA; Name : String := "nfa") is + begin + Disp_Head (Name); + Disp_Body (N); + Disp_Tail; + end Disp_NFA; + + procedure Debug_NFA (N : NFA) is + begin + Labelize_States_Debug (N); + Disp_Head ("nfa"); + Disp_Body (N); + Disp_Tail; + end Debug_NFA; + + pragma Unreferenced (Debug_NFA); +end PSL.Disp_NFAs; diff --git a/psl/psl-disp_nfas.ads b/psl/psl-disp_nfas.ads new file mode 100644 index 000000000..901eed72f --- /dev/null +++ b/psl/psl-disp_nfas.ads @@ -0,0 +1,12 @@ +with PSL.NFAs; use PSL.NFAs; +with PSL.Nodes; use PSL.Nodes; + +package PSL.Disp_NFAs is + procedure Disp_Head (Name : String); + procedure Disp_Tail; + procedure Disp_Body (N : NFA); + + procedure Disp_State (S : NFA_State); + + procedure Disp_NFA (N : NFA; Name : String := "nfa"); +end PSL.Disp_NFAs; diff --git a/psl/psl-dump_tree.adb b/psl/psl-dump_tree.adb new file mode 100644 index 000000000..db636dbb0 --- /dev/null +++ b/psl/psl-dump_tree.adb @@ -0,0 +1,867 @@ +-- This is in fact -*- Ada -*- +with Ada.Text_IO; use Ada.Text_IO; +with Types; use Types; +with Name_Table; +with PSL.Errors; + +package body PSL.Dump_Tree is + + procedure Disp_Indent (Indent : Natural) is + begin + Put (String'(1 .. 2 * Indent => ' ')); + end Disp_Indent; + + Hex_Digits : constant array (Integer range 0 .. 15) of Character + := "0123456789abcdef"; + + procedure Disp_Uns32 (Val : Uns32) + is + Res : String (1 .. 8); + V : Uns32 := Val; + begin + for I in reverse Res'Range loop + Res (I) := Hex_Digits (Integer (V mod 16)); + V := V / 16; + end loop; + Put (Res); + end Disp_Uns32; + + procedure Disp_Int32 (Val : Int32) + is + Res : String (1 .. 8); + V : Int32 := Val; + begin + for I in reverse Res'Range loop + Res (I) := Hex_Digits (Integer (V mod 16)); + V := V / 16; + end loop; + Put (Res); + end Disp_Int32; + + procedure Disp_HDL_Node (Val : HDL_Node) + is + begin + if Dump_Hdl_Node /= null then + Dump_Hdl_Node.all (Val); + else + Disp_Int32 (Val); + end if; + end Disp_HDL_Node; + + procedure Disp_Node_Number (N : Node) is + begin + Put ('['); + Disp_Int32 (Int32 (N)); + Put (']'); + end Disp_Node_Number; + + procedure Disp_NFA (Val : NFA) is + begin + Disp_Int32 (Int32 (Val)); + end Disp_NFA; + + procedure Disp_Header (Msg : String; Indent : Natural) is + begin + Disp_Indent (Indent); + Put (Msg); + Put (": "); + end Disp_Header; + + procedure Disp_Identifier (N : Node) is + begin + Put (Name_Table.Image (Get_Identifier (N))); + New_Line; + end Disp_Identifier; + + procedure Disp_Label (N : Node) is + begin + Put (Name_Table.Image (Get_Label (N))); + New_Line; + end Disp_Label; + + procedure Disp_Boolean (Val : Boolean) is + begin + if Val then + Put ("true"); + else + Put ("false"); + end if; + end Disp_Boolean; + + procedure Disp_PSL_Presence_Kind (Pres : PSL_Presence_Kind) is + begin + case Pres is + when Present_Pos => + Put ('+'); + when Present_Neg => + Put ('-'); + when Present_Unknown => + Put ('?'); + end case; + end Disp_PSL_Presence_Kind; + + procedure Disp_Location (Loc : Location_Type) is + begin + Put (PSL.Errors.Get_Location_Str (Loc)); + end Disp_Location; + +-- procedure Disp_String_Id (N : Node) is +-- begin +-- Put ('"'); +-- Put (Str_Table.Image (Get_String_Id (N))); +-- Put ('"'); +-- New_Line; +-- end Disp_String_Id; + + -- Subprograms. + procedure Disp_Tree (N : Node; Indent : Natural; Full : boolean := False) is + begin + Disp_Indent (Indent); + Disp_Node_Number (N); + Put (": "); + if N = Null_Node then + Put_Line ("*NULL*"); + return; + end if; + Put_Line (Nkind'Image (Get_Kind (N))); + Disp_Indent (Indent); + Put ("loc: "); + Disp_Location (Get_Location (N)); + New_Line; + case Get_Kind (N) is + when N_Error => + if not Full then + return; + end if; + null; + when N_Vmode => + Disp_Header ("Identifier", Indent + 1); + Disp_Identifier (N); + if not Full then + return; + end if; + Disp_Header ("Instance", Indent + 1); + New_Line; + Disp_Tree (Get_Instance (N), Indent + 1, Full); + Disp_Header ("Item_Chain", Indent + 1); + New_Line; + Disp_Tree (Get_Item_Chain (N), Indent + 1, Full); + Disp_Tree (Get_Chain (N), Indent, Full); + null; + when N_Vunit => + Disp_Header ("Identifier", Indent + 1); + Disp_Identifier (N); + if not Full then + return; + end if; + Disp_Header ("Instance", Indent + 1); + New_Line; + Disp_Tree (Get_Instance (N), Indent + 1, Full); + Disp_Header ("Item_Chain", Indent + 1); + New_Line; + Disp_Tree (Get_Item_Chain (N), Indent + 1, Full); + Disp_Tree (Get_Chain (N), Indent, Full); + null; + when N_Vprop => + Disp_Header ("Identifier", Indent + 1); + Disp_Identifier (N); + if not Full then + return; + end if; + Disp_Header ("Instance", Indent + 1); + New_Line; + Disp_Tree (Get_Instance (N), Indent + 1, Full); + Disp_Header ("Item_Chain", Indent + 1); + New_Line; + Disp_Tree (Get_Item_Chain (N), Indent + 1, Full); + Disp_Tree (Get_Chain (N), Indent, Full); + null; + when N_Hdl_Mod_Name => + Disp_Header ("Identifier", Indent + 1); + Disp_Identifier (N); + if not Full then + return; + end if; + Disp_Header ("Prefix", Indent + 1); + New_Line; + Disp_Tree (Get_Prefix (N), Indent + 1, Full); + null; + when N_Assert_Directive => + Disp_Header ("Label", Indent + 1); + Disp_Label (N); + if not Full then + return; + end if; + Disp_Header ("String", Indent + 1); + New_Line; + Disp_Tree (Get_String (N), Indent + 1, Full); + Disp_Header ("Property", Indent + 1); + New_Line; + Disp_Tree (Get_Property (N), Indent + 1, Full); + Disp_Header ("NFA", Indent + 1); + Disp_NFA (Get_NFA (N)); + New_Line; + Disp_Tree (Get_Chain (N), Indent, Full); + null; + when N_Property_Declaration => + Disp_Header ("Identifier", Indent + 1); + Disp_Identifier (N); + if not Full then + return; + end if; + Disp_Header ("Property", Indent + 1); + New_Line; + Disp_Tree (Get_Property (N), Indent + 1, Full); + Disp_Header ("Global_Clock", Indent + 1); + New_Line; + Disp_Tree (Get_Global_Clock (N), Indent + 1, Full); + Disp_Header ("Parameter_List", Indent + 1); + New_Line; + Disp_Tree (Get_Parameter_List (N), Indent + 1, Full); + Disp_Tree (Get_Chain (N), Indent, Full); + null; + when N_Sequence_Declaration => + Disp_Header ("Identifier", Indent + 1); + Disp_Identifier (N); + if not Full then + return; + end if; + Disp_Header ("Parameter_List", Indent + 1); + New_Line; + Disp_Tree (Get_Parameter_List (N), Indent + 1, Full); + Disp_Header ("Sequence", Indent + 1); + New_Line; + Disp_Tree (Get_Sequence (N), Indent + 1, Full); + Disp_Tree (Get_Chain (N), Indent, Full); + null; + when N_Endpoint_Declaration => + Disp_Header ("Identifier", Indent + 1); + Disp_Identifier (N); + if not Full then + return; + end if; + Disp_Header ("Parameter_List", Indent + 1); + New_Line; + Disp_Tree (Get_Parameter_List (N), Indent + 1, Full); + Disp_Header ("Sequence", Indent + 1); + New_Line; + Disp_Tree (Get_Sequence (N), Indent + 1, Full); + Disp_Tree (Get_Chain (N), Indent, Full); + null; + when N_Const_Parameter => + Disp_Header ("Identifier", Indent + 1); + Disp_Identifier (N); + if not Full then + return; + end if; + Disp_Header ("Actual", Indent + 1); + New_Line; + Disp_Tree (Get_Actual (N), Indent + 1, Full); + Disp_Tree (Get_Chain (N), Indent, Full); + null; + when N_Boolean_Parameter => + Disp_Header ("Identifier", Indent + 1); + Disp_Identifier (N); + if not Full then + return; + end if; + Disp_Header ("Actual", Indent + 1); + New_Line; + Disp_Tree (Get_Actual (N), Indent + 1, Full); + Disp_Tree (Get_Chain (N), Indent, Full); + null; + when N_Property_Parameter => + Disp_Header ("Identifier", Indent + 1); + Disp_Identifier (N); + if not Full then + return; + end if; + Disp_Header ("Actual", Indent + 1); + New_Line; + Disp_Tree (Get_Actual (N), Indent + 1, Full); + Disp_Tree (Get_Chain (N), Indent, Full); + null; + when N_Sequence_Parameter => + Disp_Header ("Identifier", Indent + 1); + Disp_Identifier (N); + if not Full then + return; + end if; + Disp_Header ("Actual", Indent + 1); + New_Line; + Disp_Tree (Get_Actual (N), Indent + 1, Full); + Disp_Tree (Get_Chain (N), Indent, Full); + null; + when N_Sequence_Instance => + if not Full then + return; + end if; + Disp_Header ("Declaration", Indent + 1); + New_Line; + Disp_Tree (Get_Declaration (N), Indent + 1, False); + Disp_Header ("Association_Chain", Indent + 1); + New_Line; + Disp_Tree (Get_Association_Chain (N), Indent + 1, Full); + null; + when N_Endpoint_Instance => + if not Full then + return; + end if; + Disp_Header ("Declaration", Indent + 1); + New_Line; + Disp_Tree (Get_Declaration (N), Indent + 1, False); + Disp_Header ("Association_Chain", Indent + 1); + New_Line; + Disp_Tree (Get_Association_Chain (N), Indent + 1, Full); + null; + when N_Property_Instance => + if not Full then + return; + end if; + Disp_Header ("Declaration", Indent + 1); + New_Line; + Disp_Tree (Get_Declaration (N), Indent + 1, False); + Disp_Header ("Association_Chain", Indent + 1); + New_Line; + Disp_Tree (Get_Association_Chain (N), Indent + 1, Full); + null; + when N_Actual => + if not Full then + return; + end if; + Disp_Header ("Actual", Indent + 1); + New_Line; + Disp_Tree (Get_Actual (N), Indent + 1, Full); + Disp_Header ("Formal", Indent + 1); + New_Line; + Disp_Tree (Get_Formal (N), Indent + 1, Full); + Disp_Tree (Get_Chain (N), Indent, Full); + null; + when N_Clock_Event => + if not Full then + return; + end if; + Disp_Header ("Property", Indent + 1); + New_Line; + Disp_Tree (Get_Property (N), Indent + 1, Full); + Disp_Header ("Boolean", Indent + 1); + New_Line; + Disp_Tree (Get_Boolean (N), Indent + 1, Full); + null; + when N_Always => + if not Full then + return; + end if; + Disp_Header ("Property", Indent + 1); + New_Line; + Disp_Tree (Get_Property (N), Indent + 1, Full); + null; + when N_Never => + if not Full then + return; + end if; + Disp_Header ("Property", Indent + 1); + New_Line; + Disp_Tree (Get_Property (N), Indent + 1, Full); + null; + when N_Eventually => + if not Full then + return; + end if; + Disp_Header ("Property", Indent + 1); + New_Line; + Disp_Tree (Get_Property (N), Indent + 1, Full); + null; + when N_Strong => + if not Full then + return; + end if; + Disp_Header ("Property", Indent + 1); + New_Line; + Disp_Tree (Get_Property (N), Indent + 1, Full); + null; + when N_Imp_Seq => + if not Full then + return; + end if; + Disp_Header ("Property", Indent + 1); + New_Line; + Disp_Tree (Get_Property (N), Indent + 1, Full); + Disp_Header ("Sequence", Indent + 1); + New_Line; + Disp_Tree (Get_Sequence (N), Indent + 1, Full); + null; + when N_Overlap_Imp_Seq => + if not Full then + return; + end if; + Disp_Header ("Property", Indent + 1); + New_Line; + Disp_Tree (Get_Property (N), Indent + 1, Full); + Disp_Header ("Sequence", Indent + 1); + New_Line; + Disp_Tree (Get_Sequence (N), Indent + 1, Full); + null; + when N_Log_Imp_Prop => + if not Full then + return; + end if; + Disp_Header ("Left", Indent + 1); + New_Line; + Disp_Tree (Get_Left (N), Indent + 1, Full); + Disp_Header ("Right", Indent + 1); + New_Line; + Disp_Tree (Get_Right (N), Indent + 1, Full); + null; + when N_Next => + if not Full then + return; + end if; + Disp_Header ("Property", Indent + 1); + New_Line; + Disp_Tree (Get_Property (N), Indent + 1, Full); + Disp_Header ("Strong_Flag", Indent + 1); + Disp_Boolean (Get_Strong_Flag (N)); + New_Line; + Disp_Header ("Number", Indent + 1); + New_Line; + Disp_Tree (Get_Number (N), Indent + 1, Full); + null; + when N_Next_A => + if not Full then + return; + end if; + Disp_Header ("Property", Indent + 1); + New_Line; + Disp_Tree (Get_Property (N), Indent + 1, Full); + Disp_Header ("Strong_Flag", Indent + 1); + Disp_Boolean (Get_Strong_Flag (N)); + New_Line; + Disp_Header ("Low_Bound", Indent + 1); + New_Line; + Disp_Tree (Get_Low_Bound (N), Indent + 1, Full); + Disp_Header ("High_Bound", Indent + 1); + New_Line; + Disp_Tree (Get_High_Bound (N), Indent + 1, Full); + null; + when N_Next_E => + if not Full then + return; + end if; + Disp_Header ("Property", Indent + 1); + New_Line; + Disp_Tree (Get_Property (N), Indent + 1, Full); + Disp_Header ("Strong_Flag", Indent + 1); + Disp_Boolean (Get_Strong_Flag (N)); + New_Line; + Disp_Header ("Low_Bound", Indent + 1); + New_Line; + Disp_Tree (Get_Low_Bound (N), Indent + 1, Full); + Disp_Header ("High_Bound", Indent + 1); + New_Line; + Disp_Tree (Get_High_Bound (N), Indent + 1, Full); + null; + when N_Next_Event => + if not Full then + return; + end if; + Disp_Header ("Property", Indent + 1); + New_Line; + Disp_Tree (Get_Property (N), Indent + 1, Full); + Disp_Header ("Boolean", Indent + 1); + New_Line; + Disp_Tree (Get_Boolean (N), Indent + 1, Full); + Disp_Header ("Strong_Flag", Indent + 1); + Disp_Boolean (Get_Strong_Flag (N)); + New_Line; + Disp_Header ("Number", Indent + 1); + New_Line; + Disp_Tree (Get_Number (N), Indent + 1, Full); + null; + when N_Next_Event_A => + if not Full then + return; + end if; + Disp_Header ("Property", Indent + 1); + New_Line; + Disp_Tree (Get_Property (N), Indent + 1, Full); + Disp_Header ("Boolean", Indent + 1); + New_Line; + Disp_Tree (Get_Boolean (N), Indent + 1, Full); + Disp_Header ("Strong_Flag", Indent + 1); + Disp_Boolean (Get_Strong_Flag (N)); + New_Line; + Disp_Header ("Low_Bound", Indent + 1); + New_Line; + Disp_Tree (Get_Low_Bound (N), Indent + 1, Full); + Disp_Header ("High_Bound", Indent + 1); + New_Line; + Disp_Tree (Get_High_Bound (N), Indent + 1, Full); + null; + when N_Next_Event_E => + if not Full then + return; + end if; + Disp_Header ("Property", Indent + 1); + New_Line; + Disp_Tree (Get_Property (N), Indent + 1, Full); + Disp_Header ("Boolean", Indent + 1); + New_Line; + Disp_Tree (Get_Boolean (N), Indent + 1, Full); + Disp_Header ("Strong_Flag", Indent + 1); + Disp_Boolean (Get_Strong_Flag (N)); + New_Line; + Disp_Header ("Low_Bound", Indent + 1); + New_Line; + Disp_Tree (Get_Low_Bound (N), Indent + 1, Full); + Disp_Header ("High_Bound", Indent + 1); + New_Line; + Disp_Tree (Get_High_Bound (N), Indent + 1, Full); + null; + when N_Abort => + if not Full then + return; + end if; + Disp_Header ("Property", Indent + 1); + New_Line; + Disp_Tree (Get_Property (N), Indent + 1, Full); + Disp_Header ("Boolean", Indent + 1); + New_Line; + Disp_Tree (Get_Boolean (N), Indent + 1, Full); + null; + when N_Until => + if not Full then + return; + end if; + Disp_Header ("Strong_Flag", Indent + 1); + Disp_Boolean (Get_Strong_Flag (N)); + New_Line; + Disp_Header ("Left", Indent + 1); + New_Line; + Disp_Tree (Get_Left (N), Indent + 1, Full); + Disp_Header ("Right", Indent + 1); + New_Line; + Disp_Tree (Get_Right (N), Indent + 1, Full); + Disp_Header ("Inclusive_Flag", Indent + 1); + Disp_Boolean (Get_Inclusive_Flag (N)); + New_Line; + null; + when N_Before => + if not Full then + return; + end if; + Disp_Header ("Strong_Flag", Indent + 1); + Disp_Boolean (Get_Strong_Flag (N)); + New_Line; + Disp_Header ("Left", Indent + 1); + New_Line; + Disp_Tree (Get_Left (N), Indent + 1, Full); + Disp_Header ("Right", Indent + 1); + New_Line; + Disp_Tree (Get_Right (N), Indent + 1, Full); + Disp_Header ("Inclusive_Flag", Indent + 1); + Disp_Boolean (Get_Inclusive_Flag (N)); + New_Line; + null; + when N_Or_Prop => + if not Full then + return; + end if; + Disp_Header ("Left", Indent + 1); + New_Line; + Disp_Tree (Get_Left (N), Indent + 1, Full); + Disp_Header ("Right", Indent + 1); + New_Line; + Disp_Tree (Get_Right (N), Indent + 1, Full); + null; + when N_And_Prop => + if not Full then + return; + end if; + Disp_Header ("Left", Indent + 1); + New_Line; + Disp_Tree (Get_Left (N), Indent + 1, Full); + Disp_Header ("Right", Indent + 1); + New_Line; + Disp_Tree (Get_Right (N), Indent + 1, Full); + null; + when N_Braced_SERE => + if not Full then + return; + end if; + Disp_Header ("SERE", Indent + 1); + New_Line; + Disp_Tree (Get_SERE (N), Indent + 1, Full); + null; + when N_Concat_SERE => + if not Full then + return; + end if; + Disp_Header ("Left", Indent + 1); + New_Line; + Disp_Tree (Get_Left (N), Indent + 1, Full); + Disp_Header ("Right", Indent + 1); + New_Line; + Disp_Tree (Get_Right (N), Indent + 1, Full); + null; + when N_Fusion_SERE => + if not Full then + return; + end if; + Disp_Header ("Left", Indent + 1); + New_Line; + Disp_Tree (Get_Left (N), Indent + 1, Full); + Disp_Header ("Right", Indent + 1); + New_Line; + Disp_Tree (Get_Right (N), Indent + 1, Full); + null; + when N_Within_SERE => + if not Full then + return; + end if; + Disp_Header ("Left", Indent + 1); + New_Line; + Disp_Tree (Get_Left (N), Indent + 1, Full); + Disp_Header ("Right", Indent + 1); + New_Line; + Disp_Tree (Get_Right (N), Indent + 1, Full); + null; + when N_Match_And_Seq => + if not Full then + return; + end if; + Disp_Header ("Left", Indent + 1); + New_Line; + Disp_Tree (Get_Left (N), Indent + 1, Full); + Disp_Header ("Right", Indent + 1); + New_Line; + Disp_Tree (Get_Right (N), Indent + 1, Full); + null; + when N_And_Seq => + if not Full then + return; + end if; + Disp_Header ("Left", Indent + 1); + New_Line; + Disp_Tree (Get_Left (N), Indent + 1, Full); + Disp_Header ("Right", Indent + 1); + New_Line; + Disp_Tree (Get_Right (N), Indent + 1, Full); + null; + when N_Or_Seq => + if not Full then + return; + end if; + Disp_Header ("Left", Indent + 1); + New_Line; + Disp_Tree (Get_Left (N), Indent + 1, Full); + Disp_Header ("Right", Indent + 1); + New_Line; + Disp_Tree (Get_Right (N), Indent + 1, Full); + null; + when N_Star_Repeat_Seq => + if not Full then + return; + end if; + Disp_Header ("Sequence", Indent + 1); + New_Line; + Disp_Tree (Get_Sequence (N), Indent + 1, Full); + Disp_Header ("Low_Bound", Indent + 1); + New_Line; + Disp_Tree (Get_Low_Bound (N), Indent + 1, Full); + Disp_Header ("High_Bound", Indent + 1); + New_Line; + Disp_Tree (Get_High_Bound (N), Indent + 1, Full); + null; + when N_Goto_Repeat_Seq => + if not Full then + return; + end if; + Disp_Header ("Sequence", Indent + 1); + New_Line; + Disp_Tree (Get_Sequence (N), Indent + 1, Full); + Disp_Header ("Low_Bound", Indent + 1); + New_Line; + Disp_Tree (Get_Low_Bound (N), Indent + 1, Full); + Disp_Header ("High_Bound", Indent + 1); + New_Line; + Disp_Tree (Get_High_Bound (N), Indent + 1, Full); + null; + when N_Plus_Repeat_Seq => + if not Full then + return; + end if; + Disp_Header ("Sequence", Indent + 1); + New_Line; + Disp_Tree (Get_Sequence (N), Indent + 1, Full); + null; + when N_Equal_Repeat_Seq => + if not Full then + return; + end if; + Disp_Header ("Sequence", Indent + 1); + New_Line; + Disp_Tree (Get_Sequence (N), Indent + 1, Full); + Disp_Header ("Low_Bound", Indent + 1); + New_Line; + Disp_Tree (Get_Low_Bound (N), Indent + 1, Full); + Disp_Header ("High_Bound", Indent + 1); + New_Line; + Disp_Tree (Get_High_Bound (N), Indent + 1, Full); + null; + when N_Not_Bool => + if not Full then + return; + end if; + Disp_Header ("Boolean", Indent + 1); + New_Line; + Disp_Tree (Get_Boolean (N), Indent + 1, Full); + Disp_Header ("Presence", Indent + 1); + Disp_PSL_Presence_Kind (Get_Presence (N)); + New_Line; + Disp_Header ("Hash", Indent + 1); + Disp_Uns32 (Get_Hash (N)); + New_Line; + Disp_Header ("Hash_Link", Indent + 1); + New_Line; + Disp_Tree (Get_Hash_Link (N), Indent + 1, Full); + null; + when N_And_Bool => + if not Full then + return; + end if; + Disp_Header ("Left", Indent + 1); + New_Line; + Disp_Tree (Get_Left (N), Indent + 1, Full); + Disp_Header ("Right", Indent + 1); + New_Line; + Disp_Tree (Get_Right (N), Indent + 1, Full); + Disp_Header ("Presence", Indent + 1); + Disp_PSL_Presence_Kind (Get_Presence (N)); + New_Line; + Disp_Header ("Hash", Indent + 1); + Disp_Uns32 (Get_Hash (N)); + New_Line; + Disp_Header ("Hash_Link", Indent + 1); + New_Line; + Disp_Tree (Get_Hash_Link (N), Indent + 1, Full); + null; + when N_Or_Bool => + if not Full then + return; + end if; + Disp_Header ("Left", Indent + 1); + New_Line; + Disp_Tree (Get_Left (N), Indent + 1, Full); + Disp_Header ("Right", Indent + 1); + New_Line; + Disp_Tree (Get_Right (N), Indent + 1, Full); + Disp_Header ("Presence", Indent + 1); + Disp_PSL_Presence_Kind (Get_Presence (N)); + New_Line; + Disp_Header ("Hash", Indent + 1); + Disp_Uns32 (Get_Hash (N)); + New_Line; + Disp_Header ("Hash_Link", Indent + 1); + New_Line; + Disp_Tree (Get_Hash_Link (N), Indent + 1, Full); + null; + when N_Imp_Bool => + if not Full then + return; + end if; + Disp_Header ("Left", Indent + 1); + New_Line; + Disp_Tree (Get_Left (N), Indent + 1, Full); + Disp_Header ("Right", Indent + 1); + New_Line; + Disp_Tree (Get_Right (N), Indent + 1, Full); + Disp_Header ("Presence", Indent + 1); + Disp_PSL_Presence_Kind (Get_Presence (N)); + New_Line; + Disp_Header ("Hash", Indent + 1); + Disp_Uns32 (Get_Hash (N)); + New_Line; + Disp_Header ("Hash_Link", Indent + 1); + New_Line; + Disp_Tree (Get_Hash_Link (N), Indent + 1, Full); + null; + when N_HDL_Expr => + if not Full then + return; + end if; + Disp_Header ("Presence", Indent + 1); + Disp_PSL_Presence_Kind (Get_Presence (N)); + New_Line; + Disp_Header ("HDL_Node", Indent + 1); + Disp_HDL_Node (Get_HDL_Node (N)); + New_Line; + Disp_Header ("HDL_Index", Indent + 1); + Disp_Int32 (Get_HDL_Index (N)); + New_Line; + Disp_Header ("Hash", Indent + 1); + Disp_Uns32 (Get_Hash (N)); + New_Line; + Disp_Header ("Hash_Link", Indent + 1); + New_Line; + Disp_Tree (Get_Hash_Link (N), Indent + 1, Full); + null; + when N_False => + if not Full then + return; + end if; + null; + when N_True => + if not Full then + return; + end if; + null; + when N_EOS => + if not Full then + return; + end if; + Disp_Header ("HDL_Index", Indent + 1); + Disp_Int32 (Get_HDL_Index (N)); + New_Line; + Disp_Header ("Hash", Indent + 1); + Disp_Uns32 (Get_Hash (N)); + New_Line; + Disp_Header ("Hash_Link", Indent + 1); + New_Line; + Disp_Tree (Get_Hash_Link (N), Indent + 1, Full); + null; + when N_Name => + Disp_Header ("Identifier", Indent + 1); + Disp_Identifier (N); + if not Full then + return; + end if; + Disp_Header ("Decl", Indent + 1); + New_Line; + Disp_Tree (Get_Decl (N), Indent + 1, Full); + null; + when N_Name_Decl => + Disp_Header ("Identifier", Indent + 1); + Disp_Identifier (N); + if not Full then + return; + end if; + Disp_Tree (Get_Chain (N), Indent, Full); + null; + when N_Number => + if not Full then + return; + end if; + Disp_Header ("Value", Indent + 1); + Disp_Uns32 (Get_Value (N)); + New_Line; + null; + end case; + end Disp_Tree; + + procedure Dump_Tree (N : Node; Full : Boolean := False) is + begin + Disp_Tree (N, 0, Full); + end Dump_Tree; + +end PSL.Dump_Tree; diff --git a/psl/psl-dump_tree.ads b/psl/psl-dump_tree.ads new file mode 100644 index 000000000..f8b2eb3ab --- /dev/null +++ b/psl/psl-dump_tree.ads @@ -0,0 +1,9 @@ +with PSL.Nodes; use PSL.Nodes; + +package PSL.Dump_Tree is + procedure Dump_Tree (N : Node; Full : Boolean := False); + + -- Procedure to dump an HDL node. + type Dump_Hdl_Node_Acc is access procedure (N : HDL_Node); + Dump_Hdl_Node : Dump_Hdl_Node_Acc := null; +end PSL.Dump_Tree; diff --git a/psl/psl-hash.adb b/psl/psl-hash.adb new file mode 100644 index 000000000..62744b336 --- /dev/null +++ b/psl/psl-hash.adb @@ -0,0 +1,60 @@ +with GNAT.Table; + +package body PSL.Hash is + + type Index_Type is new Natural; + No_Index : constant Index_Type := 0; + + type Cell_Record is record + Res : Node; + Next : Index_Type; + end record; + + Hash_Size : constant Index_Type := 127; + + package Cells is new GNAT.Table + (Table_Component_Type => Cell_Record, + Table_Index_Type => Index_Type, + Table_Low_Bound => 0, + Table_Initial => 256, + Table_Increment => 100); + + procedure Init is + begin + Cells.Set_Last (Hash_Size - 1); + for I in 0 .. Hash_Size - 1 loop + Cells.Table (I) := (Res => Null_Node, Next => No_Index); + end loop; + end Init; + + function Get_PSL_Node (Hdl : Int32) return Node is + Idx : Index_Type := Index_Type (Hdl mod Int32 (Hash_Size)); + N_Idx : Index_Type; + Res : Node; + begin + -- In the primary table. + Res := Cells.Table (Idx).Res; + if Res = Null_Node then + Res := Create_Node (N_HDL_Expr); + Set_HDL_Node (Res, Hdl); + Cells.Table (Idx).Res := Res; + return Res; + end if; + + loop + if Get_HDL_Node (Res) = Hdl then + return Res; + end if; + -- Look in collisions chain + N_Idx := Cells.Table (Idx).Next; + exit when N_Idx = No_Index; + Idx := N_Idx; + Res := Cells.Table (Idx).Res; + end loop; + Res := Create_Node (N_HDL_Expr); + Set_HDL_Node (Res, Hdl); + Cells.Append ((Res => Res, Next => No_Index)); + Cells.Table (Idx).Next := Cells.Last; + return Res; + end Get_PSL_Node; +end PSL.Hash; diff --git a/psl/psl-hash.ads b/psl/psl-hash.ads new file mode 100644 index 000000000..d1a60c971 --- /dev/null +++ b/psl/psl-hash.ads @@ -0,0 +1,11 @@ +with Types; use Types; +with PSL.Nodes; use PSL.Nodes; + +package PSL.Hash is + -- Initialize the package. + procedure Init; + + -- Get the PSL node for node HDL. + -- Only one PSL node is created for an HDL node. + function Get_PSL_Node (Hdl : Int32) return Node; +end PSL.Hash; diff --git a/psl/psl-nfas-utils.adb b/psl/psl-nfas-utils.adb new file mode 100644 index 000000000..06601850d --- /dev/null +++ b/psl/psl-nfas-utils.adb @@ -0,0 +1,330 @@ +with PSL.Errors; use PSL.Errors; + +package body PSL.NFAs.Utils is + generic + with function Get_First_Edge (S : NFA_State) return NFA_Edge; + with function Get_Next_Edge (E : NFA_Edge) return NFA_Edge; + with procedure Set_First_Edge (S : NFA_State; E : NFA_Edge); + with procedure Set_Next_Edge (E : NFA_Edge; N_E : NFA_Edge); + with function Get_Edge_State (E : NFA_Edge) return NFA_State; + package Sort_Edges is + procedure Sort_Edges (S : NFA_State); + procedure Sort_Edges (N : NFA); + end Sort_Edges; + + package body Sort_Edges is + -- Use merge sort to sort a list of edges. + -- The first edge is START and the list has LEN edges. + -- RES is the head of the sorted list. + -- NEXT_EDGE is the LEN + 1 edge (not sorted). + procedure Edges_Merge_Sort (Start : NFA_Edge; + Len : Natural; + Res : out NFA_Edge; + Next_Edge : out NFA_Edge) + is + function Lt (L, R : NFA_Edge) return Boolean + is + L_Expr : constant Node := Get_Edge_Expr (L); + R_Expr : constant Node := Get_Edge_Expr (R); + begin + return L_Expr < R_Expr + or else (L_Expr = R_Expr + and then Get_Edge_State (L) < Get_Edge_State (R)); + end Lt; + + pragma Inline (Lt); + + Half : constant Natural := Len / 2; + Left_Start, Right_Start : NFA_Edge; + Left_Next, Right_Next : NFA_Edge; + L, R : NFA_Edge; + Last, E : NFA_Edge; + begin + -- With less than 2 elements, the sort is trivial. + if Len < 2 then + if Len = 0 then + Next_Edge := Start; + else + Next_Edge := Get_Next_Edge (Start); + end if; + Res := Start; + return; + end if; + + -- Sort each half. + Edges_Merge_Sort (Start, Half, Left_Start, Left_Next); + Edges_Merge_Sort (Left_Next, Len - Half, Right_Start, Right_Next); + + -- Merge. + L := Left_Start; + R := Right_Start; + Last := No_Edge; + loop + -- Take from left iff: + -- * it is not empty + -- * right is empty or else (left < right) + if L /= Left_Next and then (R = Right_Next or else Lt (L, R)) then + E := L; + L := Get_Next_Edge (L); + + -- Take from right if right is not empty. + elsif R /= Right_Next then + E := R; + R := Get_Next_Edge (R); + + -- Both left are right are empty. + else + exit; + end if; + + if Last = No_Edge then + Res := E; + else + Set_Next_Edge (Last, E); + end if; + Last := E; + end loop; + -- Let the link clean. + Next_Edge := Right_Next; + Set_Next_Edge (Last, Next_Edge); + end Edges_Merge_Sort; + + procedure Sort_Edges (S : NFA_State) + is + Nbr_Edges : Natural; + First_E, E, Res : NFA_Edge; + begin + -- Count number of edges. + Nbr_Edges := 0; + First_E := Get_First_Edge (S); + E := First_E; + while E /= No_Edge loop + Nbr_Edges := Nbr_Edges + 1; + E := Get_Next_Edge (E); + end loop; + + -- Sort edges by expression. + Edges_Merge_Sort (First_E, Nbr_Edges, Res, E); + pragma Assert (E = No_Edge); + Set_First_Edge (S, Res); + + end Sort_Edges; + + procedure Sort_Edges (N : NFA) + is + S : NFA_State; + begin + -- Iterate on states. + S := Get_First_State (N); + while S /= No_State loop + Sort_Edges (S); + S := Get_Next_State (S); + end loop; + end Sort_Edges; + end Sort_Edges; + + package Sort_Src_Edges_Pkg is new + Sort_Edges (Get_First_Edge => Get_First_Src_Edge, + Get_Next_Edge => Get_Next_Src_Edge, + Set_First_Edge => Set_First_Src_Edge, + Set_Next_Edge => Set_Next_Src_Edge, + Get_Edge_State => Get_Edge_Dest); + + procedure Sort_Src_Edges (S : NFA_State) renames + Sort_Src_Edges_Pkg.Sort_Edges; + procedure Sort_Src_Edges (N : NFA) renames + Sort_Src_Edges_Pkg.Sort_Edges; + + package Sort_Dest_Edges_Pkg is new + Sort_Edges (Get_First_Edge => Get_First_Dest_Edge, + Get_Next_Edge => Get_Next_Dest_Edge, + Set_First_Edge => Set_First_Dest_Edge, + Set_Next_Edge => Set_Next_Dest_Edge, + Get_Edge_State => Get_Edge_Src); + + procedure Sort_Dest_Edges (S : NFA_State) renames + Sort_Dest_Edges_Pkg.Sort_Edges; + procedure Sort_Dest_Edges (N : NFA) renames + Sort_Dest_Edges_Pkg.Sort_Edges; + + generic + with function Get_First_Edge_Reverse (S : NFA_State) return NFA_Edge; + with function Get_First_Edge (S : NFA_State) return NFA_Edge; + with procedure Set_First_Edge (S : NFA_State; E : NFA_Edge); + with function Get_Next_Edge (E : NFA_Edge) return NFA_Edge; + with procedure Set_Next_Edge (E : NFA_Edge; E1 : NFA_Edge); + with procedure Set_Edge_State (E : NFA_Edge; S : NFA_State); + procedure Merge_State (N : NFA; S : NFA_State; S1 : NFA_State); + + procedure Merge_State (N : NFA; S : NFA_State; S1 : NFA_State) + is + E, First_E, Next_E : NFA_Edge; + begin + pragma Assert (S /= S1); + + -- Discard outgoing edges of S1. + loop + E := Get_First_Edge_Reverse (S1); + exit when E = No_Edge; + Remove_Edge (E); + end loop; + + -- Prepend incoming edges of S1 to S. + First_E := Get_First_Edge (S); + E := Get_First_Edge (S1); + while E /= No_Edge loop + Next_E := Get_Next_Edge (E); + Set_Next_Edge (E, First_E); + Set_Edge_State (E, S); + First_E := E; + E := Next_E; + end loop; + Set_First_Edge (S, First_E); + Set_First_Edge (S1, No_Edge); + + Remove_State (N, S1); + end Merge_State; + + procedure Merge_State_Dest_1 is new Merge_State + (Get_First_Edge_Reverse => Get_First_Src_Edge, + Get_First_Edge => Get_First_Dest_Edge, + Set_First_Edge => Set_First_Dest_Edge, + Get_Next_Edge => Get_Next_Dest_Edge, + Set_Next_Edge => Set_Next_Dest_Edge, + Set_Edge_State => Set_Edge_Dest); + + procedure Merge_State_Dest (N : NFA; S : NFA_State; S1 : NFA_State) renames + Merge_State_Dest_1; + + procedure Merge_State_Src_1 is new Merge_State + (Get_First_Edge_Reverse => Get_First_Dest_Edge, + Get_First_Edge => Get_First_Src_Edge, + Set_First_Edge => Set_First_Src_Edge, + Get_Next_Edge => Get_Next_Src_Edge, + Set_Next_Edge => Set_Next_Src_Edge, + Set_Edge_State => Set_Edge_Src); + + procedure Merge_State_Src (N : NFA; S : NFA_State; S1 : NFA_State) renames + Merge_State_Src_1; + + procedure Sort_Outgoing_Edges (N : NFA; Nbr_States : Natural) + is + Last_State : constant NFA_State := NFA_State (Nbr_States) - 1; + type Edge_Array is array (0 .. Last_State) of NFA_Edge; + Edges : Edge_Array := (others => No_Edge); + S, D : NFA_State; + E, Next_E : NFA_Edge; + First_Edge, Last_Edge : NFA_Edge; + begin + -- Iterate on states. + S := Get_First_State (N); + while S /= No_State loop + + -- Create an array of edges + E := Get_First_Dest_Edge (S); + while E /= No_Edge loop + Next_E := Get_Next_Dest_Edge (E); + D := Get_Edge_Dest (E); + if Edges (D) /= No_Edge then + -- TODO: merge edges. + raise Program_Error; + end if; + Edges (D) := E; + E := Next_E; + end loop; + + -- Rebuild the edge list (sorted by destination). + Last_Edge := No_Edge; + First_Edge := No_Edge; + for I in Edge_Array'Range loop + E := Edges (I); + if E /= No_Edge then + Edges (I) := No_Edge; + if First_Edge = No_Edge then + First_Edge := E; + else + Set_Next_Dest_Edge (Last_Edge, E); + end if; + Last_Edge := E; + end if; + end loop; + Set_First_Dest_Edge (S, First_Edge); + S := Get_Next_State (S); + end loop; + end Sort_Outgoing_Edges; + pragma Unreferenced (Sort_Outgoing_Edges); + + generic + with function Get_First_Edge (S : NFA_State) return NFA_Edge; + with function Get_Next_Edge (E : NFA_Edge) return NFA_Edge; + with function Get_State_Reverse (E : NFA_Edge) return NFA_State; + with function Get_First_Edge_Reverse (S : NFA_State) return NFA_Edge; + with function Get_Next_Edge_Reverse (E : NFA_Edge) return NFA_Edge; + procedure Check_Edges_Gen (N : NFA); + + procedure Check_Edges_Gen (N : NFA) + is + S : NFA_State; + E : NFA_Edge; + R_S : NFA_State; + R_E : NFA_Edge; + begin + S := Get_First_State (N); + while S /= No_State loop + E := Get_First_Edge (S); + while E /= No_Edge loop + R_S := Get_State_Reverse (E); + R_E := Get_First_Edge_Reverse (R_S); + while R_E /= No_Edge and then R_E /= E loop + R_E := Get_Next_Edge_Reverse (R_E); + end loop; + if R_E /= E then + raise Program_Error; + end if; + E := Get_Next_Edge (E); + end loop; + S := Get_Next_State (S); + end loop; + end Check_Edges_Gen; + + procedure Check_Edges_Src is new Check_Edges_Gen + (Get_First_Edge => Get_First_Src_Edge, + Get_Next_Edge => Get_Next_Src_Edge, + Get_State_Reverse => Get_Edge_Dest, + Get_First_Edge_Reverse => Get_First_Dest_Edge, + Get_Next_Edge_Reverse => Get_Next_Dest_Edge); + + procedure Check_Edges_Dest is new Check_Edges_Gen + (Get_First_Edge => Get_First_Dest_Edge, + Get_Next_Edge => Get_Next_Dest_Edge, + Get_State_Reverse => Get_Edge_Src, + Get_First_Edge_Reverse => Get_First_Src_Edge, + Get_Next_Edge_Reverse => Get_Next_Src_Edge); + + procedure Check_NFA (N : NFA) is + begin + Check_Edges_Src (N); + Check_Edges_Dest (N); + end Check_NFA; + + function Has_EOS (N : Node) return Boolean is + begin + case Get_Kind (N) is + when N_EOS => + return True; + when N_False + | N_True + | N_HDL_Expr => + return False; + when N_Not_Bool => + return Has_EOS (Get_Boolean (N)); + when N_And_Bool + | N_Or_Bool + | N_Imp_Bool => + return Has_EOS (Get_Left (N)) or else Has_EOS (Get_Right (N)); + when others => + Error_Kind ("Has_EOS", N); + end case; + end Has_EOS; + +end PSL.NFAs.Utils; diff --git a/psl/psl-nfas-utils.ads b/psl/psl-nfas-utils.ads new file mode 100644 index 000000000..bdbc0d013 --- /dev/null +++ b/psl/psl-nfas-utils.ads @@ -0,0 +1,21 @@ +package PSL.NFAs.Utils is + -- Sort outgoing edges by expression. + procedure Sort_Src_Edges (S : NFA_State); + procedure Sort_Src_Edges (N : NFA); + + procedure Sort_Dest_Edges (S : NFA_State); + procedure Sort_Dest_Edges (N : NFA); + + -- Move incoming edges of S1 to S, remove S1 and its outgoing edges. + procedure Merge_State_Dest (N : NFA; S : NFA_State; S1 : NFA_State); + + procedure Merge_State_Src (N : NFA; S : NFA_State; S1 : NFA_State); + + -- Return True if N or a child of N is EOS. + -- N must be a boolean expression. + function Has_EOS (N : Node) return Boolean; + + -- Raise Program_Error if N is not internally coherent. + procedure Check_NFA (N : NFA); +end PSL.NFAs.Utils; + diff --git a/psl/psl-nfas.adb b/psl/psl-nfas.adb new file mode 100644 index 000000000..da4866e53 --- /dev/null +++ b/psl/psl-nfas.adb @@ -0,0 +1,529 @@ +with GNAT.Table; + +package body PSL.NFAs is + -- Record that describes an NFA. + type NFA_Node is record + -- Chain of States. + First_State : NFA_State; + Last_State : NFA_State; + + -- Start and final state. + Start : NFA_State; + Final : NFA_State; + + -- If true there is an epsilon transition between the start and + -- the final state. + Epsilon : Boolean; + end record; + + -- Record that describe a node. + type NFA_State_Node is record + -- States may be numbered. + Label : Int32; + + -- Edges. + First_Src : NFA_Edge; + First_Dst : NFA_Edge; + + -- State links. + Next_State : NFA_State; + Prev_State : NFA_State; + + -- User fields. + User_Link : NFA_State; + User_Flag : Boolean; + end record; + + -- Record that describe an edge between SRC and DEST. + type NFA_Edge_Node is record + Dest : NFA_State; + Src : NFA_State; + Expr : Node; + + -- Links. + Next_Src : NFA_Edge; + Next_Dst : NFA_Edge; + end record; + + -- Table of NFA. + package Nfat is new GNAT.Table + (Table_Component_Type => NFA_Node, + Table_Index_Type => NFA, + Table_Low_Bound => 1, + Table_Initial => 128, + Table_Increment => 100); + + -- List of free nodes. + Free_Nfas : NFA := No_NFA; + + -- Table of States. + package Statet is new GNAT.Table + (Table_Component_Type => NFA_State_Node, + Table_Index_Type => NFA_State, + Table_Low_Bound => 1, + Table_Initial => 128, + Table_Increment => 100); + + -- List of free states. + Free_States : NFA_State := No_State; + + -- Table of edges. + package Transt is new GNAT.Table + (Table_Component_Type => NFA_Edge_Node, + Table_Index_Type => NFA_Edge, + Table_Low_Bound => 1, + Table_Initial => 128, + Table_Increment => 100); + + -- List of free edges. + Free_Edges : NFA_Edge := No_Edge; + + function Get_First_State (N : NFA) return NFA_State is + begin + return Nfat.Table (N).First_State; + end Get_First_State; + + function Get_Last_State (N : NFA) return NFA_State is + begin + return Nfat.Table (N).Last_State; + end Get_Last_State; + + procedure Set_First_State (N : NFA; S : NFA_State) is + begin + Nfat.Table (N).First_State := S; + end Set_First_State; + + procedure Set_Last_State (N : NFA; S : NFA_State) is + begin + Nfat.Table (N).Last_State := S; + end Set_Last_State; + + function Get_Next_State (S : NFA_State) return NFA_State is + begin + return Statet.Table (S).Next_State; + end Get_Next_State; + + procedure Set_Next_State (S : NFA_State; N : NFA_State) is + begin + Statet.Table (S).Next_State := N; + end Set_Next_State; + + function Get_Prev_State (S : NFA_State) return NFA_State is + begin + return Statet.Table (S).Prev_State; + end Get_Prev_State; + + procedure Set_Prev_State (S : NFA_State; N : NFA_State) is + begin + Statet.Table (S).Prev_State := N; + end Set_Prev_State; + + function Get_State_Label (S : NFA_State) return Int32 is + begin + return Statet.Table (S).Label; + end Get_State_Label; + + procedure Set_State_Label (S : NFA_State; Label : Int32) is + begin + Statet.Table (S).Label := Label; + end Set_State_Label; + + function Get_Epsilon_NFA (N : NFA) return Boolean is + begin + return Nfat.Table (N).Epsilon; + end Get_Epsilon_NFA; + + procedure Set_Epsilon_NFA (N : NFA; Flag : Boolean) is + begin + Nfat.Table (N).Epsilon := Flag; + end Set_Epsilon_NFA; + + function Add_State (N : NFA) return NFA_State is + Res : NFA_State; + Last : NFA_State; + begin + -- Get a new state. + if Free_States = No_State then + Statet.Increment_Last; + Res := Statet.Last; + else + Res := Free_States; + Free_States := Get_Next_State (Res); + end if; + + -- Put it in N. + Last := Get_Last_State (N); + Statet.Table (Res) := (Label => 0, + First_Src => No_Edge, + First_Dst => No_Edge, + Next_State => No_State, + Prev_State => Last, + User_Link => No_State, + User_Flag => False); + if Last = No_State then + Nfat.Table (N).First_State := Res; + else + Statet.Table (Last).Next_State := Res; + end if; + Nfat.Table (N).Last_State := Res; + return Res; + end Add_State; + + procedure Delete_Detached_State (S : NFA_State) is + begin + -- Put it in front of the free_states list. + Set_Next_State (S, Free_States); + Free_States := S; + end Delete_Detached_State; + + function Create_NFA return NFA + is + Res : NFA; + begin + -- Allocate a node. + if Free_Nfas = No_NFA then + Nfat.Increment_Last; + Res := Nfat.Last; + else + Res := Free_Nfas; + Free_Nfas := NFA (Get_First_State (Res)); + end if; + + -- Fill it. + Nfat.Table (Res) := (First_State => No_State, + Last_State => No_State, + Start => No_State, Final => No_State, + Epsilon => False); + return Res; + end Create_NFA; + + procedure Set_First_Src_Edge (N : NFA_State; T : NFA_Edge) is + begin + Statet.Table (N).First_Src := T; + end Set_First_Src_Edge; + + function Get_First_Src_Edge (N : NFA_State) return NFA_Edge is + begin + return Statet.Table (N).First_Src; + end Get_First_Src_Edge; + + procedure Set_First_Dest_Edge (N : NFA_State; T : NFA_Edge) is + begin + Statet.Table (N).First_Dst := T; + end Set_First_Dest_Edge; + + function Get_First_Dest_Edge (N : NFA_State) return NFA_Edge is + begin + return Statet.Table (N).First_Dst; + end Get_First_Dest_Edge; + + function Get_State_Flag (S : NFA_State) return Boolean is + begin + return Statet.Table (S).User_Flag; + end Get_State_Flag; + + procedure Set_State_Flag (S : NFA_State; Val : Boolean) is + begin + Statet.Table (S).User_Flag := Val; + end Set_State_Flag; + + function Get_State_User_Link (S : NFA_State) return NFA_State is + begin + return Statet.Table (S).User_Link; + end Get_State_User_Link; + + procedure Set_State_User_Link (S : NFA_State; Link : NFA_State) is + begin + Statet.Table (S).User_Link := Link; + end Set_State_User_Link; + + function Add_Edge (Src : NFA_State; Dest : NFA_State; Expr : Node) + return NFA_Edge + is + Res : NFA_Edge; + begin + -- Allocate a note. + if Free_Edges /= No_Edge then + Res := Free_Edges; + Free_Edges := Get_Next_Dest_Edge (Res); + else + Transt.Increment_Last; + Res := Transt.Last; + end if; + + -- Initialize it. + Transt.Table (Res) := (Dest => Dest, + Src => Src, + Expr => Expr, + Next_Src => Get_First_Src_Edge (Src), + Next_Dst => Get_First_Dest_Edge (Dest)); + Set_First_Src_Edge (Src, Res); + Set_First_Dest_Edge (Dest, Res); + return Res; + end Add_Edge; + + procedure Add_Edge (Src : NFA_State; Dest : NFA_State; Expr : Node) is + Res : NFA_Edge; + pragma Unreferenced (Res); + begin + Res := Add_Edge (Src, Dest, Expr); + end Add_Edge; + + procedure Delete_Empty_NFA (N : NFA) is + begin + pragma Assert (Get_First_State (N) = No_State); + pragma Assert (Get_Last_State (N) = No_State); + + -- Put it in front of the free_nfas list. + Set_First_State (N, NFA_State (Free_Nfas)); + Free_Nfas := N; + end Delete_Empty_NFA; + + function Get_Start_State (N : NFA) return NFA_State is + begin + return Nfat.Table (N).Start; + end Get_Start_State; + + procedure Set_Start_State (N : NFA; S : NFA_State) is + begin + Nfat.Table (N).Start := S; + end Set_Start_State; + + function Get_Final_State (N : NFA) return NFA_State is + begin + return Nfat.Table (N).Final; + end Get_Final_State; + + procedure Set_Final_State (N : NFA; S : NFA_State) is + begin + Nfat.Table (N).Final := S; + end Set_Final_State; + + function Get_Next_Src_Edge (N : NFA_Edge) return NFA_Edge is + begin + return Transt.Table (N).Next_Src; + end Get_Next_Src_Edge; + + procedure Set_Next_Src_Edge (E : NFA_Edge; N_E : NFA_Edge) is + begin + Transt.Table (E).Next_Src := N_E; + end Set_Next_Src_Edge; + + function Get_Next_Dest_Edge (N : NFA_Edge) return NFA_Edge is + begin + return Transt.Table (N).Next_Dst; + end Get_Next_Dest_Edge; + + procedure Set_Next_Dest_Edge (E : NFA_Edge; N_E : NFA_Edge) is + begin + Transt.Table (E).Next_Dst := N_E; + end Set_Next_Dest_Edge; + + function Get_Edge_Dest (E : NFA_Edge) return NFA_State is + begin + return Transt.Table (E).Dest; + end Get_Edge_Dest; + + procedure Set_Edge_Dest (E : NFA_Edge; D : NFA_State) is + begin + Transt.Table (E).Dest := D; + end Set_Edge_Dest; + + function Get_Edge_Src (E : NFA_Edge) return NFA_State is + begin + return Transt.Table (E).Src; + end Get_Edge_Src; + + procedure Set_Edge_Src (E : NFA_Edge; D : NFA_State) is + begin + Transt.Table (E).Src := D; + end Set_Edge_Src; + + function Get_Edge_Expr (E : NFA_Edge) return Node is + begin + return Transt.Table (E).Expr; + end Get_Edge_Expr; + + procedure Set_Edge_Expr (E : NFA_Edge; N : Node) is + begin + Transt.Table (E).Expr := N; + end Set_Edge_Expr; + + procedure Remove_Unconnected_State (N : NFA; S : NFA_State) is + N_S : constant NFA_State := Get_Next_State (S); + P_S : constant NFA_State := Get_Prev_State (S); + begin + pragma Assert (Get_First_Src_Edge (S) = No_Edge); + pragma Assert (Get_First_Dest_Edge (S) = No_Edge); + + if P_S = No_State then + Set_First_State (N, N_S); + else + Set_Next_State (P_S, N_S); + end if; + if N_S = No_State then + Set_Last_State (N, P_S); + else + Set_Prev_State (N_S, P_S); + end if; + Delete_Detached_State (S); + end Remove_Unconnected_State; + + procedure Merge_NFA (L, R : NFA) is + Last_L : constant NFA_State := Get_Last_State (L); + First_R : constant NFA_State := Get_First_State (R); + Last_R : constant NFA_State := Get_Last_State (R); + begin + if First_R = No_State then + return; + end if; + if Last_L = No_State then + Set_First_State (L, First_R); + else + Set_Next_State (Last_L, First_R); + Set_Prev_State (First_R, Last_L); + end if; + Set_Last_State (L, Last_R); + Set_First_State (R, No_State); + Set_Last_State (R, No_State); + Delete_Empty_NFA (R); + end Merge_NFA; + + procedure Redest_Edges (S : NFA_State; Dest : NFA_State) is + E, N_E : NFA_Edge; + Head : NFA_Edge; + begin + E := Get_First_Dest_Edge (S); + if E = No_Edge then + return; + end if; + Set_First_Dest_Edge (S, No_Edge); + Head := Get_First_Dest_Edge (Dest); + Set_First_Dest_Edge (Dest, E); + loop + N_E := Get_Next_Dest_Edge (E); + Set_Edge_Dest (E, Dest); + exit when N_E = No_Edge; + E := N_E; + end loop; + Set_Next_Dest_Edge (E, Head); + end Redest_Edges; + + procedure Resource_Edges (S : NFA_State; Src : NFA_State) is + E, N_E : NFA_Edge; + Head : NFA_Edge; + begin + E := Get_First_Src_Edge (S); + if E = No_Edge then + return; + end if; + Set_First_Src_Edge (S, No_Edge); + Head := Get_First_Src_Edge (Src); + Set_First_Src_Edge (Src, E); + loop + N_E := Get_Next_Src_Edge (E); + Set_Edge_Src (E, Src); + exit when N_E = No_Edge; + E := N_E; + end loop; + Set_Next_Src_Edge (E, Head); + end Resource_Edges; + + procedure Disconnect_Edge_Src (N : NFA_State; E : NFA_Edge) is + N_E : constant NFA_Edge := Get_Next_Src_Edge (E); + Prev, Cur : NFA_Edge; + begin + Cur := Get_First_Src_Edge (N); + if Cur = E then + Set_First_Src_Edge (N, N_E); + else + while Cur /= E loop + Prev := Cur; + Cur := Get_Next_Src_Edge (Prev); + pragma Assert (Cur /= No_Edge); + end loop; + Set_Next_Src_Edge (Prev, N_E); + end if; + end Disconnect_Edge_Src; + + procedure Disconnect_Edge_Dest (N : NFA_State; E : NFA_Edge) is + N_E : constant NFA_Edge := Get_Next_Dest_Edge (E); + Prev, Cur : NFA_Edge; + begin + Cur := Get_First_Dest_Edge (N); + if Cur = E then + Set_First_Dest_Edge (N, N_E); + else + while Cur /= E loop + Prev := Cur; + Cur := Get_Next_Dest_Edge (Prev); + pragma Assert (Cur /= No_Edge); + end loop; + Set_Next_Dest_Edge (Prev, N_E); + end if; + end Disconnect_Edge_Dest; + + procedure Remove_Edge (E : NFA_Edge) is + begin + Disconnect_Edge_Src (Get_Edge_Src (E), E); + Disconnect_Edge_Dest (Get_Edge_Dest (E), E); + + -- Put it on the free list. + Set_Next_Dest_Edge (E, Free_Edges); + Free_Edges := E; + end Remove_Edge; + + procedure Remove_State (N : NFA; S : NFA_State) is + E, N_E : NFA_Edge; + begin + E := Get_First_Dest_Edge (S); + while E /= No_Edge loop + N_E := Get_Next_Dest_Edge (E); + Remove_Edge (E); + E := N_E; + end loop; + + E := Get_First_Src_Edge (S); + while E /= No_Edge loop + N_E := Get_Next_Src_Edge (E); + Remove_Edge (E); + E := N_E; + end loop; + + Remove_Unconnected_State (N, S); + end Remove_State; + + procedure Labelize_States (N : NFA; Nbr_States : out Natural) + is + S, Start, Final : NFA_State; + begin + S := Get_First_State (N); + Start := Get_Start_State (N); + Final := Get_Final_State (N); + pragma Assert (Start /= No_State); + Set_State_Label (Start, 0); + Nbr_States := 1; + while S /= No_State loop + if S /= Start and then S /= Final then + Set_State_Label (S, Int32 (Nbr_States)); + Nbr_States := Nbr_States + 1; + end if; + S := Get_Next_State (S); + end loop; + pragma Assert (Final /= No_State); + Set_State_Label (Final, Int32 (Nbr_States)); + Nbr_States := Nbr_States + 1; + end Labelize_States; + + procedure Labelize_States_Debug (N : NFA) + is + S : NFA_State; + begin + S := Get_First_State (N); + while S /= No_State loop + Set_State_Label (S, Int32 (S)); + S := Get_Next_State (S); + end loop; + end Labelize_States_Debug; + +end PSL.NFAs; diff --git a/psl/psl-nfas.ads b/psl/psl-nfas.ads new file mode 100644 index 000000000..815acf223 --- /dev/null +++ b/psl/psl-nfas.ads @@ -0,0 +1,108 @@ +with Types; use Types; +with PSL.Nodes; use PSL.Nodes; + +package PSL.NFAs is + -- Represents NFAs for PSL. + -- These NFAs have the following restrictions: + -- * 1 start state + -- * 1 final state (which can be the start state). + -- * possible epsilon transition between start and final state with the + -- meaning: A | eps + + type NFA_State is new Nat32; + type NFA_Edge is new Nat32; + + No_NFA : constant NFA := 0; + No_State : constant NFA_State := 0; + No_Edge : constant NFA_Edge := 0; + + -- Create a new NFA. + function Create_NFA return NFA; + + -- Add a new state to an NFA. + function Add_State (N : NFA) return NFA_State; + + -- Add a transition. + procedure Add_Edge (Src : NFA_State; Dest : NFA_State; Expr : Node); + function Add_Edge (Src : NFA_State; Dest : NFA_State; Expr : Node) + return NFA_Edge; + + -- Disconnect and free edge E. + procedure Remove_Edge (E : NFA_Edge); + + -- Return TRUE if there is an epsilon edge between start and final. + function Get_Epsilon_NFA (N : NFA) return Boolean; + procedure Set_Epsilon_NFA (N : NFA; Flag : Boolean); + + -- Each NFA has one start and one final state. + function Get_Start_State (N : NFA) return NFA_State; + procedure Set_Start_State (N : NFA; S : NFA_State); + + procedure Set_Final_State (N : NFA; S : NFA_State); + function Get_Final_State (N : NFA) return NFA_State; + + -- Iterate on all states. + function Get_First_State (N : NFA) return NFA_State; + function Get_Next_State (S : NFA_State) return NFA_State; + + -- Per state user flag. + -- Initialized set to false. + function Get_State_Flag (S : NFA_State) return Boolean; + procedure Set_State_Flag (S : NFA_State; Val : Boolean); + + -- Per state user link. + function Get_State_User_Link (S : NFA_State) return NFA_State; + procedure Set_State_User_Link (S : NFA_State; Link : NFA_State); + + -- Edges of a state. + -- A source edge is an edge whose source is the state. + function Get_First_Src_Edge (N : NFA_State) return NFA_Edge; + function Get_Next_Src_Edge (N : NFA_Edge) return NFA_Edge; + + -- A dest edge is an edge whose destination is the state. + function Get_First_Dest_Edge (N : NFA_State) return NFA_Edge; + function Get_Next_Dest_Edge (N : NFA_Edge) return NFA_Edge; + + function Get_State_Label (S : NFA_State) return Int32; + procedure Set_State_Label (S : NFA_State; Label : Int32); + + function Get_Edge_Dest (E: NFA_Edge) return NFA_State; + function Get_Edge_Src (E : NFA_Edge) return NFA_State; + function Get_Edge_Expr (E : NFA_Edge) return Node; + + -- Move States and edges of R to L. + procedure Merge_NFA (L, R : NFA); + + -- All edges to S are redirected to DEST. + procedure Redest_Edges (S : NFA_State; Dest : NFA_State); + + -- All edges from S are redirected from SRC. + procedure Resource_Edges (S : NFA_State; Src : NFA_State); + + -- Remove a state. The state must be unconnected. + procedure Remove_Unconnected_State (N : NFA; S : NFA_State); + + -- Deconnect and remove state S. + procedure Remove_State (N : NFA; S : NFA_State); + + procedure Delete_Empty_NFA (N : NFA); + + -- Set a label on the states of the NFA N. + -- Start state is has label 0. + -- Return the number of states. + procedure Labelize_States (N : NFA; Nbr_States : out Natural); + + -- Set state index as state label. + -- Used to debug an NFA. + procedure Labelize_States_Debug (N : NFA); + + procedure Set_Edge_Expr (E : NFA_Edge; N : Node); +private + -- Low level procedures. Shouldn't be used directly. + procedure Set_First_Dest_Edge (N : NFA_State; T : NFA_Edge); + procedure Set_Next_Dest_Edge (E : NFA_Edge; N_E : NFA_Edge); + procedure Set_First_Src_Edge (N : NFA_State; T : NFA_Edge); + procedure Set_Next_Src_Edge (E : NFA_Edge; N_E : NFA_Edge); + procedure Set_Edge_Dest (E : NFA_Edge; D : NFA_State); + procedure Set_Edge_Src (E : NFA_Edge; D : NFA_State); +end PSL.NFAs; diff --git a/psl/psl-nodes.adb b/psl/psl-nodes.adb new file mode 100644 index 000000000..a6482a142 --- /dev/null +++ b/psl/psl-nodes.adb @@ -0,0 +1,1231 @@ +-- This is in fact -*- Ada -*- +with Ada.Unchecked_Conversion; +with GNAT.Table; +with PSL.Errors; +with PSL.Hash; + +package body PSL.Nodes is + -- Suppress the access check of the table base. This is really safe to + -- suppress this check because the table base cannot be null. + pragma Suppress (Access_Check); + + -- Suppress the index check on the table. + -- Could be done during non-debug, since this may catch errors (reading + -- Null_Node. + --pragma Suppress (Index_Check); + + type Format_Type is + ( + Format_Short, + Format_Medium + ); + + pragma Unreferenced (Format_Type, Format_Short, Format_Medium); + + -- Common fields are: + -- Flag1 : Boolean + -- Flag2 : Boolean + -- Flag3 : Boolean + -- Flag4 : Boolean + -- Flag5 : Boolean + -- Flag6 : Boolean + -- Nkind : Kind_Type + -- State1 : Bit2_Type + -- State2 : Bit2_Type + -- Location : Int32 + -- Field1 : Int32 + -- Field2 : Int32 + -- Field3 : Int32 + -- Field4 : Int32 + + -- Fields of Format_Short: + -- Field5 : Int32 + -- Field6 : Int32 + + -- Fields of Format_Medium: + -- Odigit1 : Bit3_Type + -- Odigit2 : Bit3_Type + -- State3 : Bit2_Type + -- State4 : Bit2_Type + -- Field5 : Int32 + -- Field6 : Int32 + -- Field7 : Int32 (location) + -- Field8 : Int32 (field1) + -- Field9 : Int32 (field2) + -- Field10 : Int32 (field3) + -- Field11 : Int32 (field4) + -- Field12 : Int32 (field5) + + type State_Type is range 0 .. 3; + type Bit3_Type is range 0 .. 7; + + type Node_Record is record + Kind : Nkind; + Flag1 : Boolean; + Flag2 : Boolean; + Flag3 : Boolean; + Flag4 : Boolean; + Flag5 : Boolean; + Flag6 : Boolean; + Flag7 : Boolean; + Flag8 : Boolean; + Flag9 : Boolean; + Flag10 : Boolean; + Flag11 : Boolean; + Flag12 : Boolean; + Flag13 : Boolean; + Flag14 : Boolean; + Flag15 : Boolean; + Flag16 : Boolean; + State1 : State_Type; + B3_1 : Bit3_Type; + Flag17 : Boolean; + Flag18 : Boolean; + Flag19 : Boolean; + + Location : Int32; + Field1 : Int32; + Field2 : Int32; + Field3 : Int32; + Field4 : Int32; + Field5 : Int32; + Field6 : Int32; + end record; + pragma Pack (Node_Record); + for Node_Record'Size use 8 * 32; + + package Nodet is new GNAT.Table + (Table_Component_Type => Node_Record, + Table_Index_Type => Node, + Table_Low_Bound => 1, + Table_Initial => 1024, + Table_Increment => 100); + + Init_Node : constant Node_Record := (Kind => N_Error, + Flag1 => False, + Flag2 => False, + State1 => 0, + B3_1 => 0, + Location => 0, + Field1 => 0, + Field2 => 0, + Field3 => 0, + Field4 => 0, + Field5 => 0, + Field6 => 0, + others => False); + + Free_Nodes : Node := Null_Node; + + + function Get_Last_Node return Node is + begin + return Nodet.Last; + end Get_Last_Node; + + function Int32_To_Uns32 is new Ada.Unchecked_Conversion + (Source => Int32, Target => Uns32); + + function Uns32_To_Int32 is new Ada.Unchecked_Conversion + (Source => Uns32, Target => Int32); + + function Int32_To_NFA is new Ada.Unchecked_Conversion + (Source => Int32, Target => NFA); + + function NFA_To_Int32 is new Ada.Unchecked_Conversion + (Source => NFA, Target => Int32); + + procedure Set_Kind (N : Node; K : Nkind) is + begin + Nodet.Table (N).Kind := K; + end Set_Kind; + + function Get_Kind (N : Node) return Nkind is + begin + return Nodet.Table (N).Kind; + end Get_Kind; + + + procedure Set_Flag1 (N : Node; Flag : Boolean) is + begin + Nodet.Table (N).Flag1 := Flag; + end Set_Flag1; + + function Get_Flag1 (N : Node) return Boolean is + begin + return Nodet.Table (N).Flag1; + end Get_Flag1; + + procedure Set_Flag2 (N : Node; Flag : Boolean) is + begin + Nodet.Table (N).Flag2 := Flag; + end Set_Flag2; + + function Get_Flag2 (N : Node) return Boolean is + begin + return Nodet.Table (N).Flag2; + end Get_Flag2; + + + procedure Set_State1 (N : Node; S : State_Type) is + begin + Nodet.Table (N).State1 := S; + end Set_State1; + + function Get_State1 (N : Node) return State_Type is + begin + return Nodet.Table (N).State1; + end Get_State1; + + + function Get_Location (N : Node) return Location_Type is + begin + return Location_Type (Nodet.Table (N).Location); + end Get_Location; + + procedure Set_Location (N : Node; Loc : Location_Type) is + begin + Nodet.Table (N).Location := Int32 (Loc); + end Set_Location; + + + procedure Set_Field1 (N : Node; V : Int32) is + begin + Nodet.Table (N).Field1 := V; + end Set_Field1; + + function Get_Field1 (N : Node) return Int32 is + begin + return Nodet.Table (N).Field1; + end Get_Field1; + + + procedure Set_Field2 (N : Node; V : Int32) is + begin + Nodet.Table (N).Field2 := V; + end Set_Field2; + + function Get_Field2 (N : Node) return Int32 is + begin + return Nodet.Table (N).Field2; + end Get_Field2; + + + function Get_Field3 (N : Node) return Int32 is + begin + return Nodet.Table (N).Field3; + end Get_Field3; + + procedure Set_Field3 (N : Node; V : Int32) is + begin + Nodet.Table (N).Field3 := V; + end Set_Field3; + + + function Get_Field4 (N : Node) return Int32 is + begin + return Nodet.Table (N).Field4; + end Get_Field4; + + procedure Set_Field4 (N : Node; V : Int32) is + begin + Nodet.Table (N).Field4 := V; + end Set_Field4; + + + function Get_Field5 (N : Node) return Int32 is + begin + return Nodet.Table (N).Field5; + end Get_Field5; + + procedure Set_Field5 (N : Node; V : Int32) is + begin + Nodet.Table (N).Field5 := V; + end Set_Field5; + + + function Get_Field6 (N : Node) return Int32 is + begin + return Nodet.Table (N).Field6; + end Get_Field6; + + procedure Set_Field6 (N : Node; V : Int32) is + begin + Nodet.Table (N).Field6 := V; + end Set_Field6; + + procedure Set_Field7 (N : Node; V : Int32) is + begin + Nodet.Table (N + 1).Field1 := V; + end Set_Field7; + + function Get_Field7 (N : Node) return Int32 is + begin + return Nodet.Table (N + 1).Field1; + end Get_Field7; + + + function Create_Node (Kind : Nkind) return Node + is + Res : Node; + begin + if Free_Nodes /= Null_Node then + Res := Free_Nodes; + Free_Nodes := Node (Get_Field1 (Res)); + else + Nodet.Increment_Last; + Res := Nodet.Last; + end if; + Nodet.Table (Res) := Init_Node; + Set_Kind (Res, Kind); + return Res; + end Create_Node; + + procedure Free_Node (N : Node) + is + begin + Set_Kind (N, N_Error); + Set_Field1 (N, Int32 (Free_Nodes)); + Free_Nodes := N; + end Free_Node; + + procedure Failed (Msg : String; N : Node) + is + begin + Errors.Error_Kind (Msg, N); + end Failed; + + procedure Init is + begin + Nodet.Init; + if Create_Node (N_False) /= False_Node then + raise Internal_Error; + end if; + if Create_Node (N_True) /= True_Node then + raise Internal_Error; + end if; + if Create_Node (N_Number) /= One_Node then + raise Internal_Error; + end if; + Set_Value (One_Node, 1); + if Create_Node (N_EOS) /= EOS_Node then + raise Internal_Error; + end if; + Set_Hash (EOS_Node, 0); + PSL.Hash.Init; + end Init; + + function Get_Psl_Type (N : Node) return PSL_Types is + begin + case Get_Kind (N) is + when N_And_Prop + | N_Or_Prop + | N_Log_Imp_Prop + | N_Always + | N_Never + | N_Eventually + | N_Next + | N_Next_E + | N_Next_A + | N_Next_Event + | N_Next_Event_A + | N_Next_Event_E + | N_Before + | N_Until + | N_Abort + | N_Strong + | N_Property_Parameter + | N_Property_Instance => + return Type_Property; + when N_Braced_SERE + | N_Concat_SERE + | N_Fusion_SERE + | N_Within_SERE + | N_Overlap_Imp_Seq + | N_Imp_Seq + | N_And_Seq + | N_Or_Seq + | N_Match_And_Seq + | N_Star_Repeat_Seq + | N_Goto_Repeat_Seq + | N_Equal_Repeat_Seq + | N_Plus_Repeat_Seq + | N_Clock_Event + | N_Sequence_Instance + | N_Endpoint_Instance + | N_Sequence_Parameter => + return Type_Sequence; + when N_Name => + return Get_Psl_Type (Get_Decl (N)); + when N_HDL_Expr => + -- FIXME. + return Type_Boolean; + when N_Or_Bool + | N_And_Bool + | N_Not_Bool + | N_Imp_Bool + | N_False + | N_True + | N_Boolean_Parameter => + return Type_Boolean; + when N_Number + | N_Const_Parameter => + return Type_Numeric; + when N_Vmode + | N_Vunit + | N_Vprop + | N_Hdl_Mod_Name + | N_Assert_Directive + | N_Sequence_Declaration + | N_Endpoint_Declaration + | N_Property_Declaration + | N_Actual + | N_Name_Decl + | N_Error + | N_EOS => + PSL.Errors.Error_Kind ("get_psl_type", N); + end case; + end Get_Psl_Type; + + procedure Reference_Failed (Msg : String; N : Node) is + begin + Failed (Msg, N); + end Reference_Failed; + pragma Unreferenced (Reference_Failed); + + pragma Unreferenced (Set_Field7, Get_Field7); + -- Subprograms. + procedure Check_Kind_For_Identifier (N : Node) is + begin + case Get_Kind (N) is + when N_Vmode + | N_Vunit + | N_Vprop + | N_Hdl_Mod_Name + | N_Property_Declaration + | N_Sequence_Declaration + | N_Endpoint_Declaration + | N_Const_Parameter + | N_Boolean_Parameter + | N_Property_Parameter + | N_Sequence_Parameter + | N_Name + | N_Name_Decl => + null; + when others => + Failed ("Get/Set_Identifier", N); + end case; + end Check_Kind_For_Identifier; + + function Get_Identifier (N : Node) return Name_Id is + begin + Check_Kind_For_Identifier (N); + return Name_Id (Get_Field1 (N)); + end Get_Identifier; + + procedure Set_Identifier (N : Node; Id : Name_Id) is + begin + Check_Kind_For_Identifier (N); + Set_Field1 (N, Int32 (Id)); + end Set_Identifier; + + procedure Check_Kind_For_Chain (N : Node) is + begin + case Get_Kind (N) is + when N_Vmode + | N_Vunit + | N_Vprop + | N_Assert_Directive + | N_Property_Declaration + | N_Sequence_Declaration + | N_Endpoint_Declaration + | N_Const_Parameter + | N_Boolean_Parameter + | N_Property_Parameter + | N_Sequence_Parameter + | N_Actual + | N_Name_Decl => + null; + when others => + Failed ("Get/Set_Chain", N); + end case; + end Check_Kind_For_Chain; + + function Get_Chain (N : Node) return Node is + begin + Check_Kind_For_Chain (N); + return Node (Get_Field2 (N)); + end Get_Chain; + + procedure Set_Chain (N : Node; Chain : Node) is + begin + Check_Kind_For_Chain (N); + Set_Field2 (N, Int32 (Chain)); + end Set_Chain; + + procedure Check_Kind_For_Instance (N : Node) is + begin + case Get_Kind (N) is + when N_Vmode + | N_Vunit + | N_Vprop => + null; + when others => + Failed ("Get/Set_Instance", N); + end case; + end Check_Kind_For_Instance; + + function Get_Instance (N : Node) return Node is + begin + Check_Kind_For_Instance (N); + return Node (Get_Field3 (N)); + end Get_Instance; + + procedure Set_Instance (N : Node; Instance : Node) is + begin + Check_Kind_For_Instance (N); + Set_Field3 (N, Int32 (Instance)); + end Set_Instance; + + procedure Check_Kind_For_Item_Chain (N : Node) is + begin + case Get_Kind (N) is + when N_Vmode + | N_Vunit + | N_Vprop => + null; + when others => + Failed ("Get/Set_Item_Chain", N); + end case; + end Check_Kind_For_Item_Chain; + + function Get_Item_Chain (N : Node) return Node is + begin + Check_Kind_For_Item_Chain (N); + return Node (Get_Field4 (N)); + end Get_Item_Chain; + + procedure Set_Item_Chain (N : Node; Item : Node) is + begin + Check_Kind_For_Item_Chain (N); + Set_Field4 (N, Int32 (Item)); + end Set_Item_Chain; + + procedure Check_Kind_For_Prefix (N : Node) is + begin + case Get_Kind (N) is + when N_Hdl_Mod_Name => + null; + when others => + Failed ("Get/Set_Prefix", N); + end case; + end Check_Kind_For_Prefix; + + function Get_Prefix (N : Node) return Node is + begin + Check_Kind_For_Prefix (N); + return Node (Get_Field2 (N)); + end Get_Prefix; + + procedure Set_Prefix (N : Node; Prefix : Node) is + begin + Check_Kind_For_Prefix (N); + Set_Field2 (N, Int32 (Prefix)); + end Set_Prefix; + + procedure Check_Kind_For_Label (N : Node) is + begin + case Get_Kind (N) is + when N_Assert_Directive => + null; + when others => + Failed ("Get/Set_Label", N); + end case; + end Check_Kind_For_Label; + + function Get_Label (N : Node) return Name_Id is + begin + Check_Kind_For_Label (N); + return Name_Id (Get_Field1 (N)); + end Get_Label; + + procedure Set_Label (N : Node; Id : Name_Id) is + begin + Check_Kind_For_Label (N); + Set_Field1 (N, Int32 (Id)); + end Set_Label; + + procedure Check_Kind_For_String (N : Node) is + begin + case Get_Kind (N) is + when N_Assert_Directive => + null; + when others => + Failed ("Get/Set_String", N); + end case; + end Check_Kind_For_String; + + function Get_String (N : Node) return Node is + begin + Check_Kind_For_String (N); + return Node (Get_Field3 (N)); + end Get_String; + + procedure Set_String (N : Node; Str : Node) is + begin + Check_Kind_For_String (N); + Set_Field3 (N, Int32 (Str)); + end Set_String; + + procedure Check_Kind_For_Property (N : Node) is + begin + case Get_Kind (N) is + when N_Assert_Directive + | N_Property_Declaration + | N_Clock_Event + | N_Always + | N_Never + | N_Eventually + | N_Strong + | N_Imp_Seq + | N_Overlap_Imp_Seq + | N_Next + | N_Next_A + | N_Next_E + | N_Next_Event + | N_Next_Event_A + | N_Next_Event_E + | N_Abort => + null; + when others => + Failed ("Get/Set_Property", N); + end case; + end Check_Kind_For_Property; + + function Get_Property (N : Node) return Node is + begin + Check_Kind_For_Property (N); + return Node (Get_Field4 (N)); + end Get_Property; + + procedure Set_Property (N : Node; Property : Node) is + begin + Check_Kind_For_Property (N); + Set_Field4 (N, Int32 (Property)); + end Set_Property; + + procedure Check_Kind_For_NFA (N : Node) is + begin + case Get_Kind (N) is + when N_Assert_Directive => + null; + when others => + Failed ("Get/Set_NFA", N); + end case; + end Check_Kind_For_NFA; + + function Get_NFA (N : Node) return NFA is + begin + Check_Kind_For_NFA (N); + return Int32_To_NFA (Get_Field5 (N)); + end Get_NFA; + + procedure Set_NFA (N : Node; P : NFA) is + begin + Check_Kind_For_NFA (N); + Set_Field5 (N, NFA_To_Int32 (P)); + end Set_NFA; + + procedure Check_Kind_For_Global_Clock (N : Node) is + begin + case Get_Kind (N) is + when N_Property_Declaration => + null; + when others => + Failed ("Get/Set_Global_Clock", N); + end case; + end Check_Kind_For_Global_Clock; + + function Get_Global_Clock (N : Node) return Node is + begin + Check_Kind_For_Global_Clock (N); + return Node (Get_Field3 (N)); + end Get_Global_Clock; + + procedure Set_Global_Clock (N : Node; Clock : Node) is + begin + Check_Kind_For_Global_Clock (N); + Set_Field3 (N, Int32 (Clock)); + end Set_Global_Clock; + + procedure Check_Kind_For_Parameter_List (N : Node) is + begin + case Get_Kind (N) is + when N_Property_Declaration + | N_Sequence_Declaration + | N_Endpoint_Declaration => + null; + when others => + Failed ("Get/Set_Parameter_List", N); + end case; + end Check_Kind_For_Parameter_List; + + function Get_Parameter_List (N : Node) return Node is + begin + Check_Kind_For_Parameter_List (N); + return Node (Get_Field5 (N)); + end Get_Parameter_List; + + procedure Set_Parameter_List (N : Node; E : Node) is + begin + Check_Kind_For_Parameter_List (N); + Set_Field5 (N, Int32 (E)); + end Set_Parameter_List; + + procedure Check_Kind_For_Sequence (N : Node) is + begin + case Get_Kind (N) is + when N_Sequence_Declaration + | N_Endpoint_Declaration + | N_Imp_Seq + | N_Overlap_Imp_Seq + | N_Star_Repeat_Seq + | N_Goto_Repeat_Seq + | N_Plus_Repeat_Seq + | N_Equal_Repeat_Seq => + null; + when others => + Failed ("Get/Set_Sequence", N); + end case; + end Check_Kind_For_Sequence; + + function Get_Sequence (N : Node) return Node is + begin + Check_Kind_For_Sequence (N); + return Node (Get_Field3 (N)); + end Get_Sequence; + + procedure Set_Sequence (N : Node; S : Node) is + begin + Check_Kind_For_Sequence (N); + Set_Field3 (N, Int32 (S)); + end Set_Sequence; + + procedure Check_Kind_For_Actual (N : Node) is + begin + case Get_Kind (N) is + when N_Const_Parameter + | N_Boolean_Parameter + | N_Property_Parameter + | N_Sequence_Parameter + | N_Actual => + null; + when others => + Failed ("Get/Set_Actual", N); + end case; + end Check_Kind_For_Actual; + + function Get_Actual (N : Node) return Node is + begin + Check_Kind_For_Actual (N); + return Node (Get_Field3 (N)); + end Get_Actual; + + procedure Set_Actual (N : Node; E : Node) is + begin + Check_Kind_For_Actual (N); + Set_Field3 (N, Int32 (E)); + end Set_Actual; + + procedure Check_Kind_For_Declaration (N : Node) is + begin + case Get_Kind (N) is + when N_Sequence_Instance + | N_Endpoint_Instance + | N_Property_Instance => + null; + when others => + Failed ("Get/Set_Declaration", N); + end case; + end Check_Kind_For_Declaration; + + function Get_Declaration (N : Node) return Node is + begin + Check_Kind_For_Declaration (N); + return Node (Get_Field1 (N)); + end Get_Declaration; + + procedure Set_Declaration (N : Node; Decl : Node) is + begin + Check_Kind_For_Declaration (N); + Set_Field1 (N, Int32 (Decl)); + end Set_Declaration; + + procedure Check_Kind_For_Association_Chain (N : Node) is + begin + case Get_Kind (N) is + when N_Sequence_Instance + | N_Endpoint_Instance + | N_Property_Instance => + null; + when others => + Failed ("Get/Set_Association_Chain", N); + end case; + end Check_Kind_For_Association_Chain; + + function Get_Association_Chain (N : Node) return Node is + begin + Check_Kind_For_Association_Chain (N); + return Node (Get_Field2 (N)); + end Get_Association_Chain; + + procedure Set_Association_Chain (N : Node; Chain : Node) is + begin + Check_Kind_For_Association_Chain (N); + Set_Field2 (N, Int32 (Chain)); + end Set_Association_Chain; + + procedure Check_Kind_For_Formal (N : Node) is + begin + case Get_Kind (N) is + when N_Actual => + null; + when others => + Failed ("Get/Set_Formal", N); + end case; + end Check_Kind_For_Formal; + + function Get_Formal (N : Node) return Node is + begin + Check_Kind_For_Formal (N); + return Node (Get_Field4 (N)); + end Get_Formal; + + procedure Set_Formal (N : Node; E : Node) is + begin + Check_Kind_For_Formal (N); + Set_Field4 (N, Int32 (E)); + end Set_Formal; + + procedure Check_Kind_For_Boolean (N : Node) is + begin + case Get_Kind (N) is + when N_Clock_Event + | N_Next_Event + | N_Next_Event_A + | N_Next_Event_E + | N_Abort + | N_Not_Bool => + null; + when others => + Failed ("Get/Set_Boolean", N); + end case; + end Check_Kind_For_Boolean; + + function Get_Boolean (N : Node) return Node is + begin + Check_Kind_For_Boolean (N); + return Node (Get_Field3 (N)); + end Get_Boolean; + + procedure Set_Boolean (N : Node; B : Node) is + begin + Check_Kind_For_Boolean (N); + Set_Field3 (N, Int32 (B)); + end Set_Boolean; + + procedure Check_Kind_For_Strong_Flag (N : Node) is + begin + case Get_Kind (N) is + when N_Next + | N_Next_A + | N_Next_E + | N_Next_Event + | N_Next_Event_A + | N_Next_Event_E + | N_Until + | N_Before => + null; + when others => + Failed ("Get/Set_Strong_Flag", N); + end case; + end Check_Kind_For_Strong_Flag; + + function Get_Strong_Flag (N : Node) return Boolean is + begin + Check_Kind_For_Strong_Flag (N); + return Get_Flag1 (N); + end Get_Strong_Flag; + + procedure Set_Strong_Flag (N : Node; B : Boolean) is + begin + Check_Kind_For_Strong_Flag (N); + Set_Flag1 (N, B); + end Set_Strong_Flag; + + procedure Check_Kind_For_Number (N : Node) is + begin + case Get_Kind (N) is + when N_Next + | N_Next_Event => + null; + when others => + Failed ("Get/Set_Number", N); + end case; + end Check_Kind_For_Number; + + function Get_Number (N : Node) return Node is + begin + Check_Kind_For_Number (N); + return Node (Get_Field1 (N)); + end Get_Number; + + procedure Set_Number (N : Node; S : Node) is + begin + Check_Kind_For_Number (N); + Set_Field1 (N, Int32 (S)); + end Set_Number; + + procedure Check_Kind_For_Decl (N : Node) is + begin + case Get_Kind (N) is + when N_Name => + null; + when others => + Failed ("Get/Set_Decl", N); + end case; + end Check_Kind_For_Decl; + + function Get_Decl (N : Node) return Node is + begin + Check_Kind_For_Decl (N); + return Node (Get_Field2 (N)); + end Get_Decl; + + procedure Set_Decl (N : Node; D : Node) is + begin + Check_Kind_For_Decl (N); + Set_Field2 (N, Int32 (D)); + end Set_Decl; + + procedure Check_Kind_For_Value (N : Node) is + begin + case Get_Kind (N) is + when N_Number => + null; + when others => + Failed ("Get/Set_Value", N); + end case; + end Check_Kind_For_Value; + + function Get_Value (N : Node) return Uns32 is + begin + Check_Kind_For_Value (N); + return Int32_To_Uns32 (Get_Field1 (N)); + end Get_Value; + + procedure Set_Value (N : Node; Val : Uns32) is + begin + Check_Kind_For_Value (N); + Set_Field1 (N, Uns32_To_Int32 (Val)); + end Set_Value; + + procedure Check_Kind_For_SERE (N : Node) is + begin + case Get_Kind (N) is + when N_Braced_SERE => + null; + when others => + Failed ("Get/Set_SERE", N); + end case; + end Check_Kind_For_SERE; + + function Get_SERE (N : Node) return Node is + begin + Check_Kind_For_SERE (N); + return Node (Get_Field1 (N)); + end Get_SERE; + + procedure Set_SERE (N : Node; S : Node) is + begin + Check_Kind_For_SERE (N); + Set_Field1 (N, Int32 (S)); + end Set_SERE; + + procedure Check_Kind_For_Left (N : Node) is + begin + case Get_Kind (N) is + when N_Log_Imp_Prop + | N_Until + | N_Before + | N_Or_Prop + | N_And_Prop + | N_Concat_SERE + | N_Fusion_SERE + | N_Within_SERE + | N_Match_And_Seq + | N_And_Seq + | N_Or_Seq + | N_And_Bool + | N_Or_Bool + | N_Imp_Bool => + null; + when others => + Failed ("Get/Set_Left", N); + end case; + end Check_Kind_For_Left; + + function Get_Left (N : Node) return Node is + begin + Check_Kind_For_Left (N); + return Node (Get_Field1 (N)); + end Get_Left; + + procedure Set_Left (N : Node; S : Node) is + begin + Check_Kind_For_Left (N); + Set_Field1 (N, Int32 (S)); + end Set_Left; + + procedure Check_Kind_For_Right (N : Node) is + begin + case Get_Kind (N) is + when N_Log_Imp_Prop + | N_Until + | N_Before + | N_Or_Prop + | N_And_Prop + | N_Concat_SERE + | N_Fusion_SERE + | N_Within_SERE + | N_Match_And_Seq + | N_And_Seq + | N_Or_Seq + | N_And_Bool + | N_Or_Bool + | N_Imp_Bool => + null; + when others => + Failed ("Get/Set_Right", N); + end case; + end Check_Kind_For_Right; + + function Get_Right (N : Node) return Node is + begin + Check_Kind_For_Right (N); + return Node (Get_Field2 (N)); + end Get_Right; + + procedure Set_Right (N : Node; S : Node) is + begin + Check_Kind_For_Right (N); + Set_Field2 (N, Int32 (S)); + end Set_Right; + + procedure Check_Kind_For_Low_Bound (N : Node) is + begin + case Get_Kind (N) is + when N_Next_A + | N_Next_E + | N_Next_Event_A + | N_Next_Event_E + | N_Star_Repeat_Seq + | N_Goto_Repeat_Seq + | N_Equal_Repeat_Seq => + null; + when others => + Failed ("Get/Set_Low_Bound", N); + end case; + end Check_Kind_For_Low_Bound; + + function Get_Low_Bound (N : Node) return Node is + begin + Check_Kind_For_Low_Bound (N); + return Node (Get_Field1 (N)); + end Get_Low_Bound; + + procedure Set_Low_Bound (N : Node; S : Node) is + begin + Check_Kind_For_Low_Bound (N); + Set_Field1 (N, Int32 (S)); + end Set_Low_Bound; + + procedure Check_Kind_For_High_Bound (N : Node) is + begin + case Get_Kind (N) is + when N_Next_A + | N_Next_E + | N_Next_Event_A + | N_Next_Event_E + | N_Star_Repeat_Seq + | N_Goto_Repeat_Seq + | N_Equal_Repeat_Seq => + null; + when others => + Failed ("Get/Set_High_Bound", N); + end case; + end Check_Kind_For_High_Bound; + + function Get_High_Bound (N : Node) return Node is + begin + Check_Kind_For_High_Bound (N); + return Node (Get_Field2 (N)); + end Get_High_Bound; + + procedure Set_High_Bound (N : Node; S : Node) is + begin + Check_Kind_For_High_Bound (N); + Set_Field2 (N, Int32 (S)); + end Set_High_Bound; + + procedure Check_Kind_For_Inclusive_Flag (N : Node) is + begin + case Get_Kind (N) is + when N_Until + | N_Before => + null; + when others => + Failed ("Get/Set_Inclusive_Flag", N); + end case; + end Check_Kind_For_Inclusive_Flag; + + function Get_Inclusive_Flag (N : Node) return Boolean is + begin + Check_Kind_For_Inclusive_Flag (N); + return Get_Flag2 (N); + end Get_Inclusive_Flag; + + procedure Set_Inclusive_Flag (N : Node; B : Boolean) is + begin + Check_Kind_For_Inclusive_Flag (N); + Set_Flag2 (N, B); + end Set_Inclusive_Flag; + + procedure Check_Kind_For_Presence (N : Node) is + begin + case Get_Kind (N) is + when N_Not_Bool + | N_And_Bool + | N_Or_Bool + | N_Imp_Bool + | N_HDL_Expr => + null; + when others => + Failed ("Get/Set_Presence", N); + end case; + end Check_Kind_For_Presence; + + function Get_Presence (N : Node) return PSL_Presence_Kind is + begin + Check_Kind_For_Presence (N); + return PSL_Presence_Kind'Val(Get_State1 (N)); + end Get_Presence; + + procedure Set_Presence (N : Node; P : PSL_Presence_Kind) is + begin + Check_Kind_For_Presence (N); + Set_State1 (N, PSL_Presence_Kind'pos (P)); + end Set_Presence; + + procedure Check_Kind_For_HDL_Node (N : Node) is + begin + case Get_Kind (N) is + when N_HDL_Expr => + null; + when others => + Failed ("Get/Set_HDL_Node", N); + end case; + end Check_Kind_For_HDL_Node; + + function Get_HDL_Node (N : Node) return HDL_Node is + begin + Check_Kind_For_HDL_Node (N); + return Get_Field1 (N); + end Get_HDL_Node; + + procedure Set_HDL_Node (N : Node; H : HDL_Node) is + begin + Check_Kind_For_HDL_Node (N); + Set_Field1 (N, H); + end Set_HDL_Node; + + procedure Check_Kind_For_HDL_Index (N : Node) is + begin + case Get_Kind (N) is + when N_HDL_Expr + | N_EOS => + null; + when others => + Failed ("Get/Set_HDL_Index", N); + end case; + end Check_Kind_For_HDL_Index; + + function Get_HDL_Index (N : Node) return Int32 is + begin + Check_Kind_For_HDL_Index (N); + return Get_Field2 (N); + end Get_HDL_Index; + + procedure Set_HDL_Index (N : Node; Idx : Int32) is + begin + Check_Kind_For_HDL_Index (N); + Set_Field2 (N, Idx); + end Set_HDL_Index; + + procedure Check_Kind_For_Hash (N : Node) is + begin + case Get_Kind (N) is + when N_Not_Bool + | N_And_Bool + | N_Or_Bool + | N_Imp_Bool + | N_HDL_Expr + | N_EOS => + null; + when others => + Failed ("Get/Set_Hash", N); + end case; + end Check_Kind_For_Hash; + + function Get_Hash (N : Node) return Uns32 is + begin + Check_Kind_For_Hash (N); + return Int32_To_Uns32 (Get_Field5 (N)); + end Get_Hash; + + procedure Set_Hash (N : Node; E : Uns32) is + begin + Check_Kind_For_Hash (N); + Set_Field5 (N, Uns32_To_Int32 (E)); + end Set_Hash; + + procedure Check_Kind_For_Hash_Link (N : Node) is + begin + case Get_Kind (N) is + when N_Not_Bool + | N_And_Bool + | N_Or_Bool + | N_Imp_Bool + | N_HDL_Expr + | N_EOS => + null; + when others => + Failed ("Get/Set_Hash_Link", N); + end case; + end Check_Kind_For_Hash_Link; + + function Get_Hash_Link (N : Node) return Node is + begin + Check_Kind_For_Hash_Link (N); + return Node (Get_Field6 (N)); + end Get_Hash_Link; + + procedure Set_Hash_Link (N : Node; E : Node) is + begin + Check_Kind_For_Hash_Link (N); + Set_Field6 (N, Int32 (E)); + end Set_Hash_Link; + + +end PSL.Nodes; + diff --git a/psl/psl-nodes.ads b/psl/psl-nodes.ads new file mode 100644 index 000000000..8802dce83 --- /dev/null +++ b/psl/psl-nodes.ads @@ -0,0 +1,563 @@ +with Types; use Types; + +package PSL.Nodes is + type Nkind is + ( + N_Error, + + N_Vmode, + N_Vunit, + N_Vprop, + + N_Hdl_Mod_Name, + + N_Assert_Directive, + N_Property_Declaration, + N_Sequence_Declaration, + N_Endpoint_Declaration, + + -- Formal parameters + N_Const_Parameter, + N_Boolean_Parameter, + N_Property_Parameter, + N_Sequence_Parameter, + + N_Sequence_Instance, + N_Endpoint_Instance, + N_Property_Instance, + N_Actual, + + N_Clock_Event, + + -- Properties + N_Always, + N_Never, + N_Eventually, + N_Strong, -- ! + N_Imp_Seq, -- |=> + N_Overlap_Imp_Seq, -- |-> + N_Log_Imp_Prop, -- -> + N_Next, + N_Next_A, + N_Next_E, + N_Next_Event, + N_Next_Event_A, + N_Next_Event_E, + N_Abort, + N_Until, + N_Before, + N_Or_Prop, + N_And_Prop, + + -- Sequences/SERE. + N_Braced_SERE, + N_Concat_SERE, + N_Fusion_SERE, + N_Within_SERE, + + N_Match_And_Seq, -- && + N_And_Seq, + N_Or_Seq, + + N_Star_Repeat_Seq, + N_Goto_Repeat_Seq, + N_Plus_Repeat_Seq, -- [+] + N_Equal_Repeat_Seq, + + -- Boolean layer. + N_Not_Bool, + N_And_Bool, + N_Or_Bool, + N_Imp_Bool, -- -> + N_HDL_Expr, + N_False, + N_True, + N_EOS, + + N_Name, + N_Name_Decl, + N_Number + ); + for Nkind'Size use 8; + + subtype N_Booleans is Nkind range N_Not_Bool .. N_True; + subtype N_Sequences is Nkind range N_Braced_SERE .. N_Equal_Repeat_Seq; + + type PSL_Types is + ( + Type_Unknown, + Type_Boolean, + Type_Bit, + Type_Bitvector, + Type_Numeric, + Type_String, + Type_Sequence, + Type_Property + ); + + -- Within CSE, it is useful to know which sub-expression already compose + -- an expression. + -- Eg: suppose we want to build A and B. + -- Each sub-expressions of B is marked either as Present_Pos or + -- Present_Neg. + -- If A is already present, return either B or FALSE. + -- Otherwise, build the node. + type PSL_Presence_Kind is + ( + Present_Unknown, + Present_Pos, + Present_Neg + ); + + -- Start of nodes: + + -- N_Error (Short) + + -- N_Vmode (Short) + -- N_Vunit (Short) + -- N_Vprop (Short) + -- + -- Get/Set_Identifier (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Instance (Field3) + -- + -- Get/Set_Item_Chain (Field4) + + -- N_Hdl_Mod_Name (Short) + -- + -- Get/Set_Identifier (Field1) + -- + -- Get/Set_Prefix (Field2) + + -- N_Assert_Directive (Short) + -- + -- Get/Set_Label (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_String (Field3) + -- + -- Get/Set_Property (Field4) + -- + -- Get/Set_NFA (Field5) + + -- N_Property_Declaration (Short) + -- + -- Get/Set_Identifier (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Global_Clock (Field3) + -- + -- Get/Set_Property (Field4) + -- + -- Get/Set_Parameter_List (Field5) + + -- N_Sequence_Declaration (Short) + -- N_Endpoint_Declaration (Short) + -- + -- Get/Set_Identifier (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Sequence (Field3) + -- + -- Get/Set_Parameter_List (Field5) + + -- N_Const_Parameter (Short) + -- N_Boolean_Parameter (Short) + -- N_Property_Parameter (Short) + -- N_Sequence_Parameter (Short) + -- + -- Get/Set_Identifier (Field1) + -- + -- Get/Set_Chain (Field2) + -- + -- -- Current actual parameter. + -- Get/Set_Actual (Field3) + + -- N_Sequence_Instance (Short) + -- N_Endpoint_Instance (Short) + -- N_Property_Instance (Short) + -- + -- Get/Set_Declaration (Field1) [Flat] + -- + -- Get/Set_Association_Chain (Field2) + + -- N_Actual (Short) + -- + -- Get/Set_Chain (Field2) + -- + -- Get/Set_Actual (Field3) + -- + -- Get/Set_Formal (Field4) + + -- N_Clock_Event (Short) + -- + -- Get/Set_Property (Field4) + -- + -- Get/Set_Boolean (Field3) + + -- N_Always (Short) + -- N_Never (Short) + -- N_Eventually (Short) + -- N_Strong (Short) + -- + -- Get/Set_Property (Field4) + + -- N_Next (Short) + -- + -- Get/Set_Strong_Flag (Flag1) + -- + -- Get/Set_Number (Field1) + -- + -- Get/Set_Property (Field4) + + -- N_Name (Short) + -- + -- Get/Set_Identifier (Field1) + -- + -- Get/Set_Decl (Field2) + + -- N_Name_Decl (Short) + -- + -- Get/Set_Identifier (Field1) + -- + -- Get/Set_Chain (Field2) + + -- N_Number (Short) + -- + -- Get/Set_Value (Field1) + + -- N_Braced_SERE (Short) + -- + -- Get/Set_SERE (Field1) + + -- N_Concat_SERE (Short) + -- N_Fusion_SERE (Short) + -- N_Within_SERE (Short) + -- + -- Get/Set_Left (Field1) + -- + -- Get/Set_Right (Field2) + + -- N_Star_Repeat_Seq (Short) + -- N_Goto_Repeat_Seq (Short) + -- N_Equal_Repeat_Seq (Short) + -- + -- Note: can be null_node for star_repeat_seq. + -- Get/Set_Sequence (Field3) + -- + -- Get/Set_Low_Bound (Field1) + -- + -- Get/Set_High_Bound (Field2) + + -- N_Plus_Repeat_Seq (Short) + -- + -- Note: can be null_node. + -- Get/Set_Sequence (Field3) + + -- N_Match_And_Seq (Short) + -- N_And_Seq (Short) + -- N_Or_Seq (Short) + -- + -- Get/Set_Left (Field1) + -- + -- Get/Set_Right (Field2) + + -- N_Imp_Seq (Short) + -- N_Overlap_Imp_Seq (Short) + -- + -- Get/Set_Sequence (Field3) + -- + -- Get/Set_Property (Field4) + + -- N_Log_Imp_Prop (Short) + -- + -- Get/Set_Left (Field1) + -- + -- Get/Set_Right (Field2) + + -- N_Next_A (Short) + -- N_Next_E (Short) + -- + -- Get/Set_Strong_Flag (Flag1) + -- + -- Get/Set_Low_Bound (Field1) + -- + -- Get/Set_High_Bound (Field2) + -- + -- Get/Set_Property (Field4) + + -- N_Next_Event (Short) + -- + -- Get/Set_Strong_Flag (Flag1) + -- + -- Get/Set_Number (Field1) + -- + -- Get/Set_Property (Field4) + -- + -- Get/Set_Boolean (Field3) + + -- N_Or_Prop (Short) + -- N_And_Prop (Short) + -- + -- Get/Set_Left (Field1) + -- + -- Get/Set_Right (Field2) + + -- N_Until (Short) + -- N_Before (Short) + -- + -- Get/Set_Strong_Flag (Flag1) + -- + -- Get/Set_Inclusive_Flag (Flag2) + -- + -- Get/Set_Left (Field1) + -- + -- Get/Set_Right (Field2) + + -- N_Next_Event_A (Short) + -- N_Next_Event_E (Short) + -- + -- Get/Set_Strong_Flag (Flag1) + -- + -- Get/Set_Low_Bound (Field1) + -- + -- Get/Set_High_Bound (Field2) + -- + -- Get/Set_Property (Field4) + -- + -- Get/Set_Boolean (Field3) + + -- N_Abort (Short) + -- + -- Get/Set_Property (Field4) + -- + -- Get/Set_Boolean (Field3) + + + -- N_HDL_Expr (Short) + -- + -- Get/Set_Presence (State1) + -- + -- Get/Set_HDL_Node (Field1) + -- + -- Get/Set_HDL_Index (Field2) + -- + -- Get/Set_Hash (Field5) + -- + -- Get/Set_Hash_Link (Field6) + + -- N_Not_Bool (Short) + -- + -- Get/Set_Presence (State1) + -- + -- Get/Set_Boolean (Field3) + -- + -- Get/Set_Hash (Field5) + -- + -- Get/Set_Hash_Link (Field6) + + -- N_And_Bool (Short) + -- N_Or_Bool (Short) + -- N_Imp_Bool (Short) + -- + -- Get/Set_Presence (State1) + -- + -- Get/Set_Left (Field1) + -- + -- Get/Set_Right (Field2) + -- + -- Get/Set_Hash (Field5) + -- + -- Get/Set_Hash_Link (Field6) + + -- N_True (Short) + -- N_False (Short) + + -- N_EOS (Short) + -- End of simulation. + -- + -- Get/Set_HDL_Index (Field2) + -- + -- Get/Set_Hash (Field5) + -- + -- Get/Set_Hash_Link (Field6) + + -- End of nodes. + + subtype Node is Types.PSL_Node; + + Null_Node : constant Node := 0; + False_Node : constant Node := 1; + True_Node : constant Node := 2; + One_Node : constant Node := 3; + EOS_Node : constant Node := 4; + + subtype NFA is Types.PSL_NFA; + + subtype HDL_Node is Types.Int32; + HDL_Null : constant HDL_Node := 0; + + procedure Init; + + -- Get the number of the last node. + -- To be used to size lateral tables. + function Get_Last_Node return Node; + + -- subtype Regs_Type_Node is Node range Reg_Type_Node .. Time_Type_Node; + + function Create_Node (Kind : Nkind) return Node; + procedure Free_Node (N : Node); + + -- Return the type of a node. + function Get_Psl_Type (N : Node) return PSL_Types; + + -- Field: Location + function Get_Location (N : Node) return Location_Type; + procedure Set_Location (N : Node; Loc : Location_Type); + + function Get_Kind (N : Node) return Nkind; + pragma Inline (Get_Kind); + +-- -- Disp: None +-- -- Field: Field6 +-- function Get_Parent (N : Node) return Node; +-- procedure Set_Parent (N : Node; Parent : Node); + + -- Disp: Special + -- Field: Field1 (conv) + function Get_Identifier (N : Node) return Name_Id; + procedure Set_Identifier (N : Node; Id : Name_Id); + + -- Disp: Special + -- Field: Field1 (conv) + function Get_Label (N : Node) return Name_Id; + procedure Set_Label (N : Node; Id : Name_Id); + + -- Disp: Chain + -- Field: Field2 (conv) + function Get_Chain (N : Node) return Node; + procedure Set_Chain (N : Node; Chain : Node); + + -- Field: Field3 (conv) + function Get_Instance (N : Node) return Node; + procedure Set_Instance (N : Node; Instance : Node); + + -- Field: Field2 (conv) + function Get_Prefix (N : Node) return Node; + procedure Set_Prefix (N : Node; Prefix : Node); + + -- Field: Field4 (conv) + function Get_Item_Chain (N : Node) return Node; + procedure Set_Item_Chain (N : Node; Item : Node); + + -- Field: Field4 (conv) + function Get_Property (N : Node) return Node; + procedure Set_Property (N : Node; Property : Node); + + -- Field: Field3 (conv) + function Get_String (N : Node) return Node; + procedure Set_String (N : Node; Str : Node); + + -- Field: Field1 (conv) + function Get_SERE (N : Node) return Node; + procedure Set_SERE (N : Node; S : Node); + + -- Field: Field1 (conv) + function Get_Left (N : Node) return Node; + procedure Set_Left (N : Node; S : Node); + + -- Field: Field2 (conv) + function Get_Right (N : Node) return Node; + procedure Set_Right (N : Node; S : Node); + + -- Field: Field3 (conv) + function Get_Sequence (N : Node) return Node; + procedure Set_Sequence (N : Node; S : Node); + + -- Field: Flag1 + function Get_Strong_Flag (N : Node) return Boolean; + procedure Set_Strong_Flag (N : Node; B : Boolean); + + -- Field: Flag2 + function Get_Inclusive_Flag (N : Node) return Boolean; + procedure Set_Inclusive_Flag (N : Node; B : Boolean); + + -- Field: Field1 (conv) + function Get_Low_Bound (N : Node) return Node; + procedure Set_Low_Bound (N : Node; S : Node); + + -- Field: Field2 (conv) + function Get_High_Bound (N : Node) return Node; + procedure Set_High_Bound (N : Node; S : Node); + + -- Field: Field1 (conv) + function Get_Number (N : Node) return Node; + procedure Set_Number (N : Node; S : Node); + + -- Field: Field1 (uc) + function Get_Value (N : Node) return Uns32; + procedure Set_Value (N : Node; Val : Uns32); + + -- Field: Field3 (conv) + function Get_Boolean (N : Node) return Node; + procedure Set_Boolean (N : Node; B : Node); + + -- Field: Field2 (conv) + function Get_Decl (N : Node) return Node; + procedure Set_Decl (N : Node; D : Node); + + -- Field: Field1 + function Get_HDL_Node (N : Node) return HDL_Node; + procedure Set_HDL_Node (N : Node; H : HDL_Node); + + -- Field: Field5 (uc) + function Get_Hash (N : Node) return Uns32; + procedure Set_Hash (N : Node; E : Uns32); + pragma Inline (Get_Hash); + + -- Field: Field6 (conv) + function Get_Hash_Link (N : Node) return Node; + procedure Set_Hash_Link (N : Node; E : Node); + pragma Inline (Get_Hash_Link); + + -- Field: Field2 + function Get_HDL_Index (N : Node) return Int32; + procedure Set_HDL_Index (N : Node; Idx : Int32); + + -- Field: State1 (pos) + function Get_Presence (N : Node) return PSL_Presence_Kind; + procedure Set_Presence (N : Node; P : PSL_Presence_Kind); + + -- Field: Field5 (uc) + function Get_NFA (N : Node) return NFA; + procedure Set_NFA (N : Node; P : NFA); + + -- Field: Field5 (conv) + function Get_Parameter_List (N : Node) return Node; + procedure Set_Parameter_List (N : Node; E : Node); + + -- Field: Field3 (conv) + function Get_Actual (N : Node) return Node; + procedure Set_Actual (N : Node; E : Node); + + -- Field: Field4 (conv) + function Get_Formal (N : Node) return Node; + procedure Set_Formal (N : Node; E : Node); + + -- Field: Field1 (conv) + function Get_Declaration (N : Node) return Node; + procedure Set_Declaration (N : Node; Decl : Node); + + -- Field: Field2 (conv) + function Get_Association_Chain (N : Node) return Node; + procedure Set_Association_Chain (N : Node; Chain : Node); + + -- Field: Field3 (conv) + function Get_Global_Clock (N : Node) return Node; + procedure Set_Global_Clock (N : Node; Clock : Node); +end PSL.Nodes; diff --git a/psl/psl-optimize.adb b/psl/psl-optimize.adb new file mode 100644 index 000000000..4ca62b89e --- /dev/null +++ b/psl/psl-optimize.adb @@ -0,0 +1,460 @@ +with Types; use Types; +with PSL.NFAs.Utils; use PSL.NFAs.Utils; +with PSL.CSE; + +package body PSL.Optimize is + procedure Push (Head : in out NFA_State; S : NFA_State) is + begin + Set_State_User_Link (S, Head); + Head := S; + end Push; + + procedure Pop (Head : in out NFA_State; S : out NFA_State) is + begin + S := Head; + Head := Get_State_User_Link (S); + end Pop; + + procedure Remove_Unreachable_States (N : NFA) + is + Head : NFA_State; + Start, Final : NFA_State; + E : NFA_Edge; + S, N_S : NFA_State; + begin + -- Remove unreachable states, ie states that can't be reached from + -- start state. + Start := Get_Start_State (N); + Final := Get_Final_State (N); + + Head := No_State; + + -- The start state is reachable. + Push (Head, Start); + Set_State_Flag (Start, True); + + -- Follow edges and mark reachable states. + while Head /= No_State loop + Pop (Head, S); + E := Get_First_Src_Edge (S); + while E /= No_Edge loop + S := Get_Edge_Dest (E); + if not Get_State_Flag (S) then + Push (Head, S); + Set_State_Flag (S, True); + end if; + E := Get_Next_Src_Edge (E); + end loop; + end loop; + + -- Remove unreachable states. + S := Get_First_State (N); + while S /= No_State loop + N_S := Get_Next_State (S); + if Get_State_Flag (S) then + -- Clean-up. + Set_State_Flag (S, False); + elsif S = Final then + -- Do not remove final state! + -- FIXME: deconnect state? + null; + else + Remove_State (N, S); + end if; + S := N_S; + end loop; + + -- Remove no-where states, ie states that can't reach the final state. + Head := No_State; + + -- The final state can reach the final state. + Push (Head, Final); + Set_State_Flag (Final, True); + + -- Follow edges and mark reachable states. + while Head /= No_State loop + Pop (Head, S); + E := Get_First_Dest_Edge (S); + while E /= No_Edge loop + S := Get_Edge_Src (E); + if not Get_State_Flag (S) then + Push (Head, S); + Set_State_Flag (S, True); + end if; + E := Get_Next_Dest_Edge (E); + end loop; + end loop; + + -- Remove unreachable states. + S := Get_First_State (N); + while S /= No_State loop + N_S := Get_Next_State (S); + if Get_State_Flag (S) then + -- Clean-up. + Set_State_Flag (S, False); + elsif S = Start then + -- Do not remove start state! + -- FIXME: deconnect state? + null; + else + Remove_State (N, S); + end if; + S := N_S; + end loop; + end Remove_Unreachable_States; + + procedure Remove_Simple_Prefix (N : NFA) + is + Start : NFA_State; + D : NFA_State; + T_Start, T_D, Next_T_D : NFA_Edge; + T_Expr : Node; + Clean : Boolean := False; + begin + Start := Get_Start_State (N); + + -- Iterate on edges from the start state. + T_Start := Get_First_Src_Edge (Start); + while T_Start /= No_Edge loop + -- Edge destination. + D := Get_Edge_Dest (T_Start); + T_Expr := Get_Edge_Expr (T_Start); + + -- Iterate on destination incoming edges. + T_D := Get_First_Dest_Edge (D); + while T_D /= No_Edge loop + Next_T_D := Get_Next_Dest_Edge (T_D); + -- Remove parallel edge. + if T_D /= T_Start + and then Get_Edge_Expr (T_D) = T_Expr + then + Remove_Edge (T_D); + Clean := True; + end if; + T_D := Next_T_D; + end loop; + T_Start := Get_Next_Src_Edge (T_Start); + end loop; + if Clean then + Remove_Unreachable_States (N); + end if; + end Remove_Simple_Prefix; + + -- Return TRUE iff the outgoing or incoming edges of L and R are the same. + -- Outgoing edges must be sorted. + generic + with function Get_First_Edge (S : NFA_State) return NFA_Edge; + with function Get_Next_Edge (E : NFA_Edge) return NFA_Edge; + with function Get_Edge_State_Reverse (E : NFA_Edge) return NFA_State; + function Are_States_Identical_Gen (L, R : NFA_State) return Boolean; + + function Are_States_Identical_Gen (L, R : NFA_State) return Boolean + is + L_E, R_E : NFA_Edge; + L_S, R_S : NFA_State; + begin + L_E := Get_First_Edge (L); + R_E := Get_First_Edge (R); + loop + if L_E = No_Edge and then R_E = No_Edge then + -- End of chain for both L and R -> identical states. + return True; + elsif L_E = No_Edge or R_E = No_Edge then + -- End of chain for either L or R -> non identical states. + return False; + elsif Get_Edge_Expr (L_E) /= Get_Edge_Expr (R_E) then + -- Different edge (different expressions). + return False; + end if; + L_S := Get_Edge_State_Reverse (L_E); + R_S := Get_Edge_State_Reverse (R_E); + if L_S /= R_S and then (L_S /= L or else R_S /= R) then + -- Predecessors are differents and not loop. + return False; + end if; + L_E := Get_Next_Edge (L_E); + R_E := Get_Next_Edge (R_E); + end loop; + end Are_States_Identical_Gen; + + generic + with procedure Sort_Edges (N : NFA); + with procedure Sort_Edges_Reverse (S : NFA_State); + with function Get_First_Edge (S : NFA_State) return NFA_Edge; + with function Get_Next_Edge (E : NFA_Edge) return NFA_Edge; + with function Get_First_Edge_Reverse (S : NFA_State) return NFA_Edge; + with function Get_Next_Edge_Reverse (E : NFA_Edge) return NFA_Edge; + with function Get_Edge_State (E : NFA_Edge) return NFA_State; + with function Get_Edge_State_Reverse (E : NFA_Edge) return NFA_State; + with procedure Merge_State_Reverse (N : NFA; + S : NFA_State; S1 : NFA_State); + procedure Merge_Identical_States_Gen (N : NFA); + + procedure Merge_Identical_States_Gen (N : NFA) + is + function Are_States_Identical is new Are_States_Identical_Gen + (Get_First_Edge => Get_First_Edge, + Get_Next_Edge => Get_Next_Edge, + Get_Edge_State_Reverse => Get_Edge_State_Reverse); + + S : NFA_State; + E : NFA_Edge; + E_State, Next_E_State : NFA_State; + Next_E, Next_Next_E : NFA_Edge; + begin + Sort_Edges (N); + + -- Iterate on states. + S := Get_First_State (N); + while S /= No_State loop + Sort_Edges_Reverse (S); + + -- Iterate on incoming edges. + E := Get_First_Edge_Reverse (S); + while E /= No_Edge loop + E_State := Get_Edge_State (E); + + -- Try to merge E with its successors. + Next_E := Get_Next_Edge_Reverse (E); + while Next_E /= No_Edge + and then Get_Edge_Expr (E) = Get_Edge_Expr (Next_E) + loop + Next_E_State := Get_Edge_State (Next_E); + Next_Next_E := Get_Next_Edge_Reverse (Next_E); + if Next_E_State = E_State then + -- Identical edge: remove the duplicate. + Remove_Edge (Next_E); + elsif Are_States_Identical (E_State, Next_E_State) then + Merge_State_Reverse (N, E_State, Next_E_State); + end if; + Next_E := Next_Next_E; + end loop; + + E := Get_Next_Edge_Reverse (E); + end loop; + + S := Get_Next_State (S); + end loop; + end Merge_Identical_States_Gen; + + procedure Merge_Identical_States_Src is new Merge_Identical_States_Gen + (Sort_Edges => Sort_Src_Edges, + Sort_Edges_Reverse => Sort_Dest_Edges, + Get_First_Edge => Get_First_Src_Edge, + Get_Next_Edge => Get_Next_Src_Edge, + Get_First_Edge_Reverse => Get_First_Dest_Edge, + Get_Next_Edge_Reverse => Get_Next_Dest_Edge, + Get_Edge_State => Get_Edge_Src, + Get_Edge_State_Reverse => Get_Edge_Dest, + Merge_State_Reverse => Merge_State_Dest); + + procedure Merge_Identical_States_Dest is new Merge_Identical_States_Gen + (Sort_Edges => Sort_Dest_Edges, + Sort_Edges_Reverse => Sort_Src_Edges, + Get_First_Edge => Get_First_Dest_Edge, + Get_Next_Edge => Get_Next_Dest_Edge, + Get_First_Edge_Reverse => Get_First_Src_Edge, + Get_Next_Edge_Reverse => Get_Next_Src_Edge, + Get_Edge_State => Get_Edge_Dest, + Get_Edge_State_Reverse => Get_Edge_Src, + Merge_State_Reverse => Merge_State_Src); + + procedure Merge_Identical_States (N : NFA) is + begin + Merge_Identical_States_Src (N); + Merge_Identical_States_Dest (N); + end Merge_Identical_States; + + procedure Merge_Edges (N : NFA) + is + use PSL.CSE; + Nbr_States : Natural; + begin + Labelize_States (N, Nbr_States); + declare + Last_State : constant Int32 := Int32 (Nbr_States) - 1; + type Edge_Array is array (0 .. Last_State) of NFA_Edge; + Edges : Edge_Array; + S, D : NFA_State; + L_D : Int32; + E, Next_E : NFA_Edge; + begin + -- Iterate on states. + S := Get_First_State (N); + while S /= No_State loop + + Edges := (others => No_Edge); + E := Get_First_Src_Edge (S); + while E /= No_Edge loop + Next_E := Get_Next_Src_Edge (E); + D := Get_Edge_Dest (E); + L_D := Get_State_Label (D); + if Edges (L_D) /= No_Edge then + Set_Edge_Expr + (Edges (L_D), + Build_Bool_Or (Get_Edge_Expr (Edges (L_D)), + Get_Edge_Expr (E))); + -- FIXME: reduce expression. + Remove_Edge (E); + else + Edges (L_D) := E; + end if; + E := Next_E; + end loop; + + S := Get_Next_State (S); + end loop; + end; + end Merge_Edges; + + procedure Remove_Identical_Src_Edges (S : NFA_State) + is + Next_E, E : NFA_Edge; + begin + Sort_Src_Edges (S); + E := Get_First_Src_Edge (S); + if E = No_Edge then + return; + end if; + loop + Next_E := Get_Next_Src_Edge (E); + exit when Next_E = No_Edge; + if Get_Edge_Dest (E) = Get_Edge_Dest (Next_E) + and then Get_Edge_Expr (E) = Get_Edge_Expr (Next_E) + then + Remove_Edge (Next_E); + else + E := Next_E; + end if; + end loop; + end Remove_Identical_Src_Edges; + + procedure Remove_Identical_Dest_Edges (S : NFA_State) + is + Next_E, E : NFA_Edge; + begin + Sort_Dest_Edges (S); + E := Get_First_Dest_Edge (S); + if E = No_Edge then + return; + end if; + loop + Next_E := Get_Next_Dest_Edge (E); + exit when Next_E = No_Edge; + if Get_Edge_Src (E) = Get_Edge_Src (Next_E) + and then Get_Edge_Expr (E) = Get_Edge_Expr (Next_E) + then + Remove_Edge (Next_E); + else + E := Next_E; + end if; + end loop; + end Remove_Identical_Dest_Edges; + + procedure Find_Partitions (N : NFA; Nbr_States : Natural) + is + Last_State : constant NFA_State := NFA_State (Nbr_States) - 1; + type Part_Offset is new Int32 range -1 .. Nat32 (Nbr_States - 1); + type Part_Id is new Part_Offset range 0 .. Part_Offset'Last; + + -- State to partition id. + State_Part : array (0 .. Last_State) of Part_Id; + pragma Unreferenced (State_Part); + + -- Last partition index. + Last_Part : Part_Id; + + -- Partitions content. + + -- To get the states in a partition P, first get the offset OFF + -- (from Offsets) of P. States are in Parts (OFF ...). The + -- number of states is not known, but they all belong to P + -- (check with STATE_PART). + Parts : array (Part_Offset) of NFA_State; + type Offset_Array is array (Part_Id) of Part_Offset; + Start_Offsets : Offset_Array; + Last_Offsets : Offset_Array; + + S, Final_State : NFA_State; + First_S : NFA_State; + Off, Last_Off : Part_Offset; + + Stable, Stable1 : Boolean; + + function Is_Equivalent (L, R : NFA_State) return Boolean is + begin + raise Program_Error; + return False; + end Is_Equivalent; + begin + -- Return now for trivial cases (0 or 1 state). + if Nbr_States < 2 then + return; + end if; + + -- Partition 1 contains the final state. + -- Partition 0 contains the other states. + Final_State := Get_Final_State (N); + Last_Part := 1; + State_Part := (others => 0); + State_Part (Final_State) := 1; + S := Get_First_State (N); + Off := -1; + while S /= No_State loop + if S /= Last_State then + Off := Off + 1; + Parts (Off) := S; + end if; + S := Get_Next_State (S); + end loop; + Start_Offsets (0) := 0; + Last_Offsets (0) := Off; + Start_Offsets (1) := Off + 1; + Last_Offsets (1) := Off + 1; + Parts (Off + 1) := Final_State; + + -- Now the hard work. + loop + Stable := True; + -- For every partition + for P in 0 .. Last_Part loop + Off := Start_Offsets (P); + First_S := Parts (Off); + Off := Off + 1; + + -- For every S != First_S in P. + Last_Off := Last_Offsets (P); + Stable1 := True; + while Off <= Last_Off loop + S := Parts (Off); + + if not Is_Equivalent (First_S, S) then + -- Swap S with the last element of the partition. + Parts (Off) := Parts (Last_Off); + Parts (Last_Off) := S; + -- Reduce partition size. + Last_Off := Last_Off - 1; + Last_Offsets (P) := Last_Off; + + if Stable1 then + -- Create a new partition. + Last_Part := Last_Part + 1; + Last_Offsets (Last_Part) := Last_Off + 1; + Stable1 := False; + end if; + -- Put S in the new partition. + Start_Offsets (Last_Part) := Last_Off + 1; + State_Part (S) := Last_Part; + Stable := False; + + -- And continue with the swapped state. + else + Off := Off + 1; + end if; + end loop; + end loop; + exit when Stable; + end loop; + end Find_Partitions; + pragma Unreferenced (Find_Partitions); +end PSL.Optimize; diff --git a/psl/psl-optimize.ads b/psl/psl-optimize.ads new file mode 100644 index 000000000..5f36a0739 --- /dev/null +++ b/psl/psl-optimize.ads @@ -0,0 +1,24 @@ +with PSL.NFAs; use PSL.NFAs; +with PSL.Nodes; use PSL.Nodes; + +package PSL.Optimize is + -- Remove unreachable states, ie + -- * states that can't be reach from the start state. + -- * states that can't reach the final state. + -- O(N) algorithm. + procedure Remove_Unreachable_States (N : NFA); + + -- Remove single prefix, ie edges to a state S that is also from start + -- to S. + -- O(M) algorithm. + procedure Remove_Simple_Prefix (N : NFA); + + procedure Merge_Identical_States (N : NFA); + + procedure Merge_Edges (N : NFA); + + procedure Remove_Identical_Src_Edges (S : NFA_State); + procedure Remove_Identical_Dest_Edges (S : NFA_State); + + --procedure Find_Partitions (N : NFA; Nbr_States : Natural); +end PSL.Optimize; diff --git a/psl/psl-prints.adb b/psl/psl-prints.adb new file mode 100644 index 000000000..6e4f37022 --- /dev/null +++ b/psl/psl-prints.adb @@ -0,0 +1,428 @@ +with Types; use Types; +with PSL.Errors; use PSL.Errors; +with Name_Table; use Name_Table; +with Ada.Text_IO; use Ada.Text_IO; + +package body PSL.Prints is + function Get_Priority (N : Node) return Priority is + begin + case Get_Kind (N) is + when N_Never | N_Always => + return Prio_FL_Invariance; + when N_Eventually + | N_Next + | N_Next_A + | N_Next_E + | N_Next_Event + | N_Next_Event_A + | N_Next_Event_E => + return Prio_FL_Occurence; + when N_Braced_SERE => + return Prio_SERE_Brace; + when N_Concat_SERE => + return Prio_Seq_Concat; + when N_Fusion_SERE => + return Prio_Seq_Fusion; + when N_Within_SERE => + return Prio_Seq_Within; + when N_Match_And_Seq + | N_And_Seq => + return Prio_Seq_And; + when N_Or_Seq => + return Prio_Seq_Or; + when N_Until + | N_Before => + return Prio_FL_Bounding; + when N_Abort => + return Prio_FL_Abort; + when N_Or_Prop => + return Prio_Seq_Or; + when N_And_Prop => + return Prio_Seq_And; + when N_Imp_Seq + | N_Overlap_Imp_Seq + | N_Log_Imp_Prop => + return Prio_Bool_Imp; + when N_Name_Decl + | N_Number + | N_True + | N_False + | N_EOS + | N_HDL_Expr => + return Prio_HDL; + when N_Or_Bool => + return Prio_Seq_Or; + when N_And_Bool => + return Prio_Seq_And; + when N_Not_Bool => + return Prio_Bool_Not; + when N_Star_Repeat_Seq + | N_Goto_Repeat_Seq + | N_Equal_Repeat_Seq + | N_Plus_Repeat_Seq => + return Prio_SERE_Repeat; + when N_Strong => + return Prio_Strong; + when others => + Error_Kind ("get_priority", N); + end case; + end Get_Priority; + + procedure Print_HDL_Expr (N : HDL_Node) is + begin + Put (Image (Get_Identifier (Node (N)))); + end Print_HDL_Expr; + + procedure Dump_Expr (N : Node) + is + begin + case Get_Kind (N) is + when N_HDL_Expr => + if HDL_Expr_Printer = null then + Put ("Expr"); + else + HDL_Expr_Printer.all (Get_HDL_Node (N)); + end if; + when N_True => + Put ("TRUE"); + when N_False => + Put ("FALSE"); + when N_Not_Bool => + Put ("!"); + Dump_Expr (Get_Boolean (N)); + when N_And_Bool => + Put ("("); + Dump_Expr (Get_Left (N)); + Put (" && "); + Dump_Expr (Get_Right (N)); + Put (")"); + when N_Or_Bool => + Put ("("); + Dump_Expr (Get_Left (N)); + Put (" || "); + Dump_Expr (Get_Right (N)); + Put (")"); + when others => + PSL.Errors.Error_Kind ("dump_expr", N); + end case; + end Dump_Expr; + + procedure Print_Expr (N : Node; Parent_Prio : Priority := Prio_Lowest) + is + Prio : Priority; + begin + if N = Null_Node then + Put ("."); + return; + end if; + Prio := Get_Priority (N); + if Prio < Parent_Prio then + Put ("("); + end if; + case Get_Kind (N) is + when N_Number => + declare + Str : constant String := Uns32'Image (Get_Value (N)); + begin + Put (Str (2 .. Str'Last)); + end; + when N_Name_Decl => + Put (Image (Get_Identifier (N))); + when N_HDL_Expr => + if HDL_Expr_Printer = null then + Put ("HDL_Expr"); + else + HDL_Expr_Printer.all (Get_HDL_Node (N)); + end if; + -- FIXME: this is true only when using the scanner. + -- Print_Expr (Node (Get_HDL_Node (N))); + when N_True => + Put ("TRUE"); + when N_False => + Put ("FALSE"); + when N_EOS => + Put ("EOS"); + when N_Not_Bool => + Put ("!"); + Print_Expr (Get_Boolean (N), Prio); + when N_And_Bool => + Print_Expr (Get_Left (N), Prio); + Put (" && "); + Print_Expr (Get_Right (N), Prio); + when N_Or_Bool => + Print_Expr (Get_Left (N), Prio); + Put (" || "); + Print_Expr (Get_Right (N), Prio); + when others => + Error_Kind ("print_expr", N); + end case; + if Prio < Parent_Prio then + Put (")"); + end if; + end Print_Expr; + + procedure Print_Sequence (Seq : Node; Parent_Prio : Priority); + + procedure Print_Count (N : Node) is + B : Node; + begin + B := Get_Low_Bound (N); + if B = Null_Node then + return; + end if; + Print_Expr (B); + B := Get_High_Bound (N); + if B = Null_Node then + return; + end if; + Put (":"); + Print_Expr (B); + end Print_Count; + + procedure Print_Binary_Sequence (Name : String; N : Node; Prio : Priority) + is + begin + Print_Sequence (Get_Left (N), Prio); + Put (Name); + Print_Sequence (Get_Right (N), Prio); + end Print_Binary_Sequence; + + procedure Print_Repeat_Sequence (Name : String; N : Node) is + S : Node; + begin + S := Get_Sequence (N); + if S /= Null_Node then + Print_Sequence (S, Prio_SERE_Repeat); + end if; + Put (Name); + Print_Count (N); + Put ("]"); + end Print_Repeat_Sequence; + + procedure Print_Sequence (Seq : Node; Parent_Prio : Priority) + is + Prio : constant Priority := Get_Priority (Seq); + Add_Paren : constant Boolean := Prio < Parent_Prio + or else Parent_Prio <= Prio_FL_Paren; + begin + if Add_Paren then + Put ("{"); + end if; + case Get_Kind (Seq) is + when N_Braced_SERE => + Put ("{"); + Print_Sequence (Get_SERE (Seq), Prio_Lowest); + Put ("}"); + when N_Concat_SERE => + Print_Binary_Sequence (";", Seq, Prio); + when N_Fusion_SERE => + Print_Binary_Sequence (":", Seq, Prio); + when N_Within_SERE => + Print_Binary_Sequence (" within ", Seq, Prio); + when N_Match_And_Seq => + Print_Binary_Sequence (" && ", Seq, Prio); + when N_Or_Seq => + Print_Binary_Sequence (" | ", Seq, Prio); + when N_And_Seq => + Print_Binary_Sequence (" & ", Seq, Prio); + when N_Star_Repeat_Seq => + Print_Repeat_Sequence ("[*", Seq); + when N_Goto_Repeat_Seq => + Print_Repeat_Sequence ("[->", Seq); + when N_Equal_Repeat_Seq => + Print_Repeat_Sequence ("[=", Seq); + when N_Plus_Repeat_Seq => + Print_Sequence (Get_Sequence (Seq), Prio); + Put ("[+]"); + when N_Booleans + | N_Name_Decl => + Print_Expr (Seq); + when others => + Error_Kind ("print_sequence", Seq); + end case; + if Add_Paren then + Put ("}"); + end if; + end Print_Sequence; + + procedure Print_Binary_Property (Name : String; N : Node; Prio : Priority) + is + begin + Print_Property (Get_Left (N), Prio); + Put (Name); + Print_Property (Get_Right (N), Prio); + end Print_Binary_Property; + + procedure Print_Binary_Property_SI (Name : String; + N : Node; Prio : Priority) + is + begin + Print_Property (Get_Left (N), Prio); + Put (Name); + if Get_Strong_Flag (N) then + Put ('!'); + end if; + if Get_Inclusive_Flag (N) then + Put ('_'); + end if; + Put (' '); + Print_Property (Get_Right (N), Prio); + end Print_Binary_Property_SI; + + procedure Print_Range_Property (Name : String; N : Node) is + begin + Put (Name); + Put ("["); + Print_Count (N); + Put ("]("); + Print_Property (Get_Property (N), Prio_FL_Paren); + Put (")"); + end Print_Range_Property; + + procedure Print_Boolean_Range_Property (Name : String; N : Node) is + begin + Put (Name); + Put ("("); + Print_Expr (Get_Boolean (N)); + Put (")["); + Print_Count (N); + Put ("]("); + Print_Property (Get_Property (N), Prio_FL_Paren); + Put (")"); + end Print_Boolean_Range_Property; + + procedure Print_Property (Prop : Node; + Parent_Prio : Priority := Prio_Lowest) + is + Prio : constant Priority := Get_Priority (Prop); + begin + if Prio < Parent_Prio then + Put ("("); + end if; + case Get_Kind (Prop) is + when N_Never => + Put ("never "); + Print_Property (Get_Property (Prop), Prio); + when N_Always => + Put ("always ("); + Print_Property (Get_Property (Prop), Prio); + Put (")"); + when N_Eventually => + Put ("eventually! ("); + Print_Property (Get_Property (Prop), Prio); + Put (")"); + when N_Strong => + Print_Property (Get_Property (Prop), Prio); + Put ("!"); + when N_Next => + Put ("next"); +-- if Get_Strong_Flag (Prop) then +-- Put ('!'); +-- end if; + Put (" ("); + Print_Property (Get_Property (Prop), Prio); + Put (")"); + when N_Next_A => + Print_Range_Property ("next_a", Prop); + when N_Next_E => + Print_Range_Property ("next_e", Prop); + when N_Next_Event => + Put ("next_event"); + Put ("("); + Print_Expr (Get_Boolean (Prop)); + Put (")("); + Print_Property (Get_Property (Prop), Prio); + Put (")"); + when N_Next_Event_A => + Print_Boolean_Range_Property ("next_event_a", Prop); + when N_Next_Event_E => + Print_Boolean_Range_Property ("next_event_e", Prop); + when N_Until => + Print_Binary_Property_SI (" until", Prop, Prio); + when N_Abort => + Print_Property (Get_Property (Prop), Prio); + Put (" abort "); + Print_Expr (Get_Boolean (Prop)); + when N_Before => + Print_Binary_Property_SI (" before", Prop, Prio); + when N_Or_Prop => + Print_Binary_Property (" || ", Prop, Prio); + when N_And_Prop => + Print_Binary_Property (" && ", Prop, Prio); + when N_Imp_Seq => + Print_Property (Get_Sequence (Prop), Prio); + Put (" |=> "); + Print_Property (Get_Property (Prop), Prio); + when N_Overlap_Imp_Seq => + Print_Property (Get_Sequence (Prop), Prio); + Put (" |-> "); + Print_Property (Get_Property (Prop), Prio); + when N_Log_Imp_Prop => + Print_Binary_Property (" -> ", Prop, Prio); + when N_Booleans + | N_Name_Decl => + Print_Expr (Prop); + when N_Sequences => + Print_Sequence (Prop, Parent_Prio); + when others => + Error_Kind ("print_property", Prop); + end case; + if Prio < Parent_Prio then + Put (")"); + end if; + end Print_Property; + + procedure Print_Assert (N : Node) is + Label : Name_Id; + begin + Put (" "); + Label := Get_Label (N); + if Label /= Null_Identifier then + Put (Image (Label)); + Put (": "); + end if; + Put ("assert "); + Print_Property (Get_Property (N)); + Put_Line (";"); + end Print_Assert; + + procedure Print_Property_Declaration (N : Node) is + begin + Put (" "); + Put ("property "); + Put (Image (Get_Identifier (N))); + Put (" = "); + Print_Property (Get_Property (N)); + Put_Line (";"); + end Print_Property_Declaration; + + procedure Print_Unit (Unit : Node) is + Item : Node; + begin + case Get_Kind (Unit) is + when N_Vunit => + Put ("vunit"); + when others => + Error_Kind ("disp_unit", Unit); + end case; + Put (' '); + Put (Image (Get_Identifier (Unit))); + Put_Line (" {"); + Item := Get_Item_Chain (Unit); + while Item /= Null_Node loop + case Get_Kind (Item) is + when N_Name_Decl => + null; + when N_Assert_Directive => + Print_Assert (Item); + when N_Property_Declaration => + Print_Property_Declaration (Item); + when others => + Error_Kind ("disp_unit", Item); + end case; + Item := Get_Chain (Item); + end loop; + Put_Line ("}"); + end Print_Unit; +end PSL.Prints; + diff --git a/psl/psl-prints.ads b/psl/psl-prints.ads new file mode 100644 index 000000000..18a36f78f --- /dev/null +++ b/psl/psl-prints.ads @@ -0,0 +1,20 @@ +with PSL.Nodes; use PSL.Nodes; +with PSL.Priorities; use PSL.Priorities; + +package PSL.Prints is + procedure Print_Unit (Unit : Node); + procedure Print_Property (Prop : Node; + Parent_Prio : Priority := Prio_Lowest); + procedure Print_Expr (N : Node; Parent_Prio : Priority := Prio_Lowest); + + -- Procedure to display HDL_Expr nodes. + type HDL_Expr_Printer_Acc is access procedure (N : HDL_Node); + HDL_Expr_Printer : HDL_Expr_Printer_Acc; + + procedure Print_HDL_Expr (N : HDL_Node); + + -- Like Print_Expr but always put parenthesis. + procedure Dump_Expr (N : Node); + +end PSL.Prints; + diff --git a/psl/psl-priorities.ads b/psl/psl-priorities.ads new file mode 100644 index 000000000..cb49239e4 --- /dev/null +++ b/psl/psl-priorities.ads @@ -0,0 +1,63 @@ +package PSL.Priorities is + -- Operator priorities, defined by PSL1.1 4.2.3.2 + type Priority is + ( + Prio_Lowest, + + -- always, never, G + Prio_FL_Invariance, + + -- ->, <-> + Prio_Bool_Imp, + + -- |->, |=> + Prio_Seq_Imp, + + -- U, W, until*, before* + Prio_FL_Bounding, + + -- next*, eventually!, X, X!, F + Prio_FL_Occurence, + + -- abort + Prio_FL_Abort, + + -- ( ) + Prio_FL_Paren, + + -- ; + Prio_Seq_Concat, + + -- : + Prio_Seq_Fusion, + + -- | + Prio_Seq_Or, + + -- &, && + Prio_Seq_And, + + -- within + Prio_Seq_Within, + + -- [*], [+], [=], [->] + Prio_SERE_Repeat, + + -- { } + Prio_SERE_Brace, + + -- @ + Prio_Clock_Event, + + -- ! + Prio_Strong, + + -- union + Prio_Union, + + -- ! + Prio_Bool_Not, + + Prio_HDL + ); +end PSL.Priorities; diff --git a/psl/psl-qm.adb b/psl/psl-qm.adb new file mode 100644 index 000000000..f5b5e1db3 --- /dev/null +++ b/psl/psl-qm.adb @@ -0,0 +1,318 @@ +with Ada.Text_IO; +with Types; use Types; +with PSL.Errors; use PSL.Errors; +with PSL.Prints; +with PSL.CSE; + +package body PSL.QM is + procedure Reset is + begin + for I in 1 .. Nbr_Terms loop + Set_HDL_Index (Term_Assoc (I), 0); + end loop; + Nbr_Terms := 0; + Term_Assoc := (others => Null_Node); + end Reset; + + function Term (P : Natural) return Vector_Type is + begin + return Shift_Left (1, P - 1); + end Term; + + procedure Disp_Primes_Set (Ps : Primes_Set) + is + use Ada.Text_IO; + use PSL.Prints; + Prime : Prime_Type; + T : Vector_Type; + First_Term : Boolean; + begin + if Ps.Nbr = 0 then + Put ("FALSE"); + return; + end if; + for I in 1 .. Ps.Nbr loop + Prime := Ps.Set (I); + if I /= 1 then + Put (" | "); + end if; + if Prime.Set = 0 then + Put ("TRUE"); + else + First_Term := True; + for J in 1 .. Max_Terms loop + T := Term (J); + if (Prime.Set and T) /= 0 then + if First_Term then + First_Term := False; + else + Put ('.'); + end if; + if (Prime.Val and T) = 0 then + Put ('!'); + end if; + Print_Expr (Term_Assoc (J)); + end if; + end loop; + end if; + end loop; + end Disp_Primes_Set; + + -- Return TRUE iff L includes R, ie + -- for all x, x in L => x in R. + function Included (L, R : Prime_Type) return Boolean is + begin + return ((L.Set or R.Set) = L.Set) + and then ((L.Val and R.Set) = (R.Val and R.Set)); + end Included; + + -- Return TRUE iff L and R have the same don't care set + -- and L and R can be merged into a new prime with a new don't care. + function Is_One_Change_Same (L, R : Prime_Type) return Boolean + is + V : Vector_Type; + begin + if L.Set /= R.Set then + return False; + end if; + V := L.Val xor R.Val; + return (V and -V) = V; + end Is_One_Change_Same; + + -- Return true iff L can add a new DC in R. + function Is_One_Change (L, R : Prime_Type) return Boolean + is + V : Vector_Type; + begin + if (L.Set or R.Set) /= R.Set then + return False; + end if; + V := (L.Val xor R.Val) and L.Set; + return (V and -V) = V; + end Is_One_Change; + + procedure Merge (Ps : in out Primes_Set; P : Prime_Type) + is + Do_Append : Boolean := True; + T : Prime_Type; + begin + for I in 1 .. Ps.Nbr loop + T := Ps.Set (I); + if Included (P, T) then + -- Already in the set. + return; + end if; + if Included (T, P) then + Ps.Set (I) := P; + Do_Append := False; + else + if Is_One_Change_Same (P, T) then + declare + V : constant Vector_Type := T.Val xor P.Val; + begin + Ps.Set (I).Set := T.Set and not V; + Ps.Set (I).Val := T.Val and not V; + end; + Do_Append := False; + end if; + if Is_One_Change (P, T) then + declare + V : constant Vector_Type := (T.Val xor P.Val) and P.Set; + begin + Ps.Set (I).Set := T.Set and not V; + Ps.Set (I).Val := T.Val and not V; + end; + -- continue. + end if; + end if; + end loop; + if Do_Append then + Ps.Nbr := Ps.Nbr + 1; + Ps.Set (Ps.Nbr) := P; + end if; + end Merge; + + function Build_Primes_And (L, R : Primes_Set) return Primes_Set + is + Res : Primes_Set (L.Nbr * R.Nbr); + L_P, R_P : Prime_Type; + P : Prime_Type; + begin + for I in 1 .. L.Nbr loop + L_P := L.Set (I); + for J in 1 .. R.Nbr loop + R_P := R.Set (J); + -- In case of conflict, discard. + if ((L_P.Val xor R_P.Val) and (L_P.Set and R_P.Set)) /= 0 then + null; + else + P.Set := L_P.Set or R_P.Set; + P.Val := (R_P.Set and R_P.Val) + or ((L_P.Set and not R_P.Set) and L_P.Val); + Merge (Res, P); + end if; + end loop; + end loop; + + return Res; + end Build_Primes_And; + + + function Build_Primes_Or (L, R : Primes_Set) return Primes_Set + is + Res : Primes_Set (L.Nbr + R.Nbr); + L_P, R_P : Prime_Type; + begin + for I in 1 .. L.Nbr loop + L_P := L.Set (I); + Merge (Res, L_P); + end loop; + for J in 1 .. R.Nbr loop + R_P := R.Set (J); + Merge (Res, R_P); + end loop; + + return Res; + end Build_Primes_Or; + + function Build_Primes (N : Node; Negate : Boolean) return Primes_Set is + begin + case Get_Kind (N) is + when N_HDL_Expr + | N_EOS => + declare + Res : Primes_Set (1); + Index : Int32; + T : Vector_Type; + begin + Index := Get_HDL_Index (N); + if Index = 0 then + Nbr_Terms := Nbr_Terms + 1; + if Nbr_Terms > Max_Terms then + raise Program_Error; + end if; + Term_Assoc (Nbr_Terms) := N; + Index := Int32 (Nbr_Terms); + Set_HDL_Index (N, Index); + else + if Index not in 1 .. Int32 (Nbr_Terms) + or else Term_Assoc (Natural (Index)) /= N + then + raise Internal_Error; + end if; + end if; + T := Term (Natural (Index)); + Res.Nbr := 1; + Res.Set (1).Set := T; + if Negate then + Res.Set (1).Val := 0; + else + Res.Set (1).Val := T; + end if; + return Res; + end; + when N_False => + declare + Res : Primes_Set (0); + begin + return Res; + end; + when N_True => + declare + Res : Primes_Set (1); + begin + Res.Nbr := 1; + Res.Set (1).Set := 0; + Res.Set (1).Val := 0; + return Res; + end; + when N_Not_Bool => + return Build_Primes (Get_Boolean (N), not Negate); + when N_And_Bool => + if Negate then + -- !(a & b) <-> !a || !b + return Build_Primes_Or (Build_Primes (Get_Left (N), True), + Build_Primes (Get_Right (N), True)); + else + return Build_Primes_And (Build_Primes (Get_Left (N), False), + Build_Primes (Get_Right (N), False)); + end if; + when N_Or_Bool => + if Negate then + -- !(a || b) <-> !a && !b + return Build_Primes_And (Build_Primes (Get_Left (N), True), + Build_Primes (Get_Right (N), True)); + else + return Build_Primes_Or (Build_Primes (Get_Left (N), False), + Build_Primes (Get_Right (N), False)); + end if; + when N_Imp_Bool => + if not Negate then + -- a -> b <-> !a || b + return Build_Primes_Or (Build_Primes (Get_Left (N), True), + Build_Primes (Get_Right (N), False)); + else + -- !(a -> b) <-> a && !b + return Build_Primes_And (Build_Primes (Get_Left (N), False), + Build_Primes (Get_Right (N), True)); + end if; + when others => + Error_Kind ("build_primes", N); + end case; + end Build_Primes; + + function Build_Primes (N : Node) return Primes_Set is + begin + return Build_Primes (N, False); + end Build_Primes; + + function Build_Node (P : Prime_Type) return Node + is + Res : Node := Null_Node; + N : Node; + S : Vector_Type := P.Set; + T : Vector_Type; + begin + if S = 0 then + return True_Node; + end if; + for I in Natural range 1 .. Vector_Type'Modulus loop + T := Term (I); + if (S and T) /= 0 then + N := Term_Assoc (I); + if (P.Val and T) = 0 then + N := PSL.CSE.Build_Bool_Not (N); + end if; + if Res = Null_Node then + Res := N; + else + Res := PSL.CSE.Build_Bool_And (Res, N); + end if; + S := S and not T; + exit when S = 0; + end if; + end loop; + return Res; + end Build_Node; + + function Build_Node (Ps : Primes_Set) return Node + is + Res : Node; + begin + if Ps.Nbr = 0 then + return False_Node; + else + Res := Build_Node (Ps.Set (1)); + for I in 2 .. Ps.Nbr loop + Res := PSL.CSE.Build_Bool_Or (Res, Build_Node (Ps.Set (I))); + end loop; + return Res; + end if; + end Build_Node; + + -- FIXME: finish the work: do a real Quine-McKluskey minimization. + function Reduce (N : Node) return Node is + begin + return Build_Node (Build_Primes (N)); + end Reduce; +end PSL.QM; diff --git a/psl/psl-qm.ads b/psl/psl-qm.ads new file mode 100644 index 000000000..85f1e3cf4 --- /dev/null +++ b/psl/psl-qm.ads @@ -0,0 +1,49 @@ +with PSL.Nodes; use PSL.Nodes; +with Interfaces; use Interfaces; + +package PSL.QM is + type Primes_Set (<>) is private; + + function Build_Primes (N : Node) return Primes_Set; + + function Build_Node (Ps : Primes_Set) return Node; + + function Reduce (N : Node) return Node; + + -- The maximum number of terms that this package can handle. + -- The algorithm is in O(2**n) + Max_Terms : constant Natural := 12; + + type Term_Assoc_Type is array (1 .. Max_Terms) of Node; + Term_Assoc : Term_Assoc_Type := (others => Null_Node); + Nbr_Terms : Natural := 0; + + procedure Reset; + + procedure Disp_Primes_Set (Ps : Primes_Set); +private + -- Scalar type used to represent a vector of booleans for terms. + subtype Vector_Type is Unsigned_16; + pragma Assert (Vector_Type'Modulus >= 2 ** Max_Terms); + + -- States of a vector of term. + -- If SET is 0, this is a don't care: the term has no influence. + -- If SET is 1, the value of the term is in VAL. + type Prime_Type is record + Val : Unsigned_16; + Set : Unsigned_16; + end record; + + subtype Len_Type is Natural range 0 .. 2 ** Max_Terms; + + type Set_Type is array (Natural range <>) of Prime_Type; + + -- A set of primes is a collection of at most MAX prime. + type Primes_Set (Max : Len_Type) is record + Nbr : Len_Type := 0; + Set : Set_Type (1 .. Max); + end record; +end PSL.QM; + + + diff --git a/psl/psl-rewrites.adb b/psl/psl-rewrites.adb new file mode 100644 index 000000000..6ba5b1026 --- /dev/null +++ b/psl/psl-rewrites.adb @@ -0,0 +1,604 @@ +with Types; use Types; +with PSL.Errors; use PSL.Errors; +with PSL.CSE; use PSL.CSE; + +package body PSL.Rewrites is +-- procedure Location_Copy (Dst, Src : Node) is +-- begin +-- Set_Location (Dst, Get_Location (Src)); +-- end Location_Copy; + + -- Return [*0] + function Build_Empty return Node is + Res, Tmp : Node; + begin + Res := Create_Node (N_Star_Repeat_Seq); + Tmp := Create_Node (N_Number); + Set_Value (Tmp, 0); + Set_Low_Bound (Res, Tmp); + return Res; + end Build_Empty; + + -- Return N[*] + function Build_Star (N : Node) return Node is + Res : Node; + begin + Res := Create_Node (N_Star_Repeat_Seq); + Set_Sequence (Res, N); + return Res; + end Build_Star; + + -- Return N[+] + function Build_Plus (N : Node) return Node is + Res : Node; + begin + Res := Create_Node (N_Plus_Repeat_Seq); + Set_Sequence (Res, N); + return Res; + end Build_Plus; + + -- Return N! + function Build_Strong (N : Node) return Node is + Res : Node; + begin + Res := Create_Node (N_Strong); + Set_Property (Res, N); + return Res; + end Build_Strong; + + -- Return T[*] + function Build_True_Star return Node is + begin + return Build_Star (True_Node); + end Build_True_Star; + + function Build_Binary (K : Nkind; L, R : Node) return Node is + Res : Node; + begin + Res := Create_Node (K); + Set_Left (Res, L); + Set_Right (Res, R); + return Res; + end Build_Binary; + + function Build_Concat (L, R : Node) return Node is + begin + return Build_Binary (N_Concat_SERE, L, R); + end Build_Concat; + + function Build_Repeat (N : Node; Cnt : Uns32) return Node is + Res : Node; + begin + if Cnt = 0 then + raise Internal_Error; + end if; + Res := N; + for I in 2 .. Cnt loop + Res := Build_Concat (Res, N); + end loop; + return Res; + end Build_Repeat; + + function Build_Overlap_Imp_Seq (S : Node; P : Node) return Node + is + Res : Node; + begin + Res := Create_Node (N_Overlap_Imp_Seq); + Set_Sequence (Res, S); + Set_Property (Res, P); + return Res; + end Build_Overlap_Imp_Seq; + + function Rewrite_Boolean (N : Node) return Node + is + Res : Node; + begin + case Get_Kind (N) is + when N_Name => + Res := Get_Decl (N); + pragma Assert (Res /= Null_Node); + return Res; + when N_Not_Bool => + Set_Boolean (N, Rewrite_Boolean (Get_Boolean (N))); + return N; + when N_And_Bool + | N_Or_Bool + | N_Imp_Bool => + Set_Left (N, Rewrite_Boolean (Get_Left (N))); + Set_Right (N, Rewrite_Boolean (Get_Right (N))); + return N; + when N_HDL_Expr => + return N; + when others => + Error_Kind ("rewrite_boolean", N); + end case; + end Rewrite_Boolean; + + function Rewrite_Star_Repeat_Seq (Seq : Node; + Lo, Hi : Uns32) return Node + is + Res : Node; + begin + pragma Assert (Lo <= Hi); + + if Lo = Hi then + + if Lo = 0 then + -- r[*0] --> [*0] + return Build_Empty; + elsif Lo = 1 then + -- r[*1] --> r + return Seq; + end if; + -- r[*c+] --> r;r;r...;r (c times) + return Build_Repeat (Seq, Lo); + end if; + + -- r[*0:1] --> [*0] | r + -- r[*0:2] --> [*0] | r;{[*0]|r} + + -- r[*0:n] --> [*0] | r;r[*0:n-1] + -- r[*l:h] --> r[*l] ; r[*0:h-l] + Res := Build_Binary (N_Or_Seq, Build_Empty, Seq); + for I in Lo + 2 .. Hi loop + Res := Build_Concat (Seq, Res); + Res := Build_Binary (N_Or_Seq, Build_Empty, Res); + end loop; + if Lo > 0 then + Res := Build_Concat (Build_Repeat (Seq, Lo), Res); + end if; + + return Res; + end Rewrite_Star_Repeat_Seq; + + function Rewrite_Star_Repeat_Seq (Seq : Node; + Lo, Hi : Node) return Node + is + Cnt_Lo : Uns32; + Cnt_Hi : Uns32; + begin + if Lo = Null_Node then + -- r[*] + raise Program_Error; + end if; + + Cnt_Lo := Get_Value (Lo); + if Hi = Null_Node then + Cnt_Hi := Cnt_Lo; + else + Cnt_Hi := Get_Value (Hi); + end if; + return Rewrite_Star_Repeat_Seq (Seq, Cnt_Lo, Cnt_Hi); + end Rewrite_Star_Repeat_Seq; + + function Rewrite_Star_Repeat_Seq (N : Node) return Node + is + Seq : constant Node := Get_Sequence (N); + Lo : constant Node := Get_Low_Bound (N); + begin + if Lo = Null_Node then + -- r[*] --> r[*] + return N; + else + return Rewrite_Star_Repeat_Seq (Seq, Lo, Get_High_Bound (N)); + end if; + end Rewrite_Star_Repeat_Seq; + + function Rewrite_Goto_Repeat_Seq (Seq : Node; + Lo, Hi : Node) return Node is + Res : Node; + begin + -- b[->] --> {(~b)[*];b} + Res := Build_Concat (Build_Star (Build_Bool_Not (Seq)), Seq); + + if Lo = Null_Node then + return Res; + end if; + + -- b[->l:h] --> {b[->]}[*l:h] + return Rewrite_Star_Repeat_Seq (Res, Lo, Hi); + end Rewrite_Goto_Repeat_Seq; + + function Rewrite_Goto_Repeat_Seq (Seq : Node; + Lo, Hi : Uns32) return Node is + Res : Node; + begin + -- b[->] --> {(~b)[*];b} + Res := Build_Concat (Build_Star (Build_Bool_Not (Seq)), Seq); + + -- b[->l:h] --> {b[->]}[*l:h] + return Rewrite_Star_Repeat_Seq (Res, Lo, Hi); + end Rewrite_Goto_Repeat_Seq; + + function Rewrite_Equal_Repeat_Seq (N : Node) return Node + is + Seq : constant Node := Get_Sequence (N); + Lo : constant Node := Get_Low_Bound (N); + Hi : constant Node := Get_High_Bound (N); + begin + -- b[=l:h] --> {b[->l:h]};(~b)[*] + return Build_Concat (Rewrite_Goto_Repeat_Seq (Seq, Lo, Hi), + Build_Star (Build_Bool_Not (Seq))); + end Rewrite_Equal_Repeat_Seq; + + function Rewrite_Within (N : Node) return Node is + Res : Node; + begin + Res := Build_Concat (Build_Concat (Build_True_Star, Get_Left (N)), + Build_True_Star); + return Build_Binary (N_Match_And_Seq, Res, Get_Right (N)); + end Rewrite_Within; + + function Rewrite_And_Seq (L : Node; R : Node) return Node is + begin + return Build_Binary (N_Or_Seq, + Build_Binary (N_Match_And_Seq, + L, + Build_Concat (R, Build_True_Star)), + Build_Binary (N_Match_And_Seq, + Build_Concat (L, Build_True_Star), + R)); + end Rewrite_And_Seq; + pragma Unreferenced (Rewrite_And_Seq); + + procedure Rewrite_Instance (N : Node) + is + Assoc : Node := Get_Association_Chain (N); + begin + while Assoc /= Null_Node loop + case Get_Kind (Get_Formal (Assoc)) is + when N_Const_Parameter => + null; + when N_Boolean_Parameter => + Set_Actual (Assoc, Rewrite_Boolean (Get_Actual (Assoc))); + when N_Sequence_Parameter => + Set_Actual (Assoc, Rewrite_SERE (Get_Actual (Assoc))); + when N_Property_Parameter => + Set_Actual (Assoc, Rewrite_Property (Get_Actual (Assoc))); + when others => + Error_Kind ("rewrite_instance", + Get_Formal (Assoc)); + end case; + Assoc := Get_Chain (Assoc); + end loop; + end Rewrite_Instance; + + function Rewrite_SERE (N : Node) return Node is + S : Node; + begin + case Get_Kind (N) is + when N_Star_Repeat_Seq => + S := Get_Sequence (N); + if S = Null_Node then + S := True_Node; + else + S := Rewrite_SERE (S); + end if; + Set_Sequence (N, S); + return Rewrite_Star_Repeat_Seq (N); + when N_Plus_Repeat_Seq => + S := Get_Sequence (N); + if S = Null_Node then + S := True_Node; + else + S := Rewrite_SERE (S); + end if; + Set_Sequence (N, S); + return N; + when N_Goto_Repeat_Seq => + return Rewrite_Goto_Repeat_Seq + (Rewrite_SERE (Get_Sequence (N)), + Get_Low_Bound (N), Get_High_Bound (N)); + when N_Equal_Repeat_Seq => + Set_Sequence (N, Rewrite_SERE (Get_Sequence (N))); + return Rewrite_Equal_Repeat_Seq (N); + when N_Braced_SERE => + return Rewrite_SERE (Get_SERE (N)); + when N_Within_SERE => + Set_Left (N, Rewrite_SERE (Get_Left (N))); + Set_Right (N, Rewrite_SERE (Get_Right (N))); + return Rewrite_Within (N); +-- when N_And_Seq => +-- return Rewrite_And_Seq (Rewrite_SERE (Get_Left (N)), +-- Rewrite_SERE (Get_Right (N))); + when N_Concat_SERE + | N_Fusion_SERE + | N_Match_And_Seq + | N_And_Seq + | N_Or_Seq => + Set_Left (N, Rewrite_SERE (Get_Left (N))); + Set_Right (N, Rewrite_SERE (Get_Right (N))); + return N; + when N_Booleans => + return Rewrite_Boolean (N); + when N_Name => + return Get_Decl (N); + when N_Sequence_Instance + | N_Endpoint_Instance => + Rewrite_Instance (N); + return N; + when N_Boolean_Parameter + | N_Sequence_Parameter + | N_Const_Parameter => + return N; + when others => + Error_Kind ("rewrite_SERE", N); + end case; + end Rewrite_SERE; + + function Rewrite_Until (N : Node) return Node + is + Res : Node; + B : Node; + L : Node; + S : Node; + begin + if Get_Inclusive_Flag (N) then + -- B1 until_ B2 --> {B1[+]:B2} + Res := Build_Binary (N_Fusion_SERE, + Build_Plus (Rewrite_Boolean (Get_Left (N))), + Rewrite_Boolean (Get_Right (N))); + if Get_Strong_Flag (N) then + Res := Build_Strong (Res); + end if; + else + -- P until B --> {(!B)[+]} |-> P + B := Rewrite_Boolean (Get_Right (N)); + L := Build_Plus (Build_Bool_Not (B)); + Res := Build_Overlap_Imp_Seq (L, Rewrite_Property (Get_Left (N))); + + if Get_Strong_Flag (N) then + -- p until! b --> (p until b) && ({b[->]}!) + S := Build_Strong + (Rewrite_Goto_Repeat_Seq (B, Null_Node, Null_Node)); + Res := Build_Binary (N_And_Prop, Res, S); + end if; + end if; + return Res; + end Rewrite_Until; + + function Rewrite_Next_Event_A (B : Node; + Lo, Hi : Uns32; + P : Node; + Strong : Boolean) return Node + is + Res : Node; + begin + Res := Rewrite_Goto_Repeat_Seq (B, Lo, Hi); + Res := Build_Overlap_Imp_Seq (Res, P); + + if Strong then + Res := Build_Binary + (N_And_Prop, + Res, + Build_Strong (Rewrite_Goto_Repeat_Seq (B, Lo, Lo))); + end if; + + return Res; + end Rewrite_Next_Event_A; + + function Rewrite_Next_Event (B : Node; + N : Uns32; + P : Node; + Strong : Boolean) return Node is + begin + return Rewrite_Next_Event_A (B, N, N, P, Strong); + end Rewrite_Next_Event; + + function Rewrite_Next_Event (B : Node; + Num : Node; + P : Node; + Strong : Boolean) return Node + is + N : Uns32; + begin + if Num = Null_Node then + N := 1; + else + N := Get_Value (Num); + end if; + return Rewrite_Next_Event (B, N, P, Strong); + end Rewrite_Next_Event; + + function Rewrite_Next (Num : Node; P : Node; Strong : Boolean) return Node + is + N : Uns32; + begin + if Num = Null_Node then + N := 1; + else + N := Get_Value (Num); + end if; + return Rewrite_Next_Event (True_Node, N + 1, P, Strong); + end Rewrite_Next; + + function Rewrite_Next_A (Lo, Hi : Uns32; + P : Node; Strong : Boolean) return Node + is + begin + return Rewrite_Next_Event_A (True_Node, Lo + 1, Hi + 1, P, Strong); + end Rewrite_Next_A; + + function Rewrite_Next_Event_E (B1 : Node; + Lo, Hi : Uns32; + B2 : Node; Strong : Boolean) return Node + is + Res : Node; + begin + Res := Build_Binary (N_Fusion_SERE, + Rewrite_Goto_Repeat_Seq (B1, Lo, Hi), + B2); + if Strong then + Res := Build_Strong (Res); + end if; + return Res; + end Rewrite_Next_Event_E; + + function Rewrite_Next_E (Lo, Hi : Uns32; + B : Node; Strong : Boolean) return Node + is + begin + return Rewrite_Next_Event_E (True_Node, Lo + 1, Hi + 1, B, Strong); + end Rewrite_Next_E; + + function Rewrite_Before (N : Node) return Node + is + Res : Node; + R : Node; + B1, B2 : Node; + N_B2 : Node; + begin + B1 := Rewrite_Boolean (Get_Left (N)); + B2 := Rewrite_Boolean (Get_Right (N)); + N_B2 := Build_Bool_Not (B2); + Res := Build_Star (Build_Bool_And (Build_Bool_Not (B1), N_B2)); + + if Get_Inclusive_Flag (N) then + R := B2; + else + R := Build_Bool_And (B1, N_B2); + end if; + Res := Build_Concat (Res, R); + if Get_Strong_Flag (N) then + Res := Build_Strong (Res); + end if; + return Res; + end Rewrite_Before; + + function Rewrite_Or (L, R : Node) return Node + is + B, P : Node; + begin + if Get_Kind (L) in N_Booleans then + if Get_Kind (R) in N_Booleans then + return Build_Bool_Or (L, R); + else + B := L; + P := R; + end if; + elsif Get_Kind (R) in N_Booleans then + B := R; + P := L; + else + -- Not in the simple subset. + raise Program_Error; + end if; + + -- B || P --> (~B) -> P + return Build_Binary (N_Log_Imp_Prop, Build_Bool_Not (B), P); + end Rewrite_Or; + + function Rewrite_Property (N : Node) return Node is + begin + case Get_Kind (N) is + when N_Star_Repeat_Seq + | N_Plus_Repeat_Seq + | N_Goto_Repeat_Seq + | N_Sequence_Instance + | N_Endpoint_Instance + | N_Braced_SERE => + return Rewrite_SERE (N); + when N_Imp_Seq + | N_Overlap_Imp_Seq => + Set_Sequence (N, Rewrite_Property (Get_Sequence (N))); + Set_Property (N, Rewrite_Property (Get_Property (N))); + return N; + when N_Log_Imp_Prop => + -- b -> p --> {b} |-> p + return Build_Overlap_Imp_Seq + (Rewrite_Boolean (Get_Left (N)), + Rewrite_Property (Get_Right (N))); + when N_Eventually => + return Build_Strong + (Build_Binary (N_Fusion_SERE, + Build_Plus (True_Node), + Rewrite_SERE (Get_Property (N)))); + when N_Until => + return Rewrite_Until (N); + when N_Next => + return Rewrite_Next (Get_Number (N), + Rewrite_Property (Get_Property (N)), + Get_Strong_Flag (N)); + when N_Next_Event => + return Rewrite_Next_Event (Rewrite_Boolean (Get_Boolean (N)), + Get_Number (N), + Rewrite_Property (Get_Property (N)), + Get_Strong_Flag (N)); + when N_Next_A => + return Rewrite_Next_A (Get_Value (Get_Low_Bound (N)), + Get_Value (Get_High_Bound (N)), + Rewrite_Property (Get_Property (N)), + Get_Strong_Flag (N)); + when N_Next_Event_A => + return Rewrite_Next_Event_A + (Rewrite_Boolean (Get_Boolean (N)), + Get_Value (Get_Low_Bound (N)), + Get_Value (Get_High_Bound (N)), + Rewrite_Property (Get_Property (N)), + Get_Strong_Flag (N)); + when N_Next_E => + return Rewrite_Next_E (Get_Value (Get_Low_Bound (N)), + Get_Value (Get_High_Bound (N)), + Rewrite_Property (Get_Property (N)), + Get_Strong_Flag (N)); + when N_Next_Event_E => + return Rewrite_Next_Event_E + (Rewrite_Boolean (Get_Boolean (N)), + Get_Value (Get_Low_Bound (N)), + Get_Value (Get_High_Bound (N)), + Rewrite_Property (Get_Property (N)), + Get_Strong_Flag (N)); + when N_Before => + return Rewrite_Before (N); + when N_Booleans => + return Rewrite_Boolean (N); + when N_Name => + return Get_Decl (N); + when N_Never + | N_Always + | N_Strong => + -- Fully handled by psl.build + Set_Property (N, Rewrite_Property (Get_Property (N))); + return N; + when N_Clock_Event => + Set_Property (N, Rewrite_Property (Get_Property (N))); + Set_Boolean (N, Rewrite_Boolean (Get_Boolean (N))); + return N; + when N_And_Prop => + Set_Left (N, Rewrite_Property (Get_Left (N))); + Set_Right (N, Rewrite_Property (Get_Right (N))); + return N; + when N_Or_Prop => + return Rewrite_Or (Rewrite_Property (Get_Left (N)), + Rewrite_Property (Get_Right (N))); + when N_Abort => + Set_Boolean (N, Rewrite_Boolean (Get_Boolean (N))); + Set_Property (N, Rewrite_Property (Get_Property (N))); + return N; + when N_Property_Instance => + Rewrite_Instance (N); + return N; + when others => + Error_Kind ("rewrite_property", N); + end case; + end Rewrite_Property; + + procedure Rewrite_Unit (N : Node) is + Item : Node; + begin + Item := Get_Item_Chain (N); + while Item /= Null_Node loop + case Get_Kind (Item) is + when N_Name_Decl => + null; + when N_Assert_Directive => + Set_Property (Item, Rewrite_Property (Get_Property (Item))); + when N_Property_Declaration => + Set_Property (Item, Rewrite_Property (Get_Property (Item))); + when others => + Error_Kind ("rewrite_unit", Item); + end case; + Item := Get_Chain (Item); + end loop; + end Rewrite_Unit; +end PSL.Rewrites; diff --git a/psl/psl-rewrites.ads b/psl/psl-rewrites.ads new file mode 100644 index 000000000..ac76b7805 --- /dev/null +++ b/psl/psl-rewrites.ads @@ -0,0 +1,7 @@ +with PSL.Nodes; use PSL.Nodes; + +package PSL.Rewrites is + function Rewrite_SERE (N : Node) return Node; + function Rewrite_Property (N : Node) return Node; + procedure Rewrite_Unit (N : Node); +end PSL.Rewrites; diff --git a/psl/psl-subsets.adb b/psl/psl-subsets.adb new file mode 100644 index 000000000..f322eafda --- /dev/null +++ b/psl/psl-subsets.adb @@ -0,0 +1,177 @@ +with PSL.Errors; use PSL.Errors; +with Types; use Types; + +package body PSL.Subsets is + procedure Check_Simple (N : Node) + is + begin + case Get_Kind (N) is + when N_Not_Bool => + if Get_Psl_Type (Get_Boolean (N)) /= Type_Boolean then + Error_Msg_Sem + ("operand of a negation operator must be a boolean", N); + end if; + when N_Never => + case Get_Psl_Type (Get_Property (N)) is + when Type_Sequence | Type_Boolean => + null; + when others => + Error_Msg_Sem ("operand of a 'never' operator must be " + & "a boolean or a sequence", N); + end case; + when N_Eventually => + case Get_Psl_Type (Get_Property (N)) is + when Type_Sequence | Type_Boolean => + null; + when others => + Error_Msg_Sem ("operand of an 'eventually!' operator must be" + & " a boolean or a sequence", N); + end case; + when N_And_Bool => + if Get_Psl_Type (Get_Left (N)) /= Type_Boolean then + Error_Msg_Sem ("left-hand side operand of logical 'and' must be" + & " a boolean", N); + end if; + when N_Or_Bool => + if Get_Psl_Type (Get_Left (N)) /= Type_Boolean then + Error_Msg_Sem ("left-hand side operand of logical 'or' must be" + & " a boolean", N); + end if; + when N_Log_Imp_Prop => + if Get_Psl_Type (Get_Left (N)) /= Type_Boolean then + Error_Msg_Sem ("left-hand side operand of logical '->' must be" + & " a boolean", N); + end if; + -- FIXME: <-> + when N_Until => + if not Get_Inclusive_Flag (N) then + if Get_Psl_Type (Get_Right (N)) /= Type_Boolean then + Error_Msg_Sem ("right-hand side of a non-overlapping " + & "'until*' operator must be a boolean", N); + end if; + else + if Get_Psl_Type (Get_Right (N)) /= Type_Boolean + or else Get_Psl_Type (Get_Left (N)) /= Type_Boolean + then + Error_Msg_Sem ("both operands of an overlapping 'until*'" + & " operator are boolean", N); + end if; + end if; + when N_Before => + if Get_Psl_Type (Get_Right (N)) /= Type_Boolean + or else Get_Psl_Type (Get_Left (N)) /= Type_Boolean + then + Error_Msg_Sem ("both operands of a 'before*'" + & " operator are boolean", N); + end if; + when others => + null; + end case; + + -- Recursion. + case Get_Kind (N) is + when N_Error => + null; + when N_Hdl_Mod_Name => + null; + when N_Vunit + | N_Vmode + | N_Vprop => + declare + Item : Node; + begin + Item := Get_Item_Chain (N); + while Item /= Null_Node loop + Check_Simple (Item); + Item := Get_Chain (Item); + end loop; + end; + when N_Name_Decl => + null; + when N_Assert_Directive + | N_Property_Declaration => + Check_Simple (Get_Property (N)); + when N_Endpoint_Declaration + | N_Sequence_Declaration => + Check_Simple (Get_Sequence (N)); + when N_Clock_Event => + Check_Simple (Get_Property (N)); + Check_Simple (Get_Boolean (N)); + when N_Always + | N_Never + | N_Eventually + | N_Strong => + Check_Simple (Get_Property (N)); + when N_Braced_SERE => + Check_Simple (Get_SERE (N)); + when N_Concat_SERE + | N_Fusion_SERE + | N_Within_SERE => + Check_Simple (Get_Left (N)); + Check_Simple (Get_Right (N)); + when N_Name => + null; + when N_Star_Repeat_Seq + | N_Goto_Repeat_Seq + | N_Equal_Repeat_Seq => + declare + N2 : constant Node := Get_Sequence (N); + begin + if N2 /= Null_Node then + Check_Simple (N2); + end if; + end; + when N_Plus_Repeat_Seq => + Check_Simple (Get_Sequence (N)); + when N_Match_And_Seq + | N_And_Seq + | N_Or_Seq => + Check_Simple (Get_Left (N)); + Check_Simple (Get_Right (N)); + when N_Imp_Seq + | N_Overlap_Imp_Seq => + Check_Simple (Get_Sequence (N)); + Check_Simple (Get_Property (N)); + when N_Log_Imp_Prop + | N_Until + | N_Before + | N_Or_Prop + | N_And_Prop + | N_And_Bool + | N_Or_Bool + | N_Imp_Bool => + Check_Simple (Get_Left (N)); + Check_Simple (Get_Right (N)); + when N_Next + | N_Next_A + | N_Next_E => + Check_Simple (Get_Property (N)); + when N_Next_Event + | N_Next_Event_A + | N_Next_Event_E + | N_Abort => + Check_Simple (Get_Boolean (N)); + Check_Simple (Get_Property (N)); + when N_Not_Bool => + Check_Simple (Get_Boolean (N)); + when N_Const_Parameter + | N_Sequence_Parameter + | N_Boolean_Parameter + | N_Property_Parameter => + null; + when N_Actual => + null; + when N_Sequence_Instance + | N_Endpoint_Instance + | N_Property_Instance => + null; + when N_True + | N_False + | N_Number + | N_EOS + | N_HDL_Expr => + null; + end case; + end Check_Simple; +end PSL.Subsets; + diff --git a/psl/psl-subsets.ads b/psl/psl-subsets.ads new file mode 100644 index 000000000..c3bae09ef --- /dev/null +++ b/psl/psl-subsets.ads @@ -0,0 +1,23 @@ +with PSL.Nodes; use PSL.Nodes; + +package PSL.Subsets is + -- Check that N (a property) follows the simple subset rules from + -- PSL v1.1 4.4.4 Simple subset. + -- Ie: + -- - The operand of a negation operator is a Boolean. + -- - The operand of a 'never' operator is a Boolean or a Sequence. + -- - The operand of an 'eventually!' operator is a Boolean or a Sequence. + -- - The left-hand side operand of a logical 'and' operator is a Boolean. + -- - The left-hand side operand of a logical 'or' operator is a Boolean. + -- - The left-hand side operand of a logical implication '->' operator + -- is a Boolean. + -- - Both operands of a logical iff '<->' operator are Boolean. + -- - The right-hand side operand of a non-overlapping 'until*' operator is + -- a Boolean. + -- - Both operands of an overlapping 'until*' operator are Boolean. + -- - Both operands of a 'before*' operator are Boolean. + -- + -- All other operators not mentioned above are supported in the simple + -- subset without restriction. + procedure Check_Simple (N : Node); +end PSL.Subsets; diff --git a/psl/psl-tprint.adb b/psl/psl-tprint.adb new file mode 100644 index 000000000..eabe8bd28 --- /dev/null +++ b/psl/psl-tprint.adb @@ -0,0 +1,255 @@ +with Types; use Types; +with PSL.Errors; use PSL.Errors; +with PSL.Prints; +with Ada.Text_IO; use Ada.Text_IO; +with Name_Table; use Name_Table; + +package body PSL.Tprint is + procedure Disp_Expr (N : Node) is + begin + case Get_Kind (N) is + when N_Number => + declare + Str : constant String := Uns32'Image (Get_Value (N)); + begin + Put (Str (2 .. Str'Last)); + end; + when others => + Error_Kind ("disp_expr", N); + end case; + end Disp_Expr; + + procedure Disp_Count (N : Node) is + B : Node; + begin + B := Get_Low_Bound (N); + if B = Null_Node then + return; + end if; + Disp_Expr (B); + B := Get_High_Bound (N); + if B = Null_Node then + return; + end if; + Put (":"); + Disp_Expr (B); + end Disp_Count; + + procedure Put_Node (Prefix : String; Name : String) is + begin + Put (Prefix); + Put ("-+ "); + Put (Name); + end Put_Node; + + procedure Put_Node_Line (Prefix : String; Name : String) is + begin + Put_Node (Prefix, Name); + New_Line; + end Put_Node_Line; + + function Down (Str : String) return String is + L : constant Natural := Str'Last; + begin + if Str (L) = '\' then + return Str (Str'First .. L - 1) & " \"; + elsif Str (L) = '/' then + return Str (Str'First .. L - 1) & "| \"; + else + raise Program_Error; + end if; + end Down; + + function Up (Str : String) return String is + L : constant Natural := Str'Last; + begin + if Str (L) = '/' then + return Str (Str'First .. L - 1) & " /"; + elsif Str (L) = '\' then + return Str (Str'First .. L - 1) & "| /"; + else + raise Program_Error; + end if; + end Up; + + procedure Disp_Repeat_Sequence (Prefix : String; Name : String; N : Node) is + S : Node; + begin + Put_Node (Prefix, Name); + Disp_Count (N); + Put_Line ("]"); + S := Get_Sequence (N); + if S /= Null_Node then + Disp_Property (Down (Prefix), S); + end if; + end Disp_Repeat_Sequence; + + procedure Disp_Binary_Sequence (Prefix : String; Name : String; N : Node) is + begin + Disp_Property (Up (Prefix), Get_Left (N)); + Put_Node_Line (Prefix, Name); + Disp_Property (Down (Prefix), Get_Right (N)); + end Disp_Binary_Sequence; + + procedure Disp_Range_Property (Prefix : String; Name : String; N : Node) is + begin + Put_Node (Prefix, Name); + Put ("["); + Disp_Count (N); + Put_Line ("]"); + Disp_Property (Down (Prefix), Get_Property (N)); + end Disp_Range_Property; + + procedure Disp_Boolean_Range_Property (Prefix : String; + Name : String; N : Node) is + begin + Disp_Property (Up (Prefix), Get_Boolean (N)); + Put_Node (Prefix, Name); + Put ("["); + Disp_Count (N); + Put_Line ("]"); + Disp_Property (Down (Prefix), Get_Property (N)); + end Disp_Boolean_Range_Property; + + procedure Disp_Property (Prefix : String; Prop : Node) is + begin + case Get_Kind (Prop) is + when N_Never => + Put_Node_Line (Prefix, "never"); + Disp_Property (Down (Prefix), Get_Property (Prop)); + when N_Always => + Put_Node_Line (Prefix, "always"); + Disp_Property (Down (Prefix), Get_Property (Prop)); + when N_Eventually => + Put_Node_Line (Prefix, "eventually!"); + Disp_Property (Down (Prefix), Get_Property (Prop)); + when N_Next => + Put_Node_Line (Prefix, "next"); +-- if Get_Strong_Flag (Prop) then +-- Put ('!'); +-- end if; + Disp_Property (Down (Prefix), Get_Property (Prop)); + when N_Next_A => + Disp_Range_Property (Prefix, "next_a", Prop); + when N_Next_E => + Disp_Range_Property (Prefix, "next_e", Prop); + when N_Next_Event => + Disp_Property (Up (Prefix), Get_Boolean (Prop)); + Put_Node_Line (Prefix, "next_event"); + Disp_Property (Down (Prefix), Get_Property (Prop)); + when N_Next_Event_A => + Disp_Boolean_Range_Property (Prefix, "next_event_a", Prop); + when N_Next_Event_E => + Disp_Boolean_Range_Property (Prefix, "next_event_e", Prop); + when N_Braced_SERE => + Put_Node_Line (Prefix, "{} (braced_SERE)"); + Disp_Property (Down (Prefix), Get_SERE (Prop)); + when N_Concat_SERE => + Disp_Binary_Sequence (Prefix, "; (concat)", Prop); + when N_Fusion_SERE => + Disp_Binary_Sequence (Prefix, ": (fusion)", Prop); + when N_Within_SERE => + Disp_Binary_Sequence (Prefix, "within", Prop); + when N_Match_And_Seq => + Disp_Binary_Sequence (Prefix, "&& (sequence matching len)", Prop); + when N_Or_Seq => + Disp_Binary_Sequence (Prefix, "| (sequence or)", Prop); + when N_And_Seq => + Disp_Binary_Sequence (Prefix, "& (sequence and)", Prop); + when N_Imp_Seq => + Disp_Property (Up (Prefix), Get_Sequence (Prop)); + Put_Node_Line (Prefix, "|=> (sequence implication)"); + Disp_Property (Down (Prefix), Get_Property (Prop)); + when N_Overlap_Imp_Seq => + Disp_Property (Up (Prefix), Get_Sequence (Prop)); + Put_Node_Line (Prefix, "|->"); + Disp_Property (Down (Prefix), Get_Property (Prop)); + when N_Or_Prop => + Disp_Binary_Sequence (Prefix, "|| (property or)", Prop); + when N_And_Prop => + Disp_Binary_Sequence (Prefix, "&& (property and)", Prop); + when N_Log_Imp_Prop => + Disp_Binary_Sequence (Prefix, "-> (property impliciation)", Prop); + when N_Until => + Disp_Binary_Sequence (Prefix, "until", Prop); + when N_Before => + Disp_Binary_Sequence (Prefix, "before", Prop); + when N_Abort => + Disp_Property (Up (Prefix), Get_Property (Prop)); + Put_Node_Line (Prefix, "abort"); + Disp_Property (Down (Prefix), Get_Boolean (Prop)); + when N_Not_Bool => + Put_Node_Line (Prefix, "! (boolean not)"); + Disp_Property (Down (Prefix), Get_Boolean (Prop)); + when N_Or_Bool => + Disp_Binary_Sequence (Prefix, "|| (boolean or)", Prop); + when N_And_Bool => + Disp_Binary_Sequence (Prefix, "&& (boolean and)", Prop); + when N_Name_Decl => + Put_Node_Line (Prefix, + "Name_Decl: " & Image (Get_Identifier (Prop))); + when N_Name => + Put_Node_Line (Prefix, "Name: " & Image (Get_Identifier (Prop))); + Disp_Property (Down (Prefix), Get_Decl (Prop)); + when N_True => + Put_Node_Line (Prefix, "TRUE"); + when N_False => + Put_Node_Line (Prefix, "FALSE"); + when N_HDL_Expr => + Put_Node (Prefix, "HDL_Expr: "); + PSL.Prints.HDL_Expr_Printer.all (Get_HDL_Node (Prop)); + New_Line; + when N_Star_Repeat_Seq => + Disp_Repeat_Sequence (Prefix, "[*", Prop); + when N_Goto_Repeat_Seq => + Disp_Repeat_Sequence (Prefix, "[->", Prop); + when N_Equal_Repeat_Seq => + Disp_Repeat_Sequence (Prefix, "[=", Prop); + when N_Plus_Repeat_Seq => + Put_Node_Line (Prefix, "[+]"); + Disp_Property (Down (Prefix), Get_Sequence (Prop)); + when others => + Error_Kind ("disp_property", Prop); + end case; + end Disp_Property; + + procedure Disp_Assert (N : Node) is + Label : constant Name_Id := Get_Label (N); + begin + Put (" "); + if Label /= Null_Identifier then + Put (Image (Label)); + Put (": "); + end if; + Put_Line ("assert "); + Disp_Property (" \", Get_Property (N)); + end Disp_Assert; + + procedure Disp_Unit (Unit : Node) is + Item : Node; + begin + case Get_Kind (Unit) is + when N_Vunit => + Put ("vunit"); + when others => + Error_Kind ("disp_unit", Unit); + end case; + Put (' '); + Put (Image (Get_Identifier (Unit))); + Put_Line (" {"); + Item := Get_Item_Chain (Unit); + while Item /= Null_Node loop + case Get_Kind (Item) is + when N_Assert_Directive => + Disp_Assert (Item); + when N_Name_Decl => + null; + when others => + Error_Kind ("disp_unit", Item); + end case; + Item := Get_Chain (Item); + end loop; + Put_Line ("}"); + end Disp_Unit; +end PSL.Tprint; + diff --git a/psl/psl-tprint.ads b/psl/psl-tprint.ads new file mode 100644 index 000000000..1b06ebf1a --- /dev/null +++ b/psl/psl-tprint.ads @@ -0,0 +1,6 @@ +with PSL.Nodes; use PSL.Nodes; + +package PSL.Tprint is + procedure Disp_Unit (Unit : Node); + procedure Disp_Property (Prefix : String; Prop : Node); +end PSL.Tprint; diff --git a/psl/psl.ads b/psl/psl.ads new file mode 100644 index 000000000..a2f4bdce0 --- /dev/null +++ b/psl/psl.ads @@ -0,0 +1,3 @@ +package PSL is + pragma Pure (PSL); +end PSL; @@ -604,6 +604,17 @@ package body Scan is Pos := Pos + 1; end loop; + if Source (Pos - 1) = '_' then + if not Flag_Psl then + -- Some PSL reserved words finish with '_'. This case is handled + -- later. + Error_Msg_Scan ("identifier cannot finish with '_'"); + end if; + Pos := Pos - 1; + Len := Len - 1; + C := '_'; + end if; + -- LRM93 13.2 -- At least one separator is required between an identifier or an -- abstract literal and an adjacent identifier or abstract literal. @@ -656,6 +667,50 @@ package body Scan is (Token_Type'Pos (Tok_First_Keyword) + Current_Identifier - Std_Names.Name_First_Keyword); end if; + elsif Flag_Psl then + case Current_Identifier is + when Std_Names.Name_Clock => + Current_Token := Tok_Psl_Clock; + when Std_Names.Name_Const => + Current_Token := Tok_Psl_Const; + when Std_Names.Name_Boolean => + Current_Token := Tok_Psl_Boolean; + when Std_Names.Name_Sequence => + Current_Token := Tok_Psl_Sequence; + when Std_Names.Name_Property => + Current_Token := Tok_Psl_Property; + when Std_Names.Name_Inf => + Current_Token := Tok_Inf; + when Std_Names.Name_Within => + Current_Token := Tok_Within; + when Std_Names.Name_Abort => + Current_Token := Tok_Abort; + when Std_Names.Name_Before => + Current_Token := Tok_Before; + when Std_Names.Name_Always => + Current_Token := Tok_Always; + when Std_Names.Name_Never => + Current_Token := Tok_Never; + when Std_Names.Name_Eventually => + Current_Token := Tok_Eventually; + when Std_Names.Name_Next_A => + Current_Token := Tok_Next_A; + when Std_Names.Name_Next_E => + Current_Token := Tok_Next_E; + when Std_Names.Name_Next_Event => + Current_Token := Tok_Next_Event; + when Std_Names.Name_Next_Event_A => + Current_Token := Tok_Next_Event_A; + when Std_Names.Name_Next_Event_E => + Current_Token := Tok_Next_Event_E; + when Std_Names.Name_Until => + Current_Token := Tok_Until; + when others => + Current_Token := Tok_Identifier; + if C = '_' then + Error_Msg_Scan ("identifiers cannot finish with '_'"); + end if; + end case; else Current_Token := Tok_Identifier; end if; @@ -834,6 +889,104 @@ package body Scan is end if; end Convert_Identifier; + -- Scan an identifier within a comment. Only lower case letters are + -- allowed. + function Scan_Comment_Identifier return Boolean + is + use Name_Table; + Len : Natural; + C : Character; + begin + -- Skip spaces. + while Source (Pos) = ' ' or Source (Pos) = HT loop + Pos := Pos + 1; + end loop; + + -- The identifier shall start with a lower case letter. + if Source (Pos) not in 'a' .. 'z' then + return False; + end if; + + -- Scan the identifier (in lower cases). + Len := 0; + loop + C := Source (Pos); + exit when C not in 'a' .. 'z' and C /= '_'; + Len := Len + 1; + Name_Buffer (Len) := C; + Pos := Pos + 1; + end loop; + + -- Shall be followed by a space or a new line. + case C is + when ' ' | HT | LF | CR => + null; + when others => + return False; + end case; + + Name_Length := Len; + return True; + end Scan_Comment_Identifier; + + function Scan_Comment return Boolean + is + use Std_Names; + Id : Name_Id; + begin + if not Scan_Comment_Identifier then + return False; + end if; + + -- Hash it. + Id := Name_Table.Get_Identifier; + + case Id is + when Name_Psl => + if not Scan_Comment_Identifier then + return False; + end if; + case Name_Table.Get_Identifier is + when Name_Property => + Current_Token := Tok_Psl_Property; + when Name_Sequence => + Current_Token := Tok_Psl_Sequence; + when Name_Endpoint => + Current_Token := Tok_Psl_Endpoint; + when Name_Assert => + Current_Token := Tok_Psl_Assert; + when Name_Default => + Current_Token := Tok_Psl_Default; + when others => + return False; + end case; + Flag_Scan_In_Comment := True; + return True; + when others => + return False; + end case; + end Scan_Comment; + + function Scan_Exclam_Mark return Boolean is + begin + if Source (Pos) = '!' then + Pos := Pos + 1; + return True; + else + return False; + end if; + end Scan_Exclam_Mark; + + function Scan_Underscore return Boolean is + begin + if Source (Pos) = '_' then + Pos := Pos + 1; + return True; + else + return False; + end if; + end Scan_Underscore; + -- Get a new token. procedure Scan is begin @@ -899,10 +1052,22 @@ package body Scan is -- is out of purpose, and a warning could be reported :-) Pos := Pos + 2; - -- LRM93 13.2 - -- In any case, a sequence of one or more format effectors other - -- than horizontal tabulation must cause at least one end of - -- line. + -- Scan inside a comment. So we just ignore the two dashes. + if Flag_Scan_In_Comment then + goto Again; + end if; + + -- Handle keywords in comment (PSL). + if Flag_Comment_Keyword + and then Scan_Comment + then + return; + end if; + + -- LRM93 13.2 + -- In any case, a sequence of one or more format + -- effectors other than horizontal tabulation must + -- cause at least one end of line. while Source (Pos) /= CR and Source (Pos) /= LF and Source (Pos) /= VT and Source (Pos) /= FF and Source (Pos) /= Files_Map.EOT @@ -919,6 +1084,10 @@ package body Scan is return; end if; goto Again; + elsif Flag_Psl and then Source (Pos + 1) = '>' then + Current_Token := Tok_Minus_Greater; + Pos := Pos + 2; + return; else Current_Token := Tok_Minus; Pos := Pos + 1; @@ -954,11 +1123,39 @@ package body Scan is Current_Token := Tok_Right_Paren; Pos := Pos + 1; return; - when '|' | '!' => - -- LRM93 13.10 - -- A vertical line (|) can be replaced by an exclamation mark (!) - -- where used as a delimiter. - Current_Token := Tok_Bar; + when '|' => + if Flag_Psl then + if Source (Pos + 1) = '|' then + Current_Token := Tok_Bar_Bar; + Pos := Pos + 2; + elsif Source (Pos + 1) = '-' + and then Source (Pos + 2) = '>' + then + Current_Token := Tok_Bar_Arrow; + Pos := Pos + 3; + elsif Source (Pos + 1) = '=' + and then Source (Pos + 2) = '>' + then + Current_Token := Tok_Bar_Double_Arrow; + Pos := Pos + 3; + else + Current_Token := Tok_Bar; + Pos := Pos + 1; + end if; + else + Current_Token := Tok_Bar; + Pos := Pos + 1; + end if; + return; + when '!' => + if Flag_Psl then + Current_Token := Tok_Exclam_Mark; + else + -- LRM93 13.10 + -- A vertical line (|) can be replaced by an exclamation + -- mark (!) where used as a delimiter. + Current_Token := Tok_Bar; + end if; Pos := Pos + 1; return; when ':' => @@ -990,8 +1187,13 @@ package body Scan is Pos := Pos + 1; return; when '&' => - Current_Token := Tok_Ampersand; - Pos := Pos + 1; + if Flag_Psl and then Source (Pos + 1) = '&' then + Current_Token := Tok_And_And; + Pos := Pos + 2; + else + Current_Token := Tok_Ampersand; + Pos := Pos + 1; + end if; return; when '<' => if Source (Pos + 1) = '=' then @@ -1016,7 +1218,7 @@ package body Scan is return; when '=' => if Source (Pos + 1) = '>' then - Current_Token := Tok_Arrow; + Current_Token := Tok_Double_Arrow; Pos := Pos + 2; else Current_Token := Tok_Equal; @@ -1092,17 +1294,40 @@ package body Scan is Scan_String; return; when '[' => - if Vhdl_Std = Vhdl_87 then - Error_Msg_Scan - ("'[' is an invalid character in vhdl87, replaced by '('"); - Current_Token := Tok_Left_Paren; + if Flag_Psl then + if Source (Pos + 1) = '*' then + Current_Token := Tok_Brack_Star; + Pos := Pos + 2; + elsif Source (Pos + 1) = '+' + and then Source (Pos + 2) = ']' + then + Current_Token := Tok_Brack_Plus_Brack; + Pos := Pos + 3; + elsif Source (Pos + 1) = '-' + and then Source (Pos + 2) = '>' + then + Current_Token := Tok_Brack_Arrow; + Pos := Pos + 3; + elsif Source (Pos + 1) = '=' then + Current_Token := Tok_Brack_Equal; + Pos := Pos + 2; + else + Current_Token := Tok_Left_Bracket; + Pos := Pos + 1; + end if; else - Current_Token := Tok_Left_Bracket; + if Vhdl_Std = Vhdl_87 then + Error_Msg_Scan + ("'[' is an invalid character in vhdl87, replaced by '('"); + Current_Token := Tok_Left_Paren; + else + Current_Token := Tok_Left_Bracket; + end if; + Pos := Pos + 1; end if; - Pos := Pos + 1; return; when ']' => - if Vhdl_Std = Vhdl_87 then + if Vhdl_Std = Vhdl_87 and not Flag_Psl then Error_Msg_Scan ("']' is an invalid character in vhdl87, replaced by ')'"); Current_Token := Tok_Right_Paren; @@ -1112,14 +1337,22 @@ package body Scan is Pos := Pos + 1; return; when '{' => - Error_Msg_Scan ("'{' is an invalid character, replaced by '('"); + if Flag_Psl then + Current_Token := Tok_Left_Curly; + else + Error_Msg_Scan ("'{' is an invalid character, replaced by '('"); + Current_Token := Tok_Left_Paren; + end if; Pos := Pos + 1; - Current_Token := Tok_Left_Paren; return; when '}' => - Error_Msg_Scan ("'}' is an invalid character, replaced by ')'"); + if Flag_Psl then + Current_Token := Tok_Right_Curly; + else + Error_Msg_Scan ("'}' is an invalid character, replaced by ')'"); + Current_Token := Tok_Right_Paren; + end if; Pos := Pos + 1; - Current_Token := Tok_Right_Paren; return; when '\' => if Vhdl_Std = Vhdl_87 then @@ -1138,13 +1371,25 @@ package body Scan is Pos := Pos + 1; Current_Token := Tok_Not; return; - when '$' | '@' | '?' | '`' + when '$' | '?' | '`' | Inverted_Exclamation .. Inverted_Question | Multiplication_Sign | Division_Sign => Error_Msg_Scan ("character """ & Source (Pos) & """ can only be used in strings or comments"); Pos := Pos + 1; goto Again; + when '@' => + if Flag_Psl then + Current_Token := Tok_Arobase; + Pos := Pos + 1; + return; + else + Error_Msg_Scan + ("character """ & Source (Pos) + & """ can only be used in strings or comments"); + Pos := Pos + 1; + goto Again; + end if; when '_' => Error_Msg_Scan ("an identifier can't start with '_'"); Pos := Pos + 1; @@ -67,12 +67,35 @@ package Scan is -- Finalize the scanner. procedure Close_File; - -- If true, comments are reported as a token. + -- If true comments are reported as a token. Flag_Comment : Boolean := False; - -- If true, newlines are reported as a token. + -- If true newlines are reported as a token. Flag_Newline : Boolean := False; + -- If true also scan PSL tokens. + Flag_Psl : Boolean := False; + + -- If true handle PSL embedded in comments: '-- psl' is ignored. + Flag_Psl_Comment : Boolean := False; + + -- If true, ignore '--'. This is automatically set when Flag_Psl_Comment + -- is true and a starting PSL keyword has been identified. + -- Must be reset to false by the parser. + Flag_Scan_In_Comment : Boolean := False; + + -- If true scan for keywords in comments. Must be enabled if + -- Flag_Psl_Comment is true. + Flag_Comment_Keyword : Boolean := False; + + -- If the next character is '!', eat it and return True, otherwise return + -- False (used by PSL). + function Scan_Exclam_Mark return Boolean; + + -- If the next character is '_', eat it and return True, otherwise return + -- False (used by PSL). + function Scan_Underscore return Boolean; + -- Get the current location, or the location of the current token. -- Since a token cannot spread over lines, file and line of the current -- token are the same as those of the current position. @@ -1243,7 +1243,7 @@ package body Sem is end if; L_Ptr := Get_String_Fat_Acc (Get_String_Id (Left)); R_Ptr := Get_String_Fat_Acc (Get_String_Id (Right)); - for I in 1 .. Natural (Len) loop + for I in 1 .. Len loop if L_Ptr (I) /= R_Ptr (I) then return False; end if; diff --git a/sem_assocs.adb b/sem_assocs.adb index e89b29c7e..820f50d28 100644 --- a/sem_assocs.adb +++ b/sem_assocs.adb @@ -551,7 +551,7 @@ package body Sem_Assocs is exit when Index_Type = Null_Iir; Chain := Get_Individual_Association_Chain (Assoc); Sem_Choices_Range - (Chain, Index_Type, False, Get_Location (Assoc), Low, High); + (Chain, Index_Type, False, False, Get_Location (Assoc), Low, High); Set_Individual_Association_Chain (Assoc, Chain); end loop; end Finish_Individual_Assoc_Array_Subtype; @@ -578,7 +578,7 @@ package body Sem_Assocs is end if; Chain := Get_Individual_Association_Chain (Assoc); Sem_Choices_Range - (Chain, Base_Index, True, Get_Location (Assoc), Low, High); + (Chain, Base_Index, True, False, Get_Location (Assoc), Low, High); Set_Individual_Association_Chain (Assoc, Chain); if Actual_Index = Null_Iir then declare diff --git a/sem_expr.adb b/sem_expr.adb index 74b7a1d4e..2293e0a38 100644 --- a/sem_expr.adb +++ b/sem_expr.adb @@ -169,7 +169,8 @@ package body Sem_Expr is | Iir_Kinds_Procedure_Declaration | Iir_Kind_Range_Array_Attribute | Iir_Kind_Reverse_Range_Array_Attribute - | Iir_Kind_Element_Declaration => + | Iir_Kind_Element_Declaration + | Iir_Kind_Psl_Declaration => Error_Msg_Sem (Disp_Node (Expr) & " not allowed in an expression", Loc); return Null_Iir; @@ -1798,7 +1799,7 @@ package body Sem_Expr is Ptr : String_Fat_Acc; El : Iir; pragma Unreferenced (El); - Len : Natural; + Len : Nat32; begin Len := Get_String_Length (Lit); @@ -1818,7 +1819,7 @@ package body Sem_Expr is Set_Expr_Staticness (Lit, Locally); - return Len; + return Natural (Len); end Sem_String_Literal; procedure Sem_String_Literal (Lit: Iir) is @@ -1839,23 +1840,26 @@ package body Sem_Expr is Len := Sem_String_Literal (Lit, El_Type); if Get_Constraint_State (Lit_Type) = Fully_Constrained then + -- The type of the context is constrained. Index_Type := Get_First_Element (Get_Index_Subtype_List (Lit_Type)); if Get_Type_Staticness (Index_Type) = Locally then - if Eval_Discrete_Type_Length (Index_Type) /= Iir_Int64 (Len) - then + if Eval_Discrete_Type_Length (Index_Type) /= Iir_Int64 (Len) then Error_Msg_Sem ("string length does not match that of " & Disp_Node (Index_Type), Lit); end if; - return; + else + -- FIXME: emit a warning because of dubious construct (the type + -- of the string is not locally constrained) ? + null; end if; + else + -- Context type is not constained. Set type of the string literal, + -- according to LRM93 7.3.2.2. + N_Type := Create_Unidim_Array_By_Length + (Lit_Base_Type, Iir_Int64 (Len), Lit); + Set_Type (Lit, N_Type); end if; - - -- Set type of the string literal, - -- according to LRM93 7.3.2.2. - N_Type := Create_Unidim_Array_By_Length - (Lit_Base_Type, Iir_Int64 (Len), Lit); - Set_Type (Lit, N_Type); end Sem_String_Literal; generic @@ -1924,8 +1928,6 @@ package body Sem_Expr is Sel_El_Type : Iir; -- Number of literals in the element type. Sel_El_Length : Iir_Int64; - -- List of literals. - Sel_El_Literal_List : Iir_List; -- Length of SEL (number of characters in SEL). Sel_Length : Iir_Int64; @@ -1939,117 +1941,20 @@ package body Sem_Expr is El : Iir; - type Str_Info is record - El : Iir; - Ptr : String_Fat_Acc; - Len : Natural; - Lit_0 : Iir; - Lit_1 : Iir; - List : Iir_List; - end record; - - -- Fill Res from EL. This is used to speed up Lt and Eq operations. - procedure Get_Info (El : Iir; Res : out Str_Info) - is - Expr : constant Iir := Get_Expression (El); - begin - case Get_Kind (Expr) is - when Iir_Kind_Simple_Aggregate => - Res := Str_Info'(El => Expr, - Ptr => null, - Len => 0, - Lit_0 | Lit_1 => Null_Iir, - List => Get_Simple_Aggregate_List (Expr)); - Res.Len := Get_Nbr_Elements (Res.List); - when Iir_Kind_Bit_String_Literal => - Res := Str_Info'(El => Expr, - Ptr => Get_String_Fat_Acc (Expr), - Len => Get_String_Length (Expr), - Lit_0 => Get_Bit_String_0 (Expr), - Lit_1 => Get_Bit_String_1 (Expr), - List => Null_Iir_List); - when Iir_Kind_String_Literal => - Res := Str_Info'(El => Expr, - Ptr => Get_String_Fat_Acc (Expr), - Len => Get_String_Length (Expr), - Lit_0 | Lit_1 => Null_Iir, - List => Null_Iir_List); - when others => - Error_Kind ("sem_string_choice_range.get_info", Expr); - end case; - end Get_Info; - - -- Return the position of element IDX of STR. - function Get_Pos (Str : Str_Info; Idx : Natural) return Iir_Int32 - is - S : Iir; - C : Character; - begin - case Get_Kind (Str.El) is - when Iir_Kind_Simple_Aggregate => - S := Get_Nth_Element (Str.List, Idx); - when Iir_Kind_String_Literal => - C := Str.Ptr (Idx + 1); - -- FIXME: build a table from character to position. - -- This linear search is O(n)! - S := Find_Name_In_List (Sel_El_Literal_List, - Name_Table.Get_Identifier (C)); - when Iir_Kind_Bit_String_Literal => - C := Str.Ptr (Idx + 1); - case C is - when '0' => - S := Str.Lit_0; - when '1' => - S := Str.Lit_1; - when others => - raise Internal_Error; - end case; - when others => - Error_Kind ("sem_string_choice_range.get_pos", Str.El); - end case; - return Get_Enum_Pos (S); - end Get_Pos; - -- Compare two elements of ARR. -- Return true iff OP1 < OP2. - function Lt (Op1, Op2 : Natural) return Boolean - is - Str1, Str2 : Str_Info; - P1, P2 : Iir_Int32; + function Lt (Op1, Op2 : Natural) return Boolean is begin - Get_Info (Arr (Op1), Str1); - Get_Info (Arr (Op2), Str2); - if Str1.Len /= Str2.Len then - raise Internal_Error; - end if; - - for I in 0 .. Natural (Sel_Length - 1) loop - P1 := Get_Pos (Str1, I); - P2 := Get_Pos (Str2, I); - if P1 /= P2 then - if P1 < P2 then - return True; - else - return False; - end if; - end if; - end loop; - return False; + return Compare_String_Literals (Get_Expression (Arr (Op1)), + Get_Expression (Arr (Op2))) + = Compare_Lt; end Lt; - function Eq (Op1, Op2 : Natural) return Boolean - is - Str1, Str2 : Str_Info; + function Eq (Op1, Op2 : Natural) return Boolean is begin - Get_Info (Arr (Op1), Str1); - Get_Info (Arr (Op2), Str2); - - for I in 0 .. Natural (Sel_Length - 1) loop - if Get_Pos (Str1, I) /= Get_Pos (Str2, I) then - return False; - end if; - end loop; - return True; + return Compare_String_Literals (Get_Expression (Arr (Op1)), + Get_Expression (Arr (Op2))) + = Compare_Eq; end Eq; procedure Swap (From : Natural; To : Natural) @@ -2112,8 +2017,6 @@ package body Sem_Expr is (Get_String_Type_Bound_Type (Sel_Type)); Sel_El_Type := Get_Element_Subtype (Sel_Type); Sel_El_Length := Eval_Discrete_Type_Length (Sel_El_Type); - Sel_El_Literal_List := Get_Enumeration_Literal_List - (Get_Base_Type (Sel_El_Type)); Has_Others := False; Nbr_Choices := 0; @@ -2221,6 +2124,7 @@ package body Sem_Expr is (Choice_Chain : in out Iir; Sub_Type : Iir; Is_Sub_Range : Boolean; + Is_Case_Stmt : Boolean; Loc : Location_Type; Low : out Iir; High : out Iir) @@ -2244,7 +2148,11 @@ package body Sem_Expr is Pos_Max : Iir_Int64; El : Iir; Prev_El : Iir; - --Index_Constraint : Iir; + + -- Staticness of the current choice. + Choice_Staticness : Iir_Staticness; + + -- Staticness of all the choices. Staticness : Iir_Staticness; -- Semantize a simple (by expression or by range) choice. @@ -2398,7 +2306,14 @@ package body Sem_Expr is when Iir_Kind_Choice_By_Expression | Iir_Kind_Choice_By_Range => if Sem_Simple_Choice then - Staticness := Min (Staticness, Get_Choice_Staticness (El)); + Choice_Staticness := Get_Choice_Staticness (El); + Staticness := Min (Staticness, Choice_Staticness); + if Choice_Staticness /= Locally + and then Is_Case_Stmt + then + -- FIXME: explain why + Error_Msg_Sem ("choice is not locally static", El); + end if; else Has_Error := True; end if; @@ -2461,14 +2376,19 @@ package body Sem_Expr is return; end if; if Staticness /= Locally then - -- LRM93 §7.3.2.2 - -- A named association of an array aggregate is allowed to have - -- a choice that is not locally static, or likewise a choice that - -- is a null range, only if the aggregate includes a single - -- element association and the element association has a single - -- choice. - if Nbr_Named > 1 or Has_Others then - Error_Msg_Sem ("not static choice exclude others choice", Loc); + -- Emit a message for aggregrate. The message has already been + -- emitted for a case stmt. + -- FIXME: what about individual associations? + if not Is_Case_Stmt then + -- LRM93 §7.3.2.2 + -- A named association of an array aggregate is allowed to have + -- a choice that is not locally static, or likewise a choice that + -- is a null range, only if the aggregate includes a single + -- element association and the element association has a single + -- choice. + if Nbr_Named > 1 or Has_Others then + Error_Msg_Sem ("not static choice exclude others choice", Loc); + end if; end if; return; end if; @@ -2958,7 +2878,7 @@ package body Sem_Expr is case Get_Kind (Aggr) is when Iir_Kind_Aggregate => Assoc_Chain := Get_Association_Choices_Chain (Aggr); - Sem_Choices_Range (Assoc_Chain, Index_Type, not Constrained, + Sem_Choices_Range (Assoc_Chain, Index_Type, not Constrained, False, Get_Location (Aggr), Low, High); Set_Association_Choices_Chain (Aggr, Assoc_Chain); diff --git a/sem_expr.ads b/sem_expr.ads index 1c7713eb6..2fa594b7f 100644 --- a/sem_expr.ads +++ b/sem_expr.ads @@ -143,6 +143,7 @@ package Sem_Expr is (Choice_Chain : in out Iir; Sub_Type : Iir; Is_Sub_Range : Boolean; + Is_Case_Stmt : Boolean; Loc : Location_Type; Low : out Iir; High : out Iir); diff --git a/sem_names.adb b/sem_names.adb index 31bca5b67..6c1c37872 100644 --- a/sem_names.adb +++ b/sem_names.adb @@ -32,6 +32,7 @@ with Sem_Stmts; use Sem_Stmts; with Sem_Decls; use Sem_Decls; with Sem_Assocs; use Sem_Assocs; with Sem_Types; +with Sem_Psl; with Xrefs; use Xrefs; package body Sem_Names is @@ -1259,6 +1260,8 @@ package body Sem_Names is -- Finish_Sem_Scalar_Type_Attribute (Res, Null_Iir); -- end if; -- return; + when Iir_Kind_Psl_Expression => + return; when others => Error_Kind ("finish_sem_name", Res); end case; @@ -2027,6 +2030,9 @@ package body Sem_Names is (Disp_Node (Prefix) & " cannot be indexed or sliced", Name); Res := Null_Iir; + when Iir_Kind_Psl_Declaration => + Res := Sem_Psl.Sem_Psl_Name (Name); + when others => Error_Kind ("sem_parenthesis_name", Prefix); end case; @@ -3018,6 +3024,8 @@ package body Sem_Names is when Iir_Kind_Implicit_Function_Declaration | Iir_Kind_Function_Declaration => Finish_Sem_Function_Specification (Name, Expr); + when Iir_Kind_Psl_Expression => + null; when others => Error_Kind ("maybe_finish_sem_name", Expr); end case; diff --git a/sem_names.ads b/sem_names.ads index 5fc57fb04..ce7573d45 100644 --- a/sem_names.ads +++ b/sem_names.ads @@ -26,6 +26,7 @@ package Sem_Names is procedure Sem_Name (Name : Iir; Keep_Alias : Boolean); -- Finish semantisation of NAME, if necessary. + -- This make remaining checks, transforms function names into calls... procedure Maybe_Finish_Sem_Name (Name : Iir); -- Same as Sem_Name but without any side-effect: diff --git a/sem_psl.adb b/sem_psl.adb new file mode 100644 index 000000000..a16da5771 --- /dev/null +++ b/sem_psl.adb @@ -0,0 +1,600 @@ +-- Semantic analysis pass for PSL. +-- Copyright (C) 2009 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Types; use Types; +with PSL.Nodes; use PSL.Nodes; +with PSL.Subsets; +with PSL.Hash; + +with Sem_Expr; +with Sem_Stmts; use Sem_Stmts; +with Sem_Scopes; +with Sem_Names; +with Std_Names; +with Iirs_Utils; use Iirs_Utils; +with Std_Package; +with Ieee.Std_Logic_1164; +with Errorout; use Errorout; +with Xrefs; use Xrefs; + +package body Sem_Psl is + -- Return TRUE iff Atype is a PSL boolean type. + -- See PSL1.1 5.1.2 Boolean expressions + function Is_Psl_Bool_Type (Atype : Iir) return Boolean + is + Btype : Iir; + begin + if Atype = Null_Iir then + return False; + end if; + Btype := Get_Base_Type (Atype); + return Btype = Std_Package.Boolean_Type_Definition + or else Btype = Std_Package.Bit_Type_Definition + or else Btype = Ieee.Std_Logic_1164.Std_Ulogic_Type; + end Is_Psl_Bool_Type; + + -- Return TRUE if EXPR type is a PSL boolean type. + function Is_Psl_Bool_Expr (Expr : Iir) return Boolean is + begin + return Is_Psl_Bool_Type (Get_Type (Expr)); + end Is_Psl_Bool_Expr; + + -- Convert VHDL and/or/not nodes to PSL nodes. + function Convert_Bool (Expr : Iir) return Node + is + use Std_Names; + Impl : Iir; + begin + case Get_Kind (Expr) is + when Iir_Kinds_Dyadic_Operator => + declare + Left : Iir; + Right : Iir; + + function Build_Op (Kind : Nkind) return Node + is + N : Node; + begin + N := Create_Node (Kind); + Set_Location (N, Get_Location (Expr)); + Set_Left (N, Convert_Bool (Left)); + Set_Right (N, Convert_Bool (Right)); + Free_Iir (Expr); + return N; + end Build_Op; + begin + Impl := Get_Implementation (Expr); + Left := Get_Left (Expr); + Right := Get_Right (Expr); + if Impl /= Null_Iir + and then Is_Psl_Bool_Expr (Left) + and then Is_Psl_Bool_Expr (Right) + then + if Get_Identifier (Impl) = Name_And then + return Build_Op (N_And_Bool); + elsif Get_Identifier (Impl) = Name_Or then + return Build_Op (N_Or_Bool); + end if; + end if; + end; + when Iir_Kinds_Monadic_Operator => + declare + Operand : Iir; + + function Build_Op (Kind : Nkind) return Node + is + N : Node; + begin + N := Create_Node (Kind); + Set_Location (N, Get_Location (Expr)); + Set_Boolean (N, Convert_Bool (Operand)); + Free_Iir (Expr); + return N; + end Build_Op; + begin + Impl := Get_Implementation (Expr); + Operand := Get_Operand (Expr); + if Impl /= Null_Iir + and then Is_Psl_Bool_Expr (Operand) + then + if Get_Identifier (Impl) = Name_Not then + return Build_Op (N_Not_Bool); + end if; + end if; + end; + when Iir_Kinds_Name => + -- Get the named entity for names in order to hash it. + declare + Name : Iir; + begin + Name := Get_Named_Entity (Expr); + if Name /= Null_Iir then + return PSL.Hash.Get_PSL_Node (HDL_Node (Name)); + end if; + end; + when others => + null; + end case; + return PSL.Hash.Get_PSL_Node (HDL_Node (Expr)); + end Convert_Bool; + + -- Semantize an HDL expression. This may mostly a wrapper except in the + -- case when the expression is in fact a PSL expression. + function Sem_Hdl_Expr (N : Node) return Node + is + use Sem_Names; + + Expr : Iir; + Name : Iir; + Decl : Node; + Res : Node; + begin + Expr := Get_HDL_Node (N); + if Get_Kind (Expr) in Iir_Kinds_Name then + Sem_Name (Expr, False); + Name := Get_Named_Entity (Expr); + case Get_Kind (Name) is + when Iir_Kind_Error => + return N; + when Iir_Kind_Overload_List => + -- FIXME: todo. + raise Internal_Error; + when Iir_Kind_Psl_Declaration => + Decl := Get_Psl_Declaration (Name); + case Get_Kind (Decl) is + when N_Sequence_Declaration => + Res := Create_Node (N_Sequence_Instance); + when N_Endpoint_Declaration => + Res := Create_Node (N_Endpoint_Instance); + when N_Property_Declaration => + Res := Create_Node (N_Property_Instance); + when N_Boolean_Parameter + | N_Sequence_Parameter + | N_Const_Parameter + | N_Property_Parameter => + -- FIXME: create a n_name + Free_Node (N); + Free_Iir (Expr); + return Decl; + when others => + Error_Kind ("sem_hdl_expr(2)", Decl); + end case; + Set_Location (Res, Get_Location (N)); + Set_Declaration (Res, Decl); + if Get_Parameter_List (Decl) /= Null_Node then + Error_Msg_Sem ("no actual for instantiation", Res); + end if; + Free_Node (N); + Free_Iir (Expr); + return Res; + when Iir_Kind_Psl_Expression => + Free_Node (N); + Free_Iir (Expr); + return Get_Psl_Expression (Name); + when others => + Expr := Name; + end case; + else + Expr := Sem_Expr.Sem_Expression (Expr, Null_Iir); + end if; + + if Expr = Null_Iir then + return N; + end if; + Free_Node (N); + if not Is_Psl_Bool_Expr (Expr) then + Error_Msg_Sem ("type of expression must be boolean", Expr); + return PSL.Hash.Get_PSL_Node (HDL_Node (Expr)); + else + return Convert_Bool (Expr); + end if; + end Sem_Hdl_Expr; + + -- Sem a boolean node. + function Sem_Boolean (Bool : Node) return Node is + begin + case Get_Kind (Bool) is + when N_HDL_Expr => + return Sem_Hdl_Expr (Bool); + when N_And_Bool + | N_Or_Bool => + Set_Left (Bool, Sem_Boolean (Get_Left (Bool))); + Set_Right (Bool, Sem_Boolean (Get_Right (Bool))); + return Bool; + when others => + Error_Kind ("psl.sem_boolean", Bool); + end case; + end Sem_Boolean; + + -- Used by Sem_Property to rewrite a property logical operator to a + -- boolean logical operator. + function Reduce_Logic_Node (Prop : Node; Bool_Kind : Nkind) return Node + is + Res : Node; + begin + Res := Create_Node (Bool_Kind); + Set_Location (Res, Get_Location (Prop)); + Set_Left (Res, Get_Left (Prop)); + Set_Right (Res, Get_Right (Prop)); + Free_Node (Prop); + return Res; + end Reduce_Logic_Node; + + function Sem_Sequence (Seq : Node) return Node + is + Res : Node; + L, R : Node; + begin + case Get_Kind (Seq) is + when N_Braced_SERE => + Res := Sem_Sequence (Get_SERE (Seq)); + Set_SERE (Seq, Res); + return Seq; + when N_Concat_SERE + | N_Fusion_SERE + | N_Within_SERE + | N_Or_Seq + | N_And_Seq + | N_Match_And_Seq => + L := Sem_Sequence (Get_Left (Seq)); + Set_Left (Seq, L); + R := Sem_Sequence (Get_Right (Seq)); + Set_Right (Seq, R); + return Seq; + when N_Star_Repeat_Seq => + Res := Get_Sequence (Seq); + if Res /= Null_Node then + Res := Sem_Sequence (Get_Sequence (Seq)); + Set_Sequence (Seq, Res); + end if; + -- FIXME: range. + return Seq; + when N_Plus_Repeat_Seq => + Res := Get_Sequence (Seq); + if Res /= Null_Node then + Res := Sem_Sequence (Get_Sequence (Seq)); + Set_Sequence (Seq, Res); + end if; + return Seq; + when N_And_Bool + | N_Or_Bool + | N_Not_Bool => + return Sem_Boolean (Seq); + when N_HDL_Expr => + return Sem_Hdl_Expr (Seq); + when others => + Error_Kind ("psl.sem_sequence", Seq); + end case; + end Sem_Sequence; + + function Sem_Property (Prop : Node; Top : Boolean := False) return Node + is + Res : Node; + L, R : Node; + begin + case Get_Kind (Prop) is + when N_Braced_SERE => + return Sem_Sequence (Prop); + when N_Always + | N_Never => + -- By extension, clock_event is allowed within outermost + -- always/never. + Res := Sem_Property (Get_Property (Prop), Top); + Set_Property (Prop, Res); + return Prop; + when N_Eventually => + Res := Sem_Property (Get_Property (Prop)); + Set_Property (Prop, Res); + return Prop; + when N_Clock_Event => + Res := Sem_Property (Get_Property (Prop)); + Set_Property (Prop, Res); + Res := Sem_Boolean (Get_Boolean (Prop)); + Set_Boolean (Prop, Res); + if not Top then + Error_Msg_Sem ("inner clock event not supported", Prop); + end if; + return Prop; + when N_Abort => + Res := Sem_Property (Get_Property (Prop)); + Set_Property (Prop, Res); + Res := Sem_Boolean (Get_Boolean (Prop)); + Set_Boolean (Prop, Res); + return Prop; + when N_Until + | N_Before => + Res := Sem_Property (Get_Left (Prop)); + Set_Left (Prop, Res); + Res := Sem_Property (Get_Right (Prop)); + Set_Right (Prop, Res); + return Prop; + when N_Log_Imp_Prop + | N_And_Prop + | N_Or_Prop => + L := Sem_Property (Get_Left (Prop)); + Set_Left (Prop, L); + R := Sem_Property (Get_Right (Prop)); + Set_Right (Prop, R); + if Get_Psl_Type (L) = Type_Boolean + and then Get_Psl_Type (R) = Type_Boolean + then + case Get_Kind (Prop) is + when N_And_Prop => + return Reduce_Logic_Node (Prop, N_And_Bool); + when N_Or_Prop => + return Reduce_Logic_Node (Prop, N_Or_Bool); + when N_Log_Imp_Prop => + return Reduce_Logic_Node (Prop, N_Imp_Bool); + when others => + Error_Kind ("psl.sem_property(log)", Prop); + end case; + end if; + return Prop; + when N_Overlap_Imp_Seq + | N_Imp_Seq => + Res := Sem_Sequence (Get_Sequence (Prop)); + Set_Sequence (Prop, Res); + Res := Sem_Property (Get_Property (Prop)); + Set_Property (Prop, Res); + return Prop; + when N_Next => + -- FIXME: number. + Res := Sem_Property (Get_Property (Prop)); + Set_Property (Prop, Res); + return Prop; + when N_Next_A => + -- FIXME: range. + Res := Sem_Property (Get_Property (Prop)); + Set_Property (Prop, Res); + return Prop; + when N_HDL_Expr => + Res := Sem_Hdl_Expr (Prop); + if not Top and then Get_Kind (Res) = N_Property_Instance then + declare + Decl : constant Node := Get_Declaration (Res); + begin + if Decl /= Null_Node + and then Get_Global_Clock (Decl) /= Null_Node + then + Error_Msg_Sem ("property instance already has a clock", + Prop); + end if; + end; + end if; + return Res; + when others => + Error_Kind ("psl.sem_property", Prop); + end case; + end Sem_Property; + + -- Extract the clock from PROP. + procedure Extract_Clock (Prop : in out Node; Clk : out Node) + is + Child : Node; + begin + Clk := Null_Node; + case Get_Kind (Prop) is + when N_Clock_Event => + Clk := Get_Boolean (Prop); + Prop := Get_Property (Prop); + when N_Always + | N_Never => + Child := Get_Property (Prop); + if Get_Kind (Child) = N_Clock_Event then + Set_Property (Prop, Get_Property (Child)); + Clk := Get_Boolean (Child); + end if; + when N_Property_Instance => + Child := Get_Declaration (Prop); + Clk := Get_Global_Clock (Child); + when others => + null; + end case; + end Extract_Clock; + + -- Sem a property/sequence/endpoint declaration. + procedure Sem_Psl_Declaration (Stmt : Iir) + is + use Sem_Scopes; + Decl : Node; + Prop : Node; + Clk : Node; + Formal : Node; + El : Iir; + begin + Sem_Scopes.Add_Name (Stmt); + Xref_Decl (Stmt); + + Decl := Get_Psl_Declaration (Stmt); + + Open_Declarative_Region; + + -- Make formal parameters visible. + Formal := Get_Parameter_List (Decl); + while Formal /= Null_Node loop + El := Create_Iir (Iir_Kind_Psl_Declaration); + Set_Location (El, Get_Location (Formal)); + Set_Identifier (El, Get_Identifier (Formal)); + Set_Psl_Declaration (El, Formal); + + Sem_Scopes.Add_Name (El); + Xref_Decl (El); + Set_Visible_Flag (El, True); + + Formal := Get_Chain (Formal); + end loop; + + case Get_Kind (Decl) is + when N_Property_Declaration => + -- FIXME: sem formal list + Prop := Get_Property (Decl); + Prop := Sem_Property (Prop, True); + Extract_Clock (Prop, Clk); + Set_Property (Decl, Prop); + Set_Global_Clock (Decl, Clk); + -- Check simple subset restrictions. + PSL.Subsets.Check_Simple (Prop); + when N_Sequence_Declaration + | N_Endpoint_Declaration => + -- FIXME: sem formal list, do not allow property parameter. + Prop := Get_Sequence (Decl); + Prop := Sem_Sequence (Prop); + Set_Sequence (Decl, Prop); + PSL.Subsets.Check_Simple (Prop); + when others => + Error_Kind ("sem_psl_declaration", Decl); + end case; + Set_Visible_Flag (Stmt, True); + + Close_Declarative_Region; + end Sem_Psl_Declaration; + + procedure Sem_Psl_Assert_Statement (Stmt : Iir) + is + Prop : Node; + Clk : Node; + begin + Prop := Get_Psl_Property (Stmt); + Prop := Sem_Property (Prop, True); + Extract_Clock (Prop, Clk); + Set_Psl_Property (Stmt, Prop); + + -- Properties must be clocked. + if Clk = Null_Node then + if Current_Psl_Default_Clock = Null_Iir then + Error_Msg_Sem ("no clock for PSL assert", Stmt); + Clk := Null_Node; + else + Clk := Get_Psl_Boolean (Current_Psl_Default_Clock); + end if; + end if; + Set_PSL_Clock (Stmt, Clk); + + -- Check simple subset restrictions. + PSL.Subsets.Check_Simple (Prop); + end Sem_Psl_Assert_Statement; + + procedure Sem_Psl_Default_Clock (Stmt : Iir) + is + Expr : Node; + begin + if Current_Psl_Default_Clock /= Null_Iir + and then Get_Parent (Current_Psl_Default_Clock) = Get_Parent (Stmt) + then + Error_Msg_Sem + ("redeclaration of PSL default clock in the same region", Stmt); + Error_Msg_Sem (" (previous default clock declaration)", + Current_Psl_Default_Clock); + end if; + Expr := Sem_Boolean (Get_Psl_Boolean (Stmt)); + Set_Psl_Boolean (Stmt, Expr); + Current_Psl_Default_Clock := Stmt; + end Sem_Psl_Default_Clock; + + function Sem_Psl_Instance_Name (Name : Iir) return Iir + is + Prefix : Iir; + Ent : Iir; + Decl : Node; + Formal : Node; + Assoc : Iir; + Res : Node; + Last_Assoc : Node; + Assoc2 : Node; + Actual : Iir; + Psl_Actual : Node; + Res2 : Iir; + begin + Prefix := Get_Prefix (Name); + Ent := Get_Named_Entity (Prefix); + pragma Assert (Get_Kind (Ent) = Iir_Kind_Psl_Declaration); + Decl := Get_Psl_Declaration (Ent); + case Get_Kind (Decl) is + when N_Property_Declaration => + Res := Create_Node (N_Property_Instance); + when N_Sequence_Declaration => + Res := Create_Node (N_Sequence_Instance); + when N_Endpoint_Declaration => + Res := Create_Node (N_Endpoint_Instance); + when others => + Error_Msg_Sem ("can only instantiate a psl declaration", Name); + return Null_Iir; + end case; + Set_Declaration (Res, Decl); + Set_Location (Res, Get_Location (Name)); + Formal := Get_Parameter_List (Decl); + Assoc := Get_Association_Chain (Name); + Last_Assoc := Null_Node; + + while Formal /= Null_Node loop + if Assoc = Null_Iir then + Error_Msg_Sem ("not enough association", Name); + exit; + end if; + if Get_Kind (Assoc) /= Iir_Kind_Association_Element_By_Expression then + Error_Msg_Sem + ("open or individual association not allowed", Assoc); + elsif Get_Formal (Assoc) /= Null_Iir then + Error_Msg_Sem ("named association not allowed in psl", Assoc); + else + Actual := Get_Actual (Assoc); + -- FIXME: currently only boolean are parsed. + Actual := Sem_Expr.Sem_Expression (Actual, Null_Iir); + if Get_Kind (Actual) in Iir_Kinds_Name then + Actual := Get_Named_Entity (Actual); + end if; + Psl_Actual := PSL.Hash.Get_PSL_Node (HDL_Node (Actual)); + end if; + + Assoc2 := Create_Node (N_Actual); + Set_Location (Assoc2, Get_Location (Assoc)); + Set_Formal (Assoc2, Formal); + Set_Actual (Assoc2, Psl_Actual); + if Last_Assoc = Null_Node then + Set_Association_Chain (Res, Assoc2); + else + Set_Chain (Last_Assoc, Assoc2); + end if; + Last_Assoc := Assoc2; + + Formal := Get_Chain (Formal); + Assoc := Get_Chain (Assoc); + end loop; + if Assoc /= Null_Iir then + Error_Msg_Sem ("too many association", Name); + end if; + + Res2 := Create_Iir (Iir_Kind_Psl_Expression); + Set_Psl_Expression (Res2, Res); + Location_Copy (Res2, Name); + return Res2; + end Sem_Psl_Instance_Name; + + -- Called by sem_names to semantize a psl name. + function Sem_Psl_Name (Name : Iir) return Iir is + begin + case Get_Kind (Name) is + when Iir_Kind_Parenthesis_Name => + return Sem_Psl_Instance_Name (Name); + when others => + Error_Kind ("sem_psl_name", Name); + end case; + return Null_Iir; + end Sem_Psl_Name; + +end Sem_Psl; diff --git a/sem_psl.ads b/sem_psl.ads new file mode 100644 index 000000000..59df96f7f --- /dev/null +++ b/sem_psl.ads @@ -0,0 +1,26 @@ +-- Semantic analysis pass for PSL. +-- Copyright (C) 2009 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Iirs; use Iirs; + +package Sem_Psl is + procedure Sem_Psl_Declaration (Stmt : Iir); + procedure Sem_Psl_Assert_Statement (Stmt : Iir); + procedure Sem_Psl_Default_Clock (Stmt : Iir); + function Sem_Psl_Name (Name : Iir) return Iir; +end Sem_Psl; diff --git a/sem_stmts.adb b/sem_stmts.adb index d18a8afa6..b5a8f17e6 100644 --- a/sem_stmts.adb +++ b/sem_stmts.adb @@ -26,6 +26,7 @@ with Sem_Expr; use Sem_Expr; with Sem_Names; use Sem_Names; with Sem_Scopes; use Sem_Scopes; with Sem_Types; +with Sem_Psl; with Std_Names; with Evaluation; use Evaluation; with Iirs_Utils; use Iirs_Utils; @@ -895,7 +896,8 @@ package body Sem_Stmts is Choice_Type := Get_Type (Choice); case Get_Kind (Choice_Type) is when Iir_Kinds_Discrete_Type_Definition => - Sem_Choices_Range (Chain, Choice_Type, False, Loc, Low, High); + Sem_Choices_Range + (Chain, Choice_Type, False, True, Loc, Low, High); when Iir_Kind_Array_Subtype_Definition | Iir_Kind_Array_Type_Definition => if not Is_Unidim_Array_Type (Choice_Type) then @@ -1706,8 +1708,10 @@ package body Sem_Stmts is El: Iir; Prev_El : Iir; Prev_Concurrent_Statement : Iir; + Prev_Psl_Default_Clock : Iir; begin Prev_Concurrent_Statement := Current_Concurrent_Statement; + Prev_Psl_Default_Clock := Current_Psl_Default_Clock; El := Get_Concurrent_Statement_Chain (Parent); Prev_El := Null_Iir; @@ -1766,13 +1770,21 @@ package body Sem_Stmts is Set_Chain (El, Next_El); end if; end; + when Iir_Kind_Psl_Declaration => + Sem_Psl.Sem_Psl_Declaration (El); + when Iir_Kind_Psl_Assert_Statement => + Sem_Psl.Sem_Psl_Assert_Statement (El); + when Iir_Kind_Psl_Default_Clock => + Sem_Psl.Sem_Psl_Default_Clock (El); when others => - Error_Kind ("sem_concurrent_statement", El); + Error_Kind ("sem_concurrent_statement_chain", El); end case; Prev_El := El; El := Get_Chain (El); end loop; + Current_Concurrent_Statement := Prev_Concurrent_Statement; + Current_Psl_Default_Clock := Prev_Psl_Default_Clock; end Sem_Concurrent_Statement_Chain; -- Put labels in declarative region. @@ -1783,13 +1795,20 @@ package body Sem_Stmts is begin Stmt := Get_Concurrent_Statement_Chain (Parent); while Stmt /= Null_Iir loop - Label := Get_Label (Stmt); - if Label /= Null_Identifier then - Sem_Scopes.Add_Name (Stmt); - Name_Visible (Stmt); - Xref_Decl (Stmt); - end if; + case Get_Kind (Stmt) is + when Iir_Kind_Psl_Declaration => + -- Special case for in-lined PSL declarations. + null; + when others => + Label := Get_Label (Stmt); + + if Label /= Null_Identifier then + Sem_Scopes.Add_Name (Stmt); + Name_Visible (Stmt); + Xref_Decl (Stmt); + end if; + end case; -- INT-1991/issue report 27 -- Generate statements represent declarative region and have diff --git a/sem_stmts.ads b/sem_stmts.ads index a420ce0d9..688a576fc 100644 --- a/sem_stmts.ads +++ b/sem_stmts.ads @@ -63,6 +63,10 @@ package Sem_Stmts is function Get_Current_Concurrent_Statement return Iir; pragma Inline (Get_Current_Concurrent_Statement); + -- Current PSL default_clock declaration. + -- Automatically saved and restore while analyzing concurrent statements. + Current_Psl_Default_Clock : Iir; + -- Add a driver for SIG. -- STMT is used in case of error (it is the statement that creates the -- driver). diff --git a/std_names.adb b/std_names.adb index 2118dc809..8ad854b53 100644 --- a/std_names.adb +++ b/std_names.adb @@ -352,6 +352,12 @@ package body Std_Names is raise Program_Error; end if; + if GI ("psl") /= Name_Psl + or GI ("pragma") /= Name_Pragma + then + raise Program_Error; + end if; + -- PSL keywords if GI ("a") /= Name_A or GI ("af") /= Name_Af diff --git a/std_names.ads b/std_names.ads index a425c1c4d..b4455e05e 100644 --- a/std_names.ads +++ b/std_names.ads @@ -489,62 +489,71 @@ package Std_Names is Name_Finish : constant Name_Id := Name_First_Systask + 01; Name_Last_Systask : constant Name_Id := Name_Finish; - Name_First_Psl : constant Name_Id := Name_Last_Systask + 1; - Name_A : constant Name_Id := Name_First_Psl + 00; - Name_Af : constant Name_Id := Name_First_Psl + 01; - Name_Ag : constant Name_Id := Name_First_Psl + 02; - Name_Ax : constant Name_Id := Name_First_Psl + 03; - Name_Abort : constant Name_Id := Name_First_Psl + 04; + Name_First_Comment : constant Name_Id := Name_Last_Systask + 1; + Name_Psl : constant Name_Id := Name_First_Comment + 0; + Name_Pragma : constant Name_Id := Name_First_Comment + 1; + Name_Last_Comment : constant Name_Id := Name_First_Comment + 1; + + -- PSL words. + Name_First_PSL : constant Name_Id := Name_Last_Comment + 1; + Name_A : constant Name_Id := Name_First_PSL + 00; + Name_Af : constant Name_Id := Name_First_PSL + 01; + Name_Ag : constant Name_Id := Name_First_PSL + 02; + Name_Ax : constant Name_Id := Name_First_PSL + 03; + Name_Abort : constant Name_Id := Name_First_PSL + 04; -- Name_Always -- Name_And - Name_Assume : constant Name_Id := Name_First_Psl + 05; - Name_Assume_Guarantee : constant Name_Id := Name_First_Psl + 06; - Name_Before : constant Name_Id := Name_First_Psl + 07; + Name_Assume : constant Name_Id := Name_First_PSL + 05; + Name_Assume_Guarantee : constant Name_Id := Name_First_PSL + 06; + Name_Before : constant Name_Id := Name_First_PSL + 07; -- Name_Boolean - Name_Clock : constant Name_Id := Name_First_Psl + 08; - Name_Const : constant Name_Id := Name_First_Psl + 09; - Name_Cover : constant Name_Id := Name_First_Psl + 10; + Name_Clock : constant Name_Id := Name_First_PSL + 08; + Name_Const : constant Name_Id := Name_First_PSL + 09; + Name_Cover : constant Name_Id := Name_First_PSL + 10; -- Name_Default - Name_E : constant Name_Id := Name_First_Psl + 11; - Name_Ef : constant Name_Id := Name_First_Psl + 12; - Name_Eg : constant Name_Id := Name_First_Psl + 13; - Name_Ex : constant Name_Id := Name_First_Psl + 14; - Name_Endpoint : constant Name_Id := Name_First_Psl + 15; - Name_Eventually : constant Name_Id := Name_First_Psl + 16; - Name_Fairness : constant Name_Id := Name_First_Psl + 17; - Name_Fell : constant Name_Id := Name_First_Psl + 18; - Name_forall : constant Name_Id := Name_First_Psl + 19; - Name_G : constant Name_Id := Name_First_Psl + 20; + Name_E : constant Name_Id := Name_First_PSL + 11; + Name_Ef : constant Name_Id := Name_First_PSL + 12; + Name_Eg : constant Name_Id := Name_First_PSL + 13; + Name_Ex : constant Name_Id := Name_First_PSL + 14; + Name_Endpoint : constant Name_Id := Name_First_PSL + 15; + Name_Eventually : constant Name_Id := Name_First_PSL + 16; + Name_Fairness : constant Name_Id := Name_First_PSL + 17; + Name_Fell : constant Name_Id := Name_First_PSL + 18; + Name_forall : constant Name_Id := Name_First_PSL + 19; + Name_G : constant Name_Id := Name_First_PSL + 20; -- Name_In - Name_Inf : constant Name_Id := Name_First_Psl + 21; - Name_Inherit : constant Name_Id := Name_First_Psl + 22; + Name_Inf : constant Name_Id := Name_First_PSL + 21; + Name_Inherit : constant Name_Id := Name_First_PSL + 22; -- Name_Is - Name_Never : constant Name_Id := Name_First_Psl + 23; + Name_Never : constant Name_Id := Name_First_PSL + 23; -- Name_Next - Name_Next_A : constant Name_Id := Name_First_Psl + 24; - Name_Next_E : constant Name_Id := Name_First_Psl + 25; - Name_Next_Event : constant Name_Id := Name_First_Psl + 26; - Name_Next_Event_A : constant Name_Id := Name_First_Psl + 27; - Name_Next_Event_E : constant Name_Id := Name_First_Psl + 28; + Name_Next_A : constant Name_Id := Name_First_PSL + 24; + Name_Next_E : constant Name_Id := Name_First_PSL + 25; + Name_Next_Event : constant Name_Id := Name_First_PSL + 26; + Name_Next_Event_A : constant Name_Id := Name_First_PSL + 27; + Name_Next_Event_E : constant Name_Id := Name_First_PSL + 28; -- Name_Not -- Name_Or - Name_Property : constant Name_Id := Name_First_Psl + 29; - Name_Prev : constant Name_Id := Name_First_Psl + 30; - Name_Restrict : constant Name_Id := Name_First_Psl + 31; - Name_Restrict_Guarantee : constant Name_Id := Name_First_Psl + 32; - Name_Rose : constant Name_Id := Name_First_Psl + 33; - Name_Sequence : constant Name_Id := Name_First_Psl + 34; - Name_Strong : constant Name_Id := Name_First_Psl + 35; - Name_Union : constant Name_Id := Name_First_Psl + 36; + Name_Property : constant Name_Id := Name_First_PSL + 29; + Name_Prev : constant Name_Id := Name_First_PSL + 30; + Name_Restrict : constant Name_Id := Name_First_PSL + 31; + Name_Restrict_Guarantee : constant Name_Id := Name_First_PSL + 32; + Name_Rose : constant Name_Id := Name_First_PSL + 33; + Name_Sequence : constant Name_Id := Name_First_PSL + 34; + Name_Strong : constant Name_Id := Name_First_PSL + 35; + Name_Union : constant Name_Id := Name_First_PSL + 36; -- Name_Until - Name_Vmode : constant Name_Id := Name_First_Psl + 37; - Name_Vprop : constant Name_Id := Name_First_Psl + 38; - Name_Vunit : constant Name_Id := Name_First_Psl + 39; - Name_W : constant Name_Id := Name_First_Psl + 40; - Name_Whilenot : constant Name_Id := Name_First_Psl + 41; - Name_Within : constant Name_Id := Name_First_Psl + 42; - Name_X : constant Name_Id := Name_First_Psl + 43; - Name_Last_Psl : constant Name_Id := Name_X; + Name_Vmode : constant Name_Id := Name_First_PSL + 37; + Name_Vprop : constant Name_Id := Name_First_PSL + 38; + Name_Vunit : constant Name_Id := Name_First_PSL + 39; + Name_W : constant Name_Id := Name_First_PSL + 40; + Name_Whilenot : constant Name_Id := Name_First_PSL + 41; + Name_Within : constant Name_Id := Name_First_PSL + 42; + Name_X : constant Name_Id := Name_First_PSL + 43; + Name_Last_PSL : constant Name_Id := Name_X; + + subtype Name_Id_PSL_Keywords is + Name_Id range Name_First_PSL .. Name_Last_PSL; -- Initialize the name table with the values defined here. procedure Std_Names_Initialize; diff --git a/str_table.adb b/str_table.adb index b064898d6..947c98792 100644 --- a/str_table.adb +++ b/str_table.adb @@ -62,13 +62,13 @@ package body Str_Table is function Get_Length (Id : String_Id) return Natural is Ptr : String_Fat_Acc; - Len : Natural; + Len : Nat32; begin Ptr := Get_String_Fat_Acc (Id); Len := 1; loop if Ptr (Len) = Nul then - return Len - 1; + return Natural (Len - 1); end if; Len := Len + 1; end loop; @@ -77,11 +77,11 @@ package body Str_Table is function Image (Id : String_Id) return String is Ptr : String_Fat_Acc; - Len : Natural; + Len : Nat32; begin - Len := Get_Length (Id); + Len := Nat32 (Get_Length (Id)); Ptr := Get_String_Fat_Acc (Id); - return Ptr (1 .. Len); + return String (Ptr (1 .. Len)); end Image; procedure Initialize is diff --git a/tokens.adb b/tokens.adb index ad56810a0..2022ecc4b 100644 --- a/tokens.adb +++ b/tokens.adb @@ -40,7 +40,7 @@ package body Tokens is return "'"; when Tok_Double_Star => return "**"; - when Tok_Arrow => + when Tok_Double_Arrow => return "=>"; when Tok_Assign => return ":="; @@ -319,6 +319,74 @@ package body Tokens is when Tok_Protected => return "protected"; + + when Tok_And_And => + return "&&"; + when Tok_Bar_Bar => + return "||"; + when Tok_Left_Curly => + return "{"; + when Tok_Right_Curly => + return "}"; + when Tok_Exclam_Mark => + return "!"; + when Tok_Brack_Star => + return "[*"; + when Tok_Brack_Plus_Brack => + return "[+]"; + when Tok_Brack_Arrow => + return "[->"; + when Tok_Brack_Equal => + return "[="; + when Tok_Bar_Arrow => + return "|->"; + when Tok_Bar_Double_Arrow => + return "|=>"; + when Tok_Minus_Greater => + return "->"; + when Tok_Arobase => + return "@"; + + when Tok_Psl_Default => + return "default"; + when Tok_Psl_Clock => + return "clock"; + when Tok_Psl_Property => + return "property"; + when Tok_Psl_Sequence => + return "sequence"; + when Tok_Psl_Endpoint => + return "endpoint"; + when Tok_Psl_Assert => + return "assert"; + when Tok_Psl_Const => + return "const"; + when Tok_Psl_Boolean => + return "boolean"; + when Tok_Inf => + return "inf"; + when Tok_Within => + return "within"; + when Tok_Abort => + return "abort"; + when Tok_Before => + return "before"; + when Tok_Always => + return "always"; + when Tok_Never => + return "never"; + when Tok_Eventually => + return "eventually"; + when Tok_Next_A => + return "next_a"; + when Tok_Next_E => + return "next_e"; + when Tok_Next_Event => + return "next_event"; + when Tok_Next_Event_A => + return "next_event_a"; + when Tok_Next_Event_E => + return "next_event_e"; end case; end Image; diff --git a/tokens.ads b/tokens.ads index c6e198707..c3fd68345 100644 --- a/tokens.ads +++ b/tokens.ads @@ -29,7 +29,7 @@ package Tokens is Tok_Colon, -- : Tok_Semi_Colon, -- ; Tok_Comma, -- , - Tok_Arrow, -- => + Tok_Double_Arrow, -- => Tok_Tick, -- ' Tok_Double_Star, -- ** Tok_Assign, -- := @@ -61,6 +61,21 @@ package Tokens is -- and adding_operator Tok_Ampersand, -- & + -- PSL + Tok_And_And, -- && + Tok_Bar_Bar, -- || + Tok_Left_Curly, -- { + Tok_Right_Curly, -- } + Tok_Exclam_Mark, -- ! + Tok_Brack_Star, -- [* + Tok_Brack_Plus_Brack, -- [+] + Tok_Brack_Arrow, -- [-> + Tok_Brack_Equal, -- [= + Tok_Bar_Arrow, -- |-> + Tok_Bar_Double_Arrow, -- |=> + Tok_Minus_Greater, -- -> + Tok_Arobase, -- @ + -- multiplying operator Tok_Star, -- * Tok_Slash, -- / @@ -191,7 +206,32 @@ package Tokens is Tok_Ror, -- Added by Vhdl 2000: - Tok_Protected); + Tok_Protected, + + -- PSL words + Tok_Psl_Default, + Tok_Psl_Clock, + Tok_Psl_Property, + Tok_Psl_Sequence, + Tok_Psl_Endpoint, + Tok_Psl_Assert, + + Tok_Psl_Const, + Tok_Psl_Boolean, + Tok_Inf, + + Tok_Within, + Tok_Abort, + Tok_Before, + Tok_Always, + Tok_Never, + Tok_Eventually, + Tok_Next_A, + Tok_Next_E, + Tok_Next_Event, + Tok_Next_Event_A, + Tok_Next_Event_E + ); -- subtype Token_Relation_Type is Token_Type range Tok_And .. Tok_Xnor; subtype Token_Relational_Operator_Type is Token_Type range diff --git a/translate/Makefile b/translate/Makefile index f33e6d52d..3033b3a22 100644 --- a/translate/Makefile +++ b/translate/Makefile @@ -18,7 +18,7 @@ BE=gcc ortho_srcdir=../ortho -GNAT_FLAGS=-aI.. -gnaty3befhkmr -gnata -gnatf -gnatwael +GNAT_FLAGS=-aI.. -aI../psl -gnaty3befhkmr -gnata -gnatf -gnatwael #GNAT_FLAGS+=-O -gnatn LN=ln -s diff --git a/translate/gcc/INSTALL b/translate/gcc/INSTALL index 8b95cea73..e710f9110 100644 --- a/translate/gcc/INSTALL +++ b/translate/gcc/INSTALL @@ -1,6 +1,6 @@ Install file for the binary distribution of GHDL. -GHDL is Copyright 2002 - 2009 Tristan Gingold. +GHDL is Copyright 2002 - 2010 Tristan Gingold. GHDL is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or diff --git a/translate/gcc/README b/translate/gcc/README index 63c3981b1..a2df5d974 100644 --- a/translate/gcc/README +++ b/translate/gcc/README @@ -4,7 +4,7 @@ To get the binary distribution or more information, go to http://ghdl.free.fr Copyright: ********** -GHDL is copyright (c) 2002 - 2009 Tristan Gingold. +GHDL is copyright (c) 2002 - 2010 Tristan Gingold. See the GHDL manual for more details. This program is free software; you can redistribute it and/or modify @@ -55,14 +55,18 @@ end Example; the gcc distribution. You should have a @GCCVERSION@/gcc/vhdl directory. * configure gcc with the --enable-languages=vhdl option. You may of course - add other languages. + add other languages. Also you'd better to disable bootstraping using + --disable-bootstrap. Refer to the gcc installation documentation. * compile gcc. 'make CFLAGS="-O"' is OK * install gcc. This installs the ghdl driver too. 'make install' is OK. -Send bugs and comments to ghdl@free.fr. +There is a mailing list for any questions. You can subscribe via: + https://mail.gna.org/listinfo/ghdl-discuss/ +Please report bugs on https://gna.org/bugs/?group=ghdl + If you cannot compile, please report the gcc version, GNAT version and gcc source version. diff --git a/translate/gcc/dist-common.sh b/translate/gcc/dist-common.sh index e3ccc9139..8ee0c16a0 100644 --- a/translate/gcc/dist-common.sh +++ b/translate/gcc/dist-common.sh @@ -27,8 +27,12 @@ sem_types.ads sem_types.adb sem_assocs.ads sem_assocs.adb +sem_psl.ads +sem_psl.adb canon.adb canon.ads +canon_psl.ads +canon_psl.adb flags.adb flags.ads configuration.adb @@ -37,6 +41,7 @@ nodes.ads nodes.adb options.ads options.adb +psl-errors.ads lists.ads lists.adb iirs.adb @@ -71,6 +76,8 @@ errorout.adb errorout.ads parse.adb parse.ads +parse_psl.ads +parse_psl.adb post_sems.ads post_sems.adb ieee.ads @@ -260,5 +267,38 @@ times.c clock.c linux.c pthread.c -win32.c -win32thr.c" +win32.c" + +psl_files=" +psl.ads +psl-build.adb +psl-build.ads +psl-cse.adb +psl-cse.ads +psl-disp_nfas.adb +psl-disp_nfas.ads +psl-dump_tree.adb +psl-dump_tree.ads +psl-hash.adb +psl-hash.ads +psl-nfas.adb +psl-nfas.ads +psl-nfas-utils.adb +psl-nfas-utils.ads +psl-nodes.adb +psl-nodes.ads +psl-optimize.adb +psl-optimize.ads +psl-prints.adb +psl-prints.ads +psl-priorities.ads +psl-qm.adb +psl-qm.ads +psl-rewrites.adb +psl-rewrites.ads +psl-subsets.adb +psl-subsets.ads +psl-tprint.adb +psl-tprint.ads +sa_bools.adb +sa_bools.ads" diff --git a/translate/gcc/dist.sh b/translate/gcc/dist.sh index e22b27845..f79719b42 100755 --- a/translate/gcc/dist.sh +++ b/translate/gcc/dist.sh @@ -27,7 +27,7 @@ # * Check lists of exported files in this file. # * Create source tar and build binaries: ./dist.sh dist_phase1 # * su root -# * Build binary tar: ./dist.sh dist_phase2 +# * Build binary tar: HOME=~user ./dist.sh dist_phase2 # * Run the testsuites: GHDL=ghdl ./testsuite.sh gcc # * Update website/index.html (./dist.sh website helps) # * upload (./dist upload) @@ -131,6 +131,9 @@ for i in $grt_config_files; do ln -sf $CWD/../grt/config/$i $VHDLDIR/grt/config/$i done +for i in $psl_files; do + ln -sf $CWD/../../psl/$i $VHDLDIR/$i +done } # Create the tar of sources. @@ -180,12 +183,39 @@ do_compile () mkdir $GCCDISTOBJ cd $GCCDISTOBJ export CFLAGS="-O -g" - ../gcc-$GCCVERSION/configure --enable-languages=vhdl --prefix=$PREFIX --disable-bootstrap --with-bugurl="<URL:http://gna.org/projects/ghdl>" --build=i686-pc-linux-gnu --with-gmp=$PWD/../build --with-mpfr=$PWD/../build --disable-shared --disable-libmudflap --disable-libssp --disable-libgomp + + case x86 in + x86) + BUILD=i686-pc-linux-gnu + CONFIG_LIBS="--with-gmp=$PWD/../build --with-mpfr=$PWD/../build" + ;; + x86-64) + BUILD=x86_64-pc-linux-gnu + CONFIG_LIBS="" + ;; + *) + exit 1 + ;; + esac + ../gcc-$GCCVERSION/configure --enable-languages=vhdl --prefix=$PREFIX --disable-bootstrap --with-bugurl="<URL:http://gna.org/projects/ghdl>" --build=$BUILD $CONFIG_LIBS --disable-shared --disable-libmudflap --disable-libssp --disable-libgomp + make make -C gcc vhdl.info cd $CWD } +# Re-package sources, update gcc sources and recompile without reconfiguring. +do_recompile () +{ + set -x + + do_sources + do_update_gcc_sources; + cd $GCCDISTOBJ + export CFLAGS="-O -g" + make +} + check_root () { if [ $UID -ne 0 ]; then @@ -400,6 +430,8 @@ else do_sources ;; compile) do_compile;; + recompile) + do_recompile;; update_gcc) do_update_gcc_sources;; compile2) diff --git a/translate/ghdldrv/Makefile b/translate/ghdldrv/Makefile index d684ce7c9..56c06750c 100644 --- a/translate/ghdldrv/Makefile +++ b/translate/ghdldrv/Makefile @@ -15,7 +15,7 @@ # along with GCC; see the file COPYING. If not, write to the Free # Software Foundation, 59 Temple Place - Suite 330, Boston, MA # 02111-1307, USA. -GNATFLAGS=-gnaty3befhkmr -gnata -gnatwae -aI../.. -aI.. -aI../grt -aO.. -g -gnatf +GNATFLAGS=-gnaty3befhkmr -gnata -gnatwae -aI../.. -aI.. -aI../../psl -aI../grt -aO.. -g -gnatf GRT_FLAGS=-g LIB_CFLAGS=-g -O2 GNATMAKE=gnatmake @@ -66,6 +66,9 @@ ghdl_llvm_jit: GRT_FLAGS+=-DWITH_GNAT_RUN_TIME ghdl_llvm_jit: default_pathes.ads $(GRT_ADD_OBJS) $(ORTHO_DEPS) bindings.o force $(GNATMAKE) -o $@ -aI../../ortho/llvm -aI../../ortho/mcode -aI../../ortho $(GNATFLAGS) ghdl_mcode $(GNAT_BARGS) -largs -m64 bindings.o $(GNAT_LARGS) $(GRT_ADD_OBJS) $(subst @,$(GRTSRCDIR),$(GRT_EXTRA_LIB)) --LINK=g++ +ghdl_simul: default_pathes.ads force + $(GNATMAKE) -aI../../simulate $(GNATFLAGS) ghdl_simul $(GNAT_BARGS) -largs $(GNAT_LARGS) + memsegs_c.o: ../../ortho/mcode/memsegs_c.c $(CC) -c -g -o $@ $< @@ -78,9 +81,6 @@ ghdl_gcc: default_pathes.ads force ghdl_llvm: default_pathes.ads force $(GNATMAKE) $(GNATFLAGS) ghdl_llvm $(GNAT_BARGS) -largs $(GNAT_LARGS) -ghdl_simul: default_pathes.ads force - gnatmake -aI../../simulate $(GNATFLAGS) ghdl_simul $(GNAT_BARGS) -largs $(GNAT_LARGS) - default_pathes.ads: default_pathes.ads.in Makefile curdir=`cd ..; pwd`; \ sed -e "s%@COMPILER_GCC@%$$curdir/ghdl1-gcc%" \ diff --git a/translate/ghdldrv/ghdl_simul.adb b/translate/ghdldrv/ghdl_simul.adb index 757feb223..d4d0abd7a 100644 --- a/translate/ghdldrv/ghdl_simul.adb +++ b/translate/ghdldrv/ghdl_simul.adb @@ -24,6 +24,7 @@ procedure Ghdl_Simul is begin -- Manual elaboration so that the order is known (because it is the order -- used to display help). + Ghdlmain.Version_String := new String'("interpretation"); Ghdlsimul.Register_Commands; Ghdllocal.Register_Commands; Ghdlprint.Register_Commands; diff --git a/translate/ghdldrv/ghdlcomp.adb b/translate/ghdldrv/ghdlcomp.adb index 4dcd208fa..1a07fc0a1 100644 --- a/translate/ghdldrv/ghdlcomp.adb +++ b/translate/ghdldrv/ghdlcomp.adb @@ -482,7 +482,7 @@ package body Ghdlcomp is end Perform_Action; -- Command Make. - type Command_Make is new Command_Lib with null record; + type Command_Make is new Command_Comp with null record; function Decode_Command (Cmd : Command_Make; Name : String) return Boolean; function Get_Short_Help (Cmd : Command_Make) return String; @@ -545,6 +545,13 @@ package body Ghdlcomp is end loop; Set_Date (Libraries.Work_Library, Date); Libraries.Save_Work_Library; + exception + when Compilation_Error => + if Flag_Expect_Failure then + return; + else + raise; + end if; end Perform_Action; -- Command Gen_Makefile. diff --git a/translate/ghdldrv/ghdllocal.adb b/translate/ghdldrv/ghdllocal.adb index 15eebe3f2..3b3ff2bc2 100644 --- a/translate/ghdldrv/ghdllocal.adb +++ b/translate/ghdldrv/ghdllocal.adb @@ -102,8 +102,7 @@ package body Ghdllocal is is pragma Unreferenced (Cmd); begin - Std_Names.Std_Names_Initialize; - Libraries.Init_Pathes; + Options.Initialize; Flag_Ieee := Lib_Standard; Back_End.Finish_Compilation := Finish_Compilation'Access; Flag_Verbose := False; @@ -638,7 +637,7 @@ package body Ghdllocal is Analyze_Files (Args, False); end Perform_Action; - -- Command --clean. + -- Command --clean: remove object files. type Command_Clean is new Command_Lib with null record; function Decode_Command (Cmd : Command_Clean; Name : String) return Boolean; function Get_Short_Help (Cmd : Command_Clean) return String; @@ -736,6 +735,7 @@ package body Ghdllocal is end loop; end Perform_Action; + -- Command --remove: remove object file and library file. type Command_Remove is new Command_Clean with null record; function Decode_Command (Cmd : Command_Remove; Name : String) return Boolean; @@ -771,6 +771,81 @@ package body Ghdllocal is & Nul); end Perform_Action; + -- Command --copy: copy work library to current directory. + type Command_Copy is new Command_Lib with null record; + function Decode_Command (Cmd : Command_Copy; Name : String) return Boolean; + function Get_Short_Help (Cmd : Command_Copy) return String; + procedure Perform_Action (Cmd : in out Command_Copy; Args : Argument_List); + + function Decode_Command (Cmd : Command_Copy; Name : String) return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "--copy"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Copy) return String + is + pragma Unreferenced (Cmd); + begin + return "--copy Copy work library to current directory"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_Copy; Args : Argument_List) + is + pragma Unreferenced (Cmd); + use Name_Table; + use Libraries; + + File : Iir_Design_File; + Dir : Name_Id; + begin + if Args'Length /= 0 then + Error ("command '--copy' does not accept any argument"); + raise Option_Error; + end if; + + Setup_Libraries (False); + Libraries.Load_Std_Library; + Dir := Work_Directory; + Work_Directory := Null_Identifier; + Libraries.Load_Work_Library; + Work_Directory := Dir; + + Dir := Get_Library_Directory (Libraries.Work_Library); + if Dir = Name_Nil or else Dir = Files_Map.Get_Home_Directory then + Error ("cannot copy library on itself (use --remove first)"); + raise Option_Error; + end if; + + File := Get_Design_File_Chain (Libraries.Work_Library); + while File /= Null_Iir loop + -- Copy object files (if any). + declare + Basename : constant String := + Get_Base_Name (Image (Get_Design_File_Filename (File))); + Src : String_Access; + Dst : String_Access; + Success : Boolean; + pragma Unreferenced (Success); + begin + Src := new String'(Image (Dir) & Basename & Get_Object_Suffix.all); + Dst := new String'(Basename & Get_Object_Suffix.all); + Copy_File (Src.all, Dst.all, Success, Overwrite, Full); + -- Be silent in case of error. + Free (Src); + Free (Dst); + end; + if Get_Design_File_Directory (File) = Name_Nil then + Set_Design_File_Directory (File, Dir); + end if; + + File := Get_Chain (File); + end loop; + Libraries.Work_Directory := Name_Nil; + Libraries.Save_Work_Library; + end Perform_Action; + -- Command --disp-standard. type Command_Disp_Standard is new Command_Lib with null record; function Decode_Command (Cmd : Command_Disp_Standard; Name : String) @@ -1090,6 +1165,7 @@ package body Ghdllocal is Register_Command (new Command_Find); Register_Command (new Command_Clean); Register_Command (new Command_Remove); + Register_Command (new Command_Copy); Register_Command (new Command_Disp_Standard); end Register_Commands; end Ghdllocal; diff --git a/translate/ghdldrv/ghdlmain.adb b/translate/ghdldrv/ghdlmain.adb index 6cc3476e1..b34c07f5b 100644 --- a/translate/ghdldrv/ghdlmain.adb +++ b/translate/ghdldrv/ghdlmain.adb @@ -1,5 +1,5 @@ -- GHDL driver - main part. --- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Tristan Gingold +-- Copyright (C) 2002 - 2010 Tristan Gingold -- -- GHDL is free software; you can redistribute it and/or modify it under -- the terms of the GNU General Public License as published by the Free @@ -225,7 +225,7 @@ package body Ghdlmain is Put_Line ("Written by Tristan Gingold."); New_Line; -- Display copyright. Assume 80 cols terminal. - Put_Line ("Copyright (C) 2003 - 2009 Tristan Gingold."); + Put_Line ("Copyright (C) 2003 - 2010 Tristan Gingold."); Put_Line ("GHDL is free software, covered by the " & "GNU General Public License. There is NO"); Put_Line ("warranty; not even for MERCHANTABILITY or" diff --git a/translate/ghdldrv/ghdlprint.adb b/translate/ghdldrv/ghdlprint.adb index 8947e6492..9eaba5ce0 100644 --- a/translate/ghdldrv/ghdlprint.adb +++ b/translate/ghdldrv/ghdlprint.adb @@ -385,6 +385,28 @@ package body Ghdlprint is else Disp_Identifier; end if; + when Tok_Psl_Default + | Tok_Psl_Clock + | Tok_Psl_Property + | Tok_Psl_Sequence + | Tok_Psl_Endpoint + | Tok_Psl_Assert + | Tok_Psl_Boolean + | Tok_Psl_Const + | Tok_Inf + | Tok_Within + | Tok_Abort + | Tok_Before + | Tok_Always + | Tok_Never + | Tok_Eventually + | Tok_Next_A + | Tok_Next_E + | Tok_Next_Event + | Tok_Next_Event_A + | Tok_Next_Event_E => + Disp_Spaces; + Disp_Text; when Tok_String | Tok_Bit_String | Tok_Character => diff --git a/translate/ghdldrv/ghdlrun.adb b/translate/ghdldrv/ghdlrun.adb index 4e13a4fcd..519181352 100644 --- a/translate/ghdldrv/ghdlrun.adb +++ b/translate/ghdldrv/ghdlrun.adb @@ -264,11 +264,15 @@ package body Ghdlrun is Grt.Lib.Ghdl_Malloc0'Address); Def (Trans_Decls.Ghdl_Assert_Default_Report, Grt.Lib.Ghdl_Assert_Default_Report'Address); + Def (Trans_Decls.Ghdl_Std_Ulogic_To_Boolean_Array, + Grt.Lib.Ghdl_Std_Ulogic_To_Boolean_Array'Address); Def (Trans_Decls.Ghdl_Report, Grt.Lib.Ghdl_Report'Address); Def (Trans_Decls.Ghdl_Assert_Failed, Grt.Lib.Ghdl_Assert_Failed'Address); + Def (Trans_Decls.Ghdl_Psl_Assert_Failed, + Grt.Lib.Ghdl_Psl_Assert_Failed'Address); Def (Trans_Decls.Ghdl_Program_Error, Grt.Lib.Ghdl_Program_Error'Address); Def (Trans_Decls.Ghdl_Malloc, @@ -288,6 +292,9 @@ package body Ghdlrun is Grt.Processes.Ghdl_Postponed_Sensitized_Process_Register'Address); Def (Trans_Decls.Ghdl_Postponed_Process_Register, Grt.Processes.Ghdl_Postponed_Process_Register'Address); + Def (Trans_Decls.Ghdl_Finalize_Register, + Grt.Processes.Ghdl_Finalize_Register'Address); + Def (Trans_Decls.Ghdl_Stack2_Allocate, Grt.Processes.Ghdl_Stack2_Allocate'Address); Def (Trans_Decls.Ghdl_Stack2_Mark, diff --git a/translate/ghdldrv/ghdlsimul.adb b/translate/ghdldrv/ghdlsimul.adb index 506b2ed02..abeb7bb9f 100644 --- a/translate/ghdldrv/ghdlsimul.adb +++ b/translate/ghdldrv/ghdlsimul.adb @@ -25,6 +25,7 @@ with Back_End; with Name_Table; with Errorout; use Errorout; with Std_Package; +with Libraries; with Canon; with Configuration; with Annotations; @@ -37,6 +38,7 @@ with Ghdlcomp; package body Ghdlsimul is Flag_Expect_Failure : Boolean := False; + pragma Unreferenced (Flag_Expect_Failure); procedure Compile_Init (Analyze_Only : Boolean) is begin @@ -73,7 +75,6 @@ package body Ghdlsimul is end Compile_Elab; -- Set options. - -- This is a little bit over-kill: from C to Ada and then again to C... procedure Set_Run_Options (Args : Argument_List) is Arg : String_Access; diff --git a/translate/ghdldrv/ortho_code-x86-flags.ads b/translate/ghdldrv/ortho_code-x86-flags.ads new file mode 100644 index 000000000..40f0bd8fe --- /dev/null +++ b/translate/ghdldrv/ortho_code-x86-flags.ads @@ -0,0 +1,2 @@ +with Ortho_Code.X86.Flags_Linux; +package Ortho_Code.X86.Flags renames Ortho_Code.X86.Flags_Linux; diff --git a/translate/grt/ghwlib.c b/translate/grt/ghwlib.c index 45856889c..2db63d9c9 100644 --- a/translate/grt/ghwlib.c +++ b/translate/grt/ghwlib.c @@ -296,7 +296,7 @@ ghw_read_range (struct ghw_handler *h) int ghw_read_str (struct ghw_handler *h) { - char hdr[12]; + unsigned char hdr[12]; int i; char *p; int prev_len; @@ -435,7 +435,7 @@ get_range_length (union ghw_range *rng) int ghw_read_type (struct ghw_handler *h) { - char hdr[8]; + unsigned char hdr[8]; int i; if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) @@ -777,7 +777,7 @@ ghw_read_value (struct ghw_handler *h, int ghw_read_hie (struct ghw_handler *h) { - char hdr[16]; + unsigned char hdr[16]; int nbr_scopes; int nbr_sigs; int i; @@ -1100,7 +1100,7 @@ ghw_read_signal_value (struct ghw_handler *h, struct ghw_sig *s) int ghw_read_snapshot (struct ghw_handler *h) { - char hdr[12]; + unsigned char hdr[12]; int i; struct ghw_sig *s; @@ -1138,7 +1138,7 @@ void ghw_disp_values (struct ghw_handler *h); int ghw_read_cycle_start (struct ghw_handler *h) { - char hdr[8]; + unsigned char hdr[8]; if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) return -1; diff --git a/translate/grt/ghwlib.h b/translate/grt/ghwlib.h index dbf20fe80..0138267ed 100644 --- a/translate/grt/ghwlib.h +++ b/translate/grt/ghwlib.h @@ -150,7 +150,7 @@ struct ghw_type_enum const char *name; enum ghw_wkt_type wkt; - int nbr; + unsigned int nbr; const char **lits; }; @@ -179,7 +179,7 @@ struct ghw_type_array enum ghdl_rtik kind; const char *name; - int nbr_dim; + unsigned int nbr_dim; union ghw_type *el; union ghw_type **dims; }; @@ -214,7 +214,7 @@ struct ghw_type_record enum ghdl_rtik kind; const char *name; - int nbr_fields; + unsigned int nbr_fields; int nbr_el; /* Number of scalar signals. */ struct ghw_record_element *el; }; diff --git a/translate/grt/grt-cbinding.c b/translate/grt/grt-cbinding.c index 1b75fcfa0..eb04a9cc3 100644 --- a/translate/grt/grt-cbinding.c +++ b/translate/grt/grt-cbinding.c @@ -37,6 +37,13 @@ __ghdl_get_stderr (void) return stderr; } +int +__ghdl_snprintf_g (char *buf, unsigned int len, double val) +{ + snprintf (buf, len, "%g", val); + return strlen (buf); +} + void __ghdl_fprintf_g (FILE *stream, double val) { diff --git a/translate/grt/grt-disp_signals.adb b/translate/grt/grt-disp_signals.adb index 85acb93a0..6a2d0c1c2 100644 --- a/translate/grt/grt-disp_signals.adb +++ b/translate/grt/grt-disp_signals.adb @@ -27,9 +27,63 @@ with Grt.Errors; use Grt.Errors; pragma Elaborate_All (Grt.Rtis_Utils); with Grt.Vstrings; use Grt.Vstrings; with Grt.Options; +with Grt.Processes; with Grt.Disp; use Grt.Disp; package body Grt.Disp_Signals is + procedure Foreach_Scalar_Signal + (Process : access procedure (Val_Addr : Address; + Val_Name : Vstring; + Val_Type : Ghdl_Rti_Access; + Param : Rti_Object)) + is + procedure Call_Process (Val_Addr : Address; + Val_Name : Vstring; + Val_Type : Ghdl_Rti_Access; + Param : Rti_Object) is + begin + Process.all (Val_Addr, Val_Name, Val_Type, Param); + end Call_Process; + + pragma Inline (Call_Process); + + procedure Foreach_Scalar_Signal_Signal is new + Foreach_Scalar (Param_Type => Rti_Object, + Process => Call_Process); + + function Foreach_Scalar_Signal_Object + (Ctxt : Rti_Context; Obj : Ghdl_Rti_Access) + return Traverse_Result + is + Sig : Ghdl_Rtin_Object_Acc; + begin + case Obj.Kind is + when Ghdl_Rtik_Signal + | Ghdl_Rtik_Port + | Ghdl_Rtik_Guard + | Ghdl_Rtik_Attribute_Quiet + | Ghdl_Rtik_Attribute_Stable + | Ghdl_Rtik_Attribute_Transaction => + Sig := To_Ghdl_Rtin_Object_Acc (Obj); + Foreach_Scalar_Signal_Signal + (Ctxt, Sig.Obj_Type, + Loc_To_Addr (Sig.Common.Depth, Sig.Loc, Ctxt), True, + Rti_Object'(Obj, Ctxt)); + when others => + null; + end case; + return Traverse_Ok; + end Foreach_Scalar_Signal_Object; + + function Foreach_Scalar_Signal_Traverse is + new Traverse_Blocks (Process => Foreach_Scalar_Signal_Object); + + Res : Traverse_Result; + pragma Unreferenced (Res); + begin + Res := Foreach_Scalar_Signal_Traverse (Get_Top_Context); + end Foreach_Scalar_Signal; + procedure Disp_Context (Ctxt : Rti_Context) is Blk : Ghdl_Rtin_Block_Acc; @@ -166,90 +220,106 @@ package body Grt.Disp_Signals is New_Line; end Disp_Simple_Signal; - procedure Disp_Scalar_Signal (Val_Addr : Address; - Val_Name : Vstring; - Val_Type : Ghdl_Rti_Access) - is - begin - Put (stdout, Val_Name); - Disp_Simple_Signal (To_Ghdl_Signal_Ptr (To_Addr_Acc (Val_Addr).all), - Val_Type, Options.Disp_Sources); - end Disp_Scalar_Signal; - - procedure Foreach_Scalar_Signal is new - Foreach_Scalar (Process => Disp_Scalar_Signal); - - procedure Disp_Signal_Name (Stream : FILEs; Sig : Ghdl_Rtin_Object_Acc) is + procedure Disp_Signal_Name (Stream : FILEs; + Ctxt : Rti_Context; + Sig : Ghdl_Rtin_Object_Acc) is begin case Sig.Common.Kind is when Ghdl_Rtik_Signal | Ghdl_Rtik_Port | Ghdl_Rtik_Guard => + Put (stdout, Ctxt); + Put ("."); Put (Stream, Sig.Name); when Ghdl_Rtik_Attribute_Quiet => + Put (stdout, Ctxt); + Put ("."); Put (Stream, " 'quiet"); when Ghdl_Rtik_Attribute_Stable => + Put (stdout, Ctxt); + Put ("."); Put (Stream, " 'stable"); when Ghdl_Rtik_Attribute_Transaction => + Put (stdout, Ctxt); + Put ("."); Put (Stream, " 'quiet"); when others => null; end case; end Disp_Signal_Name; - function Disp_Signal (Ctxt : Rti_Context; - Obj : Ghdl_Rti_Access) - return Traverse_Result + procedure Disp_Scalar_Signal (Val_Addr : Address; + Val_Name : Vstring; + Val_Type : Ghdl_Rti_Access; + Parent : Rti_Object) is - Sig : Ghdl_Rtin_Object_Acc; begin - case Obj.Kind is - when Ghdl_Rtik_Signal - | Ghdl_Rtik_Port - | Ghdl_Rtik_Guard - | Ghdl_Rtik_Attribute_Quiet - | Ghdl_Rtik_Attribute_Stable - | Ghdl_Rtik_Attribute_Transaction => - Sig := To_Ghdl_Rtin_Object_Acc (Obj); - Put (stdout, Ctxt); - Put ("."); - Disp_Signal_Name (stdout, Sig); - Foreach_Scalar_Signal - (Ctxt, Sig.Obj_Type, - Loc_To_Addr (Sig.Common.Depth, Sig.Loc, Ctxt), True); - when others => - null; - end case; - return Traverse_Ok; - end Disp_Signal; + Disp_Signal_Name (stdout, Parent.Ctxt, + To_Ghdl_Rtin_Object_Acc (Parent.Obj)); + Put (stdout, Val_Name); + Disp_Simple_Signal (To_Ghdl_Signal_Ptr (To_Addr_Acc (Val_Addr).all), + Val_Type, Options.Disp_Sources); + end Disp_Scalar_Signal; + - function Disp_All_Signals is new Traverse_Blocks (Process => Disp_Signal); + procedure Disp_All_Signals is + begin + Foreach_Scalar_Signal (Disp_Scalar_Signal'access); + end Disp_All_Signals; + + -- Option disp-sensitivity - procedure Disp_All_Signals + procedure Disp_Scalar_Sensitivity (Val_Addr : Address; + Val_Name : Vstring; + Val_Type : Ghdl_Rti_Access; + Parent : Rti_Object) is - Res : Traverse_Result; - pragma Unreferenced (Res); + pragma Unreferenced (Val_Type); + Sig : Ghdl_Signal_Ptr; + + Action : Action_List_Acc; begin - if Boolean'(False) then - for I in Sig_Table.First .. Sig_Table.Last loop - Disp_Simple_Signal - (Sig_Table.Table (I), null, Options.Disp_Sources); - end loop; + Sig := To_Ghdl_Signal_Ptr (To_Addr_Acc (Val_Addr).all); + if Sig.Flags.Seen then + return; else - Res := Disp_All_Signals (Get_Top_Context); + Sig.Flags.Seen := True; end if; - end Disp_All_Signals; + Disp_Signal_Name (stdout, Parent.Ctxt, + To_Ghdl_Rtin_Object_Acc (Parent.Obj)); + Put (stdout, Val_Name); + New_Line (stdout); + Action := Sig.Event_List; + while Action /= null loop + Put (stdout, " wakeup "); + Grt.Processes.Disp_Process_Name (stdout, Action.Proc); + New_Line (stdout); + Action := Action.Next; + end loop; + if Sig.S.Mode_Sig in Mode_Signal_User then + for I in 1 .. Sig.S.Nbr_Drivers loop + Put (stdout, " driven "); + Grt.Processes.Disp_Process_Name + (stdout, Sig.S.Drivers (I - 1).Proc); + New_Line (stdout); + end loop; + end if; + end Disp_Scalar_Sensitivity; - -- Option disp-signals-map + procedure Disp_All_Sensitivity is + begin + Foreach_Scalar_Signal (Disp_Scalar_Sensitivity'access); + end Disp_All_Sensitivity; - Cur_Signals_Map_Ctxt : Rti_Context; - Cur_Signals_Map_Obj : Ghdl_Rtin_Object_Acc; + + -- Option disp-signals-map procedure Disp_Signals_Map_Scalar (Val_Addr : Address; Val_Name : Vstring; - Val_Type : Ghdl_Rti_Access) + Val_Type : Ghdl_Rti_Access; + Parent : Rti_Object) is pragma Unreferenced (Val_Type); @@ -258,9 +328,8 @@ package body Grt.Disp_Signals is S : Ghdl_Signal_Ptr; begin - Put (stdout, Cur_Signals_Map_Ctxt); - Put ("."); - Disp_Signal_Name (stdout, Cur_Signals_Map_Obj); + Disp_Signal_Name (stdout, + Parent.Ctxt, To_Ghdl_Rtin_Object_Acc (Parent.Obj)); Put (stdout, Val_Name); Put (": "); S := To_Ghdl_Signal_Ptr (To_Addr_Acc (Val_Addr).all); @@ -273,43 +342,9 @@ package body Grt.Disp_Signals is New_Line; end Disp_Signals_Map_Scalar; - procedure Foreach_Disp_Signals_Map_Scalar is new - Foreach_Scalar (Process => Disp_Signals_Map_Scalar); - - function Disp_Signals_Map_Signal (Ctxt : Rti_Context; - Obj : Ghdl_Rti_Access) - return Traverse_Result - is - Sig : Ghdl_Rtin_Object_Acc renames Cur_Signals_Map_Obj; - begin - case Obj.Kind is - when Ghdl_Rtik_Signal - | Ghdl_Rtik_Port - | Ghdl_Rtik_Guard - | Ghdl_Rtik_Attribute_Stable - | Ghdl_Rtik_Attribute_Quiet - | Ghdl_Rtik_Attribute_Transaction => - Cur_Signals_Map_Ctxt := Ctxt; - Cur_Signals_Map_Obj := To_Ghdl_Rtin_Object_Acc (Obj); - Foreach_Disp_Signals_Map_Scalar - (Ctxt, Sig.Obj_Type, - Loc_To_Addr (Sig.Common.Depth, Sig.Loc, Ctxt), True); - when others => - null; - end case; - return Traverse_Ok; - end Disp_Signals_Map_Signal; - - function Disp_Signals_Map_Blocks is new Traverse_Blocks - (Process => Disp_Signals_Map_Signal); - - procedure Disp_Signals_Map - is - Res : Traverse_Result; - pragma Unreferenced (Res); + procedure Disp_Signals_Map is begin - Res := Disp_Signals_Map_Blocks (Get_Top_Context); - Grt.Stdio.fflush (stdout); + Foreach_Scalar_Signal (Disp_Signals_Map_Scalar'access); end Disp_Signals_Map; -- Option --disp-signals-table @@ -407,24 +442,24 @@ package body Grt.Disp_Signals is procedure Process_Scalar (Val_Addr : Address; Val_Name : Vstring; - Val_Type : Ghdl_Rti_Access) + Val_Type : Ghdl_Rti_Access; + Param : Boolean) is pragma Unreferenced (Val_Type); + pragma Unreferenced (Param); Sig1 : Ghdl_Signal_Ptr; begin -- Read the signal. Sig1 := To_Ghdl_Signal_Ptr (To_Addr_Acc (Val_Addr).all); if Sig1 = Sig and not Found then - Put (Stream, Cur_Ctxt); - Put (Stream, "."); - Disp_Signal_Name (Stream, Cur_Sig); + Disp_Signal_Name (Stream, Cur_Ctxt, Cur_Sig); Put (Stream, Val_Name); Found := True; end if; end Process_Scalar; procedure Foreach_Scalar is new Grt.Rtis_Utils.Foreach_Scalar - (Process_Scalar); + (Param_Type => Boolean, Process => Process_Scalar); function Process_Block (Ctxt : Rti_Context; Obj : Ghdl_Rti_Access) @@ -442,7 +477,8 @@ package body Grt.Disp_Signals is Cur_Sig := To_Ghdl_Rtin_Object_Acc (Obj); Foreach_Scalar (Ctxt, Cur_Sig.Obj_Type, - Loc_To_Addr (Cur_Sig.Common.Depth, Cur_Sig.Loc, Ctxt), True); + Loc_To_Addr (Cur_Sig.Common.Depth, Cur_Sig.Loc, Ctxt), + True, True); if Found then return Traverse_Stop; end if; diff --git a/translate/grt/grt-disp_signals.ads b/translate/grt/grt-disp_signals.ads index fd84fe036..398d4e575 100644 --- a/translate/grt/grt-disp_signals.ads +++ b/translate/grt/grt-disp_signals.ads @@ -26,6 +26,8 @@ package Grt.Disp_Signals is procedure Disp_Signals_Table; + procedure Disp_All_Sensitivity; + procedure Disp_Mode_Signal (Mode : Mode_Signal_Type); -- Disp informations on signal SIG. diff --git a/translate/grt/grt-lib.adb b/translate/grt/grt-lib.adb index dcddcf29b..d35c73b1f 100644 --- a/translate/grt/grt-lib.adb +++ b/translate/grt/grt-lib.adb @@ -106,6 +106,16 @@ package body Grt.Lib is Do_Report ("assertion", Str, Severity, Loc, Unit); end Ghdl_Assert_Failed; + procedure Ghdl_Psl_Assert_Failed + (Str : Std_String_Ptr; + Severity : Integer; + Loc : Ghdl_Location_Ptr; + Unit : Ghdl_Rti_Access) + is + begin + Do_Report ("psl assertion", Str, Severity, Loc, Unit); + end Ghdl_Psl_Assert_Failed; + procedure Ghdl_Report (Str : Std_String_Ptr; Severity : Integer; @@ -257,7 +267,6 @@ package body Grt.Lib is return 1.0 / Res; end if; end Ghdl_Real_Exp; - end Grt.Lib; diff --git a/translate/grt/grt-lib.ads b/translate/grt/grt-lib.ads index 5bb2cd437..d58117bc7 100644 --- a/translate/grt/grt-lib.ads +++ b/translate/grt/grt-lib.ads @@ -30,6 +30,12 @@ package Grt.Lib is Loc : Ghdl_Location_Ptr; Unit : Ghdl_Rti_Access); + procedure Ghdl_Psl_Assert_Failed + (Str : Std_String_Ptr; + Severity : Integer; + Loc : Ghdl_Location_Ptr; + Unit : Ghdl_Rti_Access); + procedure Ghdl_Report (Str : Std_String_Ptr; Severity : Integer; @@ -79,10 +85,26 @@ package Grt.Lib is -- the export pragma. pragma Export (C, Ghdl_Assert_Default_Report, "__ghdl_assert_default_report"); + + type Ghdl_Std_Ulogic_Boolean_Array_Type is array (Ghdl_E8 range 0 .. 8) + of Ghdl_B2; + + Ghdl_Std_Ulogic_To_Boolean_Array : + constant Ghdl_Std_Ulogic_Boolean_Array_Type := (False, -- U + False, -- X + False, -- 0 + True, -- 1 + False, -- Z + False, -- W + False, -- L + True, -- H + False -- - + ); private pragma Export (C, Ghdl_Memcpy, "__ghdl_memcpy"); pragma Export (C, Ghdl_Assert_Failed, "__ghdl_assert_failed"); + pragma Export (C, Ghdl_Psl_Assert_Failed, "__ghdl_psl_assert_failed"); pragma Export (C, Ghdl_Report, "__ghdl_report"); pragma Export (C, Ghdl_Bound_Check_Failed_L0, @@ -97,6 +119,9 @@ private pragma Export (C, Ghdl_Integer_Exp, "__ghdl_integer_exp"); pragma Export (C, Ghdl_Real_Exp, "__ghdl_real_exp"); + + pragma Export (C, Ghdl_Std_Ulogic_To_Boolean_Array, + "__ghdl_std_ulogic_to_boolean_array"); end Grt.Lib; diff --git a/translate/grt/grt-main.adb b/translate/grt/grt-main.adb index 43166fa0a..a19699914 100644 --- a/translate/grt/grt-main.adb +++ b/translate/grt/grt-main.adb @@ -149,6 +149,9 @@ package body Grt.Main is if Disp_Signals_Order then Grt.Disp.Disp_Signals_Order; end if; + if Disp_Sensitivity then + Grt.Disp_Signals.Disp_All_Sensitivity; + end if; -- Do the simulation. Status := Grt.Processes.Simulation; diff --git a/translate/grt/grt-options.adb b/translate/grt/grt-options.adb index a272246be..6d7384342 100644 --- a/translate/grt/grt-options.adb +++ b/translate/grt/grt-options.adb @@ -281,6 +281,8 @@ package body Grt.Options is Disp_Signals_Map := True; elsif Argument = "--disp-signals-table" then Disp_Signals_Table := True; + elsif Argument = "--disp-sensitivity" then + Disp_Sensitivity := True; elsif Argument = "--stats" then Flag_Stats := True; elsif Argument = "--no-run" then diff --git a/translate/grt/grt-options.ads b/translate/grt/grt-options.ads index 3057fc8e3..1d122caae 100644 --- a/translate/grt/grt-options.ads +++ b/translate/grt/grt-options.ads @@ -72,6 +72,7 @@ package Grt.Options is Disp_Sources : Boolean := False; Disp_Signals_Map : Boolean := False; Disp_Signals_Table : Boolean := False; + Disp_Sensitivity : Boolean := False; -- Set by --disp-order to diplay evaluation order of signals. Disp_Signals_Order : Boolean := False; diff --git a/translate/grt/grt-processes.adb b/translate/grt/grt-processes.adb index 72d3f8eea..0a57565cd 100644 --- a/translate/grt/grt-processes.adb +++ b/translate/grt/grt-processes.adb @@ -46,9 +46,20 @@ package body Grt.Processes is Table_Low_Bound => 1, Table_Initial => 16); - -- List of non_sensitized processes. - package Non_Sensitized_Process_Table is new Grt.Table - (Table_Component_Type => Process_Acc, + function To_Proc_Acc is new Ada.Unchecked_Conversion + (Source => System.Address, Target => Proc_Acc); + + type Finalizer_Type is record + -- Subprogram containing process code. + Subprg : Proc_Acc; + + -- Instance (THIS parameter) for the subprogram. + This : System.Address; + end record; + + -- List of finalizer. + package Finalizer_Table is new Grt.Table + (Table_Component_Type => Finalizer_Type, Table_Index_Type => Natural, Table_Low_Bound => 1, Table_Initial => 2); @@ -106,8 +117,6 @@ package body Grt.Processes is State : Process_State; Postponed : Boolean) is - function To_Proc_Acc is new Ada.Unchecked_Conversion - (Source => System.Address, Target => Proc_Acc); Stack : Stack_Type; P : Process_Acc; begin @@ -133,9 +142,6 @@ package body Grt.Processes is Process_Table.Append (P); -- Used to create drivers. Set_Current_Process (P); - if State /= State_Sensitized then - Non_Sensitized_Process_Table.Append (P); - end if; if Postponed then Nbr_Postponed_Processes := Nbr_Postponed_Processes + 1; else @@ -228,6 +234,22 @@ package body Grt.Processes is (Sig, Process_Table.Table (Process_Table.Last)); end Ghdl_Process_Add_Sensitivity; + procedure Ghdl_Finalize_Register (Instance : System.Address; + Proc : System.Address) + is + begin + Finalizer_Table.Append (Finalizer_Type'(To_Proc_Acc (Proc), Instance)); + end Ghdl_Finalize_Register; + + procedure Call_Finalizers is + El : Finalizer_Type; + begin + for I in Finalizer_Table.First .. Finalizer_Table.Last loop + El := Finalizer_Table.Table (I); + El.Subprg.all (El.This); + end loop; + end Call_Finalizers; + procedure Resume_Process (Proc : Process_Acc) is begin @@ -983,6 +1005,8 @@ package body Grt.Processes is Threads.Finish; end if; + Call_Finalizers; + Grt.Hooks.Call_Finish_Hooks; if Status = Run_Failure then diff --git a/translate/grt/grt-processes.ads b/translate/grt/grt-processes.ads index 1d5bb5f78..b59a5b131 100644 --- a/translate/grt/grt-processes.ads +++ b/translate/grt/grt-processes.ads @@ -81,6 +81,9 @@ package Grt.Processes is Ctxt : Ghdl_Rti_Access; Addr : System.Address); + procedure Ghdl_Finalize_Register (Instance : System.Address; + Proc : System.Address); + procedure Ghdl_Initial_Register (Instance : System.Address; Proc : System.Address); procedure Ghdl_Always_Register (Instance : System.Address; @@ -192,6 +195,8 @@ private pragma Export (C, Ghdl_Postponed_Sensitized_Process_Register, "__ghdl_postponed_sensitized_process_register"); + pragma Export (C, Ghdl_Finalize_Register, "__ghdl_finalize_register"); + pragma Export (C, Ghdl_Always_Register, "__ghdl_always_register"); pragma Export (C, Ghdl_Initial_Register, "__ghdl_initial_register"); diff --git a/translate/grt/grt-rtis.ads b/translate/grt/grt-rtis.ads index 305940850..564b39741 100644 --- a/translate/grt/grt-rtis.ads +++ b/translate/grt/grt-rtis.ads @@ -151,10 +151,10 @@ package Grt.Rtis is Ghdl_Rti_Signal_Mode_Inout : constant Ghdl_Rti_U8 := 4; Ghdl_Rti_Signal_Mode_In : constant Ghdl_Rti_U8 := 5; - Ghdl_Rti_Signal_Kind_Mask : constant Ghdl_Rti_U8 := 48; - Ghdl_Rti_Signal_Kind_No : constant Ghdl_Rti_U8 := 0; - Ghdl_Rti_Signal_Kind_Register : constant Ghdl_Rti_U8 := 16; - Ghdl_Rti_Signal_Kind_Bus : constant Ghdl_Rti_U8 := 32; + Ghdl_Rti_Signal_Kind_Mask : constant Ghdl_Rti_U8 := 3 * 16; + Ghdl_Rti_Signal_Kind_No : constant Ghdl_Rti_U8 := 0 * 16; + Ghdl_Rti_Signal_Kind_Register : constant Ghdl_Rti_U8 := 1 * 16; + Ghdl_Rti_Signal_Kind_Bus : constant Ghdl_Rti_U8 := 2 * 16; Ghdl_Rti_Signal_Has_Active : constant Ghdl_Rti_U8 := 64; @@ -198,7 +198,7 @@ package Grt.Rtis is function To_Ghdl_Rti_Access is new Ada.Unchecked_Conversion (Source => Ghdl_Rtin_Subtype_Scalar_Acc, Target => Ghdl_Rti_Access); - -- True if the type is complex. + -- True if the type is complex, set in Mode field. Ghdl_Rti_Type_Complex_Mask : constant Ghdl_Rti_U8 := 1; Ghdl_Rti_Type_Complex : constant Ghdl_Rti_U8 := 1; diff --git a/translate/grt/grt-rtis_utils.adb b/translate/grt/grt-rtis_utils.adb index d01cea9e5..dbc70c2c6 100644 --- a/translate/grt/grt-rtis_utils.adb +++ b/translate/grt/grt-rtis_utils.adb @@ -169,7 +169,8 @@ package body Grt.Rtis_Utils is procedure Foreach_Scalar (Ctxt : Rti_Context; Obj_Type : Ghdl_Rti_Access; Obj_Addr : Address; - Is_Sig : Boolean) + Is_Sig : Boolean; + Param : Param_Type) is -- Current address. Addr : Address; @@ -185,7 +186,7 @@ package body Grt.Rtis_Utils is Addr := Addr + (S / Storage_Unit); end Update; begin - Process (Addr, Name, Rti); + Process (Addr, Name, Rti, Param); if Is_Sig then Update (Address'Size); @@ -448,18 +449,15 @@ package body Grt.Rtis_Utils is declare S : String (1 .. 32); L : Integer; - -- Warning: this assumes a C99 snprintf (ie, it returns the - -- number of characters). - function snprintf (Cstr : Address; - Size : Natural; - Template : Address; - Arg : Ghdl_F64) + + function Snprintf_G (Cstr : Address; + Size : Natural; + Arg : Ghdl_F64) return Integer; - pragma Import (C, snprintf); + pragma Import (C, Snprintf_G, "__ghdl_snprintf_g"); - Format : constant String := "%g" & Character'Val (0); begin - L := snprintf (S'Address, S'Length, Format'Address, Value.F64); + L := Snprintf_G (S'Address, S'Length, Value.F64); if L < 0 then -- FIXME. Append (Str, "?"); diff --git a/translate/grt/grt-rtis_utils.ads b/translate/grt/grt-rtis_utils.ads index 9b8fd33a0..232016d67 100644 --- a/translate/grt/grt-rtis_utils.ads +++ b/translate/grt/grt-rtis_utils.ads @@ -29,6 +29,12 @@ package Grt.Rtis_Utils is -- Traverse_Stop: end of walk. type Traverse_Result is (Traverse_Ok, Traverse_Skip, Traverse_Stop); + -- An RTI object is a context and an RTI declaration. + type Rti_Object is record + Obj : Ghdl_Rti_Access; + Ctxt : Rti_Context; + end record; + -- Traverse all blocks (package, entities, architectures, block, generate, -- processes). generic @@ -38,13 +44,16 @@ package Grt.Rtis_Utils is function Traverse_Blocks (Ctxt : Rti_Context) return Traverse_Result; generic + type Param_Type is private; with procedure Process (Val_Addr : Address; Val_Name : Vstring; - Val_Type : Ghdl_Rti_Access); + Val_Type : Ghdl_Rti_Access; + Param : Param_Type); procedure Foreach_Scalar (Ctxt : Rti_Context; Obj_Type : Ghdl_Rti_Access; Obj_Addr : Address; - Is_Sig : Boolean); + Is_Sig : Boolean; + Param : Param_Type); procedure Get_Value (Str : in out Vstring; Value : Value_Union; diff --git a/translate/grt/grt-sdf.adb b/translate/grt/grt-sdf.adb index fbf9f3e8c..16d7ee8ad 100644 --- a/translate/grt/grt-sdf.adb +++ b/translate/grt/grt-sdf.adb @@ -132,7 +132,7 @@ package body Grt.Sdf is Read_Sdf; end Read_Append; - procedure Error_Sdf (Msg : String) is + procedure Error_Sdf_C is begin Error_C (Sdf_Filename.all); Error_C (":"); @@ -140,6 +140,11 @@ package body Grt.Sdf is Error_C (":"); Error_C (Pos - Line_Start); Error_C (": "); + end Error_Sdf_C; + + procedure Error_Sdf (Msg : String) is + begin + Error_Sdf_C; Error_E (Msg); end Error_Sdf; @@ -525,6 +530,7 @@ package body Grt.Sdf is -- Status of a parsing. -- ERROR: parse error (syntax is not correct) + -- ALTERN: alternate construct parsed (ie simple RNUMBER for tc_rvalue). -- OPTIONAL: the construct is absent. -- FOUND: the construct is present. -- SET: the construct is present and a value was extracted from. @@ -737,6 +743,7 @@ package body Grt.Sdf is Tok : Sdf_Token_Type; Res : Parse_Status_Type; begin + -- '(' if Get_Token /= Tok_Oparen then Error_Sdf (Tok_Oparen); return Status_Error; @@ -748,12 +755,7 @@ package body Grt.Sdf is Tok := Get_Token; if Tok = Tok_Cparen then -- This is a simple RNUMBER. - if Get_Token = Tok_Cparen then - return Status_Altern; - else - Error_Sdf (Tok_Cparen); - return Status_Error; - end if; + return Status_Altern; end if; if Sdf_Mtm = Minimum then Res := Status_Set; @@ -825,6 +827,10 @@ package body Grt.Sdf is when Status_Error => return False; when Status_Altern => + Sdf_Context.Timing_Nbr := 1; + if Get_Token /= Tok_Cparen then + Error_Sdf (Tok_Cparen); + end if; return True; when Status_Found | Status_Optional => @@ -980,7 +986,9 @@ package body Grt.Sdf is end if; Vital_Annotate.Sdf_Generic (Sdf_Context.all, Name (1 .. Len), Ok); if not Ok then - Error_Sdf ("could not annotate generic"); + Error_Sdf_C; + Error_C ("could not annotate generic "); + Error_E (Name (1 .. Len)); return False; end if; return True; diff --git a/translate/grt/grt-signals.adb b/translate/grt/grt-signals.adb index bbbc7368b..8704aab36 100644 --- a/translate/grt/grt-signals.adb +++ b/translate/grt/grt-signals.adb @@ -145,7 +145,8 @@ package body Grt.Signals is Mode => Mode, Flags => (Propag => Propag_None, Is_Dumped => False, - Cyc_Event => False), + Cyc_Event => False, + Seen => False), Net => No_Signal_Net, Link => null, @@ -3290,7 +3291,8 @@ package body Grt.Signals is Flags => (Propag => Propag_None, Is_Dumped => False, - Cyc_Event => False), + Cyc_Event => False, + Seen => False), Net => No_Signal_Net, Link => null, diff --git a/translate/grt/grt-signals.ads b/translate/grt/grt-signals.ads index 2ada098e0..bab73ce10 100644 --- a/translate/grt/grt-signals.ads +++ b/translate/grt/grt-signals.ads @@ -225,6 +225,10 @@ package Grt.Signals is -- Set when an event occured. -- Only reset by GHW file dumper. Cyc_Event : Boolean; + + -- Set if the signal has already been visited. When outside of the + -- algorithm that use it, it must be cleared. + Seen : Boolean; end record; pragma Pack (Ghdl_Signal_Flags); diff --git a/translate/grt/grt-table.adb b/translate/grt/grt-table.adb index f570b40ca..739322c82 100644 --- a/translate/grt/grt-table.adb +++ b/translate/grt/grt-table.adb @@ -22,7 +22,7 @@ with Grt.C; use Grt.C; package body Grt.Table is -- Maximum index of table before resizing. - Max : Table_Index_Type := Table_Low_Bound - 1; + Max : Table_Index_Type := Table_Index_Type'Pred (Table_Low_Bound); -- Current value of Last Last_Val : Table_Index_Type; @@ -62,7 +62,7 @@ package body Grt.Table is procedure Decrement_Last is begin - Last_Val := Last_Val - 1; + Last_Val := Table_Index_Type'Pred (Last_Val); end Decrement_Last; procedure Free is @@ -73,7 +73,7 @@ package body Grt.Table is procedure Increment_Last is begin - Last_Val := Last_Val + 1; + Last_Val := Table_Index_Type'Succ (Last_Val); if Last_Val > Max then Resize; @@ -105,7 +105,7 @@ package body Grt.Table is end Set_Last; begin - Last_Val := Table_Low_Bound - 1; + Last_Val := Table_Index_Type'Pred (Table_Low_Bound); Max := Table_Low_Bound + Table_Index_Type (Table_Initial) - 1; Table := Malloc (size_t (Table_Initial * diff --git a/translate/grt/grt-vital_annotate.adb b/translate/grt/grt-vital_annotate.adb index 2e7987ca5..b909f2291 100644 --- a/translate/grt/grt-vital_annotate.adb +++ b/translate/grt/grt-vital_annotate.adb @@ -229,6 +229,8 @@ package body Grt.Vital_Annotate is end Sdf_Instance_End; VitalDelayType01 : VhpiHandleT; + VitalDelayType01Z : VhpiHandleT; + VitalDelayType01ZX : VhpiHandleT; VitalDelayArrayType01 : VhpiHandleT; VitalDelayType : VhpiHandleT; VitalDelayArrayType : VhpiHandleT; @@ -236,8 +238,8 @@ package body Grt.Vital_Annotate is type Map_Type is array (1 .. 12) of Natural; Map_1 : constant Map_Type := (1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0); Map_2 : constant Map_Type := (1, 2, 1, 1, 2, 2, 0, 0, 0, 0, 0, 0); - --Map_3 : constant Map_Type := (1, 2, 3, 1, 3, 2, 0, 0, 0, 0, 0, 0); - --Map_6 : constant Map_Type := (1, 2, 3, 4, 5, 6, 0, 0, 0, 0, 0, 0); + Map_3 : constant Map_Type := (1, 2, 3, 1, 3, 2, 0, 0, 0, 0, 0, 0); + Map_6 : constant Map_Type := (1, 2, 3, 4, 5, 6, 0, 0, 0, 0, 0, 0); --Map_12 : constant Map_Type := (1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12); function Write_Td_Delay_Generic (Context : Sdf_Context_Type; @@ -296,6 +298,20 @@ package body Grt.Vital_Annotate is Errors.Error ("timing generic type mismatch SDF timing specification"); end case; + elsif Vhpi_Compare_Handles (Gen_Basetype, VitalDelayType01Z) then + case Context.Timing_Nbr is + when 1 => + return Write_Td_Delay_Generic (Context, Gen, 6, Map_1); + when 2 => + return Write_Td_Delay_Generic (Context, Gen, 6, Map_2); + when 3 => + return Write_Td_Delay_Generic (Context, Gen, 6, Map_3); + when 6 => + return Write_Td_Delay_Generic (Context, Gen, 6, Map_6); + when others => + Errors.Error + ("timing generic type mismatch SDF timing specification"); + end case; elsif Vhpi_Compare_Handles (Gen_Basetype, VitalDelayType) then if Vhpi_Put_Value (Gen, Context.Timing (1) * 1000) /= AvhpiErrorOk then @@ -406,7 +422,10 @@ package body Grt.Vital_Annotate is Internal_Error ("vhpiBaseType"); return; end if; - if Vhpi_Compare_Handles (Gen_Basetype, VitalDelayType01) then + if Vhpi_Compare_Handles (Gen_Basetype, VitalDelayType01) + or else Vhpi_Compare_Handles (Gen_Basetype, VitalDelayType01Z) + or else Vhpi_Compare_Handles (Gen_Basetype, VitalDelayType01ZX) + then Ok := Write_Td_Delay_Generic (Context, Gen); elsif Vhpi_Compare_Handles (Gen_Basetype, VitalDelayArrayType01) or else Vhpi_Compare_Handles (Gen_Basetype, VitalDelayArrayType) @@ -451,7 +470,8 @@ package body Grt.Vital_Annotate is Ok := Write_Td_Delay_Generic (Context, Gen_El); end; else - Errors.Error ("vital: unhandled generic type"); + Errors.Error_C ("vital: unhandled generic type for generic "); + Errors.Error_E (Name); end if; end Sdf_Generic; @@ -483,8 +503,8 @@ package body Grt.Vital_Annotate is -- Instance element. S := E; while Arg (E) /= '=' and Arg (E) /= '.' and Arg (E) /= '/' loop - exit L1 when E > Arg'Last; E := E + 1; + exit L1 when E > Arg'Last; end loop; -- Path element. @@ -545,6 +565,10 @@ package body Grt.Vital_Annotate is if Status = AvhpiErrorOk then if Name_Compare (Decl, "vitaldelaytype01") then VitalDelayType01 := Basetype; + elsif Name_Compare (Decl, "vitaldelaytype01z") then + VitalDelayType01Z := Basetype; + elsif Name_Compare (Decl, "vitaldelaytype01zx") then + VitalDelayType01ZX := Basetype; elsif Name_Compare (Decl, "vitaldelayarraytype01") then VitalDelayArrayType01 := Basetype; elsif Name_Compare (Decl, "vitaldelaytype") then @@ -559,6 +583,14 @@ package body Grt.Vital_Annotate is Error ("cannot find VitalDelayType01 in ieee.vital_timing"); return; end if; + if Vhpi_Get_Kind (VitalDelayType01Z) = VhpiUndefined then + Error ("cannot find VitalDelayType01Z in ieee.vital_timing"); + return; + end if; + if Vhpi_Get_Kind (VitalDelayType01ZX) = VhpiUndefined then + Error ("cannot find VitalDelayType01ZX in ieee.vital_timing"); + return; + end if; if Vhpi_Get_Kind (VitalDelayArrayType01) = VhpiUndefined then Error ("cannot find VitalDelayArrayType01 in ieee.vital_timing"); return; diff --git a/translate/grt/grt-waves.adb b/translate/grt/grt-waves.adb index 62c1ae414..c4319c874 100644 --- a/translate/grt/grt-waves.adb +++ b/translate/grt/grt-waves.adb @@ -633,13 +633,16 @@ package body Grt.Waves is | Ghdl_Rtik_Subtype_Array_Ptr => declare Arr : Ghdl_Rtin_Subtype_Array_Acc; + B_Ctxt : Rti_Context; begin Arr := To_Ghdl_Rtin_Subtype_Array_Acc (Rti); Create_String_Id (Arr.Name); - if Rti.Mode = 1 then - N_Ctxt := Ctxt; + if Rti.Mode = Ghdl_Rti_Type_Complex then + B_Ctxt := Ctxt; + else + B_Ctxt := N_Ctxt; end if; - Create_Type (To_Ghdl_Rti_Access (Arr.Basetype), N_Ctxt); + Create_Type (To_Ghdl_Rti_Access (Arr.Basetype), B_Ctxt); end; when Ghdl_Rtik_Type_Array => declare @@ -823,10 +826,12 @@ package body Grt.Waves is procedure Write_Signal_Number (Val_Addr : Address; Val_Name : Vstring; - Val_Type : Ghdl_Rti_Access) + Val_Type : Ghdl_Rti_Access; + Param_Type : Natural) is pragma Unreferenced (Val_Name); pragma Unreferenced (Val_Type); + pragma Unreferenced (Param_Type); Num : Natural; @@ -853,7 +858,8 @@ package body Grt.Waves is end Write_Signal_Number; procedure Foreach_Scalar_Signal_Number is new - Grt.Rtis_Utils.Foreach_Scalar (Process => Write_Signal_Number); + Grt.Rtis_Utils.Foreach_Scalar (Param_Type => Natural, + Process => Write_Signal_Number); procedure Write_Signal_Numbers (Decl : VhpiHandleT) is @@ -864,7 +870,7 @@ package body Grt.Waves is Sig := To_Ghdl_Rtin_Object_Acc (Avhpi_Get_Rti (Decl)); Foreach_Scalar_Signal_Number (Ctxt, Sig.Obj_Type, - Loc_To_Addr (Sig.Common.Depth, Sig.Loc, Ctxt), True); + Loc_To_Addr (Sig.Common.Depth, Sig.Loc, Ctxt), True, 0); end Write_Signal_Numbers; procedure Write_Hierarchy_El (Decl : VhpiHandleT) diff --git a/translate/ortho_front.adb b/translate/ortho_front.adb index d69c9b1c4..e5d6626fa 100644 --- a/translate/ortho_front.adb +++ b/translate/ortho_front.adb @@ -16,7 +16,6 @@ -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA -- 02111-1307, USA. with Types; use Types; -with Std_Names; with Name_Table; with Std_Package; with Back_End; @@ -73,8 +72,9 @@ package body Ortho_Front is begin -- Initialize. Trans_Be.Register_Translation_Back_End; - Std_Names.Std_Names_Initialize; - Libraries.Init_Pathes; + + Options.Initialize; + Elab_Filelist := null; Elab_Entity := null; Elab_Architecture := null; diff --git a/translate/trans_analyzes.adb b/translate/trans_analyzes.adb index 43d7508a1..fd533e283 100644 --- a/translate/trans_analyzes.adb +++ b/translate/trans_analyzes.adb @@ -1,3 +1,21 @@ +-- Analysis for translation. +-- Copyright (C) 2009 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + with Iirs_Utils; use Iirs_Utils; with Iirs_Walk; use Iirs_Walk; with Disp_Vhdl; @@ -107,7 +125,7 @@ package body Trans_Analyzes is if Get_Kind (Decl) = Iir_Kind_Procedure_Body or else (Get_Kind (Decl) = Iir_Kind_Function_Body and then - Get_Pure_Flag (Get_Subprogram_Specification (Decl))) + not Get_Pure_Flag (Get_Subprogram_Specification (Decl))) then Extract_Drivers_Declaration_Chain (Get_Declaration_Chain (Decl)); Extract_Drivers_Sequential_Stmt_Chain diff --git a/translate/trans_analyzes.ads b/translate/trans_analyzes.ads index 30b4f4635..ecebb7597 100644 --- a/translate/trans_analyzes.ads +++ b/translate/trans_analyzes.ads @@ -1,3 +1,21 @@ +-- Analysis for translation. +-- Copyright (C) 2009 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + with Iirs; use Iirs; package Trans_Analyzes is diff --git a/translate/trans_decls.ads b/translate/trans_decls.ads index 027cbb594..8a93fcf66 100644 --- a/translate/trans_decls.ads +++ b/translate/trans_decls.ads @@ -18,8 +18,9 @@ with Ortho_Nodes; use Ortho_Nodes; package Trans_Decls is - -- Procedure called in case of assert failed. + -- Procedures called in case of assert failed. Ghdl_Assert_Failed : O_Dnode; + Ghdl_Psl_Assert_Failed : O_Dnode; -- Procedure for report statement. Ghdl_Report : O_Dnode; -- Ortho node for default report message. @@ -31,6 +32,8 @@ package Trans_Decls is Ghdl_Postponed_Process_Register : O_Dnode; Ghdl_Postponed_Sensitized_Process_Register : O_Dnode; + Ghdl_Finalize_Register : O_Dnode; + -- Wait subprograms. -- Short forms. Ghdl_Process_Wait_Timeout : O_Dnode; @@ -222,5 +225,8 @@ package Trans_Decls is Ghdl_Get_Path_Name : O_Dnode; Ghdl_Get_Instance_Name : O_Dnode; + -- For PSL. + Ghdl_Std_Ulogic_To_Boolean_Array : O_Dnode; + Ghdl_Elaborate : O_Dnode; end Trans_Decls; diff --git a/translate/translation.adb b/translate/translation.adb index 7a6f387e5..b2294bbc6 100644 --- a/translate/translation.adb +++ b/translate/translation.adb @@ -38,7 +38,12 @@ with Sem; with Iir_Chains; use Iir_Chains; with Nodes; with GNAT.Table; +with Ieee.Std_Logic_1164; with Canon; +with Canon_PSL; +with PSL.Nodes; +with PSL.NFAs; +with PSL.NFAs.Utils; with Trans_Decls; use Trans_Decls; with Trans_Analyzes; @@ -48,6 +53,10 @@ package body Translation is Std_Boolean_Type_Node : O_Tnode; Std_Boolean_True_Node : O_Cnode; Std_Boolean_False_Node : O_Cnode; + -- Array of STD.BOOLEAN. + Std_Boolean_Array_Type : O_Tnode; + -- Std_ulogic indexed array of STD.Boolean. + Std_Ulogic_Boolean_Array_Type : O_Tnode; -- Ortho type node for string template pointer. Std_String_Ptr_Node : O_Tnode; Std_String_Node : O_Tnode; @@ -149,36 +158,29 @@ package body Translation is type Object_Kind_Type is (Mode_Value, Mode_Signal); -- Well known identifiers. - type Wk_Ident_Type is - ( - Wkie_This, Wkie_Size, Wkie_Res, Wkie_Dir_To, Wkie_Dir_Downto, - Wkie_Left, Wkie_Right, Wkie_Dir, Wkie_Length, Wkie_Kind, Wkie_Dim, - Wkie_I, Wkie_Instance, Wkie_Arch_Instance, Wkie_Name, Wkie_Sig, - Wkie_Obj, Wkie_Rti, Wkie_Parent, Wkie_Filename, Wkie_Line - ); - type Wk_Ident_Tree_Array is array (Wk_Ident_Type) of O_Ident; - Wk_Idents : Wk_Ident_Tree_Array; - Wki_This : O_Ident renames Wk_Idents (Wkie_This); - Wki_Size : O_Ident renames Wk_Idents (Wkie_Size); - Wki_Res : O_Ident renames Wk_Idents (Wkie_Res); - Wki_Dir_To : O_Ident renames Wk_Idents (Wkie_Dir_To); - Wki_Dir_Downto : O_Ident renames Wk_Idents (Wkie_Dir_Downto); - Wki_Left : O_Ident renames Wk_Idents (Wkie_Left); - Wki_Right : O_Ident renames Wk_Idents (Wkie_Right); - Wki_Dir : O_Ident renames Wk_Idents (Wkie_Dir); - Wki_Length : O_Ident renames Wk_Idents (Wkie_Length); - Wki_Kind : O_Ident renames Wk_Idents (Wkie_Kind); - Wki_Dim : O_Ident renames Wk_Idents (Wkie_Dim); - Wki_I : O_Ident renames Wk_Idents (Wkie_I); - Wki_Instance : O_Ident renames Wk_Idents (Wkie_Instance); - Wki_Arch_Instance : O_Ident renames Wk_Idents (Wkie_Arch_Instance); - Wki_Name : O_Ident renames Wk_Idents (Wkie_Name); - Wki_Sig : O_Ident renames Wk_Idents (Wkie_Sig); - Wki_Obj : O_Ident renames Wk_Idents (Wkie_Obj); - Wki_Rti : O_Ident renames Wk_Idents (Wkie_Rti); - Wki_Parent : O_Ident renames Wk_Idents (Wkie_Parent); - Wki_Filename : O_Ident renames Wk_Idents (Wkie_Filename); - Wki_Line : O_Ident renames Wk_Idents (Wkie_Line); + Wki_This : O_Ident; + Wki_Size : O_Ident; + Wki_Res : O_Ident; + Wki_Dir_To : O_Ident; + Wki_Dir_Downto : O_Ident; + Wki_Left : O_Ident; + Wki_Right : O_Ident; + Wki_Dir : O_Ident; + Wki_Length : O_Ident; + Wki_I : O_Ident; + Wki_Instance : O_Ident; + Wki_Arch_Instance : O_Ident; + Wki_Name : O_Ident; + Wki_Sig : O_Ident; + Wki_Obj : O_Ident; + Wki_Rti : O_Ident; + Wki_Parent : O_Ident; + Wki_Filename : O_Ident; + Wki_Line : O_Ident; + Wki_Lo : O_Ident; + Wki_Hi : O_Ident; + Wki_Mid : O_Ident; + Wki_Cmp : O_Ident; -- ALLOCATION_KIND defines the type of memory storage. -- ALLOC_STACK means the object is allocated on the local stack and @@ -603,6 +605,8 @@ package body Translation is Dir : Iir_Direction; Val : Unsigned_64; Itype : Iir); + + procedure Translate_Report (Stmt : Iir; Subprg : O_Dnode; Level : Iir); end Chap8; package Chap9 is @@ -670,6 +674,7 @@ package body Translation is Ghdl_Rtik_Attribute_Transaction : O_Cnode; Ghdl_Rtik_Attribute_Quiet : O_Cnode; Ghdl_Rtik_Attribute_Stable : O_Cnode; + Ghdl_Rtik_Psl_Assert : O_Cnode; Ghdl_Rtik_Error : O_Cnode; -- RTI types. @@ -757,6 +762,7 @@ package body Translation is Kind_Interface, Kind_Disconnect, Kind_Process, + Kind_Psl_Assert, Kind_Loop, Kind_Block, Kind_Component, @@ -764,6 +770,7 @@ package body Translation is Kind_Package, Kind_Config, Kind_Assoc, + Kind_Str_Choice, Kind_Design_File, Kind_Library ); @@ -1166,6 +1173,29 @@ package body Translation is -- RTI for the process. Process_Rti_Const : O_Dnode := O_Dnode_Null; + when Kind_Psl_Assert => + -- Type of assert declarations record. + Psl_Decls_Type : O_Tnode; + + -- Field in the parent block for the declarations in the assert. + Psl_Parent_Field : O_Fnode; + + -- Procedure for the state machine. + Psl_Proc_Subprg : O_Dnode; + -- Procedure for finalization. Handles EOS. + Psl_Proc_Final_Subprg : O_Dnode; + + -- Length of the state vector. + Psl_Vect_Len : Natural; + + -- Type of the state vector. + Psl_Vect_Type : O_Tnode; + + -- State vector variable. + Psl_Vect_Var : Var_Acc; + + -- RTI for the process. + Psl_Rti_Const : O_Dnode := O_Dnode_Null; when Kind_Loop => -- Labels for the loop. -- Used for exit/next from while-loop, and to exit from for-loop. @@ -1245,6 +1275,15 @@ package body Translation is -- Association informations. Assoc_In : Assoc_Conv_Info; Assoc_Out : Assoc_Conv_Info; + when Kind_Str_Choice => + -- List of choices, used to sort them. + Choice_Chain : Ortho_Info_Acc; + -- Association index. + Choice_Assoc : Natural; + -- Corresponding choice simple expression. + Choice_Expr : Iir; + -- Corresponding choice. + Choice_Parent : Iir; when Kind_Design_File => Design_Filename : O_Dnode; when Kind_Library => @@ -1261,6 +1300,7 @@ package body Translation is subtype Object_Info_Acc is Ortho_Info_Acc (Kind_Object); subtype Alias_Info_Acc is Ortho_Info_Acc (Kind_Alias); subtype Proc_Info_Acc is Ortho_Info_Acc (Kind_Process); + subtype Psl_Info_Acc is Ortho_Info_Acc (Kind_Psl_Assert); subtype Loop_Info_Acc is Ortho_Info_Acc (Kind_Loop); subtype Block_Info_Acc is Ortho_Info_Acc (Kind_Block); subtype Comp_Info_Acc is Ortho_Info_Acc (Kind_Component); @@ -2020,6 +2060,8 @@ package body Translation is Prg_Err_Missing_Return : constant Natural := 1; Prg_Err_Block_Configured : constant Natural := 2; Prg_Err_Dummy_Config : constant Natural := 3; + Prg_Err_No_Choice : constant Natural := 4; + Prg_Err_Bad_Choice : constant Natural := 5; procedure Gen_Program_Error (Loc : Iir; Code : Natural); -- Generate code to emit a failure if COND is TRUE, indicating an @@ -2276,6 +2318,8 @@ package body Translation is procedure Gen_Exit_When (Label : O_Snode; Cond : O_Enode); -- Create a uniq identifier. + subtype Uniq_Identifier_String is String (1 .. 11); + function Create_Uniq_Identifier return Uniq_Identifier_String; function Create_Uniq_Identifier return O_Ident; -- Create a region for temporary variables. @@ -2317,6 +2361,9 @@ package body Translation is -- Used only to free memory. procedure Free_Old_Temp; + -- Return a ghdl_index_type literal for NUM. + function New_Index_Lit (Num : Unsigned_64) return O_Cnode; + -- Create a constant (of name ID) for string STR. -- Append a NUL terminator (to make interfaces with C easier). function Create_String (Str : String; Id : O_Ident) return O_Dnode; @@ -2968,9 +3015,9 @@ package body Translation is Ptr : String_Fat_Acc; begin Ptr := Get_String_Fat_Acc (Expr); - Name_Length := Get_String_Length (Expr); + Name_Length := Natural (Get_String_Length (Expr)); for I in 1 .. Name_Length loop - Name_Buffer (I) := Ptr (I); + Name_Buffer (I) := Ptr (Nat32 (I)); end loop; end; when Iir_Kind_Simple_Aggregate => @@ -3163,9 +3210,9 @@ package body Translation is Uniq_Id : Natural := 0; - function Create_Uniq_Identifier return O_Ident + function Create_Uniq_Identifier return Uniq_Identifier_String is - Str : String (1 .. 12); + Str : Uniq_Identifier_String; Val : Natural; begin Str (1 .. 3) := "_UI"; @@ -3175,8 +3222,12 @@ package body Translation is Str (I) := N2hex (Val mod 16); Val := Val / 16; end loop; - --Str (12) := Nul; - return Get_Identifier (Str (1 .. 11)); + return Str; + end Create_Uniq_Identifier; + + function Create_Uniq_Identifier return O_Ident is + begin + return Get_Identifier (Create_Uniq_Identifier); end Create_Uniq_Identifier; -- Create a temporary variable. @@ -3407,6 +3458,12 @@ package body Translation is return Create_Temp_Init (Temp_Type, New_Address (Name, Temp_Type)); end Create_Temp_Ptr; + -- Return a ghdl_index_type literal for NUM. + function New_Index_Lit (Num : Unsigned_64) return O_Cnode is + begin + return New_Unsigned_Literal (Ghdl_Index_Type, Num); + end New_Index_Lit; + -- Convert NAME into a STRING_CST. -- Append a NUL terminator (to make interfaces with C easier). function Create_String_Type (Str : String) return O_Tnode is @@ -10853,6 +10910,7 @@ package body Translation is then case Get_Implicit_Definition (El) is when Iir_Predefined_Array_Equality + | Iir_Predefined_Array_Greater | Iir_Predefined_Record_Equality => -- Used implicitly in case statement or other -- predefined equality. @@ -13365,7 +13423,7 @@ package body Translation is Literal_List : Iir_List; Lit : Iir; - Len : Natural; + Len : Nat32; Ptr : String_Fat_Acc; begin Literal_List := @@ -13387,7 +13445,7 @@ package body Translation is L_0 : O_Cnode; L_1 : O_Cnode; Ptr : String_Fat_Acc; - Len : Natural; + Len : Nat32; V : O_Cnode; begin L_0 := Get_Ortho_Expr (Get_Bit_String_0 (Lit)); @@ -13506,14 +13564,16 @@ package body Translation is Lit_Type : Iir; Element_Type : Iir; + Arr_Type : O_Tnode; List : O_Array_Aggr_List; Res : O_Cnode; begin Lit_Type := Get_Type (Str); Chap3.Translate_Anonymous_Type_Definition (Lit_Type, True); + Arr_Type := Get_Ortho_Type (Lit_Type, Mode_Value); - Start_Array_Aggr (List, Get_Ortho_Type (Lit_Type, Mode_Value)); + Start_Array_Aggr (List, Arr_Type); Element_Type := Get_Element_Subtype (Lit_Type); @@ -13526,8 +13586,8 @@ package body Translation is -- Some strings literal have an unconstrained array type, -- eg: 'image of constant. Its type is not constrained -- because it is not so in VHDL! - function Translate_Static_Unconstrained_String_Literal (Str : Iir) - return O_Cnode + function Translate_Non_Static_String_Literal (Str : Iir) + return O_Enode is use Name_Table; @@ -13545,9 +13605,10 @@ package body Translation is Len : Int32; Val : Var_Acc; Bound : Var_Acc; + R : O_Enode; begin Lit_Type := Get_Type (Str); - Type_Info := Get_Info (Get_Base_Type (Lit_Type)); + Type_Info := Get_Info (Lit_Type); -- Create the string value. Len := Get_String_Length (Str); @@ -13557,51 +13618,76 @@ package body Translation is Start_Array_Aggr (Val_Aggr, Str_Type); Element_Type := Get_Element_Subtype (Lit_Type); - Translate_Static_String_Literal_Inner (Val_Aggr, Str, Element_Type); + case Get_Kind (Str) is + when Iir_Kind_String_Literal => + Translate_Static_String_Literal_Inner + (Val_Aggr, Str, Element_Type); + when Iir_Kind_Bit_String_Literal => + Translate_Static_Bit_String_Literal_Inner + (Val_Aggr, Str, Element_Type); + when others => + raise Internal_Error; + end case; Finish_Array_Aggr (Val_Aggr, Res); Val := Create_Global_Const (Create_Uniq_Identifier, Str_Type, O_Storage_Private, Res); - -- Create the string bound. - Index_Type := Get_First_Element (Get_Index_Subtype_List (Lit_Type)); - Index_Type_Info := Get_Info (Index_Type); - Start_Record_Aggr (Bound_Aggr, Type_Info.T.Bounds_Type); - Start_Record_Aggr (Index_Aggr, Index_Type_Info.T.Range_Type); - New_Record_Aggr_El - (Index_Aggr, - New_Signed_Literal (Index_Type_Info.Ortho_Type (Mode_Value), 0)); - New_Record_Aggr_El - (Index_Aggr, - New_Signed_Literal (Index_Type_Info.Ortho_Type (Mode_Value), + if Type_Info.Type_Mode = Type_Mode_Fat_Array then + -- Create the string bound. + Index_Type := + Get_First_Element (Get_Index_Subtype_List (Lit_Type)); + Index_Type_Info := Get_Info (Index_Type); + Start_Record_Aggr (Bound_Aggr, Type_Info.T.Bounds_Type); + Start_Record_Aggr (Index_Aggr, Index_Type_Info.T.Range_Type); + New_Record_Aggr_El + (Index_Aggr, + New_Signed_Literal + (Index_Type_Info.Ortho_Type (Mode_Value), 0)); + New_Record_Aggr_El + (Index_Aggr, + New_Signed_Literal (Index_Type_Info.Ortho_Type (Mode_Value), Integer_64 (Len - 1))); - New_Record_Aggr_El - (Index_Aggr, Ghdl_Dir_To_Node); - New_Record_Aggr_El - (Index_Aggr, - New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Len))); - Finish_Record_Aggr (Index_Aggr, Res); - New_Record_Aggr_El (Bound_Aggr, Res); - Finish_Record_Aggr (Bound_Aggr, Res); - Bound := Create_Global_Const - (Create_Uniq_Identifier, Type_Info.T.Bounds_Type, - O_Storage_Private, Res); - - -- The descriptor. - Start_Record_Aggr (Res_Aggr, Type_Info.Ortho_Type (Mode_Value)); - New_Record_Aggr_El - (Res_Aggr, - New_Global_Address (Get_Var_Label (Val), - Type_Info.T.Base_Ptr_Type (Mode_Value))); - New_Record_Aggr_El - (Res_Aggr, - New_Global_Address (Get_Var_Label (Bound), - Type_Info.T.Bounds_Ptr_Type)); - Finish_Record_Aggr (Res_Aggr, Res); + New_Record_Aggr_El + (Index_Aggr, Ghdl_Dir_To_Node); + New_Record_Aggr_El + (Index_Aggr, + New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Len))); + Finish_Record_Aggr (Index_Aggr, Res); + New_Record_Aggr_El (Bound_Aggr, Res); + Finish_Record_Aggr (Bound_Aggr, Res); + Bound := Create_Global_Const + (Create_Uniq_Identifier, Type_Info.T.Bounds_Type, + O_Storage_Private, Res); + + -- The descriptor. + Start_Record_Aggr (Res_Aggr, Type_Info.Ortho_Type (Mode_Value)); + New_Record_Aggr_El + (Res_Aggr, + New_Global_Address (Get_Var_Label (Val), + Type_Info.T.Base_Ptr_Type (Mode_Value))); + New_Record_Aggr_El + (Res_Aggr, + New_Global_Address (Get_Var_Label (Bound), + Type_Info.T.Bounds_Ptr_Type)); + Finish_Record_Aggr (Res_Aggr, Res); + Free_Var (Val); + Free_Var (Bound); + + Val := Create_Global_Const + (Create_Uniq_Identifier, Type_Info.Ortho_Type (Mode_Value), + O_Storage_Private, Res); + elsif Type_Info.Type_Mode = Type_Mode_Ptr_Array then + null; + else + raise Internal_Error; + end if; + + R := New_Address (Get_Var (Val), + Type_Info.Ortho_Ptr_Type (Mode_Value)); Free_Var (Val); - Free_Var (Bound); - return Res; - end Translate_Static_Unconstrained_String_Literal; + return R; + end Translate_Non_Static_String_Literal; -- Only for Strings of STD.Character. function Translate_Static_String (Str_Type : Iir; Str_Ident : Name_Id) @@ -13655,33 +13741,36 @@ package body Translation is Res : O_Cnode; R : O_Enode; begin - case Get_Kind (Str) is - when Iir_Kind_String_Literal => - if Get_Kind (Get_Type (Str)) - = Iir_Kind_Array_Subtype_Definition - then - Res := Translate_Static_String_Literal (Str); - else - Res := Translate_Static_Unconstrained_String_Literal (Str); - end if; - when Iir_Kind_Bit_String_Literal => - Res := Translate_Static_Bit_String_Literal (Str); - when Iir_Kind_Simple_Aggregate => - Res := Translate_Static_Simple_Aggregate (Str); - when Iir_Kind_Simple_Name_Attribute => - Res := Translate_Static_String - (Get_Type (Str), Get_Simple_Name_Identifier (Str)); - when others => - raise Internal_Error; - end case; Str_Type := Get_Type (Str); - Info := Get_Info (Str_Type); - Var := Create_Global_Const - (Create_Uniq_Identifier, Info.Ortho_Type (Mode_Value), - O_Storage_Private, Res); - R := New_Address (Get_Var (Var), Info.Ortho_Ptr_Type (Mode_Value)); - Free_Var (Var); - return R; + if Get_Constraint_State (Str_Type) = Fully_Constrained + and then Get_Type_Staticness + (Get_First_Element (Get_Index_Subtype_List (Str_Type))) + = Locally + then + case Get_Kind (Str) is + when Iir_Kind_String_Literal => + Res := Translate_Static_String_Literal (Str); + when Iir_Kind_Bit_String_Literal => + Res := Translate_Static_Bit_String_Literal (Str); + when Iir_Kind_Simple_Aggregate => + Res := Translate_Static_Simple_Aggregate (Str); + when Iir_Kind_Simple_Name_Attribute => + Res := Translate_Static_String + (Get_Type (Str), Get_Simple_Name_Identifier (Str)); + when others => + raise Internal_Error; + end case; + Str_Type := Get_Type (Str); + Info := Get_Info (Str_Type); + Var := Create_Global_Const + (Create_Uniq_Identifier, Info.Ortho_Type (Mode_Value), + O_Storage_Private, Res); + R := New_Address (Get_Var (Var), Info.Ortho_Ptr_Type (Mode_Value)); + Free_Var (Var); + return R; + else + return Translate_Non_Static_String_Literal (Str); + end if; end Translate_String_Literal; function Translate_Static_Implicit_Conv @@ -15067,7 +15156,7 @@ package body Translation is Lit : Iir; Pos : O_Enode; Ptr : String_Fat_Acc; - Len : Natural; + Len : Nat32; begin Ptr := Get_String_Fat_Acc (Aggr); Len := Get_String_Length (Aggr); @@ -15083,7 +15172,7 @@ package body Translation is (ON_Add_Ov, New_Obj_Value (Var_Index), New_Lit (New_Unsigned_Literal - (Ghdl_Index_Type, Natural'Pos (I - 1)))); + (Ghdl_Index_Type, Nat32'Pos (I - 1)))); end if; New_Assign_Stmt (M2Lv (Chap3.Index_Base (Base_Ptr, Aggr_Type, Pos)), @@ -15095,7 +15184,7 @@ package body Translation is (ON_Add_Ov, New_Obj_Value (Var_Index), New_Lit (New_Unsigned_Literal (Ghdl_Index_Type, - Natural'Pos (Len))))); + Nat32'Pos (Len))))); end; return; when Iir_Kind_Bit_String_Literal => @@ -15504,7 +15593,7 @@ package body Translation is -- FIXME: creating aggregate subtype is expensive and rarely used. -- (one of the current use - only ? - is check_array_match). - Chap3.Translate_Type_Definition (Aggr_Type, False); + Chap3.Translate_Anonymous_Type_Definition (Aggr_Type, False); end Translate_Array_Aggregate; procedure Translate_Aggregate @@ -18879,9 +18968,10 @@ package body Translation is Translate_Report (Stmt, Ghdl_Report, Severity_Level_Note); end Translate_Report_Statement; + -- Helper to compare a string choice with the selector. function Translate_Simple_String_Choice (Expr : O_Dnode; - Val : Iir; + Val : O_Enode; Val_Node : O_Dnode; Tinfo : Type_Info_Acc; Func : Iir) @@ -18893,7 +18983,7 @@ package body Translation is New_Assign_Stmt (New_Selected_Element (New_Obj (Val_Node), Tinfo.T.Base_Field (Mode_Value)), - Chap7.Translate_Expression (Val, Get_Type (Val))); + Val); Func_Info := Get_Info (Func); Start_Association (Assoc, Func_Info.Ortho_Func); Chap2.Add_Subprg_Instance_Assoc (Assoc, Func_Info.Subprg_Instance); @@ -18904,107 +18994,462 @@ package body Translation is return New_Function_Call (Assoc); end Translate_Simple_String_Choice; - procedure Translate_String_Choice - (Expr : O_Dnode; - Val_Node : O_Dnode; + -- Helper to evaluate the selector and preparing a choice variable. + procedure Translate_String_Case_Statement_Common + (Stmt : Iir_Case_Statement; + Expr_Type : out Iir; + Tinfo : out Type_Info_Acc; + Expr_Node : out O_Dnode; + C_Node : out O_Dnode) + is + Expr : Iir; + Base_Type : Iir; + begin + -- Translate into if/elsif statements. + -- FIXME: if the number of literals ** length of the array < 256, + -- use a case statement. + Expr := Get_Expression (Stmt); + Expr_Type := Get_Type (Expr); + Base_Type := Get_Base_Type (Expr_Type); + Tinfo := Get_Info (Base_Type); + + -- Translate selector. + Expr_Node := Create_Temp_Init + (Tinfo.Ortho_Ptr_Type (Mode_Value), + Chap7.Translate_Expression (Expr, Base_Type)); + + -- Copy the bounds for the choices. + C_Node := Create_Temp (Tinfo.Ortho_Type (Mode_Value)); + New_Assign_Stmt + (New_Selected_Element (New_Obj (C_Node), + Tinfo.T.Bounds_Field (Mode_Value)), + New_Value_Selected_Acc_Value + (New_Obj (Expr_Node), Tinfo.T.Bounds_Field (Mode_Value))); + end Translate_String_Case_Statement_Common; + + -- Translate a string case statement using a dichotomy. + procedure Translate_String_Case_Statement_Dichotomy + (Stmt : Iir_Case_Statement) + is + -- Selector. + Expr_Type : Iir; Tinfo : Type_Info_Acc; + Expr_Node : O_Dnode; + C_Node : O_Dnode; + + Choices_Chain : Iir; + Choice : Iir; + Has_Others : Boolean; Func : Iir; - Cond_Var : O_Dnode; - Choice : Iir) - is - Cond : O_Enode; - If_Blk : O_If_Block; - Stmt_Chain : Iir; - First : Boolean; - Ch : Iir; + + -- Number of non-others choices. + Nbr_Choices : Natural; + -- Number of associations. + Nbr_Assocs : Natural; + + Info : Ortho_Info_Acc; + First, Last : Ortho_Info_Acc; + Sel_Length : Iir_Int64; + + -- Dichotomy table (table of choices). + String_Type : O_Tnode; + Table_Base_Type : O_Tnode; + Table_Type : O_Tnode; + Table : O_Dnode; + List : O_Array_Aggr_List; + Table_Cst : O_Cnode; + + -- Association table. + -- Indexed by the choice, returns an index to the associated + -- statement list. + -- Could be replaced by jump table. + Assoc_Table_Base_Type : O_Tnode; + Assoc_Table_Type : O_Tnode; + Assoc_Table : O_Dnode; begin - if Choice = Null_Iir then - return; - end if; + Choices_Chain := Get_Case_Statement_Alternative_Chain (Stmt); - First := True; - Stmt_Chain := Get_Associated (Choice); - Ch := Choice; - loop - case Get_Kind (Ch) is - when Iir_Kind_Choice_By_Expression => - Cond := Translate_Simple_String_Choice - (Expr, Get_Expression (Ch), Val_Node, Tinfo, Func); + -- Count number of choices and number of associations. + Nbr_Choices := 0; + Nbr_Assocs := 0; + Choice := Choices_Chain; + First := null; + Last := null; + Has_Others := False; + while Choice /= Null_Iir loop + case Get_Kind (Choice) is when Iir_Kind_Choice_By_Others => - Translate_Statements_Chain (Stmt_Chain); - return; + Has_Others := True; + exit; + when Iir_Kind_Choice_By_Expression => + null; when others => - Error_Kind ("translate_string_choice", Ch); + raise Internal_Error; end case; - if not First then - New_Assign_Stmt - (New_Obj (Cond_Var), - New_Dyadic_Op (ON_Or, New_Obj_Value (Cond_Var), Cond)); + if not Get_Same_Alternative_Flag (Choice) then + Nbr_Assocs := Nbr_Assocs + 1; end if; - Ch := Get_Chain (Ch); - exit when Ch = Null_Iir; - exit when not Get_Same_Alternative_Flag (Ch); - exit when Get_Associated (Ch) /= Null_Iir; - if First then - New_Assign_Stmt (New_Obj (Cond_Var), Cond); - First := False; + Info := Add_Info (Choice, Kind_Str_Choice); + if First = null then + First := Info; + else + Last.Choice_Chain := Info; end if; + Last := Info; + Info.Choice_Chain := null; + Info.Choice_Assoc := Nbr_Assocs - 1; + Info.Choice_Parent := Choice; + Info.Choice_Expr := Get_Expression (Choice); + + Nbr_Choices := Nbr_Choices + 1; + Choice := Get_Chain (Choice); end loop; - if not First then - Cond := New_Obj_Value (Cond_Var); - end if; - Start_If_Stmt (If_Blk, Cond); - Translate_Statements_Chain (Stmt_Chain); - New_Else_Stmt (If_Blk); - Translate_String_Choice - (Expr, Val_Node, Tinfo, Func, Cond_Var, Ch); - Finish_If_Stmt (If_Blk); - end Translate_String_Choice; + + -- Sort choices. + declare + procedure Merge_Sort (Head : Ortho_Info_Acc; + Nbr : Natural; + Res : out Ortho_Info_Acc; + Next : out Ortho_Info_Acc) + is + L, R, L_End, R_End : Ortho_Info_Acc; + E, Last : Ortho_Info_Acc; + Half : constant Natural := Nbr / 2; + begin + -- Sorting less than 2 elements is easy! + if Nbr < 2 then + Res := Head; + if Nbr = 0 then + Next := Head; + else + Next := Head.Choice_Chain; + end if; + return; + end if; + + Merge_Sort (Head, Half, L, L_End); + Merge_Sort (L_End, Nbr - Half, R, R_End); + Next := R_End; + + -- Merge + Last := null; + loop + if L /= L_End + and then + (R = R_End + or else + Compare_String_Literals (L.Choice_Expr, R.Choice_Expr) + = Compare_Lt) + then + E := L; + L := L.Choice_Chain; + elsif R /= R_End then + E := R; + R := R.Choice_Chain; + else + exit; + end if; + if Last = null then + Res := E; + else + Last.Choice_Chain := E; + end if; + Last := E; + end loop; + Last.Choice_Chain := R_End; + end Merge_Sort; + Next : Ortho_Info_Acc; + begin + Merge_Sort (First, Nbr_Choices, First, Next); + if Next /= null then + raise Internal_Error; + end if; + end; + + Translate_String_Case_Statement_Common + (Stmt, Expr_Type, Tinfo, Expr_Node, C_Node); + + -- Generate choices table. + Sel_Length := Eval_Discrete_Type_Length + (Get_String_Type_Bound_Type (Expr_Type)); + String_Type := New_Constrained_Array_Type + (Tinfo.T.Base_Type (Mode_Value), + New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Sel_Length))); + Table_Base_Type := New_Array_Type (String_Type, Ghdl_Index_Type); + New_Type_Decl (Create_Uniq_Identifier, Table_Base_Type); + Table_Type := New_Constrained_Array_Type + (Table_Base_Type, + New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Nbr_Choices))); + New_Type_Decl (Create_Uniq_Identifier, Table_Type); + New_Const_Decl (Table, Create_Uniq_Identifier, O_Storage_Private, + Table_Type); + Start_Const_Value (Table); + Start_Array_Aggr (List, Table_Type); + Info := First; + while Info /= null loop + New_Array_Aggr_El (List, Chap7.Translate_Static_Expression + (Info.Choice_Expr, Expr_Type)); + Info := Info.Choice_Chain; + end loop; + Finish_Array_Aggr (List, Table_Cst); + Finish_Const_Value (Table, Table_Cst); + + -- Generate assoc table. + Assoc_Table_Base_Type := + New_Array_Type (Ghdl_Index_Type, Ghdl_Index_Type); + New_Type_Decl (Create_Uniq_Identifier, Assoc_Table_Base_Type); + Assoc_Table_Type := New_Constrained_Array_Type + (Assoc_Table_Base_Type, + New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Nbr_Choices))); + New_Type_Decl (Create_Uniq_Identifier, Assoc_Table_Type); + New_Const_Decl (Assoc_Table, Create_Uniq_Identifier, + O_Storage_Private, Assoc_Table_Type); + Start_Const_Value (Assoc_Table); + Start_Array_Aggr (List, Assoc_Table_Type); + Info := First; + while Info /= null loop + New_Array_Aggr_El + (List, New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Info.Choice_Assoc))); + Info := Info.Choice_Chain; + end loop; + Finish_Array_Aggr (List, Table_Cst); + Finish_Const_Value (Assoc_Table, Table_Cst); + + -- Generate dichotomy code. + declare + Var_Lo, Var_Hi, Var_Mid : O_Dnode; + Var_Cmp : O_Dnode; + Var_Idx : O_Dnode; + Label : O_Snode; + Others_Lit : O_Cnode; + If_Blk1, If_Blk2 : O_If_Block; + Case_Blk : O_Case_Block; + begin + Var_Idx := Create_Temp (Ghdl_Index_Type); + + Start_Declare_Stmt; + + New_Var_Decl (Var_Lo, Wki_Lo, O_Storage_Local, Ghdl_Index_Type); + New_Var_Decl (Var_Hi, Wki_Hi, O_Storage_Local, Ghdl_Index_Type); + New_Var_Decl (Var_Mid, Wki_Mid, O_Storage_Local, Ghdl_Index_Type); + New_Var_Decl (Var_Cmp, Wki_Cmp, + O_Storage_Local, Ghdl_Compare_Type); + + New_Assign_Stmt (New_Obj (Var_Lo), New_Lit (Ghdl_Index_0)); + New_Assign_Stmt + (New_Obj (Var_Hi), + New_Lit (New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Nbr_Choices)))); + + Func := Chap7.Find_Predefined_Function + (Get_Base_Type (Expr_Type), Iir_Predefined_Array_Greater); + + if Has_Others then + Others_Lit := New_Unsigned_Literal + (Ghdl_Index_Type, Unsigned_64 (Nbr_Assocs)); + end if; + + Start_Loop_Stmt (Label); + New_Assign_Stmt + (New_Obj (Var_Mid), + New_Dyadic_Op (ON_Div_Ov, + New_Dyadic_Op (ON_Add_Ov, + New_Obj_Value (Var_Lo), + New_Obj_Value (Var_Hi)), + New_Lit (New_Unsigned_Literal + (Ghdl_Index_Type, 2)))); + New_Assign_Stmt + (New_Obj (Var_Cmp), + Translate_Simple_String_Choice + (Expr_Node, + New_Address (New_Indexed_Element (New_Obj (Table), + New_Obj_Value (Var_Mid)), + Tinfo.T.Base_Ptr_Type (Mode_Value)), + C_Node, Tinfo, Func)); + Start_If_Stmt + (If_Blk1, + New_Compare_Op (ON_Eq, + New_Obj_Value (Var_Cmp), + New_Lit (Ghdl_Compare_Eq), + Ghdl_Bool_Type)); + New_Assign_Stmt + (New_Obj (Var_Idx), + New_Value (New_Indexed_Element (New_Obj (Assoc_Table), + New_Obj_Value (Var_Mid)))); + New_Exit_Stmt (Label); + Finish_If_Stmt (If_Blk1); + + Start_If_Stmt + (If_Blk1, + New_Compare_Op (ON_Eq, + New_Obj_Value (Var_Cmp), + New_Lit (Ghdl_Compare_Lt), + Ghdl_Bool_Type)); + Start_If_Stmt + (If_Blk2, + New_Compare_Op (ON_Le, + New_Obj_Value (Var_Mid), + New_Obj_Value (Var_Lo), + Ghdl_Bool_Type)); + if not Has_Others then + Chap6.Gen_Program_Error (Stmt, Chap6.Prg_Err_Bad_Choice); + else + New_Assign_Stmt (New_Obj (Var_Idx), New_Lit (Others_Lit)); + New_Exit_Stmt (Label); + end if; + New_Else_Stmt (If_Blk2); + New_Assign_Stmt (New_Obj (Var_Hi), + New_Dyadic_Op (ON_Sub_Ov, + New_Obj_Value (Var_Mid), + New_Lit (Ghdl_Index_1))); + Finish_If_Stmt (If_Blk2); + + New_Else_Stmt (If_Blk1); + + Start_If_Stmt + (If_Blk2, + New_Compare_Op (ON_Ge, + New_Obj_Value (Var_Mid), + New_Obj_Value (Var_Hi), + Ghdl_Bool_Type)); + if not Has_Others then + Chap6.Gen_Program_Error (Stmt, Chap6.Prg_Err_No_Choice); + else + New_Assign_Stmt (New_Obj (Var_Idx), New_Lit (Others_Lit)); + New_Exit_Stmt (Label); + end if; + New_Else_Stmt (If_Blk2); + New_Assign_Stmt (New_Obj (Var_Lo), + New_Dyadic_Op (ON_Add_Ov, + New_Obj_Value (Var_Mid), + New_Lit (Ghdl_Index_1))); + Finish_If_Stmt (If_Blk2); + + Finish_If_Stmt (If_Blk1); + + Finish_Loop_Stmt (Label); + + Finish_Declare_Stmt; + + Start_Case_Stmt (Case_Blk, New_Obj_Value (Var_Idx)); + + Choice := Choices_Chain; + while Choice /= Null_Iir loop + case Get_Kind (Choice) is + when Iir_Kind_Choice_By_Others => + Start_Choice (Case_Blk); + New_Expr_Choice (Case_Blk, Others_Lit); + Finish_Choice (Case_Blk); + Translate_Statements_Chain (Get_Associated (Choice)); + when Iir_Kind_Choice_By_Expression => + if not Get_Same_Alternative_Flag (Choice) then + Start_Choice (Case_Blk); + New_Expr_Choice + (Case_Blk, + New_Unsigned_Literal + (Ghdl_Index_Type, + Unsigned_64 (Get_Info (Choice).Choice_Assoc))); + Finish_Choice (Case_Blk); + Translate_Statements_Chain (Get_Associated (Choice)); + end if; + Free_Info (Choice); + when others => + raise Internal_Error; + end case; + Choice := Get_Chain (Choice); + end loop; + + Start_Choice (Case_Blk); + New_Default_Choice (Case_Blk); + Finish_Choice (Case_Blk); + Chap6.Gen_Program_Error (Stmt, Chap6.Prg_Err_No_Choice); + + Finish_Case_Stmt (Case_Blk); + end; + end Translate_String_Case_Statement_Dichotomy; -- Case statement whose expression is an unidim array. - procedure Translate_String_Case_Statement (Stmt : Iir_Case_Statement) + -- Translate into if/elsif statements (linear search). + procedure Translate_String_Case_Statement_Linear + (Stmt : Iir_Case_Statement) is - Expr : Iir; Expr_Type : Iir; - Base_Type : Iir; -- Node containing the address of the selector. Expr_Node : O_Dnode; -- Node containing the current choice. - C_Node : O_Dnode; + Val_Node : O_Dnode; Tinfo : Type_Info_Acc; - Choices_Chain : Iir; - Func : Iir; Cond_Var : O_Dnode; - begin - -- Translate into if/elsif statements. - -- FIXME: if the number of literals ** length of the array < 256, - -- use a case statement. - Expr := Get_Expression (Stmt); - Expr_Type := Get_Type (Expr); - Base_Type := Get_Base_Type (Expr_Type); - Tinfo := Get_Info (Base_Type); - Expr_Node := Create_Temp_Init - (Tinfo.Ortho_Ptr_Type (Mode_Value), - Chap7.Translate_Expression (Expr, Base_Type)); - C_Node := Create_Temp (Tinfo.Ortho_Type (Mode_Value)); - New_Assign_Stmt - (New_Selected_Element (New_Obj (C_Node), - Tinfo.T.Bounds_Field (Mode_Value)), - New_Value_Selected_Acc_Value - (New_Obj (Expr_Node), Tinfo.T.Bounds_Field (Mode_Value))); + Func : Iir; - Cond_Var := Create_Temp (Std_Boolean_Type_Node); + procedure Translate_String_Choice (Choice : Iir) + is + Cond : O_Enode; + If_Blk : O_If_Block; + Stmt_Chain : Iir; + First : Boolean; + Ch : Iir; + Ch_Expr : Iir; + begin + if Choice = Null_Iir then + return; + end if; + + First := True; + Stmt_Chain := Get_Associated (Choice); + Ch := Choice; + loop + case Get_Kind (Ch) is + when Iir_Kind_Choice_By_Expression => + Ch_Expr := Get_Expression (Ch); + Cond := Translate_Simple_String_Choice + (Expr_Node, + Chap7.Translate_Expression (Ch_Expr, + Get_Type (Ch_Expr)), + Val_Node, Tinfo, Func); + when Iir_Kind_Choice_By_Others => + Translate_Statements_Chain (Stmt_Chain); + return; + when others => + Error_Kind ("translate_string_choice", Ch); + end case; + if not First then + New_Assign_Stmt + (New_Obj (Cond_Var), + New_Dyadic_Op (ON_Or, New_Obj_Value (Cond_Var), Cond)); + end if; + Ch := Get_Chain (Ch); + exit when Ch = Null_Iir; + exit when not Get_Same_Alternative_Flag (Ch); + exit when Get_Associated (Ch) /= Null_Iir; + if First then + New_Assign_Stmt (New_Obj (Cond_Var), Cond); + First := False; + end if; + end loop; + if not First then + Cond := New_Obj_Value (Cond_Var); + end if; + Start_If_Stmt (If_Blk, Cond); + Translate_Statements_Chain (Stmt_Chain); + New_Else_Stmt (If_Blk); + Translate_String_Choice (Ch); + Finish_If_Stmt (If_Blk); + end Translate_String_Choice; + begin + Translate_String_Case_Statement_Common + (Stmt, Expr_Type, Tinfo, Expr_Node, Val_Node); Func := Chap7.Find_Predefined_Function - (Base_Type, Iir_Predefined_Array_Equality); + (Get_Base_Type (Expr_Type), Iir_Predefined_Array_Equality); - Choices_Chain := Get_Case_Statement_Alternative_Chain (Stmt); - Translate_String_Choice - (Expr_Node, C_Node, - Tinfo, Func, Cond_Var, Choices_Chain); - end Translate_String_Case_Statement; + Cond_Var := Create_Temp (Std_Boolean_Type_Node); + + Translate_String_Choice (Get_Case_Statement_Alternative_Chain (Stmt)); + end Translate_String_Case_Statement_Linear; procedure Translate_Case_Choice (Choice : Iir; Choice_Type : Iir; Blk : in out O_Case_Block) @@ -19045,7 +19490,30 @@ package body Translation is Expr := Get_Expression (Stmt); Expr_Type := Get_Type (Expr); if Get_Kind (Expr_Type) = Iir_Kind_Array_Subtype_Definition then - Translate_String_Case_Statement (Stmt); + declare + Nbr_Choices : Natural := 0; + Choice : Iir; + begin + Choice := Get_Case_Statement_Alternative_Chain (Stmt); + while Choice /= Null_Iir loop + case Get_Kind (Choice) is + when Iir_Kind_Choice_By_Others => + exit; + when Iir_Kind_Choice_By_Expression => + null; + when others => + raise Internal_Error; + end case; + Nbr_Choices := Nbr_Choices + 1; + Choice := Get_Chain (Choice); + end loop; + + if Nbr_Choices < 3 then + Translate_String_Case_Statement_Linear (Stmt); + else + Translate_String_Case_Statement_Dichotomy (Stmt); + end if; + end; return; end if; Start_Case_Stmt (Case_Blk, Chap7.Translate_Expression (Expr)); @@ -20950,6 +21418,313 @@ package body Translation is Info.Process_Parent_Field := Field; end Translate_Process_Declarations; + procedure Translate_Psl_Assert_Declarations (Stmt : Iir) + is + use PSL.Nodes; + use PSL.NFAs; + + Mark : Id_Mark_Type; + Info : Ortho_Info_Acc; + Itype : O_Tnode; + Field : O_Fnode; + + N : NFA; + begin + -- Create process record. + Push_Identifier_Prefix (Mark, Get_Identifier (Stmt)); + Push_Instance_Factory (O_Tnode_Null); + Info := Add_Info (Stmt, Kind_Psl_Assert); + + N := Get_PSL_NFA (Stmt); + Labelize_States (N, Info.Psl_Vect_Len); + Info.Psl_Vect_Type := New_Constrained_Array_Type + (Std_Boolean_Array_Type, + New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Info.Psl_Vect_Len))); + New_Type_Decl (Create_Identifier ("VECTTYPE"), Info.Psl_Vect_Type); + Info.Psl_Vect_Var := + Create_Var (Create_Var_Identifier ("VECT"), Info.Psl_Vect_Type); + + Pop_Instance_Factory (Itype); + New_Type_Decl (Create_Identifier ("INSTTYPE"), Itype); + Pop_Identifier_Prefix (Mark); + + -- Create a field in the parent record. + Field := Add_Instance_Factory_Field + (Create_Identifier_Without_Prefix (Stmt), Itype); + + -- Set info in child record. + Info.Psl_Decls_Type := Itype; + Info.Psl_Parent_Field := Field; + end Translate_Psl_Assert_Declarations; + + function Translate_Psl_Expr (Expr : PSL_Node; Eos : Boolean) + return O_Enode + is + use PSL.Nodes; + begin + case Get_Kind (Expr) is + when N_HDL_Expr => + declare + E : Iir; + Rtype : Iir; + Res : O_Enode; + begin + E := Get_HDL_Node (Expr); + Rtype := Get_Base_Type (Get_Type (E)); + Res := Chap7.Translate_Expression (E); + if Rtype = Boolean_Type_Definition then + return Res; + elsif Rtype = Ieee.Std_Logic_1164.Std_Ulogic_Type then + return New_Value + (New_Indexed_Element + (New_Obj (Ghdl_Std_Ulogic_To_Boolean_Array), + New_Convert_Ov (Res, Ghdl_Index_Type))); + else + Error_Kind ("translate_psl_expr/hdl_expr", Expr); + end if; + end; + when N_True => + return New_Lit (Std_Boolean_True_Node); + when N_EOS => + if Eos then + return New_Lit (Std_Boolean_True_Node); + else + return New_Lit (Std_Boolean_False_Node); + end if; + when N_Not_Bool => + return New_Monadic_Op + (ON_Not, + Translate_Psl_Expr (Get_Boolean (Expr), Eos)); + when N_And_Bool => + return New_Dyadic_Op + (ON_And, + Translate_Psl_Expr (Get_Left (Expr), Eos), + Translate_Psl_Expr (Get_Right (Expr), Eos)); + when N_Or_Bool => + return New_Dyadic_Op + (ON_Or, + Translate_Psl_Expr (Get_Left (Expr), Eos), + Translate_Psl_Expr (Get_Right (Expr), Eos)); + when others => + Error_Kind ("translate_psl_expr", Expr); + end case; + end Translate_Psl_Expr; + + -- Return TRUE iff NFA has an edge with an EOS. + -- If so, we need to create a finalizer. + function Psl_Need_Finalizer (Nfa : PSL_NFA) return Boolean + is + use PSL.NFAs; + S : NFA_State; + E : NFA_Edge; + begin + S := Get_Final_State (Nfa); + E := Get_First_Dest_Edge (S); + while E /= No_Edge loop + if PSL.NFAs.Utils.Has_EOS (Get_Edge_Expr (E)) then + return True; + end if; + E := Get_Next_Dest_Edge (E); + end loop; + return False; + end Psl_Need_Finalizer; + + procedure Translate_Psl_Assert_Statement + (Stmt : Iir; Base : Block_Info_Acc) + is + use PSL.NFAs; + Inter_List : O_Inter_List; + Instance : O_Dnode; + Info : Psl_Info_Acc; + Var_I : O_Dnode; + Var_Nvec : O_Dnode; + Label : O_Snode; + Clk_Blk : O_If_Block; + S_Blk : O_If_Block; + E_Blk : O_If_Block; + S : NFA_State; + S_Num : Int32; + E : NFA_Edge; + Sd : NFA_State; + Cond : O_Enode; + NFA : PSL_NFA; + D_Lit : O_Cnode; + begin + Info := Get_Info (Stmt); + Start_Procedure_Decl (Inter_List, Create_Identifier ("PROC"), + O_Storage_Private); + New_Interface_Decl (Inter_List, Instance, Wki_Instance, + Base.Block_Decls_Ptr_Type); + Finish_Subprogram_Decl (Inter_List, Info.Psl_Proc_Subprg); + + Start_Subprogram_Body (Info.Psl_Proc_Subprg); + Push_Local_Factory; + -- Push scope for architecture declarations. + Push_Scope (Base.Block_Decls_Type, Instance); + + -- New state vector. + New_Var_Decl (Var_Nvec, Wki_Res, O_Storage_Local, Info.Psl_Vect_Type); + + -- Initialize the new state vector. + Start_Declare_Stmt; + New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type); + Init_Var (Var_I); + Start_Loop_Stmt (Label); + Gen_Exit_When + (Label, + New_Compare_Op (ON_Ge, + New_Obj_Value (Var_I), + New_Lit (New_Unsigned_Literal + (Ghdl_Index_Type, + Unsigned_64 (Info.Psl_Vect_Len))), + Ghdl_Bool_Type)); + New_Assign_Stmt (New_Indexed_Element (New_Obj (Var_Nvec), + New_Obj_Value (Var_I)), + New_Lit (Std_Boolean_False_Node)); + Inc_Var (Var_I); + Finish_Loop_Stmt (Label); + Finish_Declare_Stmt; + + -- Global if statement for the clock. + Open_Temp; + Start_If_Stmt (Clk_Blk, + Translate_Psl_Expr (Get_PSL_Clock (Stmt), False)); + + -- For each state: if set, evaluate all outgoing edges. + NFA := Get_PSL_NFA (Stmt); + S := Get_First_State (NFA); + while S /= No_State loop + S_Num := Get_State_Label (S); + Open_Temp; + + Start_If_Stmt + (S_Blk, + New_Value + (New_Indexed_Element (Get_Var (Info.Psl_Vect_Var), + New_Lit (New_Index_Lit + (Unsigned_64 (S_Num)))))); + + E := Get_First_Src_Edge (S); + while E /= No_Edge loop + Sd := Get_Edge_Dest (E); + Open_Temp; + + D_Lit := New_Index_Lit (Unsigned_64 (Get_State_Label (Sd))); + Cond := New_Monadic_Op + (ON_Not, + New_Value (New_Indexed_Element (New_Obj (Var_Nvec), + New_Lit (D_Lit)))); + Cond := New_Dyadic_Op + (ON_And, Cond, Translate_Psl_Expr (Get_Edge_Expr (E), False)); + Start_If_Stmt (E_Blk, Cond); + New_Assign_Stmt + (New_Indexed_Element (New_Obj (Var_Nvec), New_Lit (D_Lit)), + New_Lit (Std_Boolean_True_Node)); + Finish_If_Stmt (E_Blk); + + Close_Temp; + E := Get_Next_Src_Edge (E); + end loop; + + Finish_If_Stmt (S_Blk); + Close_Temp; + S := Get_Next_State (S); + end loop; + + -- Check fail state. + S := Get_Final_State (NFA); + S_Num := Get_State_Label (S); + pragma Assert (Integer (S_Num) = Info.Psl_Vect_Len - 1); + Start_If_Stmt + (S_Blk, + New_Value + (New_Indexed_Element (New_Obj (Var_Nvec), + New_Lit (New_Index_Lit + (Unsigned_64 (S_Num)))))); + Chap8.Translate_Report + (Stmt, Ghdl_Psl_Assert_Failed, Severity_Level_Error); + Finish_If_Stmt (S_Blk); + + -- Assign state vector. + Start_Declare_Stmt; + New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type); + Init_Var (Var_I); + Start_Loop_Stmt (Label); + Gen_Exit_When + (Label, + New_Compare_Op (ON_Ge, + New_Obj_Value (Var_I), + New_Lit (New_Unsigned_Literal + (Ghdl_Index_Type, + Unsigned_64 (Info.Psl_Vect_Len))), + Ghdl_Bool_Type)); + New_Assign_Stmt + (New_Indexed_Element (Get_Var (Info.Psl_Vect_Var), + New_Obj_Value (Var_I)), + New_Value (New_Indexed_Element (New_Obj (Var_Nvec), + New_Obj_Value (Var_I)))); + Inc_Var (Var_I); + Finish_Loop_Stmt (Label); + Finish_Declare_Stmt; + + Close_Temp; + Finish_If_Stmt (Clk_Blk); + + Pop_Scope (Base.Block_Decls_Type); + Pop_Local_Factory; + Finish_Subprogram_Body; + + -- The finalizer. + if Psl_Need_Finalizer (NFA) then + Start_Procedure_Decl (Inter_List, Create_Identifier ("FINALPROC"), + O_Storage_Private); + New_Interface_Decl (Inter_List, Instance, Wki_Instance, + Base.Block_Decls_Ptr_Type); + Finish_Subprogram_Decl (Inter_List, Info.Psl_Proc_Final_Subprg); + + Start_Subprogram_Body (Info.Psl_Proc_Final_Subprg); + Push_Local_Factory; + -- Push scope for architecture declarations. + Push_Scope (Base.Block_Decls_Type, Instance); + + S := Get_Final_State (NFA); + E := Get_First_Dest_Edge (S); + while E /= No_Edge loop + Sd := Get_Edge_Src (E); + + if PSL.NFAs.Utils.Has_EOS (Get_Edge_Expr (E)) then + + S_Num := Get_State_Label (Sd); + Open_Temp; + + Cond := New_Value + (New_Indexed_Element + (Get_Var (Info.Psl_Vect_Var), + New_Lit (New_Index_Lit (Unsigned_64 (S_Num))))); + Cond := New_Dyadic_Op + (ON_And, Cond, + Translate_Psl_Expr (Get_Edge_Expr (E), True)); + Start_If_Stmt (E_Blk, Cond); + Chap8.Translate_Report + (Stmt, Ghdl_Psl_Assert_Failed, Severity_Level_Error); + New_Return_Stmt; + Finish_If_Stmt (E_Blk); + + Close_Temp; + end if; + + E := Get_Next_Dest_Edge (E); + end loop; + + Pop_Scope (Base.Block_Decls_Type); + Pop_Local_Factory; + Finish_Subprogram_Body; + else + Info.Psl_Proc_Final_Subprg := O_Dnode_Null; + end if; + end Translate_Psl_Assert_Statement; + -- Create the instance for block BLOCK. -- BLOCK can be either an entity, an architecture or a block statement. procedure Translate_Block_Declarations (Block : Iir; Origin : Iir) @@ -20964,6 +21739,12 @@ package body Translation is when Iir_Kind_Process_Statement | Iir_Kind_Sensitized_Process_Statement => Translate_Process_Declarations (El); + when Iir_Kind_Psl_Default_Clock => + null; + when Iir_Kind_Psl_Declaration => + null; + when Iir_Kind_Psl_Assert_Statement => + Translate_Psl_Assert_Declarations (El); when Iir_Kind_Component_Instantiation_Statement => Translate_Component_Instantiation_Statement (El); when Iir_Kind_Block_Statement => @@ -21191,6 +21972,21 @@ package body Translation is end if; Pop_Scope (Info.Process_Decls_Type); end; + when Iir_Kind_Psl_Default_Clock => + null; + when Iir_Kind_Psl_Declaration => + null; + when Iir_Kind_Psl_Assert_Statement => + declare + Info : Psl_Info_Acc; + begin + Info := Get_Info (Stmt); + Push_Scope (Info.Psl_Decls_Type, + Info.Psl_Parent_Field, + Block_Info.Block_Decls_Type); + Translate_Psl_Assert_Statement (Stmt, Base_Info); + Pop_Scope (Info.Psl_Decls_Type); + end; when Iir_Kind_Component_Instantiation_Statement => Chap4.Translate_Association_Subprograms (Stmt, Block, Base_Block, @@ -21511,6 +22307,89 @@ package body Translation is Pop_Scope (Info.Process_Decls_Type); end Elab_Process; + -- PROC: the process to be elaborated + -- BLOCK_INFO: info for the block containing the process + -- BASE_INFO: info for the global block + procedure Elab_Psl_Assert (Stmt : Iir; + Block_Info : Block_Info_Acc; + Base_Info : Block_Info_Acc) + is + Constr : O_Assoc_List; + Info : Psl_Info_Acc; + List : Iir_List; + Clk : PSL_Node; + Var_I : O_Dnode; + Label : O_Snode; + begin + New_Debug_Line_Stmt (Get_Line_Number (Stmt)); + + Info := Get_Info (Stmt); + + -- Set instance name. + Push_Scope (Info.Psl_Decls_Type, + Info.Psl_Parent_Field, + Block_Info.Block_Decls_Type); + + -- Register process. + Start_Association (Constr, Ghdl_Sensitized_Process_Register); + New_Association + (Constr, New_Unchecked_Address + (Get_Instance_Ref (Base_Info.Block_Decls_Type), Ghdl_Ptr_Type)); + New_Association + (Constr, + New_Lit (New_Subprogram_Address (Info.Psl_Proc_Subprg, + Ghdl_Ptr_Type))); + Rtis.Associate_Rti_Context (Constr, Stmt); + New_Procedure_Call (Constr); + + -- Register clock sensitivity. + Clk := Get_PSL_Clock (Stmt); + List := Create_Iir_List; + Canon_PSL.Canon_Extract_Sensitivity (Clk, List); + Destroy_Types_In_List (List); + Register_Signal_List (List, Ghdl_Process_Add_Sensitivity); + Destroy_Iir_List (List); + + -- Register finalizer (if any). + if Info.Psl_Proc_Final_Subprg /= O_Dnode_Null then + Start_Association (Constr, Ghdl_Finalize_Register); + New_Association + (Constr, New_Unchecked_Address + (Get_Instance_Ref (Base_Info.Block_Decls_Type), + Ghdl_Ptr_Type)); + New_Association + (Constr, + New_Lit (New_Subprogram_Address (Info.Psl_Proc_Final_Subprg, + Ghdl_Ptr_Type))); + New_Procedure_Call (Constr); + end if; + + -- Initialize state vector. + Start_Declare_Stmt; + New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type); + New_Assign_Stmt (New_Indexed_Element (Get_Var (Info.Psl_Vect_Var), + New_Lit (Ghdl_Index_0)), + New_Lit (Std_Boolean_True_Node)); + New_Assign_Stmt (New_Obj (Var_I), New_Lit (Ghdl_Index_1)); + Start_Loop_Stmt (Label); + Gen_Exit_When + (Label, + New_Compare_Op (ON_Ge, + New_Obj_Value (Var_I), + New_Lit (New_Unsigned_Literal + (Ghdl_Index_Type, + Unsigned_64 (Info.Psl_Vect_Len))), + Ghdl_Bool_Type)); + New_Assign_Stmt (New_Indexed_Element (Get_Var (Info.Psl_Vect_Var), + New_Obj_Value (Var_I)), + New_Lit (Std_Boolean_False_Node)); + Inc_Var (Var_I); + Finish_Loop_Stmt (Label); + Finish_Declare_Stmt; + + Pop_Scope (Info.Psl_Decls_Type); + end Elab_Psl_Assert; + procedure Elab_Implicit_Guard_Signal (Block : Iir_Block_Statement; Block_Info : Block_Info_Acc) is @@ -22178,6 +23057,12 @@ package body Translation is when Iir_Kind_Process_Statement | Iir_Kind_Sensitized_Process_Statement => Elab_Process (Stmt, Block_Info, Base_Info); + when Iir_Kind_Psl_Default_Clock => + null; + when Iir_Kind_Psl_Declaration => + null; + when Iir_Kind_Psl_Assert_Statement => + Elab_Psl_Assert (Stmt, Block_Info, Base_Info); when Iir_Kind_Component_Instantiation_Statement => declare Info : Block_Info_Acc; @@ -24455,6 +25340,10 @@ package body Translation is (Constr, Get_Identifier ("__ghdl_rtik_attribute_stable"), Ghdl_Rtik_Attribute_Stable); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_psl_assert"), + Ghdl_Rtik_Psl_Assert); + New_Enum_Literal (Constr, Get_Identifier ("__ghdl_rtik_error"), Ghdl_Rtik_Error); Finish_Enum_Type (Constr, Ghdl_Rtik); @@ -25205,6 +26094,8 @@ package body Translation is case Info.Type_Mode is when Type_Mode_I32 => Kind := Ghdl_Rtik_Type_I32; + when Type_Mode_I64 => + Kind := Ghdl_Rtik_Type_I64; when Type_Mode_F64 => Kind := Ghdl_Rtik_Type_F64; when Type_Mode_P64 => @@ -26320,6 +27211,37 @@ package body Translation is Push_Identifier_Prefix (Mark, Get_Identifier (Stmt)); Generate_Instance (Stmt, Parent_Rti); Pop_Identifier_Prefix (Mark); + when Iir_Kind_Psl_Default_Clock => + null; + when Iir_Kind_Psl_Declaration => + null; + when Iir_Kind_Psl_Assert_Statement => + declare + Name : O_Dnode; + List : O_Record_Aggr_List; + + Rti : O_Dnode; + Res : O_Cnode; + Info : Psl_Info_Acc; + begin + Info := Get_Info (Stmt); + Push_Identifier_Prefix (Mark, Get_Identifier (Stmt)); + Name := Generate_Name (Stmt); + + New_Const_Decl (Rti, Create_Identifier ("RTI"), + O_Storage_Public, Ghdl_Rtin_Type_Scalar); + + Start_Const_Value (Rti); + Start_Record_Aggr (List, Ghdl_Rtin_Type_Scalar); + New_Record_Aggr_El + (List, Generate_Common (Ghdl_Rtik_Psl_Assert)); + New_Record_Aggr_El + (List, New_Global_Address (Name, Char_Ptr_Type)); + Finish_Record_Aggr (List, Res); + Finish_Const_Value (Rti, Res); + Info.Psl_Rti_Const := Rti; + Pop_Identifier_Prefix (Mark); + end; when others => Error_Kind ("rti.generate_concurrent_statement_chain", Stmt); end case; @@ -26710,6 +27632,8 @@ package body Translation is when Iir_Kind_Process_Statement | Iir_Kind_Sensitized_Process_Statement => Rti_Const := Node_Info.Process_Rti_Const; + when Iir_Kind_Psl_Assert_Statement => + Rti_Const := Node_Info.Psl_Rti_Const; when others => Error_Kind ("get_context_rti", Node); end case; @@ -26738,6 +27662,8 @@ package body Translation is when Iir_Kind_Process_Statement | Iir_Kind_Sensitized_Process_Statement => Block_Type := Node_Info.Process_Decls_Type; + when Iir_Kind_Psl_Assert_Statement => + Block_Type := Node_Info.Psl_Decls_Type; when others => Error_Kind ("get_context_addr", Node); end case; @@ -26935,8 +27861,6 @@ package body Translation is Wki_Right := Get_Identifier ("right"); Wki_Dir := Get_Identifier ("dir"); Wki_Length := Get_Identifier ("length"); - Wki_Kind := Get_Identifier ("kind"); - Wki_Dim := Get_Identifier ("dim"); Wki_I := Get_Identifier ("I"); Wki_Instance := Get_Identifier ("INSTANCE"); Wki_Arch_Instance := Get_Identifier ("ARCH_INSTANCE"); @@ -26947,6 +27871,10 @@ package body Translation is Wki_Parent := Get_Identifier ("parent"); Wki_Filename := Get_Identifier ("filename"); Wki_Line := Get_Identifier ("line"); + Wki_Lo := Get_Identifier ("lo"); + Wki_Hi := Get_Identifier ("hi"); + Wki_Mid := Get_Identifier ("mid"); + Wki_Cmp := Get_Identifier ("cmp"); Sizetype := New_Unsigned_Type (32); New_Type_Decl (Get_Identifier ("__ghdl_size_type"), Sizetype); @@ -27296,6 +28224,15 @@ package body Translation is ("__ghdl_postponed_sensitized_process_register", Ghdl_Postponed_Sensitized_Process_Register); end; + + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_finalize_register"), + O_Storage_External); + New_Interface_Decl + (Interfaces, Param, Wki_This, Ghdl_Ptr_Type); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("proc"), Ghdl_Ptr_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Finalize_Register); end Initialize; procedure Create_Signal_Subprograms @@ -27486,6 +28423,8 @@ package body Translation is end Create_Report_Subprg; begin Create_Report_Subprg ("__ghdl_assert_failed", Ghdl_Assert_Failed); + Create_Report_Subprg ("__ghdl_psl_assert_failed", + Ghdl_Psl_Assert_Failed); Create_Report_Subprg ("__ghdl_report", Ghdl_Report); end; @@ -28260,6 +29199,10 @@ package body Translation is Std_Boolean_True_Node := Get_Ortho_Expr (Boolean_True); Std_Boolean_False_Node := Get_Ortho_Expr (Boolean_False); + Std_Boolean_Array_Type := + New_Array_Type (Std_Boolean_Type_Node, Ghdl_Index_Type); + New_Type_Decl (Create_Identifier ("BOOLEAN_ARRAY"), + Std_Boolean_Array_Type); Chap4.Translate_Bool_Type_Declaration (Bit_Type); Chap4.Translate_Type_Declaration (Character_Type); @@ -28337,6 +29280,16 @@ package body Translation is := Get_Info (Bit_Type_Definition).Type_Rti; end if; + -- Std_Ulogic indexed array of STD.Boolean. + -- Used by PSL to convert Std_Ulogic to boolean. + Std_Ulogic_Boolean_Array_Type := + New_Constrained_Array_Type (Std_Boolean_Array_Type, New_Index_Lit (9)); + New_Type_Decl (Get_Identifier ("__ghdl_std_ulogic_boolean_array_type"), + Std_Ulogic_Boolean_Array_Type); + New_Const_Decl (Ghdl_Std_Ulogic_To_Boolean_Array, + Get_Identifier ("__ghdl_std_ulogic_to_boolean_array"), + O_Storage_External, Std_Ulogic_Boolean_Array_Type); + Pop_Identifier_Prefix (Unit_Mark); Pop_Identifier_Prefix (Lib_Mark); @@ -28,6 +28,7 @@ package Types is for Int32'Size use 32; subtype Nat32 is Int32 range 0 .. Int32'Last; + subtype Pos32 is Nat32 range 1 .. Nat32'Last; type Uns32 is new Interfaces.Unsigned_32; @@ -53,7 +54,7 @@ package Types is type String_Cst is access constant String; type String_Acc_Array is array (Natural range <>) of String_Acc; - subtype String_Fat is String (Positive); + type String_Fat is array (Pos32) of Character; type String_Fat_Acc is access String_Fat; -- Array of iir_int32. @@ -105,6 +106,12 @@ package Types is type File_Buffer is array (Source_Ptr range <>) of Character; type File_Buffer_Acc is access File_Buffer; + -- PSL Node. + type PSL_Node is new Int32; + + -- PSL NFA + type PSL_NFA is new Int32; + -- Indentation. -- This is used by all packages that display vhdl code or informations. Indentation : constant := 2; diff --git a/version.ads b/version.ads index ba2b96d69..b8e404e23 100644 --- a/version.ads +++ b/version.ads @@ -1,5 +1,5 @@ package Version is Ghdl_Release : constant String := - "GHDL 0.29dev (20090921) [Sokcho edition]"; - Ghdl_Ver : constant String := "0.29dev"; + "GHDL 0.29 (20100109) [Sokcho edition]"; + Ghdl_Ver : constant String := "0.29"; end Version; diff --git a/xtools/check_iirs_pkg.adb b/xtools/check_iirs_pkg.adb index d0f581875..72781bbb3 100644 --- a/xtools/check_iirs_pkg.adb +++ b/xtools/check_iirs_pkg.adb @@ -505,6 +505,7 @@ package body Check_Iirs_Pkg is Line := Get_Line (In_Iirs); if not Match (Line, Start_Range_Pat) then -- Bad pattern for left bound. + Put_Line (Standard_Error, "bad pattern"); raise Err; end if; Start := Get_Iir_Pos (Ident); @@ -520,7 +521,7 @@ package body Check_Iirs_Pkg is if Match (Line, End_Range_Pat) then P := Get_Iir_Pos (Ident); if P /= Pos + 1 and then Flag_Disp_Subtype Then - Put_Line ("** missing comments"); + Put_Line (Standard_Error, "** missing comments"); for I in Pos + 1 .. P - 1 loop Put_Line (" --" & Iir_Table.Table (I).Name.all); end loop; @@ -534,6 +535,7 @@ package body Check_Iirs_Pkg is P := Get_Iir_Pos (Ident); if P /= Pos + 1 then -- Bad order. + Put_Line (Standard_Error, "** missing node in range"); raise Err; else Pos := Pos + 1; @@ -552,7 +554,8 @@ package body Check_Iirs_Pkg is begin Field_Pos := Get (Field2pos, Ident); if Field_Pos < 0 then - Put_Line ("*** field not found: '" & S (Ident) & "'"); + Put_Line (Standard_Error, + "*** field not found: '" & S (Ident) & "'"); raise Err; end if; @@ -562,7 +565,7 @@ package body Check_Iirs_Pkg is elsif Ident_2 = "uc" then Conv := Via_Unchecked; else - Put_Line ("*** bad conversion"); + Put_Line (Standard_Error, "*** bad conversion"); raise Err; end if; else @@ -571,7 +574,7 @@ package body Check_Iirs_Pkg is Line := Get_Line (In_Iirs); if not Match (Line, Function_Get_Pat) then - Put_Line ("*** function expected"); + Put_Line (Standard_Error, "*** function expected"); raise Err; end if; @@ -595,24 +598,28 @@ package body Check_Iirs_Pkg is Line := Get_Line (In_Iirs); if Match (Line, Procedure_Set_Pat) then if Func_Table.Table (F).Target_Name.all /= Ident_2 then - Put_Line ("*** procedure target name mismatch (" + Put_Line (Standard_Error, + "*** procedure target name mismatch (" & Func_Table.Table (F).Target_Name.all & " vs " & S (Ident_2) &")"); raise Err; end if; if Func_Table.Table (F).Target_Type.all /= Ident_3 then - Put_Line ("*** procedure target type name mismatch"); + Put_Line (Standard_Error, + "*** procedure target type name mismatch"); raise Err; end if; if Func_Table.Table (F).Value_Type.all /= Ident_5 then - Put_Line ("*** procedure target type name mismatch"); + Put_Line (Standard_Error, + "*** procedure target type name mismatch"); raise Err; end if; Func_Table.Table (F).Value_Name := new String'(To_String (Ident_4)); else if not Match (Line, Rpos (0)) then - Put_Line ("*** procedure or empty line expected"); + Put_Line (Standard_Error, + "*** procedure or empty line expected"); raise Err; end if; end if; @@ -623,7 +630,8 @@ package body Check_Iirs_Pkg is Set_Exit_Status (Success); exception when Err => - Put_Line ("*** Fatal error at line" + Put_Line (Standard_Error, + "*** Fatal error at line" & Positive_Count'Image (Ada.Text_IO.Line (In_Iirs))); Set_Exit_Status (Failure); raise; @@ -778,12 +786,13 @@ package body Check_Iirs_Pkg is -- Check format. if Ident_2 = Nul then - Put_Line ("*** no format for " & S (Ident)); + Put_Line (Standard_Error, + "*** no format for " & S (Ident)); raise Err; end if; P_Num := Get (Format2pos, Ident_2); if P_Num < 0 then - Put_Line ("*** unknown format"); + Put_Line (Standard_Error, "*** unknown format"); raise Err; end if; Format := Format_Type (P_Num); @@ -795,7 +804,7 @@ package body Check_Iirs_Pkg is else Rng := Get (Iir_Kinds2pos, Ident); if Rng = Null_Range then - Put_Line ("*** " & S (Ident)); + Put_Line (Standard_Error, "*** " & S (Ident)); raise Err; end if; for I in Rng.L .. Rng.H loop @@ -834,13 +843,14 @@ package body Check_Iirs_Pkg is if not Field_Table.Table (Field). Formats (Iir_Table.Table (N).Format) then - Put_Line ("** no field for format"); + Put_Line (Standard_Error, "** no field for format"); raise Err; end if; if Is_Alias then if Iir_Table.Table (N).Func (Field) = No_Func then - Put_Line ("** aliased field not yet used"); + Put_Line (Standard_Error, + "** aliased field not yet used"); raise Err; end if; else @@ -848,7 +858,8 @@ package body Check_Iirs_Pkg is --and then --Iir_Table.Table (N).Func (Field) /= Func then - Put_Line ("** Field already used"); + Put_Line (Standard_Error, + "** Field already used"); raise Err; end if; Iir_Table.Table (N).Func (Field) := Func; @@ -879,7 +890,8 @@ package body Check_Iirs_Pkg is end if; Field_Num := Get (Field2pos, Ident); if Field_Num < 0 then - Put_Line ("*** unknown field: " & S (Ident)); + Put_Line (Standard_Error, + "*** unknown field: " & S (Ident)); raise Err; end if; Field := Field_Type (Field_Num); @@ -920,7 +932,8 @@ package body Check_Iirs_Pkg is return; end if; end loop; - Put_Line ("** not currently described"); + Put_Line (Standard_Error, + "** not currently described"); raise Err; end Add_Only_For; begin @@ -930,7 +943,7 @@ package body Check_Iirs_Pkg is else Rng := Get (Iir_Kinds2pos, Ident); if Rng = Null_Range then - Put_Line ("*** " & S (Ident)); + Put_Line (Standard_Error, "*** " & S (Ident)); raise Err; end if; for I in Rng.L .. Rng.H loop @@ -939,7 +952,7 @@ package body Check_Iirs_Pkg is end if; end; elsif Match (Line, " -- Only") then - Put_Line ("** bad only for line"); + Put_Line (Standard_Error, "** bad 'Only' for line"); raise Err; elsif Match (Line, Desc_Comment_Pat) then null; @@ -959,7 +972,8 @@ package body Check_Iirs_Pkg is -- Check each Iir was described. for I in Iir_Table.First .. Iir_Table.Last loop if not Iir_Table.Table (I).Described then - Put_Line ("*** not described: " & Iir_Table.Table (I).Name.all); + Put_Line (Standard_Error, + "*** not described: " & Iir_Table.Table (I).Name.all); raise Err; end if; end loop; @@ -967,9 +981,10 @@ package body Check_Iirs_Pkg is Close (In_Iirs); exception when Err => - Put_Line ("*** Fatal error at line" + Put_Line (Standard_Error, + "*** Fatal error (2) at line" & Positive_Count'Image (Ada.Text_IO.Line (In_Iirs) - 1)); - Put_Line ("*** Line is " & S (Line)); + Put_Line (Standard_Error, "*** Line is " & S (Line)); Set_Exit_Status (Failure); raise; end Read_Desc; |