COMMENT ⊗   VALID 00005 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	 FANCY SMALL SPACE SERVICE 
C00010 00003	 SPECIAL FIXED SIZE BLOCK HANDLERS: $FXGET, $FXDEL
C00020 00004	 SAIREC -- SYSTEM RECORD HANDLER ROUTINES
C00033 00005	 SAIREC -- FLDKIL ROUTINE
C00039 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

HEREFK($GETB,$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

HEREFK($DELB,$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
HEREFK($GET1B,$GET1.)
	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
HEREFK($DEL1B,$DEL1.)		
	JUMPE	A,CPOPJ		;
	PUSHJ	P,@%DPROC(A)	;ALLOCATE ROUTINE
	JRST	DEL1B1		;LOST, TRY NEXT
	JRST	CPOPJ1		;WIN

HEREFK($FSADD,$FSAD.)		;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

HEREFK($FUNLK,$FUNL.)
	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

HEREFK($FSINS,$FSIN.)		;
	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

HEREFK($FSINI,$FSI..)
	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

HEREFK($FXGET,$FXGE.)

	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

HEREFK($FXG,$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

HEREFK($FXDEL,$FXDE.)		
	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

HEREFK($FXD,$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

HEREFK($FXSPC,$FXSP.)
	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)


HEREFK($FXBLD,$FXBL.)		
	
	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>
	,<RECQQ,ALLFOR,ARYEL,CORGET,CORREL,X11,GOGTAB,$DEL1B,$GET1B>
	,<SAIL RECORD HANDLER>,<$RDREF,$RALLO>);
REGL2:
BEGIN RECORD

;;$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
$RMAX ←← (.-$RDISP)-1

HEREFK($REC$,$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:
	SKIPE	A		; HAVE ONE?
	SOSLE	-1(A)		; YEP, DECREMENT COUNT
	POPJ	P,		; RETURN
	PUSH	P,A			; SO CAN LATER CALL CORREL
	HRRZ	C,(A)			; CLASS ADDRESS
	ADDI	A,1			; FIRST DATA ELEMENT
	SUBI	C,(A)			; CORRECTION FACTOR
	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

	AOS	-1(A)		;BUMP REF CNT
	POP	P,(A)		;THE RECID POINTER
	POPJ	P,		;RETURN

ZPOPJ:	MOVEI	A,0
	POPJ	P,


HEREFK($RERR,$RERR.)
	ERR	<ACCESS TO A SUBFIELD OF A NULL RECORD>,1
	POPJ	P,
;; SAIREC -- FLDKIL ROUTINE

HEREFK(FLDKIL,.FLDKI)
		;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
	WRDRF			;13 RECORD DEREFERENCING



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

BEND RECORD

ENDCOM(REC)