Artifact 3dfcd9135a5c00b47a9c68390c4135edddad4df66dca25ad2000741ac8ce0c9b:

• File psl-1983/3-1/tests/gc-test.red — part of check-in [eb17ceb7f6] at 2020-04-21 19:40:01 on branch master — Add Reduce 3.0 to the historical section of the archive, and some more
  files relating to version sof PSL from the early 1980s. Thanks are due to
  Paul McJones and Nelson Beebe for these, as well as to all the original
  authors.

  git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 5349) [annotate] [blame] [check-ins using] [more...]

% GC-TEST.RED - Test of P-COMP-GC Marking primitives
% M. L. Griss, 17 June 1983
% MAcros extracted for file, P-COMP-GC.RED

On Syslisp;

internal WConst GCMarkValue = 8#777,
		HSkip = Forward;

CompileTime <<
syslsp smacro procedure Mark X;		% Get GC mark bits in item X points to
    GCField @X;

syslsp smacro procedure SetMark X;	% Set GC mark bits in item X points to
    GCField @X := GCMarkValue;

syslsp smacro procedure ClearMark X;  % Clear GC mark bits in item X points to
    GCField @X := if NegIntP @X then -1 else 0;

syslsp smacro procedure Marked X;	% Is item pointed to by X marked?
    Mark X eq GCMarkValue;

syslsp smacro procedure MarkID X;
    Field(SymNam X, TagStartingBit, TagBitLength) := Forward;

syslsp smacro procedure MarkedID X;
    Tag SymNam X eq Forward;

syslsp smacro procedure ClearIDMark X;
    Field(SymNam X, TagStartingBit, TagBitLength) := STR;


% Relocation primitives

syslsp smacro procedure SkipLength X;	% Stored in heap header
    Inf @X;

syslsp smacro procedure PutSkipLength(X, L);	% Store in heap header
    Inf @X := L;

put('SkipLength, 'Assign!-Op, 'PutSkipLength);
>>;

internal WConst BitsInSegment = 13,
		SegmentLength = LShift(1, BitsInSegment),
		SegmentMask = SegmentLength - 1;

%/ External WArray GCArray;


CompileTime <<
syslsp smacro procedure SegmentNumber X;	% Get segment part of pointer
    LShift(X - HeapLowerBound, -BitsInSegment);

syslsp smacro procedure OffsetInSegment X;	% Get offset part of pointer
    LAnd(X - HeapLowerBound, SegmentMask);

syslsp smacro procedure MovementWithinSegment X;	% Reloc field in item
    GCField @X;

syslsp smacro procedure PutMovementWithinSegment(X, M);	% Store reloc field
    GCField @X := M;

syslsp smacro procedure ClearMovementWithinSegment X;	% Clear reloc field
    GCField @X := if NegIntP @X then -1 else 0;

put('MovementWithinSegment, 'Assign!-Op, 'PutMovementWithinSegment);

syslsp smacro procedure SegmentMovement X;	% Segment table
    GCArray[X];

syslsp smacro procedure PutSegmentMovement(X, M);	% Store in seg table
    GCArray[X] := M;

put('SegmentMovement, 'Assign!-Op, 'PutSegmentMovement);

syslsp smacro procedure Reloc X;	% Compute pointer adjustment
    X - (SegmentMovement SegmentNumber X + MovementWithinSegment X);
>>;

syslsp procedure testmarking;
 begin
	Prin2T "---- Test GC MARK of various HEAP structures ----";
	Prin2T "     Examine each case carefully, see MARK go on and back off";
	Test1Mark cons(1 , 2); % Build a fresh one
	Test1Mark cons(- 1 , -2); % testing sign extend
	Test1Mark cons('A, 'B);
	Test1Mark '[0 1 2 3];
	Test1Mark "01234";
	TestIdmark 'A;
	TestIdmark 'JUNK;
	TestIdmark 'NIL;
	Prin2T "---- Mark tests all done ---     ";
 End;

syslsp procedure Test1Mark X;
 Begin scalar P;
	Prin2 ".... Object to mark:           "; Print X;
	P:=Inf X;
	Prin2 "     MARK field:               "; Print Mark P;
	Prin2 "     MARKED should be NIL:     "; Print Marked P;
	PrintBits @P;
	Prin2 "  .. SETMARK :                 "; Print SetMark P;
	Prin2 "     MARK field now:           "; Print Mark P;
	Prin2 "     MARKED should be T:       "; Print Marked P;
	PrintBits @P;
	Prin2 "  .. CLEARMARK:                "; Print ClearMark P;
	Prin2 "     MARK field finally:       "; Print Mark P;
	Prin2 "     MARKED should be NIL:     "; Print Marked P;
	PrintBits @P;
	Prin2 "  .. Object again legal:       "; Print X;
 End;

syslsp procedure TestIDMark X;
 Begin scalar P;
	Prin2 ".... ID to mark:               "; Print X;
	P:=IDInf X;
	Prin2 "     MARKEDID should be NIL:     "; Print MARKEDID P;
	PrintBits SYMNAM P;
	Prin2 "  .. MARKID :                    "; Print MarkId P;
	Prin2 "     MARKEDID should be T:       "; Print MARKEDID P;
	PrintBits SYMNAM P;
	Prin2 "  .. CLEARIDMARK:                "; Print Clearidmark P;
	Prin2 "     MARKEDID should be NIL:     "; Print MARKEDID P;
	PrintBits SYMNAM P;
	Prin2 "  .. ID again legal:             "; Print X;
 End;

syslsp procedure PrintBits x;
      <<Prin2 "     BitPattern:               ";
        Prin2 Tag x; 
        Prin2 ":     ";
        Prin2 Inf x;
        Terpri();
      >>;
off syslisp;

procedure GCTEST;
Begin scalar X,N,M;
	Prin2T "---- GTEST series -----";
	Prin2T ".... Try individual Types first ...";
	Prin2  "     Reclaim called:     "; Reclaim();
	Prin2  " ..  Allocate a PAIR:    "; Print (x:=cons(1,2));
	Prin2  "     Reclaim called:     "; Reclaim();
	Prin2  " ..  Release the PAIR:   "; Print (X:=NIL);

	Prin2  "     Reclaim called:     "; Reclaim();

	Prin2  " ..  Allocate a  VECTOR: "; Print (x:=Mkvect(4));
	Prin2  "     Reclaim called:     "; Reclaim();
	Prin2  " ..  Release the VECTOR: "; Print (X:=NIL);

	Prin2  "     Reclaim called:     "; Reclaim();

	Prin2  " ..  Allocate a STRING:  "; Print (x:=Mkstring(5,65));
	Prin2  "     Reclaim called:     "; Reclaim();
	Prin2  " ..  Release the STRING: "; Print (X:=NIL);

	Prin2  "     Reclaim called:     "; Reclaim();
	M:=2;
	Prin2 ".... Loop until RECLAIM automatically called :";
         Prin2 M; Prin2t " times";
        N:=GCknt!*+M;
	Prin2T  " ..  Loop on PAIRs:      ";
	   While GCKnt!* <=N do list(1,2,3,4,5,6,7,8,9,10);
        N:=GCknt!*+M;
	Prin2T  " ..  Loop on VECTORs:    ";
	   While GCknt!* <=N do MkVect 5;
        N:=GCknt!*+M;
	Prin2T  " ..  Loop on STRINGs:    ";
	   While GCKnt!* <=N do Mkstring(20,65);
End;

off syslisp;

End;