TITLE GCHACK

RELOCATABLE

.INSRT MUDDLE >

.GLOBAL FRMUNG,PARBOT,TYPVEC,GCHACK,REHASH,IMPURI,NWORDT,GCDFLG
.GLOBAL TD.LNT,TD.GET,TD.PUT,GCSTOP,GCSBOT,GCHK10,STOSTR,UBIT,PVSTOR,SPSTOR

UBIT==40000		; BIT INDICATING VECTOR
.LIST.==400000

; THIS IS AN INTERNAL MUDDLE SUBROUTINE TO RUN AROUND GC SPACE DOING
; SOMETHING ARBITRARY TO EVERY ENTITY THEREIN

; CALL --
;	A/  INSTRUCTION TO BE EXECUTED
;	PVP/	NON-ZERO OPTIMIZE--ONLY LOOK AT ATOMS
;	PUSHJ P,GCHACK

; HERE FOR SPECIAL HACKS WHICH DON'T TOUCH STOAGE

GCHK10:	PUSHJ	P,GHSTUP
	JRST	GCHK1

GCHACK:	PUSHJ	P,GHSTUP	; SETUP
	MOVE	B,CODTOP	; START OFF WITH IMPURE STORAGE
	SUBI	B,1		; START AT FIRST WORD
LOPSTO:	CAIG	B,STOSTR
	JRST	GCHK1
	HRRE	0,1(B)		; GET INDICATOR OF MODIFICATION
	JUMPGE	0,LOSTO		; JUMP IF GARBAGE
	PUSHJ	P,VHACK		; VHACK
	JRST	LOPSTO
LOSTO:	HLRZ	C,1(B)		; BACK OF VECTOR
	TRZ	C,400000
	SUBI	B,(C)		; SKIP OVER VECTOR
	JRST	LOPSTO

GCHK1:	MOVE	B,VECTOP	; NO LOOP THRU GCS
	MOVEI	B,-2(B)


LOOPHK:	MOVE	C,SVTAB
	MOVEM	B,(C)
	EXCH	C,NXTTAB	; SWAP LOCATIONS
	EXCH	C,SVTAB
	TLZ	B,.LIST.	; TURN OFF LIST BIT
	CAMGE	B,GCSBOT	; SEE IF DONE
	JRST	REHASQ		; SEE IF ASSOCIATIONS ARE GOOD
	MOVE	C,(B)		; GET ELEMENT
	TLNE	C,.VECT.	; SEE IF IT IS A VECTOR
	JRST	VHCK		; JUMP IF IT IS
GLSTHK:	GETYP	C,(B)		; TYPE OF CURRENT PAIR
	MOVE	D,1(B)		; AND ITS DATUM
	TLO	B,.LIST.	; INDICATE A LIST
	SKIPL	(B)		; SKIP IF MARKED
	XCT	A		; APPLY INS
	SUBI	B,2
	JRST	LOOPHK
VHCK:	PUSHJ	P,VHACK		; TO VHACK
	JRST	LOOPHK

; NOW DO THE SAME THING TO VECTOR SPACE
VHACK:	HLRE	D,(B)		; GET TYPE FROM D.W.
	TRZ	D,.VECT.	; GET RID OF VECTOR INDICATION BIT
	HLRZ	C,1(B)		; AND TOTAL LENGTH
	TRZE	C,400000	; GET RID OF POSSIBLE MARK BIT
	JRST	MKHAK		; JUMP IF MARKED
	SUBI	B,(C)-2		; POINT TO START OF VECTOR
	PUSH	P,B
	SUBI	C,2		; CHECK WINNAGE
	JUMPL	C,BADV		; FATAL LOSSAGE
	PUSH	P,C		; SAVE COUNT
	JUMPE	C,VHACK1	; EMPTY VECTOR, FINISHED

; DECIDE BASED ON TYPE WHETHER GENERAL,UNIFORM OR SPECIAL

	JUMPGE	D,UHACK		; UNIFORM
	TRNE	D,377777	; SKIP IF GENERAL
	JRST	SHACK		; SPECIAL

; FALL THROUGH TO GENERAL

