First import from sources

1 files changed, 242 insertions, 0 deletions

diff --git a/translate/grt/grt-avls.adb b/translate/grt/grt-avls.adb
new file mode 100644
index 0000000..c44f329
--- /dev/null
+++ b/translate/grt/grt-avls.adb
@@ -0,0 +1,242 @@
+--  GHDL Run Time (GRT) - binary balanced tree.
+--  Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold
+--
+--  GHDL is free software; you can redistribute it and/or modify it under
+--  the terms of the GNU General Public License as published by the Free
+--  Software Foundation; either version 2, or (at your option) any later
+--  version.
+--
+--  GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+--  WARRANTY; without even the implied warranty of MERCHANTABILITY or
+--  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+--  for more details.
+--
+--  You should have received a copy of the GNU General Public License
+--  along with GCC; see the file COPYING.  If not, write to the Free
+--  Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+--  02111-1307, USA.
+with Grt.Errors; use Grt.Errors;
+
+package body Grt.Avls is
+   function Get_Height (Tree: AVL_Tree; N : AVL_Nid) return Ghdl_I32 is
+   begin
+      if N = AVL_Nil then
+         return 0;
+      else
+         return Tree (N).Height;
+      end if;
+   end Get_Height;
+
+   procedure Check_AVL (Tree : AVL_Tree; N : AVL_Nid)
+   is
+      L, R : AVL_Nid;
+      Lh, Rh : Ghdl_I32;
+      H : Ghdl_I32;
+   begin
+      if N = AVL_Nil then
+         return;
+      end if;
+      L := Tree (N).Left;
+      R := Tree (N).Right;
+      H := Get_Height (Tree, N);
+      if L = AVL_Nil and R = AVL_Nil then
+         if Get_Height (Tree, N) /= 1 then
+            Internal_Error ("check_AVL(1)");
+         end if;
+         return;
+      elsif L = AVL_Nil then
+         Check_AVL (Tree, R);
+         if H /= Get_Height (Tree, R) + 1 or H > 2 then
+            Internal_Error ("check_AVL(2)");
+         end if;
+      elsif R = AVL_Nil then
+         Check_AVL (Tree, L);
+         if H /= Get_Height (Tree, L) + 1 or H > 2 then
+            Internal_Error ("check_AVL(3)");
+         end if;
+      else
+         Check_AVL (Tree, L);
+         Check_AVL (Tree, R);
+         Lh := Get_Height (Tree, L);
+         Rh := Get_Height (Tree, R);
+         if Ghdl_I32'Max (Lh, Rh) + 1 /= H then
+            Internal_Error ("check_AVL(4)");
+         end if;
+         if Rh - Lh > 1 or Rh - Lh < -1 then
+            Internal_Error ("check_AVL(5)");
+         end if;
+      end if;
+   end Check_AVL;
+
+   procedure Compute_Height (Tree : in out AVL_Tree; N : AVL_Nid)
+   is
+   begin
+      Tree (N).Height :=
+        Ghdl_I32'Max (Get_Height (Tree, Tree (N).Left),
+                      Get_Height (Tree, Tree (N).Right)) + 1;
+   end Compute_Height;
+
+   procedure Simple_Rotate_Right (Tree : in out AVL_Tree; N : AVL_Nid)
+   is
+      R : AVL_Nid;
+      V : AVL_Value;
+   begin
+      --  Rotate nodes.
+      R := Tree (N).Right;
+      Tree (N).Right := Tree (R).Right;
+      Tree (R).Right := Tree (R).Left;
+      Tree (R).Left := Tree (N).Left;
+      Tree (N).Left := R;
+      --  Swap vals.
+      V := Tree (N).Val;
+      Tree (N).Val := Tree (R).Val;
+      Tree (R).Val := V;
+      --  Adjust bal.
+      Compute_Height (Tree, R);
+      Compute_Height (Tree, N);
+   end Simple_Rotate_Right;
+
+   procedure Simple_Rotate_Left (Tree : in out AVL_Tree; N : AVL_Nid)
+   is
+      L : AVL_Nid;
+      V : AVL_Value;
+   begin
+      L := Tree (N).Left;
+      Tree (N).Left := Tree (L).Left;
+      Tree (L).Left := Tree (L).Right;
+      Tree (L).Right := Tree (N).Right;
+      Tree (N).Right := L;
+      V := Tree (N).Val;
+      Tree (N).Val := Tree (L).Val;
+      Tree (L).Val := V;
+      Compute_Height (Tree, L);
+      Compute_Height (Tree, N);
+   end Simple_Rotate_Left;
+
+   procedure Double_Rotate_Right (Tree : in out AVL_Tree; N : AVL_Nid)
+   is
+      R : AVL_Nid;
+   begin
+      R := Tree (N).Right;
+      Simple_Rotate_Left (Tree, R);
+      Simple_Rotate_Right (Tree, N);
+   end Double_Rotate_Right;
+
+   procedure Double_Rotate_Left (Tree : in out AVL_Tree; N : AVL_Nid)
+   is
+      L : AVL_Nid;
+   begin
+      L := Tree (N).Left;
+      Simple_Rotate_Right (Tree, L);
+      Simple_Rotate_Left (Tree, N);
+   end Double_Rotate_Left;
+
+   procedure Insert (Tree : in out AVL_Tree;
+                    Cmp : AVL_Compare_Func;
+                    Val : AVL_Nid;
+                    N : AVL_Nid;
+                    Res : out AVL_Nid)
+   is
+      Diff : Integer;
+      Op_Ch, Ch : AVL_Nid;
+   begin
+      Diff := Cmp.all (Tree (Val).Val, Tree (N).Val);
+      if Diff = 0 then
+         Res := N;
+         return;
+      end if;
+      if Diff < 0 then
+         if Tree (N).Left = AVL_Nil then
+            Tree (N).Left := Val;
+            Compute_Height (Tree, N);
+            --  N is balanced.
+            Res := Val;
+         else
+            Ch := Tree (N).Left;
+            Op_Ch := Tree (N).Right;
+            Insert (Tree, Cmp, Val, Ch, Res);
+            if Res /= Val then
+               return;
+            end if;
+            if Get_Height (Tree, Ch) - Get_Height (Tree, Op_Ch) = 2 then
+               --  Rotate
+               if Get_Height (Tree, Tree (Ch).Left)
+                 > Get_Height (Tree, Tree (Ch).Right)
+               then
+                  Simple_Rotate_Left (Tree, N);
+               else
+                  Double_Rotate_Left (Tree, N);
+               end if;
+            else
+               Compute_Height (Tree, N);
+            end if;
+         end if;
+      else
+         if Tree (N).Right = AVL_Nil then
+            Tree (N).Right := Val;
+            Compute_Height (Tree, N);
+            --  N is balanced.
+            Res := Val;
+         else
+            Ch := Tree (N).Right;
+            Op_Ch := Tree (N).Left;
+            Insert (Tree, Cmp, Val, Ch, Res);
+            if Res /= Val then
+               return;
+            end if;
+            if Get_Height (Tree, Ch) - Get_Height (Tree, Op_Ch) = 2 then
+               --  Rotate
+               if Get_Height (Tree, Tree (Ch).Right)
+                 > Get_Height (Tree, Tree (Ch).Left)
+               then
+                  Simple_Rotate_Right (Tree, N);
+               else
+                  Double_Rotate_Right (Tree, N);
+               end if;
+            else
+               Compute_Height (Tree, N);
+            end if;
+         end if;
+      end if;
+   end Insert;
+
+   procedure Get_Node (Tree : in out AVL_Tree;
+                       Cmp : AVL_Compare_Func;
+                       N : AVL_Nid;
+                       Res : out AVL_Nid)
+   is
+   begin
+      if Tree'First /= AVL_Root or N /= Tree'Last then
+         Internal_Error ("avls.get_node");
+      end if;
+      Insert (Tree, Cmp, N, AVL_Root, Res);
+      Check_AVL (Tree, AVL_Root);
+   end Get_Node;
+
+   function Find_Node (Tree : AVL_Tree;
+                       Cmp : AVL_Compare_Func;
+                       Val : AVL_Value) return AVL_Nid
+   is
+      N : AVL_Nid;
+      Diff : Integer;
+   begin
+      N := AVL_Root;
+      if Tree'Last < AVL_Root then
+         return AVL_Nil;
+      end if;
+      loop
+         Diff := Cmp.all (Val, Tree (N).Val);
+         if Diff = 0 then
+            return N;
+         end if;
+         if Diff < 0 then
+            N := Tree (N).Left;
+         else
+            N := Tree (N).Right;
+         end if;
+         if N = AVL_Nil then
+            return AVL_Nil;
+         end if;
+      end loop;
+   end Find_Node;
+end Grt.Avls;