**********************************************************************
* Name:		XRCL
* Stack:	(       id --> ob   )
*		(      lam --> ob   )
*		(      $bz --> ob   )
*		(     pict --> grob )
*		(     romp --> ob   )
*		(   accptr --> ob   )
*		(    #addr --> ob   )
*		( hxs_addr --> ob   )
*		(   {path} --> ob   )
*		(   {seco} --> seco )
*		(   {romp} --> ob   )
*		(    %port --> obs  )
*		(     %lib --> lib  )
*		(   :&:lib --> lib  )	lib is % or hxs
*		(:port:lib --> lib  )
*		(  :x:name --> ob   )
*
* Desc:		General purpose RCL replacement
* Calls:	BZ to uncompress
**********************************************************************
ASSEMBLE
	CON(1)	8
RPL
xNAME XRCL
::
  CK1&Dispatch
  str	xBZ
  idnt	XEQRCL
  lam	XEQRCL
  seco	PICTRCL
  romp	:: ROMPTR@ ?SEMI SETROMPERR ;
  list
	::
	  DUPLENCOMP #1<> case LISTRCL
	  DUP CARCOMP DTYPECOL? case SWAPDROP
          DUPTYPEROMP? NOTcasedrop LISTRCL
          SWAPDROP ROMPTR@ ?SEMI SETROMPERR
	;
  hxs
	::
	  HXS>#
	  CODE
		GOSBVL	=POP#
		GOVLNG	=PUSHA
	  ENDCODE
	;
  bint
	  CODE
		GOSBVL	=POP#
		GOVLNG	=PUSHA
	  ENDCODE
  accptr
	:: GX? case ?ACCPTR> SETTYPEERR ;
  real
	::
	  COERCE
	  GX? ITE THIRTYTHREE TWO
	  OVER#< NOTcase
	  ::				( * Get port contents * )
	    GetBVars >PortIds
            UNCOERCE
	  ;
	  ZEROSWAP			( * Search ports for library * )
	  GX? ITE THIRTYTHREE THREE
	  ZERO_DO (DO)
	     INDEX@
	     GX? ITE G_X@ S_X@	  
	     IT
	     ::
	       GX? IT ?ACCPTR>
	       ROT#1+ ROT
	       INDEX@ UNCOERCE UNROT
	     ;
	  LOOP
	  DROP #0=case SETNOLIBERR	( * Error if found none * )
	;
  TAGGED
	::
	  DUP
	  GX? ITE G_TAG> TAG>
	  SWAP				( * Check for library number body * )
	  DUPTYPEREAL? IT COERCE
	  DUPTYPEHSTR? IT HXS>#
	  DUPTYPEBINT? NOTcase
	  :: 2DROP XEQXRCL ;		( * Recall backup object * )

	  ROTDROPSWAP			( #lid "port" )

	  tok& tok=casedrop		( * Recall from any port * )
	  ::
	    ZERO GX? ITE

* The following code objects were written for recalling the N'th
* library from the romptab. Here N is always 0 to recall the active
* library.

	    CODE			( * Search LID from GX * )
		GOSBVL	=POP2#		A[A]=lid C[A]=0
		RSTK=C
		GOSBVL	=SAVPTR
		D0=(5)	=G_ROMPTAB
		C=DAT0	A
		D=C	A		D[X]=libs
		D0=D0+	3
		C=RSTK
		B=C	A		B[A]=N
xrclgxloop	D=D-1	X		libs--
		GOC	xrclgxfail
		C=DAT0	A
		D0=D0+	16
		?A#C	X
		GOYES	xrclgxloop
		B=B-1	A		N--
		GONC	xrclgxloop
		D0=D0-	13
		GONC	+
xrclgxfail	GOVLNG	=GPPushFLoop
+		A=DAT0	A
		D0=D0+	5
		C=DAT0	A
		?C=0	A
		GOYES	xrcllibrary
		GOTO	xrclgxacp
xrcllibrary	D0=A			* Push library segment
		GOSBVL	=TRAVERSE-
		D0=D0-	10
		A=DAT0	A
		LC(5)	=DOLIB
		?A#C	A
		GOYES	+
		AD0EX			* Push library object
		GOSBVL	=GPPushA
		GOVLNG	=DOTRUE
+		D0=D0+	5		* Create and push library object
		C=DAT0	A		libsize
		AD0EX
		R2=A.F	A
		C=C+CON	A,5
		GOSBVL	=GETTEMP
		A=R2.F	A
		AD0EX
		D1=A
		R0=A.F	A
		LA(5)	=DOLIB
		DAT1=A	A
		D1=D1+	5
		C=C-CON	A,5
		GOSBVL	=MOVEDOWN
		A=R0.F	A
		GOSBVL	=GPPushA
		GOVLNG	=DOTRUE
xrclgxacp	R3=A.F	A		* Fetch covered library
		R4=C.F	A
		GOSUB	xrcltosafe:
		GOSUB	xrclaccess	----------------+ THIS SEGMENT
		A=R3.F	A				| IS COPIED TO THE
		D0=A					| UART_BUFFER
		GOSBVL	=TRAVERSE-			| FOR SAFE EVALUATION
		D0=D0-	5				|
		A=DAT0	A				|
		A=A+CON	A,5				|
		D0=D0-	5				|
		CD0EX					|
		R0=C.F	A				|
		P=	1				|
		GOSUB	xrclaccess			|
		P=	3				|
		GOSUB	xrclaccess			|
		GOC	xrclmemerr			|
		A=R0.F	A				|
		D0=A					|
		LC(5)	=DOLIB				|
		DAT0=C	A				|
		GOSBVL	=GPPushA			|
		GOVLNG	=DOTRUE				|
xrclmemerr	GOVLNG	=GPMEMERR			|
xrclaccess	C=R4.F	A				|
		PC=C			----------------+
xrcltosafe:	A=PC
		C=RSTK
		D0=C
		C=A-C	A
		D1=(5)	=G_uart_buffer
		GOSBVL	=MOVEDOWN
		GOVLNG	=G_uart_buffer
	    ENDCODE

	    CODE			( * Search LID from SX * )
		GOSBVL	=POP2#
		RSTK=C
		GOSBVL	=SAVPTR
		D0=(5)	=ROMPTAB
		C=DAT0	A
		D=C	A
		D0=D0+	3
		C=RSTK
		B=C	A
xrclsxloop	D=D-1	X
		GOC	xrclsxfail
		C=DAT0	A
		D0=D0+	8
		?A#C	X
		GOYES	xrclsxloop
		B=B-1	A		N--
		GONC	xrclsxloop
		D0=D0-	5
		GONC	+
xrclsxfail	GOVLNG	=GPPushFLoop
+		A=DAT0	A
		GOTO	xrcllibrary
	    ENDCODE	    

	    ?SEMI SETNOLIBERR	 
	  ;

	  palparse NcaseTYPEERR		( * Recall from specific port * )
	  CKREAL COERCEDUP		( #lid #port #port )
	  GX? ITE THIRTYTHREE TWO
	  #>case SETPORTNOTAV		( #lid #port )
	  ::				( * Check if port exits * )
	    DUP#0= ?SEMI
	    DUP PORTSTATUS
	    4ROLL 3DROP NOTAND		( present and not merged ? )
	    ?SEMI
	    SETPORTNOTAV
	  ;
	  GX? ITE G_X@ S_X@
	  NOTcase SETNOLIBERR
	  SWAPDROP
	  GX? IT ?ACCPTR>
	;
;
**********************************************************************