00100	COMMENT ⊗   VALID 00017 PAGES
00200	C REC  PAGE   DESCRIPTION
00300	C00001 00001
00400	C00003 00002	 FANCY SMALL SPACE SERVICE 
00500	C00011 00003	 SPECIAL FIXED SIZE BLOCK HANDLERS: $FXGET, $FXDEL
00600	C00020 00004	 SAIREC -- SYSTEM RECORD HANDLER ROUTINES
00700	C00022 00005	 GETSTR, STRINIT, RELSTR, RSGC
00800	C00024 00006	 RECORD STRING SUBFIELD GARBAGE COLLECTION
00900	C00027 00007	 SAIREC -- $REC$ AND $RECFN
01000	C00033 00008	 SAIREC -- $RCINI 
01100	C00038 00009	 SAIREC -- FLDKIL ROUTINE
01200	C00043 00010	 SAIREC (RECGC) -- $ENQR,ENQRB,ENQRBB,PAMRK
01300	C00046 00011	 SAIREC (RECGC) -- %PSMRR
01400	C00048 00012	 SAIREC (RECGC) -- RCIMRK 
01500	C00050 00013	 SAIREC (RECGC) -- $MRK.1, $MFLDS
01600	C00053 00014	 SAIREC (RECGC) -- $RGCMK
01700	C00054 00015	 SAIREC (RECGC) -- $RGCSW
01800	C00057 00016	 SAIREC (RECGC) -- MAIN ROUTINE
01900	C00058 00017	 SAIREC (RECGC) -- $M1FLD
02000	C00060 ENDMK
02100	C⊗;
     

00100	;; FANCY SMALL SPACE SERVICE 
00200	COMPIL(SPC,,,,,,DUMMYFORGDSCISS)
00300	
00400	DEFINE SPCINS <$FUNLK,$FXBLD,$FXGET,$FXG,$FXDEL,$FXD>
00500	
00600	
00700	
00800	COMPXX(SPC,<$GETB,$GET1B,$DELB,$DEL1B,$FSADD,$FSINS,$FSINI,SPCINS>
00900		,<GOGTAB,X22,X33,CORGET,CORREL>
01000		,<SMALL SPACE SERVICE ROUTINES>,,HIIFPOSIB)
01100	
01200	BEGIN SPCSER -- SMALL FREE BLOCK SERVICE
01300	
01400	DSCR $GETB,$DELB,$GET1B,$DEL1B,$FSADD,$FSINS,$FUNLK
01500	
01600	These routines are generally useful for handling allocation of small
01700	blocks of storage.  Essentially, there is a linked list (homed at
01800	$FSLIS(<gogtab>) ) of blocks, each of which specifies a "space".
01900	
02000		<prev on chain>,,<next on chain>
02100		<addr of "allocate" routine>
02200		<addr of "deallocate" routine>
02300		< ... miscellaneous info ... >
02400			     :
02500		< ... miscellaneous info ... >
02600	
02700	Each allocate routine is assumed to take as parameters:
02800	
02900		A -- pointer to the space descriptor block
03000		C -- size of request
03100	
03200	results:
03300		skip return -- B points to a fresh block of the correct size
03400		no skip return -- failure
03500	
03600	Each deallocate routine is assumed to take as parameters:
03700	
03800		A -- pointer to the space descriptor block
03900		B -- pointer to block to be released
04000	
04100	results:
04200		skip return -- the block release was successful
04300		no skip return -- block release was unsuccessful
04400	
04500	Except as stated above, the routines are assumed to have no side effects.
04600	(except possibly to load USER with GOGTAB).
04700	
04800	$GET1B acts just like an allocate routine, except that it takes (in A)
04900		a pointer to the first block in a whole list of routines
05000		and returns as its value (in A) a pointer to the descriptor
05100		block of the last allocate routine called.
05200	
05300	$DEL1B acts like a deallocate routine except that it takes (in A)
05400		a pointer to the first block in a whole list of routines
05500		and returns as its value (in A) a pointer to the descriptor
05600		block of the last deallocate routine called.
05700	
05800	SAIL calling sequence routines that cdr down $FRELIS:
05900	
06000	<block>←$GETB(size) ;returns 0 if lose
06100	<result>←$DELB(blockid) ;returns 0 if lose, space id if win
06200	
06300	$FSLIS service routines (munch USER,TEMP,LPSA):
06400	
06500	$FSADD(<dcsr block>) ; adds named block to $FSLIS
06600	$FSINS(@<list owner>,<block addr>) ;adds named block to named list (at head)
06700	$FUNLK(<dscr block>) ; removes named block from any list
06800	
06900	⊗
07000	
07100	%GPROC ←← 1	;GETTING PROC
07200	%DPROC ←← 2	;DELETING PROC
07300	%FFRXX ←← 3	;INDEX OF FIRST FREE LOCATION
07400	
07500	HERE($GETB)
07600		MOVE	C,-1(P)		;GET SIZE
07700		MOVE	USER,GOGTAB	;
07800		SKIPE	A,$FSLIS(USER)
07900		PUSHJ	P,$GET1B	;CDR DOWN LIST
08000		TDZA	A,A		;NO JOY
08100		MOVE	A,B		;THE RESULT
08200	RET22:	SUB	P,X22
08300		JRST	@2(P)		;RETURN
08400	
08500	HERE($DELB)
08600		MOVE	B,-1(P)		;THE BLOCK
08700		MOVE	USER,GOGTAB
08800		SKIPE	A,$FSLIS(USER)
08900		PUSHJ	P,$DEL1B
09000		MOVEI	A,0
09100		JRST	RET22
09200	
09300	GET1B1:	HRRZ	A,(A)		;PART OF THE $GET1B LOOP
09400	HERE($GET1B)
09500		JUMPE	A,CPOPJ		;CHECK NULLITUDE
09600		PUSHJ	P,@%GPROC(A)	;CALL THE ROUTINE
09700		JRST	GET1B1		;LOOP ON TO NEXT, THIS ONE LOST
09800	CPOPJ1:	AOS	(P)		;SKIP RETURN IF WIN
09900	CPOPJ:	POPJ	P,		;RETURN
10000	
10100	DEL1B1:	HRRZ	A,(A)		;SAME KLUGE
10200	HERE($DEL1B)		
10300		JUMPE	A,CPOPJ		;
10400		PUSHJ	P,@%DPROC(A)	;ALLOCATE ROUTINE
10500		JRST	DEL1B1		;LOST, TRY NEXT
10600		JRST	CPOPJ1		;WIN
10700	
10800	HERE($FSADD)		;LINKS IN ONE BLOCK
10900		MOVE	USER,GOGTAB
11000		MOVEI	LPSA,$FSLIS(USER)
11100		PUSH	P,LPSA		;THIS IS THE OWNER
11200		PUSH	P,-2(P)		;THE RECORD TO ADD
11300		PUSHJ	P,$FSINS	;CALL INSERT ROUTINE
11400		JRST	RET22		;GO RETURN
11500	
11600	HERE($FUNLK)
11700		MOVE	LPSA,-1(P)	;THE BLOCK WE ARE TO UNLINK
11800		MOVE	TEMP,(LPSA)	;THE LEFT,,RIGHT
11900		TRNE	TEMP,-1		;IF HAVE A RIGHT HAND
12000		HLLM	TEMP,(TEMP)	;LET HIM HOLD MY LEFT
12100		MOVSS	TEMP		;SWAP HALVES
12200		HLRM	TEMP,(TEMP)	;LET HIM HOLD MY RIGHT
12300		JRST	RET22		;DONE
12400	
12500	HERE($FSINS)		;
12600		HRRZ	TEMP,-1(P)	;THE THING TO INSERT
12700		HRRZ	LPSA,-2(P)	;ADDRESS OF OWNER CELL
12800		HRLM	LPSA,(TEMP)	;REMEMBER AS BACK POINTER
12900		EXCH	LPSA,(LPSA)	;LPSA IS NOW FWD PTR
13000		TRNE	LPSA,-1		;WAS THE CHAIN NULL?
13100		HRLM	TEMP,(LPSA)	;NO HE GETS A BACK PTR TOO
13200		HRRM	LPSA,(TEMP)	;OLD HEAD IS NEW RIGHT BROTHER
13300	RET33:	SUB	P,X33		;RETURN
13400		JRST	@3(P)		;
13500	
13600	NOLOW <
13700	NOUP <
13800	REN <
13900		USE
14000	>;REN
14100	FSI:	0
14200		$FSINI
14300		0
14400		LINK	%INLNK,FSI
14500	REN <
14600		USE HIGHS
14700	>;REN
14800	>;NOUP
14900	>;NOLOW
15000	
15100	HERE($FSINI)
15200		SKIPN	USER,GOGTAB
15300		ERR	<$FSINI CALLED W/O GOGTAB INITIALIZED>
15400		SKIPE	$FSLIS(USER)
15500		ERR	<$FSINI CALLED WITH THINGS ON $FSLIS>,1
15600		MOVEI	C,3	;JUST A LITTLE BLOCK
15700		PUSHJ	P,CORGET
15800		ERR	<CORGET DIDN'T GIVE ME ANY>,1
15900		HRRZM	B,$FSLIS(USER)
16000		HRLZI	C,$FSLIS(USER)
16100		MOVEM	C,(B)
16200		MOVEI	C,CORGET
16300		MOVEM	C,%GPROC(B)
16400		MOVEI	C,[PUSHJ P,CORREL
16500			   AOS(P)
16600			   POPJ P,
16700			  ]
16800		MOVEM	C,%DPROC(B)
16900		POPJ	P,
     

