Google
 

Trailing-Edge - PDP-10 Archives - -
There are no other files named in the archive.
COMMENT    VALID 00008 PAGES VERSION 17-1(22)
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	HISTORY
C00005 00003	Array Stuff 
C00013 00004	  bexit & stkuwd  
C00023 00005	 array info & the like 
C00028 00006	 the procedure item routines
C00033 00007	
C00043 00008	
C00048 ENDMK
C;
COMMENT HISTORY
AUTHOR,REASON
021  102100000026  ;


COMMENT 
VERSION 17-1(22) 4-5-75 BY JFR ALLOW FOR DEFAULT ARGS IN APPLY P.7
VERSION 17-1(21) 11-30-74 BY RHT BUG #TS# ARRCLR WAS LOSING FOR 1 WORD ARRAYS
VERSION 17-1(20) 9-27-74 BY JFR INSTALL BAIL (MODIFY APPLY)
VERSION 17-1(19) 6-6-74 BY RHT BUG #SO# CLOBBERING B IN PARLP
VERSION 17-1(18) 5-27-74 BY RHT ADD FACILITY FOR RECORD ARRAYS IN BEXIT
VERSION 17-1(17) 5-19-74 
VERSION 17-1(16) 4-14-74 BY RHT %BI% ADD RECORDS TO BEXIT
VERSION 17-1(15) 4-14-74 
VERSION 17-1(14) 3-6-74 BY RHT ADD LEAP TO EXTERNS FOR SAIPIT
VERSION 17-1(13) 2-24-74 BY RHT FEAT %BH% -- TEMP REF ITEMS
VERSION 17-1(12) 2-3-74 BY RHT BUG #QZ# APPLY TESTING WRONG FIELD FOR STRING VAL PARAM
VERSION 17-1(11) 1-29-74 BY RHT BUG #QW# APPLY TOO TOUGH ON UNTYP ITEMVAR ACTUALS
VERSION 17-1(10) 1-28-74 BY RHT BUG #QU# TYPO IN APPLY
VERSION 17-1(9) 12-8-73 BY JRL REMOVE SPECIAL STANFORD CHARACTERS(WHERE POSSIBLE)
VERSION 17-1(8) 12-4-73 BY RHT MAKE ARRCL HAVE A DEFAULT VALUE TO STORE
VERSION 17-1(7) 12-2-73 BY RLS EDIT
VERSION 17-1(6) 12-2-73 BY RLS EDIT
VERSION 17-1(5) 12-1-73 BY RLS BUG #PL#  DONT BLT IF LENGTH LEQ 0; PLUS ADD ARRCLR FUNCTION
VERSION 17-1(4) 11-20-73 BY RFS   
VERSION 17-1(3) 11-20-73 BY rfs MAKE LOWER BOUND > UPPER BOUND CONTINUABLE
VERSION 17-1(2) 10-14-73 BY RHT BUG #OP#
VERSION 17-1(1) 10-14-73 BY RHT BUG #OL#-- TYPO IN APPLY
VERSION 17-1(0) 7-26-73 BY RHT **** VERSION 17 **** **** VERSION 17-1(0)
VERSION 16(4) 7-24-73 BY RHT BUG #NG# SIMPLE PROC GO TO NS PROC SHOULD SORT OF WORK
VERSION 16(3) 7-24-73 BY RHT BUG #NF# -- FOUND TBITS USE LURKING IN STKUWD
VERSION 16(2) 7-14-73 BY RHT ADD APPLY$
VERSION 16(1) 7-13-73 BY RHT MAKE APPLY RETURN A VALUE LIKE IT IS SUPPOSED TO

;
COMMENT Array Stuff 

;ARYDIR, ARRPDL, AND FRIENDS ARE NO MORE

DSCR LRCOP, ARCOP


COMPIL(ARY,<LRCOP,ARCOP,LRMAK,ARMAK,ARYEL,BEXIT,STKUWD
ENTINT <ARRINFO,ARRBLT,ARRTRAN,ARRCLR>>
  ,<SAVE,RESTR,CORGET,CORREL,X11,X22,X33,X44,GOGTAB,ARRRCL,RECQQ,LEAP,ALLFOR>
  ,<ARRAY ALLOCATION ROUTINES>)

HERE(LRCOP)
HERE(ARCOP)
;;#HO# 6-7-72 DCS ALLOW BOTH ADDRS TO BE RETURNED
	PUSH	P,B
	PUSH	P,C		;SOME WORK SPACE.
	PUSH	P,-3(P)		;ARRAY TO BE COPIED
	PUSHJ	P,..ARCOP	;COPY IT
	POP	P,C
	POP	P,B
	SUB	P,X22
	JRST	@2(P)		;DONE

^^..ARCOP:
;;#HO#
	HRRZ	A,-1(P)		;THE ARRAY TO BE COPIED.
	SKIPGE	-2(A)
	SUBI	A,1		;FOR STRING ARRAYS.
	HLRE	B,-1(A)		;NUMBER OF DIMENSIONS.
	MOVMS	B		;ABSOLUTE VALUE.
	IMUL	B,[-3]
	ADDI	A,-2(B)		;A NOW POINTS TO "CORGET" GUY.
	MOVN	C,-1(A)		;SIZE
	SUBI	C,3		;TO ACCOUNT FOR BOOKEEPING.
	PUSHJ	P,CORGET
	ERR	<NO ROOM FOR ARRAY>
	PUSH	P,B
	HRLI	B,(A)		;MAKE UP A BLT WORD.
	ADDI	C,(B)
	BLT	B,-1(C)		;COPY THE WHOLE ARRAY.
	POP	P,B		;BECAUSE BLT DESTROYS ITS.
	HRRZS	A		;SINCE THE ADDI ABOVE LEFT STUFF IN LEFT HALF.
	MOVNS	A
	ADDI	A,(B)		;A HAS NEW-OLD DIFFERENCE.
	ADDM	A,(B)		;THESE HAVE TO BE RELOCATED.
	ADD	A,-1(P)		;NEW ARRAY DESCRIPTOR.
	HRRM	A,-2(B)		;FOR STRING GARBAGE COLLECTOR.
	MOVE	C,-1(P)		;ARRAY THAT WAS COPIED.
	SKIPGE	-2(C)		;WAS IT A STRING ARRAY?
	SOS	-2(B)		;BACK IT UP ONCE.
	SUB	P,X22
	JRST	@2(P)		;ALL DONE.

DSCR LRMAK

HERE(LRMAK)
DSCR ARMAK


