Lists_Generic.adb

WITH Unchecked_Deallocation;
PACKAGE BODY Lists_Generic IS

  PROCEDURE Dispose IS
    NEW Unchecked_Deallocation(Object => Node, Name => Position);

  FUNCTION Allocate (X: ElementType; P: Position) RETURN Position IS
    Result: Position;
  BEGIN
    Result := NEW Node'(Info => X, Link => P);
    RETURN Result;
  EXCEPTION
    WHEN Storage_Error =>
      RAISE OutOfSpace;
  END Allocate;

  PROCEDURE Deallocate (P: IN OUT Position) IS
  BEGIN
    Dispose (X => P);
  END Deallocate;

  PROCEDURE Initialize(L: IN OUT List) IS
    Previous: Position;
    Current : Position;
  BEGIN
    IF L.Head /= NULL THEN
      Current := L.Head;
      WHILE Current /= NULL LOOP
    Previous := Current;
    Current := Current.Link;
    Deallocate(Previous);
      END LOOP;
      L := (Head => NULL, Tail => NULL);
    END IF;
  END Initialize;

  PROCEDURE AddToFront(L: IN OUT List; X: ElementType) IS
  BEGIN
    L.Head := Allocate(X, L.Head);
    IF L.Tail = NULL THEN
      L.Tail := L.Head;
    END IF;
  END AddToFront;

  PROCEDURE AddToRear (L: IN OUT List; X: ElementType) IS
    P: Position;
  BEGIN
    P := Allocate(X, NULL);
    IF L.Head = NULL THEN
      L.Head := P;
    ELSE
      L.Tail.Link := P;
    END IF;
    L.Tail := P;
  END AddToRear;

  FUNCTION IsEmpty (L: List) RETURN Boolean IS
  BEGIN
    RETURN L.Head = NULL;
  END IsEmpty;

  FUNCTION IsFirst (L: List; P: Position) RETURN Boolean IS
  BEGIN
    RETURN (L.Head /= NULL) AND (P = L.Head);
  END IsFirst;

  FUNCTION IsLast (L: List; P: Position) RETURN Boolean IS
  BEGIN
    RETURN (L.Tail /= NULL) AND (P = L.Tail);
  END IsLast;

  FUNCTION IsPastEnd (L: List; P: Position) RETURN Boolean IS
  BEGIN
    RETURN P = NULL;
  END IsPastEnd;

  FUNCTION IsPastBegin (L: List; P: Position) RETURN Boolean IS
  BEGIN
    RETURN P = NULL;
  END IsPastBegin;

  FUNCTION First (L: List) RETURN Position IS
  BEGIN
    RETURN L.Head;
  END First;

  FUNCTION  Last (L: List) RETURN Position IS
  BEGIN
    RETURN L.Tail;
  END Last;

  FUNCTION Retrieve (L: IN List; P: IN Position) RETURN ElementType IS
  BEGIN
    IF IsEmpty(L) THEN
      RAISE EmptyList;
    ELSIF IsPastBegin(L, P) THEN
      RAISE PastBegin;
    ELSIF IsPastEnd(L, P) THEN
      RAISE PastEnd;
    ELSE
      RETURN P.Info;
    END IF;
  END Retrieve;

  PROCEDURE GoAhead (L: List; P: IN OUT Position) IS
  BEGIN
    IF IsEmpty(L) THEN
      RAISE EmptyList;
    ELSIF IsPastEnd(L, P) THEN
      RAISE PastEnd;
    ELSE
      P := P.Link;
    END IF;
  END GoAhead;

  PROCEDURE GoBack (L: List; P: IN OUT Position) IS
    Current: Position;
  BEGIN
    IF IsEmpty(L) THEN
      RAISE EmptyList;
    ELSIF IsPastBegin(L, P) THEN
      RAISE PastBegin;
    ELSIF IsFirst(L, P) THEN
      P := NULL;
    ELSE                    -- see whether P is in the list
      Current := L.Head;
      WHILE (Current /= NULL) AND THEN (Current.Link /= P) LOOP
    Current := Current.Link;
      END LOOP;

      IF Current = NULL THEN -- P was not in the list
        RAISE PastEnd;
      ELSE
        P := Current;        -- return predecessor pointer
      END IF;
    END IF;
  END GoBack;

  PROCEDURE Delete    (L: IN OUT List; P: Position) IS
    Previous: Position;
    Current : Position;
  BEGIN
    Current := P;
    IF IsEmpty(L) THEN
      RAISE EmptyList;
    ELSIF IsPastBegin(L, Current) THEN
      RAISE PastBegin;
    ELSIF IsFirst(L, Current) THEN  -- must adjust list header
      L.Head := Current.Link;
      IF L.Head = NULL THEN         -- deleted the only node
        L.Tail := NULL;
      END IF;
    ELSE                            -- "normal" situation
      Previous := Current;
      GoBack(L, Previous);
      Previous.Link := Current.Link;
      IF IsLast(L, Current) THEN     -- deleted the last node
        L.Tail := Previous;
      END IF;
    END IF;
    Deallocate(Current);
  END Delete;

  PROCEDURE Insert    (L: IN OUT List; X: ElementType; P: Position) IS
  BEGIN
    IF P = NULL THEN
      AddToRear(L, X);
    ELSE
      P.Link := Allocate(X, P.Link);
    END IF;
  END Insert;

  PROCEDURE Replace   (L: IN OUT List; X: ElementType; P: Position) IS
  BEGIN
    IF P = NULL THEN
      RAISE PastEnd;
    ELSE
      P.Info := X;
    END IF;
  END Replace;

  PROCEDURE Copy (To: IN OUT List; From: IN List) IS
    Current: Position;
  BEGIN
    Initialize(To);
    Current := First(From);
    WHILE NOT IsPastEnd(From, Current) LOOP
      AddToRear(To, Retrieve(From, Current));
      GoAhead(From, Current);
    END LOOP;
  END Copy;

END Lists_Generic;