00100	;; SPECIAL FIXED SIZE BLOCK HANDLERS: $FXGET, $FXDEL
00200	
00300	DSCR $FXG,$FXD,$FXGET,$FXDEL,$FXSPC,$FXBLD
00400	
00500	DES These routines operate on space descriptor blocks of the form:
00600	
00700	word 0:	left,,right
00800		$FXG
00900		$FXD
01000	blksiz:	block size
01100	minsiz: minimum size request to honor
01200	blkcnt: number of blocks per space
01300	usecnt:	number of blocks allocated from this space
01400	maxadr: address of last record in this space
01500	frelis:	free list of blocks
01600	sublis:	a list header word for other blocks with this format
01700	firblk: ... first "data word" in the space ...
01800		:
01900		< blkcnt*blksiz +firblk words of corget space >
02000		:
02100	
02200	Note: 	the "top" such block (Ie the one on the $FSLIS) will usually
02300		contain the routines $FXGET & $FXREL & will have actually no
02400		blocks (ie frelis=0).  They will mapcar down their subordinates
02500		looking for customers.  The subordinates ($FXG & $FXD) will
02600		work by having brothers.  If a $FXG block gets bloated, it
02700		will just fail.  If one goes empty, it will just go away.
02800		If all of a $FXGET block's subordinates lose, it just adds a 
02900		new one as the left subchild.
03000	
03100	A space descriptor block ($FXGET style) may be built by the runtime routine
03200	
03300	<block> ← $FXSPC(<block size>,<min size>,<block count>)
03400	
03500	Thus a new space for allocating blocks of size 9 to 16 could be
03600	defined & added to $FSLIS by the statement
03700	
03800		$FSADD($FXSPC(16,9,32)); ! 32 blocks per buffer;
03900	
04000	The routine $FXBLD(@<chain header>,<template block>) makes a fresh
04100	block patterned after the template & puts it on the named chain.
04200	
04300	⊗
04400	%FXIX ←← %FFRXX	;FIRST LEGAL FIELD
04500	DEFINE $FXFLD(ID) <
04600		ID ←← %FXIX
04700		%FXIX ←← %FXIX+1
04800	>
04900	$FXFLD	%BLKSIZ	;BLOCK SIZE
05000	$FXFLD	%MINSIZ	;MIN ACCEPTABLE SIZE
05100	$FXFLD	%BLKCNT	;NUMBER OF BLOCKS PER SPACE
05200	$FXFLD	%USECNT	;NUMBER OF BLOCKS ALLOCATED FROM THIS SPACE
05300	$FXFLD	%MAXADR	;MAX ADDRESS OF A BLOCK IN THIS SPACE
05400	$FXFLD	%FRELIS	;FREE LIST
05500	$FXFLD	%SUBLIS	;SUBLIST OF SIMILAR BLOCKS
05600	$FXFLD	%FIRBLK	;FIRST DATA WORD
05700	
05800	HERE($FXGET)
05900	
06000		CAMG	C,%BLKSIZ(A)	;WOULD IT FIT
06100		CAMGE	C,%MINSIZ(A)	;
06200		POPJ	P,		;NO
06300		PUSH	P,A		;YEP GO DOWN KINDERN
06400	FGTRY:	SKIPE	A,%SUBLIS(A)	;IF ANY
06500		PUSHJ	P,$GET1B	;
06600		JRST	ADDAB		;ADD A BLOCK
06700	FGWIN:	POP	P,A		;I AM SUCH A WINNER
06800		JRST	CPOPJ1		;& GO WIN
06900	;#  # RHT ! I HAD LEFT OUT THE RESTORE OF A
07000	ADDAB:	MOVE	A,(P)		;SINCE A IS ZERO AT THIS POINT
07100		MOVEI	B,%SUBLIS(A)	;OWNER OF NEW LIST
07200	
07300		PUSH	P,B		;BUILD CALL TO $FXBLD
07400		PUSH	P,-1(P)		;PUSH A COPY OF A
07500		PUSHJ	P,$FXBLD	;MAKES A NEW SPACE FOR $FXG
07600	
07700		MOVE	A,(P)		;WHERE WE HAD SAVED IT
07800		JRST	FGTRY		;GO TRY AGAIN -- EXPECT TO WIN
07900	
08000	HERE($FXG)
08100		CAMG	C,%BLKSIZ(A)	;WOULD IT FIT?
08200		CAMGE	C,%MINSIZ(A)	;
08300		POPJ	P,		;NO WAY
08400		SKIPN	B,%FRELIS(A)	;ONE ON FREE LIST
08500		POPJ	P,		;NO SUCH LUCK
08600		AOS	%USECNT(A)	;ONE LESS FREE NOW
08700		PUSH	P,(B)		;KLUGY WAY TO COPY FREE LIST
08800		POP	P,%FRELIS(A)	;PUTS BACK THE NEXT ONE
08900		JRST	CPOPJ1		;GO SKIP RETURN -- WE WIN
09000	
09100	HERE($FXDEL)		
09200		PUSH	P,A		;IN THIS CASE, JUST GO DOWN CHILDREN
09300		SKIPE	A,%SUBLIS(A)	;
09400		PUSHJ	P,$DEL1B	;LIKE SO
09500		SOS	-1(P)		;WILL NA SKIP RETURN
09600		POP	P,A		;GET OWN NAME BACK
09700		JRST	CPOPJ1		;I AM A WINNER
09800	
09900	HERE($FXD)		
10000		CAMG	B,%MAXADR(A)	;IN RANGE?
10100		CAIG	B,(A)		;A IS MY OWN POINTER,REMEMBER
10200		POPJ	P,		;NOPE
10300		SOSG	%USECNT(A)	;IF THIS WAS THE LAST
10400		JRST	BIGKIL		;THEN THE WHOLE BLOCK GOES AWAY
10500		PUSH	P,B		;MUST PRESERVE
10600		HRRZS	B		;JUST BE SURE RHS ONLY IS ON
10700		EXCH	B,%FRELIS(A)	;SAVE AWAY NEW LIST
10800		MOVEM	B,@%FRELIS(A)	;& LINK IT TO OLD
10900		POP	P,B		;GET BACK
11000		JRST	CPOPJ1		;WHAT WINNAGE!
11100	BIGKIL:	PUSH	P,LPSA		;SAVE A COUPLE
11200		PUSH	P,TEMP		;
11300		PUSH	P,B
11400		PUSH	P,A		;GO UNLINK THIS BLOCK
11500		PUSHJ	P,$FUNLK	;LIKE SO
11600		MOVE	B,A		;GO CLOBBER THE WHOLE BLOCK
11700		PUSHJ	P,CORREL	;LIKE SO
11800		POP	P,B		;A PITY CANNOT JUST ZERO OUT B
11900		POP	P,TEMP		;GET ACS BACK
12000		POP	P,LPSA		;
12100		JRST	CPOPJ1		;RETURN
12200	
12300	HERE($FXSPC)
12400		MOVEI	C,%FIRBLK	;HOW BIG IT NEEDS TO BE
12500		PUSHJ P,CORGET		;USE CORGET SPACE FOR THIS (DONT REALLY HAVE TO
12600		ERR <NO CORE TO BE HAD>,1  ; BUT MAY WANT TO DO THIS AT FUNNY TIMES)
12700		MOVE	A,B		;WHERE WE WILL RETURN VALUE
12800		HRL	B,B		;CLEANSE IT
12900		HRRI	B,1(B)
13000		SETZM	(B)
13100		BLT	B,%FIRBLK-1(A)
13200		MOVEI	B,$FXGET	;
13300		MOVEM	B,%GPROC(A)
13400		MOVEI	B,$FXDEL
13500		MOVEM	B,%DPROC(A)
13600		POP	P,B
13700		POP	P,%BLKCNT(A)
13800		POP	P,%MINSIZ(A)
13900		POP	P,%BLKSIZ(A)
14000		JRST	(B)
14100	
14200	
14300	HERE($FXBLD)		
14400		
14500		MOVE	A,-1(P)		;MUST ADD A BLOCK
14600		PUSH	P,C		;SAVE THIS SIZE REQUEST
14700		PUSH	P,TEMP		;SAVE A COUPLE ACS
14800		PUSH	P,LPSA		;WHICH WE PROMISSED NOT TO MUNGE
14900		PUSH	P,B		
15000		SKIPN	C,%BLKCNT(A)	;
15100		ERR	<IT DOESN'T HELP YOU MUCH TO ALLOCATE ZERO MORE BLOCKS>,1,L1DON
15200		IMUL	C,%BLKSIZ(A)	;B ← NOMINAL BLOCK SIZE * COUNT + OVERHEAD
15300		ADDI	C,%FIRBLK	; 
15400		PUSHJ	P,CORGET	;A BLOCK OF THIS GREAT SIZE
15500		ERR	<COULDN'T GET ANY MORE SPACE FROM CORGET>,1
15600		MOVEI	TEMP,%FIRBLK(A)	;NOW CHAIN ALL SUB-BLOCKS TOGETHER
15700		MOVEI	LPSA,0		;
15800		MOVE	C,%BLKCNT(A)	;SO WE WILL COUNT DOWN
15900		MOVEM	C,%BLKCNT(B)	;ALSO, THE BLOCK COUNT FOR THIS
16000	L1B:	MOVEM	LPSA,(TEMP)	;POINT TO NEXT
16100		MOVE	LPSA,TEMP	;REMEMBER THE BACK POINTER
16200		ADD	TEMP,%BLKSIZ(A)	;NEXT BLOCK
16300		SOJG	C,L1B		;COUNT DOWN TO ZERO
16400	L1DON:	MOVEM	LPSA,%FRELIS(B)	;THIS IS THE FIRST FREE
16500		MOVEM	LPSA,%MAXADR(B)	;ALSO THE MAX ADDRESS BLOCK IN THIS SPACE
16600		SETZM	%USECNT(B)	;USE COUNT IS ZERO
16700		SETZM	%SUBLIS(B)	;THE SUBLIST IS ZERO
16800		MOVE	LPSA,%MINSIZ(A)	;COPY THESE, TOO (HRROI POP IS FASTER
16900		MOVEM	LPSA,%MINSIZ(B)	;BUT THIS ALLOWS EASIER REARRANGEMENT)
17000		MOVE	LPSA,%BLKSIZ(A)	;
17100		MOVEM	LPSA,%BLKSIZ(B)	;
17200		MOVEI	LPSA,$FXG	;THE HANDLERS FOR THESE
17300		MOVEM	LPSA,%GPROC(B)	;REMEMBER THE HANDLER
17400		MOVEI	LPSA,$FXD
17500		MOVEM	LPSA,%DPROC(B)	;
17600		PUSH	P,-6(P)		;GO LINK ONTO THIS ADDRESS
17700		PUSH	P,B		;THE BLOCKID
17800		PUSHJ	P,$FSINS	;USING THE STANDARD INSERTER
17900		POP	P,B
18000		POP	P,LPSA		;GET ACS BACK
18100		POP	P,TEMP		;
18200		POP	P,C		;
18300		SUB	P,X33
18400		JRST	@3(P)		;RETURN
18500	
18600	BEND SPCSER
18700	
18800	ENDCOM	(SPC)
     

