{$M-}
program alloc;

include {NOLIST} 'pascal:extern.pas';		
include {NOLIST} 'domain:mdep.def';
include {NOLIST} 'domain:master.def';
include {NOLIST} 'domain:lparse.def';
include {NOLIST} 'domain:msub.hdr';
include {NOLIST} 'domain:mdep.hdr';
include {NOLIST} 'domain:iomsg.hdr';
include {NOLIST} 'domain:addrr.hdr';
include {NOLIST} 'domain:dump.hdr';

var	y:integer_pointer;
	master:master_block_pointer;

{	**********************************************************

	This file contains procedures for storage allocation

	********************************************************** }

function getdbpage(count:integer):pagenumber;

{	DBPAGE takes a page count as an argument, and returns
	the page number of a that many free pages
}

var	anyused,done:boolean;
	i,j:pagenumber;
	block:free_block_pointer;
	myfbp:file_blk_ptr;

begin
master:=getmaster;
done:=false;
i:=db_first_page;

repeat	anyused:=false;
	for j:=i to i+count-1
	do	anyused:=anyused or master^.used_pages[j];
	if anyused
	then	if i+count>db_last_page
		then	begin
			myfbp:=ofile(fatl);
			writeln(myfbp^.fident, 'Data Base Full');
			cfile(myfbp);
			quit
			end
		else	i:=i+1
	else	begin
		done:=true;
		for j:=i to i+count-1
		do	master^.used_pages[j]:=true;
		getdbpage:=i;
		block:=aofpage(i);
		blkzero(au_per_page*count,block)
		end
until	done;


end; { getdbpage }
function free_round(x:integer):integer;

{	FREE_ROUND is used to round the size of a free block.  While
	block size may be rounded to increase storage efficiency,
	FREE_ROUND must guarantee that a block is at least big enough to
	contain a FREE_BLOCK }

var	y:integer;

begin
if x<au_min_size
then	y:=au_min_size
else	y:=x;

if (y mod au_mod)=0
then	free_round:=y
else	free_round:=((y div au_mod)*au_mod)+au_mod

end; { free_round }

procedure fret(var myzone:zone_entry;
		   poolid:sapool;
		   block:free_block_pointer);

{	FRET releases a block of free storage into a pool for
	a zone.  Note that the page map is unaffected
}

var	done:boolean;
	anchor,search:free_block_pointer;
	newsize:integer;

begin
anchor:=NIL;
search:=myzone.zone_pools[poolid];
block^.size:=free_round(block^.size);

while not done
do	begin
	done:=true;	{ assume it will work }
	{ end of chain ? }
	if search=NIL
	then	begin
		block^.next:=NIL;
		if anchor=NIL
		then	myzone.zone_pools[poolid]:=block
		else	anchor^.next:=block
		end
	else	{ front of next block ? }
		if quotep(block) < quotep(search)
		then	{ either in front or on front }
			begin
			if (quotep(block)+block^.size)=quotep(search)
			then	{ on front }
				begin
				block^.size:=block^.size+search^.size;
				block^.next:=search^.next
				end
			else	{ in front }
				block^.next:=search;
			if anchor=NIL
			then	myzone.zone_pools[poolid]:=block
			else	anchor^.next:=block
			end
		else	{ fits on back ? }
			if (quotep(search)+search^.size)=quotep(block)
			then	begin
				newsize:=search^.size+block^.size;
				{ combine with next ? }
				if (quotep(search)+newsize)=quotep(search^.next)
				then	{ combine three blocks}
					begin
					search^.size:=newsize+search^.next^.size;
					search^.next:=search^.next^.next
					end
				else	{ just two }
					search^.size:=newsize
				end
			else	{ advance }
				begin
				done:=false;
				anchor:=search;
				search:=anchor^.next
				end
	end

end; { fret }
procedure getzpages(var myzone:zone_entry;
		        poolid:sapool;
			size:integer);

{	GETZPAGES is called when an allocation fails and it is
	necessary to acquire new pages.  Because an allocation may exceed
	a page size is passed to specify how large a block is required }

var	page_count:integer;
	page:pagenumber;
	block:free_block_pointer;
	i:integer;

begin
page_count:=(size+au_per_page-1) div au_per_page;
page:=getdbpage(page_count);

{ remember that this zone has the pages }
for i:=0 to page_count-1
do	myzone.zone_pages[page+i]:=true;

{ create a free block }
block:=aofpage(page);
block^.size:=au_per_page*page_count;
fret(myzone,poolid,block);	{ fake a free of this block }

end; { getzpages }
procedure free(var myzone:zone_entry;
		   poolid:sapool;
	       var x:integer_pointer;
		   size:integer);

{	FREE obtains a block of free storage from the specified zone
	pool.
}

var	req_size:integer;
	anchor,scan,left_over:free_block_pointer;

begin
req_size:=free_round(size);	{ get next bigger size }

