// February 17, 1978  7:14 PM			*** resident ***

get "zpDefs.bcpl"

// outgoing procedures:

external [
	overlay
	obtainBlock
	maxBlockSize
	getBlock
	putBlock
	trimBlock
	giveUp
	CheckPSerror
	pushDTTstack
	flushDTTstack
	]


// incoming procedures:

external [
	MoveBlock			// SYSTEM
	Allocate
	Free
	Gets
	Closes
	CreateDiskStream
	PositionPage
	ReadBlock

	typeForm			// ZPUTIL
	FatalError
	]


// incoming statics:

external [
	@freeStorageZone			// ZPINIT
	@freeStorageSize
	@overlayTable

	@DTTstack
	@DTTstackTop

	keys				// SYSTEM
	]


//-------------------------------------------------------------------
let overlay(i) = valof  [overlay
//-------------------------------------------------------------------
	if overlayTable>>OVT.current eq i resultis true
	let overlayStream=CreateDiskStream(lv(overlayTable>>OVT.fp), ksTypeReadOnly)
	PositionPage(overlayStream, overlayTable>>OVT.pn↑i)
	let ovl=vec 16
	ReadBlock(overlayStream, ovl, 16)
	let PCstart=ovl!0
	ReadBlock(overlayStream, PCstart, ovl!4 - 16)
	// relocate statics:
	let relTable=PCstart + ovl!3 - 16
	let relTableLength=2*relTable!0
	for p=1 to relTableLength by 2 do
		@(relTable!p)=relTable!(p+1) + PCstart
	Closes(overlayStream)
	overlayTable>>OVT.current=i
	unless (overlayTable>>OVT.swat & (1 lshift (i-1))) eq 0 then [
		typeForm(0, "Overlay ", 10, i, 0, ". Pause to SWAT*N")
		Gets(keys)
		]
	resultis i
	]overlay



//-------------------------------------------------------------------
and obtainBlock(n) = valof [obtainBlock
//-------------------------------------------------------------------
	[ let r=Allocate(freeStorageZone, n, lv freeStorageSize)
	  if r resultis r
	  [ switchon pushDTTstack() into [
		case 0: resultis 0
		case 1: loop
		case 2: break
		] repeat
	  ] repeat
	]obtainBlock



//-------------------------------------------------------------------
and getBlock(n) =
//-------------------------------------------------------------------
	Allocate(freeStorageZone, n, lv freeStorageSize)


//-------------------------------------------------------------------
and maxBlockSize() =
//-------------------------------------------------------------------
	Allocate(freeStorageZone, #77777, lv freeStorageSize)

//-------------------------------------------------------------------
and putBlock(block) =
//-------------------------------------------------------------------
	(block ? Free(freeStorageZone, block), 0)



//-------------------------------------------------------------------
and trimBlock(block, freeWord) be [
//-------------------------------------------------------------------
	if @(block-1) eq 0 then block=block-1
	let usedLength=freeWord-block+1
	let freeLength=(-@(block-1))-usedLength
	if freeLength ls 6 return
	@(block-1)= -usedLength
	@freeWord= -freeLength
	Free(freeStorageZone, freeWord+1)
	]



//-------------------------------------------------------------------
and giveUp(proc,p1,p2,p3,p4,p5,p6,p7,p8; numargs n) = valof [giveup
//-------------------------------------------------------------------
	// proc is procedure name
	// pi are free storage blocks to return
	let p=lv p1
	for i=0 to n-2 do putBlock(p!i)
	typeForm(0,proc,0," Sorry, not enough storage: the command has been aborted*N")
	resultis 0
	]giveup


//-------------------------------------------------------------------
and CheckPSerror(error) = valof [
//-------------------------------------------------------------------
	// check if out of storage
	if error eq 1 then resultis 0
	FatalError("PSpline", error)
	]



//-------------------------------------------------------------------
and flushDTTstack() be [flushDTTstack
//-------------------------------------------------------------------
	[ if pushDTTstack() eq 0 break ] repeat
	maxBlockSize()
	]flushDTTstack



//-------------------------------------------------------------------
and pushDTTstack() = valof [pushDTTstack
//-------------------------------------------------------------------
	// DTTstackTop < 0 : error 
	if DTTstackTop ls 0 then typeForm(0,"[expunge] stack error*N")
	// DTTstackTop = 0 : nothing to push down ! 
	if DTTstackTop le 0 resultis 0
	let count=DTTstack>>stackCOUNT.count
	let code=DTTstack>>stackCOUNT.code
	let total=count + code + 1
	if code eq 0 then
		for i=1 to count do putBlock(DTTstack!i)
	DTTstackTop=DTTstackTop-total
	if DTTstackTop gr 0 then
		MoveBlock(DTTstack, DTTstack+total, DTTstackTop)
	resultis code eq 0 ? 2, 1
	// result 0: nothing to push down
	// result 1: no storage freed
	// result 2: some storage freed
	]pushDTTstack