GHACK1:	SKIPGE	(B)		; CHECK FOR FENCE POST
	JRST	VHACK1
	GETYP	C,(B)		; LOOK A T 1ST ELEMENT
	CAIE	C,TCBLK
	CAIN	C,TENTRY	; FRAME ON STACK
	SOJA	B,EHACK
	CAIE	C,TUBIND
	CAIN	C,TBIND		; BINDING BLOCK
	JRST	BHACK
	CAIN	C,TGATOM	; ATOM WITH GDECL?
	JRST	GDHACK
	MOVE	D,1(B)		; GET DATUM
	XCT	A		; USER INS
GDHCK1:	ADDI	B,2		; NEXT ELEMENT
	SOS	(P)
	SOSLE	(P)		; COUNT ELEMENTS
	SKIPGE	(B)		; OR FENCE POST HIT
	JRST	VHACK1
	JRST	GHACK1

; HERE TO GO OVER UVECTORS

UHACK:	CAMN	A,[PUSHJ P,SBSTIS]
	JRST	VHACK1		; IF THIS SUBSTITUTE, DONT DO UVEC
	MOVEI	C,(D)		; COPY UNIFORM TYPE
	JUMPE	PVP,UHACKX	; JUMP IF NOT ONLY ATOMS
	ASH	C,1		; COMPUTE SAT
	ADD	C,TYPVEC+1
	HRRZ	C,(C)
	ANDI	C,SATMSK	; GOT ITS SAT
	CAIE	C,SCHSTR	; COULD BE SPNAME
	 JRST	.+3
	CAIE	C,SATOM		; DON'T BOTHER IF NOT ALL ATOMS
	 JRST	VHACK1
	MOVEI	C,(D)
UHACKX:	PUSH	P,C		; ATFIX CLOBBERS C
	SUBI	B,1		; BACK OFF

UHACK1:	MOVE	C,(P)
       	TLO	B,UBIT		; TURN ON BIT INDICATING UVECTOR
	MOVE	D,1(B)		; DATUM
	XCT	A
	SOSLE	-1(P)		; COUNT DOEN
	AOJA	B,UHACK1
	TLZ	UBIT
	POP	P,C
	JRST	VHACK1

; HERE TO HACK VARIOUS FLAVORS OF SPECIAL GOODIES

SHACK:	ANDI	D,377777	; KILL EXTRA CRUFT
	CAIN	D,SATOM
	JRST	ATHACK
	CAIE	D,STPSTK	; STACK OR
	CAIN	D,SPVP		; PROCESS
	JRST	GHACK1		; TREAT LIKE GENERAL
	CAIN	D,SASOC		; ASSOCATION
	JRST	ASHACK
	CAIG	D,NUMSAT	; TEMPLATE MAYBE?
	JRST	BADV		; NO CHANCE
	ADDI	C,(B)		; POINT TO DOPE WORDS
	SUBI	D,NUMSAT+1
	HRLI	D,(D)
	ADD	D,TD.LNT+1
	JUMPGE	D,BADV		; JUMP IF INVALID TEMPLATE HACKER

	CAMN	A,[PUSHJ P,SBSTIS]
	JRST	VHACK1

TD.UPD:	PUSH	P,A		; INS TO EXECUTE
	XCT	(D)
	HLRZ	E,B		; POSSIBLE BASIC LENGTH
	PUSH	P,[0]
	PUSH	P,E
	MOVEI	B,(B)		; ISOLATE LENGTH
	PUSH	P,C		; SAVE POINTER TO OBJECT

	PUSH	P,[0]		; HOME FOR VALUES
	PUSH	P,[0]		; SLOT FOR TEMP
	PUSH	P,B		; SAVE
	SUB	D,TD.LNT+1
	PUSH	P,D		; SAVE FOR FINDING OTHER TABLES
	JUMPE	E,TD.UP2	; NO REPEATING SEQ
	ADD	D,TD.GET+1	; COMP LNTH OF REPEATING SEQ
	HLRE	D,(D)		; D ==> - LNTH OF TEMPLATE
	ADDI	D,(E)		; D ==> -LENGTH OF REP SEQ
	MOVNS	D
	HRLM	D,-5(P)		; SAVE IT AND BASIC

