LEX   'INFOLEX'  * A file which can be used on LEX files
        CON(2)   #EC     * October,1988, revised December 1988
        CON(2)   #39     * extra keywords added to take advantage of code
        CON(2)   #3C     * already written
        REL(5)   LINKS   * offset to linked LEX table
        NIBHEX   F       * no speed table
        CON(4)   (TxTbSt)+1-(*) * text table offset
        CON(4) 0         * no message table
        REL(5)   POLHND  * offset to pollhandler (version poll)
        CON(3) (TxEn03)-(TxTbSt) * offset into text table for 1st keyword
        REL(5)  keywd    * relative address of execution code of KEYWORD$
        NIBHEX  F        * characterisation nib for a function
        CON(3) (TxEn01)-(TxTbSt) * same story for each keyword
        REL(5)  HIT    
        NIBHEX  F      
        CON(3) (TxEn02)-(TxTbSt)
        REL(5)  ID     
        NIBHEX  F      
        CON(3) (TxEn04)-(TxTbSt)
        REL(5)  LOT    
        NIBHEX  F      
TxTbSt
TxEn01  CON(1) (TxEn02)-(*)-4 * keyword 'length'= # bytes*2-1
        NIBASC 'HITOKEN' * Syntax: HITOKEN(<filename>[,link #])
        CON(2) #3A       * (error on invalid filetype, must be LEX)
TxEn02  CON(1) (TxEn03)-(*)-4 * default link # is 0
        NIBASC 'ID'      * Syntax: as above
        CON(2) #3B     
TxEn03  CON(1) (TxEn04)-(*)-4
        NIBASC 'KEYWORD$' * Syntax: exactly as for MSG$
        CON(2) #39        * KEYWORD$(iiittt), ttt = token #
TxEn04  CON(1) (TxTbEn)-(*)-4 * iii = ID (leading 0's may be omitted)
        NIBASC 'LOTOKEN' * Syntax: as for ID
        CON(2) #3C     
TxTbEn  NIBHEX 1FF      * text table terminator
POLHND  ?B=0   B        * VER$ poll?
        GOYES  VER$P    * yes
        RTNSXM          * no, go on
VER$P   A=R2            * fetch avmems
        C=R3            * fetch stack pointer
        D1=C           
        D1=D1- (VER$en)-(VER$st)-2 * make room for o/p
        CD1EX           * swap into c(a)
        ?A>C   A        * insufficient mem?
        GOYES  VER$Pe   * exit not handled
        D1=C            * restore stack pointer
        R3=C            * and save for exit
VER$st  LCASC   ' KEYWD:d' * version string
VER$en  DAT1=C (VER$en)-(VER$st)-2 * write to stack
VER$Pe  RTNSXM          * exit poll-handler
MFERR   EQU    #09393   * mainframe error handler
INVFSP  EQU    #066FC   * invalid file specifier error exit
FILXQ$  EQU    #09B95   * filename execute (pops it)
FINDF+  EQU    #09F63   * finds a file (sets D1 to start of file)
HDFLT   EQU    #1B31B   * hex integer to floating point conversion
FNRTN1  EQU    #0F216   * function return
F-R0-0  EQU    #2F89B   * function scratch RAM
ARGERR  EQU    #0BF19   * invalid argument error exit
RNDAHX  EQU    #136CB   * pop as a hex integer
R3=D10  EQU    #03526   * save D0,D1 in R3
IDIVA   EQU    #0EC6E   * A field integer divide
I/OFND  EQU    #118BA   * I/O buffer find
A-MULT  EQU    #1B349   * multiply 2 20 bit integers
D1C=R3  EQU    #03047   * restore pointers from R3
D=AVMS  EQU    #1A460   * put avmems address into D(A)
ADHEAD  EQU    #181B7   * add header to string on stack
BF2DSP  EQU    #01C0E   * send buffer of characters to display
EXPR    EQU    #0F23C   * most general function return
REV$    EQU    #1B38E   * reverse a string on the stack
MFWRN   EQU    #093BC   * send out a warning (used to send msg to display)
FIXDC   EQU    #05493   * FIX decompile
FIXP    EQU    #02A6E   * FIX parse
EXPEXC  EQU    #0F186   * evaluate expression
NXTSTM  EQU    #08A48   * goto NeXTSTMent
ADR$09  EQU    #1C81D   * 17 nibs before 1C824(ADR$10): D1 holds addr.
* by coming in at this point in the code of ADDR$, we allow the mainframe to
* to convert the address pointed to by D1 into a 5 byte string. Quite
* fortuitously and fortunately PC was saved in F-R0-0 and MS pointer in F-R0-1
* This was checked out on a Version CDCC machine and is OK.
bLEX    EQU    #BFC     * ID of LEX buffer
err     GOTO   ERR
        NIBHEX 811       * 1 obligatory numeric parameter
keywd   GOSBVL RNDAHX    * pop it in hex
        GONC   err       * no negatives allowed
        R0=A             * save in R0
        D1=D1+ 16        * point to top of stack
        GOSBVL R3=D10    * save pointers
        A=R0             * recover argument
        GOSUB  DIV       * 1000 decimal
        C=B    B         * copy token # into c
        R0=A             * save ID in R0
        R1=C             * save token # in R1
        LC(5)  bLEX      * load LEX buffer ID
        GOSBVL I/OFND    * find it
        C=R0             * drag back our ID
        B=C    B         * put into C
        A=R1             * and token into A
NEXTID  C=DAT1 6         * copy ID, LOToken,HIToken bytes
        ?C=0   B         * is ID=0?
        GOYES  AVAIL     * whole buffer has been checked,cannot use ID=0
        ?B#C   B         * ID no match?
        GOYES  SKIP      * don't waste effort checking tokens
        CSR    W         * rotate ID byte
        CSR    W         * out of the way
        ?A<C   B         * is our token<LOToken?
        GOYES  SKIP      * not in range
        R2=C             * save LOToken
        CSR    W         * rotate
        CSR    W       
        C=C-A  B         * carry set if token out of range
        GONC   FOUND     * in range!
SKIP    D1=D1+ 11        * step past this LEX buffer entry to the next
        GONC   NEXTID    *BET* (carry cleared in previous line)
AVAIL   ?ST=1  13        * is a program running?
        GOYES  PRGM      * yes, avoid the following display
        GOSUB  POP       * no, we want display
        NIBASC 'ID,Token' * CR/LF omitted to keep display in LCD
        NIBASC ' Availab' * otherwise, null string o/p would push
        NIBASC 'le.'     * display off out of sight
        NIBHEX FF        * buffer terminator byte
POP     C=RSTK           * address of buffer into C
        D1=C             * and D1
        GOSBVL BF2DSP    * send to display now
PRGM    GOSBVL D1C=R3    * restore pointer
        D0=C
        CD1EX
        R1=C             * copy D1 into R1
        CD1EX          
        GOTO   NULL      * exit null string o/p
FOUND   D1=D1+ 6         * step past ID & token bytes
        C=DAT1 A         * read main table address
        D1=C             * set D1 there
        R0=C             * and save address in R0
        C=R1             * recover our token
        A=R2             * and LOToken
        C=C-A  B         * number of tokens-1
        A=0    W         * clear A for multiply
        A=C    B         * 9*(#tokens-1)=offset into main table
        LC(5)  9         * load 9
        GOSBVL A-MULT    * multiply
        C=R0             * recover main table address
        C=C+A  A         * address of our keyword's main table entry
        D1=C             * point D1 there
        A=0    W         * clean up
        A=DAT1 3         * read offset from start of text table
        R1=A             * save this offset
        C=0    A         * clean up C for finding text table offset
        P=     13        * which is found 13 nibs back
        CPEX   0         * now P=0 & C(0)=D
        A=R0             * main table address again
        A=A-C  A         * A(A) set @ text table offset address
        D1=A             * point D1 there
        C=DAT1 4         * read the REL(4)
        A=A+C  A         * add to get text table start
        C=R1             * recover offset from TxTbSt
        A=A+C  A         * add
        D1=A             * D1 now points to our keyword
        D1=D1- 1         * but how long is it ?
        C=0    W         * always cleaning up!
        C=DAT1 1         * read nibblecount nibble
        R2=C             * save
        CPEX   0         * swap into P
        D1=A             * D1 @ text
        A=0    W         * text wil be written to A
        A=DAT1 WP        * but only up to P
        R0=A             * save text in R0
        GOSBVL D1C=R3    * restore pointers
        D0=C
        CD1EX          
        R1=C             * ADHEAD needs address of start of string in R1
        A=R2             * nibblecount
        C=C-A  A         * deduct from top of stack
        C=C-1  A         * 1 more to get whole # of bytes
        D1=C             * D1 now @ end of string's intended place
        A=R0             * recover text
        C=R2             * recover nibblecount
        P=C    0         * count in P
        DAT1=A WP        * write string to stack
NULL    P=     0         * re-entry point for null string
        GOSBVL D=AVMS    * needed
        ST=1   0         * force return
        GOSBVL ADHEAD    * add header
        GOSBVL REV$      * reverse the string
        GOVLNG EXPR      * and output
DIV     C=0    A        * prepare for integer divide
        LCHEX  3E8      * 1000 decimal
        GOSBVL IDIVA    * A field integer divide
        P=     0        * leaves P @ 15
        C=0    A        * for comparisons
        LCHEX  FF       * =255
        ?C<A   A        * is quotient (ID) >255?
        GOYES  ERR      * no good!
        ?C<B   A        * is remainder (token or msg number)>255?
        GOYES  ERR      * throw it out!
        RTN             * all is well, return
ERR     GOVLNG ARGERR
mFERR   GOVLNG MFERR                 
iNVFSP  GOVLNG INVFSP
FIND0   A=0    A         * Popping routine for ID,LOTOKEN,HITOKEN starts here
* FIND0 is also called by FIND2 which is called by codes for MAXMSG, MINMSG,
* MSGADDR$, POLADDR$ ad POLL?
        C=C-1  S         * C(S) holds # of parameters
        C=C-1  S         * carry is set here if there was only 1
        GOC    LBLA      * the 2nd being the link number
        GOSBVL RNDAHX    * which is popped here as a hex integer
        GONC   ERR       * cannot have a -ve # of links
        D1=D1+ 16        * step past the numeric
LBLA    CD1EX          
        D1=(5) (F-R0-0)+16 * this is F-R1-0, scratch RAM
        DAT1=A A         * write the link # to scratch
        D1=C           
        ST=0   4         * ST4 as flag for the above keywords
FIND1   CD0EX            * entry for LINKS pop
        D0=(5) F-R0-0    * scratch
        DAT0=C A         * to save D0
        GOSBVL FILXQ$    * supported entry point to pop a filename off stack
        GONC   iNVFSP    * illegal specifier error
        ?A=0   W         * test for ":PORT[(n)]" file specifier
        GOYES  iNVFSP    * don't want it
        CD1EX            * save the mathstack address
        D1=C
        D0=(5) (F-R0-0)+5 * in F-R0-1
        DAT0=C A
        GOSBVL FINDF+    * then find the file
        GOC    mFERR     * carry set=file or device not found; ERRN in C(3,0)
        A=0    A         * prepare for filetype test
        C=0    A
        D1=D1+ 16        * nibs 17-20 should lie in range E208 to E20B
        A=DAT1 4         * read the filetype nibs
        LC(4)  #E208     * smallest value
        ?A<C   A         * is ours less?
        GOYES  TYPE?     * yes, not LEX; error out
        LC(1)  #B        * alter E208 to E20B
        ?A>C   A         * is ours greater?
        GOYES  TYPE?     * yes, not LEX
        D1=D1+ 16        * move pointer to link-to-next-LEX-table offset
        D1=D1+ 11        * 27 nibs frther on
        ?ST=1  4         * called from LINKS?
        RTNYES           * yes, return
        C=DAT1 A         * read the offset (if 0, no next file linked)
        D0=(5) (F-R0-0)+16  * collect our numeric parameter
        A=DAT0 A         * read it
NXTLNK  ?A=0   A         * is it 0?(1st time means primary LEX table)
        RTNYES           * return (if not 1st time then @ desired link)
        ?C#0   A         * we hope the offset is not 0
        GOYES  OK        * it's alright
        GOTO   ERR       * no, we asked for a nonexistent  link
OK      AD1EX            * use the offset
        A=A+C  A         * to step to the next linked table
        AD1EX            * D1 @ next LEX table
        A=A-1  A         * decrement required number of links
        D1=D1+ 6         * step past ID & token bytes
        C=DAT1 A         * read offset to next table
        GONC   NXTLNK    * Branch Every Time
TYPE?   LCHEX  3F        * ERN=63
        GOTO   mFERR     * ERR: Invalid File Type (chirp!)
        NIBHEX 8412      * obligatory string, optional numeric
HIT     GOSUB  FIND0     * pop what parameters there are & point to link
        D1=D1- 2         * back 2 nibs for HIToken byte
        GONC   FINISH    *BET*
        NIBHEX 8412      * as above
ID      GOSUB  FIND0     * ditto
        D1=D1- 6         * point to ID byte
        GONC   FINISH    *BET*
        NIBHEX 8412     
LOT     GOSUB FIND0     
        D1=D1- 4         * point to LOToken byte
FINISH  A=0    A         * common exit
        A=DAT1 B         * read the appropriate byte
OUT2    GOSBVL HDFLT     * float the hex integer
        D0=(5) (F-R0-0)+5 * back to scratch for the mathstack address
        C=DAT0 A         * read it
        D1=C             * reset it
        D0=D0- 5         * shift along a bit (actually 20 bits)
        C=DAT0 A         * read PC
        D0=C             * reset it
        C=A    W         * copy result to C for output
        GOVLNG FNRTN1    * send it out.
        NIBHEX 411       * 1 obligatory string
LINK    ST=1   4         * flag to indicate LINKS call to FIND routine
        GOSUB  FIND1     * cut in after numeric pop
        C=DAT1 A         * read offset to next table
        A=0    A         * result counter in A(A)
NEXT    ?C=0   A         * is the offset 0?
        GOYES  OUT2      * yes, no [more] links
        AD1EX            * no, swap A & D1
        A=A+C  A         * to add the offset
        AD1EX            * position D1 to start of next LEX table
        A=A+1  A         * increment counter
        D1=D1+ 6         * step past ID & token bytes
        C=DAT1 A         * read next offset
        GONC   NEXT      *BET* loop back for test
* This was my succesful attempt to write a linked LEX file. The main reason
* was that the tokens after that of LOTOKEN had already been used, and I
* did not wish to duplicate existing code. I added LINKS in this manner in
* October then in early December I decided that the code could be further
* used constructively. So here it is. Note that MAXMSG, MINMSG and POLL?
* return the equivalent of FFFFF in decimal if there is no MSGTBL or POLHND,
* respectively, and further, if the code at the start of the poll-handler
* is more complex than:
* polhnd  ?B=0   B , or
* polhnd  LCHEX  nn
*         ?C=B   B, then that FFFFF equiv appears again and the msg(232)
* ' Not Found' is displayed. The two address functions return '00000' if
* there is no msgtbl or polhnd. MSGDISP takes a single numeric parameter
* identical to that of MSG$.
LINKS   CON(2) #EE      * (ID=238) It is here that the REL(5) in line 5 points
        CON(2) #EE      * lotoken=238
        CON(2) #F4      * hitoken=244
        CON(5) 0        * no further link
        NIBHEX F        * no speed table
        CON(4) (TXTBST)+1-(*) * offset to text table
        CON(4) 0        * no message table
        CON(5) 0        * no pollhandler
        CON(3) 0        * offset into text table (for 1st keyword)
        REL(5) LINK     * relative offset to execution code
        NIBHEX F        * a function
        CON(3) (TXENEF)-(TXTBST) * o/s 2nd kwd
        REL(5) MAX      * to execution code
        NIBHEX F        * function
        CON(3) (TXENF0)-(TXTBST)
        REL(5) MIN
        NIBHEX F
        CON(3) (TXENF1)-(TXTBST)
        REL(5) MADDR
        NIBHEX F
        CON(3) (TXENF2)-(TXTBST)
        REL(5) DISP     * execution code of MSGDISP
        NIBHEX D        * a statement
        CON(3) (TXENF3)-(TXTBST)
        REL(5) PADDR
        NIBHEX F
        CON(3) (TXENF4)-(TXTBST)
        REL(5) POLL?
        NIBHEX F
TXTBST  CON(1) (TXENEF)-(*)-4 * length of keyword in nibs less 1
        NIBASC 'LINKS'  * the keyword, Syntax: LINKS(<filename>)
        CON(2) #EE      * its token
TXENEF  CON(1) (TXENF0)-(*)-4
        NIBASC 'MAXMSG' * Syntax: MAXMSG(<filename>[,n]) as for ID etc.
        CON(2) #EF
TXENF0  CON(1) (TXENF1)-(*)-4
        NIBASC 'MINMSG' * Syntax: as for ID
        CON(2) #F0
TXENF1  CON(1) (TXENF2)-(*)-4
        NIBASC 'MSGADDR$' * Syntax: as for ID
        CON(2) #F1
TXENF2  CON(1) (TXENF3)-(*)-4
        NIBASC 'MSGDISP' * Syntax: as for KEYWORD$
        CON(2) #F2
TXENF3  CON(1) (TXENF4)-(*)-4
        NIBASC 'POLADDR$' * Syntax: as for ID
        CON(2) #F3
TXENF4  CON(1) (TXTBEN)-(*)-4
        NIBASC 'POLL?'  * Syntax: as for ID
        CON(2) #F4
TXTBEN  NIBHEX 1FF      * end of text table
FIND2   GOSUB  FIND0
        D1=D1+ 5        * point past link offset
        A=0    A
        A=DAT1 1        * read speed table nib
        ?A#0   A        * if no table, should be F, else 0-spdtbl-0
        GOYES  nospd    * no table
        C=0    A
        LCHEX  4F       * spdtbl uses 78 nibs, with a 0 nib before & after
        AD1EX
        A=A+C  A        * add 79 for one 0 and spdtbl
        AD1EX
nospd   D1=D1+ 5        * speed table nib + 4 nibs for text table offset
        RTN             * return pointing at msgtbl offset
msg     P=     13       * routine for sending out msg
        LCHEX  F1
        P=     2
        GOVLNG MFWRN
fixdc   GOVLNG FIXDC
fixp    GOVLNG FIXP
Errr    GOTO   ERR
        REL(5) fixdc
        REL(5) fixp
DISP    GOSBVL EXPEXC   * evaluate expression pointed to by D0, put on stack
        GOSBVL RNDAHX   * pop as a hex integer
        GONC   Errr     * message args can't be negative
        GOSUB  DIV      * split into ID & msg #
        ASL    A        * rotate ID byte into into A(3,2)
        ASL    A
        A=B    B        * copy msg# into A(1,0), ie A(B)
        C=0    W        * want total msg no in C(3,0)
        C=A    A
        GOSUB  msg      * send message out
        GOVLNG NXTSTM   * continue
        NIBHEX 8412     * as for ID
MIN     ST=1   3        * ST3 distinguishes MINMSG & MAXMSG
        GOTO   MAXMIN
        NIBHEX 8412
MAX     ST=0   3
MAXMIN  GOSUB  FIND2    * point to msgtbl o/s
        A=0    A
        A=DAT1 4        * read o/s
        ?A=0   A        * is it 0?
        GOYES  nomsg    * yes, no msgtbl
        CD1EX           * no, there is a table
        C=C+A  A        * add o/s
        D1=C            * point to actual table
        ?ST=1  3        * min message?
        GOYES  LOMSG    * yes, poining at low msg #
        D1=D1+ 2        * no, point to high msg #
LOMSG   GOTO   FINISH   * exit through existing o/p routine
nomsg   A=0    A        * if no msgtbl,o/p 1048575 (unrealistic enough?)
        A=A-1  A        * A(A)=FFFFF
        GOTO   OUT2
        NIBHEX 8412
POLL?   GOSUB  FIND2
        D1=D1+ 4        * point past msgtbl o/s to polhnd o/s
        A=0    A
        A=DAT1 A        * read it
        ?A=0   A        * is it 0?
        GOYES  nomsg    * same o/p as for no msgtbl
        CD1EX
        A=A+C  A        * point to poll-handler
        D1=A            * with D1
        LCHEX  969      * this is code for ?B=0  B
        A=DAT1 A
        ?A#C   X        * is this not 1st instruction in code?
        GOYES  NOTVER   * yes, not version poll
        A=0    A        * no, it is, so process number is 0
        GOTO   OUT2     * o/p a 0
NOTVER  A=DAT1 1        * 1st nib of LCHEX is 3, 2nd is # nibs to load
        C=0    A
        P=     3        * putting a 3 into C(0)
        CPEX   0
        ?A#C   P        * do we not have a 3?
        GOYES  notfnd   * o/p FFFFF & Not Found message (too complicated)
        D1=D1+ 2        * point to nibs for loading into C
        GOTO   FINISH   * this will read the next byte & o/p process #
notfnd  C=0    W
        LCHEX  E8       * =232
        GOSUB  msg      * send out msg
        GOTO   nomsg    * o/p ridiculous answer
        NIBHEX 8412
MADDR   GOSUB  FIND2
        A=0    A
        A=DAT1 4        * read msgtbl o/s
        GOTO   MADPAD
        NIBHEX 8412
PADDR   GOSUB  FIND2
        D1=D1+ 4        * point to polhnd o/s
        A=0    A
        A=DAT1 A        * read it
MADPAD  ?A#0   A        * non-zero?
        GOYES  OUT3
        D1=A            * A(A)=00000
        GOTO   ADR10
OUT3    CD1EX           * D1 into C
        C=C+A  A        * add o/s
        CD1EX           * back in D1
ADR10   GOVLNG ADR$09   * my name for 'entry point'.