Artifact 9d702bf105501f677892327d68f0ccda833f1bd5bb97da968276918b178a36e4:

• File psl-1983/3-1/tests/p-allocators.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: 4190) [annotate] [blame] [check-ins using] [more...]

% P-ALLOCATORS.RED - Low level storage management
% 
% Author:      Eric Benson
%              Computer Science Dept.
%              University of Utah
% Date:        27 August 1981
% Copyright (c) 1981 University of Utah

% Revisions:
% MLG, 19 June 1983
%	Reset HeapLast to HeapPreviousLast in GTheap.
% MLG, 20 Feb 1983
% 	Moved space declarations to XXX-HEADER.RED
%	Duplicated code body for GtEvect
%	Added InitHeap in XXX-HEADER.RED
%	Modified comments
%  <PSL.KERNEL>ALLOCATORS.RED.4, 10-Jan-83 15:50:50, Edit by PERDUE
%  	Added GtEVect

on SysLisp;

external Wvar HeapLowerBound,
	      HeapUpperBound,
	      HeapLast,
	      HeapPreviousLast,
	      HeapTrapBound,
	      NextBPS,
	      LastBPS;


syslsp procedure GtHEAP N;	
%  get heap block of N words
if null N then (HeapUpperBound - HeapLast) / AddressingUnitsPerItem else
<<  HeapPreviousLast := HeapLast;
    HeapLast := HeapLast + N*AddressingUnitsPerItem;
    if HeapLast > HeapUpperBound then
    <<  HeapLast:=HeapPreviousLast; % Reset pointer before RECLAIM
        !%Reclaim();
	HeapPreviousLast := HeapLast;
	HeapLast := HeapLast + N*AddressingUnitsPerItem;
	if HeapLast > HeapUpperBound then
	    FatalError "Heap space exhausted" >>;
    HeapPreviousLast >>;

syslsp procedure DelHeap(LowPointer, HighPointer);
    if HighPointer eq HeapLast then HeapLast := LowPointer;

syslsp procedure GtSTR N;	
%  Allocate space for a string N chars
begin scalar S, NW;
    S := GtHEAP((NW := STRPack N) + 1);
    @S := MkItem(HBytes, N);
    S[NW] := 0;				% clear last word, including last byte
    return S;
end;

syslsp procedure GtConstSTR N;	 
% allocate un-collected string for print name
begin scalar S, NW;			% same as GtSTR, but uses BPS, not heap
    S := GtBPS((NW := STRPack N) + 1);
    @S := N;
    S[NW] := 0;				% clear last word, including last byte
    return S;
end;

syslsp procedure GtHalfWords N;	
%  Allocate space for N halfwords
begin scalar S, NW;
    S := GtHEAP((NW := HalfWordPack N) + 1);
    @S := MkItem(HHalfWords, N);
    return S;
end;

syslsp procedure GtVECT N;	
%  Allocate space for a vector N items
begin scalar V;
    V := GtHEAP(VECTPack N + 1);
    @V := MkItem(HVECT, N);
    return V;
end;

syslsp procedure GtEVECT N;	
%  Allocate space for a Evector N items
begin scalar V;
    V := GtHEAP(VECTPack N + 1);
    @V := MkItem(HVECT, N);
    return V;
end;


syslsp procedure GtWRDS N;	
%  Allocate space for N untraced words
begin scalar W;
    W := GtHEAP(WRDPack N + 1);
    @W := MkItem(HWRDS, N);
    return W;
end;


syslsp procedure GtFIXN();	
%  allocate space for a fixnum
begin scalar W;
    W := GtHEAP(WRDPack 0 + 1);
    @W := MkItem(HWRDS, 0);
    return W;
end;

syslsp procedure GtFLTN();	
%  allocate space for a float
begin scalar W;
    W := GtHEAP(WRDPack 1 + 1);
    @W := MkItem(HWRDS, 1);
    return W;
end;



syslsp procedure GtID();	
%  Allocate a new ID
% NextSymbol  and HashTable are globally declared
% IDs are allocated as a linked free list through the SymNam cell,
% with a 0 to indicate the end of the list.
begin scalar U;
    if NextSymbol = 0 then 
    <<  Reclaim();
	if NextSymbol = 0 then
	    return FatalError "Ran out of ID space" >>;
    U := NextSymbol;
    NextSymbol := SymNam U;
    return U;
end;


syslsp procedure GtBPS N;	
%  Allocate N words for binary code
begin scalar B;
    if null N then return((LastBPS - NextBPS)/AddressingUnitsPerItem);
					% GTBPS NIL returns # left
    B := NextBPS;
    NextBPS := NextBPS + N*AddressingUnitsPerItem;
    return if NextBPS > LastBPS then
	StdError '"Ran out of binary program space"
    else B;
end;

syslsp procedure DelBPS(Bottom, Top);
%  Return space to BPS
    if NextBPS eq Top then NextBPS := Bottom;

syslsp procedure GtWArray N;
%  Allocate N words for WVar/WArray/WString
begin scalar B;
    if null N then return((LastBPS - NextBPS)/AddressingUnitsPerItem);
					% GtWArray NIL returns # left
    B := LastBPS - N*AddressingUnitsPerItem;
    return if NextBPS > B then
	StdError '"Ran out of WArray space"
    else
	LastBPS := B;
end;

syslsp procedure DelWArray(Bottom, Top);
%  Return space for WArray
    if LastBPS eq Bottom then LastBPS := Top;

off SysLisp;

END;