COMPIL(CAS,<CSERR,LPRYER>,<GOGTAB>
	  ,<CSERR, LPRYER -- SUPPORT ROUTINES>)
COMMENT ⊗ Lpryer, Cserr ⊗

HERE(CSERR)	MOVE	USER,GOGTAB
	POP	P,UUO1(USER)	;STANDARD PLACE
	ERR	<CASE INDEX OVERFLOW, VALUE IS >,13
	JRST	@UUO1(USER)	;RETURN OK

HERE (LPRYER) ERR	<DATUM OF ARRAY NOT THERE>,1
	POPJ	P,

ENDCOM(SAV)

COMPIL(BRK,<BREAKSET,SETBREAK>
	  ,<SAVE,RESTR,BRKMSK,SIMIO,GOGTAB,X22,X33>
	  ,<BREAKSET, SETBREAK, ROUTINES (EXCEPT STDBRK)>)
COMMENT ⊗Breakset ⊗

DSCR BREAKSET(TABLE #,"STRING",WAY);
CAL SAIL
⊗

HERE (BREAKSET)
	PUSHJ	P,SAVE		;SAVE ACS AND THINGS
	MOVE	LPSA,X33
	SUB	SP,X22
	SKIPLE	A,-2(P)		;TABLE #
	CAILE	A,=18
	ERR	<THERE ARE ONLY 18 BREAK TABLES>
	HLLZ	B,BRKMSK(A)	;BREAK MASK FOR THIS TABLE
	ADD	A,USER
	MOVE	C,[ANDCAM B,(D)]  ;USUAL CLEARING INSTR
	LDB	X,[POINT 4,-1(P),35] ;COMMAND
	TRZN	X,10		  ;LEFT OR RIGHT HALF OF TABLE?
	SKIPA	X,BKCOM(X)	  ;RIGHT HALF
	HLRZ	X,BKCOM(X)	  ;LEFT HALF
	JRST	(X)		  ;DISPATCH

BKCOM:	XWD	XCLUDE,PASLINS	;X,,P
	XWD	INCL,PENDCH	;I,,A
	XWD	ILLSET,RETCH	;-,,R
	XWD	ILLSET,SKIPCH	;-,,S
	XWD	BRKLIN,DSPSET	;L,,D
	XWD	ILLSET,ERMAN	;-,,E
	XWD	NOLINS,ILLSET	;N,,-
	XWD	OMIT,ILLSET	;O,,-

ILLSET:	ERR	<ILLEGAL COMMAND TO BREAKSET>,1
	JRST	RESTR

XCLUDE:	SKIPA	C,[IORM B,(D)]	;YES, SET ALL TO 1 TO INITIALIZE
OMIT:	MOVSS	B		;OMIT, PUT BIT IN RH
INCL:	MOVSI	D,-200
	HRRI	D,BRKTBL(USER)	;RELOCATABLE IOWD
BRKLUP:	XCT	C		;CLEAR (OR SET) PROPER (HALF OF PROPER) TABLE
	AOBJN	D,BRKLUP
	MOVE	C,[IORM B,BRKTBL(D)]	;USUAL SETTING INSTR
	CAIN	X,XCLUDE	;BY EXCEPTION?
	MOVE	C,[ANDCAM B,BRKTBL(D)] ;YES, WANT TO TURN OFF BITS
	ADDI	C,(USER)	;RELOCATE IT
	HRRZ	A,1(SP)		;LENGTH OF STRING
	MOVE	X,2(SP)		;BYTE POINTER
	JRST	BRKL2
BRKL1:	ILDB	D,X		;GET A CHAR
	XCT	C		;DO RIGHT THING TO RIGHT BIT
BRKL2:	SOJGE	A,BRKL1
	JRST	RESTR

PASLINS: TDZA	B,B		;PASS LINE NOS. SINE COMMENT
NOLINS:	MOVEI	B,-1		;INFORM IN THAT IT SHOULD 
	MOVEM	B,LINTBL(A)	;  DELETE LINE NOS.
	JRST	RESTR

BRKLIN:	SKIPA	B,[-1]		;MARK BREAK ON LINE NOS. FOR THIS TBL
ERMAN:	MOVSI	B,-1		;LH NEG SIGNALS ERMAN'S SCHEME
	MOVEM	B,LINTBL(A)
	JRST	RESTR

PENDCH:	SETOM	DSPTBL(A)	;APPEND TO END OF INPUT
	JRST	RESTR

SKIPCH:	TDZA	B,B		;CHAR NEVER APPEARS IN INPUT STRING
RETCH:	MOVEI	B,-1		;RETAIN FOR NEXT TIME
	MOVEM	B,DSPTBL(A)
	JRST	RESTR

DSPSET:	SETOM	PGNNFL(USER)	;WE'RE DISPLAYING PAGE/LINE NUMBERS ON DPY
	JRST	RESTR
COMMENT ⊗Setbreak 

  TBL IS AS IN BREAKSET
  BRKSTRNG IS USED FOR ANY "I" OR "X" APPEARING IN MODESTRNG
  OMITSTRNG (IF NOT NULL) IS USED TO SET THE "OMIT" SIDE OF THE TABLE
  MODESTRNG CAN CONTAIN ANY OF THE VALID BREAKSET "MODE" CHARACTERS
     I,X,O,N,R,A,P, or S.
This function is not attainable by the user unless he declares it.
⊗

DSCR SETBREAK(TABLE,"BREAKSTRING","OMITSTRING",MODESTRING");
CAL SAIL
⊗

HERE (SETBREAK)
	HRRZ	TEMP,-3(SP)		;DO OMIT STRING, IF PRESENT
	JUMPE	TEMP,NO.O		;NULL STRING DOESN'T COUNT
	PUSH	P,-1(P)			;TABLE #
	PUSH	SP,-3(SP)		;OMIT CHARACTERS
	PUSH	SP,-3(SP)
	PUSH	P,["O"]			;OMIT!
	PUSHJ	P,BREAKSET		;DO THAT
NO.O:	HRRZS	-1(SP)			;COUNT OF # OF COMMANDS
BKSLUP:	SOSGE	-1(SP)		;DONE?
	 JRST	 BKSDUN			; YES
	PUSH	P,-1(P)			;TABLE #
	ILDB	TEMP,(SP)		;COMMAND
	PUSH	P,TEMP
	PUSH	SP,-5(SP)
	PUSH	SP,-5(SP)		;STRING TO USE IF NECESSARY
	PUSHJ	P,BREAKSET
	JRST	BKSLUP			;DO IT -- AGAIN

BKSDUN:	SUB	P,X22
	SUB	SP,[XWD 6,6]
	JRST	@2(P)

ENDCOM(BRK)
COMPIL(USC,<USERCON>,<SAVE,RESTR,GOGTAB>,<USERCON ROUTINE>)
COMMENT ⊗Usercon ⊗

DSCR USERCON(@INDEX,@SETGET,FLAG);
CAL SAIL
PAR INDEX is USER-table displacement (usually obtained from HEAD.REL)
 SETGET is used to communicate USER table values
 FLAG is "OPCODE" input to USERCON
RES The INDEXth USER table entry is accessed (GLUSER table if FLAG negative).
 On exit, SETGET contains old value of this entry.
 If FLAG is odd, the original SETGET value replaces this entry.
⊗


HERE(USERCON)
	PUSHJ	P,SAVE
	MOVE	LPSA,[XWD 4,4]
	MOVE	A,-1(P)		;THE FLAG
GLOB <
	MOVEI	B,ENDREN
	JUMPL	A,[MOVEI USER,GLUSER
		   MOVEI B,ZAPEND ;USE GLOBAL TABLE
		   JRST .+1]
	SKIPL	C,-3(P)		;THE INDEX
	CAML	C,B
>;GLOB
NOGLOB <
	SKIPL	C,-3(P)		;THE INDEX
	CAIL	C,ENDREN	;CHECK BOUNDS
>;NOGLOB
	ERR	<USERCON INDEX OUT OF BOUNDS >,7,RESTR
	ADD	C,USER		;POINT AT CORRECT ENTRY
	MOVE	B,(C)		;GET OLD VALUE
	MOVE	D,@-2(P)	;(PERHAPS) NEW VALUE
	TRNE	A,1		;STORE NEW VALUE?
	MOVEM	D,(C)		;YES
	MOVEM	B,@-2(P)	;RETURN OLD VALUE
GLOB <
	MOVE	USER,GOGTAB	;RESET
>;GLOB
	JRST	RESTR
ENDCOM(USC)

COMPIL(ARY,<LRCOP,ARCOP,LRMAK,ARMAK,ARYEL,BEXIT,STKUWD
ENTINT <ARRINFO,ARRBLT,ARRTRAN>>

,<SAVE,RESTR,CORGET,CORREL,X11,X22,X33,X44,GOGTAB,ARRRCL,RECQQ,LEAP,ALLFOR>
   ,<ARRAY ALLOCATION ROUTINES>)


COMMENT ⊗Array Stuff ⊗

;ARYDIR, ARRPDL, AND FRIENDS ARE NO MORE

DSCR LRCOP, ARCOP
⊗
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)		;→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	 <LOWER BOUND ≥ UPPER BOUND>
	IMUL	C,D		;COLLECT SIZE
	SUBI	B,2		;LOOK AT NEXT
	JRST	MAKLUP

SIZDUN:	; MOVEI C,SIZE DESIRED -- ALREADY THERE
	SKIPGE	-1(P)		;IF #DIMS POSITIVE, THEN NOT STRING ARRAY
	LSH	C,1		;MULTIPLY BY TWO FOR STRINGS.
	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
	PUSHJ	P,CORGET		;ARRAY
	 ERR	 <NO ROOM FOR ARRAY>

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 →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→NEXT WORD INTO TABLE,  A=COUNT OF DIMENSIONS LEFT,
    C=ACCUMULATING TOTAL SIZES (AGAIN)
    B→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)		;→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	;→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
	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
	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
				DRYROT	;11
				DRYROT	;12
				DRYROT	;13
				DRYROT	;14
				DRYROT	;15
				DRYROT	;16
				BKE	;17 END OF BLOCK AREA
				](A)
	AOJA	BKPTR,NXTEN	;GET NEXT

