1--  Copyright 1994 Grady Booch
2--  Copyright 1994-1997 David Weller
3--  Copyright 1998-2014 Simon Wright <simon@pushface.org>
4
5--  This package is free software; you can redistribute it and/or
6--  modify it under terms of the GNU General Public License as
7--  published by the Free Software Foundation; either version 2, or
8--  (at your option) any later version. This package is distributed in
9--  the hope that it will be useful, but WITHOUT ANY WARRANTY; without
10--  even the implied warranty of MERCHANTABILITY or FITNESS FOR A
11--  PARTICULAR PURPOSE. See the GNU General Public License for more
12--  details. You should have received a copy of the GNU General Public
13--  License distributed with this package; see file COPYING.  If not,
14--  write to the Free Software Foundation, 59 Temple Place - Suite
15--  330, Boston, MA 02111-1307, USA.
16
17--  As a special exception, if other files instantiate generics from
18--  this unit, or you link this unit with other files to produce an
19--  executable, this unit does not by itself cause the resulting
20--  executable to be covered by the GNU General Public License.  This
21--  exception does not however invalidate any other reasons why the
22--  executable file might be covered by the GNU Public License.
23
24with System;
25
26package body BC.Containers.Stacks is
27
28   procedure Process_Top (S : in out Abstract_Stack'Class) is
29   begin
30      Process (Item_At (S, 1).all);
31   end Process_Top;
32
33   function Are_Equal (Left, Right : Abstract_Stack'Class) return Boolean is
34   begin
35      if System."=" (Left'Address, Right'Address) then
36         return True;
37      end if;
38      if Depth (Left) /= Depth (Right) then
39         return False;
40      end if;
41      declare
42         Left_Iter : Iterator'Class := New_Iterator (Left);
43         Right_Iter : Iterator'Class := New_Iterator (Right);
44      begin
45         while not Is_Done (Left_Iter) and then
46           not Is_Done (Right_Iter) loop
47            if Current_Item (Left_Iter) /= Current_Item (Right_Iter) then
48               return False;
49            end if;
50            Next (Left_Iter);
51            Next (Right_Iter);
52         end loop;
53         return True;
54      end;
55   end Are_Equal;
56
57   procedure Copy (From : Abstract_Stack'Class;
58                   To : in out Abstract_Stack'Class) is
59      Iter : Iterator'Class := New_Iterator (From);
60   begin
61      if System."/=" (From'Address, To'Address) then
62         Clear (To);
63         Reset (Iter);
64         while not Is_Done (Iter) loop
65            Add (To, Current_Item (Iter));
66            Next (Iter);
67         end loop;
68      end if;
69   end Copy;
70
71   function Available (S : in Abstract_Stack) return Natural is
72      pragma Warnings (Off, S);
73   begin
74      return Natural'Last;
75   end Available;
76
77   --  Subprograms to be overridden
78
79   procedure Add (S : in out Abstract_Stack; Elem : Item) is
80   begin
81      raise Should_Have_Been_Overridden;
82   end Add;
83
84   procedure Remove (S : in out Abstract_Stack; From : Positive) is
85   begin
86      raise Should_Have_Been_Overridden;
87   end Remove;
88
89   --  Iterators
90
91   procedure Reset (It : in out Stack_Iterator) is
92      S : Abstract_Stack'Class
93        renames Abstract_Stack'Class (It.For_The_Container.all);
94   begin
95      if Depth (S) = 0 then
96         It.Index := 0;
97      else
98         It.Index := 1;
99      end if;
100   end Reset;
101
102   procedure Next (It : in out Stack_Iterator) is
103   begin
104      It.Index := It.Index + 1;
105   end Next;
106
107   function Is_Done (It : Stack_Iterator) return Boolean is
108      S : Abstract_Stack'Class
109     renames Abstract_Stack'Class (It.For_The_Container.all);
110   begin
111      return It.Index = 0 or else It.Index > Depth (S);
112   end Is_Done;
113
114   function Current_Item (It : Stack_Iterator) return Item is
115   begin
116      if Is_Done (It) then
117         raise BC.Not_Found;
118      end if;
119      return Item_At (It.For_The_Container.all, It.Index).all;
120   end Current_Item;
121
122   function Current_Item_Ptr (It : Stack_Iterator) return Item_Ptr is
123   begin
124      if Is_Done (It) then
125         raise BC.Not_Found;
126      end if;
127      return Item_At (It.For_The_Container.all, It.Index);
128   end Current_Item_Ptr;
129
130   procedure Delete_Item_At (It : in out Stack_Iterator) is
131      S : Abstract_Stack'Class
132        renames Abstract_Stack'Class (It.For_The_Container.all);
133   begin
134      if Is_Done (It) then
135         raise BC.Not_Found;
136      end if;
137      Remove (S, It.Index);
138   end Delete_Item_At;
139
140end BC.Containers.Stacks;
141