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)