HERE (ARMAK)
BEGIN	ARMAK
	PUSHJ	P,SAVE
	HRRZ	A,-1(P)		;#DIMENSIONS
	MOVEI	B,-2(P)		; PTR TO BOUNDS(n)
	MOVEI	C,1

MAKLUP:	SOJL	A,SIZDUN	;DONE GETTING TOTAL SIZE
	MOVE	D,(B)		;UPPER BOUND
	ADDI	D,1		;PLUS ONE.
	SUB	D,-1(B)		;  -LOWER BOUND IS TOTAL SIZE
	SKIPG	D		;MUST BE POSITIVE
	 ERR	 <ARRAY lower bound gtr  upper bound>,1,SIZ0
	IMUL	C,D		;COLLECT SIZE
SIZ0:	SUBI	B,2		;LOOK AT NEXT
	JRST	MAKLUP

SIZDUN:	; MOVEI C,SIZE DESIRED -- ALREADY THERE
	SKIPL	TEMP,-1(P)	;BITS,,#DIMS
	TLNE	TEMP,40		;LONG (40,,) OR STRING (-1,,)?
	 LSH	C,1		;MULTIPLY BY TWO
	PUSH	P,C		;SAVE SIZE OF ARRAY ITSELF
	HRRZ	A,-2(P)		;#DIMENSIONS AGAIN
	IMULI	A,3		;SIZE OF ARRAY DESCRIPTOR TABLE
	ADDI	C,2(A)		;ADD TO SIZE OF AREA NEEDED
AGIN:	PUSH	P,C		;SAVE IT
;; \UR#27\ JRL (8-3-78) check to see if size > 256k
        TLNN	C,777777	; if any bit in lh on => too big!
;; \UR#27\
	PUSHJ	P,CORGET		;ARRAY
	 ERR	 <ARRAY no room>

GOTARR:	POP	P,C		;TOTAL SIZE AGAIN
	MOVE	D,B		;SAVE ADDRESS
	HRRZ	TEMP,B
	ADD	TEMP,C
	POP	P,C		;ARRAY SIZE
	PUSH	P,B		;SAVE PTR TO ARRAY BLOCK
	SETZM	(B)
	HRLS	B
	ADDI	B,1
	BLT	B,-1(TEMP)	;CLEAR ARRAY
	HRRZI	B,(D)		;GET ADDRESS BACK
	HRRZ	TEMP,-2(P)	;#DIMENSIONS AGAIN
	SKIPGE	-2(P)		;STRING ARRAY?
	 MOVNS	TEMP		; YES
	HRL	C,TEMP		;#DIMS, TOTAL SIZE (#DIMS NEG IF STRING)
	PUSH	P,C		;SAVE INFORMATION WORD


COMMENT 
LET D PNT TO NEXT WORD INTO TABLE,  A=COUNT OF DIMENSIONS LEFT,
    C=ACCUMULATING TOTAL SIZES (AGAIN)
    B PNTS AT CURRENT DESCRIPTIONS (IN STACK),  TEMP USED FOR MOVING THINGS


	ADDI	B,1		;LEAVE ROOM FOR ADDRESS WORD
	HRRZ	A,-3(P)		;#DIMS
	MOVE	LPSA,A		;PREPARE FOR SUBRT RETURN
	LSH	LPSA,1
	ADDI	LPSA,2
	HRLS	LPSA
	MOVEI	D,-4(P)		; PTR TO INFO
	;MOVE	D,[FIRST WORD]	;ALREADY THERE
	MOVEI	C,1		;MULTIPLY FACTOR
	MOVEI	X,0		;ACCUMULATE TOTAL DISPLACEMENT

STOLUP:	SOJL	A,STODUN
	MOVEW	(<1(B)>,<(D)>) ;UPPER BOUND
	ADDI	TEMP,1
	SUB	TEMP,-1(D)		;TOTAL SIZE
	MOVEM	C,2(B)		;AND MULTIPLY FACTOR
	IMUL	C,TEMP		;TEMP HAS SIZE THIS DIMENSION
	MOVEW	(<(B)>,<-1(D)>)	;STORE LOWER BOUND
	IMUL	TEMP,2(B)	;COLLECT TOTAL DISPLACEMENT
	ADD	X,TEMP		;IN X
	ADDI	B,3
	SUBI	D,2
	JRST	STOLUP		;UPDATE POINTERS AND LOOP


STODUN:
	POP	P,(B)		;INFO WORD
	ADDI	B,1		;WILL POINT AT FIRST DATA WORD
	POP	P,TEMP	;PTR TO BLOCK HEAD
	HRRZM	B,-2(TEMP)	;STORE WHERE STRNGC CAN FIND IT
	SKIPGE	-1(B)		;IS IT A STRING ARRAY?
	HRROI	B,1(B)		;YES, POINT AT 2D WORD OF FIRST ELEMENT
	MOVEM	B,RACS+1(USER)	;RESULT
	MOVE	C,-1(P)		;FLAGS,,#DIMS
	TLNN	C,40		;LONG ARRAY?
	JUMPGE	B,NSTG		;STRING ARRAY?
	 LSH	 X,1		; YES, DOUBLE DISPLACEMENT
NSTG:	SUB	B,X		;ARRAY ADDR - TOTAL DISPLACEMENT
	HLL	B,RACS+1(USER)	;-1 IF STRING, 0 OTHERWISE
	MOVEM	B,(TEMP)	;SAVE IN (0,0,0) WORD
	JUMPL	C,RESTR		;DONE IF STRING
	TLNE	C,40		;LONG?
	 HLLM	C,3(TEMP)	;YES, FLAG MULT(N)
	JRST	RESTR


BEND ARMAK


DSCR ARYEL


HERE(ARYEL)
BEGIN ARYEL
	HRRZ	B,-1(P)
	POP	P,-1(P)		;PUT POPJ ADDRESS BACK FOR CORREL.
	SKIPGE	-2(B)
	SUBI	B,1		;COMPUTE THE HEADER ADDRESS.
	HLRE	A,-1(B)
	MOVMS	A
	IMUL	A,[-3]
	ADDI	B,-2(A)
	HRRZS	B
	JRST	CORREL		;RELEASE IT.

BEND
COMMENT	  bexit & stkuwd  
DSCR BEXIT
PARM -- XWD #LEVELS-1,LVI ADDRESS IN LPSA
DES -- RELEASES STROAGE FOR BLOCKS -- REPLACES THE OLD ARRREL
SID -- MANGLES ALL REGISTERS


