perm filename GEOMEM[GEM,BGB] blob
sn#019094 filedate 1973-03-25 generic text, type T, neo UTF8
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