x:=NIL;
repeat	anchor:=NIL;				{ place to splice }
	scan:=myzone.zone_pools[poolid];	{ place to examine }
	while (x=NIL) and (scan<>NIL)
	do	if scan^.size>=req_size
		then	{ block fits }
			begin
			cpyptr(scan,x);
			if scan^.size=req_size
			then	{ block fits exactly }
				if anchor=NIL
				then	myzone.zone_pools[poolid]:=scan^.next
				else	anchor^.next:=scan^.next
			else	{ left overs }
				begin
				cpyptr(scan,left_over);
				modptr(left_over,req_size);
				left_over^.size:=scan^.size-req_size;
				left_over^.next:=scan^.next;
				if anchor=NIL
				then	myzone.zone_pools[poolid]:=left_over
				else	anchor^.next:=left_over
				end;
			blkzero(req_size,x)
			end
		else	{ advance to next block }
			begin
			anchor:=scan;
			scan:=scan^.next
			end;
	if x=NIL
	then	getzpages(myzone,poolid,req_size) { get adequate contig pages }
until	x<>NIL

end; {free}
procedure a_slt(var myzone:zone_entry;
		var x:secondary_label_table_pointer);

begin
with myzone
do	begin
	sadata[sd_slt,sa_units]:=sadata[sd_slt,sa_units]+1;
	sadata[sd_slt,sa_aus]:=sadata[sd_slt,sa_aus]+free_round(sizeof(x));
	free(myzone,sa_search,y,sizeof(x));
	cpyptr(y,x)
	end
end; { a_slt }

procedure a_ulabel(var myzone:zone_entry;
		var x:ulabel_pointer;
		less_bytes:integer);

var	asize:integer;

begin
with myzone
do	begin
	sadata[sd_ulabel,sa_units]:=sadata[sd_ulabel,sa_units]+1;
	asize:=free_round(sizeof(x)-(less_bytes div bytes_per_au));
	sadata[sd_ulabel,sa_aus]:=sadata[sd_ulabel,sa_aus]+asize;
	free(myzone,sa_search,y,asize);
	cpyptr(y,x)
	end
end; { a_ulabel }

procedure a_dname(var myzone:zone_entry;
		var x:dname_pointer);

begin
with myzone
do	begin
	sadata[sd_dname,sa_units]:=sadata[sd_dname,sa_units]+1;
	sadata[sd_dname,sa_aus]:=sadata[sd_dname,sa_aus]+free_round(sizeof(x));
	free(myzone,sa_data,y,sizeof(x));
	cpyptr(y,x)
	end
end; { a_dname }

procedure a_node(var myzone:zone_entry;
		var x:node_pointer);

begin
with myzone
do	begin
	sadata[sd_node,sa_units]:=sadata[sd_node,sa_units]+1;
	sadata[sd_node,sa_aus]:=sadata[sd_node,sa_aus]+free_round(sizeof(x));
	free(myzone,sa_search,y,sizeof(x));
	cpyptr(y,x)
	end
end; { a_node }

procedure a_lht(var myzone:zone_entry;
		var x:label_hashtable_pointer);

{	allocate a label hashtable }
begin
with myzone
do	begin
	sadata[sd_lht,sa_units]:=sadata[sd_lht,sa_units]+1;
	sadata[sd_lht,sa_aus]:=sadata[sd_lht,sa_aus]+free_round(sizeof(x));
	free(myzone,sa_search,y,sizeof(x));
	cpyptr(y,x)
	end
end; { a_lht }

procedure a_rr(var myzone:zone_entry;
		var x:rr_pointer);

begin
with myzone
do	begin
	sadata[sd_rr,sa_units]:=sadata[sd_rr,sa_units]+1;
	sadata[sd_rr,sa_aus]:=sadata[sd_rr,sa_aus]+free_round(sizeof(x));
	free(myzone,sa_data,y,sizeof(x));
	cpyptr(y,x)
	end
end; { a_rr }

procedure a_rdchunk(var myzone:zone_entry;
		var x:rdchunk_pointer);

begin
with myzone
do	begin
	sadata[sd_rdchunk,sa_units]:=sadata[sd_rdchunk,sa_units]+1;
	sadata[sd_rdchunk,sa_aus]:=sadata[sd_rdchunk,sa_aus]+free_round(sizeof(x));
	free(myzone,sa_data,y,sizeof(x));
	cpyptr(y,x)
	end
end; { a_rdchunk }

procedure a_litstring(var myzone:zone_entry;
		      var x:litstring_pointer;
			  less_bytes:integer);

var	asize:integer;
begin
with myzone
do	begin
	sadata[sd_litstring,sa_units]:=sadata[sd_litstring,sa_units]+1;
	asize:=free_round(sizeof(x)-(less_bytes div bytes_per_au));
	sadata[sd_litstring,sa_aus]:=sadata[sd_litstring,sa_aus]+asize;
	free(myzone,sa_data,y,asize);
	cpyptr(y,x)
	end
end; { a_litstring }

procedure a_zone(var mzp:zone_entry_pointer);

{	This procedure is called to allocate a new zone.

	The allocation procedure is special because we must create the
	zone before we can assign the zone_entry's pages to itself.
}

var	page_count:integer;
	page:pagenumber;
	block:free_block_pointer;
	i:integer;
       
begin
page_count:=(sizeof(mzp)+au_per_page-1) div au_per_page;
page:=getdbpage(page_count);

block:=aofpage(page);
cpyptr(block,mzp);

for i:=0 to page_count-1 (* setup storage allocation *)
do	mzp^.zone_pages[page+i]:=true;
mzp^.sadata[sd_zone,sa_units]:=1;
mzp^.sadata[sd_zone,sa_aus]:=free_round(sizeof(mzp));

zinit(mzp^)

end. { a_zone }