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
301 CHECK1: MOVE D,-2(TP) ; ANY LEFT?
306 CHECK3: MOVE D,-2(TP)
313 ANDI A,377777 ; SIGN MIGHT BE ON IF IN PURIFY ETC.
322 \f; FUNCTION TO INSERT AN ATOM ON AN OBLIST
324 MFUNCTION INSERT,SUBR
348 ;INSERT WITH A GIVEN PNAME
355 PUSH TP,$TFIX ;FLAG CALL
358 PUSHJ P,CSTAK ;COPY ONTO STACK
361 PUSHJ P,ILOOK ;LOOK IT UP (BUCKET RETURNS IN C)
363 SETZM -5(TP) ; KILL STRING POINTER TO KEEP FROM CONFUSING GC
364 JUMPN B,ALRDY ;EXISTS, LOSE
365 MOVE D,-2(TP) ; GET OBLIST BACK
366 INSRT1: PUSH TP,$TATOM
367 PUSH TP,0 ; PREV ATOM
368 PUSH TP,$TUVEC ;SAVE BUCKET POINTER
371 PUSH TP,D ; SAVE OBLIST
372 INSRT3: PUSHJ P,IATOM ; MAKE AN ATOM
373 HLRE A,B ; FIND DOPE WORD
376 SKIPN E,-4(TP) ; AFTER AN ATOM?
377 JRST INSRT7 ; NO, FIRST IN BUCKET
378 MOVEI 0,(E) ; CHECK IF PURE
381 PUSH TP,$TATOM ; SAVE NEW ATOM
388 HLRE A,B ; FIND DOPE WORD
392 INSRNP: HLRZ 0,2(E) ; NEXT
397 INSRT7: MOVE E,-2(TP)
399 HRLM A,2(B) ; IN CASE OLD ONE
401 INSRT8: MOVE E,(TP) ; GET OBLIST
402 HRRM E,2(B) ; STORE OBLIST
403 MOVE E,(E) ; POINT TO LIST OF ATOMS
407 HRRM B,(E) ;INTO NEW BUCKET
409 MOVE B,1(B) ;GET ATOM BACK
410 MOVE C,-6(TP) ;GET FLAG
411 SUB TP,[8,,8] ;POP STACK
416 ;INSERT WITH GIVEN ATOM
417 INSRT0: MOVE A,-2(TP) ;GOBBLE PNAME
418 SKIPE 2(A) ; SKIP IF NOT ON AN OBLIST
423 PUSH P,(A) ;FLUSH PNAME ONTO P STACK
426 MOVE B,(TP) ; GET OBLIST FOR LOOKUP
428 PUSHJ P,ILOOK ;ALREADY THERE?
432 HLRE A,-2(TP) ; FIND DOPE WORD
434 JUMPE 0,INSRT9 ; NO CURRENT ATOM
437 CAIGE 0,HIBOT ; PURE?
452 INSRPN: HLRZ 0,2(E) ; POINT TO NEXT
453 HRLM A,2(E) ; CLOBBER NEW GUY IN
454 HRLM 0,2(D) ; FINISH SLPICE
458 EXCH A,(C) ; INTO BUCKET
466 MOVE C,(TP) ;RESTORE OBLIST
468 MOVE B,-2(TP) ; GET BACK ATOM
469 HRRM C,2(B) ; CLOBBER OBLIST IN
477 LINKCK: HRRZ C,FSAV(TB) ;CALLER'S NAME
480 SKIPA C,$TATOM ;LET US INSERT A LINK INSTEAD OF AN ATOM
481 SKIPA C,$TLINK ;GET REAL ATOM FOR CALL TO ICONS
490 ALRDY: ERRUUO EQUOTE ATOM-ALREADY-THERE
492 ONOBL: ERRUUO EQUOTE ON-AN-OBLIST-ALREADY
494 ; INTERNAL INSERT CALL
496 INSRTX: POP P,0 ; GET RET ADDR
510 JRST INSRT3 ; INTO INSERT CODE
512 INSRXT: PUSH P,-4(TP)
517 ; FUNCTION TO REMOVE AN ATOM FROM AN OBLIST
519 MFUNCTION REMOVE,SUBR
527 CAML AB,[-3,,] ; SKIP IF OBLIST GIVEN
546 IRMV1: GETYP 0,A ; CHECK 1ST ARG
549 CAIE 0,TATOM ; ATOM, TREAT ACCORDINGLY
552 HRRZ D,2(B) ; SKIP IF ON OBLIST AND GET SAME
554 CAMG D,VECBOT ; SKIP IF REAL OBLIST
555 HRRZ D,(D) ; NO, REF, GET IT
558 CAIE D,(C) ; BETTER BE THE SAME
561 GOTOBL: ADD B,[3,,3] ; POINT TO PNAME
564 PUSH P,(B) ; PUSH PNAME
567 HRROM D,(TP) ; SAVE OBLIST
586 CAIGE A,HIBOT ; SKIP IF PURE
598 RMV2: JUMPN 0,RMV9 ; JUMP IF FIRST NOT IN BUCKET
599 HLRZ 0,2(B) ; POINT TO NEXT
603 RMV9: MOVE C,0 ; C IS PREV ATOM
607 RMV8: SETZM 2(B) ; CLOBBER OBLIST SLOT
608 MOVE C,(TP) ; GET OBLIST FOR SPLICE OUT
613 CAMN B,1(E) ; SEARCH OBLIST
619 RMVDON: SUB TP,[4,,4]
624 HRRM E,(C) ; SMASH IN
628 ;INTERNAL CALL FROM THE READER
630 RLOOKU: PUSH TP,$TFIX ;PUSH A FLAG
631 POP P,C ;POP OFF RET ADR
632 PUSH TP,C ;AND USE AS A FLAG FOR INTERNAL
633 MOVE C,(P) ; CHANGE CHAR COUNT TO WORD
639 CAIN D,TOBLS ;IS IT ONE OBLIST?
641 CAIE D,TLIST ;IS IT A LIST
645 PUSH TP,$TUVEC ; SLOT FOR REMEBERIG
656 RLOOK2: GETYP A,(B) ;CHECK THIS IS AN OBLIST
660 SKIPE -4(TP) ; SKIP IF DEFAULT NOT STORED
665 HRRZ B,@(TP) ;CDR THE LIST
677 SKIPN D,-2(TP) ; RESTORE FOR INSERT
678 JRST BADDEF ; NO DEFAULT, USER LOST ON SPECIFICATION
679 SUB TP,[6,,6] ; FLUSH CRAP
684 DEFFLG==1 ;SPECIAL FLAG USED TO INDICATE THAT A DEFAULT HAS ALREADY BEEN
687 CAIN A,TATOM ;SPECIAL DEFAULT INDICATING ATOM ?
688 CAME 0,MQUOTE DEFAULT
689 JRST BADDEF ;NO, LOSE
691 XORB A,-11(TP) ;SET AND TEST FLAG
692 TRNN A,DEFFLG ; HAVE WE BEEN HERE BEFORE ?
693 JRST BADDEF ; YES, LOSE
694 SETZM -6(TP) ;ZERO OUT PREVIOUS DEFAULT
696 JRST RLOOK4 ;CONTINUE
700 RLOOK3: SUB TP,[6,,6] ;POP OFF LOSSAGE
701 PUSHJ P,ILINK ;IF THIS IS A LINK FOLLOW IT
702 PUSH P,(TP) ;GET BACK RET ADR
703 SUB TP,[2,,2] ;POP TP
704 JRST IATM1 ;AND RETURN
707 BADOBL: ERRUUO EQUOTE BAD-OBLIST-OR-LIST-THEREOF
709 BADDEF: ERRUUO EQUOTE BAD-DEFAULT-OBLIST-SPECIFICATION
711 ONOTH: ERRUUO EQUOTE ATOM-ON-DIFFERENT-OBLIST
712 \f;SUBROUTINE TO MAKE AN ATOM
727 IATOMI: GETYP 0,A ;CHECK ARG TYPE
730 JRST .+2 ;JUMP IF WINNERS
737 PUSHJ P,CSTAK ;COPY ONTO STACK
738 PUSHJ P,IATOM ;NOW MAKE THE ATOM
744 IATOM: MOVE A,-1(P) ;GET WORDS IN PNAME
745 ADDI A,3 ;FOR VALUE CELL
746 PUSHJ P,IBLOCK ; GET BLOCK
747 MOVSI C,<(GENERAL)>+SATOM ;FOR TYPE FIELD
748 MOVE D,-1(P) ;RE-GOBBLE LENGTH
749 ADDI D,3(B) ;POINT TO DOPE WORD
751 SKIPG -1(P) ;EMPTY PNAME ?
752 JRST IATM0 ;YES, NO CHARACTERS TO MOVE
753 MOVE E,B ;COPY ATOM POINTER
754 ADD E,[3,,3] ;POINT TO PNAME AREA
756 SUB C,-1(P) ;POINT TO STRING ON STACK
757 MOVE D,(C) ;GET SOME CHARS
758 MOVEM D,(E) ;AND COPY THEM
761 IATM0: MOVSI A,TATOM ;TYPE TO ATOM
762 IATM1: POP P,D ;RETURN ADR
768 \f;SUBROUTINE TO GET AN ATOM'S PNAME
775 CAIE A,TATOM ;CHECK TYPE IS ATOM
788 PUSH P,(A) ;FLUSH PNAME ONTO P
790 MOVE 0,(P) ; LAST WORD
793 PUSHJ P,CHMAK ;MAKE A STRING
796 PNMCNT: IMULI B,5 ; CHARS TO B
798 SUBI A,1 ; FIND LAST 1
799 ANDCM 0,A ; 0 HAS 1ST 1
801 HRREI 0,-34.(A) ; FIND HOW MUCH TO ADD
806 MFUNCTION SPNAME,SUBR
832 \f; BLOCK STRUCTURE SUBROUTINES FOR MUDDLE
834 IMFUNCTION BLK,SUBR,BLOCK
838 GETYP A,(AB) ;CHECK TYPE OF ARG
839 CAIE A,TOBLS ;IS IT AN OBLIST
840 CAIN A,TLIST ;OR A LIAT
843 MOVSI A,TATOM ;LOOK UP OBLIST
844 MOVE B,IMQUOTE OBLIST
845 PUSHJ P,IDVAL ;GET VALUE
849 PUSH TP,.BLOCK(PVP) ;HACK THE LIST
850 PUSH TP,.BLOCK+1(PVP)
851 MCALL 2,CONS ;CONS THE LIST
853 MOVEM A,.BLOCK(PVP) ;STORE IT BACK
854 MOVEM B,.BLOCK+1(PVP)
856 PUSH TP,IMQUOTE OBLIST
859 MCALL 2,SET ;SET OBLIST TO ARG
862 MFUNCTION ENDBLOCK,SUBR
867 SKIPN B,.BLOCK+1(PVP) ;IS THE LIST NIL?
868 JRST BLKERR ;YES, LOSE
869 HRRZ C,(B) ;CDR THE LIST
870 HRRZM C,.BLOCK+1(PVP)
871 PUSH TP,$TATOM ;NOW RESET OBLIST
872 PUSH TP,IMQUOTE OBLIST
873 HLLZ A,(B) ;PUSH THE TYPE OF THE CAR
875 PUSH TP,1(B) ;AND VALUE OF CAR
879 BLKERR: ERRUUO EQUOTE UNMATCHED
881 BADLST: ERRUUO EQUOTE NIL-LIST-OF-OBLISTS
882 \f;SUBROUTINE TO CREATE CHARACTER STRING GOODIE
888 MOVEI C,-1(P) ;FIND START OF CHARS
890 ADD C,E ;C POINTS TO START
891 MOVE D,B ;COPY VECTOR RESULT
892 JUMPGE D,NULLST ;JUMP IF EMPTY
895 ADDI C,1 ;BUMP POINTER
897 NULLST: MOVSI C,TCHRS+.VECT. ;GET TYPE
898 MOVEM C,(D) ;CLOBBER IT IN
899 MOVE A,-1(P) ; # WORDS
902 MOVMM E,-1(P) ; SO IATM1 WORKS
905 ; SUBROUTINE TO READ FIVE CHARS FROM STRING.
906 ; TWO CALLS, ONE WITH A POINTING TO LIST ELEMENT,
907 ; THE OTHER WITH B POINTING TO PAIR. SKIPS IF WINNER, ELSE DOESNT
909 NXTDCL: GETYP B,(A) ;CHECK TYPE
910 CAIE B,TDEFER ;LOSE IF NOT DEFERRED
913 MOVE B,1(A) ;GET REAL BYTE POINTER
915 GETYP C,(B) ;CHECK IT IS CHSTR
917 JRST CPOPJC ;NO, QUIT
921 MOVEI E,0 ;INITIALIZE DESTINATION
922 HRRZ C,(B) ; GET CHAR COUNT
923 JUMPE C,GOTDCL ; NULL, FINISHED
924 MOVE B,1(B) ;GET BYTE POINTER
925 MOVE D,[440700,,E] ;BYTE POINT TO E
926 CHLOOP: ILDB 0,B ; GET A CHR
927 IDPB 0,D ;CLOBBER AWAY
928 SOJE C,GOTDCL ; JUMP IF DONE
929 TLNE D,760000 ; SKIP IF WORD FULL
930 JRST CHLOOP ; MORE THAN 5 CHARS
931 TRO E,1 ; TURN ON FLAG
933 GOTDCL: MOVE B,E ;RESULT TO B
934 AOS -4(P) ;SKIP RETURN
941 \f;ROUTINES TO DEFINE AND HANDLE LINKS
945 CAML AB,[-6,,0] ;NO MORE THAN 3 ARGS
946 CAML AB,[-2,,0] ;NO LESS THAN 2 ARGS
948 CAML AB,[-4,,0] ;ONLY TWO ARGS SUPPLIED ?
949 JRST GETOB ;YES, GET OBLIST FROM CURRENT PATH
955 MOVE B,IMQUOTE OBLIST
967 LINKIN: PUSHJ P,IINSRT
968 CAMN A,$TFALSE ;LINK NAME ALREADY USED ?
969 JRST ALRDY ;YES, LOSE
978 SUBM B,A ;FOUND A LINK ?
983 POPJ P, ;NO, FINISHED
985 PUSHJ P,IGVAL ;GET THE LINK'S DESTINATION
986 CAME A,$TUNBOUND ;WELL FORMED LINK ?
988 ERRUUO EQUOTE BAD-LINK
991 ; THIS SUBROUTINE IMPURIFIES A PURE ATOM TO ALLOW MODIFICATION OF SYSTEM SUBRS
999 JRST RTNATM ; NOT PURE, RETURN
1002 ; ROUTINE PASSED TO GCHACK
1010 ADD C,TYPVEC+1 ; COMPUTE SAT
1023 ; SUBROUTINE TO FIND A BYTE STRINGS DOPE WORD
1024 ; RECEIVES POINTER TO PAIR CONNTAINIGN CHSTR IN C, RETURNS DOPE WORD IN A
1026 BYTDOP: PUSH P,B ; SAVE SOME ACS
1029 MOVE B,1(C) ; GET BYTE POINTER
1030 LDB D,[360600,,B] ; POSITION TO D
1031 LDB E,[300600,,B] ; AND BYTE SIZE
1032 MOVEI A,(E) ; A COPY IN A
1033 IDIVI D,(E) ; D=> # OF BYTES IN WORD 1
1034 HRRZ E,(C) ; GET LENGTH
1035 SUBM E,D ; # OF BYTES IN OTHER WORDS
1036 JUMPL D,BYTDO1 ; NEAR DOPE WORD
1037 MOVEI B,36. ; COMPUTE BYTES PER WORD
1039 ADDI D,-1(A) ; NOW COMPUTE WORDS
1040 IDIVI D,(A) ; D/ # NO. OF WORDS PAST 1ST
1041 ADD D,1(C) ; D POINTS TO DOPE WORD
1048 BYTDO1: MOVEI A,2(B)
1051 ; 1) IMPURIFY ITS OBLIST LIST
1053 IMPURX: HRRZ B,2(C) ; PICKUP OBLIST IF IT EXISTS
1054 JUMPE B,IMPUR0 ; NOT ON ONE, IGNORE THIS CODE
1057 PUSH TP,$TOBLS ; SAVE BUCKET
1060 MOVE B,(E) ; GET NEXT ONE
1065 SKIPE GPURFL ; IF PURIFY SMASH THE OBLIST SLOT TO PROTECT
1068 CAIGE 0,HIBOT ; SKIP IF PURE
1069 JRST IMPUR3 ; FOUND IMPURE NESS, SKIP IT
1070 HLLZ C,(B) ; SET UP ICONS CALL
1072 IMPR1: PUSHJ P,ICONS ; CONS IT UP
1073 IMPR2: HRRZ E,(TP) ; RETRV PREV
1074 HRRM B,(E) ; AND CLOBBER
1076 CAMN D,-2(TP) ; HAVE GOTTEN TO OUR SLOT?
1079 MOVEM 0,-1(TP) ; FIX TYPE
1080 HRRZM B,(TP) ; STORE GOODIE
1082 JUMPN B,IMPUR4 ; LOOP
1083 IMPPR3: SUB TP,[2,,2] ; FLUSH TP CRUFT
1085 ; 1.5) IMPURIFY GLOBAL HASH BUCKET, A REAL PAIN
1087 IMPUR0: MOVE C,(TP) ; GET ATOM
1091 ADD C,[3,,3] ; POINT TO PNAME
1092 HLRE A,C ; GET LNTH IN WORDS OF PNAME
1094 ; PUSH P,[SETZ IMPUR2] ; FAKE OUT ILOOKC
1097 PUSH P,(C) ; PUSH UP THE PNAME
1099 PUSH P,A ; NOW THE COUNT
1101 JRST ILOOKC ; GO FIND BUCKET
1103 IMPUR2: JUMPE B,IMPUR1
1104 JUMPE 0,IMPUR1 ; YUP, DONE
1106 CAIG C,HIBOT ; SKIP IF PREV IS PURE
1110 PUSH P,GPURFL ; PRERTEND OUT OF PURIFY
1113 HRRZ C,(C) ; ARE WE ON PURIFY LIST
1114 CAIG C,HIBOT ; IF SO, WE ARE STILL PURIFY
1116 PUSHJ P,IMPURIF ; RECURSE
1118 MOVE B,(TP) ; AND RETURN ORIGINAL
1120 ; 2) GENERATE A DUPLICATE ATOM
1122 IMPUR1: SKIPE GPURFL ; SEE IF IN PURIFY
1124 HLRE A,(TP) ; GET LNTH OF ATOM
1127 PUSHJ P,IBLOCK ; GET NEW BLOCK FOR ATOM
1130 HRL B,-2(TP) ; SETUP BLT
1132 ADDI A,(B) ; END OF BLT
1133 BLT B,(A) ; CLOBBER NEW ATOM
1134 MOVSI B,.VECT. ; TURN ON BIT FOR GCHACK
1137 ; 3) NOW COPY GLOBAL VALUE
1139 IMPUR7: MOVE B,(TP) ; ATOM BACK
1141 SKIPE A,1(B) ; NON-ZER POINTER?
1142 CAIN 0,TUNBOU ; BOUND?
1143 JRST IMPUR5 ; NO, DONT COPY GLOB VAL
1150 SKIPN GPURFL ; HERE IS SOME CODE NEEDED FOR PURIFY
1154 PUSH P,AB ; GET AB BACK
1155 MOVE AB,ABSTO+1(PVP)
1156 IMPUR8: PUSHJ P,BSETG ; SETG IT
1158 JRST .+3 ; RESTORE SP AND AB FOR PURIFY
1161 SUB TP,[2,,2] ; KILL ATOM SLOTS ON TP
1162 POP TP,C ;POP OFF VALUE SLOTS
1164 MOVEM A,(B) ; FILL IN SLOTS ON GLOBAL STACK
1166 IMPUR5: SKIPE GPURFL ; FINISH OFF DIFFERENTLY FOR PURIFY
1169 PUSH TP,$TFIX ;SAVE OLD ATOM WITH FUNNY TYPE TO AVOID LOSSAGE
1171 PUSH TP,$TFIX ; OTHER KIND OF POINTER ALSO
1177 ; 4) UPDATE ALL POINTERS TO THIS ATOM
1179 MOVE A,[PUSHJ P,ATFIX] ; INS TO PASS TO GCHACK
1180 MOVEI PVP,1 ; SAY MIGHT BE NON-ATOMS
1188 IMPUR9: SUB TP,[2,,2]
1189 POPJ P, ; RESTORE AND GO