**********************************************************************
* Name:		PG
* Desc:		General purpose PURGE replacement
* Stack:	(      id --> )
*		(    pict --> )
*		(  tagged --> )
*		( {above} --> )
**********************************************************************
ASSEMBLE
	CON(1)	8
RPL
xNAME PG
::
  CK1&Dispatch
  seco
	XEQPURGEPICT
  TAGGED
	::
	  DUP 'EvalNoCK: xOBJ> DROP
	  DTYPEREAL? NOTcasedrop XEQXPURGE
	  0LastRomWrd!
	  DUP COERCE OFFSRRP
	  ERRSET CKID&CLR
	  ERRTRAP DROP
	  COLA XEQXPURGE  
	;
  idnt
	::
	  DoHere: @ NOT?SEMI
	  DUPTYPERRP? NOTcase PURGEOB
	  DUP ?ClrLastCtxt
	  REFERENCED? ITE PDIROB DELOB
	;
  list
	::
	  RESOROMP xPG
	  SWAP ZERO BEGIN
	    NEXTCOMPOB
	  WHILE
	    4PICK EvalNoCK
	  REPEAT
	  2DROP
	;
  real
	::
	  COERCE			( #romid )

	  ( Find the port the given library is in )
	  CODE
		GOSBVL	=SAVPTR
		GOSBVL	=POP#
		B=A	A		B[A]=romid

		GOSUB	pggxflag
		GONC	purgesx

purgegx		D0=(5)	=G_ROMPTAB
		C=DAT0	A		C[X]=libs
		D0=D0+	3
-		C=C-1	X
		GOC	pgfail
		A=DAT0	A
		D0=D0+	16
		?A<B	X
		GOYES	-
		?A=B	X
		GOYES	+
pgfail		GOVLNG	=GPPushFLoop
+		D0=D0-	8
		C=DAT0	A		C[A]=access
		D0=D0-	5
pgcont		A=DAT0	A		A[A]=address
		GOSUB	pggetport	C[A]=port
		C=C+1	A
		GOC	pgfail		Can't purge ROM library
		C=C-1	A
		R0=C
		GOVLNG	=Push#TLoop	( --> #port TRUE )

purgesx		D0=(5)	=ROMPTAB
		C=DAT0	A		C[X]=libs
		D0=D0+	3
-		C=C-1	X
		GOC	pgfail
		A=DAT0	A
		D0=D0+	8
		?A<B	X
		GOYES	-
		?A#B	X
		GOYES	pgfail
		D0=D0-	5
		C=0	A		No access
		GONC	pgcont		Jump to common code

pggetport	?C=0	A
		GOYES	+
		P=	4
		PC=C
+		C=0	A
		C=C-1	A
		D=C	A
		LC(5)	#70000		RAMSTART in SX
		?ST=0	0
		GOYES	+
		LC(5)	#80000		RAMSTART in GX
+		?A<C	A
		GOYES	pggotport
		D=D+1	A		port++
		D0=(5)	=RAMEND
		?ST=0	0
		GOYES	+
		D0=(5)	=G_RAMEND
+		C=DAT0	A
		?A<C	A
		GOYES	pggotport
		D=D+1	A		port++
		?ST=1	0
		GOYES	gxgetport
		LC(5)	#C0000		Port 2 in SX
		?A<C	A
		GOYES	+
		D=D+1	A		port++
		GONC	pggotport
+		D=D-CON	A,2
		GOTO	pggotport
gxgetport	D0=(5)	=CTAB_STAT1
		C=DAT0	S
		?C#0	S
		GOYES	pggotport
		D=D-CON	A,2
pggotport	C=D	A
		RTN

pggxflag	ST=0	0		Assume SX
		LC(5)	=IRAM@
		CD0EX
		C=DAT0	S
		CD0EX
		C=C+C	S
		RTNNC			CC: SX
		ST=1	0		Flag GX
		RTNSC			CS: GX

	  ENDCODE

	  NOTcase SETPORTNOTAV		( Cannot purge library )

	  :: DUP#0=case TRUE		( can always purge from port 0 )
	     DUP PORTSTATUS		( otherwise check port status )
	     3DROP SWAPDROP		( leave writeable? flag on stack )
	  ;

	  NOTcase SETPORTNOTAV		( Cannot purge - avoid detach too )

	  ( Detach library from HOME )

	  OVER				( #romid #port #romid )
	  CODE
		GOSUB	pggxflag
		GONC	+
		GOSBVL	=GX_SETSRRP
		GONC	++
+		GOSBVL	=SETSRRP
++		D=0	A
		GOTO	pginto		Jump into the loop
-		C=DAT0	A
		?C=A	X
		GOYES	pgoffnow
		D0=D0+	13
pginto		B=B-1	X		libs--
		GONC	-
		GOC	pgoffexit
pgoffnow	D1=D1+	5
		C=DAT1	A
		C=C-1	A		attachments--
		DAT1=C	A
		AD0EX
		LC(5)	13
		GOSBVL	=MOVEDSU	Remove attachment (*safe*)
pgoffexit	GOVLNG	=GETPTRLOOP
	  ENDCODE

	  ( Finally do the purge - so that HACK itself can be purged )
	  ( The code finally does a TOSRRP to recover another library )
	  ( in some other port into use - if there is one. )

	  OVERSWAP GX?			( #romid #romid #port gx? )
	  '
	  :: 0LastRomWrd!
	     OVER #0= ITE
	     :: SWAPDROP ITE G_XPURGEp0 XPURGEp0 ;
	     :: ITE G_XPURGEp XPURGEp ;
	     TOSRRP
	  ;
	  TOTEMPOB COLA_EVAL
	;

;
**********************************************************************