TITLE UUO HANDLER FOR MUDDLE AND HYDRA
RELOCATABLE
.INSRT MUDDLE >

SYSQ
XJRST=JRST 5,
;XBLT=123000,,[020000,,0]

IFE ITS,.INSRT STENEX >

;GLOBALS FOR THIS PROGRAM

.GLOBAL BACKTR,PRINT,PDLBUF,TPGROW,SPECSTO,TIMOUT,AGC,VECBOT,VECTOP
.GLOBAL BCKTRK,TPOVFL,.MONWR,.MONRD,.MONEX,MAKACT,IGVAL,ILVAL,BFRAME
.GLOBAL FLGSET,QMPOPJ,SAVM,STBL,FMPOPJ,PVSTOR,SPSTOR,POPUNW,RMCALL
.GLOBAL PURTOP,PURBOT,PLOAD,PURVEC,STOSTR,MSGTYP,UUOH,ILLUUO,RSTACK,IBLOCK
.GLOBAL NFPOPJ,NSPOPJ,MULTSG,MLTUUP
.GLOBAL SHRRM,SHRLM,SMOVEM,SSETZM,SXBLT,SHLRZ
.GLOBAL C%11,C%22,C%33,C%44,C%55,C%66,C%0,C%1,C%2,C%3,C%M1,C%M2,C%M10
.GLOBAL C%M20,C%M30,C%M40,C%M60

;SETUP UUO DISPATCH TABLE HERE
UUOLOC==40
F==PVP
G==F+1

UUOTBL:	ILLUUO

IRP UUOS,,[[DP,DODP],[.MCALL,DMCALL],[.ACALL,DACALL],[.ECALL,DECALL],[.SAVAC,DSAVAC]
[.FATAL,DFATAL],[.ERRUU,DOERR],[.POPUN,DPOPUN],[.LSAVA,DLSAVA]
[SHRRM,DHRRM],[SHRLM,DHRLM],[SXBLT,DXBLT],[SMOVEM,DMOVEM],[SHLRZ,DHLRZ],[SSETZM,DSETZM],[SMOVE,DMOVE]]
UUFOO==.IRPCNT+1
IRP UUO,DISP,[UUOS]
.GLOBAL UUO
UUO=UUFOO_33
SETZ DISP
.ISTOP
TERMIN
TERMIN

;SINCE CHECKING HAPPENS IN UUOH, NO LONGER NEED TABLE FULL OF ILLUUOS
;REPEAT 100-UUFOO,[ILLUUO
;]


RMT [
IMPURE

UUOH:
LOC 41
	JSR	UUOH
LOC UUOH
	0
IFE ITS,[
	JRST	UUOPUR
PURE
UUOPUR:
]
	MOVEM	C,SAVEC
ALLUUO:	LDB	C,[331100,,UUOLOC]	;GET OPCODE
	SKIPE	C
	 CAILE	C,UUFOO
	  CAIA			;SKIP IF ILLEGAL UUO
	JRST	@UUOTBL(C)	;DISPATCH TO SUITABLE HANDLER
IFN ITS,[
	.SUSET	[.RJPC,,SAVJPC]
]
	MOVE	C,SAVEC
ILLUUO:	FATAL ILLEGAL UUO
; THIS WILL LEAVE .JPC FOR DEBUGGING AND SUCH
IFE ITS,[
IMPURE
]
SAVJPC:	0			; SAVE JPC IN CASE OF LOSS
SAVEC:	0			; USED TO SAVE WORKING AC
NOLINK:	0
IFE ITS,[
MLTUUP:	0			; HOLDS UUO (SWAPPED SORT OF)
MLTPC:	0			; 23 BIT PC
MLTEA:	0			; EFF ADDR OF UUO INSTRUCTION
MLTUUH:	FSEG,,MLTUOP		; RUN IN "FSEG"
]	
PURE
]

;SEPARATION OF PURE FROM IMPURE CODE HERE

;UUOPUR:	MOVEM	C,SAVEC		; SAVE AC
;	LDB	C,[330900,,UUOLOC]
;	JRST	@UUOTBL(C)	;DISPATCH BASED ON THE UUO

; HANDLER FOR UUOS IN MULTI SEG MODE
IFE ITS,[
MLTUOP:	MOVEM	C,SAVEC
	MOVE	C,MLTPC
	MOVEM	C,UUOH			; SO MANY THINGS WIN IMMEDIATE
	HRLZ	C,MLTUUP
	TLZ	C,37
	HRR	C,MLTEA
	MOVEM	C,UUOLOC		; GET INS CODE
	JRST	ALLUUO
]


;CALL HANDLER

IMQUOTE CALLER
CALLER:

DMCALL":
	SETZB	D,R		; FLAG NOT ENTRY CALL
	LDB	C,[270400,,UUOLOC]	; GET AC FIELD OF UUO
COMCAL:	LSH	C,1		; TIMES 2
	MOVN	AB,C		; GET NEGATED # OF ARGS
	HRLI	C,(C)		; TO BOTH SIDES
	SUBM	TP,C		; NOW HAVE TP TO SAVE
	MOVEM	C,TPSAV(TB)	; SAVE IT
	MOVSI	AB,(AB)		; BUILD THE AB POINTER
	HRRI	AB,1(C)		; POINT TO ARGS
	HRRZ	C,UUOH		; GET PC OF CALL
	CAIL	C,HIBOT		; SKIP IF NOT IN GC SPACE
	JRST	.+3
	SUBI	C,(M)		; RELATIVIZE THE PC
	TLOA	C,400000+M	; FOR RETURNER TO WIN
	TLO	C,400000
	SKIPE	SAVM
	MOVEI	C,(C)
	MOVEM	C,PCSAV(TB)
	MOVE	SP,SPSTOR+1
	MOVEM	SP,SPSAV(TB)	; SAVE BINDING GOODIE
	MOVSI	C,TENTRY	; SET UP ENTRY WORD
	HRR	C,UUOLOC	; POINT TO CALLED SR
	ADD	TP,[FRAMLN,,FRAMLN]	; ALLOCATE NEW FRAME
	JUMPGE	TP,TPLOSE