DRYROT: ERR <DRYROT AT BEXIT>
	POPJ	P,
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 AT BEXIT -- WENT TOO FAR>
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,

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 
	HLRZ	PDA,1(RF)		;PICK UP PROC DESC ADDRESS
PLOOP:	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← →→ 1 BEFORE 1'ST ARITH PARM
PARLP:	SOJLE	B,ADJSKS		;COUNT DOWN # ARGS
	AOS	C			;POINT AT NEXT
	MOVE	B,(SIN)			;TBITS
	TRNE	B,SET
	TDNE	B,[XWD REFRNC!SBSCRP,LPARRAY!ITEM!ITMVAR]
	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
	PUSHJ	P,@LVIDAC+3		;CALL SET RELEASER
	AOJA	SIN,PARLP		;GO ON TO NEXT
ADJSKS:	HRRZ	RF,(RF)			;BACK A DYNAMIC LINK
	HLRZ	PDA,1(RF)		;NEW PDA
	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
	ADD	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
	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
	HRRZ	TEMP,-3(P)
	HRL	TEMP,-2(P)
	SOS	LPSA,-1(P)
	ADDI	LPSA,(TEMP)
	BLT	TEMP,(LPSA)
	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

ENDCOM(ARY)

IFE ALWAYS, <
COMPIL(DM1,<RECQQ,ARRRCL,LEAP,ALLFOR>,,<DUMMY LEAP BEXIT TARGETS>)
↑↑RECQQ:
↑↑ARRRCL:
↑↑LEAP: 
↑↑ALLFOR:
	ERR <DRYROT-LIBRARY>