00100	;; SAIREC -- SYSTEM RECORD HANDLER ROUTINES
00200	COMPIL(REC,<$REC$,FLDKIL,$RERR,$RECGC,$M1FLD,$ENQR,$RECFN,$RCINI,$RMARK>
00300		,<RECQQ,ALLFOR,ARYEL,CORGET,CORREL,X11,X22,X33,CLSLNK,STRCHN,SGINS,RSGCLK,GOGTAB,$DEL1B,$GET1B>
00400		,<SAIL RECORD HANDLER>,<$RDREF,$RALLO>);
00500	
00600	BEGIN RECORD
00700	IFE ALWAYS, <
00800		EXTERNAL	$CLASS,RECCHN,RGCLST,RBLIST,RUNNER,SPRPDA,PLISTE,ACF
00900	>;IFE ALWAYS
01000	
01100	PDA ← 7		;DEF USED BY THE GARBAGE COLLECTOR
01200	
01300	
01400	; FORMAT OF ALL RECORDS
01500	CLSRNG←-2		;RING OF COMPILED-IN CLASSES
01600	RING←-1			;RING OF RECORDS OF SAME CLASS
01700	RMARK←←0		;GARBAGE COLLECTOR MARK CHAIN IN LEFT HALF
01800	CLSPTR←←0		; RIGHT HALF OF THIS WORD POINTS TO CLASS TEMPLATE RECORD
01900	
02000	
02100	; FORMAT OF RECORD CLASS TEMPLATES, IE CLASS="CLASS"
02200			;WORDS -1 AND 0 ARE STANDARD, IE. RING AND MARK
02300	RECRNG←←1	;RING OF RECORDS OF THIS CLASS - FOR RECORDS OF CLASS = "CLASS"
02400	HNDLER←←2	;HANDLER PROCEDURE FOR THIS CLASS
02500	RECSIZ←←3	;COUNT OF # FIELDS IN RECORDS OF THIS CLASS
02600	TYPARR←←4	;INTEGER ARRAY OF TYPE INFO FOR FIELDS	
02700			;	- 0TH WORD IN ARRAY IS TYPE BITS FOR THE CLASS
02800	TXTARR←←5	;STRING ARRAY OF FIELD NAMES 
02900			;	- 0TH ELEMENT IS NAME OF RECORD CLASS
03000	
03100	;;** VARIOUS "TYPE BITS" ARE NOW DEFINED UP IN HEAD
     

00100	;; GETSTR, STRINIT, RELSTR, RSGC
00200	
00300	; ROUTINE TO SET UP A BLOCK OF FREE STRING DESCRS.
00400	FSTRSIZ←←20
00500	
00600	STRINIT:	
00700		MOVEI C,2*FSTRSIZ+1		;ENOUGH ROOM FOR 20 STRINGS
00800		PUSHJ P,CORGET
00900		ERR <NO CORE FOR RECORD STRINGS>,1,ZPOPJ
01000	;;*** CHECK THAT CORGET SETS UP USER ***
01100		MOVE A,STBLST(USER)	;LINKED LIST OF FREE STRING DESCR ARRAYS
01200		MOVEM A,(B)		;LINK NEW ONE IN
01300		MOVEM B,STBLST(USER)		;
01400		MOVEI A,FSTRSIZ
01500		ADDI B,2
01600		MOVEM B,STRCHN		;HEAD OF NEW CHAIN
01700	L:	SETZM -1(B)
01800		ADDI B,2
01900		HRRZM B,-2(B)		;CONSTRUCT FREE CHAIN
02000		SOJG A,L
02100		SETZM -2(B)		;ZERO LAST ENTRY
02200		MOVE A,STRCHN
02300		POPJ P,
02400	
02500	; ROUTINE TO GET A FREE STRING DESCRIPTOR  (CLOBBERS A & B AND SOMETIMES THE REST)
02600	GETSTR:	SKIPN A,STRCHN		;ANY FREE STRINGS?
02700		PUSHJ P,STRINIT		;SET UP ANOTHER BLOCK OF STRINGS
02800		MOVE B,(A)
02900		MOVEM B,STRCHN		;CDR DOWN FREE CHAIN
03000		SETZM -1(A)		;CLEAR BOTH WORDS
03100		SETZM (A)
03200		POPJ P,
03300		
03400	
03500	; RETURN A STRING TO FREE STRING LIST;
03600	RELSTR:	SKIPN A,(A)		; POINTER TO STRING ARRAY ENTRY
03700		JRST CPOPJ		; NOTHING TO DO
03800		MOVE B,STRCHN		; CHAIN OF FREE STRINGS
03900		HRRZM B,(A)		; CHAIN TOGETHER 
04000		SETZM -1(A)		; ZERO CHARACTER COUNT
04100		MOVEM A,STRCHN	
04200		POPJ P,
04300	
04400	
     