TD.UP2:	SKIPG	D,-1(P)		; ANY LEFT?
	JRST	TD.UP1

	MOVE	E,TD.GET+1
	ADD	E,(P)
	MOVE	E,(E)		; POINTER TO VECTOR IN E
	MOVEM	D,-6(P)		; SAVE ELMENT #
	SKIPN	B,-5(P)		; SKIP IF "RESTS" EXIST
	SOJA	D,TD.UP3

	MOVEI	0,(B)		; BASIC LNT TO 0
	SUBI	0,(D)		; SEE IF PAST BASIC
	JUMPGE	0,.-3		; JUMP IF O.K.
	MOVSS	B		; REP LNT TO RH, BASIC TO LH
	IDIVI	0,(B)		; A==> -WHICH REPEATER
	MOVNS	A
	ADD	A,-5(P)		; PLUS BASIC
	ADDI	A,1		; AND FUDGE
	MOVEM	A,-6(P)		; SAVE FOR PUTTER
	ADDI	E,-1(A)		; POINT
	SOJA	D,.+2

TD.UP3:	ADDI	E,(D)		; POINT TO SLOT
	XCT	(E)		; GET THIS ELEMENT INTO A AND B
	TLO	A,UBIT		; INDICATE ITS A ANY
	MOVEM	A,-3(P)		; SAVE TYPE FOR LATER PUT
	MOVEM	B,-2(P)
	GETYP	C,A		; TYPE TO C
	MOVE	D,B		; DATUME
	MOVEI	B,-3(P)		; POINTER TO HOME
	MOVE	A,-7(P)		; GET INS
	XCT	A		; AND DO IT
	MOVE	C,-4(P)		; GET POINTER FOR UPDATE OF ELEMENT
	MOVE	E,TD.PUT+1
	SOS	D,-1(P)		; RESTORE COUNT
	ADD	E,(P)
	MOVE	E,(E)		; POINTER TO VECTOR IN E
	MOVE	B,-6(P)		; SAVED OFFSET
	ADDI	E,(B)-1		; POINT TO SLOT
	MOVE	A,-3(P)		; RESTORE TYPE WORD
	MOVE	B,-2(P)
	XCT	(E)		; SMASH IT BACK
	JRST	TD.LOS
TD.WIN:	MOVE	C,-4(P)
	JRST	TD.UP2

TD.LOS:	SKIPN	GCDFLG
	FATAL TEMPLATE LOSSAGE
	JRST	TD.WIN

TD.UP1:	MOVE	A,-7(P)		; RESTORE INS
	SUB	P,[10,,10]
	MOVSI	D,400000	; RESTORE MARK/UNMARK BIT
	JRST	VHACK1

; FATAL LOSSAGE ARRIVES HERE

BADV:	FATAL GC SPACE IN A BAD STATE

; HERE TO HACK SPECIAL CRUFT IN GENERAL VECTORS (STACKS)

EHACK:	JUMPE	PVP,EHACKX
	ADDI	B,FRAMLN+1	; SKIP THE FRAME
	JRST	GHACK1

EHACKX:	HRRZ	D,1(B)
	CAILE	D,HIBOT
	JRST	EHCK10
	PUSH	P,1(B)
	HRL	D,(D)
	MOVEI	C,TVEC
	CAME	A,[PUSHJ P,SBSTIS]
	XCT 	A		; XCT SUBSTITUTE
	POP	P,C		; RESTORE TYPE
	HLLM	C,1(B)		; SMASH BACK
EHCK10:	ADDI	B,1
	MOVSI	D,-FRAMLN+1	; SET UP AOBJN PNTR

EHACK1:	HRRZ	C,ETB(D)	; GET 1ST TYPE
	PUSH	P,D		; SAVE AOBJN
	MOVE	D,1(B)		; GET ITEM
	CAME	A,[PUSHJ P,SBSTIS]	; DONT IF SUBSTITUTE DIFFERENT
	XCT	A		; USER GOODIE
	POP	P,D		; RESTORE AOBJN
	ADDI	B,1		; MOVE ON
	SOSLE	(P)		; ALSO COUNT IN TOTAL VECTOR
	AOBJN	D,EHACK1
	AOJA	B,GHACK1		; AND GO ON

