.TITLE P.HEAP  PASCAL HEAP ROUTINES
.MCALL	DIR$
.PSECT P$HEAP
.GLOBL	P$HEAP	;FIRST LOCATION OF HEAP
.PAGE
.SBTTL P$HINT - PASCAL INITIALIZE HEAP
P$HINT::; PASCAL HEAP INITIALIZE
	; USES R4
		; R4 -> LEVEL 0 STACK FRAME
	; DESTROYS R0,R1
MOV	#P$HEAP,R0
MOV	R0,-2(R4)	;-2(LEVEL 0) -> HEAP HEADER
MOV	(R0)+,R1	;GET HEAP SIZE
MOV	R0,(R0)
ADD	#6,(R0)+	;POINTER TO FREE LIST
CLR	(R0)+		;POINTER TO LAST HEAP
CLR	(R0)+		;UNUSED WORD
MOV	R1,(R0)
SUB	#8.,(R0)+	;SIZE FREE BLOCK
CLR	(R0)		;POINTER TO NEXT FREE BLOCK
RTS	PC
.PAGE
.SBTTL P$HNEW - PASCAL HEAP REQUEST FUNCTION "NEW"
P$HNEW::; PASCAL NEW FUNCTION
	; USES R0,R4
		; R0 = SIZE REQUESTED
		; R4 -> LEVEL 0 STACK FRAME
	; SETS R0
		; R0 -> ALLOCATED BLOCK
	; DESTROYS R1,R2,R3

	; REGISTER ALLOCATION
		RS=R2 ; SIZE REQUESTED, ROUNDED UP TO EVEN # WORDS
		RQ=R0 ; LAST BLOCK
		RP=R1 ; THIS BLOCK
		RT=R3 ; TEMPORARY

MOV	R0,RS
ROR	R0
ADC	RS
ASL	RS		;NO WORDS --> NO BYTES
BLE	NOGO 		;SIZE MUST BE > 0
MOV	-2(R4),RQ	;GET POINTER TO HEAPHEAD
BEQ	NOGO		;NO HEAPHEAD
TST	(RQ)+		;BUMP POINTER TO POINT TO FIRST BLOCK

LOOP:		;BASIC SEARCH LOOP
MOV	(RQ),RP		;GET POINTER TO THIS BLOCK
BEQ	NOGO		;NO MORE BLOCKS, SEARCH FAILS
CMP	RS,(RP)+	;IS SIZE SUFFICIENT?
BLE	FOUND		;YES
MOV	RP,RQ		;NO, THIS BLOCK BECOMES OLD BLOCK
BR	LOOP

FOUND:
CMP	RS,-(RP)	;EXACT FIT?
BEQ	EXIT		;YES
MOV	RS,RT		;NO
ADD	RP,RT		;RT -> LEFTOVERS
MOV	RT,(RQ)		;CHAIN TO PREVIOUS BLOCK
MOV	(RP)+,(RT)
SUB	RS,(RT)+	;SIZE OF LEFTOVERS
MOV	(RP),(RT)	;CHAIN TO REMAINDER OF LIST
TST	-(RP)		;BUMP BACK POINTER

EXIT:
MOV	RP,R0	;RETURN POINTER TO BLOCK
RTS	PC

NOGO:		;FAILURE
MOV	#10,-(SP)	;ERROR #10: NEW FAILURE
JSR	PC,P$HERR	;HEAP ERROR OUTPUT
CLR	R0		;IF RETURN, THEN RETURN
NEG	R0		;A NIL POINTER
RTS	PC
.PAGE
.SBTTL P$HFRE - PASCAL HEAP FREE ROUTINE
P$HFRE::
	;USES R0,R1,R4
		; R0 -> BLOCK TO BE FREED
		; R1 = SIZE OF BLOCK (WORDS)
		; R4 -> LEVEL 0 STACK FRAME
	; DESTROYS R0,R1,R2,R3,R4
	; REGISTER ALLOCATION
		RT=R1
		RP=R2
		RS=R3
		RQ=R4

MOV	R1,RS
BLE	EXITF	;IS SIZE <= 0, IGNORE
ROR	R1
ADC	RS
ASL	RS		;NO WORDS --> NO BYTES
MOV	-2(R4),RQ	;GET POINTER TO HEAPHEAD
		;LOOP TO FIND THE HEAP OF WHICH
LOOP1F:		;THIS BLOCK IS A MEMBER
BEQ	ERROR1
CMP	RQ,R0
BHI	NEXTHEAP
MOV	RQ,RT
ADD	(RQ),RT
CMP	R0,RT
BLO	THISHEAP
NEXTHEAP:
MOV	4(RQ),RQ	;CHAIN TO PREVIOUS HEAP
BR	LOOP1F

THISHEAP:
		;LOOP TO FIND WHERE THE FREED BLOCK
