LEX   'SCPLEX'
       TITLE  SCOPE HPIL analyzer, John R Baker
       ID     #5E t50>59
       MSG    0
       POLL   POLHND
*
********************************
* these are HP equates (more or less)
SNAPBF EQU #2F7F0    the snapshot buffer
bLEX   EQU #00BFC    the LEX buffer ID #
LEXPIL EQU #000FF    the HPIL ROM ID #
eXWORD EQU #00023    mainframe error # for XWORD
FNDMB- EQU #03BAB
CHKST+ EQU #03160
sSRQ   EQU #00003
oINHS  EQU #00008
sMSGAV EQU #00000
MBOX^  EQU #2F7A9
Except EQU #0000C
NoCont EQU #0000E
SFLAGC EQU #13601
flAC   EQU #FFFC7
CHIRP  EQU #0EC5A
SFLAGS EQU #135FA
RJUST  EQU #12AE2
HEXDEC EQU #0ECAF
HDFLT  EQU #1B31B
ASRW5  EQU #0ED0A
BLDBIT EQU #019BC
NXTSTM EQU #08A48
ASLW5  EQU #0ED1B
SFLAG? EQU #1364C
I/ORES EQU #118FF
I/OFND EQU #118BA
HEXASC EQU #17148
FUNCR0 EQU #2F89B
BSERR  EQU #0939A
BF2DSP EQU #01C0E
CK"ON" EQU #076AD
SLEEP  EQU #006C2
CKSREQ EQU #00721
POPBUF EQU #010EE
OUTELA EQU #05303
MGOSUB EQU #1AF01
I/OALL EQU #1197D
I/ODAL EQU #11A41
WIPOUT EQU #1B0AF
********************************
* these are my equates
BuFsZe EQU #00F00
kB     EQU #00021
kON    EQU #0002B
kS     EQU #00010
kENDLN EQU #00026
kINC   EQU #00032
kDEC   EQU #00033
k0     EQU #00035
k1     EQU #00027
k2     EQU #00028
sSTORE EQU #00005
sTIME0 EQU #00001
sTIME1 EQU #00002
sTIME2 EQU #00003
sDSPBT EQU #00004
bSCOPE EQU #00FFF
MAXBUF EQU #00FFA
MARKER EQU #00FFF
SCOPON EQU #00005
PTHOME EQU #00006
RESNIB EQU #00007
*
pVER$  EQU #00000
pCONFG EQU #000FB
pSREQ  EQU #000F9
*
       ENTRY  DELBUF
       CHAR   #D
       ENTRY  SCOPE
       CHAR   #D
*
       KEY   'DELSCOPE'
       TOKEN  50
       KEY   'SCOPE'
       TOKEN  51
       ENDTXT
*
********************************
* this is the exit routine for scope mode
*
EXITSM
       GOSUB  I/OCLR
       SETHEX
       C=R3
*
       LC(3)  bSCOPE
       GOSBVL I/OFND
       D1=D1+ SCOPON
       C=0    A
       DAT1=C 1
       A=R3
       B=A    A
       GOSBVL ASRW5
       D1=A
       GOSBVL ASRW5
       D0=A
       ST=0   Except
       ST=0   NoCont
       GOVLNG NXTSTM
*
pSCOPE RTNCC
dSCOPE GOVLNG OUTELA
*
********************************
* this is the start of execution code for scope mode
*
       REL(5) dSCOPE
       REL(5) pSCOPE
SCOPE  P=     0
       CLRST
       SETHEX
       A=0    W
       AD0EX
       GOSBVL ASLW5
       AD1EX
       GOSBVL ASLW5
       A=B    A
*
*
*
*
*
*
*
       R3=A
*
*
       ST=1   sTIME1
*
       LC(3)  bSCOPE
       GOSBVL I/ORES
       GOC    BUF01
       GOSUB  BUFSET
*
BUF01  LC(3)  bSCOPE
       GOSBVL I/OFND
       C=0    A
       D1=D1- RESNIB
       LCHEX  1
       DAT1=C 1
       D1=D1+ RESNIB
       D1=D1+ SCOPON
       LCHEX  9
       DAT1=C 1
       GOSUB  I/OSET