; TABLE OF ENTRY BLOCK TYPES

ETB:	TTB
	TAB
	TSP
	TPDL
	TTP
	TWORD

; HERE TO GROVEL OVER BINDING BLOCKS

BHACK:	MOVEI	C,TATOM		; ALSO TREEAT AS ATOM
	MOVE	D,1(B)
	CAME	A,[PUSHJ P,SBSTIS]	; DONT IF SUBSTITUTE DIFFERENT
	XCT	A
	PUSHJ	P,NXTGDY	; NEXT GOODIE
	PUSHJ	P,NXTGDY	; AND NEXT
	MOVEI	C,TSP		; TYPE THE BACK LOCATIVE
	SKIPGE	D,1(B)
	XCT	A
	PUSHJ	P,BMP		; AND NEXT
	PUSH	P,B
	HLRZ	D,-2(B)		; DECL POINTER
	MOVEI	B,0		; MAKE SURE NO CLOBBER
	MOVEI	C,TDECL
	XCT	A		; DO THE THING BEING DONE
	POP	P,B
	HRLM	D,-2(B)		; FIX UP IN CASE CHANGED
	JRST	GHACK1

; HERE TO HACK ATOMS WITH GDECLS

GDHACK:	CAMN	A,[PUSHJ P,SBSTIS]
	JRST	GDHCK1

	MOVEI	C,TATOM		; TREAT LIKE ATOM
	MOVE	D,1(B)
	XCT	A
	HRRZ	D,(B)		; GET DECL
	JUMPE	D,GDHCK1
	CAIN	D,-1		; WATCH OUT FOR MAINFEST
	JRST	GDHCK1
	PUSH	P,B		; SAVE POINTER
	MOVEI	B,0
	MOVEI	C,TLIST
	XCT	A
	POP	P,B
	HRRM	D,(B)		; RESET
	JRST	GDHCK1


; HERE TO HACK ATOMS

ATHACK:	JUMPN	PVP,BUCKHK	; IF ONLY CHANGING ATOMS, IGNROE OBLIST
	MOVEI	C,TOBLS		; GET TYPE
	HRRZ	D,2(B)		; AND DATUM
	JUMPE	D,BUCKHK	; NOT ON OBLIST, SO FLUSH
	CAMGE	D,VECBOT
	MOVE	D,(D)		; GET REAL OBLIST POINTER
	HRLI	D,-1
	CAMN	A,[PUSHJ P,SBSTIS]	; DONT IF SUBSTITUTE DIFFERENT
	JRST	VHACK1
	PUSH	P,B
	MOVEI	B,0
	XCT	A
	POP	P,B
	HRRM	D,2(B)
BUCKHK:	CAMN	A,[PUSHJ P,SBSTIS]	; DONT IF SUBSTITUTE DIFFERENT
	JRST	VHACK1
	HLRZ	D,2(B)
	JUMPE	D,VHACK1
	PUSH	P,B
	PUSH	P,D
	MOVEI	B,-1(P)		; FAKE OUT TO MUNG STACK
;	HLRZ	B,1(D)
;	ANDI	B,377777
;	SUBI	B,2
;	HRLI	B,(B)
;	SUB	D,B		; D NOW ATOM PNTR
	MOVEI	C,TATOM
	XCT	A
;	HLRE	B,D
;	SUB	D,B
	POP	P,D
	POP	P,B
	HRLM	D,2(B)
	JRST	VHACK1

; HERE TO HACK ASSOCIATION BLOCKS

ASHACK:	MOVEI	D,3		; COUNT GOODIES TO MARK

ASHAK1:	PUSH	P,D
	MOVE	D,1(B)
	GETYP	C,(B)
	PUSH	P,D		; SAVE POINTER
	XCT	A
	POP	P,D		; GET OLD BACK
	CAME	D,1(B)		; CHANGED?
	TLO	E,400000	; SET NON-VIRGIN FLAG
	POP	P,D
	PUSHJ	P,BMP		; TO NEXT
	SOJG	D,ASHAK1