ENDCOM(DUM)
COMPIL(DM2,<SPRPDA,RESUME,TERMIN,SPROUT,DADDY,CURSCB>,,<DUMMY PROCESS VARIABLES>)
↑↑SPRPDA:
↑↑RESUME:
↑↑TERMIN:
↑↑SPROUT:
↑↑DADDY:
↑↑CURSCB:
	ERR <DRYROT-LIBRARY>
ENDCOM(DM2)
>;IFE ALWAYS

COMMENT ⊗ the procedure item routines
⊗

COMPIL(PIT,<PITCOP,PITBND,APPLY,PITDTM>,<GINFTB,INFTB,DATM,GDATM,GOGTAB>
	,<PROCEDURE ITEM ROUTINES>)
BEGIN PITS
FLAG←0;
PDA ← 4
NA ← 5
L ← 6
ARG ← 7
OLDP ←10
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
	HRRZ	TEMP,PD.PPD(LPSA)	;PARENT'S PDA
	SKIPE	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 
	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.

⊗
HERE(APPLY)
	MOVE	OLDP,P			;IN CASE OF TROUBLE
	MOVE	PDA,-2(P)
	MOVE	NA,PD.NPW(PDA)		;NUMBER OF PARAMETERS
	TLNE	NA,-1			;BETTER BE NO STRINGS
	JRST	[
		PRINT	<ATTEMPT TO EVAL A PROCEDURE WITH STRING PARAMETERS>
CPITE:		PUSHJ	P,PITERR
		MOVE	P,OLDP		;
		JRST	CRET		;GO EXIT
		]
	MOVE	ARG,PD.DLW(PDA)		;POINT AT FIRST SET OF TBITS
	HLRE	L,-1(P)			;LEN OF ARG LIST
	MOVM	L,L			;MAKE IT POS -- JRL'S CROCK STRIKES
	CAIGE	L,-1(NA)		;DO WE HAVE ENOUGH?
	JRST	[
		PRINT	<NOT ENOUGH ACTUAL PARAMETERS SUPPLIED TO INTERP CALL>
		JRST	CPITE
		]
	HRRZ	L,-1(P)			;POINT AT PTR TO FIRST
	HRRZ	L,(L)			;PTR TO FIRST
