1 TITLE ATOMHACKER FOR MUDDLE
\r
6 .GLOBAL RLOOKU,CHMAK,OBLNT,ROOT,INTOBL,ERROBL,IFALSE
\r
7 .GLOBAL .BLOCK,IDVAL,NXTDCL,CHRWRD,CSTACK,CSTAK,ILOOKC,IGVAL,BYTDOP
\r
8 .GLOBAL ICONS,INCONS,IBLOCK,INSRTX,GCHACK,IMPURIFY
\r
9 .GLOBAL CINSER,CIRMV,CLOOKU,CATOM,CIPNAM,MPOPJ,CSETG
\r
11 .VECT.==40000 ; BIT FOR GCHACK
\r
13 ; FUNCTION TO GENERATE AN EMPTY OBLIST
\r
15 MFUNCTION MOBLIST,SUBR
\r
18 CAMGE AB,[-5,,0] ;CHECK NUMBER OF ARGS
\r
20 JUMPGE AB,MOBL2 ; NO ARGS
\r
24 PUSH TP,IMQUOTE OBLIST
\r
25 MCALL 2,GET ; CHECK IF IT EXISTS ALREADY
\r
28 MOBL2: MOVE A,OBLNT ;GET DEFAULT LENGTH
\r
29 CAML AB,[-3,,0] ;IS LENGTH SUPPLIED
\r
30 JRST MOBL1 ;NO, USE STANDARD LENGTH
\r
31 GETYP C,2(AB) ;GET ARG TYPE
\r
34 MOVE A,3(AB) ;GET LENGTH
\r
35 MOBL1: PUSH TP,$TFIX
\r
37 MCALL 1,UVECTOR ;GET A UNIFORM VECTOR
\r
38 MOVSI C,TLIST+.VECT. ;IT IS OF TYPE LIST
\r
39 HLRE D,B ;-LENGTH TO D
\r
40 SUBM B,D ;D POINTS TO DOPE WORD
\r
41 MOVEM C,(D) ;CLOBBER TYPE IN
\r
43 JUMPGE AB,FINIS ; IF NO ARGS, DONE
\r
52 PUSH TP,IMQUOTE OBLIST
\r
55 MCALL 3,PUT ; PUT THE NAME ON THE OBLIST
\r
59 PUSH TP,IMQUOTE OBLIST
\r
62 MCALL 3,PUT ; PUT THE OBLIST ON THE NAME
\r
68 MFUNCTION GROOT,SUBR,ROOT
\r
74 MFUNCTION GINTS,SUBR,INTERRUPTS
\r
77 MOVE B,INTOBL+1(TVP)
\r
80 MFUNCTION GERRS,SUBR,ERRORS
\r
83 MOVE B,ERROBL+1(TVP)
\r
87 COBLQ: SKIPN B,2(B) ; SKIP IF EXISTS
\r
100 MFUNCTION OBLQ,SUBR,[OBLIST?]
\r
106 MOVE B,1(AB) ; GET ATOM
\r
111 \f; FUNCTION TO FIND AN ATOM ON A GIVEN OBLIST WITH A GIVEN PNAME
\r
113 MFUNCTION LOOKUP,SUBR
\r
116 PUSHJ P,ILOOKU ;CALL INTERNAL ROUTINE
\r
137 ILOOKU: PUSHJ P,ARGCHK ;CHECK ARGS
\r
138 PUSHJ P,CSTACK ;PUT CHARACTERS ON THE STACK
\r
140 CALLIT: MOVE B,3(AB) ;GET OBLIST
\r
141 ILOOKC: PUSHJ P,ILOOK ;LOOK IT UP
\r
142 POP P,D ;RESTORE COUNT
\r
143 HRLI D,(D) ;TO BOTH SIDES
\r
147 ;THIS ROUTINE CHECKS ARG TYPES
\r
149 ARGCHK: GETYP A,(AB) ;GET TYPES
\r
151 CAIE A,TCHRS ;IS IT EITHER CHAR STRING
\r
153 CAIE C,TOBLS ;IS 2ND AN OBLIST
\r
154 JRST WRONGT ;TYPES ARE WRONG
\r
157 ;THIS SUBROUTINE PUTS CHARACTERS ON THE STACK (P WILL BE CHANGED)
\r
160 CSTACK: MOVEI B,(AB)
\r
161 CSTAK: POP P,D ;RETURN ADDRESS TO D
\r
162 CAIE A,TCHRS ;IMMEDIATE?
\r
163 JRST NOTIMM ;NO, HAIR
\r
164 MOVE A,1(B) ; GET CHAR
\r
165 LSH A,29. ; POSITION
\r
167 PUSH P,[1] ;WITH NUMBER
\r
168 JRST (D) ;GO CALL SEARCHER
\r
170 NOTIMM: MOVEI A,1 ; CLEAR CHAR COUNT
\r
171 HRRZ C,(B) ; GET COUNT OF CHARS
\r
172 JUMPE C,NULST ; FLUSH NULL STRING
\r
173 MOVE B,1(B) ;GET BYTE POINTER
\r
175 CLOOP1: PUSH P,[0] ; STORE CHARS ON STACK
\r
176 MOVSI E,(<440700,,(P)>) ; SETUP BYTE POINTER
\r
177 CLOOP: ILDB 0,B ;GET A CHARACTER
\r
179 SOJE C,CDONE ; ANY MORE?
\r
180 TLNE E,760000 ; WORD FULL
\r
181 JRST CLOOP ;NO CONTINUE
\r
182 AOJA A,CLOOP1 ;AND CONTINUE
\r
185 CDONE1: PUSH P,A ;AND NUMBER OF WORDS
\r
189 NULST: PUSH TP,$TATOM
\r
190 PUSH TP,EQUOTE NULL-STRING
\r
192 \f; THIS FUNCTION LOOKS FOR ATOMS. CALLED BY PUSHJ P,ILOOK
\r
193 ; B/ OBLIST POINTER
\r
194 ; -1(P)/ LENGTH IN WORDS OF CHARACTER BLOCK
\r
195 ; CHAR STRING IS ON THE STACK
\r
197 ILOOK: MOVN A,-1(P) ;GET -LENGTH
\r
198 HRLI A,-1(A) ;<-LENGTH-1>,,-LENGTH
\r
199 PUSH TP,$TFIX ;SAVE
\r
201 ADDI A,-1(P) ;HAVE AOBJN POINTER TO CHARS
\r
202 MOVEI D,0 ;HASH WORD
\r
204 AOBJN A,.-1 ;XOR THEM ALL TOGETHER
\r
205 HLRE A,B ;GET LENGTH OF OBLIST
\r
207 TLZ D,400000 ; MAKE SURE + HASH CODE
\r
208 IDIVI D,(A) ;DIVIDE
\r
209 HRLI E,(E) ;TO BOTH HALVES
\r
210 ADD B,E ;POINT TO BUCKET
\r
212 MOVEI 0,(B) ;IN CASE REMOVING 1ST
\r
213 SKIPN C,(B) ;BUCKET EMPTY?
\r
214 JRST NOTFND ;YES, GIVE UP
\r
215 LOOK2: SKIPN A,1(C) ;NIL CAR ON LIST?
\r
216 JRST NEXT ;YES TRY NEXT
\r
217 ADD A,[3,,3] ;POINT TO ATOMS PNAME
\r
218 MOVE D,(TP) ;GET PSEUDO AOBJN POINTER TO CHARS
\r
219 ADDI D,-1(P) ;NOW ITS A REAL AOBJN POINTER
\r
220 JUMPE D,CHECK0 ;ONE IS EMPTY
\r
221 LOOK1: MOVE E,(D) ;GET A WORD
\r
222 CAME E,(A) ;COMPARE
\r
223 JRST NEXT ;THIS ONE DOESN'T MATCH
\r
224 AOBJP D,CHECK ;ONE RAN OUT
\r
225 AOBJN A,LOOK1 ;JUMP IF STILL MIGHT WIN
\r
227 NEXT: MOVEI 0,(C) ;POINT TO PREVIOUS ELEMENT
\r
228 HRRZ C,(C) ;STEP THROUGH
\r
231 NOTFND: EXCH C,B ;RETURN BUCKET IN B
\r
233 CPOPJT: SUB TP,[2,,2] ;REMOVE RANDOM TP STUFF
\r
236 CHECK0: JUMPN A,NEXT ;JUMP IF NOT ALSO EMPTY
\r
238 CHECK: AOBJN A,NEXT ;JUMP IF NO MATCH
\r
240 MOVE E,B ; RETURN BUCKET
\r
241 MOVE B,1(C) ;GET ATOM
\r
245 \f; FUNCTION TO INSERT AN ATOM ON AN OBLIST
\r
247 MFUNCTION INSERT,SUBR
\r
271 ;INSERT WITH A GIVEN PNAME
\r
278 PUSH TP,$TFIX ;FLAG CALL
\r
281 PUSHJ P,CSTAK ;COPY ONTO STACK
\r
283 PUSHJ P,ILOOK ;LOOK IT UP (BUCKET RETURNS IN C)
\r
284 JUMPN B,ALRDY ;EXISTS, LOSE
\r
285 MOVE D,-2(TP) ; GET OBLIST BACK
\r
286 INSRT1: PUSH TP,$TOBLS ;SAVE BUCKET POINTER
\r
289 PUSH TP,D ; SAVE OBLIST
\r
290 INSRT3: PUSHJ P,IATOM ; MAKE AN ATOM
\r
291 PUSHJ P,LINKCK ; A LINK REALLY NEEDED ?
\r
293 HRRZ E,(E) ; GET BUCKET
\r
295 MOVE C,-2(TP) ;BUCKET AGAIN
\r
296 HRRM B,(C) ;INTO NEW BUCKET
\r
298 MOVE B,1(B) ;GET ATOM BACK
\r
299 MOVE D,(TP) ; GET OBLIST
\r
300 MOVEM D,2(B) ; AND CLOBBER
\r
301 MOVE C,-4(TP) ;GET FLAG
\r
302 SUB TP,[6,,6] ;POP STACK
\r
307 ;INSERT WITH GIVEN ATOM
\r
308 INSRT0: MOVE A,-2(TP) ;GOBBLE PNAME
\r
309 SKIPE 2(A) ; SKIP IF NOT ON AN OBLIST
\r
314 PUSH P,(A) ;FLUSH PNAME ONTO P STACK
\r
317 MOVE B,(TP) ; GET OBLIST FOR LOOKUP
\r
318 PUSHJ P,ILOOK ;ALREADY THERE?
\r
320 PUSH TP,$TOBLS ;SAVE NECESSARY STUFF AWAY FROM CONS
\r
321 PUSH TP,C ;WHICH WILL MAKE A LIST FROM THE ATOM
\r
325 MOVE C,(TP) ;RESTORE
\r
330 MOVE B,-4(TP) ; GET BACK ATOM
\r
331 MOVEM C,2(B) ; CLOBBER OBLIST IN
\r
339 LINKCK: HRRZ C,FSAV(TB) ;CALLER'S NAME
\r
341 SKIPA C,$TLINK ;LET US INSERT A LINK INSTEAD OF AN ATOM
\r
342 MOVSI C,TATOM ;GET REAL ATOM FOR CALL TO ICONS
\r
348 ALRDY: PUSH TP,$TATOM
\r
349 PUSH TP,EQUOTE ATOM-ALREADY-THERE
\r
352 ONOBL: PUSH TP,$TATOM
\r
353 PUSH TP,EQUOTE ON-AN-OBLIST-ALREADY
\r
356 ; INTERNAL INSERT CALL
\r
358 INSRTX: POP P,0 ; GET RET ADDR
\r
368 JRST INSRT3 ; INTO INSERT CODE
\r
370 INSRXT: PUSH P,-4(TP)
\r
375 ; FUNCTION TO REMOVE AN ATOM FROM AN OBLIST
\r
377 MFUNCTION REMOVE,SUBR
\r
385 CAML AB,[-3,,] ; SKIP IF OBLIST GIVEN
\r
404 IRMV1: GETYP 0,A ; CHECK 1ST ARG
\r
407 CAIE 0,TATOM ; ATOM, TREAT ACCORDINGLY
\r
410 SKIPN D,2(B) ; SKIP IF ON OBLIST AND GET SAME
\r
416 CAME C,D ; BETTER BE THE SAME
\r
419 GOTOBL: ADD B,[3,,3] ; POINT TO PNAME
\r
422 PUSH P,(B) ; PUSH PNAME
\r
425 MOVEM D,(TP) ; SAVE OBLIST
\r
441 HRRZ D,0 ;PREPARE TO SPLICE (0 POINTS PRIOR TO LOSING PAIR)
\r
442 HRRZ C,(C) ;GET NEXT OF LOSING PAIR
\r
444 CAIGE 0,HIBOT ; SKIP IF PURE
\r
451 RMV2: HRRM C,(D) ;AND SPLICE
\r
452 SETZM 2(B) ; CLOBBER OBLIST SLOT
\r
453 RMVDON: SUB TP,[4,,4]
\r
457 ;INTERNAL CALL FROM THE READER
\r
459 RLOOKU: PUSH TP,$TFIX ;PUSH A FLAG
\r
460 POP P,C ;POP OFF RET ADR
\r
461 PUSH TP,C ;AND USE AS A FLAG FOR INTERNAL
\r
462 MOVE C,(P) ; CHANGE CHAR COUNT TO WORD
\r
467 CAMN A,$TOBLS ;IS IT ONE OBLIST?
\r
469 CAME A,$TLIST ;IS IT A LIST
\r
473 PUSH TP,$TOBLS ; SLOT FOR REMEBERIG
\r
480 RLOOK2: GETYP A,(B) ;CHECK THIS IS AN OBLIST
\r
484 PUSHJ P,ILOOK ;LOOK IT UP
\r
485 JUMPN B,RLOOK3 ;WIN
\r
486 SKIPE -2(TP) ; SKIP IF DEFAULT NOT STORED
\r
488 HRRZ D,(TP) ; GET CURRENT
\r
489 MOVE D,1(D) ; OBLIST
\r
491 MOVEM C,-4(TP) ; FOR INSERT IF NEEDED
\r
493 HRRZ B,@(TP) ;CDR THE LIST
\r
496 SKIPN D,-2(TP) ; RESTORE FOR INSERT
\r
497 JRST BADDEF ; NO DEFAULT, USER LOST ON SPECIFICATION
\r
499 SUB TP,[6,,6] ; FLUSH CRAP
\r
502 DEFFLG==1 ;SPECIAL FLAG USED TO INDICATE THAT A DEFAULT HAS ALREADY BEEN SPECIFIED
\r
503 DEFALT: CAIN A,TATOM ;SPECIAL DEFAULT INDICATING ATOM ?
\r
504 CAME B,MQUOTE DEFAULT
\r
505 JRST BADDEF ;NO, LOSE
\r
507 XORB A,-6(TP) ;SET AND TEST FLAG
\r
508 TLNN A,DEFFLG ; HAVE WE BEEN HERE BEFORE ?
\r
509 JRST BADDEF ; YES, LOSE
\r
510 SETZM -2(TP) ;ZERO OUT PREVIOUS DEFAULT
\r
512 JRST RLOOK4 ;CONTINUE
\r
514 RLOOK1: PUSH TP,$TOBLS
\r
515 PUSH TP,B ; SAVE OBLIST
\r
516 PUSHJ P,ILOOK ;LOOK IT UP THERE
\r
517 MOVE D,(TP) ; GET OBLIST
\r
519 JUMPE B,INSRT1 ;GO INSET IT
\r
523 RLOOK3: SUB TP,[6,,6] ;POP OFF LOSSAGE
\r
524 PUSHJ P,ILINK ;IF THIS IS A LINK FOLLOW IT
\r
525 PUSH P,(TP) ;GET BACK RET ADR
\r
526 SUB TP,[2,,2] ;POP TP
\r
527 JRST IATM1 ;AND RETURN
\r
530 BADOBL: PUSH TP,$TATOM
\r
531 PUSH TP,EQUOTE BAD-OBLIST-OR-LIST-THEREOF
\r
534 BADDEF: PUSH TP,$TATOM
\r
535 PUSH TP,EQUOTE BAD-DEFAULT-OBLIST-SPECIFICATION
\r
538 ONOTH: PUSH TP,$TATOM
\r
539 PUSH TP,EQUOTE ATOM-ON-DIFFERENT-OBLIST
\r
541 \f;SUBROUTINE TO MAKE AN ATOM
\r
543 MFUNCTION ATOM,SUBR
\r
556 IATOMI: GETYP 0,A ;CHECK ARG TYPE
\r
559 JRST .+2 ;JUMP IF WINNERS
\r
566 PUSHJ P,CSTAK ;COPY ONTO STACK
\r
567 PUSHJ P,IATOM ;NOW MAKE THE ATOM
\r
570 ;INTERNAL ATOM MAKER
\r
572 IATOM: MOVE A,-1(P) ;GET WORDS IN PNAME
\r
573 ADDI A,3 ;FOR VALUE CELL
\r
574 PUSHJ P,IBLOCK ; GET BLOCK
\r
575 MOVSI C,<(GENERAL)>+SATOM+.VECT. ;FOR TYPE FIELD
\r
576 MOVE D,-1(P) ;RE-GOBBLE LENGTH
\r
577 ADDI D,3(B) ;POINT TO DOPE WORD
\r
579 SKIPG -1(P) ;EMPTY PNAME ?
\r
580 JRST IATM0 ;YES, NO CHARACTERS TO MOVE
\r
581 MOVE E,B ;COPY ATOM POINTER
\r
582 ADD E,[3,,3] ;POINT TO PNAME AREA
\r
584 SUB C,-1(P) ;POINT TO STRING ON STACK
\r
585 MOVE D,(C) ;GET SOME CHARS
\r
586 MOVEM D,(E) ;AND COPY THEM
\r
589 IATM0: MOVSI A,TATOM ;TYPE TO ATOM
\r
590 IATM1: POP P,D ;RETURN ADR
\r
596 \f;SUBROUTINE TO GET AN ATOM'S PNAME
\r
598 MFUNCTION PNAME,SUBR
\r
603 CAIE A,TATOM ;CHECK TYPE IS ATOM
\r
613 IPNAME: ADD A,[3,,3]
\r
616 PUSH P,(A) ;FLUSH PNAME ONTO P
\r
618 IMULI B,5 ; CHARS TO B
\r
619 MOVE 0,(P) ; LAST WORD
\r
621 SUBI A,1 ; FIND LAST 1
\r
622 ANDCM 0,A ; 0 HAS 1ST 1
\r
624 HRREI 0,-34.(A) ; FIND HOW MUCH TO ADD
\r
628 PUSHJ P,CHMAK ;MAKE A STRING
\r
631 \f; BLOCK STRUCTURE SUBROUTINES FOR MUDDLE
\r
633 MFUNCTION BLK,SUBR,BLOCK
\r
637 GETYP A,(AB) ;CHECK TYPE OF ARG
\r
638 CAIE A,TOBLS ;IS IT AN OBLIST
\r
639 CAIN A,TLIST ;OR A LIAT
\r
642 MOVSI A,TATOM ;LOOK UP OBLIST
\r
643 MOVE B,IMQUOTE OBLIST
\r
644 PUSHJ P,IDVAL ;GET VALUE
\r
647 PUSH TP,.BLOCK(PVP) ;HACK THE LIST
\r
648 PUSH TP,.BLOCK+1(PVP)
\r
649 MCALL 2,CONS ;CONS THE LIST
\r
650 MOVEM A,.BLOCK(PVP) ;STORE IT BACK
\r
651 MOVEM B,.BLOCK+1(PVP)
\r
653 PUSH TP,IMQUOTE OBLIST
\r
656 MCALL 2,SET ;SET OBLIST TO ARG
\r
659 MFUNCTION ENDBLOCK,SUBR
\r
663 SKIPN B,.BLOCK+1(PVP) ;IS THE LIST NIL?
\r
664 JRST BLKERR ;YES, LOSE
\r
665 HRRZ C,(B) ;CDR THE LIST
\r
666 HRRZM C,.BLOCK+1(PVP)
\r
667 PUSH TP,$TATOM ;NOW RESET OBLIST
\r
668 PUSH TP,IMQUOTE OBLIST
\r
669 HLLZ A,(B) ;PUSH THE TYPE OF THE CAR
\r
671 PUSH TP,1(B) ;AND VALUE OF CAR
\r
675 BLKERR: PUSH TP,$TATOM
\r
676 PUSH TP,EQUOTE UNMATCHED
\r
679 BADLST: PUSH TP,$TATOM
\r
680 PUSH TP,EQUOTE NIL-LIST-OF-OBLISTS
\r
682 \f;SUBROUTINE TO CREATE CHARACTER STRING GOODIE
\r
684 CHMAK: MOVE A,-1(P)
\r
688 MOVEI C,-1(P) ;FIND START OF CHARS
\r
689 HLRE E,B ; - LENGTH
\r
690 ADD C,E ;C POINTS TO START
\r
691 MOVE D,B ;COPY VECTOR RESULT
\r
692 JUMPGE D,NULLST ;JUMP IF EMPTY
\r
693 MOVE A,(C) ;GET ONE
\r
695 ADDI C,1 ;BUMP POINTER
\r
697 NULLST: MOVSI C,TCHRS+.VECT. ;GET TYPE
\r
698 MOVEM C,(D) ;CLOBBER IT IN
\r
699 MOVE A,-1(P) ; # WORDS
\r
702 MOVMM E,-1(P) ; SO IATM1 WORKS
\r
705 ; SUBROUTINE TO READ FIVE CHARS FROM STRING.
\r
706 ; TWO CALLS, ONE WITH A POINTING TO LIST ELEMENT,
\r
707 ; THE OTHER WITH B POINTING TO PAIR. SKIPS IF WINNER, ELSE DOESNT
\r
709 NXTDCL: GETYP B,(A) ;CHECK TYPE
\r
710 CAIE B,TDEFER ;LOSE IF NOT DEFERRED
\r
713 MOVE B,1(A) ;GET REAL BYTE POINTER
\r
715 GETYP C,(B) ;CHECK IT IS CHSTR
\r
717 JRST CPOPJC ;NO, QUIT
\r
721 MOVEI E,0 ;INITIALIZE DESTINATION
\r
722 HRRZ C,(B) ; GET CHAR COUNT
\r
723 JUMPE C,GOTDCL ; NULL, FINISHED
\r
724 MOVE B,1(B) ;GET BYTE POINTER
\r
725 MOVE D,[440700,,E] ;BYTE POINT TO E
\r
726 CHLOOP: ILDB 0,B ; GET A CHR
\r
727 IDPB 0,D ;CLOBBER AWAY
\r
728 SOJE C,GOTDCL ; JUMP IF DONE
\r
729 TLNE D,760000 ; SKIP IF WORD FULL
\r
730 JRST CHLOOP ; MORE THAN 5 CHARS
\r
731 TRO E,1 ; TURN ON FLAG
\r
733 GOTDCL: MOVE B,E ;RESULT TO B
\r
734 AOS -4(P) ;SKIP RETURN
\r
741 ; SUBROUTINE TO FIND A BYTE STRINGS DOPE WORD
\r
742 ; RECEIVES POINTER TO PAIR CONNTAINIGN CHSTR IN C, RETURNS DOPE WORD IN A
\r
744 BYTDOP: PUSH P,B ; SAVE SOME ACS
\r
747 MOVE B,1(C) ; GET BYTE POINTER
\r
748 LDB D,[360600,,B] ; POSITION TO D
\r
749 LDB E,[300600,,B] ; AND BYTE SIZE
\r
750 MOVEI A,(E) ; A COPY IN A
\r
751 IDIVI D,(E) ; D=> # OF BYTES IN WORD 1
\r
752 HRRZ E,(C) ; GET LENGTH
\r
753 SUBM E,D ; # OF BYTES IN OTHER WORDS
\r
754 JUMPL D,BYTDO1 ; NEAR DOPE WORD
\r
755 MOVEI B,36. ; COMPUTE BYTES PER WORD
\r
757 ADDI D,-1(A) ; NOW COMPUTE WORDS
\r
758 IDIVI D,(A) ; D/ # NO. OF WORDS PAST 1ST
\r
759 ADD D,1(C) ; D POINTS TO DOPE WORD
\r
766 BYTDO1: MOVEI A,1(B)
\r
770 \f;ROUTINES TO DEFINE AND HANDLE LINKS
\r
772 MFUNCTION LINK,SUBR
\r
774 CAML AB,[-6,,0] ;NO MORE THAN 3 ARGS
\r
775 CAML AB,[-2,,0] ;NO LESS THAN 2 ARGS
\r
777 CAML AB,[-4,,0] ;ONLY TWO ARGS SUPPLIED ?
\r
778 JRST GETOB ;YES, GET OBLIST FROM CURRENT PATH
\r
783 GETOB: MOVSI A,TATOM
\r
784 MOVE B,IMQUOTE OBLIST
\r
796 LINKIN: PUSHJ P,IINSRT
\r
797 CAMN A,$TFALSE ;LINK NAME ALREADY USED ?
\r
798 JRST ALRDY ;YES, LOSE
\r
806 ILINK: CAME A,$TLINK ;FOUND A LINK ?
\r
807 POPJ P, ;NO, FINISHED
\r
809 PUSHJ P,IGVAL ;GET THE LINK'S DESTINATION
\r
810 CAME A,$TUNBOUND ;WELL FORMED LINK ?
\r
813 PUSH TP,EQUOTE BAD-LINK
\r
817 ; THIS SUBROUTINE IMPURIFIES A PURE ATOM TO ALLOW MODIFICATION OF SYSTEM SUBRS
\r
825 JRST RTNATM ; NOT PURE, RETURN
\r
827 ; 1) IMPURIFY ITS OBLIST BUCKET
\r
829 SKIPN B,2(C) ; PICKUP OBLIST IF IT EXISTS
\r
830 JRST IMPUR1 ; NOT ON ONE, IGNORE THIS CODE
\r
832 ADDI B,(TVP) ; POINT TO SLOT
\r
833 MOVE B,(B) ; GET THE REAL THING
\r
834 ADD C,[3,,3] ; POINT TO PNAME
\r
835 HLRE A,C ; GET LNTH IN WORDS OF PNAME
\r
837 PUSH P,[IMPUR2] ; FAKE OUT ILOOKC
\r
838 PUSH P,(C) ; PUSH UP THE PNAME
\r
840 PUSH P,A ; NOW THE COUNT
\r
841 JRST ILOOKC ; GO FIND BUCKET
\r
843 IMPUR2: JUMPE B,IMPUR1 ; NOT THERE, GO
\r
844 PUSH TP,$TOBLS ; SAVE BUCKET
\r
847 MOVE B,(E) ; GET NEXT ONE
\r
848 IMPUR4: MOVEI 0,(B)
\r
849 CAIGE 0,HIBOT ; SKIP IF PURE
\r
850 JRST IMPUR3 ; FOUND IMPURE NESS, SKIP IT
\r
851 HLLZ C,(B) ; SET UP ICONS CALL
\r
854 PUSHJ P,ICONS ; CONS IT UP
\r
855 HRRZ E,(TP) ; RETRV PREV
\r
856 HRRM B,(E) ; AND CLOBBER
\r
857 IMPUR3: MOVSI 0,TLIST
\r
858 MOVEM 0,-1(TP) ; FIX TYPE
\r
859 HRRZM B,(TP) ; STORE GOODIE
\r
860 HRRZ B,(B) ; CDR IT
\r
861 JUMPN B,IMPUR4 ; LOOP
\r
862 SUB TP,[2,,2] ; FLUSH TP CRUFT
\r
864 ; 2) GENERATE A DUPLICATE ATOM
\r
866 IMPUR1: HLRE A,(TP) ; GET LNTH OF ATOM
\r
869 PUSHJ P,IBLOCK ; GET NEW BLOCK FOR ATOM
\r
872 HRL B,-2(TP) ; SETUP BLT
\r
874 ADDI A,(B) ; END OF BLT
\r
875 BLT B,(A) ; CLOBBER NEW ATOM
\r
876 MOVSI B,.VECT. ; TURN ON BIT FOR GCHACK
\r
879 ; 3) NOW COPY GLOBAL VALUE
\r
881 MOVE B,(TP) ; ATOM BACK
\r
883 SKIPE A,1(B) ; NON-ZER POINTER?
\r
884 CAIN 0,TUNBOU ; BOUND?
\r
885 JRST IMPUR5 ; NO, DONT COPY GLOB VAL
\r
893 IMPUR5: PUSH TP,$TFIX ;SAVE OLD ATOM WITH FUNNY TYPE TO AVOID LOSSAGE
\r
896 ; 4) UPDATE ALL POINTERS TO THIS ATOM
\r
898 MOVE A,[PUSHJ P,ATFIX] ; INS TO PASS TO GCHACK
\r
906 ; ROUTINE PASSED TO GCHACK
\r
908 ATFIX: CAIE C,TGATOM ; GLOBAL TYPE ATOM
\r
910 CAME D,(TP) ; SKIP IF WINNER
\r