-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
--    The primary authors of ayacc were David Taback and Deepak Tolani.
--    Enhancements were made by Ronald J. Schmalz.
--
--    Send requests for ayacc information to ayacc-info@ics.uci.edu
--    Send bug reports for ayacc to ayacc-bugs@ics.uci.edu
--
-- Redistribution and use in source and binary forms are permitted
-- provided that the above copyright notice and this paragraph are
-- duplicated in all such forms and that any documentation,
-- advertising materials, and other materials related to such
-- distribution and use acknowledge that the software was developed
-- by the University of California, Irvine.  The name of the
-- University may not be used to endorse or promote products derived
-- from this software without specific prior written permission.
-- THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
-- IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
-- WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.

-- Module       : set_pack_body.ada
-- Component of : ayacc
-- Version      : 1.2
-- Date         : 11/21/86  12:35:14
-- SCCS File    : disk21~/rschm/hasee/sccs/ayacc/sccs/sxset_pack_body.ada

-- $Header: set_pack_body.a,v 0.1 86/04/01 15:11:59 ada Exp $
-- $Log:        set_pack_body.a,v $
-- Revision 0.1  86/04/01  15:11:59  ada
--  This version fixes some minor bugs with empty grammars
--  and $$ expansion. It also uses vads5.1b enhancements
--  such as pragma inline.
--
--
-- Revision 0.0  86/02/19  18:41:30  ada
--
-- These files comprise the initial version of Ayacc
-- designed and implemented by David Taback and Deepak Tolani.
-- Ayacc has been compiled and tested under the Verdix Ada compiler
-- version 4.06 on a vax 11/750 running Unix 4.2BSD.
--

package body Set_Pack is

   -- SCCS_ID : constant String := "@(#) set_pack_body.ada, Version 1.2";
   -- Rcs_ID : constant String := "$Header: set_pack_body.a,v 0.1 86/04/01 15:11:59 ada Exp $";

   type Cell is record
      Value : Universe;
      Next  : Link;
   end record;

   Extras : Link; -- For garbage collection.

   function Get_Node return Link;
