TITLE MODIFIED AFREE FOR MUDDLE

RELOCATABLE

.INSRT MUDDLE >

.GLOBAL CAFREE,CAFRET,PARNEW,AGC,PARBOT,CODTOP,CAFRE1
.GLOBAL STOGC,STOSTR,CAFRE,ISTOST,STOLST,SAT,ICONS,BYTDOP
.GLOBAL FLIST,STORIC,GPURFL,GCDANG,PVSTOR,SPSTOR
.GLOBAL %CLNCO

MFUNCTION FREEZE,SUBR

	ENTRY	1

	GETYP	A,(AB)		; get type of it
	PUSH	TP,(AB)		; save a copy
	PUSH	TP,1(AB)
	PUSH	P,[0]		; flag for tupel freeze
	PUSHJ	P,SAT		; to SAT
	MOVEI	B,0		; final type
	CAIN	A,SNWORD	; check valid types
	MOVSI	B,TUVEC		; use UVECTOR
	CAIN	A,S2NWOR
	MOVSI	B,TVEC
	CAIN	A,SARGS
	MOVSI	B,TVEC
	CAIN	A,SCHSTR
	MOVSI	B,TCHSTR
	CAIN	A,SBYTE
	MOVEI	B,TBYTE
	JUMPE	B,WTYP1
	PUSH	P,B		; save final type
	CAMN	B,$TBYTE
	JRST	.+3
	CAME	B,$TCHSTR	; special chars hack
	JRST	OK.FR
	HRR	B,(AB)		; fixup count
	MOVEM	B,(P)

	MOVEI	C,(TB)		; point to it
	PUSHJ	P,BYTDOP	; A==> points to dope word
	HRRO	B,1(TB)
	SUBI	A,1(B)		; A==> length of block
	TLC	B,-1(A)
	MOVEM	B,1(TB)		; and save
	MOVSI	0,TUVEC
	MOVEM	0,(TB)

OK.FR:	HLRE	A,1(TB)		; get length
	MOVNS	A
	PUSH	P,A
	ADDI	A,2
	PUSHJ	P,CAFREE	; get storage
	HRLZ	B,1(TB)		; set up to BLT
	HRRI	B,(A)
	POP	P,C
	ADDI	C,(A)		; compute end
	BLT	B,(C)
	HLLOS	1(C)		; INDICATION IN RELOCATION FIELD THAT ITS NOT GARBAGE
	MOVEI	B,(A)
	HLL	B,1(AB)
	POP	P,A
	JRST	FINIS

		
CAFRE:	PUSH	P,A
	HRRZ	E,STOLST+1
	SETZB	C,D
	PUSHJ	P,ICONS		; get list element
	PUSH	TP,$TLIST	; and save
	PUSH	TP,B
	MOVE	A,(P)		; restore length
	ADDI	A,2		; 2 more for dope words
	PUSHJ	P,CAFREE	; get the core and dope words
	POP	P,B		; restore count
	MOVNS	B		; build AOBJN pointer
	MOVSI	B,(B)
	HRRI	B,(A)
	MOVE	C,(TP)
	MOVEM	B,1(C)		; save on list
	MOVSI	0,TSTORA	; and type
	HLLM	0,(C)
	HRRZM	C,STOLST+1	; and save as new list
	SUB	TP,[2,,2]
	POPJ	P,
	
CAFRE1:	PUSH	P,A
	ADDI	A,2
	PUSHJ	P,CAFREE
	HRROI	B,(A)		; pointer to B
	POP	P,A		; length back
	TLC	B,-1(A)
	POPJ	P,

CAFREE:	IRP	AC,,[B,C,D,E]
	PUSH	P,AC
	TERMIN
	SKIPG	A		; make sure arg is a winner
	FATAL BAD CALL TO CAFREE
	MOVSI	A,(A)		; count to left half for search
	MOVEI	B,FLIST		; get first pointer
	HRRZ	C,(B)		; c points to next block
CLOOP:	CAMG	A,(C)		; skip if not big enough
	JRST	CONLIS		; found one
	MOVEI	D,(B)		; save in case fall out
	MOVEI	B,(C)		; point to new previous
	HRRZ	C,(C)		; next block
	JUMPN	C,CLOOP		; go on through loop
	HLRZ	E,A		; count to E
	CAMGE	E,STORIC	; skip if a area or more
	MOVE	E,STORIC	; else use a whole area
	MOVE	C,PARBOT	; found out if any funny space
	SUB	C,CODTOP	; amount around to C
	EXCH	B,D
	CAMLE	C,E		; skip if must GC
	JRST	CHAVIT		; already have it
	SUBI	E,-1(C)		; get needed from agc
	MOVEM	E,PARNEW	; funny arg to AGC
	PUSH	P,A
	MOVE	C,[7,,6]	; SET UP AGC INDICATORS
	SKIPE	GPURFL		; DONT GC IF IN DUMPER
	JRST	PURGC
	PUSHJ	P,AGC		; collect that garbage
	SETZM	PARNEW		; dont do it again
	POP	P,A

; Make sure pointers still good after GC

	MOVEI	B,FLIST
	HRRZ	D,(B)

	HRRZ	E,(D)		; next pointer
	JUMPE	E,.+4		; end of list ok
	MOVEI	B,(D)
	MOVEI	D,(E)
	JRST	.-4		; look at next

