FORTH
       TITLE  HPILFORTH Ver<851001>, John R Baker
*
***********************************************************
*                    ***>EQUATE TABLE<***
* these equates are supported entry points to HPIL
* access is via JUMPER since HPIL is soft configured
*
GETMBX EQU #03B62 this sets D0 to the current mailbox
PUTE   EQU #06AC0 this puts a 6 nib command to the mailbox
*
***********************************************************
*
       WORD   'REMOTE' word to set HPIL Remote Enable mode
*
       AD0EX
       R0=A          save D0 in R0
       AD1EX
       R1=A          save D1 in R1
       A=B    A
       R2=A          save B(A) in R2
*
       GOSUB  JUMPER
       CON(5) GETMBX set D0 to current mailbox
       P=     0
       LCHEX  149200 value to send a REN frame
*
EXIT
       GOSUB  JUMPER
       CON(5) PUTE   put command to HPIL mailbox
*
       A=R2
       B=A    A      restore B(A))
       A=R1
       D1=A          restore D1
       A=R0
       D0=A          restore D0
*
       RTNCC         return to FORTH
*
***********************************************************
*
       WORD   'NOTREM' this is HPIL Not Remote Enabled mode
*
       AD0EX
       R0=A          save D0 in R0
       AD1EX
       R1=A          save D1 in R1
       A=B    A
       R2=A          save B(A) in R2
*
       GOSUB  JUMPER
       CON(5) GETMBX point to mailbox
       P=     0
       LCHEX  149300 load value for NRE frame
       GOTO   EXIT   continue with common code
*
***********************************************************
*
* JUMPER: a routine for accessing the HPIL ROM
*
SNAPBF EQU #2F7F0    the snapshot buffer
bLEX   EQU #00BFC    the LEX buffer ID #
I/OFND EQU #118BA    finds an I/O buffer given the ID #
LEXPIL EQU #000FF    the HPIL ROM ID #
eXWORD EQU #00023    mainframe error # for XWORD
BSERR  EQU #0939A    the BASIC error reporting routine
*
* this routine is transparent to the CPU except for SB
*
* (assembly code)
* (setup CPU for call)
* GOSUB  JUMPER
* CON(5) (target routine offset)
* (resume assembly code)
*
***********************************************************
*
JUMPER RSTK=C
       CD1EX
       D1=(5) SNAPBF
       DAT1=C A      write D1 @ SNAPBF
       D1=(2) (SNAPBF)+5
       C=RSTK
       DAT1=C W      write C(W) @ SNAPBF + 5
       D1=(4) (SNAPBF)+21
       DAT1=A W      write A(W) @ SNAPBF + 21
       D1=(2) (SNAPBF)+37
       C=B    A
       CPEX   5      save P @ SNAPBF + 42
       P=     6
       C=0    P
       GONC   JUMP05 C:6='0' means carry clear
       C=C-1  P      C:6#'0' means carry set
JUMP05 P=     7
       C=0    P
       C=C-1  P      C:7='9' means decimal mode
       DAT1=C 8      write B(A),P,Carry,mode @ SNAPBF + 37
       SETHEX        set hex mode for I/OFND
************
* now A(W), B(A), C(W), and D1 are available for use
*
       P=     0
       LC(3)  bLEX   find the LEX buffer
       GOSBVL I/OFND
       GONC   JUMP90 if not there, error exit
************
* LEX buffer found; D1 points to it
* search the LEX buffer for the HPIL ROM entry
*
       LC(2)  LEXPIL C(B)=HPIL ROM ID #
       B=C    A
       A=0    A
       A=A+1  A      A(B)=Token # within HPIL ROM
JUMP10 C=DAT1 6
       ?C=0   B      is this the end of the LEX buffer ?
       GOYES  JUMP90 yes, then error exit
       ?B#C   B      is this the right ID ?
       GOYES  JUMP20 no, try the next one
************
* LEX ID matches; see if token # is in range
*
       CSR    W
       CSR    A      C 3:0 is now the token range
       ?A<C   B      too small ?
       GOYES  JUMP20 yes, keep looking
       CSR    A
       CSR    A
       C=C-A  B      if no carry token # is in range
       GONC   JUMP30 in range; go process offset
JUMP20 D1=D1+ 11     not in range; goto next LEX entry
       GONC   JUMP10 B.E.T.
************
* entry to error routine
*
JUMP90 LC(4)  eXWORD "XWORD Not Found"
       GOVLNG BSERR  do not return from error
************
* found the requestted LEX table
*
JUMP30 D1=D1+ 6      point to address of main table
       C=DAT1 A      read main table address into C(A)
       B=C    A
************
* now get target offset from RSTK
*
       C=RSTK        get address of offset
       D1=C          put in D1
       D1=D1+ 5      step over offset field
       CD1EX
       RSTK=C        put final return address back on RSTK
       C=DAT1 A      read offset from main table
       C=C+B  A      add address of main table
       RSTK=C        push target address on RSTK
************
* restore all registers & jump to routine
*
       D1=(5) (SNAPBF)+21
       A=DAT1 W      restore A(W)
       D1=D1+ 16     position to carry/mode/B(A) save area
       C=DAT1 8
       B=C    A      restore B(A)
       P=     7      check mode
       C=C+1  P      if carry; then hex mode
       GOC    JUMP50
       SETDEC        no carry is decimal mode
JUMP50 P=     6
       ?C#0   P
       GOYES  JUMP60 set carry if C:7 # 0
JUMP60 P=C    5      restore P from C:5
       D1=(4) (SNAPBF)+5
       C=DAT1 W      restore C(W)
       D1=(2) SNAPBF
       RSTK=C        save C(A) on RSTK temporarily
       C=DAT1 A
       D1=C          restore D1
       C=RSTK        restore C(A)
       RTN           jump to target routine
*
***********************************************************
*
       END