00100	; RECORD STRING SUBFIELD GARBAGE COLLECTION
00200	
00300	BEGIN  RSGC
00400	F←←E+1
00500	; STRING AND STRING ARRAY SUBFIELDS ARE MARKED BY SWEEPING
00600	;	THROUGH ALL RECORD CLASSES LOOKING FOR ONES THAT ARE RELEVENT,
00700	;	AND MARKING STRING AND STRING ARRAY SUBFIELDS OF ALL RECORDS
00800	;	UNDER THE APPROPRIATE CLASSES
00900	
01000	↑RSGCMK:	
01100		HRRZ	D,RECRNG+$CLASS		;RING OF ALL CLASSES
01200	
01300	RSGSWC:	MOVE	TEMP,@TYPARR(D)		;TYPE BITS FOR THIS CLASS
01400		TRNN	TEMP,HASSTR		;DOES IT HAVE STRING OR STRING ARRAY SUBFIELDS?
01500		JRST	NXTCLS			;NO STRING ARRAYS IN THIS CLASS
01600		HRRZ	E,RECRNG(D)		;RING OF RECORDS FOR THIS CLASS;
01700		JRST	NXTREC
01800	
01900	RSGSWP:	MOVN	F,RECSIZ(D)
02000		MOVSS	F
02100		HRR	F,TYPARR(D)		;MAKE AOBJN WORD FOR TYPE ARRAY
02200		PUSH 	P,E
02300	
02400	DOFLD:	ADDI 	E,1
02500		LDB 	B,[POINT 6,1(F),=12]	;GET TYPE BITS
02600		CAIN	B,STTYPE
02700		JRST	DOSTR			;IT'S A STRING
02800		CAIN	B,ARRTYP+STTYPE		
02900		JRST	DOSTRA			;IT'S A STRING ARRAY
03000	NXFLD:	AOBJN	F,DOFLD
03100		POP	P,E
03200		HRRZ	E,RING(E)		;POINT AT NEXT IN CLASS
03300	NXTREC:	CAIE	E,RECRNG-RING(D)	;IS IT HEAD OF CLASS?
03400		JRST	RSGSWP			;NOPE, CONTINUE
03500	
03600	NXTCLS:	HRRZ	D,RING(D)		;NEXT CLASS ON RING OF CLASSES
03700		CAIE	D,$CLASS+RECRNG-RING	;HEAD OF RING OF CLASSES?
03800		JRST	RSGSWC			;NOPE, CONTINUE
03900		POPJ 	P,			;DONE AT LAST
04000		
04100	DOSTR:	MOVE	A,(E)			;GET SUBFIELD -- POINTER TO STRING DESCR
04200		SUBI	A,1			;CRETINS - POINT TO FIRST WORD OF DESCR
04300		PUSHJ	P,@-2(P)		;CALL STRING MARK ROUTINE
04400		JRST	NXFLD
04500	
04600	DOSTRA:	PUSH	P,D			
04700		MOVE	D,(E)			;GET SUBFIELD -- POINTER TO STRING ARRAY
04800		MOVN	A,-2(D)			;STRING ARRAY LENGTH
04900		HRL	D,A			;MAKE AOBJN WORD
05000	STALP:	MOVEI 	A,-1(D)			;POINTER TO FIRST WORD OF STRING DESCR
05100		PUSHJ	P,@-3(P)			
05200		AOBJN	D,.+1
05300		AOBJN	D,STALP
05400		POP	P,D
05500		JRST	NXFLD
05600	
05700	BEND RSGC
     