CALDON:	MOVEM	C,FSAV+1(TP)	; CLOBBER THE FRAME
	MOVEM	TB,OTBSAV+1(TP)
	MOVEM	AB,ABSAV+1(TP)	; FRAME BUILT
	MOVEM	P,PSAV(TB)
	HRRI	TB,(TP)		; SETUP NEW TB
	MOVEI	C,(C)
	SETZB	M,SAVM		; ZERO M AND SAVM FOR GC WINNAGE
	CAILE	C,HIBOT		; SKIP IF RSUBR
	JRST	CALLS
	GETYP	A,(C)		; GET CONTENTS OF SLOT
	JUMPN	D,EVCALL	; EVAL CALLING ENTRY ?
	CAIE	A,TRSUBR	; RSUBR CALLING RSUBR ?
	JRST	RCHECK		; NO
	MOVE	R,(C)+1		; YES, SETUP R
CALLR0:	HRRM	R,FSAV+1(TB)	; FIXUP THE PROPER FSAV

CALLR1:	SKIPL	M,(R)+1		; SETUP M
	JRST	SETUPM		; JUMP IF A PURE RSUBR IN QUESTION
IFN ITS,	AOBJP	TB,.+1		; GO TO CALLED RSUBR
IFE ITS,[
	AOBJP	TB,MCHK
]
MCHK1:	INTGO			; CHECK FOR INTERRUPTS
	JRST	(M)

IFE ITS,[
MCHK:	SKIPE	MULTSG
	 HRLI	TB,400000	; KEEP TB NEGATIVE
	JRST	MCHK1
]	
CALLS:
IFN ITS,	AOBJP	TB,.+1		; GO TO CALLED SUBR
IFE ITS,	AOBJP	TB,MCHK3
MCHK4:	INTGO			; CHECK FOR INTERRUPTS
IFE ITS,	SKIPN	MULTSG
	 JRST	@C		; WILL DO "RIGHT THING IN MULTI SEG"
IFE ITS,[
	HRLI	C,FSEG
	JRST	(C)


MCHK3:	SKIPE	MULTSG
	 HRLI	TB,400000	; KEEP TB NEGATIVE
	JRST	MCHK4
]	



; HERE TO HANDLE A PURE RSUBR (LOAD IF PUNTED OR OTHERWISE FLUSHED)

SETUPM:	MOVEI	C,0		; OFFSET (FOR MAIN ENTRIES)
STUPM1:	MOVEI	D,(M)		; GET OFFSET INTO  CODE
	HLRS	M		; GET VECTOR OFFSET IN BOTH HALVES
	ADD	M,PURVEC+1	; GET IT
	SKIPL	M
	FATAL	LOSING PURE RSUBR POINTER
	HLLM	TB,2(M)		; MARK FOR LRU ALGORITHM
	SKIPN	M,1(M)		; POINT TO CORE IF LOADED
	AOJA	TB,STUPM2	; GO LOAD IT
STUPM3:	ADDI	M,(D)		; POINT TO REAL THING
IFN ITS,[
	HRLI	C,M
	AOBJP	TB,MCHK7
	INTGO
MCHK7:	JRST	@C
]
IFE ITS,[
	AOBJP	TB,MCHK7
MCHK8:	INTGO
	ADD	C,M		; POINT TO START PC
	SKIPE	MULTSG
	 TLZ	C,777400	; KILL COUNT

	SKIPN	MULTSG
	 JRST	(C)
	MOVEI	B,0		; AVOID FLAG MUNG
	XJRST	B		; EXTENDED JRST HACK

MCHK7:	SKIPE	MULTSG
	 HRLI	TB,400000	; KEEP TB NEGATIVE
	JRST	MCHK8
]	

STUPM2:	HLRZ	A,1(R)		; SET UP TO CALL LOADER
	PUSH	P,D
	PUSH	P,C
	PUSHJ	P,PLOAD		; LOAD IT
	JRST	PCANT1
	POP	P,C
	POP	P,D
	MOVE	M,B		; GET LOCATION
	SOJA	TB,STUPM3

RCHECK:	CAIN	A,TPCODE	; PURE RSUBR?
	JRST	.+3
	CAIE	A,TCODE		; EVALUATOR CALLING RSUBR ?
	JRST	SCHECK		; NO
	MOVS	R,(C)		; YES, SETUP R
	HRRI	R,(C)
	JRST	CALLR1		; GO FINISH THE RSUBR CALL


SCHECK:	CAIE	A,TSUBR		; RSUBR CALLING SUBR AS REFERENCE ?
	CAIN	A,TFSUBR
	SKIPA	C,(C)+1		; SKIP AND GET ROUTINE'S ADDRESS
	JRST	ECHECK
	HRRM	C,FSAV+1(TB)	; FIXUP THE PROPER FSAV
IFE ITS,	SKIPN	MULTSG
	 JRST	CALLS		; GO FINISH THE SUBR CALL