HERE(BEXIT)
BEGIN BEXIT
BKCNT_5
BKPTR_6
TPTR_7
EN_10	;ALSO USED BY STKUWD
PDA_11	;THIS IS USED BY STKUWD, BUT SOME OF THE LVIDAC ROUTINES MUST SAVE IT
	;SINCE THEY ARE SOMETIMES USED BY STKUWD -- THIS IS CHEAPEST WAY

	PUSH	P,A			;SAVE A
	HLRE	BKCNT,LPSA		;SAVE COUNT
	HRRZ	BKPTR,LPSA		;POINT
	MOVE	TPTR,[POINT 4,EN,3]	;BYTE PTR FOR TYPE
NXTEN:	MOVE	EN,(BKPTR)		;PICK ONE UP
	LDB	A,TPTR			;PICK UP TYPE
	PUSHJ	P,@[ ^^LVIDAC:	DRYROT
				RARY	;1
				RARY	;2
				SLFRE	;3 -- SET OR LIST
				LAFRE	;LEAP ARRAY OF SETS OR LISTS
	
				FEVAR	;5 FOR EACH CONTROL VARIABLE
				KLIST	;6  
				CTEXTT	;7 CONTEXT
				CLNUP	;10
				RDREF	;11 RECORD
				RRARY	;12 RECORD ARRAY
				DRYROT	;13
				DRYROT	;14
				DRYROT	;15
				DRYROT	;16
				BKE	;17 END OF BLOCK AREA
				](A)
	AOJA	BKPTR,NXTEN	;GET NEXT

DRYROT: ERR <DRYROT: BEXIT>
	POPJ	P,

RGC <
RRARY:				;RECORD ARRAYS ARENT SPECIAL IF HAVE GC
>;RGC

RARY:	SKIPN   C,@EN
	POPJ	P,
	EXCH	C,(P)		;CLEVER WAY TO FIX THE STACK FOR CALL TO
				;ARYEL
	PUSH	P,C
	SETZM	@EN		;SAY IT IS GONE
	JRST	ARYEL		;MAKE IT THE TRUTH
SLFRE:	SKIPN	A,@EN		;
	POPJ	P,
	SETZM	@EN		;ZERO OUT THE DESCRIPTOR
	PUSH	P,5		;SAVE IT
	PUSH	P,6
	MOVEI	5,0		;FOR RECLAIMER
	PUSHJ	P,RECQQ		;SINCE SET
	POP	P,6
	POP	P,5
	POPJ	P,
CTEXTT: SKIPN	A,@EN		;CONTEXT EMPTY?
	POPJ	P,		;YES
	PUSH	P,EN		;CONTEXT ADDRESS
	PUSHJ	P,ALLFOR	;FORGET EVERYTHING
	POPJ	P,

LAFRE:	SKIPN	A,@EN		;ARRAY PTR
	POPJ	P,		;NOBODY HOME
	PUSH	P,A
	SETZM	@EN
	PUSHJ	P,ARRRCL	;JRL'S MAGICAL SET ARRAY ZAPPER
	EXCH	A,(P)		;CLEVER TRICK AGAIN
	PUSH	P,A		;
	JRST	ARYEL		;GIVE UP THE SPACE
BKE:	SOJGE	BKCNT,GETNXT	;DO WE NEED TO DO MORE?
	MOVE	A,-1(P)
	SUB	P,[XWD 3,3]	;
	JRST	@1(P)		;NO
GETNXT:	MOVEI	BKPTR,@EN	;GET LINK
	SOJGE	BKPTR,CPOPJ	;WILL COMPENSATE FOR AOS
	ERR 	<DRYROT: BEXIT>
FEVAR:	SKIPN	A,@EN
CPOPJ:	POPJ	P,
	PUSH	P,PDA
	PUSH	P,BKCNT
	PUSH	P,BKPTR
	PUSH	P,TPTR
; NOW CALL LEAP TO RELEASE FOREACH
	MOVEI	5,47		;CHANGED (11-30-72) TO REFLECT NEW INDICES
	PUSHJ	P,LEAP
	POP	P,TPTR
	POP	P,BKPTR
	POP	P,BKCNT
	POP	P,PDA
	POPJ	P,
KLIST:	SKIPN	A,@EN
	POPJ	P,
	ERR	<UNTERMINATED PROCESS DEPENDS ON A BLOCK BEING EXITED 
MAY CONTINUE >,1
	POPJ	P,


CLNUP:	PUSH	P,PDA
	PUSH	P,BKCNT
	PUSH	P,BKPTR
	PUSH	P,TPTR
	PUSHJ	P,(EN)		;CALL THE PROUCEDURE
	POP	P,TPTR
	POP	P,BKPTR
	POP	P,BKCNT
	POP	P,PDA
	POPJ	P,

REC <
RDREF:	
NORGC <
	SKIPN	A,@EN		;GONE ALREADY
	POPJ	P,
	SOSLE	-1(A)		;REF COUNT LOSES ONE
	JRST	.+3		;DONE
	AOS	-1(A)		;PUT IT BACK SO NEXT GUY CAN DO SAME
	RECUUO	0,@EN		;DEREFERENCE LIKE SO
	SETZM	@EN		;ZERO OUT
	POPJ	P,		;RETURN

RRARY:	SKIPN	A,@EN		;RECORD ARRAY STILL THERE??
	POPJ	P,		;NOPE
	SETZM	@EN		;WE ARE KILLING IT
	PUSH	P,(P)		;RETN ADRS
	MOVEM	A,-1(P)		;FOR EVENTUAL CALL TO ARYEL
	HRLZI	EN,C		;
	HRRI	EN,-1(A)	;EN = POINTER AT NEXT
	HRRZ	C,-1(A)		;C = COUNT
	JUMPE	C,ARYEL		;ALL DONE
	PUSHJ	P,RDREF		;DEREFERENCE ONE
	SOJG	C,.-1		;ITERATE UNTIL DONE
	JRST	ARYEL
>;NORGC
RGC <
	SETZM	@EN		;SO GC DOESN'T FIND IT
	POPJ	P,
>;RGC
>;REC
NOREC <
RRARY:
RDREF:	JRST	DRYROT
>;NOREC


BEND BEXIT

HERE (STKUWD)
BEGIN	STKUWD
DSCR STKUWD
DES THIS PROCEDURE UNWINDS THE STACK TO ESTABLISH A CORRECT DISPLAY AND
	LEXIC LEVEL.
PAR LPSA=XWD CORRECT LL,CORRECT DL
SID MANGLES YOUR ACS (EXCEPT F, P, SP -- WHICH ARE PROPERLY FIXED UP)


