00100	TITLE GEOMEM - FREE STORAGE & NODE/LINK ROUTINES - AUGUST 1972.
00200	COMMENT /  ...in particular, chapter II of Knuth.
00300	
00400	/
00500	;DYNAMIC FREE STORAGE ROUTINES.
00700		NIL←777777
00800		INTERN CORSIZ↔CORSIZ: 0
00900		SAVP1: .+1
01000		AVAIL: NIL
01100	; ADDR ← GETBLK(SIZE);
01200	SUBR GETBLK;(SIZE)
01300	BEGIN	GETBLK
01400		ACCUMULATORS{PTR,SIZ,P1,P2,N}
01500		SAVAC(6)
01600	
01700	; FETCH THE ARGUMENTS.
01800		LAC N,ARG1↔ADDM N,CORSIZ
01900		LAC P1,SAVP1
02000	
02100	; SCAN AVAIL LIST.
02200	L1:	CDR P2,(P1);
02300		CAIN P2,NIL;
02400	
02500	; WHEN THERE'S NO ROOM, GET A BIG BLOCK FROM SAIL.
02600		GO[NIM SIZ,=4090
02700		GO[FATAL(GETBLK)];
02800		DIP SIZ,(PTR)
02900		CALL RELBLK,PTR;
03000		LACI P1,AVAIL↔LAC N,ARG1↔GO L1]
03100	
03200	; IS THIS ONE BIG ENUF ?
03300		CAR SIZ,(P2)
03400		CAMGE SIZ,N
03500		GO[LAC P1,P2↔GO L1]
03600	
03700	; CARVE N WORDS OFF THE TOP.
03800		SUB SIZ,N
03900		JUMPE SIZ,[CDR(P2)↔DAP(P1)↔LACI P1,AVAIL↔GO L2];ALL USED UP.
04000		DIP SIZ,(P2)
04100	L2:	ADD SIZ, P2
04200		SETZM (SIZ)
04300		LAC 1,SIZ↔GETAC(6)↔POP1J
04400		LIT
04500	BEND
     

00100	;RELEASE A BLOCK  -  RELBLK(E)  -  E/ SIZE,,0
00200	SUBR RELBLK;(ADDR)
00300	BEGIN	RELBLK
00400		ACCUMULATORS{E,SIZ,P1,P2}
00500	; FETCH ARGUMENTS AND CLEAR THE BLOCK.
00600		CDR E,ARG1↔CAR SIZ,(E)
00700		CAIGE SIZ,=4000↔GO[
00800		MOVNS SIZ↔ADDM SIZ,CORSIZ↔MOVNS SIZ↔GO .+1]
00900		SETZM 1(E)↔CAIE SIZ,1↔GO[
01000		LAC E↔HRL E↔ADD [XWD 1,2]
01100		LAC 1,SIZ↔ADD 1,E↔BLT -1(1)↔GO .+1]
01200	
01300	; FIND BLOCK'S PLACE IN AVAIL.
01400		LACI P1,AVAIL
01500	L3:	CDR P2,(P1)
01600		CAMG P2,E
01700		GO [LAC P1,P2↔ GO L3]
01800	
01900	; TRY TO MERGE WITH THE BLOCK ABOVE.
02000		LAC E↔ ADD SIZ↔ CAME P2;
02100		GO [DAP P2,(E)↔ GO L4];	NO MERGE - SO ME POINT AT HIM.
02200	
02300	; MERGE WITH BLOCK ABOVE.
02400		CAR(P2)↔ADD SIZ,;	ME BIGGER NOW.
02500		CDR(P2)↔DAP (E) ;	ME POINT WHERE HE POINTS.
02600		SETZM(P2)
02700	
02800	; TRY TO MERGE WITH THE BLOCK BELOW.
02900	L4:	CAR(P1)↔ADD P1↔CAME E;
03000		GO[DAP E,(P1)↔DIP SIZ,(E)↔GO L5]
03100	
03200	; MERGE WITH BLOCK BELOW.
03300		CAR(P1)↔ADD SIZ↔DIP (P1);	HIM BIGGER NOW.
03400		CDR(E)↔DAP(P1);			HIM POINT WHERE I POINT.
03500		SETZM(E)
03600	
03700	L5:	POP1J
03800		LIT
03900	BEND
     

00100	;RINGIN(E,R,N) - RING IN E JUST LEFT OF R AT Nth WORD.
00200	SUBR RINGIN
00300	BEGIN RINGIN
00400		ACCUMULATORS{Q,E,R}
00500		CDR E,ARG3
00600		CDR R,ARG2
00700		LAC ARG1
00800		DAP .+1↔CDR Q,(E)↔JUMPE Q,L
00900		CAME Q,E↔POP3J; E AIN'T EMPTY.
01000	L:	DAP .+1↔CAR Q,(R)
01100		DAP .+1↔DAP E,(Q)
01200		DAP .+1↔DIP E,(R)
01300		DAP .+1↔DIP Q,(E)
01400		DAP .+1↔DAP R,(E)
01500		POP3J
01600	BEND
01700	
01800	;RINGO(E,N) - RING OUT E AT Nth WORD - LEAVE E LEGALLY EMPTY.
01900	SUBR RINGO
02000	BEGIN RINGO
02100		ACCUMULATORS{Q,E,R}
02200		CDR ARG1↔CDR E,ARG2
02300		DAP .+1↔CAR Q,(E)↔JUMPE Q,L
02400		DAP .+1↔CDR R,(E)
02500		DAP .+1↔DAP R,(Q)
02600		DAP .+1↔DIP Q,(R)
02700	L:	HRL E,E
02800		DAP .+1↔DAC E,(E)
02900		POP2J
03000	BEND
03100	
03200	;EMPTY(E,N) - RETURNS TRUE WHEN RING IS EMPTY.
03300	SUBR(EMPTY)
03400	BEGIN EMPTY
03500		CDR ARG1
03600		CDR 1,ARG2
03700		DAP .+1↔CDR (1)
03800		SKIPN↔POP2J
03900		CAME 1↔SETZ 1,↔POP2J
04000	BEND
04100	
04200	;BLIT(TO,FROM,SIZE)
04300	SUBR(BLIT)
04400	BEGIN	BLIT
04500		CDR ARG3↔LAC 1,
04600		HRL ARG2↔ADD 1,ARG1
04700		BLT -1(1)↔POP3J
04800	BEND
04900	END