IFE ITS,[
	HRLI	C,FSEG		; FOR SEG #1
	JRST	CALLS
]
ECHECK:	CAIE	A,TENTER	; SKIP IF SUB ENTRY OF RSUBR
	JRST	ACHECK		; COULD BE EVAL CALLING ONE
	MOVE	C,1(C)		; POINT TO SUB ENTRY BLOCK
ECHCK3:	GETYP	A,(C)		; SEE IF LINKED TO ITS MAIN ENTRY
	MOVE	B,1(C)
	CAIN	A,TRSUBR
	JRST	ECHCK2

; CHECK IF CAN LINK ATOM

	CAIE	A,TATOM
	JRST	BENTRY		; LOSER , COMPLAIN
ECHCK4:	MOVE	B,1(C)		; GET ATOM
	PUSH	TP,$TVEC
	PUSH	TP,C
	PUSHJ	P,IGVAL		; TRY GLOBAL VALUE
	HRRZ	C,(TP)
	SUB	TP,C%22
	GETYP	0,A
	CAIN	0,TUNBOU
	JRST	BADVAL
	CAIE	0,TRSUBR	; IS IT A WINNER
	JRST	BENTRY
	CAMGE	C,PURTOP	; DONT TRY TO SMASH PURE
	SKIPE	NOLINK
	JRST	ECHCK2
	HLLM	A,(C)		; FIXUP LINKAGE
	MOVEM	B,1(C)
	JRST	ECHCK2

EVCALL:	CAIN	A,TATOM		; EVAL CALLING ENTRY?
	JRST	ECHCK4		; COULD BE MUST FIXUP
	CAIE	A,TRSUBR	; YES THIS IS ONE
	JRST	BENTRY
	MOVE	B,1(C)
ECHCK2:	MOVE	R,B		; SET UP R
	HRRM	C,FSAV+1(TB)	; SET POINTER INTO FRAME
	HRRZ	C,2(C)		; FIND OFFSET INTO SAME
	SKIPL	M,1(R)		; POINT TO START OF RSUBR
	JRST	STUPM1		; JUMP IF A LOSER
	ADDI	C,(M)
IFE ITS,	SKIPN	MULTSG
	 JRST	CALLS		; GO TO SR
IFE ITS,[
CALLSX:	HRLI	C,FSEG
	JRST	CALLS
]
ACHECK:	CAIE	A,TATOM		; RSUBR CALLING THROUGH REFERENCE ATOM ?
	JRST	DOAPP3		; TRY APPLYING IT
	MOVE	A,(C)
	MOVE	B,(C)+1
	PUSHJ	P,IGVAL
	HRRZ	C,UUOLOC	; REGOBBLE POINTER TO SLOT
	GETYP	0,A		; GET TYPE
	CAIN	0,TUNBOUND
	JRST	TRYLCL
SAVEIT:	CAIE	0,TRSUBR
	CAIN	0,TENTER
	JRST	SAVEI1		; WINNER
	CAIE	0,TSUBR
	CAIN	0,TFSUBR
	JRST	SUBRIT
	JRST	BADVAL		; SOMETHING STRANGE
SAVEI1:	CAMGE	C,PURTOP	; SKIP IF PURE RSUBR VECTOR (NEVER LINKED)
	SKIPE	NOLINK
	JRST	.+3
	MOVEM	A,(C)		; CLOBBER NEW VALUE
	MOVEM	B,(C)+1
	CAIN	0,TENTER
	JRST	ENTRIT		; HACK ENTRY TO SUB RSUBR
	MOVE	R,B		; SETUP R
	JRST	CALLR0		; GO FINISH THE RSUBR CALL

ENTRIT:	MOVE	C,B
	JRST	ECHCK3

SUBRIT:	CAMGE	C,PURBOT
	SKIPE	NOLINK
	JRST	.+3
	MOVEM	A,(C)
	MOVEM	B,1(C)
	HRRM	B,FSAV+1(TB)	; FIXUP THE PROPER FSAV
	MOVEI	C,(B)
IFN ITS,	JRST	CALLS		; GO FINISH THE SUBR CALL
IFE ITS,	JRST	CALLSX

TRYLCL:	MOVE	A,(C)
	MOVE	B,(C)+1
	PUSHJ	P,ILVAL
	GETYP	0,A
	CAIE	0,TUNBOUND
	JRST	SAVEIT
	SKIPA	D,EQUOTE UNBOUND-VARIABLE
BADVAL:	MOVEI	D,0
ERCALX:
IFN ITS,[
	AOBJP	TB,.+1		; MAKE TB A LIGIT FRAME PNTR
]
IFE ITS,[
	AOBJP	TB,MCHK5
]
MCHK6:	MOVEI	E,CALLER
	HRRM	E,FSAV(TB)	; SET A WINNING FSAV
	HRRZ	C,UUOLOC	; REGOBBLE POINTER TO SLOT
	JUMPE	D,DOAPPL
	PUSH	TP,$TATOM
	PUSH	TP,D
	PUSH	TP,(C)
	PUSH	TP,(C)+1
	PUSH	TP,$TATOM
	PUSH	TP,IMQUOTE CALLER
	MCALL	3,ERROR
	GETYP	0,A
	MOVEI	C,-1
	SOJA	TB,SAVEIT

BENTRY:	MOVE	D,EQUOTE BAD-ENTRY-BLOCK
	JRST	ERCALX

IFE ITS,[
MCHK5:	SKIPN	MULTSG
	 JRST	MCHK6
	HRLI	TB,400000	; KEEP TB NEGATIVE
	JRST	MCHK6
]	


;HANDLER FOR CALL WHERE SPECIFIES NUMBER OF ARGS

