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

;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 PURTOP,PURBOT,PLOAD,PURVEC,STOSTR,MSGTYP,UUOH,ILLUUO

;SETUP UUO DISPATCH TABLE HERE

UUOTBL:	ILLUUO

IRP UUOS,,[[DP,DODP],[.MCALL,DMCALL],[.ACALL,DACALL],[.ECALL,DECALL],[.FATAL,DFATAL]]
UUFOO==.IRPCNT+1
IRP UUO,DISP,[UUOS]
.GLOBAL UUO
UUO=UUFOO_33
DISP
.ISTOP
TERMIN
TERMIN

REPEAT 100-UUFOO,[ILLUUO
]


RMT [
IMPURE

UUOH:
LOC 41
	JSR	UUOH
LOC UUOH
	0
	JRST	UUOPUR		;GO TO PURE CODE FOR THIS

SAVEC:	0			; USED TO SAVE WORKING AC
NOLINK:	0

PURE
]

;SEPARATION OF PURE FROM IMPURE CODE HERE

UUOPUR:	MOVEM	C,SAVEC		; SAVE AC
	LDB	C,[330900,,40]
	JRST	@UUOTBL(C)	;DISPATCH BASED ON THE UUO



ILLUUO:	FATAL ILLEGAL UUO
;CALL HANDLER

MQUOTE CALLER
CALLER:

DMCALL":
	MOVEI	D,0		; FLAG NOT ENTRY CALL
	LDB	C,[270400,,40]	; 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
	CAMG	C,PURTOP	; SKIP IF NOT IN GC SPACE
	CAIGE	C,STOSTR	; SKIP IF IN GC SPACE
	JRST	.+3
	SUBI	C,(M)		; RELATIVIZE THE PC
	HRLI	C,M		; FOR RETURNER TO WIN
	MOVEM	C,PCSAV(TB)
	MOVEM	SP,SPSAV(TB)	; SAVE BINDING GOODIE
	MOVSI	C,TENTRY	; SET UP ENTRY WORD
	HRR	C,40		; 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)
	MOVEI	M,0		; UNSETUP M FOR GC WINNAGE
	CAMG	C,VECTOP	; SKIP IF NOT RSUBR
	CAMGE	C,VECBOT	; 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:	AOS	E,2(R)		; COUNT THE CALLS
	TRNN	E,-1		; SKIP IF OK
	JRST	COUNT1

	SKIPL	M,(R)+1		; SETUP M
	JRST	SETUPM		; JUMP IF A PURE RSUBR IN QUESTION
	AOBJP	TB,.+1		; GO TO CALLED RSUBR
	INTGO			; CHECK FOR INTERRUPTS
	JRST	(M)

COUNT1:	SOS	2(R)		; UNDO OVERFLOW
	HLLZS	2(R)
	JRST	CALLR1

CALLS:	AOBJP	TB,.+1		; GO TO CALLED SUBR
	INTGO			; CHECK FOR INTERRUPTS
	JRST	@C

