--- /dev/null
+
+TITLE ATOMHACKER FOR MUDDLE
+
+RELOCATABLE
+
+.INSRT MUDDLE >
+.GLOBAL RLOOKU,CHMAK,OBLNT,ROOT,INTOBL,ERROBL,IFALSE,PVSTOR,SPSTOR
+.GLOBAL .BLOCK,IDVAL,NXTDCL,CHRWRD,CSTACK,CSTAK,ILOOKC,IGVAL,BYTDOP,HASHTB
+.GLOBAL ICONS,INCONS,IBLOCK,INSRTX,GCHACK,IMPURIFY,BSETG,TYPVEC,IGET,IPUT
+.GLOBAL CINSER,CIRMV,CLOOKU,CATOM,CIPNAM,MPOPJ,CSETG,CSPNAM,GPURFL,IMPURX
+
+LPVP==SP
+TYPNT==AB
+LNKBIT==200000
+
+; FUNCTION TO GENERATE AN EMPTY OBLIST
+
+MFUNCTION MOBLIST,SUBR
+
+ ENTRY
+ CAMGE AB,[-5,,0] ;CHECK NUMBER OF ARGS
+ JRST TMA
+ JUMPGE AB,MOBL2 ; NO ARGS
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ MOVSI C,TATOM
+ MOVE D,IMQUOTE OBLIST
+ PUSHJ P,IGET ; CHECK IF IT EXISTS ALREADY
+ CAMN A,$TOBLS
+ JRST FINIS
+MOBL2:
+ MOVEI A,1
+ PUSHJ P,IBLOCK ;GET A UNIFORM VECTOR
+ MOVSI C,TLIST+.VECT. ;IT IS OF TYPE LIST
+ HLRE D,B ;-LENGTH TO D
+ SUBM B,D ;D POINTS TO DOPE WORD
+ MOVEM C,(D) ;CLOBBER TYPE IN
+ MOVSI A,TOBLS
+ JUMPGE AB,FINIS ; IF NO ARGS, DONE
+ GETYP A,(AB)
+ CAIE A,TATOM
+ JRST WTYP1
+ MOVSI A,TOBLS
+ PUSH TP,$TOBLS
+ PUSH TP,B
+ MOVSI C,TATOM
+ MOVE D,IMQUOTE OBLIST
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+ PUSHJ P,IPUT ; PUT THE NAME ON THE OBLIST
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ MOVSI C,TATOM
+ MOVE D,IMQUOTE OBLIST
+ PUSH TP,(TB)
+ PUSH TP,1(TB)
+ PUSHJ P,IPUT ; PUT THE OBLIST ON THE NAME
+
+ POP TP,B
+ POP TP,A
+ JRST FINIS
+
+MFUNCTION GROOT,SUBR,ROOT
+ ENTRY 0
+ MOVE A,ROOT
+ MOVE B,ROOT+1
+ JRST FINIS
+
+MFUNCTION GINTS,SUBR,INTERRUPTS
+ ENTRY 0
+ MOVE A,INTOBL
+ MOVE B,INTOBL+1
+ JRST FINIS
+
+MFUNCTION GERRS,SUBR,ERRORS
+ ENTRY 0
+ MOVE A,ERROBL
+ MOVE B,ERROBL+1
+ JRST FINIS
+
+
+COBLQ: SKIPN B,2(B) ; SKIP IF EXISTS
+ JRST IFLS
+ MOVSI A,TOBLS
+
+ ANDI B,-1
+ CAMG B,VECBOT ; TVP IS IN FROZEN SPACE, NEVER OBLISTS
+ MOVE B,(B)
+ HRLI B,-1
+
+CPOPJ1: AOS (P)
+ POPJ P,
+
+IFLS: MOVEI B,0
+ MOVSI A,TFALSE
+ POPJ P,
+
+MFUNCTION OBLQ,SUBR,[OBLIST?]
+
+ ENTRY 1
+ GETYP A,(AB)
+ CAIE A,TATOM
+ JRST WTYP1
+ MOVE B,1(AB) ; GET ATOM
+ PUSHJ P,COBLQ
+ JFCL
+ JRST FINIS
+
+\f; FUNCTION TO FIND AN ATOM ON A GIVEN OBLIST WITH A GIVEN PNAME
+
+MFUNCTION LOOKUP,SUBR
+
+ ENTRY 2
+ PUSHJ P,ILOOKU ;CALL INTERNAL ROUTINE
+ JRST FINIS
+
+CLOOKU: SUBM M,(P)
+ PUSH TP,A
+ PUSH TP,B
+ MOVEI B,-1(TP)
+ PUSH TP,$TOBLS
+ PUSH TP,C
+ GETYP A,A
+ PUSHJ P,CSTAK
+ MOVE B,(TP)
+ MOVSI A,TOBLS ; THIS IS AN OBLIST
+ PUSHJ P,ILOOK
+ POP P,D
+ HRLI D,(D)
+ SUB P,D
+ SKIPE B
+ SOS (P)
+ SUB TP,[4,,4]
+ JRST MPOPJ
+
+ILOOKU: PUSHJ P,ARGCHK ;CHECK ARGS
+ PUSHJ P,CSTACK ;PUT CHARACTERS ON THE STACK
+
+CALLIT: MOVE B,3(AB) ;GET OBLIST
+ MOVSI A,TOBLS
+ILOOKC: PUSHJ P,ILOOK ;LOOK IT UP
+ POP P,D ;RESTORE COUNT
+ HRLI D,(D) ;TO BOTH SIDES
+ SUB P,D
+ POPJ P,
+
+;THIS ROUTINE CHECKS ARG TYPES
+
+ARGCHK: GETYP A,(AB) ;GET TYPES
+ GETYP C,2(AB)
+ CAIE A,TCHRS ;IS IT EITHER CHAR STRING
+ CAIN A,TCHSTR
+ CAIE C,TOBLS ;IS 2ND AN OBLIST
+ JRST WRONGT ;TYPES ARE WRONG
+ POPJ P,
+
+;THIS SUBROUTINE PUTS CHARACTERS ON THE STACK (P WILL BE CHANGED)
+
+
+CSTACK: MOVEI B,(AB)
+CSTAK: POP P,D ;RETURN ADDRESS TO D
+ CAIE A,TCHRS ;IMMEDIATE?
+ JRST NOTIMM ;NO, HAIR
+ MOVE A,1(B) ; GET CHAR
+ LSH A,29. ; POSITION
+ PUSH P,A ;ONTO P
+ PUSH P,[1] ;WITH NUMBER
+ JRST (D) ;GO CALL SEARCHER
+
+NOTIMM: MOVEI A,1 ; CLEAR CHAR COUNT
+ MOVE C,(B) ; GET COUNT OF CHARS
+ TRNN C,-1
+ JRST NULST ; FLUSH NULL STRING
+ MOVE PVP,PVSTOR+1
+ MOVEM C,BSTO(PVP)
+ ANDI C,-1
+ MOVE B,1(B) ;GET BYTE POINTER
+
+CLOOP1: PUSH P,[0] ; STORE CHARS ON STACK
+ MOVSI E,(<440700,,(P)>) ; SETUP BYTE POINTER
+CLOOP: SKIPL INTFLG ; SO CAN WIN WITH INTERRUPTS
+ JRST CLOOP2
+ MOVE PVP,PVSTOR+1
+ HRRM C,BSTO(PVP) ;SAVE STRING LENGTH
+ JSR LCKINT
+CLOOP2: ILDB 0,B ;GET A CHARACTER
+ IDPB 0,E ;STORE IT
+ SOJE C,CDONE ; ANY MORE?
+ TLNE E,760000 ; WORD FULL
+ JRST CLOOP ;NO CONTINUE
+ AOJA A,CLOOP1 ;AND CONTINUE
+
+CDONE:
+CDONE1: MOVE PVP,PVSTOR+1
+ SETZM BSTO(PVP)
+ PUSH P,A ;AND NUMBER OF WORDS
+ JRST (D) ;RETURN
+
+
+NULST: ERRUUO EQUOTE NULL-STRING
+\f; THIS FUNCTION LOOKS FOR ATOMS. CALLED BY PUSHJ P,ILOOK
+; A,B/ OBLIST POINTER (CAN BE LIST OF SAME)
+; -1(P)/ LENGTH IN WORDS OF CHARACTER BLOCK
+; CHAR STRING IS ON THE STACK
+; IF ATOM EXISTS RETURNS:
+; B/ THE ATOM
+; C/ THE BUCKET
+; 0/ THE PREVIOUS BUCKET
+;
+; IF NOT
+; B/ 0
+; 0/ PREV IF ONE WITH SAME PNAME, ELSE 0
+; C/ BUCKET
+
+ILOOK: PUSH TP,A
+ PUSH TP,B
+
+ MOVN A,-1(P) ;GET -LENGTH
+ HRLI A,-1(A) ;<-LENGTH-1>,,-LENGTH
+ PUSH TP,$TFIX ;SAVE
+ PUSH TP,A
+ ADDI A,-1(P) ;HAVE AOBJN POINTER TO CHARS
+ MOVE 0,[202622077324] ;HASH WORD
+ ROT 0,1
+ TSC 0,(A)
+ AOBJN A,.-2 ;XOR THEM ALL TOGETHER
+ HLRE A,HASHTB+1
+ MOVNS A
+ MOVMS 0 ; MAKE SURE + HASH CODE
+ IDIVI 0,(A) ;DIVIDE
+ HRLI A,(A) ;TO BOTH HALVES
+ ADD A,HASHTB+1
+
+ MOVE C,A
+ HRRZ A,(A) ; POINT TO FIRST ATOM
+ SETZB E,0 ; INDICATE NO ATOM
+
+ JUMPE A,NOTFND
+LOOK2: HLRZ E,1(A) ; PREPARE TO BUILD AOBJN
+ ANDI E,377777 ; SIGN MIGHT BE ON IF IN PURIFY ETC.
+ SUBI E,2
+ HRLS E
+ SUBB A,E
+
+ ADD A,[3,,3] ;POINT TO ATOMS PNAME
+ MOVE D,(TP) ;GET PSEUDO AOBJN POINTER TO CHARS
+ ADDI D,-1(P) ;NOW ITS A REAL AOBJN POINTER
+ JUMPE D,CHECK0 ;ONE IS EMPTY
+LOOK1:
+ MOVE SP,(D)
+ CAME SP,(A)
+
+ JRST NEXT1 ;THIS ONE DOESN'T MATCH
+ AOBJP D,CHECK ;ONE RAN OUT
+ AOBJN A,LOOK1 ;JUMP IF STILL MIGHT WIN
+
+NEXT1: HRRZ A,-1(TP) ; SEE IF WE'VE ALREADY SEEN THIS NAME
+ GETYP D,-3(TP) ; SEE IF LIST OF OBLISTS
+ CAIN D,TLIST
+ JUMPN A,CHECK3 ; DON'T LOOK FURTHER
+ JUMPN A,NOTFND
+NEXT:
+ MOVE 0,E
+ HLRZ A,2(E) ; NEXT ATOM
+ JUMPN A,LOOK2
+ HRRZ A,-1(TP)
+ JUMPN A,NEXT1
+
+ SETZB E,0
+
+NOTFND:
+ MOVEI B,0
+ MOVSI A,TFALSE
+CPOPJT:
+
+ SUB TP,[4,,4]
+ POPJ P,
+
+CHECK0: JUMPN A,NEXT1 ;JUMP IF NOT ALSO EMPTY
+ SKIPA
+CHECK: AOBJN A,NEXT1 ;JUMP IF NO MATCH
+
+CHECK5: HRRZ A,-1(TP) ; SEE IF FIRST SHOT AT THIS GUY?
+ SKIPN A
+ MOVE B,0 ; REMEMBER ATOM FOR FALL BACK
+ HLLOS -1(TP) ; INDICATE NAME MATCH HAS OCCURRED
+ HRRZ A,2(E) ; COMPUTE OBLIST POINTER
+ CAMGE A,VECBOT
+ MOVE A,(A)
+ HRROS A
+ GETYP D,-3(TP) ; SEE IF LIST OF OBLISTS OR
+ CAIE D,TOBLS
+ JRST CHECK1
+ CAME A,-2(TP) ; DO OBLISTS MATCH?
+ JRST NEXT
+
+CHECK2: MOVE B,E ; RETURN ATOM
+ MOVSI A,TATOM
+ JRST CPOPJT
+
+CHECK1: MOVE D,-2(TP) ; ANY LEFT?
+ CAMN A,1(D) ; MATCH
+ JRST CHECK2
+ JRST NEXT
+
+CHECK3: MOVE D,-2(TP)
+ HRRZ D,(D)
+ MOVEM D,-2(TP)
+ JUMPE D,NOTFND
+ JUMPE B,CHECK6
+ HLRZ E,2(B)
+CHECK7: HLRZ A,1(E)
+ ANDI A,377777 ; SIGN MIGHT BE ON IF IN PURIFY ETC.
+ SUBI A,2
+ HRLS A
+ SUBB E,A
+ JRST CHECK5
+
+CHECK6: HRRZ E,(C)
+ JRST CHECK7
+
+\f; FUNCTION TO INSERT AN ATOM ON AN OBLIST
+
+MFUNCTION INSERT,SUBR
+
+ ENTRY 2
+ GETYP A,2(AB)
+ CAIE A,TOBLS
+ JRST WTYP2
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ MOVE C,3(AB)
+ PUSHJ P,IINSRT
+ JRST FINIS
+
+CINSER: SUBM M,(P)
+ PUSHJ P,IINSRT
+ JRST MPOPJ
+
+IINSRT: PUSH TP,A
+ PUSH TP,B
+ PUSH TP,$TOBLS
+ PUSH TP,C
+ GETYP A,A
+ CAIN A,TATOM
+ JRST INSRT0
+
+;INSERT WITH A GIVEN PNAME
+
+ CAIE A,TCHRS
+ CAIN A,TCHSTR
+ JRST .+2
+ JRST WTYP1
+
+ PUSH TP,$TFIX ;FLAG CALL
+ PUSH TP,[0]
+ MOVEI B,-5(TP)
+ PUSHJ P,CSTAK ;COPY ONTO STACK
+ MOVE B,-2(TP)
+ MOVSI A,TOBLS
+ PUSHJ P,ILOOK ;LOOK IT UP (BUCKET RETURNS IN C)
+ SETZM -4(TP)
+ SETZM -5(TP) ; KILL STRING POINTER TO KEEP FROM CONFUSING GC
+ JUMPN B,ALRDY ;EXISTS, LOSE
+ MOVE D,-2(TP) ; GET OBLIST BACK
+INSRT1: PUSH TP,$TATOM
+ PUSH TP,0 ; PREV ATOM
+ PUSH TP,$TUVEC ;SAVE BUCKET POINTER
+ PUSH TP,C
+ PUSH TP,$TOBLS
+ PUSH TP,D ; SAVE OBLIST
+INSRT3: PUSHJ P,IATOM ; MAKE AN ATOM
+ HLRE A,B ; FIND DOPE WORD
+ SUBM B,A
+ ANDI A,-1
+ SKIPN E,-4(TP) ; AFTER AN ATOM?
+ JRST INSRT7 ; NO, FIRST IN BUCKET
+ MOVEI 0,(E) ; CHECK IF PURE
+ CAIG 0,HIBOT
+ JRST INSRNP
+ PUSH TP,$TATOM ; SAVE NEW ATOM
+ PUSH TP,B
+ MOVE B,E
+ PUSHJ P,IMPURIF
+ MOVE B,(TP)
+ MOVE E,-6(TP)
+ SUB TP,[2,,2]
+ HLRE A,B ; FIND DOPE WORD
+ SUBM B,A
+ ANDI A,-1
+
+INSRNP: HLRZ 0,2(E) ; NEXT
+ HRLM A,2(E) ; SPLICE
+ HRLM 0,2(B)
+ JRST INSRT8
+
+INSRT7: MOVE E,-2(TP)
+ EXCH A,(E)
+ HRLM A,2(B) ; IN CASE OLD ONE
+
+INSRT8: MOVE E,(TP) ; GET OBLIST
+ HRRM E,2(B) ; STORE OBLIST
+ MOVE E,(E) ; POINT TO LIST OF ATOMS
+ PUSHJ P,LINKCK
+ PUSHJ P,ICONS
+ MOVE E,(TP)
+ HRRM B,(E) ;INTO NEW BUCKET
+ MOVSI A,TATOM
+ MOVE B,1(B) ;GET ATOM BACK
+ MOVE C,-6(TP) ;GET FLAG
+ SUB TP,[8,,8] ;POP STACK
+ JUMPN C,(C)
+ SUB TP,[4,,4]
+ POPJ P,
+
+;INSERT WITH GIVEN ATOM
+INSRT0: MOVE A,-2(TP) ;GOBBLE PNAME
+ SKIPE 2(A) ; SKIP IF NOT ON AN OBLIST
+ JRST ONOBL
+ ADD A,[3,,3]
+ HLRE C,A
+ MOVNS C
+ PUSH P,(A) ;FLUSH PNAME ONTO P STACK
+ AOBJN A,.-1
+ PUSH P,C
+ MOVE B,(TP) ; GET OBLIST FOR LOOKUP
+ MOVSI A,TOBLS
+ PUSHJ P,ILOOK ;ALREADY THERE?
+ JUMPN B,ALRDY
+ MOVE D,-2(TP)
+
+ HLRE A,-2(TP) ; FIND DOPE WORD
+ SUBM D,A ; TO A
+ JUMPE 0,INSRT9 ; NO CURRENT ATOM
+ MOVE E,0
+ MOVEI 0,(E)
+ CAIGE 0,HIBOT ; PURE?
+ JRST INSRPN
+ PUSH TP,$TATOM
+ PUSH TP,E
+ PUSH TP,$TATOM
+ PUSH TP,D
+ MOVE B,E
+ PUSHJ P,IMPURIF
+ MOVE D,(TP)
+ MOVE E,-2(TP)
+ SUB TP,[4,,4]
+ HLRE A,D
+ SUBM D,A
+
+
+INSRPN: HLRZ 0,2(E) ; POINT TO NEXT
+ HRLM A,2(E) ; CLOBBER NEW GUY IN
+ HRLM 0,2(D) ; FINISH SLPICE
+ JRST INSRT6
+
+INSRT9: ANDI A,-1
+ EXCH A,(C) ; INTO BUCKET
+ HRLM A,2(D)
+
+INSRT6: HRRZ E,(TP)
+ HRRZ E,(E)
+ MOVE B,D
+ PUSHJ P,LINKCK
+ PUSHJ P,ICONS
+ MOVE C,(TP) ;RESTORE OBLIST
+ HRRZM B,(C)
+ MOVE B,-2(TP) ; GET BACK ATOM
+ HRRM C,2(B) ; CLOBBER OBLIST IN
+ MOVSI A,TATOM
+ SUB TP,[4,,4]
+ POP P,C
+ HRLI C,(C)
+ SUB P,C
+ POPJ P,
+
+LINKCK: HRRZ C,FSAV(TB) ;CALLER'S NAME
+ MOVE D,B
+ CAIE C,LINK
+ SKIPA C,$TATOM ;LET US INSERT A LINK INSTEAD OF AN ATOM
+ SKIPA C,$TLINK ;GET REAL ATOM FOR CALL TO ICONS
+ POPJ P,
+ HLRE A,D
+ SUBM D,A
+ MOVEI B,LNKBIT
+ IORM B,(A)
+ POPJ P,
+
+
+ALRDY: ERRUUO EQUOTE ATOM-ALREADY-THERE
+
+ONOBL: ERRUUO EQUOTE ON-AN-OBLIST-ALREADY
+
+; INTERNAL INSERT CALL
+
+INSRTX: POP P,0 ; GET RET ADDR
+ PUSH TP,$TFIX
+ PUSH TP,0
+ PUSH TP,$TATOM
+ PUSH TP,[0]
+ PUSH TP,$TUVEC
+ PUSH TP,[0]
+ PUSH TP,$TOBLS
+ PUSH TP,B
+ MOVSI A,TOBLS
+ PUSHJ P,ILOOK
+ JUMPN B,INSRXT
+ MOVEM 0,-4(TP)
+ MOVEM C,-2(TP)
+ JRST INSRT3 ; INTO INSERT CODE
+
+INSRXT: PUSH P,-4(TP)
+ SUB TP,[6,,6]
+ POPJ P,
+ JRST IATM1
+\f
+; FUNCTION TO REMOVE AN ATOM FROM AN OBLIST
+
+MFUNCTION REMOVE,SUBR
+
+ ENTRY
+
+ JUMPGE AB,TFA
+ CAMGE AB,[-5,,]
+ JRST TMA
+ MOVEI C,0
+ CAML AB,[-3,,] ; SKIP IF OBLIST GIVEN
+ JRST .+5
+ GETYP 0,2(AB)
+ CAIE 0,TOBLS
+ JRST WTYP2
+ MOVE C,3(AB)
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ PUSHJ P,IRMV
+ JRST FINIS
+
+CIRMV: SUBM M,(P)
+ PUSHJ P,IRMV
+ JRST MPOPJ
+
+IRMV: PUSH TP,A
+ PUSH TP,B
+ PUSH TP,$TOBLS
+ PUSH TP,C
+IRMV1: GETYP 0,A ; CHECK 1ST ARG
+ CAIN 0,TLINK
+ JRST .+3
+ CAIE 0,TATOM ; ATOM, TREAT ACCORDINGLY
+ JRST RMV1
+
+ HRRZ D,2(B) ; SKIP IF ON OBLIST AND GET SAME
+ JUMPE D,RMVDON
+ CAMG D,VECBOT ; SKIP IF REAL OBLIST
+ HRRZ D,(D) ; NO, REF, GET IT
+
+ JUMPGE C,GOTOBL
+ CAIE D,(C) ; BETTER BE THE SAME
+ JRST ONOTH
+
+GOTOBL: ADD B,[3,,3] ; POINT TO PNAME
+ HLRE A,B
+ MOVNS A
+ PUSH P,(B) ; PUSH PNAME
+ AOBJN B,.-1
+ PUSH P,A
+ HRROM D,(TP) ; SAVE OBLIST
+ JRST RMV3
+
+RMV1: JUMPGE C,TFA
+ CAIE 0,TCHRS
+ CAIN 0,TCHSTR
+ SKIPA A,0
+ JRST WTYP1
+ MOVEI B,-3(TP)
+ PUSHJ P,CSTAK
+RMV3: MOVE B,(TP)
+ MOVSI A,TOBLS
+ PUSHJ P,ILOOK
+ POP P,D
+ HRLI D,(D)
+ SUB P,D
+ JUMPE B,RMVDON
+
+ MOVEI A,(B)
+ CAIGE A,HIBOT ; SKIP IF PURE
+ JRST RMV2
+ PUSH TP,$TATOM
+ PUSH TP,0
+ PUSHJ P,IMPURIFY
+ MOVE 0,(TP)
+ SUB TP,[2,,2]
+ MOVE A,-3(TP)
+ MOVE B,-2(TP)
+ MOVE C,(TP)
+ JRST IRMV1
+
+RMV2: JUMPN 0,RMV9 ; JUMP IF FIRST NOT IN BUCKET
+ HLRZ 0,2(B) ; POINT TO NEXT
+ MOVEM 0,(C)
+ JRST RMV8
+
+RMV9: MOVE C,0 ; C IS PREV ATOM
+ HLRZ 0,2(B) ; NEXT
+ HRLM 0,2(C)
+
+RMV8: SETZM 2(B) ; CLOBBER OBLIST SLOT
+ MOVE C,(TP) ; GET OBLIST FOR SPLICE OUT
+ MOVEI 0,-1
+ HRRZ E,(C)
+
+RMV7: JUMPE E,RMVDON
+ CAMN B,1(E) ; SEARCH OBLIST
+ JRST RMV6
+ MOVE C,E
+ HRRZ E,(C)
+ SOJG 0,RMV7
+
+RMVDON: SUB TP,[4,,4]
+ MOVSI A,TATOM
+ POPJ P,
+
+RMV6: HRRZ E,(E)
+ HRRM E,(C) ; SMASH IN
+ JRST RMVDON
+
+\f
+;INTERNAL CALL FROM THE READER
+
+RLOOKU: PUSH TP,$TFIX ;PUSH A FLAG
+ POP P,C ;POP OFF RET ADR
+ PUSH TP,C ;AND USE AS A FLAG FOR INTERNAL
+ MOVE C,(P) ; CHANGE CHAR COUNT TO WORD
+ ADDI C,4
+ IDIVI C,5
+ MOVEM C,(P)
+ GETYP D,A
+
+ CAIN D,TOBLS ;IS IT ONE OBLIST?
+ JRST .+3
+ CAIE D,TLIST ;IS IT A LIST
+ JRST BADOBL
+
+ JUMPE B,BADLST
+ PUSH TP,$TUVEC ; SLOT FOR REMEBERIG
+ PUSH TP,[0]
+ PUSH TP,$TOBLS
+ PUSH TP,[0]
+ PUSH TP,A
+ PUSH TP,B
+ CAIE D,TLIST
+ JRST RLOOK1
+
+ PUSH TP,$TLIST
+ PUSH TP,B
+RLOOK2: GETYP A,(B) ;CHECK THIS IS AN OBLIST
+ CAIE A,TOBLS
+ JRST DEFALT
+
+ SKIPE -4(TP) ; SKIP IF DEFAULT NOT STORED
+ JRST RLOOK4
+ MOVE D,1(B) ; OBLIST
+ MOVEM D,-4(TP)
+RLOOK4: INTGO
+ HRRZ B,@(TP) ;CDR THE LIST
+ HRRZM B,(TP)
+ JUMPN B,RLOOK2
+ SUB TP,[2,,2]
+ JRST .+3
+
+RLOOK1: MOVE B,(TP)
+ MOVEM B,-2(TP)
+ MOVE A,-1(TP)
+ MOVE B,(TP)
+ PUSHJ P,ILOOK
+ JUMPN B,RLOOK3
+ SKIPN D,-2(TP) ; RESTORE FOR INSERT
+ JRST BADDEF ; NO DEFAULT, USER LOST ON SPECIFICATION
+ SUB TP,[6,,6] ; FLUSH CRAP
+ SKIPN NOATMS
+ JRST INSRT1
+ JRST INSRT1
+
+DEFFLG==1 ;SPECIAL FLAG USED TO INDICATE THAT A DEFAULT HAS ALREADY BEEN
+ ; SPECIFIED
+DEFALT: MOVE 0,1(B)
+ CAIN A,TATOM ;SPECIAL DEFAULT INDICATING ATOM ?
+ CAME 0,MQUOTE DEFAULT
+ JRST BADDEF ;NO, LOSE
+ MOVEI A,DEFFLG
+ XORB A,-11(TP) ;SET AND TEST FLAG
+ TRNN A,DEFFLG ; HAVE WE BEEN HERE BEFORE ?
+ JRST BADDEF ; YES, LOSE
+ SETZM -6(TP) ;ZERO OUT PREVIOUS DEFAULT
+ SETZM -4(TP)
+ JRST RLOOK4 ;CONTINUE
+
+
+INSRT2: JRST .+2 ;
+RLOOK3: SUB TP,[6,,6] ;POP OFF LOSSAGE
+ PUSHJ P,ILINK ;IF THIS IS A LINK FOLLOW IT
+ PUSH P,(TP) ;GET BACK RET ADR
+ SUB TP,[2,,2] ;POP TP
+ JRST IATM1 ;AND RETURN
+
+
+BADOBL: ERRUUO EQUOTE BAD-OBLIST-OR-LIST-THEREOF
+
+BADDEF: ERRUUO EQUOTE BAD-DEFAULT-OBLIST-SPECIFICATION
+
+ONOTH: ERRUUO EQUOTE ATOM-ON-DIFFERENT-OBLIST
+\f;SUBROUTINE TO MAKE AN ATOM
+
+IMFUNCTION ATOM,SUBR
+
+ ENTRY 1
+
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ PUSHJ P,IATOMI
+ JRST FINIS
+
+CATOM: SUBM M,(P)
+ PUSHJ P,IATOMI
+ JRST MPOPJ
+
+IATOMI: GETYP 0,A ;CHECK ARG TYPE
+ CAIE 0,TCHRS
+ CAIN 0,TCHSTR
+ JRST .+2 ;JUMP IF WINNERS
+ JRST WTYP1
+
+ PUSH TP,A
+ PUSH TP,B
+ MOVEI B,-1(TP)
+ MOVE A,0
+ PUSHJ P,CSTAK ;COPY ONTO STACK
+ PUSHJ P,IATOM ;NOW MAKE THE ATOM
+ SUB TP,[2,,2]
+ POPJ P,
+
+;INTERNAL ATOM MAKER
+
+IATOM: MOVE A,-1(P) ;GET WORDS IN PNAME
+ ADDI A,3 ;FOR VALUE CELL
+ PUSHJ P,IBLOCK ; GET BLOCK
+ MOVSI C,<(GENERAL)>+SATOM ;FOR TYPE FIELD
+ MOVE D,-1(P) ;RE-GOBBLE LENGTH
+ ADDI D,3(B) ;POINT TO DOPE WORD
+ MOVEM C,(D)
+ SKIPG -1(P) ;EMPTY PNAME ?
+ JRST IATM0 ;YES, NO CHARACTERS TO MOVE
+ MOVE E,B ;COPY ATOM POINTER
+ ADD E,[3,,3] ;POINT TO PNAME AREA
+ MOVEI C,-1(P)
+ SUB C,-1(P) ;POINT TO STRING ON STACK
+ MOVE D,(C) ;GET SOME CHARS
+ MOVEM D,(E) ;AND COPY THEM
+ ADDI C,1
+ AOBJN E,.-3
+IATM0: MOVSI A,TATOM ;TYPE TO ATOM
+IATM1: POP P,D ;RETURN ADR
+ POP P,C
+ HRLI C,(C)
+ SUB P,C
+ JRST (D) ;RETURN
+
+\f;SUBROUTINE TO GET AN ATOM'S PNAME
+
+MFUNCTION PNAME,SUBR
+
+ ENTRY 1
+
+ GETYP A,(AB)
+ CAIE A,TATOM ;CHECK TYPE IS ATOM
+ JRST WTYP1
+ MOVE A,1(AB)
+ PUSHJ P,IPNAME
+ JRST FINIS
+
+CIPNAM: SUBM M,(P)
+ PUSHJ P,IPNAME
+ JRST MPOPJ
+
+IPNAME: ADD A,[3,,3]
+ HLRE B,A
+ MOVM B,B
+ PUSH P,(A) ;FLUSH PNAME ONTO P
+ AOBJN A,.-1
+ MOVE 0,(P) ; LAST WORD
+ PUSHJ P,PNMCNT
+ PUSH P,B
+ PUSHJ P,CHMAK ;MAKE A STRING
+ POPJ P,
+
+PNMCNT: IMULI B,5 ; CHARS TO B
+ MOVE A,0
+ SUBI A,1 ; FIND LAST 1
+ ANDCM 0,A ; 0 HAS 1ST 1
+ JFFO 0,.+1
+ HRREI 0,-34.(A) ; FIND HOW MUCH TO ADD
+ IDIVI 0,7
+ ADD B,0
+ POPJ P,
+
+MFUNCTION SPNAME,SUBR
+
+ ENTRY 1
+
+ GETYP 0,(AB)
+ CAIE 0,TATOM
+ JRST WTYP1
+
+ MOVE B,1(AB)
+ PUSHJ P,CSPNAM
+ JRST FINIS
+
+CSPNAM: ADD B,[3,,3]
+ MOVEI D,(B)
+ HLRE A,B
+ SUBM B,A
+ MOVE 0,-1(A)
+ HLRES B
+ MOVMS B
+ PUSHJ P,PNMCNT
+ MOVSI A,TCHSTR
+ HRRI A,(B)
+ MOVSI B,010700
+ HRRI B,-1(D)
+ POPJ P,
+
+\f; BLOCK STRUCTURE SUBROUTINES FOR MUDDLE
+
+IMFUNCTION BLK,SUBR,BLOCK
+
+ ENTRY 1
+
+ GETYP A,(AB) ;CHECK TYPE OF ARG
+ CAIE A,TOBLS ;IS IT AN OBLIST
+ CAIN A,TLIST ;OR A LIAT
+ JRST .+2
+ JRST WTYP1
+ MOVSI A,TATOM ;LOOK UP OBLIST
+ MOVE B,IMQUOTE OBLIST
+ PUSHJ P,IDVAL ;GET VALUE
+ PUSH TP,A
+ PUSH TP,B
+ MOVE PVP,PVSTOR+1
+ PUSH TP,.BLOCK(PVP) ;HACK THE LIST
+ PUSH TP,.BLOCK+1(PVP)
+ MCALL 2,CONS ;CONS THE LIST
+ MOVE PVP,PVSTOR+1
+ MOVEM A,.BLOCK(PVP) ;STORE IT BACK
+ MOVEM B,.BLOCK+1(PVP)
+ PUSH TP,$TATOM
+ PUSH TP,IMQUOTE OBLIST
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+ MCALL 2,SET ;SET OBLIST TO ARG
+ JRST FINIS
+
+MFUNCTION ENDBLOCK,SUBR
+
+ ENTRY 0
+
+ MOVE PVP,PVSTOR+1
+ SKIPN B,.BLOCK+1(PVP) ;IS THE LIST NIL?
+ JRST BLKERR ;YES, LOSE
+ HRRZ C,(B) ;CDR THE LIST
+ HRRZM C,.BLOCK+1(PVP)
+ PUSH TP,$TATOM ;NOW RESET OBLIST
+ PUSH TP,IMQUOTE OBLIST
+ HLLZ A,(B) ;PUSH THE TYPE OF THE CAR
+ PUSH TP,A
+ PUSH TP,1(B) ;AND VALUE OF CAR
+ MCALL 2,SET
+ JRST FINIS
+
+BLKERR: ERRUUO EQUOTE UNMATCHED
+
+BADLST: ERRUUO EQUOTE NIL-LIST-OF-OBLISTS
+\f;SUBROUTINE TO CREATE CHARACTER STRING GOODIE
+
+CHMAK: MOVE A,-1(P)
+ ADDI A,4
+ IDIVI A,5
+ PUSHJ P,IBLOCK
+ MOVEI C,-1(P) ;FIND START OF CHARS
+ HLRE E,B ; - LENGTH
+ ADD C,E ;C POINTS TO START
+ MOVE D,B ;COPY VECTOR RESULT
+ JUMPGE D,NULLST ;JUMP IF EMPTY
+ MOVE A,(C) ;GET ONE
+ MOVEM A,(D)
+ ADDI C,1 ;BUMP POINTER
+ AOBJN D,.-3 ;COPY
+NULLST: MOVSI C,TCHRS+.VECT. ;GET TYPE
+ MOVEM C,(D) ;CLOBBER IT IN
+ MOVE A,-1(P) ; # WORDS
+ HRLI A,TCHSTR
+ HRLI B,010700
+ MOVMM E,-1(P) ; SO IATM1 WORKS
+ SOJA B,IATM1 ;RETURN
+
+; SUBROUTINE TO READ FIVE CHARS FROM STRING.
+; TWO CALLS, ONE WITH A POINTING TO LIST ELEMENT,
+; THE OTHER WITH B POINTING TO PAIR. SKIPS IF WINNER, ELSE DOESNT
+
+NXTDCL: GETYP B,(A) ;CHECK TYPE
+ CAIE B,TDEFER ;LOSE IF NOT DEFERRED
+ POPJ P,
+
+ MOVE B,1(A) ;GET REAL BYTE POINTER
+CHRWRD: PUSH P,C
+ GETYP C,(B) ;CHECK IT IS CHSTR
+ CAIE C,TCHSTR
+ JRST CPOPJC ;NO, QUIT
+ PUSH P,D
+ PUSH P,E
+ PUSH P,0
+ MOVEI E,0 ;INITIALIZE DESTINATION
+ HRRZ C,(B) ; GET CHAR COUNT
+ JUMPE C,GOTDCL ; NULL, FINISHED
+ MOVE B,1(B) ;GET BYTE POINTER
+ MOVE D,[440700,,E] ;BYTE POINT TO E
+CHLOOP: ILDB 0,B ; GET A CHR
+ IDPB 0,D ;CLOBBER AWAY
+ SOJE C,GOTDCL ; JUMP IF DONE
+ TLNE D,760000 ; SKIP IF WORD FULL
+ JRST CHLOOP ; MORE THAN 5 CHARS
+ TRO E,1 ; TURN ON FLAG
+
+GOTDCL: MOVE B,E ;RESULT TO B
+ AOS -4(P) ;SKIP RETURN
+CPOPJ0: POP P,0
+ POP P,E
+ POP P,D
+CPOPJC: POP P,C
+ POPJ P,
+
+\f;ROUTINES TO DEFINE AND HANDLE LINKS
+
+MFUNCTION LINK,SUBR
+ ENTRY
+ CAML AB,[-6,,0] ;NO MORE THAN 3 ARGS
+ CAML AB,[-2,,0] ;NO LESS THAN 2 ARGS
+ JRST WNA
+ CAML AB,[-4,,0] ;ONLY TWO ARGS SUPPLIED ?
+ JRST GETOB ;YES, GET OBLIST FROM CURRENT PATH
+ MOVE A,2(AB)
+ MOVE B,3(AB)
+ MOVE C,5(AB)
+ JRST LINKIN
+GETOB: MOVSI A,TATOM
+ MOVE B,IMQUOTE OBLIST
+ PUSHJ P,IDVAL
+ CAMN A,$TOBLS
+ JRST LINKP
+ CAME A,$TLIST
+ JRST BADOBL
+ JUMPE B,BADLST
+ GETYPF A,(B)
+ MOVE B,(B)+1
+LINKP: MOVE C,B
+ MOVE A,2(AB)
+ MOVE B,3(AB)
+LINKIN: PUSHJ P,IINSRT
+ CAMN A,$TFALSE ;LINK NAME ALREADY USED ?
+ JRST ALRDY ;YES, LOSE
+ MOVE C,B
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ PUSHJ P,CSETG
+ JRST FINIS
+
+
+ILINK: HLRE A,B
+ SUBM B,A ;FOUND A LINK ?
+ MOVE A,(A)
+ TRNE A,LNKBIT
+ JRST .+3
+ MOVSI A,TATOM
+ POPJ P, ;NO, FINISHED
+ MOVSI A,TATOM
+ PUSHJ P,IGVAL ;GET THE LINK'S DESTINATION
+ CAME A,$TUNBOUND ;WELL FORMED LINK ?
+ POPJ P, ;YES
+ ERRUUO EQUOTE BAD-LINK
+
+\f
+; THIS SUBROUTINE IMPURIFIES A PURE ATOM TO ALLOW MODIFICATION OF SYSTEM SUBRS
+
+IMPURIFY:
+ PUSH TP,$TATOM
+ PUSH TP,B
+ MOVE C,B
+ MOVEI 0,(C)
+ CAIGE 0,HIBOT
+ JRST RTNATM ; NOT PURE, RETURN
+ JRST IMPURX
+
+; ROUTINE PASSED TO GCHACK
+
+ATFIX: CAME D,(TP)
+ CAMN D,-2(TP)
+ JRST .+2
+ POPJ P,
+
+ ASH C,1
+ ADD C,TYPVEC+1 ; COMPUTE SAT
+ HRRZ C,(C)
+ ANDI C,SATMSK
+ CAIE C,SATOM
+CPOPJ: POPJ P,
+
+ SUB D,-2(TP)
+ ADD D,-4(TP)
+ SKIPE B
+ MOVEM D,1(B)
+ POPJ P,
+
+
+; SUBROUTINE TO FIND A BYTE STRINGS DOPE WORD
+; RECEIVES POINTER TO PAIR CONNTAINIGN CHSTR IN C, RETURNS DOPE WORD IN A
+
+BYTDOP: PUSH P,B ; SAVE SOME ACS
+ PUSH P,D
+ PUSH P,E
+ MOVE B,1(C) ; GET BYTE POINTER
+ LDB D,[360600,,B] ; POSITION TO D
+ LDB E,[300600,,B] ; AND BYTE SIZE
+ MOVEI A,(E) ; A COPY IN A
+ IDIVI D,(E) ; D=> # OF BYTES IN WORD 1
+ HRRZ E,(C) ; GET LENGTH
+ SUBM E,D ; # OF BYTES IN OTHER WORDS
+ JUMPL D,BYTDO1 ; NEAR DOPE WORD
+ MOVEI B,36. ; COMPUTE BYTES PER WORD
+ IDIVM B,A
+ ADDI D,-1(A) ; NOW COMPUTE WORDS
+ IDIVI D,(A) ; D/ # NO. OF WORDS PAST 1ST
+ ADD D,1(C) ; D POINTS TO DOPE WORD
+ MOVEI A,2(D)
+
+BYTDO2: POP P,E
+ POP P,D
+ POP P,B
+ POPJ P,
+BYTDO1: MOVEI A,2(B)
+ JRST BYTDO2
+
+; 1) IMPURIFY ITS OBLIST LIST
+
+IMPURX: HRRZ B,2(C) ; PICKUP OBLIST IF IT EXISTS
+ JUMPE B,IMPUR0 ; NOT ON ONE, IGNORE THIS CODE
+
+ HRRO E,(B)
+ PUSH TP,$TOBLS ; SAVE BUCKET
+ PUSH TP,E
+
+ MOVE B,(E) ; GET NEXT ONE
+IMPUR4: MOVEI 0,(B)
+ MOVE D,1(B)
+ CAME D,-2(TP)
+ JRST .+3
+ SKIPE GPURFL ; IF PURIFY SMASH THE OBLIST SLOT TO PROTECT
+ ; ATOM
+ HRRM D,1(B)
+ CAIGE 0,HIBOT ; SKIP IF PURE
+ JRST IMPUR3 ; FOUND IMPURE NESS, SKIP IT
+ HLLZ C,(B) ; SET UP ICONS CALL
+ HRRZ E,(B)
+IMPR1: PUSHJ P,ICONS ; CONS IT UP
+IMPR2: HRRZ E,(TP) ; RETRV PREV
+ HRRM B,(E) ; AND CLOBBER
+IMPUR3: MOVE D,1(B)
+ CAMN D,-2(TP) ; HAVE GOTTEN TO OUR SLOT?
+ JRST IMPPR3
+ MOVSI 0,TLIST
+ MOVEM 0,-1(TP) ; FIX TYPE
+ HRRZM B,(TP) ; STORE GOODIE
+ HRRZ B,(B) ; CDR IT
+ JUMPN B,IMPUR4 ; LOOP
+IMPPR3: SUB TP,[2,,2] ; FLUSH TP CRUFT
+
+; 1.5) IMPURIFY GLOBAL HASH BUCKET, A REAL PAIN
+
+IMPUR0: MOVE C,(TP) ; GET ATOM
+
+ HRRZ B,2(C)
+ MOVE B,(B)
+ ADD C,[3,,3] ; POINT TO PNAME
+ HLRE A,C ; GET LNTH IN WORDS OF PNAME
+ MOVNS A
+; PUSH P,[SETZ IMPUR2] ; FAKE OUT ILOOKC
+ XMOVEI 0,IMPUR2
+ PUSH P,0
+ PUSH P,(C) ; PUSH UP THE PNAME
+ AOBJN C,.-1
+ PUSH P,A ; NOW THE COUNT
+ MOVSI A,TOBLS
+ JRST ILOOKC ; GO FIND BUCKET
+
+IMPUR2: JUMPE B,IMPUR1
+ JUMPE 0,IMPUR1 ; YUP, DONE
+ HRRZ C,0
+ CAIG C,HIBOT ; SKIP IF PREV IS PURE
+ JRST IMPUR1
+
+ MOVE B,0
+ PUSH P,GPURFL ; PRERTEND OUT OF PURIFY
+ HLRE C,B
+ SUBM B,C
+ HRRZ C,(C) ; ARE WE ON PURIFY LIST
+ CAIG C,HIBOT ; IF SO, WE ARE STILL PURIFY
+ SETZM GPURFL
+ PUSHJ P,IMPURIF ; RECURSE
+ POP P,GPURFL
+ MOVE B,(TP) ; AND RETURN ORIGINAL
+
+; 2) GENERATE A DUPLICATE ATOM
+
+IMPUR1: SKIPE GPURFL ; SEE IF IN PURIFY
+ JRST IMPUR7
+ HLRE A,(TP) ; GET LNTH OF ATOM
+ MOVNS A
+ PUSH P,A
+ PUSHJ P,IBLOCK ; GET NEW BLOCK FOR ATOM
+ PUSH TP,$TATOM
+ PUSH TP,B
+ HRL B,-2(TP) ; SETUP BLT
+ POP P,A
+ ADDI A,(B) ; END OF BLT
+ BLT B,(A) ; CLOBBER NEW ATOM
+ MOVSI B,.VECT. ; TURN ON BIT FOR GCHACK
+ IORM B,(A)
+
+; 3) NOW COPY GLOBAL VALUE
+
+IMPUR7: MOVE B,(TP) ; ATOM BACK
+ GETYP 0,(B)
+ SKIPE A,1(B) ; NON-ZER POINTER?
+ CAIN 0,TUNBOU ; BOUND?
+ JRST IMPUR5 ; NO, DONT COPY GLOB VAL
+ PUSH TP,(A)
+ PUSH TP,1(A)
+ PUSH TP,$TATOM
+ PUSH TP,B
+ SETZM (B)
+ SETZM 1(B)
+ SKIPN GPURFL ; HERE IS SOME CODE NEEDED FOR PURIFY
+ JRST IMPUR8
+ PUSH P,LPVP
+ MOVE PVP,PVSTOR+1
+ PUSH P,AB ; GET AB BACK
+ MOVE AB,ABSTO+1(PVP)
+IMPUR8: PUSHJ P,BSETG ; SETG IT
+ SKIPN GPURFL
+ JRST .+3 ; RESTORE SP AND AB FOR PURIFY
+ POP P,TYPNT
+ POP P,SP
+ SUB TP,[2,,2] ; KILL ATOM SLOTS ON TP
+ POP TP,C ;POP OFF VALUE SLOTS
+ POP TP,A
+ MOVEM A,(B) ; FILL IN SLOTS ON GLOBAL STACK
+ MOVEM C,1(B)
+IMPUR5: SKIPE GPURFL ; FINISH OFF DIFFERENTLY FOR PURIFY
+ JRST IMPUR9
+
+ PUSH TP,$TFIX ;SAVE OLD ATOM WITH FUNNY TYPE TO AVOID LOSSAGE
+ PUSH TP,-3(TP)
+ PUSH TP,$TFIX ; OTHER KIND OF POINTER ALSO
+ HLRE 0,-1(TP)
+ HRRZ A,-1(TP)
+ SUB A,0
+ PUSH TP,A
+
+; 4) UPDATE ALL POINTERS TO THIS ATOM
+
+ MOVE A,[PUSHJ P,ATFIX] ; INS TO PASS TO GCHACK
+ MOVEI PVP,1 ; SAY MIGHT BE NON-ATOMS
+ PUSHJ P,GCHACK
+ SUB TP,[6,,6]
+
+RTNATM: POP TP,B
+ POP TP,A
+ POPJ P,
+
+IMPUR9: SUB TP,[2,,2]
+ POPJ P, ; RESTORE AND GO
+
+
+
+END
projects / pdp10-muddle.git / blobdiff