Return to generic_lists.adb CVS log

Up to [local] / OpenXM_contrib / PHC / Ada / Math_Lib / Polynomials

Import the second public release of PHCpack.

OKed by Jan Verschelde.

package body Generic_Lists is

-- INTERNAL DATA :

  type Node is record
    The_Item : Item;
    Next     : List;
  end record;

  Free_List : List := null;

-- AUXILIARIES :

  procedure Set_Next ( The_Node : in out Node; To_Next : in List ) is
  begin
    The_Node.Next := To_Next;
  end Set_Next;

  function Next_Of ( The_Node : in Node ) return List is
  begin
    return The_Node.Next;
  end Next_Of;

  procedure Free ( l : in out List ) is

    tmp : List;

  begin
    while l /= null loop
      tmp := l;
      l := Next_Of(l.all);
      Set_Next(tmp.all,Free_List);
      Free_List := tmp;
    end loop;
  end Free;

  function New_Item return List is

    tmp : List;

  begin
    if Free_List = null
     then return new Node;
     else tmp := Free_List;
          Free_List := Next_Of(tmp.all);
          Set_Next(tmp.all,null);
          return tmp;
    end if;
  end New_Item;

-- CONSTRUCTORS :

  procedure Construct ( i : in Item; l : in out List ) is

    tmp : List;

  begin
    tmp := New_Item;
    tmp.The_Item := i;
    tmp.Next := l;
    l := tmp;
  exception
    when Storage_Error => raise Overflow;
  end Construct;

  procedure Append ( first,last : in out List; i : in Item ) is
  begin
    if Is_Null(first)
     then Construct(i,first);
          last := first;
     else declare
            tmp : List;
          begin
            Construct(i,tmp);
            Swap_Tail(last,tmp);
            last := Tail_Of(last);
          end;
    end if;
  end Append;

  procedure Concat ( first,last : in out List; l : in List ) is

    tmp : List := l;

  begin
    while not Is_Null(tmp) loop
      Append(first,last,Head_Of(tmp));
      tmp := Tail_Of(tmp);
    end loop;
  end Concat;

  procedure Set_Head ( l : in out List; i : in Item ) is
  begin
    l.The_Item := i;
  exception
    when Constraint_Error => raise List_Is_Null;
  end Set_Head;

  procedure Swap_Tail ( l1,l2 : in out List ) is

    tmp : List;

  begin
    tmp := l1.Next;
    l1.Next := l2;
    l2 := tmp;
  exception
    when Constraint_Error => raise List_Is_Null;
  end Swap_Tail;

  procedure Copy ( l1 : in List; l2 : in out List ) is

    From_Index : List := l1;
    To_Index   : List;

  begin
    Free(l2);
    if l1 /= null
     then l2 := New_Item;
          l2.The_Item := From_Index.The_Item;
          To_Index := l2;
          From_Index := From_Index.Next;
          while From_Index /= null loop
            To_Index.Next := New_Item;
            To_Index := To_Index.Next;
            To_Index.The_Item := From_Index.The_Item;
            From_Index := From_Index.Next;
          end loop;
    end if;
  exception
    when Storage_Error => raise Overflow;
  end Copy;

-- SELECTORS :

  function Is_Equal ( l1,l2 : List ) return boolean is

    left_index  : List := l1;
    right_index : List := l2;

  begin
    while left_index /= null loop
      if left_index.The_Item /= right_index.The_Item
       then return False;
      end if;
      left_index := left_index.Next;
      right_index := right_index.Next;
    end loop;
    return (right_index = null);
  exception
    when Constraint_Error => return false;
  end Is_Equal;

  function Length_Of ( l : List ) return natural is

    cnt : natural := 0;
    tmp : List := l;

  begin
    while not Is_Null(tmp) loop
      cnt := cnt + 1;
      tmp := Tail_Of(tmp);
    end loop;
    return cnt;
  end Length_Of;
      
  function Is_Null ( l : list ) return boolean is
  begin
    return (l = null);
  end Is_Null;

  function Head_Of ( l : List ) return Item is
  begin
    return l.The_Item;
  exception
    when Constraint_Error => raise List_Is_Null;
  end Head_Of;

  function Tail_Of ( l : List ) return List is
  begin
    return l.Next;
  exception
    when Constraint_Error => raise List_Is_Null;
  end Tail_Of;

-- DESTRUCTOR :

  procedure Clear ( l : in out List ) is
  begin
    Free(l);
  end Clear;

end Generic_Lists;