; 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(TVP)	; 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
	HRLI	C,M		; POINT TO START PC
	AOBJP	TB,.+1
	INTGO
	JRST	@C		; GO TO IT

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
	JRST	CALLS		; GO FINISH THE SUBR CALL

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
	MOVE	C,(TP)
	SUB	TP,[2,,2]
	CAMN	A,$TUNBOU
	JRST	BADVAL
	CAME	A,$TRSUBR	; IS IT A WINNER
	JRST	BENTRY
	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
	HRLI	C,M
	JRST	CALLS		; GO TO SR

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,40		; 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:	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:	SKIPE	NOLINK
	JRST	.+3
	MOVEM	A,(C)
	MOVEM	B,1(C)
	HRRM	B,FSAV+1(TB)	; FIXUP THE PROPER FSAV
	MOVEI	C,(B)
	JRST	CALLS		; GO FINISH THE SUBR CALL

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
ERCAL:	AOBJP	TB,.+1		; MAKE TB A LIGIT FRAME PNTR
	MOVEI	E,CALLER
	HRRM	E,FSAV(TB)	; SET A WINNING FSAV
	HRRZ	C,40		; REGOBBLE POINTER TO SLOT
	JUMPE	D,DOAPPL
	SUBI	C,(R)		; CALCULATE OFFSET
	HRLS	C
	ADD	C,R		; MAKE INTO REAL RSUBR POINTER
	PUSH	TP,$TRSUBR	; SAVE
	PUSH	TP,C
	HRRZ	C,40		; REGOBBLE POINTER TO SLOT
	PUSH	TP,$TATOM
	PUSH	TP,D
	PUSH	TP,(C)
	PUSH	TP,(C)+1
	PUSH	TP,$TATOM
	PUSH	TP,MQUOTE CALLER
	MCALL	3,ERROR
	MOVE	C,(TP)		; GET SAVED RSUBR POINTER
	SUB	TP,[2,,2]		; POP STACK
	GETYP	0,A
	HRRM	C,40
	SOJA	TB,SAVEIT

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

;HANDLER FOR CALL WHERE SPECIFIES NUMBER OF ARGS

DACALL":
	LDB	C,[270400,,40]	; 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,,40]	; 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,[2,,2]
	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:	HRLI	A,M		; RELATIVIZE PC
	MOVEM	A,PCSAV(TB)	; CLOBBER PC IN
	MOVEM	TP,TPSAV(TB)	; SAVE STATE
	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)
	AOBJN	TB,.+1
	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)
	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
	CAMG	C,VECTOP
	CAMGE	C,VECBOT
	JRST	@PCSAV(TB)	; AND RETURN
	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
	SKIPGE	M,1(R)		; GET LOC OF REAL SUBR
	JRST	@PCSAV(TB)
	JRST	FINIS2

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

FINIS2:	MOVEI	C,(M)		; COMPUTE REAL M FOR PURE RSUBR
	HLRS	M
	ADD	M,PURVEC+1(TVP)
	SKIPN	M,1(M)		; SKIP IF LOADED
	JRST	FINIS3
	ADDI	M,(C)		; POINT TO SUB PART
	JRST	@PCSAV(TB)

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
	MOVE	C,(TP)
	HLLM	A,(C)
	MOVEM	B,1(C)
	MOVE	A,-3(TP)
	MOVE	B,-2(TP)
	SUB	TP,[4,,4]
	JRST	FINIS1

BADENT:	PUSH	TP,$TATOM
	PUSH	TP,EQUOTE RSUBR-ENTRY-UNLINKED
	JRST	CALER1

PCANT1:	ADD	TB,[1,,]
PCANT:	PUSH	TP,$TATOM
	PUSH	TP,EQUOTE PURE-LOAD-FAILURE
	JRST	CALER1
	
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	1

	GETYP	0,(AB)
	SETZM	NOLINK
	CAIN	0,TFALSE
	SETOM	NOLINK
	MOVE	A,(AB)
	MOVE	B,1(AB)
	JRST	FINIS

;HANDLER FOR DEBUGGING CALL TO PRINT

DODP":
	PUSH	TP, @40
	AOS	40
	PUSH	TP,@40
	PUSH P,0
	PUSH P,1
	PUSH	P,2
	PUSH	P,SAVEC
	PUSH P,4
	PUSH P,5
	PUSH P,40
	PUSH	P,UUOH
	MCALL	1,PRINT
	POP	P,UUOH
	POP P,40
	POP P,5
	POP P,4
	POP P,3
	POP P,2
	POP P,1
	POP P,0
	JRST	2,@UUOH


DFATAL:	MOVEM	A,20
	MOVEM	B,21
	MOVE	B,40
	HRLI	B,440700
	PUSHJ	P,MSGTYP
	JRST	4,.
END