%#SEGMENT(LIB2) 

// Partly taken from:  
//  
// $THE TEXT OF OSPub; Christopher Strachey and Joseph Stoy
//  
// HTTPS://WWW.CS.OX.AC.UK/PUBLICATIONS/PUBLICATION3726-ABSTRACT.HTML   
//  
// $Other parts extracted from original SUBGROUPSRB1  


MANIFEST // Free Store   
$( 
	$FSVECSIZE = 6

	FBC = 0		// Free block chain   
	$FWC = 1		// Free word chain   
	$PBC = 2		// Pending block chain   
	$PWC = 3		// Pending word chain
	$LB = 4		// Lower bound of current area
	$UB = 5		// Upper bound of curret area 
	$FPRE = 6	// Predecessor of vector  

	// $Free block format:   

	$SIZE = 0 
	NXTB = 1  
		// SIZE and NXTB cannot be interchanged without  
		// ALTERATION TO THE PROGRAM ($See "FREESTORE").  

	END = 0   
	NOSTORE = -1  
$) 

GET "GLOBALS"   

// Should get this from NHEAD2, but that is ALL CAPS

GLOBAL $(  
	NewVec :80;  NewWord :81;  ReturnVec :82;  ReturnWord :83; 
	$NewFreeStore :84;  RestoreFreeStore :85;  
	$SetupVecAsFreeStore :86;  FS:87;   
	ReportFreeStoreState :88;  
	$FSErr :89;  
$) 

// $FREESTORE   

