Trailing-Edge
-
PDP-10 Archives
-
-
There are no other files named in the archive.
COMMENT VALID 00020 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002 FANCY SMALL SPACE SERVICE
C00011 00003 SPECIAL FIXED SIZE BLOCK HANDLERS: $FXGET, $FXDEL
C00020 00004 SAIREC -- SYSTEM RECORD HANDLER ROUTINES
C00024 00005 GETSTR, STRINIT, RELSTR, RSGC
C00026 00006 RECORD STRING FIELD GARBAGE COLLECTION
C00029 00007 SAIREC -- $REC$ AND $RECFN
C00037 00008 SAIREC -- $RCINI
C00043 00009 SAIREC -- FLDKIL ROUTINE
C00048 00010 SAIREC (RECGC) -- $ENQR,ENQRB,ENQRBB,PAMRK
C00052 00011 SAIREC (RECGC) -- %PSMRR
C00054 00012 SAIREC (RECGC) -- RCIMRK
C00056 00013 SAIREC (RECGC) -- $MRK.1, $MFLDS
C00059 00014 SAIREC (RECGC) -- $RGCMK
C00060 00015 SAIREC (RECGC) -- $RGCSW
C00063 00016 SAIREC (RECGC) -- MAIN ROUTINE
C00065 00017 SAIREC (RECGC) -- $M1FLD
C00067 00018 SAIREC -- $RBDEL
C00071 00019 SAIREC -- $RBGET
C00074 00020 BEND RECORD
C00076 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 <$FSINI: NO CORE>,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
$FSADD($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 <$FXSPC: NO CORE>,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 <$FXBLD: ALLOCATING ZERO 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 <$FXBLD: NO CORE>,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,$RECFN,$RCINI,$RMARK>
,<RECQQ,ALLFOR,ARYEL,CORGET,CORREL,X11,X22,X33,CLSLNK,STRCHN,GOGTAB,SGINS,$SPCAR>
,<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
; FORMAT OF ALL RECORDS
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
; FORMAT OF RECORD CLASS TEMPLATES, IE CLASS="CLASS"
;WORDS -1 AND 0 ARE STANDARD, IE. RING AND MARK
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
; - 0TH WORD IN ARRAY IS TYPE BITS FOR THE CLASS
TXTARR__5 ;STRING ARRAY OF FIELD NAMES
; - 0TH ELEMENT IS NAME OF RECORD CLASS
;;** VARIOUS "TYPE BITS" ARE NOW DEFINED UP IN HEAD
;;%DA%
;;DESCRIPTOR FORMAT
DEFINE DX(ID) <
ID __ DSCSIZ
DSCSIZ __ DSCSIZ+1
>
DSCSIZ __ 0
DX(BLKSIZ) ;SIZE OF BLOCKS
DX(TRIGGER) ; COUNT DOWN FOR RECGC
DX(TGRMIN) ; MINIMUM NUMBER PERMITTED FOR TRIGGER SETTING
INIBFS __ 2 ;ALLOW TWO BUFFERS WORTH AS DEFAULT TRIGGER FLOOR
DX(TINUSE) ;TOTAL NUMBER IN USE
DX(TUNUSED) ;TOTAL UNUSED BUFFERS
DX(FBLIST) ; FREE BUFFER LIST
DX(FULLS) ; FULL BUFFER LIST
DX(CULPRT) ; COUNTED UP EACH TIME GC IS TRIGGERED BY THIS SPACE
;; BUFFER FORMAT
LINKS__ 0 ;
BINUSE __ 1 ;WORDS IN USE IN THIS BUFFER?
FFREE __ 2 ;FREE LIST FOR BUFFER
FBDWD __ 3 ;FIRST BUFFER DATA WORD
RBSIZE __ = 256 ;SIZE OF RECORD BUFFER
MAXSB __ =16 ;
MINSB __ = 3 ;
;**** SEE ALSO INITIALIZATION CODE FOR ASSIGNMENTS OF BLOCK SIZES
NSBSZS __ =8
;;%DA% ^^
;; GETSTR, STRINIT, RELSTR, RSGC
; ROUTINE TO SET UP A BLOCK OF FREE STRING DESCRS.
FSTRSIZ__20
STRINIT:
MOVEI C,2*FSTRSIZ+1 ;ENOUGH ROOM FOR 20 STRINGS
PUSHJ P,CORGET
ERR <NO CORE FOR RECORD STRINGS>,1,ZPOPJ
;;*** CHECK THAT CORGET SETS UP USER ***
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,
; ROUTINE TO GET A FREE STRING DESCRIPTOR (CLOBBERS A & B AND SOMETIMES THE REST)
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,
; RETURN A STRING TO FREE STRING LIST;
RELSTR: SKIPN A,(A) ; POINTER TO STRING ARRAY ENTRY
JRST CPOPJ ; NOTHING TO DO
RELST.: MOVE B,STRCHN ; CHAIN OF FREE STRINGS
HRRZM B,(A) ; CHAIN TOGETHER
SETZM -1(A) ; ZERO CHARACTER COUNT
MOVEM A,STRCHN
POPJ P,
; RETURN A DOUBLE
RELDBL: SKIPN A,(A)
JRST CPOPJ
AOJA A,RELST. ;POINT TO WD 2 AND MAKE LIKE A STRING
; RECORD STRING FIELD GARBAGE COLLECTION
BEGIN RSGC
F__E+1
; STRING AND STRING ARRAY FIELDS ARE MARKED BY SWEEPING
; THROUGH ALL RECORD CLASSES LOOKING FOR ONES THAT ARE RELEVENT,
; AND MARKING STRING AND STRING ARRAY FIELDS OF ALL RECORDS
; UNDER THE APPROPRIATE CLASSES
^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 FIELDS?
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 FIELD -- 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
;;#VC# (1 OF 2) USED TO BE A MOVE
SKIPN D,(E) ;GET FIELD -- POINTER TO STRING ARRAY
JRST PPDNXT ;
;;#VC# ^
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
;;#VC# ! ADDED A LABEL HERE
PPDNXT: POP P,D
JRST NXFLD
BEND RSGC
;; SAIREC -- $REC$ AND $RECFN
;;$REC$ CALLED VIA PUSH P,[OP]
; PUSH P,ARG1
; PUSHJ P,$REC$
; IS ASSUMED TO WIPE OUT THE ACS
;;$RECFN IS CALLED JUST LIKE $REC$
$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
;;%DA% !
PUSH P,RECSIZ(C) ; RECORD SIZE -- REMEMBER FOR KILL
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
;;%DA%
POP P,C ; PICK UP THE SIZE FIELD
ADDI C,2 ; CORRECT FOR OVERHEAD
POP P,B ; THE CORREL POINTER
SUBI B,1 ; NOW IT IS -- THE EXTRA CHAIN WORD
CAIL C,MINSB ; IS IT A SPECIAL GUY?
CAILE C,MAXSB
JRST CORREL ; NO, JUST DO A CORREL
ADD C,$SPCAR ;
SKIPE A,-MINSB(C) ;PICK UP THE DESCRIPTOR
PUSHJ P,$RBDEL ;GO KILL BLOCK
ERR <STRANGENESS IN RELEASING RECORD>,1,CORREL
POPJ P,
; 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,
;;%DA% ^^
^^$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
; AND +1 FOR DESCRIPTOR WORD
PUSH P,A ; EVENTUALLY, BECOMES THE RECID POINTER
;;%DA% RHT
MOVEI B,CORGET
CAIL C,MINSB ;DO WE WANT CORGET OR OUR SPECIAL GUY?
CAILE C,MAXSB ;
JRST GETCAL ;NO, USE CORGET
SKIPN A,$SPCAR ;PICK UP ARRAY DESCRIPTOR
ERR <UNINITIALIZED SPACE SYSTEM?>,1,GETCAL
ADDI A,-MINSB(C) ;POINT AT RIGHT DESCRIPTOR
SKIPN A,(A) ;PICK IT OUT
ERR <UNINITIALIZED SPACE SYSTEM?>,1,GETCAL
MOVEI B,$RBGET ;USE SPECIAL ROUTINE
GETCAL: PUSHJ P,(B) ;GET A BLOCK
ERR <COULDN'T GET BLOCK FOR A RECORD>,1,ZPOPJ
MOVEI A,1(B) ;THE POINTER WE WILL ACTUALLY RETURN
;;%DA% ^^
;;#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
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!HASDBL
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,STTYPE5 ;STRING
CAIN B,LFLTYP5 ;OR LONG
JRST .+2 ;YES
JRST NXTFLD ;NO
PUSH P,B ;SAVE TYPE
PUSH P,C ;AND FIELD PTR
PUSHJ P,GETSTR ;GET A FREE STRING DESCR
POP P,C
POP P,B
CAIN B,LFLTYP5 ;IF LONG
MOVEI A,-1(A) ;THEN GET ADDRESS OF FIRST WORD
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 FIELD OF A NULL RECORD>,1
POPJ P,
;; SAIREC -- $RCINI
;; SETS UP $CLASS, THEN RUNS DOWN THE CLASS LINKS
;; HOMED ON CLSLNK & SETS UP THE QUAM-STYLE RING LINKAGES.
;; ALSO ZEROS ALL OWN (AND OUTER BLOCK) RECORD POINTERS.
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
;*** CAME A,$CLASS+RECSIZ ;OF THE COUNT
;*** ERR <WARNING. $CLASS WAS MUNGED>,1
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
;;%DA% -- INITIALIZE SMALL BLOCK SYSTEM
MOVE A,[0.33] ;STANDARD FACTOR 1/0.75 -1
MOVEM A,RGCRHO(USER)
MOVEI C,6+MAXSB-MINSB ;SIZE OF DESCRIPTOR ARRAY
PUSHJ P,CORGET ;GET SOME ROOM
ERR <COULDN'T GET SPACE FOR $SPCAR>
MOVEI A,5-MINSB(B) ;BUILD ARRAY HEADER
SUBI B,1 ;SO ALL THE PUSHES WORK RIGHT
PUSH B,A ;
PUSH B,[MINSB]
PUSH B,[MAXSB]
PUSH B,[1]
PUSH B,[1,,MAXSB+1-MINSB]
HRRZM B,$SPCAR ;WILL AOS IT IN A BIT
MOVEI C,NSBSZS*DSCSIZ ;GET SPACE FOR DESCRIPTORS
PUSHJ P,CORGET
ERR <CANNOT GET ROOM FOR SPACE DESCRIPTORS>
SETZM (B)
HRLI C,(B)
HRRI C,1(B)
BLT C,NSBSZS*DSCSIZ-1(B) ;ZERO IT ALL OUT
NN __ 0 ;FILL IN BLKSIZ
;; *** SEE ALSO DEFINITIONS OF MAXSB & MINSB & NSIZES
FOR II IN (3,4,5,6,=8,=10,=12,=16)
< MOVEI A,II
MOVEM A,NN+BLKSIZ(B)
MOVEI A,((RBSIZE-FBDWD)/II)*INIBFS
MOVEM A,NN+TRIGGER(B)
MOVEM A,NN+TGRMIN(B)
NN __ NN+DSCSIZ
>
AOS C,$SPCAR ;NOW FILL IN SPCAR ENTRIES
SUBI C,1 ;GET BACK INTO PUSH PHASE
FOR II IN (0,1,2,3,4,4,5,5,6,6,7,7,7,7)
<MOVEI A,II*DSCSIZ(B)
PUSH C,A
>
;;%DA% ^^
; ZERO ALL THE OWN AND OUTER BLOCK RECORD POINTERS
ZERO0: 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
;;#XK# ! JFR 7-28-76 -1 IN LEFT HALF
-1,,$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
;; 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
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
WZAPR ;'16
WZAPR ;'17
WZAPR ;'20
WDBLKL ;'21 DOUBLE PRECISION
WSTRKL: PUSH P,A
PUSHJ P,RELSTR
POP P,A
JRST WZAPR
WDBLKL: PUSH P,A
PUSH P,RELDBL
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
;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
HERE($ENQR)
JUMPE A,CPOPJ ;NULL NEVER
HACK < ;BUG TRAP
HRRZ TEMP,(A) ;GET THE CLASS OF WHAT WE ARE MARKING
HRRZ TEMP,(TEMP) ;ALL CLASSES BETTER BE $CLASS INSTANCES
CAIE TEMP,$CLASS ;
ERR <ATTEMPT TO MARK INVALID RECORD POINTER>,1
>;HACK
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 OUT
;;#XV#
NXTARG: LDB TEMP,[POINT =12,(B),=12] ;INTERESTED IN VALUE RECORDS
CAIN TEMP,STTYPE ;CHECK IF VALUE STRING
AOJA B,NXTARG ;YES, SKIP TO NEXT ARG (NOT ON P)
;;#XV# ^
CAIE TEMP,RECTYP ;CHECK IF VALUE RECORD!POINTER
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:
;;#VF# (1-1) THIS CODE WAS JUST WRONG
; 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
JUMPE A,RIMITR ;ARRAY WASN'T REALLY THERE
PUSH P,C ;MUST NOT MUNCH ITEM NUMBER
MOVN C,-1(A) ;MAKE AOBJN PTR
HRL C,A
MOVS C,C
PUSHJ P,ENQRB ;GO HANDLE THE LOT
POP P,C ;GET ITEM BACK
JRST RIMITR ;ITERATE
;;#VF# ^^
;; SAIREC (RECGC) -- $MRK.1, $MFLDS
$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
;;%##% RHT + PDQ DO NOT PROCEED FURTHER IF NO RECORD FIELDS
HRL C,(C) ;GET TYPE BITS
TLNN C,HASRPS ;HAVE RECORD OR RECORD ARRAY FIELDS
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,
;; SAIREC (RECGC) -- $RGCMK
$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
;; SAIREC (RECGC) -- $RGCSW
$RGCSW: ;;**** THESE LINES CHANGED FROM PDQ METHOD ****
;;HRRZ D,CLSREC ;HEAD OF ALL CLASSES
;;MOVEI TEMP,RECRNG-RING(D) ;HEAD OF RING OF ALL CLASSES
;;MOVEM TEMP,CLSRHD#
;;HRRZ D,RECRNG(D) ;RING OF ALL CLASSES
;;****
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;
;RESET MARKS FOR ALL RECORDS OF THIS CLASS -- NEVER DELETE
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
;;**** CAME D,CLSRHD ;HEAD OF 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
;; SAIREC (RECGC) -- MAIN ROUTINE
HERE($RECGC)
SETOM RECCHN ;INITIALIZE MARK AS NULL
PUSHJ P,$RGCMK ;MARK THEM ALL
PUSHJ P,$RGCSW ;SWEEP THEM ALL
;ALL DONE NOW
SKIPE A,TGRADJ(USER) ;DOES USER WANT TO ADJUST TRIGGERS HIMSELF?
JRST (A) ;YES, LET HIM WORRY -- HE WILL POPJ SOMEDAY.
ADJTGR: MOVE TEMP,$SPCAR ;ROUTINE TO ADJUST TRIGGER LEVELS
HRLI TEMP,MINSB-MAXSB-1 ;-BUCKETS,,FIRST
PUSH P,TEMP ;DO IT THIS WAY TO AVOID WORK
SKIPE A,(TEMP) ;LOOK AT A BUCKET
SETOM TRIGGER(A) ;USE NEG TRIGGER AS A FLAG
AOBJN TEMP,.-2 ;ITERATE
POP P,TEMP ;GET BACK THE AOBJN PTR
ADJ1TG:
SKIPE A,(TEMP) ;ANYTHING IN THIS BUCKET?
SKIPL TRIGGER(A) ;ALREADY DONE?
JRST ADJNXT ;DONT DO IT AGAIN
MOVE B,TINUSE(A) ;
FSC B,233 ;MAKE REAL
FMPR B,RGCRHO(USER) ;B _ NUMBER IN USE * RHO
UFA B,[233000000000];MAKE AN INTEGER
TLZ C,777000 ;IT HAS TO BE POSITIVE
CAMGE C,TUNUSED(A) ;IF UNUSED MORE THAN THIS
MOVE C,TUNUSED(A) ;THEN USE THEM
CAMGE C,TGRMIN(A) ;GET THE FLOOR QUANTITY FOR THIS SPACE
MOVE C,TGRMIN(A) ;
SETTGR: MOVEM C,TRIGGER(A) ;TRIGGER_MAX(INUSE*RHO,UNUSED,TGRMIN)
ADJNXT: AOBJN TEMP,ADJ1TG ;ITERATE
POPJ P, ;ALL DONE
;; 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,
;;#WF#
TLNE A,REFB ;IF JUST REFERENCE
POPJ P, ;THEN RELY ON MARKING SOME OTHER WAY
;;#WF# ^
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
;;#VL# ! used to be a popj
JRST M1AXIT ;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,
;; SAIREC -- $RBDEL
$RBDEL: PUSH P,C ;NO SIZE CHECK IF ENTER HERE
MOVEI C,FBLIST-LINKS(A);
PUSHJ P,$RBD.1 ;TRY TO FIND IN FBLIST
JRST POPCJ1 ;GO SAY WE WON
MOVEI C,FULLS-LINKS(A);
PUSHJ P,$RBD.1 ;TRY IN FULLS
POPCJ1: AOS -1(P) ;SKIP RETURN
POPCJ: POP P,C
POPJ P,
$RBD.1: HRRZ C,LINKS(C) ;HAVE A RIGHT LINKS
JUMPE C,CPOPJ1 ;OUT OF BUFFERS, JUST FAIL
CAIL B,(C) ;IN THIS BUFFER?
CAIL B,RBSIZE(C) ;
JRST $RBD.1 ;NO
AOS TRIGGER(A) ;WE KNOW WHERE, SO DELETE BLOCK
SOS TINUSE(A)
AOS TUNUSED(A) ;NUMBER OF UNUSED BLOCKS IN SPACE
EXCH B,FFREE(C) ;CONS ONTO FREE LIST
MOVEM B,@FFREE(C) ;LIKE THIS
JUMPN B,$RBD.2 ;GO FROM FULL LIST TO FREE LIST?
PUSHJ P,UNLKC ;GO UNLINK C
MOVEI B,FBLIST-LINKS(A);AND LINK ONTO FBLIST
PUSHJ P,LNKCB ;
$RBD.2: SOSLE BINUSE(C) ;ANY BLOCKS STILL IN USE HERE?
POPJ P, ;YES
PUSHJ P,UNLKC ;REMOVE FROM ITS CHAIN
MOVE B,C ;
PUSHJ P,CORREL ;GO REMOVE FROM CORGET SPACE
MOVNI B,RBSIZE-FBDWD+1;COMPUTE HOW MANY BUFFERS WE LOSE
IDIV B,BLKSIZ(A) ; (- DATAWDS)/SIZE
ADDM B,TUNUSED(A) ; CORRECT NOTION OF HOW MANY WE HAVE
POPJ P,
CPOPJ1: AOS (P)
POPJ P,
UNLKC: MOVS TEMP,LINKS(C) ;RIGHT,,LEFT
HLRM TEMP,LINKS(TEMP);RIGHT[LEFT]_RIGHT
TLNN TEMP,-1 ;HAVE A RIGHT LINK?
POPJ P, ;NO
MOVSS TEMP ;LEFT,,RIGHT
HLLM TEMP,LINKS(TEMP);LEFT[RIGHT]_LEFT
POPJ P,
LNKCB: SKIPE TEMP,LINKS(B) ;EMPTY?
HRLM C,LINKS(TEMP) ;NO, LEFT[OLD]_NEW
HRLI TEMP,LINKS(B) ;[HEAD],,OLD
MOVEM TEMP,LINKS(C) ; INTO NEW WORD
HRRZM C,LINKS(B) ;RIGHT[HEAD]_NEW
POPJ P,
;; SAIREC -- $RBGET
$RBGET:
;;#VK# ! PUSH USED TO COME AFTER GC CALL (RHT)
PUSH P,C ;PRESERVE AC
SOSGE TRIGGER(A) ;COUNT DOWN
PUSHJ P,GCTRY ;TIME TO THINK ABOUT GC
AOS TINUSE(A) ;
RBG.1: SKIPN C,FBLIST(A) ;GET A BUFFER WITH FREES
JRST RBG.2 ;NONE TO BE HAD
RBG.1A: AOS BINUSE(C)
SOS TUNUSED(A) ;UPDATE ACTUAL FREE COUNT
MOVE B,@FFREE(C) ;GET A FREE
EXCH B,FFREE(C) ;AND UPDATE LIST
SKIPE FFREE(C) ;ANY LEFT ON FREE LIST
JRST POPCJ1 ;YES, GO EXIT
PUSH P,B ;PRESERVE THE ONE WE GOT
PUSHJ P,UNLKC ;UNLINK FROM FBLIST
MOVEI B,FULLS-LINKS(A) ;
PUSHJ P,LNKCB ;AND PUT ON FULLS
POP P,B ;RETURN VALUE BACK
JRST POPCJ1 ;GO RETURN
RBG.2: MOVEI C,RBSIZE ;GO GET A BUFFER
PUSHJ P,CORGET ;
ERR <NO SPACE FOR RECORD BUFFER>,1,POPCJ
MOVE C,B ;
MOVEI B,FBLIST-LINKS(A) ;PUT ON FREE LIST
PUSHJ P,LNKCB
SETZB TEMP,BINUSE(C) ;NONE IN USE YET
MOVEI B,FBDWD(C) ;BUILD SMALL BLOCKS
MOVEM B,FFREE(C) ;WILL BE FIRST FREE
MOVE LPSA,BLKSIZ(A) ;
RBG.3: MOVEM LPSA,(B) ;
ADDB B,(B) ;LINKS FORWARD & MOVES B DOWN
CAIG B,RBSIZE(C) ;OUT OF ROOM?
AOJA TEMP,RBG.3 ;NO, DO ANOTHER
SUB B,LPSA ;WELL, BACK UP & ZERO THAT LAST ONE
SUB B,LPSA ;MUST BACK UP TWICE TO GET LAST GOOD
SETZM (B) ;BLOCK
ADDM TEMP,TUNUSED(A) ;UPDATE FREE COUNT
JRST RBG.1A ;DONE LINKING, GO TRY AGAIN
;; NOTE: THIS ROUTINE MAY WIPE OUT ALL ACS EXCEPT A
GCTRY: MOVE USER,GOGTAB ;
SKIPE RGCOFF(USER) ;TEST TO SEE IF AUTO GC IS DISABLED
POPJ P, ;DO NOTHING
AOS CULPRT(A) ;I'VE GOT A LITTLE LIST ...
PUSH P,A
PUSHJ P,$RECGC ;GO GARBAGE COLLECT & ADJUST TRIGGERS
POP P,A ;RETURN
SOSGE TRIGGER(A) ;SINCE USE UP ONE FOR THIS
ERR <WARNING: TRIGGER SET TO ZERO AFTER $RECGC>,1
POPJ P,
BEND RECORD
ENDCOM(REC)