DACALL":
	LDB	C,[270400,,UUOLOC]	; GOBBLE THE AC LOCN INTO C
	EXCH	C,SAVEC		; C TO SAVE LOC RESTORE C
	MOVE	C,@SAVEC	; C NOW HAS NUMBER OF ARGS
	MOVEI	D,0		; FLAG NOT E CALL
	JRST	COMCAL		; JOIN MCALL

; CALL TO ENTRY FROM EVAL (LIKE ACALL)

DECALL:		LDB	C,[270400,,UUOLOC]	; GET NAME OF AC
	EXCH	C,SAVEC		; STORE NAME
	MOVE	C,@SAVEC	; C NOW HAS NUM OF ARGS
	MOVEI	D,1		; FLAG THIS
	JRST	COMCAL

;HANDLE OVERFLOW IN THE TP

TPLOSE:	PUSHJ	P,TPOVFL
	JRST	CALDON

; RSUBR HAS POSSIBLY BEEN REPLACED BY A FUNCTION OR WHATEVER, DO AN APPLY

DOAPPL:	PUSH	TP,A		; PUSH THE THING TO APPLY
	PUSH	TP,B
	MOVEI	A,1
DOAPP2:	JUMPGE	AB,DOAPP1	; ARGS DONE

	PUSH	TP,(AB)
	PUSH	TP,1(AB)
	ADD	AB,C%22
	AOJA	A,DOAPP2

DOAPP1:	ACALL	A,APPLY		; APPLY THE LOSER
	JRST	FINIS

DOAPP3:	MOVE	A,(C)		; GET VAL
	MOVE	B,1(C)
	JRST	BADVAL		; GET SETUP FOR APPLY CALL

; ENTRY TO BUILD A FRAME (USED BY SOME COMPILED PROG/REPEAT)

BFRAME:	SKIPN	SAVM
	HRLI	A,400000+M	; RELATIVIZE PC
	MOVEM	A,PCSAV(TB)	; CLOBBER PC IN
	MOVEM	TP,TPSAV(TB)	; SAVE STATE
	MOVE	SP,SPSTOR+1
	MOVEM	SP,SPSAV(TB)
	ADD	TP,[FRAMLN,,FRAMLN]
	SKIPL	TP
	PUSHJ	TPOVFL	; HACK BLOWN PDL
	MOVSI	A,TCBLK		; FUNNY FRAME
	HRRI	A,(R)
	MOVEM	A,FSAV+1(TP)	; CLOBBER
	MOVEM	TB,OTBSAV+1(TP)
	MOVEM	AB,ABSAV+1(TP)
	POP	P,A		; RET ADDR TO A
	MOVEM	P,PSAV(TB)
	HRRI	TB,(TP)
IFN ITS,	AOBJN	TB,.+1
IFE ITS,	AOBJP	TB,.+2
	JRST	(A)

IFE ITS,[
	SKIPN	MULTSG
	 JRST	(A)
	HRLI	TB,400000	; KEEP TB NEGATIVE
	JRST	(A)
]	

;SUBROUTINE TERMINATION CODE (NOT A UUO BUT HERE FOR COMPLETENENSS)

FINIS:
CNTIN1:	HRRZS	C,OTBSAV(TB)	; RESTORE BASE
	HRRI	TB,(C)
CONTIN:	MOVE	TP,TPSAV(TB)	; START HERE FOR FUNNY RESTART
	MOVE	P,PSAV(TB)
	MOVE	SP,SPSTOR+1
	CAME	SP,SPSAV(TB)	; ANY RESTORATION NEEDED
	PUSHJ	P,SPECSTO	; YES, GO UNRAVEL THE WORLDS BINDINGS
	MOVE	AB,ABSAV(TB)	; AND GET OLD ARG POINTER
	HRRZ	C,FSAV(TB)	; CHECK FOR RSUBR
	MOVEI	M,0		; UNSETUP M FOR GC WINNAGE
	CAILE	C,HIBOT		; SKIP IF ANY FLAVOR OF RSUBR
IFN ITS,	JRST	@PCSAV(TB)	; AND RETURN
IFE ITS,	JRST	MRET
	GETYP	0,(C)		; RETURN TO MAIN OR SUB ENTRY?
	CAIN	0,TCODE
	JRST	.+3
	CAIE	0,TPCODE
	JRST	FINIS1
	MOVS	R,(C)
	HRRI	R,(C)		; RESET R
	SKIPL	M,1(R)		; GET LOC OF REAL SUBR
	JRST	FINIS2

;HERE TO RETURN TO NBIN

RETNBI:	HLRZ	0,PCSAV(TB)	; GET FUNNY STUFF
	JUMPN	0,@PCSAV(TB)
	MOVEM	M,SAVM
	MOVEI	M,0
	JRST	@PCSAV(TB)

FINIS1:	CAIE	0,TRSUBR
	JRST	FINISA		; MAY HAVE BEEN PUT BACK TO ATOM
	MOVE	R,1(C)
FINIS9:	SKIPGE	M,1(R)
	JRST	RETNBI

FINIS2:	MOVEI	C,(M)		; COMPUTE REAL M FOR PURE RSUBR
	HLRS	M
	ADD	M,PURVEC+1
	SKIPN	M,1(M)		; SKIP IF LOADED
	JRST	FINIS3
	ADDI	M,(C)		; POINT TO SUB PART