00100	;; SAIREC -- $REC$ AND $RECFN
00200	;;$REC$ CALLED VIA PUSH	P,[OP]
00300	;		   PUSH P,ARG1
00400	;		   PUSHJ P,$REC$ 
00500	; IS ASSUMED TO WIPE OUT THE ACS
00600	;;$RECFN IS CALLED JUST LIKE $REC$
00700	
00800	$RDISP:	JRST	$RDREF		;DEREFERENCE ARG1
00900		JRST	$RALLO		;ALLOCATE RECORD WITH CLASS ARG1
01000		JRST	CPOPJ		;2			NON-STANDARD PRINT ROUTINE?
01100		JRST	CPOPJ		;3			NON-STANDARD READ ROUTINE?
01200		JRST	$MFLDS		;4 -- MARK ALL FIELDS OF A RECORD
01300		JRST	$DIE		;5 DELETE SPACE FOR RECORD
01400	$RMAX ←← (.-$RDISP)-1
01500	
01600	HEREFK($RECFN,$RECF.)
01700		SKIPN	A,-1(P)		;PICK UP ARG1
01800		JRST	NLARG1		;
01900		MOVE	B,-2(P)		;PICK UP OP
02000		CAIE	B,1		;RALLO IS FUNNY
02100		HRRZ	A,CLSPTR(A)	;
02200	HACK <
02300		HRLZI	C,777740	;OLD-STYLE COUNT FIELD
02400		TDNE	C,(A)		;CHECK TO BE SURE NOT OLD-STYLE CLASS
02500		ERR	<OLD STYLE RECORD DESCRIPTOR.  RECOMPILE>
02600	>;HACK
02700		JRST	@HNDLER(A)	;DISPATCH TO HANDLER ROUTINE
02800	NLARG1:	ERR	<NULL ARGUMENT TO $RECFN>,1
02900		SUB	P,X33		;
03000		JRST	@3(P)		;RETURN
03100	
03200	HERE($REC$)		
03300		POP	P,C		;RET ADR
03400		POP	P,A
03500		EXCH	C,(P)		; NOW C=OP, A=ARG1
03600		CAILE	C,$RMAX
03700		POPJ	P,
03800		JUMPN	C,@$RDISP(C)	; OBEY COMMAND
03900	
04000	↑↑$RDREF:
04100		ERR	<CALL ON $RDREF IN RECORD GC VERSION>,1
04200		POPJ	P,
04300	
04400	$DIE:	JUMPE	A,CPOPJ			;
04500		PUSH	P,A			; SO CAN LATER CALL CORREL
04600		HLRZ	B,RING(A)
04700		HRRZ	C,RING(A)
04800		HRRM	C,RING(B)
04900		HRLM	B,RING(C)		; UNLINK FROM RING OF CLASS
05000	
05100		HRRZ	C,CLSPTR(A)		; CLASS ADDRESS
05200		PUSH    P,RECSIZ(C)		; RECORD SIZE 
05300		HRRZ	C,TYPARR(C)		; CLASS TYPE ARRAY
05400		SUBI	C,(A)			; CORRECTION FACTOR
05500		ADDI	A,1			; FIRST DATA ELEMENT
05600		HRLI	C,(<POINT =13,(A),=12>); DESCRIPTOR TO GET BITS
05700		PUSH	P,C
05800	
05900	GETFLD:	SOSGE	-1(P)			; IS THIS THE LAST FIELD
06000		JRST	NOMORE
06100		LDB	C,(P)			; GET FIELD
06200		DPB	C,[POINT =13,A,=12]	; PUT DESCRIPTOR BITS IN PLACE
06300		PUSHJ	P,FLDKIL		; GO KILL THIS FIELD
06400		AOJA	A,GETFLD		; GO ON TO NEXT
06500	
06600	NOMORE:	SUB	P,X22			; JUST POP TWO OFF
06700		POP	P,B			; THE CORREL POINTER
06800		SUBI	B,1			; NOW IT IS (THE REF CNT WORD, REMEMBER)
06900		MOVE	USER,GOGTAB		; FREE THE SPACE UP
07000		MOVE	A,$FSLIS(USER)		; BY CALLING THE FREER-UPPER
07100		PUSHJ	P,$DEL1B		; 
07200		ERR	<CONFUSION IN FREEING A BLOCK>,1
07300		POPJ	P,
07400	
07500	↑↑$RALLO:
07600	HACK <
07700		HRLZI	C,777740	;OLD-STYLE COUNT FIELD
07800		TDNE	C,(A)		;CHECK TO BE SURE NOT OLD-STYLE CLASS
07900		ERR	<OLD STYLE RECORD DESCRIPTOR.  RECOMPILE>
08000	>;HACK
08100		MOVE	C,RECSIZ(A)	; A = RECORD CLASS ID.  GET THE WORD COUNT
08200		ADDI	C,2		; RECORD SIZE +1 FOR RING WORD
08300					; AND +1 FOR DESCRIPTOR WORD
08400		PUSH	P,A		; EVENTUALLY, BECOMES THE RECID POINTER
08500		MOVE	USER,GOGTAB	; GET THE SYSTEM FREE LIST
08600		MOVE	A,$FSLIS(USER)	;
08700		PUSHJ	P,$GET1B	; MAY WANT MORE EFFICIENCY LATER
08800		ERR	<NO CORE FOR RECORD ALLOCATION>,1,ZPOPJ
08900		MOVEI	A,1(B)		;THE POINTER WE WILL ACTUALLY RETURN
09000	
09100	;;#SF# ! USED TO BE (B)
09200		ADDI	C,-1(B)		;STOPPING PLACE
09300		SETZM	(B);		;ZERO OUT (ALSO REF CNT ← 0)
09400		HRL	B,B		;BUILD BLT PTR
09500		HRRI	B,1(B)
09600		BLT	B,(C)		;BLT THEM AWAY
09700		PUSH 	P,A
09800		PUSH	P,A
09900		MOVE	A,-2(P)		;GET CLASS POINTER
10000		MOVE B,@TYPARR(A)	;GET TYPE BITS FOR CLASS
10100		TRNN B,HASSTR	
10200		JRST NOSTRS		;NO STRINGS TO ALLOCATE
10300		MOVN C,RECSIZ(A)	;WE GOT STRINGS
10400		MOVSS C
10500		HRR C,TYPARR(A)		;BUILD IOWD FOR TYPARR
10600	
10700	STALLO:	MOVS B,1(C)
10800		AOS (P)
10900		CAIE B,140		;### CHANGE THIS TO TYPE BIT SYMBOL
11000		JRST NXTFLD
11100		PUSH P,C
11200		PUSHJ P,GETSTR		;GET A FREE STRING DESCR
11300		POP P,C
11400		MOVEM A,@(P)		;STORE POINTER TO STRING DESCR IN FIELD
11500	NXTFLD:	AOBJN C,STALLO
11600	NOSTRS:	SUB P,X11
11700		POP P,A
11800	
11900	RNGIT2:	POP	P,B		; CLASSID
12000	RNGIT:	HRRZM	B,CLSPTR(A)	; PUT ZERO IN MARK FIELD
12100		ADDI	B,RECRNG-RING	; OFFSET FOR HEAD OF CLASS
12200		HRRZ	C,RING(B)	; RING OF RECORDS FOR THE CLASS
12300		HRRZM	C,RING(A)	; NEW RECORD POINTS TO RING
12400		HRRM	A,RING(B)	; CLASS POINTS TO NEW RECORD
12500		HRLM	B,RING(A)	; NEW RECORD POINTS TO CLASS
12600		HRLM	A,RING(C)	; RING POINTS BACK TO NEW RECORD
12700		POPJ	P,		;RETURN
12800	
12900	ZPOPJ:	MOVEI	A,0
13000		POPJ	P,
13100	
13200		
13300		
13400	
13500		
13600		
13700		
13800	
13900	HERE($RERR)
14000		ERR	<ACCESS TO A SUBFIELD OF A NULL RECORD>,1
14100		POPJ	P,
14200	
     

00100	;; SAIREC -- $RCINI 
00200	
00300	;; SETS UP $CLASS, THEN RUNS DOWN THE CLASS LINKS
00400	;; HOMED ON CLSLNK & SETS UP THE QUAM-STYLE RING LINKAGES.
00500	;; ALSO ZEROS ALL OWN (AND OUTER BLOCK) RECORD POINTERS.
00600	
00700	NOLOW <
00800	NOUP <
00900	REN <
01000		USE
01100	>;REN
01200	RCLK:	0
01300		$RCINI
01400		0
01500		LINK	%INLNK,RCLK
01600	REN <
01700		USE	HIGHS
01800	>;REN
01900	>;NOUP
02000	>;NOLOW
02100	
02200	HEREFK($RCINI,$RCIN.)
02300		PUSH	P,[RSGCMK]		;POINTER TO RECORD STRING GC
02400		MOVEI 	A,RSGCLK+1(USER)
02500		PUSH 	P,A
02600		PUSHJ 	P,SGINS			;ENQUE RECORD STRING GARBAGE COLLECTOR
02700	
02800	
02900		MOVE	A,[XWD $CLASS,$CLASS]	;
03000		HRRZM	A,$CLASS		;INITIALIZE $CLASS
03100		MOVEM	A,$CLASS+RECRNG		;
03200		ADD	A,[XWD RECRNG-RING,RECRNG-RING];
03300		MOVEM	A,$CLASS+RING		;
03400		MOVEI	A,$REC$			;HANDLER
03500		MOVEM	A,$CLASS+HNDLER		;
03600		MOVEI	A,$CLSTY		;TYPE ARRAY
03700		MOVEM	A,$CLASS+TYPARR		;
03800		MOVEI	A,$CLSTX+1		;TEXT ARRAY
03900		MOVEM	A,$CLASS+TXTARR		;
04000		MOVEI	A,5			;TEST MUNGAGE
04100	;***	CAME	A,$CLASS+RECSIZ		;OF THE COUNT
04200	;***	ERR	<WARNING.  $CLASS WAS MUNGED>,1
04300		MOVEM	A,$CLASS+RECSIZ
04400	
04500		SKIPN	D,CLSLNK		;PICK UP THE CLASS LIST
04600		POPJ	P,			;IF NO CLASSES, THEN DONE
04700	LNKCLS:	MOVEI	B,$CLASS		;CLASS OF CLASSES
04800		MOVEI	A,-CLSRNG(D)		;POINT AT CLASS DESCRIPTOR
04900		PUSHJ	P,RNGIT			;LINK THIS CLASS ONTO CLASS RING
05000		MOVEI	D,RECRNG-RING(A)	;SET UP RECORD RING
05100		HRL	D,D			;RECRNG SHOULD POINT AT ITSELF
05200		MOVEM	D,RECRNG(A)		;MAKE IT DO SO
05300		HRRZ	D,CLSRNG(A)		;POINT AT NEXT CLASS
05400		JUMPN	D,LNKCLS		;GO ON IF HAVE ANY LEFT
05500		MOVE	USER,GOGTAB
05600		SETZM 	STRCHN			;ZERO CHAIN OF FREE STRING DESCRS
05700		SETZM 	STBLST(USER)		;AND CHAIN OF FREE STRING DESCR ARRAYS
05800	
05900	; ZERO ALL THE OWN AND OUTER BLOCK RECORD POINTERS
06000		HRRZ D,RBLIST			;CHAIN OF ALL OWN AND OUTER BLOCK RECORD POINTERS
06100		JRST ZERO3
06200	ZERO1:	HRRZ D,(D)			;NEXT BLOCK IN RBLIST CHAIN
06300	ZERO3:	JUMPE D,CPOPJ			;DONE
06400		HRRZI B,1(D)
06500	ZERO2:	SKIPN C,(B)			;GET AOBJN WORD
06600		JRST ZERO1			;DONE WITH THIS BLOCK
06700		SETZM (C)			;ZERO THE RECORD POINTER (ARRAY)
06800		AOBJN C,.-1			
06900		AOJA B,ZERO2
07000	
07100		$CLSTY				;TYPE BITS ARRAY HEADER
07200		0				;LB
07300		TXTARR				;UB
07400		1
07500		XWD	1,TXTARR+1		;NDIMS,,TOTAL SIZE
07600	$CLSTY:	CMPLDC+NODELC+HASSTR		;TYPE BITS
07700		INTYPE*1B12			;RECRNG
07800		INTYPE*1B12			;HNDLER
07900		INTYPE*1B12			;RECSIZ --ONLY "REAL" INTEGER
08000		(ARRTYP+INTYPE)*1B12		;TYPE ARRAY
08100		(ARRTYP+STTYPE)*1B12		;TEXT ARRAY
08200	
08300	CLSTXT:	ASCIZ /$CLASSRECRNGHNDLERRECSIZTYPARRTXTARR/
08400	
08500	DEFINE SUBSTR(STR,N,CNT) <
08600		CNT
08700		POINT	7,STR-1+(N+4)/5,6+7*(N+4-5*((N+4)/5))
08800		>
08900	
09000	DEFINE IDTXT(CNT) <
09100		SUBSTR(CLSTXT,II,CNT)
09200		II ←← II+CNT
09300		>
09400	
09500		II ←← 0
09600	
09700		$CLSTX+1			;TEXT ARRAY HEADER
09800		0				;LB
09900		TXTARR				;UB
10000		1				;MUL(1)
10100		XWD	-1,2*(TXTARR+1)		;TOTAL SIZE
10200	$CLSTX:	IDTXT(6)			;$CLASS
10300		IDTXT(6)			;RECRNG
10400		IDTXT(6)			;HNDLER
10500		IDTXT(6)			;RECSIZ
10600		IDTXT(6)			;TYPARR
10700		IDTXT(6)			;TXTARR
10800	
     