; HERE  TO GOT TO NEXT VECTOR

VHACK1:	MOVE	B,-1(P)		; GET POINTER
	SUB	P,[2,,2]	; FLUSH CRUFT
	SUBI	B,2		; FIX UP PTR
	POPJ	P,

; HERE TO SKIP OVER MARKED VECTOR

MKHAK:	SUBI	B,(C)		; POINT BELOW VECTOR
	POPJ	P,

; ROUTINE TO GET A GOODIE

NXTGDY:	GETYP	C,(B)
NXTGD1:	MOVE	D,1(B)
	XCT	A		; DO IT TO IT
BMP:	SOS	-1(P)
	SOSG	-1(P)
	JRST	BMP1
	ADDI	B,2
	POPJ	P,
BMP1:	SUB	P,[1,,1]
	JRST	VHACK1

REHASQ:	JUMPL	E,REHASH	; HASH TABLE RAPED, FIX IT
	POPJ	P,


MFUNCTION SUBSTI,SUBR,[SUBSTITUTE]

;THIS FUNCTION CODED BY NDR IS AN INCREDIBLE WAY TO
;KILL YOURSELF, EVEN IF YOU THINK YOU REALLY KNOW WHAT
;YOU ARE DOING.
;IT DOES A MINI-GC CHANGING EACH REFERENCE OF THE
;SECOND ITEM TO A REFERENCE OF THE FIRST ITEM, HA HA HA.
;BOTH ITEMS MUST BE OF THE SAME TYPE OR
;IF NOT, NEITHER CAN BE A TYPE REQUIRING TWO WORDS
;  OF STORAGE, AND SUBSTITUTION CANT BE DONE IN
;  UVECTORS WHEN THEY ARE DIFFERENT, AS WELL AS IN
;  A FEW OTHER YUCKY PLACES.
;RETURNS ITEM TWO--THE ONLY WAY TO GET YOUR HANDS BACK ON IT

	ENTRY 2


SBSTI1:	GETYP	A,2(AB)
	CAIE	A,TATOM
	JRST	SBSTI2
	MOVE	B,3(AB)		; IMPURIFY HASH BUCKET MAYBE?
	PUSHJ	P,IMPURI
	GETYP	A,(AB)		; ATOM FOR ATOM SUBS?
	CAIE	A,TATOM
	JRST	SBSTI2		; NO
	MOVE	B,3(AB)		; SEE IF OLD GUY
	HLRE	A,B
	SUBM	B,A		; POINT TO DOPE
	HRRZ	A,(A)		; POSSIBLE TYPE CODE
	JUMPE	A,SBSTI2	; NOT A TYPE, GO
	MOVE	B,1(AB)
	HLRE	C,B
	SUBM	B,C
	HRRZ	C,(C)		; GET OTHER POSSIBLE CODE
	JUMPN	C,BADTYP
	PUSH	P,A
	PUSHJ	P,IMPURI	; IMPURIFY FOR SMASH
	POP	P,A
	MOVE	B,1(AB)	
	HLRE	C,B
	SUBM	B,C
	HRRM	A,(C)

SBSTI2:	GETYP	A,2(AB)		; GET TYPE OF SECOND ARG
	MOVE	D,A
	PUSHJ	P,NWORDT	; AND STORAGE ALLOCATION
	MOVE	E,A
	GETYP	A,(AB)		; GET TYPE OF FIRST ARG	
	MOVE	B,A
	PUSHJ	P,NWORDT
	CAMN	B,D		; IF TYPES SAME, DONT CHECK FOR ALLOCATION
	JRST	SBSTI3
	CAIN	E,1
	CAIE	A,1
	JRST	SBSTIL		; LOOSE, NOT BOTH ONE WORD GOODIES

