00100	COMPIL(REC,<$REC$,FLDKIL,$RERR,$RECGC,$M1FLD,$ENQR,$RECFN,$RCINI,$RMARK>
00200		,<RECQQ,ALLFOR,ARYEL,CORGET,CORREL,X11,X22,X33,CLSLNK,STRCHN,SGINS,RSGCLK,GOGTAB,$DEL1B,$GET1B>
00300		,<SAIL RECORD HANDLER>,<$RDREF,$RALLO>);
00400	BEGIN RECORD
00500	IFE ALWAYS, <
00600		EXTERNAL	$CLASS,RECCHN,RGCLST,RBLIST,RUNNER,SPRPDA,PLISTE,ACF
00700	>;IFE ALWAYS
00800	PDA ← 7		;DEF USED BY THE GARBAGE COLLECTOR
00900	CLSRNG←-2		;RING OF COMPILED-IN CLASSES
01000	RING←-1			;RING OF RECORDS OF SAME CLASS
01100	RMARK←←0		;GARBAGE COLLECTOR MARK CHAIN IN LEFT HALF
01200	CLSPTR←←0		; RIGHT HALF OF THIS WORD POINTS TO CLASS TEMPLATE RECORD
01300	RECRNG←←1	;RING OF RECORDS OF THIS CLASS - FOR RECORDS OF CLASS = "CLASS"
01400	HNDLER←←2	;HANDLER PROCEDURE FOR THIS CLASS
01500	RECSIZ←←3	;COUNT OF # FIELDS IN RECORDS OF THIS CLASS
01600	TYPARR←←4	;INTEGER ARRAY OF TYPE INFO FOR FIELDS	
01700	TXTARR←←5	;STRING ARRAY OF FIELD NAMES 
01800	FSTRSIZ←←20
01900	STRINIT:	
02000		MOVEI C,2*FSTRSIZ+1		;ENOUGH ROOM FOR 20 STRINGS
02100		PUSHJ P,CORGET
02200		ERR <NO CORE FOR RECORD STRINGS>,1,ZPOPJ
02300		MOVE A,STBLST(USER)	;LINKED LIST OF FREE STRING DESCR ARRAYS
02400		MOVEM A,(B)		;LINK NEW ONE IN
02500		MOVEM B,STBLST(USER)		;
02600		MOVEI A,FSTRSIZ
02700		ADDI B,2
02800		MOVEM B,STRCHN		;HEAD OF NEW CHAIN
02900	L:	SETZM -1(B)
03000		ADDI B,2
03100		HRRZM B,-2(B)		;CONSTRUCT FREE CHAIN
03200		SOJG A,L
03300		SETZM -2(B)		;ZERO LAST ENTRY
03400		MOVE A,STRCHN
03500		POPJ P,
03600	GETSTR:	SKIPN A,STRCHN		;ANY FREE STRINGS?
03700		PUSHJ P,STRINIT		;SET UP ANOTHER BLOCK OF STRINGS
03800		MOVE B,(A)
03900		MOVEM B,STRCHN		;CDR DOWN FREE CHAIN
04000		SETZM -1(A)		;CLEAR BOTH WORDS
04100		SETZM (A)
04200		POPJ P,
04300	RELSTR:	SKIPN A,(A)		; POINTER TO STRING ARRAY ENTRY
04400		JRST CPOPJ		; NOTHING TO DO
04500		MOVE B,STRCHN		; CHAIN OF FREE STRINGS
04600		HRRZM B,(A)		; CHAIN TOGETHER 
04700		SETZM -1(A)		; ZERO CHARACTER COUNT
04800		MOVEM A,STRCHN	
04900		POPJ P,
05000	BEGIN  RSGC
05100	F←←E+1
05200	↑RSGCMK:	
05300		HRRZ	D,RECRNG+$CLASS		;RING OF ALL CLASSES
05400	RSGSWC:	MOVE	TEMP,@TYPARR(D)		;TYPE BITS FOR THIS CLASS
05500		TRNN	TEMP,HASSTR		;DOES IT HAVE STRING OR STRING ARRAY SUBFIELDS?
05600		JRST	NXTCLS			;NO STRING ARRAYS IN THIS CLASS
05700		HRRZ	E,RECRNG(D)		;RING OF RECORDS FOR THIS CLASS;
05800		JRST	NXTREC
05900	RSGSWP:	MOVN	F,RECSIZ(D)
06000		MOVSS	F
06100		HRR	F,TYPARR(D)		;MAKE AOBJN WORD FOR TYPE ARRAY
06200		PUSH 	P,E
06300	DOFLD:	ADDI 	E,1
06400		LDB 	B,[POINT 6,1(F),=12]	;GET TYPE BITS
06500		CAIN	B,STTYPE
06600		JRST	DOSTR			;IT'S A STRING
06700		CAIN	B,ARRTYP+STTYPE		
06800		JRST	DOSTRA			;IT'S A STRING ARRAY
06900	NXFLD:	AOBJN	F,DOFLD
07000		POP	P,E
07100		HRRZ	E,RING(E)		;POINT AT NEXT IN CLASS
07200	NXTREC:	CAIE	E,RECRNG-RING(D)	;IS IT HEAD OF CLASS?
07300		JRST	RSGSWP			;NOPE, CONTINUE
07400	NXTCLS:	HRRZ	D,RING(D)		;NEXT CLASS ON RING OF CLASSES
07500		CAIE	D,$CLASS+RECRNG-RING	;HEAD OF RING OF CLASSES?
07600		JRST	RSGSWC			;NOPE, CONTINUE
07700		POPJ 	P,			;DONE AT LAST
07800	DOSTR:	MOVE	A,(E)			;GET SUBFIELD -- POINTER TO STRING DESCR
07900		SUBI	A,1			;CRETINS - POINT TO FIRST WORD OF DESCR
08000		PUSHJ	P,@-2(P)		;CALL STRING MARK ROUTINE
08100		JRST	NXFLD
08200	DOSTRA:	PUSH	P,D			
08300		MOVE	D,(E)			;GET SUBFIELD -- POINTER TO STRING ARRAY
08400		MOVN	A,-2(D)			;STRING ARRAY LENGTH
08500		HRL	D,A			;MAKE AOBJN WORD
08600	STALP:	MOVEI 	A,-1(D)			;POINTER TO FIRST WORD OF STRING DESCR
08700		PUSHJ	P,@-3(P)			
08800		AOBJN	D,.+1
08900		AOBJN	D,STALP
09000		POP	P,D
09100		JRST	NXFLD
09200	BEND RSGC
09300	$RDISP:	JRST	$RDREF		;DEREFERENCE ARG1
09400		JRST	$RALLO		;ALLOCATE RECORD WITH CLASS ARG1
09500		JRST	CPOPJ		;2			NON-STANDARD PRINT ROUTINE?
09600		JRST	CPOPJ		;3			NON-STANDARD READ ROUTINE?
09700		JRST	$MFLDS		;4 -- MARK ALL FIELDS OF A RECORD
09800		JRST	$DIE		;5 DELETE SPACE FOR RECORD
09900	$RMAX ←← (.-$RDISP)-1
10000	HEREFK($RECFN,$RECF.)
10100		SKIPN	A,-1(P)		;PICK UP ARG1
10200		JRST	NLARG1		;
10300		MOVE	B,-2(P)		;PICK UP OP
10400		CAIE	B,1		;RALLO IS FUNNY
10500		HRRZ	A,CLSPTR(A)	;
10600	HACK <
10700		HRLZI	C,777740	;OLD-STYLE COUNT FIELD
10800		TDNE	C,(A)		;CHECK TO BE SURE NOT OLD-STYLE CLASS
10900		ERR	<OLD STYLE RECORD DESCRIPTOR.  RECOMPILE>
11000	>;HACK
11100		JRST	@HNDLER(A)	;DISPATCH TO HANDLER ROUTINE
11200	NLARG1:	ERR	<NULL ARGUMENT TO $RECFN>,1
11300		SUB	P,X33		;
11400		JRST	@3(P)		;RETURN
11500	HERE($REC$)		
11600		POP	P,C		;RET ADR
11700		POP	P,A
11800		EXCH	C,(P)		; NOW C=OP, A=ARG1
11900		CAILE	C,$RMAX
12000		POPJ	P,
12100		JUMPN	C,@$RDISP(C)	; OBEY COMMAND
12200	↑↑$RDREF:
12300		ERR	<CALL ON $RDREF IN RECORD GC VERSION>,1
12400		POPJ	P,
12500	$DIE:	JUMPE	A,CPOPJ			;
12600		PUSH	P,A			; SO CAN LATER CALL CORREL
12700		HLRZ	B,RING(A)
12800		HRRZ	C,RING(A)
12900		HRRM	C,RING(B)
13000		HRLM	B,RING(C)		; UNLINK FROM RING OF CLASS
13100		HRRZ	C,CLSPTR(A)		; CLASS ADDRESS
13200		PUSH    P,RECSIZ(C)		; RECORD SIZE 
13300		HRRZ	C,TYPARR(C)		; CLASS TYPE ARRAY
13400		SUBI	C,(A)			; CORRECTION FACTOR
13500		ADDI	A,1			; FIRST DATA ELEMENT
13600		HRLI	C,(<POINT =13,(A),=12>); DESCRIPTOR TO GET BITS
13700		PUSH	P,C
13800	GETFLD:	SOSGE	-1(P)			; IS THIS THE LAST FIELD
13900		JRST	NOMORE
14000		LDB	C,(P)			; GET FIELD
14100		DPB	C,[POINT =13,A,=12]	; PUT DESCRIPTOR BITS IN PLACE
14200		PUSHJ	P,FLDKIL		; GO KILL THIS FIELD
14300		AOJA	A,GETFLD		; GO ON TO NEXT
14400	NOMORE:	SUB	P,X22			; JUST POP TWO OFF
14500		POP	P,B			; THE CORREL POINTER
14600		SUBI	B,1			; NOW IT IS (THE REF CNT WORD, REMEMBER)
14700		MOVE	USER,GOGTAB		; FREE THE SPACE UP
14800		MOVE	A,$FSLIS(USER)		; BY CALLING THE FREER-UPPER
14900		PUSHJ	P,$DEL1B		; 
15000		ERR	<CONFUSION IN FREEING A BLOCK>,1
15100		POPJ	P,
15200	↑↑$RALLO:
15300	HACK <
15400		HRLZI	C,777740	;OLD-STYLE COUNT FIELD
15500		TDNE	C,(A)		;CHECK TO BE SURE NOT OLD-STYLE CLASS
15600		ERR	<OLD STYLE RECORD DESCRIPTOR.  RECOMPILE>
15700	>;HACK
15800		MOVE	C,RECSIZ(A)	; A = RECORD CLASS ID.  GET THE WORD COUNT
15900		ADDI	C,2		; RECORD SIZE +1 FOR RING WORD
16000		PUSH	P,A		; EVENTUALLY, BECOMES THE RECID POINTER
16100		MOVE	USER,GOGTAB	; GET THE SYSTEM FREE LIST
16200		MOVE	A,$FSLIS(USER)	;
16300		PUSHJ	P,$GET1B	; MAY WANT MORE EFFICIENCY LATER
16400		ERR	<NO CORE FOR RECORD ALLOCATION>,1,ZPOPJ
16500		MOVEI	A,1(B)		;THE POINTER WE WILL ACTUALLY RETURN
16600		ADDI	C,-1(B)		;STOPPING PLACE
16700		SETZM	(B);		;ZERO OUT (ALSO REF CNT ← 0)
16800		HRL	B,B		;BUILD BLT PTR
16900		HRRI	B,1(B)
17000		BLT	B,(C)		;BLT THEM AWAY
17100		PUSH 	P,A
17200		PUSH	P,A
17300		MOVE	A,-2(P)		;GET CLASS POINTER
17400		MOVE B,@TYPARR(A)	;GET TYPE BITS FOR CLASS
17500		TRNN B,HASSTR	
17600		JRST NOSTRS		;NO STRINGS TO ALLOCATE
17700		MOVN C,RECSIZ(A)	;WE GOT STRINGS
17800		MOVSS C
17900		HRR C,TYPARR(A)		;BUILD IOWD FOR TYPARR
18000	STALLO:	MOVS B,1(C)
18100		AOS (P)
18200		CAIE B,140		;### CHANGE THIS TO TYPE BIT SYMBOL
18300		JRST NXTFLD
18400		PUSH P,C
18500		PUSHJ P,GETSTR		;GET A FREE STRING DESCR
18600		POP P,C
18700		MOVEM A,@(P)		;STORE POINTER TO STRING DESCR IN FIELD
18800	NXTFLD:	AOBJN C,STALLO
18900	NOSTRS:	SUB P,X11
19000		POP P,A
19100	RNGIT2:	POP	P,B		; CLASSID
19200	RNGIT:	HRRZM	B,CLSPTR(A)	; PUT ZERO IN MARK FIELD
19300		ADDI	B,RECRNG-RING	; OFFSET FOR HEAD OF CLASS
19400		HRRZ	C,RING(B)	; RING OF RECORDS FOR THE CLASS
19500		HRRZM	C,RING(A)	; NEW RECORD POINTS TO RING
19600		HRRM	A,RING(B)	; CLASS POINTS TO NEW RECORD
19700		HRLM	B,RING(A)	; NEW RECORD POINTS TO CLASS
19800		HRLM	A,RING(C)	; RING POINTS BACK TO NEW RECORD
19900		POPJ	P,		;RETURN
20000	ZPOPJ:	MOVEI	A,0
20100		POPJ	P,
20200	HERE($RERR)
20300		ERR	<ACCESS TO A SUBFIELD OF A NULL RECORD>,1
20400		POPJ	P,
20500	NOLOW <
20600	NOUP <
20700	REN <
20800		USE
20900	>;REN
21000	RCLK:	0
21100		$RCINI
21200		0
21300		LINK	%INLNK,RCLK
21400	REN <
21500		USE	HIGHS
21600	>;REN
21700	>;NOUP
21800	>;NOLOW
21900	HEREFK($RCINI,$RCIN.)
22000		PUSH	P,[RSGCMK]		;POINTER TO RECORD STRING GC
22100		MOVEI 	A,RSGCLK+1(USER)
22200		PUSH 	P,A
22300		PUSHJ 	P,SGINS			;ENQUE RECORD STRING GARBAGE COLLECTOR
22400		MOVE	A,[XWD $CLASS,$CLASS]	;
22500		HRRZM	A,$CLASS		;INITIALIZE $CLASS
22600		MOVEM	A,$CLASS+RECRNG		;
22700		ADD	A,[XWD RECRNG-RING,RECRNG-RING];
22800		MOVEM	A,$CLASS+RING		;
22900		MOVEI	A,$REC$			;HANDLER
23000		MOVEM	A,$CLASS+HNDLER		;
23100		MOVEI	A,$CLSTY		;TYPE ARRAY
23200		MOVEM	A,$CLASS+TYPARR		;
23300		MOVEI	A,$CLSTX+1		;TEXT ARRAY
23400		MOVEM	A,$CLASS+TXTARR		;
23500		MOVEI	A,5			;TEST MUNGAGE
23600		MOVEM	A,$CLASS+RECSIZ
23700		SKIPN	D,CLSLNK		;PICK UP THE CLASS LIST
23800		POPJ	P,			;IF NO CLASSES, THEN DONE
23900	LNKCLS:	MOVEI	B,$CLASS		;CLASS OF CLASSES
24000		MOVEI	A,-CLSRNG(D)		;POINT AT CLASS DESCRIPTOR
24100		PUSHJ	P,RNGIT			;LINK THIS CLASS ONTO CLASS RING
24200		MOVEI	D,RECRNG-RING(A)	;SET UP RECORD RING
24300		HRL	D,D			;RECRNG SHOULD POINT AT ITSELF
24400		MOVEM	D,RECRNG(A)		;MAKE IT DO SO
24500		HRRZ	D,CLSRNG(A)		;POINT AT NEXT CLASS
24600		JUMPN	D,LNKCLS		;GO ON IF HAVE ANY LEFT
24700		MOVE	USER,GOGTAB
24800		SETZM 	STRCHN			;ZERO CHAIN OF FREE STRING DESCRS
24900		SETZM 	STBLST(USER)		;AND CHAIN OF FREE STRING DESCR ARRAYS
25000		HRRZ D,RBLIST			;CHAIN OF ALL OWN AND OUTER BLOCK RECORD POINTERS
25100		JRST ZERO3
25200	ZERO1:	HRRZ D,(D)			;NEXT BLOCK IN RBLIST CHAIN
25300	ZERO3:	JUMPE D,CPOPJ			;DONE
25400		HRRZI B,1(D)
25500	ZERO2:	SKIPN C,(B)			;GET AOBJN WORD
25600		JRST ZERO1			;DONE WITH THIS BLOCK
25700		SETZM (C)			;ZERO THE RECORD POINTER (ARRAY)
25800		AOBJN C,.-1			
25900		AOJA B,ZERO2
26000		$CLSTY				;TYPE BITS ARRAY HEADER
26100		0				;LB
26200		TXTARR				;UB
26300		1
26400		XWD	1,TXTARR+1		;NDIMS,,TOTAL SIZE
26500	$CLSTY:	CMPLDC+NODELC+HASSTR		;TYPE BITS
26600		INTYPE*1B12			;RECRNG
26700		INTYPE*1B12			;HNDLER
26800		INTYPE*1B12			;RECSIZ --ONLY "REAL" INTEGER
26900		(ARRTYP+INTYPE)*1B12		;TYPE ARRAY
27000		(ARRTYP+STTYPE)*1B12		;TEXT ARRAY
27100	CLSTXT:	ASCIZ /$CLASSRECRNGHNDLERRECSIZTYPARRTXTARR/
27200	DEFINE SUBSTR(STR,N,CNT) <
27300		CNT
27400		POINT	7,STR-1+(N+4)/5,6+7*(N+4-5*((N+4)/5))
27500		>
27600	DEFINE IDTXT(CNT) <
27700		SUBSTR(CLSTXT,II,CNT)
27800		II ←← II+CNT
27900		>
28000		II ←← 0
28100		$CLSTX+1			;TEXT ARRAY HEADER
28200		0				;LB
28300		TXTARR				;UB
28400		1				;MUL(1)
28500		XWD	-1,2*(TXTARR+1)		;TOTAL SIZE
28600	$CLSTX:	IDTXT(6)			;$CLASS
28700		IDTXT(6)			;RECRNG
28800		IDTXT(6)			;HNDLER
28900		IDTXT(6)			;RECSIZ
29000		IDTXT(6)			;TYPARR
29100		IDTXT(6)			;TXTARR
29200	HERE(FLDKIL)
29300		TLNN	A,REFB	; IF REFB ON, THEN NO DELETION REQUIRED
29400		SKIPN	@A	; NOTHING TO DO IF A NULL
29500		POPJ	P,
29600		TLNE	A,ARY2B		;ITEMVAR ARRAY ??
29700		JRST	ARYKIL		;YEP
29800		TLNN	A,ITEMB		;NOTHING TO DO IF ITEM
29900		TLNE	A,PROCB		;OR PROCEDURE
30000		POPJ	P,
30100		LDB	TEMP,[POINT 6,A,=12] ; SIX BIT TYPE
30200		CAIL	TEMP,INVTYP	;VERIFY VALID
30300		ERR	<DRYROT -- INVALID REFERENCE TYPE IN FLDKIL>,5,RPOPJ
30400		CAIG	TEMP,MXSTYP	;IS THIS A LEGAL ARRAY TYPE ??
30500		JRST	@FKDISP(TEMP)	;NOPE DO WHATEVER YOU MUST
30600		MOVEI	TEMP,@FKDISP-ARRTYP(TEMP) ;FIND OUT WHAT SORT OF ARRAY YOU HAVE
30700		CAIE	TEMP,WZAPR	;A DONOTHING ??
30800		CAIN	TEMP,WSTRKL	;A STRING ARRAY?
30900		JRST	ARYKIL		;YEP
31000		PUSH	P,A		;HERE MUST CALL SELF RECURSIVELY TO 
31100		MOVEI	A,@A		;PROCESS EACH ARRAY ELEMENT
31200		PUSH	P,TEMP		;ROUTINE TO CALL
31300		HRRZ	TEMP,-1(A)	;COUNT
31400		JUMPE	TEMP,NOELS	;NONE
31500		PUSH	P,TEMP		;SAVE COUNT
31600	DEL1EL:	SKIPE	(A)		;HAVE ONE
31700		PUSHJ	P,@-1(P)	;CALL THE ROUTINE
31800		SOSG	(P)		;DECREMENT THE COUNT
31900		AOJA	A,DEL1EL	;DELETE ONE ELEMENT
32000		POP	P,TEMP		;GET THIS OFF
32100	NOELS:	POP	P,TEMP		;GET THIS OFF, TOO.
32200		JRST	ARYKL2		;MAY AS WELL LEAVE A ON THE STACK
32300	ARYKIL:	PUSH	P,A		;SINCE  ARYEL CLOBBERS IT
32400	ARYKL2:	PUSH	P,@A		;CALL TO ARYEL
32500		SETZM	@A		;ZAP IT
32600		PUSHJ	P,ARYEL		;KILL THE ARRAY
32700		POP	P,A		;OH WELL, GET A BACK
32800		POPJ	P,		;RETURN FROM KILLING THE ARRAY
32900	FKDISP:	WZAPR			;ACTUALLY A NOTHING
33000		WZAPR			;1 UNTYPED
33100		WZAPR			;2 BTRIP
33200		WSTRKL			;3 STRING
33300		WZAPR			;4 REAL
33400		WZAPR			;5 INTEGER
33500		WSLKL			;6 SET
33600		WSLKL			;7 LIST
33700		WZAPR			;8 PROCEDURE ITEM
33800		WZAPR			;9 PROCESS ITEM
33900		WZAPR			;10 EVENT TYPE
34000		WCTXTK			;11 CONTEXT
34100		WZAPR			;12 REFITEM
34200		WZAPR			;13 RECORD DEREFERENCING
34300	WSTRKL:	PUSH P,A
34400		PUSHJ P,RELSTR
34500		POP P,A
34600		JRST WZAPR
34700	WSLKL:	SKIPN	B,@A		;DO WE HAVE ONE
34800		JRST	WZAPR		;NOPE JUST WORRY ABOUT FREES
34900		PUSH	P,A		;WHO KNOWS WHAT EVIL LURKS IN THE HEART OF LEAP
35000		SETZM	@A		;CLEAR IT OUT
35100		MOVE	A,B		;
35200		MOVEI	5,0		;ALL SET UP
35300		PUSHJ	P,RECQQ		;RELEASE THE SET OR LIST
35400		POP	P,A		;GET A BACK
35500		JRST	WZAPR
35600	WCTXTK:	SKIPN	B,@A		;HAVE ONE
35700		POPJ	P,		;YEP
35800		SETZM	@A		;
35900		PUSH	P,A		;KILLING A CONTEXT
36000		PUSH	P,B
36100		PUSHJ	P,ALLFOR	;FORGET IT
36200		POP	P,A		;GET BACK A
36300		JRST	WZAPR
36400	WRDRF:	PUSH	P,A		;SAVE
36500		MOVE	A,@A		; DO DEREFERENCE
36600		PUSHJ	P,$RDREF	;CALL DEREFERENCER
36700		POP	P,A		;GET A BACK
36800	WZAPR:	TLNN	A,TMPB		;CALLING FROM LEAP ???
36900	RPOPJ:	POPJ	P,		;
37000		ERR	<FLDKIL NOT YET READY FOR CALL FOR REFITEMS>,1,RPOPJ
37100	HERE($ENQR)
37200		JUMPE	A,CPOPJ			;NULL NEVER
37300		HLRZ	TEMP,RMARK(A)		;BE SURE NOT THERE YET
37400		JUMPN	TEMP,CPOPJ
37500		HRR	TEMP,RECCHN		;LINK ONTO CHAIN
37600		HRLM	TEMP,RMARK(A)
37700		HRRM	A,RECCHN
37800		POPJ	P,
37900	ENQRB:	TLNN	C,-1			;C =-COUNT,,ADR
38000		POPJ	P,			;NULL CALL
38100		HRRZ	A,(C)
38200		PUSHJ	P,$ENQR			;PUT ONE ON QUEUE
38300		AOBJN	C,.-2			;ITERATE
38400		POPJ	P,
38500	ENQRBB:	MOVE	C,(B)			;B →→ A BLOCK OF -CNT,,ADR WORDS
38600		JUMPE	C,CPOPJ			;TERMINATED BY A ZERO
38700		PUSHJ	P,ENQRB
38800		AOJA	B,ENQRBB		;ITERATE
38900	ENQRBL: HRRZ	D,RBLIST		;ROUTINE THAT HANDLES RBLIST
39000	EQRB.L:	JUMPE	D,CPOPJ
39100		HRRZI	B,1(D)			;POINT AT THIS BLOCK
39200		PUSHJ	P,ENQRBB		;MARK EM ALL
39300		HRRZ	D,(D)			;ITERATE
39400		JRST	EQRB.L			
39500	PAMRK:  HLRZ	PDA,1(RF)		;HANDLES ONE EACH PROCEDURE ACTIVATION
39600		CAIN	PDA,SPRPDA		;CAN QUIT ON THIS
39700		POPJ	P,
39800		MOVEI	D,-1(RF)		;LAST PARAMETER LOCATION
39900		HRLI	D,C
40000		HRRZ	C,PD.NPW(PDA)		;NUMBER OF ARITH PARAMS
40100		MOVNI	C,(C)			;
40200		HRRZ	B,PD.DLW(PDA)		;POINT AT PARAMS
40300	MKPRM:	AOJGE	C,PRMSDN		;COUNT UP, QUIT WHEN RUN OUT
40400		LDB	TEMP,[POINT =12,(B),=12] ;INTERESTED IN VALUE RECORDS
40500		CAIE	TEMP,RECTYP		;TEST CODE
40600		AOJA	B,MKPRM			;NO, GO MARK NEXT
40700		HRRZ	A,@D			;PICK UP PARAMETER
40800		PUSHJ	P,$ENQR			;HANDLE IT
40900		AOJA	B,MKPRM
41000	PRMSDN: HRRZ	B,PD.LLW(PDA)		;POINT AT LVI
41100	LVI.DO:	SKIPN	D,(B)			;A ZERO MEANS DONE
41200		POPJ	P,
41300		LDB	TEMP,[POINT 4,D,3]
41400		CAIN	TEMP,RPACOD
41500		JRST	MRKRPA
41600		CAIE	TEMP,RPCOD
41700		AOJA	B,LVI.DO
41800		HRRZ	A,@D			;GET DESCRIPTOR
41900		PUSHJ	P,$ENQR
42000		AOJA	B,LVI.DO
42100	MRKRPA:	SKIPN	C,@D
42200		AOJA	B,LVI.DO
42300		MOVN	TEMP,-1(C)		;WORD COUNT
42400		HRL	C,TEMP
42500		PUSHJ	P,ENQRB			;DO THEM ALL
42600		AOJA	B,LVI.DO
42700	%PSMRR:	
42800		SKIPE	TEMP,RUNNER		;FANCY CASE
42900		JRST	PSMK.2			;HERE IF PROCESSES IN USE
43000		PUSH	P,RF			;SAVE RF
43100		PUSHJ	P,PSMK.1		;
43200		POP	P,RF
43300		POPJ	P,
43400	PSMK.1:	PUSHJ	P,PAMRK			;MARK 
43500		HRRZ	RF,(RF)			;DYNAMIC LINK
43600		CAIE	RF,-1			;DONE??
43700		JUMPN	RF,PSMK.1		;NO (ALSO TEST DONE ANOTHER WAY)
43800		POPJ	P,			;DONE ALL
43900	PSMK.2:	MOVEM	RF,ACF(TEMP)		;SAVE RF IN TABLE
44000		HRLZI	B,-NPRIS
44100		HRR	B,GOGTAB
44200	PSCHL:	SKIPN	TEMP,PRILIS(B)
44300		JRST	NXLS
44400		PUSH	P,B			;SAVE B
44500	PSCHL2:	
44600		PUSH	P,TEMP
44700		MOVE	RF,ACF(TEMP)
44800		PUSHJ	P,PSMK.1		;MARK THAT STACK
44900		POP	P,TEMP
45000		HRRZ	TEMP,PLISTE(TEMP)
45100		JUMPN	TEMP,PSCHL2
45200		POP	P,B
45300	NXLS:	AOBJN	B,PSCHL
45400		MOVE	TEMP,RUNNER
45500		MOVE	RF,ACF(TEMP)
45600		POPJ	P,
45700	RCIMRK:	MOVE	USER,GOGTAB	
45800		SKIPE	HASMSK(USER)		;ACTUALLY HAVE LEAP
45900		SKIPG	C,MAXITM(USER)		;ALL THE ITEMS TO MARK
46000		POPJ	P,			;NOPE
46100	RI1MK:	LDB	TEMP,INFOTAB(USER)	;GET TYPE
46200		MOVE	A,@DATAB(USER)		;AND DATUM READY
46300		CAIN	TEMP,RFITYP		;REFERENCE
46400		JRST	RFFOL
46500		CAIN	TEMP,ARRTYP+RECTYP	;RECORD ARRAY??
46600		JRST	RAIMK			;YES
46700		CAIN	TEMP,RECTYP		;REGULAR RECORD
46800		PUSHJ	P,$ENQR			;YES
46900	RIMITR:	SOJG	C,RI1MK			;ITERATE
47000		POPJ	P,
47100	RFFOL:	PUSH	P,C			;SINCE NO PROMISSES WERE MADE
47200		PUSHJ	P,$M1FLD		;MARK A FIELD
47300		POP	P,C
47400		JRST	RIMITR
47500	RAIMK:	
47600		SKIPN	TEMP,@A			;POINT AT RECORD ARRAY
47700		JRST 	RIMITR			;EMPTY
47800		PUSH	P,C			;SAVE ITEM NUMBER
47900		MOVN	C,-1(TEMP)
48000		HRL	C,TEMP
48100		MOVS	C,C			;-CNT,,ADR
48200		PUSHJ	P,ENQRB			;HANDLE EM ALL
48300		JRST 	RIMITR			;ITERATE
48400	$MRK1R:	PUSHJ	P,$ENQR			;ENQUEUE ONE RECORD
48500	HEREFK($RMARK,$RMAR.)
48600	$MRK.1:	HRRZ	A,RECCHN		;GET A RECORD OFF THE CHAIN
48700		CAIN	A,-1			;END OF THE ROAD??
48800		POPJ	P,			;YES
48900		HLRZ	D,RMARK(A)		;CDR THE QUEUE
49000		HRRM	D,RECCHN		;NEW NEXT ELT ON QUEUE
49100		HLRZ	D,RECCHN		;
49200		HRLM	D,RMARK(A)		;MAKE CHAIN OF ALL MARKED RECORDS
49300		HRLM	A,RECCHN
49400		HRRZ	D,CLSPTR(A)		;POINTER TO CLASS
49500		HRRZ	D,HNDLER(D)		;GET HANDLER ADDRESS
49600		CAIN	D,$REC$			;STANDARD HANDLER??
49700		JRST	MFLDS1			;YES
49800		PUSH	P,[4]			;THE "MARK" OP
49900		PUSH	P,A			;REC ID
50000		PUSHJ	P,(D)			;CALL ROUTINE
50100		JRST	$MRK.1
50200	MFLDS1:	PUSH	P,[$MRK.1]
50300	$MFLDS:	JUMPE	A,CPOPJ			;MARK ALL FIELDS OF RCD IN A
50400		HRRZ	C,CLSPTR(A)			;CLASS ID
50500		PUSH	P,RECSIZ(C)		;RECORD SIZE
50600		HRRZ	C,TYPARR(C)		;POINTER TO TYPE ARRAY
50700		HRL	C,(C)			;GET TYPE BITS
50800		TLNN	C,HASRPS		;HAVE RECORD OR RECORD ARRAY SUBFIELDS
50900		JRST	CPOP1J			;NO
51000		SUBI	C,(A)			;CORRECTION FACTOR
51100		ADDI	A,1			;FIRST DATA FIELD
51200		HRLI	C,(<POINT =13,(A),=12>)	;TO GET TYPE BITS
51300		PUSH	P,C			;SAVE IT
51400	G1FLD:	SOSGE	-1(P)			;ARE WE DONE?
51500		JRST 	CPOP2J			; YEP
51600		LDB	C,(P)			;GET TYPE
51700		DPB	C,[POINT =13,A,=12]	;DESCRIPTOR FOR ONE FIELD
51800		PUSHJ	P,$M1FLD		;MARK ONE FIELD
51900		AOJA	A,G1FLD			;ITERATE UNTIL DONE
52000	CPOP2J:	SUB	P,X22
52100		POPJ P,
52200	CPOP1J:	SUB	P,X11
52300	CPOPJ:	POPJ	P,
52400	$RGCMK:	PUSHJ	P,ENQRBL		;DO SOME STANDARD MARK ROUTINES -- OWNS
52500		PUSHJ	P,RCIMRK		;ITEMS
52600		PUSHJ	P,%PSMRR		;ACTIVE PROCEDURES
52700		PUSH	P,RGCLST		;NOW DO ANY SPECIAL ENLISTED ROUTINES
52800	RGCMK1:	POP	P,A			;GET NEXT ENQUEUEING ROUTINE TO CALL
52900		JUMPE	A,$MRK.1		;NO MORE -- GO PROCESS ALL WE HAVE SEEN
53000		PUSH	P,(A)			;SAVE LINK
53100		PUSHJ	P,@1(A)			;CALL THIS FELLOW
53200		JRST	RGCMK1			;GO GET SOME MORE
53300	$RGCSW:	;;****  THESE LINES CHANGED FROM PDQ METHOD ****
53400		HRRZ	D,RECRNG+$CLASS		;RING OF ALL CLASSES
53500	RGSWC:	MOVE	TEMP,@TYPARR(D)		;TYPE BITS FOR THIS CLASS
53600		HRRZ	A,RECRNG(D)		;RING OF RECORDS FOR THIS CLASS;
53700		TRNN	TEMP,NODELC		
53800		JRST	NXTREC			;DELETE UNMARKED RECORDS OF THIS CLASS;
53900	RGNODL:	HRRZS	RMARK(A)		;CLEAR MARK
54000		HRRZ	A,RING(A)
54100		CAIE	A,RECRNG-RING(D)	;HEAD OF CLASS?
54200		JRST	RGNODL			;NO, AGAIN
54300		JRST 	NXTCLS			;DONE WITH THIS RECORD CLASS -- ON TO NEXT
54400	RGSWPP:	HLL	TEMP,RMARK(A)		;GET MARK
54500		TLNN	TEMP,-1			;
54600		JRST	RGSWP1			;UNMARKED MEANS IT DIES
54700		HRRZS	RMARK(A)		;CLEAR MARK
54800		HRRZ	A,RING(A)		;POINT AT NEXT IN CLASS
54900	NXTREC:	CAIE	A,RECRNG-RING(D)	;IS IT HEAD OF CLASS?
55000		JRST	RGSWPP			;NOPE, CONTINUE
55100	NXTCLS:	HRRZ	D,RING(D)		;NEXT CLASS ON RING OF CLASSES
55200		CAIE	D,$CLASS+RECRNG-RING	;HEAD OF RING OF CLASSES?
55300		JRST	RGSWC			;NOPE, CONTINUE
55400		POPJ 	P,			;DONE AT LAST
55500	RGSWP1:	HRRZ	TEMP,RING(A)
55600		PUSH	P,TEMP			;SAVE POINTER TO NEXT ON RING
55700		PUSH	P,D			
55800		HRRZ	TEMP,CLSPTR(A)		;CLASS
55900		HRRZ 	TEMP,HNDLER(TEMP)	;HANDLER FOR CLASS
56000		CAIE	TEMP,$REC$		;IS IT STANDARD
56100		JRST	RGSWP3			;NO DO A REGULAR CALL
56200		PUSHJ	P,$DIE			;KILL RECORD
56300	RGSWP2:	POP	P,D
56400		POP	P,A
56500		JRST	NXTREC
56600	RGSWP3:	PUSH	P,[5]		;KILL YOURSELF
56700		PUSH	P,A
56800		PUSHJ	P,(TEMP)
56900		JRST	RGSWP2
57000	HERE($RECGC)
57100		SETOM	RECCHN		;INITIALIZE MARK AS NULL
57200		PUSHJ	P,$RGCMK	;MARK THEM ALL
57300		JRST	$RGCSW		;SWEEP THEM ALL
57400	HERE($M1FLD)
57500		JUMPE	A,CPOPJ		;NOTHING TO DO IF NULL
57600		TLNN	A,ITEMB		;NOTHING TO DO IF ITEMISH
57700		TLNE	A,PROCB		;OR PROCEDURE
57800		POPJ	P,
57900		LDB	TEMP,[POINT 6,A,=12] ; SIX BIT TYPE
58000		CAIN	TEMP,RECTYP	;A RECORD??
58100		JRST	M1REC		;YES, ENQUEUE IT
58200		CAIN	TEMP,RFITYP	;A REFERENCE ITSELF
58300		JRST	M1REF		;YES
58400		CAIE	TEMP,RECTYP+ARRTYP; A RECORD ARRAY??
58500		POPJ	P,		;NOPE
58600		PUSH	P,A		;SINCE AGREED TO LEAVE ALONE
58700		PUSH	P,B
58800		SKIPN	B,(A)		;PICK UP ARRAY DESCRIPTOR
58900		POPJ	P,		;EMPTY
59000		MOVN	TEMP,-1(B)	;WORD COUNT
59100		JUMPE	TEMP,M1AXIT	;NO WORDS
59200		HRL	B,TEMP
59300	M1ALP:	MOVE	A,(B)		;PICK UP A WORD
59400		PUSHJ	P,$ENQR		;ENQUEUE IT
59500		AOBJN	B,M1ALP
59600	M1AXIT:	POP	P,B		;
59700		POP	P,A
59800		POPJ	P,
59900	M1REC:	PUSH	P,A		;WE PROMISSED TO LEAVE ALONE
60000		MOVE	A,@A		;FETCH VARIABLE
60100		PUSHJ	P,$ENQR		;ENQUEUE IT
60200		POP	P,A		;RESTORE
60300		POPJ	P,
60400	M1REF:	PUSH	P,A
60500		MOVE	A,@A
60600		PUSHJ	P,$M1FLD	;MARK THE THING REFERENCED
60700		POP	P,A
60800		POPJ	P,
60900	BEND RECORD
61000	ENDCOM(REC)