--- /dev/null
+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
+\f
+; 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
+]
+
+
+\f;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
+]
+
+
+\f
+; 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
+\f
+; 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)
+]
+
+\f;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
+]
+\f
+; 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,440640 ; OR IN THE BYTE POINTER
+ SKIPN MULTSG
+ HRR A,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
+\f
\ No newline at end of file
projects / pdp10-muddle.git / blobdiff