2 TITLE ATOMHACKER FOR MUDDLE
7 .GLOBAL RLOOKU,CHMAK,OBLNT,ROOT,INTOBL,ERROBL,IFALSE,PVSTOR,SPSTOR
8 .GLOBAL .BLOCK,IDVAL,NXTDCL,CHRWRD,CSTACK,CSTAK,ILOOKC,IGVAL,BYTDOP,HASHTB
9 .GLOBAL ICONS,INCONS,IBLOCK,INSRTX,GCHACK,IMPURIFY,BSETG,TYPVEC,IGET,IPUT
10 .GLOBAL CINSER,CIRMV,CLOOKU,CATOM,CIPNAM,MPOPJ,CSETG,CSPNAM,GPURFL,IMPURX
17 ; FUNCTION TO GENERATE AN EMPTY OBLIST
19 MFUNCTION MOBLIST,SUBR
22 CAMGE AB,[-5,,0] ;CHECK NUMBER OF ARGS
24 JUMPGE AB,MOBL2 ; NO ARGS
29 PUSHJ P,IGET ; CHECK IF IT EXISTS ALREADY
34 PUSHJ P,IBLOCK ;GET A UNIFORM VECTOR
35 MOVSI C,TLIST+.VECT. ;IT IS OF TYPE LIST
36 HLRE D,B ;-LENGTH TO D
37 SUBM B,D ;D POINTS TO DOPE WORD
38 MOVEM C,(D) ;CLOBBER TYPE IN
40 JUMPGE AB,FINIS ; IF NO ARGS, DONE
51 PUSHJ P,IPUT ; PUT THE NAME ON THE OBLIST
58 PUSHJ P,IPUT ; PUT THE OBLIST ON THE NAME
64 MFUNCTION GROOT,SUBR,ROOT
70 MFUNCTION GINTS,SUBR,INTERRUPTS
76 MFUNCTION GERRS,SUBR,ERRORS
83 COBLQ: SKIPN B,2(B) ; SKIP IF EXISTS
88 CAMG B,VECBOT ; TVP IS IN FROZEN SPACE, NEVER OBLISTS
99 MFUNCTION OBLQ,SUBR,[OBLIST?]
105 MOVE B,1(AB) ; GET ATOM
110 \f; FUNCTION TO FIND AN ATOM ON A GIVEN OBLIST WITH A GIVEN PNAME
112 MFUNCTION LOOKUP,SUBR
115 PUSHJ P,ILOOKU ;CALL INTERNAL ROUTINE
127 MOVSI A,TOBLS ; THIS IS AN OBLIST
137 ILOOKU: PUSHJ P,ARGCHK ;CHECK ARGS
138 PUSHJ P,CSTACK ;PUT CHARACTERS ON THE STACK
140 CALLIT: MOVE B,3(AB) ;GET OBLIST
142 ILOOKC: PUSHJ P,ILOOK ;LOOK IT UP
143 POP P,D ;RESTORE COUNT
144 HRLI D,(D) ;TO BOTH SIDES
148 ;THIS ROUTINE CHECKS ARG TYPES
150 ARGCHK: GETYP A,(AB) ;GET TYPES
152 CAIE A,TCHRS ;IS IT EITHER CHAR STRING
154 CAIE C,TOBLS ;IS 2ND AN OBLIST
155 JRST WRONGT ;TYPES ARE WRONG
158 ;THIS SUBROUTINE PUTS CHARACTERS ON THE STACK (P WILL BE CHANGED)
162 CSTAK: POP P,D ;RETURN ADDRESS TO D
163 CAIE A,TCHRS ;IMMEDIATE?
164 JRST NOTIMM ;NO, HAIR
165 MOVE A,1(B) ; GET CHAR
168 PUSH P,[1] ;WITH NUMBER
169 JRST (D) ;GO CALL SEARCHER
171 NOTIMM: MOVEI A,1 ; CLEAR CHAR COUNT
172 MOVE C,(B) ; GET COUNT OF CHARS
174 JRST NULST ; FLUSH NULL STRING
178 MOVE B,1(B) ;GET BYTE POINTER
180 CLOOP1: PUSH P,[0] ; STORE CHARS ON STACK
181 MOVSI E,(<440700,,(P)>) ; SETUP BYTE POINTER
182 CLOOP: SKIPL INTFLG ; SO CAN WIN WITH INTERRUPTS
185 HRRM C,BSTO(PVP) ;SAVE STRING LENGTH
187 CLOOP2: ILDB 0,B ;GET A CHARACTER
189 SOJE C,CDONE ; ANY MORE?
190 TLNE E,760000 ; WORD FULL
191 JRST CLOOP ;NO CONTINUE
192 AOJA A,CLOOP1 ;AND CONTINUE
195 CDONE1: MOVE PVP,PVSTOR+1
197 PUSH P,A ;AND NUMBER OF WORDS
201 NULST: ERRUUO EQUOTE NULL-STRING
202 \f; THIS FUNCTION LOOKS FOR ATOMS. CALLED BY PUSHJ P,ILOOK
203 ; A,B/ OBLIST POINTER (CAN BE LIST OF SAME)
204 ; -1(P)/ LENGTH IN WORDS OF CHARACTER BLOCK
205 ; CHAR STRING IS ON THE STACK
206 ; IF ATOM EXISTS RETURNS:
209 ; 0/ THE PREVIOUS BUCKET
213 ; 0/ PREV IF ONE WITH SAME PNAME, ELSE 0
219 MOVN A,-1(P) ;GET -LENGTH
220 HRLI A,-1(A) ;<-LENGTH-1>,,-LENGTH
223 ADDI A,-1(P) ;HAVE AOBJN POINTER TO CHARS
224 MOVE 0,[202622077324] ;HASH WORD
227 AOBJN A,.-2 ;XOR THEM ALL TOGETHER
230 MOVMS 0 ; MAKE SURE + HASH CODE
232 HRLI A,(A) ;TO BOTH HALVES
236 HRRZ A,(A) ; POINT TO FIRST ATOM
237 SETZB E,0 ; INDICATE NO ATOM
240 LOOK2: HLRZ E,1(A) ; PREPARE TO BUILD AOBJN
241 ANDI E,377777 ; SIGN MIGHT BE ON IF IN PURIFY ETC.
246 ADD A,[3,,3] ;POINT TO ATOMS PNAME
247 MOVE D,(TP) ;GET PSEUDO AOBJN POINTER TO CHARS
248 ADDI D,-1(P) ;NOW ITS A REAL AOBJN POINTER
249 JUMPE D,CHECK0 ;ONE IS EMPTY
254 JRST NEXT1 ;THIS ONE DOESN'T MATCH
255 AOBJP D,CHECK ;ONE RAN OUT
256 AOBJN A,LOOK1 ;JUMP IF STILL MIGHT WIN
258 NEXT1: HRRZ A,-1(TP) ; SEE IF WE'VE ALREADY SEEN THIS NAME
259 GETYP D,-3(TP) ; SEE IF LIST OF OBLISTS
261 JUMPN A,CHECK3 ; DON'T LOOK FURTHER
265 HLRZ A,2(E) ; NEXT ATOM
280 CHECK0: JUMPN A,NEXT1 ;JUMP IF NOT ALSO EMPTY
282 CHECK: AOBJN A,NEXT1 ;JUMP IF NO MATCH
284 CHECK5: HRRZ A,-1(TP) ; SEE IF FIRST SHOT AT THIS GUY?
286 MOVE B,0 ; REMEMBER ATOM FOR FALL BACK
287 HLLOS -1(TP) ; INDICATE NAME MATCH HAS OCCURRED
288 HRRZ A,2(E) ; COMPUTE OBLIST POINTER
292 GETYP D,-3(TP) ; SEE IF LIST OF OBLISTS OR
295 CAME A,-2(TP) ; DO OBLISTS MATCH?
298 CHECK2: MOVE B,E ; RETURN ATOM
307 CHECK1: MOVE D,-2(TP) ; ANY LEFT?
312 CHECK3: MOVE D,-2(TP)
319 ANDI A,377777 ; SIGN MIGHT BE ON IF IN PURIFY ETC.
328 \f; FUNCTION TO INSERT AN ATOM ON AN OBLIST
330 MFUNCTION INSERT,SUBR
354 ;INSERT WITH A GIVEN PNAME
361 PUSH TP,$TFIX ;FLAG CALL
364 PUSHJ P,CSTAK ;COPY ONTO STACK
367 PUSHJ P,ILOOK ;LOOK IT UP (BUCKET RETURNS IN C)
369 SETZM -5(TP) ; KILL STRING POINTER TO KEEP FROM CONFUSING GC
370 JUMPN B,ALRDY ;EXISTS, LOSE
371 MOVE D,-2(TP) ; GET OBLIST BACK
372 INSRT1: PUSH TP,$TATOM
373 PUSH TP,0 ; PREV ATOM
374 PUSH TP,$TUVEC ;SAVE BUCKET POINTER
377 PUSH TP,D ; SAVE OBLIST
378 INSRT3: PUSHJ P,IATOM ; MAKE AN ATOM
379 HLRE A,B ; FIND DOPE WORD
382 SKIPN E,-4(TP) ; AFTER AN ATOM?
383 JRST INSRT7 ; NO, FIRST IN BUCKET
384 MOVEI 0,(E) ; CHECK IF PURE
387 PUSH TP,$TATOM ; SAVE NEW ATOM
394 HLRE A,B ; FIND DOPE WORD
398 INSRNP: HLRZ 0,2(E) ; NEXT
403 INSRT7: MOVE E,-2(TP)
405 HRLM A,2(B) ; IN CASE OLD ONE
407 INSRT8: MOVE E,(TP) ; GET OBLIST
408 HRRM E,2(B) ; STORE OBLIST
409 MOVE E,(E) ; POINT TO LIST OF ATOMS
413 HRRM B,(E) ;INTO NEW BUCKET
415 MOVE B,1(B) ;GET ATOM BACK
416 MOVE C,-6(TP) ;GET FLAG
417 SUB TP,[8,,8] ;POP STACK
422 ;INSERT WITH GIVEN ATOM
423 INSRT0: MOVE A,-2(TP) ;GOBBLE PNAME
424 SKIPE 2(A) ; SKIP IF NOT ON AN OBLIST
429 PUSH P,(A) ;FLUSH PNAME ONTO P STACK
432 MOVE B,(TP) ; GET OBLIST FOR LOOKUP
434 PUSHJ P,ILOOK ;ALREADY THERE?
438 HLRE A,-2(TP) ; FIND DOPE WORD
440 JUMPE 0,INSRT9 ; NO CURRENT ATOM
443 CAIGE 0,HIBOT ; PURE?
458 INSRPN: HLRZ 0,2(E) ; POINT TO NEXT
459 HRLM A,2(E) ; CLOBBER NEW GUY IN
460 HRLM 0,2(D) ; FINISH SLPICE
464 EXCH A,(C) ; INTO BUCKET
472 MOVE C,(TP) ;RESTORE OBLIST
474 MOVE B,-2(TP) ; GET BACK ATOM
475 HRRM C,2(B) ; CLOBBER OBLIST IN
483 LINKCK: HRRZ C,FSAV(TB) ;CALLER'S NAME
486 SKIPA C,$TATOM ;LET US INSERT A LINK INSTEAD OF AN ATOM
487 SKIPA C,$TLINK ;GET REAL ATOM FOR CALL TO ICONS
496 ALRDY: ERRUUO EQUOTE ATOM-ALREADY-THERE
498 ONOBL: ERRUUO EQUOTE ON-AN-OBLIST-ALREADY
500 ; INTERNAL INSERT CALL
502 INSRTX: POP P,0 ; GET RET ADDR
516 JRST INSRT3 ; INTO INSERT CODE
518 INSRXT: PUSH P,-4(TP)
523 ; FUNCTION TO REMOVE AN ATOM FROM AN OBLIST
525 MFUNCTION REMOVE,SUBR
533 CAML AB,[-3,,] ; SKIP IF OBLIST GIVEN
552 IRMV1: GETYP 0,A ; CHECK 1ST ARG
555 CAIE 0,TATOM ; ATOM, TREAT ACCORDINGLY
558 HRRZ D,2(B) ; SKIP IF ON OBLIST AND GET SAME
560 CAMG D,VECBOT ; SKIP IF REAL OBLIST
561 HRRZ D,(D) ; NO, REF, GET IT
564 CAIE D,(C) ; BETTER BE THE SAME
567 GOTOBL: ADD B,[3,,3] ; POINT TO PNAME
570 PUSH P,(B) ; PUSH PNAME
573 HRROM D,(TP) ; SAVE OBLIST
592 CAIGE A,HIBOT ; SKIP IF PURE
604 RMV2: JUMPN 0,RMV9 ; JUMP IF FIRST NOT IN BUCKET
605 HLRZ 0,2(B) ; POINT TO NEXT
609 RMV9: MOVE C,0 ; C IS PREV ATOM
613 RMV8: SETZM 2(B) ; CLOBBER OBLIST SLOT
614 MOVE C,(TP) ; GET OBLIST FOR SPLICE OUT
619 CAMN B,1(E) ; SEARCH OBLIST
625 RMVDON: SUB TP,[4,,4]
630 HRRM E,(C) ; SMASH IN
634 ;INTERNAL CALL FROM THE READER
636 RLOOKU: PUSH TP,$TFIX ;PUSH A FLAG
637 POP P,C ;POP OFF RET ADR
638 PUSH TP,C ;AND USE AS A FLAG FOR INTERNAL
639 MOVE C,(P) ; CHANGE CHAR COUNT TO WORD
645 CAIN D,TOBLS ;IS IT ONE OBLIST?
647 CAIE D,TLIST ;IS IT A LIST
651 PUSH TP,$TUVEC ; SLOT FOR REMEBERIG
662 RLOOK2: GETYP A,(B) ;CHECK THIS IS AN OBLIST
666 SKIPE -4(TP) ; SKIP IF DEFAULT NOT STORED
671 HRRZ B,@(TP) ;CDR THE LIST
683 SKIPN D,-2(TP) ; RESTORE FOR INSERT
684 JRST BADDEF ; NO DEFAULT, USER LOST ON SPECIFICATION
685 SUB TP,[6,,6] ; FLUSH CRAP
690 DEFFLG==1 ;SPECIAL FLAG USED TO INDICATE THAT A DEFAULT HAS ALREADY BEEN
693 CAIN A,TATOM ;SPECIAL DEFAULT INDICATING ATOM ?
694 CAME 0,MQUOTE DEFAULT
695 JRST BADDEF ;NO, LOSE
697 XORB A,-11(TP) ;SET AND TEST FLAG
698 TRNN A,DEFFLG ; HAVE WE BEEN HERE BEFORE ?
699 JRST BADDEF ; YES, LOSE
700 SETZM -6(TP) ;ZERO OUT PREVIOUS DEFAULT
702 JRST RLOOK4 ;CONTINUE
706 RLOOK3: SUB TP,[6,,6] ;POP OFF LOSSAGE
707 PUSHJ P,ILINK ;IF THIS IS A LINK FOLLOW IT
708 PUSH P,(TP) ;GET BACK RET ADR
709 SUB TP,[2,,2] ;POP TP
710 JRST IATM1 ;AND RETURN
713 BADOBL: ERRUUO EQUOTE BAD-OBLIST-OR-LIST-THEREOF
715 BADDEF: ERRUUO EQUOTE BAD-DEFAULT-OBLIST-SPECIFICATION
717 ONOTH: ERRUUO EQUOTE ATOM-ON-DIFFERENT-OBLIST
718 \f;SUBROUTINE TO MAKE AN ATOM
733 IATOMI: GETYP 0,A ;CHECK ARG TYPE
736 JRST .+2 ;JUMP IF WINNERS
743 PUSHJ P,CSTAK ;COPY ONTO STACK
744 PUSHJ P,IATOM ;NOW MAKE THE ATOM
750 IATOM: MOVE A,-1(P) ;GET WORDS IN PNAME
751 ADDI A,3 ;FOR VALUE CELL
752 PUSHJ P,IBLOCK ; GET BLOCK
753 MOVSI C,<(GENERAL)>+SATOM ;FOR TYPE FIELD
754 MOVE D,-1(P) ;RE-GOBBLE LENGTH
755 ADDI D,3(B) ;POINT TO DOPE WORD
757 SKIPG -1(P) ;EMPTY PNAME ?
758 JRST IATM0 ;YES, NO CHARACTERS TO MOVE
759 MOVE E,B ;COPY ATOM POINTER
760 ADD E,[3,,3] ;POINT TO PNAME AREA
762 SUB C,-1(P) ;POINT TO STRING ON STACK
763 MOVE D,(C) ;GET SOME CHARS
764 MOVEM D,(E) ;AND COPY THEM
767 IATM0: MOVSI A,TATOM ;TYPE TO ATOM
768 IATM1: POP P,D ;RETURN ADR
774 \f;SUBROUTINE TO GET AN ATOM'S PNAME
781 CAIE A,TATOM ;CHECK TYPE IS ATOM
794 PUSH P,(A) ;FLUSH PNAME ONTO P
796 MOVE 0,(P) ; LAST WORD
799 PUSHJ P,CHMAK ;MAKE A STRING
802 PNMCNT: IMULI B,5 ; CHARS TO B
804 SUBI A,1 ; FIND LAST 1
805 ANDCM 0,A ; 0 HAS 1ST 1
807 HRREI 0,-34.(A) ; FIND HOW MUCH TO ADD
812 MFUNCTION SPNAME,SUBR
838 \f; BLOCK STRUCTURE SUBROUTINES FOR MUDDLE
840 IMFUNCTION BLK,SUBR,BLOCK
844 GETYP A,(AB) ;CHECK TYPE OF ARG
845 CAIE A,TOBLS ;IS IT AN OBLIST
846 CAIN A,TLIST ;OR A LIAT
849 MOVSI A,TATOM ;LOOK UP OBLIST
850 MOVE B,IMQUOTE OBLIST
851 PUSHJ P,IDVAL ;GET VALUE
855 PUSH TP,.BLOCK(PVP) ;HACK THE LIST
856 PUSH TP,.BLOCK+1(PVP)
857 MCALL 2,CONS ;CONS THE LIST
859 MOVEM A,.BLOCK(PVP) ;STORE IT BACK
860 MOVEM B,.BLOCK+1(PVP)
862 PUSH TP,IMQUOTE OBLIST
865 MCALL 2,SET ;SET OBLIST TO ARG
868 MFUNCTION ENDBLOCK,SUBR
873 SKIPN B,.BLOCK+1(PVP) ;IS THE LIST NIL?
874 JRST BLKERR ;YES, LOSE
875 HRRZ C,(B) ;CDR THE LIST
876 HRRZM C,.BLOCK+1(PVP)
877 PUSH TP,$TATOM ;NOW RESET OBLIST
878 PUSH TP,IMQUOTE OBLIST
879 HLLZ A,(B) ;PUSH THE TYPE OF THE CAR
881 PUSH TP,1(B) ;AND VALUE OF CAR
885 BLKERR: ERRUUO EQUOTE UNMATCHED
887 BADLST: ERRUUO EQUOTE NIL-LIST-OF-OBLISTS
888 \f;SUBROUTINE TO CREATE CHARACTER STRING GOODIE
894 MOVEI C,-1(P) ;FIND START OF CHARS
896 ADD C,E ;C POINTS TO START
897 MOVE D,B ;COPY VECTOR RESULT
898 JUMPGE D,NULLST ;JUMP IF EMPTY
901 ADDI C,1 ;BUMP POINTER
903 NULLST: MOVSI C,TCHRS+.VECT. ;GET TYPE
904 MOVEM C,(D) ;CLOBBER IT IN
905 MOVE A,-1(P) ; # WORDS
908 MOVMM E,-1(P) ; SO IATM1 WORKS
911 ; SUBROUTINE TO READ FIVE CHARS FROM STRING.
912 ; TWO CALLS, ONE WITH A POINTING TO LIST ELEMENT,
913 ; THE OTHER WITH B POINTING TO PAIR. SKIPS IF WINNER, ELSE DOESNT
915 NXTDCL: GETYP B,(A) ;CHECK TYPE
916 CAIE B,TDEFER ;LOSE IF NOT DEFERRED
919 MOVE B,1(A) ;GET REAL BYTE POINTER
921 GETYP C,(B) ;CHECK IT IS CHSTR
923 JRST CPOPJC ;NO, QUIT
927 MOVEI E,0 ;INITIALIZE DESTINATION
928 HRRZ C,(B) ; GET CHAR COUNT
929 JUMPE C,GOTDCL ; NULL, FINISHED
930 MOVE B,1(B) ;GET BYTE POINTER
931 MOVE D,[440700,,E] ;BYTE POINT TO E
932 CHLOOP: ILDB 0,B ; GET A CHR
933 IDPB 0,D ;CLOBBER AWAY
934 SOJE C,GOTDCL ; JUMP IF DONE
935 TLNE D,760000 ; SKIP IF WORD FULL
936 JRST CHLOOP ; MORE THAN 5 CHARS
937 TRO E,1 ; TURN ON FLAG
939 GOTDCL: MOVE B,E ;RESULT TO B
940 AOS -4(P) ;SKIP RETURN
947 \f;ROUTINES TO DEFINE AND HANDLE LINKS
951 CAML AB,[-6,,0] ;NO MORE THAN 3 ARGS
952 CAML AB,[-2,,0] ;NO LESS THAN 2 ARGS
954 CAML AB,[-4,,0] ;ONLY TWO ARGS SUPPLIED ?
955 JRST GETOB ;YES, GET OBLIST FROM CURRENT PATH
961 MOVE B,IMQUOTE OBLIST
973 LINKIN: PUSHJ P,IINSRT
974 CAMN A,$TFALSE ;LINK NAME ALREADY USED ?
975 JRST ALRDY ;YES, LOSE
984 SUBM B,A ;FOUND A LINK ?
989 POPJ P, ;NO, FINISHED
991 PUSHJ P,IGVAL ;GET THE LINK'S DESTINATION
992 CAME A,$TUNBOUND ;WELL FORMED LINK ?
994 ERRUUO EQUOTE BAD-LINK
997 ; THIS SUBROUTINE IMPURIFIES A PURE ATOM TO ALLOW MODIFICATION OF SYSTEM SUBRS
1005 JRST RTNATM ; NOT PURE, RETURN
1008 ; ROUTINE PASSED TO GCHACK
1016 ADD C,TYPVEC+1 ; COMPUTE SAT
1029 ; SUBROUTINE TO FIND A BYTE STRINGS DOPE WORD
1030 ; RECEIVES POINTER TO PAIR CONNTAINIGN CHSTR IN C, RETURNS DOPE WORD IN A
1032 BYTDOP: PUSH P,B ; SAVE SOME ACS
1035 MOVE B,1(C) ; GET BYTE POINTER
1036 LDB D,[360600,,B] ; POSITION TO D
1037 LDB E,[300600,,B] ; AND BYTE SIZE
1038 MOVEI A,(E) ; A COPY IN A
1039 IDIVI D,(E) ; D=> # OF BYTES IN WORD 1
1040 HRRZ E,(C) ; GET LENGTH
1041 SUBM E,D ; # OF BYTES IN OTHER WORDS
1042 JUMPL D,BYTDO1 ; NEAR DOPE WORD
1043 MOVEI B,36. ; COMPUTE BYTES PER WORD
1045 ADDI D,-1(A) ; NOW COMPUTE WORDS
1046 IDIVI D,(A) ; D/ # NO. OF WORDS PAST 1ST
1047 ADD D,1(C) ; D POINTS TO DOPE WORD
1054 BYTDO1: MOVEI A,2(B)
1057 ; 1) IMPURIFY ITS OBLIST LIST
1059 IMPURX: HRRZ B,2(C) ; PICKUP OBLIST IF IT EXISTS
1060 JUMPE B,IMPUR0 ; NOT ON ONE, IGNORE THIS CODE
1063 PUSH TP,$TOBLS ; SAVE BUCKET
1066 MOVE B,(E) ; GET NEXT ONE
1071 SKIPE GPURFL ; IF PURIFY SMASH THE OBLIST SLOT TO PROTECT
1074 CAIGE 0,HIBOT ; SKIP IF PURE
1075 JRST IMPUR3 ; FOUND IMPURE NESS, SKIP IT
1076 HLLZ C,(B) ; SET UP ICONS CALL
1078 IMPR1: PUSHJ P,ICONS ; CONS IT UP
1079 IMPR2: HRRZ E,(TP) ; RETRV PREV
1080 HRRM B,(E) ; AND CLOBBER
1082 CAMN D,-2(TP) ; HAVE GOTTEN TO OUR SLOT?
1085 MOVEM 0,-1(TP) ; FIX TYPE
1086 HRRZM B,(TP) ; STORE GOODIE
1088 JUMPN B,IMPUR4 ; LOOP
1089 IMPPR3: SUB TP,[2,,2] ; FLUSH TP CRUFT
1091 ; 1.5) IMPURIFY GLOBAL HASH BUCKET, A REAL PAIN
1093 IMPUR0: MOVE C,(TP) ; GET ATOM
1097 ADD C,[3,,3] ; POINT TO PNAME
1098 HLRE A,C ; GET LNTH IN WORDS OF PNAME
1100 ; PUSH P,[SETZ IMPUR2] ; FAKE OUT ILOOKC
1101 ;The below is really: XMOVEI 0,IMPUR2
1104 PUSH P,(C) ; PUSH UP THE PNAME
1106 PUSH P,A ; NOW THE COUNT
1108 JRST ILOOKC ; GO FIND BUCKET
1110 IMPUR2: JUMPE B,IMPUR1
1111 JUMPE 0,IMPUR1 ; YUP, DONE
1113 CAIG C,HIBOT ; SKIP IF PREV IS PURE
1117 PUSH P,GPURFL ; PRERTEND OUT OF PURIFY
1120 HRRZ C,(C) ; ARE WE ON PURIFY LIST
1121 CAIG C,HIBOT ; IF SO, WE ARE STILL PURIFY
1123 PUSHJ P,IMPURIF ; RECURSE
1125 MOVE B,(TP) ; AND RETURN ORIGINAL
1127 ; 2) GENERATE A DUPLICATE ATOM
1129 IMPUR1: SKIPE GPURFL ; SEE IF IN PURIFY
1131 HLRE A,(TP) ; GET LNTH OF ATOM
1134 PUSHJ P,IBLOCK ; GET NEW BLOCK FOR ATOM
1137 HRL B,-2(TP) ; SETUP BLT
1139 ADDI A,(B) ; END OF BLT
1140 BLT B,(A) ; CLOBBER NEW ATOM
1141 MOVSI B,.VECT. ; TURN ON BIT FOR GCHACK
1144 ; 3) NOW COPY GLOBAL VALUE
1146 IMPUR7: MOVE B,(TP) ; ATOM BACK
1148 SKIPE A,1(B) ; NON-ZER POINTER?
1149 CAIN 0,TUNBOU ; BOUND?
1150 JRST IMPUR5 ; NO, DONT COPY GLOB VAL
1157 SKIPN GPURFL ; HERE IS SOME CODE NEEDED FOR PURIFY
1161 PUSH P,AB ; GET AB BACK
1162 MOVE AB,ABSTO+1(PVP)
1163 IMPUR8: PUSHJ P,BSETG ; SETG IT
1165 JRST .+3 ; RESTORE SP AND AB FOR PURIFY
1168 SUB TP,[2,,2] ; KILL ATOM SLOTS ON TP
1169 POP TP,C ;POP OFF VALUE SLOTS
1171 MOVEM A,(B) ; FILL IN SLOTS ON GLOBAL STACK
1173 IMPUR5: SKIPE GPURFL ; FINISH OFF DIFFERENTLY FOR PURIFY
1176 PUSH TP,$TFIX ;SAVE OLD ATOM WITH FUNNY TYPE TO AVOID LOSSAGE
1178 PUSH TP,$TFIX ; OTHER KIND OF POINTER ALSO
1184 ; 4) UPDATE ALL POINTERS TO THIS ATOM
1186 MOVE A,[PUSHJ P,ATFIX] ; INS TO PASS TO GCHACK
1187 MOVEI PVP,1 ; SAY MIGHT BE NON-ATOMS
1195 IMPUR9: SUB TP,[2,,2]
1196 POPJ P, ; RESTORE AND GO