00100	;; SAIREC -- FLDKIL ROUTINE
00200	
00300	HERE(FLDKIL)
00400			;CALLED WITH REFITEM TYPE DESCRIPTOR IN A
00500			;WILL TAKE ALL APPROPTIATE ACTION
00600			;IF TMPB IS ON IN A, THEN ASSUMES THAT CALLED FROM LEAP
00700			;  -- THUS, IF TMPB AND NOT REFB, WILL DO THE RIGHT THING
00800			;  ABOUT ONE & TWO WORD FREES
00900			;PRESERVES A BUT ALL OTHERS MAY BE MUNGED
01000	
01100		TLNN	A,REFB	; IF REFB ON, THEN NO DELETION REQUIRED
01200		SKIPN	@A	; NOTHING TO DO IF A NULL
01300		POPJ	P,
01400		TLNE	A,ARY2B		;ITEMVAR ARRAY ??
01500		JRST	ARYKIL		;YEP
01600		TLNN	A,ITEMB		;NOTHING TO DO IF ITEM
01700		TLNE	A,PROCB		;OR PROCEDURE
01800		POPJ	P,
01900		LDB	TEMP,[POINT 6,A,=12] ; SIX BIT TYPE
02000		CAIL	TEMP,INVTYP	;VERIFY VALID
02100		ERR	<DRYROT -- INVALID REFERENCE TYPE IN FLDKIL>,5,RPOPJ
02200		CAIG	TEMP,MXSTYP	;IS THIS A LEGAL ARRAY TYPE ??
02300		JRST	@FKDISP(TEMP)	;NOPE DO WHATEVER YOU MUST
02400		MOVEI	TEMP,@FKDISP-ARRTYP(TEMP) ;FIND OUT WHAT SORT OF ARRAY YOU HAVE
02500		CAIE	TEMP,WZAPR	;A DONOTHING ??
02600		CAIN	TEMP,WSTRKL	;A STRING ARRAY?
02700		JRST	ARYKIL		;YEP
02800		PUSH	P,A		;HERE MUST CALL SELF RECURSIVELY TO 
02900		MOVEI	A,@A		;PROCESS EACH ARRAY ELEMENT
03000		PUSH	P,TEMP		;ROUTINE TO CALL
03100		HRRZ	TEMP,-1(A)	;COUNT
03200		JUMPE	TEMP,NOELS	;NONE
03300		PUSH	P,TEMP		;SAVE COUNT
03400	DEL1EL:	SKIPE	(A)		;HAVE ONE
03500		PUSHJ	P,@-1(P)	;CALL THE ROUTINE
03600		SOSG	(P)		;DECREMENT THE COUNT
03700		AOJA	A,DEL1EL	;DELETE ONE ELEMENT
03800		POP	P,TEMP		;GET THIS OFF
03900	NOELS:	POP	P,TEMP		;GET THIS OFF, TOO.
04000		JRST	ARYKL2		;MAY AS WELL LEAVE A ON THE STACK
04100	
04200	ARYKIL:	PUSH	P,A		;SINCE  ARYEL CLOBBERS IT
04300	ARYKL2:	PUSH	P,@A		;CALL TO ARYEL
04400		SETZM	@A		;ZAP IT
04500		PUSHJ	P,ARYEL		;KILL THE ARRAY
04600		POP	P,A		;OH WELL, GET A BACK
04700		POPJ	P,		;RETURN FROM KILLING THE ARRAY
04800	
04900	FKDISP:	WZAPR			;ACTUALLY A NOTHING
05000		WZAPR			;1 UNTYPED
05100		WZAPR			;2 BTRIP
05200		WSTRKL			;3 STRING
05300		WZAPR			;4 REAL
05400		WZAPR			;5 INTEGER
05500		WSLKL			;6 SET
05600		WSLKL			;7 LIST
05700		WZAPR			;8 PROCEDURE ITEM
05800		WZAPR			;9 PROCESS ITEM
05900		WZAPR			;10 EVENT TYPE
06000		WCTXTK			;11 CONTEXT
06100		WZAPR			;12 REFITEM
06200		WZAPR			;13 RECORD DEREFERENCING
06300	
06400	WSTRKL:	PUSH P,A
06500		PUSHJ P,RELSTR
06600		POP P,A
06700		JRST WZAPR
06800	
06900	WSLKL:	SKIPN	B,@A		;DO WE HAVE ONE
07000		JRST	WZAPR		;NOPE JUST WORRY ABOUT FREES
07100		PUSH	P,A		;WHO KNOWS WHAT EVIL LURKS IN THE HEART OF LEAP
07200		SETZM	@A		;CLEAR IT OUT
07300		MOVE	A,B		;
07400		MOVEI	5,0		;ALL SET UP
07500		PUSHJ	P,RECQQ		;RELEASE THE SET OR LIST
07600		POP	P,A		;GET A BACK
07700		JRST	WZAPR
07800	
07900	WCTXTK:	SKIPN	B,@A		;HAVE ONE
08000		POPJ	P,		;YEP
08100		SETZM	@A		;
08200		PUSH	P,A		;KILLING A CONTEXT
08300		PUSH	P,B
08400		PUSHJ	P,ALLFOR	;FORGET IT
08500		POP	P,A		;GET BACK A
08600		JRST	WZAPR
08700	
08800	WRDRF:	PUSH	P,A		;SAVE
08900		MOVE	A,@A		; DO DEREFERENCE
09000		PUSHJ	P,$RDREF	;CALL DEREFERENCER
09100		POP	P,A		;GET A BACK
09200		;FALL INTO WZAPR
09300	WZAPR:	TLNN	A,TMPB		;CALLING FROM LEAP ???
09400	RPOPJ:	POPJ	P,		;
09500					;MUST WORRY ABOUT LEAPISHNESS
09600		ERR	<FLDKIL NOT YET READY FOR CALL FOR REFITEMS>,1,RPOPJ
09700	
09800	
     

