perm filename RECSER[S,AIL]5 blob
sn#124481 filedate 1974-10-10 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00012 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 FANCY SMALL SPACE SERVICE
C00009 00003 SPECIAL FIXED SIZE BLOCK HANDLERS: $FXGET, $FXDEL
C00018 00004 SAIREC -- SYSTEM RECORD HANDLER ROUTINES
C00023 00005 SAIREC -- FLDKIL ROUTINE
C00028 00006 SAIREC (RECGC) -- $ENQR,ENQRB,ENQRBB,PAMRK
C00031 00007 SAIREC (RECGC) -- %PSMRR
C00033 00008 SAIREC (RECGC) -- RCIMRK
C00035 00009 SAIREC (RECGC) -- $MRK.1, $MFLDS
C00037 00010 SAIREC (RECGC) -- $RGCMK, $RGCSW
C00039 00011 SAIREC (RECGC) -- MAIN ROUTINE
C00040 00012 SAIREC (RECGC) -- $M1FLD
C00042 ENDMK
C⊗;
;; FANCY SMALL SPACE SERVICE
COMPIL(SPC,,,,,,DUMMYFORGDSCISS)
DEFINE SPCINS <$FUNLK,$FXBLD,$FXGET,$FXG,$FXDEL,$FXD>
COMPXX(SPC,<$GETB,$GET1B,$DELB,$DEL1B,$FSADD,$FSINS,$FSINI,SPCINS>
,<GOGTAB,X22,X33,CORGET,CORREL>
,<SMALL SPACE SERVICE ROUTINES>,,HIIFPOSIB)
BEGIN SPCSER -- SMALL FREE BLOCK SERVICE
DSCR $GETB,$DELB,$GET1B,$DEL1B,$FSADD,$FSINS,$FUNLK
These routines are generally useful for handling allocation of small
blocks of storage. Essentially, there is a linked list (homed at
$FSLIS(<gogtab>) ) of blocks, each of which specifies a "space".
<prev on chain>,,<next on chain>
<addr of "allocate" routine>
<addr of "deallocate" routine>
< ... miscellaneous info ... >
:
< ... miscellaneous info ... >
Each allocate routine is assumed to take as parameters:
A -- pointer to the space descriptor block
C -- size of request
results:
skip return -- B points to a fresh block of the correct size
no skip return -- failure
Each deallocate routine is assumed to take as parameters:
A -- pointer to the space descriptor block
B -- pointer to block to be released
results:
skip return -- the block release was successful
no skip return -- block release was unsuccessful
Except as stated above, the routines are assumed to have no side effects.
(except possibly to load USER with GOGTAB).
$GET1B acts just like an allocate routine, except that it takes (in A)
a pointer to the first block in a whole list of routines
and returns as its value (in A) a pointer to the descriptor
block of the last allocate routine called.
$DEL1B acts like a deallocate routine except that it takes (in A)
a pointer to the first block in a whole list of routines
and returns as its value (in A) a pointer to the descriptor
block of the last deallocate routine called.
SAIL calling sequence routines that cdr down $FRELIS:
<block>←$GETB(size) ;returns 0 if lose
<result>←$DELB(blockid) ;returns 0 if lose, space id if win
$FSLIS service routines (munch USER,TEMP,LPSA):
$FSADD(<dcsr block>) ; adds named block to $FSLIS
$FSINS(@<list owner>,<block addr>) ;adds named block to named list (at head)
$FUNLK(<dscr block>) ; removes named block from any list
⊗
%GPROC ←← 1 ;GETTING PROC
%DPROC ←← 2 ;DELETING PROC
%FFRXX ←← 3 ;INDEX OF FIRST FREE LOCATION
HERE($GETB)
MOVE C,-1(P) ;GET SIZE
MOVE USER,GOGTAB ;
SKIPE A,$FSLIS(USER)
PUSHJ P,$GET1B ;CDR DOWN LIST
TDZA A,A ;NO JOY
MOVE A,B ;THE RESULT
RET22: SUB P,X22
JRST @2(P) ;RETURN
HERE($DELB)
MOVE B,-1(P) ;THE BLOCK
MOVE USER,GOGTAB
SKIPE A,$FSLIS(USER)
PUSHJ P,$DEL1B
MOVEI A,0
JRST RET22
GET1B1: HRRZ A,(A) ;PART OF THE $GET1B LOOP
HERE($GET1B)
JUMPE A,CPOPJ ;CHECK NULLITUDE
PUSHJ P,@%GPROC(A) ;CALL THE ROUTINE
JRST GET1B1 ;LOOP ON TO NEXT, THIS ONE LOST
CPOPJ1: AOS (P) ;SKIP RETURN IF WIN
CPOPJ: POPJ P, ;RETURN
DEL1B1: HRRZ A,(A) ;SAME KLUGE
HERE($DEL1B)
JUMPE A,CPOPJ ;
PUSHJ P,@%DPROC(A) ;ALLOCATE ROUTINE
JRST DEL1B1 ;LOST, TRY NEXT
JRST CPOPJ1 ;WIN
HERE($FSADD) ;LINKS IN ONE BLOCK
MOVE USER,GOGTAB
MOVEI LPSA,$FSLIS(USER)
PUSH P,LPSA ;THIS IS THE OWNER
PUSH P,-2(P) ;THE RECORD TO ADD
PUSHJ P,$FSINS ;CALL INSERT ROUTINE
JRST RET22 ;GO RETURN
HERE($FUNLK)
MOVE LPSA,-1(P) ;THE BLOCK WE ARE TO UNLINK
MOVE TEMP,(LPSA) ;THE LEFT,,RIGHT
TRNE TEMP,-1 ;IF HAVE A RIGHT HAND
HLLM TEMP,(TEMP) ;LET HIM HOLD MY LEFT
MOVSS TEMP ;SWAP HALVES
HLRM TEMP,(TEMP) ;LET HIM HOLD MY RIGHT
JRST RET22 ;DONE
HERE($FSINS) ;
HRRZ TEMP,-1(P) ;THE THING TO INSERT
HRRZ LPSA,-2(P) ;ADDRESS OF OWNER CELL
HRLM LPSA,(TEMP) ;REMEMBER AS BACK POINTER
EXCH LPSA,(LPSA) ;LPSA IS NOW FWD PTR
TRNE LPSA,-1 ;WAS THE CHAIN NULL?
HRLM TEMP,(LPSA) ;NO HE GETS A BACK PTR TOO
HRRM LPSA,(TEMP) ;OLD HEAD IS NEW RIGHT BROTHER
RET33: SUB P,X33 ;RETURN
JRST @3(P) ;
NOLOW <
NOUP <
REN <
USE
>;REN
FSI: 0
$FSINI
0
LINK %INLNK,FSI
REN <
USE HIGHS
>;REN
>;NOUP
>;NOLOW
HERE($FSINI)
SKIPN USER,GOGTAB
ERR <$FSINI CALLED W/O GOGTAB INITIALIZED>
SKIPE $FSLIS(USER)
ERR <$FSINI CALLED WITH THINGS ON $FSLIS>,1
MOVEI C,3 ;JUST A LITTLE BLOCK
PUSHJ P,CORGET
ERR <CORGET DIDN'T GIVE ME ANY>,1
HRRZM B,$FSLIS(USER)
HRLZI C,$FSLIS(USER)
MOVEM C,(B)
MOVEI C,CORGET
MOVEM C,%GPROC(B)
MOVEI C,[PUSHJ P,CORREL
AOS(P)
POPJ P,
]
MOVEM C,%DPROC(B)
POPJ P,
;; SPECIAL FIXED SIZE BLOCK HANDLERS: $FXGET, $FXDEL
DSCR $FXG,$FXD,$FXGET,$FXDEL,$FXSPC,$FXBLD
DES These routines operate on space descriptor blocks of the form:
word 0: left,,right
$FXG
$FXD
blksiz: block size
minsiz: minimum size request to honor
blkcnt: number of blocks per space
usecnt: number of blocks allocated from this space
maxadr: address of last record in this space
frelis: free list of blocks
sublis: a list header word for other blocks with this format
firblk: ... first "data word" in the space ...
:
< blkcnt*blksiz +firblk words of corget space >
:
Note: the "top" such block (Ie the one on the $FSLIS) will usually
contain the routines $FXGET & $FXREL & will have actually no
blocks (ie frelis=0). They will mapcar down their subordinates
looking for customers. The subordinates ($FXG & $FXD) will
work by having brothers. If a $FXG block gets bloated, it
will just fail. If one goes empty, it will just go away.
If all of a $FXGET block's subordinates lose, it just adds a
new one as the left subchild.
A space descriptor block ($FXGET style) may be built by the runtime routine
<block> ← $FXSPC(<block size>,<min size>,<block count>)
Thus a new space for allocating blocks of size 9 to 16 could be
defined & added to $FSLIS by the statement
$FXADD($FXSPC(16,9,32)); ! 32 blocks per buffer;
The routine $FXBLD(@<chain header>,<template block>) makes a fresh
block patterned after the template & puts it on the named chain.
⊗
%FXIX ←← %FFRXX ;FIRST LEGAL FIELD
DEFINE $FXFLD(ID) <
ID ←← %FXIX
%FXIX ←← %FXIX+1
>
$FXFLD %BLKSIZ ;BLOCK SIZE
$FXFLD %MINSIZ ;MIN ACCEPTABLE SIZE
$FXFLD %BLKCNT ;NUMBER OF BLOCKS PER SPACE
$FXFLD %USECNT ;NUMBER OF BLOCKS ALLOCATED FROM THIS SPACE
$FXFLD %MAXADR ;MAX ADDRESS OF A BLOCK IN THIS SPACE
$FXFLD %FRELIS ;FREE LIST
$FXFLD %SUBLIS ;SUBLIST OF SIMILAR BLOCKS
$FXFLD %FIRBLK ;FIRST DATA WORD
HERE($FXGET)
CAMG C,%BLKSIZ(A) ;WOULD IT FIT
CAMGE C,%MINSIZ(A) ;
POPJ P, ;NO
PUSH P,A ;YEP GO DOWN KINDERN
FGTRY: SKIPE A,%SUBLIS(A) ;IF ANY
PUSHJ P,$GET1B ;
JRST ADDAB ;ADD A BLOCK
FGWIN: POP P,A ;I AM SUCH A WINNER
JRST CPOPJ1 ;& GO WIN
;# # RHT ! I HAD LEFT OUT THE RESTORE OF A
ADDAB: MOVE A,(P) ;SINCE A IS ZERO AT THIS POINT
MOVEI B,%SUBLIS(A) ;OWNER OF NEW LIST
PUSH P,B ;BUILD CALL TO $FXBLD
PUSH P,-1(P) ;PUSH A COPY OF A
PUSHJ P,$FXBLD ;MAKES A NEW SPACE FOR $FXG
MOVE A,(P) ;WHERE WE HAD SAVED IT
JRST FGTRY ;GO TRY AGAIN -- EXPECT TO WIN
HERE($FXG)
CAMG C,%BLKSIZ(A) ;WOULD IT FIT?
CAMGE C,%MINSIZ(A) ;
POPJ P, ;NO WAY
SKIPN B,%FRELIS(A) ;ONE ON FREE LIST
POPJ P, ;NO SUCH LUCK
AOS %USECNT(A) ;ONE LESS FREE NOW
PUSH P,(B) ;KLUGY WAY TO COPY FREE LIST
POP P,%FRELIS(A) ;PUTS BACK THE NEXT ONE
JRST CPOPJ1 ;GO SKIP RETURN -- WE WIN
HERE($FXDEL)
PUSH P,A ;IN THIS CASE, JUST GO DOWN CHILDREN
SKIPE A,%SUBLIS(A) ;
PUSHJ P,$DEL1B ;LIKE SO
SOS -1(P) ;WILL NA SKIP RETURN
POP P,A ;GET OWN NAME BACK
JRST CPOPJ1 ;I AM A WINNER
HERE($FXD)
CAMG B,%MAXADR(A) ;IN RANGE?
CAIG B,(A) ;A IS MY OWN POINTER,REMEMBER
POPJ P, ;NOPE
SOSG %USECNT(A) ;IF THIS WAS THE LAST
JRST BIGKIL ;THEN THE WHOLE BLOCK GOES AWAY
PUSH P,B ;MUST PRESERVE
HRRZS B ;JUST BE SURE RHS ONLY IS ON
EXCH B,%FRELIS(A) ;SAVE AWAY NEW LIST
MOVEM B,@%FRELIS(A) ;& LINK IT TO OLD
POP P,B ;GET BACK
JRST CPOPJ1 ;WHAT WINNAGE!
BIGKIL: PUSH P,LPSA ;SAVE A COUPLE
PUSH P,TEMP ;
PUSH P,B
PUSH P,A ;GO UNLINK THIS BLOCK
PUSHJ P,$FUNLK ;LIKE SO
MOVE B,A ;GO CLOBBER THE WHOLE BLOCK
PUSHJ P,CORREL ;LIKE SO
POP P,B ;A PITY CANNOT JUST ZERO OUT B
POP P,TEMP ;GET ACS BACK
POP P,LPSA ;
JRST CPOPJ1 ;RETURN
HERE($FXSPC)
MOVEI C,%FIRBLK ;HOW BIG IT NEEDS TO BE
PUSHJ P,CORGET ;USE CORGET SPACE FOR THIS (DONT REALLY HAVE TO
ERR <NO CORE TO BE HAD>,1 ; BUT MAY WANT TO DO THIS AT FUNNY TIMES)
MOVE A,B ;WHERE WE WILL RETURN VALUE
HRL B,B ;CLEANSE IT
HRRI B,1(B)
SETZM (B)
BLT B,%FIRBLK-1(A)
MOVEI B,$FXGET ;
MOVEM B,%GPROC(A)
MOVEI B,$FXDEL
MOVEM B,%DPROC(A)
POP P,B
POP P,%BLKCNT(A)
POP P,%MINSIZ(A)
POP P,%BLKSIZ(A)
JRST (B)
HERE($FXBLD)
MOVE A,-1(P) ;MUST ADD A BLOCK
PUSH P,C ;SAVE THIS SIZE REQUEST
PUSH P,TEMP ;SAVE A COUPLE ACS
PUSH P,LPSA ;WHICH WE PROMISSED NOT TO MUNGE
PUSH P,B
SKIPN C,%BLKCNT(A) ;
ERR <IT DOESN'T HELP YOU MUCH TO ALLOCATE ZERO MORE BLOCKS>,1,L1DON
IMUL C,%BLKSIZ(A) ;B ← NOMINAL BLOCK SIZE * COUNT + OVERHEAD
ADDI C,%FIRBLK ;
PUSHJ P,CORGET ;A BLOCK OF THIS GREAT SIZE
ERR <COULDN'T GET ANY MORE SPACE FROM CORGET>,1
MOVEI TEMP,%FIRBLK(A) ;NOW CHAIN ALL SUB-BLOCKS TOGETHER
MOVEI LPSA,0 ;
MOVE C,%BLKCNT(A) ;SO WE WILL COUNT DOWN
MOVEM C,%BLKCNT(B) ;ALSO, THE BLOCK COUNT FOR THIS
L1B: MOVEM LPSA,(TEMP) ;POINT TO NEXT
MOVE LPSA,TEMP ;REMEMBER THE BACK POINTER
ADD TEMP,%BLKSIZ(A) ;NEXT BLOCK
SOJG C,L1B ;COUNT DOWN TO ZERO
L1DON: MOVEM LPSA,%FRELIS(B) ;THIS IS THE FIRST FREE
MOVEM LPSA,%MAXADR(B) ;ALSO THE MAX ADDRESS BLOCK IN THIS SPACE
SETZM %USECNT(B) ;USE COUNT IS ZERO
SETZM %SUBLIS(B) ;THE SUBLIST IS ZERO
MOVE LPSA,%MINSIZ(A) ;COPY THESE, TOO (HRROI POP IS FASTER
MOVEM LPSA,%MINSIZ(B) ;BUT THIS ALLOWS EASIER REARRANGEMENT)
MOVE LPSA,%BLKSIZ(A) ;
MOVEM LPSA,%BLKSIZ(B) ;
MOVEI LPSA,$FXG ;THE HANDLERS FOR THESE
MOVEM LPSA,%GPROC(B) ;REMEMBER THE HANDLER
MOVEI LPSA,$FXD
MOVEM LPSA,%DPROC(B) ;
PUSH P,-6(P) ;GO LINK ONTO THIS ADDRESS
PUSH P,B ;THE BLOCKID
PUSHJ P,$FSINS ;USING THE STANDARD INSERTER
POP P,B
POP P,LPSA ;GET ACS BACK
POP P,TEMP ;
POP P,C ;
SUB P,X33
JRST @3(P) ;RETURN
BEND SPCSER
ENDCOM (SPC)
;; SAIREC -- SYSTEM RECORD HANDLER ROUTINES
COMPIL(REC,<$REC$,FLDKIL,$RERR,$RECGC,$M1FLD,$ENQR>
,<RECQQ,ALLFOR,ARYEL,CORGET,CORREL,X11,GOGTAB,$DEL1B,$GET1B>
,<SAIL RECORD HANDLER>,<$RDREF,$RALLO>);
BEGIN RECORD
RGC <
IFE ALWAYS, <
EXTERNAL RECCHN,RGCLST,RBLIST,RUNNER,SPRPDA,PLISTE,ACF
>;IFE ALWAYS
>;RGC
PDA ← 7 ;DEF USED BY THE GARBAGE COLLECTOR
;;$REC$ CALLED VIA PUSH P,[OP]
; PUSH P,ARG1
; PUSH P,ARG2
; PUSHJ P,$REC$ ;(OR @<RECORD HEADER>)
; IS ASSUMED TO WIPE OUT THE ACS
$RDISP: JRST $RDREF ;DEREFERENCE ARG1
JRST $RALLO ;ALLOCATE RECORD WITH CLASS ARG1
JRST CPOPJ ;2
JRST CPOPJ ;3
JRST $MFLDS ;4 -- MARK ALL FIELDS OF A RECORD
JRST $DIE ;5 DELETE SPACE FOR RECORD
$RMAX ←← (.-$RDISP)-1
HERE($REC$)
POP P,C ;RET ADR
POP P,B
POP P,A
EXCH C,(P) ; NOW C=OP, A=ARG1, B=ARG2
CAILE C,$RMAX
POPJ P,
JUMPN C,@$RDISP(C) ; OBEY COMMAND
↑↑$RDREF:
NORGC <
SKIPE A ; HAVE ONE?
SOSLE -1(A) ; YEP, DECREMENT COUNT
POPJ P, ; RETURN
$DIE:
>;NORGC
RGC <
ERR <CALL ON $RDREF IN RECORD GC VERSION>,1
POPJ P,
$DIE: JUMPE A,CPOPJ ;
>;RGC
PUSH P,A ; SO CAN LATER CALL CORREL
HRRZ C,(A) ; CLASS ADDRESS
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: LDB C,(P) ; GET FIELD
JUMPE C,NOMORE ; NO MORE FIELDS LEFT
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,X11 ; JUST POP ONE 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:
LDB C,[POINT =13,(A),=12] ; A = RECORD CLASS ID. GET THE WORD COUNT
;;#SF# ! USED TO BE 1
ADDI C,2 ; C = NUMBER OF WORDS+1 FOR REFCNT
;+1 FOR DESCRIPTOR WORD
HRLI A,20 ; INDIREC BIT
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
;;#SF# ! USED TO BE (B)
ADDI C,-1(B) ;STOPPING PLACE
SETZM (B); ;ZERO OUT (ALSO REF CNT ← 0)
HRL B,B ;BUILD BLT PTR
HRRI B,1(B)
BLT B,(C) ;BLT THEM AWAY
NORGC <
AOS -1(A) ;BUMP REF CNT
>;NORGC
RGC <
HLLZ B,RECCHN ;ADD TO SWEEP LIST
HLLZM B,-1(A) ;LIKE SO
HRLM A,RECCHN
>;RCG
POP P,(A) ;THE RECID POINTER
POPJ P, ;RETURN
ZPOPJ: MOVEI A,0
POPJ P,
HERE($RERR)
ERR <ACCESS TO A SUBFIELD OF A NULL RECORD>,1
POPJ P,
NORGC <
$MFLDS: ERR <CALL TO $MFLDS IN NON RECORD GC VERSION>,1
POPJ P,
>;NORGC
;; SAIREC -- FLDKIL ROUTINE
HERE(FLDKIL)
;CALLED WITH REFITEM TYPE DESCRIPTOR IN A
;WILL TAKE ALL APPROPTIATE ACTION
;IF TMPB IS ON IN A, THEN ASSUMES THAT CALLED FROM LEAP
; -- THUS, IF TMPB AND NOT REFB, WILL DO THE RIGHT THING
; ABOUT ONE & TWO WORD FREES
;PRESERVES A BUT ALL OTHERS MAY BE MUNGED
TLNN A,REFB ; IF REFB ON, THEN NO DELETION REQUIRED
SKIPN @A ; NOTHING TO DO IF A NULL
POPJ P,
TLNE A,ARY2B ;ITEMVAR ARRAY ??
JRST ARYKIL ;YEP
TLNN A,ITEMB ;NOTHING TO DO IF ITEM
TLNE A,PROCB ;OR PROCEDURE
POPJ P,
LDB TEMP,[POINT 6,A,=12] ; SIX BIT TYPE
CAIL TEMP,INVTYP ;VERIFY VALID
ERR <DRYROT -- INVALID REFERENCE TYPE IN FLDKIL>,5,RPOPJ
CAIG TEMP,MXSTYP ;IS THIS A LEGAL ARRAY TYPE ??
JRST @FKDISP(TEMP) ;NOPE DO WHATEVER YOU MUST
MOVEI TEMP,@FKDISP-ARRTYP(TEMP) ;FIND OUT WHAT SORT OF ARRAY YOU HAVE
CAIN TEMP,WZAPR ;A DONOTHING ??
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 .+2 ;MAY AS WELL LEAVE A ON THE STACK
ARYKIL: PUSH P,A ;SINCE ARYEL CLOBBERS IT
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
WZAPR ;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
NORGC <
WRDRF ;13 RECORD DEREFERENCING
>;NORGC
RGC <
WZAPR ;13 RECORD DEREFERENCING
>;RGC
WSLKL: SKIPN B,@A ;DO WE HAVE ONE
JRST WZAPR ;NOPE JUST WORRY ABOUT FREES
PUSH P,A ;WHO KNOWS WHAT EVIL LURKS IN THE HEART OF LEAP
SETZM @A ;CLEAR IT OUT
MOVE A,B ;
MOVEI 5,0 ;ALL SET UP
PUSHJ P,RECQQ ;RELEASE THE SET OR LIST
POP P,A ;GET A BACK
JRST WZAPR
WCTXTK: SKIPN B,@A ;HAVE ONE
POPJ P, ;YEP
SETZM @A ;
PUSH P,A ;KILLING A CONTEXT
PUSH P,B
PUSHJ P,ALLFOR ;FORGET IT
POP P,A ;GET BACK A
JRST WZAPR
WRDRF: PUSH P,A ;SAVE
MOVE A,@A ; DO DEREFERENCE
PUSHJ P,$RDREF ;CALL DEREFERENCER
POP P,A ;GET A BACK
;FALL INTO WZAPR
WZAPR: TLNN A,TMPB ;CALLING FROM LEAP ???
RPOPJ: POPJ P, ;
;MUST WORRY ABOUT LEAPISHNESS
ERR <FLDKIL NOT YET READY FOR CALL FOR REFITEMS>,1,RPOPJ
;; SAIREC (RECGC) -- $ENQR,ENQRB,ENQRBB,PAMRK
RGC <
HERE($ENQR)
JUMPE A,CPOPJ ;NULL NEVER
HRRZ TEMP,-1(A) ;BE SURE NOT THERE YET
JUMPN TEMP,CPOPJ
HRR TEMP,RECCHN ;LINK ONTO CHAIN
HRRM TEMP,-1(A)
HRRM A,RECCHN
POPJ P,
ENQRB: TLNN C,-1 ;C =-COUNT,,ADR
POPJ P, ;NULL CALL
HRRZ A,(C)
PUSHJ P,$ENQR ;PUT ONE ON QUEUE
AOBJN C,.-2 ;ITERATE
POPJ P,
ENQRBB: MOVE C,(B) ;B →→ A BLOCK OF -CNT,,ADR WORDS
JUMPE C,CPOPJ ;TERMINATED BY A ZERO
PUSHJ P,ENQRB
AOJA B,ENQRBB ;ITERATE
ENQRBL: HRRZ D,RBLIST ;ROUTINE THAT HANDLES RBLIST
EQRB.L: JUMPE D,CPOPJ
HRRZI B,1(D) ;POINT AT THIS BLOCK
PUSHJ P,ENQRBB ;MARK EM ALL
HRRZ D,(D) ;ITERATE
JRST EQRB.L
PAMRK: HLRZ PDA,1(RF) ;HANDLES ONE EACH PROCEDURE ACTIVATION
CAIN PDA,SPRPDA ;CAN QUIT ON THIS
POPJ P,
MOVEI D,-1(RF) ;LAST PARAMETER LOCATION
HRLI D,C
HRRZ C,PD.NPW(PDA) ;NUMBER OF ARITH PARAMS
MOVNI C,(C) ;
HRRZ B,PD.DLW(PDA) ;POINT AT PARAMS
MKPRM: AOJGE C,PRMSDN ;COUNT UP, QUIT WHEN RUN OUT
LDB TEMP,[POINT =12,(B),=12] ;INTERESTED IN VALUE RECORDS
CAIE TEMP,RECTYP ;TEST CODE
AOJA B,MKPRM ;NO, GO MARK NEXT
HRRZ A,@D ;PICK UP PARAMETER
PUSHJ P,$ENQR ;HANDLE IT
AOJA B,MKPRM
PRMSDN: HRRZ B,PD.LLW(PDA) ;POINT AT LVI
LVI.DO: SKIPN D,(B) ;A ZERO MEANS DONE
POPJ P,
LDB TEMP,[POINT 4,D,3]
CAIN TEMP,RPACOD
JRST MRKRPA
CAIE TEMP,RPCOD
AOJA B,LVI.DO
HRRZ A,@D ;GET DESCRIPTOR
PUSHJ P,$ENQR
AOJA B,LVI.DO
MRKRPA: SKIPN C,@D
AOJA B,LVI.DO
MOVN TEMP,-1(C) ;WORD COUNT
HRL C,TEMP
PUSHJ P,ENQRB ;DO THEM ALL
AOJA B,LVI.DO
;; SAIREC (RECGC) -- %PSMRR
%PSMRR:
SKIPE TEMP,RUNNER ;FANCY CASE
JRST PSMK.2 ;HERE IF PROCESSES IN USE
PUSH P,RF ;SAVE RF
PUSHJ P,PSMK.1 ;
POP P,RF
POPJ P,
PSMK.1: PUSHJ P,PAMRK ;MARK
HRRZ RF,(RF) ;DYNAMIC LINK
CAIE RF,-1 ;DONE??
JUMPN RF,PSMK.1 ;NO (ALSO TEST DONE ANOTHER WAY)
POPJ P, ;DONE ALL
PSMK.2: MOVEM RF,ACF(TEMP) ;SAVE RF IN TABLE
HRLZI B,-NPRIS
HRR B,GOGTAB
PSCHL: SKIPN TEMP,PRILIS(B)
JRST NXLS
PUSH P,B ;SAVE B
PSCHL2:
PUSH P,TEMP
MOVE RF,ACF(TEMP)
PUSHJ P,PSMK.1 ;MARK THAT STACK
POP P,TEMP
HRRZ TEMP,PLISTE(TEMP)
JUMPN TEMP,PSCHL2
POP P,B
NXLS: AOBJN B,PSCHL
MOVE TEMP,RUNNER
MOVE RF,ACF(TEMP)
POPJ P,
;; SAIREC (RECGC) -- RCIMRK
RCIMRK: MOVE USER,GOGTAB
SKIPE HASMSK(USER) ;ACTUALLY HAVE LEAP
SKIPG C,MAXITM(USER) ;ALL THE ITEMS TO MARK
POPJ P, ;NOPE
RI1MK: LDB TEMP,INFOTAB(USER) ;GET TYPE
MOVE A,@DATAB(USER) ;AND DATUM READY
CAIN TEMP,RFITYP ;REFERENCE
JRST RFFOL
CAIN TEMP,ARRTYP+RECTYP ;RECORD ARRAY??
JRST RAIMK ;YES
CAIN TEMP,RECTYP ;REGULAR RECORD
PUSHJ P,$ENQR ;YES
RIMITR: SOJG C,RI1MK ;ITERATE
POPJ P,
RFFOL: PUSH P,C ;SINCE NO PROMISSES WERE MADE
PUSHJ P,$M1FLD ;MARK A FIELD
POP P,C
JRST RIMITR
RAIMK:
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
;; SAIREC (RECGC) -- $MRK.1, $MFLDS
$MRK1R: PUSHJ P,$ENQR ;ENQUEUE ONE RECORD
$MRK.1: HRRZ A,RECCHN ;GET A RECORD OFF THE CHAIN
CAIN A,-1 ;END OF THE ROAD??
POPJ P, ;YES
MOVE D,-1(A) ;CDR THE QUEUE
HRRM D,RECCHN ;NEW NEXT ELT ON QUEUE
MOVEI D,@(A) ;GET HANDLER ADDRESS
CAIN D,$REC$ ;STANDARD HANDLER??
JRST MFLDS1 ;YES
PUSH P,[4] ;THE "MARK" OP
PUSH P,A ;REC ID
PUSH P,[0] ;PLACE HOLDER
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,(A) ;CLASS ID
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: LDB C,(P) ;GET TYPE
JUMPE C,CPOP1J ;ALL DONE
DPB C,[POINT =13,A,=12] ;DESCRIPTOR FOR ONE FIELD
PUSHJ P,$M1FLD ;MARK ONE FIELD
AOJA A,G1FLD ;ITERATE UNTIL DONE
CPOP1J: SUB P,X11
CPOPJ: POPJ P,
;; SAIREC (RECGC) -- $RGCMK, $RGCSW
$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: HLRZ A,RECCHN
MOVEI D,-1 ;NEW RECORD LIST
JUMPE A,RGSWPT ;DONE
RGSWPP: MOVS TEMP,-1(A) ;GET NEXT
TLNN TEMP,-1 ;
JRST RGSWP1 ;UNMARKED MEANS IT DIES
HLLZM D,-1(A) ;LINK ONTO LIVE LIST
HRLO D,A
HRRZ A,TEMP ;POINT AT NEXT
JUMPN A,RGSWPP
RGSWPT: MOVEM D,RECCHN
POPJ P,
RGSWP1: PUSH P,TEMP ;WILL EVENTUALLY BE RECORD WE LOOK AT
MOVEM D,RECCHN ;OUT OF HARMS WAY
HRRZI TEMP,@(A) ;LOOK AT HANDLER ROUTINE
CAIE TEMP,$REC$ ;IS IT STANDARD
JRST RGSWP3 ;NO DO A REGULAR CALL
PUSHJ P,$DIE ;KILL RECORD
RGSWP2: MOVE D,RECCHN
POP P,A
JUMPN A,RGSWPP
JRST RGSWPT
RGSWP3:
PUSH P,[5] ;KILL YOURSELF
PUSH P,A
PUSH P,[0] ;PLACE HOLDER
PUSHJ P,(TEMP)
JRST RGSWP2
;; SAIREC (RECGC) -- MAIN ROUTINE
HERE($RECGC)
HLRZ A,RECCHN ;FIRST VERIFY THAT THE CHAIN IS OK
JUMPE A,CPOPJ ;NO RECORDS AT ALL
RGC.1: MOVE D,A ;FOR REMEMBERING
MOVS A,-1(A) ;CHECK LINK
TLNE A,-1
JRST RGCLER ;LINK GLUBBED UP
JUMPN A,RGC.1 ;GO BACK & CHECK NEXT ONE
RGC.2: HLLOS RECCHN ;INITIALIZE MARK AS NULL
PUSHJ P,$RGCMK ;MARK THEM ALL
JRST $RGCSW ;SWEEP THEM ALL
;ALL DONE NOW
RGCLER: CAI D,
ERR <GLUBBED UP RECORD LINK FOUND BY RECORD GC>,7
SETZM (D) ;JUST CUT YOUR LOSSES
JRST RGC.2
;; SAIREC (RECGC) -- $M1FLD
HERE($M1FLD)
;CALLED WITH REFITEM TYPE DESCRIPTOR IN A
;WILL TAKE ALL APPROPTIATE ACTION
;PRESERVES A BUT ALL OTHERS MAY BE MUNGED
JUMPE A,CPOPJ ;NOTHING TO DO IF NULL
TLNN A,ITEMB ;NOTHING TO DO IF ITEMISH
TLNE A,PROCB ;OR PROCEDURE
POPJ P,
LDB TEMP,[POINT 6,A,=12] ; SIX BIT TYPE
CAIN TEMP,RECTYP ;A RECORD??
JRST M1REC ;YES, ENQUEUE IT
CAIN TEMP,RFITYP ;A REFERENCE ITSELF
JRST M1REF ;YES
CAIE TEMP,RECTYP+ARRTYP; A RECORD ARRAY??
POPJ P, ;NOPE
PUSH P,A ;SINCE AGREED TO LEAVE ALONE
PUSH P,B
SKIPN B,(A) ;PICK UP ARRAY DESCRIPTOR
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,
>;RGC
BEND RECORD
ENDCOM(REC)