*
dspbuf GOSUB  BSIZE
       P=     0
       GOSBVL HEXDEC
       SETHEX
       C=0    W
       ASL    A
       ASR    A
       P=     3
       C=P    15
       P=     0
       GOSBVL HEXASC
       D1=(5) FUNCR0
       DAT1=A 8
       D1=D1+ 8
       LCASC  'semarF '
       DAT1=C 14
       D1=D1+ 14
       LCASC '     '
       DAT1=C 10
       C=0    W
       P=     14
       LCHEX  #F
       D=C    W
       P=     0
       LC(5)  FUNCR0
       GOSBVL BLDBIT
*
********************************
* this is the start of the scope main loop
* virtually everything falls back to here
*
*
SCOPLP GOSBVL CK"ON"
       GONC   EXIT
       GOTO   SLEPIN
*
EXIT   GOTO   EXITSM
*
* don't insert
* anything here
*
SLEPIN GOSBVL SLEEP
       GONC   INPKBD
       GOSBVL CKSREQ
       P=     0
       LC(3)  bSCOPE
       GOSBVL I/OFND
       D1=D1+ SCOPON
       C=DAT1 A
       P=C    0
       ?P=    8
       GOYES  frmwrk
       P=     0
       LCHEX  9
       DAT1=C 1
       GOTO   SCOPLP
frmwrk
       GOTO INPFRM
*
INPKBD GOSBVL POPBUF
       GOC    SCOPLP
       P=     0
       C=0    A
       LC(2)  kON
       ?C=B   B
       GOYES  EXIT
       LC(2)  kS
       ?C=B   B
       GOYES  STOMOD
       LC(2)  kENDLN
       ?C=B   B
       GOYES  RSTPTR
       LC(2)  kINC
       ?C=B   B
       GOYES  INCPTR
       LC(2)  kDEC
       ?C=B   B
       GOYES  DECPTR
       LC(2)  k0
       ?C=B   B
       GOYES  TIME0
       LC(2)  k1
       ?C=B   B
       GOYES  TIME1
       LC(2)  k2
       ?C=B   B
       GOYES  TIME2
       LC(2)  kB
       ?C=B   B
       GOYES  DSPBUF
       GOTO   SCOPLP
*    ^      ^
* don't insert
* anything here
*    V      V
DSPBUF GOTO   dspbuf
STOMOD GOTO   stomod
RSTPTR GOTO   rstptr
INCPTR GOTO   incptr
DECPTR GOTO   decptr
TIME0  GOTO   time0
TIME1  GOTO   time1
TIME2  GOTO   time2
*
********************************
* this sets the frame time delays
*
time0
       ST=1   sTIME0
       ST=0   sTIME1
       ST=0   sTIME2
       GOSUB  SMDPOP
       NIBASC 'No Delay'
       NIBASC '        '
*
time1
       ST=0   sTIME0
       ST=1   sTIME1
       ST=0   sTIME2
       GOSUB  SMDPOP
       NIBASC '1/4 Seco'
       NIBASC 'nd Delay'
*
time2
       ST=0   sTIME0
       ST=0   sTIME1
       ST=1   sTIME2
       GOSUB  SMDPOP
       NIBASC '1/2 Seco'
       NIBASC 'nd Delay'
*
********************************
* this creates the buffer
*
BUFSET P=     0
       C=0    A
       LC(5)  BuFsZe
       B=C    A
       LC(3)  bSCOPE
       GOSBVL MGOSUB
       CON(5) I/OALL
       GOSUB  BUFini
       LC(3)  bSCOPE
       GOSBVL I/OFND
PTzero D1=D1+ PTHOME
       CD1EX
       D1=C
       D1=D1- PTHOME
       DAT1=C A
       RTN
*
********************************
* this displays the size of bSCOPE in frames
*
BSIZE  LC(3)  bSCOPE
       GOSBVL I/OFND
       C=0    A
       P=     0
       ASL    A
       ASL    A
       ASR    A
       ASR    A
       LCHEX #A
       A=A-C  A
       LCHEX #3
       B=0    A
BSIZE2 A=A-C  A
       GOC    BSIZE1
       B=B+1  A
       GONC   BSIZE2
BSIZE1 A=B    A
       RTN
*
********************************
* this toggles and displays store mode status
*
stomod P=     0
       ?ST=0  sSTORE
       GOYES  SMD01
       ST=0   sSTORE
       GOTO   SMD02
SMD01  ST=1   sSTORE
SMD02  ?ST=0  sSTORE
       GOYES  SMD05
*
*
*
*
*
*
*
*-----------------------
       GOSUB  SMDPOP
       NIBASC 'STORE mo'
       NIBASC 'de  ON  '
