mirror of
https://github.com/PDP-10/its.git
synced 2026-02-03 15:22:48 +00:00
a7399d0f9a
Looking at the backup dates for files in <mdl.int>, mdl106.exe is from 20th January 1981, whereas some of the source files are from a couple of years later. Revert to the last version prior to 20th January 1981 -- in every case, this was the earliest revision that was kept in <mdl.int>. This undoes the changes that we'd previously made to these files, many of which are no longer necessary now that we're using MIDAS 73.
1186 lines
22 KiB
Plaintext
1186 lines
22 KiB
Plaintext
|
||
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
|
||
|
||
; 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
|
||
; 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
|
||
|
||
; 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
|
||
|
||
; 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
|
||
|
||
|
||
;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
|
||
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
|
||
;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
|
||
|
||
;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,
|
||
|
||
; 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
|
||
;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,
|
||
|
||
;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
|
||
|
||
|
||
; 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,[IMPUR2] ; FAKE OUT ILOOKC
|
||
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
|
||
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
|