--- /dev/null
+TITLE UUO HANDLER FOR MUDDLE AND HYDRA\r
+RELOCATABLE\r
+.INSRT MUDDLE >\r
+\r
+;GLOBALS FOR THIS PROGRAM\r
+\r
+.GLOBAL BACKTR,PRINT,PDLBUF,TPGROW,SPECSTO,TIMOUT,AGC,VECBOT,VECTOP\r
+.GLOBAL BCKTRK,TPOVFL,.MONWR,.MONRD,.MONEX,MAKACT,IGVAL,ILVAL,BFRAME\r
+.GLOBAL PURTOP,PURBOT,PLOAD,PURVEC,STOSTR,MSGTYP,UUOH,ILLUUO\r
+\r
+;SETUP UUO DISPATCH TABLE HERE\r
+\r
+UUOTBL: ILLUUO\r
+\r
+IRP UUOS,,[[DP,DODP],[.MCALL,DMCALL],[.ACALL,DACALL],[.ECALL,DECALL],[.FATAL,DFATAL]]\r
+UUFOO==.IRPCNT+1\r
+IRP UUO,DISP,[UUOS]\r
+.GLOBAL UUO\r
+UUO=UUFOO_33\r
+DISP\r
+.ISTOP\r
+TERMIN\r
+TERMIN\r
+\r
+REPEAT 100-UUFOO,[ILLUUO\r
+]\r
+\r
+\r
+RMT [\r
+IMPURE\r
+\r
+UUOH:\r
+LOC 41\r
+ JSR UUOH\r
+LOC UUOH\r
+ 0\r
+ JRST UUOPUR ;GO TO PURE CODE FOR THIS\r
+\r
+SAVEC: 0 ; USED TO SAVE WORKING AC\r
+NOLINK: 0\r
+\r
+PURE\r
+]\r
+\r
+;SEPARATION OF PURE FROM IMPURE CODE HERE\r
+\r
+UUOPUR: MOVEM C,SAVEC ; SAVE AC\r
+ LDB C,[330900,,40]\r
+ JRST @UUOTBL(C) ;DISPATCH BASED ON THE UUO\r
+\r
+\r
+\r
+ILLUUO: FATAL ILLEGAL UUO\r
+\f;CALL HANDLER\r
+\r
+MQUOTE CALLER\r
+CALLER:\r
+\r
+DMCALL":\r
+ MOVEI D,0 ; FLAG NOT ENTRY CALL\r
+ LDB C,[270400,,40] ; GET AC FIELD OF UUO\r
+COMCAL: LSH C,1 ; TIMES 2\r
+ MOVN AB,C ; GET NEGATED # OF ARGS\r
+ HRLI C,(C) ; TO BOTH SIDES\r
+ SUBM TP,C ; NOW HAVE TP TO SAVE\r
+ MOVEM C,TPSAV(TB) ; SAVE IT\r
+ MOVSI AB,(AB) ; BUILD THE AB POINTER\r
+ HRRI AB,1(C) ; POINT TO ARGS\r
+ HRRZ C,UUOH ; GET PC OF CALL\r
+ CAMG C,PURTOP ; SKIP IF NOT IN GC SPACE\r
+ CAIGE C,STOSTR ; SKIP IF IN GC SPACE\r
+ JRST .+3\r
+ SUBI C,(M) ; RELATIVIZE THE PC\r
+ HRLI C,M ; FOR RETURNER TO WIN\r
+ MOVEM C,PCSAV(TB)\r
+ MOVEM SP,SPSAV(TB) ; SAVE BINDING GOODIE\r
+ MOVSI C,TENTRY ; SET UP ENTRY WORD\r
+ HRR C,40 ; POINT TO CALLED SR\r
+ ADD TP,[FRAMLN,,FRAMLN] ; ALLOCATE NEW FRAME\r
+ JUMPGE TP,TPLOSE\r
+CALDON: MOVEM C,FSAV+1(TP) ; CLOBBER THE FRAME\r
+ MOVEM TB,OTBSAV+1(TP)\r
+ MOVEM AB,ABSAV+1(TP) ; FRAME BUILT\r
+ MOVEM P,PSAV(TB)\r
+ HRRI TB,(TP) ; SETUP NEW TB\r
+ MOVEI C,(C)\r
+ MOVEI M,0 ; UNSETUP M FOR GC WINNAGE\r
+ CAMG C,VECTOP ; SKIP IF NOT RSUBR\r
+ CAMGE C,VECBOT ; SKIP IF RSUBR\r
+ JRST CALLS\r
+ GETYP A,(C) ; GET CONTENTS OF SLOT\r
+ JUMPN D,EVCALL ; EVAL CALLING ENTRY ?\r
+ CAIE A,TRSUBR ; RSUBR CALLING RSUBR ?\r
+ JRST RCHECK ; NO\r
+ MOVE R,(C)+1 ; YES, SETUP R\r
+CALLR0: HRRM R,FSAV+1(TB) ; FIXUP THE PROPER FSAV\r
+CALLR1: AOS E,2(R) ; COUNT THE CALLS\r
+ TRNN E,-1 ; SKIP IF OK\r
+ JRST COUNT1\r
+\r
+ SKIPL M,(R)+1 ; SETUP M\r
+ JRST SETUPM ; JUMP IF A PURE RSUBR IN QUESTION\r
+ AOBJP TB,.+1 ; GO TO CALLED RSUBR\r
+ INTGO ; CHECK FOR INTERRUPTS\r
+ JRST (M)\r
+\r
+COUNT1: SOS 2(R) ; UNDO OVERFLOW\r
+ HLLZS 2(R)\r
+ JRST CALLR1\r
+\r
+CALLS: AOBJP TB,.+1 ; GO TO CALLED SUBR\r
+ INTGO ; CHECK FOR INTERRUPTS\r
+ JRST @C\r
+\f\r
+; HERE TO HANDLE A PURE RSUBR (LOAD IF PUNTED OR OTHERWISE FLUSHED)\r
+\r
+SETUPM: MOVEI C,0 ; OFFSET (FOR MAIN ENTRIES)\r
+STUPM1: MOVEI D,(M) ; GET OFFSET INTO CODE\r
+ HLRS M ; GET VECTOR OFFSET IN BOTH HALVES\r
+ ADD M,PURVEC+1(TVP) ; GET IT\r
+ SKIPL M\r
+ FATAL LOSING PURE RSUBR POINTER\r
+ HLLM TB,2(M) ; MARK FOR LRU ALGORITHM\r
+ SKIPN M,1(M) ; POINT TO CORE IF LOADED\r
+ AOJA TB,STUPM2 ; GO LOAD IT\r
+STUPM3: ADDI M,(D) ; POINT TO REAL THING\r
+ HRLI C,M ; POINT TO START PC\r
+ AOBJP TB,.+1\r
+ INTGO\r
+ JRST @C ; GO TO IT\r
+\r
+STUPM2: HLRZ A,1(R) ; SET UP TO CALL LOADER\r
+ PUSH P,D\r
+ PUSH P,C\r
+ PUSHJ P,PLOAD ; LOAD IT\r
+ JRST PCANT1\r
+ POP P,C\r
+ POP P,D\r
+ MOVE M,B ; GET LOCATION\r
+ SOJA TB,STUPM3\r
+\r
+RCHECK: CAIN A,TPCODE ; PURE RSUBR?\r
+ JRST .+3\r
+ CAIE A,TCODE ; EVALUATOR CALLING RSUBR ?\r
+ JRST SCHECK ; NO\r
+ MOVS R,(C) ; YES, SETUP R\r
+ HRRI R,(C)\r
+ JRST CALLR1 ; GO FINISH THE RSUBR CALL\r
+\r
+\r
+SCHECK: CAIE A,TSUBR ; RSUBR CALLING SUBR AS REFERENCE ?\r
+ CAIN A,TFSUBR\r
+ SKIPA C,(C)+1 ; SKIP AND GET ROUTINE'S ADDRESS\r
+ JRST ECHECK\r
+ HRRM C,FSAV+1(TB) ; FIXUP THE PROPER FSAV\r
+ JRST CALLS ; GO FINISH THE SUBR CALL\r
+\r
+ECHECK: CAIE A,TENTER ; SKIP IF SUB ENTRY OF RSUBR\r
+ JRST ACHECK ; COULD BE EVAL CALLING ONE\r
+ MOVE C,1(C) ; POINT TO SUB ENTRY BLOCK\r
+ECHCK3: GETYP A,(C) ; SEE IF LINKED TO ITS MAIN ENTRY\r
+ MOVE B,1(C)\r
+ CAIN A,TRSUBR\r
+ JRST ECHCK2\r
+\r
+; CHECK IF CAN LINK ATOM\r
+\r
+ CAIE A,TATOM\r
+ JRST BENTRY ; LOSER , COMPLAIN\r
+ECHCK4: MOVE B,1(C) ; GET ATOM\r
+ PUSH TP,$TVEC\r
+ PUSH TP,C\r
+ PUSHJ P,IGVAL ; TRY GLOBAL VALUE\r
+ MOVE C,(TP)\r
+ SUB TP,[2,,2]\r
+ CAMN A,$TUNBOU\r
+ JRST BADVAL\r
+ CAME A,$TRSUBR ; IS IT A WINNER\r
+ JRST BENTRY\r
+ SKIPE NOLINK\r
+ JRST ECHCK2\r
+ HLLM A,(C) ; FIXUP LINKAGE\r
+ MOVEM B,1(C)\r
+ JRST ECHCK2\r
+\r
+EVCALL: CAIN A,TATOM ; EVAL CALLING ENTRY?\r
+ JRST ECHCK4 ; COULD BE MUST FIXUP\r
+ CAIE A,TRSUBR ; YES THIS IS ONE\r
+ JRST BENTRY\r
+ MOVE B,1(C)\r
+ECHCK2: MOVE R,B ; SET UP R\r
+ HRRM C,FSAV+1(TB) ; SET POINTER INTO FRAME\r
+ HRRZ C,2(C) ; FIND OFFSET INTO SAME\r
+ SKIPL M,1(R) ; POINT TO START OF RSUBR\r
+ JRST STUPM1 ; JUMP IF A LOSER\r
+ HRLI C,M\r
+ JRST CALLS ; GO TO SR\r
+\r
+ACHECK: CAIE A,TATOM ; RSUBR CALLING THROUGH REFERENCE ATOM ?\r
+ JRST DOAPP3 ; TRY APPLYING IT\r
+ MOVE A,(C)\r
+ MOVE B,(C)+1\r
+ PUSHJ P,IGVAL\r
+ HRRZ C,40 ; REGOBBLE POINTER TO SLOT\r
+ GETYP 0,A ; GET TYPE\r
+ CAIN 0,TUNBOUND\r
+ JRST TRYLCL\r
+SAVEIT: CAIE 0,TRSUBR\r
+ CAIN 0,TENTER\r
+ JRST SAVEI1 ; WINNER\r
+ CAIE 0,TSUBR\r
+ CAIN 0,TFSUBR\r
+ JRST SUBRIT\r
+ JRST BADVAL ; SOMETHING STRANGE\r
+SAVEI1: SKIPE NOLINK\r
+ JRST .+3\r
+ MOVEM A,(C) ; CLOBBER NEW VALUE\r
+ MOVEM B,(C)+1\r
+ CAIN 0,TENTER\r
+ JRST ENTRIT ; HACK ENTRY TO SUB RSUBR\r
+ MOVE R,B ; SETUP R\r
+ JRST CALLR0 ; GO FINISH THE RSUBR CALL\r
+\r
+ENTRIT: MOVE C,B\r
+ JRST ECHCK3\r
+\r
+SUBRIT: SKIPE NOLINK\r
+ JRST .+3\r
+ MOVEM A,(C)\r
+ MOVEM B,1(C)\r
+ HRRM B,FSAV+1(TB) ; FIXUP THE PROPER FSAV\r
+ MOVEI C,(B)\r
+ JRST CALLS ; GO FINISH THE SUBR CALL\r
+\r
+TRYLCL: MOVE A,(C)\r
+ MOVE B,(C)+1\r
+ PUSHJ P,ILVAL\r
+ GETYP 0,A\r
+ CAIE 0,TUNBOUND\r
+ JRST SAVEIT\r
+ SKIPA D,EQUOTE UNBOUND-VARIABLE\r
+BADVAL: MOVEI D,0\r
+ERCAL: AOBJP TB,.+1 ; MAKE TB A LIGIT FRAME PNTR\r
+ MOVEI E,CALLER\r
+ HRRM E,FSAV(TB) ; SET A WINNING FSAV\r
+ HRRZ C,40 ; REGOBBLE POINTER TO SLOT\r
+ JUMPE D,DOAPPL\r
+ SUBI C,(R) ; CALCULATE OFFSET\r
+ HRLS C\r
+ ADD C,R ; MAKE INTO REAL RSUBR POINTER\r
+ PUSH TP,$TRSUBR ; SAVE\r
+ PUSH TP,C\r
+ HRRZ C,40 ; REGOBBLE POINTER TO SLOT\r
+ PUSH TP,$TATOM\r
+ PUSH TP,D\r
+ PUSH TP,(C)\r
+ PUSH TP,(C)+1\r
+ PUSH TP,$TATOM\r
+ PUSH TP,MQUOTE CALLER\r
+ MCALL 3,ERROR\r
+ MOVE C,(TP) ; GET SAVED RSUBR POINTER\r
+ SUB TP,[2,,2] ; POP STACK\r
+ GETYP 0,A\r
+ HRRM C,40\r
+ SOJA TB,SAVEIT\r
+\r
+BENTRY: MOVE D,EQUOTE BAD-ENTRY-BLOCK\r
+ JRST ERCAL\r
+\r
+;HANDLER FOR CALL WHERE SPECIFIES NUMBER OF ARGS\r
+\r
+DACALL":\r
+ LDB C,[270400,,40] ; GOBBLE THE AC LOCN INTO C\r
+ EXCH C,SAVEC ; C TO SAVE LOC RESTORE C\r
+ MOVE C,@SAVEC ; C NOW HAS NUMBER OF ARGS\r
+ MOVEI D,0 ; FLAG NOT E CALL\r
+ JRST COMCAL ; JOIN MCALL\r
+\r
+; CALL TO ENTRY FROM EVAL (LIKE ACALL)\r
+\r
+DECALL: LDB C,[270400,,40] ; GET NAME OF AC\r
+ EXCH C,SAVEC ; STORE NAME\r
+ MOVE C,@SAVEC ; C NOW HAS NUM OF ARGS\r
+ MOVEI D,1 ; FLAG THIS\r
+ JRST COMCAL\r
+\r
+;HANDLE OVERFLOW IN THE TP\r
+\r
+TPLOSE: PUSHJ P,TPOVFL\r
+ JRST CALDON\r
+\r
+; RSUBR HAS POSSIBLY BEEN REPLACED BY A FUNCTION OR WHATEVER, DO AN APPLY\r
+\r
+DOAPPL: PUSH TP,A ; PUSH THE THING TO APPLY\r
+ PUSH TP,B\r
+ MOVEI A,1\r
+DOAPP2: JUMPGE AB,DOAPP1 ; ARGS DONE\r
+\r
+ PUSH TP,(AB)\r
+ PUSH TP,1(AB)\r
+ ADD AB,[2,,2]\r
+ AOJA A,DOAPP2\r
+\r
+DOAPP1: ACALL A,APPLY ; APPLY THE LOSER\r
+ JRST FINIS\r
+\r
+DOAPP3: MOVE A,(C) ; GET VAL\r
+ MOVE B,1(C)\r
+ JRST BADVAL ; GET SETUP FOR APPLY CALL\r
+\f\r
+; ENTRY TO BUILD A FRAME (USED BY SOME COMPILED PROG/REPEAT)\r
+\r
+BFRAME: HRLI A,M ; RELATIVIZE PC\r
+ MOVEM A,PCSAV(TB) ; CLOBBER PC IN\r
+ MOVEM TP,TPSAV(TB) ; SAVE STATE\r
+ MOVEM SP,SPSAV(TB)\r
+ ADD TP,[FRAMLN,,FRAMLN]\r
+ SKIPL TP\r
+ PUSHJ TPOVFL ; HACK BLOWN PDL\r
+ MOVSI A,TCBLK ; FUNNY FRAME\r
+ HRRI A,(R)\r
+ MOVEM A,FSAV+1(TP) ; CLOBBER\r
+ MOVEM TB,OTBSAV+1(TP)\r
+ MOVEM AB,ABSAV+1(TP)\r
+ POP P,A ; RET ADDR TO A\r
+ MOVEM P,PSAV(TB)\r
+ HRRI TB,(TP)\r
+ AOBJN TB,.+1\r
+ JRST (A)\r
+\f;SUBROUTINE TERMINATION CODE (NOT A UUO BUT HERE FOR COMPLETENENSS)\r
+\r
+FINIS:\r
+CNTIN1: HRRZS C,OTBSAV(TB) ; RESTORE BASE\r
+ HRRI TB,(C)\r
+CONTIN: MOVE TP,TPSAV(TB) ; START HERE FOR FUNNY RESTART\r
+ MOVE P,PSAV(TB)\r
+ CAME SP,SPSAV(TB) ; ANY RESTORATION NEEDED\r
+ PUSHJ P,SPECSTO ; YES, GO UNRAVEL THE WORLDS BINDINGS\r
+ MOVE AB,ABSAV(TB) ; AND GET OLD ARG POINTER\r
+ HRRZ C,FSAV(TB) ; CHECK FOR RSUBR\r
+ MOVEI M,0 ; UNSETUP M FOR GC WINNAGE\r
+ CAMG C,VECTOP\r
+ CAMGE C,VECBOT\r
+ JRST @PCSAV(TB) ; AND RETURN\r
+ GETYP 0,(C) ; RETURN TO MAIN OR SUB ENTRY?\r
+ CAIN 0,TCODE\r
+ JRST .+3\r
+ CAIE 0,TPCODE\r
+ JRST FINIS1\r
+ MOVS R,(C)\r
+ HRRI R,(C) ; RESET R\r
+ SKIPGE M,1(R) ; GET LOC OF REAL SUBR\r
+ JRST @PCSAV(TB)\r
+ JRST FINIS2\r
+\r
+FINIS1: CAIE 0,TRSUBR\r
+ JRST FINISA ; MAY HAVE BEEN PUT BACK TO ATOM\r
+ MOVE R,1(C)\r
+ SKIPGE M,1(R)\r
+ JRST @PCSAV(TB)\r
+\r
+FINIS2: MOVEI C,(M) ; COMPUTE REAL M FOR PURE RSUBR\r
+ HLRS M\r
+ ADD M,PURVEC+1(TVP)\r
+ SKIPN M,1(M) ; SKIP IF LOADED\r
+ JRST FINIS3\r
+ ADDI M,(C) ; POINT TO SUB PART\r
+ JRST @PCSAV(TB)\r
+\r
+FINIS3: PUSH TP,A\r
+ PUSH TP,B\r
+ HLRZ A,1(R) ; RELOAD IT\r
+ PUSHJ P,PLOAD\r
+ JRST PCANT\r
+ POP TP,B\r
+ POP TP,A\r
+ MOVE M,1(R)\r
+ JRST FINIS2\r
+\r
+FINISA: CAIE 0,TATOM\r
+ JRST BADENT\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ PUSH TP,$TENTER\r
+ HRL C,(C)\r
+ PUSH TP,C\r
+ MOVE B,1(C) ; GET ATOM\r
+ PUSHJ P,IGVAL ; GET VAL\r
+ GETYP 0,A\r
+ CAIE 0,TRSUBR\r
+ JRST BADENT\r
+ MOVE C,(TP)\r
+ HLLM A,(C)\r
+ MOVEM B,1(C)\r
+ MOVE A,-3(TP)\r
+ MOVE B,-2(TP)\r
+ SUB TP,[4,,4]\r
+ JRST FINIS1\r
+\r
+BADENT: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE RSUBR-ENTRY-UNLINKED\r
+ JRST CALER1\r
+\r
+PCANT1: ADD TB,[1,,]\r
+PCANT: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE PURE-LOAD-FAILURE\r
+ JRST CALER1\r
+ \r
+REPEAT 0,[\r
+BCKTR1: PUSH TP,A ; SAVE VALUE TO BE RETURNED\r
+ PUSH TP,B ; SAVE FRAME ON PP\r
+ PUSHJ P,BCKTRK\r
+ POP TP,B\r
+ POP TP,A\r
+ JRST CNTIN1\r
+]\r
+\f\r
+; SUBR TO ENABLE AND DISABLE LINKING OF RSUBRS AT RUN TIME\r
+\r
+MFUNCTION %RLINK,SUBR,[RSUBR-LINK]\r
+\r
+ ENTRY 1\r
+\r
+ GETYP 0,(AB)\r
+ SETZM NOLINK\r
+ CAIN 0,TFALSE\r
+ SETOM NOLINK\r
+ MOVE A,(AB)\r
+ MOVE B,1(AB)\r
+ JRST FINIS\r
+\r
+;HANDLER FOR DEBUGGING CALL TO PRINT\r
+\r
+DODP":\r
+ PUSH TP, @40\r
+ AOS 40\r
+ PUSH TP,@40\r
+ PUSH P,0\r
+ PUSH P,1\r
+ PUSH P,2\r
+ PUSH P,SAVEC\r
+ PUSH P,4\r
+ PUSH P,5\r
+ PUSH P,40\r
+ PUSH P,UUOH\r
+ MCALL 1,PRINT\r
+ POP P,UUOH\r
+ POP P,40\r
+ POP P,5\r
+ POP P,4\r
+ POP P,3\r
+ POP P,2\r
+ POP P,1\r
+ POP P,0\r
+ JRST 2,@UUOH\r
+\r
+\r
+DFATAL: MOVEM A,20\r
+ MOVEM B,21\r
+ MOVE B,40\r
+ HRLI B,440700\r
+ PUSHJ P,MSGTYP\r
+ JRST 4,.\r
+END\r
+\f\ 3\ 3\ 3
\ No newline at end of file
projects / pdp10-muddle.git / blobdiff