CDLSAV_5
LLFGR_6
SIN_7
EN_10
PDA_11

	MOVE	USER,GOGTAB		
	POP	P,STKURT(USER)		;REMEMBER RETURN ADDRESS
	HRRZM	LPSA,CDLSAV		;
	HLROM	LPSA,LLFGR		;SET UP PARAMETERS FOR USE 
PLOOP:	HLRZ	PDA,1(RF)		;PICK UP PROC DESC ADDRESS
;;#LP# (25 FEB 73)1 OF 1 -- RHT -- MUST CHECK FOR GO TO OUT OF PROCESS
	CAIN	PDA,0			;IS THIS THE BITTER END
	ERR	<GO TO OUT OF A PROCESS WILL NOT WORK> ;YES
;;#LP#
;;#NG# -- RHT ALWAYS ADJUST STACKS BEFORE DO LVI NOW!
	MOVE	SP,2(RF)		;OLD OLD SP
	HLLZ	A,PD.DSW(PDA)		;EXTRA SS DISPL NEED
	HLR	A,A			;BOTH SIDES
	ADD	SP,A			;
	HRRZ	A,PD.DSW(PDA)		;ARITH STK DISPL
	ADDI	A,(RF)			;+RF
	HRRZ	B,P			;WHERE WE ARE NOW
	SUB	B,A			;HOW FAR BACK TO GO
	HRL	B,B			;BOTH SIDES
	SUB	P,B			;TRIMMED BACK
;;#NG# 
	CAMN	PDA,CDLSAV		;IS THIS THE PARENT ???
	HRRZS	LLFGR			;USE THIS AS A FLAG
	HRRZ	SIN,PD.LLW(PDA)		;POINTER AT LVI INFO
NXTEN:	SKIPN	EN,(SIN)		;A ZERO SAYS
	JRST	EOPD			;WE ARE AT END OF LOC VAR INF
TPGET:	LDB	A,[POINT 4,EN,3]	;TYPE FIELD
	CAIN	A,17			;IGNORE END OOF BK ENTRIES
	AOJA	SIN,NXTEN
	JUMPL	LLFGR,DOIT		;IF NOT AT RIGHT DL, ZAP EM ALL
	LDB	B,[POINT =9,EN,=12]	;LL FIELD
	CAMG	B,LLFGR			;IF LEX LEV IS LOW ENOUGH
	AOJA	SIN,NXTEN		;LET HIM LIVE -- VERY INEFFICIENT CODE
DOIT:	PUSHJ	P,@LVIDAC(A)		;CALL APPROPRIATE ROUTINE
	AOJA	SIN,NXTEN
EOPD:	JUMPL	LLFGR,EOPD.1		;RETURN TEST
	MOVE 	USER,GOGTAB		;
	JRST	@STKURT(USER)
EOPD.1:	HRRZ	SIN,PD.DLW(PDA)		;NOW HAVE TO CLEAR OUT SET FORMALS
	HRRZ	B,PD.NPW(PDA)		;#ARITH +1
	MOVE	C,RF			;F REG
	SUBI	C,1(B)			;C_ PTR 1 BEFORE 1'ST ARITH PARM
PARLP:	SOJLE	B,ADJSKS		;COUNT DOWN # ARGS
	AOS	C			;POINT AT NEXT
;;#SO# RHT,RFS THIS PIECE OF CODE WAS STILL USING B
	MOVE	EN,(SIN)			;TYPE CODE
;;#NF# RHT 24 JULY 73 THIS PIECE OF CODE WAS STILL USING TBITS
	TLC	EN,SETYPE5		;VALUE SET MUST BE RELEASED
	TLNN	EN,REFB!ITEMB!PROCB	;THESE ARE NOT RELEASED
	TLNE	EN,MSK6BT		;CHECK THE SET CODE
;;#NF#
;;#SO#
	AOJA	SIN,PARLP		;IF NOT VALUE SET, NO PROBLEMS
	MOVEI	EN,(C)			;EN__ PTR TO SET
;; BY JRL 8-31- 72 FOLLOWING INSTRUCTION WAS PUSHJ P,@LVIDAC+4
;;%  % MAKE SET RELEASE SAFE FOR THIS LOOP (MERE PARANOIA)
	PUSH	P,SIN
	PUSH	P,C
	PUSH	P,B
	PUSHJ	P,@LVIDAC+3		;CALL SET RELEASER
	POP	P,B
	POP	P,C
	POP	P,SIN
;;%  %
	AOJA	SIN,PARLP		;GO ON TO NEXT
ADJSKS:	HRRZ	RF,(RF)			;BACK A DYNAMIC LINK
;;#NG# -- USED TO ADJUST STACKS HERE
	JRST	PLOOP			;

BEND STKUWD
COMMENT  array info & the like 

DSCR INTEGER_ARRINFO(ARRAY,CODE);
CAL SAIL


HERE (ARRINFO)
BEGIN ARRINFO
	MOVE	A,-2(P)	;ARRAY ADDRESS
	SKIPGE	-2(A)	;STRING ARRAY?
	 SUBI	 A,1		; YES, BACK UP FOR IT
	SKIPGE	TEMP,-1(P)	;CONTROL PARAMETER
	 JRST	 [HLRE A,-1(A) ;WANTS NUMBER OF DIMENSIONS
		   JRST RSINFO]
	JUMPE	TEMP,[HRRZ A,-1(A) ;WANTS TOTAL SIZE
			JRST RSINFO]
; WANTS A BOUND
	ROT	TEMP,-1		;SAVE LOW ORDER BIT AS SIGN
	MOVNI	LPSA,3		;GET DISPLACEMENT INTO ARRAY TABLE
	IMULI	LPSA,(TEMP)
	SKIPGE	TEMP		;WANT UPPER OR LOWER BOUND
	SUBI	LPSA,4
	HRLI	A,LPSA
	MOVE	A,@A		;GET THE REQD BOUND
RSINFO:	
	SUB	P,X33
	JRST	@3(P)
BEND ARRINFO

DSCR ARRBLT(@DEST,@SOURCE,LENGTH);
CAL SAIL


HERE (ARRBLT) 
BEGIN ARRBLT
;;#PL 12-1-73 RLS  (1 OF 2)  DONT BLT IF COUNT IS LEQ 0
	SOSGE	LPSA,-1(P)		;GET LENGTH, SUBTRACT 1
	  JRST	BLTRET			;LEQ 0, DONT BLT
;;#PL
	HRRZ	TEMP,-3(P)
	HRL	TEMP,-2(P)
	ADDI	LPSA,(TEMP)
	BLT	TEMP,(LPSA)