PCREST:	HLRZ	0,PCSAV(TB)
IFN ITS,	JUMPN	@PCSAV(TB)
IFE ITS,[
	JUMPE	0,NOMULT
	SKIPN	MULTSG
	 JRST	NOMULT
	HRRZ	G,PCSAV(TB)
	CAML	G,PURBOT
	 JRST	MRET
	ADD	G,M
	TLZ	G,777400
	MOVEI	F,0
	XJRST	F
NOMULT:	JUMPN	0,MRET
]
	MOVEM	M,SAVM
	MOVEI	M,0
IFN ITS,	JRST	@PCSAV(TB)
IFE ITS,[
MRET:	SKIPN	MULTSG
	 JRST	@PCSAV(TB)
	MOVE	D,PCSAV(TB)
	HRLI	D,FSEG
	MOVEI	C,0
	XJRST	C
]

FINIS3:	PUSH	TP,A
	PUSH	TP,B
	HLRZ	A,1(R)		; RELOAD IT
	PUSHJ	P,PLOAD
	JRST	PCANT
	POP	TP,B
	POP	TP,A
	MOVE	M,1(R)
	JRST	FINIS2

FINISA:	CAIE	0,TATOM
	JRST	BADENT
	PUSH	TP,A
	PUSH	TP,B
	PUSH	TP,$TENTER
	HRL	C,(C)
	PUSH	TP,C
	MOVE	B,1(C)		; GET ATOM
	PUSHJ	P,IGVAL		; GET VAL
	GETYP	0,A
	CAIE	0,TRSUBR
	JRST	BADENT
	HRRZ	C,(TP)
	MOVE	R,B
	CAMLE	C,PURTOP	; SKIP IF CAN LINK UP
	JRST	.+3
	HLLM	A,(C)
	MOVEM	B,1(C)
	MOVE	A,-3(TP)
	MOVE	B,-2(TP)
	SUB	TP,C%44
	JRST	FINIS9

BADENT:	ERRUUO	EQUOTE RSUBR-ENTRY-UNLINKED

PCANT1:	ADD	TB,[1,,]
PCANT:	ERRUUO	EQUOTE PURE-LOAD-FAILURE
	
REPEAT 0,[
BCKTR1:	PUSH	TP,A		; SAVE VALUE TO BE RETURNED
	PUSH	TP,B		; SAVE FRAME ON PP
	PUSHJ	P,BCKTRK
	POP	TP,B
	POP	TP,A
	JRST	CNTIN1
]

; SUBR TO ENABLE AND DISABLE LINKING OF RSUBRS AT RUN TIME

MFUNCTION %RLINK,SUBR,[RSUBR-LINK]

	ENTRY

	HRROI	E,NOLINK
	JRST	FLGSET

;HANDLER FOR DEBUGGING CALL TO PRINT

DODP":
	PUSH	P,0
	MOVSI	0,7777400
	ANDCAM	0,UUOLOC
	PUSH	TP, @UUOLOC
	AOS	UUOLOC
	PUSH	TP,@UUOLOC
	PUSH	P,A
	PUSH	P,B
	PUSH	P,SAVEC
	PUSH	P,D
	PUSH	P,E
	PUSH	P,PVP
	PUSH	P,TVP
	PUSH	P,SP
	PUSH	P,UUOLOC
	PUSH	P,UUOH
	MCALL	1,PRINT
	POP	P,UUOH
	POP	P,UUOLOC
	POP	P,SP
	POP	P,TVP
	POP	P,PVP
	POP	P,E
	POP	P,D
	POP	P,C
	POP	P,B
	POP	P,A
	POP	P,0
	JRST	UUOH