LOOP2F:		;FITS IN THIS FREELIST
TST	(RQ)+		;BUMP POINTER
MOV	(RQ),RP
BEQ	INSERT
CMP	RP,R0
BGE	PREFIX
MOV	(RP),RT
ADD	RP,RT
CMP	RT,R0
BLT	CHAINF		;DOES FREED BLOCK SUFFIX
ADD	R0,RS		;YES, CALCULATE NEW LENGTH
SUB	RP,RS		;FOR CURRENT BLOCK AND
MOV	RS,(RP)		;UPDATE IT.
MOV	RP,R0		;TREAT COMBINED BLOCK AS FREED BLOCK
CHAINF:
MOV	RP,RQ
BR	LOOP2F
		;CHECK TO SEE IF FREED BLOCK
PREFIX:		;PREFIXES TO CURRENT BLOCK
MOV	R0,RT
ADD	RS,RT
CMP	RT,RP
BLT	INSERT
MOV	RP,RS		;CALCULATE SIZE OF
ADD	(RP)+,RS	;COMBINED BLOCK
SUB	R0,RS
MOV	(RP),RP		;GET LINK TO NEXT BLOCK
		;INSERT THE FREED BLOCK
INSERT:		;INTO THE FREELIST
MOV	R0,(RQ)		;CHAIN BACK
MOV	RS,(R0)+	;MOVE IN SIZE
MOV	RP,(R0)		;AND LINK

EXITF:
RTS	PC

ERROR1:		;BLOCK TO BE FREED IS NOT IN THE
		;RANGE OF ANY HEAP
MOV	#11,-(SP)	;ERROR #11: FREE ERROR
JSR	PC,P$HERR	;HEAP ERROR OUTPUT
RTS	PC
.PAGE
.SBTTL P$HMAR - PASCAL HEAP MARK PROCEDURE
P$HMAR::
	;USES R4
		; R4 -> LEVEL 0 STACK FRAME
	; DESTROYS R0,R1,R2,R3
	; REGISTER ASSIGNMENT
		RS=R0
		RP=R1
		RQ=R2
		RT=R3

MOV	-2(R4),RQ	;GET POINTER TO HEAP HEAD
BEQ	ERRMAR
CLR	RT		;RT=0 => ADEQUATE BLOCK NOT FOUND
MOV	#12.,RS		;BLOCK SIZE MUST BE >= 12 BYTES
ADD	#2,RQ
		;LOOP TO FIND LARGEST BLOCK IN
LOOPM:		;THE CURRENT FREELIST
MOV	(RQ),RP
BEQ	ENDCHAIN
CMP	RS,(RP)+
BGE	SMALL
MOV	-2(RP),RS	;NEW "LARGEST" BLOCK, SAVE SIZE AND
MOV	RQ,RT		;POINTER TO PREVIOUS BLOCK
SMALL:
MOV	RP,RQ
BR	LOOPM
		;MAKE THE LARGEST BLOCK INTO A NEW
ENDCHAIN:	;HEAP WITH ONE BLOCK ON ITS FREELIST.
TST	RT
BEQ	ERRMAR		;NO SATISFACTORY BLOCK FOUND
MOV	(RT),RP		;RP -> DESIRED BLOCK (NEW HEAP)
MOV	RP,RQ
TST	(RQ)+
MOV	(RQ),(RT)	;UNLINK FROM FREE LIST
MOV	RP,(RQ)
ADD	#8.,(RQ)+	;POINTER TO NEW FREECHAIN
MOV	-2(R4),(RQ)+	;LINK TO PREVIOUS HEAP
MOV	RP,-2(R4)	;POINTER TO NEW (AND NOW CURRENT) HEAP
CLR	(RQ)+		;UNUSED WORD
MOV	(RP),(RQ)	;INITIALIZE THE ONE FREE BLOCK
SUB	#8.,(RQ)+	;SIZE
CLR	(RQ)		;AND NULL LINK

EXITM:
RTS	PC

ERRMAR:		;MARK ERROR
MOV	#12,-(SP)	;ERROR #12: MARK ERROR
JSR	PC,P$HERR	;HEAP ERROR OUTPUT
RTS	PC
.PAGE
.SBTTL P$HREL - PASCAL HEAP RELEASE PROCEDURE
P$HREL::
	;USES R4
		; R4 -> LEVEL 0 STACK FRAME
	; DESTROYS R0,R1
	; REGISTER ASSIGNMENT
		RQ=R0
		RS=R1

MOV	-2(R4),RQ	;GET POINTER TO HEAP TO BE RELEASED
BEQ	EXITR
MOV	4(RQ),-2(R4)	;MAKE PREVIOUS HEAP THE CURRENT ONE
MOV	(RQ),RS		;SIZE
ASR	RS		;BYTES --> WORDS
JSR	PC,P$HFRE	;ADD TO FREE CHAIN

EXITR:
RTS	PC
.PAGE
.SBTTL P$HERR - PASCAL HEAP ERROR OUTPUT
P$HERR::
MOV	2(SP),R0
IOT		;JUST ABORT THE TURKEY
.END