CHAVIT:	MOVE	C,CODTOP
	MOVE	E,PARBOT
	PUSHJ	P,%CLNCO	; flush extra pages
       	MOVE	E,PARBOT	; find amount obtained
	SUBI	E,1		; dont use a real pair
	MOVEI	C,(E)		; for reset of CODTOP
	SUB	E,CODTOP
	EXCH	C,CODTOP	; store it back
	CAIE	B,(C)		; did we simply grow the last block?
	JRST	CSPLIC		; no, splice it in
	HLRZ	C,(B)		; length of old guy
	ADDI	C,(E)		; total length
	ADDI	B,(E)		; point to new last dope word
	HRLZM	C,(B)		; clobber final length in
	HRRM	B,(D)		; and splice into free list
	MOVEI	C,(B)		; reset acs for reentry into loop
	MOVEI	B,(D)
	JRST	CLOOP

; Here to splice new core onto end of list.

CSPLIC:	MOVE	C,CODTOP	; point to end of new block
	HRLZM	E,(C)		; store length of new block in dope words
	HRRM	C,(D)		; D is old previous, link it up
	MOVEI	B,(D)		; and reset B for reentry into loop
	JRST	CLOOP

; here if an appropriate block is on the list

CONLIS:	HLRZS	A		; count back to a rh
	HLRZ	D,(C)		; length of proposed block to D
	CAIN	A,(D)		; skip if they are different
	JRST	CEASY		; just splice it out
	MOVEI	B,(C)		; point to block to be chopped up
	SUBI	B,-1(D)		; point to beginning of same
	SUBI	D,(A)		; amount of block to be left to D
	HRLM	D,(C)		; and fix up dope words
	ADDI	B,-1(A)		; point to end of same
	HRLZM	A,(B)
	HRRM	B,(B)		; for GC benefit

CFREET:	CAIE	A,1		; if more than 1
	SETZM	-1(B)		; make tasteful dope worda
	SUBI	B,-1(A)
	MOVEI	A,(B)
ACRST:	IRP	AC,,[E,D,C,B]
	POP	P,AC
	TERMIN
	POPJ	P,

PURGC:	SUB	P,[1,,1]	; CLEAN OFF STACK
	SETOM	GCDANG		; INDICATE GC SHOULD HAVE OCCURED
	JRST	ACRST

CEASY:	MOVEI	D,(C)		; point to block to return
	HRRZ	C,(C)		; point to next of same
	HRRM	C,(B)		; smash its previous
	MOVEI	B,(D)		; point to block with B
	HRRM	B,(B)		; for GC benefit
	JRST	CFREET

CAFRET:	HRROI	B,(B)		; prepare to search list
	TLC	B,-1(A)		; by making an AOBJN pointer
	HRRZ	C,STOLST+1	; start of list
	MOVEI	D,STOLST+1

CAFRTL:	JUMPE	C,CPOPJ		; not founc
	CAME	B,1(C)		; this it?
	JRST	CAFRT1
	HRRZ	C,(C)		; yes splice it out
	HRRM	C,(D)		; smash it
CPOPJ:	POPJ	P,		; dont do anything now

CAFRT1:	MOVEI	D,(C)
	HRRZ	C,(C)
	JRST	CAFRTL

; Here from GC to collect all unused blocks into free list

STOGC:	SETZB	C,E		; zero current length and pointer
	MOVE	A,CODTOP	; get high end of free space

STOGCL:	CAIG	A,STOSTR	; end?
	JRST	STOGCE		; yes, cleanup and leave

	HLRZ	0,(A)		; get length
	ANDI	0,377777
	SKIPGE	(A)		; skip if a not used block
	JRST	STOGC1		; jump if marked

; HERE TO SEE WHETHER AN UNMARKED ITEM IS AN ATOM. IF IT IS IT IS NOT GARBAGE
; AND IT IS PRESERVED WITH ITS VALUE CELLS FLUSHED

	HLRZ	0,-1(A)		; GET TYPE OF FIRST D.W.
	ANDI	0,TYPMSK	; FLUSH MONITORS
	CAIE	0,SATOM
	JRST	STOGC5		; NOT AN ATOM COLLECT THE GARBAGE
	PUSH	P,A		; SAVE PTR TO D.W.
	HLRZ	0,(A)
	SUB	A,0		; POINT TO JUST BEFORE ATOM
	SETZM	1(A)		; ZERO VALUE CELLS
	SETZM	2(A)
	POP	P,A		; RESTORE A
	JRST	STOGC1

STOGC5:	HLRZ	0,(A)
	JUMPE	C,STOGC3	; jump if no block under construction
	ADD	C,0		; else add this length to current
	JRST	STOGC4

STOGC3:	MOVEI	B,(A)		; save pointer
	MOVE	C,0		; init length

STOGC4:	SUB	A,0		; point to next block
	JRST	STOGCL

STOGC1:	HLLOS	(A)		; -1 IS INDICATOR OF FREE SLOT
	ANDCAM	D,(A)		; kill mark bit
	JUMPE	C,STOGC4	; if no block under cons, dont fix
	HRLM	C,(B)		; store total block length
	HRRM	E,(B)		; next pointer hooked in
	MOVEI	E,(B)		; new next pointer
	MOVEI	C,0
	JRST	STOGC4

STOGCE:	JUMPE	C,STGCE1	; jump if no current block
	HRLM	C,(B)		; smash in count
	HRRM	E,(B)		; smash in next pointer
	MOVEI	E,(B)		; and setup E

STGCE1:	HRRZM	E,FLIST+1	; final link up
	POPJ	P,

IMPURE

FLIST:	.+1
	ISTOST

PURE

END