*-----------------------
SMD05  GOSUB  SMDPOP
       NIBASC 'STORE mo'
       NIBASC 'de  OFF '
*-----------------------
SMDPOP P=     14
       C=0    W
       LCHEX  F
       D=C    W
       P=     0
       C=RSTK
       GOSBVL BLDBIT
       GOTO   SCOPLP
*
************************
*
* this is the start of the poll handler code
* we start with pVER$
*
POLHND
       ?B=0   B
       GOYES  POL00
       GONC   POLCFG
POL00  C=R3
       D1=C
       A=R2
       D1=D1- (pe)-(ps)-2
       CD1EX
       ?A>C   A
       GOYES  VEX
       D1=C
       R3=C
ps     LCASC ' SCP:C'
pe     DAT1=C (pe)-(ps)-2
VEX    RTNSXM
*
********************************
* this handles pCONFG to save bSCOPE
*
POLCFG
       LC(2)  pCONFG
       ?B=C   B
       GOYES  POL10
       GONC   POLSRQ
POL10  LC(3)  bSCOPE
       GOSBVL I/ORES
       RTNSXM
*
********************************
* this handles poll pSREQ
*
POLSRQ
       LC(2)  pSREQ
       ?B=C   B
       GOYES  POL20
       RTNSXM
*
POL20
       SREQ?
       ?SR=0
       GOYES  POL25
       SR=0
       CSTEX
       ?ST=1  1
       GOYES  POL30
       CSTEX
POL25  C=-C-1 A
       RTNSXM
POL30  CSTEX
       GOTO   pilsrq
*
********************************
* this restores the pointer to home and displays 
* the mnemonic of the frame there
*
rstptr LC(3)  bSCOPE
       GOSBVL I/OFND
       GOSUB  PTzero
       GOSUB  DSPmnm
       GOTO   SCOPLP
*
********************************
* this decodes the 11 bit frame
* and returns mnemonics
*
DSPmnm
       C=ST
       D=C    X
       LC(3)  bSCOPE
       GOSBVL I/OFND
       C=DAT1 A
       D1=C
       C=DAT1 X
DSPfrm ST=C
       ?ST=0  10
       GOYES  doefrm
       ?ST=1  9
       GOYES  idyfrm
       GOTO   cmdrdy
idyfrm ?ST=1  8
       GOYES  idysrq
       GOSUB  dsppop
       NIBASC 'IDY     '
idysrq GOSUB  dsppop
       NIBASC 'IDY SRQ '
doefrm ?ST=0  9
       GOYES  dab
       ?ST=1  8
       GOYES  endsrq
       GOSUB  dsppop
       NIBASC 'END     '
endsrq GOSUB  dsppop
       NIBASC 'END SRQ '
dab    ?ST=1  8
       GOYES  dabsrq
       GOSUB  dsppop
       NIBASC 'DAB     '
dabsrq GOSUB  dsppop
       NIBASC 'DAB SRQ '
cmdrdy
       ?ST=1  8
       GOYES  rdy
       GOSUB  dsppop
       NIBASC 'CMD     '
rdy    GOSUB  dsppop
       NIBASC 'RDY     '
*
dsppop
       A=C    B
       P=     15
       LCHEX  1
       P=     0
       GOSBVL HEXASC
       C=RSTK
       D1=C
       C=DAT1 16
       D1=(5) FUNCR0
       DAT1=C 16
       D1=D1+ 16
       DAT1=A 4
       D1=D1+ 4
       LCASC '      '
       DAT1=C 12
       C=D    X
       ST=C
       C=0    W
       P=     14
       LCHEX  F
       D=C    W
       P=     0
       LC(5)  FUNCR0
       GOSBVL BLDBIT
       RTN
*
********************************
* this initializes the buffer at creation
* new buffers always contain junk!
*
BUFini
       P=     0
       LC(3)  bSCOPE
       GOSBVL I/OFND
       D1=D1+ PTHOME
       LC(5)  (BuFsZe)-(PTHOME)
       GOVLNG WIPOUT
*
       NIBASC 'John R'
       NIBASC ' Baker'
*
*
********************************
* this increments the pointer
*
incptr
       LC(3)  bSCOPE
       GOSBVL I/OFND
       B=0    A
       B=A    X
       AD1EX
       B=B+A  A
       AD1EX
       A=DAT1 A
       AD1EX
       D1=D1+ 3
       AD1EX
       ?A>=B  A
       GOYES  inc01
       DAT1=A A
