(* Simple test module for Collector and CollectorS *)

MODULE CollTest;

IMPORT
  (* $IF Debug *) Debug, (* $END *)
  io, Random, NoGuru,
  (* $IF Collector *)
    c:Collector;
  (* $ELSE *)
    c:CollectorS;
  (* $END *)

TYPE
  ElemP = POINTER TO Elem;

  Elem = RECORD
    (c.Element)
    nr  : LONGINT;  (* creation count, 0 for 'deleted' elements *)
    ref : ElemP;    (* a reference out *)
  END;

VAR
  rootType : SHORTINT;
  elemType : SHORTINT;
  elemNr   : LONGINT;
  root     : ARRAY 200 OF ElemP;
  elem     : ARRAY 200 OF ElemP;
  tmp1, tmp2 : ElemP;
  i, j     : INTEGER;
  count    : INTEGER;
  nRoot    : INTEGER;
  nElem    : INTEGER;

PROCEDURE newElem () : c.ElementP;
VAR p : ElemP;
BEGIN
  NEW(p);
  RETURN p;
END newElem;


PROCEDURE (this : ElemP) mark *;
BEGIN
  IF (this.nr # 0) & (this.ref # NIL) THEN
    c.Mark(this.ref);
  END;
END mark;


PROCEDURE (this : ElemP) free * () : INTEGER;
BEGIN
    (* Non-Root or deleted Root elements may be freed *)
  IF ~(c.Root IN this.ecFlags) OR (this.nr = 0) THEN
    this.ref := NIL;
    RETURN c.enlist;
    (* Note that the pointer in the global root[] or elem[]
    ** should be removed here as well.
    *)
  END;
  RETURN c.keep;
END free;


PROCEDURE NewElem (type : SHORTINT) : ElemP;
VAR p : ElemP;
BEGIN
  p := c.New(type)(Elem);
  INC(elemNr);
  p.nr := elemNr;
  p.ref := NIL;
  RETURN p;
END NewElem;


PROCEDURE FreeRoot;
VAR i : LONGINT;
BEGIN
  FOR i := 0 TO LEN(root)-1 DO
    IF root[i] # NIL THEN
      root[i].nr := 0;
      root[i] := NIL;
    END;
  END;
END FreeRoot;


BEGIN
  elemNr := 0;
  rootType := c.RegisterType(newElem, TRUE, 100);
  elemType := c.RegisterType(newElem, FALSE, 100);
  Random.PutSeed(31415926);

  (* Simplest case: GC if nothing is there *)
  IF c.GC(0) THEN END;

  (* GC after allocating a few Root elements with crossreferences *)
  root[0] := NewElem(rootType);
  root[1] := NewElem(rootType);
  root[2] := NewElem(rootType);
  root[3] := NewElem(rootType);
  root[1].ref := root[3];
  c.Check(root[1], root[3]);
  IF c.GC(0) THEN END;

  (* 'Delete' the root elements, then GC again *)
  FreeRoot;
  IF c.GC(0) THEN END;

  (* Return the memory collected to the system *)
  c.ShortenLists(0);

  (* Now lets play with referenced and unreferenced non-root objects
  *)
  elem[0] := NewElem(elemType); (* A floating loop *)
  elem[1] := NewElem(elemType);
  elem[2] := NewElem(elemType);
  elem[0].ref := elem[2];
  c.Check(elem[0], elem[2]);
  elem[3] := NewElem(elemType); (* This is just unreferenced *)
  elem[4] := NewElem(elemType); (* A sequence of two elements *)
  elem[5] := NewElem(elemType);
  elem[5].ref := elem[4];
  c.Check(elem[5], elem[4]);
  root[0] := NewElem(rootType); (* Get a hold on the sequence *)
  root[0].ref := elem[5];       (* enforce a second run through the non-roots *)
  c.Check(root[0], elem[5]);

  (* Let just the referenced elements survive *)
  IF c.GC(0) THEN END;

  (* Now return all *)
  FreeRoot;
  IF c.GC(0) THEN END;

  (* Now check if the interleaving of referencing and garbage collection
  ** succeeds.
  ** First the setup...
  *)
  elem[0] := NewElem(elemType);
  root[0] := NewElem(rootType);
  root[0].ref := elem[0];
  c.Check(root[0], elem[0]);

  (* The GC comes from the end, our references will be built from the
  ** beginning.
  *)
  FOR i := 1 TO 3 DO
    elem[i]     := NewElem(elemType);
    elem[i].ref := root[0].ref;
    c.Check(elem[i], elem[i].ref);
    root[0].ref := elem[i];
    c.Check(root[0], elem[i]);
    IF c.GC(4) THEN END;
  END;

    (* Now, what would be wrong with this test code instead?
    **   FOR i := 1 TO 3 DO
    **     elem[i]       := NewElem(elemType);
    **     elem[i-1].ref := elem[i];
    **     c.Check(elem[i], elem[i].ref);
    **     IF c.GC(4) THEN END;
    **   END;
    ** After a call to GC() the content of elem[i-1] might have gone away.
    ** In this case it doesn't because all elements are chained, but that's
    ** just this case.
    ** There is a lesson here to learn: between two calls of GC() we may
    ** just use the elements we trace ourself down from a root element,
    ** or we allocate ourself.
    ** It is therefore a good idea to NIL all the 'weak' pointers to an element
    ** in the free() method of that very element.
    *)

  IF c.GC(0) THEN END;

  (* Cleanup again *)
  FreeRoot;
  IF c.GC(0) THEN END;


  io.WriteLn;
  io.WriteInt(c.gcReqT, 1); io.WriteString(" elements requested so far, ");
  io.WriteInt(c.gcFreeT, 1); io.WriteString(" retrieved : ");
  IF (c.gcFreeT = 16) & (c.gcReqT = 16) THEN
    io.WriteString("correct.\n");
  ELSE
    io.WriteString("wrong, should be both 16.\n");
  END;
  io.WriteLn;

  (* If you finaly come here, you can relax: the collector is functional.
  ** Now let's see how responsive it is..
  ** (You don't really want to single-step this part, believe me).
  *)

  FOR i := 1 TO (* $IF Debug *) 5 (* $ELSE *) 10 (* $END *) DO
    io.WriteString("Loop "); io.WriteInt(i, 2); io.WriteString(": ");

    nRoot := 0;
    nElem := 0;
    count := 0;

    WHILE (nRoot < 200) & (nElem < 200) DO
      INC(count);
      tmp1 := NIL;
      tmp2 := NIL;
      IF (Random.RND(100) < 50) & (nRoot < 200) THEN
        root[nRoot] := NewElem(rootType);
        INC(nRoot);
      END;
      IF (Random.RND(100) < 50) & (nRoot < 200) THEN
        root[nRoot] := NewElem(rootType);
        INC(nRoot);
      END;
      IF (Random.RND(100) < 50) & (nElem < 200) THEN
        elem[nElem] := NewElem(elemType);
        tmp1 := elem[nElem];
        INC(nElem);
      END;
      IF (Random.RND(100) < 50) & (nElem < 200) THEN
        elem[nElem] := NewElem(elemType);
        tmp2 := elem[nElem];
      END;

      IF (tmp1 # NIL) & (nRoot > 0) THEN
        j := Random.RND(nRoot);
        IF root[j].nr # 0 THEN
          root[j].ref := tmp1;
          c.Check(root[j], tmp1);
        END;
      END;
      IF (tmp2 # NIL) & (nRoot > 0) THEN
        j := Random.RND(nRoot);
        IF root[j].nr # 0 THEN
          root[j].ref := tmp2;
          c.Check(root[j], tmp2);
        END;
      END;

      j := Random.RND(300);
      IF j < nRoot THEN
        root[j].nr := 0;
      END;
      j := Random.RND(300);
      IF j < nRoot THEN
        root[j].nr := 0;
      END;

      j := Random.RND(300);
      IF j < nRoot THEN
        root[j].ref := NIL;
      END;
      j := Random.RND(300);
      IF j < nRoot THEN
        root[j].ref := NIL;
      END;

      j := Random.RND(300);
      IF (j < nRoot) & (root[j].nr # 0) & (root[j].ref # NIL) THEN
        tmp1 := root[j].ref;
        j := Random.RND(nRoot);
        IF root[j].nr # 0 THEN
          root[j].ref := tmp1;
          c.Check(root[j], tmp1);
        END;
      END;
      j := Random.RND(300);
      IF (j < nRoot) & (root[j].nr # 0) & (root[j].ref # NIL) THEN
        tmp1 := root[j].ref;
        j := Random.RND(nRoot);
        IF root[j].nr # 0 THEN
          root[j].ref := tmp1;
          c.Check(root[j], tmp1);
        END;
      END;

      IF c.GC(20) THEN
        io.WriteInt(count, 1); io.WriteString(", ");
      END;
    END;

    FreeRoot;
    IF c.GC(0) THEN END;
    io.WriteLn;
  END;

  (* Ensure a complete GC *)

  IF c.GC(0) THEN END;

  io.WriteLn;
  io.WriteInt(c.gcRuns, 1); io.WriteString(" GCs completed in ");
  io.WriteInt(c.gcCallsT, 1); io.WriteString(" calls.\n");
  io.WriteInt(c.gcReqT, 1); io.WriteString(" elements requested, ");
  io.WriteInt(c.gcFreeT, 1); io.WriteString(" retrieved.\n");
  io.WriteInt(c.gcExaT, 1); io.WriteString(" elements examined\n");

END CollTest.