File : bc-containers-maps.adb


-- Copyright (C) 1994-1999 Grady Booch and Simon Wright.
-- All Rights Reserved.
--
--      This program is free software; you can redistribute it
--      and/or modify it under the terms of the Ada Community
--      License which comes with this Library.
--
--      This program 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 Ada Community License for more details.
--      You should have received a copy of the Ada Community
--      License with this library, in the file named "Ada Community
--      License" or "ACL". If not, contact the author of this library
--      for a copy.
--

-- $Id: bc-containers-maps.adb,v 1.2.2.1 1999/12/05 18:44:49 simon Exp $

with BC.Support.Exceptions;
with System.Address_To_Access_Conversions;

package body BC.Containers.Maps is

  package BSE renames BC.Support.Exceptions;
  procedure Assert
  is new BSE.Assert ("BC.Containers.Maps");

  function Are_Equal (L, R : Map'Class) return Boolean is
    It : Iterator := New_Iterator (L);
  begin
    -- XXX left out the optimisation which checks whether L, R are
    -- identical.
    if Cardinality (L) /= Cardinality (R) then
      return False;
    end if;
    while not Is_Done (It) loop
      if not Exists (R, Current_Item (It)) then
        return False;
      end if;
      -- XXX what about the Value?
      Next (It);
    end loop;
    return True;
  end Are_Equal;

  procedure Initialize (It : in out Map_Iterator) is
  begin
    It.Index := 0;
    if Cardinality (It.M.all) = 0 then
      It.Bucket_Index := 0;
    else
      It.Bucket_Index := 1;
      while It.Bucket_Index <= Number_Of_Buckets (It.M.all) loop
        if Length (It.M.all, It.Bucket_Index) > 0 then
          It.Index := 1;
          exit;
        end if;
        It.Bucket_Index := It.Bucket_Index + 1;
      end loop;
    end if;
  end Initialize;

  procedure Reset (It : in out Map_Iterator) is
  begin
    It.Index := 0;
    if Cardinality (It.M.all) = 0 then
      It.Bucket_Index := 0;
    else
      It.Bucket_Index := 1;
      while It.Bucket_Index <= Number_Of_Buckets (It.M.all) loop
        if Length (It.M.all, It.Bucket_Index) > 0 then
          It.Index := 1;
          exit;
        end if;
        It.Bucket_Index := It.Bucket_Index + 1;
      end loop;
    end if;
  end Reset;

  procedure Next (It : in out Map_Iterator) is
  begin
    if It.Bucket_Index <= Number_Of_Buckets (It.M.all) then
      if It.Index < Length (It.M.all, It.Bucket_Index) then
        It.Index := It.Index + 1;
      else
        It.Bucket_Index := It.Bucket_Index + 1;
        It.Index := 0;
        while It.Bucket_Index <= Number_Of_Buckets (It.M.all) loop
          if Length (It.M.all, It.Bucket_Index) > 0 then
            It.Index := 1;
            exit;
          end if;
          It.Bucket_Index := It.Bucket_Index + 1;
        end loop;
      end if;
    end if;
  end Next;

  function Is_Done (It : Map_Iterator) return Boolean is
  begin
    if It.Bucket_Index = 0
       or else It.Bucket_Index > Number_Of_Buckets (It.M.all) then
      return True;
    end if;
    if It.Index <= Length (It.M.all, It.Bucket_Index) then
      return False;
    end if;
    declare
      package Conversions is new System.Address_To_Access_Conversions
         (Map_Iterator'Class);
      P : Conversions.Object_Pointer := Conversions.To_Pointer (It'Address);
    begin
      P.Bucket_Index := P.Bucket_Index + 1;
      P.Index := 0;
      while P.Bucket_Index <= Number_Of_Buckets (P.M.all) loop
        if Length (P.M.all, P.Bucket_Index) > 0 then
          P.Index := 1;
          return False;
        end if;
        P.Bucket_Index := P.Bucket_Index + 1;
      end loop;
    end;
    return True;
  end Is_Done;

  function Current_Item (It : Map_Iterator) return Item is
  begin
    if Is_Done (It) then
      raise BC.Not_Found;
    end if;
    return Item_At (It.M.all, It.Bucket_Index, It.Index).all;
  end Current_Item;

  function Current_Item (It : Map_Iterator) return Item_Ptr is
    -- XXX this should probably not be permitted!
  begin
    if Is_Done (It) then
      raise BC.Not_Found;
    end if;
    return Item_At (It.M.all, It.Bucket_Index, It.Index);
  end Current_Item;

  procedure Delete_Item_At (It : Map_Iterator) is
  begin
    if Is_Done (It) then
      raise BC.Not_Found;
    end if;
    raise BC.Not_Yet_Implemented;
  end Delete_Item_At;

  function Current_Value (It : Iterator) return Value is
    Map_Iter : Map_Iterator
       renames Map_Iterator (SP.Value (SP.Pointer (It)).all);
  begin
    if Is_Done (Map_Iter) then
      raise BC.Not_Found;
    end if;
    return Value_At (Map_Iter.M.all,
                     Map_Iter.Bucket_Index,
                     Map_Iter.Index).all;
  end Current_Value;

  procedure Visit (Over_The_Container : Map'Class) is
    Iter : Iterator := New_Iterator (Over_The_Container);
    Map_Iter : Map_Iterator
       renames Map_Iterator (SP.Value (SP.Pointer (Iter)).all);
    Status : Boolean;
  begin
    while not Is_Done (Iter) loop
      Apply (Item_At (Over_The_Container,
                      Map_Iter.Bucket_Index,
                      Map_Iter.Index).all,
             Value_At (Over_The_Container,
                       Map_Iter.Bucket_Index,
                       Map_Iter.Index).all,
             Status);
      exit when not Status;
      Next (Iter);
    end loop;
  end Visit;

  procedure Modify (Over_The_Container : Map'Class) is
    Iter : Iterator := New_Iterator (Over_The_Container);
    Map_Iter : Map_Iterator
       renames Map_Iterator (SP.Value (SP.Pointer (Iter)).all);
    Status : Boolean;
  begin
    while not Is_Done (Iter) loop
      Apply (Item_At (Over_The_Container,
                      Map_Iter.Bucket_Index,
                      Map_Iter.Index).all,
             Value_At (Over_The_Container,
                       Map_Iter.Bucket_Index,
                       Map_Iter.Index).all,
             Status);
      exit when not Status;
      Next (Iter);
    end loop;
  end Modify;

  -- Subprograms to be overridden

  procedure Attach (M : in out Map; I : Item; V : Value) is
  begin
    raise Should_Have_Been_Overridden;
  end Attach;

  function Number_Of_Buckets (M : Map) return Natural is
  begin
    raise Should_Have_Been_Overridden;
    return 0;
  end Number_Of_Buckets;

  function Length (M : Map; Bucket : Positive) return Natural is
  begin
    raise Should_Have_Been_Overridden;
    return 0;
  end Length;

  function Exists (M : Map; I : Item) return Boolean is
  begin
    raise Should_Have_Been_Overridden;
    return False;
  end Exists;

  function Item_At (M : Map; Bucket, Index : Positive) return Item_Ptr is
  begin
    raise Should_Have_Been_Overridden;
    return null;
  end Item_At;

  function Value_At (M : Map; Bucket, Index : Positive) return Value_Ptr is
  begin
    raise Should_Have_Been_Overridden;
    return null;
  end Value_At;

end BC.Containers.Maps;