LEX    'LENTERLX'
*
*      NIBASC 'LENTERLX'
*      NIBHEX 802E   LEX type
*      CON(2) 0      flags=0
*      NIBHEX 0000   Mn/Hr
*      NIBHEX 000068 Dy/Mo/Yr
*      REL(5) FILEND
*
       TITLE  Get Data from RS232 Ver<861127> J Baker
*
       CON(2) #5E    last scratch
       CON(2) #4C    see JRBTOKEN for assignment
       CON(2) #4C
       CON(5) 0      no link
       NIBHEX F      no speed
       REL(4) (TxTbSt)+1
       CON(4) 0      no message
       CON(5) 0      no poll
*
*      MAIN TABLE
*
       CON(3) (TxEn01)-(TxTbSt)
       REL(5) RS232
       NIBHEX D      fully programmable
*
*      TEXT TABLE
*
TxTbSt
TxEn01
       CON(1) (TxEnTm)-(*)-4
       NIBASC 'LENTER'         LENTER <device>;<variable>
       CON(2) #4C    see JRBTOKEN for assignment
*
TxEnTm
       NIBHEX 1FF    table end
*
*      EQUATE TABLE
*
GETDID EQU #06D84
eNORDY EQU #0FF22
eMEM   EQU #00018
eDATTY EQU #0001F
FORSTK EQU #2F59E
STMTR0 EQU #2F871
FUNCR0 EQU #2F89B
FUNCD0 EQU (FUNCR0)+32
EXPEXC EQU #0F186
DEST   EQU #0F7B0
DVCSPp EQU #07925
NTOKEN EQU #0493B
t@     EQU #000F4
tSEMIC EQU #000F2
SYNTXe EQU #02E2B
OUTBYT EQU #02CE8
READP5 EQU #0323B
FILDC* EQU #05759
DROPDC EQU #05470
NXTSTM EQU #08A48
STORE  EQU #0F5F8
AVMEMS EQU #2F594
GETDev EQU #00B5B
GETMBX EQU #03B62
PUTE   EQU #06AC0
YTML   EQU #00C9B
GETX   EQU #066B0
FRAME- EQU #0073B
*
************************************************************
*
*
* 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"
bserr  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
*
pute
       GOSUB  JUMPER
       CON(5) PUTE
PILCHK
       RTNNC
       GOTO   Rerror
ytml
       GOSUB  JUMPER
       CON(5) YTML
       GOTO   PILCHK
getx
       GOSUB  JUMPER
       CON(5) GETX
       GOTO   PILCHK
frame-
       GOSUB  JUMPER
       CON(5) FRAME-
       GOTO   PILCHK
*
************************************************************
*      STITLE Execution code
***********************************************************
**
**    Name: LENTER
**
** Purpose: enter bytes from RS232 to string variable
**
**   Entry: D0 at alleged device specifier
**
**    Exit: through NXTSTM unless error
**
**   Calls: GETDID, EXPEXC, DEST, GETMBX, PUTE, (YTML)
**          GETX, FRAME-, STORE, <NXTSTM>
**
**    Uses: everything available to expressions, STMTxx
**
**  Levels: 7
**
**   Notes: terminates on either char match or EOT
**          code also strips trailing CRs and LFs
***********************************************************
*
pGETRS
       ST=0   10     disallow *
       GOSUB  JUMPER
       CON(5) DVCSPp parse device specifier
       GOSBVL NTOKEN fetch next token
       LC(2)  tSEMIC
       ?A=C   B      is it semicolon ?
       GOYES  pGETR1 yes
       GOVLNG SYNTXe no, error
pGETR1
       LC(2)  t@
       GOSBVL OUTBYT write an @ token to terminate device
       LC(2)  tSEMIC
       GOSBVL OUTBYT now write a semicolon token
       ST=1   8      disallow stupid (dummy) arrays
       ST=1   9      parse only a single string variable
       GOVLNG READP5 go parse and exit
*
dGETRS
       GOSBVL FILDC* decompile device
       D1=D1+ 2      step past @ token
       GOVLNG DROPDC decompile variable
*
*
       REL(5) dGETRS
       REL(5) pGETRS
RS232
       GOSUB  JUMPER
       CON(5) GETDID fetch device
       GONC   RS01
Rerror
       P=     0      error if bad
       LC(4)  eNORDY use some convenient error message
       GOTO   bserr
RS01
       ?D#0   B      address given ?
       GOYES  RS04   yes
       C=D    S      no
       P=C    15
       ?P#    5      LOOP ?
       GOYES  Rerror no
       P=     0      yes
