COMMENT ⊗   VALID 00020 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00003 00002	 FANCY SMALL SPACE SERVICE 
C00011 00003	 SPECIAL FIXED SIZE BLOCK HANDLERS: $FXGET, $FXDEL
C00020 00004	 SAIREC -- SYSTEM RECORD HANDLER ROUTINES
C00024 00005	 GETSTR, STRINIT, RELSTR, RSGC
C00026 00006	 RECORD STRING SUBFIELD GARBAGE COLLECTION
C00029 00007	 SAIREC -- $REC$ AND $RECFN
C00037 00008	 SAIREC -- $RCINI 
C00043 00009	 SAIREC -- FLDKIL ROUTINE
C00048 00010	 SAIREC (RECGC) -- $ENQR,ENQRB,ENQRBB,PAMRK
C00051 00011	 SAIREC (RECGC) -- %PSMRR
C00053 00012	 SAIREC (RECGC) -- RCIMRK 
C00055 00013	 SAIREC (RECGC) -- $MRK.1, $MFLDS
C00058 00_β	P%α≤
&J⊗~↓"J⊗≤:
%↓ji↓∩J<~6,4T→AAA+I↓AAβ	T%α≤
&J⊗~↓"J⊗≤:
%↓ji↓∩J<~N\4T→AAA3⊃↓AAβ	X%α≤
&J⊗~↓"J⊗≤:
%↓jiα6εLqαJ>-"&:∀hR
AAβ1Q↓Aβ↓E\%¬~ε&J,→↓"J,~≡
%αi5↓∩k
~2⊂hR
AAβ1Y↓Aβ↓E`%¬~ε&J,→↓55α"J
∩,a4*≠↓AA]α↓AAAH%αNJJ⊗
αi5↓∩∀∩≡⊗Qh*
Aβ↓]M↓β↓AI@L∩⊗:⊃¬∩⊗∞>∀ 4*
β↓A]U∧*:∩6Xh*YXh(1mm∧2ε:∞JαN6εdaαNB~∃αN-∩Z&∞*4*∞|jB&1E~B
1ba112%*66f4zJ≡∩≤~&NMHh(4*$*~&:*αNB∞LrM↓q$2V:2Za∩~b∀b⊃1∩5B≡⊗Qb"~b≥b"~b∩,a1∩~D!x4(hP4(4T_α>6BEA"NB~aq∩≡-"	1∩<*QF	b"∩⊗2∩a∩∩⊗c
	1∩5~ε∩⊃b"~N&u→1∩~≤J:%2≥α∞&:≠p4(%cb≡>≡$
	2a∪⊃2aM~b∞>J<*Q2∞⎇∩J⊗1ph(%1e~6ε2bαNBε≤)αN⊗∃2&∞∃¬∩>VRLr⊗Mybb"&&5α>N&∩H4(4T∩⊗≡&rαNB∞≤*I↓5jαN6εdaα~J,)α
2|~-αN-∩Z&∞(h(4*%~∞I↓$:⊗R	b"∩⊗2∩a∩≡⊗#
	1∩$*1F	b"~Nε$!1∩~≤J:M1$2V:2Xh(4*&C↔O∃π∪?WSNs↔Mβ∂∪∃β∨.s↔KπfceβW≡+≠W1ε3?IβF;∪3Ns≥βπfc?∂π&K?9β}1βO7∞c04+⊗c?∂/~β?→β∨#?Kπ>)9↓α/≠O↔;&Kπ33JaβS#/∪∃β'~β¬β3Ns/↔⊃εc'OQαC#?7.!βπPhQ∩~NdJM!s>{∨Sπ∪q%↓%ε{→βf{∂/Mbβ↔π∂Bβ?→β>C'∂!π≠C↔∂N3'↔Mε	↓Oε∂∃	ph(4(KcCK↔2β?9β≡Cπ'9ra1s;/CQβ?rβ∂#πNqx4(Kcπ∪∪∩β?→↓⊗33?≡S∃	π∪?WSNs∃x4PIsπ∪'⊃β?→α∪∪↔πfc?∂π&)	βK␈+S';+p4(%b↓999εk'O∂.c3π;.{WMβNs≠=↓rq9↓xhP$%↓α↓↓↓hhP%q↓rq9β7O≠∂↔3f;↔?/→β';6y↓99r↓x4(hR↔π∂Bβπ33}≠πS∃π∪?WSNs∃β'~βπOO.k↔⊃β&yβSπ↑)βπMπβπKπn+S↔K≠P4(4PJ¬↓5jβC?'w#↔Iβ&yβS#*βOCπ≡)β∪↔≡≠K'C&{Iβf{∂,4PJ
↓5jβO'k*β?→β⊗+GW↔∨ 4(4W∪↔OWg#Mh4PKO/'αβK↔S/∪9↓5jα	βC}K;SMπ#=β¬ε3K↔OBβ3?≡Yβ?→π##∃β≡{KK↔∨!βO'V(4('vyβO/O↓βK↔'+K9↓jiβ≠πNcWK∀hP4*↔∞≠!β∪.33?≡S∃β⊗{WS'v)β'MεOOWn+⊃βSzβSπ/*βπMβεKπ7/#↔KMPh(4(L	↓55πβ?';&+IβSzβS#∃π≠Cπ∂*β∪↔O∨∪'CS␈⊃β3}≠,4(L⊃↓55πβ?';&+IβSzβ3?≡YβS=ε∪∃βK.c↔πO. 4(4W∪↔OWg#Mh4PKO/'αβK↔S/∪9↓5jβS#∃ε∪3?∂ZβK↔3.O∃β>MβO.≠∂↔O≡3W04PK;=β≡['Aβ⊗+SWKr↓55β⊗c?∂-π∪↔3↔∂≠∃β←∂→βW;∨+∂∂↔∨≠≠W0hP4*↔F≠↔CQεMβO&S↔⊃ε?[*aβS#*βK?W&K;↔MεK∃β∂≠OW7.!βS=εCπ[∃εs=βON#∃β↔63↔∂S~p4)#/C∂↔C"βC?O≡K3eπ#=β3}⊃αV≤*Iβ←O#!α≡|:Rε	Jp4(4R"≡⊗Q⊃βπ∂'→β+W∨!β3'↑)βπ9ε33?≡S∃β⊗{WS'v)1β↔F≠↔CQπ##πQεKQβS∞[↔M↓FK9α¬Hh('¬πβ?';&+IβSzβS#∃ε3'KO"β3?≡Yβ'9ε	β←#}c∃β3O≠Qβ?2βK?W&K;↔LhP'π;"βK↔S/∪;Mβ∂→β'S~β[π3.)↓#'rα¬%β
βC?'w#↔Iβ&yβS#*β∪↔O∨∪'CS␈⊂4('⊗c?∂-ε{→βSF)β3π∨!βπ3f{∂πS*βK?W&K;∃β≡33↔"p4(4R"∩⊗1⊃βπ∂'→β3'↑)β¬β&+π33}≠πS∃π∪?WSNs∃β↔F≠↔CQπ##πQεKQβS∞[↔M↓FK9α¬Hh('¬πβ?';&+IβSzβS#∃ε3'KO"β3?≡Yβ'9ε	β←#}c∃β3O≠Qβ?2βK?W&K;↔LhP'π;"βK↔S/∪;Mβ∂→β'S~β[π3.)↓#'rα¬%β
βC?'w#↔Iβ&yβS#*β∪↔O∨∪'CS␈⊂4('⊗c?∂-ε{→βSF)β3π∨!β∪↔∞c3?∂∂#∃βK␈+S';*β∂π3f+⊃84Ph*NεLaβ∂πfc';≥π≠↔GW.s∂∃β⊗{WS'v+MβSFQβ∂'⊃β∪?>q↓∩~∀*2&MPh(4)f∪3?∂[r⎇∩≡-"	#OOS∃%↓←∪↔SW⊗sM↓AεK→β3␈≠∀4)g∪↔OWg!z⎇∩$*2	#⊗c?∂/N!%↓o⊗+SWKw→↓AβN1β3?≡)1βOε∂∃βN!β'→π;'84Ph)∩~≤b&Mβ≡+K['≡)βK?/#';↔~↓#7Wv≠!αV≤*I2R,jA22¬~¬%hhP4)∩5~ε∩⊃Cc∪∂O∩β3?≡Yy%↓Zβπ∪∪~β;π7.!β3}≠-βSz↓∩~NdJL4)$2N&:~B↓s3O≠Qβ?>s↔Iycc3?≡Yβπ∪'⊃y%↓↑∪∪Mεsπ7↔"β3?≡YβS=εsπ7↔"β3'O"↓#πQεC↔π⊃Hh)∩~,r2-!f#O∂Iε∪3?∂[q%↓mπ∪↔7?6+Mβ;∞k↔⊃β⊗c?∂-ε3K?5ε;eβfKOP4Ph(X4Ph)⊗≡¬∩>
α⎇y↓D%\:⊗RRLr≥αB∀z4),"BJ>~α}⎇↓⊂In∩⊗d*R&::αBJ>_h)⊗~5∩baα⎇y↓L%\J:∩⊗Bα>→α4JJNQ∧2J⊗∃∧b>∞ε$J>84Ph*"⊗∀)!∩≡-"	$4PJ6>Z(J
15
BA$$KZ≡⊗Q¬~&j∀hP&6>4(&VN-⊃2≡>="ελ%Xh(&N\JB∀&
a∩~NdJM"V≤*I$4PJBVNDP&A1$:⊗QF⊂In∞∩∩α∩>↑rα2&N h(&R%R∧&¬dλ$%ntyα*>Hh(&6⎇2∀&¬d⊂$%n$B∃αJ-~V2PhRJ⊗Q∪⊃h&N,⊂&A2C⊃H4(LRJNPL↓I"AHH%nJ-"VJ8hP4*"-∩∃!∩$*2	$hP&6>4(&	1k	"A$HInR"*α
2>≤X4(&lzZ∀&-~⊗I2<z≡Rε⊂h(&N\JB∀&
a∩~NdJM"V≤*I$4PJBVNDP&A1$"⊗1F⊂h(&6⎇2⊗$&
a@4(LRJNPM∩⊗QI⊂h(4*<*QF	P&"J∃P&¬1D	$$%]αεJQ∧z→αRD)↓∩≡-!F	αdz>@4TB⊗J∃B"≡⊗Q⊃$4(LRV6B(J¬2∞∧zB($KZ∞"⊗≤Yα:Vdb&RV$(4(&¬*N"(M↓2↓⊗=αJ>
D	$%n≤
21α$B∃αJ⎇*R&:(h(&*∃~P&≡-!F	DHIn2>⎇↓α>9¬"=α:-BQ1α$B&Mα|r∃α2⎇~P4*≥α>B)P&ε>_I"A$HInN.M↓αJ⊗%*J9αL1α↑&ph*∞B⎇α)h&∧zB(&α`$%n∀*RVJph(4*$*1F	P&"J∃P&¬1D	$$%]~ε6∃∧Z2V≡(h*"⊗∀)!∩∩,aF	$HH4(&U*6B∀L	2∞B⎇α($%Xh(&B-~"(&αb↓⊗∩¬∩>
"
H%nεdb>∞ε$)αJ>-"&:∀hP&*J≥ &∩⊗c
	D$KZ2>N"aαRJJα:⊗b h(&*∃~P&∞∧zB)DHIn↑&ph(4*D*J∃!$2Nε∩"H$%ndJ:.M∧J9α>t)α
2|~,4(Lj>Z∀M*N⊗Id:>≡R⊂4(&lzZ⊗$LbBN¬b"~N2M→"VN-⊃$4(MαVN M↓22B≤λ$%n$B&MαM→αR"*α>↑:-⊂4(&¬*N &αa5I"αH$%n$B∃αJ,~>J⊃¬"=αε$ 4(&¬*N"(M↓1∩~≤J:L%\~ε21∧J:N⊗∃!αJ>-"&:∀hP&*J≥ &J⊗#⊃H$%\:=αJ-"VJ8hP4*"-∩∃!∩5*:2-Hh(&6⎇2∀&2¬~¬15
BA$%]""∃α∀b>∞-¬:∃αε∀)αR=¬*:2&tX4(&lzZ∀&$*6A1DbBN¬HInR"*α2⊗~"a2J&<BP4(M"J:∀M"⊗6AbiD$%\J→α"
2∃ᬬ∩&≡""α"ε: h(&"db4&R,jA1"$*6A$KZ2⊗Q∧B&5αDz2⊃αmIα2⊗5 4(&lzZNLM"⊗6@HInN↑
↓α"εe2⊗L4PJ"2JhJR⊗6αa"R⊗m↓$%nd*Qα"Liα">d!α6e¬∩&≡" h(&*∃~P&J-!IH$KZ∩>:(h(4*D*J∃!$2N&:~H$%lhP&"J∃P&R⊗m↓15EE↓$%n$B∃αRDJ:≥α$yα&:≤*JP4PJ"JJPJ2BN
a5I"αH%nε$"J⊗N~α>→α⎇::⊗I∧~⊗20hP&"Jdh&2B≤	1"R,jA$%]∩⊗6⊗l∩⊗Iα
→α
ε≤YαB>LrR⊗HhP&⊗b≤@&2B≤	1"2¬~¬$%\bBN¬∧JMα:⎇9α~↑"αBRHhP&RJt(&2B≤	15DHIn↑ε~αR"∃∧~"ε&rα:V2cx4(&E∩24&$*6A1DbBN¬HIn:=∧B∃α≡-"Mα¬∧∩ε∞-¬αRIα$z<4(LBJJ4LbBN¬bBR⊗6αH%n>d!α"⊗!α&M∧r⊗]α∀J≡"Q∧∩J>RD*H4*∀*QMMPJNVλM↓2aM_H%nJ-"VJ8hP&*J≥ &↓ME↓$$%Xh(4*tz2>]β`4*:⎇*A↓phRJ⊗9β`4(&-~∀4)sZJ⊗8hR~N%PI@4(J"~N&tH4(%h(&2Lr,%⊗Lr2:-d2N$4U∩⊗9↓`h(&V≤)α"&<BL4)sZJ⊗8hQyn:⎇*@4)sZ:>2⎇84(4TB⊗J∃B"~N&tI$4(M~.&BpJVN⊗∩b≡>≡$
λ4(L*JH%b"~N&tIα∞εdb⊗⊃α:z=α≡|:Rε	∧J:&RL
2&j,!x4(M~.&B(I∩~NdJM"V≤*I$4PJ⊗JHKa∩~NLr%α∞b2⊗⊃¬:&R!¬""&:=→α>9α"~N2M→y1DhP&6>4*$&
c_%n*-~Qα¬∧b&RRd)α
2|~,4(MαVN"PJA2∞⎇∩≡⊗PhP&⊗J⊂Ir∞>∀:⊗Qα$J∩9≡"α≡&Z*α6∃αrey1λh(&"∃∩j4&∩a∩~NdJM"V≤*I$4PJ"J2TH&
1$2N2&~BVN⊗∩H4(&lzZ⊗4L→1"	Hh(&6⎇2⊗$&~b∞>J<*P4(Lj>Z⊗hJ
1⊗=αJ>
D⊃$4(Lj>Z⊗HJ
2n¬*N")¬↓2∞>∃∩⊗04PH%↓↓∧
>M"αH4($J↓↓αB⎇α)αA`h($%ααt4(Lj>Z⊗hJ
1⊗%αJ>
D⊃$4(Mα>B(M↓04(;; SPECIAL FIXED SIZE BLOCK HANDLERS: $FXGET, $FXDEL

DSCR $FXG,$FXD,$FXGET,$FXDEL,$FXSPC,$FXBLD

DES These routines operate on space descriptor blocks of the form:

word 0:	left,,right
	$FXG
	$FXD
blksiz:	block size
minsiz: minimum size request to honor
blkcnt: number of blocks per space
usecnt:	number of blocks allocated from this space
maxadr: address of last record in this space
frelis:	free list of blocks
sublis:	a list header word for other blocks with this format
firblk: ... first "data word" in the space ...
	:
	< blkcnt*blksiz +firblk words of corget space >
	:

Note: 	the "top" such block (Ie the one on the $FSLIS) will usually
	contain the routines $FXGET & $FXREL & will have actually no
	blocks (ie frelis=0).  They will mapcar down their subordinates
	looking for customers.  The subordinates ($FXG & $FXD) will
	work by having brothers.  If a $FXG block gets bloated, it
	will just fail.  If one goes empty, it will just go away.
	If all of a $FXGET block's subordinates lose, it just adds a 
	new one as the left subchild.

A space descriptor block ($FXGET style) may be built by the runtime routine

<block> ← $FXSPC(<block size>,<min size>,<block count>)

Thus a new space for allocating blocks of size 9 to 16 could be
defined & added to $FSLIS by the statement

	$FSADD($FXSPC(16,9,32)); ! 32 blocks per buffer;

The routine $FXBLD(@<chain header>,<template block>) makes a fresh
block patterned after the template & puts it on the named chain.

⊗
%FXIX ←← %FFRXX	;FIRST LEGAL FIELD
DEFINE $FXFLD(ID) <
	ID ←← %FXIX
	%FXIX ←← %FXIX+1
>
$FXFLD	%BLKSIZ	;BLOCK SIZE
$FXFLD	%MINSIZ	;MIN ACCEPTABLE SIZE
$FXFLD	%BLKCNT	;NUMBER OF BLOCKS PER SPACE
$FXFLD	%USECNT	;NUMBER OF BLOCKS ALLOCATED FROM THIS SPACE
$FXFLD	%MAXADR	;MAX ADDRESS OF A BLOCK IN THIS SPACE
$FXFLD	%FRELIS	;FREE LIST
$FXFLD	%SUBLIS	;SUBLIST OF SIMILAR BLOCKS
$FXFLD	%FIRBLK	;FIRST DATA WORD

HERE($FXGET)

	CAMG	C,%BLKSIZ(A)	;WOULD IT FIT
	CAMGE	C,%MINSIZ(A)	;
	POPJ	P,		;NO
	PUSH	P,A		;YEP GO DOWN KINDERN
FGTRY:	SKIPE	A,%SUBLIS(A)	;IF ANY
	PUSHJ	P,$GET1B	;
	JRST	ADDAB		;ADD A BLOCK
FGWIN:	POP	P,A		;I AM SUCH A WINNER
	JRST	CPOPJ1		;& GO WIN
;#  # RHT ! I HAD LEFT OUT THE RESTORE OF A
ADDAB:	MOVE	A,(P)		;SINCE A IS ZERO AT THIS POINT
	MOVEI	B,%SUBLIS(A)	;OWNER OF NEW LIST

	PUSH	P,B		;BUILD CALL TO $FXBLD
	PUSH	P,-1(P)		;PUSH A COPY OF A
	PUSHJ	P,$FXBLD	;MAKES A NEW SPACE FOR $FXG

	MOVE	A,(P)		;WHERE WE HAD SAVED IT
	JRST	FGTRY		;GO TRY AGAIN -- EXPECT TO WIN

HERE($FXG)
	CAMG	C,%BLKSIZ(A)	;WOULD IT FIT?
	CAMGE	C,%MINSIZ(A)	;
	POPJ	P,		;NO WAY
	SKIPN	B,%FRELIS(A)	;ONE ON FREE LIST
	POPJ	P,		;NO SUCH LUCK
	AOS	%USECNT(A)	;ONE LESS FREE NOW
	PUSH	P,(B)		;KLUGY WAY TO COPY FREE LIST
	POP	P,%FRELIS(A)	;PUTS BACK THE NEXT ONE
	JRST	CPOPJ1		;GO SKIP RETURN -- WE WIN

HERE($FXDEL)		
	PUSH	P,A		;IN THIS CASE, JUST GO DOWN CHILDREN
	SKIPE	A,%SUBLIS(A)	;
	PUSHJ	P,$DEL1B	;LIKE SO
	SOS	-1(P)		;WILL NA SKIP RETURN
	POP	P,A		;GET OWN NAME BACK
	JRST	CPOPJ1		;I AM A WINNER

HERE($FXD)		
	CAMG	B,%MAXADR(A)	;IN RANGE?
	CAIG	B,(A)		;A IS MY OWN POINTER,REMEMBER
	POPJ	P,		;NOPE
	SOSG	%USECNT(A)	;IF THIS WAS THE LAST
	JRST	BIGKIL		;THEN THE WHOLE BLOCK GOES AWAY
	PUSH	P,B		;MUST PRESERVE
	HRRZS	B		;JUST BE SURE RHS ONLY IS ON
	EXCH	B,%FRELIS(A)	;SAVE AWAY NEW LIST
	MOVEM	B,@%FRELIS(A)	;& LINK IT TO OLD
	POP	P,B		;GET BACK
	JRST	CPOPJ1		;WHAT WINNAGE!
BIGKIL:	PUSH	P,LPSA		;SAVE A COUPLE
	PUSH	P,TEMP		;
	PUSH	P,B
	PUSH	P,A		;GO UNLINK THIS BLOCK
	PUSHJ	P,$FUNLK	;LIKE SO
	MOVE	B,A		;GO CLOBBER THE WHOLE BLOCK
	PUSHJ	P,CORREL	;LIKE SO
	POP	P,B		;A PITY CANNOT JUST ZERO OUT B
	POP	P,TEMP		;GET ACS BACK
	POP	P,LPSA		;
	JRST	CPOPJ1		;RETURN

HERE($FXSPC)
	MOVEI	C,%FIRBLK	;HOW BIG IT NEEDS TO BE
	PUSHJ P,CORGET		;USE CORGET SPACE FOR THIS (DONT REALLY HAVE TO
	ERR <NO CORE TO BE HAD>,1  ; BUT MAY WANT TO DO THIS AT FUNNY TIMES)
	MOVE	A,B		;WHERE WE WILL RETURN VALUE
	HRL	B,B		;CLEANSE IT
	HRRI	B,1(B)
	SETZM	(B)
	BLT	B,%FIRBLK-1(A)
	MOVEI	B,$FXGET	;
	MOVEM	B,%GPROC(A)
	MOVEI	B,$FXDEL
	MOVEM	B,%DPROC(A)
	POP	P,B
	POP	P,%BLKCNT(A)
	POP	P,%MINSIZ(A)
	POP	P,%BLKSIZ(A)
	JRST	(B)


HERE($FXBLD)		
	
	MOVE	A,-1(P)		;MUST ADD A BLOCK
	PUSH	P,C		;SAVE THIS SIZE REQUEST
	PUSH	P,TEMP		;SAVE A COUPLE ACS
	PUSH	P,LPSA		;WHICH WE PROMISSED NOT TO MUNGE
	PUSH	P,B		
	SKIPN	C,%BLKCNT(A)	;
	ERR	<IT DOESN'T HELP YOU MUCH TO ALLOCATE ZERO MORE BLOCKS>,1,L1DON
	IMUL	C,%BLKSIZ(A)	;B ← NOMINAL BLOCK SIZE * COUNT + OVERHEAD
	ADDI	C,%FIRBLK	; 
	PUSHJ	P,CORGET	;A BLOCK OF THIS GREAT SIZE
	ERR	<COULDN'T GET ANY MORE SPACE FROM CORGET>,1
	MOVEI	TEMP,%FIRBLK(A)	;NOW CHAIN ALL SUB-BLOCKS TOGETHER
	MOVEI	LPSA,0		;
	MOVE	C,%BLKCNT(A)	;SO WE WILL COUNT DOWN
	MOVEM	C,%BLKCNT(B)	;ALSO, THE BLOCK COUNT FOR THIS
L1B:	MOVEM	LPSA,(TEMP)	;POINT TO NEXT
	MOVE	LPSA,TEMP	;REMEMBER THE BACK POINTER
	ADD	TEMP,%BLKSIZ(A)	;NEXT BLOCK
	SOJG	C,L1B		;COUNT DOWN TO ZERO
L1DON:	MOVEM	LPSA,%FRELIS(B)	;THIS IS THE FIRST FREE
	MOVEM	LPSA,%MAXADR(B)	;ALSO THE MAX ADDRESS BLOCK IN THIS SPACE
	SETZM	%USECNT(B)	;USE COUNT IS ZERO
	SETZM	%SUBLIS(B)	;THE SUBLIST IS ZERO
	MOVE	LPSA,%MINSIZ(A)	;COPY THESE, TOO (HRROI POP IS FASTER
	MOVEM	LPSA,%MINSIZ(B)	;BUT THIS ALLOWS EASIER REARRANGEMENT)
	MOVE	LPSA,%BLKSIZ(A)	;
	MOVEM	LPSA,%BLKSIZ(B)	;
	MOVEI	LPSA,$FXG	;THE HANDLERS FOR THESE
	MOVEM	LPSA,%GPROC(B)	;REMEMBER THE HANDLER
	MOVEI	LPSA,$FXD
	MOVEM	LPSA,%DPROC(B)	;
	PUSH	P,-6(P)		;GO LINK ONTO THIS ADDRESS
	PUSH	P,B		;THE BLOCKID
	PUSHJ	P,$FSINS	;USING THE STANDARD INSERTER
	POP	P,B
	POP	P,LPSA		;GET ACS BACK
	POP	P,TEMP		;
	POP	P,C		;
	SUB	P,X33
	JRST	@3(P)		;RETURN

BEND SPCSER

ENDCOM	(SPC)
;; SAIREC -- SYSTEM RECORD HANDLER ROUTINES
COMPIL(REC,<$REC$,FLDKIL,$RERR,$RECGC,$M1FLD,$ENQR,$RECFN,$RCINI,$RMARK>
	,<RECQQ,ALLFOR,ARYEL,CORGET,CORREL,X11,X22,X33,CLSLNK,STRCHN,GOGTAB,SGINS,$SPCAR>
	,<SAIL RECORD HANDLER>,<$RDREF,$RALLO>);

BEGIN RECORD
IFE ALWAYS, <
	EXTERNAL	$CLASS,RECCHN,RGCLST,RBLIST,RUNNER,SPRPDA,PLISTE,ACF
>;IFE ALWAYS

PDA ← 7		;DEF USED BY THE GARBAGE COLLECTOR


; FORMAT OF ALL RECORDS
CLSRNG←-2		;RING OF COMPILED-IN CLASSES
RING←-1			;RING OF RECORDS OF SAME CLASS
RMARK←←0		;GARBAGE COLLECTOR MARK CHAIN IN LEFT HALF
CLSPTR←←0		; RIGHT HALF OF THIS WORD POINTS TO CLASS TEMPLATE RECORD


; FORMAT OF RECORD CLASS TEMPLATES, IE CLASS="CLASS"
		;WORDS -1 AND 0 ARE STANDARD, IE. RING AND MARK
RECRNG←←1	;RING OF RECORDS OF THIS CLASS - FOR RECORDS OF CLASS = "CLASS"
HNDLER←←2	;HANDLER PROCEDURE FOR THIS CLASS
RECSIZ←←3	;COUNT OF # FIELDS IN RECORDS OF THIS CLASS
TYPARR←←4	;INTEGER ARRAY OF TYPE INFO FOR FIELDS	
		;	- 0TH WORD IN ARRAY IS TYPE BITS FOR THE CLASS
TXTARR←←5	;STRING ARRAY OF FIELD NAMES 
		;	- 0TH ELEMENT IS NAME OF RECORD CLASS

;;** VARIOUS "TYPE BITS" ARE NOW DEFINED UP IN HEAD

;;%DA% 

;;DESCRIPTOR FORMAT
DEFINE DX(ID)  <
ID ←← DSCSIZ
DSCSIZ ←← DSCSIZ+1
>
DSCSIZ ←← 0

DX(BLKSIZ)	;SIZE OF BLOCKS
DX(TRIGGER)	; COUNT DOWN FOR RECGC
DX(TGRMIN)	; MINIMUM NUMBER PERMITTED FOR TRIGGER SETTING
INIBFS ←← 2	;ALLOW TWO BUFFERS WORTH AS DEFAULT TRIGGER FLOOR
DX(TINUSE)	;TOTAL NUMBER IN USE
DX(TUNUSED)	;TOTAL UNUSED BUFFERS
DX(FBLIST)	; FREE BUFFER LIST
DX(FULLS)	; FULL BUFFER LIST
DX(CULPRT)	; COUNTED UP EACH TIME GC IS TRIGGERED BY THIS SPACE

;; BUFFER FORMAT
LINKS←← 0	;
BINUSE ←← 1	;WORDS IN USE IN THIS BUFFER?
FFREE ←← 2	;FREE LIST FOR BUFFER
FBDWD ←← 3	;FIRST BUFFER DATA WORD
RBSIZE ←← = 256 ;SIZE OF RECORD BUFFER

MAXSB ←← =16	;
MINSB ←← = 3	;

;**** SEE ALSO INITIALIZATION CODE FOR ASSIGNMENTS OF BLOCK SIZES

NSBSZS ←← =8

;;%DA% ↑↑
;; GETSTR, STRINIT, RELSTR, RSGC

; ROUTINE TO SET UP A BLOCK OF FREE STRING DESCRS.
FSTRSIZ←←20

STRINIT:	
	MOVEI C,2*FSTRSIZ+1		;ENOUGH ROOM FOR 20 STRINGS
	PUSHJ P,CORGET
	ERR <NO CORE FOR RECORD STRINGS>,1,ZPOPJ
;;*** CHECK THAT CORGET SETS UP USER ***
	MOVE A,STBLST(USER)	;LINKED LIST OF FREE STRING DESCR ARRAYS
	MOVEM A,(B)		;LINK NEW ONE IN
	MOVEM B,STBLST(USER)		;
	MOVEI A,FSTRSIZ
	ADDI B,2
	MOVEM B,STRCHN		;HEAD OF NEW CHAIN
L:	SETZM -1(B)
	ADDI B,2
	HRRZM B,-2(B)		;CONSTRUCT FREE CHAIN
	SOJG A,L
	SETZM -2(B)		;ZERO LAST ENTRY
	MOVE A,STRCHN
	POPJ P,

; ROUTINE TO GET A FREE STRING DESCRIPTOR  (CLOBBERS A & B AND SOMETIMES THE REST)
GETSTR:	SKIPN A,STRCHN		;ANY FREE STRINGS?
	PUSHJ P,STRINIT		;SET UP ANOTHER BLOCK OF STRINGS
	MOVE B,(A)
	MOVEM B,STRCHN		;CDR DOWN FREE CHAIN
	SETZM -1(A)		;CLEAR BOTH WORDS
	SETZM (A)
	POPJ P,
	

; RETURN A STRING TO FREE STRING LIST;
RELSTR:	SKIPN A,(A)		; POINTER TO STRING ARRAY ENTRY
	JRST CPOPJ		; NOTHING TO DO
	MOVE B,STRCHN		; CHAIN OF FREE STRINGS
	HRRZM B,(A)		; CHAIN TOGETHER 
	SETZM -1(A)		; ZERO CHARACTER COUNT
	MOVEM A,STRCHN	
	POPJ P,


; RECORD STRING SUBFIELD GARBAGE COLLECTION

BEGIN  RSGC
F←←E+1
; STRING AND STRING ARRAY SUBFIELDS ARE MARKED BY SWEEPING
;	THROUGH ALL RECORD CLASSES LOOKING FOR ONES THAT ARE RELEVENT,
;	AND MARKING STRING AND STRING ARRAY SUBFIELDS OF ALL RECORDS
;	UNDER THE APPROPRIATE CLASSES

↑RSGCMK:	
	HRRZ	D,RECRNG+$CLASS		;RING OF ALL CLASSES

RSGSWC:	MOVE	TEMP,@TYPARR(D)		;TYPE BITS FOR THIS CLASS
	TRNN	TEMP,HASSTR		;DOES IT HAVE STRING OR STRING ARRAY SUBFIELDS?
	JRST	NXTCLS			;NO STRING ARRAYS IN THIS CLASS
	HRRZ	E,RECRNG(D)		;RING OF RECORDS FOR THIS CLASS;
	JRST	NXTREC

RSGSWP:	MOVN	F,RECSIZ(D)
	MOVSS	F
	HRR	F,TYPARR(D)		;MAKE AOBJN WORD FOR TYPE ARRAY
	PUSH 	P,E

DOFLD:	ADDI 	E,1
	LDB 	B,[POINT 6,1(F),=12]	;GET TYPE BITS
	CAIN	B,STTYPE
	JRST	DOSTR			;IT'S A STRING
	CAIN	B,ARRTYP+STTYPE		
	JRST	DOSTRA			;IT'S A STRING ARRAY
NXFLD:	AOBJN	F,DOFLD
	POP	P,E
	HRRZ	E,RING(E)		;POINT AT NEXT IN CLASS
NXTREC:	CAIE	E,RECRNG-RING(D)	;IS IT HEAD OF CLASS?
	JRST	RSGSWP			;NOPE, CONTINUE

NXTCLS:	HRRZ	D,RING(D)		;NEXT CLASS ON RING OF CLASSES
	CAIE	D,$CLASS+RECRNG-RING	;HEAD OF RING OF CLASSES?
	JRST	RSGSWC			;NOPE, CONTINUE
	POPJ 	P,			;DONE AT LAST
	
DOSTR:	MOVE	A,(E)			;GET SUBFIELD -- POINTER TO STRING DESCR
	SUBI	A,1			;CRETINS - POINT TO FIRST WORD OF DESCR
	PUSHJ	P,@-2(P)		;CALL STRING MARK ROUTINE
	JRST	NXFLD

DOSTRA:	PUSH	P,D			
;;#VC# (1 OF 2)  USED TO BE A MOVE
	SKIPN	D,(E)			;GET SUBFIELD -- POINTER TO STRING ARRAY
	JRST	PPDNXT			;
;;#VC# ↑
	MOVN	A,-2(D)			;STRING ARRAY LENGTH
	HRL	D,A			;MAKE AOBJN WORD
STALP:	MOVEI 	A,-1(D)			;POINTER TO FIRST WORD OF STRING DESCR
	PUSHJ	P,@-3(P)			
	AOBJN	D,.+1
	AOBJN	D,STALP
;;#VC# ! ADDED A LABEL HERE
PPDNXT:	POP	P,D
	JRST	NXFLD

BEND RSGC
;; SAIREC -- $REC$ AND $RECFN
;;$REC$ CALLED VIA PUSH	P,[OP]
;		   PUSH P,ARG1
;		   PUSHJ P,$REC$ 
; IS ASSUMED TO WIPE OUT THE ACS
;;$RECFN IS CALLED JUST LIKE $REC$

$RDISP:	JRST	$RDREF		;DEREFERENCE ARG1
	JRST	$RALLO		;ALLOCATE RECORD WITH CLASS ARG1
	JRST	CPOPJ		;2			NON-STANDARD PRINT ROUTINE?
	JRST	CPOPJ		;3			NON-STANDARD READ ROUTINE?
	JRST	$MFLDS		;4 -- MARK ALL FIELDS OF A RECORD
	JRST	$DIE		;5 DELETE SPACE FOR RECORD
$RMAX ←← (.-$RDISP)-1

HEREFK($RECFN,$RECF.)
	SKIPN	A,-1(P)		;PICK UP ARG1
	JRST	NLARG1		;
	MOVE	B,-2(P)		;PICK UP OP
	CAIE	B,1		;RALLO IS FUNNY
	HRRZ	A,CLSPTR(A)	;
HACK <
	HRLZI	C,777740	;OLD-STYLE COUNT FIELD
	TDNE	C,(A)		;CHECK TO BE SURE NOT OLD-STYLE CLASS
	ERR	<OLD STYLE RECORD DESCRIPTOR.  RECOMPILE>
>;HACK
	JRST	@HNDLER(A)	;DISPATCH TO HANDLER ROUTINE
NLARG1:	ERR	<NULL ARGUMENT TO $RECFN>,1
	SUB	P,X33		;
	JRST	@3(P)		;RETURN

HERE($REC$)		
	POP	P,C		;RET ADR
	POP	P,A
	EXCH	C,(P)		; NOW C=OP, A=ARG1
	CAILE	C,$RMAX
	POPJ	P,
	JUMPN	C,@$RDISP(C)	; OBEY COMMAND

↑↑$RDREF:
	ERR	<CALL ON $RDREF IN RECORD GC VERSION>,1
	POPJ	P,

$DIE:	JUMPE	A,CPOPJ			;
	PUSH	P,A			; SO CAN LATER CALL CORREL
	HLRZ	B,RING(A)
	HRRZ	C,RING(A)
	HRRM	C,RING(B)
	HRLM	B,RING(C)		; UNLINK FROM RING OF CLASS

	HRRZ	C,CLSPTR(A)		; CLASS ADDRESS
;;%DA%  !
	PUSH    P,RECSIZ(C)		; RECORD SIZE -- REMEMBER FOR KILL
	PUSH    P,RECSIZ(C)		; RECORD SIZE 
	HRRZ	C,TYPARR(C)		; CLASS TYPE ARRAY
	SUBI	C,(A)			; CORRECTION FACTOR
	ADDI	A,1			; FIRST DATA ELEMENT
	HRLI	C,(<POINT =13,(A),=12>); DESCRIPTOR TO GET BITS
	PUSH	P,C

GETFLD:	SOSGE	-1(P)			; IS THIS THE LAST FIELD
	JRST	NOMORE
	LDB	C,(P)			; GET FIELD
	DPB	C,[POINT =13,A,=12]	; PUT DESCRIPTOR BITS IN PLACE
	PUSHJ	P,FLDKIL		; GO KILL THIS FIELD
	AOJA	A,GETFLD		; GO ON TO NEXT

NOMORE:	SUB	P,X22			; JUST POP TWO OFF
;;%DA% 
	POP	P,C			; PICK UP THE SIZE FIELD
	ADDI	C,2			; CORRECT FOR OVERHEAD
	POP	P,B			; THE CORREL POINTER
	SUBI	B,1			; NOW IT IS  -- THE EXTRA CHAIN WORD
	CAIL	C,MINSB			; IS IT A SPECIAL GUY?
	CAILE	C,MAXSB	
	JRST	CORREL			; NO, JUST DO A CORREL
	ADD	C,$SPCAR		;
	SKIPE	A,-MINSB(C)		;PICK UP THE DESCRIPTOR
	PUSHJ	P,$RBDEL		;GO KILL BLOCK
	ERR	<STRANGENESS IN RELEASING RECORD>,1,CORREL
	POPJ	P,
	
;	MOVE	USER,GOGTAB		; FREE THE SPACE UP
;	MOVE	A,$FSLIS(USER)		; BY CALLING THE FREER-UPPER
;	PUSHJ	P,$DEL1B		; 
;	ERR	<CONFUSION IN FREEING A BLOCK>,1
;	POPJ	P,
;;%DA% ↑↑

↑↑$RALLO:
HACK <
	HRLZI	C,777740	;OLD-STYLE COUNT FIELD
	TDNE	C,(A)		;CHECK TO BE SURE NOT OLD-STYLE CLASS
	ERR	<OLD STYLE RECORD DESCRIPTOR.  RECOMPILE>
>;HACK
	MOVE	C,RECSIZ(A)	; A = RECORD CLASS ID.  GET THE WORD COUNT
	ADDI	C,2		; RECORD SIZE +1 FOR RING WORD
				; AND +1 FOR DESCRIPTOR WORD
	PUSH	P,A		; EVENTUALLY, BECOMES THE RECID POINTER

;;%DA% RHT
	MOVEI	B,CORGET
	CAIL	C,MINSB		;DO WE WANT CORGET OR OUR SPECIAL GUY?
	CAILE	C,MAXSB		;
	JRST	GETCAL		;NO, USE CORGET
	SKIPN	A,$SPCAR	;PICK UP ARRAY DESCRIPTOR
	ERR	<UNINITIALIZED SPACE SYSTEM?>,1,GETCAL
	ADDI	A,-MINSB(C)	;POINT AT RIGHT DESCRIPTOR
	SKIPN	A,(A)		;PICK IT OUT
	ERR	<UNINITIALIZED SPACE SYSTEM?>,1,GETCAL
	MOVEI	B,$RBGET	;USE SPECIAL ROUTINE
GETCAL:	PUSHJ	P,(B)		;GET A BLOCK
	ERR	<COULDN'T GET BLOCK FOR A RECORD>,1,ZPOPJ
	MOVEI	A,1(B)		;THE POINTER WE WILL ACTUALLY RETURN
;;%DA% ↑↑

;;#SF# ! USED TO BE (B)
	ADDI	C,-1(B)		;STOPPING PLACE
	SETZM	(B);		;ZERO OUT (ALSO REF CNT ← 0)
	HRL	B,B		;BUILD BLT PTR
	HRRI	B,1(B)
	BLT	B,(C)		;BLT THEM AWAY
	PUSH 	P,A
	PUSH	P,A
	MOVE	A,-2(P)		;GET CLASS POINTER
	MOVE B,@TYPARR(A)	;GET TYPE BITS FOR CLASS
	TRNN B,HASSTR	
	JRST NOSTRS		;NO STRINGS TO ALLOCATE
	MOVN C,RECSIZ(A)	;WE GOT STRINGS
	MOVSS C
	HRR C,TYPARR(A)		;BUILD IOWD FOR TYPARR

STALLO:	MOVS B,1(C)
	AOS (P)
	CAIE B,140		;### CHANGE THIS TO TYPE BIT SYMBOL
	JRST NXTFLD
	PUSH P,C
	PUSHJ P,GETSTR		;GET A FREE STRING DESCR
	POP P,C
	MOVEM A,@(P)		;STORE POINTER TO STRING DESCR IN FIELD
NXTFLD:	AOBJN C,STALLO
NOSTRS:	SUB P,X11
	POP P,A

RNGIT2:	POP	P,B		; CLASSID
RNGIT:	HRRZM	B,CLSPTR(A)	; PUT ZERO IN MARK FIELD
	ADDI	B,RECRNG-RING	; OFFSET FOR HEAD OF CLASS
	HRRZ	C,RING(B)	; RING OF RECORDS FOR THE CLASS
	HRRZM	C,RING(A)	; NEW RECORD POINTS TO RING
	HRRM	A,RING(B)	; CLASS POINTS TO NEW RECORD
	HRLM	B,RING(A)	; NEW RECORD POINTS TO CLASS
	HRLM	A,RING(C)	; RING POINTS BACK TO NEW RECORD
	POPJ	P,		;RETURN

ZPOPJ:	MOVEI	A,0
	POPJ	P,

	
	

	
	
	

HERE($RERR)
	ERR	<ACCESS TO A SUBFIELD OF A NULL RECORD>,1
	POPJ	P,

;; SAIREC -- $RCINI 

;; SETS UP $CLASS, THEN RUNS DOWN THE CLASS LINKS
;; HOMED ON CLSLNK & SETS UP THE QUAM-STYLE RING LINKAGES.
;; ALSO ZEROS ALL OWN (AND OUTER BLOCK) RECORD POINTERS.

NOLOW <
NOUP <
REN <
	USE
>;REN
RCLK:	0
	$RCINI
	0
	LINK	%INLNK,RCLK
REN <
	USE	HIGHS
>;REN
>;NOUP
>;NOLOW

HEREFK($RCINI,$RCIN.)
	PUSH	P,[RSGCMK]		;POINTER TO RECORD STRING GC
	MOVEI 	A,RSGCLK+1(USER)
	PUSH 	P,A
	PUSHJ 	P,SGINS			;ENQUE RECORD STRING GARBAGE COLLECTOR


	MOVE	A,[XWD $CLASS,$CLASS]	;
	HRRZM	A,$CLASS		;INITIALIZE $CLASS
	MOVEM	A,$CLASS+RECRNG		;
	ADD	A,[XWD RECRNG-RING,RECRNG-RING];
	MOVEM	A,$CLASS+RING		;
	MOVEI	A,$REC$			;HANDLER
	MOVEM	A,$CLASS+HNDLER		;
	MOVEI	A,$CLSTY		;TYPE ARRAY
	MOVEM	A,$CLASS+TYPARR		;
	MOVEI	A,$CLSTX+1		;TEXT ARRAY
	MOVEM	A,$CLASS+TXTARR		;
	MOVEI	A,5			;TEST MUNGAGE
;***	CAME	A,$CLASS+RECSIZ		;OF THE COUNT
;***	ERR	<WARNING.  $CLASS WAS MUNGED>,1
	MOVEM	A,$CLASS+RECSIZ

	SKIPN	D,CLSLNK		;PICK UP THE CLASS LIST
	POPJ	P,			;IF NO CLASSES, THEN DONE
LNKCLS:	MOVEI	B,$CLASS		;CLASS OF CLASSES
	MOVEI	A,-CLSRNG(D)		;POINT AT CLASS DESCRIPTOR
	PUSHJ	P,RNGIT			;LINK THIS CLASS ONTO CLASS RING
	MOVEI	D,RECRNG-RING(A)	;SET UP RECORD RING
	HRL	D,D			;RECRNG SHOULD POINT AT ITSELF
	MOVEM	D,RECRNG(A)		;MAKE IT DO SO
	HRRZ	D,CLSRNG(A)		;POINT AT NEXT CLASS
	JUMPN	D,LNKCLS		;GO ON IF HAVE ANY LEFT

	MOVE	USER,GOGTAB
	SETZM 	STRCHN			;ZERO CHAIN OF FREE STRING DESCRS
	SETZM 	STBLST(USER)		;AND CHAIN OF FREE STRING DESCR ARRAYS

;;%DA%	-- INITIALIZE SMALL BLOCK SYSTEM
	MOVE	A,[0.33]		;STANDARD FACTOR 1/0.75 -1
	MOVEM	A,RGCRHO(USER)
	MOVEI	C,6+MAXSB-MINSB		;SIZE OF DESCRIPTOR ARRAY
	PUSHJ	P,CORGET		;GET SOME ROOM
	ERR	<COULDN'T GET SPACE FOR $SPCAR>
	MOVEI	A,5-MINSB(B)		;BUILD ARRAY HEADER
	SUBI	B,1			;SO ALL THE PUSHES WORK RIGHT
	PUSH	B,A			;
	PUSH	B,[MINSB]
	PUSH	B,[MAXSB]
	PUSH	B,[1]
	PUSH	B,[1,,MAXSB+1-MINSB]
	HRRZM	B,$SPCAR		;WILL AOS IT IN A BIT
	MOVEI	C,NSBSZS*DSCSIZ		;GET SPACE FOR DESCRIPTORS
	PUSHJ	P,CORGET
	ERR	<CANNOT GET ROOM FOR SPACE DESCRIPTORS>
	SETZM	(B)
	HRLI	C,(B)
	HRRI	C,1(B)
	BLT	C,NSBSZS*DSCSIZ-1(B)	;ZERO IT ALL OUT
	NN ←← 0				;FILL IN BLKSIZ
	;; *** SEE ALSO DEFINITIONS OF MAXSB & MINSB & NSIZES
	FOR II IN (3,4,5,6,=8,=10,=12,=16)
		< MOVEI	A,II
		  MOVEM A,NN+BLKSIZ(B)
		  MOVEI A,((RBSIZE-FBDWD)/II)*INIBFS
		  MOVEM A,NN+TRIGGER(B)
		  MOVEM A,NN+TGRMIN(B)
		  NN ←← NN+DSCSIZ
		>
	AOS	C,$SPCAR		;NOW FILL IN SPCAR ENTRIES
	SUBI	C,1			;GET BACK INTO PUSH PHASE
	FOR II IN (0,1,2,3,4,4,5,5,6,6,7,7,7,7)
		<MOVEI A,II*DSCSIZ(B)
		 PUSH C,A
		>
;;%DA% ↑↑

; ZERO ALL THE OWN AND OUTER BLOCK RECORD POINTERS
ZERO0:	HRRZ D,RBLIST			;CHAIN OF ALL OWN AND OUTER BLOCK RECORD POINTERS
	JRST ZERO3
ZERO1:	HRRZ D,(D)			;NEXT BLOCK IN RBLIST CHAIN
ZERO3:	JUMPE D,CPOPJ			;DONE
	HRRZI B,1(D)
ZERO2:	SKIPN C,(B)			;GET AOBJN WORD
	JRST ZERO1			;DONE WITH THIS BLOCK
	SETZM (C)			;ZERO THE RECORD POINTER (ARRAY)
	AOBJN C,.-1			
	AOJA B,ZERO2

	$CLSTY				;TYPE BITS ARRAY HEADER
	0				;LB
	TXTARR				;UB
	1
	XWD	1,TXTARR+1		;NDIMS,,TOTAL SIZE
$CLSTY:	CMPLDC+NODELC+HASSTR		;TYPE BITS
	INTYPE*1B12			;RECRNG
	INTYPE*1B12			;HNDLER
	INTYPE*1B12			;RECSIZ --ONLY "REAL" INTEGER
	(ARRTYP+INTYPE)*1B12		;TYPE ARRAY
	(ARRTYP+STTYPE)*1B12		;TEXT ARRAY

CLSTXT:	ASCIZ /$CLASSRECRNGHNDLERRECSIZTYPARRTXTARR/

DEFINE SUBSTR(STR,N,CNT) <
	CNT
	POINT	7,STR-1+(N+4)/5,6+7*(N+4-5*((N+4)/5))
	>

DEFINE IDTXT(CNT) <
	SUBSTR(CLSTXT,II,CNT)
	II ←← II+CNT
	>

	II ←← 0

	$CLSTX+1			;TEXT ARRAY HEADER
	0				;LB
	TXTARR				;UB
	1				;MUL(1)
	XWD	-1,2*(TXTARR+1)		;TOTAL SIZE
$CLSTX:	IDTXT(6)			;$CLASS
	IDTXT(6)			;RECRNG
	IDTXT(6)			;HNDLER
	IDTXT(6)			;RECSIZ
	IDTXT(6)			;TYPARR
	IDTXT(6)			;TXTARR

;; SAIREC -- FLDKIL ROUTINE

HERE(FLDKIL)
		;CALLED WITH REFITEM TYPE DESCRIPTOR IN A
		;WILL TAKE ALL APPROPTIATE ACTION
		;IF TMPB IS ON IN A, THEN ASSUMES THAT CALLED FROM LEAP
		;  -- THUS, IF TMPB AND NOT REFB, WILL DO THE RIGHT THING
		;  ABOUT ONE & TWO WORD FREES
		;PRESERVES A BUT ALL OTHERS MAY BE MUNGED

	TLNN	A,REFB	; IF REFB ON, THEN NO DELETION REQUIRED
	SKIPN	@A	; NOTHING TO DO IF A NULL
	POPJ	P,
	TLNE	A,ARY2B		;ITEMVAR ARRAY ??
	JRST	ARYKIL		;YEP
	TLNN	A,ITEMB		;NOTHING TO DO IF ITEM
	TLNE	A,PROCB		;OR PROCEDURE
	POPJ	P,
	LDB	TEMP,[POINT 6,A,=12] ; SIX BIT TYPE
	CAIL	TEMP,INVTYP	;VERIFY VALID
	ERR	<DRYROT -- INVALID REFERENCE TYPE IN FLDKIL>,5,RPOPJ
	CAIG	TEMP,MXSTYP	;IS THIS A LEGAL ARRAY TYPE ??
	JRST	@FKDISP(TEMP)	;NOPE DO WHATEVER YOU MUST
	MOVEI	TEMP,@FKDISP-ARRTYP(TEMP) ;FIND OUT WHAT SORT OF ARRAY YOU HAVE
	CAIE	TEMP,WZAPR	;A DONOTHING ??
	CAIN	TEMP,WSTRKL	;A STRING ARRAY?
	JRST	ARYKIL		;YEP
	PUSH	P,A		;HERE MUST CALL SELF RECURSIVELY TO 
	MOVEI	A,@A		;PROCESS EACH ARRAY ELEMENT
	PUSH	P,TEMP		;ROUTINE TO CALL
	HRRZ	TEMP,-1(A)	;COUNT
	JUMPE	TEMP,NOELS	;NONE
	PUSH	P,TEMP		;SAVE COUNT
DEL1EL:	SKIPE	(A)		;HAVE ONE
	PUSHJ	P,@-1(P)	;CALL THE ROUTINE
	SOSG	(P)		;DECREMENT THE COUNT
	AOJA	A,DEL1EL	;DELETE ONE ELEMENT
	POP	P,TEMP		;GET THIS OFF
NOELS:	POP	P,TEMP		;GET THIS OFF, TOO.
	JRST	ARYKL2		;MAY AS WELL LEAVE A ON THE STACK

ARYKIL:	PUSH	P,A		;SINCE  ARYEL CLOBBERS IT
ARYKL2:	PUSH	P,@A		;CALL TO ARYEL
	SETZM	@A		;ZAP IT
	PUSHJ	P,ARYEL		;KILL THE ARRAY
	POP	P,A		;OH WELL, GET A BACK
	POPJ	P,		;RETURN FROM KILLING THE ARRAY

FKDISP:	WZAPR			;ACTUALLY A NOTHING
	WZAPR			;1 UNTYPED
	WZAPR			;2 BTRIP
	WSTRKL			;3 STRING
	WZAPR			;4 REAL
	WZAPR			;5 INTEGER
	WSLKL			;6 SET
	WSLKL			;7 LIST
	WZAPR			;8 PROCEDURE ITEM
	WZAPR			;9 PROCESS ITEM
	WZAPR			;10 EVENT TYPE
	WCTXTK			;11 CONTEXT
	WZAPR			;12 REFITEM
	WZAPR			;13 RECORD DEREFERENCING

WSTRKL:	PUSH P,A
	PUSHJ P,RELSTR
	POP P,A
	JRST WZAPR

WSLKL:	SKIPN	B,@A		;DO WE HAVE ONE
	JRST	WZAPR		;NOPE JUST WORRY ABOUT FREES
	PUSH	P,A		;WHO KNOWS WHAT EVIL LURKS IN THE HEART OF LEAP
	SETZM	@A		;CLEAR IT OUT
	MOVE	A,B		;
	MOVEI	5,0		;ALL SET UP
	PUSHJ	P,RECQQ		;RELEASE THE SET OR LIST
	POP	P,A		;GET A BACK
	JRST	WZAPR

WCTXTK:	SKIPN	B,@A		;HAVE ONE
	POPJ	P,		;YEP
	SETZM	@A		;
	PUSH	P,A		;KILLING A CONTEXT
	PUSH	P,B
	PUSHJ	P,ALLFOR	;FORGET IT
	POP	P,A		;GET BACK A
	JRST	WZAPR

WRDRF:	PUSH	P,A		;SAVE
	MOVE	A,@A		; DO DEREFERENCE
	PUSHJ	P,$RDREF	;CALL DEREFERENCER
	POP	P,A		;GET A BACK
	;FALL INTO WZAPR
WZAPR:	TLNN	A,TMPB		;CALLING FROM LEAP ???
RPOPJ:	POPJ	P,		;
				;MUST WORRY ABOUT LEAPISHNESS
	ERR	<FLDKIL NOT YET READY FOR CALL FOR REFITEMS>,1,RPOPJ


;; SAIREC (RECGC) -- $ENQR,ENQRB,ENQRBB,PAMRK


HERE($ENQR)
	JUMPE	A,CPOPJ			;NULL NEVER
HACK <					;BUG TRAP
	HRRZ	TEMP,(A)		;GET THE CLASS OF WHAT WE ARE MARKING
	HRRZ	TEMP,(TEMP)		;ALL CLASSES BETTER BE $CLASS INSTANCES
	CAIE	TEMP,$CLASS		;
	ERR	<ATTEMPT TO MARK INVALID RECORD POINTER>,1
>;HACK
	HLRZ	TEMP,RMARK(A)		;BE SURE NOT THERE YET
	JUMPN	TEMP,CPOPJ
	HRR	TEMP,RECCHN		;LINK ONTO CHAIN
	HRLM	TEMP,RMARK(A)
	HRRM	A,RECCHN
	POPJ	P,

ENQRB:	TLNN	C,-1			;C =-COUNT,,ADR
	POPJ	P,			;NULL CALL
	HRRZ	A,(C)
	PUSHJ	P,$ENQR			;PUT ONE ON QUEUE
	AOBJN	C,.-2			;ITERATE
	POPJ	P,

ENQRBB:	MOVE	C,(B)			;B →→ A BLOCK OF -CNT,,ADR WORDS
	JUMPE	C,CPOPJ			;TERMINATED BY A ZERO
	PUSHJ	P,ENQRB
	AOJA	B,ENQRBB		;ITERATE

ENQRBL: HRRZ	D,RBLIST		;ROUTINE THAT HANDLES RBLIST
EQRB.L:	JUMPE	D,CPOPJ
	HRRZI	B,1(D)			;POINT AT THIS BLOCK
	PUSHJ	P,ENQRBB		;MARK EM ALL
	HRRZ	D,(D)			;ITERATE
	JRST	EQRB.L			

PAMRK:  HLRZ	PDA,1(RF)		;HANDLES ONE EACH PROCEDURE ACTIVATION
	CAIN	PDA,SPRPDA		;CAN QUIT ON THIS
	POPJ	P,
	MOVEI	D,-1(RF)		;LAST PARAMETER LOCATION
	HRLI	D,C
	HRRZ	C,PD.NPW(PDA)		;NUMBER OF ARITH PARAMS
	MOVNI	C,(C)			;
	HRRZ	B,PD.DLW(PDA)		;POINT AT PARAMS
MKPRM:	AOJGE	C,PRMSDN		;COUNT UP, QUIT WHEN RUN OUT
	LDB	TEMP,[POINT =12,(B),=12] ;INTERESTED IN VALUE RECORDS
	CAIE	TEMP,RECTYP		;TEST CODE
	AOJA	B,MKPRM			;NO, GO MARK NEXT
	HRRZ	A,@D			;PICK UP PARAMETER
	PUSHJ	P,$ENQR			;HANDLE IT
	AOJA	B,MKPRM
PRMSDN: HRRZ	B,PD.LLW(PDA)		;POINT AT LVI
LVI.DO:	SKIPN	D,(B)			;A ZERO MEANS DONE
	POPJ	P,
	LDB	TEMP,[POINT 4,D,3]
	CAIN	TEMP,RPACOD
	JRST	MRKRPA
	CAIE	TEMP,RPCOD
	AOJA	B,LVI.DO
	HRRZ	A,@D			;GET DESCRIPTOR
	PUSHJ	P,$ENQR
	AOJA	B,LVI.DO
MRKRPA:	SKIPN	C,@D
	AOJA	B,LVI.DO
	MOVN	TEMP,-1(C)		;WORD COUNT
	HRL	C,TEMP
	PUSHJ	P,ENQRB			;DO THEM ALL
	AOJA	B,LVI.DO

;; SAIREC (RECGC) -- %PSMRR

%PSMRR:	
	SKIPE	TEMP,RUNNER		;FANCY CASE
	JRST	PSMK.2			;HERE IF PROCESSES IN USE
	PUSH	P,RF			;SAVE RF
	PUSHJ	P,PSMK.1		;
	POP	P,RF
	POPJ	P,

PSMK.1:	PUSHJ	P,PAMRK			;MARK 
	HRRZ	RF,(RF)			;DYNAMIC LINK
	CAIE	RF,-1			;DONE??
	JUMPN	RF,PSMK.1		;NO (ALSO TEST DONE ANOTHER WAY)
	POPJ	P,			;DONE ALL

PSMK.2:	MOVEM	RF,ACF(TEMP)		;SAVE RF IN TABLE
	HRLZI	B,-NPRIS
	HRR	B,GOGTAB
PSCHL:	SKIPN	TEMP,PRILIS(B)
	JRST	NXLS
	PUSH	P,B			;SAVE B
PSCHL2:	
	PUSH	P,TEMP
	MOVE	RF,ACF(TEMP)
	PUSHJ	P,PSMK.1		;MARK THAT STACK
	POP	P,TEMP
	HRRZ	TEMP,PLISTE(TEMP)
	JUMPN	TEMP,PSCHL2
	POP	P,B
NXLS:	AOBJN	B,PSCHL
	MOVE	TEMP,RUNNER
	MOVE	RF,ACF(TEMP)
	POPJ	P,
;; SAIREC (RECGC) -- RCIMRK 

RCIMRK:	MOVE	USER,GOGTAB	
	SKIPE	HASMSK(USER)		;ACTUALLY HAVE LEAP
	SKIPG	C,MAXITM(USER)		;ALL THE ITEMS TO MARK
	POPJ	P,			;NOPE
RI1MK:	LDB	TEMP,INFOTAB(USER)	;GET TYPE
	MOVE	A,@DATAB(USER)		;AND DATUM READY
	CAIN	TEMP,RFITYP		;REFERENCE
	JRST	RFFOL
	CAIN	TEMP,ARRTYP+RECTYP	;RECORD ARRAY??
	JRST	RAIMK			;YES
	CAIN	TEMP,RECTYP		;REGULAR RECORD
	PUSHJ	P,$ENQR			;YES
RIMITR:	SOJG	C,RI1MK			;ITERATE
	POPJ	P,

RFFOL:	PUSH	P,C			;SINCE NO PROMISSES WERE MADE
	PUSHJ	P,$M1FLD		;MARK A FIELD
	POP	P,C
	JRST	RIMITR

RAIMK:	
;;#VF# (1-1) THIS CODE WAS JUST WRONG
;	SKIPN	TEMP,@A			;POINT AT RECORD ARRAY
;	JRST 	RIMITR			;EMPTY
;	PUSH	P,C			;SAVE ITEM NUMBER
;	MOVN	C,-1(TEMP)
;	HRL	C,TEMP
;	MOVS	C,C			;-CNT,,ADR
;	PUSHJ	P,ENQRB			;HANDLE EM ALL
;	JRST 	RIMITR			;ITERATE

	JUMPE	A,RIMITR		;ARRAY WASN'T REALLY THERE
	PUSH	P,C			;MUST NOT MUNCH ITEM NUMBER
	MOVN	C,-1(A)			;MAKE AOBJN PTR
	HRL	C,A
	MOVS	C,C
	PUSHJ	P,ENQRB			;GO HANDLE THE LOT
	POP	P,C			;GET ITEM BACK
	JRST	RIMITR			;ITERATE
;;#VF# ↑↑
;; SAIREC (RECGC) -- $MRK.1, $MFLDS

$MRK1R:	PUSHJ	P,$ENQR			;ENQUEUE ONE RECORD
HEREFK($RMARK,$RMAR.)
$MRK.1:	HRRZ	A,RECCHN		;GET A RECORD OFF THE CHAIN
	CAIN	A,-1			;END OF THE ROAD??
	POPJ	P,			;YES
	HLRZ	D,RMARK(A)		;CDR THE QUEUE
	HRRM	D,RECCHN		;NEW NEXT ELT ON QUEUE
	HLRZ	D,RECCHN		;
	HRLM	D,RMARK(A)		;MAKE CHAIN OF ALL MARKED RECORDS
	HRLM	A,RECCHN
	HRRZ	D,CLSPTR(A)		;POINTER TO CLASS
	HRRZ	D,HNDLER(D)		;GET HANDLER ADDRESS
	CAIN	D,$REC$			;STANDARD HANDLER??
	JRST	MFLDS1			;YES
	PUSH	P,[4]			;THE "MARK" OP
	PUSH	P,A			;REC ID
	PUSHJ	P,(D)			;CALL ROUTINE
	JRST	$MRK.1

MFLDS1:	PUSH	P,[$MRK.1]
$MFLDS:	JUMPE	A,CPOPJ			;MARK ALL FIELDS OF RCD IN A
	HRRZ	C,CLSPTR(A)			;CLASS ID
	PUSH	P,RECSIZ(C)		;RECORD SIZE
	HRRZ	C,TYPARR(C)		;POINTER TO TYPE ARRAY
;;%##% RHT + PDQ DO NOT PROCEED FURTHER IF NO RECORD SUBFIELDS
	HRL	C,(C)			;GET TYPE BITS
	TLNN	C,HASRPS		;HAVE RECORD OR RECORD ARRAY SUBFIELDS
	JRST	CPOP1J			;NO
;;%##%
	SUBI	C,(A)			;CORRECTION FACTOR
	ADDI	A,1			;FIRST DATA FIELD
	HRLI	C,(<POINT =13,(A),=12>)	;TO GET TYPE BITS
	PUSH	P,C			;SAVE IT
G1FLD:	SOSGE	-1(P)			;ARE WE DONE?
	JRST 	CPOP2J			; YEP
	LDB	C,(P)			;GET TYPE
	DPB	C,[POINT =13,A,=12]	;DESCRIPTOR FOR ONE FIELD
	PUSHJ	P,$M1FLD		;MARK ONE FIELD
	AOJA	A,G1FLD			;ITERATE UNTIL DONE

CPOP2J:	SUB	P,X22
	POPJ P,

CPOP1J:	SUB	P,X11
CPOPJ:	POPJ	P,

;; SAIREC (RECGC) -- $RGCMK

$RGCMK:	PUSHJ	P,ENQRBL		;DO SOME STANDARD MARK ROUTINES -- OWNS
	PUSHJ	P,RCIMRK		;ITEMS
	PUSHJ	P,%PSMRR		;ACTIVE PROCEDURES
	PUSH	P,RGCLST		;NOW DO ANY SPECIAL ENLISTED ROUTINES
RGCMK1:	POP	P,A			;GET NEXT ENQUEUEING ROUTINE TO CALL
	JUMPE	A,$MRK.1		;NO MORE -- GO PROCESS ALL WE HAVE SEEN
	PUSH	P,(A)			;SAVE LINK
	PUSHJ	P,@1(A)			;CALL THIS FELLOW
	JRST	RGCMK1			;GO GET SOME MORE

;; SAIREC (RECGC) -- $RGCSW

$RGCSW:	;;****  THESE LINES CHANGED FROM PDQ METHOD ****
	;;HRRZ	D,CLSREC		;HEAD OF ALL CLASSES
	;;MOVEI	TEMP,RECRNG-RING(D)	;HEAD OF RING OF ALL CLASSES
	;;MOVEM	TEMP,CLSRHD#
	;;HRRZ	D,RECRNG(D)		;RING OF ALL CLASSES
	;;****
	HRRZ	D,RECRNG+$CLASS		;RING OF ALL CLASSES

RGSWC:	MOVE	TEMP,@TYPARR(D)		;TYPE BITS FOR THIS CLASS
	HRRZ	A,RECRNG(D)		;RING OF RECORDS FOR THIS CLASS;
	TRNN	TEMP,NODELC		
	JRST	NXTREC			;DELETE UNMARKED RECORDS OF THIS CLASS;
;RESET MARKS FOR ALL RECORDS OF THIS CLASS -- NEVER DELETE
RGNODL:	HRRZS	RMARK(A)		;CLEAR MARK
	HRRZ	A,RING(A)
	CAIE	A,RECRNG-RING(D)	;HEAD OF CLASS?
	JRST	RGNODL			;NO, AGAIN
	JRST 	NXTCLS			;DONE WITH THIS RECORD CLASS -- ON TO NEXT


RGSWPP:	HLL	TEMP,RMARK(A)		;GET MARK
	TLNN	TEMP,-1			;
	JRST	RGSWP1			;UNMARKED MEANS IT DIES
	HRRZS	RMARK(A)		;CLEAR MARK
	HRRZ	A,RING(A)		;POINT AT NEXT IN CLASS
NXTREC:	CAIE	A,RECRNG-RING(D)	;IS IT HEAD OF CLASS?
	JRST	RGSWPP			;NOPE, CONTINUE
NXTCLS:	HRRZ	D,RING(D)		;NEXT CLASS ON RING OF CLASSES
;;****	CAME	D,CLSRHD		;HEAD OF RING OF CLASSES?
	CAIE	D,$CLASS+RECRNG-RING	;HEAD OF RING OF CLASSES?
	JRST	RGSWC			;NOPE, CONTINUE
	POPJ 	P,			;DONE AT LAST

RGSWP1:	HRRZ	TEMP,RING(A)
	PUSH	P,TEMP			;SAVE POINTER TO NEXT ON RING
	PUSH	P,D			
	HRRZ	TEMP,CLSPTR(A)		;CLASS
	HRRZ 	TEMP,HNDLER(TEMP)	;HANDLER FOR CLASS
	CAIE	TEMP,$REC$		;IS IT STANDARD
	JRST	RGSWP3			;NO DO A REGULAR CALL
	PUSHJ	P,$DIE			;KILL RECORD
RGSWP2:	POP	P,D
	POP	P,A
	JRST	NXTREC

RGSWP3:	PUSH	P,[5]		;KILL YOURSELF
	PUSH	P,A
	PUSHJ	P,(TEMP)
	JRST	RGSWP2
;; SAIREC (RECGC) -- MAIN ROUTINE

HERE($RECGC)

	SETOM	RECCHN		;INITIALIZE MARK AS NULL
	PUSHJ	P,$RGCMK	;MARK THEM ALL
	PUSHJ	P,$RGCSW	;SWEEP THEM ALL
				;ALL DONE NOW
	SKIPE	A,TGRADJ(USER)	;DOES USER WANT TO ADJUST TRIGGERS HIMSELF?
	JRST	(A)		;YES, LET HIM WORRY -- HE WILL POPJ SOMEDAY.

ADJTGR:	MOVE	TEMP,$SPCAR	;ROUTINE TO ADJUST TRIGGER LEVELS
	HRLI	TEMP,MINSB-MAXSB-1 ;-BUCKETS,,FIRST
	PUSH	P,TEMP		;DO IT THIS WAY TO AVOID WORK
	SKIPE	A,(TEMP)	;LOOK AT A BUCKET
	SETOM	TRIGGER(A)	;USE NEG TRIGGER AS A FLAG
	AOBJN	TEMP,.-2	;ITERATE
	POP	P,TEMP		;GET BACK THE AOBJN PTR
ADJ1TG:	
	SKIPE	A,(TEMP)	;ANYTHING IN THIS BUCKET?
	SKIPL	TRIGGER(A)	;ALREADY DONE?
	JRST	ADJNXT		;DONT DO IT AGAIN
	MOVE	B,TINUSE(A)	;
	FSC	B,233		;MAKE REAL
	FMPR	B,RGCRHO(USER)	;B ← NUMBER IN USE * RHO
	UFA	B,[233000000000];MAKE AN INTEGER
	TLZ	C,777000	;IT HAS TO BE POSITIVE
	CAMGE	C,TUNUSED(A)	;IF UNUSED MORE THAN THIS
	MOVE	C,TUNUSED(A)	;THEN USE THEM
	CAMGE	C,TGRMIN(A)	;GET THE FLOOR QUANTITY FOR THIS SPACE
	MOVE	C,TGRMIN(A)	;
SETTGR:	MOVEM	C,TRIGGER(A)	;TRIGGER←MAX(INUSE*RHO,UNUSED,TGRMIN)
ADJNXT:	AOBJN	TEMP,ADJ1TG	;ITERATE
	POPJ	P,		;ALL DONE
;; SAIREC (RECGC) -- $M1FLD

HERE($M1FLD)
		;CALLED WITH REFITEM TYPE DESCRIPTOR IN A
		;WILL TAKE ALL APPROPTIATE ACTION
		;PRESERVES A BUT ALL OTHERS MAY BE MUNGED

	JUMPE	A,CPOPJ		;NOTHING TO DO IF NULL
	TLNN	A,ITEMB		;NOTHING TO DO IF ITEMISH
	TLNE	A,PROCB		;OR PROCEDURE
	POPJ	P,
	LDB	TEMP,[POINT 6,A,=12] ; SIX BIT TYPE
	CAIN	TEMP,RECTYP	;A RECORD??
	JRST	M1REC		;YES, ENQUEUE IT
	CAIN	TEMP,RFITYP	;A REFERENCE ITSELF
	JRST	M1REF		;YES
	CAIE	TEMP,RECTYP+ARRTYP; A RECORD ARRAY??
	POPJ	P,		;NOPE
	PUSH	P,A		;SINCE AGREED TO LEAVE ALONE
	PUSH	P,B
	SKIPN	B,(A)		;PICK UP ARRAY DESCRIPTOR
;;#VL# ! used to be a popj
	JRST    M1AXIT		;EMPTY
	MOVN	TEMP,-1(B)	;WORD COUNT
	JUMPE	TEMP,M1AXIT	;NO WORDS
	HRL	B,TEMP
M1ALP:	MOVE	A,(B)		;PICK UP A WORD
	PUSHJ	P,$ENQR		;ENQUEUE IT
	AOBJN	B,M1ALP
M1AXIT:	POP	P,B		;
	POP	P,A
	POPJ	P,

M1REC:	PUSH	P,A		;WE PROMISSED TO LEAVE ALONE
	MOVE	A,@A		;FETCH VARIABLE
	PUSHJ	P,$ENQR		;ENQUEUE IT
	POP	P,A		;RESTORE
	POPJ	P,

M1REF:	PUSH	P,A
	MOVE	A,@A
	PUSHJ	P,$M1FLD	;MARK THE THING REFERENCED
	POP	P,A
	POPJ	P,

;; SAIREC -- $RBDEL 

$RBDEL:	PUSH	P,C		;NO SIZE CHECK IF ENTER HERE
	MOVEI	C,FBLIST-LINKS(A);
	PUSHJ	P,$RBD.1	;TRY TO FIND IN FBLIST
	JRST	POPCJ1		;GO SAY WE WON
	MOVEI	C,FULLS-LINKS(A);
	PUSHJ	P,$RBD.1	;TRY IN FULLS
POPCJ1:	AOS	-1(P)		;SKIP RETURN
POPCJ:	POP	P,C
	POPJ	P,

$RBD.1:	HRRZ	C,LINKS(C)	;HAVE A RIGHT LINKS
	JUMPE	C,CPOPJ1	;OUT OF BUFFERS, JUST FAIL
	CAIL	B,(C)		;IN THIS BUFFER?
	CAIL	B,RBSIZE(C)	;
	JRST	$RBD.1		;NO
	AOS	TRIGGER(A)	;WE KNOW WHERE, SO DELETE BLOCK
	SOS	TINUSE(A)
	AOS	TUNUSED(A)	;NUMBER OF UNUSED BLOCKS IN SPACE
	EXCH	B,FFREE(C)	;CONS ONTO FREE LIST
	MOVEM	B,@FFREE(C)	;LIKE THIS
	JUMPN	B,$RBD.2	;GO FROM FULL LIST TO FREE LIST?
	PUSHJ	P,UNLKC		;GO UNLINK C
	MOVEI	B,FBLIST-LINKS(A);AND LINK ONTO FBLIST
	PUSHJ	P,LNKCB		;
$RBD.2:	SOSLE	BINUSE(C)	;ANY BLOCKS STILL IN USE HERE?
	POPJ	P,		;YES
	PUSHJ	P,UNLKC		;REMOVE FROM ITS CHAIN
	MOVE	B,C		;
	PUSHJ	P,CORREL	;GO REMOVE FROM CORGET SPACE
	MOVNI	B,RBSIZE-FBDWD+1;COMPUTE HOW MANY BUFFERS WE LOSE
	IDIV	B,BLKSIZ(A)	; (- DATAWDS)/SIZE
	ADDM	B,TUNUSED(A)	; CORRECT NOTION OF HOW MANY WE HAVE
	POPJ	P,
	
CPOPJ1:	AOS	(P)
	POPJ	P,

UNLKC:	MOVS	TEMP,LINKS(C)	;RIGHT,,LEFT
	HLRM	TEMP,LINKS(TEMP);RIGHT[LEFT]←RIGHT
	TLNN	TEMP,-1		;HAVE A RIGHT LINK?
	POPJ	P,		;NO
	MOVSS	TEMP		;LEFT,,RIGHT
	HLLM	TEMP,LINKS(TEMP);LEFT[RIGHT]←LEFT
	POPJ	P,

LNKCB:	SKIPE	TEMP,LINKS(B)	;EMPTY?
	HRLM	C,LINKS(TEMP)	;NO, LEFT[OLD]←NEW
	HRLI	TEMP,LINKS(B)	;[HEAD],,OLD
	MOVEM	TEMP,LINKS(C)	; INTO NEW WORD
	HRRZM	C,LINKS(B)	;RIGHT[HEAD]←NEW
	POPJ	P,

;; SAIREC -- $RBGET 

$RBGET:	
;;#VK# ! PUSH USED TO COME AFTER GC CALL (RHT)
	PUSH	P,C			;PRESERVE AC
	SOSGE	TRIGGER(A)		;COUNT DOWN
	PUSHJ	P,GCTRY			;TIME TO THINK ABOUT GC
	AOS	TINUSE(A)		;
RBG.1:	SKIPN	C,FBLIST(A)		;GET A BUFFER WITH FREES
	JRST 	RBG.2			;NONE TO BE HAD
RBG.1A:	AOS	BINUSE(C)
	SOS	TUNUSED(A)		;UPDATE ACTUAL FREE COUNT
	MOVE	B,@FFREE(C)		;GET A FREE
	EXCH	B,FFREE(C)		;AND UPDATE LIST
	SKIPE	FFREE(C)		;ANY LEFT ON FREE LIST
	JRST	POPCJ1			;YES, GO EXIT
	PUSH	P,B			;PRESERVE THE ONE WE GOT
	PUSHJ	P,UNLKC			;UNLINK FROM FBLIST
	MOVEI	B,FULLS-LINKS(A)	;
	PUSHJ	P,LNKCB			;AND PUT ON FULLS
	POP	P,B			;RETURN VALUE BACK
	JRST	POPCJ1			;GO RETURN
RBG.2:	MOVEI	C,RBSIZE		;GO GET A BUFFER
	PUSHJ	P,CORGET		;
	ERR	<NO SPACE FOR RECORD BUFFER>,1,POPCJ
	MOVE	C,B			;
	MOVEI	B,FBLIST-LINKS(A)		;PUT ON FREE LIST
	PUSHJ	P,LNKCB
	SETZB	TEMP,BINUSE(C)		;NONE IN USE YET
	MOVEI	B,FBDWD(C)		;BUILD SMALL BLOCKS
	MOVEM	B,FFREE(C)		;WILL BE FIRST FREE
	MOVE	LPSA,BLKSIZ(A)		;
RBG.3:	MOVEM	LPSA,(B)		;
	ADDB	B,(B)			;LINKS FORWARD & MOVES B DOWN
	CAIG	B,RBSIZE(C)		;OUT OF ROOM?
	AOJA	TEMP,RBG.3		;NO, DO ANOTHER
	SUB	B,LPSA			;WELL, BACK UP & ZERO THAT LAST ONE
	SUB	B,LPSA			;MUST BACK UP TWICE TO GET LAST GOOD
	SETZM	(B)			;BLOCK
	ADDM	TEMP,TUNUSED(A)		;UPDATE FREE COUNT
	JRST	RBG.1A			;DONE LINKING, GO TRY AGAIN

;; NOTE: THIS ROUTINE MAY WIPE OUT ALL ACS EXCEPT A
GCTRY:	MOVE	USER,GOGTAB		;
	SKIPE	RGCOFF(USER)		;TEST TO SEE IF AUTO GC IS DISABLED
	POPJ	P,			;DO NOTHING
	AOS	CULPRT(A)		;I'VE GOT A LITTLE LIST ...
	PUSH	P,A
	PUSHJ	P,$RECGC		;GO GARBAGE COLLECT & ADJUST TRIGGERS
	POP	P,A			;RETURN
	SOSGE	TRIGGER(A)		;SINCE USE UP ONE FOR THIS
	ERR	<WARNING: TRIGGER SET TO ZERO AFTER $RECGC>,1
	POPJ	P,

BEND RECORD

ENDCOM(REC)