with Unchecked_Deallocation;
package body List_Polymorphic_Cntl is
   procedure Free is new Unchecked_Deallocation (Place_Holder'Class, Holder_Class_Ptr);
   procedure Free is new Unchecked_Deallocation (Holder_Class_Ptr, List_Anchor);
   procedure Recycle (Point: in out Holder_Class_Ptr) renames Free;

procedure Initialize (Object: in out Place_Holder) is
   begin -- Initialize
      null;
   end Initialize;
   -----------------------------------------------------
procedure Finalize (Object: in out Place_Holder) is
   begin -- Finalize
      null;
   end Finalize;
   -----------------------------------------------------
procedure Adjust (Object: in out Place_Holder) is
   begin -- Adjust
      null;
   end Adjust;
   -----------------------------------------------------

procedure Initialize (List: in out List_Type) is
   begin -- Initialize
      List.Actual:= new Holder_Class_Ptr;
      List.Base  := true;
   end Initialize;
   ---------------------------------------------------
function Tail_Of (List: List_Type) return List_Type is
   Answer: List_Type;
   begin -- Tail_Of
      if List.Actual = null then
          raise List_Underflow;
        else
          Answer.Actual:= list.Actual.all.next'Access;
          Answer.Base  := false;
          return Answer;
      end if;
   end Tail_Of;
   ---------------------------------------------------
procedure Finalize (List: in out List_Type) is
   Cur_Ptr, Nxt_Ptr: Holder_Class_Ptr;
   begin -- Finalize
   if List.Base then
      Cur_Ptr:= List.Actual.all;
      while Cur_Ptr /= null loop
         Nxt_Ptr:= Cur_Ptr.Next;
         Free (Cur_Ptr);
         Cur_Ptr:= Nxt_Ptr;
      end loop;
      Free (List.Actual);
   end if;
   end Finalize;
   ---------------------------------------------------
function Empty_List return List_Type is
   Answer: List_Type;
   begin -- Empty_List
      return Answer;
   end Empty_List;
   ---------------------------------------------------
function g_Head_Of (List: List_Type) return Extended_Type is
   begin -- g_Head_Of
      if List.Actual.all = null then
          raise List_Underflow;
        else
          return Extended_Type(List.Actual.all.all);
      end if;
   end g_Head_Of;
   ---------------------------------------------------
function Head_Of (List: List_Type) return Holder_Class_Ptr is
   begin -- Head_Of
      if List.Actual.all = null then
          raise List_Underflow;
        else
          declare
            Answer: Holder_Class_Ptr
                    := new Place_Holder'Class'(List.Actual.all.all);
          begin
            return Answer;
          end;
      end if;
   end Head_Of;
   ---------------------------------------------------
function Empty (List: List_Type) return boolean is
   begin -- Empty
      return List.Actual.all = null;
   end Empty;
   ---------------------------------------------------
procedure New_Head (Object: in     Place_Holder'Class;
                    List  : in     List_Type) is
   New_Elem: Holder_Class_Ptr;
   begin -- New_Head
      New_Elem:= new Place_Holder'Class'(Object);
      New_Elem.Next  := List.Actual.all;
      List.Actual.all:= New_Elem;
   end New_Head;
   ---------------------------------------------------
procedure g_Remove_Head (List  : in     List_Type;
                         Object: in out Extended_Type) is
   Old_One: Holder_Class_Ptr;
   begin -- g_Remove_Head
      Remove_Head (List, Old_One);
      Object := Extended_Type(Old_One.all);
   end g_Remove_Head;
   ---------------------------------------------------
procedure Remove_Head (List  : in     List_Type;
                       Object: in out Holder_Class_Ptr) is
   begin -- Remove_Head
      if List.Actual.all = null then
          raise List_Underflow;
        else
          Free (Object);
          Object:= List.Actual.all;
          List.Actual.all:= Object.Next;
      end if;
   end Remove_Head;
   ---------------------------------------------------
procedure Append (List    : in     List_Type;
                  New_Tail: in out List_Type) is
   procedure Rec_app (Point: in out Holder_Class_Ptr) is
      begin -- Rec_app
         if Point = null then
             Point:= New_Tail.Actual.all;
             New_Tail.Actual.all:= null;
           else
             Rec_App (Point.Next);
         end if;
      end Rec_app;
      ------------------------------------------------
   begin -- Append
      if New_Tail.Actual.all = List.Actual.all then
          raise constraint_error;
        elsif New_Tail.Actual.all /= null then
          Rec_App (List.Actual.all);
      end if;
   end Append;
   ---------------------------------------------------
procedure Append (List    : in     List_Type;
                  New_Tail: in     Place_Holder'Class) is
   Temp: List_Type;
   begin -- Append
      New_Head (New_Tail, Temp);
      Append (List, Temp);
   end Append;
   ---------------------------------------------------
procedure Update_Head (List  : in     List_Type;
                       Object: in     Place_Holder'Class) is
   Holder_Ptr: Holder_Class_Ptr;
   begin -- Update_Head
      if List.Actual.all /= null then
          Remove_Head (List, Holder_Ptr);
          Free (Holder_Ptr);
          New_Head (Object, List);
        else
          raise List_Underflow;
      end if;
   end Update_Head;
   ----------------------------------------------------
procedure Adjust (List: in out List_Type) is
   Original: Holder_Class_Ptr;
   procedure Clone (Source, Target: in out Holder_Class_Ptr) is
      begin -- Clone
         if Source /= null then
             Target:= new Place_Holder'Class'(Source.all);
             --Initialize (Target.all);
             --Copy (Source.all, Target.all);
             Target.all := Source.all;
             Target.Next:= null;
             Clone (Source.Next, Target.Next);
         end if;
      end Clone;
      -------------------------------------------------
   begin
      Original:= List.Actual.all;
      List.Actual.all:= null;
      Clone (Original, List.Actual.all);
   end Adjust;
   ----------------------------------------------------
procedure Swap (Source: in out List_Type;
                Target: in out List_Type) is
   Temp: Holder_Class_Ptr;
   begin -- Swap
      Temp             := Target.Actual.all;
      Target.Actual.all:= Source.Actual.all;
      Source.Actual.all:= Temp;
   end Swap;
   ----------------------------------------------------
procedure Swap_Tail (Source: in     List_Type;
                     Target: in     List_Type) is
   Tail_S, Tail_T: Holder_Class_Ptr;
   begin -- Swap_Tail
      if Source.Actual.all = Target.Actual.all then
          raise constraint_error;
        else
          if Target.Actual.all = null then
              Tail_T:= null;
            else
              Tail_T                := Target.Actual.all.Next;
              Target.Actual.all.Next:= null;
          end if;
          if Source.Actual.all = null then
              Tail_S           := null;
              Source.Actual.all:= Tail_T;
            else
              Tail_S                := Source.Actual.all.Next;
              Source.Actual.all.Next:= Tail_T;
          end if;
          if Target.Actual.all = null then
              Target.Actual.all:= Tail_S;
            else
              Target.Actual.all.Next:= Tail_S;
          end if;
      end if;
   end Swap_Tail;
   ----------------------------------------------------

end List_Polymorphic_Cntl;