inc01  GOSUB  DSPmnm
       GOTO   SCOPLP
*
********************************
* this decrements the pointer
*
decptr
       LC(3)  bSCOPE
       GOSBVL I/OFND
       D1=D1+ PTHOME
       CD1EX
       B=C    A
       CD1EX
       D1=D1- PTHOME
       C=DAT1 A
       CD1EX
       D1=D1- 3
       CD1EX
       ?C<B   A
       GOYES  dec01
       DAT1=C A
dec01  GOSUB  DSPmnm
       GOTO   SCOPLP
*
********************************
* this deletes buffer bSCOPE
*
       REL(5) dSCOPE
       REL(5) pSCOPE
DELBUF
       P=     0
       SETHEX
       LC(3)  bSCOPE
       GOSBVL MGOSUB
       CON(5) I/ODAL
       GOVLNG NXTSTM
*
********************************
* this handles pil SRQs
*
pilsrq LC(3)  bSCOPE
       GOSBVL I/OFND
       GOC tstscp
       RTNSXM
*
tstscp 
       D1=D1+ SCOPON
       C=DAT1 1
       P=C    0
       ?P=    9
       GOYES  scpact
       P=     0
       RTNSXM
*
scpact
       P=     0
       GOSUB  getmbx
       C=0    W
       D0=D0+ oINHS
       C=DAT0 1
       ST=C
       ?ST=0  sSRQ
       GOYES  act01
       ST=0   sSRQ
       C=ST
       DAT0=C 1
act01  ?ST=1  sMSGAV
       GOYES  setupM
       RTNSXM
*
setupM
       LC(3)  bSCOPE
       GOSBVL I/OFND
       D1=D1+ SCOPON
       C=0    A
       LCHEX  8
       DAT1=C 1
       RTNSXM
********************************
getmbx
       D0=(5) MBOX^
       C=DAT0 A
       CSL    A
       CPEX   4
       P=     2
       CPEX   4
       D0=C
       RTNCC
*
********************************
* this handles incoming frames
*
INPFRM
       GOSUB  getmbx
       D0=D0+ 10
       P=     0
       ?ST=1  sSTORE is store mode set?
       GOYES  stofrm yes, go store
*
       C=DAT0 6
       B=C    X
frmrtn
       C=ST
       D=C    X
       C=B    X
frm01  GOSUB  DSPfrm
       GOSUB  timdel
       P=     0
       LC(3)  bSCOPE
       GOSBVL I/OFND
       D1=D1+ SCOPON
       LCHEX  9
       DAT1=C 1
       GOTO   SCOPLP
*
********************************
* this stores pil frames if in that mode
*
stofrm C=DAT0 6
       B=C    X
       LC(3)  bSCOPE
       GOSBVL I/OFND
       C=A    A
       D=0    A
       D=C    X
       CD1EX
       D=D+C  A
       CD1EX
       D=D-1  A
       D=D-1  A
       D=D-1  A
       C=DAT1 A
       ?C<D   A
       GOYES  sto01
       ST=0   sSTORE
       C=B    X
       R0=C
       GOSBVL CHIRP
       C=ST
       D=C    X
       C=R0
       GOTO   frm01
sto01  AD1EX
       D1=C
       C=B    X
       DAT1=C X
       D1=D1+ 3
       CD1EX
       AD1EX
       DAT1=C A
       GOTO   frmrtn
*
********************************
* this sets I/O CPU to SCOPE mode
*
I/OSET
       GOSUB  getmbx
       P=     0
       C=0    W
       LCHEX  10080100
       DAT0=C 8
       RTN
*
********************************
* this clears the I/O CPU
*
I/OCLR
       C=0    W
       GOSUB  JUMPER
       CON(5) FNDMB-
       C=0    W
       P=     7
       LCHEX  8
       DAT0=C 9
       GOSUB  JUMPER
       CON(5) CHKST+
       RTN
********************************
* this provides the frame LCD delay
*
timdel 
       ?ST=1  sTIME1
       GOYES  tm1del
       ?ST=1  sTIME2
       GOYES  tm2del
       RTN
tm1del C=0    A
       LCHEX  #3000
       GOTO   del01
tm2del C=0    A
       LCHEX  #8000
del01  C=C-1  A
       GONC   del01
       RTNCC
********************************
*
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