--RJS    pragma inline(get_node);

   function Get_Node return Link is
      Temp_Link : Link;
   begin
      if Extras = null then
         return new Cell;
      else
         Temp_Link      := Extras;
         Extras         := Extras.Next;
         Temp_Link.Next := null;
         return Temp_Link;
      end if;
   end Get_Node;

   procedure Make_Null (Set_1 : in out Set) is
      Temp_Link : Link;
   begin

      if Set_1.Head = null then
         Set_1.Size := 0;
         return;
      end if;

      -- Find tail of set_1 --

      Temp_Link := Set_1.Head;
      while Temp_Link.Next /= null loop
         Temp_Link := Temp_Link.Next;
      end loop;

      -- Add set_1 elements to the extras stack --

      Temp_Link.Next := Extras;
      Extras         := Set_1.Head;
      Set_1          := (Size => 0, Head => null);

   end Make_Null;

   procedure Assign (Object : in out Set; Value : in Set) is
      Temp_1, Temp_2 : Link;
   begin

      if Object = Value then
         return;
      else
         Make_Null (Object);
      end if;

      if Value.Head = null then
         return;
      end if;

      Object.Head       := Get_Node;
      Object.Head.Value := Value.Head.Value;
      Object.Head.Next  := null;
      Temp_1            := Object.Head;
      Temp_2            := Value.Head.Next;

      while Temp_2 /= null loop
         Temp_1.Next     := Get_Node;
         Temp_1.Next.all := (Value => Temp_2.Value, Next => null);
         Temp_1          := Temp_1.Next;
         Temp_2          := Temp_2.Next;
      end loop;
      Temp_1.Next := null;
      Object.Size := Value.Size;

   end Assign;

   procedure Insert (Element : in Universe; Into : in out Set) is
      Temp_Link   : Link;
      Temp_Link_2 : Link;
   begin

      if Into.Head = null or else Element < Into.Head.Value then
         Temp_Link     := Get_Node;
         Temp_Link.all := (Value => Element, Next => Into.Head);
         Into.Head     := Temp_Link;
         Into.Size     := Into.Size + 1;
         return;
      end if;

      if Into.Head.Value = Element then
         return;
      end if;

      Temp_Link := Into.Head;
      while Temp_Link.Next /= null loop
         if Element = Temp_Link.Next.Value then -- Already in the list.
            return;
         elsif Element < Temp_Link.Next.Value then
            exit;  -- Found place to insert.
         else
            Temp_Link := Temp_Link.Next;
         end if;
      end loop;

      --  insert element  --

      Temp_Link_2       := Get_Node;
      Temp_Link_2.Next  := Temp_Link.Next;
      Temp_Link_2.Value := Element;
      Temp_Link.Next    := Temp_Link_2;
      Into.Size         := Into.Size + 1;

   end Insert;

   procedure Insert (Set_1 : in Set; Into : in out Set) is
      Temp, Trav1, Trav2 : Link;

   begin
      if Set_1.Head = null then
         return;
      elsif Set_1.Head = Into.Head then
         return;
      elsif Into.Head = null then
         Assign (Into, Set_1);
         return;
      end if;

      if Set_1.Head.Value < Into.Head.Value then
         Temp          := Into.Head;
         Into.Head     := Get_Node;
         Into.Head.all := (Set_1.Head.Value, Temp);
         Trav1         := Set_1.Head.Next;
         Into.Size     := Into.Size + 1;
      elsif Set_1.Head.Value = Into.Head.Value then
         Trav1 := Set_1.Head.Next;
      else
         Trav1 := Set_1.Head;
      end if;

      Trav2 := Into.Head;

      while Trav1 /= null loop

         while Trav2.Next /= null and then Trav2.Next.Value < Trav1.Value loop
            Trav2 := Trav2.Next;
         end loop;

         if Trav2.Next = null then
            while Trav1 /= null loop
               Trav2.Next     := Get_Node;
               Trav2.Next.all := (Trav1.Value, null);
               Trav1          := Trav1.Next;
               Trav2          := Trav2.Next;
               Into.Size      := Into.Size + 1;
            end loop;
            return;
         end if;

         if Trav2.Next.Value /= Trav1.Value then
            Temp           := Trav2.Next;
            Trav2.Next     := Get_Node;
            Trav2.Next.all := (Trav1.Value, Temp);
            Trav2          := Trav2.Next;
            Into.Size      := Into.Size + 1;
         end if;

         Trav1 := Trav1.Next;
      end loop;
   end Insert;

   procedure Delete (Element : in Universe; From : in out Set) is
      Temp_Link : Link;
      T         : Link;
   begin
      if From.Head = null then
         return;
      elsif Element < From.Head.Value then
         return;
      elsif Element = From.Head.Value then
         Temp_Link      := From.Head;
         From.Head      := From.Head.Next;
         From.Size      := From.Size - 1;
         Temp_Link.Next := Extras;
         Extras         := Temp_Link;
         return;
      end if;

      Temp_Link := From.Head;

      while Temp_Link.Next /= null and then Temp_Link.Next.Value < Element loop
         Temp_Link := Temp_Link.Next;
      end loop;

      if Temp_Link.Next /= null and then Temp_Link.Next.Value = Element then
         T              := Temp_Link.Next;
         Temp_Link.Next := Temp_Link.Next.Next;
         T.Next         := Extras;
         Extras         := T;
         From.Size      := From.Size - 1;
      end if;

   end Delete;

   procedure Fassign (Object : in out Set; Value : in out Set) is
   begin
      -- Free the contents of OBJECT first.
      Object := Value;
      Value  := (Head => null, Size => 0);
   end Fassign;

   function Is_Member (Element : Universe; Of_Set : Set) return Boolean is
      Temp_Link : Link;
   begin

      Temp_Link := Of_Set.Head;
      while Temp_Link /= null and then Temp_Link.Value < Element loop
         Temp_Link := Temp_Link.Next;
      end loop;

      return Temp_Link /= null and then Temp_Link.Value = Element;

   end Is_Member;

   function Is_Empty (Set_1 : Set) return Boolean is
   begin
      return Set_1.Head = null;
   end Is_Empty;

   function Size_Of (Set_1 : Set) return Natural is
   begin
      return Set_1.Size;
   end Size_Of;

   function "=" (Set_1 : Set; Set_2 : Set) return Boolean is
      Link_1, Link_2 : Link;
   begin

      if Set_1.Size /= Set_2.Size then
         return False;
      end if;

      Link_1 := Set_1.Head;
      Link_2 := Set_2.Head;
      while Link_1 /= null and then Link_2 /= null loop
         if Link_1.Value /= Link_2.Value then
            exit;
         end if;
         Link_1 := Link_1.Next;
         Link_2 := Link_2.Next;
      end loop;

      return Link_1 = Link_2;  -- True if both equal to null

   end "=";

   procedure Initialize (Iterator : in out Set_Iterator; Using : in Set) is
   begin
      Iterator := Set_Iterator (Using.Head);
   end Initialize;

   function More (Iterator : Set_Iterator) return Boolean is
   begin
      return Iterator /= null;
   end More;

   procedure Next (Iterator : in out Set_Iterator; Element : out Universe) is
   begin
      Element  := Iterator.Value;
      Iterator := Set_Iterator (Iterator.Next);
   exception
      when Constraint_Error =>
         raise No_More_Elements;
   end Next;

end Set_Pack;
