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
682 DEFFLG==1 ;SPECIAL FLAG USED TO INDICATE THAT A DEFAULT HAS ALREADY BEEN
685 CAIN A,TATOM ;SPECIAL DEFAULT INDICATING ATOM ?
686 CAME 0,MQUOTE DEFAULT
687 JRST BADDEF ;NO, LOSE
689 XORB A,-11(TP) ;SET AND TEST FLAG
690 TRNN A,DEFFLG ; HAVE WE BEEN HERE BEFORE ?
691 JRST BADDEF ; YES, LOSE
692 SETZM -6(TP) ;ZERO OUT PREVIOUS DEFAULT
694 JRST RLOOK4 ;CONTINUE
698 RLOOK3: SUB TP,[6,,6] ;POP OFF LOSSAGE
699 PUSHJ P,ILINK ;IF THIS IS A LINK FOLLOW IT
700 PUSH P,(TP) ;GET BACK RET ADR
701 SUB TP,[2,,2] ;POP TP
702 JRST IATM1 ;AND RETURN
705 BADOBL: ERRUUO EQUOTE BAD-OBLIST-OR-LIST-THEREOF
707 BADDEF: ERRUUO EQUOTE BAD-DEFAULT-OBLIST-SPECIFICATION
709 ONOTH: ERRUUO EQUOTE ATOM-ON-DIFFERENT-OBLIST
710 \f;SUBROUTINE TO MAKE AN ATOM
725 IATOMI: GETYP 0,A ;CHECK ARG TYPE
728 JRST .+2 ;JUMP IF WINNERS
735 PUSHJ P,CSTAK ;COPY ONTO STACK
736 PUSHJ P,IATOM ;NOW MAKE THE ATOM
742 IATOM: MOVE A,-1(P) ;GET WORDS IN PNAME
743 ADDI A,3 ;FOR VALUE CELL
744 PUSHJ P,IBLOCK ; GET BLOCK
745 MOVSI C,<(GENERAL)>+SATOM ;FOR TYPE FIELD
746 MOVE D,-1(P) ;RE-GOBBLE LENGTH
747 ADDI D,3(B) ;POINT TO DOPE WORD
749 SKIPG -1(P) ;EMPTY PNAME ?
750 JRST IATM0 ;YES, NO CHARACTERS TO MOVE
751 MOVE E,B ;COPY ATOM POINTER
752 ADD E,[3,,3] ;POINT TO PNAME AREA
754 SUB C,-1(P) ;POINT TO STRING ON STACK
755 MOVE D,(C) ;GET SOME CHARS
756 MOVEM D,(E) ;AND COPY THEM
759 IATM0: MOVSI A,TATOM ;TYPE TO ATOM
760 IATM1: POP P,D ;RETURN ADR
766 \f;SUBROUTINE TO GET AN ATOM'S PNAME
773 CAIE A,TATOM ;CHECK TYPE IS ATOM
786 PUSH P,(A) ;FLUSH PNAME ONTO P
788 MOVE 0,(P) ; LAST WORD
791 PUSHJ P,CHMAK ;MAKE A STRING
794 PNMCNT: IMULI B,5 ; CHARS TO B
796 SUBI A,1 ; FIND LAST 1
797 ANDCM 0,A ; 0 HAS 1ST 1
799 HRREI 0,-34.(A) ; FIND HOW MUCH TO ADD
804 MFUNCTION SPNAME,SUBR
830 \f; BLOCK STRUCTURE SUBROUTINES FOR MUDDLE
832 IMFUNCTION BLK,SUBR,BLOCK
836 GETYP A,(AB) ;CHECK TYPE OF ARG
837 CAIE A,TOBLS ;IS IT AN OBLIST
838 CAIN A,TLIST ;OR A LIAT
841 MOVSI A,TATOM ;LOOK UP OBLIST
842 MOVE B,IMQUOTE OBLIST
843 PUSHJ P,IDVAL ;GET VALUE
847 PUSH TP,.BLOCK(PVP) ;HACK THE LIST
848 PUSH TP,.BLOCK+1(PVP)
849 MCALL 2,CONS ;CONS THE LIST
851 MOVEM A,.BLOCK(PVP) ;STORE IT BACK
852 MOVEM B,.BLOCK+1(PVP)
854 PUSH TP,IMQUOTE OBLIST
857 MCALL 2,SET ;SET OBLIST TO ARG
860 MFUNCTION ENDBLOCK,SUBR
865 SKIPN B,.BLOCK+1(PVP) ;IS THE LIST NIL?
866 JRST BLKERR ;YES, LOSE
867 HRRZ C,(B) ;CDR THE LIST
868 HRRZM C,.BLOCK+1(PVP)
869 PUSH TP,$TATOM ;NOW RESET OBLIST
870 PUSH TP,IMQUOTE OBLIST
871 HLLZ A,(B) ;PUSH THE TYPE OF THE CAR
873 PUSH TP,1(B) ;AND VALUE OF CAR
877 BLKERR: ERRUUO EQUOTE UNMATCHED
879 BADLST: ERRUUO EQUOTE NIL-LIST-OF-OBLISTS
880 \f;SUBROUTINE TO CREATE CHARACTER STRING GOODIE
886 MOVEI C,-1(P) ;FIND START OF CHARS
888 ADD C,E ;C POINTS TO START
889 MOVE D,B ;COPY VECTOR RESULT
890 JUMPGE D,NULLST ;JUMP IF EMPTY
893 ADDI C,1 ;BUMP POINTER
895 NULLST: MOVSI C,TCHRS+.VECT. ;GET TYPE
896 MOVEM C,(D) ;CLOBBER IT IN
897 MOVE A,-1(P) ; # WORDS
900 MOVMM E,-1(P) ; SO IATM1 WORKS
903 ; SUBROUTINE TO READ FIVE CHARS FROM STRING.
904 ; TWO CALLS, ONE WITH A POINTING TO LIST ELEMENT,
905 ; THE OTHER WITH B POINTING TO PAIR. SKIPS IF WINNER, ELSE DOESNT
907 NXTDCL: GETYP B,(A) ;CHECK TYPE
908 CAIE B,TDEFER ;LOSE IF NOT DEFERRED
911 MOVE B,1(A) ;GET REAL BYTE POINTER
913 GETYP C,(B) ;CHECK IT IS CHSTR
915 JRST CPOPJC ;NO, QUIT
919 MOVEI E,0 ;INITIALIZE DESTINATION
920 HRRZ C,(B) ; GET CHAR COUNT
921 JUMPE C,GOTDCL ; NULL, FINISHED
922 MOVE B,1(B) ;GET BYTE POINTER
923 MOVE D,[440700,,E] ;BYTE POINT TO E
924 CHLOOP: ILDB 0,B ; GET A CHR
925 IDPB 0,D ;CLOBBER AWAY
926 SOJE C,GOTDCL ; JUMP IF DONE
927 TLNE D,760000 ; SKIP IF WORD FULL
928 JRST CHLOOP ; MORE THAN 5 CHARS
929 TRO E,1 ; TURN ON FLAG
931 GOTDCL: MOVE B,E ;RESULT TO B
932 AOS -4(P) ;SKIP RETURN
939 \f;ROUTINES TO DEFINE AND HANDLE LINKS
943 CAML AB,[-6,,0] ;NO MORE THAN 3 ARGS
944 CAML AB,[-2,,0] ;NO LESS THAN 2 ARGS
946 CAML AB,[-4,,0] ;ONLY TWO ARGS SUPPLIED ?
947 JRST GETOB ;YES, GET OBLIST FROM CURRENT PATH
953 MOVE B,IMQUOTE OBLIST
965 LINKIN: PUSHJ P,IINSRT
966 CAMN A,$TFALSE ;LINK NAME ALREADY USED ?
967 JRST ALRDY ;YES, LOSE
976 SUBM B,A ;FOUND A LINK ?
981 POPJ P, ;NO, FINISHED
983 PUSHJ P,IGVAL ;GET THE LINK'S DESTINATION
984 CAME A,$TUNBOUND ;WELL FORMED LINK ?
986 ERRUUO EQUOTE BAD-LINK
989 ; THIS SUBROUTINE IMPURIFIES A PURE ATOM TO ALLOW MODIFICATION OF SYSTEM SUBRS
997 JRST RTNATM ; NOT PURE, RETURN
1000 ; ROUTINE PASSED TO GCHACK
1008 ADD C,TYPVEC+1 ; COMPUTE SAT
1021 ; SUBROUTINE TO FIND A BYTE STRINGS DOPE WORD
1022 ; RECEIVES POINTER TO PAIR CONNTAINIGN CHSTR IN C, RETURNS DOPE WORD IN A
1024 BYTDOP: PUSH P,B ; SAVE SOME ACS
1027 MOVE B,1(C) ; GET BYTE POINTER
1028 LDB D,[360600,,B] ; POSITION TO D
1029 LDB E,[300600,,B] ; AND BYTE SIZE
1030 MOVEI A,(E) ; A COPY IN A
1031 IDIVI D,(E) ; D=> # OF BYTES IN WORD 1
1032 HRRZ E,(C) ; GET LENGTH
1033 SUBM E,D ; # OF BYTES IN OTHER WORDS
1034 JUMPL D,BYTDO1 ; NEAR DOPE WORD
1035 MOVEI B,36. ; COMPUTE BYTES PER WORD
1037 ADDI D,-1(A) ; NOW COMPUTE WORDS
1038 IDIVI D,(A) ; D/ # NO. OF WORDS PAST 1ST
1039 ADD D,1(C) ; D POINTS TO DOPE WORD
1046 BYTDO1: MOVEI A,2(B)
1049 ; 1) IMPURIFY ITS OBLIST LIST
1051 IMPURX: HRRZ B,2(C) ; PICKUP OBLIST IF IT EXISTS
1052 JUMPE B,IMPUR0 ; NOT ON ONE, IGNORE THIS CODE
1055 PUSH TP,$TOBLS ; SAVE BUCKET
1058 MOVE B,(E) ; GET NEXT ONE
1063 SKIPE GPURFL ; IF PURIFY SMASH THE OBLIST SLOT TO PROTECT
1066 CAIGE 0,HIBOT ; SKIP IF PURE
1067 JRST IMPUR3 ; FOUND IMPURE NESS, SKIP IT
1068 HLLZ C,(B) ; SET UP ICONS CALL
1070 IMPR1: PUSHJ P,ICONS ; CONS IT UP
1071 IMPR2: HRRZ E,(TP) ; RETRV PREV
1072 HRRM B,(E) ; AND CLOBBER
1074 CAMN D,-2(TP) ; HAVE GOTTEN TO OUR SLOT?
1077 MOVEM 0,-1(TP) ; FIX TYPE
1078 HRRZM B,(TP) ; STORE GOODIE
1080 JUMPN B,IMPUR4 ; LOOP
1081 IMPPR3: SUB TP,[2,,2] ; FLUSH TP CRUFT
1083 ; 1.5) IMPURIFY GLOBAL HASH BUCKET, A REAL PAIN
1085 IMPUR0: MOVE C,(TP) ; GET ATOM
1089 ADD C,[3,,3] ; POINT TO PNAME
1090 HLRE A,C ; GET LNTH IN WORDS OF PNAME
1092 PUSH P,[IMPUR2] ; FAKE OUT ILOOKC
1093 PUSH P,(C) ; PUSH UP THE PNAME
1095 PUSH P,A ; NOW THE COUNT
1097 JRST ILOOKC ; GO FIND BUCKET
1099 IMPUR2: JUMPE B,IMPUR1
1100 JUMPE 0,IMPUR1 ; YUP, DONE
1102 CAIG C,HIBOT ; SKIP IF PREV IS PURE
1106 PUSH P,GPURFL ; PRERTEND OUT OF PURIFY
1108 PUSHJ P,IMPURIF ; RECURSE
1110 MOVE B,(TP) ; AND RETURN ORIGINAL
1112 ; 2) GENERATE A DUPLICATE ATOM
1114 IMPUR1: SKIPE GPURFL ; SEE IF IN PURIFY
1116 HLRE A,(TP) ; GET LNTH OF ATOM
1119 PUSHJ P,IBLOCK ; GET NEW BLOCK FOR ATOM
1122 HRL B,-2(TP) ; SETUP BLT
1124 ADDI A,(B) ; END OF BLT
1125 BLT B,(A) ; CLOBBER NEW ATOM
1126 MOVSI B,.VECT. ; TURN ON BIT FOR GCHACK
1129 ; 3) NOW COPY GLOBAL VALUE
1131 IMPUR7: MOVE B,(TP) ; ATOM BACK
1133 SKIPE A,1(B) ; NON-ZER POINTER?
1134 CAIN 0,TUNBOU ; BOUND?
1135 JRST IMPUR5 ; NO, DONT COPY GLOB VAL
1142 SKIPN GPURFL ; HERE IS SOME CODE NEEDED FOR PURIFY
1146 PUSH P,AB ; GET AB BACK
1147 MOVE AB,ABSTO+1(PVP)
1148 IMPUR8: PUSHJ P,BSETG ; SETG IT
1150 JRST .+3 ; RESTORE SP AND AB FOR PURIFY
1153 SUB TP,[2,,2] ; KILL ATOM SLOTS ON TP
1154 POP TP,C ;POP OFF VALUE SLOTS
1156 MOVEM A,(B) ; FILL IN SLOTS ON GLOBAL STACK
1158 IMPUR5: SKIPE GPURFL ; FINISH OFF DIFFERENTLY FOR PURIFY
1161 PUSH TP,$TFIX ;SAVE OLD ATOM WITH FUNNY TYPE TO AVOID LOSSAGE
1163 PUSH TP,$TFIX ; OTHER KIND OF POINTER ALSO
1169 ; 4) UPDATE ALL POINTERS TO THIS ATOM
1171 MOVE A,[PUSHJ P,ATFIX] ; INS TO PASS TO GCHACK
1172 MOVEI PVP,1 ; SAY MIGHT BE NON-ATOMS
1180 IMPUR9: SUB TP,[2,,2]
1181 POPJ P, ; RESTORE AND GO