TITLE ATOMHACKER FOR MUDDLE RELOCATABLE .INSRT MUDDLE > .GLOBAL RLOOKU,CHMAK,WRONGT,ERRTMA,OBLNT,ROOT,INTOBL,ERROBL .GLOBAL .BLOCK,CALER1,IDVAL,NXTDCL,CHRWRD ; FUNCTION TO GENERATE AN EMPTY OBLIST MFUNCTION MOBLIST,SUBR ENTRY CAMGE AB,[-3,,0] ;CHECK NUMBER OF ARGS JRST ERRTMA MOVE A,OBLNT ;GET DEFAULT LENGTH CAML AB,[-1,,0] ;IS LENGTH SUPPLIED JRST MOBL1 ;NO, USE STANDARD LENGTH HLRZ C,(AB) ;GET ARG TYPE CAIE C,TFIX JRST WRONGT ;LOSE MOVE A,1(AB) ;GET LENGTH MOBL1: PUSH TP,$TFIX PUSH TP,A MCALL 1,UVECTOR ;GET A UNIFORM VECTOR MOVSI C,TLIST ;IT IS OF TYPE LIST HLRE D,B ;-LENGTH TO D SUBM B,D ;D POINTS TO DOPE WORD MOVEM C,(D) ;CLOBBER TYPE IN MOVSI A,TOBLS JRST FINIS MFUNCTION GROOT,SUBR,ROOT ENTRY 0 MOVE B,ROOT+1(TVP) HRRZ B,(B) ;CDR THE LIST HLLZ A,(B) MOVE B,1(B) ;RETURN ROOT OBLIST JRST FINIS MFUNCTION GINTS,SUBR,INTERRUPTS ENTRY 0 MOVE A,INTOBL(TVP) MOVE B,INTOBL+1(TVP) JRST FINIS MFUNCTION GERRS,SUBR,ERRORS ENTRY 0 MOVE A,ERROBL(TVP) MOVE B,ERROBL+1(TVP) JRST FINIS ; FUNCTION TO FIND AN ATOM ON A GIVEN OBLIST WITH A GIVEN PNAME MFUNCTION LOOKUP,SUBR ENTRY 2 PUSHJ P,ILOOKU ;CAL INTERNAL ROUTINE JRST FINIS ILOOKU: PUSHJ P,ARGCHK ;CHECK ARGS PUSHJ P,CSTACK ;PUT CHARACTERS ON THE STACK CALLIT: MOVE B,3(AB) ;GET OBLIST PUSHJ P,ILOOK ;LOOK IT UP POP P,D ;RESTORE COUNT HRLI D,(D) ;TO BOTH SIDES SUB P,D POPJ P, ;THIS ROUTINE CHECKS ARG TYPES ARGCHK: HLRZ A,(AB) ;GET TYPES HLRZ C,2(AB) CAIE A,TCHRS ;IS IT EITHER CHAR STRING CAIN A,TCHSTR CAIE C,TOBLS ;IS 2ND AN OBLIST JRST WRONGT ;TYPES ARE WRONG POPJ P, ;THIS SUBROUTINE PUTS CHARACTERS ON THE STACK (P WILL BE CHANGED) CSTACK: POP P,D ;RETURN ADDRESS TO D CAIE A,TCHRS ;IMMEDIATE? JRST NOTIMM ;NO, HAIR PUSH P,1(AB) ;ONTO P PUSH P,[1] ;WITH NUMBER JRST (D) ;GO CALL SEARCHER NOTIMM: SETZB A,E ;INITIALIZE WORD COUNT AND CHAR WORD HRRZ C,(AB) ;POINT TO DOPE WORD SUBI C,1 MOVE B,1(AB) ;GET BYTE POINTER LDB 0,B ;GET 1ST CHR JUMPE 0,CDONE1 CLOOP1: PUSH P,[440700,,E] ;SETUP A BYTE POINTER FOR STORING JUMPN 0,.+2 ;DON'T READ FOR 1ST CLOOP: ILDB 0,B ;GET A CHARACTER CAIN C,(B) ;AT END OF INPUT JRST CDONE ;YES, QUIT JUMPE 0,CDONE ;FINISHED? IDPB 0,(P) ;STORE IT TRNN E,377 ;WORD FULL JRST CLOOP ;NO CONTINUE MOVEM E,(P) ;STORE CHARS SETZB E,0 ;RESET CHAR WORD AOJA A,CLOOP1 ;AND CONTINUE CDONE: SUB P,[1,,1] ;REMOVE BYTE POINTER JUMPE E,CDONE1 ADDI A,1 PUSH P,E ;PUSH LAST WORD CDONE1: PUSH P,A ;AND NUMBER OF WORDS JRST (D) ;RETURN ; THIS FUNCTION LOOKS FOR ATOMS. CALLED BY PUSHJ P,ILOOK ; B/ OBLIST POINTER ; -1(P)/ LENGTH IN WORDS OF CHARACTER BLOCK ; CHAR STRING IS ON THE STACK ILOOK: MOVN A,-1(P) ;GET -LENGTH HRLI A,-1(A) ;<-LENGTH-1>,,-LENGTH PUSH TP,$TFIX ;SAVE PUSH TP,A ADDI A,-1(P) ;HAVE AOBJN POINTER TO CHARS MOVEI D,0 ;HASH WORD XOR D,(A) AOBJN A,.-1 ;XOR THEM ALL TOGETHER HLRE A,B ;GET LENGTH OF OBLIST MOVNS A MOVMS D ;MAKE SURE OF + HASH CODE IDIVI D,(A) ;DIVIDE HRLI E,(E) ;TO BOTH HALVES ADD B,E ;POINT TO BUCKET MOVEI 0,(B) ;IN CASE REMOVING 1ST SKIPN C,(B) ;BUCKET EMPTY? JRST NOTFND ;YES, GIVE UP LOOK2: SKIPN A,1(C) ;NIL CAR ON LIST? JRST NEXT ;YES TRY NEXT ADD A,[2,,2] ;POINT TO ATOMS PNAME MOVE D,(TP) ;GET PSEUDO AOBJN POINTER TO CHARS ADDI D,-1(P) ;NOW ITS A REAL AOBJN POINTER LOOK1: MOVE E,(D) ;GET A WORD CAME E,(A) ;COMPARE JRST NEXT ;THIS ONE DOESN'T MATCH AOBJP D,CHECK ;ONE RAN OUT AOBJN A,LOOK1 ;JUMP IF STILL MIGHT WIN NEXT: MOVEI 0,(C) ;POINT TO PREVIOUS ELEMENT HRRZ C,(C) ;STEP THROUGH JUMPN C,LOOK2 NOTFND: EXCH C,B ;RETURN BUCKET IN B MOVSI A,TFALSE CPOPJT: SUB TP,[2,,2] ;REMOVE RANDOM TP STUFF POPJ P, CHECK: AOBJN A,NEXT ;JUMP IF NO MATCH MOVE B,1(C) ;GET ATOM MOVSI A,TATOM JRST CPOPJT ; FUNCTION TO INSERT AN ATOM ON AN OBLIST MFUNCTION INSERT,SUBR ENTRY 2 PUSH TP,$TFIX ;FLAG CALL PUSH TP,[0] PUSHJ P,ARGCHK ;CHECK ARGS PUSHJ P,CSTACK ;COPY ONTO STACK MOVE B,3(AB) ;GET OBLIST PUSHJ P,ILOOK ;LOOK IT UP (BUCKET RETURNS IN C) JUMPN B,RETFLS ;EXISTS, RETURN FALSE INSRT1: PUSH TP,$TOBLS ;SAVE BUCKET POINTER PUSH TP,C PUSHJ P,IATOM ;MAKE AN ATOM PUSH TP,$TATOM PUSH TP,B ;PUSH ATOM PUSH TP,$TLIST ;AND LIST NOW IN BUCKET MOVE C,-3(TP) ;GET BUCKET BACK PUSH TP,(C) ;PUSH ITS LIST MCALL 2,CONS MOVE C,(TP) ;BUCKET AGAIN HRRM B,(C) ;INTO NEW BUCKET MOVSI A,TATOM MOVE B,1(B) ;GET ATOM BACK MOVE C,-2(TP) ;GET FLAG SUB TP,[4,,4] ;POP STACK JUMPE C,FINIS JRST (C) ;RETURN INTERNAL RETFLS: PUSH P,CFINIS ;FOR POPJ TO WORK MOVEI B,0 MOVSI A,TFALSE JRST IATM1 ;RETURN ; FUNCTION TO REMOVE AN ATOM FROM AN OBLIST MFUNCTION REMOVE,SUBR ENTRY 2 PUSHJ P,ILOOKU ;LOOK IT UP CFINIS: JUMPE B,FINIS ;NOT THERE HRRZ D,0 ;PREPARE TO SPLICE (0 POINTS PRIOR TO LOSING PAIR) HRRZ C,(C) ;GET NEXT OF LOSING PAIR HRRM C,(D) ;AND SPLICE JRST FINIS ;INTERNAL CALL FROM THE READER RLOOKU: PUSH TP,$TFIX ;PUSH A FLAG POP P,C ;POP OFF RET ADR PUSH TP,C ;AND USE AS A FLAG FOR INTERNAL CAMN A,$TOBLS ;IS IT ONE OBLIST? JRST RLOOK1 CAME A,$TLIST ;IS IT A LIST JRST WRONGT JUMPE B,BADLST PUSH TP,A PUSH TP,B ;TWO COPIES OF ARG PUSH TP,A PUSH TP,B RLOOK2: INTGO HLRZ A,(B) ;CHECK THIS IS AN OBLIST CAIE A,TOBLS JRST WRONGT MOVE B,1(B) ;LOOK FOR IT PUSHJ P,ILOOK ;LOOK IT UP JUMPN B,RLOOK3 ;WIN HRRZ B,@(TP) ;CDR THE LIST HRRZM B,(TP) JUMPN B,RLOOK2 MOVE B,-2(TP) ;FAILED USE FIRST MOVE B,1(B) SUB TP,[4,,4] ;POP TP RLOOK1: PUSHJ P,ILOOK ;LOOK IT UP THERE JUMPE B,INSRT1 ;GO INSET IT INSRT2: JRST .+2 ; RLOOK3: SUB TP,[4,,4] ;POP OFF LOSSAGE PUSH P,(TP) ;GET BACK RET ADR SUB TP,[2,,2] ;POP TP JRST IATM1 ;AND RETURN ;SUBROUTINE TO MAKE AN ATOM MFUNCTION ATOM,SUBR ENTRY 1 HLRZ A,(AB) ;CHECK ARG TYPE CAIE A,TCHRS CAIN A,TCHSTR JRST .+2 ;JUMP IF WINNERS JRST WRONGT PUSHJ P,CSTACK ;COPY ONTO STACK PUSHJ P,IATOM ;NOW MAKE THE ATOM JRST FINIS ;AND LEAVE ;INTERNAL ATOM MAKER IATOM: MOVE A,-1(P) ;GET WORDS IN PNAME ADDI A,2 ;FOR VALUE CELL PUSH TP,$TFIX PUSH TP,A ;LENGTH IS ARG MCALL 1,UVECTOR ;GET STORAGE MOVSI C,<(GENERAL)>+SATOM ;FOR TYPE FIELD MOVE D,-1(P) ;RE-GOBBLE LENGTH ADDI D,2(B) ;POINT TO DOPE WORD MOVEM C,(D) MOVE E,B ;COPY ATOM POINTER ADD E,[2,,2] ;POINT TO PNAME AREA MOVEI C,-1(P) SUB C,-1(P) ;POINT TO STRING ON STACK MOVE D,(C) ;GET SOME CHARS MOVEM D,(E) ;AND COPY THEM ADDI C,1 AOBJN E,.-3 MOVSI A,TATOM ;TYPE TO ATOM IATM1: POP P,D ;RETURN ADR POP P,C ;WORDA OF CHARS HRLI C,(C) SUB P,C JRST (D) ;RETURN ; BLOCK STRUCTURE SUBROUTINES FOR MUDDLE MFUNCTION BLK,SUBR,BLOCK ENTRY 1 HLRZ A,(AB) ;CHECK TYPE OF ARG CAIE A,TOBLS ;IS IT AN OBLIST CAIN A,TLIST ;OR A LIAT JRST .+2 JRST WRONGT MOVSI A,TATOM ;LOOK UP OBLIST MOVE B,MQUOTE OBLIST PUSHJ P,IDVAL ;GET VALUE PUSH TP,A PUSH TP,B PUSH TP,.BLOCK(PVP) ;HACK THE LIST PUSH TP,.BLOCK+1(PVP) MCALL 2,CONS ;CONS THE LIST MOVEM A,.BLOCK(PVP) ;STORE IT BACK MOVEM B,.BLOCK+1(PVP) PUSH TP,$TATOM PUSH TP,MQUOTE OBLIST PUSH TP,(AB) PUSH TP,1(AB) MCALL 2,SET ;SET OBLIST TO ARG JRST FINIS MFUNCTION ENDBLOCK,SUBR ENTRY 0 SKIPN B,.BLOCK+1(PVP) ;IS THE LIST NIL? JRST BLKERR ;YES, LOSE HRRZ C,(B) ;CDR THE LIST HRRZM C,.BLOCK+1(PVP) PUSH TP,$TATOM ;NOW RESET OBLIST PUSH TP,MQUOTE OBLIST HLLZ A,(B) ;PUSH THE TYPE OF THE CAR PUSH TP,A PUSH TP,1(B) ;AND VALUE OF CAR MCALL 2,SET JRST FINIS BLKERR: PUSH TP,$TATOM PUSH TP,MQUOTE UNMATCHED JRST CALER1 BADLST: PUSH TP,$TATOM PUSH TP,MQUOTE NIL-LIST-OF-OBLISTS JRST CALER1 ;SUBROUTINE TO CREATE CHARACTER STRING GOODIE CHMAK: PUSH TP,$TFIX ;SET UP CALL TO UVECTOR PUSH TP,-1(P) MCALL 1,UVECTOR MOVEI C,-1(P) ;FIND START OF CHARS SUB C,-1(P) ;C POINTS TO START MOVE D,B ;COPY VECTOR RESULT JUMPGE D,NULLST ;JUMP IF EMPTY MOVE A,(C) ;GET ONE MOVEM A,(D) ADDI C,1 ;BUMP POINTER AOBJN D,.-3 ;COPY NULLST: MOVSI C,TCHRS ;GET TYPE MOVEM C,(D) ;CLOBBER IT IN MOVSI A,TCHSTR ;SETUP TYPE HRRI A,1(D) ;POINT TO DOPE HRLI B,350700 ;MAKE A BYTE POINTER JRST IATM1 ;RETURN ; SUBROUTINE TO READ FIVE CHARS FROM STRING. TWO CALLS, ONE WITH A POINTING TO LIST ELEMENT, THE OTHER WITH B POINTING TO PAIR. SKIPS IF WINNER, ELSE DOESNT NXTDCL: GETYP B,(A) ;CHECK TYPE CAIE B,TDEFER ;LOSE IF NOT DEFERRED POPJ P, MOVE B,1(A) ;GET REAL BYTE POINTER CHRWRD: PUSH P,C GETYP C,(B) ;CHECK IT IS CHSTR CAIE C,TCHSTR JRST CPOPJC ;NO, QUIT PUSH P,D PUSH P,E PUSH P,0 MOVEI E,0 ;INITIALIZE DESTINATION HRRZ C,(B) ;POINT TO DOPE WORD MOVE B,1(B) ;GET BYTE POINTER CAIN C,1(B) ;CHECK FULLNESS JRST GOTDCL ;RETURN NIL WORD MOVE D,[440700,,E] ;BYTE POINT TO E LDB 0,B ;GET 1ST CHR CHLOOP: JUMPE 0,GOTDCL ;FINISHED, WIN TRNE E,377 ;WORD FULL? JRST CHREXT ;YES, LOSE IDPB 0,D ;CLOBBER AWAY ILDB 0,B ;AND GET NEXT CAILE C,1(B) ;FULL NOW? JRST CHLOOP ;NO, CONTINUE GOTDCL: MOVE B,E ;RESULT TO B AOS -4(P) ;SKIP RETURN CPOPJ0: POP P,0 POP P,E POP P,D CPOPJC: POP P,C POPJ P, CHREXT: TRO E,1 ;MAKE IT LOOK FUNNY JRST GOTDCL END