--- /dev/null
+TITLE ATOMHACKER FOR MUDDLE\r
+\r
+RELOCATABLE\r
+\r
+.INSRT MUDDLE >\r
+.GLOBAL RLOOKU,CHMAK,OBLNT,ROOT,INTOBL,ERROBL,IFALSE\r
+.GLOBAL .BLOCK,IDVAL,NXTDCL,CHRWRD,CSTACK,CSTAK,ILOOKC,IGVAL,BYTDOP\r
+.GLOBAL ICONS,INCONS,IBLOCK,INSRTX,GCHACK,IMPURIFY\r
+.GLOBAL CINSER,CIRMV,CLOOKU,CATOM,CIPNAM,MPOPJ,CSETG\r
+\r
+.VECT.==40000 ; BIT FOR GCHACK\r
+\r
+; FUNCTION TO GENERATE AN EMPTY OBLIST\r
+\r
+MFUNCTION MOBLIST,SUBR\r
+\r
+ ENTRY\r
+ CAMGE AB,[-5,,0] ;CHECK NUMBER OF ARGS\r
+ JRST TMA\r
+ JUMPGE AB,MOBL2 ; NO ARGS\r
+ PUSH TP,(AB)\r
+ PUSH TP,1(AB)\r
+ PUSH TP,$TATOM\r
+ PUSH TP,IMQUOTE OBLIST\r
+ MCALL 2,GET ; CHECK IF IT EXISTS ALREADY\r
+ CAMN A,$TOBLS\r
+ JRST FINIS\r
+MOBL2: MOVE A,OBLNT ;GET DEFAULT LENGTH\r
+ CAML AB,[-3,,0] ;IS LENGTH SUPPLIED\r
+ JRST MOBL1 ;NO, USE STANDARD LENGTH\r
+ GETYP C,2(AB) ;GET ARG TYPE\r
+ CAIE C,TFIX\r
+ JRST WTYP2 ;LOSE\r
+ MOVE A,3(AB) ;GET LENGTH\r
+MOBL1: PUSH TP,$TFIX\r
+ PUSH TP,A\r
+ MCALL 1,UVECTOR ;GET A UNIFORM VECTOR\r
+ MOVSI C,TLIST+.VECT. ;IT IS OF TYPE LIST\r
+ HLRE D,B ;-LENGTH TO D\r
+ SUBM B,D ;D POINTS TO DOPE WORD\r
+ MOVEM C,(D) ;CLOBBER TYPE IN\r
+ MOVSI A,TOBLS\r
+ JUMPGE AB,FINIS ; IF NO ARGS, DONE\r
+ GETYP A,(AB)\r
+ CAIE A,TATOM\r
+ JRST WTYP1\r
+ PUSH TP,$TOBLS\r
+ PUSH TP,B\r
+ PUSH TP,$TOBLS\r
+ PUSH TP,B\r
+ PUSH TP,$TATOM\r
+ PUSH TP,IMQUOTE OBLIST\r
+ PUSH TP,(AB)\r
+ PUSH TP,1(AB)\r
+ MCALL 3,PUT ; PUT THE NAME ON THE OBLIST\r
+ PUSH TP,(AB)\r
+ PUSH TP,1(AB)\r
+ PUSH TP,$TATOM\r
+ PUSH TP,IMQUOTE OBLIST\r
+ PUSH TP,(TB)\r
+ PUSH TP,1(TB)\r
+ MCALL 3,PUT ; PUT THE OBLIST ON THE NAME\r
+\r
+ POP TP,B\r
+ POP TP,A\r
+ JRST FINIS\r
+\r
+MFUNCTION GROOT,SUBR,ROOT\r
+ ENTRY 0\r
+ MOVE A,ROOT(TVP)\r
+ MOVE B,ROOT+1(TVP)\r
+ JRST FINIS\r
+\r
+MFUNCTION GINTS,SUBR,INTERRUPTS\r
+ ENTRY 0\r
+ MOVE A,INTOBL(TVP)\r
+ MOVE B,INTOBL+1(TVP)\r
+ JRST FINIS\r
+\r
+MFUNCTION GERRS,SUBR,ERRORS\r
+ ENTRY 0\r
+ MOVE A,ERROBL(TVP)\r
+ MOVE B,ERROBL+1(TVP)\r
+ JRST FINIS\r
+\r
+\r
+COBLQ: SKIPN B,2(B) ; SKIP IF EXISTS\r
+ JRST IFLS\r
+ MOVSI A,TOBLS\r
+ JUMPL B,CPOPJ1\r
+ ADDI B,(TVP)\r
+ MOVE B,(B)\r
+CPOPJ1: AOS (P)\r
+ POPJ P,\r
+\r
+IFLS: MOVEI B,0\r
+ MOVSI A,TFALSE\r
+ POPJ P,\r
+\r
+MFUNCTION OBLQ,SUBR,[OBLIST?]\r
+\r
+ ENTRY 1\r
+ GETYP A,(AB)\r
+ CAIE A,TATOM\r
+ JRST WTYP1\r
+ MOVE B,1(AB) ; GET ATOM\r
+ PUSHJ P,COBLQ\r
+ JFCL\r
+ JRST FINIS\r
+\r
+\f; FUNCTION TO FIND AN ATOM ON A GIVEN OBLIST WITH A GIVEN PNAME\r
+\r
+MFUNCTION LOOKUP,SUBR\r
+\r
+ ENTRY 2\r
+ PUSHJ P,ILOOKU ;CALL INTERNAL ROUTINE\r
+ JRST FINIS\r
+\r
+CLOOKU: SUBM M,(P)\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ MOVEI B,-1(TP)\r
+ PUSH TP,$TOBLS\r
+ PUSH TP,C\r
+ GETYP A,A\r
+ PUSHJ P,CSTAK\r
+ MOVE B,(TP)\r
+ PUSHJ P,ILOOK\r
+ POP P,D\r
+ HRLI D,(D)\r
+ SUB P,D\r
+ SKIPE B\r
+ SOS (P)\r
+ SUB TP,[4,,4]\r
+ JRST MPOPJ\r
+\r
+ILOOKU: PUSHJ P,ARGCHK ;CHECK ARGS\r
+ PUSHJ P,CSTACK ;PUT CHARACTERS ON THE STACK\r
+\r
+CALLIT: MOVE B,3(AB) ;GET OBLIST\r
+ILOOKC: PUSHJ P,ILOOK ;LOOK IT UP\r
+ POP P,D ;RESTORE COUNT\r
+ HRLI D,(D) ;TO BOTH SIDES\r
+ SUB P,D\r
+ POPJ P,\r
+\r
+;THIS ROUTINE CHECKS ARG TYPES\r
+\r
+ARGCHK: GETYP A,(AB) ;GET TYPES\r
+ GETYP C,2(AB)\r
+ CAIE A,TCHRS ;IS IT EITHER CHAR STRING\r
+ CAIN A,TCHSTR\r
+ CAIE C,TOBLS ;IS 2ND AN OBLIST\r
+ JRST WRONGT ;TYPES ARE WRONG\r
+ POPJ P,\r
+\r
+;THIS SUBROUTINE PUTS CHARACTERS ON THE STACK (P WILL BE CHANGED)\r
+\r
+\r
+CSTACK: MOVEI B,(AB)\r
+CSTAK: POP P,D ;RETURN ADDRESS TO D\r
+ CAIE A,TCHRS ;IMMEDIATE?\r
+ JRST NOTIMM ;NO, HAIR\r
+ MOVE A,1(B) ; GET CHAR\r
+ LSH A,29. ; POSITION\r
+ PUSH P,A ;ONTO P\r
+ PUSH P,[1] ;WITH NUMBER\r
+ JRST (D) ;GO CALL SEARCHER\r
+\r
+NOTIMM: MOVEI A,1 ; CLEAR CHAR COUNT\r
+ HRRZ C,(B) ; GET COUNT OF CHARS\r
+ JUMPE C,NULST ; FLUSH NULL STRING\r
+ MOVE B,1(B) ;GET BYTE POINTER\r
+\r
+CLOOP1: PUSH P,[0] ; STORE CHARS ON STACK\r
+ MOVSI E,(<440700,,(P)>) ; SETUP BYTE POINTER\r
+CLOOP: ILDB 0,B ;GET A CHARACTER\r
+ IDPB 0,E ;STORE IT\r
+ SOJE C,CDONE ; ANY MORE?\r
+ TLNE E,760000 ; WORD FULL\r
+ JRST CLOOP ;NO CONTINUE\r
+ AOJA A,CLOOP1 ;AND CONTINUE\r
+\r
+CDONE:\r
+CDONE1: PUSH P,A ;AND NUMBER OF WORDS\r
+ JRST (D) ;RETURN\r
+\r
+\r
+NULST: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE NULL-STRING\r
+ JRST CALER1\r
+\f; THIS FUNCTION LOOKS FOR ATOMS. CALLED BY PUSHJ P,ILOOK\r
+; B/ OBLIST POINTER\r
+; -1(P)/ LENGTH IN WORDS OF CHARACTER BLOCK\r
+; CHAR STRING IS ON THE STACK\r
+\r
+ILOOK: MOVN A,-1(P) ;GET -LENGTH\r
+ HRLI A,-1(A) ;<-LENGTH-1>,,-LENGTH\r
+ PUSH TP,$TFIX ;SAVE\r
+ PUSH TP,A\r
+ ADDI A,-1(P) ;HAVE AOBJN POINTER TO CHARS\r
+ MOVEI D,0 ;HASH WORD\r
+ XOR D,(A)\r
+ AOBJN A,.-1 ;XOR THEM ALL TOGETHER\r
+ HLRE A,B ;GET LENGTH OF OBLIST\r
+ MOVNS A\r
+ TLZ D,400000 ; MAKE SURE + HASH CODE\r
+ IDIVI D,(A) ;DIVIDE\r
+ HRLI E,(E) ;TO BOTH HALVES\r
+ ADD B,E ;POINT TO BUCKET\r
+\r
+ MOVEI 0,(B) ;IN CASE REMOVING 1ST\r
+ SKIPN C,(B) ;BUCKET EMPTY?\r
+ JRST NOTFND ;YES, GIVE UP\r
+LOOK2: SKIPN A,1(C) ;NIL CAR ON LIST?\r
+ JRST NEXT ;YES TRY NEXT\r
+ ADD A,[3,,3] ;POINT TO ATOMS PNAME\r
+ MOVE D,(TP) ;GET PSEUDO AOBJN POINTER TO CHARS\r
+ ADDI D,-1(P) ;NOW ITS A REAL AOBJN POINTER\r
+ JUMPE D,CHECK0 ;ONE IS EMPTY\r
+LOOK1: MOVE E,(D) ;GET A WORD\r
+ CAME E,(A) ;COMPARE\r
+ JRST NEXT ;THIS ONE DOESN'T MATCH\r
+ AOBJP D,CHECK ;ONE RAN OUT\r
+ AOBJN A,LOOK1 ;JUMP IF STILL MIGHT WIN\r
+\r
+NEXT: MOVEI 0,(C) ;POINT TO PREVIOUS ELEMENT\r
+ HRRZ C,(C) ;STEP THROUGH\r
+ JUMPN C,LOOK2\r
+\r
+NOTFND: EXCH C,B ;RETURN BUCKET IN B\r
+ MOVSI A,TFALSE\r
+CPOPJT: SUB TP,[2,,2] ;REMOVE RANDOM TP STUFF\r
+ POPJ P,\r
+\r
+CHECK0: JUMPN A,NEXT ;JUMP IF NOT ALSO EMPTY\r
+ SKIPA\r
+CHECK: AOBJN A,NEXT ;JUMP IF NO MATCH\r
+ HLLZ A,(C)\r
+ MOVE E,B ; RETURN BUCKET\r
+ MOVE B,1(C) ;GET ATOM\r
+ JRST CPOPJT\r
+\r
+\r
+\f; FUNCTION TO INSERT AN ATOM ON AN OBLIST\r
+\r
+MFUNCTION INSERT,SUBR\r
+\r
+ ENTRY 2\r
+ GETYP A,2(AB)\r
+ CAIE A,TOBLS\r
+ JRST WTYP2\r
+ MOVE A,(AB)\r
+ MOVE B,1(AB)\r
+ MOVE C,3(AB)\r
+ PUSHJ P,IINSRT\r
+ JRST FINIS\r
+\r
+CINSER: SUBM M,(P)\r
+ PUSHJ P,IINSRT\r
+ JRST MPOPJ\r
+\r
+IINSRT: PUSH TP,A\r
+ PUSH TP,B\r
+ PUSH TP,$TOBLS\r
+ PUSH TP,C\r
+ GETYP A,A\r
+ CAIN A,TATOM\r
+ JRST INSRT0\r
+\r
+;INSERT WITH A GIVEN PNAME\r
+\r
+ CAIE A,TCHRS\r
+ CAIN A,TCHSTR\r
+ JRST .+2\r
+ JRST WTYP1\r
+\r
+ PUSH TP,$TFIX ;FLAG CALL\r
+ PUSH TP,[0]\r
+ MOVEI B,-5(TP)\r
+ PUSHJ P,CSTAK ;COPY ONTO STACK\r
+ MOVE B,-2(TP)\r
+ PUSHJ P,ILOOK ;LOOK IT UP (BUCKET RETURNS IN C)\r
+ JUMPN B,ALRDY ;EXISTS, LOSE\r
+ MOVE D,-2(TP) ; GET OBLIST BACK\r
+INSRT1: PUSH TP,$TOBLS ;SAVE BUCKET POINTER\r
+ PUSH TP,C\r
+ PUSH TP,$TOBLS\r
+ PUSH TP,D ; SAVE OBLIST\r
+INSRT3: PUSHJ P,IATOM ; MAKE AN ATOM\r
+ PUSHJ P,LINKCK ; A LINK REALLY NEEDED ?\r
+ MOVE E,-2(TP)\r
+ HRRZ E,(E) ; GET BUCKET\r
+ PUSHJ P,ICONS\r
+ MOVE C,-2(TP) ;BUCKET AGAIN\r
+ HRRM B,(C) ;INTO NEW BUCKET\r
+ MOVSI A,TATOM\r
+ MOVE B,1(B) ;GET ATOM BACK\r
+ MOVE D,(TP) ; GET OBLIST\r
+ MOVEM D,2(B) ; AND CLOBBER\r
+ MOVE C,-4(TP) ;GET FLAG\r
+ SUB TP,[6,,6] ;POP STACK\r
+ JUMPN C,(C)\r
+ SUB TP,[4,,4]\r
+ POPJ P,\r
+\r
+;INSERT WITH GIVEN ATOM\r
+INSRT0: MOVE A,-2(TP) ;GOBBLE PNAME\r
+ SKIPE 2(A) ; SKIP IF NOT ON AN OBLIST\r
+ JRST ONOBL\r
+ ADD A,[3,,3]\r
+ HLRE C,A\r
+ MOVNS C\r
+ PUSH P,(A) ;FLUSH PNAME ONTO P STACK\r
+ AOBJN A,.-1\r
+ PUSH P,C\r
+ MOVE B,(TP) ; GET OBLIST FOR LOOKUP\r
+ PUSHJ P,ILOOK ;ALREADY THERE?\r
+ JUMPN B,ALRDY\r
+ PUSH TP,$TOBLS ;SAVE NECESSARY STUFF AWAY FROM CONS\r
+ PUSH TP,C ;WHICH WILL MAKE A LIST FROM THE ATOM\r
+ MOVSI C,TATOM\r
+ MOVE D,-4(TP)\r
+ PUSHJ P,INCONS\r
+ MOVE C,(TP) ;RESTORE\r
+ HRRZ D,(C)\r
+ HRRM B,(C)\r
+ HRRM D,(B)\r
+ MOVE C,-2(TP)\r
+ MOVE B,-4(TP) ; GET BACK ATOM\r
+ MOVEM C,2(B) ; CLOBBER OBLIST IN\r
+ MOVSI A,TATOM\r
+ SUB TP,[6,,6]\r
+ POP P,C\r
+ HRLI C,(C)\r
+ SUB P,C\r
+ POPJ P,\r
+\r
+LINKCK: HRRZ C,FSAV(TB) ;CALLER'S NAME\r
+ CAIN C,LINK\r
+ SKIPA C,$TLINK ;LET US INSERT A LINK INSTEAD OF AN ATOM\r
+ MOVSI C,TATOM ;GET REAL ATOM FOR CALL TO ICONS\r
+ MOVE D,B\r
+ POPJ P,\r
+\r
+\r
+\r
+ALRDY: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE ATOM-ALREADY-THERE\r
+ JRST CALER1\r
+\r
+ONOBL: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE ON-AN-OBLIST-ALREADY\r
+ JRST CALER1\r
+\r
+; INTERNAL INSERT CALL\r
+\r
+INSRTX: POP P,0 ; GET RET ADDR\r
+ PUSH TP,$TFIX\b \r
+ PUSH TP,0\r
+ PUSH TP,$TOBLS\r
+ PUSH TP,B\r
+ PUSH TP,$TOBLS\r
+ PUSH TP,B\r
+ PUSHJ P,ILOOK\r
+ JUMPN B,INSRXT\r
+ MOVEM C,-2(TP)\r
+ JRST INSRT3 ; INTO INSERT CODE\r
+\r
+INSRXT: PUSH P,-4(TP)\r
+ SUB TP,[6,,6]\r
+ POPJ P,\r
+ JRST IATM1\r
+\f\r
+; FUNCTION TO REMOVE AN ATOM FROM AN OBLIST\r
+\r
+MFUNCTION REMOVE,SUBR\r
+\r
+ ENTRY\r
+\r
+ JUMPGE AB,TFA\r
+ CAMGE AB,[-5,,]\r
+ JRST TMA\r
+ MOVEI C,0\r
+ CAML AB,[-3,,] ; SKIP IF OBLIST GIVEN\r
+ JRST .+5\r
+ GETYP 0,2(AB)\r
+ CAIE 0,TOBLS\r
+ JRST WTYP2\r
+ MOVE C,3(AB)\r
+ MOVE A,(AB)\r
+ MOVE B,1(AB)\r
+ PUSHJ P,IRMV\r
+ JRST FINIS\r
+\r
+CIRMV: SUBM M,(P)\r
+ PUSHJ P,IRMV\r
+ JRST MPOPJ\r
+\r
+IRMV: PUSH TP,A\r
+ PUSH TP,B\r
+ PUSH TP,$TOBLS\r
+ PUSH TP,C\r
+IRMV1: GETYP 0,A ; CHECK 1ST ARG\r
+ CAIN 0,TLINK\r
+ JRST .+3\r
+ CAIE 0,TATOM ; ATOM, TREAT ACCORDINGLY\r
+ JRST RMV1\r
+\r
+ SKIPN D,2(B) ; SKIP IF ON OBLIST AND GET SAME\r
+ JRST IFALSE\r
+ JUMPL D,.+3\r
+ ADDI D,(TVP)\r
+ MOVE D,(D)\r
+ JUMPE C,GOTOBL\r
+ CAME C,D ; BETTER BE THE SAME\r
+ JRST ONOTH\r
+\r
+GOTOBL: ADD B,[3,,3] ; POINT TO PNAME\r
+ HLRE A,B\r
+ MOVNS A\r
+ PUSH P,(B) ; PUSH PNAME\r
+ AOBJN B,.-1\r
+ PUSH P,A\r
+ MOVEM D,(TP) ; SAVE OBLIST\r
+ JRST RMV3\r
+\r
+RMV1: JUMPE C,TFA\r
+ CAIE 0,TCHRS\r
+ CAIN 0,TCHSTR\r
+ SKIPA A,0\r
+ JRST WTYP1\r
+ MOVEI B,-3(TP)\r
+ PUSHJ P,CSTAK\r
+RMV3: MOVE B,(TP)\r
+ PUSHJ P,ILOOK\r
+ POP P,D\r
+ HRLI D,(D)\r
+ SUB P,D\r
+ JUMPE B,RMVDON\r
+ HRRZ D,0 ;PREPARE TO SPLICE (0 POINTS PRIOR TO LOSING PAIR)\r
+ HRRZ C,(C) ;GET NEXT OF LOSING PAIR\r
+ MOVEI 0,(B)\r
+ CAIGE 0,HIBOT ; SKIP IF PURE\r
+ JRST RMV2\r
+ PUSHJ P,IMPURIFY\r
+ MOVE A,-3(TP)\r
+ MOVE B,-2(TP)\r
+ MOVE C,(TP)\r
+ JRST IRMV1\r
+RMV2: HRRM C,(D) ;AND SPLICE\r
+ SETZM 2(B) ; CLOBBER OBLIST SLOT\r
+RMVDON: SUB TP,[4,,4]\r
+ POPJ P,\r
+\r
+\f\r
+;INTERNAL CALL FROM THE READER\r
+\r
+RLOOKU: PUSH TP,$TFIX ;PUSH A FLAG\r
+ POP P,C ;POP OFF RET ADR\r
+ PUSH TP,C ;AND USE AS A FLAG FOR INTERNAL\r
+ MOVE C,(P) ; CHANGE CHAR COUNT TO WORD\r
+ ADDI C,4\r
+ IDIVI C,5\r
+ MOVEM C,(P)\r
+\r
+ CAMN A,$TOBLS ;IS IT ONE OBLIST?\r
+ JRST RLOOK1\r
+ CAME A,$TLIST ;IS IT A LIST\r
+ JRST BADOBL\r
+\r
+ JUMPE B,BADLST\r
+ PUSH TP,$TOBLS ; SLOT FOR REMEBERIG\r
+ PUSH TP,[0]\r
+ PUSH TP,$TOBLS\r
+ PUSH TP,[0]\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+\r
+RLOOK2: GETYP A,(B) ;CHECK THIS IS AN OBLIST\r
+ MOVE B,1(B) ;VALUE\r
+ CAIE A,TOBLS\r
+ JRST DEFALT\r
+ PUSHJ P,ILOOK ;LOOK IT UP\r
+ JUMPN B,RLOOK3 ;WIN\r
+ SKIPE -2(TP) ; SKIP IF DEFAULT NOT STORED\r
+ JRST RLOOK4\r
+ HRRZ D,(TP) ; GET CURRENT\r
+ MOVE D,1(D) ; OBLIST\r
+ MOVEM D,-2(TP)\r
+ MOVEM C,-4(TP) ; FOR INSERT IF NEEDED\r
+RLOOK4: INTGO\r
+ HRRZ B,@(TP) ;CDR THE LIST\r
+ HRRZM B,(TP)\r
+ JUMPN B,RLOOK2\r
+ SKIPN D,-2(TP) ; RESTORE FOR INSERT\r
+ JRST BADDEF ; NO DEFAULT, USER LOST ON SPECIFICATION\r
+ MOVE C,-4(TP)\r
+ SUB TP,[6,,6] ; FLUSH CRAP\r
+ JRST INSRT1\r
+\r
+DEFFLG==1 ;SPECIAL FLAG USED TO INDICATE THAT A DEFAULT HAS ALREADY BEEN SPECIFIED\r
+DEFALT: CAIN A,TATOM ;SPECIAL DEFAULT INDICATING ATOM ?\r
+ CAME B,MQUOTE DEFAULT\r
+ JRST BADDEF ;NO, LOSE\r
+ MOVSI A,DEFFLG\r
+ XORB A,-6(TP) ;SET AND TEST FLAG\r
+ TLNN A,DEFFLG ; HAVE WE BEEN HERE BEFORE ?\r
+ JRST BADDEF ; YES, LOSE\r
+ SETZM -2(TP) ;ZERO OUT PREVIOUS DEFAULT\r
+ SETZM -4(TP)\r
+ JRST RLOOK4 ;CONTINUE\r
+\r
+RLOOK1: PUSH TP,$TOBLS\r
+ PUSH TP,B ; SAVE OBLIST\r
+ PUSHJ P,ILOOK ;LOOK IT UP THERE\r
+ MOVE D,(TP) ; GET OBLIST\r
+ SUB TP,[2,,2]\r
+ JUMPE B,INSRT1 ;GO INSET IT\r
+\r
+\r
+INSRT2: JRST .+2 ;\r
+RLOOK3: SUB TP,[6,,6] ;POP OFF LOSSAGE\r
+ PUSHJ P,ILINK ;IF THIS IS A LINK FOLLOW IT\r
+ PUSH P,(TP) ;GET BACK RET ADR\r
+ SUB TP,[2,,2] ;POP TP\r
+ JRST IATM1 ;AND RETURN\r
+\r
+\r
+BADOBL: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE BAD-OBLIST-OR-LIST-THEREOF\r
+ JRST CALER1\r
+\r
+BADDEF: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE BAD-DEFAULT-OBLIST-SPECIFICATION\r
+ JRST CALER1\r
+\r
+ONOTH: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE ATOM-ON-DIFFERENT-OBLIST\r
+ JRST CALER1\r
+\f;SUBROUTINE TO MAKE AN ATOM\r
+\r
+MFUNCTION ATOM,SUBR\r
+\r
+ ENTRY 1\r
+\r
+ MOVE A,(AB)\r
+ MOVE B,1(AB)\r
+ PUSHJ P,IATOMI\r
+ JRST FINIS\r
+\r
+CATOM: SUBM M,(P)\r
+ PUSHJ P,IATOMI\r
+ JRST MPOPJ\r
+\r
+IATOMI: GETYP 0,A ;CHECK ARG TYPE\r
+ CAIE 0,TCHRS\r
+ CAIN 0,TCHSTR\r
+ JRST .+2 ;JUMP IF WINNERS\r
+ JRST WTYP1\r
+\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ MOVEI B,-1(TP)\r
+ MOVE A,0\r
+ PUSHJ P,CSTAK ;COPY ONTO STACK\r
+ PUSHJ P,IATOM ;NOW MAKE THE ATOM\r
+ POPJ P,\r
+\r
+;INTERNAL ATOM MAKER\r
+\r
+IATOM: MOVE A,-1(P) ;GET WORDS IN PNAME\r
+ ADDI A,3 ;FOR VALUE CELL\r
+ PUSHJ P,IBLOCK ; GET BLOCK\r
+ MOVSI C,<(GENERAL)>+SATOM+.VECT. ;FOR TYPE FIELD\r
+ MOVE D,-1(P) ;RE-GOBBLE LENGTH\r
+ ADDI D,3(B) ;POINT TO DOPE WORD\r
+ MOVEM C,(D)\r
+ SKIPG -1(P) ;EMPTY PNAME ?\r
+ JRST IATM0 ;YES, NO CHARACTERS TO MOVE\r
+ MOVE E,B ;COPY ATOM POINTER\r
+ ADD E,[3,,3] ;POINT TO PNAME AREA\r
+ MOVEI C,-1(P)\r
+ SUB C,-1(P) ;POINT TO STRING ON STACK\r
+ MOVE D,(C) ;GET SOME CHARS\r
+ MOVEM D,(E) ;AND COPY THEM\r
+ ADDI C,1\r
+ AOBJN E,.-3\r
+IATM0: MOVSI A,TATOM ;TYPE TO ATOM\r
+IATM1: POP P,D ;RETURN ADR\r
+ POP P,C\r
+ HRLI C,(C)\r
+ SUB P,C\r
+ JRST (D) ;RETURN\r
+\r
+\f;SUBROUTINE TO GET AN ATOM'S PNAME\r
+\r
+MFUNCTION PNAME,SUBR\r
+\r
+ ENTRY 1\r
+\r
+ GETYP A,(AB)\r
+ CAIE A,TATOM ;CHECK TYPE IS ATOM\r
+ JRST WTYP1\r
+ MOVE A,1(AB)\r
+ PUSHJ P,IPNAME\r
+ JRST FINIS\r
+\r
+CIPNAM: SUBM M,(P)\r
+ PUSHJ P,IPNAME\r
+ JRST MPOPJ\r
+\r
+IPNAME: ADD A,[3,,3]\r
+ HLRE B,A\r
+ MOVM B,B\r
+ PUSH P,(A) ;FLUSH PNAME ONTO P\r
+ AOBJN A,.-1\r
+ IMULI B,5 ; CHARS TO B\r
+ MOVE 0,(P) ; LAST WORD\r
+ MOVE A,0\r
+ SUBI A,1 ; FIND LAST 1\r
+ ANDCM 0,A ; 0 HAS 1ST 1\r
+ JFFO 0,.+1\r
+ HRREI 0,-34.(A) ; FIND HOW MUCH TO ADD\r
+ IDIVI 0,7\r
+ ADD B,0\r
+ PUSH P,B\r
+ PUSHJ P,CHMAK ;MAKE A STRING\r
+ POPJ P,\r
+\r
+\f; BLOCK STRUCTURE SUBROUTINES FOR MUDDLE\r
+\r
+MFUNCTION BLK,SUBR,BLOCK\r
+\r
+ ENTRY 1\r
+\r
+ GETYP A,(AB) ;CHECK TYPE OF ARG\r
+ CAIE A,TOBLS ;IS IT AN OBLIST\r
+ CAIN A,TLIST ;OR A LIAT\r
+ JRST .+2\r
+ JRST WTYP1\r
+ MOVSI A,TATOM ;LOOK UP OBLIST\r
+ MOVE B,IMQUOTE OBLIST\r
+ PUSHJ P,IDVAL ;GET VALUE\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ PUSH TP,.BLOCK(PVP) ;HACK THE LIST\r
+ PUSH TP,.BLOCK+1(PVP)\r
+ MCALL 2,CONS ;CONS THE LIST\r
+ MOVEM A,.BLOCK(PVP) ;STORE IT BACK\r
+ MOVEM B,.BLOCK+1(PVP)\r
+ PUSH TP,$TATOM\r
+ PUSH TP,IMQUOTE OBLIST\r
+ PUSH TP,(AB)\r
+ PUSH TP,1(AB)\r
+ MCALL 2,SET ;SET OBLIST TO ARG\r
+ JRST FINIS\r
+\r
+MFUNCTION ENDBLOCK,SUBR\r
+\r
+ ENTRY 0\r
+\r
+ SKIPN B,.BLOCK+1(PVP) ;IS THE LIST NIL?\r
+ JRST BLKERR ;YES, LOSE\r
+ HRRZ C,(B) ;CDR THE LIST\r
+ HRRZM C,.BLOCK+1(PVP)\r
+ PUSH TP,$TATOM ;NOW RESET OBLIST\r
+ PUSH TP,IMQUOTE OBLIST\r
+ HLLZ A,(B) ;PUSH THE TYPE OF THE CAR\r
+ PUSH TP,A\r
+ PUSH TP,1(B) ;AND VALUE OF CAR\r
+ MCALL 2,SET\r
+ JRST FINIS\r
+\r
+BLKERR: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE UNMATCHED\r
+ JRST CALER1\r
+\r
+BADLST: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE NIL-LIST-OF-OBLISTS\r
+ JRST CALER1\r
+\f;SUBROUTINE TO CREATE CHARACTER STRING GOODIE\r
+\r
+CHMAK: MOVE A,-1(P)\r
+ ADDI A,4\r
+ IDIVI A,5\r
+ PUSHJ P,IBLOCK\r
+ MOVEI C,-1(P) ;FIND START OF CHARS\r
+ HLRE E,B ; - LENGTH\r
+ ADD C,E ;C POINTS TO START\r
+ MOVE D,B ;COPY VECTOR RESULT\r
+ JUMPGE D,NULLST ;JUMP IF EMPTY\r
+ MOVE A,(C) ;GET ONE\r
+ MOVEM A,(D)\r
+ ADDI C,1 ;BUMP POINTER\r
+ AOBJN D,.-3 ;COPY\r
+NULLST: MOVSI C,TCHRS+.VECT. ;GET TYPE\r
+ MOVEM C,(D) ;CLOBBER IT IN\r
+ MOVE A,-1(P) ; # WORDS\r
+ HRLI A,TCHSTR\r
+ HRLI B,440700\r
+ MOVMM E,-1(P) ; SO IATM1 WORKS\r
+ JRST IATM1 ;RETURN\r
+\r
+; SUBROUTINE TO READ FIVE CHARS FROM STRING.\r
+; TWO CALLS, ONE WITH A POINTING TO LIST ELEMENT,\r
+; THE OTHER WITH B POINTING TO PAIR. SKIPS IF WINNER, ELSE DOESNT\r
+\r
+NXTDCL: GETYP B,(A) ;CHECK TYPE\r
+ CAIE B,TDEFER ;LOSE IF NOT DEFERRED\r
+ POPJ P,\r
+\r
+ MOVE B,1(A) ;GET REAL BYTE POINTER\r
+CHRWRD: PUSH P,C\r
+ GETYP C,(B) ;CHECK IT IS CHSTR\r
+ CAIE C,TCHSTR\r
+ JRST CPOPJC ;NO, QUIT\r
+ PUSH P,D\r
+ PUSH P,E\r
+ PUSH P,0\r
+ MOVEI E,0 ;INITIALIZE DESTINATION\r
+ HRRZ C,(B) ; GET CHAR COUNT\r
+ JUMPE C,GOTDCL ; NULL, FINISHED\r
+ MOVE B,1(B) ;GET BYTE POINTER\r
+ MOVE D,[440700,,E] ;BYTE POINT TO E\r
+CHLOOP: ILDB 0,B ; GET A CHR\r
+ IDPB 0,D ;CLOBBER AWAY\r
+ SOJE C,GOTDCL ; JUMP IF DONE\r
+ TLNE D,760000 ; SKIP IF WORD FULL\r
+ JRST CHLOOP ; MORE THAN 5 CHARS\r
+ TRO E,1 ; TURN ON FLAG\r
+\r
+GOTDCL: MOVE B,E ;RESULT TO B\r
+ AOS -4(P) ;SKIP RETURN\r
+CPOPJ0: POP P,0\r
+ POP P,E\r
+ POP P,D\r
+CPOPJC: POP P,C\r
+ POPJ P,\r
+\r
+; SUBROUTINE TO FIND A BYTE STRINGS DOPE WORD\r
+; RECEIVES POINTER TO PAIR CONNTAINIGN CHSTR IN C, RETURNS DOPE WORD IN A\r
+\r
+BYTDOP: PUSH P,B ; SAVE SOME ACS\r
+ PUSH P,D\r
+ PUSH P,E\r
+ MOVE B,1(C) ; GET BYTE POINTER\r
+ LDB D,[360600,,B] ; POSITION TO D\r
+ LDB E,[300600,,B] ; AND BYTE SIZE\r
+ MOVEI A,(E) ; A COPY IN A\r
+ IDIVI D,(E) ; D=> # OF BYTES IN WORD 1\r
+ HRRZ E,(C) ; GET LENGTH\r
+ SUBM E,D ; # OF BYTES IN OTHER WORDS\r
+ JUMPL D,BYTDO1 ; NEAR DOPE WORD\r
+ MOVEI B,36. ; COMPUTE BYTES PER WORD\r
+ IDIVM B,A\r
+ ADDI D,-1(A) ; NOW COMPUTE WORDS\r
+ IDIVI D,(A) ; D/ # NO. OF WORDS PAST 1ST\r
+ ADD D,1(C) ; D POINTS TO DOPE WORD\r
+ MOVEI A,2(D)\r
+\r
+BYTDO2: POP P,E\r
+ POP P,D\r
+ POP P,B\r
+ POPJ P,\r
+BYTDO1: MOVEI A,1(B)\r
+ CAME D,[-5]\r
+ AOJA A,BYTDO2\r
+ JRST BYTDO2\r
+\f;ROUTINES TO DEFINE AND HANDLE LINKS\r
+\r
+MFUNCTION LINK,SUBR\r
+ ENTRY\r
+ CAML AB,[-6,,0] ;NO MORE THAN 3 ARGS\r
+ CAML AB,[-2,,0] ;NO LESS THAN 2 ARGS\r
+ JRST WNA\r
+ CAML AB,[-4,,0] ;ONLY TWO ARGS SUPPLIED ?\r
+ JRST GETOB ;YES, GET OBLIST FROM CURRENT PATH\r
+ MOVE A,2(AB)\r
+ MOVE B,3(AB)\r
+ MOVE C,5(AB)\r
+ JRST LINKIN\r
+GETOB: MOVSI A,TATOM\r
+ MOVE B,IMQUOTE OBLIST\r
+ PUSHJ P,IDVAL\r
+ CAMN A,$TOBLS\r
+ JRST LINKP\r
+ CAME A,$TLIST\r
+ JRST BADOBL\r
+ JUMPE B,BADLST\r
+ GETYPF A,(B)\r
+ MOVE B,(B)+1\r
+LINKP: MOVE C,B\r
+ MOVE A,2(AB)\r
+ MOVE B,3(AB)\r
+LINKIN: PUSHJ P,IINSRT\r
+ CAMN A,$TFALSE ;LINK NAME ALREADY USED ?\r
+ JRST ALRDY ;YES, LOSE\r
+ MOVE C,B\r
+ MOVE A,(AB)\r
+ MOVE B,1(AB)\r
+ PUSHJ P,CSETG\r
+ JRST FINIS\r
+\r
+\r
+ILINK: CAME A,$TLINK ;FOUND A LINK ?\r
+ POPJ P, ;NO, FINISHED\r
+ MOVSI A,TATOM\r
+ PUSHJ P,IGVAL ;GET THE LINK'S DESTINATION\r
+ CAME A,$TUNBOUND ;WELL FORMED LINK ?\r
+ POPJ P, ;YES\r
+ PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE BAD-LINK\r
+ JRST CALER1\r
+\r
+\f\r
+; THIS SUBROUTINE IMPURIFIES A PURE ATOM TO ALLOW MODIFICATION OF SYSTEM SUBRS\r
+\r
+IMPURIFY:\r
+ PUSH TP,$TATOM\r
+ PUSH TP,B\r
+ MOVE C,B\r
+ MOVEI 0,(C)\r
+ CAIGE 0,HIBOT\r
+ JRST RTNATM ; NOT PURE, RETURN\r
+\r
+; 1) IMPURIFY ITS OBLIST BUCKET\r
+\r
+ SKIPN B,2(C) ; PICKUP OBLIST IF IT EXISTS\r
+ JRST IMPUR1 ; NOT ON ONE, IGNORE THIS CODE\r
+\r
+ ADDI B,(TVP) ; POINT TO SLOT\r
+ MOVE B,(B) ; GET THE REAL THING\r
+ ADD C,[3,,3] ; POINT TO PNAME\r
+ HLRE A,C ; GET LNTH IN WORDS OF PNAME\r
+ MOVNS A\r
+ PUSH P,[IMPUR2] ; FAKE OUT ILOOKC\r
+ PUSH P,(C) ; PUSH UP THE PNAME\r
+ AOBJN C,.-1\r
+ PUSH P,A ; NOW THE COUNT\r
+ JRST ILOOKC ; GO FIND BUCKET\r
+\r
+IMPUR2: JUMPE B,IMPUR1 ; NOT THERE, GO\r
+ PUSH TP,$TOBLS ; SAVE BUCKET\r
+ PUSH TP,E\r
+\r
+ MOVE B,(E) ; GET NEXT ONE\r
+IMPUR4: MOVEI 0,(B)\r
+ CAIGE 0,HIBOT ; SKIP IF PURE\r
+ JRST IMPUR3 ; FOUND IMPURE NESS, SKIP IT\r
+ HLLZ C,(B) ; SET UP ICONS CALL\r
+ HRRZ E,(B)\r
+ MOVE D,1(B)\r
+ PUSHJ P,ICONS ; CONS IT UP\r
+ HRRZ E,(TP) ; RETRV PREV\r
+ HRRM B,(E) ; AND CLOBBER\r
+IMPUR3: MOVSI 0,TLIST\r
+ MOVEM 0,-1(TP) ; FIX TYPE\r
+ HRRZM B,(TP) ; STORE GOODIE\r
+ HRRZ B,(B) ; CDR IT\r
+ JUMPN B,IMPUR4 ; LOOP\r
+ SUB TP,[2,,2] ; FLUSH TP CRUFT\r
+\r
+; 2) GENERATE A DUPLICATE ATOM\r
+\r
+IMPUR1: HLRE A,(TP) ; GET LNTH OF ATOM\r
+ MOVNS A\r
+ PUSH P,A\r
+ PUSHJ P,IBLOCK ; GET NEW BLOCK FOR ATOM\r
+ PUSH TP,$TATOM\r
+ PUSH TP,B\r
+ HRL B,-2(TP) ; SETUP BLT\r
+ POP P,A\r
+ ADDI A,(B) ; END OF BLT\r
+ BLT B,(A) ; CLOBBER NEW ATOM\r
+ MOVSI B,.VECT. ; TURN ON BIT FOR GCHACK\r
+ IORM B,(A)\r
+\r
+; 3) NOW COPY GLOBAL VALUE\r
+\r
+ MOVE B,(TP) ; ATOM BACK\r
+ GETYP 0,(B)\r
+ SKIPE A,1(B) ; NON-ZER POINTER?\r
+ CAIN 0,TUNBOU ; BOUND?\r
+ JRST IMPUR5 ; NO, DONT COPY GLOB VAL\r
+ PUSH TP,$TATOM\r
+ PUSH TP,B\r
+ PUSH TP,(A)\r
+ PUSH TP,1(A) \r
+ SETZM (B)\r
+ SETZM 1(B)\r
+ MCALL 2,SETG\r
+IMPUR5: PUSH TP,$TFIX ;SAVE OLD ATOM WITH FUNNY TYPE TO AVOID LOSSAGE\r
+ PUSH TP,-3(TP)\r
+\r
+; 4) UPDATE ALL POINTERS TO THIS ATOM\r
+\r
+ MOVE A,[PUSHJ P,ATFIX] ; INS TO PASS TO GCHACK\r
+ PUSHJ P,GCHACK\r
+ SUB TP,[4,,4]\r
+\r
+RTNATM: POP TP,B\r
+ POP TP,A\r
+ POPJ P,\r
+\r
+; ROUTINE PASSED TO GCHACK\r
+\r
+ATFIX: CAIE C,TGATOM ; GLOBAL TYPE ATOM\r
+ CAIN C,TATOM\r
+ CAME D,(TP) ; SKIP IF WINNER\r
+ POPJ P,\r
+ MOVE D,-2(TP)\r
+ SKIPE B\r
+ MOVEM D,1(B)\r
+ POPJ P,\r
+\r
+\r
+END\r
+\f\f\r
projects / pdp10-muddle.git / blobdiff