perm filename SAIREC.FAI[S,AIL]4 blob sn#163071 filedate 1975-06-10 generic text, type T, neo UTF8
COMPIL(REC,<$REC$,FLDKIL,$RERR,$RECGC,$M1FLD,$ENQR,$RECFN,$RCINI,$RMARK>
	,<RECQQ,ALLFOR,ARYEL,CORGET,CORREL,X11,X22,X33,CLSLNK,STRCHN,RSGCLK,GOGTAB,$DEL1B,$GET1B>
	,<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
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
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	
TXTARR←←5	;STRING ARRAY OF FIELD NAMES 
FSTRSIZ←←20
STRINIT:	
	MOVEI C,2*FSTRSIZ+1		;ENOUGH ROOM FOR 20 STRINGS
	PUSHJ P,CORGET
	ERR <NO CORE FOR RECORD STRINGS>,1,ZPOPJ
	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,
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,
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,
BEGIN  RSGC
F←←E+1
↑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			
	MOVE	D,(E)			;GET SUBFIELD -- POINTER TO STRING ARRAY
	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
	POP	P,D
	JRST	NXFLD
BEND RSGC
$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
	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
	POP	P,B			; THE CORREL POINTER
	SUBI	B,1			; NOW IT IS (THE REF CNT WORD, REMEMBER)
	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,
↑↑$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
	PUSH	P,A		; EVENTUALLY, BECOMES THE RECID POINTER
	MOVE	USER,GOGTAB	; GET THE SYSTEM FREE LIST
	MOVE	A,$FSLIS(USER)	;
	PUSHJ	P,$GET1B	; MAY WANT MORE EFFICIENCY LATER
	ERR	<NO CORE FOR RECORD ALLOCATION>,1,ZPOPJ
	MOVEI	A,1(B)		;THE POINTER WE WILL ACTUALLY RETURN
	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,
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
	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
	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
HERE(FLDKIL)
	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
WZAPR:	TLNN	A,TMPB		;CALLING FROM LEAP ???
RPOPJ:	POPJ	P,		;
	ERR	<FLDKIL NOT YET READY FOR CALL FOR REFITEMS>,1,RPOPJ
HERE($ENQR)
	JUMPE	A,CPOPJ			;NULL NEVER
	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
%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,
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:	
	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
$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
	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,
$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
$RGCSW:	;;****  THESE LINES CHANGED FROM PDQ METHOD ****
	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;
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
	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
HERE($RECGC)
	SETOM	RECCHN		;INITIALIZE MARK AS NULL
	PUSHJ	P,$RGCMK	;MARK THEM ALL
	JRST	$RGCSW		;SWEEP THEM ALL
HERE($M1FLD)
	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
	POPJ	P,		;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,
BEND RECORD
ENDCOM(REC)