00100	;; SAIREC (RECGC) -- $ENQR,ENQRB,ENQRBB,PAMRK
00200	
00300	
00400	HERE($ENQR)
00500		JUMPE	A,CPOPJ			;NULL NEVER
00600		HLRZ	TEMP,RMARK(A)		;BE SURE NOT THERE YET
00700		JUMPN	TEMP,CPOPJ
00800		HRR	TEMP,RECCHN		;LINK ONTO CHAIN
00900		HRLM	TEMP,RMARK(A)
01000		HRRM	A,RECCHN
01100		POPJ	P,
01200	
01300	ENQRB:	TLNN	C,-1			;C =-COUNT,,ADR
01400		POPJ	P,			;NULL CALL
01500		HRRZ	A,(C)
01600		PUSHJ	P,$ENQR			;PUT ONE ON QUEUE
01700		AOBJN	C,.-2			;ITERATE
01800		POPJ	P,
01900	
02000	ENQRBB:	MOVE	C,(B)			;B →→ A BLOCK OF -CNT,,ADR WORDS
02100		JUMPE	C,CPOPJ			;TERMINATED BY A ZERO
02200		PUSHJ	P,ENQRB
02300		AOJA	B,ENQRBB		;ITERATE
02400	
02500	ENQRBL: HRRZ	D,RBLIST		;ROUTINE THAT HANDLES RBLIST
02600	EQRB.L:	JUMPE	D,CPOPJ
02700		HRRZI	B,1(D)			;POINT AT THIS BLOCK
02800		PUSHJ	P,ENQRBB		;MARK EM ALL
02900		HRRZ	D,(D)			;ITERATE
03000		JRST	EQRB.L			
03100	
03200	PAMRK:  HLRZ	PDA,1(RF)		;HANDLES ONE EACH PROCEDURE ACTIVATION
03300		CAIN	PDA,SPRPDA		;CAN QUIT ON THIS
03400		POPJ	P,
03500		MOVEI	D,-1(RF)		;LAST PARAMETER LOCATION
03600		HRLI	D,C
03700		HRRZ	C,PD.NPW(PDA)		;NUMBER OF ARITH PARAMS
03800		MOVNI	C,(C)			;
03900		HRRZ	B,PD.DLW(PDA)		;POINT AT PARAMS
04000	MKPRM:	AOJGE	C,PRMSDN		;COUNT UP, QUIT WHEN RUN OUT
04100		LDB	TEMP,[POINT =12,(B),=12] ;INTERESTED IN VALUE RECORDS
04200		CAIE	TEMP,RECTYP		;TEST CODE
04300		AOJA	B,MKPRM			;NO, GO MARK NEXT
04400		HRRZ	A,@D			;PICK UP PARAMETER
04500		PUSHJ	P,$ENQR			;HANDLE IT
04600		AOJA	B,MKPRM
04700	PRMSDN: HRRZ	B,PD.LLW(PDA)		;POINT AT LVI
04800	LVI.DO:	SKIPN	D,(B)			;A ZERO MEANS DONE
04900		POPJ	P,
05000		LDB	TEMP,[POINT 4,D,3]
05100		CAIN	TEMP,RPACOD
05200		JRST	MRKRPA
05300		CAIE	TEMP,RPCOD
05400		AOJA	B,LVI.DO
05500		HRRZ	A,@D			;GET DESCRIPTOR
05600		PUSHJ	P,$ENQR
05700		AOJA	B,LVI.DO
05800	MRKRPA:	SKIPN	C,@D
05900		AOJA	B,LVI.DO
06000		MOVN	TEMP,-1(C)		;WORD COUNT
06100		HRL	C,TEMP
06200		PUSHJ	P,ENQRB			;DO THEM ALL
06300		AOJA	B,LVI.DO
06400	
     

00100	;; SAIREC (RECGC) -- %PSMRR
00200	
00300	%PSMRR:	
00400		SKIPE	TEMP,RUNNER		;FANCY CASE
00500		JRST	PSMK.2			;HERE IF PROCESSES IN USE
00600		PUSH	P,RF			;SAVE RF
00700		PUSHJ	P,PSMK.1		;
00800		POP	P,RF
00900		POPJ	P,
01000	
01100	PSMK.1:	PUSHJ	P,PAMRK			;MARK 
01200		HRRZ	RF,(RF)			;DYNAMIC LINK
01300		CAIE	RF,-1			;DONE??
01400		JUMPN	RF,PSMK.1		;NO (ALSO TEST DONE ANOTHER WAY)
01500		POPJ	P,			;DONE ALL
01600	
01700	PSMK.2:	MOVEM	RF,ACF(TEMP)		;SAVE RF IN TABLE
01800		HRLZI	B,-NPRIS
01900		HRR	B,GOGTAB
02000	PSCHL:	SKIPN	TEMP,PRILIS(B)
02100		JRST	NXLS
02200		PUSH	P,B			;SAVE B
02300	PSCHL2:	
02400		PUSH	P,TEMP
02500		MOVE	RF,ACF(TEMP)
02600		PUSHJ	P,PSMK.1		;MARK THAT STACK
02700		POP	P,TEMP
02800		HRRZ	TEMP,PLISTE(TEMP)
02900		JUMPN	TEMP,PSCHL2
03000		POP	P,B
03100	NXLS:	AOBJN	B,PSCHL
03200		MOVE	TEMP,RUNNER
03300		MOVE	RF,ACF(TEMP)
03400		POPJ	P,
     

00100	;; SAIREC (RECGC) -- RCIMRK 
00200	
00300	RCIMRK:	MOVE	USER,GOGTAB	
00400		SKIPE	HASMSK(USER)		;ACTUALLY HAVE LEAP
00500		SKIPG	C,MAXITM(USER)		;ALL THE ITEMS TO MARK
00600		POPJ	P,			;NOPE
00700	RI1MK:	LDB	TEMP,INFOTAB(USER)	;GET TYPE
00800		MOVE	A,@DATAB(USER)		;AND DATUM READY
00900		CAIN	TEMP,RFITYP		;REFERENCE
01000		JRST	RFFOL
01100		CAIN	TEMP,ARRTYP+RECTYP	;RECORD ARRAY??
01200		JRST	RAIMK			;YES
01300		CAIN	TEMP,RECTYP		;REGULAR RECORD
01400		PUSHJ	P,$ENQR			;YES
01500	RIMITR:	SOJG	C,RI1MK			;ITERATE
01600		POPJ	P,
01700	
01800	RFFOL:	PUSH	P,C			;SINCE NO PROMISSES WERE MADE
01900		PUSHJ	P,$M1FLD		;MARK A FIELD
02000		POP	P,C
02100		JRST	RIMITR
02200	
02300	RAIMK:	
02400		SKIPN	TEMP,@A			;POINT AT RECORD ARRAY
02500		JRST 	RIMITR			;EMPTY
02600		PUSH	P,C			;SAVE ITEM NUMBER
02700		MOVN	C,-1(TEMP)
02800		HRL	C,TEMP
02900		MOVS	C,C			;-CNT,,ADR
03000		PUSHJ	P,ENQRB			;HANDLE EM ALL
03100		JRST 	RIMITR			;ITERATE
     