DFATAL:
IFE ITS,[
	MOVEM	A,20
	HRRO	A,UUOLOC
	ESOUT
	HALTF
	MOVE	A,20
	MOVE	C,SAVEC
	JRST	@UUOH
]
REPEAT 0,[
; QUICK CALL HANDLER

DQCALL:	GETYP	C,@40		; SEE IF THIS GUY IS A QRSUBR OR QENT
	CAIN	C,TQENT
	JRST	DQCALE
	CAIN	C,TQRSUB
	JRST	DQCALR

; NOT A QENT OR QRSUBR, MAYBE AN ATOM THAT LINKS TO ONE

	SKIPN	NOLINK
	CAIE	C,TATOM		; SKIP IF ATOM
	JRST	DMCALL		; PRETEND TO BE AN MCALL

	MOVE	C,UUOH		; GET PC OF CALL
	SUBI	C,(M)		; RELATIVIZE
	PUSH	P,C		; AND SAVE
	LDB	C,[270400,,40]	; GET # OF ARGS
	PUSH	P,C
	HRRZ	C,40		; POINT TO RSUBR SLOT
	MOVE	B,1(C)		; GET ATOM
	SUBI	C,(R)		; RELATIVIZE IT
	HRLI	C,(C)
	ADD	C,R		; C IS NOW A VECTOR POINTER
	PUSH	TP,$TVEC
	PUSH	TP,C
	PUSH	TP,$TATOM
	PUSH	TP,B
	PUSHJ	P,IGVAL		; SEE IF IT HAS A VALUE
	GETYP	0,A		; IS IT A WINNER
	CAIE	0,TUNBOU
	JRST	DQCAL2
	MOVE	B,(TP)
	PUSHJ	P,ILVAL		; LOCAL?
	GETYP	0,A
	CAIE	0,TUNBOU
	JRST	DQCAL2		; MAY BE A WINNER

	PUSH	TP,$TATOM
	PUSH	TP,EQUOTE UNBOUND-VARIABLE
	PUSH	TP,$TATOM
	PUSH	TP,-3(TP)
	PUSH	TP,$TATOM
	PUSH	TP,IMQUOTE CALLER
	MCALL	3,ERROR
	GETYP	0,A
DQCAL2:	PUSH	TP,$TENTE		; IN CASE RSUBR ENTRY
	PUSH	TP,C%0
	CAIN	0,TRSUBR		; RSUBR?
	JRST	DQRSB		; YES, WIN
	CAIN	0,TENTER
	JRST	DQENT

DQMCAL:	HRRZ	C,-6(TP)	; PRETEND WE WERE AN MCALL
	HRRM	C,40
	POP	P,C
	DPB	C,[270400,,40]
	POP	P,C
	ADDI	C,(M)		; AND PC
	MOVEM	C,UUOH
	SUB	TP,[10,,10]
	JRST	DMCALL		; FALL INTO MCALL CODE

DQENT:	MOVEM	B,(TP)		; SAVE IT
	GETYP	0,(B)		; LINKED UP?
	MOVE	B,1(B)
	CAIN	0,TRSUBR
	JRST	DQENT1
DQENT2:	CAIE	0,TATOM		; BETTER BE ATOM
	JRST	BENTRY
	PUSHJ	P,IGVAL		; TRY TO LINK IT UP
	GETYP	0,A
	CAIE	0,TRSUBR
	JRST	BENTRY		; LOSER!
	MOVE	C,(TP)
	HLLM	A,(C)
	MOVEM	B,1(C)

DQENT1:	
DQRSB:	PUSH	TP,$TRSUBR
	PUSH	TP,B

	PUSH	TP,$TUVEC
	PUSH	TP,M

	SKIPL	M,1(B)
	PUSHJ	P,DQCALQ	; MAP ONE IN

	MOVEI	E,0		; GET OFFSET
	SKIPL	1(B)
	HLRZ	E,1(B)
	HLRE	B,M		; FIND END OF CODE VECTOR
	SUBM	M,B
	MOVE	M,(TP)
	SUB	TP,C%22
	HLRZ	A,-1(B)		; GET LENGTH OF ENTRY VECTOR
	HRRZ	C,-1(B)		; GET LENGTH OF DDT SYMBOL TABLE
	ADDI	C,(A)		; TOTAL LENGTH OF RANDOM CRUFT AT THE END OF CODE
	SUBI	B,1(C)		; POINT TO FIRST ELEMENT IN ENTRY VECTOR

SL2:	HRRZ	D,(B)
	CAIL	D,(E)		; IN RANGE?
	JRST	SL1
	ADDI	B,1
	SOJG	A,SL2
	JRST	DQMCAL

SL1:	HLRE	D,(B)		; GET NEXT
	JUMPL	D,DQMCAL
	CAMN	D,(P)
	JRST	.+4
	ADDI	B,1
	SOJG	A,.-4
	JRST	DQMCAL

	HRRZ	C,(B)		; GET OFFSET
	MOVE	R,(TP)		; SETUP R
	SKIPN	B,-2(TP)	; SKIP IF RSUBR ENTRY
	JRST	DQRSB1

	ADD	C,2(B)
	HRLI	C,TQENT
	JRST	DQMUNG

DQRSB1:	MOVE	B,(TP)
	HRLI	C,TQRSUB

DQMUNG:	HRRZ	D,-6(TP)	; GET CALLING RVECTOR
	CAILE	D,@PURTOP	; SMASHABLE?
	JRST	DQLOSS		; NO LOSE

	MOVEM	C,(D)		; SMASH
	MOVEM	B,1(D)

DQLOSS:	SUB	P,C%11
	POP	P,E		; RESTORE PC
	ADDI	E,(M)
	MOVEM	E,UUOH
	SUB	TP,[10,,10]
	MOVEI	E,C
	JRST	DQCAL1

DQCALE:	MOVE	E,40
	MOVE	B,1(E)		; GET RSUBR ENTRY
	MOVE	R,1(B)
	JRST	DQCAL1

DQCALR:	MOVE	E,40
	MOVE	B,1(E)
	MOVE	R,B

DQCAL1:	HRRZ	E,(E)
	HRRZ	C,RSTACK(PVP)
	HRLI	C,(C)
	ADD	C,RSTACK+1(PVP)
	JUMPGE	C,QCOPY
	HRRZ	A,FSAV(TB)
	HRL	A,(A)
	MOVEM	A,(C)		; SAVE IT
	AOS	C,RSTACK(PVP)
	HRRM	B,FSAV(TB)	; FOR FUTURE MCALLS
	HRLI	C,-1(C)
	HRR	C,UUOH
	SUBI	C,(M)		; RELATIVIZE
	PUSH	P,C		; SAVE BOTH
	SKIPL	M,1(R)		; MAYBE LINK UP?
	PUSHJ	P,DQCALP
	ADDI	E,1(M)
	JRST	(E)		; GO

DQCALP:	MOVE	B,R
DQCALQ:	HLRS	M		; GET VECTOR OFFSET IN BOTH HALVES
	ADD	M,PURVEC+1	; GET IT
	SKIPL	M
	FATAL	LOSING PURE RSUBR POINTER
	SKIPE	M,1(M)
	POPJ	P,

DQCLP1:	PUSH	TP,$TRSUBR
	PUSH	TP,B
	PUSH	P,E
	HLRZ	A,1(B)		; SET UP TO CALL LOADER
	PUSHJ	P,PLOAD		; LOAD IT
	JRST	PCANT
	POP	P,E
	MOVE	M,B		; GET LOCATION
	MOVE	B,(TP)
	SUB	TP,C%22
	POPJ	P,

QCOPY:	PUSH	TP,$TVEC
	PUSH	TP,B
	HRRZ	C,UUOH
	SUBI	C,(M)
	PUSH	P,C
	PUSH	P,E
	HLRE	A,RSTACK+1(PVP)
	MOVNS	A
	ADDI	A,100
	PUSHJ	P,IBLOCK	; GET BLOCK
	MOVEI	A,.VECT.+TRSUBR
	HLRE	C,B
	SUBM	B,C
	MOVEM	A,(C)
	HRLZ	A,RSTACK+1(PVP)
	JUMPE	A,.+3
	HRRI	A,(B)
	BLT	A,-101(C)	; COPY IT
	MOVEM	B,RSTACK+1(PVP)
	MOVE	B,(TP)
	SUB	TP,C%22
	POP	P,E
	POP	P,C
	ADDI	C,(M)
	HRRM	C,UUOH
	JRST	DQCAL1
	
QMPOPJ:	SKIPL	E,(P)
	JRST	QFINIS
	SUBM	M,(P)
	POPJ	P,

QFINIS:	POP	P,D
	HLRZS	D
	HRRM	D,RSTACK(PVP)
	ADD	D,RSTACK+1(PVP)
	MOVE	R,(D)		; GET R OR WHATEVER
	HRRM	R,FSAV(TB)
	GETYP	0,(R)		; TYPE
	CAIN	0,TRSUBR	; RSUBR?
	MOVE	R,1(R)
	SKIPL	M,1(R)	; RSUBR IN CORE ETC
	JRST	QRLD

QRLD2:	ADDI	E,(M)
	JRST	(E)

QRLD:	HLRS	M
	ADD	M,PURVEC+1
	SKIPE	M,1(M)		; SKIP IF LOADED
	JRST	QRLD2
	PUSH	TP,A
	PUSH	TP,B
	HLRZ	A,1(R)		; RELOAD IT
	PUSHJ	P,PLOAD
	JRST	PCANT
	POP	TP,B
	POP	TP,A
	MOVE	M,1(R)
	JRST	QRLD2

]
; THIS IS A UUO TO CALL ERROR WITH ONE ARGUMENT

