with Unchecked_Deallocation;
package body List_LPBase is
   procedure Free is new Unchecked_Deallocation (Object_Holder, List_Ptr);
   procedure Free is new Unchecked_Deallocation (List_Ptr, LPList_Type);

procedure Initialize (List: in out LPList_Type) is
   begin -- Initialize
      List     := new List_Ptr;
      List.all := null;
   end Initialize;
   ---------------------------------------------------
function Tail_Of (List: LPList_Type) return LPList_Type is
   Answer: LPList_Type;
   begin -- Tail_Of
      if List.all = null then
          raise List_Underflow;
        else
          Answer := list.all.next'Access;
          return Answer;
      end if;
   end Tail_Of;
   ---------------------------------------------------
procedure Finalize (List: in out LPList_Type) is
   Cur_Ptr, Nxt_Ptr: List_Ptr;
   begin -- Finalize
      Cur_Ptr := List.all;
      while Cur_Ptr /= null loop
         Nxt_Ptr := Cur_Ptr.Next;
         Finalize (Cur_Ptr.Object);
         Free (Cur_Ptr);
         Cur_Ptr := Nxt_Ptr;
      end loop;
      Free (List);
      List := null;
   end Finalize;
   ---------------------------------------------------
function Head_Of (List: LPList_Type) return Object_Type is
   begin -- Head_Of
      if List.all = null then
          raise List_Underflow;
        else
          return List.all.Object;
      end if;
   end Head_Of;
   ---------------------------------------------------
function Empty (List: LPList_Type) return boolean is
   begin -- Empty
      return List.all = null;
   end Empty;
   ---------------------------------------------------
procedure New_Head (Object: in out Object_Type;
                    List  : in     LPList_Type) is
   New_Elem: List_Ptr;
   begin -- New_Head
      New_Elem := new Object_Holder;
      Initialize (New_Elem.Object);
      New_Elem.Next := List.all;
      List.all := New_Elem;
      Swap (New_Elem.Object, Object);
   end New_Head;
   ---------------------------------------------------
procedure Remove_Head (List  : in     LPList_Type;
                       Object: in out Object_Type) is
   Old_One: List_Ptr;
   begin -- Remove_Head
      if List.all = null then
          raise List_Underflow;
        else
          Swap(Object, List.all.Object);
          Old_One := List.all;
          List.all:= Old_One.Next;
          Finalize (Old_One.Object);
          Free (Old_One);
      end if;
   end Remove_Head;
   ---------------------------------------------------
procedure Append (List    : in     LPList_Type;
                  New_Tail: in     LPList_Type) is
   procedure Rec_app (Point: in out List_Ptr) is
      begin -- Rec_app
         if Point = null then
             Point := New_Tail.all;
             New_Tail.all := null;
           else
             Rec_App (Point.Next);
         end if;
      end Rec_app;
      ------------------------------------------------
   begin -- Append
      if New_Tail.all = List.all then
          raise constraint_error;
        elsif New_Tail.all /= null then
          Rec_App (List.all);
      end if;
   end Append;
   ---------------------------------------------------
procedure Append (List    : in     LPList_Type;
                  New_Tail: in out Object_Type) is
   Temp: LPList_Type;
   begin -- Append
      Initialize (Temp);
      New_Head (New_Tail, Temp);
      Append (List, Temp);
      Finalize (Temp);
   end Append;
   ---------------------------------------------------
procedure Process_Head (List   : in     LPList_Type;
                        Process:        In_Place_Process_Type) is
   begin
      if List.all /= null then
          Process (List.all.Object);
        else
          raise List_Underflow;
      end if;
   end Process_Head;
   ---------------------------------------------------
procedure Update_Head (List  : in     LPList_Type;
                       Object: in out Object_Type) is
   begin -- Update_Head
      if List.all /= null then
          Swap(List.all.Object, Object);
        else
          raise List_Underflow;
      end if;
   end Update_Head;
   ----------------------------------------------------
procedure Copy (Source: in     LPList_Type;
                Target: in out LPList_Type) is
   procedure Clone (S, T: in out List_Ptr) is
      begin -- Clone
         if S /= null then
             T := new Object_Holder;
             Initialize (T.Object);
             Copy (S.Object, T.Object);
             T.Next := null;
             --|| T.all := (S.Object, null);
             Clone (S.Next, T.Next);
         end if;
      end Clone;
      -------------------------------------------------
   begin
      if Source.all /= Target.all then
          Finalize (Target);
          Initialize (Target);
          Clone (Source.all, Target.all);
      end if;
   end Copy;
   ----------------------------------------------------
procedure Swap (Source: in out LPList_Type;
                Target: in out LPList_Type) is
   Temp: LPList_Type;
   begin -- Swap
      Initialize (Temp);
      Temp.all   := Target.all;
      Target.all := Source.all;
      Source.all := Temp.all;
      Temp.all := null;
      Finalize (Temp);
   end Swap;
   ----------------------------------------------------
procedure Swap_Tail (Source: in     LPList_Type;
                     Target: in     LPList_Type) is
   Tail_S, Tail_T: List_Ptr;
   begin -- Swap_Tail
      if Source.all = Target.all then
          raise constraint_error;
        else
          if Target.all = null then
              Tail_T := null;
            else
              Tail_T := Target.all.Next;
              Target.all.Next := null;
          end if;
          if Source.all = null then
              Tail_S := null;
              Source.all := Tail_T;
            else
              Tail_S := Source.all.Next;
              Source.all.Next := Tail_T;
          end if;
          if Target.all = null then
              Target.all := Tail_S;
            else
              Target.all.Next := Tail_S;
          end if;
      end if;
   end Swap_Tail;
   ----------------------------------------------------

end List_LPBase;