SBSTI3:	MOVEI	C,0
	CAIN	D,0		; IF GOODIE IS OF TYPE ZERO
	MOVEI	C,1		; USE TYPE 1 TO KEEP INFO FROM CLOBBERAGE
	PUSH	TP,C
	SUBI	E,1
	PUSH	TP,E		; 1=DEFERRED TYPE ITEM, 0=ELSE
	PUSH	TP,C
	PUSH	TP,D		; TYPE OF GOODIE
	PUSH	TP,C
	PUSH	TP,[0]
	CAIN	D,TLIST
	AOS	(TP)		; 1=TYPE LIST, 0=ELSE
	PUSH	TP,C
	PUSH	TP,2(AB)		; TYPE-WORD
	PUSH	TP,C
	PUSH	TP,3(AB)	; VALUE-WORD
	PUSH	TP,(AB)
	PUSH	TP,1(AB)	; TYPE-VALUE OF THINGS TO CHANGE INTO
	MOVE	A,[PUSHJ P,SBSTIR]
	CAME	B,D		; IF NOT SAME TYPE, USE DIFF MUNGER
	MOVE	A,[PUSHJ P,SBSTIS]
	MOVEI	PVP,0		; INDICATE NOT SPECIAL ATOM THING
	PUSHJ	P,GCHACK	; DO-IT
	MOVE	A,-4(TP)
	MOVE	B,-2(TP)
	JRST	FINIS		; GIVE THE LOOSER A HANDLE ON HIS GOODIE

SBSTIR:	CAME	D,-2(TP)
	JRST	LSUB		; THIS IS IT
	CAME	C,-10(TP)
	JRST	LSUB		; IF ITEM CANT BE SAME CHECK FOR LISTAGE
	JUMPE	B,LSUB+1	; WE GOT HOLD OF A FUNNY GOODIE, JUST IGNORE IT
	MOVE	0,(TP)
	MOVEM	0,1(B)		; SMASH IT
	MOVE	0,-1(TP)	; GET TYPE WORD
	SKIPE	-12(TP)		; IF THIS IS A DEFFERABLE ITEM THEN WE MUST
	MOVEM	0,(B)		; ALSO SMASH THE TYPE WORD SLOT

LSUB:	SKIPN	-6(TP)		; IF WE ARE LOOKING FOR LISTS, LOOK ON
	POPJ	P,		; ELSE THATS ALL
	TLNN	B,.LIST.		; SEE IF A LIST
	POPJ	P,		; WELL NO LIST SMASHING THIS TIME
	HRRZ	0,(B)		; GET ITS LIST POINTER
	CAME	0,-2(TP)
	POPJ	P,		; THIS ONE DIDNT MATCH
	MOVE	0,(TP)		; GET THE NEW REST OF THE LIST
	HRRM	0,(B)		; AND SMASH INTO THE REST OF THE LIST
	POPJ	P,

SBSTIS:	CAMN	D,-2(TP)
	CAME	C,-10(TP)
	POPJ	P,
	SKIPN	B		; SEE IF THIS IS A FUNNY GOODIE WE NO TOUCHIE
	POPJ	P,
	MOVE	0,(TP)
	MOVEM	0,1(B)		; KLOBBER VALUE CELL
	MOVE	0,-1(TP)
	HLLM	0,(B)		; KLOBBER TYPE CELL, WHICH WE KNOW IS THERE
	POPJ	P,

SBSTIL:	ERRUUO	EQUOTE CANT-SUBSTITUTE-WITH-STRING-OR-TUPLE-AND-OTHER
BADTYP:	ERRUUO	EQUOTE SUBSTITUTE-TYPE-FOR-TYPE

GHSTUP:	HRRZ	E,TYPVEC+1	; SET UP TYPE POINTER
	HRLI	E,C		; WILL HAVE TYPE CODE IN C
	SETOM	1(TP)		; FENCE POST PDL
	PUSH	P,A
	MOVEI	A,(TB)
	PUSHJ	P,FRMUNG		; MUNG CURRENT FRAME
	POP	P,A
	POPJ	P,


IMPURE

; LOCATION TO REMEMBER PREVIOUS VALUES

SVTAB:	SVLOC1
NXTTAB:	SVLOC2

SVLOC1:	0
SVLOC2:	0

PURE

END