;;#PL 12-1-73 RLS (2 OF 2)  DONT BLT IF COUNT IS LEQ 0:  LABEL NEXT LINE
BLTRET:	SUB	P,X44
	JRST	@4(P)
BEND  ARRBLT

DSCR ARRTRAN(DEST ARRAY,SOURCE ARRAY);
CAL SAIL


HERE (ARRTRAN)
BEGIN ARRTRAN
	HRRZ	TEMP,-2(P)		;DEST ARRAY ADDR
	HRRZ	LPSA,-1(P)		;SOURCE ARRAY ADDR
	SKIPL	-2(TEMP)		;STRING ARRAY?
	 JRST	 NSTR			; NO
	SUBI	TEMP,1
	SUBI	LPSA,1

NSTR:	HRL	TEMP,LPSA		;BLT WORD
	HRRZ	LPSA,-1(LPSA)		;SOURCE SIZE
	HRRZ	USER,-1(TEMP)
	CAMLE	LPSA,USER
	 HRRZ	 LPSA,USER
	ADDI	LPSA,-1(TEMP)		;TERMINATION WORD
	BLT	TEMP,(LPSA)
	SUB	P,X33
	JRST	@3(P)
BEND ARRTRAN


DSCR ARRCLR(ARRAY,VAL(0)) 
DES	FILLS UP ARRAY WITH VAL
CAL SAIL


HERE(ARRCLR)
BEGIN ARRCLR
	MOVE	USER,-1(P)		;VALUE TO PUT
	MOVE	TEMP,-2(P)		;GET ADDRESS OF ARRAY
	SKIPL	-2(TEMP)		;CHECK STRING ARRAY
	JRST	NOSACL
	SUBI	TEMP,1			;A STRING ARRAY STARTS EARLIER
	CAIE	USER,0			;
	ERR	<YOU CANNOT CLEAR STRING ARRAYS TO OTHER THAN NULL>;
NOSACL:	HRLI	LPSA,(TEMP)		;PREPARE FOR BLT
	HRRI	LPSA,1(TEMP)
	MOVEM	USER,(TEMP)
	HRRZ	USER,-1(TEMP)		;GET NUMBER OF WORDS IN ARRAY
;;#TS# CHECK FOR ONE WORD ARRAYS
	SOJLE	USER,DONEIT		;CHECK ONE WORD ARRAYS
	ADDI	TEMP,(USER)		;NUMBER OF WORDS TO MOVE IN BLT
;;#TS# ^
	BLT	LPSA,(TEMP)		;DO A BLT
DONEIT:	SUB	P,X33
	JRST	@3(P)			;RETURN
BEND ARRCLR


ENDCOM(ARY)

IFE ALWAYS, <
;; \UR#10\ ADD DUMMY ENTRIES FOR COPARR AND CATLST
COMPIL(DM1,<CATLST,COPARR,RECQQ,ARRRCL,LEAP,CVIS>,,<DUMMY LEAP BEXIT TARGETS>)
^^RECQQ:
^^ARRRCL:
^^LEAP: 
^^CVIS:
;; |UR#10| DUMMY ENTRIES FOR CATLST AND COPARR
^^CATLST:
^^COPARR:
;; |UR#10|
	ERR <DRYROT-LIBRARY>
ENDCOM(DM1)
COMPIL(DM2,<SPRPDA,RESUME,TERMIN,SPROUT,DADDY,CURSCB,ACF,PLISTE>
					,,<DUMMY PROCESS VARIABLES>)
^^SPRPDA:
^^RESUME:
^^TERMIN:
^^SPROUT:
^^DADDY:
	ERR <DRYROT-LIBRARY>
^^CURSCB __ 0;
^^ACF__12+3;
^^PLISTE __ 0;
ENDCOM(DM2)
COMPIL(DM3,<ALLFOR>,,<DUMMY BACKTRACKING BEXIT TARGET>)
^^ALLFOR:
	ERR <DRYROT-LIBRARY>
ENDCOM(DM3)

COMPIL(DM4,<APPL$Y>,,<DUMMY APPLY PD ENTRY>)
^^APPL$Y: 
	.+1
	ERR <DRYROT-LIBRARY>
ENDCOM(DM4)
>;IFE ALWAYS
COMMENT  the procedure item routines


COMPIL(PIT,<PITCOP,PITBND,APPLY,PITDTM>,<GINFTB,INFTB,DATM,GDATM,GOGTAB,RECQQ,LEAP>
	,<PROCEDURE ITEM ROUTINES>,<APPL$Y>)

COMMENT  APPLY$ IS NOT MADE AN ENTRY.  HOWEVER IT IS INTERNALED.  THUS
PIT WILL NOT BE LOADED SIMPLY BECAUSE OF THE EXTERNAL REQUEST IN SAIPRC
FOR APPLY$ 

BEGIN PITS
;;%##% ! half kill the symbol
FLAG__0;
PDA _ 4
NPW _ 5
FPTR_6
FRM_7
APTR_10
SPPCNT__11		;# PUSHED ONTO SP,,# PUSHED ONTO P

GLOB <
GBRK__6000 
>;GLOB

DSCR PITBND,PITCOP
CAL
	PUSH P,DITM
	PUSH P,XXX
	PUSHJ P,PITBND	<OR PITCOP>

PARM DITM IS ITEM TO BE MADE INTO PROCEDURE ITEM
	FOR PITBND, XXX IS PDA OF PROC TO BE BOUND
	FOR PITCOP, XXX IS PROCEDURE ITEM NUMBER
DES PUTS INTO DITM'S DATUM: XWD STATIC LINK,PDA &SETS DITM'S TYPE TO PITTYP
SID MANGLE TEMP,LPSA,USER,B,C




HERE (PITBND)
	HRRZ	LPSA,-1(P)		;PICK UP PDA
NOCMU<;;[CMU =F6= LDE 6-16-76] "WE KNOW WHAT WE ARE DOING"
;;%CV% JFR 8-22-75 Try to trap problems before they get too far in overlays
IFNDEF JOBOVL,<JOBOVL__131>
	SKIPN	TEMP,JOBOVL
	 JRST	.+3
	CAMGE	TEMP,(LPSA)	;IS ENTRY ADDR GTR THAN CONTROL SECTION ADDRESS OF ROOT?
	 ERR	<PITBND: PROC ADDR GTR (JOBOVL)>,1
;;%CV% ^
>;NOCMU =F6=
	HRRZ	TEMP,PD.PPD(LPSA)	;PARENT'S PDA