RS04
       GOSUB  JUMPER
       CON(5) GETDev
       GOC    Rerror error if not controller
       D1=(5) FORSTK
       A=DAT1 A      read FORSTK pointer
       D1=D1- 5      point to MTHSTK pointer
       AD1EX
       D1=D1- 3      allow for device
       AD1EX
       DAT1=A A      write new stack bottom
       D1=A          point there
       C=D    X
       DAT1=C X      save device
       D0=(5) FUNCD0
       C=DAT0 A
       D0=C          restore D0
       D0=D0+ 4      skip t@ and tSEMIC
       GOSBVL EXPEXC evaluate variable
       GOSBVL DEST   save variable stuff for STORE
       P=     13
       C=P    15     load string type
       P=     0
       ?C=B   S      is this a string variable ?
       GOYES  RS03   yes
RS02
       LC(4)  eDATTY
       GOTO   bserr  no, give type error
RS03
       D0=(5) (STMTR0)+21
       C=0    A
       C=DAT0 4      fetch dimensioned length
       ?C=0   A      null ?
       GOYES  RS02   yes, error
       D1=(5) FORSTK no
       A=DAT1 A      read FORSTK pointer
       D1=D1- 5      point to MTHSTK
       DAT1=A A      collapse mathstack to forstack
       D1=A          point there
       D1=D1- 3      go to device
       C=DAT1 X
       D=C    X      restore device
       D1=A          restore stack
       R0=A          save stack bottom
       D0=(5) AVMEMS
       A=DAT0 A      read memory start
       D0=A
       D0=D0+ 16     allow for a future string header
       AD0EX
       C=R0          fetch stack bottom
       ?A<C   A      collision ?
       GOYES  RS05   no
RS06
       LC(4)  eMEM   yes, load memory error
       GOTO   bserr
RS05
       R2=A          save (memory start)+16
       D0=(5) (STMTR0)+21
       A=0    A
       A=DAT0 4      fetch strings dimensioned length
       B=A    A      save as byte counter
       GOSUB  JUMPER
       CON(5) GETMBX set D0 to mailbox
       LCHEX  F50A00
       GOSUB  pute   set term char to LF
       LCHEX  F40100
       GOSUB  pute   set term on char match mode
       ?D=0   B      LOOP ?
       GOYES  RS07   yes
       GOSUB  ytml   no, set device to talk, me to listen
RS07
       ?B#0   A      count finished ?
       GOYES  RS09   no
RS08
       GOTO   RSEND  yes, exit
RS09
       LCHEX  8FFFFF
       GOSUB  pute   send SDA SOT frame w/no count
       A=R2          fetch memory start
RS10
       ?B=0   A      count finished ?
       GOYES  RS08   yes, exit
       GOSUB  JUMPER no
       CON(5) GETX   fetch I/O processor message
       GOC    RS20   exit if not DOE frame
RS11
       B=B-1  A      decrement count
       D1=D1- 2      allow for byte
       CD1EX
       ?A>=C  A      collision ?
       GOYES  RS06   yes, give memory error
       CD1EX         no, restore D1
       DAT1=C B      write byte
       ?P=    0      single DOE ?
       GOYES  RS10   yes, loop
       P=P-1         no, must be 3 DOE transfer, dec count
       CSR    W
       CSR    A      shift in next to C(B)
       ?B#0   A      count overflow ?
       GOYES  RS11   no
       GOTO   RSEND  yes, terminate, may lose 2 frames!!!!!
RS20
       ?P#    0      ON key abort ?
       GOYES  RSEND  yes, keep previously read bytes
       GOSUB  frame- no, see why we stopped
       ?P=    6      EOT frame ?
       GOYES  RSEND  yes
       ?P=    8      Terminator match ?
       GOYES  RSEND  yes
       P=     0      no, must be an error
       ?D=0   B      LOOP ?
       GOYES  RS22   yes
       LCHEX  145F00 no
       GOSUB  pute   send UNT frame
RS22
       GOTO   Rerror error out
RSEND
       P=     0
       ?D=0   B      LOOP ?
       GOYES  RS30   yes
       LCHEX  145F00 no
       GOSUB  pute   send UNT
RS30
       LCHEX  F40000
       GOSUB  put   clear terminator mode
       C=R0          fetch stack bottom
       AD1EX
       D1=A          swap out stack pointer
       C=C-A  A      compute length
       ACEX   A
       ?A=0   A      null ?
       GOYES  RS32   yes
       LCHEX  0D
       D=C    B      load CR char
       C=DAT1 B      read last char from loop
       ?D#C   B      match ?
       GOYES  RS31   no
       D1=D1+ 2      yes, eliminate
       A=A-1  A
       A=A-1  A      alter count
RS31
       LCHEX  0A
       D=C    B      load LF
       C=DAT1 B      read char
       ?D#C   B      match ?
       GOYES  RS32   no
       D1=D1+ 2      yes, skip
       A=A-1  A
       A=A-1  A      alter count
RS32
       C=0    W
       C=A    A      copy in count
       CSLC
       CSLC
       LCHEX  F      makeup string header
       D1=D1- 16
       DAT1=C W      write it out
       A=C    W      also copy to A(W) for use by STORE
       GOSBVL STORE  write to variable
       GOVLNG NXTSTM exit
*
       END