DOERR:	PUSH	P,UUOH
	PUSH	TP,$TATOM
	MOVSI	0,7777400
	ANDCAM	0,UUOLOC
	PUSH	TP,@UUOLOC
	JRST	CALER1

; ROUTINE TO DO AN RCALL FOR SUBRIFIED GOODIES

RMCALL:	MOVEM	M,SAVM				; SAVE M
	SUBM	M,(P)
	MOVEI	M,0
	PUSHJ	P,@0
	MOVE	M,SAVM
	SETZM	SAVM
	SUBM	M,(P)
	POPJ	P,
	

; ROUTINE USED BY COMPILED CODE TO SAVE ACS CALL AN INTERRUPT AND RESTORE ACS.
; THIS UUO TAKES A LOCATION FROM WHICH TO FIND A DESCRIPTION OF HOW ACS ARE TO
; BE SAVED.
; .SAVAC	LOC
; LOC POINTS TO A BLOCK WHICH CAN BE ONE OR MORE WORDS LONG DEPENDING ON BOTH
; THE NUMBER OF SCRATCH AC'S (CURRENTLY 5) AND THE NUMBER OF AC'S CONTAINING
; TEMPLATE TYPES.
; THE FIRST PART OF THE BLOCK CONTAINS THE AC DECRIPTIONS.  EACH AC IS DESCRIBED
; BY A SIX BIT FIELD WITH THE EXCEPTION OF AC'S CONTAINING TEMPLATES.
; THE SIX BIT FIELD CAN BE
; 
; 0		EITHER A TYPE WORD OR NOTHING
; 1  ->  8	THE NUMBER OF THE AC CONTAINING THE TYPE
; 9  ->  62	THE SAT OF THE THING CONTAINED IN THE AC (+ 8)
; 63		A TEMPLATE LOOK AT THE BLOCK AFTER TO FIND A POINTER TO THE TYPE WORD
;
; TEMPLATE DESCRIPTIONS ARE FOUND AFTER THE AC DESCRIPTION BLOCK. THESE ARE FOUND
; IN SUCESSIVE WORDS CONTAINING POINTERS INTO THE R VECTOR

NOACS==10
TMPPTR==2

ONOACS==5
OTMPPT==1

DLSAVA:	PUSH	P,[SETZ NOACS]
	PUSH	P,[SETZ TMPPTR]
	JRST	DSAVA1

DSAVAC:	PUSH	P,[SETZ ONOACS]
	PUSH	P,[SETZ OTMPPT]