PALP:	SOJLE	NA,ARGSON		;COUNT DOWN
	MOVE	L,(L)			;LOOK AT NEXT
	HLRZ	C,L			;ITEM NUMBER
	MOVE	A,GOGTAB		;
GLOB <
	CAIL	C,GBRK			;
	MOVE	A,GLUSER		;GLOBAL
>;GLOB
	LDB	A,INFOTAB(A)		;TYPE
	MOVE	B,(ARG)			;TBITS OF ARG
	TLZN	B,VALUE			;BETTER BE VALUE
	JRST	[
		PRINT	<EVAL WITH NON-VALUE ITEMVAR FORMAL>
		JRST	CPITE
		]
	CAIN	B,ITMVAR		;IF SIMPLE ITEMVAR
	JRST	PSHIT			;JUST PUSH IT ON
	CAILE	A,ARRTYP		;IS IT AN ARRAY ITEM?
	JRST	[
		TRZN	B,LPARRAY	;YES, TEST THE FORMAL
		JRST	BFACT		;LOSE
		SUBI	A,ARRTYP	;SUBTRACT OFF THE ARRAY OFFSET
		JRST 	.+1
		]
	CAME	B,TBTBL(A)		;DO TYPE BITS AGREE???
	JRST	[			;LOSE
BFACT:
		PRINT <BAD FORMAL-ACTUAL TYPE MATCH FOR ARGUMENT >
		DECPNT	ARG
		TERPRI	< IN AN INTERPRETIVE CALL>
		PUSHJ	P,PITERR
		JRST	.+1

		]
PSHIT:	PUSH	P,C			;PUSH ON THE ITEM NUMBER
	AOJA	ARG,PALP		;LOOP BACK

ARGSON:	TLNN	PDA,-1			;WERE WE GIVEN A CONTEXT
	JRST 	CAL1			;NO
	PUSH	P,[CRET]		;PUSH	RETURN ADDRESS
	PUSH	P,RF
	HRRZ	ARG,PD.PPD(PDA)		;PARENTS PDA
	MOVS	B,PDA			;PDA,,STATIC LINK
	HLRZ	NA,1(B)			;PDA OF DADDY???
	CAME	NA,ARG			;????
	JRST	[

		PRINT	<CONTEXT WRONG OR CLOBBERED IN INTERP CALL>
		JRST	CPITE
		]
	PUSH	P,B			;STATIC LINK
	PUSH	P,SP			;
	HLRZ	ARG,PD.PPD(PDA)		;WORD AFTER MKSEMT
	JRST	(ARG)			;GO THERE
CAL1:	HRRZ	ARG,PD.(PDA)		;ENTRY ADDRESS
	PUSHJ	P,(ARG)			;CALL IT
CRET:	MOVE	PDA,-2(P)		;HERE ON RETURN
	MOVE	ARG,PD.PDB(PDA)		;PROC TBITS
	TRNN	ARG,ITEM!ITMVAR		;IF NOT ONE OF THESE
	MOVEI	A,0			;THEN RETURN 0
	SUB	P,[XWD 3,3]
	JRST	@3(P)			;RETURN


PITERR:	TERPRI 
	PRINT <PROCEDURE IS >
	TERPRI
	PUSHJ	P,PRPID
	ERR	< >,1
	POPJ	P,

PRPID:	PUSH	P,A
	PUSH	P,B
	PUSH	P,C
	HRRZI	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,

COMMENT ⊗ TABLE OF TYPE BITS FOR ITEMS ⊗
TBTBL:	0				;0
	0				;1
	0				;2
	STRING!ITMVAR			;3
	FLOTNG!ITMVAR			;4
	INTEGR!ITMVAR			;5
	ITMVAR!SET			;6
	LSTBIT!ITMVAR!SET		;7
	0				;10

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