LET NewVec[n = VALOF
$(NV   
	IF n < 0 DO 
	$(   
		FSErr["Negative arg in NewVec" 
		$FINISH 
	$)   

	IF (n = 0) LOGAND (FS!FWC NE END) DO
	$(   
		LET w = FS!FWC		// First word in FreeWordChain   
		$FS!FWC := RV w
		$RESULTIS w
	$)   

	$(   
		$LET BP = LV FS!FBC	// Block Pointer
		$LET B = RV BP		// Block 

		$($R   
			IF B = END DO 
			$(   
				FSErr("Free Store exhausted" 
				$FINISH 
			$)   
			IF B!SIZE >= n BREAK
			BP := LV B!NXTB   
			B := RV BP
		$)R REPEAT 

		// If the block is bigger than we need we add it   
		// TO THE FREE STORE.  $We could just use ReturnVec
		// TO DO THAT, BUT THAT DOES QUITE A LOT OF DUPLICATE   
		// WORK, SO, INSTEAD OF:
		//  
		// $IF B!SIZE > n DO ReturnVec (B + n + 1, B!SIZE - n - 1) 
		// WE DO:   

		$TEST B!SIZE <= n + 1  
		$THEN $(   
			RV BP := B!NXTB   
			IF B!SIZE > n DO ReturnWord[LV(B!(n+1))  
		$) 
		$OR $( 
			LET SB = LV(B!(n+1))		//$SurplusBlock   
			$SB!NXTB := B!NXTB
			SB!SIZE := (B!SIZE)-(n+1)
				// $The order of the last two assignments  
				// IS IMPORTANT IF N=0.  $Here NXTB > SIZE
			RV BP := SB   
		$) 

		RESULTIS B  
	$)   
$)NV   

LET NewWord[ = newVec[0 

LET ReturnVec[V, n BE   
$(RV   
	LET RVGiveUp (reason, vec, size, fs) BE $(   
		FSErr ("Wrong args in RETURNVEC*N") 
		FINISH  
	$)   

	// If the vector bein returned isn't in the current free store   
	// THEN ADD IT TO THE PENDING LIST

	$UNLESS FS!LB <= V <= V+n <= FS!UB DO   
	$(PEND   

		// Before adding it to pending make sure it's actually 
		// IN SOME VALID FREE STORE AREA

		$IF n < 0 DO RVGiveUp[313, V, n, 0 

		$UNLESS (V > FS!UB) LOGOR (V + n < FS!LB) 
			DO RVGiveUp[314, V, n, FS 

		$( 
			LET f = FS  
			WHILE f > f!FPRE DO f := f!FPRE	// seek first FS   
			UNLESS f = f!FPRE DO RVGiveUp[315, V, n, FS 
			UNLESS (f!LB <= V) LOGAND (V+n <= f!UB)   
				DO RVGiveUp[316, V, n, f 

			$TEST n = 0  
			$THEN $( 
				RV V := FS!PWC  
				FS!PWC := V	// Pending word   
			$)   
			$OR $(   
				V!SIZE, V!NXTB := n, FS!PBC   
				FS!PBC := V	// Pending block  
			$)   
		$) 
	$)$PEND  

	$(   
		LET PW = LV FS!FWC	// Previous word   
		$LET W = RV PW		// Word  
		$UNTIL (W = END) LOGOR (W >= V-1) DO    
		$( 
			PW := W   
			W := RV PW
		$) 
		UNLESS W = END DO   
		$(1
			IF W = V-1 DO 
			$(   
				W := RV W   
				RV PW := W  
				V := V - 1  
				n := n + 1 
			$)   

			$IF V <= W <= V+n DO RVGiveUp[317, V, n, FS 

			IF W-1 = V+1 DO   
			$(   
				RV PW := RV W   
				n := n + 1 
			$)   
		$)1

		$( 
			$LET BP = LV FS!FBC	// Block pointer
			$LET B = RV BP		// Block   

			$UNTIL (B = END) LOGOR (B+B!SIZE >= V-1) DO   
			$(   
				BP := LV B!NXTB 
				B := RV BP  
			$)   

			UNLESS B = END DO 
			$(2  
				IF B+B!SIZE = V-1 DO
				$(3
					B!SIZE := B!SIZE + (n + 1)   
					$IF (B!NXTB)-1 = V+n DO 
					$(   
						B!SIZE := B!SIZE +  
							((B!NXTB)!SIZE + 1)   
						B!NXTB := (B!NXTB)!NXTB 
					$)   
					RETURN
				$)3
	  
				IF B-1 = V+n DO   
				$(4
					V!SIZE := n + (B!SIZE + 1)  
					V!NXTB := B!NXTB  
					// the order of the last two assignment  
					// STATEMENTS IS IMPORTANT IF N=0 
					$RV BP := V   
					RETURN
				$)4
				UNLESS B > V + n DO RVGiveUp[318, V, n, FS
			$)2  

			TEST n = 0   
			$THEN $( 
				RV V := W   
				RV PW := V  
			$)   
			OR $(
				V!NXTB := B 
				V!SIZE := n
				$RV BP := V 
			$)   
		$) 
	$)   
$)RV   

LET ReturnWord[w BE ReturnVec[w,0

$LET MaxVecSize[ = valof
$(MVS  
	LET M = (FS!FWC = END)->NOSTORE,0 
	LET B = FS!FBC

	UNTIL B = END DO  
	$(   
		IF B!SIZE > M DO M := B!SIZE
		B := B!NXTB 
	$)   

	RESULTIS M
$)MVS  

LET NewFreeStore[ be
$(NFS  
	LET f = NewVec[FSVECSIZE	// New FSBlock   
	$LET MVS = MaxVecSize[
	LET A = NewVec[MVS		// New area  

	F!$FBC, f!FWC := A, END 
	f!PBC, f!PWC := END, END  
	f!LB, f!UB := A, (A + MVS)
	f!FPRE := FS

	A!NXTB := END 
	FS := f  
$)$NFS 

LET RestoreFreeStore[FStore BE
$(RFS  
	$(1  
		LET f = FS
		UNTIL (f < FStore) LOGOR (f < f!FPRE) DO f := f!FPRE
		UNLESS f = FStore DO $(
			FSErr ("Bad args in RestoreFreeStore")   
			$FINISH   
		$) 
	$)1  

	UNTIL FS = FStore DO
	$(U  
		LET f = FS
		FS := FS!FPRE   
		ReturnVec[f!LB, (f!UB-f!LB) 

		$( 
			LET x = f!PBC	// Pending blocks   
			$UNTIL x = END DO   
			$(   
				LET b = x  
				X := B!$NXTB
				ReturnVec[b, b!SIZE 
			$)   
			x := f!PWC	// Pending words   
			$UNTIL x = END DO   
			$(   
				LET w = x  
				X := $RV w 
				$ReturnWord[w
			$)   
			$ReturnVec[f,FSVECSIZE
		$) 
	$)U  
$)RFS  

LET SetupVecAsFreeStore (v, size) BE $(  

	FS := v  

	V!$FBC := v + (FSVECSIZE + 1)   
	v!FWC := 0  
	v!PBC := 0  
	v!PWC := 0  
	v!LB := v + (FSVECSIZE + 1)   
	v!UB := v + size   
	V!$FPRE := v 

	V!($FSVECSIZE + 1 + SIZE) := size - (FSVECSIZE + 1) 
	v!(FSVECSIZE + 1 + NXTB) := 0   

	ReportFreeStoreState(FS)  
$) 

// PM   

LET ReportFreeStoreState [f BE  
$(RFS  
	WRITEF["Free Store state. Control block %N, area %N to %N*N",   
		f, f!LB, f!UB 
	ReportBlocks["Free", f!FBC
	ReportWords["Free", f!FWC 
	ReportBlocks["Pending", f!PBC 
	ReportWords["Pending", f!PWC  
$)RFS  

AND ReportBlocks[String, b BE   
$(RB   
	LET n, w, m = 0, 0, 0
	$IF b = END RETURN  
	  
	UNTIL b = END DO
	$(U  
		n := n + 1 
		$IF b!SIZE > m THEN m := b!SIZE   
		w := w + (b!SIZE + 1) 
		b := b!NXTB   
	$)U  

	WRITEF["%N %S %S*N  %N words*N  Largest block size %N*N", 
		n, String, (n = 1 -> "Block", "Blocks"), w, m  
$)$RB  

AND ReportWords[String,w BE 
$(RW   
	LET n = 0
	$IF w = END RETURN  

	UNTIL w = END   
	$(   
		n := n + 1 
		W := $RV w 
	$)   

	$WRITEF["%N %S %S*N", n, String, (n = 1 -> "Word", "Words")  
$)$RW  

LET FSErr (txt) BE
$( 
	LET prev = OUTPUT   
	LET f = FS  

	OUTPUT := MONITOR 

	WRITEF ("*N*NFREE STORE ERROR :- %S", txt)   

	$ReportFreeStoreState (FS)

	WHILE f!FPRE NE f DO $(  
		f := f!FPRE   
		ReportFreeStoreState (f) 
	$)   

	$NEWLINE ()   

	TY.DISPLAY (txt) 

	$OUTPUT := prev  
$) 

****

