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
16 ; FUNCTION TO GENERATE AN EMPTY OBLIST
18 MFUNCTION MOBLIST,SUBR
21 CAMGE AB,[-5,,0] ;CHECK NUMBER OF ARGS
23 JUMPGE AB,MOBL2 ; NO ARGS
28 PUSHJ P,IGET ; CHECK IF IT EXISTS ALREADY
33 PUSHJ P,IBLOCK ;GET A UNIFORM VECTOR
34 MOVSI C,TLIST+.VECT. ;IT IS OF TYPE LIST
35 HLRE D,B ;-LENGTH TO D
36 SUBM B,D ;D POINTS TO DOPE WORD
37 MOVEM C,(D) ;CLOBBER TYPE IN
39 JUMPGE AB,FINIS ; IF NO ARGS, DONE
50 PUSHJ P,IPUT ; PUT THE NAME ON THE OBLIST
57 PUSHJ P,IPUT ; PUT THE OBLIST ON THE NAME
63 MFUNCTION GROOT,SUBR,ROOT
69 MFUNCTION GINTS,SUBR,INTERRUPTS
75 MFUNCTION GERRS,SUBR,ERRORS
82 COBLQ: SKIPN B,2(B) ; SKIP IF EXISTS
87 CAMG B,VECBOT ; TVP IS IN FROZEN SPACE, NEVER OBLISTS
98 MFUNCTION OBLQ,SUBR,[OBLIST?]
104 MOVE B,1(AB) ; GET ATOM
109 \f; FUNCTION TO FIND AN ATOM ON A GIVEN OBLIST WITH A GIVEN PNAME
111 MFUNCTION LOOKUP,SUBR
114 PUSHJ P,ILOOKU ;CALL INTERNAL ROUTINE
126 MOVSI A,TOBLS ; THIS IS AN OBLIST
136 ILOOKU: PUSHJ P,ARGCHK ;CHECK ARGS
137 PUSHJ P,CSTACK ;PUT CHARACTERS ON THE STACK
139 CALLIT: MOVE B,3(AB) ;GET OBLIST
141 ILOOKC: PUSHJ P,ILOOK ;LOOK IT UP
142 POP P,D ;RESTORE COUNT
143 HRLI D,(D) ;TO BOTH SIDES
147 ;THIS ROUTINE CHECKS ARG TYPES
149 ARGCHK: GETYP A,(AB) ;GET TYPES
151 CAIE A,TCHRS ;IS IT EITHER CHAR STRING
153 CAIE C,TOBLS ;IS 2ND AN OBLIST
154 JRST WRONGT ;TYPES ARE WRONG
157 ;THIS SUBROUTINE PUTS CHARACTERS ON THE STACK (P WILL BE CHANGED)
161 CSTAK: POP P,D ;RETURN ADDRESS TO D
162 CAIE A,TCHRS ;IMMEDIATE?
163 JRST NOTIMM ;NO, HAIR
164 MOVE A,1(B) ; GET CHAR
167 PUSH P,[1] ;WITH NUMBER
168 JRST (D) ;GO CALL SEARCHER
170 NOTIMM: MOVEI A,1 ; CLEAR CHAR COUNT
171 MOVE C,(B) ; GET COUNT OF CHARS
173 JRST NULST ; FLUSH NULL STRING
177 MOVE B,1(B) ;GET BYTE POINTER
179 CLOOP1: PUSH P,[0] ; STORE CHARS ON STACK
180 MOVSI E,(<440700,,(P)>) ; SETUP BYTE POINTER
181 CLOOP: SKIPL INTFLG ; SO CAN WIN WITH INTERRUPTS
184 HRRM C,BSTO(PVP) ;SAVE STRING LENGTH
186 CLOOP2: ILDB 0,B ;GET A CHARACTER
188 SOJE C,CDONE ; ANY MORE?
189 TLNE E,760000 ; WORD FULL
190 JRST CLOOP ;NO CONTINUE
191 AOJA A,CLOOP1 ;AND CONTINUE
194 CDONE1: MOVE PVP,PVSTOR+1
196 PUSH P,A ;AND NUMBER OF WORDS
200 NULST: ERRUUO EQUOTE NULL-STRING
201 \f; THIS FUNCTION LOOKS FOR ATOMS. CALLED BY PUSHJ P,ILOOK
202 ; A,B/ OBLIST POINTER (CAN BE LIST OF SAME)
203 ; -1(P)/ LENGTH IN WORDS OF CHARACTER BLOCK
204 ; CHAR STRING IS ON THE STACK
205 ; IF ATOM EXISTS RETURNS:
208 ; 0/ THE PREVIOUS BUCKET
212 ; 0/ PREV IF ONE WITH SAME PNAME, ELSE 0
218 MOVN A,-1(P) ;GET -LENGTH
219 HRLI A,-1(A) ;<-LENGTH-1>,,-LENGTH
222 ADDI A,-1(P) ;HAVE AOBJN POINTER TO CHARS
223 MOVE 0,[202622077324] ;HASH WORD
226 AOBJN A,.-2 ;XOR THEM ALL TOGETHER
229 MOVMS 0 ; MAKE SURE + HASH CODE
231 HRLI A,(A) ;TO BOTH HALVES
235 HRRZ A,(A) ; POINT TO FIRST ATOM
236 SETZB E,0 ; INDICATE NO ATOM
239 LOOK2: HLRZ E,1(A) ; PREPARE TO BUILD AOBJN
240 ANDI E,377777 ; SIGN MIGHT BE ON IF IN PURIFY ETC.
245 ADD A,[3,,3] ;POINT TO ATOMS PNAME
246 MOVE D,(TP) ;GET PSEUDO AOBJN POINTER TO CHARS
247 ADDI D,-1(P) ;NOW ITS A REAL AOBJN POINTER
248 JUMPE D,CHECK0 ;ONE IS EMPTY
253 JRST NEXT1 ;THIS ONE DOESN'T MATCH
254 AOBJP D,CHECK ;ONE RAN OUT
255 AOBJN A,LOOK1 ;JUMP IF STILL MIGHT WIN
257 NEXT1: HRRZ A,-1(TP) ; SEE IF WE'VE ALREADY SEEN THIS NAME
258 GETYP D,-3(TP) ; SEE IF LIST OF OBLISTS
260 JUMPN A,CHECK3 ; DON'T LOOK FURTHER
264 HLRZ A,2(E) ; NEXT ATOM
279 CHECK0: JUMPN A,NEXT1 ;JUMP IF NOT ALSO EMPTY
281 CHECK: AOBJN A,NEXT1 ;JUMP IF NO MATCH
283 CHECK5: HRRZ A,-1(TP) ; SEE IF FIRST SHOT AT THIS GUY?
285 MOVE B,0 ; REMEMBER ATOM FOR FALL BACK
286 HLLOS -1(TP) ; INDICATE NAME MATCH HAS OCCURRED
287 HRRZ A,2(E) ; COMPUTE OBLIST POINTER
291 GETYP D,-3(TP) ; SEE IF LIST OF OBLISTS OR
294 CAME A,-2(TP) ; DO OBLISTS MATCH?
297 CHECK2: MOVE B,E ; RETURN ATOM
306 CHECK1: MOVE D,-2(TP) ; ANY LEFT?
311 CHECK3: MOVE D,-2(TP)
318 ANDI A,377777 ; SIGN MIGHT BE ON IF IN PURIFY ETC.
327 \f; FUNCTION TO INSERT AN ATOM ON AN OBLIST
329 MFUNCTION INSERT,SUBR
353 ;INSERT WITH A GIVEN PNAME
360 PUSH TP,$TFIX ;FLAG CALL
363 PUSHJ P,CSTAK ;COPY ONTO STACK
366 PUSHJ P,ILOOK ;LOOK IT UP (BUCKET RETURNS IN C)
368 SETZM -5(TP) ; KILL STRING POINTER TO KEEP FROM CONFUSING GC
369 JUMPN B,ALRDY ;EXISTS, LOSE
370 MOVE D,-2(TP) ; GET OBLIST BACK
371 INSRT1: PUSH TP,$TATOM
372 PUSH TP,0 ; PREV ATOM
373 PUSH TP,$TUVEC ;SAVE BUCKET POINTER
376 PUSH TP,D ; SAVE OBLIST
377 INSRT3: PUSHJ P,IATOM ; MAKE AN ATOM
378 HLRE A,B ; FIND DOPE WORD
381 SKIPN E,-4(TP) ; AFTER AN ATOM?
382 JRST INSRT7 ; NO, FIRST IN BUCKET
383 MOVEI 0,(E) ; CHECK IF PURE
386 PUSH TP,$TATOM ; SAVE NEW ATOM
393 HLRE A,B ; FIND DOPE WORD
397 INSRNP: HLRZ 0,2(E) ; NEXT
402 INSRT7: MOVE E,-2(TP)
404 HRLM A,2(B) ; IN CASE OLD ONE
406 INSRT8: MOVE E,(TP) ; GET OBLIST
407 HRRM E,2(B) ; STORE OBLIST
408 MOVE E,(E) ; POINT TO LIST OF ATOMS
412 HRRM B,(E) ;INTO NEW BUCKET
414 MOVE B,1(B) ;GET ATOM BACK
415 MOVE C,-6(TP) ;GET FLAG
416 SUB TP,[8,,8] ;POP STACK
421 ;INSERT WITH GIVEN ATOM
422 INSRT0: MOVE A,-2(TP) ;GOBBLE PNAME
423 SKIPE 2(A) ; SKIP IF NOT ON AN OBLIST
428 PUSH P,(A) ;FLUSH PNAME ONTO P STACK
431 MOVE B,(TP) ; GET OBLIST FOR LOOKUP
433 PUSHJ P,ILOOK ;ALREADY THERE?
437 HLRE A,-2(TP) ; FIND DOPE WORD
439 JUMPE 0,INSRT9 ; NO CURRENT ATOM
442 CAIGE 0,HIBOT ; PURE?
457 INSRPN: HLRZ 0,2(E) ; POINT TO NEXT
458 HRLM A,2(E) ; CLOBBER NEW GUY IN
459 HRLM 0,2(D) ; FINISH SLPICE
463 EXCH A,(C) ; INTO BUCKET
471 MOVE C,(TP) ;RESTORE OBLIST
473 MOVE B,-2(TP) ; GET BACK ATOM
474 HRRM C,2(B) ; CLOBBER OBLIST IN
482 LINKCK: HRRZ C,FSAV(TB) ;CALLER'S NAME
485 SKIPA C,$TATOM ;LET US INSERT A LINK INSTEAD OF AN ATOM
486 SKIPA C,$TLINK ;GET REAL ATOM FOR CALL TO ICONS
495 ALRDY: ERRUUO EQUOTE ATOM-ALREADY-THERE
497 ONOBL: ERRUUO EQUOTE ON-AN-OBLIST-ALREADY
499 ; INTERNAL INSERT CALL
501 INSRTX: POP P,0 ; GET RET ADDR
515 JRST INSRT3 ; INTO INSERT CODE
517 INSRXT: PUSH P,-4(TP)
522 ; FUNCTION TO REMOVE AN ATOM FROM AN OBLIST
524 MFUNCTION REMOVE,SUBR
532 CAML AB,[-3,,] ; SKIP IF OBLIST GIVEN
551 IRMV1: GETYP 0,A ; CHECK 1ST ARG
554 CAIE 0,TATOM ; ATOM, TREAT ACCORDINGLY
557 HRRZ D,2(B) ; SKIP IF ON OBLIST AND GET SAME
559 CAMG D,VECBOT ; SKIP IF REAL OBLIST
560 HRRZ D,(D) ; NO, REF, GET IT
563 CAIE D,(C) ; BETTER BE THE SAME
566 GOTOBL: ADD B,[3,,3] ; POINT TO PNAME
569 PUSH P,(B) ; PUSH PNAME
572 HRROM D,(TP) ; SAVE OBLIST
591 CAIGE A,HIBOT ; SKIP IF PURE
603 RMV2: JUMPN 0,RMV9 ; JUMP IF FIRST NOT IN BUCKET
604 HLRZ 0,2(B) ; POINT TO NEXT
608 RMV9: MOVE C,0 ; C IS PREV ATOM
612 RMV8: SETZM 2(B) ; CLOBBER OBLIST SLOT
613 MOVE C,(TP) ; GET OBLIST FOR SPLICE OUT
618 CAMN B,1(E) ; SEARCH OBLIST
624 RMVDON: SUB TP,[4,,4]
629 HRRM E,(C) ; SMASH IN
633 ;INTERNAL CALL FROM THE READER
635 RLOOKU: PUSH TP,$TFIX ;PUSH A FLAG
636 POP P,C ;POP OFF RET ADR
637 PUSH TP,C ;AND USE AS A FLAG FOR INTERNAL
638 MOVE C,(P) ; CHANGE CHAR COUNT TO WORD
644 CAIN D,TOBLS ;IS IT ONE OBLIST?
646 CAIE D,TLIST ;IS IT A LIST
650 PUSH TP,$TUVEC ; SLOT FOR REMEBERIG
661 RLOOK2: GETYP A,(B) ;CHECK THIS IS AN OBLIST
665 SKIPE -4(TP) ; SKIP IF DEFAULT NOT STORED
670 HRRZ B,@(TP) ;CDR THE LIST
682 SKIPN D,-2(TP) ; RESTORE FOR INSERT
683 JRST BADDEF ; NO DEFAULT, USER LOST ON SPECIFICATION
684 SUB TP,[6,,6] ; FLUSH CRAP
689 DEFFLG==1 ;SPECIAL FLAG USED TO INDICATE THAT A DEFAULT HAS ALREADY BEEN
692 CAIN A,TATOM ;SPECIAL DEFAULT INDICATING ATOM ?
693 CAME 0,MQUOTE DEFAULT
694 JRST BADDEF ;NO, LOSE
696 XORB A,-11(TP) ;SET AND TEST FLAG
697 TRNN A,DEFFLG ; HAVE WE BEEN HERE BEFORE ?
698 JRST BADDEF ; YES, LOSE
699 SETZM -6(TP) ;ZERO OUT PREVIOUS DEFAULT
701 JRST RLOOK4 ;CONTINUE
705 RLOOK3: SUB TP,[6,,6] ;POP OFF LOSSAGE
706 PUSHJ P,ILINK ;IF THIS IS A LINK FOLLOW IT
707 PUSH P,(TP) ;GET BACK RET ADR
708 SUB TP,[2,,2] ;POP TP
709 JRST IATM1 ;AND RETURN
712 BADOBL: ERRUUO EQUOTE BAD-OBLIST-OR-LIST-THEREOF
714 BADDEF: ERRUUO EQUOTE BAD-DEFAULT-OBLIST-SPECIFICATION
716 ONOTH: ERRUUO EQUOTE ATOM-ON-DIFFERENT-OBLIST
717 \f;SUBROUTINE TO MAKE AN ATOM
732 IATOMI: GETYP 0,A ;CHECK ARG TYPE
735 JRST .+2 ;JUMP IF WINNERS
742 PUSHJ P,CSTAK ;COPY ONTO STACK
743 PUSHJ P,IATOM ;NOW MAKE THE ATOM
749 IATOM: MOVE A,-1(P) ;GET WORDS IN PNAME
750 ADDI A,3 ;FOR VALUE CELL
751 PUSHJ P,IBLOCK ; GET BLOCK
752 MOVSI C,<(GENERAL)>+SATOM ;FOR TYPE FIELD
753 MOVE D,-1(P) ;RE-GOBBLE LENGTH
754 ADDI D,3(B) ;POINT TO DOPE WORD
756 SKIPG -1(P) ;EMPTY PNAME ?
757 JRST IATM0 ;YES, NO CHARACTERS TO MOVE
758 MOVE E,B ;COPY ATOM POINTER
759 ADD E,[3,,3] ;POINT TO PNAME AREA
761 SUB C,-1(P) ;POINT TO STRING ON STACK
762 MOVE D,(C) ;GET SOME CHARS
763 MOVEM D,(E) ;AND COPY THEM
766 IATM0: MOVSI A,TATOM ;TYPE TO ATOM
767 IATM1: POP P,D ;RETURN ADR
773 \f;SUBROUTINE TO GET AN ATOM'S PNAME
780 CAIE A,TATOM ;CHECK TYPE IS ATOM
793 PUSH P,(A) ;FLUSH PNAME ONTO P
795 MOVE 0,(P) ; LAST WORD
798 PUSHJ P,CHMAK ;MAKE A STRING
801 PNMCNT: IMULI B,5 ; CHARS TO B
803 SUBI A,1 ; FIND LAST 1
804 ANDCM 0,A ; 0 HAS 1ST 1
806 HRREI 0,-34.(A) ; FIND HOW MUCH TO ADD
811 MFUNCTION SPNAME,SUBR
837 \f; BLOCK STRUCTURE SUBROUTINES FOR MUDDLE
839 IMFUNCTION BLK,SUBR,BLOCK
843 GETYP A,(AB) ;CHECK TYPE OF ARG
844 CAIE A,TOBLS ;IS IT AN OBLIST
845 CAIN A,TLIST ;OR A LIAT
848 MOVSI A,TATOM ;LOOK UP OBLIST
849 MOVE B,IMQUOTE OBLIST
850 PUSHJ P,IDVAL ;GET VALUE
854 PUSH TP,.BLOCK(PVP) ;HACK THE LIST
855 PUSH TP,.BLOCK+1(PVP)
856 MCALL 2,CONS ;CONS THE LIST
858 MOVEM A,.BLOCK(PVP) ;STORE IT BACK
859 MOVEM B,.BLOCK+1(PVP)
861 PUSH TP,IMQUOTE OBLIST
864 MCALL 2,SET ;SET OBLIST TO ARG
867 MFUNCTION ENDBLOCK,SUBR
872 SKIPN B,.BLOCK+1(PVP) ;IS THE LIST NIL?
873 JRST BLKERR ;YES, LOSE
874 HRRZ C,(B) ;CDR THE LIST
875 HRRZM C,.BLOCK+1(PVP)
876 PUSH TP,$TATOM ;NOW RESET OBLIST
877 PUSH TP,IMQUOTE OBLIST
878 HLLZ A,(B) ;PUSH THE TYPE OF THE CAR
880 PUSH TP,1(B) ;AND VALUE OF CAR
884 BLKERR: ERRUUO EQUOTE UNMATCHED
886 BADLST: ERRUUO EQUOTE NIL-LIST-OF-OBLISTS
887 \f;SUBROUTINE TO CREATE CHARACTER STRING GOODIE
893 MOVEI C,-1(P) ;FIND START OF CHARS
895 ADD C,E ;C POINTS TO START
896 MOVE D,B ;COPY VECTOR RESULT
897 JUMPGE D,NULLST ;JUMP IF EMPTY
900 ADDI C,1 ;BUMP POINTER
902 NULLST: MOVSI C,TCHRS+.VECT. ;GET TYPE
903 MOVEM C,(D) ;CLOBBER IT IN
904 MOVE A,-1(P) ; # WORDS
907 MOVMM E,-1(P) ; SO IATM1 WORKS
910 ; SUBROUTINE TO READ FIVE CHARS FROM STRING.
911 ; TWO CALLS, ONE WITH A POINTING TO LIST ELEMENT,
912 ; THE OTHER WITH B POINTING TO PAIR. SKIPS IF WINNER, ELSE DOESNT
914 NXTDCL: GETYP B,(A) ;CHECK TYPE
915 CAIE B,TDEFER ;LOSE IF NOT DEFERRED
918 MOVE B,1(A) ;GET REAL BYTE POINTER
920 GETYP C,(B) ;CHECK IT IS CHSTR
922 JRST CPOPJC ;NO, QUIT
926 MOVEI E,0 ;INITIALIZE DESTINATION
927 HRRZ C,(B) ; GET CHAR COUNT
928 JUMPE C,GOTDCL ; NULL, FINISHED
929 MOVE B,1(B) ;GET BYTE POINTER
930 MOVE D,[440700,,E] ;BYTE POINT TO E
931 CHLOOP: ILDB 0,B ; GET A CHR
932 IDPB 0,D ;CLOBBER AWAY
933 SOJE C,GOTDCL ; JUMP IF DONE
934 TLNE D,760000 ; SKIP IF WORD FULL
935 JRST CHLOOP ; MORE THAN 5 CHARS
936 TRO E,1 ; TURN ON FLAG
938 GOTDCL: MOVE B,E ;RESULT TO B
939 AOS -4(P) ;SKIP RETURN
946 \f;ROUTINES TO DEFINE AND HANDLE LINKS
950 CAML AB,[-6,,0] ;NO MORE THAN 3 ARGS
951 CAML AB,[-2,,0] ;NO LESS THAN 2 ARGS
953 CAML AB,[-4,,0] ;ONLY TWO ARGS SUPPLIED ?
954 JRST GETOB ;YES, GET OBLIST FROM CURRENT PATH
960 MOVE B,IMQUOTE OBLIST
972 LINKIN: PUSHJ P,IINSRT
973 CAMN A,$TFALSE ;LINK NAME ALREADY USED ?
974 JRST ALRDY ;YES, LOSE
983 SUBM B,A ;FOUND A LINK ?
988 POPJ P, ;NO, FINISHED
990 PUSHJ P,IGVAL ;GET THE LINK'S DESTINATION
991 CAME A,$TUNBOUND ;WELL FORMED LINK ?
993 ERRUUO EQUOTE BAD-LINK
996 ; THIS SUBROUTINE IMPURIFIES A PURE ATOM TO ALLOW MODIFICATION OF SYSTEM SUBRS
1004 JRST RTNATM ; NOT PURE, RETURN
1007 ; ROUTINE PASSED TO GCHACK
1015 ADD C,TYPVEC+1 ; COMPUTE SAT
1028 ; SUBROUTINE TO FIND A BYTE STRINGS DOPE WORD
1029 ; RECEIVES POINTER TO PAIR CONNTAINIGN CHSTR IN C, RETURNS DOPE WORD IN A
1031 BYTDOP: PUSH P,B ; SAVE SOME ACS
1034 MOVE B,1(C) ; GET BYTE POINTER
1035 LDB D,[360600,,B] ; POSITION TO D
1036 LDB E,[300600,,B] ; AND BYTE SIZE
1037 MOVEI A,(E) ; A COPY IN A
1038 IDIVI D,(E) ; D=> # OF BYTES IN WORD 1
1039 HRRZ E,(C) ; GET LENGTH
1040 SUBM E,D ; # OF BYTES IN OTHER WORDS
1041 JUMPL D,BYTDO1 ; NEAR DOPE WORD
1042 MOVEI B,36. ; COMPUTE BYTES PER WORD
1044 ADDI D,-1(A) ; NOW COMPUTE WORDS
1045 IDIVI D,(A) ; D/ # NO. OF WORDS PAST 1ST
1046 ADD D,1(C) ; D POINTS TO DOPE WORD
1053 BYTDO1: MOVEI A,2(B)
1056 ; 1) IMPURIFY ITS OBLIST LIST
1058 IMPURX: HRRZ B,2(C) ; PICKUP OBLIST IF IT EXISTS
1059 JUMPE B,IMPUR0 ; NOT ON ONE, IGNORE THIS CODE
1062 PUSH TP,$TOBLS ; SAVE BUCKET
1065 MOVE B,(E) ; GET NEXT ONE
1070 SKIPE GPURFL ; IF PURIFY SMASH THE OBLIST SLOT TO PROTECT
1073 CAIGE 0,HIBOT ; SKIP IF PURE
1074 JRST IMPUR3 ; FOUND IMPURE NESS, SKIP IT
1075 HLLZ C,(B) ; SET UP ICONS CALL
1077 IMPR1: PUSHJ P,ICONS ; CONS IT UP
1078 IMPR2: HRRZ E,(TP) ; RETRV PREV
1079 HRRM B,(E) ; AND CLOBBER
1081 CAMN D,-2(TP) ; HAVE GOTTEN TO OUR SLOT?
1084 MOVEM 0,-1(TP) ; FIX TYPE
1085 HRRZM B,(TP) ; STORE GOODIE
1087 JUMPN B,IMPUR4 ; LOOP
1088 IMPPR3: SUB TP,[2,,2] ; FLUSH TP CRUFT
1090 ; 1.5) IMPURIFY GLOBAL HASH BUCKET, A REAL PAIN
1092 IMPUR0: MOVE C,(TP) ; GET ATOM
1096 ADD C,[3,,3] ; POINT TO PNAME
1097 HLRE A,C ; GET LNTH IN WORDS OF PNAME
1099 ; PUSH P,[SETZ IMPUR2] ; FAKE OUT ILOOKC
1102 PUSH P,(C) ; PUSH UP THE PNAME
1104 PUSH P,A ; NOW THE COUNT
1106 JRST ILOOKC ; GO FIND BUCKET
1108 IMPUR2: JUMPE B,IMPUR1
1109 JUMPE 0,IMPUR1 ; YUP, DONE
1111 CAIG C,HIBOT ; SKIP IF PREV IS PURE
1115 PUSH P,GPURFL ; PRERTEND OUT OF PURIFY
1118 HRRZ C,(C) ; ARE WE ON PURIFY LIST
1119 CAIG C,HIBOT ; IF SO, WE ARE STILL PURIFY
1121 PUSHJ P,IMPURIF ; RECURSE
1123 MOVE B,(TP) ; AND RETURN ORIGINAL
1125 ; 2) GENERATE A DUPLICATE ATOM
1127 IMPUR1: SKIPE GPURFL ; SEE IF IN PURIFY
1129 HLRE A,(TP) ; GET LNTH OF ATOM
1132 PUSHJ P,IBLOCK ; GET NEW BLOCK FOR ATOM
1135 HRL B,-2(TP) ; SETUP BLT
1137 ADDI A,(B) ; END OF BLT
1138 BLT B,(A) ; CLOBBER NEW ATOM
1139 MOVSI B,.VECT. ; TURN ON BIT FOR GCHACK
1142 ; 3) NOW COPY GLOBAL VALUE
1144 IMPUR7: MOVE B,(TP) ; ATOM BACK
1146 SKIPE A,1(B) ; NON-ZER POINTER?
1147 CAIN 0,TUNBOU ; BOUND?
1148 JRST IMPUR5 ; NO, DONT COPY GLOB VAL
1155 SKIPN GPURFL ; HERE IS SOME CODE NEEDED FOR PURIFY
1159 PUSH P,AB ; GET AB BACK
1160 MOVE AB,ABSTO+1(PVP)
1161 IMPUR8: PUSHJ P,BSETG ; SETG IT
1163 JRST .+3 ; RESTORE SP AND AB FOR PURIFY
1166 SUB TP,[2,,2] ; KILL ATOM SLOTS ON TP
1167 POP TP,C ;POP OFF VALUE SLOTS
1169 MOVEM A,(B) ; FILL IN SLOTS ON GLOBAL STACK
1171 IMPUR5: SKIPE GPURFL ; FINISH OFF DIFFERENTLY FOR PURIFY
1174 PUSH TP,$TFIX ;SAVE OLD ATOM WITH FUNNY TYPE TO AVOID LOSSAGE
1176 PUSH TP,$TFIX ; OTHER KIND OF POINTER ALSO
1182 ; 4) UPDATE ALL POINTERS TO THIS ATOM
1184 MOVE A,[PUSHJ P,ATFIX] ; INS TO PASS TO GCHACK
1185 MOVEI PVP,1 ; SAY MIGHT BE NON-ATOMS
1193 IMPUR9: SUB TP,[2,,2]
1194 POPJ P, ; RESTORE AND GO