--- /dev/null
+TITLE MAIN LOOP AND GLOBALLY REFERENCED SUBROUTINES\r
+\r
+RELOCA\r
+\r
+.GLOBAL PATCH,TBINIT,PIDSTO,PROCID,PTIME,GCPDL,PBASE,TYPTOP,RERR,FRMSTK,EMERGE\r
+.GLOBAL PAT,PDLBUF,INTINT,START,SWAP,ICR,SPBASE,TPBASE,TPBAS,SAT,CURPRI,CHFINI\r
+.GLOBAL TOPLEVEL,INTOBL,INITIA,ERROBL,MAINPR,RESFUN,STATUS,TYPVEC,ROOT,TTICHN,TTOCHN\r
+.GLOBAL TTYOPE,MOPEN,MCLOSE,MIOT,ILVAL,MESS,ERROR,CHFRM,IGVAL,TYPBOT,ASOVEC\r
+.GLOBAL PRINT,PRIN1,PRINC,MUDSTR,VECBOT,CSTACK,IFALSE,TYPLOO,RCALL,SWAPIN,CTMPLT\r
+.GLOBAL IDPROC,CHFSWP,ILOC,MAKACT,BNDV,SPECSTORE,BINDID,IGLOC,MTYO,MSGTYP,CAFRE1\r
+.GLOBAL EVATYP,EVTYPE,APLTYP,APTYPE,PRNTYP,PRTYPE,AGC,SGSNAM,NAPT,APLQ,STRTO6\r
+.GLOBAL 6TOCHS,TYPFND,STBL,CHNL0,N.CHNS,CLOSAL,%LOGOUT,%SSNAM,%RSNAM,%KILLM\r
+.GLOBAL MAKINF,%VALRET,COMPERR,IPUT,IGET,TMATCH,INITIZ,IPCINI,%UNAM,%JNAM,%RUNAM,%RJNAM\r
+.GLOBAL NOTTY,PATEND,CFRAME,CARGS,CFUNCT,CITYPE,CTYPEQ,CPTYPE,CTYPEP,CUTYPE,CCHUTY\r
+.GLOBAL RTFALS,PGINT,PURCLN,CTYPEC,CTYPEW,IDVAL1,CALLTY,MESSAG,INITFL,WHOAMI\r
+.GLOBAL %SLEEP,%HANG,%TOPLQ,ONINT,CHUNW,CURFCN,BUFRIN,TD.LNT,TD.GET,TD.PUT,MPOPJ\r
+.GLOBAL PURVEC,PLOAD,SSPECS,OUTRNG\r
+.GLOBAL TYPIC\r
+.INSRT MUDDLE >\r
+\r
+MONITS==1 ; SET TO 1 IF PC DEMON WANTED\r
+.VECT.==1 ; BIT TO INDICATE VECTORS FOR GCHACK\r
+\r
+;MAIN LOOP AND STARTUP\r
+\r
+START: MOVEI 0,0 ; SET NO HACKS\r
+ MOVEM 0,WHOAMI ; HACK FOR TS FOO linked to TS MUDDLE\r
+ MOVE PVP,MAINPR ; MAKE SURE WE START IN THE MAIN PROCESS\r
+ JUMPE 0,INITIZ ; MIGHT BE RESTART\r
+ MOVE P,PSTO+1(PVP) ; SET UP FOR BOOTSTRAP HACK\r
+ MOVE TP,TPSTO+1(PVP)\r
+INITIZ: SKIPN P ; IF NO CURRENT P\r
+ MOVE P,PSTO+1(PVP) ; PDL TO GET OFF THE GROUND\r
+ SKIPN TP ; SAME FOR TP\r
+ MOVE TP,TPSTO+1(PVP) ; GET A TP TO WORK WITH\r
+ MOVE TVP,TVPSTO+1(PVP) ; GET A TVP\r
+ SETZB R,M ; RESET RSUBR AC'S\r
+ PUSHJ P,%RUNAM\r
+ PUSHJ P,%RJNAM\r
+ PUSHJ P,TTYOPE ;OPEN THE TTY\r
+ MOVEI B,MUDSTR\r
+ SKIPE WHOAMI ; SKIP IF THIS IS MUDDLE\r
+ JRST .+3 ; ELSE NO MESSAGE\r
+ SKIPN NOTTY ; IF NO TTY, IGNORE\r
+ PUSHJ P,MSGTYP ;TYPE OUT TO USER\r
+\r
+ XCT MESSAG ;MAYBE PRINT A MESSAGE\r
+ PUSHJ P,INTINT ;INITIALIZE INTERRUPT HANDLER\r
+ XCT IPCINI\r
+ PUSHJ P,PURCLN ; CLEAN UP PURE SHARED AREA\r
+RESTART: ;RESTART A PROCESS\r
+STP: MOVEI C,0\r
+ MOVE B,TBINIT+1(PVP) ;POINT INTO STACK AT START\r
+ PUSHJ P,CHUNW ; LEAVE WHILE DOING UNWIND CHECK\r
+ MOVEI E,TOPLEV\r
+ MOVEI A,TFALSE ; IN CASE FALLS OFF PROCESS\r
+ MOVEI B,0\r
+ MOVEM E,-1(TB)\r
+ JRST CONTIN\r
+\r
+ MQUOTE TOPLEVEL\r
+TOPLEVEL:\r
+ MCALL 0,LISTEN\r
+ JRST TOPLEVEL\r
+\f\r
+\r
+MFUNCTION LISTEN,SUBR\r
+\r
+ ENTRY\r
+ PUSH P,[0] ;FLAG: DON'T PRINT ERROR MSG\r
+ JRST ER1\r
+\r
+; USER SUPPLIED ERROR HANDLER, TEMPORARY KLUDGE\r
+ IMQUOTE ERROR\r
+\r
+ERROR: MOVE B,IMQUOTE ERROR\r
+ PUSHJ P,IGVAL ; GET VALUE\r
+ GETYP C,A\r
+ CAIN C,TSUBR ; CHECK FOR NO CHANGE\r
+ CAIE B,RERR1 ; SKIP IF NOT CHANGED\r
+ JRST .+2\r
+ JRST RERR1 ; GO TO THE DEFAULT\r
+ PUSH TP,A ; SAVE VALUE\r
+ PUSH TP,B\r
+ MOVE C,AB ; SAVE AB\r
+ MOVEI D,1 ; AND COUNTER\r
+USER1: PUSH TP,(C) ; PUSH THEM\r
+ PUSH TP,1(C)\r
+ ADD C,[2,,2] ; BUMP\r
+ ADDI D,1\r
+ JUMPL C,USER1\r
+ ACALL D,APPLY ; EVAL USERS ERROR\r
+ JRST FINIS\r
+\r
+\r
+TPSUBR==TSUBR+400000\r
+\r
+MFUNCTION ERROR%,PSUBR,ERROR\r
+\r
+RMT [EXPUNGE TPSUBR\r
+]\r
+RERR1: ENTRY\r
+ PUSH TP,$TATOM\r
+ PUSH TP,MQUOTE ERROR,ERROR,INTRUP\r
+ PUSHJ P,FRMSTK ; PUT ERROR'S FRAME ON STACK\r
+ MOVEI D,2\r
+ MOVE C,AB\r
+RERR2: JUMPGE C,RERR22\r
+ PUSH TP,(C)\r
+ PUSH TP,1(C)\r
+ ADD C,[2,,2]\r
+ AOJA D,RERR2\r
+RERR22: ACALL D,EMERGENCY\r
+ JRST RERR\r
+\r
+IMQUOTE ERROR\r
+RERR: ENTRY\r
+ PUSH P,[-1] ;PRINT ERROR FLAG\r
+\r
+ER1: MOVE B,IMQUOTE INCHAN\r
+ PUSHJ P,ILVAL ; CHECK INPUT CHANNEL IS SOME KIND OF TTY\r
+ GETYP A,A\r
+ CAIE A,TCHAN ; SKIP IF IT IS A CHANNEL\r
+ JRST ER2 ; NO, MUST REBIND\r
+ CAMN B,TTICHN+1(TVP)\r
+ JRST NOTINC\r
+ER2: MOVE B,IMQUOTE INCHAN\r
+ MOVEI C,TTICHN(TVP) ; POINT TO VALU\r
+ PUSHJ P,PUSH6 ; PUSH THE BINDING\r
+ MOVE B,TTICHN+1(TVP) ; GET IN CHAN\r
+NOTINC: SKIPE NOTTY\r
+ JRST NOECHO\r
+ PUSH TP,$TCHAN\r
+ PUSH TP,B\r
+ PUSH TP,$TATOM\r
+ PUSH TP,MQUOTE T\r
+ MCALL 2,TTYECH ; ECHO INPUT\r
+NOECHO: MOVE B,IMQUOTE OUTCHAN\r
+ PUSHJ P,ILVAL ; GET THE VALUE\r
+ GETYP A,A\r
+ CAIE A,TCHAN ; SKIP IF OK CHANNEL\r
+ JRST ER3 ; NOT CHANNEL, MUST REBIND\r
+ CAMN B,TTOCHN+1(TVP)\r
+ JRST NOTOUT\r
+ER3: MOVE B,IMQUOTE OUTCHAN\r
+ MOVEI C,TTOCHN(TVP)\r
+ PUSHJ P,PUSH6 ; PUSH THE BINDINGS\r
+NOTOUT: MOVE B,IMQUOTE OBLIST\r
+ PUSHJ P,ILVAL ; GET THE VALUE OF OBLIST\r
+ PUSHJ P,OBCHK ; IS IT A WINNER ?\r
+ SKIPA A,$TATOM ; NO, SKIP AND CONTINUE\r
+ JRST NOTOBL ; YES, DO NOT DO REBINDING\r
+ MOVE B,IMQUOTE OBLIST\r
+ PUSHJ P,IGLOC\r
+ GETYP 0,A\r
+ CAIN 0,TUNBOU\r
+ JRST MAKOB ; NO GLOBAL OBLIST, MAKE ONE\r
+ MOVEI C,(B) ; COPY ADDRESS\r
+ MOVE A,(C) ; GET THE GVAL\r
+ MOVE B,(C)+1\r
+ PUSHJ P,OBCHK ; IS IT A WINNER ?\r
+ JRST MAKOB ; NO, GO MAKE A NEW ONE\r
+ MOVE B,IMQUOTE OBLIST\r
+ PUSHJ P,PUSH6\r
+\r
+NOTOBL: PUSH TP,[TATOM,,-1] ;FOR BINDING\r
+ PUSH TP,IMQUOTE LER,[LERR ]INTRUP\r
+ PUSHJ P,MAKACT\r
+ HRLI A,TFRAME ; CORRCT TYPE\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ PUSH TP,[0]\r
+ PUSH TP,[0]\r
+ MOVE A,PVP ; GET PROCESS\r
+ ADD A,[PROCID,,PROCID] ; POINT TO ID (ALSO LEVEL)\r
+ PUSH TP,BNDV\r
+ PUSH TP,A\r
+ MOVE A,PROCID(PVP)\r
+ ADDI A,1 ; BUMP ERROR LEVEL\r
+ PUSH TP,A\r
+ PUSH TP,PROCID+1(PVP)\r
+ PUSH P,A\r
+\r
+ MOVE B,IMQUOTE READ-TABLE\r
+ PUSHJ P,IGVAL\r
+ PUSH TP,[TATOM,,-1]\r
+ PUSH TP,IMQUOTE READ-TABLE\r
+ GETYP C,A ; TO GVAL OF READ-TABLE ON ERROR AND\r
+ CAIE C,TVEC ; TOP ERRET'S\r
+ JRST .+4\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ JRST .+3\r
+ PUSH TP,$TUNBOUND\r
+ PUSH TP,[-1]\r
+ PUSH TP,[0]\r
+ PUSH TP,[0]\r
+\r
+ PUSHJ P,SPECBIND ;BIND THE CRETANS\r
+ MOVE A,-1(P) ;RESTORE SWITHC\r
+ JUMPE A,NOERR ;IF 0, DONT PRINT ERROR MESS\r
+ PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE *ERROR*\r
+ MCALL 0,TERPRI\r
+ MCALL 1,PRINC ;PRINT THE MESSAGE\r
+NOERR: MOVE C,AB ;GET A COPY OF AB\r
+\r
+ERRLP: JUMPGE C,LEVPRT ;IF NONE, RE-ENTER READ-EVAL-PRINT LOOP\r
+ PUSH TP,$TAB\r
+ PUSH TP,C\r
+ MOVEI B,PRIN1\r
+ GETYP A,(C) ; GET ARGS TYPE\r
+ CAIE A,TATOM\r
+ JRST ERROK\r
+ MOVE A,1(C) ; GET ATOM\r
+ MOVE A,2(A)\r
+ CAIE A,ERROBL+1\r
+ CAMN A,ERROBL+1(TVP) ; DONT SKIP IF IN ERROR OBLIST\r
+ MOVEI B,PRINC ; DONT PRINT TRAILER\r
+ERROK: PUSH P,B ; SAVE ROUTINE POINTER\r
+ PUSH TP,(C)\r
+ PUSH TP,1(C)\r
+ MCALL 0,TERPRI ; CRLF\r
+ POP P,B ; GET ROUTINE BACK\r
+ .MCALL 1,(B)\r
+ POP TP,C\r
+ SUB TP,[1,,1]\r
+ ADD C,[2,,2] ;BUMP SAVED AB\r
+ JRST ERRLP ;AND CONTINUE\r
+\r
+\r
+LEVPRT: XCT INITFL ;LOAD MUDDLE INIT FILE IF FIRST TIME\r
+ MCALL 0,TERPRI\r
+ PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE [LISTENING-AT-LEVEL ]\r
+ MCALL 1,PRINC ;PRINT LEVEL\r
+ PUSH TP,$TFIX ;READY TO PRINT LEVEL\r
+ HRRZ A,(P) ;GET LEVEL\r
+ SUB P,[2,,2] ;AND POP STACK\r
+ PUSH TP,A\r
+ MCALL 1,PRIN1 ;PRINT WITHOUT SPACES ETC.\r
+ PUSH TP,$TATOM ;NOW PROCESS\r
+ PUSH TP,EQUOTE [ PROCESS ]\r
+ MCALL 1,PRINC ;DONT SLASHIFY SPACES\r
+ PUSH TP,PROCID(PVP) ;NOW ID\r
+ PUSH TP,PROCID+1(PVP)\r
+ MCALL 1,PRIN1\r
+ SKIPN C,CURPRI\r
+ JRST MAINLP\r
+ PUSH TP,$TFIX\r
+ PUSH TP,C\r
+ PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE [ INT-LEVEL ]\r
+ MCALL 1,PRINC\r
+ MCALL 1,PRIN1\r
+ JRST MAINLP ; FALL INTO MAIN LOOP\r
+ \r
+\f;ROUTINES FOR ERROR-LISTEN\r
+\r
+OBCHK: GETYP 0,A\r
+ CAIN 0,TOBLS\r
+ JRST CPOPJ1 ; WIN FOR SINGLE OBLIST\r
+ CAIE 0,TLIST ; IF LIST, MAKE SURE EACH IS AN OBLIST\r
+ JRST CPOPJ ; ELSE, LOSE\r
+\r
+ JUMPE B,CPOPJ ; NIL ,LOSE\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ PUSH P,[0] ;FLAG FOR DEFAULT CHECKING\r
+ MOVEI 0,1000 ; VERY BIG NUMBER FOR CIRCULARITY TEST\r
+\r
+OBCHK0: INTGO\r
+ SOJE 0,OBLOSE ; CIRCULARITY TEST\r
+ HRRZ B,(TP) ; GET LIST POINTER\r
+ GETYP A,(B)\r
+ CAIE A,TOBLS ; SKIP IF WINNER\r
+ JRST DEFCHK ; CHECK FOR SPECIAL ATOM DEFAULT\r
+ HRRZ B,(B)\r
+ MOVEM B,(TP)\r
+ JUMPN B,OBCHK0\r
+OBWIN: AOS (P)-1\r
+OBLOSE: SUB TP,[2,,2]\r
+ SUB P,[1,,1]\r
+ POPJ P,\r
+\r
+DEFCHK: SKIPN (P) ; BEEN HERE BEFORE ?\r
+ CAIE A,TATOM ; OR, NOT AN ATOM ?\r
+ JRST OBLOSE ; YES, LOSE\r
+ MOVE A,(B)+1\r
+ CAME A,MQUOTE DEFAULT\r
+ JRST OBLOSE ; LOSE\r
+ SETOM (P) ; SET FLAG\r
+ HRRZ B,(B) ; CHECK FOR END OF LIST\r
+ MOVEM B,(TP)\r
+ JUMPN B,OBCHK0 ; NOT THE END, CONTINUE LOOKING\r
+ JRST OBLOSE ; LOSE FOR DEFAULT AT THE END\r
+\r
+\r
+\r
+PUSH6: PUSH TP,[TATOM,,-1]\r
+ PUSH TP,B\r
+ PUSH TP,(C)\r
+ PUSH TP,1(C)\r
+ PUSH TP,[0]\r
+ PUSH TP,[0]\r
+ POPJ P,\r
+\r
+\r
+MAKOB: PUSH TP,INITIAL(TVP)\r
+ PUSH TP,INITIAL+1(TVP)\r
+ PUSH TP,ROOT(TVP)\r
+ PUSH TP,ROOT+1(TVP)\r
+ MCALL 2,LIST\r
+ PUSH TP,$TATOM\r
+ PUSH TP,IMQUOTE OBLIST\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ MCALL 2,SETG\r
+ PUSH TP,[TATOM,,-1]\r
+ PUSH TP,IMQUOTE OBLIST\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ PUSH TP,[0]\r
+ PUSH TP,[0]\r
+ JRST NOTOBL\r
+\f\r
+\r
+;THIS IS IT FOLKS...THE MAIN LOOP. READ, EVAL, PRINT\r
+\r
+MAINLP: MOVE A,$TATOM ;KLUDGE BY NDR LIKE ERROR TO LET LOOSER REDEFINE\r
+ MOVE B,MQUOTE REP\r
+ PUSHJ P,ILVAL ;GET ITS LVAL TO SEE IF REDEFINED\r
+ GETYP C,A\r
+ CAIE C,TUNBOUND\r
+ JRST REPCHK\r
+ MOVE A,$TATOM ;SEE IF IT HAS GVAL SINCE NO LVAL\r
+ MOVE B,MQUOTE REP\r
+ PUSHJ P,IGVAL\r
+ GETYP C,A\r
+ CAIN C,TUNBOUN\r
+ JRST IREPER\r
+REPCHK: CAIN C,TSUBR\r
+ CAIE B,REPER\r
+ JRST .+2\r
+ JRST IREPER\r
+REREPE: PUSH TP,A\r
+ PUSH TP,B\r
+ GETYP A,-1(TP)\r
+ PUSHJ P,APLQ\r
+ JRST ERRREP\r
+ MCALL 1,APPLY ;LOOSER HAS REDEFINED SO CALL HIS\r
+ JRST MAINLP\r
+IREPER: PUSH P,[0] ;INDICATE FALL THROUGH\r
+ JRST REPERF\r
+\r
+ERRREP: PUSH TP,[TATOM,,-1]\r
+ PUSH TP,MQUOTE REP\r
+ PUSH TP,$TSUBR\r
+ PUSH TP,[REPER]\r
+ PUSH TP,[0]\r
+ PUSH TP,[0]\r
+ PUSHJ P,SPECBIN\r
+ PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE NON-APPLICABLE-REP\r
+ PUSH TP,-11(TP)\r
+ PUSH TP,-11(TP)\r
+ MCALL 2,ERROR\r
+ SUB TP,[6,,6]\r
+ PUSHJ P,SSPECS\r
+ JRST REREPE\r
+\r
+\r
+MFUNCTION REPER,SUBR,REP\r
+REPER: ENTRY 0\r
+ PUSH P,[1] ;INDICATE DIRECT CALL\r
+REPERF: MCALL 0,TERPRI\r
+ MCALL 0,READ\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ MCALL 0,TERPRI\r
+ MCALL 1,EVAL\r
+ PUSH TP,$TATOM\r
+ PUSH TP,IMQUOTE LAST-OUT\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ MCALL 2,SET\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ MCALL 1,PRIN1\r
+ POP P,C ;FLAG FOR FALL THROUGH OR CALL\r
+ JUMPN C,FINIS ;IN CASE LOOSER CALLED REP\r
+ JRST MAINLP\r
+\r
+\f\r
+;FUNCTION TO RETRY A PREVIOUS FUNCTION CALL\r
+\r
+MFUNCTION RETRY,SUBR\r
+\r
+ ENTRY\r
+ JUMPGE AB,RETRY1 ; USE MOST RECENT\r
+ CAMGE AB,[-2,,0]\r
+ JRST TMA\r
+ GETYP A,(AB) ; CHECK TYPE\r
+ CAIE A,TFRAME\r
+ JRST WTYP1\r
+ MOVEI B,(AB) ; POINT TO ARG\r
+ JRST RETRY2\r
+RETRY1: MOVE B,IMQUOTE LER,[LERR ]INTRUP\r
+ PUSHJ P,ILOC ; LOCATIVE TO FRAME\r
+RETRY2: PUSHJ P,CHFSWP ; CHECK VALIDITY AND SWAP IF NECESSARY\r
+ HRRZ 0,OTBSAV(B) ; CHECK FOR TOP\r
+ JUMPE 0,RESTAR ; YES RE-ENTER TOP LEVEL\r
+ PUSH TP,$TTB\r
+ PUSH TP,B ; SAVE FRAME\r
+ MOVE B,OTBSAV(B) ; GET PRVIOUS FOR UNBIND HACK\r
+ MOVEI C,-1(TP)\r
+ PUSHJ P,CHUNW ; CHECK ANY UNWINDING\r
+ CAME SP,SPSAV(TB) ; UNBINDING NEEDED?\r
+ PUSHJ P,SPECSTORE\r
+ MOVE P,PSAV(TB) ; GET OTHER STUFF\r
+ MOVE AB,ABSAV(B)\r
+ HLRE A,AB ; COMPUTE # OF ARGS\r
+ MOVNI A,-FRAMLN(A) ; MAKE TP POINT PAST FRAME\r
+ HRLI A,(A)\r
+ MOVE C,TPSAV(TB) ; COMPUTE TP\r
+ ADD C,A\r
+ MOVE TP,C\r
+ MOVE TB,B ; FIX UP TB\r
+ HRRZ C,FSAV(TB) ; GET FUNCTION\r
+ CAMGE C,VECTOP ; CHECK FOR RSUBR\r
+ CAMG C,VECBOT\r
+ JRST (C) ; GO\r
+ GETYP 0,(C) ; RSUBR OR ENTRY?\r
+ CAIE 0,TATOM\r
+ CAIN 0,TRSUBR\r
+ JRST RETRNT\r
+ MOVS R,(C) ; SET UP R\r
+ HRRI R,(C)\r
+ MOVEI C,0\r
+ JRST RETRN3\r
+\r
+RETRNT: CAIE 0,TRSUBR\r
+ JRST RETRN1\r
+ MOVE R,1(C)\r
+RETRN4: HRRZ C,2(C) ; OFFSET\r
+RETRN3: SKIPL M,1(R)\r
+ JRST RETRN5\r
+RETRN7: ADDI C,(M)\r
+ JRST (C)\r
+\r
+RETRN5: MOVEI D,(M) ; TOTAL OFFSET\r
+ MOVSS M\r
+ ADD M,PURVEC+1(TVP)\r
+ SKIPL M,1(M)\r
+ JRST RETRN6\r
+ ADDI M,(D)\r
+ JRST RETRN7\r
+RETRN6: HLRZ A,1(R)\r
+ PUSH P,D\r
+ PUSH P,C\r
+ PUSHJ P,PLOAD\r
+ JRST RETRER ; LOSER\r
+ POP P,C\r
+ POP P,D\r
+ MOVE M,B\r
+ JRST RETRN7\r
+\r
+RETRN1: MOVE B,1(C)\r
+ PUSH TP,$TVEC\r
+ PUSH TP,C\r
+ PUSHJ P,IGVAL\r
+ GETYP 0,A\r
+ MOVE C,(TP)\r
+ SUB TP,[2,,2]\r
+ CAIE 0,TRSUBR\r
+ JRST RETRN2\r
+ MOVE R,B\r
+ JRST RETRN3\r
+\r
+RETRN2: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE CANT-RETRY-ENTRY-GONE\r
+ JRST CALER1\r
+\r
+RETRER: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE PURE-LOAD-FAILURE\r
+ JRST CALER1\r
+\r
+\f\r
+;FUNCTION TO DO ERROR RETURN\r
+\r
+MFUNCTION ERRET,SUBR\r
+\r
+ ENTRY\r
+ HLRE A,AB ; -2*# OF ARGS\r
+ JUMPGE A,STP ; RESTART PROCESS\r
+ ASH A,-1 ; -# OF ARGS\r
+ AOJE A,ERRET2 ; NO FRAME SUPPLIED\r
+ AOJL A,TMA\r
+ ADD AB,[2,,2]\r
+ PUSHJ P,OKFRT\r
+ JRST WTYP2\r
+ SUB AB,[2,,2]\r
+ PUSHJ P,CHPROC ; POINT TO FRAME SLOT\r
+ JRST ERRET3\r
+ERRET2: MOVE B,IMQUOTE LER,[LERR ]INTRUP\r
+ PUSHJ P,ILVAL ; GET ITS VALUE\r
+ERRET3: PUSH TP,A\r
+ PUSH TP,B\r
+ MOVEI B,-1(TP)\r
+ PUSHJ P,CHFSWP ; CHECK VALIDITY AND SWAP IF NECESSARY\r
+ HRRZ 0,OTBSAV(B) ; TOP LEVEL?\r
+ JUMPE 0,TOPLOS\r
+ PUSHJ P,CHUNW ; ANY UNWINDING\r
+ JRST CHFINIS\r
+\r
+\r
+; FUNCTION TO RETURN LAST ERROR FRAME OR PREVIOUS FRAME\r
+\r
+MFUNCTION FRAME,SUBR\r
+ ENTRY\r
+ SETZB A,B\r
+ JUMPGE AB,FRM1 ; DEFAULT CASE\r
+ CAMG AB,[-3,,0] ; SKIP IF OK ARGS\r
+ JRST TMA\r
+ PUSHJ P,OKFRT ; A FRAME OR SIMILAR THING?\r
+ JRST WTYP1\r
+\r
+FRM1: PUSHJ P,CFRAME ; GO TO INTERNAL\r
+ JRST FINIS\r
+\r
+CFRAME: JUMPN A,FRM2 ; ARG SUPPLIED?\r
+ MOVE B,IMQUOTE LER,[LERR ]INTRUP\r
+ PUSHJ P,ILVAL\r
+ JRST FRM3\r
+FRM2: PUSHJ P,CHPROC ; CHECK FOR PROCESS\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ MOVEI B,-1(TP) ; POINT TO SLOT\r
+ PUSHJ P,CHFRM ; CHECK IT\r
+ MOVE C,(TP) ; GET FRAME BACK\r
+ MOVE B,OTBSAV(C) ;GET PREVIOUS FRAME\r
+ SUB TP,[2,,2]\r
+ TRNN B,-1 ; SKIP IF OK\r
+ JRST TOPLOSE\r
+\r
+FRM3: JUMPN B,FRM4 ; JUMP IF WINNER\r
+ MOVE B,IMQUOTE THIS-PROCESS\r
+ PUSHJ P,ILVAL ; GET PROCESS OF INTEREST\r
+ GETYP A,A ; CHECK IT\r
+ CAIN A,TUNBOU\r
+ MOVE B,PVP ; USE CURRENT\r
+ MOVEI A,PVLNT*2+1(B) ; POINT TO DOPE WORDS\r
+ MOVE B,TBINIT+1(B) ; AND BASE FRAME\r
+FRM4: HLL B,OTBSAV(B) ;TIME\r
+ HRLI A,TFRAME\r
+ POPJ P,\r
+\r
+OKFRT: AOS (P) ;ASSUME WINNAGE\r
+ GETYP 0,(AB)\r
+ MOVE A,(AB)\r
+ MOVE B,1(AB)\r
+ CAIE 0,TFRAME\r
+ CAIN 0,TENV\r
+ POPJ P,\r
+ CAIE 0,TPVP\r
+ CAIN 0,TACT\r
+ POPJ P,\r
+ SOS (P)\r
+ POPJ P,\r
+\r
+CHPROC: GETYP 0,A ; TYPE\r
+ CAIE 0,TPVP\r
+ POPJ P, ; OK\r
+ MOVEI A,PVLNT*2+1(B)\r
+ CAMN B,PVP ; THIS PROCESS?\r
+ JRST CHPRO1\r
+ MOVE B,TBSTO+1(B)\r
+ JRST FRM4\r
+\r
+CHPRO1: MOVE B,OTBSAV(TB)\r
+ JRST FRM4\r
+\r
+; FUNCTION TO RETURN ARGS TUPLE FOR A FRAME\r
+\r
+MFUNCTION ARGS,SUBR\r
+ ENTRY 1\r
+ PUSHJ P,OKFRT ; CHECK FRAME TYPE\r
+ JRST WTYP1\r
+ PUSHJ P,CARGS\r
+ JRST FINIS\r
+\r
+CARGS: PUSHJ P,CHPROC\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ MOVEI B,-1(TP) ; POINT TO FRAME SLOT\r
+ PUSHJ P,CHFRM ; AND CHECK FOR VALIDITY\r
+ MOVE C,(TP) ; FRAME BACK\r
+ MOVSI A,TARGS\r
+CARGS1: GETYP 0,FSAV(C) ; IS THIS A FUNNY ONE\r
+ CAIE 0,TCBLK ; SKIP IF FUNNY\r
+ JRST .+3 ; NO NORMAL\r
+ MOVE C,OTBSAV(C) ; ASSOCIATE WITH PREVIOUS FRAME\r
+ JRST CARGS1\r
+ HLR A,OTBSAV(C) ; TIME IT AND\r
+ MOVE B,ABSAV(C) ; GET POINTER\r
+ SUB TP,[2,,2] ; FLUSH CRAP\r
+ POPJ P,\r
+\r
+; FUNCTION TO RETURN FUNCTION ASSOCIATED WITH A FRAME\r
+\r
+MFUNCTION FUNCT,SUBR ;RETURNS FUNCTION NAME OF\r
+ ENTRY 1 ; FRAME ARGUMENT\r
+ PUSHJ P,OKFRT ; CHECK TYPE\r
+ JRST WTYP1\r
+ PUSHJ P,CFUNCT\r
+ JRST FINIS\r
+\r
+CFUNCT: PUSHJ P,CHPROC\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ MOVEI B,-1(TP)\r
+ PUSHJ P,CHFRM ; CHECK IT\r
+ MOVE C,(TP) ; RESTORE FRAME\r
+ HRRZ A,FSAV(C) ;FUNCTION POINTER\r
+ CAMG A,VECTOP ;IS THIS AN RSUBR ?\r
+ CAMGE A,VECBOT\r
+ SKIPA B,@-1(A) ;NO, GET SUBR'S NAME POINTER\r
+ MOVE B,(A)+3 ;YES, GET RSUBR'S NAME ENTRY\r
+ MOVSI A,TATOM\r
+ SUB TP,[2,,2]\r
+ POPJ P,\r
+\r
+BADFRAME:\r
+ PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE FRAME-NO-LONGER-EXISTS\r
+ JRST CALER1\r
+\r
+\r
+TOPLOSE:\r
+ PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE TOP-LEVEL-FRAME\r
+ JRST CALER1\r
+\r
+\r
+\f\r
+\f\r
+; ROUTINE TO HANG INDEFINITELY WITH INTERRUPTS ENABLED\r
+\r
+MFUNCTION HANG,SUBR\r
+\r
+ ENTRY\r
+\r
+ JUMPGE AB,HANG1 ; NO PREDICATE\r
+ CAMGE AB,[-3,,]\r
+ JRST TMA\r
+REHANG: MOVE A,[PUSHJ P,CHKPRH]\r
+ MOVEM A,ONINT ; CHECK PREDICATE AFTER ANY INTERRUPT\r
+ PUSH TP,(AB)\r
+ PUSH TP,1(AB)\r
+HANG1: ENABLE ;LET OURSELVES BE INTERRUPTED OUT\r
+ PUSHJ P,%HANG\r
+ DISABLE ;PREVENT INTERRUPTS AT RANDOM TIMES\r
+ SETZM ONINT\r
+ MOVE A,$TATOM\r
+ MOVE B,MQUOTE T\r
+ JRST FINIS\r
+\r
+\r
+; ROUTINE TO SLEEP FOR POSITIVE NUMBER OF SECONDS WITH INTERRUPTS ENABLED\r
+; ARGUMENT SHOULD BE OF TYPE FIX OR FLOAT AND NON-NEGATIVE\r
+\r
+MFUNCTION SLEEP,SUBR\r
+\r
+ ENTRY\r
+\r
+ JUMPGE AB,TFA\r
+ CAML AB,[-3,,]\r
+ JRST SLEEP1\r
+ CAMGE AB,[-5,,]\r
+ JRST TMA\r
+ PUSH TP,2(AB)\r
+ PUSH TP,3(AB)\r
+SLEEP1: GETYP 0,(AB)\r
+ CAIE 0,TFIX\r
+ JRST .+5\r
+ MOVE B,1(AB)\r
+ JUMPL B,OUTRNG ;ARG SHOULDNT BE NEGATIVE\r
+ IMULI B,30. ;CONVERT TO # OF THIRTIETHS OF A SECOND\r
+ JRST SLEEPR ;GO SLEEP\r
+ CAIE 0,TFLOAT ;IF IT WASNT FIX MAKE SURE IT IS FLOAT\r
+ JRST WTYP1 ;WRONG TYPE ARG\r
+ MOVE B,1(AB)\r
+ FMPR B,[30.0] ;CONVERT TO FLOATING # OF THIRTIETHS OF A SECOND\r
+ MULI B,400 ;KLUDGE TO FIX IT\r
+ TSC B,B\r
+ ASH C,(B)-243\r
+ MOVE B,C ;MOVE THE FIXED NUMBER INTO B\r
+ JUMPL B,OUTRNG ;CHECK TO SEE THAT WE HAVE POSITIVE NUMBER\r
+SLEEPR: MOVE A,B\r
+RESLEE: MOVE B,[PUSHJ P,CHKPRS]\r
+ CAMGE AB,[-3,,]\r
+ MOVEM B,ONINT\r
+ ENABLE\r
+ PUSHJ P,%SLEEP\r
+ DISABLE\r
+ SETZM ONINT\r
+ MOVE A,$TATOM\r
+ MOVE B,MQUOTE T\r
+ JRST FINIS\r
+\r
+CHKPRH: PUSH P,B\r
+ MOVEI B,HANGP\r
+ JRST .+3\r
+\r
+CHKPRS: PUSH P,B\r
+ MOVEI B,SLEEPP\r
+ HRRM B,LCKINT\r
+ SETZM ONINT ; TURN OFF FEATURE FOR NOW\r
+ POP P,B\r
+ POPJ P,\r
+\r
+HANGP: SKIPA B,[REHANG]\r
+SLEEPP: MOVEI B,RESLEE\r
+ PUSH P,B\r
+ PUSH P,A\r
+ DISABLE\r
+ PUSH TP,(TB)\r
+ PUSH TP,1(TB)\r
+ MCALL 1,EVAL\r
+ GETYP 0,A\r
+ CAIE 0,TFALSE\r
+ JRST FINIS\r
+ POP P,A\r
+ POPJ P,\r
+\r
+MFUNCTION VALRET,SUBR\r
+; SUBR TO VALRET A STRING TO SUPERIOR ITS PROCESS\r
+\r
+ ENTRY 1\r
+ GETYP A,(AB) ; GET TYPE OF ARGUMENT\r
+ CAIE A,TCHSTR ; IS IT A CHR STRING?\r
+ JRST WTYP1 ; NO...ERROR WRONG TYPE\r
+ PUSHJ P,CSTACK ; COPY THE CHR STRING TO THE STACK\r
+ ; CSTACK IS IN ATOMHK\r
+ MOVEI B,0 ; ASCIZ TERMINATOR\r
+ EXCH B,(P) ; STORE AND RETRIEVE COUNT\r
+\r
+; CALCULATE THE BEGINNING ADDR OF THE STRING\r
+ MOVEI A,-1(P) ; GET ADDR OF TOP OF STACK\r
+ SUBI A,-1(B) ; GET STARTING ADDR\r
+ PUSHJ P,%VALRE ; PASS UP TO MONITOR\r
+ JRST IFALSE ; IF HE RETURNS, RETURN FALSE\r
+\r
+\r
+MFUNCTION LOGOUT,SUBR\r
+\r
+; SUBR TO DO A .LOGOUT (VALID ONLY AT TOP LEVEL)\r
+ ENTRY 0\r
+ PUSHJ P,%TOPLQ ; SKIP IF AT TOP LEVEL\r
+ JRST IFALSE\r
+ PUSHJ P,CLOSAL\r
+ PUSHJ P,%LOGOUT ; TRY TO FLUSH\r
+ JRST IFALSE ; COULDN'T DO IT...RETURN FALSE\r
+\r
+; FUNCTS TO GET UNAME AND JNAME\r
+\r
+MFUNCTION UNAME,SUBR\r
+\r
+ ENTRY 0\r
+\r
+ PUSHJ P,%RUNAM\r
+ JRST RSUJNM\r
+\r
+MFUNCTION JNAME,SUBR\r
+\r
+ ENTRY 0\r
+\r
+ PUSHJ P,%RJNAM\r
+ JRST RSUJNM\r
+\r
+; FUNCTION TO SET AND READ GLOBAL SNAME\r
+\r
+MFUNCTION SNAME,SUBR\r
+\r
+ ENTRY\r
+\r
+ JUMPGE AB,SNAME1\r
+ CAMG AB,[-3,,]\r
+ JRST TMA\r
+ GETYP A,(AB) ; ARG MUST BE STRING\r
+ CAIE A,TCHSTR\r
+ JRST WTYP1\r
+ PUSH TP,$TATOM\r
+ PUSH TP,IMQUOTE SNM\r
+ PUSH TP,(AB)\r
+ PUSH TP,1(AB)\r
+ MCALL 2,SETG\r
+ JRST FINIS\r
+\r
+SNAME1: MOVE B,IMQUOTE SNM\r
+ PUSHJ P,IDVAL1\r
+ GETYP 0,A\r
+ CAIN 0,TCHSTR\r
+ JRST FINIS\r
+ MOVE A,$TCHSTR\r
+ MOVE B,CHQUOTE\r
+ JRST FINIS\r
+\r
+RSUJNM: PUSHJ P,6TOCHS ; CONVERT IT\r
+ JRST FINIS\r
+\r
+\r
+SGSNAM: MOVE B,IMQUOTE SNM\r
+ PUSHJ P,IDVAL1\r
+ GETYP 0,A\r
+ CAIE 0,TCHSTR\r
+ JRST SGSN1\r
+\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ PUSHJ P,STRTO6\r
+ POP P,A\r
+ SUB TP,[2,,2]\r
+ JRST .+2\r
+\r
+SGSN1: MOVEI A,0\r
+ PUSHJ P,%SSNAM ; SET SNAME IN SYSTEM\r
+ POPJ P,\r
+\r
+\f\r
+\r
+;THIS SUBROUTINE ALLOCATES A NEW PROCESS TAKES NO ARGS AND\r
+;IS CALLED BY PUSHJ P,. RETURNS IN A AND B A NEW PROCESS.\r
+\r
+ICR: MOVEI A,PVLNT ;SETUP CALL TO VECTOR FOR PVP\r
+ PUSHJ P,IVECT ;GOBBLE A VECTOR\r
+ HRLI C,PVBASE ;SETUP A BLT POINTER\r
+ HRRI C,(B) ;GET INTO ADDRESS\r
+ BLT C,PVLNT*2-1(B) ;COPY A PROTOTYPE INTO NEW PVP\r
+ MOVSI C,400000+SPVP+.VECT. ;SET SPECIAL TYPE\r
+ MOVEM C,PVLNT*2(B) ;CLOBBER IT IN\r
+ PUSH TP,A ;SAVE THE RESULTS OF VECTOR\r
+ PUSH TP,B\r
+\r
+ PUSH TP,$TFIX ;GET A UNIFORM VECTOR\r
+ PUSH TP,[PLNT]\r
+ MCALL 1,UVECTOR\r
+ ADD B,[PDLBUF-2,,-1] ;FUDGE WITH BUFFER\r
+ MOVE C,(TP) ;REGOBBLE PROCESS POINTER\r
+ MOVEM B,PSTO+1(C) ;STORE IN ALL HOMES\r
+ MOVEM B,PBASE+1(C)\r
+\r
+\r
+ MOVEI A,TPLNT ;PREPARE TO CREATE A TEMPORARY PDL\r
+ PUSHJ P,IVECT ;GET THE TEMP PDL\r
+ ADD B,[PDLBUF,,0] ;PDL GROWTH HACK\r
+ MOVE C,(TP) ;RE-GOBBLE NEW PVP\r
+ SUB B,[1,,1] ;FIX FOR STACK\r
+ MOVEM B,TPBASE+1(C)\r
+\r
+;SETUP INITIAL BINDING\r
+\r
+ PUSH B,$TBIND\r
+ MOVEM B,SPBASE+1(C) ;SAVE AS BASE OF SP\r
+ MOVEM B,SPSTO+1(C) ;AND CURRENT THEREOF\r
+ MOVEM B,CURFCN+1(C) ; AND AS CURRENT FCN FOR SPEC/UNSPEC LOGIC\r
+ PUSH B,IMQUOTE THIS-PROCESS\r
+ PUSH B,$TPVP ;GIVE IT PROCESS AS VALUE\r
+ PUSH B,C\r
+ ADD B,[2,,2] ;FINISH FRAME\r
+ MOVEM B,TPSTO+1(C) ;MAKE THIS THE CURRENT STACK POINTER\r
+ MOVEM C,PVPSTO+1(C) ;SAVE THE NEW PVP ITSELF\r
+ MOVEM TVP,TVPSTO+1(C) ;AND THE GOOD OLD TRANSFER VECTOR\r
+ AOS A,IDPROC ;GOBBLE A UNIQUE PROCESS I.D.\r
+ MOVEM A,PROCID+1(C) ;SAVE THAT ALSO\r
+ AOS A,PTIME ; GET A UNIQUE BINDING ID\r
+ MOVEM A,BINDID+1(C)\r
+\r
+ MOVSI A,TPVP ;CLOBBER THE TYPE\r
+ MOVE B,(TP) ;AND POINTER TO PROCESS\r
+ SUB TP,[2,,2]\r
+ POPJ P,\r
+\r
+;MINI ROUTINE TO CALL VECTOR WITH COUNT IN A\r
+\r
+IVECT: PUSH TP,$TFIX\r
+ PUSH TP,A\r
+ MCALL 1,VECTOR ;GOBBLE THE VECTOR\r
+ POPJ P,\r
+\r
+\r
+;SUBROUTINE TO SWAP A PROCESS IN\r
+;CALLED WITH JSP A,SWAP AND NEW PVP IN B\r
+\r
+SWAP: ;FIRST STORE ALL THE ACS\r
+\r
+ IRP A,,[PVP,TVP,AB,TB,TP,SP,P,M,R]\r
+ MOVEM A,A!STO+1(PVP)\r
+ TERMIN\r
+\r
+ SETOM 1(TP) ; FENCE POST MAIN STACK\r
+ MOVEM TP,TPSAV(TB) ; CORRECT FRAME\r
+ SETZM PSAV(TB) ; CLEAN UP CURRENT FRAME\r
+ SETZM SPSAV(TB)\r
+ SETZM PCSAV(TB)\r
+\r
+ MOVE E,PVP ;RETURN OLD PROCESS IN E\r
+ MOVE PVP,D ;AND MAKE NEW ONE BE D\r
+\r
+SWAPIN:\r
+ ;NOW RESTORE NEW PROCESSES AC'S\r
+\r
+ IRP A,,[PVP,TVP,AB,TB,TP,SP,P,M,R]\r
+ MOVE A,A!STO+1(PVP)\r
+ TERMIN\r
+\r
+ JRST (C) ;AND RETURN\r
+\r
+\r
+\f\r
+\r
+;SUBRS ASSOCIATED WITH TYPES\r
+\r
+;INTERNAL FUNCTION TO GET STRAGE ALLOCATION TYPE\r
+;GETS THE TYPE CODE IN A AND RETURNS SAT IN A.\r
+\r
+SAT: LSH A,1 ;TIMES 2 TO REF VECTOR\r
+ HRLS A ;TO BOTH HALVES TO HACK AOBJN POINTER\r
+ ADD A,TYPVEC+1(TVP) ;ACCESS THE VECTOR\r
+ HRR A,(A) ;GET PROBABLE SAT\r
+ JUMPL A,.+2 ;DID WE REALLY HAVE A VALID TYPE\r
+ MOVEI A,0 ;NO RETURN 0\r
+ ANDI A,SATMSK\r
+ POPJ P, ;AND RETURN\r
+\r
+;TYPE (ITYPE) ARE FUNCTIONS TO RETURN THE ATOMIC NAME OF THE\r
+;TYPE OF A GOODIE. TYPE TAKES ITS ARGS ON AP AND RETURNS IN A AND B.\r
+;ITYPE TAKES ITS ARGS IN A AND B AND RETURNS IN SAME (B=0) FOR INVALID\r
+;TYPECODE.\r
+MFUNCTION TYPE,SUBR\r
+\r
+ ENTRY 1\r
+ GETYP A,(AB) ;TYPE INTO A\r
+TYPE1: PUSHJ P,ITYPE ;GO TO INTERNAL\r
+ JUMPN B,FINIS ;GOOD RETURN\r
+TYPERR: PUSH TP,$TATOM ;SETUP ERROR CALL\r
+ PUSH TP,EQUOTE TYPE-UNDEFINED\r
+ JRST CALER1" ;STANDARD ERROR HACKER\r
+\r
+CITYPE: GETYP A,A ; GET TYPE FOR COMPILER CALL\r
+ITYPE: LSH A,1 ;TIMES 2\r
+ HRLS A ;TO BOTH SIDES\r
+ ADD A,TYPVEC+1(TVP) ;GET ACTUAL LOCATION\r
+ JUMPGE A,TYPERR ;LOST, TYPE OUT OF BOUNDS\r
+ MOVE B,1(A) ;PICKUP TYPE\r
+ HLLZ A,(A)\r
+ POPJ P,\r
+\r
+; PREDICATE -- IS OBJECT OF TYPE SPECIFIED\r
+\r
+MFUNCTION %TYPEQ,SUBR,[TYPE?]\r
+\r
+ ENTRY\r
+\r
+ MOVE D,AB ; GET ARGS\r
+ ADD D,[2,,2]\r
+ JUMPGE D,TFA\r
+ MOVE A,(AB)\r
+ HLRE C,D\r
+ MOVMS C\r
+ ASH C,-1 ; FUDGE\r
+ PUSHJ P,ITYPQ ; GO INTERNAL\r
+ JFCL\r
+ JRST FINIS\r
+\r
+ITYPQ: GETYP A,A ; OBJECT\r
+ PUSHJ P,ITYPE\r
+TYPEQ0: SOJL C,CIFALS\r
+ GETYP 0,(D)\r
+ CAIE 0,TATOM ; Type name must be an atom\r
+ JRST WRONGT\r
+ CAMN B,1(D) ; Same as the OBJECT?\r
+ JRST CPOPJ1 ; Yes, return type name\r
+ ADD D,[2,,2]\r
+ JRST TYPEQ0 ; No, continue comparing\r
+\r
+CIFALS: MOVEI B,0\r
+ MOVSI A,TFALSE\r
+ POPJ P,\r
+\r
+CTYPEQ: SOJE A,CIFALS ; TREAT NO ARGS AS FALSE\r
+ MOVEI D,1(A) ; FIND BASE OF ARGS\r
+ ASH D,1\r
+ HRLI D,(D)\r
+ SUBM TP,D ; D POINTS TO BASE\r
+ MOVE E,D ; SAVE FOR TP RESTORE\r
+ ADD D,[3,,3] ; FUDGE\r
+ MOVEI C,(A) ; NUMBER OF TYPES\r
+ MOVE A,-2(D)\r
+ PUSHJ P,ITYPQ\r
+ JFCL ; IGNORE SKIP FOR NOW\r
+ MOVE TP,E ; SET TP BACK\r
+ JUMPL B,CPOPJ1 ; SKIP\r
+ POPJ P,\r
+\f\r
+; Entries to get type codes for types for fixing up RSUBRs and assembling\r
+\r
+MFUNCTION %TYPEC,SUBR,[TYPE-C]\r
+\r
+ ENTRY\r
+\r
+ JUMPGE AB,TFA\r
+ GETYP 0,(AB)\r
+ CAIE 0,TATOM\r
+ JRST WTYP1\r
+ MOVE B,1(AB)\r
+ CAMGE AB,[-3,,0] ; skip if only type name given\r
+ JRST GTPTYP\r
+ MOVE C,MQUOTE ANY\r
+\r
+TYPEC1: PUSHJ P,CTYPEC ; go to internal\r
+ JRST FINIS\r
+\r
+GTPTYP: CAMGE AB,[-5,,0]\r
+ JRST TMA\r
+ GETYP 0,2(AB)\r
+ CAIE 0,TATOM\r
+ JRST WTYP2\r
+ MOVE C,3(AB)\r
+ JRST TYPEC1\r
+\r
+CTYPEC: PUSH P,C ; save primtype checker\r
+ PUSHJ P,TYPLOO ; search type vector\r
+ POP P,B\r
+ CAMN B,MQUOTE ANY\r
+ JRST CTPEC1\r
+ PUSH P,D\r
+ HRRZ A,(A)\r
+ ANDI A,SATMSK\r
+ PUSH P,A\r
+ PUSHJ P,TYPLOO\r
+ HRRZ 0,(A)\r
+ ANDI 0,SATMSK\r
+ CAME 0,(P)\r
+ JRST TYPDIF\r
+ MOVE D,-1(P)\r
+ SUB P,[2,,2]\r
+CTPEC1: MOVEI B,(D)\r
+ MOVSI A,TTYPEC\r
+ POPJ P,\r
+\r
+MFUNCTION %TYPEW,SUBR,[TYPE-W]\r
+\r
+ ENTRY\r
+\r
+ JUMPGE AB,TFA\r
+ GETYP 0,(AB)\r
+ CAIE 0,TATOM\r
+ JRST WTYP1\r
+ MOVEI D,0\r
+ MOVE C,MQUOTE ANY\r
+ MOVE B,1(AB)\r
+ CAMGE AB,[-3,,0]\r
+ JRST CTYPW1\r
+\r
+CTYPW3: PUSHJ P,CTYPEW\r
+ JRST FINIS\r
+\r
+CTYPW1: GETYP 0,2(AB)\r
+ CAIE 0,TATOM\r
+ JRST WTYP2\r
+ CAMGE AB,[-5,,0] ; JUMP IF RH IS GIVEN\r
+ JRST CTYPW2\r
+ MOVE C,3(AB)\r
+ JRST CTYPW3\r
+\r
+CTYPW2: CAMGE AB,[-7,,0]\r
+ JRST TMA\r
+ GETYP 0,4(AB)\r
+ CAIE 0,TFIX\r
+ JRST WRONGT\r
+ MOVE D,5(AB)\r
+ JRST CTYPW3\r
+\r
+CTYPEW: PUSH P,D\r
+ PUSHJ P,CTYPEC ; GET CODE IN B\r
+ POP P,B\r
+ HRLI B,(D)\r
+ MOVSI A,TTYPEW\r
+ POPJ P,\r
+\f \r
+;PRIMTTYPE RETURNS THE TYPE ATOM OF A PRIMITIVE TYPE IN A CLASS\r
+\r
+STBL: REPEAT NUMSAT,MQUOTE INTERNAL-TYPE\r
+\r
+LOC STBL\r
+\r
+IRP A,,[[1WORD,WORD],[2WORD,LIST],[NWORD,UVECTOR],[2NWORD,VECTOR],[STORE,STORAGE]\r
+[ARGS,TUPLE],[FRAME,FRAME],[ATOM,ATOM],[LOCID,LOCD],[CHSTR,STRING]\r
+[PVP,PROCESS],[ASOC,ASOC],[LOCA,LOCA],[LOCS,LOCS],[LOCU,LOCU],[LOCV,LOCV]\r
+[LOCL,LOCL],[LOCN,LOCAS],[LOCT,LOCT]]\r
+IRP B,C,[A]\r
+LOC STBL+S!B\r
+MQUOTE C\r
+\r
+.ISTOP\r
+\r
+TERMIN\r
+TERMIN\r
+\r
+LOC STBL+NUMSAT+1\r
+\r
+\r
+MFUNCTION TYPEPRIM,SUBR\r
+\r
+ ENTRY 1\r
+ GETYP A,(AB)\r
+ CAIE A,TATOM\r
+ JRST NOTATOM\r
+ MOVE B,1(AB)\r
+ PUSHJ P,CTYPEP\r
+ JRST FINIS\r
+\r
+CTYPEP: PUSHJ P,TYPLOO ; CONVERT ATOM TO CODE\r
+ HRRZ A,(A) ; SAT TO A\r
+ ANDI A,SATMSK\r
+ JRST PTYP1\r
+\r
+MFUNCTION PRIMTYPE,SUBR\r
+\r
+ ENTRY 1\r
+\r
+ MOVE A,(AB) ;GET TYPE\r
+ PUSHJ P,CPTYPE\r
+ JRST FINIS\r
+\r
+CPTYPE: GETYP A,A\r
+ PUSHJ P,SAT ;GET SAT\r
+PTYP1: JUMPE A,TYPERR\r
+ MOVE B,MQUOTE TEMPLATE\r
+ CAIG A,NUMSAT ; IF BIG SAT, THEN TEMPLATE\r
+ MOVE B,@STBL(A)\r
+ MOVSI A,TATOM\r
+ POPJ P,\r
+\f\r
+\r
+; RSUBR MAKES A VECTOR INTO AN OBJECT OF TYPE RSUBR, ALSO SLIGHTLY MUNGING IT\r
+\r
+MFUNCTION RSUBR,SUBR\r
+ ENTRY 1\r
+\r
+ GETYP A,(AB)\r
+ CAIE A,TVEC ; MUST BE VECTOR\r
+ JRST WTYP1\r
+ MOVE B,1(AB) ; GET IT\r
+ GETYP A,(B) ; CHECK 1ST ELEMENTS TYPE\r
+ CAIN A,TPCODE ; PURE CODE\r
+ JRST .+3\r
+ CAIE A,TCODE\r
+ JRST NRSUBR\r
+ HLRM B,(B) ; CLOBEER SPECIAL COUNT FIELD\r
+ MOVSI A,TRSUBR\r
+ JRST FINIS\r
+\r
+NRSUBR: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE FIRST-ELEMENT-OF-VECTOR-NOT-CODE\r
+ JRST CALER1\r
+\r
+; ROUTINE TO GENERATE ENTRYY OTHER THAN FIRST TO RSUBRR\r
+\r
+MFUNCTION MENTRY,SUBR,[RSUBR-ENTRY]\r
+\r
+ ENTRY 2\r
+\r
+ GETYP 0,(AB) ; TYPE OF ARG\r
+ CAIE 0,TVEC ; BETTER BE VECTOR\r
+ JRST WTYP1\r
+ GETYP 0,2(AB)\r
+ CAIE 0,TFIX\r
+ JRST WTYP2\r
+ MOVE B,1(AB) ; GET VECTOR\r
+ CAML B,[-3,,0]\r
+ JRST BENTRY\r
+ GETYP 0,(B) ; FIRST ELEMENT\r
+ CAIE 0,TRSUBR\r
+ JRST MENTR1\r
+MENTR2: GETYP 0,2(B)\r
+ CAIE 0,TATOM\r
+ JRST BENTRY\r
+ MOVE C,3(AB)\r
+ HRRM C,2(B) ; OFFSET INTO VECTOR\r
+ HLRM B,(B)\r
+ MOVSI A,TENTER\r
+ JRST FINIS\r
+\r
+MENTR1: CAIE 0,TATOM\r
+ JRST BENTRY\r
+ MOVE B,1(B) ; GET ATOM\r
+ PUSHJ P,IGVAL ; GET VAL\r
+ GETYP 0,A\r
+ CAIE 0,TRSUBR\r
+ JRST BENTRY\r
+ MOVE B,1(AB) ; RESTORE B\r
+ JRST MENTR2\r
+\r
+BENTRY: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE BAD-VECTOR\r
+ JRST CALER1\r
+ \r
+; SUBR TO GET ENTRIES OFFSET\r
+\r
+MFUNCTION LENTRY,SUBR,[ENTRY-LOC]\r
+\r
+ ENTRY 1\r
+\r
+ GETYP 0,(AB)\r
+ CAIE 0,TENTER\r
+ JRST WTYP1\r
+ MOVE B,1(AB)\r
+ HRRZ B,2(B)\r
+ MOVSI A,TFIX\r
+ JRST FINIS\r
+\r
+; RETURN FALSE\r
+\r
+RTFALS: MOVSI A,TFALSE\r
+ MOVEI B,0\r
+ POPJ P,\r
+\r
+;SUBROUTINE CALL FOR RSUBRs\r
+RCALL: SUBM M,(P) ;CALCULATE PC's OFFSET IN THE RSUBR\r
+ PUSHJ P,@0 ;GO TO THE PROPER SUBROUTINE\r
+ SUBM M,(P) ;RECONSTITUTE THE RSUBR's PC\r
+ POPJ P,\r
+\r
+\r
+; ERRORS IN COMPILED CODE MAY END UP HERE\r
+\r
+COMPERR:\r
+ PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE ERROR-IN-COMPILED-CODE\r
+ JRST CALER1\r
+\f\r
+\r
+;CHTYPE TAKES TWO ARGUMENTS. ANY GOODIE AND A AN ATOMIC TYPE NAME\r
+;IT CHECKS THE STORAGE ALLOCATION TYPES OF THE TWO ARE THE SAME AND\r
+;IF THEY ARE CHANGES THE TYPE OF THE FIRST TO THAT NAME D IN THE SECOND\r
+\r
+MFUNCTION CHTYPE,SUBR\r
+\r
+ ENTRY 2\r
+ GETYP A,2(AB) ;FIRST CHECK THAT ARG 2 IS AN ATOM\r
+ CAIE A,TATOM \r
+ JRST NOTATOM\r
+ MOVE B,3(AB) ;AND TYPE NAME\r
+ PUSHJ P,TYPLOO ;GO LOOKUP TYPE\r
+TFOUND: HRRZ B,(A) ;GOBBLE THE SAT\r
+ TRNE B,CHBIT ; SKIP IF CHTYPABLE\r
+ JRST CANTCH\r
+ TRNE B,TMPLBT ; TEMPLAT\r
+ HRLI B,-1\r
+ AND B,[-1,,SATMSK]\r
+ GETYP A,(AB) ;NOW GET TYPE TO HACK\r
+ PUSHJ P,SAT ;FIND OUT ITS SAT\r
+ JUMPE A,TYPERR ;COMPLAIN\r
+ CAILE A,NUMSAT\r
+ JRST CHTMPL ; JUMP IF TEMPLATE DATA\r
+ CAIE A,(B) ;DO THEY AGREE?\r
+ JRST TYPDIF ;NO, COMPLAIN\r
+CHTMP1: MOVSI A,(D) ;GET NEW TYPE\r
+ HRR A,(AB) ; FOR DEFERRED GOODIES\r
+ JUMPL B,CHMATC ; CHECK IT\r
+ MOVE B,1(AB) ;AND VALUE\r
+ JRST FINIS\r
+\r
+CHTMPL: MOVE E,1(AB) ; GET ARG\r
+ HLRZ A,(E)\r
+ ANDI A,SATMSK\r
+ MOVE 0,3(AB) ; SEE IF TO "TEMPLATE"\r
+ CAME 0,MQUOTE TEMPLATE\r
+ CAIN A,(B)\r
+ JRST CHTMP1\r
+ JRST TYPDIF\r
+\r
+CHMATC: PUSH TP,A\r
+ PUSH TP,1(AB) ; SAVE GOODIE\r
+ MOVSI A,TATOM\r
+ MOVE B,3(AB)\r
+ MOVSI C,TATOM\r
+ MOVE D,MQUOTE DECL\r
+ PUSHJ P,IGET ; FIND THE DECL\r
+ MOVE C,(AB)\r
+ MOVE D,1(AB) ; NOW GGO TO MATCH\r
+ PUSHJ P,TMATCH\r
+ JRST TMPLVIO\r
+ POP TP,B\r
+ POP TP,A\r
+ JRST FINIS\r
+\r
+TYPLOO: PUSHJ P,TYPFND\r
+ JRST .+2\r
+ POPJ P,\r
+ PUSH TP,$TATOM ;LOST, GENERATE ERROR\r
+ PUSH TP,EQUOTE BAD-TYPE-NAME\r
+ JRST CALER1\r
+\r
+TYPFND: MOVE A,TYPVEC+1(TVP) ;GOBBLE DOWN TYPE VECTOR\r
+ MOVEI D,0 ;INITIALIZE TYPE COUNTER\r
+TLOOK: CAMN B,1(A) ;CHECK THIS ONE\r
+ JRST CPOPJ1\r
+ ADDI D,1 ;BUMP COUNTER\r
+ AOBJP A,.+2 ;COUTN DOWN ON VECTOR\r
+ AOBJN A,TLOOK\r
+ POPJ P,\r
+CPOPJ1: AOS (P)\r
+ POPJ P,\r
+\r
+TYPDIF: PUSH TP,$TATOM ;MAKE ERROR MESSAGE\r
+ PUSH TP,EQUOTE STORAGE-TYPES-DIFFER\r
+ JRST CALER1\r
+\r
+\r
+TMPLVI: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE DECL-VIOLATION\r
+ JRST CALER1\r
+\f\r
+\r
+; FUNCTION TO ADD A NEW TYPE TO THE WORLD WITH GIVEN PRIMITIVE TYPE\r
+\r
+MFUNCTION NEWTYPE,SUBR\r
+\r
+ ENTRY\r
+\r
+ HLRZ 0,AB ; CHEC # OF ARGS\r
+ CAILE 0,-4 ; AT LEAST 2\r
+ JRST TFA\r
+ CAIGE 0,-6\r
+ JRST TMA ; NOT MORE THAN 3\r
+ GETYP A,(AB) ; GET 1ST ARGS TYPE (SHOULD BE ATOM)\r
+ GETYP C,2(AB) ; SAME WITH SECOND\r
+ CAIN A,TATOM ; CHECK\r
+ CAIE C,TATOM\r
+ JRST NOTATOM\r
+\r
+ MOVE B,3(AB) ; GET PRIM TYPE NAME\r
+ PUSHJ P,TYPLOO ; LOOK IT UP\r
+ HRRZ A,(A) ; GOBBLE SAT\r
+ HRLI A,TATOM ; MAKE NEW TYPE\r
+ PUSH P,A ; AND SAVE\r
+ MOVE B,1(AB) ; SEE IF PREV EXISTED\r
+ PUSHJ P,TYPFND\r
+ JRST NEWTOK ; DID NOT EXIST BEFORE\r
+ MOVEI B,2(A) ; FOR POSSIBLE TMPLAT BIT\r
+ HRRZ A,(A) ; GET SAT\r
+ HRRZ 0,(P) ; AND PROPOSED\r
+ ANDI 0,SATMSK\r
+ ANDI A,SATMSK\r
+ CAIN 0,(A) ; SKIP IF LOSER\r
+ JRST NEWTFN ; O.K.\r
+\r
+ PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE TYPE-ALREADY-EXISTS\r
+ JRST CALER1\r
+\r
+NEWTOK: POP P,A\r
+ MOVE B,1(AB) ; NEWTYPE NAME\r
+ PUSHJ P,INSNT ; MUNG IN NEW TYPE\r
+\r
+NEWTFN: CAML AB,[-5,,] ; SKIP IF TEMPLAT SUPPLIED\r
+ JRST NEWTF1\r
+ MOVEI 0,TMPLBT ; GET THE BIT\r
+ IORM 0,-2(B) ; INTO WORD\r
+ MOVE A,(AB) ; GET TYPE NAME\r
+ MOVE B,1(AB)\r
+ MOVSI C,TATOM\r
+ MOVE D,MQUOTE DECL\r
+ PUSH TP,4(AB) ; GET TEMLAT\r
+ PUSH TP,5(AB)\r
+ PUSHJ P,IPUT\r
+NEWTF1: MOVE A,(AB)\r
+ MOVE B,1(AB) ; RETURN NAME\r
+ JRST FINIS\r
+\r
+; SET UP GROWTH FIELDS\r
+\r
+IGROWT: SKIPA A,[111100,,(C)]\r
+IGROWB: MOVE A,[001100,,(C)]\r
+ HLRE B,C\r
+ SUB C,B ; POINT TO DOPE WORD\r
+ MOVE B,TYPIC ; INDICATED GROW BLOCK\r
+ DPB B,A\r
+ POPJ P,\r
+\r
+INSNT: PUSH TP,A\r
+ PUSH TP,B ; SAVE NAME OF NEWTYPE\r
+ MOVE C,TYPBOT+1(TVP) ; CHECK GROWTH NEED\r
+ CAMGE C,TYPVEC+1(TVP)\r
+ JRST ADDIT ; STILL ROOM\r
+GAGN: PUSHJ P,IGROWB ; SETUP BOTTOM GROWTH\r
+ SKIPE C,EVATYP+1(TVP)\r
+ PUSHJ P,IGROWT ; SET UP TOP GROWTH\r
+ SKIPE C,APLTYP+1(TVP)\r
+ PUSHJ P,IGROWT\r
+ MOVE C,[11.,,5] ; SET UP INDICATOR FOR AGC\r
+ PUSHJ P,AGC ; GROW THE WORLD\r
+ AOJL A,GAGN ; BAD AGC LOSSAGE\r
+ MOVE 0,[-101,,-100]\r
+ ADDM 0,TYPBOT+1(TVP) ; FIX UP POINTER\r
+\r
+ADDIT: MOVE C,TYPVEC+1(TVP)\r
+ SUB C,[2,,2] ; ALLOCATE ROOM\r
+ MOVEM C,TYPVEC+1(TVP)\r
+ HLRE B,C ; PREPARE TO BLT\r
+ SUBM C,B ; C POINTS DOPE WORD END\r
+ HRLI C,2(C) ; GET BLT AC READY\r
+ BLT C,-3(B)\r
+ POP TP,-1(B) ; CLOBBER IT IN\r
+ POP TP,-2(B)\r
+ POPJ P,\r
+\r
+\f\r
+; Interface to interpreter for setting up tables associated with\r
+; template data structures.\r
+; A/ <\b-name of type>\b-\r
+; B/ <\b-length ins>\b-\r
+; C/ <\b-uvector of length code or 0>\r
+; D/ <\b-uvector of GETTERs>\b-\r
+; E/ <\b-uvector of PUTTERs>\b-\r
+\r
+CTMPLT: SUBM M,(P) ; could possibly gc during this stuff\r
+ SKIPE C ; for now dont handle vector of length ins\r
+ FATAL TEMPLATE DATA WITH COMPUTED LENGTH\r
+ PUSH TP,$TATOM ; save name of type\r
+ PUSH TP,A\r
+ PUSH P,B ; save length instr\r
+ HLRE A,TD.LNT+1(TVP) ; check for template slots left?\r
+ HRRZ B,TD.LNT+1(TVP)\r
+ SUB B,A ; point to dope words\r
+ HLRZ B,1(B) ; get real length\r
+ ADDM B,A ; any room?\r
+ JUMPG A,GOODRM ; jump if ok\r
+\r
+ PUSH TP,$TUVEC ; save getters and putters\r
+ PUSH TP,D\r
+ PUSH TP,$TUVEC\r
+ PUSH TP,E\r
+ MOVEI A,6(B) ; grow it 10 by copying\r
+ PUSH P,A ; save new length\r
+ PUSHJ P,CAFRE1 ; get frozen uvector\r
+ ADD B,[10,,10] ; rest it down some\r
+ HRL C,TD.LNT+1(TVP) ; prepare to BLT in\r
+ MOVEM B,TD.LNT+1(TVP) ; and save as new length vector\r
+ HRRI C,(B) ; destination\r
+ ADD B,(P) ; final destination address\r
+ BLT C,-13(B)\r
+ MOVE A,(P) ; length for new getters\r
+ PUSHJ P,CAFRE1\r
+ MOVE C,TD.GET+1(TVP) ; get old for copy\r
+ MOVEM B,TD.GET+1(TVP)\r
+ HRRI C,(B)\r
+ ADD B,(P)\r
+ BLT C,-13(B) ; zap those guys in\r
+ MOVE A,(P) ; finally putters\r
+ PUSHJ P,CAFRE1\r
+ MOVE C,TD.PUT+1(TVP)\r
+ MOVEM B,TD.PUT+1(TVP)\r
+ HRRI C,(B) ; BLT pointer\r
+ ADD B,(P)\r
+ BLT C,-13(B)\r
+ SUB P,[1,,1] ; flush stack craft\r
+ MOVE E,(TP)\r
+ MOVE D,-2(TP)\r
+ SUB TP,[4,,4]\r
+\r
+GOODRM: MOVE B,TD.LNT+1(TVP) ; move down to fit new guy\r
+ SUB B,[1,,1] ; will always win due to prev checks\r
+ MOVEM B,TD.LNT+1(TVP)\r
+ HRLI B,1(B)\r
+ HLRE A,TD.LNT+1(TVP)\r
+ MOVNS A\r
+ ADDI A,-1(B) ; A/ final destination\r
+ BLT B,-1(A)\r
+ POP P,(A) ; new length ins munged in\r
+ HLRE A,TD.LNT+1(TVP)\r
+ MOVNS A ; A/ offset for other guys\r
+ PUSH P,A ; save it\r
+ ADD A,TD.GET+1(TVP) ; point for storing uvs of ins\r
+ MOVEM D,-1(A)\r
+ MOVE A,(P)\r
+ ADD A,TD.PUT+1(TVP)\r
+ MOVEM E,-1(A) ; store putter also\r
+ POP P,A ; compute primtype\r
+ ADDI A,NUMSAT\r
+ HRLI A,TATOM\r
+ MOVE B,(TP) ; ready to mung type vector\r
+ SUB TP,[2,,2]\r
+ PUSHJ P,INSNT ; insert into vector\r
+ JRST MPOPJ\r
+\f\r
+\r
+; FUNCTIONS TO SET UP EVALUATION AND APPLICATION RULES FOR DATA TYPES\r
+\r
+MFUNCTION EVALTYPE,SUBR\r
+\r
+ ENTRY 2\r
+\r
+ PUSHJ P,CHKARG ; VERIFY WINNAGE IN ARGS\r
+ MOVEI A,EVATYP ; POINT TO TABLE\r
+ MOVEI E,EVTYPE ; POINT TO PURE VERSION\r
+TBLCAL: PUSHJ P,TBLSET ; SETUP TABLE ENTRY\r
+ JRST FINIS\r
+\r
+MFUNCTION APPLYTYPE,SUBR\r
+\r
+ ENTRY 2\r
+\r
+ PUSHJ P,CHKARG\r
+ MOVEI A,APLTYP ; POINT TO APPLY TABLE\r
+ MOVEI E,APTYPE ; PURE TABLE\r
+ JRST TBLCAL\r
+\r
+\r
+MFUNCTION PRINTTYPE,SUBR\r
+\r
+ ENTRY 2\r
+\r
+ PUSHJ P,CHKARG\r
+ MOVEI A,PRNTYP ; POINT TO APPLY TABLE\r
+ MOVEI E,PRTYPE ; PURE TABLE\r
+ JRST TBLCAL\r
+\r
+; CHECK ARGS AND SETUP FOR TABLE HACKER\r
+\r
+CHKARG: GETYP A,(AB) ; 1ST MUST BE TYPE NAME\r
+ CAIE A,TATOM\r
+ JRST WTYP1\r
+ MOVE B,1(AB) ; GET ATOM\r
+ PUSHJ P,TYPLOO ; VERIFY THAT IT IS A TYPE\r
+ PUSH P,D ; SAVE TYPE NO.\r
+ HRRZ A,(A) ; GET SAT\r
+ ANDI A,SATMSK\r
+ PUSH P,A\r
+ GETYP A,2(AB) ; GET 2D TYPE\r
+ CAIE A,TATOM ; EITHER TYPE OR APPLICABLE\r
+ JRST TRYAPL ; TRY APPLICABLE\r
+ MOVE B,3(AB) ; VERIFY IT IS A TYPE\r
+ PUSHJ P,TYPLOO\r
+ HRRZ A,(A) ; GET SAT\r
+ ANDI A,SATMSK\r
+ POP P,C ; RESTORE SAVED SAT\r
+ CAIE A,(C) ; SKIP IF A WINNER\r
+ JRST TYPDIF ; REPORT ERROR\r
+ POP P,C ; GET SAVED TYPE\r
+ MOVEI B,0 ; TELL THAT WE ARE A TYPE\r
+ POPJ P,\r
+\r
+TRYAPL: PUSHJ P,APLQ ; IS THIS APPLICABLE\r
+ JRST NAPT\r
+ SUB P,[1,,1]\r
+ MOVE B,2(AB) ; RETURN SAME\r
+ MOVE D,3(AB)\r
+ POP P,C\r
+ POPJ P,\r
+\r
+\f\r
+; HERE TO PUT ENTRY IN APPROPRIATE TABLE\r
+\r
+TBLSET: HRLI A,(A) ; FOR TVP HACKING\r
+ ADD A,TVP ; POINT TO TVP SLOT\r
+ PUSH TP,B\r
+ PUSH TP,D ; SAVE VALUE \r
+ PUSH TP,$TVEC\r
+ PUSH TP,A\r
+ PUSH P,C ; SAVE TYPE BEING HACKED\r
+ PUSH P,E\r
+ SKIPE B,1(A) ; SKIP IF VECTOR DOESN'T EXIST YET\r
+ JRST TBL.OK\r
+ HLRE A,TYPBOT+1(TVP) ; GET CURRENT TABLE LNTH\r
+ MOVNS A\r
+ ASH A,-1\r
+ PUSHJ P,IVECT ; GET VECTOR\r
+ MOVE C,(TP) ; POINT TO RETURN POINT\r
+ MOVEM B,1(C) ; SAVE VECTOR\r
+\r
+TBL.OK: POP P,E\r
+ POP P,C ; RESTORE TYPE\r
+ SUB TP,[2,,2]\r
+ POP TP,D\r
+ POP TP,A\r
+ JUMPN A,TBLOK1 ; JUMP IF FUNCTION ETC. SUPPLIED\r
+ CAILE D,NUMPRI ; SKIP IF ORIGINAL TYPE\r
+ MOVNI E,(D) ; CAUSE E TO ENDUP 0\r
+ ADDI E,(D) ; POINT TO PURE SLOT\r
+TBLOK1: ADDI C,(C) ; POINT TO VECTOR SLOT\r
+ ADDI C,(B)\r
+ JUMPN A,OK.SET ; OK TO CLOBBER\r
+ ADDI B,(D) ; POINT TO TARGET TYPE'S SLOT\r
+ ADDI B,(D) ; POINT TO TARGET TYPE'S SLOT\r
+ SKIPN A,(B) ; SKIP IF WINNER\r
+ SKIPE 1(B) ; SKIP IF LOSER\r
+ SKIPA D,1(B) ; SETUP D\r
+ JRST CH.PTB ; CHECK PURE TABLE\r
+\r
+OK.SET: MOVEM A,(C) ; STORE\r
+ MOVEM D,1(C)\r
+ MOVE A,(AB) ; RET TYPE\r
+ MOVE B,1(AB)\r
+ JRST FINIS\r
+\r
+CH.PTB: MOVEI A,0\r
+ MOVE D,[SETZ NAPT]\r
+ JUMPE E,OK.SET\r
+ MOVE D,(E)\r
+ JRST OK.SET\r
+\r
+CALLTY: MOVE A,TYPVEC(TVP)\r
+ MOVE B,TYPVEC+1(TVP)\r
+ POPJ P,\r
+\r
+MFUNCTION ALLTYPES,SUBR\r
+\r
+ ENTRY 0\r
+\r
+ MOVE A,TYPVEC(TVP)\r
+ MOVE B,TYPVEC+1(TVP)\r
+ JRST FINIS\r
+\r
+;\f\r
+\r
+;FUNCTION TO RETURN TYPE OF ELEMENTS IN A UVECTOR\r
+\r
+MFUNCTION UTYPE,SUBR\r
+\r
+ ENTRY 1\r
+\r
+ GETYP A,(AB) ;GET U VECTOR\r
+ PUSHJ P,SAT\r
+ CAIE A,SNWORD\r
+ JRST WTYP1\r
+ MOVE B,1(AB) ; GET UVECTOR\r
+ PUSHJ P,CUTYPE\r
+ JRST FINIS\r
+\r
+CUTYPE: HLRE A,B ;GET -LENGTH\r
+ HRRZS B\r
+ SUB B,A ;POINT TO TYPE WORD\r
+ GETYP A,(B)\r
+ JRST ITYPE ; GET NAME OF TYPE\r
+\r
+; FUNCTION TO CHANGE UNIFORM TYPE OF A VECTOR\r
+\r
+MFUNCTION CHUTYPE,SUBR\r
+\r
+ ENTRY 2\r
+\r
+ GETYP A,2(AB) ;GET 2D TYPE\r
+ CAIE A,TATOM\r
+ JRST NOTATO\r
+ GETYP A,(AB) ; CALL WITH UVECTOR?\r
+ PUSHJ P,SAT\r
+ CAIE A,SNWORD\r
+ JRST WTYP1\r
+ MOVE A,1(AB) ; GET UV POINTER\r
+ MOVE B,3(AB) ;GET ATOM\r
+ PUSHJ P,CCHUTY\r
+ MOVE A,(AB) ; RETURN UVECTOR\r
+ MOVE B,1(AB)\r
+ JRST FINIS\r
+\r
+CCHUTY: PUSH TP,$TUVEC\r
+ PUSH TP,A\r
+ PUSHJ P,TYPLOO ;LOOK IT UP\r
+ HRRZ B,(A) ;GET SAT\r
+ TRNE B,CHBIT\r
+ JRST CANTCH\r
+ ANDI B,SATMSK\r
+ HLRE C,(TP) ;-LENGTH\r
+ HRRZ E,(TP)\r
+ SUB E,C ;POINT TO TYPE\r
+ GETYP A,(E) ;GET TYPE\r
+ JUMPE A,WIN0 ;ALLOW TYPE "LOSE" TO CHANGE TO ANYTHING\r
+ PUSHJ P,SAT ;GET SAT\r
+ JUMPE A,TYPERR\r
+ CAIE A,(B) ;COMPARE\r
+ JRST TYPDIF\r
+WIN0: HRLM D,(E) ;CLOBBER NEW ONE\r
+ POP TP,B\r
+ POP TP,A\r
+ POPJ P,\r
+\r
+CANTCH: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE CANT-CHTYPE-INTO\r
+ PUSH TP,2(AB)\r
+ PUSH TP,3(AB)\r
+ MOVEI A,2\r
+ JRST CALER\r
+\r
+NOTATOM:\r
+ PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE NON-ATOMIC-ARGUMENT\r
+ PUSH TP,(AB)\r
+ PUSH TP,1(AB)\r
+ MOVEI A,2\r
+ JRST CALER\r
+\r
+\r
+\f\r
+; SUBROUTINE TO LEAVE MUDDLE CLOSING ALL CHANNELS ON THE WAY\r
+\r
+MFUNCTION QUIT,SUBR\r
+\r
+ ENTRY 0\r
+\r
+\r
+ PUSHJ P,CLOSAL ; DO THE CLOSES\r
+ PUSHJ P,%KILLM\r
+ JRST IFALSE ; JUST IN CASE\r
+\r
+CLOSAL: MOVE B,TVP ; POINT TO XFER VECCTOR\r
+ ADD B,[CHNL0+2,,CHNL0+2] ; POINT TO 1ST (NOT INCLUDING TTY I/O)\r
+ PUSH TP,$TVEC\r
+ PUSH TP,B\r
+ PUSH P,[N.CHNS-1] ; MAX NO. OF CHANS\r
+\r
+CLOSA1: MOVE B,(TP)\r
+ ADD B,[2,,2]\r
+ MOVEM B,(TP)\r
+ SKIPN C,-1(B) ; THIS ONE OPEN?\r
+ JRST CLOSA4 ; NO\r
+ CAME C,TTICHN+1(TVP)\r
+ CAMN C,TTOCHN+1(TVP)\r
+ JRST CLOSA4\r
+ PUSH TP,-2(B) ; PUSH IT\r
+ PUSH TP,-1(B)\r
+ MCALL 1,FCLOSE ; CLOSE IT\r
+CLOSA4: SOSLE (P) ; COUNT DOWN\r
+ JRST CLOSA1\r
+\r
+\r
+ SUB TP,[2,,2]\r
+ SUB P,[1,,1]\r
+\r
+CLOSA3: SKIPN B,CHNL0+1(TVP)\r
+ POPJ P,\r
+ PUSH TP,(B)\r
+ HLLZS (TP)\r
+ PUSH TP,1(B)\r
+ HRRZ B,(B)\r
+ MOVEM B,CHNL0+1(TVP)\r
+ MCALL 1,FCLOSE\r
+ JRST CLOSA3\r
+\f\r
+; LITTLE ROUTINES USED ALL OVER THE PLACE\r
+\r
+CRLF: MOVEI A,15\r
+ PUSHJ P,MTYO\r
+ MOVEI A,12\r
+ JRST MTYO\r
+MSGTYP: HRLI B,440700 ;MAKE BYTE POINTER\r
+MSGTY1: ILDB A,B ;GET NEXT CHARACTER\r
+ JUMPE A,CPOPJ ;NULL ENDS STRING\r
+ CAIE A,177 ; DONT PRINT RUBOUTS\r
+ PUSHJ P,MTYO"\r
+ JRST MSGTY1 ;AND GET NEXT CHARACTER\r
+CPOPJ: POPJ P,\r
+\r
+IMPURE\r
+\r
+WHOAMI: 0 ; SYAYS WHETHER I AM REALLY A MUDDLE OR SOME HACK\r
+\r
+\r
+;GARBAGE COLLECTORS PDLS\r
+\r
+\r
+GCPDL: -GCPLNT,,GCPDL\r
+\r
+ BLOCK GCPLNT\r
+\r
+\r
+PURE\r
+\r
+MUDSTR: ASCII /MUDDLE \7f\7f\7f/\r
+STRNG: -1\r
+ -1\r
+ -1\r
+ ASCIZ / IN OPERATION./\r
+\r
+;MARKED PDLS FOR GC PROCESS\r
+\r
+VECTGO\r
+; DUMMY FRAME FOR INITIALIZER CALLS\r
+\r
+ TENTRY,,LISTEN\r
+ 0\r
+ .-3\r
+ 0\r
+ 0\r
+ -ITPLNT,,TPBAS-1\r
+ 0\r
+\r
+TPBAS: BLOCK ITPLNT+PDLBUF\r
+ GENERAL\r
+ ITPLNT+2+PDLBUF+7,,0\r
+\r
+\r
+VECRET\r
+\r
+\r
+\r
+\r
+$TMATO: TATOM,,-1\r
+\r
+\r
+PATCH:\r
+PAT: BLOCK 100\r
+PATEND: 0\r
+\r
+END\r
+\f\r
projects / pdp10-muddle.git / blobdiff