00100	;; SAIREC (RECGC) -- $MRK.1, $MFLDS
00200	
00300	$MRK1R:	PUSHJ	P,$ENQR			;ENQUEUE ONE RECORD
00400	HEREFK($RMARK,$RMAR.)
00500	$MRK.1:	HRRZ	A,RECCHN		;GET A RECORD OFF THE CHAIN
00600		CAIN	A,-1			;END OF THE ROAD??
00700		POPJ	P,			;YES
00800		HLRZ	D,RMARK(A)		;CDR THE QUEUE
00900		HRRM	D,RECCHN		;NEW NEXT ELT ON QUEUE
01000		HLRZ	D,RECCHN		;
01100		HRLM	D,RMARK(A)		;MAKE CHAIN OF ALL MARKED RECORDS
01200		HRLM	A,RECCHN
01300		HRRZ	D,CLSPTR(A)		;POINTER TO CLASS
01400		HRRZ	D,HNDLER(D)		;GET HANDLER ADDRESS
01500		CAIN	D,$REC$			;STANDARD HANDLER??
01600		JRST	MFLDS1			;YES
01700		PUSH	P,[4]			;THE "MARK" OP
01800		PUSH	P,A			;REC ID
01900		PUSHJ	P,(D)			;CALL ROUTINE
02000		JRST	$MRK.1
02100	
02200	MFLDS1:	PUSH	P,[$MRK.1]
02300	$MFLDS:	JUMPE	A,CPOPJ			;MARK ALL FIELDS OF RCD IN A
02400		HRRZ	C,CLSPTR(A)			;CLASS ID
02500		PUSH	P,RECSIZ(C)		;RECORD SIZE
02600		HRRZ	C,TYPARR(C)		;POINTER TO TYPE ARRAY
02700	;;%##% RHT + PDQ DO NOT PROCEED FURTHER IF NO RECORD SUBFIELDS
02800		HRL	C,(C)			;GET TYPE BITS
02900		TLNN	C,HASRPS		;HAVE RECORD OR RECORD ARRAY SUBFIELDS
03000		JRST	CPOP1J			;NO
03100	;;%##%
03200		SUBI	C,(A)			;CORRECTION FACTOR
03300		ADDI	A,1			;FIRST DATA FIELD
03400		HRLI	C,(<POINT =13,(A),=12>)	;TO GET TYPE BITS
03500		PUSH	P,C			;SAVE IT
03600	G1FLD:	SOSGE	-1(P)			;ARE WE DONE?
03700		JRST 	CPOP2J			; YEP
03800		LDB	C,(P)			;GET TYPE
03900		DPB	C,[POINT =13,A,=12]	;DESCRIPTOR FOR ONE FIELD
04000		PUSHJ	P,$M1FLD		;MARK ONE FIELD
04100		AOJA	A,G1FLD			;ITERATE UNTIL DONE
04200	
04300	CPOP2J:	SUB	P,X22
04400		POPJ P,
04500	
04600	CPOP1J:	SUB	P,X11
04700	CPOPJ:	POPJ	P,
04800	
     

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

00100	;; SAIREC (RECGC) -- $RGCSW
00200	
00300	$RGCSW:	;;****  THESE LINES CHANGED FROM PDQ METHOD ****
00400		;;HRRZ	D,CLSREC		;HEAD OF ALL CLASSES
00500		;;MOVEI	TEMP,RECRNG-RING(D)	;HEAD OF RING OF ALL CLASSES
00600		;;MOVEM	TEMP,CLSRHD#
00700		;;HRRZ	D,RECRNG(D)		;RING OF ALL CLASSES
00800		;;****
00900		HRRZ	D,RECRNG+$CLASS		;RING OF ALL CLASSES
01000	
01100	RGSWC:	MOVE	TEMP,@TYPARR(D)		;TYPE BITS FOR THIS CLASS
01200		HRRZ	A,RECRNG(D)		;RING OF RECORDS FOR THIS CLASS;
01300		TRNN	TEMP,NODELC		
01400		JRST	NXTREC			;DELETE UNMARKED RECORDS OF THIS CLASS;
01500	;RESET MARKS FOR ALL RECORDS OF THIS CLASS -- NEVER DELETE
01600	RGNODL:	HRRZS	RMARK(A)		;CLEAR MARK
01700		HRRZ	A,RING(A)
01800		CAIE	A,RECRNG-RING(D)	;HEAD OF CLASS?
01900		JRST	RGNODL			;NO, AGAIN
02000		JRST 	NXTCLS			;DONE WITH THIS RECORD CLASS -- ON TO NEXT
02100	
02200	
02300	RGSWPP:	HLL	TEMP,RMARK(A)		;GET MARK
02400		TLNN	TEMP,-1			;
02500		JRST	RGSWP1			;UNMARKED MEANS IT DIES
02600		HRRZS	RMARK(A)		;CLEAR MARK
02700		HRRZ	A,RING(A)		;POINT AT NEXT IN CLASS
02800	NXTREC:	CAIE	A,RECRNG-RING(D)	;IS IT HEAD OF CLASS?
02900		JRST	RGSWPP			;NOPE, CONTINUE
03000	NXTCLS:	HRRZ	D,RING(D)		;NEXT CLASS ON RING OF CLASSES
03100	;;****	CAME	D,CLSRHD		;HEAD OF RING OF CLASSES?
03200		CAIE	D,$CLASS+RECRNG-RING	;HEAD OF RING OF CLASSES?
03300		JRST	RGSWC			;NOPE, CONTINUE
03400		POPJ 	P,			;DONE AT LAST
03500	
03600	RGSWP1:	HRRZ	TEMP,RING(A)
03700		PUSH	P,TEMP			;SAVE POINTER TO NEXT ON RING
03800		PUSH	P,D			
03900		HRRZ	TEMP,CLSPTR(A)		;CLASS
04000		HRRZ 	TEMP,HNDLER(TEMP)	;HANDLER FOR CLASS
04100		CAIE	TEMP,$REC$		;IS IT STANDARD
04200		JRST	RGSWP3			;NO DO A REGULAR CALL
04300		PUSHJ	P,$DIE			;KILL RECORD
04400	RGSWP2:	POP	P,D
04500		POP	P,A
04600		JRST	NXTREC
04700	
04800	RGSWP3:	PUSH	P,[5]		;KILL YOURSELF
04900		PUSH	P,A
05000		PUSHJ	P,(TEMP)
05100		JRST	RGSWP2
     

00100	;; SAIREC (RECGC) -- MAIN ROUTINE
00200	
00300	HERE($RECGC)
00400	
00500		SETOM	RECCHN		;INITIALIZE MARK AS NULL
00600		PUSHJ	P,$RGCMK	;MARK THEM ALL
00700		JRST	$RGCSW		;SWEEP THEM ALL
00800					;ALL DONE NOW
00900	
     

00100	;; SAIREC (RECGC) -- $M1FLD
00200	
00300	HERE($M1FLD)
00400			;CALLED WITH REFITEM TYPE DESCRIPTOR IN A
00500			;WILL TAKE ALL APPROPTIATE ACTION
00600			;PRESERVES A BUT ALL OTHERS MAY BE MUNGED
00700	
00800		JUMPE	A,CPOPJ		;NOTHING TO DO IF NULL
00900		TLNN	A,ITEMB		;NOTHING TO DO IF ITEMISH
01000		TLNE	A,PROCB		;OR PROCEDURE
01100		POPJ	P,
01200		LDB	TEMP,[POINT 6,A,=12] ; SIX BIT TYPE
01300		CAIN	TEMP,RECTYP	;A RECORD??
01400		JRST	M1REC		;YES, ENQUEUE IT
01500		CAIN	TEMP,RFITYP	;A REFERENCE ITSELF
01600		JRST	M1REF		;YES
01700		CAIE	TEMP,RECTYP+ARRTYP; A RECORD ARRAY??
01800		POPJ	P,		;NOPE
01900		PUSH	P,A		;SINCE AGREED TO LEAVE ALONE
02000		PUSH	P,B
02100		SKIPN	B,(A)		;PICK UP ARRAY DESCRIPTOR
02200		POPJ	P,		;EMPTY
02300		MOVN	TEMP,-1(B)	;WORD COUNT
02400		JUMPE	TEMP,M1AXIT	;NO WORDS
02500		HRL	B,TEMP
02600	M1ALP:	MOVE	A,(B)		;PICK UP A WORD
02700		PUSHJ	P,$ENQR		;ENQUEUE IT
02800		AOBJN	B,M1ALP
02900	M1AXIT:	POP	P,B		;
03000		POP	P,A
03100		POPJ	P,
03200	
03300	M1REC:	PUSH	P,A		;WE PROMISSED TO LEAVE ALONE
03400		MOVE	A,@A		;FETCH VARIABLE
03500		PUSHJ	P,$ENQR		;ENQUEUE IT
03600		POP	P,A		;RESTORE
03700		POPJ	P,
03800	
03900	M1REF:	PUSH	P,A
04000		MOVE	A,@A
04100		PUSHJ	P,$M1FLD	;MARK THE THING REFERENCED
04200		POP	P,A
04300		POPJ	P,
04400	
04500	BEND RECORD
04600	
04700	ENDCOM(REC)