DSAVA1:
IFN ITS,	MOVE	0,UUOH		; GET PC
IFE ITS,[
	MOVE	0,UUOH
	SKIPE	MULTSG
	 MOVE	0,MLTPC
	PUSH	P,0
	ANDI	0,-1
	PUSH	P,UUOLOC	; SAVE UUO
	CAMG	0,PURTOP
	CAMGE	0,VECBOT
	JRST	DONREL
	SUBI	0,(M)		; M IS BASE REG
IFN ITS,	TLO	0,M		; INDEX IT OFF M
IFE ITS,[
	HRLI	0,400000+M
]
	MOVEM	0,-1(P)		; AND RESTORE TO STACK
;	MOVE	0,UUOLOC	; GET REL POINTER TO TBL - REDUNDANT
;	MOVEM	0,(P)		; AND SAVE IT - REDUNDANT PTR ALREADY PUSHED
DONREL:	MOVE	C,SAVEC
	MOVE	0,[A,,ACSAV]
	BLT	0,ACSAV+NOACS-1
	HRRZ	0,-3(P)			; NUMBER OF ACS
;	MOVE	A,[440620,,UUOLOC]	; BYTE POINTER INDIRECTED TO 40
IFN ITS,[
	MOVE	A,UUOLOC		; GET THE INSTRUCTION
	HRLI	A,440640		; OR IN THE BYTE POINTER
]
IFE ITS,[
	MOVSI	A,440600+B		; OR IN THE BYTE POINTER
	SKIPN	MULTSG
	 HRRZ	B,UUOLOC
	SKIPE	MULTSG
	 MOVE	B,MLTEA
]
	MOVE	D,-2(P)			; POINTER TO TEMPLATE BLOCK
IFN ITS,[
	MOVSI	C,7777400
	ANDCAM	C,UUOLOC
	ADD	D,UUOLOC	; GET TO BLOCK
]
IFE ITS,[
	SKIPE	MULTSG
	 JRST	XXXYYY
	MOVSI	C,7777400
	ANDCAM	C,UUOLOC
	ADD	D,UUOLOC
	CAIA

XXXYYY:	ADD	D,MLTEA
]
	HRROI	C,1
LOPSAV:	ILDB	E,A			; GET A DESCRIPTOR
	JUMPE	E,NOAC1			; ZERO==TYPE WORD
	CAIE	E,77			; IF 63. THEN TEMPLATE HANDLE SPECIALLY
	JRST	NOTEM			; NOT A TEMPLATE
	PUSH	TP,@(D)			; IT IS A TEMPLATE POINTER SO PUSH TYPE
	ADDI	D,1			; AOS B
LOPPUS:	PUSH	TP,ACSAV-1(C)		; PUSH AC
LPSVDN:	ADDI	C,1
	SOJG	0,LOPSAV		; LOOP BACK
	MOVE	0,[ACSAV,,A]
	BLT	0,NOACS
	JSR	LCKINT			; GO INTERRUPT
	HRRZ	B,-3(P)			; NUMBER OF ACS
LOPPOP:	POP	TP,ACSAV-1(B)
LOPBAR:	SUB	TP,C%11
LOPFOO:	SOJG	B,LOPPOP
	JUMPE	R,LOPBLT		; OK, NOT RSUBR
	SKIPL	1(R)		; NOT PURE RSUBR
	 SKIPN	MULTSG
	  JRST	LOPBLT

	MOVE	B,M
	TLZ	B,77740
	MOVEI	A,0
	HRRI	B,LOPBLT
	XJRST	A

LOPBLT:	MOVE	0,[ACSAV,,A]
	BLT	0,@-3(P)		; RESTORE AC'S
	MOVE	0,-1(P)
	SUB	P,C%44		; RETURN ADDRESS, (M)
	JRST	@0

NOTEM:	CAILE	E,8.			; SKIP IF AC IS TO BE PUSHED
	JRST	NOAC
IFE ITS,	TLO	E,400000	; MAKE LOCAL INDEX	
	PUSH	TP,ACSAV-1(E)
	JRST	LOPPUS			; FINISH PUSHING
NOAC:	SUBI	E,8			; COMPENSATE FOR ADDED AMOUNT
NOAC1:
IFE ITS,	TLO	E,400000	; MAKE LOCAL INDEX	
	MOVE	E,@STBL(E)
	HLRE	F,E			; GET NEGATIVE
	SUB	E,F
	HRLZ	E,(E)			; GET TYPE CODE 
	TLZ	E,400000+<0,,<-1>#<TYPMSK>>		; KILL SIGN BIT
	PUSH	TP,E			; PUSH TYPE
	JRST	LOPPUS			; FINISH PUSHING

FMPOPJ:	MOVE	TP,FRM
	MOVE	FRM,(TP)
	HRLS	C,-1(TP)
	SUB	TP,C
	SUBM	M,(P)
	POPJ	P,


NFPOPJ:	MOVE	TP,FRM			; CLEAR OFF FRM
	MOVE	FRM,(TP)
	HRLS	C,-1(TP)
	SUB	TP,C

; THIS WEIRD PIECE OF CODE IS USED TO DO AN MPOPJ IN SUBRIFIED CODE THAT
; DOES A SKIP/NON SKIP RETURN.     

NSPOPJ:	EXCH	(P)
	TLNE	37
	MOVNS	0
	EXCH	(P)
	POPJ	P,


DPOPUN:	PUSHJ	P,POPUNW
	JRST	@UUOH

; HERE FOR MULTI SEG SIMULATION STUFF

DMOVE:	MOVSI	C,(MOVE)
	JRST	MEX
DHRRM:	MOVSI	C,(HRRM)
	JRST	MEX
DHRLM:	MOVSI	C,(HRLM)
	JRST	MEX
DMOVEM:	MOVSI	C,(MOVEM)
	JRST	MEX
DHLRZ:	MOVSI	C,(HLRZ)
	JRST	MEX
DSETZM:	MOVSI	C,(SETZM)
	JRST	MEX
DXBLT:	MOVE	C,[123000,,[020000,,]]

MEX:	MOVEM	A,20
	MOVE	A,UUOH			; GET LOC OF INS
	MOVE	A,-1(A)
	TLZ	A,777000
	IOR	A,C
	XJRST	.+1
		0
		FSEG,,.+1
	MOVE	C,SAVEC
	EXCH	A,20
	XCT	20
	XJRST	.+1
		0
		.+1
	JRST	@UUOH


IMPURE

SAVM:	0					; SAVED M FOR SUBRIFY HACKERS

ACSAV:	BLOCK	NOACS


PURE

END