;;#LM# ! WAS A SKIPE
	SKIPN	PD.PPD(TEMP)		;IF DADDY IS THE GLOBAL MAN (IE
	JRST	PUTDTM			;THE OUTER BLOCK -- INDICATED BY HIS
					;HAVING NO FATHER -- THEN DONT LOOK FOR
					;A STATIC LINK -- YOU WILL USE 0

	SKIPA	USER,RF			;
CTXTLP:	HRRZ	USER,(USER)		;GO UP A LINK
	HLRZ	B,1(USER)		;PDA AT THIS LEVEL.  NOTE WE
	CAME	TEMP,B			;FIRST LOOK AT THIS GUY
	JRST	CTXTLP			;NOT THE ONE
	HRL	LPSA,USER		;NOW LPSA IS SL,,PDA
	JRST	PUTDTM			;GO PUT IN THE DATUM

HERE(PITCOP)
	MOVE	C,-1(P)			;PICK UP ITEM NO INTO B
	PUSHJ	P,PITDGT		;GET DATUM
PUTDTM:	MOVE 	C,-2(P)			;TARGET
	MOVEI	TEMP,PITTYP		;SPECIAL CODE
GLOB <
	CAIL 	C,GBRK			;IS IT GLOBAL???
	JRST	[
		TERPRI	<DON'T BIND PROCEDURES TO GLOBAL ITEMS>
		CAI	C,
		ERR	<ITEM NUMBER>,6
		]
	>;GLOB

	MOVE	USER,GOGTAB
	DPB	TEMP,INFOTAB(USER)	;PUT IN NEW DATUM TYPE
	MOVEM	LPSA,@DATAB(USER)	;SET DATUM
	SUB	P,[XWD 3,3]
	JRST	@3(P)			;RETURN

PITDGT:					;PROCEDURE TO GET PIT DATUM
	MOVE	LPSA,GOGTAB
GLOB <
	CAIL	C,GBRK			;
	MOVE	LPSA,GLUSER
>;GLOB
	LDB	B,INFOTAB(LPSA)
	CAIE	B,PITTYP		;IS IT A PROCEDURE ITEM???
	JRST	[ CAI C,
		ERR <NOT A PROCEDURE ITEM >,6]
GLOB <
	CAIL	C,GBRK
	ERR	<DRYROT AT PITDGT>
>;GLOB
	MOVE	LPSA,@DATAB(LPSA)	;FETCH DATUM
	POPJ	P,

DSCR PITDTM
CAL 	PUSH	P,PIT NO
	PUSHJ	P,PITDTM
DES	SETS THE TOP OT THE STACK TO THE DATUM OF THE PROCEDURE ITEM


HERE(PITDTM)
	MOVE	C,-1(P)			;PICK UP ITEM NO
	PUSHJ	P,PITDGT		;GET ITS DATUM
	MOVEM	LPSA,-1(P)		;SET IT DOWN INTO THE STACK
	POPJ	P,
DSCR APPLY
CAL 
BAIL<
	PUSH	P,location to return string result
	PUSH	P,location to return non-string result	
>;BAIL
	PUSH	P,[xwd context,pda]
	PUSH	P,ARGLIS
	PUSHJ	P,APPLY
DES  
	APPLY is the interpretive caller. Essentially, it uses the items
in ARGLIS to build a procedure call on the procedure named by the pda.
If context=0, then the procedure is just called in the normal manner. 
If context is not zero, then APPLY will build a MSCP, using this value
as the static link, and will jrst to the instruction after the mscp.

%DG% If ARGLIS has form 0,,pointer, then the BAIL form of call is
assumed.  (i.e, ARGLIS is assumed to point to one word before
a block of refitem-like descriptors, terminated by a 0.)  In this
case TPMB never gets looked at.



HERE(APPL$Y)
	APPLY	;A FAKED UP PD SO CAN SPROUT APPLY
		;NOTE HERE THAT FOR UP WILL HAVE TO GO THROUGH 1 MORE 
		;LEVEL OF INDIRECTION

HERE(APPLY)
	MOVEI	SPPCNT,0	;NOTHING PUSHED YET
	MOVE	PDA,-2(P)
BAIL<
;;%DG%
;	SETZ	TAC2,			;ASSUME NOT BAIL APPLY
;	TLC	PDA,-1
;	TLCN	PDA,-1			;BAIL APPLY?
	SKIPE	TAC2,-1(P)		;NULL ARGLIS IMPLIES NORMAL
	TLNE	TAC2,-1			;ZERO COUNT IMPLIES BAIL APPLY
	TDZA	TAC2,TAC2		;FLAG NORMAL
;;%DG% ^
	SETO	TAC2,			;YES
>;BAIL
	MOVE	NPW,PD.NPW(PDA)		;THE STACK DISPLACEMENTS
	HRRZ	FPTR,PD.DLW(PDA)	;POINT AT FORMALS
NOGLOB <
	MOVE	USER,GOGTAB		;
>;NOGLOB
BAIL<
	JUMPE	TAC2,NBAP01		;IF NOT BAIL APPLY
	MOVE	APTR,-1(P)		;ARLIST LOCATION-1
	JRST	NXTP
NBAP01:
>;BAIL
	SKIPN	APTR,-1(P)		;ARG LIST
	JUMPN	FPTR,NEACTS		;NULL ACTS,NON NULL FRMS
NXTP:	SOJLE	NPW,ARGSON		;HAD ENOUGH?
	HLRZ	FRM,(FPTR)		;NEXT FORMAL TYPE
BAIL<
	JUMPE	TAC2,NBAP02		;IF NOT BAIL APPLY
	AOS	APTR			;POINT TO NEXT REFITEM DATUM
	SKIPN	A,(APTR)		;SKIP IF NOT END OF LIST
	JRST	NEACTS
	JRST	BAPCHK			;GO CHECK TYPES
NBAP02:
>;BAIL
	HRRZ	APTR,(APTR)		;LOOK AT NEXT ACTUAL
	JUMPE	APTR,NEACTS		;DONT HAVE ONE
	HLRZ	C,(APTR)		;THE ITEM
GLOB <
	MOVE	USER,GOGTAB		;
	CAIL	C,GBRK			;GLOBAL ??
	MOVE	USER,GLUSER		;
>;NOGLOB
	LDB	A,INFOTAB(USER)		;GET TYPE
	CAIE	A,RFITYP		;REF ITEM?
	JRST	[ PRINT <APPLY -- NON REFERENCE ITEM USED IN ACT PARAM LIST>
		JRST	BARG1
		]
	MOVE	A,@DATAB(USER)		;GET THE DATUM
BAIL<
BAPCHK:	
>;BAIL
DEFACT:
	TRNE	FRM,ITEMB		;FORMAL AN ITEM?
	JRST 	FITEM			;YES
	TLNE	A,ITEMB			;ACTUAL AN ITEMVAR TYPE THING?
	JRST	BFACT			;LOSE ON CORRESP
	MOVE	B,A			;CHECK 6 BIT TYPE CORRESP
	TLC	B,(FRM)			;
	TLNE	B,MSK6BT		;TEST 6 BIT MASK
	JRST	BFACT			;MAY LATER CONSIDER COERCING
	TRNE	FRM,REFB		;
	JRST	FRMREF			;FORMAL IS A REF
;;#QZ# ! 2-3-74 USED NOT TO BE SHIFTED RHT
	TLC	A,STTYPE5		;STRING ?
	TLNN	A,MSK6BT		;WELL?
	JRST	STVPSH			;YOU BETCHA
DEF1CT:	PUSH	P,@A			;PUSH THE VALUE OF THE ARG
	ADDI	SPPCNT,1		;ONE MORE ONTO P
	TRC	FRM,LFLTYP5		;LONG ?
	TRNE	FRM,MSK6BT!ITEMB
	AOJA	FPTR,NXTP		;GO GET NEXT
	MOVEI	A,@A			;YES, LONG. GET ADDR OF FIRST
	AOJA	A,DEF1CT		;AND BE TRICKY
STVPSH:	PUSH	SP,-1(A)		;PUSH A STRING
	PUSH	SP,(A)			;
	ADD	SPPCNT,[2,,0]		;TWO MORE ONTO SP
	ADD	NPW,[XWD -2,1]		;FIX FOR THE SOJ AT NXTP
	AOJA	FPTR,NXTP
FRMREF:	MOVEI	A,@A			;THE ADDRESS
	PUSH	P,A			;THE REF
	ADDI	SPPCNT,1
	AOJA	FPTR,NXTP		;NEXT
FITEM:	TLNN	A,ITEMB			;IS ACTUAL AN ITEM TOO
	JRST	BFACT			;YOU LOSE!
	MOVE	B,A			;GET ACTUAL BITS
	TLC	B,(FRM)			;6 BIT TYPES
	TRNN	FRM,MSKUNT		;FORMAL HAS 6 BIT TYPE?
	JRST	OK6BT			;NO
;;#QW# 1 OF 2 ALLOW MORE LENIENCY HERE
	TLNN	A,MSKUNT		;DOES ACT HAVE 6 BIT TYPE SPEC
	JRST	AUTITM			;NOPE
;;#QW#
	TLNE	B,MSK6BT		;WIN?
	JRST	BFACT			;NO
OK6BT:	TLNE	B,ARY2B			;THE ARY2 BIT OK?
	JRST	BFACT			;NO
	TLNE	A,BINDB			;BINDING ACTUAL?
	JRST	BNDACT			;YES
	TLNE	A,QUESB			;? ACTUAL?
	JRST	QUEACT			;YES
;;#OL# WAS MAKING WRONG TEST !!
	TRNE	FRM,REFB		;FORMAL REF?
	JRST	FRMREF			;YES
	PUSH	P,@A			;PUSH THE ITEM
	ADDI	SPPCNT,1
	AOJA	FPTR,NXTP		;FETCH NEXT
BNDACT:	TRNN	FRM,QUESB		;FORMAL BETTER BE ?
	JRST 	BFACT
PSHBRF:	MOVEI	A,@A
	TLO	A,20			;TURN ON INDIR BIT
	PUSH	P,A			; @ REF
	ADDI	SPPCNT,1
	AOJA	FPTR,NXTP		; GO DO NEXT
QUEACT:	TRNN	FRM,QUESB		;BETTER BE ?
	JRST	BFACT
	MOVE	B,@A			;GET  THE VALUE NOW
	CAIN	B,UNBND			;HAVE A BINDING?
	JRST	PSHBRF			;NO
	PUSH	P,B			;YES
	ADDI	SPPCNT,1
	AOJA	FPTR,NXTP		;

;;#QW# 1-29-74 RHT (2 OF 2)
AUTITM:					;COME HERE WHEN FORMAL SPEC & ACT UNSPEC
	TLNE	A,ARY2B			;ACT AN ARY2 THING?
	JRST	OK6BT			;YES, PRETEND THAT 6 BIT TYPES ARE OK
	TRNE	FRM,REFB!BINDB		;FORMAL REF OR BIND ?
	JRST	OK6BT			;IF SO, A REGULAR WIN
	SKIPN	C,@A			;GET ULT VALUE TO SEE IF OK
	JRST	OK6BT			;LET ANY THROUGH TOO
	CAIN	C,UNBND			;UNBOUND ? WILL ACT LIKE BIND
	TRNN	FRM,QUESB		;
	SKIPA	USER,GOGTAB		;NOT THIS BAD CASE
	JRST	OK6BT			;WAS UNBND ? IVAR
GLOB <	
	CAIL	C,GBRK
	MOVEI	USER,GLUSER
>;GLOB
	LDB	C,INFOTAB(USER)		;GET ACTUAL ITEM TYPE
	LSH	C,5			;TO LINE THINGS UP FOR THE TRC
	TRC	C,(FRM)			;CHECK 6 BIT TYPE OF THIS ACTUAL VAL ITEM
	TRNN	C,MSK6BT		;SEE IF WIN
	JRST	OK6BT			;WELL, WE HAVE REALLY WON
;ELSE FALL INTO BFACT CODE
;;#QW# 
BFACT:	PRINT	<BAD CORRESPONDENCE BETWEEN ACTUAL & FORMAL PARAMETER TYPE>
BARG1:	JSP	TAC1,PRTARG		;
	JSP	TAC1,PITERR
	JSP	TAC1,PSPFIX		;FIX P & SP
	JRST	CRET			;EXIT FROM IT ALL

PRTARG:	MOVEI	FLAG,1(FPTR)		;FORMAL POINTER
	SUB	FLAG,PD.DLW(PDA)	;ORIGIN
	HRRZ	FLAG,FLAG		;GET THE RH OF IT
	TERPRI
	PRINT	<ARGUMENT NUMBER >
	DECPNT	FLAG
	TERPRI
	JRST	(TAC1)			;RETURN
PSPFIX:	HRRZ	A,SPPCNT
	HRLI	A,(A)
	SUB	P,A			;JUSTIFY P STACK
	HLRZ	A,SPPCNT
	HRLI	A,(A)
	SUB	SP,A			;JUSTIFY SP STACK
	MOVEI	A,0
	JRST	(TAC1)

NEACTS:
;;%##% JFR 4-4-75 ALLOW FOR DEFAULT ARGUMENTS
	TRNN	FRM,400000		;IS IT DEFAULTABLE?
	 JRST	NEACT1			;NO
BAIL<	JUMPE	TAC2,.+2		;SKIP IF NOT BAIL APPLY
	 SOS	APTR			;FIX FOR NEXT TIME
>;BAIL
	MOVE	A,(FPTR)		;REFITEM FOR DEFAULT VALUE
	JRST	DEFACT			;CONTINUE
NEACT1:
;;%##% ^
	TERPRI
	PRINT	<APPLY--NOT ENOUGH ACTUAL PARAMETERS SUPPLIED >
	JRST	BARG1

ARGSON:
BAIL<
;;%DG%
;	JUMPN	TAC2,CAL1		;SKIP SPECIAL CONTEXT FOR BAIL
	TLC	PDA,-1			; -1 NEVER VALID CONTEXT TO LOOK FOR
	TLCN	PDA,-1			; 
	JRST	CAL1			; NOT(LH) WAS ALL 0
;;%DG% ^
>;BAIL
	TLNN	PDA,-1			;WERE WE GIVEN A CONTEXT
	JRST 	CAL1			;NO
	PUSH	P,[CRET]		;PUSH	RETURN ADDRESS
	PUSH	P,RF
	ADDI	SPPCNT,2
	HRRZ	A,PD.PPD(PDA)		;PARENTS PDA
	MOVS	B,PDA			;PDA,,STATIC LINK
	HLRZ	FRM,1(B)			;PDA OF DADDY???
	CAME	FRM,A			;????
	JRST	[
		PRINT	<CONTEXT WRONG OR CLOBBERED IN INTERP CALL>
		JSP	TAC1,PITERR
		JSP	TAC1,PSPFIX
		JRST	CRET
		]
	PUSH	P,B			;STATIC LINK
	PUSH	P,SP			;
	HLRZ	A,PD.PPD(PDA)		;WORD AFTER MKSEMT
	JRST	(A)			;GO THERE
CAL1:	HRRZ	A,PD.(PDA)		;ENTRY ADDRESS
	PUSHJ	P,(A)			;CALL IT
CRET:	MOVE	PDA,-2(P)		;HERE ON RETURN
BAIL<
;;%DG%
;	SETZ	TAC2,			;ASSUME NOT BAIL APPLY
;	TLC	PDA,-1
;	TLCN	PDA,-1			;BAIL APPLY?
;	SETO	TAC2,			;YES
;;%DG% ^
>;BAIL
	MOVE	FRM,PD.PDB(PDA)		;PROC type
BAIL<
;;%DG%
;	JUMPE	TAC2,NBAP03		;IF NOT BAIL APPLY
	SKIPE	TAC2,-1(P)		;NULL IS NORMAL
	TLNE	TAC2,-1			;CHECK FOR BAIL APPLY
	JRST	NBAP03			;NORMAL APPLY
;;%DG% ^
	LDB	TEMP,[POINT 8,FRM,=12]	;8 BITS INCLUDES ITEMB
	CAIE	TEMP,LFLTYP
	 JRST	BAPRN1			;NOT LONG
	DMOVEM	A,@-3(P)		;LONG. STORE DOUBLE VALUE
	JRST	BAPRN2
BAPRN1:
	CAIE	TEMP,STTYPE		;SIMPLE STRING?
	 JRST	BAPRNS			;NO
	MOVE	A,-4(P)			;YES. ADDRESS OF STRING DESCR
	POP	SP,(A)			;FIRST WORD
	POP	SP,-1(A)		;SECOND WORD
	JRST	BAPRN2
BAPRNS:	MOVEM	A,@-3(P)		;RETURN NON-STRING RESULT
BAPRN2:	SUB	P,[XWD 5,5]
	JRST	@5(P)			;RETURN
NBAP03:
>;BAIL
;;#QU# ! type forgot the lsh 5 RHT  1-28-74
	TLC	FRM,STTYPE5		;SIMPLE STRING?
	TLNN	FRM,MSK6BT!ITEMB	;WELL?
	SUB	SP,[XWD 2,2]		;POP	SP STACK
;;%BH%
	SKIPN	B,-1(P)			;GET THE LIST
	JRST	TMIDON			;NO LIST
TMIKIL:	
	HRRZ	B,(B)			;STEP THE LIST
	JUMPE	B,TMIDON		;A ZERO MARKS THE END
	HLRZ	C,(B)			;GET ITEM NUMBER
	SKIPL	@DATM			;AT THIS POINT, KNOW IS REFITEM
	JRST	TMIKIL			; THE SIGN BIT IS TMPB (GEQ 0 MEANS PERM)
					;IF GET HERE C IS A TEMP ITEM
	PUSH	P,B			;SAVE LIST PTR
	PUSH	P,C			;THE ITEM NUMBER
	MOVEI	5,43			;DELETE CODE
	PUSHJ	P,LEAP			;UGH! WHAT A TERRIBLE WAY TO DO THINGS
	POP	P,B
	JRST	TMIKIL			;CONTINUE
TMIDON:
;;%BH%
	SKIPGE	B,-1(P)			;GET THE LIST 
	PUSHJ	P,RECBQQ		;ARGL WAS TEMP, RELEASE IT
	SUB	P,[XWD 3,3]
	JRST	@3(P)			;RETURN


PITERR:	TERPRI 
	PRINT <PROCEDURE IS >
	TERPRI
	PUSHJ	P,PRPID
	ERR	<IF YOU CONTINUE, THE PROCEDURE WILL NOT BE CALLED >,1
	JRST	(TAC1)

PRPID:	PUSH	P,A
	PUSH	P,B
	PUSH	P,C
	HRRZ	B,PD.ID1(PDA)
	MOVE	A,PD.ID2(PDA)
	SOJL	B,.+4
	ILDB	C,A
	TTCALL	1,C
	JRST	.-3
	POP	P,C
	POP	P,B
	POP	P,A
	POPJ	P,

;;#OP# MAKE SURE A GETS SAVED
RECBQQ:	EXCH 	A,B
	PUSH	P,B
	PUSHJ	P,RECQQ
	POP	P,A
	POPJ	P,
;;#OP#

BEND PITS
ENDCOM(PIT)
BEND GOGOL
INTERNAL ..PAT.
..PAT.:
PATCH:	BLOCK	50