Jump to content
webdeck

Original TI Source Code

Recommended Posts

I am wondering how much of original TI source code is available out there.  Not decompiled source from ROMs/GROMs, but the original source with comments, which can be a treasure trove of information.

 

What I have found so far:

  • TI-99/4A Console ROM source code (included in The Cyc)
  • RXB purchased the Extended Basic ROM and GROM source code (RXB source code)

 

Is there anything else out there?

  • Like 1

Share this post


Link to post
Share on other sites
20 minutes ago, webdeck said:

I am wondering how much of original TI source code is available out there.  Not decompiled source from ROMs/GROMs, but the original source with comments, which can be a treasure trove of information.

 

What I have found so far:

  • TI-99/4A Console ROM source code (included in The Cyc)
  • RXB purchased the Extended Basic ROM and GROM source code (RXB source code)

 

Is there anything else out there?

ET at Sea, but was incomplete.

 

Share this post


Link to post
Share on other sites

TI Forth source is available as CV182.DSK (“03NOV82”) and CV183.DSK (“08DEC82”) on WHTech. The support code is pretty well documented, but the word definitions in the resident dictionary have little to no documentation. In a way, you could say they are self-documenting because they are mostly DATA statements composed of lists of execution addresses (cfas) that are mnemonic. and follow corresponding high-level Forth code. I have added  my own comments to a lot of the code (though not much of the dictionary code) in “Appendix O TMS9900 Assembly Source Code for TI Forth” in my second edition of the TI Forth Manual available in the “Forth – Software” section of the first post of TI-99/4A development resources.

 

...lee

Share this post


Link to post
Share on other sites

Thanks for the pointer to the development resources thread - great stuff there.  I'm surprised that more original source code hasn't surfaced over the years, like the GPL source for GROMs 0-2.

Share this post


Link to post
Share on other sites

Source code for the BASIC Support Module, the 99/8, and several other utilities are also out there. Source for a few third-party items are also available, like the entire set of source code for the Myarc Geneve and the Personality Card.

Share this post


Link to post
Share on other sites

I would have liked the source code for the p-code card as well as at least a kernel unit with interface code (which is delivered with many p-systems, but not the one for the TI 99/4A).

Share this post


Link to post
Share on other sites
16 minutes ago, apersson850 said:

I would have liked the source code for the p-code card as well as at least a kernel unit with interface code (which is delivered with many p-systems, but not the one for the TI 99/4A).

There is PSystem source code for the Geneve for MDOS mode that is out there.

 

Beery

Share this post


Link to post
Share on other sites
On 9/27/2020 at 1:34 PM, FarmerPotato said:

TI writer and Editor Assembler. There’s a thread somewhere. 

REA has source code for Editor Assembler but have to go back to RXB Version 1005 to see it.

Oh and I released Disk Manager 4 which at time was updated TI version.

Disk Manager Cart that you could use 9 Disks, RAMDISK and even demo a GPL fake Disk drive. 

  • Like 1

Share this post


Link to post
Share on other sites

If you know the links to the items that are "out there" somewhere (or at least the thread if it's on this forum), please add them either here or to the main developer resources thread so they're all in one place.

  • Like 1

Share this post


Link to post
Share on other sites

Should I be posting the Source Codes for people?

 

Disk Manager Source

Editor Assembler Source

XB GPL and ROM source

ET AT SEA GPL source

  • Like 2
  • Thanks 1

Share this post


Link to post
Share on other sites

I found some ARK files that look interesting, judging from the file name. Can I view them on something else than a real machine? Simulator? Or is there some program for Windows that opens them directly?

Share this post


Link to post
Share on other sites

If you import the ARK files on a DSK image, you can easily view them with TIImageTool.

  • Like 1

Share this post


Link to post
Share on other sites
On 9/30/2020 at 1:21 AM, RXB said:

Should I be posting the Source Codes for people?

 

Disk Manager Source

Editor Assembler Source

XB GPL and ROM source

ET AT SEA GPL source

Please do so, Rich. Source code is always good. . .

  • Like 4

Share this post


Link to post
Share on other sites
Spoiler

 
********************************************************************************
* DISK MANAGER 5 * by RICH GILBERTSON * UPGRADE OF Disk Manger II module by TI *
********************************************************************************
*
* FLAGS
*
N      EQU   0
YN     EQU   1
NUMBER EQU   2
Y      EQU   2
TWO    EQU   >32
THREE  EQU   >33
FOUR   EQU   >34
NINE   EQU   >39
*
* KEYS
*
CLEAR  EQU   2
REDO   EQU   6
DOWN   EQU   10
PROCD  EQU   12
BEGIN  EQU   14
BACK   EQU   15
SPACE  EQU   32
*
* GROM
*
G0000  EQU   >0000
*
* CPU
*
MBASE  EQU   >8300
REDOX  EQU   >8306
BEGINX EQU   >8308
BACKX  EQU   >830A
SCRADD EQU   >830C            * SCReen ADDress
SECNUM EQU   >8316            * SECtor NUMber
DSKNUM EQU   >8318            * DiSK NUMber
IOSEC  EQU   >8319            * Input Output SECtor bit
BUFADD EQU   >831A            * BUFfer ADDress
MCFLAG EQU   >8329            * Master/Copy FLAG
LOGFLG EQU   >832A            * LOG FLaG
ACODE  EQU   >832D            * Access CODE
DFLAG  EQU   >832E            * Disk FLAG
ONEDSK EQU   >8330            * ONE DiSK flag
OVROW  EQU   >8339            * Old Vertical ROW
OVCOL  EQU   >833A            * Old Vertical COL
CURSOR EQU   >833D
OUTFLG EQU   >833E            * OUTput FLAG for catalog device
ABORTF EQU   >833F            * ABORT Flag
ADINFO EQU   >8340            * ADditional INFO buffer offset
MESNUM EQU   >8349            * MESsage NUMber
FAC    EQU   >834A
FAC1   EQU   >834B
FAC2   EQU   >834C
FAC3   EQU   >834D
FAC4   EQU   >834E
FAC5   EQU   >834F
FAC6   EQU   >8350
FAC7   EQU   >8351
FAC8   EQU   >8352
FAC9   EQU   >8353
ERCODE EQU   >8354
FAC11  EQU   >8355
FAC12  EQU   >8356
FAC13  EQU   >8357
FAC17  EQU   >835B
ARG    EQU   >835C
ARG1   EQU   >835D
ARG2   EQU   >835E
MEMSIZ EQU   >8370
DATSTK EQU   >8372
SUBSTK EQU   >8373
KEY    EQU   >8375
ITIMER EQU   >8379
STATUS EQU   >837C
VCHAR  EQU   >837D
VROW   EQU   >837E
VCOL   EQU   >837F
*
* VDP
*
VBUFF  EQU   >0B10            * Vdp BUFFer
VLEN   EQU   >0B19            * Length byte
NUMAU  EQU   >0C12            * NUMber of AUs
SECTRK EQU   >0C14            * SECtors per TRacK
SAVCPU EQU   >0C28            * SAVe CPU >0C28 - >0C72 (>8300 - >834A)
TRACKS EQU   >0C1C            * Number of TRACKS
DMAST  EQU   >0C72
DCOPY  EQU   >0C8A
SIDES  EQU   >0E10            * Number of SIDES
DENSTY EQU   >0E11            * DENSITY
********************************************************************************
       GROM >6000
       TITL 'DM 2 GROM >6000'
       DATA >AA02,>0100,>0000,MENU1,>0000,>0000,>0000,>0000
 
       AORG >002A
***************************** COPY FILE ****************************************
FCOPY  DST   FCOPY,@REDOX
       CALL  HEADER           * 'COPY FILE'
       BYTE  >24
FCOPY2 CALL  GETDRIVEGETINPUT         * 'MASTER DISK (1-9)?'
       BYTE  >03,>FF,>FF,>FF,>FF,>FF  * >03 = VROW
       BYTE  >4F,>00                  * >4F = 'FILENAME?'
       CALL  FILECOPY
       CALL  CMDDONE
       BR    FCOPY2
***************************** RENAME FILE **************************************
FRENA  DST   FRENA,@REDOX
       CALL  HEADER           * 'RENAME FILE'
       BYTE  >25
       CALL  GETDRIVEGETINPUT         * 'MASTER DISK (1-9)?'
       BYTE  >03,>FF,>FF,>00,>FF,>34  * >03 = VROW
       BYTE  >34,>00                  * >34 = 'NEW FILENAME?'
       DST   >0C75,@FAC6      * POINTER TO OLD BUFFER NAME
       DST   >0C8D,@FAC4      * POINTER TO NEW BUFFER NAME
       ST    [email protected],@FAC2    * DRIVE NUMBER
       CALL  RENAME
       CALL  CHKERR
       CALL  CMDDONE
       BR    FRENA
***************************** DELETE FILE **************************************
FDEL   CALL  HEADER           * 'DELETE FILE'
       BYTE  >26
       DST   FDEL,@REDOX
       CALL  DSPLY            * 'SELECTIVE (Y/N)?'
       BYTE  >FE,>03,>62,>FF
       CALL  INKEY
       BYTE  YN,>0C,>10,Y
       CEQ   >02,[email protected]>0C10      * Y?
       BS    FDEL3            * Yes
FDEL2  CALL  GETDRIVEGETINPUT * 'MASTER DISK (1-9)?'
       BYTE  >04,>FF,>FF,>00  * >04 = VROW
       BYTE  >00,>FF
       ST    [email protected],@DSKNUM  * DRIVE NUMBER
       CALL  DELETE
       CALL  CMDDONE
       BR    FDEL2
FDEL3  CALL  GETDRIVEGETINPUT * 'MASTER DISK (1-9)?'
       BYTE  >04,>00,>00,>00  * >04 = VROW
       BYTE  >00,>00
       CALL  BLINES
       BYTE  >03,>08
       DST   >0302,@VROW
       CALL  CATALOGER
       CALL  DSPLY            * ' FILENAME   SIZE    TYPE   P'
                              * '__________  ____   _______ _'
       BYTE  >FE,>06,>38,>FF
FDEL4  DCZ   V*>8302          * FILE COUNTER
       BS    FDEL8
       DST   >0802,@VROW
       CALL  STEPFILE
       CALL  BLINES
       BYTE  >12,>17
       CALL  DSPLY            * 'DELETE (Y/N)?'
       BYTE  >FE,>0B,>45,>FF
       CALL  INKEY
       BYTE  YN,>0C,>1E,N
       CZ    [email protected]>0C1E          * N? DELETE
       BS    FDEL7            * No
       CLOG  >08,[email protected]>0E1E      * FILE PROTECTED?
       BS    FDEL5            * No
       CALL  OVERIDEPROTECT
       CZ    [email protected]>0C20          * N? OVERRIDE
       BS    FDEL7            * No
       CALL  PROTECTION       * UNPROTECT OR PROTECT
       BYTE  >0C,>75,>0C,>72
FDEL5  CALL  DELETE
       CEQ   >F8,@DFLAG
       BR    FDEL6
       DDECT @>8302           * FILE COUNTER-1
FDEL6  CALL  BLINES
       BYTE  >0D,>0D
FDEL7  CALL  WORKNG           * SKIP FILE AND GET NEXT FILE
       PUSH  @>8302
       PUSH  @>8303
       CALL  BLINES
       BYTE  >08,>12
       DST   >0302,@VROW
       CALL  CATALOGER
       ST    *STATUS,@>8303
       ST    *STATUS,@>8302
       B     FDEL4
FDEL8  CALL  CMDDONE
       BR    FDEL
***************************** MODIFY FILE PROTECTION ***************************
FMODP  CALL  HEADER           * 'MODIFY FILE PROTECTION'
       BYTE  >28
       DST   FMODP,@REDOX
FMODP2 CALL  GETDRIVEGETINPUT * 'MASTER DISK (1-9)?'
       BYTE  >03,>FF,>FF,>00  * >03 = VROW
       BYTE  >00,>00
       DST   FMODP2,@REDOX
       CALL  DSPLY            * 'PROTECT (Y/N)?'
       BYTE  >FE,>07,>46,>FF
       CALL  INKEY
       BYTE  YN,>0C,>20,N
       CALL  WORKNG
       DST   >0C75,@FAC4      * POINTER TO BUFFER NAME
       ST    [email protected],@FAC2    * DRIVE NUMBER
       CLR   @FAC3            * UNPROTECT
       CZ    [email protected]>0C20          * N? PROTECT
       BS    FMODP3           * No
       INV   @FAC3            * PROTECT
FMODP3 CALL  PROTCT
       CALL  CHKERR
       CALL  CMDDONE
       BR    FMODP
***************************** CATALOG DISK *************************************
DCAT   CALL  HEADER           * 'CATALOG DISK'
       BYTE  >2A
       DST   DCAT,@REDOX
       CALL  GETDRIVEGETINPUT * 'MASTER DISK (1-9)?'
       BYTE  >03,>FF,>00,>00  * >03 = VROW
       BYTE  >00,>00
       CALL  DSPLY            * 'WHERE DO YOU WANT LISTING?'
                              * '1 SCREEN        '
                              * '2 SOLID STATE PRINTER         '
                              * '3 PIO INTERFACE               '
                              * '4 OTHER'
                              * 'YOUR CHOICE?'
       BYTE  >FE,>06,>40,>F5,>41,>F5
       BYTE  >4E,>FF
       CALL  INKEY
       BYTE  NUMBER,>0C,>25,FOUR
       ST    [email protected]>0C25,@KEY
       DEC   @KEY
       CASE  @KEY
       BR    DCAT4            * Screen
       BR    DCAT1            * Thermal Printer
       BR    DCAT2            * PIO
       BR    DCAT3            * Device input
DCAT1  ST    >02,[email protected]>0CCF      * LENGTH BYTE
       DST   >5450,[email protected]>0CD0    * TP output
       B     DCAT4
DCAT2  MOVE  4,[email protected],[email protected]>0CCF * Length byte
       B     DCAT4
G61B1  STRI  'PIO'
DCAT3  CALL  DSPLY            * 'DEVICE NAME?'
       BYTE  >FE,>0C,>50,>F5,>FF
       CALL  GETDEVICENAME    * GET DEVICE NAME
       BYTE  >0C,>D0,>38,>0C,>CF
DCAT4  CALL  WORKNG
       CALL  DSPLY            * 'PRESS :         '
                              * '                '
                              * 'CLEAR TO ABORT COMMAND'
       BYTE  >FE,>16,>5C,>FF
       ST    [email protected],@DSKNUM  * DRIVE NUMBER
       CLR   @OUTFLG          * OUTPUT FLAG OFF
       CEQ   >02,[email protected]>0C21
       BR    DCAT5
       CEQ   >01,[email protected]>0C23
       BR    DCAT5
       CEQ   >01,[email protected]>0C25      * Screen ouput
       BS    DCAT5
       ST    >FF,@OUTFLG      * OUTPUT FLAG ON
       CALL  EXIO             * OPEN,VAR/DIS/OUT/SEQ
       BYTE  >00,>12
DCAT5  CALL  BLINES
       BYTE  >03,>12
       CALL  DSPLY            * VROW=>03 VCOL=>02
       BYTE  >FE,>03,>FF
       CALL  CATALOGER
       DCZ   V*>8302
       BS    DCAT7
       CALL  DSPLY            * ' FILENAME   SIZE    TYPE   P'
                              * ' ________   ____   _______ _'
       BYTE  >FE,>11,>38,>FF
       CZ    @OUTFLG          * OUTPUT FLAG OFF?
       BS    DCAT6            * Yes
       CALL  EXIO             * WRITE,ROW,COL
       BYTE  >03,>00,>04
       CALL  EXIO             * WRITE,ROW,COL
       BYTE  >03,>11,>12
DCAT6  BR    PAUSE
DCAT7  CZ    @OUTFLG          * OUTPUT FLAG OFF?
       BS    PAUSE            * Yes
       CALL  EXIO             * WRITE,ROW,COL
       BYTE  >03,>00,>04
PAUSE  DCZ   V*>8302          * FILE COUNT
       BS    PAUSE4
       CALL  STEPFILE
       DCZ   @>832B
       BR    PAUSE3
       SCAN                   * SCAN KEYS
       BR    PAUSE3
       CEQ   CLEAR,@KEY       * FCTN 4
       BS    PAUSE4
       CEQ   SPACE,@KEY       * SPACE?
       BR    PAUSE3
PAUSE2 SCAN                   * SCAN KEYS
       BR    PAUSE2
       CEQ   SPACE,@KEY       * SPACE?
       BR    PAUSE2
PAUSE3 B     PAUSE
PAUSE4 CZ    @OUTFLG          * OUTPUT FLAG OFF?
       BS    PAUSE5            * Yes
       CALL  EXIO             * CLOSE CODE
       BYTE  >01
PAUSE5 CALL  CMDDONE
       BR    DCAT
****************************** CATALOGER
CATALOGER DCLR  @SECNUM       * SECTOR NUMBER TO READ OR WRITE
          ST    >FF,@IOSEC    * SET READ SECTOR BIT
          DST   >0E12,@BUFADD * BUFFER ADDRESS
          CALL  SECTORREADWRITE
          CALL  CHKERR
          CALL  DSPLY         * 'DSK  -  DISKNAME='
          BYTE  >35,>FF
          FMT
          COL   5
          SCRO  48
          HSTR  1,@DSKNUM     * DRIVE NUMBER
          FEND
          ST    @OVCOL,@VCOL
          CALL  CVRC
          MOVE  10,[email protected]>0E12,V*SCRADD * COPY BUFFER NAME
          DST   >0640,@FAC
          ST    >C8,@FAC3
          DST   >0E4A,@FAC4
CATALOGER1 ST    V*FAC4,@FAC6
          CEQ   >FF,@FAC6
          BR    CATALOGER2
          DSUB  >0008,@FAC
          B     CATALOGER4
CATALOGER2 CLOG  >80,@FAC6
          BS    CATALOGER3
          DDEC  @FAC
CATALOGER3 SLL   >01,@FAC6
          CZ    @FAC6
          BR    CATALOGER2
CATALOGER4 DINC  @FAC4
          DEC   @FAC3
          BR    CATALOGER1
          DST   @FAC,@>8302
          DST   [email protected]>0E1C,@>8304
          DSUB  @>8302,@>8304
          CALL  ADSPLY        * 'AVAILABLE='
          BYTE  >F5,>36,>FF
          CALL  G70DC         * SHOW NUMBER
          BYTE  >02
          CALL  ADSPLY        * 'USED='
          BYTE  >F0,>01,>37,>FF
          DDECT @>8304
          CALL  G70DC         * SHOW NUMBER
          BYTE  >04
          DST   >0001,@SECNUM * SECTOR NUMBER TO READ OR WRITE
          DST   >0D10,@BUFADD * BUFFER ADDRESS
          CALL  SECTORREADWRITE
          CALL  CHKERR
          DST   >0E12,@BUFADD * BUFFER ADDRESS
          DST   >0D10,@>8302
          RTN
STEPFILE DST   >0E12,@BUFADD  * BUFFER ADDRESS
       DST   V*>8302,@SECNUM  * SECTOR NUMBER TO READ OR WRITE
       CALL  SECTORREADWRITE
       CALL  CHKERR
       DST   [email protected]>0E20,@>8304
       DINC  @>8304
       CALL  G6377
       CALL  CVRC
       MOVE  10,[email protected]>0E12,V*SCRADD * MOVE BUFFER
       MOVE  10,[email protected]>0E12,[email protected]>0C75  * COPY BUFFER
       ADD   >0B,@VCOL
       CALL  G70DC            * SHOW NUMBER
       BYTE  >04
       CLOG  >01,[email protected]>0E1E      * FILE TYPE
       BS    STEPFILE1
       CALL  DSPLY            * 'PROGRAM'
       BYTE  >E6,>39,>FF
       BR    STEPFILE6
STEPFILE1 CLR   @>832F
       CLOG  >02,[email protected]>0E1E      * FILE TYPE
       BS    STEPFILE2
       CALL  DSPLY            * 'INT/'
       BYTE  >E6,>3B,>FF
       BR    STEPFILE3
STEPFILE2 CALL  DSPLY         * 'DIS/'
       BYTE  >E6,>3A,>FF
STEPFILE3 CLR   @>832F
       CLOG  >80,[email protected]>0E1E      * FILE TYPE
       BS    STEPFILE4
       CALL  DSPLY            * 'VAR'
       BYTE  >3C,>FF
       BR    STEPFILE5
STEPFILE4 CALL  DSPLY         * 'FIX'
       BYTE  >3D,>FF
STEPFILE5 CLR   @>8304
       ST    [email protected]>0E23,@>8305   * FILE SIZE
       CALL  G70E2            * SHOW NUMBER
       BYTE  >04
STEPFILE6 CLOG  >08,[email protected]>0E1E   * FILE TYPE
       BS    STEPFILE7
       CALL  DSPLY            * 'Y'
       BYTE  >FB,>1D,>01,>F5,>FF
       BR    STEPFILE8
STEPFILE7 CALL  DSPLY         * VROW+1 VCOL=2
       BYTE  >F5,>FF
STEPFILE8 CALL  G63A9
       DINCT @>8302
       RTN
G6377  CEQ   >02,[email protected]>0C21
       BR    G63A8
       CEQ   >01,[email protected]>0C23
       BR    G63A8
       CEQ   >2D,[email protected]>00C6
       BR    G6392
       MOVE  >0160,[email protected]>0100,[email protected]>00E0 * SCROLL UP 2 LINES
       BR    G6399
G6392  MOVE  >01A0,[email protected]>00C0,[email protected]>00A0 * SCROLL UP 2 LINES
G6399  ST    SPACE,[email protected]>0240
       MOVE  31,[email protected]>0240,[email protected]>0241    * BLANK 1 LINE
       DST   >1202,@VROW
G63A8  RTN
G63A9  CEQ   >02,[email protected]>0C21
       BR    G63BF
       CEQ   >01,[email protected]>0C23
       BR    G63BF
       CZ    @OUTFLG          * OUTPUT FLAG OFF?
       BS    G63BF            * Yes
       CALL  EXIO             * WRITE,ROW,COL
       BYTE  >03,>12,>12
G63BF  RTN
***************************** DISK BACKUP **************************************
DBKUP  CALL  HEADER           * 'BACKUP DISK'
       BYTE  >2B
       DST   DBKUP,@REDOX
DBKUP1 ST    >F8,[email protected]>0C73
       ST    >F8,[email protected]>0C8B
       CALL  DSPLY            * 'SELECTIVE (Y/N)?'
       BYTE  >FE,>03,>62,>FF
       CALL  INKEY
       BYTE  YN,>0C,>1E,Y
DBKUP2 CALL  DSPLY            * 'MASTER DISK (1-9)?'
       BYTE  >FE,>04,>52,>FF
       CZ    @ONEDSK
       BS    DBKUP3
       ST    >31,@VCHAR       * 1
       BR    DBKUP4
DBKUP3 CALL  INKEY
       BYTE  NUMBER,>0C,>72,NINE
DBKUP4 CALL  CHECKDISK
       BYTE  >0C,>72,>0E,>12,>0C,>7F
       CHE   >F2,[email protected]>0C73
       BS    DBKUP5
       CZ    @ONEDSK
       BS    DBKUP2
       CALL  BANK5
       CALL  FCTNBEEP
       BR    DBKUP2
DBKUP5 CALL  DSPLY            * 'COPY DISK (1-9)?'
       BYTE  >FE,>06,>53,>FF
       CZ    @ONEDSK
       BS    DBKUP6
       ST    >31,@VCHAR       * 1
       BR    DBKUP7
DBKUP6 CALL  INKEY
       BYTE  NUMBER,>0C,>8A,NINE
       CEQ   [email protected],[email protected]
       BR    DBKUP7
       CALL  XHONK
       BR    DBKUP5
DBKUP7 CALL  CHECKDISK
       BYTE  >0C,>8A,>0E,>12,>0C,>97
       CHE   >F1,@DFLAG
       BS    DBKUP8
       CZ    @ONEDSK
       BS    DBKUP5
       CALL  BANK5
       CALL  FCTNBEEP
       BR    DBKUP5
DBKUP8 CALL  DSPLY            * 'INITIALIZE NEW DISK' '(Y/N)?'
       BYTE  >FE,>08,>2F,>61,>FF
       CEQ   >F1,[email protected]>0C8B
       BS    DBKUP9
       CEQ   >31,[email protected]>0C8B
       BS    DBKUP9
       CALL  INKEY
       BYTE  YN,>0C,>1F,N
       BR    DBKUPA
DBKUP9 ST    >59,@VCHAR       * Y
       ST    >02,[email protected]>0C1F      * Y
DBKUPA CEQ   >02,[email protected]>0C1F      * Y?
       BR    DBKUPE           * No
       CLR   [email protected]>0CA1          * START TO INITIALIZE
       MOVE  10,[email protected]>0C7F,[email protected]>0C97
       DST   >0C97,@>830E
       ST    >01,@>833C
       B     DBKUPC
DBKUPB INC   @>833C
DBKUPC CGT   >0A,@>833C
       BS    DBKUPD
       CEQ   SPACE,V*>830E
       BS    DBKUPD
       INC   [email protected]>0CA1
       DINC  @>830E
       B     DBKUPB
DBKUPD CALL  DSPLY            * 'NEW DISKNAME?'
       BYTE  >FE,>09,>51,>FF
       CALL  GETINPUT         * GET INPUT
       BYTE  >0C,>97,>0A,>0C,>A1
       CALL  DSPLY
       BYTE  >F5,>FF
       CALL  FORMATINPUT
       B     DBKUPF
DBKUPE CEQ   >F1,[email protected]>0C8B      * INITIALIZED DISK
       BS    DBKUP1
DBKUPF CALL  WORKNG
       CEQ   >02,[email protected]>0C1F      * Y? INITIALIZE
       BR    DBKUPG           * No
       ST    [email protected],@DSKNUM  * DRIVE NUMBER
       CALL  DINIT2
       DST   >0902,@VROW
       CALL  CATALOGER
DBKUPG CZ    [email protected]>0C1E          * N? SELECTIVE
       BR    DBKUPH           * Yes
       CALL  DSPLY            * 'PRESS           '
                              * '                '
                              * 'CLEAR TO ABORT COMMAND'
       BYTE  >FE,>16,>5C,>FF
DBKUPH CZ    [email protected]>0C1E          * N? SELECTIVE
       BR    DBKUPI           * No
       ST    >02,[email protected]>0C20      * Set YES flag
DBKUPI CALL  G6B63
       DST   >0B02,@VROW
       ST    [email protected],@DSKNUM  * DRIVE NUMBER
       ST    >4D,@MCFLAG      * Master
       CALL  CATALOGER
       CALL  DSPLY            * ' FILENAME SIZE    TYPE   P'
                              * ' ________ ____   _______ _'
       BYTE  >FE,>0D,>38,>FF
DBKUPJ DCZ   V*>8302
       BS    DBKUPO
       DCEQ  >0001,@SECNUM    * SECTOR 1?
       BS    DBKUPK           * Yes
       CEQ   >02,[email protected]>0C20      * Y? SELECTIVE
       BR    DBKUPK           * No
       CALL  G6B63
DBKUPK DST   >0F02,@VROW
       CALL  STEPFILE
       CZ    [email protected]>0C1E          * N? SELECTIVE
       BS    DBKUPL           * No
       CALL  BLINES
       BYTE  >12,>17
       CALL  DSPLY            * 'COPY FILE' '(Y/N)?'
       BYTE  >FE,>12,>24,>61,>FF
       CALL  INKEY
       BYTE  YN,>0C,>20,N
       CALL  BLINES
       BYTE  >12,>12
       CALL  WORKNG
       CZ    [email protected]>0C20          * N? COPY FILE
       BS    DBKUPM           * No
DBKUPL MOVE  10,[email protected]>0C75,[email protected]>0C8D
       CALL  FILECOPY2
DBKUPM CZ    [email protected]>0C1E          * N? SELECTIVE
       BR    DBKUPN           * Yes
       SCAN                   * SCAN KEYS
       BR    DBKUPN
       CEQ   CLEAR,@KEY       * FCTN4
       BS    DBKUPO
DBKUPN PUSH  @>8310
       PUSH  @>8311
       CALL  BLINES
       BYTE  >0F,>10
       DST   >0F02,@VROW
       ST    *STATUS,@>8311
       ST    *STATUS,@>8310
       B     DBKUPJ
DBKUPO CALL  CMDDONE
       BR    DBKUP
***************************** MODIFIY DISK NAME ********************************
DMOD   CALL  HEADER           * 'MODIFY DISK NAME'
       BYTE  >2D
       DST   DMOD,@REDOX
       CALL  GETDRIVEGETINPUT * 'MASTER DISK (1-9)?'
       BYTE  >03,>FF,>00,>00  * >03 = VROW
       BYTE  >00,>00
       CALL  DSPLY            * 'NEW DISKNAME?'
       BYTE  >FE,>06,>51,>FF
       CALL  GETINPUT         * GET DISKNAME
       BYTE  >0C,>97,>0A,>0C,>A1
       CALL  WORKNG
       CALL  SECTORREADWRITE  * READ OLD DISKNAME
       CALL  CHKERR
       MOVE  10,[email protected]>0C97,[email protected]>0E12 * SET UP NEW DISKNAME
       CLR   @IOSEC             * SET WRITE SECTOR BIT
       CALL  SECTORREADWRITE    * WRITE NEW DISKNAME
       CALL  CHKERR
       CALL  CMDDONE
       B     DMOD
***************************** INITIALIZE DISK **********************************
DINIT  CALL  HEADER           * 'INITIALIZE NEW DISK'
       BYTE  >2F
       DST   DINIT,@REDOX
       ST    >F8,[email protected]>0C73
       ST    >F8,[email protected]>0C8B
       CALL  DSPLY            * 'MASTER DISK (1-9)?'
       BYTE  >FE,>03,>52,>FF
       ST    >31,@VCHAR       * 1
       CZ    @ONEDSK
       BR    DINIT1
       CALL  INKEY
       BYTE  NUMBER,>0C,>72,NINE
DINIT1 CALL  CHECKDISK
       BYTE  >0C,>72,>0E,>12,>0C,>7F
       CALL  DSPLY            * 'NEW DISKNAME?'
       BYTE  >FE,>06,>51,>FF
       CALL  GETINPUT         * GET INPUT
       BYTE  >0C,>97,>0A,>0C,>A1
       CALL  DSPLY            * VROW=>08
       BYTE  >FC,>08,>FF
       CALL  FORMATINPUT
       CALL  WORKNG
       ST    [email protected],@DSKNUM  * DRIVE NUMBER
       CALL  DINIT2
       CALL  DSPLY            * VROW=>0C VCOL=>02
       BYTE  >FE,>0C,>FF
       CALL  CATALOGER
       CALL  CMDDONE
       BR    DINIT
DINIT2 CALL  INITIALIZEDISK
       CLR   [email protected]>0E12
       MOVE  >00FF,[email protected]>0E12,[email protected]>0E13
       ST    >FF,[email protected]>0E4A
       MOVE  >00C7,[email protected]>0E4A,[email protected]>0E4B
       DST   [email protected],@>8312   * Number of AU
       DCLR  @>8310
       DDIV  >0008,@>8310
       DDEC  @>8310
       CLR   [email protected]>0E4A
       MOVE  @>8310,[email protected]>0E4A,[email protected]>0E4B
       DCZ   @>8312
       BS    FORMATANDMAP2
       DADD  >0E4B,@>8310
       CLR   @>8332           * FLAG
       B     FORMATANDMAP1
FORMATANDMAP  SLL   >01,@>8332
FORMATANDMAP1 INC   @>8332
       DDEC  @>8312
       BR    FORMATANDMAP
       INV   @>8332
       ST    @>8332,V*>8310
FORMATANDMAP2  DCLR  @SECNUM    * SECTOR NUMBER
       CLR   @IOSEC             * SET READ SECTOR BIT
       DST   >0E12,@BUFADD      * BUFFER ADDRESS
       ST    >03,[email protected]>0E4A
       MOVE  10,[email protected]>0C97,[email protected]>0E12 * DISK VOLUME NAME
       DST   [email protected],[email protected]>0E1C    * NUMBER OF AUs
       ST    [email protected],[email protected]>0E1E   * SECTORS PER TRACK
       DST   >4453,[email protected]>0E1F      * Store DS
       CEQ   >0A,[email protected]>0C27        * PROPRIETARY?
       BR    FORMATANDMAP3      * No
       DST   >4B50,[email protected]>0E21      * Store KP
       B     FORMATANDMAP4
FORMATANDMAP3 DST >4B20,[email protected]>0E21    * Store K
FORMATANDMAP4 ST  [email protected],[email protected]>0E23 * TRACKS PER SIDE
       ST    [email protected],[email protected]>0E24    * NUMBER OF SIDES
       ST    [email protected],[email protected]>0E25   * DENSITY
       CALL  ABORT              * SECTORREADWRITE
       CALL  CHKERR
       CHE   >F8,@DFLAG
       BR    FORMATANDMAP8
       DST   VBUFF,@BUFADD    * BUFFER ADDRESS
       CLR   [email protected]          * CLEAR THE VDP BUFFER
       MOVE  >00FF,[email protected],[email protected]>0B11
       DINC  @SECNUM          * SECTOR NUMBER+1
       CALL  ABORT            * SECTORREADWRITE
       CALL  CHKERR
       CHE   >F8,@DFLAG
       BR    FORMATANDMAP8
       ST    >FF,@IOSEC       * SET READ SECTOR BIT
       DST   >0002,@>8310     * NEW SECTOR NUMBER 2
FORMATANDMAP5 DST   @>8310,@SECNUM   * SECTOR NUMBER
       CALL  ABORT            * SECTORREADWRITE
       CHE   >F8,@DFLAG
       BS    FORMATANDMAP7
       DST   @SECNUM,@>8312   * SAVE SECTOR NUMBER
       DST   @SECNUM,@>8314   * SAVE SECTOR NUMBER
       DSRL  >0003,@>8312
       DADD  >0E4A,@>8312
       ST    >01,@>8332
       DAND  >0007,@>8314
       DCZ   @>8314
       BS    FORMATANDMAP6
       SLL   @>8315,@>8332
FORMATANDMAP6 OR    @>8332,V*>8312
FORMATANDMAP7 DINC  @>8310
       DCEQ  [email protected],@>8310   * Number of AU
       BR    FORMATANDMAP5
       DST   >0E12,@BUFADD    * BUFFER ADDRESS
       CLR   @IOSEC           * SET WRITE SECTOR BIT
       DCLR  @SECNUM          * SECTOR NUMBER
       CALL  ABORT            * SECTORREADWRITE
       CALL  CHKERR
       CALL  BLINES
       BYTE  >13,>13
FORMATANDMAP8 RTN
***************************** QUICK TEST ***************************************
TQICK  CLR   @ABORTF
       CALL  HEADER           * 'QUICK TEST'
       BYTE  >30
       DST   TQICK,@REDOX
TQICK1 ST    >F8,[email protected]>0C73
       ST    >F8,[email protected]>0C8B
       CALL  DSPLY            * 'DESTRUCTIVE TEST (Y/N)?'
       BYTE  >FE,>03,>4A,>FF
       CALL  INKEY
       BYTE  YN,>0C,>1E,N
       CEQ   >02,[email protected]>0C1E      * Y? DESTRUCTIVE
       BR    TQICK2           * No
       CALL  DSPLY            * VROW=>04
       BYTE  >FC,>04,>FF
       CALL  FORMATINPUT
TQICK2 CALL  DSPLY            * 'MASTER DISK (1-9)?'
       BYTE  >FE,>07,>52,>FF
       ST    >31,@VCHAR       * 1
       CZ    @ONEDSK
       BR    TQICK3
       CALL  INKEY
       BYTE  NUMBER,>0C,>72,NINE
TQICK3 CALL  CHECKDISK
       BYTE  >0C,>72,>0E,>12,>0C,>7F
       CZ    [email protected]>0C1E          * N? DESTRUCTIVE
       BR    TQICK4           * Yes
       CHE   >F2,[email protected]>0C73
       BR    TQICK1
TQICK4 CALL  DSPLY            * 'LOOP (Y/N)?'
       BYTE  >FE,>09,>49,>FF
       CALL  INKEY
       BYTE  YN,>0C,>26,N
       CALL  DSPLY            * 'LOG ERRORS (Y/N)?'
       BYTE  >FE,>0A,>5F,>FF
       CALL  INKEY
       BYTE  YN,>0C,>10,N
       ST    [email protected]>0C10,@LOGFLG
       CEQ   >02,@LOGFLG      * Y? LOG
       BR    TQICK5           * No
       CALL  DSPLY            * 'DEVICE NAME?'
       BYTE  >FE,>0B,>50,>F5,>FF
       CALL  GETDEVICENAME    * GET DEVICE NAME
       BYTE  >0C,>D0,>38,>0C,>CF
       CALL  G6AFF
TQICK5 CALL  WORKNG
       CEQ   >02,@LOGFLG      * Y? LOG
       BR    TQICK6           * No
       CALL  EXIO             * OPEN,VAR/DIS/OUT/SEQ
       BYTE  >00,>12
       CALL  EXIO             * WRITE,ROW,COL
       BYTE  >03,>00,>03
       CALL  EXIO             * WRITE,ROW,COL
       BYTE  >03,>00,>00
       CALL  EXIO             * CLOSE
       BYTE  >01
TQICK6 DCLR  [email protected]>0C16
       DCLR  [email protected]>0C18
       ST    >07,@VROW
       CALL  DSPLY            * VROW=>08 VCOL=>02
       BYTE  >FE,>08,>FF
       ST    [email protected],@DSKNUM  * DRIVE NUMBER
       CEQ   >02,[email protected]>0C1E      * Y? DESTRUCTIVE
       BR    TQICK7           * No
       CALL  INITIALIZEDISK
TQICK7 CALL  DSPLY            * 'PRESS           '
                              * '                '
                              * 'CLEAR TO ABORT COMMAND'
       BYTE  >FE,>16,>5C,>FF
TQICK8 CALL  ERRORSANDPASS
       ST    [email protected],@DSKNUM  * DRIVE NUMBER
       CZ    [email protected]>0C1E          * N? DESTRUCTIVE
       BR    TQICK9           * Yes
       CALL  READINGSECTORS
       B     TQICKA
TQICK9 CALL  TCOMPD
       BYTE  >FF
       BYTE  >F7
TQICKA CALL  ERRORSANDPASS2
       CEQ   >02,@ABORTF      * ABORT?
       BS    TQICKC           * Yes
       CEQ   >02,@LOGFLG      * Y? LOG
       BR    TQICKB           * No
       CALL  G6AE2
TQICKB CEQ   >02,[email protected]>0C26      * Y? LOOP
       BS    TQICK8           * Yes
TQICKC CEQ   >02,@LOGFLG      * Y? LOG
       BR    TQICKD           * No
       CALL  G6AEF
TQICKD CALL  CMDDONE
       B     TQICK
***************************** COMPREHENSIVE TEST *******************************
TCOMP  CLR   @ABORTF
       CALL  HEADER           * 'COMPREHENSIVE TEST'
       BYTE  >31
       CALL  HEADER2
       BYTE  >42
       ST    >F8,[email protected]>0C73
       ST    >F8,[email protected]>0C8B
       CALL  DSPLY            * 'MASTER DISK (1-9)?'
       BYTE  >FE,>04,>52,>FF
       ST    >31,@VCHAR       * 1
       CZ    @ONEDSK
       BR    TCOMP1
       CALL  INKEY
       BYTE  NUMBER,>0C,>72,NINE
TCOMP1 CALL  CHECKDISK
       BYTE  >0C,>72,>0E,>12,>0C,>7F
       CALL  DSPLY            * VROW=>06
       BYTE  >FC,>06,>FF
       CALL  FORMATINPUT
       CALL  DSPLY            * 'LOOP (Y/N)?'
       BYTE  >FE,>09,>49,>FF
       CALL  INKEY
       BYTE  YN,>0C,>26,N
       CALL  DSPLY            * 'LOG ERRORS (Y/N)?'
       BYTE  >FE,>0A,>5F,>FF
       CALL  INKEY
       BYTE  YN,>0C,>10,N
       ST    [email protected]>0C10,@LOGFLG
       CEQ   >02,@LOGFLG      * Y? LOG
       BR    TCOMP2           * No
       CALL  DSPLY            * 'DEVICE NAME?'
       BYTE  >FE,>0B,>50,>F5,>FF
       CALL  GETDEVICENAME    * GET DEVICE NAME
       BYTE  >0C,>D0,>38,>0C,>CF
       CALL  G6AFF
TCOMP2 CALL  WORKNG
       CEQ   >02,@LOGFLG      * Y? LOG
       BR    TCOMP3           * No
       CALL  EXIO             * OPEN,VAR/DIS/OUT/SEQ
       BYTE  >00,>12
       CALL  EXIO             * WRITE,ROW,COL
       BYTE  >03,>00,>03
       CALL  EXIO             * CLOSE
       BYTE  >01
TCOMP3 CALL  INITIALIZEDISK
       CALL  DSPLY            * 'PRESS           '
                              * '                '
                              * 'CLEAR TO ABORT COMMAND'
       BYTE  >FE,>16,>5C,>FF
       DCLR  [email protected]>0C18
       DCLR  [email protected]>0C16
       CALL  ERRORSANDPASS
       ST    [email protected],@DSKNUM  * DRIVE NUMBER
TCOMP4 CALL  TESTNUMBER
       BYTE  >01,>6E,>6E
       CEQ   >02,@ABORTF      * ABORT?
       BS    TCOMPB           * Yes
       CALL  TESTNUMBER
       BYTE  >02,>C5,>C5
       CEQ   >02,@ABORTF      * ABORT?
       BS    TCOMPB           * Yes
       CALL  TESTNUMBER
       BYTE  >03,>00,>08
       CEQ   >02,@ABORTF      * ABORT?
       BS    TCOMPB           * Yes
       CALL  TESTNUMBER
       BYTE  >04,>FF,>F7
       CEQ   >02,@ABORTF      * ABORT?
       BS    TCOMPB           * Yes
       CALL  DSPLY            * 'TEST #'
       BYTE  >FE,>14,>63,>19,>FF
       CEQ   >02,@LOGFLG      * Y? LOG
       BR    TCOMP5           * No
       CALL  LOGOUTPUT
TCOMP5 CEQ   >02,@ABORTF      * ABORT?
       BS    TCOMPB           * Yes
       DCLR  @>8310           * ???????
       DST   [email protected],@>8312   * Number of AU
       DDEC  @>8312           * AU -1
       CLR   @IOSEC           * SET READ SECTOR BIT
TCOMP6 DST   @>8310,@SECNUM   * SECTOR NUMBER
       DST   @SECNUM,[email protected]>0E12
       ST    >08,@SCRADD
       CALL  ABORT            * SECTORREADWRITE
       CEQ   >02,@ABORTF      * ABORT?
       BS    TCOMPB           * Yes
       CALL  G6C2C
       DST   @>8312,@SECNUM   * SECTOR NUMBER
       DST   @SECNUM,[email protected]>0E12
       CALL  ABORT            * SECTORREADWRITE
       CEQ   >02,@ABORTF      * ABORT?
       BS    TCOMPB           * Yes
       CALL  G6C2C
       DINC  @>8310
       DDEC  @>8312
       DCGT  @>8312,@>8310
       BR    TCOMP6
       ST    >FF,@IOSEC       * SET WRITE SECTOR BIT
       DINC  @>8310           * ????
       DDEC  @>8312           * ?????
       CALL  DSPLY            * 'TEST #'
       BYTE  >FE,>14,>63,>1A,>FF
       CEQ   >02,@LOGFLG      * Y? LOG
       BR    TCOMP7           * No
       CALL  LOGOUTPUT
TCOMP7 DDEC  @>8310
       DINC  @>8312           * ???????
       DCEQ  @>8312,@>8310    * ????????
       BS    TCOMP8
       DST   @>8310,@SECNUM   * SECTOR NUMBER
       CALL  ABORT            * SECTORREADWRITE
       CEQ   >02,@ABORTF      * ABORT?
       BS    TCOMPB           * Yes
       CALL  G6C2C
       DCEQ  @SECNUM,[email protected]>0E12
       BS    TCOMP8
       ST    >08,@SCRADD
       ST    >99,@DFLAG
       CALL  G6C31
TCOMP8 DST   @>8312,@SECNUM   * SECTOR NUMBER
       CALL  ABORT            * SECTORREADWRITE
       CEQ   >02,@ABORTF      * ABORT?
       BS    TCOMPB           * Yes
       CALL  G6C2C
       CEQ   >F8,@DFLAG
       BR    TCOMP9
       DCEQ  @SECNUM,[email protected]>0E12
       BS    TCOMP9
       ST    >99,@DFLAG
       CALL  G6C31
TCOMP9 DCZ   @>8310
       BR    TCOMP7
       CALL  BLINES
       BYTE  >14,>14
       CALL  ERRORSANDPASS2
       CEQ   >02,@LOGFLG      * Y? LOG
       BR    TCOMPA           * No
       CALL  G6AE2
TCOMPA CEQ   >02,[email protected]>0C26      * Y? LOOP
       BS    TCOMP4           * Yes
TCOMPB CEQ   >02,@LOGFLG      * Y? LOG
       BR    TCOMPC           * No
       CALL  G6AEF
TCOMPC CALL  CMDDONE
       BR    TCOMP
TCOMPD PUSH  @>8310
       PUSH  @>8311
       B     TESTNUMBER2
TESTNUMBER PUSH  @>8310
       PUSH  @>8311
       DCLR  @>8310
       FETCH @>8311
       CALL  DSPLY            * 'TEST #'
       BYTE  >FE,>14,>63,>FF
       CALL  G70F2
       BYTE  >10
       CEQ   >02,@LOGFLG      * Y? LOG
       BR    TESTNUMBER2      * No
       CALL  LOGOUTPUT
TESTNUMBER2 FETCH @>8311
       ST    @>8311,[email protected]>0E12
       MOVE  >00FF,[email protected]>0E12,[email protected]>0E13
       FETCH @>8310
       ST    @>8310,[email protected]>0E92
       ST    *STATUS,@>8311
       ST    *STATUS,@>8310
       DCLR  @SECNUM          * SECTOR NUMBER
       CLR   @IOSEC           * SET WRITE SECTOR BIT
       DST   >0E12,@BUFADD    * BUFFER ADDRESS
       B     READINGSECTORS1
READINGSECTORS DCLR  @SECNUM  * SECTOR NUMBER
       ST    >FF,@IOSEC       * SET READ SECTOR BIT
       DST   >0E12,@BUFADD    * BUFFER ADDRESS
READINGSECTORS1 CALL  ABORT            * SECTORREADWRITE
       CEQ   >02,@ABORTF      * ABORT?
       BS    READINGSECTORS2           * Yes
       CALL  G6C2C
       DINC  @SECNUM          * SECTOR NUMBER+1
       DST   [email protected],@FAC12   * Number of AU
       DCEQ  @FAC12,@SECNUM
       BR    READINGSECTORS1
       CALL  BLINES
       BYTE  >14,>14
READINGSECTORS2 RTN
ERRORSANDPASS PUSH  @>8314
       PUSH  @>8315
       PUSH  @VCOL
       PUSH  @VROW
       DST   [email protected]>0C18,@>8314
       CALL  DSPLY            * '  TOTAL ERRORS:'
       BYTE  >FE,>11,>5E,>FF
       BR    ERRORSANDPASS3
ERRORSANDPASS2 PUSH  @>8314
       PUSH  @>8315
       PUSH  @VCOL
       PUSH  @VROW
       DINC  [email protected]>0C16
       DST   [email protected]>0C16,@>8314
       CALL  DSPLY            * 'COMPLETED PASS:'
       BYTE  >FE,>12,>5D,>FF
ERRORSANDPASS3 CALL  G70CC            * SHOW NUMBER
       BYTE  >14
       ST    *STATUS,@VROW
       ST    *STATUS,@VCOL
       ST    *STATUS,@>8315
       ST    *STATUS,@>8314
       RTN
INITIALIZEDISK  CALL  BLINES
       BYTE  >13,>13
       CALL  DSPLY            * 'INITIALIZE NEW DISK'
       BYTE  >FE,>14,>2F,>FF
       ST    @DSKNUM,@FAC2    * DRIVE NUMBER
       ST    [email protected],@FAC3   * NUMBER OF TRACKS
       DST   >0E12,@FAC4      * BUFFER ADDRESS
       ST    [email protected],@FAC7    * NUMBER OF SIDES
       CEQ   >01,@FAC7        * 1 SIDE?
       BS    INITIALIZEDISK1  * Yes
       OR    >10,@FAC2
INITIALIZEDISK1 ST [email protected],@FAC6 * DENSITY
       CEQ   >01,@FAC6
       BS    INITIALIZEDISK2
       OR    >20,@FAC2
INITIALIZEDISK2 CEQ   >28,@FAC3   * 40 TRACK?
       BS    INITIALIZEDISK3      * Yes
       CEQ   >23,@FAC3            * 35 TRACK?
       BS    INITIALIZEDISK3      * Yes
       OR    >10,@FAC2
INITIALIZEDISK3 CALL  FORMAT
       DST   @FAC,[email protected]     * Get Number of AU
       DST   @FAC3,[email protected]   * Sectors per Track
       CEQ   >02,[email protected]      * 2 SIDES?
       BR    INITIALIZEDISK4  * No
       CEQ   >02,@FAC7        * 2 SIDES?
       BS    INITIALIZEDISK4  * Yes
       ST    >01,[email protected]      * 1 SIDE
INITIALIZEDISK4 CALL  CHKERR
       CALL  BLINES
       BYTE  >14,>14
       RTN
LOGOUTPUT  CALL  EXIO         * OPEN,VAR/DIS/APE/SEQ
       BYTE  >00,>16
       CALL  EXIO             * WRITE,ROW,COL
       BYTE  >03,>14,>14
       BR    G6AFA
G6AE2  CALL  EXIO             * OPEN,VAR/DIS/APE/SEQ
       BYTE  >00,>16
       CALL  EXIO             * WRITE,ROW,COL
       BYTE  >03,>12,>12
       BR    G6AFA
G6AEF  CALL  EXIO             * OPEN,VAR/DIS/APE/SEQ
       BYTE  >00,>16
       CALL  EXIO             * WRITE,ROW,COL
       BYTE  >03,>11,>11
G6AFA  CALL  EXIO             * CLOSE
       BYTE  >01
       RTN
G6AFF  DCEQ  >4453,[email protected]>0CD0    * DS?
       BR    G6B25
       CEQ   >4B,[email protected]>0CD2      * K?
       BR    G6B25
       ST    [email protected],@>830E
       ADD   >30,@>830E       * ADD ASCII 0
       CEQ   [email protected]>0CD3,@>830E
       BR    G6B25
       CALL  DSPLY            * 'LISTING DEVICE ERROR'
       BYTE  >FE,>14,>43,>FF
       CALL  HONKFCTN
       BR    FCTN8
G6B25  RTN
***************************** HONK *********************************************
XHONK  CALL  BADTON
       BR    G6B2E
***************************** BEEP *********************************************
XBEEP  CALL  ACCTON
G6B2E  CLR   @ITIMER
G6B30  CZ    @>83CE
       BR    G6B30
       RTN
       PUSH  @VCOL
       PUSH  @VROW
       ST    SPACE,[email protected]>0C7F
       MOVE  9,[email protected]>0C7F,[email protected]>0C80
       CALL  BANK5
       CALL  DSPLY            * 'LOAD MASTER DISK'
       BYTE  >FE,>14,>0E,>FF
       CALL  FCTNBEEP
       CALL  BLINES
       BYTE  >15,>15
       ST    >4D,@MCFLAG      * Master
******************************* Restore VROW VCOL
RESTOREVROWVCOL ST    *STATUS,@VROW
       ST    *STATUS,@VCOL
       RTN
G6B63  PUSH  @VCOL
       PUSH  @VROW
       ST    >4D,@MCFLAG      * Master
       CZ    @ONEDSK
       BS    RESTOREVROWVCOL
       CALL  READSECTOR
       BR    RESTOREVROWVCOL
G6B73  PUSH  @VCOL
       PUSH  @VROW
       ST    SPACE,[email protected]>0C97
       MOVE  9,[email protected]>0C97,[email protected]>0C98
       CALL  BANK5
       CALL  DSPLY            * 'LOAD COPY DISK'
       BYTE  >FE,>14,>0F,>FF
       CALL  FCTNBEEP
       CALL  BLINES
       BYTE  >15,>15
       ST    >43,@MCFLAG      * Copy
       B     RESTOREVROWVCOL
G6B9A  PUSH  @VCOL
       PUSH  @VROW
       ST    >43,@MCFLAG      * Copy
       CZ    @ONEDSK
       BS    RESTOREVROWVCOL
       CALL  READSECTOR
       BR    RESTOREVROWVCOL
READSECTOR CALL  G6BF8
       DST   VBUFF,@BUFADD    * BUFFER ADDRESS
       ST    >FF,@IOSEC       * SET READ SECTOR BIT
       ST    [email protected],@DSKNUM  * DRIVE NUMBER
       CEQ   >4D,@MCFLAG      * Master?
       BS    G6BC1            * Yes
       ST    [email protected],@DSKNUM  * DRIVE NUMBER
G6BC1  DCLR  @SECNUM          * SECTOR NUMBER
G6BC3  CALL  SECTORREADWRITE
       DST   >0C7F,@FAC
       CEQ   >4D,@MCFLAG      * Master?
       BS    G6BD3            * Yes
       DST   >0C97,@FAC
G6BD3  DST   VBUFF,@FAC2
       ST    >01,@>833C
       B     G6BDF
G6BDD  INC   @>833C
G6BDF  CGT   >05,@>833C
       BS    G6BF2
       DCEQ  V*FAC2,V*FAC
       BR    G6BF3
       DINCT @FAC
       DINCT @FAC2
       B     G6BDD
G6BF2  RTN
G6BF3  CALL  G6BF8
       BR    G6BC3
G6BF8  CALL  BANK5
       DST   >1502,@VROW
       CALL  DSPLY            * 'DISKNAME='
       BYTE  >33,>FF
       CALL  CVRC
       CEQ   >4D,@MCFLAG      * Master?
       BR    G6C1C            * No
       MOVE  10,[email protected]>0C7F,V*SCRADD
       CALL  DSPLY            * 'LOAD MASTER DISK'
       BYTE  >FE,>14,>0E,>FF
       BR    FCTNBEEP
G6C1C  MOVE  10,[email protected]>0C97,V*SCRADD
       CALL  DSPLY            * 'LOAD COPY DISK'
       BYTE  >FE,>14,>0F,>FF
       BR    FCTNBEEP
G6C2C  CEQ   >F8,@DFLAG
       BS    G6C97
G6C31  MOVE  >00E0,[email protected]>0140,[email protected]>0120 * SCROLL 7 LINES
       ST    SPACE,[email protected]>0220
       MOVE  31,[email protected]>0220,[email protected]>0221    * BLANK 1 LINE
       DINC  [email protected]>0C18
       PUSH  @>8310
       PUSH  @>8311
       PUSH  @VCOL
       PUSH  @VROW
       DST   [email protected]>0C18,@>8310
       CALL  XHONK
       CALL  DSPLY            * '  TOTAL ERRORS:'
       BYTE  >FE,>11,>5E,>FF
       CALL  G70DC            * SHOW NUMBER
       BYTE  >10
       CALL  DSPLY            * 'BAD ADDRESS/CODE'
       BYTE  >FE,>10,>56,>FF
       CALL  G70DC            * SHOW NUMBER
       BYTE  >16
       CALL  DSPLY            * VCOL+1
       BYTE  >E0,>FF
       CALL  G6CB4
       CEQ   >02,@LOGFLG      * Y?  LOG
       BR    G6C87            * No
       CALL  EXIO             * OPEN,VAR/DIS/APE/SEQ
       BYTE  >00,>16
       CALL  EXIO             * WRITE,ROW,COL
       BYTE  >03,>10,>10
       CALL  EXIO             * CLOSE
       BYTE  >01
G6C87  ST    *STATUS,@VROW
       ST    *STATUS,@VCOL
       ST    *STATUS,@>8311
       ST    *STATUS,@>8310
G6C97  RTN
****************************  Check for error
CHKERR CEQ   >F8,@DFLAG
       BS    G6CB3
       CALL  BLINES
       BYTE  >14,>14
       CALL  DSPLY            * VROW=>14 VCOL=>02 'DISK ERROR'
       BYTE  >FE,>14,>05,>FF
       CALL  BLINES
       BYTE  >15,>15
       CALL  G6CB4
       BR    HONKFCTN
G6CB3  RTN
G6CB4  PUSH  @>8310
       PUSH  @>8311
       CLR   @>8310
       ST    @DFLAG,@>8311
       AND   >F0,@>8311
       SRL   >04,@>8311
       CALL  G70F2
       BYTE  >10
       CLR   @>8310
       ST    @DFLAG,@>8311
       AND   >0F,@>8311
       CALL  G70F2
       BYTE  >10
       ST    *STATUS,@>8311
       ST    *STATUS,@>8310
       RTN
***************************** Calculate Vaddr from ROW and COL
CVRC   CLR   @SCRADD
       ST    @VROW,@>830D
       DSLL  >0005,@SCRADD
       ADD   @VCOL,@>830D
       RTN
DELETE CALL  DELETE1            * LENGTH,BUFFER ADDRESS
       BYTE  >07,>0C,>72
       RTN
DELETE1 CLR  [email protected]
       MOVE  10,[email protected],[email protected]>0B11
       FETCH @>830E             * Max device name length
       ST    @>830E,[email protected]
       FETCH @>830E             * Buffer address
       FETCH @>830F             * Buffer address
       MOVE  6,[email protected],[email protected]   * Get DSK0. into PAB
       ADD   @DSKNUM,[email protected]>0B1D    * DRIVE NUMBER
       MOVE  10,[email protected]>0C75,[email protected]>0B1F * Get filename
       CLR   [email protected]>0B11
       DST   @>830E,@FAC        * Get buffer address
       DADD  >0003,@FAC
       ST    >01,@FAC3          * COUNTER=1
       B     DELETE3
DELETE2 INC  @FAC3              * COUNTER +1
DELETE3 CGT  >0A,@FAC3          * Filename length > 10 ?
       BS    DELETE4            * Yes
       CEQ   SPACE,V*FAC        * End filename?
       BS    DELETE4            * Yes
       INC   [email protected]             * Length +1
       DINC  @FAC               * Address of name +1
       B     DELETE2
DELETE4 DST  VLEN,@FAC12        * Length byte
       CALL  LINK
       BYTE  >08
       BS    DELETE5
       ST    [email protected]>0B11,@DFLAG
       SRL   >05,@DFLAG
       CZ    @DFLAG
       BR    DELETE6
       ST    >F8,@DFLAG
       BR    DELETE6
DELETE5 ST   >F0,@DFLAG
DELETE6 ST   @DFLAG,[email protected]>0001(@>830E)
       BR    CHKERR
G6D5F  STRI  'DSK0.'
***************************** DSRLNK routine
*   Parm 1 I/O op
*    0, flags
*    3, row, col
*    Other
EXIO   MOVE  >004A,@MBASE,[email protected]
       FETCH @>8332           * Get flag
       ST    @>8332,[email protected]>0CC6   * I/O CODE
       CZ    @>8332           * FLAG<>0
       BR    EXIO1            * Yes
       FETCH @>8332           * Get byte
       ST    @>8332,[email protected]>0CC7   * FILE TYPE
                              * >0CC8 = BUFFER ADDDRESS
       ST    >20,[email protected]>0CCA      * LOGICAL RECORD LENGTH
       ST    >20,[email protected]>0CCB      * CHARACTER COUNT
       DCLR  [email protected]>0CCC          * RECORD NUMBER
       CLR   [email protected]>0CCE          * SCREEN OFFSET
       DST   >0CCF,@FAC12     * LENGTH BYTE
       CALL  LINK
       BYTE  >08
       BS    G6DE1            * ERROR
       CALL  CHECKOPCODE
       BR    EXIO4            * No error
EXIO1  CEQ   >03,[email protected]>0CC6      * CLOSE?
       BR    EXIO3            * No
       DCLR  @>8310
       DCLR  @>8312
       FETCH @>8311
       DSLL  >0005,@>8310
       FETCH @>8313
       DINC  @>8312
       DSLL  >0005,@>8312
EXIO2  DST   >0CCF,@FAC12     * Length byte
       DST   @>8310,[email protected]>0CC8
       CALL  LINK
       BYTE  >08
       BS    G6DE1            * ERROR
       CALL  CHECKOPCODE
       DADD  >0020,@>8310     * SCREEN ADDRESS +32
       DCEQ  @>8312,@>8310    * SCREEN ADDRESS = LAST LINE
       BR    EXIO2
       B     EXIO4
EXIO3  DST   >0CCF,@FAC12     * Length byte
       CALL  LINK
       BYTE  >08
       BS    G6DE1            * ERROR
       CALL  CHECKOPCODE
EXIO4  MOVE  >004A,[email protected],@MBASE
       RTN
G6DE1  CLR   @DFLAG
       B     LISTINGDEVICEERROR
CHECKOPCODE ST [email protected]>0CC7,@DFLAG  * I/O CODE
       SRL   >05,@DFLAG
       CZ    @DFLAG
       BR    LISTINGDEVICEERROR
       ST    >F8,@DFLAG
       RTN
LISTINGDEVICEERROR CALL DSPLY  * 'LISTING DEVICE ERROR'
       BYTE  >F3,>FE,>14,>43,>FF
       DCLR  @>830E
       ST    @DFLAG,@>830F
       CALL  G70F2
       BYTE  >0E
       CALL  HONKFCTN
       B     FCTN8
***************************** BLANK LINES (VROW,COUNT)
BLINES PUSH  @VCOL
       PUSH  @VROW
       FETCH @VROW
       FETCH @SCRADD
       CLR   @VCOL
G6E16  FMT
       HCHA  32,' '
       FEND
       CZ    @VROW
       BS    RESTOREVROWVCOL
       CH    @SCRADD,@VROW
       BR    G6E16
       B     RESTOREVROWVCOL
BANK5  ST    SPACE,[email protected]>027F    * BLANK 5 LINES
       MOVE  >00A0,[email protected]>027F,[email protected]>0280
       RTN
****************************** INITILIAZE DISK INPUT
FORMATINPUT CALL  DSPLY            * 'TRACKS PER SIDE?'
       BYTE  >FB,>02,>4D,>FF
       MOVE  4,[email protected],[email protected]
       CALL  GETINPUT         * GET INPUT
       BYTE  >0B,>11,>02,>0B,>10
       CEQ   >01,[email protected]
       BR    FORMATINPUT1
       ST    >20,[email protected]>0B12
FORMATINPUT1 DST   >0B11,@FAC12 * TRACKS PER SIDE
       CLR   @ERCODE
       XML   >10              * CSN
       CZ    @ERCODE
       BS    FORMATINPUT2
       CALL  XHONK
       BR    FORMATINPUT
FORMATINPUT2  XML   >12       * CFI
       CZ    @ERCODE
       BS    FORMATINPUT3
       CALL  XHONK
       BR    FORMATINPUT
FORMATINPUT3  ST    @FAC1,[email protected]
       CALL  DSPLY            * 'SINGLE SIDED (Y/N)?'
       BYTE  >F5,>4C,>FF
       CALL  INKEY
       BYTE  YN,>0E,>10,N
       CEQ   >02,[email protected]      * Y? SINGLE SIDED
       BR    FORMATINPUT4            * No
       ST    >01,[email protected]      * SINGLE SIDED
       BR    FORMATINPUT5
FORMATINPUT4 ST >02,[email protected]   * DOUBLE SIDED
FORMATINPUT5 CALL  DSPLY      * 'SINGLE DENSITY (Y/N)?'
       BYTE  >F5,>4B,>FF
       CALL  INKEY
       BYTE  YN,>0E,>11,N
       CEQ   >02,[email protected]     * Y? SINGLE DENSITY
       BR    FORMATINPUT6            * No
       ST    >01,[email protected]     * SINGLE DENSITY
       BR    FORMATINPUT7
FORMATINPUT6 ST >02,[email protected]  * DOUBLE DENSITY
FORMATINPUT7 RTN
G6EAD  BYTE  >02,>34,>30,>20
SECTOR DST   >0110,[email protected]>0C1A    * W/R SECTOR
       B     LEVEL1
FORMAT DST   >0111,[email protected]>0C1A    * FORMAT DISK
LEVEL1  DST   >0C1A,@FAC12
       CALL  LINK
       BYTE  >0A
       BS    G6F0D
       ST    @FAC6,@DFLAG     * ERROR CODE
       CZ    @FAC6
       BR    G6ED4
       ST    >F8,@DFLAG       * NO ERROR
       BR    G6ED7
G6ED4  ADD   >10,@DFLAG       * ?
G6ED7  RTN
PROTCT DST   >0112,[email protected]>0C1A    * PROTECT/UNPROTECT
       B     LEVEL2
RENAME DST   >0113,[email protected]>0C1A    * RENAME
       B     LEVEL2
FILEIN DST   >0114,[email protected]>0C1A    * FILE INPUT
       B     LEVEL2
FILEOU DST   >0115,[email protected]>0C1A    * FILE OUTPUT
LEVEL2  DST   >0C1A,@FAC12
       CALL  LINK
       BYTE  >0A
       BS    G6F0D
       SRL   >05,@FAC6
       ST    @FAC6,@DFLAG
       CZ    @DFLAG
       BR    G6F0C
       ST    >F8,@DFLAG
G6F0C  RTN
G6F0D  ST    >F0,@DFLAG
       RTN
ABORT  PUSH  @VCOL
       PUSH  @VROW
       DCZ   @>832B
       BR    ABORT1
       SCAN                   * SCAN KEYS
       BR    ABORT1
       CEQ   CLEAR,@KEY       * FCTN4
       BR    ABORT1
       ST    >02,@ABORTF
ABORT1 DST   >130D,@VROW
       CALL  G70DC            * SHOW NUMBER
       BYTE  >16
       CEQ   >FF,@IOSEC       * WRITE SECTOR BIT SET?
       BR    ABORT2           * No
       ST    >3E,@VCHAR       * >
       BR    ABORT3
ABORT2 ST    >3C,@VCHAR       * <
ABORT3 ST    *STATUS,@VROW
       ST    *STATUS,@VCOL
SECTORREADWRITE DST @SECNUM,@FAC6 * SECTOR NUMBER TO READ OR WRITE
                 DST   @DSKNUM,@FAC2 * DRIVE NUMBER/READ OR WRITE BIT
                 DST   @BUFADD,@FAC4 * BUFFER ADDRESS
                 B     SECTOR
***************************** Key Scan
KSCAN  CLR   @ITIMER
KSCAN1 SCAN                   * SCAN KEYS
       BS    KSCAN2
       CHE   >14,@ITIMER
       BR    KSCAN1
       EX    @CURSOR,@VCHAR
       B     KSCAN
KSCAN2 CEQ   >60,@VCHAR
       BR    KSCAN3
       EX    @CURSOR,@VCHAR
KSCAN3 CEQ   DOWN,@KEY         * FCTN X
       BR    KSCAN6
       INC   [email protected]>0C27
       CEQ   >0A,[email protected]>0C27
       BS    KSCAN4
       CALL  XHONK
       BR    KSCAN5
KSCAN4 CALL  XBEEP
KSCAN5 CALL  G740E
       BR    KSCAN
KSCAN6 RTN
G6F81  INC   @VCOL            * VCOL+1
       CH    >1D,@VCOL
       BR    G6F8D
G6F88  INC   @VROW            * VROW+1
       ST    >02,@VCOL        * VCOL=2
G6F8D  RTN
G6F8E  DEC   @VCOL
       CGE   >02,@VCOL
       BS    G6F9A
       ST    >1D,@VCOL
       DEC   @VROW
G6F9A  RTN
CHECKDISK PUSH @>8310
       PUSH  @>8311
       FETCH @>8302           * DRIVE NUMBER ADDRESS
       FETCH @>8303           * DRIVE NUMBER ADDRESS
       ST    V*>8302,@DSKNUM  * DRIVE NUMBER
       FETCH @BUFADD          * BUFFER ADDRESS
       FETCH @BUFADD+1        * BUFFER ADDRESS
CHECKDISK1 CZ @ONEDSK
       BS    CHECKDISK3
       PUSH  @VROW
       PUSH  @VCOL
       DCEQ  >0C8A,@>8302
       BR    CHECKDISK2
       CALL  G6B73
CHECKDISK2 ST *STATUS,@VCOL
       ST    *STATUS,@VROW
CHECKDISK3 DCLR  @SECNUM      * SECTOR NUMBER
       ST    >FF,@IOSEC       * SET READ SECTOR BIT
       CALL  SECTORREADWRITE
       CEQ   >F8,@DFLAG
       BR    CHECKDISK4
       ST    >F1,@DFLAG
       DCEQ  >4453,[email protected]>000D(@BUFADD) * DS?
       BR    CHECKDISK4
       CEQ   >4B,[email protected]>000F(@BUFADD)   * K?
       BR    CHECKDISK4
       INC   @VROW
       ST    >02,@VCOL
       CALL  DSPLY            * BLANK >1C BYTES
       BYTE  >F0,>1C,>FF
       ST    >02,@VCOL
       CALL  DSPLY            * 'DISKNAME='
       BYTE  >33,>FF
       CALL  CVRC
       MOVE  10,V*BUFADD,V*SCRADD
       ADD   >0A,@VCOL
       DST   [email protected]>000A(@BUFADD),[email protected]  * Number of AU
       DST   [email protected]>000C(@BUFADD),[email protected] * Sectors per Track
       ST    >F8,@DFLAG
       CEQ   >50,[email protected]>0010(@BUFADD) * P?
       BR    CHECKDISK4
       ST    >F2,@DFLAG       * PROPRITARY DISK ERROR
CHECKDISK4 CEQ >16,@DFLAG
       BR    CHECKDISK5
       CALL  DSPLY            * VROW+2 VCOL=>02 'DISK ERROR'
       BYTE  >F5,>05,>FF
       CALL  G6CB4
       CALL  DSPLY            * BLANK >0A BYTES
       BYTE  >F0,>0A,>FF
       BR    G70B8
CHECKDISK5 CEQ >F0,@DFLAG
       BR    CHECKDISK6
       CALL  DSPLY            * 'DISK ERROR'
       BYTE  >F5,>05,>E6,>E9,>F0,>0D
       BYTE  >FF
       BR    G70B8
CHECKDISK6 CEQ >31,@DFLAG     * ERROR?
       BS    CHECKDISK7       * Yes
       CEQ   >32,@DFLAG       * ERROR?
       BS    CHECKDISK7       * Yes
       CEQ   >F1,@DFLAG
       BR    CHECKDISK8
CHECKDISK7 CALL  DSPLY        * 'DISK NOT INITIALIZED'
       BYTE  >F5,>57,>F0,>05,>FF
       ST    >F1,@DFLAG
CHECKDISK8 CHE >F0,@DFLAG
       BS    CHECKDISK9
       CEQ   >31,@DFLAG
       BS    CHECKDISK9
       CEQ   >16,@DFLAG
       BS    CHECKDISK9
       CALL  DSPLY            * VROW+2 VCOL=>02 'DISK ERROR'
       BYTE  >F5,>05,>FF
       CALL  G6CB4
       CALL  DSPLY            * BLANK >0A BYTES
       BYTE  >F0,>0A,>FF
CHECKDISK9 FETCH @>8310
           FETCH @>8311
       CHE   >F8,@DFLAG
       BS    CHECKDISKA
       CALL  XHONK
CHECKDISKA CHE   >F2,@DFLAG
       BS    CHECKDISKB
       ST    SPACE,V*BUFADD   * CLEAR NAME BUFFER
       MOVE  9,V*BUFADD,[email protected]>0001(@BUFADD)
CHECKDISKB MOVE  10,V*BUFADD,V*>8310
       DCEQ  >0C7F,@>8310
       BR    CHECKDISKC
       ST    @DFLAG,[email protected]>0C73   * WHY ?????????
       BR    CHECKDISKD
CHECKDISKC ST    @DFLAG,[email protected]>0C8B
CHECKDISKD ST *STATUS,@>8311
       ST    *STATUS,@>8310
       RTN
G70B8  CALL  XHONK
       PUSH  @VROW
       CALL  BANK5
       CALL  FCTNBEEP
       ST    *STATUS,@VROW
       DEC   @VROW
       B     CHECKDISK1
G70CC  ST    >FF,@ERCODE      * SHOW NUMBER
       FETCH @FAC
       DST   *FAC,@FAC
       DST   >2710,@FAC4
       B     G7105
G70DC  ST    >FF,@ERCODE      * SHOW NUMBER
       B     G70F5
G70E2  ST    >FF,@ERCODE      * SHOW NUMBER
       FETCH @FAC
       DST   *FAC,@FAC
       DST   >0064,@FAC4
       B     G7105
G70F2  CLR   @ERCODE
G70F5  FETCH @FAC
       DST   *FAC,@FAC
       B     G7101
       CLR   @ERCODE
G7101  DST   >03E8,@FAC4
G7105  DST   @FAC,@FAC2
       CLR   @FAC11
G710B  DCLR  @FAC
       DDIV  @FAC4,@FAC
       CEQ   >FF,@FAC11
       BR    G711E
       FMT
       SCRO  48
       HSTR  1,@FAC1
       FEND
       B     G7137
G711E  DCZ   @FAC
       BS    G712E
       FMT
       SCRO  48
       HSTR  1,@FAC1
       FEND
       ST    >FF,@FAC11
       B     G7137
G712E  CEQ   >FF,@ERCODE
       BR    G7137
       FMT
       HTEX  ' '
       FEND
G7137  DST   @FAC4,@FAC6
       DCLR  @FAC4
       DDIV  >000A,@FAC4
       DCEQ  >0001,@FAC4
       BR    G710B
       FMT
       SCRO  48
       HSTR  1,@FAC3
       FEND
       RTN
HONKFCTN  CALL  XHONK
       CALL  DSPLY            * 'PRESS: PROC'D, REDO,'
                              * '       BEGIN OR BACK'
       BYTE  >FE,>16,>12,>FF
       BR    G7171
FCTNBEEP  CALL  DSPLY            * 'PRESS: PROC'D, REDO,'
                              * '       BEGIN OR BACK'
       BYTE  >FE,>16,>12,>FF
       BR    BEEPFCTN
BLANK5FCTNBEEP  CALL  BANK5
       CALL  DSPLY            * 'SCREEN IS COMPLETE'
                              * 'PRESS: PROC'D, REDO,'
                              * '       BEGIN OR BACK'
       BYTE  >FE,>15,>11,>F5,>12,>FF
BEEPFCTN  CALL  XBEEP
G7171  ST    SPACE,@VCHAR
       CALL  KSCAN
       CEQ   REDO,@KEY        * FCTN 8
       BR    G7181
G717C  CALL  BANK5
       BR    FCTN8
G7181  CEQ   BEGIN,@KEY       * FCTN 5
       BR    G718B
       CALL  BANK5
       BR    FCTN5
G718B  CEQ   BACK,@KEY        * FCTN 9
       BR    G7195
       CALL  BANK5
       BR    FCTN9
G7195  CEQ   PROCD,@KEY       * FCTN 6
       BR    G71A3
       CEQ   >F8,@DFLAG
       BR    G717C
       CALL  WORKNG
       RTN
G71A3  CALL  XHONK
       BR    G7171
***************************** Subroutine
CMDDONE CALL  BANK5
       CALL  DSPLY            * 'COMMAND COMPLETED'
                              * 'PRESS: PROC'D, REDO,'
                              * '       BEGIN OR BACK'
       BYTE  >FE,>15,>0D,>F5,>12,>FF
       CALL  XBEEP
G71B7  ST    SPACE,@VCHAR
       CALL  KSCAN
       CALL  FCTN
       CEQ   PROCD,@KEY       * FCTN 6
       BR    G71C6
       RTN
G71C6  CALL  XHONK
       BR    G71B7
WORKNG CALL  BANK5
       CALL  DSPLY            * 'WORKING.....   PLEASE WAIT.'
       BYTE  >FE,>15,>10,>FF
       RTN
OVERIDEPROTECT CALL  DSPLY    * 'OVERRIDE PROTECTION (Y/N)?'
       BYTE  >F4,>47,>FF
       CALL  INKEY
       BYTE  YN,>0C,>20,N
       RTN
***************************** Subroutine, 4 bytes fetched
PROTECTION FETCH @FAC4        * UNPROTECT OR PROTECT
       FETCH @FAC5
       FETCH @FAC2
       FETCH @FAC3
       ST    V*FAC2,@FAC2
       CLR   @FAC3
       CEQ   >02,[email protected]>0C20      * >02=YES
       BR    G71FD
       CALL  PROTCT
       BR    CHKERR
G71FD  RTN
GETDRIVEGETINPUT  CALL  BLINES
                  BYTE  >04,>17
       ST    >F8,[email protected]>0C73
       ST    >F8,[email protected]>0C8B
       FETCH @>831C           * ROW value
       CEQ   >FF,@ONEDSK
       BR    G7217
       ST    [email protected],[email protected]
G7217  FETCH @>831E           * ROW+1 FLAG
       FETCH @>831F           * FILENAME FLAG
       FETCH @>8320           * COPY DISK FLAG
       CEQ   >FF,@>8320       * COPY DISK FLAG?
       BR    G7224            * No
       FETCH @>8321           * ROW+1 FLAG
G7224  FETCH @>8322           * 'N' FLAG
       CEQ   >FF,@>8322       * 'N' FLAG?
       BR    G722D            * No
       FETCH @>8324           * MESSAGE NUMBER
G722D  FETCH @>8326           * RETURN FLAG
       ST    @>831C,@VROW     * GET ROW
       ST    >02,@VCOL
       DST   @VROW,@>8327     * SAVE VROW
G7238  DST   @>8327,@VROW     * RESTORE VROW
       CALL  DSPLY            * 'MASTER DISK (1-9)?'
       BYTE  >52,>FF
       ST    >31,@VCHAR       * 1
       CZ    @ONEDSK
       BR    G724E
       CALL  INKEY
       BYTE  NUMBER,>0C,>72,NINE
G724E  CALL  CHECKDISK
       BYTE  >0C,>72,>0E,>12,>0C,>7F
       CALL  G6F88            * VROW+1 VCOL=2
       CHE   >F8,@DFLAG
       BS    G7270
       CEQ   >F2,@DFLAG
       BS    G7270
       CZ    @ONEDSK
       BS    G726E
       CALL  BANK5
       CALL  FCTNBEEP
G726E  BR    G7238
G7270  DST   @>8327,@VROW
       INC   @VROW
       CEQ   >FF,@>831E       * ROW+1 FLAG
       BR    G727C            * No
       INC   @VROW
G727C  CEQ   >FF,@>831F       * FILENAME FLAG
       BR    G728E            * No
       CALL  DSPLY            * 'FILENAME?'
       BYTE  >4F,>FF
       CALL  GETINPUT         * GET INPUT
       BYTE  >0C,>75,>0A,>0C,>74
G728E  INCT  @VROW
       ST    >02,@VCOL
G7293  DST   @>8327,@VROW     * RESTORE VROW
       ADD   >03,@VROW        * VROW+3
       CEQ   >FF,@>831E       * ROW+1 FLAG
       BR    G72A0            * No
       INC   @VROW
G72A0  CZ    @>8320           * COPY DISK FLAG
       BR    G72A9            * Yes
       ST    [email protected],[email protected]
G72A9  CEQ   >FF,@>8320       * COPY DISK FLAG
       BR    G72DC            * No
       CALL  DSPLY            * 'COPY DISK (1-9)?'
       BYTE  >53,>FF
       ST    >31,@VCHAR       * 1
       CZ    @ONEDSK
       BR    G72D3
       CALL  INKEY
       BYTE  NUMBER,>0C,>8A,NINE
       CEQ   >02,[email protected]>0C21
       BR    G72D3
       CEQ   [email protected],[email protected]
       BR    G72D3
       CALL  XHONK
       BR    G7293
G72D3  CALL  CHECKDISK
       BYTE  >0C,>8A,>0E,>12,>0C,>97
G72DC  CALL  G6F88            * VROW+1 VCOL=2
       CHE   >F8,@DFLAG
       BS    G72F5
       CEQ   >F2,@DFLAG
       BS    G72F5
       CZ    @ONEDSK
       BS    G72F3
       CALL  BANK5
       CALL  FCTNBEEP
G72F3  BR    G7293
G72F5  DST   @>8327,@VROW     * RESTORE VROW
       ADD   >04,@VROW        * VROW+4
       CEQ   >FF,@>831E       * ROW+1 FLAG
       BR    G7302            * No
       INC   @VROW
G7302  CEQ   >FF,@>8320       * COPY DISK FLAG
       BR    G730E            * No
       CEQ   >FF,@>8321       * ROW+1 FLAG
       BR    G730E            * No
       INC   @VROW
G730E  CEQ   >FF,@>8322       * 'N' FLAG
       BR    G7323            * No
       CLR   @FAC6            * CLEAR MESSAGE NUMBER
       ST    @>8324,@FAC7     * GET MESSAGE NUMBER
       CALL  DMSG
       CALL  GETINPUT         * GET INPUT
       BYTE  >0C,>8D,>0A,>0C,>8C
G7323  CZ    @>8326           * RETURN FLAG
       BR    BLANK5FCTNBEEP
       RTN
FILECOPY CALL  G6B63
FILECOPY2 ST [email protected],@FAC2    * DRIVE NUMBER
       CLR   @FAC3            * ACCESS CODE
       DST   >0C75,@FAC4      * POINTER TO BUFFER NAME
       ST    >40,@FAC6        * OFFSET POINTER TO ADDITIONAL INFO
       DST   >0E12,@ADINFO    * BUFFER START ADDRESS
       CALL  FILEIN
       ST    @>8331,@ACODE    * ACCESS CODE
       CALL  CHKERR
       CHE   >F8,@DFLAG
       BR    G73E4
       PUSH  @>8342
       PUSH  @>8343
       DCLR  @>8342
       B     G7356
G7353  CALL  G6B63
G7356  ST    [email protected],@DSKNUM  * DRIVE NUMBER
       DST   VBUFF,@BUFADD    * BUFFER ADDRESS
       DCLR  @SECNUM          * SECTOR NUMBER
       ST    >FF,@IOSEC       * SET READ SECTOR BIT
       CALL  SECTORREADWRITE
       CEQ   >50,[email protected]>0B20      * P?
       BR    G7379            * No
       CALL  DSPLY            * 'PROPRIETARY DISK ERROR'
       BYTE  >F3,>FE,>14,>60,>FF
       CALL  HONKFCTN
       BR    FCTN8
G7379  ST    [email protected],@FAC2    * DRIVE NUMBER
       ST    @ACODE,@FAC3     * ACCESS CODE
       DST   >0C75,@FAC4      * POINTER TO BUFFER NAME
       ST    >40,@FAC6        * OFFSET POINTER TO ADDITIONAL INFO
       CALL  FILEIN
       ST    @FAC3,@ACODE     * ACCESS CODE
       CALL  CHKERR
       CHE   >F8,@DFLAG
       BR    G73E4
       CALL  G6B9A
       DCZ   @>8342
       BR    G73BE
       ST    *STATUS,@>8343   * STATUS FLAG
       ST    *STATUS,@>8342   * NUMBER OF FIRST RECORD
       ST    [email protected],@FAC2    * DRIVE NUMBER
       CLR   @FAC3            * ACCESS CODE
       DST   >0C8D,@FAC4      * POINTER TO BUFFER NAME
       ST    >40,@FAC6        * OFFSET POINTER TO ADDITIONAL INFO
       CALL  FILEOU
       CALL  CHKERR
       CHE   >F8,@DFLAG
       BR    G73E4
       DCLR  @>8342
G73BE  ST    [email protected],@FAC2    * DRIVE NUMBER
       ST    @ACODE,@FAC3     * ACCESS CODE
       DST   >0C8D,@FAC4      * POINTER TO BUFFER NAME
       ST    >40,@FAC6        * OFFSET POINTER TO ADDITIONAL INFO
       CALL  FILEOU
       CALL  CHKERR
       CHE   >F8,@DFLAG
       BR    G73E4
       CLR   @>830E
       ST    @ACODE,@>830F    * ACCESS CODE
       DADD  @>830E,@>8342    * NUMBER OF FIRST SECTOR
       CHE   @>8331,@ACODE    * ACCESS CODE
       BS    G7353
G73E4  RTN
***************************** DISPLAY HEADING (parm=message #)
HEADER ALL   SPACE
       CLR   @VROW
HEADER2 INC   @VROW
       CLR   @>8310
       FETCH @>8311           * MESSAGE #
       DST   @>8310,@FAC6     * Save it
       DADD  @>8310,@>8310    * Double it
       DADD  @MBASE,@>8310    * Add in >8300+Message#
       MOVE  4,[email protected](@>8310),@>8312 * Get index address
       DSUB  @>8312,@>8314
       SRL   >01,@>8315
       ST    >10,@VCOL
       SUB   @>8315,@VCOL
       CALL  DMSG             * Put message on screen
G740E  CEQ   >0A,[email protected]>0C27
       BS    G741A
       DST   >2020,[email protected]>000F    * SPACE SPACE
       RTN
G741A  DST   >3E3C,[email protected]>000F    * <>
       RTN
***************************** Subroutine, 4 bytes fetched
INKEY  FETCH @FAC             * FLAG byte
       FETCH @FAC1            * Flag address
       FETCH @FAC2            * Flag address
       CEQ   >02,@FAC         * Message?
       BR    INKEY1           * No.
       FETCH @FAC5            * Highest key
       BR    INKEY3
INKEY1 FETCH @MESNUM          * Message #
       DST   @MBASE,@FAC7     * >8300
       DADD  >0002,@FAC7      * >8300+2
       MOVE  2,[email protected](@FAC7),@FAC9  * Get index address
       MOVE  1,[email protected](@FAC9),@FAC11 * Single byte
       DST   @MBASE,@FAC7     * >8300
       DADD  >0000,@FAC7      * What the heck is this?
       MOVE  2,[email protected](@FAC7),@FAC9  * Get index address
       MOVE  1,[email protected](@FAC9),@FAC12 * Single byte
       CEQ   >02,@MESNUM      * Single letter?
       BR    INKEY2           * No
       ST    @FAC11,V*FAC1    * Save single character 123456789
       BR    INKEY3
INKEY2 ST    @FAC12,V*FAC1    * Save single character YN
INKEY3 CALL  XBEEP
       DST   @OVROW,@VROW
       ST    V*FAC1,@VCHAR    * Show character
       CEQ   >02,@FAC
       BR    INKEY4
       ADD   >30,@VCHAR       * Add >30 to NUMBER
INKEY4 CALL  KSCAN
       CGT   >0F,@KEY
       BS    INKEY5
       DEC   @KEY
       CASE  @KEY
       BR    INKEY8           * FCTN 7
       BR    INKEY3           * FCTN 4
       BR    INKEY8           * FCTN 1
       BR    INKEY8           * FCTN 2
       BR    INKEY8           * FCTN =
       BR    INKEY9           * FCTN 8
       BR    INKEY8           * FCTN 3
       BR    INKEY8           * FCTN S
       BR    INKEY8           * FCTN D
       BR    INKEYA           * FCTN X
       BR    INKEY8           * FCTN E
       BR    INKEY8           * FCTN 6
       BR    INKEYA           * ENTER
       BR    FCTN5            * FCTN 5
       BR    FCTN9            * FCTN 9
INKEY5 CEQ   >01,@FAC
       BR    INKEY6
       CEQ   @FAC11,@KEY
       BS    INKEY6
       CEQ   @FAC12,@KEY
       BR    INKEY8
INKEY6 CEQ   >02,@FAC
       BR    INKEY7
       CH    @FAC5,@KEY
       BS    INKEY8
       CHE   >31,@KEY         * 1?
       BR    INKEY8
INKEY7 ST    @KEY,@VCHAR
       BR    INKEY4
INKEY8 CALL  XHONK
       BR    INKEY4
INKEY9 B     FCTN8
INKEYA CEQ   >01,@FAC
       BR    INKEYC
       ST    @VCHAR,@KEY
       CEQ   @FAC11,@VCHAR
       BR    INKEYB
       ST    >02,V*FAC1
       BR    INKEYC
INKEYB CLR   V*FAC1
INKEYC CEQ   >02,@FAC
       BR    INKEYD
       ST    @VCHAR,V*FAC1
       SUB   >30,V*FAC1
       ST    V*FAC1,@KEY
INKEYD RTN
GETDEVICENAME ST   >02,@FAC17 * GET DEVICE NAME
              B     GETINPUT1
GETINPUT  CLR   @FAC17         * GET INPUT
GETINPUT1 FETCH @FAC12
          FETCH @FAC13
          FETCH @FAC
          ST    >01,@FAC1
GETINPUT2 CALL  G6F81
          INC   @FAC1
          CEQ   @FAC,@FAC1
          BR    GETINPUT2
          CALL  CVRC
          DST   @SCRADD,@FAC5
          DST   @VROW,@FAC3
          CALL  XBEEP
          FETCH @ARG
          FETCH @ARG1
          ST    V*ARG,@FAC2
GETINPUT3 DST   @OVROW,@VROW
          DST   @FAC12,@ARG2
          ST    >01,@FAC1
          CZ    @FAC2
          BS    GETINPUT5
GETINPUT4 ST    V*ARG2,@VCHAR
          DINC  @ARG2
          CALL  G6F81
          INC   @FAC1
          CH    @FAC2,@FAC1
          BR    GETINPUT4
GETINPUT5 CGT   @FAC,@FAC1
          BS    GETINPUT7
          CALL  CVRC
GETINPUT6 ST    >61,@VCHAR
          CALL  G6F81
          CALL  CVRC
          DCGT  @FAC5,@SCRADD
          BR    GETINPUT6
GETINPUT7 DST   @OVROW,@VROW
GETINPUT8 CLR   @FAC7
          MOVE  8,[email protected],[email protected]>0B00
GETINPUT9 EX    @CURSOR,@VCHAR
          CALL  KSCAN
          CGT   >0F,@KEY
          BS    GETINPUTA
          DEC   @KEY
          CASE  @KEY
          BR    GETINPUTH        * FCTN 7
          BR    GETINPUTI        * FCTN 4
          BR    GETINPUTJ        * FCTN 1
          BR    GETINPUTM        * FCTN 2
          BR    GETINPUTH        * FCTN =
          BR    FCTN8            * FCTN 8
          BR    GETINPUTH        * FCTN 3
          BR    GETINPUTO        * FCTN S
          BR    GETINPUTP        * FCTN D
          BR    GETINPUTH        * FCTN X
          BR    GETINPUTH        * FCTN E
          BR    GETINPUTH        * FCTN 6
          BR    GETINPUTQ        * ENTER
          BR    FCTN5            * FCTN 5
          BR    FCTN9            * FCTN 9
GETINPUTA CZ    @FAC17
          BR    GETINPUTB
          CEQ   SPACE,@KEY       * SPACE?
          BS    GETINPUTH
          CEQ   >2E,@KEY         * PERIOD?
          BS    GETINPUTH
GETINPUTB CEQ   >FF,@FAC7
          BR    GETINPUTE
          CEQ   @FAC,@FAC2
          BS    GETINPUTH
          DST   @VROW,@FAC8
          CALL  CVRC
          DCEQ  @FAC5,@SCRADD
          BS    GETINPUTH
          ST    @VCHAR,@ERCODE
          CALL  G6F81
GETINPUTC ST    @VCHAR,@FAC11
          ST    @ERCODE,@VCHAR
          ST    @FAC11,@ERCODE
          CALL  G6F81
          CALL  CVRC
          DCGT  @FAC5,@SCRADD
          BS    GETINPUTD
          CEQ   >61,@ERCODE
          BR    GETINPUTC
GETINPUTD DST   @FAC8,@VROW
          ST    >61,@VCHAR
GETINPUTE CEQ   >61,@VCHAR
          BR    GETINPUTF
          INC   @FAC2
GETINPUTF ST    @KEY,@VCHAR
          CALL  CVRC
          DCEQ  @FAC5,@SCRADD
          BS    GETINPUTG
          CALL  G6F81
GETINPUTG B     GETINPUT9
GETINPUTH CALL  XHONK
          BR    GETINPUT9
GETINPUTI CLR   @FAC2
          B     GETINPUT3
GETINPUTJ CEQ   >61,@VCHAR
          BS    GETINPUTH
          CZ    @FAC2
          BS    GETINPUTH
          DEC   @FAC2
          DST   @VROW,@FAC8
          CALL  CVRC
          DCEQ  @FAC5,@SCRADD
          BS    GETINPUTL
          DST   @FAC5,@>8310
          DSUB  @SCRADD,@>8310
GETINPUTK CALL  G6F81
          ST    @VCHAR,V*SCRADD
          CEQ   >61,@VCHAR
          BS    GETINPUTL
          CALL  CVRC
          DCEQ  @FAC5,@SCRADD
          BR    GETINPUTK
GETINPUTL ST    >61,@VCHAR
          DST   @FAC8,@VROW
          B     GETINPUT8
GETINPUTM CZ    @FAC2
          BS    GETINPUTH
          CEQ   @FAC,@FAC2
          BS    GETINPUTH
          DCEQ  >004D,@VROW
GETINPUTN BS    GETINPUTH
          ST    >FF,@FAC7
          MOVE  8,[email protected],[email protected]>0B00
          B     GETINPUT9
GETINPUTO DCEQ  @OVROW,@VROW
          BS    GETINPUTH
          CALL  G6F8E
          BR    GETINPUT8
GETINPUTP CALL  CVRC
          DCEQ  @FAC5,@SCRADD
          BS    GETINPUTH
          CEQ   >61,@VCHAR
          BS    GETINPUTH
          CALL  G6F81
          BR    GETINPUT8
GETINPUTQ CZ    @FAC2
          BS    GETINPUTH
          DST   @OVROW,@VROW
          CLR   @FAC1
GETINPUTR CEQ   >61,@VCHAR
          BR    GETINPUTS
          ST    SPACE,@VCHAR
GETINPUTS ST    @VCHAR,V*FAC12
          DINC  @FAC12
          CALL  G6F81
          INC   @FAC1
          CEQ   @FAC,@FAC1
          BR    GETINPUTR
          ST    @FAC2,V*ARG
          MOVE  8,[email protected],[email protected]>0B00
          RTN
FCTN   CEQ   REDO,@KEY        * FCTN 8
       BS    FCTN8
       CEQ   BEGIN,@KEY       * FCTN 5
       BS    FCTN5
       CEQ   BACK,@KEY        * FCTN 9
       BS    FCTN9
       RTN
FCTN8  DST   @REDOX,[email protected]>0C1A
       B     G76C2
FCTN5  DST   @BEGINX,[email protected]>0C1A
       B     G76C2
FCTN9  DST   @BACKX,[email protected]>0C1A
G76C2  CALL  BANK5
       ST    >7E,@SUBSTK
       ST    >9E,@DATSTK
       CALL  G76CE
G76CE  DST   [email protected]>0C1A,*SUBSTK
       MOVE  8,[email protected],[email protected]>0B00
       RTN
***************************** Display Message.  8350=msg #
DMSG   DCHE  >0064,@FAC6      * Highest number of messeges
       BS    DMSG1
       DST   @MBASE,@FAC4
       BR    DMSG2
DMSG1  DST   @>8337,@FAC4
       DSUB  >0064,@FAC6
DMSG2  DADD  @FAC6,@FAC4
       DADD  @FAC6,@FAC4
       MOVE  4,[email protected](@FAC4),@FAC6
       DSUB  @FAC6,@FAC8
       CALL  CVRC
       MOVE  @FAC8,[email protected](@FAC6),V*SCRADD
       DST   @FAC8,@>830E
       DSRL  >0005,@FAC8
       ADD   @FAC9,@VROW
       AND   >1F,@>830F
       ADD   @>830F,@VCOL
DMSG3  CZ    @>832F
       BS    DMSG4
       ST    SPACE,@VCHAR
       INC   @VCOL
DMSG4  ST    >FF,@>832F
       DST   @VROW,@OVROW
       RTN
       BYTE  >2F,>2C,>2A,>3D,>23,>3F
       BYTE  >20,>3E,>3C,>30
ADSPLY ST   >00,@>832F
***************************** Multi-lingual display
*  >F0nn nn blanks to current posn
*  >F1   blank lines 1-18
*  >F2   blank line 18
*  >F3   blank lines 20-23
*  >F4   VROW+2, VCOL=2
*  >F5   VROW+1, VCOL=2
*  >FF   end of parms
*  >FB   fetch VCOL
*  >FC   fetch VROW
*  >FE   fetch VROW, VCOL=2
DSPLY  CLR   @FAC6
DSPLY1 FETCH @FAC7
       CALL  CVRC
       CHE   >E0,@FAC7
       BS    DSPLY2
       CALL  DMSG
       BR    DSPLY
DSPLY2 CHE   >F0,@FAC7
       BS    DSPLY3
       MOVE  1,[email protected](@FAC6),V*SCRADD
       INC   @VCOL
       B     DSPLY
DSPLY3 CEQ   >FF,@FAC7
       BS    DMSG4
       CH    >FA,@FAC7
       BS    DSPLYC
       SUB   >F0,@FAC7
       CASE  @FAC7
       BR    DSPLY4
       BR    DSPLY6
       BR    DSPLY7
       BR    DSPLY8
       BR    DSPLYA
       BR    DSPLYB
       CALL  DMSG3
       BR    DSPLY
DSPLY4 FETCH @FAC2
DSPLY5 ST    SPACE,@VCHAR
       INC   @VCOL
       DEC   @FAC2
       BR    DSPLY5
       BR    DSPLY1
DSPLY6 DST   @VROW,@FAC11
       FMT
       COL   0
       ROW   0
       FOR   19
       HCHA  32,' '
       ROW+  1
       FEND
       FEND
       B     DSPLY9
DSPLY7 DST   @VROW,@FAC11
       CALL  BLINES
       BYTE  >12,>12
       BR    DSPLY9
DSPLY8 DST   @VROW,@FAC11
       CALL  BLINES
       BYTE  >14,>17
DSPLY9 DST   @FAC11,@VROW
       B     DSPLY1
DSPLYA INC   @VROW
DSPLYB INC   @VROW
       ST    >02,@VCOL
       B     DSPLY1
DSPLYC CEQ   >FC,@FAC7
       BR    DSPLYD
       FETCH @VROW
DSPLYD CEQ   >FB,@FAC7
       BR    DSPLYE
       FETCH @VCOL
DSPLYE CEQ   >FD,@FAC7
       BR    DSPLYF
       FETCH @VCOL
       CLR   @VROW
       DSRC  >0004,@VROW
       SRL   >04,@VROW
DSPLYF CEQ   >FE,@FAC7
       BR    DSPLYG
       FETCH @VROW
       ST    >02,@VCOL
DSPLYG B     DSPLY1
********************************************************************************
MENU1  DATA  >0000
       DATA  ENGLSH
       STRI  'DISK MANAGER 5'
********************************************************************************
ENGLSH DST  ENGMSG,@MBASE
       ALL   SPACE
G81F2  DST   DMANGR,@BEGINX
       ST    >01,@FAC2        * CALL FILES 1
       DST   >0116,[email protected]>0C1A    *
       DST   >0C1A,@FAC12      *
       CALL  LINK             *
       BYTE  >0A              *
       ALL   SPACE
       DST   >0900,@FAC
       CALL  LOCASE           * Load lower case
       ST    >01,[email protected]
       ST    >02,[email protected]
       DCLR  @>832B
       DST   @MEMSIZ,@>830E
       DINC  @>830E
       DSUB  >0E12,@>830E
       ST    @>830E,@>8331
       ST    >FF,@>832F
       ST    >60,@CURSOR
       MOVE  8,[email protected],[email protected]>0B00 * CURSOR
       MOVE  8,[email protected],[email protected]>0B08 * EDGE CHARACTER
       CLR   @ONEDSK
       ST    >01,[email protected]>0C21
       MOVE  5,[email protected]>0C21,[email protected]>0C22
       CLR   [email protected]>0C74
       CLR   [email protected]>0C8C
       CLR   [email protected]>0CCF          * Length byte
       CLR   [email protected]>0C27
***************************** Disk Manager *************************************
DMANGR DST   DMANGR,@REDOX
       DST   QUIT,@BACKX
       CALL  HEADER           * 'DISK MANAGER'
       BYTE  >1E
       CALL  DSPLY            * '1' 'FILE COMMANDS'
                              * '2' 'DISK COMMANDS'
                              * '3' 'DISK TESTS'
                              *
       BYTE  >F4,>15,>1F,>F4,>16,>20
       BYTE  >F4,>17,>21,>FF
       CZ    @ONEDSK
       BR    SINGLE
       CALL  DSPLY            * '4''SET ALL COMMANDS FOR SINGLE DISK PROCESSING'
                              * 'YOUR CHOICE?'
       BYTE  >F4,>18,>22,>FE,>16,>4E
       BYTE  >FF
       CALL  INKEY
       BYTE  NUMBER,>0C,>21,FOUR
       BR    NORMAL
SINGLE CALL  DSPLY            * 'SINGLE DISK PROCESSING HAS BEEN INITIALIZED'
                              * 'YOUR CHOICE?'
       BYTE  >F4,>23,>FE,>16,>4E,>FF
       CALL  INKEY
       BYTE  NUMBER,>0C,>21,THREE
NORMAL DEC   @KEY
       CASE  @KEY
       BR    FMANGR
       BR    DCMDS
       BR    DTEST
       ST    >FF,@ONEDSK
       ST    >01,[email protected]
       ST    >01,[email protected]
       ST    >01,[email protected]>0C21
       B     DMANGR
QUIT   EXIT
***************************** File Manger **************************************
FMANGR DST   FMANGR,@REDOX
       DST   DMANGR,@BACKX
       CALL  HEADER           * 'FILE COMMANDS'
       BYTE  >1F
       CALL  DSPLY            * '1' 'COPY FILE'
                              * '2' 'RENAME FILE'
                              * '3' 'DELETE FILE'
                              * '4' 'MODIFIY FILE PROTECTION'
                              * 'YOUR CHOICE?'
       BYTE  >F4,>15,>24,>F4,>16,>25
       BYTE  >F4,>17,>26,>F4,>18,>28
       BYTE  >FE,>16,>4E,>FF
       CALL  INKEY
       BYTE  NUMBER,>0C,>22,FOUR
       DEC   @KEY
       DST   FMANGR,@BACKX
       CLR   [email protected]>0C74
       CLR   [email protected]>0C8C
       CASE  @KEY
       BR    FCOPY
       BR    FRENA
       BR    FDEL
       BR    FMODP
***************************** Disk Commands ************************************
DCMDS  DST   DCMDS,@REDOX
       DST   DMANGR,@BACKX
       CALL  HEADER           * 'DISK COMMANDS'
       BYTE  >20
       CALL  DSPLY            * '1' 'CATALOG DISK'
                              * '2' 'BACKUP DISK'
                              * '3' 'MODIFY DISK NAME'
                              * '4' 'INITIALIZE NEW DISK'
                              * 'YOUR CHOICE?'
       BYTE  >F4,>15,>2A,>F4,>16,>2B
       BYTE  >F4,>17,>2D,>F4,>18,>2F
       BYTE  >FE,>16,>4E,>FF
       CALL  INKEY
       BYTE  NUMBER,>0C,>23,FOUR
       DEC   @KEY
       DST   DCMDS,@BACKX
       CLR   [email protected]>0C89
       CLR   [email protected]>0CA1
       CASE  @KEY
       BR    DCAT
       BR    DBKUP
       BR    DMOD
       BR    DINIT
***************************** Disk Tests ***************************************
DTEST  DST   DTEST,@REDOX
       DST   DMANGR,@BACKX
       CALL  HEADER           * 'DISK TESTS'
       BYTE  >21
       CALL  DSPLY            * '1' 'QUICK TEST'
                              * '2' 'COMPREHENSIVE TEST'
                              * 'YOUR CHOICE?'
       BYTE  >F4,>15,>30,>F4,>16,>31
       BYTE  >FE,>16,>4E,>FF
       CALL  INKEY
       BYTE  NUMBER,>0C,>24,TWO
       DEC   @KEY
       DST   DTEST,@BACKX
       CLR   [email protected]>0C89
       CLR   [email protected]>0CA1
       CASE  @KEY
       BR    TQICK
       BR    TCOMP
 
****************************** GROM 8000 ***************************************
       GROM  >8000
       AORG  >0010
 
G8010  TEXT  '<<$$$$<<'              * CURSOR CHARACTER
G8018  TEXT  'xx````xx'              * EDGE CHARACTER
G8020  BYTE  >00,>00,>00,>00,>24,>24,>3C,>3C,>42,>59
***************************** Message Table ************************************
                                * ADDRESS OF MESSAGES IN GROM
ENGMSG DATA  G8448,G8449,G844A
       DATA  G844A,G844A,G844A
       DATA  G8454,G8454,G8454
       DATA  G8454,G8454,G8454
       DATA  G8454,G8454,G8465
       DATA  G8475,G8483,G849D
       DATA  G84AF,G84E4,G84E4
       DATA  G84E4,G84E5,G84E6
       DATA  G84E7,G84E8,G84E9
       DATA  G84EA,G84EB,G84EC
       DATA  G84ED,G84F9,G8506
       DATA  G8513,G851D,G8553
       DATA  G8583,G858C,G8597
       DATA  G85A2,G85A2,G85B8
       DATA  G85B8,G85C4,G85CF
       DATA  G85CF,G85DF,G85DF
       DATA  G85F2,G85FC,G860E
       DATA  G860E,G8617,G8624
       DATA  G8635,G863F,G8645
       DATA  G8681,G8688,G868C
       DATA  G8690,G8693,G8696
       DATA  G8696,G8696,G86B0
       DATA  G8717,G8722,G8736
       DATA  G8736,G8743,G8751
       DATA  G876B,G876B,G8776
       DATA  G878D,G87A2,G87B5
       DATA  G87C5,G87D1,G87DA
       DATA  G87E6,G87F3,G8805
       DATA  G8815,G8815,G8815
       DATA  G8825,G8839,G8839
       DATA  G8839,G8839,G8839
       DATA  G886F,G887E,G888D
       DATA  G889E,G88B4,G88BA
       DATA  G88CA,G88D0
***************************** TEXT MESSAGES ************************************
G8448  TEXT  'N'                                                      * >00
G8449  TEXT  'Y'                                                      * >01
G844A  TEXT  'DISK ERROR'                                             * >05
G8454  TEXT  'COMMAND COMPLETED'                                      * >0D
G8465  TEXT  'LOAD MASTER DISK'                                       * >0E
G8475  TEXT  'LOAD COPY DISK'                                         * >0F
G8483  TEXT  'WORKING.....  PLEASE WAIT.'                             * >10
G849D  TEXT  'SCREEN IS COMPLETE'                                     * >11
G84AF  TEXT  'PRESS: PROC''D, REDO,            BEGIN, OR BACK'        * >12
G84E4  TEXT  '1'                                                      * >15
G84E5  TEXT  '2'                                                      * >16
G84E6  TEXT  '3'                                                      * >17
G84E7  TEXT  '4'                                                      * >18
G84E8  TEXT  '5'                                                      * >19
G84E9  TEXT  '6'                                                      * >1A
G84EA  TEXT  '7'                                                      * >1B
G84EB  TEXT  '8'                                                      * >1C
G84EC  TEXT  '9'                                                      * >1D
G84ED  TEXT  'DISK MANAGER'                                           * >1E
G84F9  TEXT  'FILE COMMANDS'                                          * >1F
G8506  TEXT  'DISK COMMANDS'                                          * >20
G8513  TEXT  'DISK TESTS'                                             * >21
G851D  TEXT  'SET ALL COMMANDS FOR            SINGLE DISK PROCESSING' * >22
G8553  TEXT  'SINGLE DISK PROCESSING HAS      BEEN INITIALIZED'       * >23
G8583  TEXT  'COPY FILE'                                              * >24
G858C  TEXT  'RENAME FILE'                                            * >25
G8597  TEXT  'DELETE FILE'                                            * >26
G85A2  TEXT  'MODIFY FILE PROTECTION'                                 * >28
G85B8  TEXT  'CATALOG DISK'                                           * >2A
G85C4  TEXT  'BACKUP DISK'                                            * >2B
G85CF  TEXT  'MODIFY DISK NAME'                                       * >2D
G85DF  TEXT  'INITIALIZE NEW DISK'                                    * >2F
G85F2  TEXT  'QUICK TEST'                                             * >30
G85FC  TEXT  'COMPREHENSIVE TEST'                                     * >31
G860E  TEXT  'DISKNAME='                                              * >33
G8617  TEXT  'NEW FILENAME?'                                          * >34
G8624  TEXT  'DSK  -  DISKNAME='                                      * >35
G8635  TEXT  'AVAILABLE='                                             * >36
G863F  TEXT  ' USED='                                                 * >37
G8645  TEXT  ' FILENAME  SIZE '                                       * >38
       TEXT  '   TYPE    P    '
       TEXT  '---------- ---- '
       TEXT  '---------- -'
G8681  TEXT  'PROGRAM'                                                * >39
G8688  TEXT  'DIS/'                                                   * >3A
G868C  TEXT  'INT/'                                                   * >3B
G8690  TEXT  'VAR'                                                    * >3C
G8693  TEXT  'FIX'                                                    * >3D
G8696  TEXT  'WHERE DO YOU WANT LISTING?'                             * >40
G86B0  TEXT  '1 SCREEN        '                                       * >41
       TEXT  '                '
       TEXT  '2 SOLID STATE PRINTER           '
       TEXT  '3 PIO INTERFACE                 '
       TEXT  '4 OTHER'
G8717  TEXT  'DESTRUCTIVE'                                            * >42
G8722  TEXT  'LISTING DEVICE ERROR'                                   * >43
G8736  TEXT  'DELETE (Y/N)?'                                          * >45
G8743  TEXT  'PROTECT (Y/N)?'                                         * >46
G8751  TEXT  'OVERRIDE PROTECTION (Y/N)?'                             * >47
G876B  TEXT  'LOOP (Y/N)?'                                            * >49
G8776  TEXT  'DESTRUCTIVE TEST (Y/N)?'                                * >4A
G878D  TEXT  'SINGLE DENSITY (Y/N)?'                                  * >4B
G87A2  TEXT  'SINGLE SIDED (Y/N)?'                                    * >4C
G87B5  TEXT  'TRACKS PER SIDE?'                                       * >4D
G87C5  TEXT  'YOUR CHOICE?'                                           * >4E
G87D1  TEXT  'FILENAME?'                                              * >4F
G87DA  TEXT  'DEVICE NAME?'                                           * >50
G87E6  TEXT  'NEW DISKNAME?'                                          * >51
G87F3  TEXT  'MASTER DISK (1-9)?'                                     * >52
G8805  TEXT  'COPY DISK (1-9)?'                                       * >53
G8815  TEXT  'BAD ADDRESS/CODE'                                       * >56
G8825  TEXT  'DISK NOT INITIALIZED'                                   * >57
G8839  TEXT  'PRESS:          '                                       * >5C
       TEXT  '                '
       TEXT  'CLEAR TO ABORT COMMAND'
G886F  TEXT  'COMPLETED PASS:'                                        * >5D
G887E  TEXT  '  TOTAL ERRORS:'                                        * >5E
G888D  TEXT  'LOG ERRORS (Y/N)?'                                      * >5F
G889E  TEXT  'PROPRIETARY DISK ERROR'                                 * >60
G88B4  TEXT  '(Y/N)?'                                                 * >61
G88BA  TEXT  'SELECTIVE (Y/N)?'                                       * >62
G88CA  TEXT  'TEST #'                                                 * >63
G88D0  BYTE  >00
********************************************************************************
       END
 
 

 

  • Like 1

Share this post


Link to post
Share on other sites

Above was Rich Disk Manager 5

This below is RXB2001 but the XB source is there, lost the original in a Hard Drive failure.

Spoiler

 
***********************************************************
       TITL 'MYXB3'
***********************************************************
       GROM >6000
***********************************************************
       TITL 'EQUATES EDIT-359'
***********************************************************
CPUBAS EQU  >A040             CRU base
***********************************************************
*           GROM ADDRESSES
MZMSG  EQU  >6038             Start of message area
MZPSCN EQU  >6A70             Module PSCAN branch table add
***********************************************************
OUTREC EQU  >801A
G8024  EQU  >8024             CHKEND in upper GROM is diffe
KEYTAB EQU  >CB00
ERRTAB EQU  >CD77
TRACBK EQU  >CE1F
RETNOS EQU  >CF68
EDTZZ0 EQU  >D000             Edit a line or display it tab
EDTZ00 EQU  >D00D             Edit a line or display it
SAVLIN EQU  >D0AF             Save input line address
GE025  EQU  >E025             RXB PATCH CODE FOR EA CART
***********************************************************
*    EQUATES FOR ROUTINES FROM OTHER SECTIONS
 
CLSALL EQU  >8012             CLose ALL open files
SAVE   EQU  >8014             SAVE a program
OLD    EQU  >8016             OLD  (load a program)
LIST   EQU  >8018             LIST a program
OLD1   EQU  >8026             A subprogram for LOAD
MERGE  EQU  >8028             MERGE a program
GRMLST EQU  >802A             List program line from ERAM
GRSUB2 EQU  >802C             Read from ERAM(GREAD1) or VDP
GRSUB3 EQU  >802E             Read from ERAM(use GREAD1) or
*                              VDP, reset prossible bkpt to
ATNZZ  EQU  >0032             Arctangent routine
ERRZ   EQU  >6A84             ERRor routine
EXEC   EQU  >A004
ASC    EQU  >A00A
EXEC1  EQU  >A00C             EXECute a program statememt
EXEC6D EQU  >A00E
DELINK EQU  >A010
SQUISH EQU  >A014
INTRND EQU  >A018             Initilize random number
LINK1  EQU  >A026             LINK to subprogram
***********************************************************
*    Equates for routine in MONITOR
CALDSR EQU  >10               CALL DEVICE SERVICE ROUTINE
TONE1  EQU  >34               ACCEPT TONE
TONE2  EQU  >36               BAD TONE
***********************************************************
*    Equates for XMLs
SYNCHK EQU  >00               SYNCHK XML selector
SEETWO EQU  >03               SEETWO XML selector
COMPCT EQU  >70               PREFORM A GARBAGE COLLECTION
MEMCHK EQU  >72               MEMORY check routine: VDP
VPUSH  EQU  >77               Push on value stack
VPOP   EQU  >78               Pop off value stack
PGMCHR EQU  >79               GET PROGRAM CHARACTER
SCHSYM EQU  >7D               Search symbol table
SPEED  EQU  >7E               SPEED UP XML
CRUNCH EQU  >7F               Crunch an input line
CONTIN EQU  >81               Continue after a break
SCROLL EQU  >83               SCROLL THE SCREEN
IO     EQU  >84               IO utility (KW table search)
GREAD  EQU  >85               READ DATA FROM ERAM
GWRITE EQU  >86               WRITE DATA TO ERAM
DELREP EQU  >87               REMOVE CONTENT FROM VDP/ERAM
MVDN   EQU  >88               MOVE DATA IN VDP/ERAM
MVUP EQU    >89               MOVE DATA IN VDP/ERAM
VGWITE EQU  >8A               MOVE DATA FROM VDP TO ERAM
GVWITE EQU  >8B               WRITE DATA FROM GRAM TO VRAM
GDTECT EQU  >8E               ERAM DETECT&ROM PAGE 1 ENABLE
SCNSMT EQU  >8F               SCAN STATEMENT FOR PRESCAN
***********************************************************
*    GPL Status Block
STACK  EQU  >8372             STACK FOR DATA
KEYBD  EQU  >8374             KEYBOARD SELCTION
RKEY   EQU  >8375             KEY CODE
RANDOM EQU  >8378             RANDOM NUMBER GENERATOR
TIMER  EQU  >8379             TIMING REGISTER
MOTION EQU  >837A             NUMBER OF MOVING SPRITES
VDPSTS EQU  >837B             VDP STATUS REGISTER
ERCODE EQU  >837C             STATUS REGISTER
***********************************************************
*    Temporary workspaces in EDIT
VAR0   EQU  >8300            TEMPORARY
VARV   EQU  >8301            TEMPORARY
ACCUM  EQU  >8302            # OF BYTES ACCUMULATOR (4 BYTE
STPT   EQU  >8302            TWO BYTES
VARY   EQU  >8304
VARY2  EQU  >8306
PABPTR EQU  >8304
DFLTLM EQU  >8306            Default array limit (10)
CCPPTR EQU  >8306            OFFSET WITHIN RECORED (1)
RECLEN EQU  >8307            LENGTH OF CURRENT RECORD (1)
CCPADR EQU  >8308            RAM address of current refs
VARC   EQU  >8308
CCPADD EQU  >8308            RAM address of current color
CALIST EQU  >830A            Call list for resolving refs
RAMPTR EQU  >830A            Pointer for crunching
BYTES  EQU  >830C            BYTE COUNTER
NMPTR  EQU  >830C            Pointer save for pscan
CHSAV  EQU  >830E
CURINC EQU  >830E            Increment for auto-num mode
TOPSTK EQU  >8310            Top of data stack pointer
LINUM  EQU  >8312            Used to determine end of scan
NMLEN  EQU  >8314            Current line for auto-num
CURLIN EQU  >8314            Current line for auto-num
VAR9   EQU  >8316
XFLAG  EQU  >8316            SCAN FLAG-BITS USED AS BELOW
DSRFLG EQU  >8317            INTERNAL =60, EXTERNAL =0 (1)
FORNET EQU  >8317            Nesting level of for/next
AAA1   EQU  >8302
BBB1   EQU  >830C
CCC1   EQU  >8308
***********************************************************
*    Permanent workspace variables
STRSP  EQU  >8318            String space begining
STREND EQU  >831A            String space ending
SREF   EQU  >831C            Temporary string pointer
SMTSRT EQU  >831E            Start of current statement
VARW   EQU  >8320            Screen address
ERRCOD EQU  >8322            Return error code from ALC
STVSPT EQU  >8324            Value-stack base
VARA   EQU  >832A            Ending display location
PGMPTR EQU  >832C            Program text pointer
EXTRAM EQU  >832E            Line number table pointer
STLN   EQU  >8330            Start of line number table
ENLN   EQU  >8332            End of line number table
DATA   EQU  >8334            Data pointer for READ
LNBUF  EQU  >8336            Line table pointer for READ
INTRIN EQU  >8338            Add of intrinsic poly constant
SUBTAB EQU  >833A            Subprogram symbol table
IOSTRT EQU  >833C            PAB list/Start of I/O chain
SYMTAB EQU  >833E            Symbol table pointer
FREPTR EQU  >8340            Free space pointer
CHAT   EQU  >8342            Current charater/token
BASE   EQU  >8343            OPTION BASE value
PRGFLG EQU  >8344            Program/imperative flag
FLAG   EQU  >8345            General 8-bit flag
BUFLEV EQU  >8346            Crunch-buffer destruction leve
LSUBP  EQU  >8348            Last subprogram block on stack
* FAC  EQU  >834A            Floating-point ACcurmulator
FAC1   EQU  FAC+1
FAC2   EQU  FAC+2
FAC3   EQU  FAC+3
FAC4   EQU  FAC+4
FAC5   EQU  FAC+5
FAC6   EQU  FAC+6
FAC7   EQU  FAC+7
FAC8   EQU  FAC+8
FAC9   EQU  FAC+9
FAC10  EQU  FAC+10
FAC12  EQU  FAC+12
FAC13  EQU  FAC+13
FAC14  EQU  FAC+14
FAC15  EQU  FAC+15
FAC16  EQU  FAC+16
FAC17  EQU  FAC+17
AAA    EQU  FAC+2
CCC    EQU  FAC+4
BBB    EQU  FAC+6
DDD    EQU  FAC+2
FFF    EQU  FAC+4
EEE    EQU  FAC+6
DDD1   EQU  FAC+10
FFF1   EQU  FAC+12
EEE1   EQU  FAC+14
* ARG  EQU  >835C             Floating-point ARGument
ARG1   EQU  ARG+1
ARG2   EQU  ARG+2
ARG3   EQU  ARG+3
ARG4   EQU  ARG+4
ARG5   EQU  ARG+5
ARG6   EQU  ARG+6
ARG7   EQU  ARG+7
ARG8   EQU  ARG+8
XSTLN  EQU  >8364            GKXB variable
XENLN  EQU  >8366            GKXB variable
ARG11  EQU  ARG+11
XCURLI EQU  >8368            GKXB variable
XCURIN EQU  >836A            GKXB variable
ARG15  EQU  ARG+15
ARG16  EQU  ARG+16
* VSPTR  EQU  >836E          Value stack pointer
EXPZ   EQU  >8376            Exponent in floating-point
RAMTOP EQU  >8384            Highest address in ERAM
RAMFRE EQU  >8386            Free pointer in the ERAM
RSTK   EQU  >8388            Subroutine stack base
RAMFLG EQU  >8389            ERAM flag
STKMIN EQU  >83AF            Base of data stack
STKMAX EQU  >83BD            Top of data stack
PRTNFN EQU  >83CE
***********************************************************
*    VDP addresses
NLNADD EQU  >02E2             New LiNe ADDress
ENDSCR EQU  >02FE             END of SCReen address
LODFLG EQU  >0371             Auto-boot needed flag
START  EQU  >0372             Line to start execution at
SYMBOL EQU  >0376             Saved symbol table pointer
SPGMPT EQU  >0382             Saved PGMPTR for continue
SBUFLV EQU  >0384             Saved BUFLEV for contiue
SEXTRM EQU  >0386             Saved EXTRAM for continue
* SAVEVP EQU  >0388           Saved VSPRT for continue
* ERRLN  EQU  >038A           On-error line pointer
BUFSRT EQU  >038C             Edit recall start addr (VARW)
BUFEND EQU  >038E             Edit recall end addr (VARA)
TABSAV EQU  >0392             Saved main symbol table ponte
SLSUBP EQU  >0396             Saved LSUBP for continue
SFLAG  EQU  >0398             Saved on-warning/break bits
SSTEMP EQU  >039A             To save subprogram program ta
SSTMP2 EQU  >039C             Same as above. Used in SUBPRO
MRGPAB EQU  >039E             MERGEd temporary for pab ptr
*----------------------------------------------------------
* Added 6/8/81 for NOPSCAN feature
PSCFG  EQU  >03B7
*----------------------------------------------------------
*    Flag 0:  99/4  console, 5/29/81
*         1:  99/4A console
CONFLG EQU  >03BB
*----------------------------------------------------------
* Temporary
NOTONE EQU  >0374             NO-TONE for SIZE in ACCEPT us
*                              in FLMGRS (4 bytes used)
SAVEVP EQU  >0388
ERRLN  EQU  >038A
ACCVRW EQU  >03AC             Temoporary used in ERRZZ, als
*                              used in FLMGRS
VALIDP EQU  >03B0             Use as two values passing fro
VALIDL EQU  >03B2             VALIDATE code to READL1
OLDTOP EQU  >03BC             Temporary used in ERRZZ, also
CRNBUF EQU  >0820             CRuNch BUFfer address
CRNEND EQU  >08BE             CRuNch buffer END
RECBUF EQU  >08C0             Edit RECall BUFfer
VRAMVS EQU  >0958             Default base of value stack
CNSTMP EQU  >0390             Use as temporary stored place
***********************************************************
*    IMMEDITATE VALUES
NUMBR  EQU  >00               NUMERIC validate
LISTZ  EQU  >02
OLDZ   EQU  >05
RESEQZ EQU  >06
SAVEZ  EQU  >07
MERGEZ EQU  >08
DWNARR EQU  >0A
UPARR  EQU  >0B
CHRTN  EQU  >0D
OFFSET EQU  >60
OSPACE EQU  >20+OFFSET        GKXB space plus offset
*  Bits in XFLAG
REMODE EQU  0                 REM only mode
OPTFLG EQU  1                 Option base declared flag
FNCFLG EQU  2                 Scanning UDF
SUBFLG EQU  3                 Scanning a subprogram
STRFLG EQU  4                 Scanning a string variable
SAFLG  EQU  5                 Scanning subprogram arguments
IFFLAG EQU  6                 Scanning an if-statement
ENTXFL EQU  7                 ENTERX flag
*
*               BITS IN FLAG
* NUMBIT EQU  >00             Autonum bit (Can't use MACRO)
WRNPRT EQU  1                 Warning print bit
WRNSTP EQU  2                 Warning stop bit
***********************************************************
* Editting command equates
BREAK  EQU  >02               Break key
DLETE  EQU  >03               Delete key
INSRT  EQU  >04               Insert key
RECALL EQU  >06               Edit-buffer recall
CLRLN  EQU  >07               Clear-line key
BACK   EQU  >08               Back-space key
FORW   EQU  >09               Forward-space key
DOWN   EQU  >0A               Down-arrow key
UPMV   EQU  >0B               Up-arrow key
***********************************************************
* IMMEDITE VALUES
QUOTE  EQU  >22               "
DOLLAR EQU  >24               $
CURSOR EQU  >1E+OFFSET        CURSOR
EDGECH EQU  >1F+OFFSET        EDGE character
COMMA  EQU  >2C               ,
DASH   EQU  >2D               -  GKXB
COLON  EQU  >3A               :  GKXB
***********************************************************
* PAB offset
CZCLOS EQU  1                 CLOSE CODE
COD    EQU  4                 I/O code
NLEN   EQU  13                Length of file descriptor
***********************************************************
*    BASIC TOKEN TABLE
*      EQU  >80               spare token
ELSEZ  EQU  >81               ELSE
SSEPZ  EQU  >82               ::
TREMZ  EQU  >83               $
IFZ    EQU  >84               IF
GOZ    EQU  >85               GO
GOTOZ  EQU  >86               GOTO
GOSUBZ EQU  >87               GOSUB
RETURZ EQU  >88               RETURN
DEFZ   EQU  >89               DEF
DIMZ   EQU  >8A               DIM
ENDZ   EQU  >8B               END
FORZ   EQU  >8C               FOR
LETZ   EQU  >8D               LET
BREAKZ EQU  >8E               BREAK
UNBREZ EQU  >8F               UNBREAK
TRACEZ EQU  >90               TRACE
UNTRAZ EQU  >91               UNTRACE
INPUTZ EQU  >92               INPUT
DATAZ  EQU  >93               DATA
RESTOZ EQU  >94               RESTORE
RANDOZ EQU  >95               RANDOMIZE
NEXTZ  EQU  >96               NEXT
READZ  EQU  >97               READ
STOPZ  EQU  >98               STOP
DELETZ EQU  >99               DELETE
REMZ   EQU  >9A               REM
ONZ    EQU  >9B               ON
PRINTZ EQU  >9C               PRINT
CALLZ  EQU  >9D               CALL
OPTIOZ EQU  >9E               OPTION
OPENZ  EQU  >9F               OPEN
CLOSEZ EQU  >A0               CLOSE
SUBZ   EQU  >A1               SUB
DISPLZ EQU  >A2               DISPLAY
IMAGEZ EQU  >A3               IMAGE
ACCEPZ EQU  >A4               ACCEPT
ERRORZ EQU  >A5               ERROR
WARNZ  EQU  >A6               WARNING
SUBXTZ EQU  >A7               SUBEXIT
SUBNDZ EQU  >A8               SUBEND
RUNZ   EQU  >A9               RUN
LINPUZ EQU  >AA               LINPUT
*      EQU  >AB               Zpare token (LIBRARY)
*      EQU  >AC               Zpare token (REAL)
*      EQU  >AD               Zpare token (INTEGER)
*      EQU  >AE               Zpare token (SCRATCH)
*      EQU  >AF               Zpare token
THENZ  EQU  >B0               THEN
TOZ    EQU  >B1               TO
STEPZ  EQU  >B2               STEP
COMMAZ EQU  >B3               ,
SEMICZ EQU  >B4               ;
COLONZ EQU  >B5               :
RPARZ  EQU  >B6               )
LPARZ  EQU  >B7               (
CONCZ  EQU  >B8               &          (CONCATENATE)
*      EQU  >B9               spare token
ORZ    EQU  >BA               OR
ANDZ   EQU  >BB               AND
XORZ   EQU  >BC               XOR
NOTZ   EQU  >BD               NOT
EQUALZ EQU  >BE               =
LESSZ  EQU  >BF               <
GREATZ EQU  >C0               >
PLUSZ  EQU  >C1               +
MINUSZ EQU  >C2               -
MULTZ  EQU  >C3               *
DIVIZ  EQU  >C4               /
CIRCUZ EQU  >C5               ^
*      EQU  >C6               spare token
STRINZ EQU  >C7               QUOTED STRING
UNQSTZ EQU  >C8               UNQUOTED STRING
NUMZ   EQU  >C8               ALSO NUMERICAL STRING
NUMCOZ EQU  >C8               ALSO UNQUOTED STRING
LNZ    EQU  >C9               LINE NUMBER CONSTANT
*      EQU  >CA               spare token
ABSZ   EQU  >CB               ABS
ATNZ   EQU  >CC               ATN
COSZ   EQU  >CD               COS
EXPZZ  EQU  >CE               EXP
INTZ   EQU  >CF               INT
LOGZ   EQU  >D0               LOG
SGNZZ  EQU  >D1               SGN
SINZ   EQU  >D2               SIN
SQRZ   EQU  >D3               SQR
TANZ   EQU  >D4               TAN
LENZ   EQU  >D5               LEN
CHRZZ  EQU  >D6               CHR$
RNDZ   EQU  >D7               RND
SEGZZ  EQU  >D8               SEG$
POSZ   EQU  >D9               POS
VAL    EQU  >DA               VAL
STRZZ  EQU  >DB               STR$
ASCZ   EQU  >DC               ASC
PIZ    EQU  >DD               PI
RECZ   EQU  >DE               REC
MAXZ   EQU  >DF               MAX
MINZ   EQU  >E0               MIN
RPTZZ  EQU  >E1               RPT$
*      EQU  >E2  to >E7
NUMERZ EQU  >E8               NUMERIC
DIGITZ EQU  >E9               DIGIT
UALPHZ EQU  >EA               UALPHA
SIZEZ  EQU  >EB               SIZE
ALLZ   EQU  >EC               ALL
USINGZ EQU  >ED               USING
BEEPZ  EQU  >EE               BEEP
ERASEZ EQU  >EF               ERASE
ATZ    EQU  >F0               AT
BASEZ  EQU  >F1               BASE
*      EQU  >F2               spare token (TEMPORARY)
*      EQU  >F3               spare token (VARIABLE)
*      EQU  >F4               spare token (RELATIVE)
*      EQU  >F5               spare token (INTERNAL)
SEQUEZ EQU  >F6               SEQUENTIAL
OUTPUZ EQU  >F7               OUTPUT
UPDATZ EQU  >F8               UPDATE
APPENZ EQU  >F9               APPEND
FIXEDZ EQU  >FA               FIXED
PERMAZ EQU  >FB               PERMANENT
TABZ   EQU  >FC               TAB
NUMBEZ EQU  >FD               #
VALIDZ EQU  >FE               VALIDATE
*      EQU  >FF               ILLEGAL VALUE
***********************************************************
       TITL 'EDIT-359'
***********************************************************
*                        GROM HEADER
***********************************************************
       GROM >6000
       AORG 0
       DATA >AA02,>0100,0,USER,0,LINK1,0,0
***********************************************************
*    Branch table for routines in EDIT
***********************************************************
       BR   AUTON
G6012  BR   TOPL15
       BR   INITPG
       BR   SPRINT            Initialize sprites.
       BR   CHRTBL            RXB CHRTBL
       BR   TOPL10
G601C  BR   CHRTAB
       BR   SZRUN
       BR   $                 Was GETLNB
       BR   KILSYM
       BR   $                 Was CRUNCH
       BR   GETNB
       BR   GETNB2
       BR   GETCHR
       BR   GETLN
       BR   AUTO1
       DATA TOPL02
       BR   EDITLN
       BR   GRSUB1            Read from ERAM (use GREAD/VDP
       BR   GWSUB             Write a few bytes to ERAM/VDP
*    Error and system messages
*      BASE 0,0,>300,>300,0,0,>60
MSGERR BYTE >A9,>CE,>80,>A5,>D2,>D2,>CF,>D2
*           In Error
MSGFST BYTE >07,>B2,>C5,>C1,>C4,>D9,>80,>8A
*            Ready
MSGBRK BYTE >0A,>A2,>D2,>C5,>C1,>CB,>D0,>CF,>C9,>CE,>D4
*            Breakpoint
MSGTA  BYTE >B4,>D2,>D9,>80,>A1,>C7,>C1,>C9,>CE
*           Try Again
MSGWRN BYTE >8A,>80,>B7,>C1,>D2,>CE,>C9,>CE,>C7
*            * Warning
MSG10  BYTE >10,>AE,>D5,>CD,>C5,>D2,>C9,>C3,>80
*            Numeric
       BYTE >AF,>D6,>C5,>D2,>C6,>CC,>CF,>D7
*           Overflow
MSG14  BYTE >0C,>B3,>D9,>CE,>D4,>C1,>D8,>80,>A5,>D2,>D2,>CF
*            Syntax Error
MSG16  BYTE >18,>A9,>CC,>CC,>C5,>C7,>C1,>CC,>80,>A1,>C6,>D4
*            Illegal After
       BYTE >B3,>D5,>C2,>D0,>D2,>CF,>C7,>D2,>C1,>CD
*           Subprogram
MSG17  BYTE >10,>B5,>CE,>CD,>C1,>D4,>C3,>C8,>C5,>C4,>80
*           Unmatched
       BYTE >B1,>D5,>CF,>D4,>C5,>D3
*           Quotes
MSG19  BYTE >0D,>AE,>C1,>CD,>C5,>80,>B4,>CF,>CF,>80,>AC,>CF
*            Name Too Long
MSG24  BYTE >16,>B3,>D4,>D2,>C9,>CE,>C7,>8D,>AE,>D5,>CD,>C2
*            String-Number
       BYTE >AD,>C9,>D3,>CD,>C1,>D4,>C3,>C8
*           Mismatch
MSG25  BYTE >11,>AF,>D0,>D4,>C9,>CF,>CE,>80,>A2,>C1,>D3,>C5
*            Option Base
       BYTE >A5,>D2,>D2,>CF,>D2
*           Error
MSG28  BYTE >14,>A9,>CD,>D0,>D2,>CF,>D0,>C5,>D2,>CC,>D9,>80
*            Improperly
       BYTE >B5,>D3,>C5,>C4,>80,>AE,>C1,>CD,>C5
*           Used Name
MSG34  BYTE >16,>B5,>CE,>D2,>C5,>C3,>CF,>C7,>CE,>C9,>DA,>C5
*            Unrecognized
       BYTE >A3,>C8,>C1,>D2,>C1,>C3,>D4,>C5,>D2
*           Character
MSG36  BYTE >0B,>A9,>CD,>C1,>C7,>C5,>80,>A5,>D2,>D2,>CF,>D2
*            Image Error
MSG39  BYTE >0B,>AD,>C5,>CD,>CF,>D2,>D9,>80,>A6,>D5,>CC,>CC
*            Memory Full
MSG40  BYTE >0E,>B3,>D4,>C1,>C3,>CB,>80,>AF,>D6,>C5,>D2,>C6
*            Stack Overflow
MSG43  BYTE >10,>AE,>A5,>B8,>B4,>80,>B7,>C9,>D4,>C8,>CF,>D5
*            NEXT Without
       BYTE >A6,>AF,>B2
*           FOR
MSG44  BYTE >10,>A6,>AF,>B2,>8D,>AE,>A5,>B8,>B4,>80
*           FOR-NEXT
       BYTE >AE,>C5,>D3,>D4,>C9,>CE,>C7
*           Nesting
MSG47  BYTE >15,>AD,>D5,>D3,>D4,>80,>A2,>C5,>80,>A9,>CE
*            Must be in
       BYTE >80,>B3,>D5,>C2,>D0,>D2,>CF,>C7,>D2,>C1,>CD
*            Subprogram
MSG48  BYTE >19,>B2,>C5,>C3,>D5,>D2,>D3,>C9,>D6,>C5,>80
*           Recursive
       BYTE >B3,>D5,>C2,>D0,>D2,>CF,>C7,>D2,>C1,>CD,>80,>A3
*           Subprogram Call
MSG49  BYTE >0E,>AD,>C9,>D3,>D3,>C9,>CE,>C7,>80,>B3,>B5,>A2
*            Missing Subend
MSG51  BYTE >14,>B2,>A5,>B4,>B5,>B2,>AE,>80,>B7,>C9,>D4,>C8
*            RETURN Without
       BYTE >80,>A7,>AF,>B3,>B5,>A2
*           GOSUB
MSG54  BYTE >10,>B3,>D4,>D2,>C9,>CE,>C7,>80
*            String
       BYTE >B4,>D2,>D5,>CE,>C3,>C1,>D4,>C5,>C4
*           Truncated
MSG57  BYTE >0D,>A2,>C1,>C4,>80,>B3,>D5,>C2,>D3,>C3,>D2,>C9
*            Bad Subscript
MSG60  BYTE >0E,>AC,>C9,>CE,>C5,>80,>AE,>CF,>D4,>80,>A6,>CF
*           Line Not Found
MSG61  BYTE >0F,>A2,>C1,>C4,>80,>AC,>C9,>CE,>C5,>80
*           Bad Line
       BYTE >AE,>D5,>CD,>C2,>C5,>D2
*           Number
MSG67  BYTE >0E,>A3,>C1,>CE,>87,>D4,>80,>A3,>CF,>CE,>D4,>C9
*            Can't Continue
MSG69  BYTE >1A,>A3,>CF,>CD,>CD,>C1,>CE,>C4,>80
*            Command
       BYTE >A9,>CC,>CC,>C5,>C7,>C1,>CC,>80,>C9,>CE,>80
*           Illegal in
       BYTE >B0,>D2,>CF,>C7,>D2,>C1,>CD
*           Program
MSG70  BYTE >17,>AF,>CE,>CC,>D9,>80,>AC,>C5,>C7,>C1,>CC,>80
*            Only Legal
       BYTE >C9,>CE,>80 >C1,>80,>B0,>D2,>CF,>C7,>D2,>C1,>CD
*           in a Program
MSG74  BYTE >0C,>A2,>C1,>C4,>80,>A1,>D2,>C7,>D5,>CD,>C5,>CE
*            Bad Argument
MSG78  BYTE >12,>AE,>CF,>80,>B0,>D2,>CF,>C7,>D2,>C1,>CD
*            No Program
       BYTE >80,>B0,>D2,>C5,>D3,>C5,>CE,>D4
*            Present
MSG79  BYTE >09,>A2,>C1,>C4,>80,>B6,>C1,>CC,>D5,>C5
*            Bad Value
MSG81  BYTE >17,>A9,>D1,>C3,>C3,>D2,>D2,>C5,>C3,>D4,>80
*            Incorrect
       BYTE >A1,>D2,>C7,>D5,>CD,>C5,>CE,>D4,>80,>AC,>C9,>D3
*           Argument List
MSG83  BYTE >0B,>A9,>CE,>D0,>D5,>D4,>80,>A5,>D2,>D2,>CF,>D2
*            Input Error
MSG84  BYTE >0A,>A4,>C1,>D4,>C1,>80,>A5,>D2,>D2,>CF,>D2
*            Data Error
MSG97  BYTE >14,>B0,>D2,>CF,>D4,>C5,>C3,>D4,>C9,>CF,>CE,>80
*            Protection
       BYTE >B6,>C9,>CF,>CC,>C1,>D4,>C9,>CF,>CE
*           Violation
MSG109 BYTE >0A,>A6,>C9,>CC,>C5,>80,>A5,>D2,>D2,>CF,>D2
*            File Error
MSG130 BYTE >09,>A9,>8F,>AF,>80,>A5,>D2,>D2,>CF,>D2
*            I/O Error
MSG135 BYTE >14,>B3,>D5,>C2,>D0,>D2,>CF,>C7,>D2,>C1,>CD,>80
*            Subprogram
       BYTE >AE,>CF,>D4,>80,>A6,>CF,>D5,>CE,>C4
*            Not Found
MSG62  BYTE >0D,>AC,>C9,>CE,>C5,>80,>B4,>CF,>CF,>80,>AC,>CF
*            Line Too Long
MSGFRE BYTE >A2,>D9,>D4,>C5,>D3,>80,>A6,>D2,>C5,>C5
*           Bytes Free
MSGSFR BYTE >A2,>D9,>D4,>C5,>D3,>80,>CF,>C6,>80,>B3,>D4,>C1
*           Bytes of Stack
       BYTE >A6,>D2,>C5,>C5
*           Free
MSGGFR BYTE >A2,>D9,>D4,>C5,>D3,>80,>CF,>C6,>80,>B0,>D2,>CF
*           Bytes of Program
       BYTE >CD
MSGGF1 BYTE >B3,>D0,>C1,>C3,>C5,>80,>A6,>D2,>C5,>C5
*           Space Free
MSGCIS BYTE >B5,>A4,>A6,>80,>B2,>C5,>C6,>D3,>80,>A9,>D4,>D3
*           UDF Refs Itself
MSGCF  BYTE >A3,>C1,>CC,>CC,>C5,>C4,>80,>A6,>D2,>CF,>CD
*           Called From
MSG56  BYTE >16,>B3,>D0,>C5,>C5,>C3,>C8,>80,>B3,>D4,>D2,>C9
*            Speech String
       BYTE >B4,>CF,>CF,>80,>AC,>CF,>CE,>C7
*           Too Long
*      BASE 0,0,>0300,>0300,0,0,0
USER   DATA 0,TOPLEV
 
       BYTE 17
       TEXT 'RXB VERSION 2001 '
DSCLOD BYTE 9
       TEXT 'DSK1.LOAD'
       BYTE 0
SPCCHR BYTE >81,>00,>00,>00,>00,>00,>81,>00     * CURSOR CH
       DATA 0,0,0,0                             * EDGE CHAR
VDPREG BYTE >E0,>00,>20,>00,>06,>00
***********************************************************
*            START OF BASIC INTERPETER
***********************************************************
TOPLEV CLR  [email protected]>0370           Initialize temp area
       MOVE 77,[email protected]>0370,[email protected]>0371
* RXB MODULE PATCH CODE FOR RXB MODULE ********************
*      ST   5,@KEYBD          Select full keyboard
*      SCAN
*      CZ   @KEYBD
*      BR   G6388             99/4A Console?
       CALL CART              * RXB PATCH CODE FOR CARTRIDE
       ST   >01,[email protected]      Select 99/4A console
G6388  CLR  @KEYBD
* RXB MODULE PATCH CODE FOR RXB MODULE ********************
*      DST  NLNADD,[email protected]   Initialize edit-buffer start
*      DST  NLNADD,[email protected]   Initialize edit-buffer end
       MOVE 2,[email protected],@INTRIN Get address of ATNZZ
       AND  >1F,@INTRIN       Throw away the BR opcode
       DADD >5B,@INTRIN       Address of polynomial constan
 
* RXB PATCH CODE *************
       ST   >31,[email protected]      indicate try auto-boot
       BR   SZNEW
       AORG >03A5
*----------------------------------------------------------
* Add the following line for fixing "MEMORY FULL" error
* occurring during MERGE execution will leave the file open
* to disk DSR bug, 5/19/81
SZNEW  CLR  [email protected]          Initialize merged temporary
*                              for PAB pointer
*----------------------------------------------------------
       ST   RSTK,@SUBSTK      Load base of subroutine stack
       CALL CHRTA2            Load character table
       CLR  @FLAG             Initialize flag byte
       DCLR @BUFLEV           Initialize crunch buffer leve
       CALL CLSALL            Close all open files
       CLR  @DATA             Initialize READ/DATA pointer
       DST  VRAMVS,@VSPTR     Initialize base of value stac
       DST  @VSPTR,@STVSPT    Save in permanent base
       DST  @VSPTR,[email protected]
       CALL INITPG            Initialize program & s.t.
       CALL INTRND            Initialize random number
       CZ   [email protected]
       BS   TOPL02            If need auto-boot
* RXB PATCH CODE *************
*      CLR  [email protected]          Won't ever need to do again
       BR   G63D0
* RXB PATCH CODE ******************************************
       AORG >03D0
G63D0  CALL AUTOLD            Attempt an auto-boot
*     Label TOPL02 is used by auto-boot in detection of err
ERRRDY EQU  $
TOPL02 CALL G6A84             Say READY
       BYTE 0               *  returns to TOPL15
TOPL05 CALL INITPG            Initialize program space
TOPL10 CALL KILSYM            Kill the symbol table
* RXB PATCH CODE *************
* TOPL15 AND  >F7,@FLAG         If error in UDF execution
TOPL15 B    MYSRCH
G63E0  ST   5,@KEYBD          Select full keyboard
       SCAN
       CLR  @KEYBD
TOPL20 ST   RSTK,@SUBSTK      Initialize subroutine stack
TOPL25 DST  NLNADD,@VARW      Screen addr = lower left corn
       CLR  @RAMFLG           Clear the RAMFLG
       CLR  @PRGFLG           Make sure not in program mode
* Check for auto-num mode
       CLOG >01,@FLAG         If auto-num on
       BS   TOPL35
       DADD @CURINC,@CURLIN   Generate new line number
       CGE  0,@CURLIN         >32767?
       BS   TOPL30
       AND  >FE,@FLAG         If out of range->exit auto-nu
       B    TOPL35            Merge in below
* Must be a long branch!!
TOPL30 DCEQ @ENLN,@STLN       Line might exist
       BS   G6412
       DST  @CURLIN,@FAC      Ready for program search
       XML  SPEED
       BYTE SEETWO          * Search for existence of line
       BS   EDTZ05            COND set = line found
G6412  XML  SCROLL            Scroll to the next line
       DST  @CURLIN,@ARG2     New line #
       CALL DISO              Display the line number
       DINC @VARW             Following by a space
       BR   G6420
TOPL35 XML  SCROLL            Scroll the screen
G6420  ST   >9E,[email protected]    Display the prompt character
       CALL G6A76             Read in a line
       CALL SAVLIN            Save input line for recall
*    Crunch the input line
       CLR  @ERRCOD           Assume no-error return
       DST  CRNBUF,@RAMPTR    Initialize crunch pointer
       XML  CRUNCH            CRUNCH the input line
       BYTE 0              *  Normal crunch mode
TOPL42 CASE @ERRCOD+1
       BR   TOPL45            No error detected
       BR   ERRSYN            *SYNTAX ERROR
       BR   ERRBLN            *BAD LINE NUMBER
       BR   ERRLTL            *LINE TOO LONG
       BR   ERRNTL            *NAME TOO LONG
       BR   ERRNQS            *UNMATCHED QUOTES
       BR   ERRCIP            *COMMAND ILLEGAL IN PROGRAM
       BR   ERRIVN            *UNRECOGNIZED CHARACTER
TOPL45 DCZ  @FAC              Line # present
       BS   TOPL55
       CLOG >01,@FLAG         Not AUTONUM
       BR   G645B
       CEQ  >0D,@RKEY         Must be up or down
       BS   G645B
       CEQ  >01,@CHAT         Start EDIT mode
       BR   G645B
       B    EDTZZ0
G645B  CALL EDITLN            EDIT the line into the progra
       BS   TOPL25            If didn't change the line
       BR   TOPL10
*    Jump always
TOPL55 CEQ  >01,@CHAT         If blank line - ignore
       BS   TOPL25
       CEQ  >EB,[email protected]
       BS   SZSIZE
       CH   >08,[email protected]      If imperative
* GKXB Branch code for new commands DEL, COPY, and MOVE.
       BS   NEWCMD            Go here to test for new
*                              keywords
       DST  CRNBUF+1,@PGMPTR  Anticipate usage of PGMCHR
       XML  PGMCHR            Prepare CHAT for OLD and SAVE
       CASE [email protected]          Select the keyword
       BR   SZNEW             NEW                 0
       BR   SZCONT            CONTINUE            1
       BR   SZLIST            LIST                2
       BR   SZBYE             BYE                 3
       BR   SZNUM             NUMBER              4
       BR   SZOLD             OLD                 5
       BR   SZRES             RESEQUENCE          6
       BR   SZSAVE            SAVE                7
       BR   SZMERG            MERGE               8
*    AUTO-BOOT - attempt a ---->   RUN "DSK1.LOAD"
AUTOLD MOVE 11,[email protected],[email protected]
       DST  CRNBUF,@PGMPTR    DSK1.LOAD is in crunch buffer
* RXB PATCH CODE *************
*      BR   SZRUNL            Go to the RUN "NAME" CODE
       BR   MYRUN
********************************* RUN *********************
SZRUN  CEQ  >C7,@CHAT         Ready for 'RUN "NAME" ----
       BR   G64BF
SZRUNL DST  @PGMPTR,@FAC14    Save pointer to name
       XML  PGMCHR            Get the length of the string
       ST   @CHAT,@FAC13      Put it in FAC13
       CLR  @FAC12            Make it a double byte
       DADD @FAC12,@PGMPTR    Skip the string
       XML  PGMCHR            To see there is line no. ahea
       CALL G8024             Only RUN "NAME" ?
       BR   ERRSYN            No - junk on end so error
       ST   STRINZ,@CHAT      Prepare for LOAD routine
       DST  @FAC14,@PGMPTR    Restore the saved PGMPTR
       CALL OLD1              Load the program
       BR   SZRUN0            Go ahead from here
*                              No RUN "NAME" : just run the
*                              current program in memory
G64BF  CEQ  >C9,@CHAT         Is there a line # after RUN?
       BR   G64D5
       XML  PGMCHR            Get the line number
       ST   @CHAT,@FAC        Put it in FAC for SEETWO
       XML  PGMCHR
       ST   @CHAT,@FAC1
       XML  PGMCHR            Should be EOS now
       CALL G8024             Is it?
       BS   SZRUN2            Yes - Go ahead from here
*                              Just 'RUN'
G64D5  CALL G8024             Should be EOS now
       BR   ERRSYN            No-SYNTAX ERROR
SZRUN0 DCEQ @ENLN,@STLN       Refuse without program
       BS   ILLST
       DST  @ENLN,[email protected]     Defualt to beginning
       DSUB 3,[email protected]         Offset into the table
       BR   SZRUN1            Merge in below
*    Jump always
SZRUN2 DCEQ @ENLN,@STLN       Refuse without program
       BR   G64F9
ILLST  XML  SCROLL            Scroll the screen for message
       CLR  @PRGFLG           Prevent line # printing
WRNNPP CALL G6A82
       BYTE 29                * NO PROGRAM PRESENT
       BR   TOPL15
*    Condition can never be set since line 0 is prohibited
G64F9  XML  SPEED
       BYTE SEETWO          * Find the line in the program
       BR   ERRLNF            * LINE NOT FOUND
       DST  @EXTRAM,[email protected]   Program run starts here
* GKXB RUN code for color change.
SZRUN1 BR   RUNPAT            Change colors.
G6504  CALL CLSALL            Close any open files
       DEC  @PRGFLG           Put it back in execution
       ST   @RAMTOP+1,@RAMFLG Set/reset RAMFLG flag -- when
       DCLR [email protected]           in program mode & ERAM exist
       DCLR [email protected]           Disallow CONTINUE after RUN
       CALL KILSYM            Reset ERR handling to defualt
       ST   RSTK,@SUBSTK      Set the stack empty
* RXB PATCH CODE ************ Turn off DSK#.LOAD search
* SZRUN4 B    G6A70
SZRUN4 B    SCHOFF            Turn off search first then G6
EDTZ05 B    EDTZ00
**************************** CONTINUE *********************
SZCONT CALL GETNB             Check for END-OF-LINE
       BR   ERRSY1            Junk on end of command
       DCZ  [email protected]          If can continue
       BS   ERRCC
       XML  SCROLL
       DST  [email protected],@EXTRAM  Copy old line table pointer
       DST  [email protected],@PGMPTR  Copy old text pointer
       DST  [email protected],@BUFLEV  Copy old buffer level
       DST  [email protected],@LSUBP   Copy last subprogram on stack
       OR   [email protected],@FLAG     Restore on-warning/break bits
G6540  DCH  [email protected],@VSPTR   While extra on stack
       BR   G654A
       XML  VPOP              Pop them off
       BR   G6540
G654A  ST   >FF,@PRGFLG       Idicate program mode
       ST   @RAMTOP+1,@RAMFLG Set/reset RAMFLG flag --- whe
*                              in program mode & ERAM exist
       DCLR [email protected]          Prevent unauthorized CONTINUE
       DST  VRAMVS,[email protected]   Init for program completion
       XML  CONTIN            Resume normal execution
ERRCC  CALL G6A84             Indicate error
       BYTE 25              * "* CAN'T CONTINUE"
**************************** NUMBER ***********************
*----------------------------------------------------------
* Fix NUMBER command cause XB goes into a loop displaying
* *PROTECTION VIOLATION when a PROTECTED program is in
* memory bug, add the following line after label SZNEW
SZNUM  CLOG >80,@FLAG         Check PROTEDTION VIOLATION
       BR   ERRPV
*----------------------------------------------------------
       CALL AUTON             Get start line # and incremen
       OR   >01,@FLAG         Set AUTONUM bit for future us
       DST  NLNADD,@VARW      Initialize screen address
       BR   TOPL30            Jump back into it
*    Jump always
***********************************************************
* AUTON - scans the NUM, LIST and RES commands for line
* numbers. Leaves 1st line number in CURLIN and 2nd line
* number in CURINC. AUTON is entry point from NUM to defual
* to 100,10          AUTON is entry point for LIST.
***********************************************************
AUTON  DST  100,@CURLIN       Defualt start
 
* GKXB AUTO4 label
AUTO4  DST  10,@CURINC        Defualt increment
       ST   COMMA,@VARC       Comma is the separator
AUTO1  DDEC @VARW             Don't miss the first characte
* GKXB AUTO3 label
AUTO3  CALL GETNB             Get 1st character after keywo
       BS   AUTO2             If end of line
       CALL GETLN             Try to get a line number
       CZ   @BYTES            If digits gotten
       BS   G658D
       DST  @FAC,@CURLIN      Set initial
G658D  CALL GETNB2            Allow spaces before separator
       DCH  @VARA,@VARW       Check end of line
       BS   AUTO2
       CEQ  @VARC,@CHAT       If not correct separator
* GKXB Modification to the RES to allow renumbering a
*      portion of a program.
       BR   CKLIST            GKXB AUTON for record length.
* GKXB AUTO5 label
AUTO5  CALL GETNB             Get char after separator
       BS   AUTO2             If end of line
       CALL GETLN             Try to get 2nd number
       CZ   @BYTES            If digits gotten
       BS   G65A9
       DST  @FAC,@CURINC      Save the increment
G65A9  CALL GETNB2            Check EOL
* GKXB Modification to the RES to allow renumbering a
*      portion of a program.
       BR   RES2              GKXB AUTON for range check
AUTO2  RTN
*************************** SAVE **************************
SZSAVE DCEQ @ENLN,@STLN       If no program
       BS   ILLST
       B    SAVE
*************************** OLD ***************************
SZOLD  B    OLD
*************************** BYE ***************************
SZBYE  CALL CLSALL            Properly close all files
SZEXIT EXIT                   Return to MONITOR
*************************** LIST **************************
SZLIST DCEQ @ENLN,@STLN       Refuse LIST without prrogram
       BS   ILLST
       B    LIST              LIST the program
*************************** MERGE *************************
SZMERG B    MERGE
*************************** SIZE **************************
* RXB SIZE PATCH CODE ********
* SZSIZE CZ   [email protected]+1        Must have EOL
SZSIZE B    NSIZE
       BR   ERRSYN
G65CE  XML  COMPCT            Garbage collect to free space
       DST  @STREND,@ARG2     Get end of string space
       DSUB @VSPTR,@ARG2      Subtract stack pointer
       DSUB 63,@ARG2          Require 64-byte buffer
       GT                     If less then 64 bytes left
       BS   G65DF
       DCLR @ARG2             Then indicate zero
G65DF  XML  SCROLL            Scroll the screen
       DST  NLNADD+2,@VARW    Begin a new line
       CALL DISO              Display the number
       CZ   @RAMTOP           If no ERAM present
       BR   G65F7
       MOVE 10,[email protected],[email protected](@VARW)
       BR   G6621
G65F7  MOVE 19,[email protected],[email protected](@VARW)
       XML  SCROLL            Scroll the screen
       DST  NLNADD+2,@VARW    Beginning of line
       DST  @RAMFRE,@ARG2     Calculate space in ERAM
       DSUB CPUBAS-1,@ARG2    Subtract base
       CALL DISO              Display the number
       MOVE 16,[email protected],[email protected](@VARW)
* RXB SIZE PATCH CODE ********
G6618  XML  SCROLL
       MOVE 10,[email protected],[email protected]+4
G6621  XML  SCROLL            Scroll the screen
* RXB SIZE PATCH CODE ********
*      BR   TOPL15            Return to top-level
G6623  RTN
       RTN                    RXB wasted byte.
************************** RESEQUENCE *********************
SZRES  DCEQ @ENLN,@STLN       If no program
       BS   ILLST
* GKXB Modification to the RES command to allow renumbering
*      a portion of the program.
       CALL RES1              GKXB pickup of renage
* GKXB RES6 label
RES6   DST  @XENLN,@FAC       GKXB Compute # of increments
       DSUB @XSTLN,@FAC       GKXB Actual number of lines -
       DSRL 2,@FAC            Also takes care of this ^^^
       DMUL @CURINC,@FAC      Compute space taken by increm
       DCZ  @FAC              Bad line number
       BR   ERRBLN
       DADD @FAC2,@CURLIN     Compute highest address used
       CARRY                  Watch out for overflow
       BS   ERRBLN
       CH   >7F,@CURLIN       Overflow is > 32767
       BS   ERRBLN
       ST   @RAMTOP+1,@RAMFLG Set/reset RAMFLG to use PGMCH
       CLR  @ARG4             To be used for double add
* GKXB Modification to the RES command to allow renumbering
*      a portion of the program.
       CALL RES4              GKXB Check high line # for ov
       DST  @>8370,@VAR0      Assume VDP-top
       CZ   @RAMFLG           But if ERAM exists
       BS   G665F
       DST  @RAMTOP,@VAR0     Top for ERAM
G665F  DINCT @PGMPTR          Skip EOL and count
G6661  XML  PGMCHR            VDP RAM or ERAM
       CEQ  >C7,@CHAT         Skip strings
       BS   SEQZ2
       CEQ  >C8,@CHAT         If numeric
       BR   G6677
SEQZ2  XML  PGMCHR            Get next token (count)
       ST   @CHAT,@ARG5       For double add
       DADD @ARG4,@PGMPTR     Up to end of string
       BR   G66AA
G6677  CEQ  >C9,@CHAT         Check for line #
       BR   G66AA
       CALL GRSUB2            Get the line # in the text
       BYTE PGMPTR          * @PGMPTR : Source addr on ERAM
       DST  @EEE1,@FAC8       Save it temporary place
       DST  @CURLIN,@ARG2     Set for searching
* GKXB Modification to the RES command to allow renumbering
*      a portion of the program.
       DST  @XSTLN,@ARG       GKXB New segment start
G6689  CALL GRSUB3            Read the line # fromn ERAM
*                              (use GREAD1) or VDP, reset
*                              possible breakpoint too
       BYTE ARG             * @ARG : Source addr on ERAM/VD
       DCEQ @EEE1,@FAC8
       BS   SEQZ3
       DSUB @CURINC,@ARG2     Update new line #
       DADD 4,@ARG            And entry in line # table
* GKXB Modification to the RES command to allow renumbering
*      a portion of the program.
       DCH  @XENLN,@ARG       GKXB New segment end
       BR   G6689
       BR   G66A8             GKXB Skip replacing undefined
*                              line # with 32767
       DATA >7FFF *           GKXB unused bytes
SEQZ3  CALL GWSUB             Write a few bytes of data
*                 @PGMPTR : Destination address on ERAM/VDP
*                 @ARG2   : Data
*                 2       : Byte count
       BYTE PGMPTR,ARG2,2
G66A8  DINCT @PGMPTR          Pass two byte line # in text
G66AA  DCLR @>83D6            Reset VDP timeout
       DCHE @VAR0,@PGMPTR     And on end of program
       BR   G6661
*  Now update the line # table itself
* GKXB Modification to the RES command to allow renumbering
*      a portion of the program.
       DST  @XSTLN,@FAC       GKXB New segment start
       DST  @CURLIN,@ARG      With start address off course
G66B8  CALL GWSUB             Write a few bytes of data to
*                              ERAM (use GWRITE) or VDP
*                 @FAC   : Destination address on ERAM/VDP
*                 @ARG   : Data
*                 2      : Byte count
       BYTE FAC,ARG,2
       DSUB @CURINC,@ARG      Compute next line #
       DADD 4,@FAC            And next entry in line # tabl
* GKXB Modification to the RES command to allow renumbering
*      a portion of the program.
       DCH  @XENLN,@FAC       GKXB New segment end# table
       BR   G66B8
       CLR  @RAMFLG           Restore the ERAM flag
* GKXB Modification to the RES command to allow renumbering
*      a portion of the program.
       BR   RES5              GKXB find out where to return
***********************************************************
*              EDIT a line into a program
*
* Must be called with the following set up:
*    FAC    = line number of line to be edited into program
*    CHAT   = length of line
*    CRNBUF = crunched line
***********************************************************
EDITLN CLOG >80,@FLAG         Protection violation
       BR   ERRPV
       CALL CLSALL            Close any open files
       CALL KILSYM            Kill symbol table
       CLR  @STPT             Restore STPT
       ST   @CHAT,@STPT+1
***********************************************************
* @CHAT=1 ? YES : LINE NUMBER ONLY -  GO TO DELETE THE LINE
*           NO  : INSERT A NEW LINE OR REPLACE EXISTING LIN
***********************************************************
       CEQ  >01,@CHAT         Something besides line #
       BR   INSREP
       CLOG >01,@FLAG         Auto-number mode on
       BS   G66F0
       AND  >FE,@FLAG         Reset AUTONUM mode
RTNSET CEQ  @>8300,@>8300     Set condition bit
       RTNC                   And return
G66F0  DCEQ @ENLN,@STLN       If no program
       BS   RTNSET
***********************************************************
* EDITZ1 Delete the line # from line-#-buffer.
*        Delete the text from program text area.
***********************************************************
EDITZ1 XML  SPEED             Try to find the given line #
       BYTE SEETWO
       BR   RTNSET            Return if not found
       XML  DELREP            Remove it's text from program
*   Delete the 4 bytes from the line # table
       DST  @EXTRAM,@VARY2    Pointer to line pointer
       DINC @VARY2            Advance to last byte of entry
       DDECT @EXTRAM          Point to first byte of entry
       DST  @EXTRAM,@VAR0
       DDEC @VAR0             Last byte of next line entry
*                              Move down 4 bytes from here
       DSUB @STLN,@EXTRAM     # of bytes to move down
       DCZ  @EXTRAM
       BS   G6714
       DST  @EXTRAM,@ARG      Put in arg for MVDN
       XML  MVDN              Move one byte at a time
G6714  DADD >04,@STLN         New start addr of line # tab
       CZ   @RAMTOP           If ERAM not exist
       BR   G6724
       DCH  @>8370,@STLN      Delete the only line
       BS   TOPL05
       BR   G672E             With ERAM
G6724  DCZ  @STLN
       BS   TOPL05
       DCH  @RAMTOP,@STLN
       BS   TOPL05
G672E  BR   KILSYM            Kill symbol table with return
***********************************************************
*    INSERT A NEW LINE OR REPLACE AN EXISTING LINE
***********************************************************
* BUILD LINE # AND LINE POINTER IN VARY, +1, +2, +3, +4
INSREP DST  @FAC,@VARY        2 bytes of line #
       DST  @ENLN,@VARY2      Last address of line-#-table
       DST  @ENLN,@EXTRAM     Prepare to search the line #
***********************************************************
* 1ST LINE IN MEMORY : EDITZ5 -- EDITZ6 -- EDITZ8 -- DONE
***********************************************************
       DCEQ @ENLN,@STLN       1st text?
       BS   EDITZ5
***********************************************************
* EDITZ3
*    COMPARE LINE # IN FAC WITH LINE # IN THE LINE # TABLE
*    EQUATE : --DELTX--EDITZ8-DONE
*    HIGHER : HIGHEST LINE? YES : EDITZ6--EDITZ8--DONE
*                           NO  : BACK TO EDITZ3
*    LOWER  : EDITZ4--EDITZ8--DONE
***********************************************************
       DINC @EXTRAM           Get line
EDITZ3 DSUB 4,@EXTRAM         Go to next line in program
       CALL GRSUB1            Read from ERAM(use GREAD)/VDP
       BYTE EXTRAM          * @EXTRAM : Source addr on ERAM
*                              or VDP
       AND  >7F,@EEE          Reset possible breakpoint
       DCEQ @EEE,@FAC         If #s match-delete old
       BS   DELTX
       DST  4,@VARA           For MEMFUL
       H                      New line # is greater
       BR   G675E
       DCEQ @STLN,@EXTRAM     Line to be inserted got the
*                              highest line number in line
*                              # table :: add to the end of
*                              line-#table
       BS   EDITZ6
       BR   EDITZ3
***********************************************************
* EDITZ4
*    ALLOCATE SPACE IN LINE # TABLE BY MOVING
*    PART (ARG=4) OF THE LINE # TABLE UP
***********************************************************
G675E  DST  4,@ARG
EDITZ4 DADD @EXTRAM,@ARG
       DSUB @STLN,@ARG        # of bytes in between
       DST  @STLN,@VAR9       Copy old start address of lin
       CALL MEMFUL            Check for memory full
       DADD @STPT,@STLN
       CZ   @RAMTOP
       BR   G677E
       MOVE @ARG,V*VAR9,V*STLN Move line # table
       BR   G6783
G677E  DST  @STLN,@VAR0       Destination address for MVUP
       XML  MVUP              Move the line # table up
G6783  DST  @ENLN,@VARY2      Set up line ptr in line # ent
       BR   EDITZ8
***********************************************************
* EDITZ5
* EDITZ6
*    SET UP 1ST ENTRY IN LINE # TABLE BY GIVING @VARA=3
*    WHEN INSERT THE HIGHEST LINE :
*     CONCATENATE LINE # ENTRY TO  LINE # TABLE
***********************************************************
EDITZ5 DST  >03,@VARA         Subtract >03 from STLN(@>8370
*                              to get new start addr of tab
EDITZ6 CALL MEMFUL            Check for memory full
       DADD @STPT,@STLN       Concatenate line # entry to
       DST  @STLN,@EXTRAM      table
***********************************************************
* EDITZ8
*    UPDATE ENTRY IN LINE # TABLE, PUT TEXT IN -- DONE
***********************************************************
EDITZ8 EQU  $
* Update the 4 bytes entry in line # table
       DINC @VARY2            Point to 1st token (not lengt
       DSUB @STPT,@VARY2      Set up the line pointer for V
       CALL GWSUB             Write a few bytes of data to
*                              ERAM (use GWRITE) or VDP
*      @EXTRAM : Destination address on ERAM/VDP
*      @VARY   : Data
*      4       : Byte count
       BYTE EXTRAM,VARY,4
***********************************************************
* Now insert the line's text between the line number table
*  and the rest of the program's text
***********************************************************
********** GET THE LENGTH OF LINE # TABLE IN @ARG *********
       DST  @ENLN,@ARG        Highest addr for line # table
       DSUB @STLN,@ARG        Total length of line # table
       DINC @ARG              Add one for extra offset
****************** MOVE THE LINE # TABLE ******************
       DST  @STLN,@VAR9       Old start addr of line # tabl
       DINC @STPT             Point to next free byte in VD
       DSUB @STPT,@STLN       New entry to line # table
       DSUB @STPT,@ENLN
       CZ   @RAMTOP           If ERAM not exist
       BR   G67C0
       MOVE @ARG,V*VAR9,V*STLN  Move line # table
       BR   G67C5
G67C0  DST  @STLN,@VAR0       Set up destination addr for M
       XML  MVUP              Move line # table
****************** WRITE THE LENGTH BYTE ******************
G67C5  DDEC @STPT             Update length of text
       DDEC @VARY2            Point to the length byte
       CALL GWSUB             Write a few bytes of data
*                              to ERAM (use GWRITE) or VDP
*      @VAR2      : Destination address on ERAM or VDP
*      @(STPT+1)  : Data
*      1          : Byte count
       BYTE VARY2,STPT+1,1
       DINC @VARY2
********************* WRITE THE TEXT **********************
       CZ   @RAMTOP           If ERAM not exist
       BR   G67DE
       MOVE @STPT,[email protected],V*VARY2 Move text
       BR   G67EA
G67DE  DST  CRNBUF,@AAA       Copy the text from crunch
*                         buffer (which is on VDP) to ERAM
       DST  @VARY2,@BBB
       DST  @STPT,@CCC        @CCC : Byte count
       XML  VGWITE
G67EA  BR   KILSYM            Kill symbol table and return
***********************************************************
* REPLACE AN EXISTING LINE
************** Compute length of old entry ****************
DELTX  DINCT @EXTRAM          Point to the line pointer
       CALL GRSUB1            Read from ERAM (use GREAD)/VD
       BYTE EXTRAM          * @EXTRAM : Source addr on ERAM
       DDECT @EXTRAM          Restore back
       DDEC  @EEE             Point to the length byte
       CALL GRSUB1            Read the length from ERAM/VDP
       BYTE EEE             * @EEE : Source addr on ERAM/VD
       ST   @EEE,@VARA+1
       CLR  @VARA             Make a double byte
       DNEG @VARA             And get length difference
       CALL MEMFUL            Check for memory full
       DADD @VARA,@STLN       Update STLN
       XML  DELREP            Remove old text (same line #)
       DDECT @EXTRAM          Correct pointer
******* SET UP THE LINE POINTER IN LINE # ENTRY ***********
       DST  @ENLN,@VARY2      Prepare setting up line point
       BR   EDITZ8            Go update entry in line # tab
*                              and put text in
***********************************************************
* SUBROUTINE TO READ 2 BYTES OF DATA FROM VDP OR ERAM
*  (use GREAD)
***********************************************************
GRSUB1 FETCH @FFF             Fetch the source addr on ERAM
       DST  *FFF,@DDD         Put it in @DDD
       CZ   @RAMTOP           If ERAM present
       BS   G6823
       DST  2,@FFF            @FFF : Byte count
       XML  GREAD             Read data from ERAM
*                             @EEE : Destination addr on CP
       BR   G6827             ERAM not exists
G6823  DST  V*DDD,@EEE        Read data from VDP
G6827  RTN
***********************************************************
* SUBROUTINE TO WRITE A FEW BYTES OF DATA TO VDP OR ERAM
*  (use GWRITE)
***********************************************************
GWSUB  FETCH @AAA             Fetch the destination addr on
       DST  *AAA,@AAA         ERAM/VDP
       FETCH @BBB+1           Fetch the source addr on CPU
*                              where data is stored
       CLR  @BBB              Make a double byte
       FETCH @CCC+1           Fetch the byte count
       CLR  @CCC              Make a double byte
       CZ   @RAMTOP           If ERAM exists
       BS   G683E
       XML  GWRITE            Write the data to ERAM
       RTN
G683E  MOVE @CCC,*BBB+1,V*AAA Write to VDP
       RTN
***********************************************************
* SUBROUTINE TO GET A NON-BLANK CHARACTER FROM LINE
***********************************************************
GETNB  CALL GETCHR            Get a character
       BS   RTNSET            If end-of-line
GETNB2 CEQ  >20,@CHAT
       BS   GETNB
       RTN
***********************************************************
* SUBROUTNE TO GET A CHARACTER FROM LINE
***********************************************************
GETCHR DCH  @VARA,@VARW
       BS   RTNSET
       ST   V*VARW,@CHAT      Put character in @CHAT
       CEQ  >7F,@CHAT         If not edge character
       BS   G6864
       SUB  OFFSET,@CHAT   >60 Screen character into ASCII
       DINC @VARW
       RTN
G6864  DADD 4,@VARW           Skip to next line
       BR   GETCHR
*  Jump always
***********************************************************
* GETLN - Gets an line number after a command and puts it
* into the FAC. If the character in CHAT when it is called
* is not in the legal numeric range (0-9) then GETLN
* GETLN returns with no other action.
*  Called by: AUTON, RUN, EDITLN
***********************************************************
GETLN  DCLR @FAC              Assume no number
       CLR  @BYTES            Assume no digits
GETLN2 SUB  >30,@CHAT         ASCII to normal range
       CHE  10,@CHAT          If numeric digit
       BS   G6891
       DMUL 10,@FAC           Multiply by 10
       DCZ  @FAC              Error if overflow
       BR   GTLNER
       ST   @CHAT,@FAC1       Need to add in this digit
       DADD @FAC2,@FAC        Add accumulator into last dig
       DCGE 0,@FAC            Error if overflow
       BR   GTLNER
       INC  @BYTES            Got another digit
       CALL GETCHR            Get the next character
       BR   GETLN2            If not EOS
G6891  CZ   @BYTES            If digits gotten
       BS   G6899
       DCZ  @FAC              If hit natural zero
       BS   GTLNER
G6899  ADD  >30,@CHAT         Put back into ASCII
       RTN
GTLNER XML  SCROLL            Scroll the screen
       CLR  @PRGFLG           Don't print a line number
       BR   ERRBLN            * BAD LINE NUMBER
MEMFUL DADD @STPT,@VARA       Total # of bytes to be added
* GKXB MEMFLL label
MEMFLL DSUB @VARA,@STLN       New STLN
       CZ   @RAMTOP
       BS   G68B5
       DCHE CPUBAS,@STLN      Not enough memory
       BR   MEMZ1
       RTN
G68B5  DCHE VRAMVS+64+256,@STLN Memory full
       BS   G68C2
MEMZ1  DADD @VARA,@STLN       Back to old start line # tabl
       CALL G6A84
       BYTE 11                * MEMORY FULL
G68C2  RTN
* Initialize program space
INITPG CLR  @RAMFLG           Reset RAMFLG
       XML  GDTECT            Search for ERAM & select ROM
       DST  @RAMTOP,@RAMFRE   Initialize free pointer
       DST  @>8370,@STLN      Assume VDP - initialize STLN
       CZ   @RAMTOP           If ERAM is present
       BS   G68D9
       DST  @RAMTOP,@STLN     Initialize STLN for ERAM
G68D9  DST  @STLN,@ENLN       Init ENLN based upon STLN
* Kill the symbol table
KILSYM DST  @STLN,@FREPTR     Assume VDP and init free poin
       DCEQ @>8370,@FREPTR
       BS   G68E6
       DDEC @FREPTR           Back off 1 if program present
G68E6  CZ   @RAMTOP           If ERAM exists
       BS   G68FC
       DST  @STLN,@RAMFRE     Update the @RAMFRE
       DCEQ @RAMTOP,@RAMFRE
       BS   G68F9
       DDEC @RAMFRE           Back off 1 if program present
G68F9  DST  @>8370,@FREPTR    Initialize VDP free pointer
G68FC  DCLR @SYMTAB           Kill symbol table
       DCLR @SUBTAB           Kill subprogram table
       DST  @FREPTR,@STRSP    Initialize string space
       DST  @STRSP,@STREND
       CLR  @BASE             Reset OPTION BASE to 0
       DCLR [email protected]          Disallow CONTINUE
       DST  VRAMVS,@STVSPT    Initialize base of value stac
       DST  @STVSPT,@VSPTR    Initialize value stack pointe
       DST  @VSPTR,[email protected]   Initialize pointer in VDP too
       RTN
***********************************************************
* Data for the color tables (starts at >0800)
* BYTE >D0,>00,>00,>00,>00,>00,>00,>00
* BYTE >00,>00,>00,>00,>00,>00,>00,>10
* BYTE >10,>10,>10,>10,>10,>10,>10,>10
* BYTE >10,>10,>10,>10,>10,>10,>10,>10
***********************************************************
CHRTA2 ALL  >20+OFFSET        Clear the screen
       DST  >3567,@>83C0      Initialize random number gen
       MOVE 16,[email protected],[email protected]>03F0 Cursor character
* RXB PATCH CODE
CHRTAB DST  >0400,@FAC        Address of chracater tables
       ST   95,@FAC2          Number of characters
       CALL CHRTBL            RXB character loader
       BR   G6939
* RXB SUB CODE FOR SIZE ******
SDISO  DST NLNADD+2,@VARW    *
       CALL DISO             *
       RTN                   *
******************************
G6939  BACK 4                 Border color = BLUE
       CLR  [email protected]>0800
       MOVE 14,[email protected]>0800,[email protected]>0801
       ST   >F0,[email protected]>080F       WHITE fore/transparent back
       MOVE 16,[email protected]>080F,[email protected]>0810
       CALL SPRINT
* This part might be moved up later, load special character
* here. Don't load before hiding all sprites.
       MOVE 6,[email protected],#1
       RTN
*
****** Initialization of sprites. Enable 28 sprites. ******
*
SPRINT CLR  [email protected]>0780           Clear motion of all sprites
       MOVE >6F,[email protected]>0780,[email protected]>0781
* Replace the line for speeding up XB. 5/22/81
*      ST   28,@MOTION        All in motion
       CLR  @MOTION           All not in motion
       ST   >D0,[email protected]>0370       Sprites 29 to 32 unavailiable
       DST  >C000,[email protected]>0300     Hide the first sprites
       DCLR [email protected]>0302           Make first sprite transparent
       MOVE 108,[email protected]>0300,[email protected]>0304 Ripple for the rest
       RTN
*
* ERROR messages in this file
*
ERRSY1 CLR  @PRGFLG           Without a line number
ERRSYN CALL G6A84
       BYTE 3                 * SYNTAX ERROR
ERRNQS XML  SCROLL            Scroll up the screen
       CALL G6A84             EOL before end of string
       BYTE 5                 * UNMATCHED QUOTES message
ERRNTL CLR  @PRGFLG           Don't print a line #
       CALL G6A84
       BYTE 6                 * NAME TOO LONG
ERRLNF CALL G6A84
       BYTE 22                * LINE NOT FOUND
ERRBLN CALL G6A84
       BYTE 23                * BAD LINE NUMBER
ERRLTL CLR  @PRGFLG           Don't print line number
       CALL G6A84             Issue the error
       BYTE 24                * LINE TOO LONG
ERRCIP XML  SCROLL            Scrolling the screen
       CALL G6A84
       BYTE 26                * COMMAND ILLEGAL IN PROGRAM
ERRPV  CALL G6A84
       BYTE 39                * PROTECTION VIOLATION
ERRIVN CLR  @PRGFLG           Don't print line number
       CALL G6A84
       BYTE 40                * UNRECOGNIZED CHARACTER
*
* Other ERROR messages in the program
*
* ERRRDY    * READY                BYTE 0
* ERRMEM    * MEMORY FULL          BYTE 11
* ERRCC     * CAN'T CONTINUE       BYTE 25
* WRNNPP    * NO PROGRAM PRESENT   BYTE 29
***********************************************************
* RXB SIZE
NSIZE  CZ   @PRGFLG           * PROGRAM MODE?
       BR   CSIZE
       CZ   [email protected]+1        * NORMAL
       BR   ERROLP
       CALL SIZEAS
       BR   TOPL15
CSIZE  CALL CHKEND            * CALL SIZE
       CALL SIZEAS
       CALL RETURN
SIZEAS CALL G65CE
       CZ   @RAMTOP
       BS   AMSSIZ
       MOVE 6,@>2002,@FAC
       DCEQ >AA55,@FAC+4
       BR   AMSSIZ
       DST  @FAC+2,@ARG2
       DSUB @FAC,@ARG2
       CALL SDISO
       MOVE 17,[email protected],[email protected](@VARW)
       CALL G6618
       B    AMSSIZ
***********************************************************
       AORG >0A70
G6A70  BR   PRESCN
       BR   $                 Spare
       BR   LLIST
G6A76  BR   READLN
       BR   CHKEND            check End Of Statement
       BR   $                 Was SEETWO - now spare
G6A7C  BR   DISO
       BR   ENTER
       BR   ENT09
G6A82  BR   WARNZZ
G6A84  BR   ERRZZ
G6A86  BR   READL1
       BR   READ00
       BR   READL3
       BR   $                 Spare
***********************************************************
* READLN - Read one logical line (up to four physical lines
* from the keyboard. Interpret things like BACKSPACE,
* INSERT, DELETE AND FORWARD. The total number of character
* can be limited by changing the start value for ARG2
* (upper limit), and entering at READL1 and VARW has to
* contain the start address of the feild, and VARA the
* current highest wirte address. Entering at READ00 allows
* for specification of the intial cursor-position. In this
* case ARG5 has to be set to the cursor-position. Please se
* to it that VARA, VARW, ARG2, and ARG4 have consistent
* values, i.e.
*           VARW <= ARG5 <= VARA <= ARG2
* ARG4 indicates if the line has been changed. If so, it
* contains a 0. If you enter READLN through READ00, you hav
* to initialize ARG4 to a nonzero value, should you want to
* use this feature.
***********************************************************
*----------------------------------------------------------
* Fix "You cannot add characters to a line whose number is
* multiple of 256, if that line was reached by typing eithe
* an up arrow or a down arrow form a previous line" bug,
* replace following 3 lines:
* READLN ST   >FF,@ARG7         Indicate non-check mode
*        DST  >037D,@ARG2       Set default upper limit
*        DST  @VARW,@VARA       Default nothing entered yet
*      with
READLN DST  >057D,@ARG2       Set default upper limit
       DST  @VARW,@VARA       Default to nothing entered ye
READL3 ST   >FF,@ARG7         Indicate non-check mode
*----------------------------------------------------------
* Please make sure that VARA points at a space location, or
* at the end-of-field.
*-------------- ADD FOLLOWING LINES 6/12/81 ---------------
READL1 CLR  [email protected]          Reset flag for ACCEPT SIZE to
       ST   1,@ARG4           This means "no change" in lin
READL2 DST  @VARW,@ARG5       Position cursor at start of f
*----------------------------------------------------------
* Auto-repeat function is added for 99/4A, in PSCANS line
* READ00 to READZ2+1 are changed to following code
*----------------------------------------------------------
READ00 CLR  @VAR0             Counter for auto-repeat fucti
*
* To get out of insert mode, we usually return here.
*
READ01 CLR  @ARG8             Indicate normal operation mod
       ST   CURSOR,@VARV      Use VARV for CURSOR/CHARACTER
* Idicate one character and alternate current character
* position between normal and cursor.
READZ1 EX   @VARV,V*ARG5      By alternating between the
*                              normal character and the
*                              cursor, we make the cursor
       CLR  @TIMER             blink
* RXB PATCH CODE FOR USER *****
* G6AAE  SCAN                   Scan for a character
*        RAND 99                Force randomize to be rando
G6AAE  CALL DUSER             USER from EDIT mode
       BS   READZ2            Found one!!!!
G6AB3  INC  @VAR0             Increment the auto-repeat cou
       CEQ  >FF,@RKEY         It is an old key
       BS   G6AC5
       CHE  >FE,@VAR0         Hold old key for a while
       BR   G6AC5
       SUB  30,@VAR0          Control repeat rate
       B    READZ5
G6AC5  CH   >10,@TIMER        Time next character switch
       BR   G6AAE
       BR   READZ1            Restart character blink cycle
*
* Correct if we ended up with a displayed cursor
*
READZ2 CLR  @VAR0
READZ5 CEQ  CURSOR,@VARV      Will have to change once more
       BS   G6AD7
       EX   @VARV,V*ARG5      Exchange for current cursor
* GKXB key routines CTRL up, down, left, right
G6AD7  B    CTRLS             GKXB CTRL KEYS
       BS   G6BD0
*
* BREAK character handling comes first
*
G6ADC  CEQ  BREAK,@RKEY       Saw break character
       BR   G6AF4
       AND  >FE,@FLAG         Reset AUTONUM mode
       CZ   @PRGFLG           If in run mode
       BS   BTOP15
*----------------------------------------------------------
* FIX FCTN4 breaks a program during an execution of INPUT,
* ACCEPT, or LINPUT statement regardless of ON BREAK NEXT
* flag bug 5/19/81
* Replace following 2 lines:
*        DST  @SMTSRT,[email protected] Save place for continue
*        B    EXEC6D           Interrupt execution
* with:
       CLOG >40,@FLAG         If ON-BREAK-NEXT has not been
       BR    G6AF4             set, i.e. break is illegal
       DST  @SMTSRT,[email protected]  Save place for continue
       B    EXEC6D            Interrupt execution
*----------------------------------------------------------
*
* Edit buffer recall
*
* RXB PATCH CODE ************ USER PATCH
*  G6AF4  CEQ  RECALL,@RKEY     If edit recall
G6AF4  CEQ  >FF,@RKEY         NO KEY---SO NEVER USE
       BR   G6B2A
       CZ   @PRGFLG           Ignore if exec mode
       BR   READZ1
       AND  >FE,@FLAG         Reset AUTONUM
       DST  NLNADD+32,@VARW   Initialize to 32 below screen
G6B04  XML  SCROLL            Scroll the screen
       DSUB 32,@VARW          Line start is 32 lower now
       DCEQ [email protected],@VARW    Until reach recall start
       BR   G6B04
       DST  [email protected],@VARA    Set old end of line
       DST  @VARA,@FAC        Calculate length of old line
       DSUB @VARW,@FAC        Subtract start from end
       BS   READZ3            If no characters to recall
* RXB PATCH CODE FOR USER ****
*      MOVE @FAC,[email protected],V*VARW Recall line
       MOVE @FAC,V*VARW,V*VARW
READZ3 ST   >FF,@ARG7         Non-check mode
       DST  @VARW,@ARG5       Cursor at beginning of line
       BR   READ00            Allow edit of line
*
* BACK-ARROW - Space back one position
*
G6B2A  CEQ  BACK,@RKEY        Backup to previous position
       BS   RBACK
*
* RIGHT-ARROW - Forward space
*
       CEQ  FORW,@RKEY        Space one position
       BS   RFORW
*
* INSERT - Start INSERT mode here
*
       CEQ  INSRT,@RKEY       Set INSERT flag
       BR   G6B3C
       ST   1,@ARG8           Select INSERT mode
*
* DELETE - Delete the current character
*
G6B3C  CEQ  DLETE,@RKEY       DELETE all right
       BR   G6B94
*------------ ADD THE FOLLOWING LINE 6/12/81 --------------
       CLR  [email protected]          Reset flag for SIZE in ACCEPT
       CLR  @ARG4             Indicate definite change in l
       DCEQ @ARG5,@VARA       Not an empty line
       BS   G6B8E
       CEQ  EDGECH,V*VARA     If pointing at end
       BR   G6B53
       DDEC @VARA             Backup up onto line
G6B53  DST  @VARA,@ARG        Move everything from right
       DSUB @ARG5,@ARG         of the cursor to the left
       MOVE @ARG,[email protected](@ARG5),V*ARG5
       DST  @ARG5,@ARG        Start at the beginning
       AND  >FC,@ARG1
       OR   >1D,@ARG1         Move over to the end of the l
G6B69  DCHE @VARA,@ARG        Update all errors
       BS   G6B7A
       EX   V*ARG,[email protected](@ARG)   Restore edge characters
       DADD 32,@ARG           Next victim please
       BR   G6B69
G6B7A  DDEC @VARA             Pre-update end of string
       CEQ  EDGECH,V*VARA     Hit edge character
       BR   G6B86
       DSUB 4,@VARA           Skip over edge characters
* For auto-repeat function 5/19/81
G6B86  CEQ  >20+OFFSET,V*VARA
       BS   READ01
       DINC @VARA             Locked at feild position
G6B8E  ST   >20+OFFSET,V*VARA Clear last position
       BR   READ01
*
* CLEAR - Clear the entire input line
*
G6B94  CEQ  CLRLN,@RKEY       Found CLEAR command
       BR   G6BB3
*-------------- ADD THE FOLLOWING LINE 6/12/81 ------------
       CLR  [email protected]          Reset flag for SIZE in ACCEPT
*                              Current maximum to minimum
G6B9C  CEQ  >7F,V*VARA         Don't clear edges
       BS   G6BA6
       ST   >20+OFFSET,V*VARA Blank line
G6BA6  DDEC @VARA             Pre-update end-of-line
       DCHE @VARW,@VARA       Up to and including first pos
       BS   G6B9C
       DINC @VARA             Undo last subtraction
       CLR  @ARG4             Indicate change
       BR   READL2            And restart everything
* General exit point. Unidentified control codes don't have
* effect!!!!!
G6BB3  CEQ  CHRTN,@RKEY       Only react on CR/UP/DOWN
       BS   G6BC2
       CEQ  UPMV,@RKEY
       BS   G6BC2
       CEQ  DOWN,@RKEY
       BR   READZ1
G6BC2  DCEQ @ARG2,@VARA       Check for block on last posit
       BR   G6BCF
       CEQ  >20+OFFSET,V*VARA Blocked. . . . . .
       BS   G6BCF
       DINC @VARA             Point beyond last character i
*                              line
G6BCF  RTN                    ENTER the current line
G6BD0  CZ   @ARG7             Check value of RKEY against g
       BR   VALIZ9
       DST  [email protected],@ARG     Pick up the standard stuff
       ST   V*ARG,@ARG        [email protected] : Pointer to the
*                              standard stuff
       CLOG >04,@ARG          Specified UPPER CASE
       BS   G6BF0
       CH   >5A,@RKEY         Z too high for anything
       BS   VALIZ2
       CHE  >41,@RKEY         A already in range
       BS   VALIZ9
       CEQ  >20,@RKEY         SPACE allow spaces in UALPHA
       BS   VALIZ9
G6BF0  CLOG >01,@ARG          Specified NUMERIC
       BS   G6C0B
       CEQ  >45,@RKEY         E ?
       BS   VALIZ9
       CEQ  >2E,@RKEY         . ?
       BS   VALIZ9
       CEQ  >2B,@RKEY         + ?
       BS   VALIZ9
       CEQ  >2D,@RKEY         - ?
       BS   VALIZ9
       BR   VALIZ1            now try DIGIT range
G6C0B  CLOG >02,@ARG          Digit range selected
       BS   VALIZ2
VALIZ1 CHE  >30,@RKEY         0 ?
       BR   VALIZ2            No good
       CHE  >3A,@RKEY         9 ?
       BR   VALIZ9            Numeric allright
VALIZ2 DST  [email protected],@ARG     Copy start address of string
       ST   [email protected]+1,@FAC6   and string length
       BR   VALIZ4             now test given characters
VALIZ3 CEQ  V*ARG,@RKEY       valid!!!!
       BS   VALIZ9
VALIZ4 DINC @ARG              Update actual address
       DEC  @FAC6              and count # of characters
       BR   VALIZ3
G6C30  CZ   @PRTNFN           Wait for completion of previo
       BR   G6C30              tone, and then
       CALL TONE2               ---BEEP---
       BR   READZ1            Continue in whatever mode we'
*                              in now
VALIZ9 CZ   @ARG8             INSERT mode?
       BS   G6C91
* INSERT - is COMPLICATED!!!!! Because of those edge charac
* Shift up all things. . . . continue as a standard insert
* VARA <= ARG2
       DCEQ @ARG2,@VARA       If end of screen
       BS   READZ4
*----------------------------------------------------------
* Fix Editing a line that has been retrived by the REDO key
* and may garble the last few characters bug, 5/28/81
       CEQ  EDGECH,V*VARA     If at end of line
       BR   READZ4
       DCEQ >02FE,@VARA       If also at end of screen
       BR   G6C64
       XML  SCROLL            Scroll the screen
       DSUB 32,@VARW          Back up line start address
       DSUB 28,@VARA          Back up to current start line
       DSUB 32,@ARG2          Absolute high limit backs up
       DSUB 32,@ARG5          Current cursor position too
       B    READZ4
G6C64  DADD 4,@VARA           Skip to next line
*----------------------------------------------------------
READZ4 DST  @VARA,@ARG        Use ARG as temp for insert
G6C6B  DCH  @ARG5,@ARG        Move everything up to current
*                              line
       BR   G6C8A
       DDEC @ARG              Copy lower location to higher
       ST   V*ARG,[email protected](@ARG)   Going from high to low
       CEQ  EDGECH,V*ARG      Bumped into wall again
       BR   G6C88
       DSUB 4,@ARG            Skip the wall
       ST   V*ARG,[email protected](@ARG)   And move character over
G6C88  BR   G6C6B
G6C8A  DCHE @ARG2,@VARA       Only update VARA if upper
       BS   G6C91
       DINC @VARA              hasn't been reached yet
G6C91  ADD  OFFSET,@RKEY      Create displayable character
       ST   @RKEY,V*ARG5      Display at current character
*                              position
       CLR  @ARG4             Indicate change in line
READ05 DCEQ @ARG2,@ARG5       Hit right margin
       BR   G6CAD
       CZ   [email protected]          If not the first time
       BS   G6CA7
       CALL TONE1             ---BEEP---
G6CA7  ST   >FF,[email protected]      Set the flag
       BR   READZ1            Stay in current mode !!!!
G6CAD  DINC @ARG5             Update current address
       CEQ  EDGECH,V*ARG5     Correct for next line
       BR   G6CB9
       DADD 4,@ARG5           By skipping border
G6CB9  DCH  @VARA,@ARG5       Check for last new high limit
       BR   G6CC1
       DST  @ARG5,@VARA       Update new high limit
G6CC1  DCHE >02FE,@VARA       Still some space to go
       BR   READZ1
       XML  SCROLL            Scroll the screen!!!
       DSUB 28,@VARA          Back to current start of line
       CZ   @ARG8             If not insert mode then
       BS   G6CD5
       DSUB 4,@VARA           Off by 4 more-correct it
G6CD5  DSUB 32,@VARW          Backup line start address
       DSUB 32,@ARG2          Absolute high limit backs up
       DSUB 32,@ARG5          Current cursor position too
       BR   READZ1            Start with something else
*
* Something special for forward cursor move
*
RFORW  CLR  @ARG8             Leave INSERT mode - don't cop
       BR   READ05             but use rest of input logic
*----------------------------------------------------------
* RBACK section has been moved from READL2+1 for adding
* auto-repeat function in 99/4A. Also
*       BR   READ01   is added at the end, 5/18/81
*----------------------------------------------------------
* This will cause the next test to fail initialy, since
* VARW clearly equals ARG5 first time through
*------------- ADD THE FOLLOWING LINE 6/12/81 -------------
RBACK  CLR  [email protected]          Reset flag for SIZE in ACCEPT
       DCH  @VARW,@ARG5       The standard backup entry
       BR   G6CFB
       DDEC @ARG5             So we backup the current posi
       CEQ  EDGECH,V*ARG5     Skip border line
       BR   G6CFB
       DSUB 4,@ARG5           Backup to previous line
G6CFB  BR   READ01            Go back for next character
***********************************************************
* WARNZZ - Checks the special warning handling conditions
* which can be set by an ON WARNING statement and does the
* following based upon those conditions:
* ON WARNING PRINT - prints continues execution
* ON WARNING STOP  - prints and stops
* ON WARNING NEXT  - ignores the warning and goes on
***********************************************************
WARNZZ DCLR @ERRCOD           Clear the error if form 9900
       CLR  @EXPZ
       FETCH @EXPZ+1          Get index into error table
       DSLL 2,@EXPZ           Multiply by 4
       DADD ERRTAB,@EXPZ      Get addres of entry into tabl
       MOVE 4,[email protected](@EXPZ),@FAC10
       CZ   @PRGFLG           If its imperative
       BS   WRNZZ3             take defualt.
       CLOG >02,@FLAG         If print turned on
       BR   G6D35
WRNZZ3 XML  SCROLL            Scroll the screen
       MOVE 9,[email protected],[email protected] * WARNING
       XML  SCROLL            Scroll the screen again
       DST  NLNADD+2,@VARW    Start address behind warning
       CALL TRACBK            Check for warning in UDF
       BS   WRNZZ5            Was UDF so message already ou
       CALL ERPNT5            Print the message
WRNZZ5 ST   3,@XPT
* If imperative then continue on normally
G6D35  CZ   @PRGFLG           If its imperative
       BR   G6D3C
       B    RETNOS
* If warning continue turned on the continue
G6D3C  CLOG >04,@FLAG         If contiue
       BR   ERRZZ4
       B    RETNOS
ERRZZ4 CALL CLEAN             Clean up stack and s.t.
ERRZZ5 DST  [email protected],@VSPTR   Restore value stack
BTOP15 B    G6012             Finish up and go back
***********************************************************
* ERRZZ - Sets up an error stack entry based upon the
* information passed to it by the caller and what it can
* gather from the error table. It then either prints the
* error message and aborts or goes to the line specified by
* a previously executed ON ERROR statement. The stack enrry
* looks like:
* ---------------------------------------------------------
* | Error code | Severity | >69 | Luno # | EXTRAM | PGMPTR
* | ^          | ^        | ^   | ^      | ^      | ^
* | FAC        | FAC1     | FAC2| FAC3   | FAC4   | FAC6
*----------------------------------------------------------
* ERROR CODE - the error number
* SEVERITY   - Severity of the error
*      1     - Warning
*      5     - Possibly recoverable
*      9     - Fatal, unrecoverable
* >69  ERROR STACK ENTRY ID
* LUNO #     - Luno # if file error or -1 if non-file error
* EXTRAM, PGMPTR - Information to indicate the line # of
*                  the error
***********************************************************
*----------------------------------------------------------
* In order to fix MEMORY FULL error occurring during MERGE
* execution will leave the file open to disk DSR bug,
* following lines should be added,
*??????? ????????????????????? ???????????????? ???????????
* This note for the reshipment of FLMGR after 6/10/81
* IOCALL routine are copied from FLMGR here, becuase FLMGR
* is not in the branch table in FLMGR.
*??????? ????????????????????? ???????????????? ???????????
* ERRZZ DST  [email protected],@PABPTR
*       DCZ  @PABPTR          Error must occur in EDITLN
*                              routine during MERGEing
*       BS   HERE
*       CALL IOCALL           Close all files
*       DATA CZCLOS
* HERE  ...........program continues
* A statement BR IOCALL needs to be added in FLMGRS, which
* is not going to be reshipped at this time 6/10/81
* Therefore, the following patch is used
*??????????????????????????????????????????????????????????
ERRZZ  DEX  [email protected],@PABPTR
       DCZ  @PABPTR           Error must occur in EDITLN
*                              routine during MERGEing
       BS   G6D74
       MOVE 30,@FAC,[email protected]>03C0   Save FAC area
       DST  @PABPTR,@FAC12    Get the PAB pointer in FAC
       DADD NLEN,@FAC12       Compute name length entry
       ST   1,[email protected](@PABPTR)    * Select name length entry
       CALL CALDSR            Call actual DSR line routine
       BYTE 8
       MOVE 30,[email protected]>03C0,@FAC
 
* Ignore the error coming back from DSR
       DCLR @PABPTR           Clear [email protected] in case
*                              any kind of I/O operation
*                              following MERGE
*                              (Also for the DEX statement)
G6D74  DEX  [email protected],@PABPTR  Get the PABPTR back
*----------------------------------------------------------
       DCLR @ERRCOD           Clear error code if from 9900
       DSUB @CURINC,@CURLIN   Just in case in autonum mode
       DCEQ CRNBUF,@SYMTAB    If prescanning r.h.
       BR   G6D87              of UDF and parameter in
       DST  [email protected]+2,@SYMTAB crunch buffer, fix SYMTAB
G6D87  CLR  @EXPZ             Get index into error table
       FETCH @EXPZ+1          Get index into error table
       DSLL 2,@EXPZ           Multiply index by 4
       DADD ERRTAB,@EXPZ      Address of table entry
       MOVE 4,[email protected](@EXPZ),@FAC10  Get table entry
       ST   RSTK+2,@SUBSTK    Init subroutine stack but all
*                              for GROM return address
       CZ   @FAC13            If message only
       BR   G6DAF
ERRZZR CALL ERPRNT            Display the error message
       DCEQ MSGFST,@FAC10     If * READY *
       BR   G6DAD
       CALL CLSALL            Close all files
G6DAD  BR   ERRZZ4             and clean up
G6DAF  CZ   @PRGFLG           If imperative-default
       BS   ERRZ1
       DCZ  [email protected]           If error turned off
       BR   G6DBF
ERRZ1  CALL TRACBK            Check for UDF
       BS   ERRZZ4            Was UDF, message already out
       BR   ERRZZR            Assume normal error
*
* Error turned on. Now build the error entry
*
G6DBF  CALL CLEAN             Clean up the stack
       DST  @FAC12,@FAC       Put in error & severity
       ST   >69,@FAC2         Error stack ID
       DCEQ MSG130,@FAC10     If I/O error
       BR   G6DD6
       ST   [email protected](@PABPTR),@FAC3  *  Put in LUNO #
       OR   >80,@FAC1         And indicate an I/O error
G6DD6  DST  @EXTRAM,@FAC6     Save line pointer
       DST  @SMTSRT,@FAC4     Save pointer to beginning of
*                              statement
       DST  @VSPTR,@ARG       Must check for room on stack
       DADD 24,@ARG           Need 24 to help out VPUSH
       DCH  @ARG,@STREND      If not room
       BS   G6DFD
       CALL ERPRNT            Put out the message anyway
       DST  MSG39,@FAC10      Memory full message
       CLR  @PRGFLG           Don't print a line #
       CALL ERPRNT            Print it too
       MOVE 8,[email protected],[email protected]
       BR   ERRZZ5            And give up
G6DFD  XML  VPUSH             Push the error entry
       DCLR @EXTRAM           Clear on-error entry
       DEX  [email protected],@EXTRAM   Set line pointer & clear on-e
       CALL GRSUB2            Read the line text pointer VD
*                              ERAM (use GREAD1) or VDP
       BYTE EXTRAM          * @EXTRAM : Source address
*                              in ERAM/VDP
       DST  @EEE1,@PGMPTR     Put the result in @PGMPTR
       XML  CONTIN            And go to the line
***********************************************************
* ERPRNT - Print an error or warning message
*
* ERPRNT - Entry point for ERROR
* ERPNT5 - Entry point for WARNING
***********************************************************
ERPRNT CALL G601C             Load the character table
       XML  SCROLL            Scroll the screen
       ST   >2A+OFFSET,[email protected] Put the * in
       DST  NLNADD+2,@VARW    Set up for the message
ERPNT5 CLR  @KEYBD            Enable main console
       MOVE 1,[email protected](@FAC10),@ARG1  Get message length
       CLR  @ARG
       MOVE @ARG,[email protected](@FAC10),V*VARW   Display
       DADD @ARG,@VARW        Start location for " IN "
       DCEQ MSG130,@FAC10     "* I/O ERROR [xx]xy"
       BR   G6E4D
       DINC @VARW             Update for one space
*                              separation
       ST   [email protected]>04(@PABPTR),@ARG3   * Create high order resu
       CLR  @ARG2             Only display high order decim
       CALL DISO              Display this number
       ST   [email protected]>05(@PABPTR),@ARG3  * Get low order result
       SRL  5,@ARG3           Remove mose identification bi
       CALL DISO              Output the number in decimal
G6E4D  DCEQ MSGFST,@FAC10
       BS   G6E79
       CALL TONE2             Wake up the idiot!!!!
       CZ   @PRGFLG           If program, print line #
       BS   G6E79
       DCH  >02F6,@VARW       It will pass EOL
       BR   G6E66
       XML  SCROLL            Display on next line
       DST  NLNADD+1,@VARW    Indent for the "IN"
G6E66  DST  >C9CE,[email protected](@VARW)   * Put in the "in"
       DADD 4,@VARW           Display location for line
       ST   @CHAT,@EXPZ       ASC destroys CHAT
       CALL ASC               DISPLAY THE LINE #
       ST   @EXPZ,@CHAT       Restore CHAT
G6E79  XML  SCROLL
       RTN
***********************************************************
* LLIST - Lists one program line on the screen. The
* entrypoint to the line is given in STPT.
* In this routine, FAC2 is used as a flag to indicate that
* the most recent character output was an alphanumeric
* character. If the next character is also an alphanumeric
* character, then the two are separated by a space.
***********************************************************
LLIST  CLOG >80,@FLAG         If program protected
       BS   G6E85
       CALL ERRZZ             * PROTECTION VIOLATION
       BYTE 39
G6E85  CALL OUTREC            Make room for a new line
       DST  V*EXTRAM,@ARG2    Prepare for line # printing
       AND  >7F,@ARG2         Reset possible BreakPoint
       CALL OUTLN             Diplay line in free format
       DST  @CCPADD,@VARW     Copy position for editing
       DINC @VARW             Leave room for space
       DST  [email protected](@EXTRAM),@PGMPTR   * Get pointer to line
LLISZ0 DST  >0020,@FAC2       Clear blank fill and set spac
LLIZ12 XML  PGMCHR            Get next token on line
       CZ   @CHAT             Exit on end of line
       BS   LLISZ9
       CZ   @FAC3             If separator needed
       BS   LLIZ15
       EX   @CHAT,@FAC3       Save CHAT and bare the separa
       CALL DSPCHR            Put the separator out
       EX   @CHAT,@FAC3       Restore CHAT
* Next thing to determine is whether or not we need a space
* for separation with the next stuff.
LLIZ15 CLR  @FAC3             Assume we'll get alphanumeric
       CEQ  SSEPZ,@CHAT       If double-colon
       BS   LLIZ16
       CEQ  COLONZ,@CHAT      If colon now and colon
       BR   G6EC4
LLIZ16 CEQ  COLONZ,@FAC        before-separater
       BS   LLIZ17
G6EC4  CHE  COMMAZ,@CHAT      Figure out separator range
       BR   G6ECE
       CHE  ORZ,@CHAT
       BR   LLISZ2
G6ECE  CH   NOTZ,@CHAT        Figure out separator range
       BR   G6ED8
       CHE  NUMCOZ,@CHAT
       BR   LLISZ2
G6ED8  ST   >20,@FAC3          Prepare for alfa indication
       CZ   @FAC2              alfanum-alfanum combination
       BS   LLISZ2
       CEQ  >20,@FAC10        Don't ouput 2 spaces
       BS   LLISZ2
LLIZ17 ST   @CHAT,@FAC2       Save CHAT somewhere
       ST   >20,@CHAT         And display a space
       CALL DSPCHR
       ST   @FAC2,@CHAT       Retrive CHAT
LLISZ2 EX   @FAC3,@FAC2       Could be for the next time to
* That takes care of all the extra spaces we might need
       CLOG >80,@CHAT         Just copy variable names
       BR   G6F0A
G6EF8  CALL DSPCHR            Copy the character to output
       XML  PGMCHR            Get the next character
       CZ   @CHAT             But exit on EOL
       BS   LLISZ9
       CLOG >80,@CHAT
       BS   G6EF8
       CLR  @FAC             No spaces if ":" or "::"
       BR   LLIZ15
G6F0A  CEQ  NUMZ,@CHAT
       BS   G6F17
       CEQ  STRINZ,@CHAT
       BR   LLISZ3
       CALL DSPQUO            Display first quote of string
* This place is the general location for strings both quote
* unquoted.
G6F17  XML  PGMCHR            Get string length in CHAT
       ST   @CHAT,@FAC        Copy in temporary space
G6F1C  CZ   @FAC              Also take care of empty strin
       BS   G6F35
       XML  PGMCHR
       CZ   @FAC2             Alpha means unquoted string
       BR   G6F2E
       CEQ  QUOTE,@CHAT
       BR   G6F2E
       CALL DSPCHR            Display two quotes for one
G6F2E  CALL DSPCHR            Display 2nd quote or char
       DEC  @FAC              Update string length, get nex
       BR   G6F1C
G6F35  CZ   @FAC2
       BR   LLISZ1            Non-alfa end means extra
       CALL DSPQUO            Display closing quote
       ST   >20,@FAC2         Cause space before following
       BR   LLISZ1             alpha
* Try to decode line numbers and keywords
LLISZ3 CEQ  LNZ,@CHAT         Decode line #
       BR   G6F55
       XML  PGMCHR            Get the high order byte first
       ST   @CHAT,@ARG2
       XML  PGMCHR
       ST   @CHAT,@ARG3        information as collected her
       CALL OUTLN             Display the actual informatio
       BR   LLISZ1            And continue
* Now it has to be a normal keyword
G6F55  DST  KEYTAB,@FAC       Address of KEYTAB for search
       XML  IO                Search keyword table
       BYTE 0                 * Select table search
*                      FAC8 returns with pointer to keyword
*                      FAC4 has length
LLISZ6 MOVE 1,[email protected](@FAC8),@CHAT
* And output the thus found character
       CALL DSPCHR            Display character on screen
       DINC @FAC8             Update FAC8 for next referenc
       DEC  @FAC5             Count number of characters
       BR   LLISZ6            Always less then 255
       CEQ  TREMZ,@FAC        No spaces after!!!
       BS   LLISZ7
       CEQ  REMZ,@FAC         No spaces after REM
       BS   LLISZ7
       CHE  COMMAZ,@FAC       Master stuff =>space
       BR   LLISZ0
       CEQ  USINGZ,@FAC       Master stuff =>space
       BS   LLISZ0
       CEQ  NUMBEZ,@FAC       "#" never followed by space
       BR   LLISZ1
LLISZ7 CLR  @FAC2             Avoid spaces behind here
LLISZ1 CLR  @FAC3             Indicate separator not needed
       BR   LLIZ12            Continue for next keyword
***********************************************************
* Convert a number from binary to ASCII
* Input  : binary number in ARG2 and ARG3
* Output : pointer to ASCII number in FAC11 with the actual
*          number lying just before and ending with FAC10.
*          i.e. the last digit of the ASCII representation
*          is in FAC10; number of digits in the number in
*          ARG5
***********************************************************
CVRTLN CLR  @ARG5             Start with 0 characters
       ST   ARG11,@ARG11      Select first address + 1
G6F90  DCLR @ARG              Clear upper 2 bytes of 4 byte
       DEC  @ARG11            Go to next position
       DDIV 10,@ARG           Compute least significant rem
       ADD  >30,@ARG3         Always < 10 off course
       ST   @ARG3,*ARG11      Store it in ARG
       DST  @ARG,@ARG2        Replace remainder by result
       INC  @ARG5             Update total # of characters
       DCZ  @ARG2             Until whole number converted
       BR   G6F90
LLISZ9 RTN
* Output a line number to a device (or screen)
OUTLN  CALL CVRTLN            Convert from binary to ASCII
OUTLZ1 ST   *ARG11,@CHAT      Get the next character
       CALL DSPCHR            Display the character
       INC  @ARG11            Increment the character posit
       DEC  @ARG5             Decrement number of digits
       BR   OUTLZ1            Output digit if not all out
       RTN
* Display number on the screen
DISO   CALL CVRTLN            Convert from binary to ASCII
DISPZ1 ST   *ARG11,V*VARW     Get more significant characte
       ADD  OFFSET,V*VARW     Display character on screen
       DINC @VARW             Update screen pointer
       INC  @ARG11            Get next position
       DEC  @ARG5             Update count
       BR   DISPZ1            Add loop until finished
       RTN
* Put out a quote
DSPQUO ST   QUOTE,@CHAT       DISPLAY A QUOTE
* Put out next character
DSPCHR CH   @RECLEN,@CCPPTR   Action on end of screen
       BR   G6FDE
       CALL OUTREC            Output crrrent record
       DSUB 32,@VARW          Keep track of begining of lin
G6FDE  ST   @DSRFLG,V*CCPADD  Put offset on screen
       ADD  @CHAT,V*CCPADD    Add in the character
       DINC @CCPADD           Bump output pointer
       INC  @CCPPTR           Update current line positon
       ST   @CHAT,@FAC10      FAC10 may be used by OUTREC !
       RTN
***********************************************************
* Static scanner to build the main symbol table and to buil
* symbol tables for each subprogram and to build the
* subprogram table. Checks some errors and aborts if any
* detected.
***********************************************************
*----------------------------------------------------------
* Added the following 6/8/81  for NOPSCAN feature
*  Flag PSCFG: >00 NOPSCAN
*              >FF RESUME PSCAN
PRESCN ST   >FF,[email protected]       Default to PSCAN
*----------------------------------------------------------
       DCLR @CALIST           Initialize call list
       DST  10,@DFLTLM        Set default array size
       DCLR @XFLAG            Initialize prescan flag bits
*                              and FOR/NEXT counter
       CZ   @PRGFLG           If imperative
       BR   G700B
       DST  CRNBUF,@PGMPTR    Pointer to 1st token
       XML  PGMCHR            Get the 1st token
       XML  SCROLL            Scroll the screen
       CALL SCAN10            Do the static scan of the lin
       BR   G7013             If program
G700B  CALL SCAN              Scan the program
       AND  >90,@FLAG         Reset all the flags but the
*                              TRACE & LIST/EDIT protection
       DCLR @LSUBP
G7013  DST  [email protected],@VSPTR   Initialize VSPTR
       B    EXEC              Execute the program or statem
***********************************************************
*                     Static Scanner
***********************************************************
SCAN   DST  @ENLN,@EXTRAM     1st address of line # table
       DADD 3,@EXTRAM
       DCLR @SYMTAB           Clear the symbol table
       DCLR @SUBTAB           Clear the subprogram table
       CZ   @RAMTOP
       BR   G7031
       DST  @STLN,@FREPTR     Initialize free-space pointer
       DDEC @FREPTR           Back up from line # table
       BR   G703B
G7031  DST  @STLN,@RAMFRE     Initialize ERAM free-space
       DDEC @RAMFRE           pointer
       DST  @>8370,@FREPTR    Initialize with no pgm in VDP
G703B  CLR  @BASE             OPTION BASE = 0
       DST  @FREPTR,@STRSP    Initailize string space
       DST  @STRSP,@STREND
       DST  @STLN,@LINUM
       DINCT @LINUM           Point to last line in program
* THE FOLLOWING 20 STATEMENTS CANNOT BE SEPARATED OR THE
* ASSEMBLY LANGUAGE CODE WILL NOT WORK - SRH
       XML  SCNSMT            Scan the program
       BYTE 0               * Entire program flag
SCAN10 XML  SCNSMT            Scan the statement
       BYTE 2               * Single statement flag
       BR   SCANRT            Normal end of scan
       BR   SCNDEF            Scan a def
       BR   SCNDIM            Scan a dim
       BR   CALLS             Scan a call
       BR   SCNOPT            Scan an option base
       BR   SUBS              Scan a sub
       BR   SUBNDS            Scan a subexit
       BR   SUBNDS            Scan a subend
       BR   CALENT            Call ENTER
       BR   ERROLP            * ONLY LEGAL IN A PROGRAM
       BR   ERRNWF            * NEXT WITHOUT FOR
       BR   ERRFNN            * FOR/NEXT NESTING
       BR   ERRMS             * MISSING SUBEND
       BR   ERRSYX            * SYNTAX ERROR
       BR   ERRMEM            * MEMORY FULL
       BR   ERRIBS            * ILLEGAL AFTER SUBPROGRAM
*
*                    SPECIALLY SCANNED STATEMENTS
* DIM STATEMENT
SCNDIM CLOG >40,@XFLAG
       BR   ERRSYX
G7073  CALL ENTER             Declare this symbol
       CEQ  COMMAZ,@CHAT      Loop if more
       BS   G7073
       BR   SCAN25            Must have EOL now
* OPTION BASE STATEMENT
SCNOPT CALL IMPIF             Can't be imperative or in "IF
       CALL PGMERR            OPTION - therefore must be BA
       CLOG >02,@XFLAG
       BR   ERROBE
*                             Error if OPTFLG already set
       CALL CHKSYN            Must have a "BASE"
       BYTE BASEZ
       CALL CHKSYN            Must have a numeric constant
       BYTE NUMCOZ
       CALL CHKSYN            Must have 1-char numeric cons
       BYTE 1
       CLR  @BASE             Assume BASE=0
       SUB  >30,@CHAT         Must be 0 or 1
       BS   SCAN20            OK if 0
       DEC  @CHAT             Check for a 1
       BR   ERROBE            If it was not a 1 then ERROR
       INC  @BASE             Set OPTION BASE=1
SCAN20 OR   >02,@XFLAG        Set the option base flag
SCAN22 XML  PGMCHR            Now - check for end-of-line
SCAN25 CALL CHKEND            If not EOL or :: or !    -err
       BS   CONSCN            If EOS - continue scan
       BR   ERRSYX            * SYNTAX ERROR
* DEF STATEMENT
SCNDEF CALL IMPIF             Can't be imperative or in "IF
       OR   >84,@XFLAG        Set function bit
*                             Set ENTERX bit
       CALL ENTER             Enter the function name
*                             ENTER resets function bit
       CLOG >07,V*SYMTAB      Did function have parm?
       BS   SCAN55            No...
       OR   >80,@XFLAG        >80 call for parm enter
       OR   >08,@FLAG         Fake it so symbol table
*                              searches won't be made
       CALL ENTERW            Enter the parameter
       AND  >F7,@FLAG         Reset function bit
       CALL CHKSYN            Complex symbol must be
       BYTE RPARZ           *  followed by ")="
       CALL CHKSYN
       BYTE EQUALZ
       MOVE 29,V*SYMTAB,[email protected]
       DST  [email protected]+4,@VAR0  Get pointer to name
       CZ   @RAMTOP           If ERAM program
       BS   G70EB
* If ERAM must fix up the name pointer because the name was
* moved too
       DSUB @SYMTAB,@VAR0     Offset into entry
       DADD CRNBUF,@VAR0      New location of name
       DST  @VAR0,[email protected]+4  Put it in
G70EB  DST  [email protected](@SYMTAB),@FREPTR  * Reset free space pointe
       DST  CRNBUF,@SYMTAB    Point into crunch buffer
       DDEC @FREPTR
SCAN35 CALL CHKEND            If EOL or ! or ::
       BS   SCAN50            Yes
       CGT  >00,@CHAT
       BS   SCAN40
       CEQ  NUMZ,@CHAT        If numeric - skip it
       BS   SCAN45
       CEQ  STRINZ,@CHAT      If string - skip
       BR   G710D
SCAN45 CALL SKPSTR            Skip the string or numeric
G710D  XML  PGMCHR            Get next charater
       BR   SCAN35
* Jump always
SCAN40 OR   >80,@XFLAG        Make an ENTERX (>80)call
       CALL ENTERX            Enter the symbol
**** Relink to keep parameter at the beginning of the table
       DCEQ CRNBUF,@SYMTAB    If no entry
       BS   SCAN35
       DST  [email protected]+2,[email protected](@SYMTAB)  * Put link in
       DST  @SYMTAB,[email protected]+2      Put new pointer in
       DST  CRNBUF,@SYMTAB    Put new pointer in
       BR   SCAN35            Go on
* Jump always
SCAN50 DST  [email protected]+2,@SYMTAB  Delink the parameter
       BR   CONSCN            Continue the scan
SCAN55 CALL CHKSYN
       BYTE EQUALZ
       BR   CONSCN
CALENT OR   >80,@XFLAG        Set enterx (>80) flag
       CALL ENTERX            Enter in symbol table
CONSCN XML  SCNSMT            Return to 9900 code to resume
       BYTE 1               * Return call to 9900 code
IMPIF  CLOG >40,@XFLAG        Not in if
       BR   ERRSYX
IMPILL CZ   @PRGFLG           Program mode - OK - return
       BR   SCANRT
ERROLP CALL ERRZZ             If imperative - error
       BYTE 27              * Only legal in a program
* Syntax required token routine
CHKSYN FETCH @FAC
       CEQ  @FAC,@CHAT
       BS   PGMERR
ERRSYX CALL ERRZZ
       BYTE 3                 * Syntax error
CHKEND CLOG >80,@CHAT
       BS   G7168
       CHE  TREMZ+1,@CHAT
       BS   G7168
       CEQ  @>8300,@>8300     Force COND to "SET"
       RTNC
G7168  CZ   @CHAT             Set COND according to CHAT
SCANRT RTNC
***********************************************************
*                    CALLS routine
* This routine scans the CALL statement. Get the subprogram
* name, search the table and update the call list
* (value stack area) if necessary. Share eht same XML
* search routine as the symbol table code uses.
***********************************************************
CALLS  XML  PGMCHR            Get token after call
       CALL CHKSYN            Check subprogram name
       BYTE UNQSTZ          * Must start with unquoted stri
       CH   >0F,@CHAT         * NAME TOO LONG!!
       BS   NTLERR
       DST  @PGMPTR,@VAR0     Save program pointer to name
       ST   FAC,@FAC17        Set up a pointer
       ST   @CHAT,@FAC15      Save name length
       ST   @CHAT,@FAC16      Save name length as a counter
CALL20 XML  PGMCHR            Get one byte of name
       ST   @CHAT,*FAC17      Store that character in FAC a
       INC  @FAC17            Increment pointer
       DEC  @FAC16            Decrement conter
       BR   CALL20            Get next character
*                            Exchange call list address wit
*                            symbol table address to run th
*                            same search routine used for
*                            symbol table search.
       DEX  @SYMTAB,@CALIST
       XML  SCHSYM            Search to see if name there
       DEX  @CALIST,@SYMTAB   Exchange back both addresses
       BS   SCAN67            If name found do nothing
       CZ   @RAMFLG           If not imperative and ERAM
       BS   G71AE
       XML  VPUSH             Put first 8 byte of name
       DST  @VSPTR,@VAR0      Pointing to new name location
       CGT  >08,@FAC15        If more characters in name
       BR   G71AE
       MOVE 8,@FAC8,@FAC      Move rest of the name
       XML  VPUSH             Push one more time
G71AE  CLR  @FAC
       ST   @FAC15,@FAC1      Put in name length
       DST  @CALIST,@FAC2     Put in call list link
       DST  @VAR0,@FAC4       Put in pointer to name
       XML  VPUSH             Put the entry in the VDP
       DST  @VSPTR,@CALIST    Change pointer to call list
SCAN67 XML  PGMCHR
       BR   CONSCN
***********************************************************
*                  SUBS routine
* This routine scans SUB statement in subprogram. First
* check the subprogram name and call list. Then builds
* subprogram table without argument list, scans symbols in
* the subprogram and create symbol table for the subprogram
* make entry to the subprogram table and add (if necessary)
* to call list.
***********************************************************
SUBS   CALL IMPIF             Can't be imperative or in "IF
       CZ   @FORNET           Check FOR-NEXT nesting
       BR   ERRFNN
       CLOG >01,@XFLAG        Called first time
       BR   G71D7
       CLOG >08,@XFLAG
       BR   ERRMS
* Cannot be in subprogram.  Can't start another one.
       DST  @SYMTAB,[email protected]  Finish off main table
* From the second SUB statement
G71D7  DCLR @SYMTAB           Start with empty symbol table
       OR   >28,@XFLAG        Set flag for SAFLG and SUBFLG
       AND  >FE,@XFLAG        Reset REMODE flag
       XML  PGMCHR            Get name behind SUB statement
       CALL CHKSYN            Make sure it's unquoted strin
       BYTE UNQSTZ
       CH   >0F,@CHAT         Length must be <= 15
       BS   NTLERR
       ST   @CHAT,@FAC1       Save name length
       DST  @PGMPTR,@FAC4     Assume pointer to VDP name
       CZ   @RAMTOP           But if ERAM save name in tabl
       BS   G720E
       CLR  @FAC
       XML  MEMCHK            FAC already has name length
       BS   ERRMEM            * MEMORY FULL
       DSUB @FAC,@FREPTR      Get pointer to put name in
       DST  @FREPTR,@EEE1     Re-do pointer to name
       DINC @EEE1             Correct for one off
       DST  @FAC,@FFF1        Set for XML GVWITE
       DST  @PGMPTR,@DDD1     Set for XML GVWITE
       XML  GVWITE            Move @FFF1 bytes from ERAM at
*                              DDD1 to VDP at EEE1
*
* Start building the subprogram table
       DST  @EEE1,@FAC4       Put pointer in VRAM to name
G720E  DST  14,@FAC           Minimum table size for subpro
       XML  MEMCHK            Make sure enough room there
       BS   ERRMEM            * MEMORY FULL
       CLR  @FAC              Prepare for name length
       ST   @CHAT,@FAC1       Get the name length
       DST  @SUBTAB,@FAC2     Save subprogram table address
       DCLR @FAC6             Mark end of argumant list
*  @FAC   = name length       @FAC2  = subprogram table lin
*  @FAC4  = pointer to name   @FAC6  = argument list = 00
*  @FAD8  = @PGMPTR           @FAC10 = @EXTRAM
*  @FAC12 = symbol table = 00
       DADD @FAC,@PGMPTR      Skip the name to look ahead
       MOVE 4,@PGMPTR,@FAC8   Copy PGMPTR and EXTRAM
       DCLR @FAC12            Assume subpgm has no symbol t
       DSUB 14,@FREPTR        Reset free pointer
       DST  @FREPTR,@SUBTAB   Copy
       DINC @SUBTAB           Set new subtable pointer
       MOVE 14,@FAC,V*SUBTAB  Put the table in!!
* Start fixing up subprogram's symbol table
       DST  @SUBTAB,[email protected]  Copy address of subtable
       DADD 6,[email protected]        Point to argument list
       DST  [email protected],[email protected] Duplicate for later use
       XML  PGMCHR            Get next token
       CALL CHKEND            Check if end of statement
       BS   SCAN90            Yes. Get out here quick
*                            Start looking at aruguments.
       CALL CHKSYN            Check for left parenthesis
       BYTE LPARZ
SCAN86 OR   >80,@XFLAG        Flag for ENTXFL
       CALL ENTERX            Enter next parameter
       DST  2,@FAC            Get room for ptr in sub block
       XML  MEMCHK            See if we had space for 2 byt
       BS   ERRMEM            * MEMORY FULL
       DST  [email protected],@FAC     Copy current arg list pointer
       DSUB @SYMTAB,@FAC      Find length from table addres
*                            Move symbol table down two byt
*                            to make space for next argueme
MINUST EQU  -2
       MOVE @FAC,V*SYMTAB,[email protected](@SYMTAB)
       DDECT @SUBTAB          Adjust the subtable pointer
       DDECT [email protected]         Adjust to point to first argu
       DST  [email protected],@VAR0
       DST  @SYMTAB,[email protected](@VAR0)   Put pointer in subtab
       DST  @SYMTAB,@FAC      Copy symbol table address
       DDECT @FAC             Pointing to real s.t. address
SCAN88 DST  [email protected](@FAC),@FAC2   Copy pointer to symbol table
       DDEC @FAC2
       DCH  @SUBTAB,@FAC2     If name moved also
       BS   G7293
       DDECT [email protected](@FAC)         correct for the movement.
G7293  DCZ   [email protected](@FAC)        If more symbol there
       BS   G72A4
       DDECT [email protected](@FAC)        Adjust the link address also
       DST  [email protected](@FAC),@FAC    Point to next s.t. address
       BR   SCAN88            Check for more s.t. adjustmen
G72A4  DST  [email protected],@FAC     Restore pointer to first argu
G72A8  DCEQ [email protected],@FAC     Fix all pointers in argument
       BS   G72B5
       DDECT V*FAC            Shift address by 2 bytes
       DINCT @FAC             Go to next argument pointer
       BR   G72A8
G72B5  DDECT @SYMTAB          Restore s.t. pointer
       DDECT @FREPTR          Restore free pointer
* Done with building a subprogram table.
       CEQ  RPARZ,@CHAT       Next character not ")" ?
       BS   G72C4
       CALL CHKSYN            Must be ","
       BYTE COMMAZ
       BR   SCAN86            Ge get more argument
G72C4  XML  PGMCHR            Finished...
       CALL CHKEND            Check if end of statement
       BR   ERRSYX            If not, error
SCAN90 AND  >DF,@XFLAG        Finished scanning sub argumen
       DADD 6,[email protected]        Point to location of pointer
*                              in subtab
       BR   CONSCN            Start scanning subprogram
***********************************************************
*                 SUBNDS and SUBXTS
* This routine scans SUBEND and SUBEXIT statement
***********************************************************
SUBNDS CALL IMPILL            Can't be imperative
       CLOG >08,@XFLAG
       BS   ERRSNS
********* MUST BE IN SUBPROGRAM message above *************
       CEQ  SUBNDZ,@CHAT
       BR   G72FB             Check for end of statement
       CZ   @FORNET           Check FOR-NEXT nesting
       BR   ERRFNN
       CLOG >01,@XFLAG
       BR   ERRSNS
       CLOG >40,@XFLAG
       BR   ERRSYX
       DST  [email protected],@VAR0
       DST  @SYMTAB,V*VAR0
       OR   >01,@XFLAG
G72FB  BR   SCAN22            Check for end of statement
***********************************************************
*           ENTER and ENTERX routines
* These routines take care of entering a symbol into the
* symbol table. If a symbol is encountered which is already
* in the table, the usage of the symbol is checked for
* consistency.
***********************************************************
ENTER  CALL PGMERR            Get next token - error if EOL
ENTERW CGE  >00,@CHAT         If token - error
       BR   ERRSYX
ENTERX ST   FAC-1,@FAC15      FOR INDIRECTION IN NAME SAVE
       DST  @PGMPTR,@NMPTR    SAVE POINTER TO NAME
       DDEC @NMPTR            CORRECT FOR PGMCHR POST INCRE
******************** Accumulate the name of the symbol
ENT01  INC  @FAC15            Count the character
       CH   FAC14,@FAC15
       BS   NTLERR
       ST   @CHAT,*FAC15      Save it
       XML  PGMCHR            Get the next one
       CGT  >00,@CHAT         If not token or EOL
       BS   ENT01
       DST  @PGMPTR,@ARG16    Save text pointer to put into
       DDEC @ARG16             symbol table entry loater
       CEQ  >24,*FAC15        String variable?
       BR   G732D
       OR   >10,@XFLAG        Set string flag
G732D  SUB  FAC,@FAC15        Calculate length of name
       INC  @FAC15            + offset of 1
       CEQ  LPARZ,@CHAT       If complex
       BS   ENT22
       CLOG >80,@XFLAG        If ENTERX
       BR   ENT08
       CLOG >04,@XFLAG
       BS   ERRSYX
* If not DEF then DIM without subscripted variable
***********************************************************
*           CODE FOR SIMPLE ENTRY INTO TABLE
* This incudes all non-dimensioned variables as well as
* phony entries for no-parameter functions. ENT09 is the
* entry point for entering one of these phony entries ENT10
* is the code which checks for consistent use of symbols
* within the user's program.
***********************************************************
ENT08  DDEC @PGMPTR           Correct pointer overshoot
ENT09  DST  @PGMPTR,@CHSAV    Save character pointer
       CLR  @STKMIN+1         Zero dimensions for simple
       ST   STKMIN+1,@TOPSTK  Save top of stack
       CLOG >08,@FLAG         No search in function
       BR   ENT16
       XML  SCHSYM            Search symbol table
       BR   ENT16             Not found - must enter it
       DINC @PGMPTR           Correct pointer undershoot
* Common code used by SIMPLE and COMPLEX
* When the symbol appears in the SYMBOL TABLE. It varifies
* that the declarations are the same
* (# of paremeters/dimensions, string, funciton)
ENT10  CLOG >80,@XFLAG        Redeclaring
       BS   ERRMUV
       CLOG >24,@XFLAG        If function or sub-arg
       BR   ERRMUV            Then redefining variable UDF
       ST   V*FAC,@VAR0       Fetch declaration
       AND  >07,@VAR0         MASK FUNCTION AND STRING BITS
       CEQ  *TOPSTK,@VAR0     Not same # of dim
       BR   ERRMUV
       AND  >6B,@XFLAG        Clear FNCFLG, STRFLG and ENTE
       RTN                    All OK - Type matches perfect
ENT16  MOVE 16,@FAC,@ARG      Save name
       DST  14,@NMLEN         Need 14 bytes for a simple va
       CLOG >14,@XFLAG        String or function?
       BS   ENT61             No - allocate & update table
       BR   ENT60             Yes - need 8 bytes for them
*                              Set count to 8 and update
***********************************************************
*           CODE FOR A COMPLEX ENTER
***********************************************************
ENT22  DST  @PGMPTR,@CHSAV    Save the line pointer
       ST   STKMIN,@STACK     Initiaze base of date stack
       MOVE 16,@FAC,@ARG      Save name
       CLOG >84,@XFLAG        ENTERX or inside a DEF ?
       BR   ENT28             Yes, require special scanning
ENT24  XML  PGMCHR            Get next character
       CALL CHKSYN            Must have numeric constant
       BYTE NUMCOZ
       CALL CSINT             Convert dimension to integer
       BS   ERRBV             If got an error on conversion
       CZ   @FAC              If not BIG dim
       BR   G73A6
       CHE  @BASE,@FAC1        Dim < BASE
       BR   ERRBV
G73A6  PUSH @FAC1             Push this dimension
       PUSH @FAC              Both bytes
       CH   STKMAX,@STACK     If too many dims
       BS   ERRSYX
       CEQ  COMMAZ,@CHAT      If comma-more dims
       BS   ENT24
       CEQ  RPARZ,@CHAT       Ok if end on rpar
       BS   ENT40
       BR   ERRSYX            Didn't end on a rpar
******************* Code for a non-DIM statement
ENT28  ST   1,@VAR0           Parenthisis level counter
*                              At first level
ENT29  CALL PGMERR            Get next token - error if EOL
       CGT  >00,@CHAT
       BR   G73CD
       CLOG >20,@XFLAG        Not accepted?
       BR   ERRBA
       BR   ENT29             Get next token
G73CD  CEQ  RPARZ,@CHAT
       BS   ENT34
       CLOG >04,@XFLAG
       BR   ERRSYX
       CEQ  COMMAZ,@CHAT
       BR   G73EC
       CGT  >01,@VAR0         If not top-level command
       BS   ENT29
       PUSH @DFLTLM+1
       PUSH @DFLTLM           Push a default limit
       CGT  STKMAX,@STACK     NOT too many dim
       BR   ENT29
       BR   ERRSYX            Too many dims - so error
* Jump always
G73EC  CLOG >20,@XFLAG        * BAD ARGUMENT
       BR   ERRBA
       CEQ  STRINZ,@CHAT
       BR   G73FB
ENT30  CALL SKPSTR
       BR   ENT29
G73FB  CEQ  NUMCOZ,@CHAT
       BS   ENT30
       CEQ  LPARZ,@CHAT
       BR   G7407
       INC  @VAR0             Increase nesting level
G7407  BR   ENT29             Not anything above. Get next
ENT34  DEC  @VAR0             Decrease nesting level
       BR   ENT29             Continue scan unless through
       PUSH @DFLTLM+1         Push final default limit
       PUSH @DFLTLM
***********************************************************
* Calculate number of dims and search symbol table
***********************************************************
ENT40  ST   @STACK,@VAR0      Compute the # of dims
       SUB  STKMIN,@VAR0
       SRL  1,@VAR0           Divide by 2
       PUSH @VAR0             Push the number of dims on to
       ST   @STACK,@TOPSTK    Save stack top
       MOVE 16,@ARG,@FAC      Get name back
       XML  SCHSYM            Search symbol table for it
       BR   ENT44             Not found in table - ENTER it
       DST  @CHSAV,@PGMPTR    Restore scan restart at "("
       BR   ENT10             And check for consistency
ENT44  CLOG >24,@XFLAG        If function or subprogram
       BR   ENT60              argument then need 8 bytes
* Caculate total number of array elements
       ST   @STACK,@TOPSTK    Save stack pointer
       DEC  @STACK            Skip # of dims
       POP  @FAC              Assume base=0
       POP  @FAC1
       DINC @FAC
       CLR  @VARC             But correct if base=1
       ST   @BASE,@VARC+1     Handle 1st dim specially to
       DSUB @VARC,@FAC         Avoid 1 multiply
       DST  @FAC,@NMLEN       FAC gets # of elements in arr
       B    ENT53             Merge into loop
ENT50  POP  @FAC              Get next dimension
       POP  @FAC1
       DINC @FAC              Assume base=0
       DSUB @VARC,@FAC        But correct if base=1
       DST  @NMLEN,@ACCUM
       DMUL @FAC,@ACCUM       Accumulate size
       DCZ  @ACCUM            Out of memory
       BR   ERRMEM
       DST  @ACCUM+2,@NMLEN
ENT53  CEQ  STKMIN,@STACK
       BR   ENT50
       CLOG >E0,@NMLEN        If any of the top 3 bits set
       BR   ERRMEM             then * MEMORY FULL
       DSLL 1,@NMLEN          Assume string| memory=elemets
       CLOG >10,@XFLAG        But it numeric
       BR   G7480
       DSLL 2,@NMLEN          Memory = 4*(2 * # of elements
G7480  DADD 6,@NMLEN          Need 6 more bytes for header
       CLR  @FAC              For double
       ST   *TOPSTK,@FAC1     Get # of dimensions
       SLL  1,@FAC1           Multiply by 2
       DST  @FAC,@VARC        Save # of elements for later
       DADD @FAC,@NMLEN       Total # of bytes needed
       CARRY
       BS   ERRMEM
       BR   ENT61             Jump always
ENT60  DST  8,@NMLEN          Functions & simple strings ne
***********************************************************
* Check to see if enough memory in VDP RAM or ERAM
* Put symbol name in table if imperatively created or if
* excuting an ERAM program.
***********************************************************
ENT61  CZ   @RAMTOP           If not ERAM
       BR   G74A5
       CZ   @PRGFLG           If program mode
       BR   ENT62
G74A5  CZ   @ARG15            If 0-length (function)
       BS   ENT62
* Move the name into the symbol table
       CLR  @VAR0             Re-do name and pointer
       ST   @ARG15,@VAR0+1    Get length of name
       DST  @VAR0,@FAC        Put length for MEMCHK
       XML  MEMCHK            Check enough memory for name
       BS   ERRMEM            * MEMORY FULL
       DSUB @VAR0,@FREPTR     Get space for the name
       DST  @FREPTR,@NMPTR    Set new pointer to name
       DINC @NMPTR            New pointer to name
       MOVE @VAR0,@ARG,V*NMPTR Move the name
ENT62  CLR  @FAC7             Assume not simple numeric
       CZ   @RAMTOP           Set simple numeric variable
       BS   ENT63A
       ST   @TOPSTK,@STACK    Get # of dimensions of pareme
       POP  @FAC8
       CLOG >14,@XFLAG        If string or UDFunction
       BR   ENT62A            Yes, don't set FAC7
*                             No, if array?
       CZ   @FAC8             Not array
       BR   ENT62A
       INC  @FAC7             Has to be a simple numeric
       DST  @NMLEN,@VAR0      Check enough memory in VDP
       DST  8,@NMLEN          For later use - to locate
       DST  @NMLEN,@FAC       Check enough memory in VDP
       XML  MEMCHK
       BS   ERRMEM            * MEMORY FULL
       BR   ENT63             Check enough memory in ERAM
ENT62A CLR  @FAC6
       CLOG >04,@XFLAG
       BR   ENT63A
*                          UDFunction
       ST   @FAC8,@FAC6
       CZ   @FAC6             String or numeric array?
       BS   ENT63A
* If numeric array goto ENT62B. When checking subprogram
* arguments, numeric array is treated the same as string
* array case.
       CLOG >20,@XFLAG
       BR   ENT62C
       CLOG >10,@XFLAG
       BS   ENT62B
ENT62C CLR  @FAC6             Clear FAC6 to indicate string
       BR   ENT63A            So skip the next portion
* Numeric array case...
ENT62B DST  @NMLEN,@VAR0      Store @NMLEN in temporary
       DST  @VARC,@NMLEN      # of bytes for dimension info
       DADD 8,@NMLEN          # of bytes need in the symbol
*                              table entry in VDP RAM
       DST  @NMLEN,@FAC       Check enough memory in VDP RA
       XML  MEMCHK
       BS   ERRMEM            * MEMORY FULL
       DST  @VAR0,@FAC        Restore @NMLEN from VAR0
       DSUB @VARC,@FAC
       DSUB 6,@FAC
ENT63  DST  @RAMFRE,@FAC2     Get ERAM free pointer
       DSUB @FAC,@FAC2        Calculate lowest address need
       DINC @FAC2             One byte off here
       DCHE CPUBAS,@FAC2      * MEMORY FULL
       BR   ERRMEM
       DST  @FAC2,@RAMFRE     Set new ERAM freespace pointe
       BR   ENT65
ENT63A DST  @NMLEN,@FAC       No, # of bytes needed
       XML  MEMCHK            * MEMORY FULL
       BS   ERRMEM             in VDP RAM
* Now, construct the entry for the symbol table in the FAC
* for ease and speed. Then move it to VDP RAM
ENT65  CLR  @FAC              Clear the header byte
       CLOG >10,@XFLAG        If string
       BS   G7548
       OR   >80,@FAC          Set string bit in header
G7548  CLOG >04,@XFLAG        If UDFunction
       BS   G7550
       OR   >40,@FAC          Set function bit
G7550  ST   @TOPSTK,@STACK    Get # of dimensions or parame
       POP  @FAC8
       CZ   @FAC8             If array or parameters
       BS   ENT67
       OR   @FAC8,@FAC        Overlay # of dimensions
       CLOG >24,@XFLAG        If def or sub-arg
       BR   ENT67             Don't set opt flag
       OR   >02,@XFLAG        Array so set OPTION BASE flag
ENT67  ST   @ARG15,@FAC1      Save length of name
       DST  @SYMTAB,@FAC2     Link to previous entry
       DST  @NMPTR,@FAC4      Save pointer to the name
       DSUB @NMLEN,@FREPTR    Set new table pointer
       DINC @FREPTR
* Move the entry from the FAC to the symbol table
       MOVE 6,@FAC,V*FREPTR
       DST  @FREPTR,@SYMTAB   Pointer to beginning of table
       CLOG >08,@FLAG         If not run-function modify
       BR   G758B
       CLOG >08,@XFLAG        If not in subprogram
       BR   G758B
       DST  @SYMTAB,[email protected]  Save pointer in VDP RAM
G758B  DADD 6,@FREPTR
       CZ   @RAMTOP           If ERAM exists then
       BS   G75C1
       CEQ  >01,@FAC7         If simple numeric variable
       BR   G75A8
       DST  @VAR0,@NMLEN      Restore NMLEN
       DST  @RAMFRE,V*FREPTR  Set the pointer into ERAM
       CLOG >20,@XFLAG
       BR   ENT69
       BR   G75BF
G75A8  CLOG >20,@XFLAG
       BR   ENT69
       CZ   @FAC6             If numeric array
       BS   G75BF
       DST  @VAR0,@NMLEN      Restore NMLEN
       DST  @VARC,@VAR0       Leave the space for dimension
*                              info whtich is going to be
*                              filled in later
       DADD @FREPTR,@VAR0
       DST  @RAMFRE,V*VAR0    Set pointer in ERAM
G75BF  BR   G75C6
G75C1  CLOG >20,@XFLAG
       BR   ENT69
G75C6  CLOG >04,@XFLAG        If UDF - no dimensions
       BS   G75D1
       DST  @ARG16,V*FREPTR   SAVE POINTER TO "(" OR "="
       BR   ENT69B            Jump always
**** Save the dimension information in the symbol table
G75D1  CGT STKMIN,@STACK      If non-array
       BR   ENT69
       ST   STKMIN,@STACK     Get to bottom of stack
ENT68  INC  @STACK            Point tat LSB of next entry
       CHE  @TOPSTK,@STACK    If finished, out
       BS   ENT69
       ST   *STACK,[email protected]>01(@FREPTR)  * Put directly into tabl
       INC  @STACK            Point at MSB of next entry
       ST   *STACK,V*FREPTR   Put directly into table
       DDECT @NMLEN           Used up 2 bytes in table
       DINCT @FREPTR          Adjust pointer to unused byte
       BR   ENT68             Get next dimension
***** Now, zero the required amount of memory
ENT69  CZ   @RAMTOP           If ERAM exists
       BS   ENT69D
       CLOG >10,@XFLAG
       BR   ENT69D
       CEQ  >01,@FAC7         If simple numeric variable
       BR   G7608
       DST  8,@NMLEN          Zero 8 bytes of ERAM memory
       BR   ENT69C
G7608  CZ   @FAC6             If numeric array
       BS   G7618
       DSUB 6,@NMLEN          Calculate amount of ERAM to c
ENT69C XML  IO                Special code to clear ERAM
       BYTE 3               * Select the clear - ERAM code
       BYTE RAMFRE          * Address of ERAM address
       BYTE NMLEN           * Address of number of bytes
       DDEC @RAMFRE           Adjust ERAM free pointer
G7618  BR   ENT69B            VDP case
ENT69D DSUB 7,@NMLEN          Now clear VDP RAM
       CLR  V*FREPTR          Clear 1st byte, then the rest
       MOVE @NMLEN,V*FREPTR,[email protected](@FREPTR)
ENT69B DST  @SYMTAB,@FREPTR   Set new free pointer @ then t
       DDEC @FREPTR           Now, set it at 1st free byte
       AND  >EB,@XFLAG        Clear STRFLG and FNCFLG
       CLOG >80,@XFLAG        If ENTERX call
       BS   G763D
       CLOG >20,@XFLAG        If not scanning
       BR   G763D              a subprogram argument then
       DST  @CHSAV,@PGMPTR    Restore character pointer
G763D  XML  PGMCHR            Get next character
       RTN
***********************************************************
* THIS ROUTINE READS A CHARACTER AND WILL GIVE AN ERROR IF
* IT READS AN END OF LINE (PREMATURE END)
***********************************************************
PGMERR XML  PGMCHR
       CALL CHKEND
       BS   ERRSYX            Premature EOL
       RTN
***********************************************************
* THIS ROUTINE SKIPS QUOTED STRINGS UNQUOTED STRINGS AND
* NUMERIC CONSTANTS
***********************************************************
SKPSTR XML  PGMCHR            Get the byte count
       CLR  @VARC              for double
       ST   @CHAT,@VARC+1     Get count for add
       DADD @VARC,@PGMPTR     Skip the string
       RTN
* ERROR messages called in this file
ERRIBS CALL ERRZZ             * ILLEGAL AFTER SUBPROGRAM
       BYTE 4
NTLERR CALL ERRZZ             * NAME TOO LONG
       BYTE 6
ERROBE CALL ERRZZ             * OPTION BASE ERROR
       BYTE 8
ERRMUV CALL ERRZZ             * IMPROPERLY USED NAME
       BYTE 9
ERRMEM CALL ERRZZ             * MEMORY FULL
       BYTE 11
ERRNWF CALL ERRZZ             * NEXT WITHOUT FOR
       BYTE 13
ERRFNN CALL ERRZZ             * FOR/NEXT NESTING
       BYTE 14
ERRSNS CALL ERRZZ             * MUST BE IN SUBPROGRAM
       BYTE 15
ERRMS  CALL ERRZZ             * MISSING SUBEND
       BYTE 17
ERRBA  CALL ERRZZ             * BAD ARGUMENT
       BYTE 28
ERRBV  CALL ERRZZ             * BAD VALUE
       BYTE 30
* Other error messages inside this program
* ERRSYN    * SYNTAX ERROR                         DATA  3
* ERROLP    * ONLY LEGAL IN A PROGRAM              DATA 27
* ERRPV     * PROTECTION VIOLATION                 DATA 39
***********************************************************
* Search and clean up stack and symbol table to not allow
* garbage to accumulate
***********************************************************
CLEAN  DST  @VSPTR,@FAC8      Get a temporary stack pointer
CLEAN1 DCH  @STVSPT,@FAC8     While not end of stack
       BR   G76BE
       ST   [email protected](@FAC8),@FAC14 Get stack ID byte
       SUB  >66,@FAC14        Check the range
       CH   >04,@FAC14        If string, numeric, >70, >72
       BR   G7698
       XML  VPOP              Throw it away (Must be on top
       BR   CLEAN
G7698  CASE @FAC14
       BR   CLEANG            GOSUB entry                >6
       BR   CLEANF            FOR   entry                >6
       BR   CLEANU            UDF   entry                >6
       BR   CLEANE            ERROR entry                >6
       BR   CLEANS            SUB   entry                >6
CLEANE CALL SQUISH            ERROR Entry - squish it out
CLEANG DSUB 8,@FAC8           Go down 1 entry
       BR   CLEAN1            Go on to next entry
* Jump always
CLEANF DSUB 16,@FAC8          Keep it around but get below
CLEANS DSUB 16,@FAC8          16 bytes further down
       BR   CLEAN1            FOR or SUB entry
* Jump always
CLEANU DCLR @FAC4             Cause delink to work right
       CALL DELINK            Delink the symbol table entry
       BR   CLEANG
G76BE  RTN
***********************************************************
* Subroutine to convert numeric to integer
***********************************************************
CSINT  DCLR @FAC              Start with clean FAC
CSINT2 XML  PGMCHR
       SUB  >30,@CHAT         Subtract ASCII value for "0"
       CHE  >0A,@CHAT         Valid numeric
       BS   G76E3
       DMUL 10,@FAC           Multiply previous result
       DCZ  @FAC              Overflow ??????
       BR   RETSET
       ST   @CHAT,@FAC1       Get result back down
       DADD @FAC2,@FAC        Add current digit
       CARRY                  If >65535
       BS   RETSET
       CGE  >00,@FAC          Integer > 32767
       BR   RETSET
       BR   CSINT2            And loop until done
G76E3  ADD  >30,@CHAT
       RTN                    Also used somewhere else
RETSET CEQ  @>8300,@>8300
       RTNC
*
* GKXB CODE FOLLOWS ***************************************
RES1   DCLR @PGMPTR      Set flag
       DST  @STLN,@XSTLN Save STLN & ENLN
       DST  @ENLN,@XENLN
       CALL AUTON        Get first parameters
       INC  @PGMPTR      Destroy flag
       RTN
*
* RES2 entered from AUTON if more than 2 numbers entered
*
RES2   DCZ  @PGMPTR      Check flag
       BS   RES2A        Yes, continue
       B    CKOTHR       No, check for copy & move
RES2A  INC  @PGMPTR      Destroy flag
       CEQ  COMMA,@CHAT  Check for comma
       BR   ERRSY1       If no comma
       DST  @CURLIN,@XCURLI Save CURLIN & CURINC
       DST  @CURINC,@XCURIN
       DCLR @CURLIN      Clear out pointers
       DCLR @CURINC
       ST   DASH,@VARC   Separator
       CALL AUTO3        Get range
       CALL GTRANG       Find locations in line table
       DST  @XCURLI,@CURLIN Restore CURLIN & CURINC
       DST  @XCURIN,@CURINC
       DCEQ @XENLN,@ENLN See if start line is first line
       BS   RES3         Yes, continue
       DST  @XENLN,@FAC  Copy start addr to FAC
       DINC @FAC         Point to next lower table entry
       CALL GRSUB3       Get line # of line before start
       BYTE FAC-PAD
       DCH  @EEE1,@CURLIN New start # must be higher than
*                         last # in preceding segment
       BR   ERRBLN       Bad line number if not!
RES3   RTN
*
RES4   DST  @ENLN,@PGMPTR Moved from RES routine
       CZ   V[email protected]     Called from RES?
       BS   RES4B        No, skip a few lines
       DCEQ @XSTLN,@STLN Renumbering to end of prog?
       BS   RES4A        Yes, skip the check
       DST  @XSTLN,@FAC  Check for high # overlap
       DSUB 4,@FAC       Point to entry after RES segment
       CALL GRSUB3       Get that line #
       BYTE FAC-PAD
RES4B  DCHE @EEE1,@CURLIN Check that CURLIN is'nt higher
*                         or equal
       BS   ERRBLN       If so, bad line number
RES4A  RTN
*
RES5   CEQ  6,[email protected]   A true RES?
       BS   TOPL25       Yes, return to basic
       RTN               No, just do a return
*
* Code for new commands DEL, COPY, and MOVE
*
* NOTICE !!!!!
* RAM BANK 2 CHANGED AS FOLLOWS-----
* 7D1B changed from >08 to >0B
* 7D35 changed from >08 to >0C
*
*
NEWCMD CH   >0B,[email protected] If higher than MOVE token,
       BS   SZRUN4        continue with old stuff
       DST  CRNBUF+1,@PGMPTR Anticipate usage of PGMCHR
       XML  PGMCHR       Setup CHAT
       ST   [email protected],@FAC Copy token
       SUB  9,@FAC       Adjust for CASE
       CASE @FAC         Select the keyword
       BR   DEL
       BR   COPY
       BR   MOVE
*
* Patch to change to default colors on RUN
*
RUNPAT CZ   @PRGFLG      Program already running?
       BR   RUNRET       Yes, do nothing
       BACK 7            Screen color
       ST   >10,[email protected]>80F   Character colors
       MOVE 16,[email protected]>80F,[email protected]>810
RUNRET CLR  @PRGFLG      Moved from RUN routine
       B    G6504        Return
*
* DEL routine... Allows the deletion of a program segment
*
DEL    ST   DASH,@VARC   Select separator
       DCLR @CURLIN      Clear variables
       DCLR @CURINC
       CALL AUTO1        Get parameters
       DST  @STLN,@XSTLN Save pointers
       DST  @ENLN,@XENLN
       CALL GTRANG       Get the range to delete
*
DEL01  DST  @ENLN,@XCURLI Store a copy of ENLN
*
       DST  @XENLN,@FAC  Check to see if we need
       DSUB 3,@FAC        to delete another line
       DCHE @XSTLN,@FAC
       BR   DELEND       We're through
*
       CALL GRSUB3       Get line # of line to delete
       BYTE FAC-PAD
       DST  @EEE1,@FAC   Store number in FAC
       ST   1,@CHAT      Flag to delete line
       CALL EDITLN       Delete the line
*
       DADD 4,@XSTLN     Adjust for deleted line
 
       DST  @ENLN,@FAC   New ENLN value
       DSUB @XCURLI,@FAC How much did we delete?
       DADD @FAC,@XSTLN  New XSTLN value
       DADD @FAC,@XENLN  New XENLN value
       B    DEL01        Loop
DELEND B    TOPL20       Return to basic
 
* GTRANG - Sets XSTLN & XENLN as a line #
* table for a range of line #s in CURLIN
* & CURINC. XSTLN & XENLN should contain
* the values in STLN & ENLN when called.
* A bad line number error is generated if
* the range does not contain at least one
* valid program line. If CURINC is zero,
* then the line # in CURLIN must be a valid
* program line. A syntax error is occurs if
* both CURLIN & CURINC are zero.
*
GTRANG DCEQ @STLN,@ENLN  If no program, then error
       BS   ERRNPP
       DST  @ENLN,@FAC   Get first line #
       DSUB 3,@FAC       FAC=source addr in ERAM/VDP
 
       DCZ  @CURLIN      Beginning line specified?
       BR   GTRAN0       Yes, get it
       DCZ  @CURINC      Ending line also zero?
       BS   ERRSY        Yes, syntax error
GTRAN0 CALL GRSUB3       Read the line #
       BYTE FAC-PAD
       DCHE @CURLIN,@EEE1 Check for good number
       BS   GTRAN2       Good number
       DSUB 4,@FAC       Get next table entry
       DCHE @STLN,@FAC   Make sure we're still in table
       BS   GTRAN0       Loop till good number found
       BR   ERRBL        Bad line number error
GTRAN2 DST  @FAC,@XENLN  Store for RES routine
       DADD 3,@XENLN     Fake an ENLN entry
* Evaluate what's in CURINC
GTRAN1 DCZ  @CURINC      Zero?
       BR   GTRAN4       No, go get a line #
       DST  @VARW,@FAC2  Store screen pointer
GTRAN3 DDEC @FAC2        Back up one space on screen
       CEQ  OSPACE,V*FAC2 Is it a space?
       BS   GTRAN3       Yes, loop till no space
       CEQ  DASH+OFFSET,V*FAC2 Is it a dash?
       BS   GTRAN7       Yes, use default for STLN
       BR   GTRAN8       Just one # entered, check it!
GTRAN4 DCH  @CURINC,@CURLIN End line higher than start?
       BR   GTRAN5       No, go get end line
       DST  @CURLIN,@CURINC Make a good line #
GTRAN5 CALL GRSUB3       Get next line #
       BYTE FAC-PAD
       DCH  @CURINC,@EEE1 Gone too far?
       BS   GTRAN6       Yes, we're done
       DSUB 4,@FAC       Next table entry
       DCHE @STLN,@FAC   Make sure we're still in table
       BS   GTRAN5       Loop
       BR   GTRAN7       End of table, use default
GTRAN6 DADD 4,@FAC       Back up one entry
GTRAN9 DST  @FAC,@XSTLN  Put it in place
GTRAN7 DCH  @XENLN,@XSTLN If XSTLN > XENLN then error
       BS   ERRBL
       RTN
GTRAN8 CH   9,[email protected]   Called from RES or DEL?
       BS   GTRAN9       No, skip this check
       DCEQ @EEE1,@CURLIN Check that line found is good
       BR   ERRBL        Bad line number if not
       BR   GTRAN9       Set XSTLN and return
*
ERRSY  B    ERRSY1
ERRBL  B    ERRBLN
ERRNPP B    >64EF        No program present
*
* CKOTHR - Intercepts error from AUTON if more than
* two line #s are entered.
*
CKOTHR CH   >B,[email protected]  Error if higher than MOVE
       BS   ERRSY
       CH   >9,[email protected]  Error if lower than COPY
       BR   ERRSY
       CEQ  COMMA,@CHAT  Check separator
       BR   ERRSY        Error if not
       RTN               Return if OK
*
* GETPAR - gets a line # range and a new starting
* # and increment for MOVE & COPY
*
GETPAR DST  @ENLN,@XENLN Load segment pointers
       DST  @STLN,@XSTLN
       DCLR @CURLIN      Set up variables
       DCLR @CURINC
       ST   DASH,@VARC   Separator
       CALL AUTO1        Get segment start, end
       CALL GTRANG       Get line table range
       DCZ  @CURINC      Fix XSTLN if necessary
       BR   GETPA3
       DST  @STLN,@XSTLN
* Now get new starting # and increment
GETPA3 DCLR @CURLIN      Clear start line#
       DINC @VARW        So AUTON don't screw up
       CLR  [email protected]     So AUTON checks EOS correctly
       CALL AUTO4        Get numbers
       DCZ  @CURLIN      Must specify starting line #
       BS   ERRSY        Syntax error if not
* Find out where to move/copy the segment
       DST  @ENLN,@FAC   End of table to FAC
       DSUB 3,@FAC       Adjust
GETPA1 CALL GRSUB3       Get line # from table
       BYTE FAC-PAD
       DCHE @CURLIN,@EEE1 If high, segment gets moved here
       BS   GETPA2       Go move it!
       DSUB 4,@FAC       Next table entry
       DCHE @STLN,@FAC   Make sure we're still in table
       BS   GETPA1       Search some more
       DST  >8000,@EEE1  To satisfy RES routine
       CEQ  @FAC,@FAC    Set COND bit
       RTNC              Return w/COND
GETPA2 RTN               Return
*
* MOVE -Moves a program segment within a program
* If the new starting line is within the segment to
* be moved, then the segment is just renumbered.
*
MOVE   CALL GETPAR       Get the parameters
       BS   MOVE09       Segment goes to end of program
* Check to see if new start line is inside moved segment
       DCH  @XENLN,@FAC  If FAC is higher than segment end
       BS   MOVE03        then continue
       DCH  @FAC,@XSTLN  If FAC is lower than segment start
       BS   MOVE03        then continue
* Segment need not be moved, just RES
       INC  [email protected]     Fake a RES, almost
       CALL RES6         Do the RES
       BR   MOVE99       Return
* If new start line is a valid program line outside of
* segment to be moved, then error!
MOVE03 DCEQ @EEE1,@CURLIN Check for equal #s
       BS   ERRBL        Bad line number error
* New location found.
MOVE09 DST  @FAC,@XCURLI Save FAC
       DADD 3,@XCURLI    Adjust to end of pointer
       DST  @XENLN,@VARA Find out how many bytes to move
       DSUB @XSTLN,@VARA
       DINC @VARA
       CALL MEMFLL       See if there's enough memory
       DADD @VARA,@STLN  Correct STLN
       CALL RES6         RES the segment
       CALL CLSALL       Close all open files
       CALL KILSYM       Kill the symbol tables
* Now redo the line number table
* First make space for moved segment
       DCH  @XCURLI,@STLN If moving to end of prog
       BS   MOVE05         then skip this part
       DST  @XCURLI,@ARG Figure byte count
       DSUB @STLN,@ARG
       DINC @ARG
       DST  @STLN,@VAR9  Source address
       DST  @STLN,@VAR0  Figure destination addr
       DSUB @VARA,@VAR0
       CZ   @RAMTOP      If pgm in VDP
       BR   MOVE04
       MOVE @ARG,V*VAR9,V*VAR0 Move it!
       BR   MOVE05
MOVE04 XML  MVUP         If pgm in ERAM
* Space now available to move the segment
* Figure whether up or down move
MOVE05 DST  @VARA,@ARG   Byte count for next move
       DCH  @XCURLI,@XSTLN
       BS   MOVE06       Moving to a higher line #
* Move from a higher # to a lower #
       DST  @XSTLN,@VAR0
       DDEC @VAR0        Source address
       DST  @XCURLI,@VARY2 Destination address
       XML  MVDN         Move it
       DST  @XSTLN,@ARG  Figure byte count
       DSUB @STLN,@ARG
       DCZ  @ARG         Don't move zero bytes
       BS   MOVE99
       DST  @XSTLN,@VARY2 Figure destination address
       DDEC @VARY2
       DST  @VARY2,@VAR0 Figure source address
       DSUB @VARA,@VAR0
       XML  MVDN         Move again
MOVE99 CALL CLSALL
       B    TOPL10       Return to basic
* Move from a lower # to a higher #
MOVE06 DST  @XSTLN,@VAR9 Source address
       DST  @XCURLI,@VAR0 Figure destination address
       DSUB @VARA,@VAR0
       DINC @VAR0
       CZ   @RAMTOP      If pmg in VDP
       BR   MOVE07
       MOVE @ARG,V*VAR9,V*VAR0 Move it!
       BR   MOVE08
MOVE07 XML  MVUP         If pgm in ERAM
MOVE08 DST  @XENLN,@ARG  Figure byte count
       DSUB @STLN,@ARG
       DINC @ARG
       DST  @XSTLN,@VAR0 Figure source address
       DDEC @VAR0
       DST  @XENLN,@VARY2 Destination address
       XML  MVDN         Move again
       BR   MOVE99       Return
*
* COPY - copies a block of program lines to any
* other location in the program
*
COPY   CALL GETPAR       Get the parameters
       DCEQ @EEE1,@CURLIN Error if trying to copy
       BS   ERRBL         to a valid line.
       DST  4,@XCURLI    Set a variable
       DST  @EEE1,@XCURIN Save EEE1
* Check to see if new start line is inside copied segment
       DCH  @XENLN,@FAC  If FAC is higher than segment end
       BS   COPY03        then continue
       DCH  @FAC,@XSTLN  If FAC is lower than segment start
       BS   COPY04        then continue
       DADD 3,@FAC       One last chance
       DCEQ @FAC,@XENLN  Make sure we're going lower
       BS   COPY03
COPY05 BR   ERRBL        Error if we get here
COPY03 DSUB 4,@XCURLI    New variable
COPY04 DST  @XENLN,@FAC  Compute # of increments required
       DSUB @XSTLN,@FAC  # of table entries
       DSRL 2,@FAC       # of lines
       DST  @FAC,@XENLN  Save count
       DINC @XENLN       Adjust
       DMUL @CURINC,@FAC Compute space taken by increment
       DCZ  @FAC         Check overflow
       BR   ERRBL        Error if > 65536
       DADD @FAC2,@CURLIN Compute highest line #
       CARR              Test carry bit
       BS   ERRBL        Error if > 65536
       CH   >7F,@CURLIN  Error if > 32767
       BS   ERRBL
       DCHE @XCURIN,@CURLIN Error if last line overlaps
       BS   ERRBL
* Do the actual COPY
       DINCT @XSTLN      Point to line location
COPY00 CALL GRSUB2       Get the location
       BYTE XSTLN-PAD
       DST  @EEE1,@FAC   Copy EEE1
       DDEC @FAC         Point to length byte
       CALL GRSUB2       Get the length byte
       BYTE FAC-PAD
       ST   @EEE1,@CHAT  Store the length in CHAT
       ST   @EEE1,@FFF1+1 Also use for count
       CLR  @FFF1        Assure correct count
       DINC @FAC         FAC points to program text
       CZ   @RAMTOP      If zero, then pgm in VDP
       BS   COPY01
* If program in ERAM
       DST  @FAC,@DDD1   Source address
       DST  CRNBUF,@EEE1 Destination address
       XML  GVWITE       Move to VDP
       BR   COPY02
* If program in VDP
COPY01 MOVE @FFF1,V*FAC,[email protected] Move into CRNBUF
*
COPY02 DST  @CURLIN,@FAC Line # to FAC
       CALL EDITLN       Edit the line into program
       CLR  @FAC         Find next line in table
       ST   @CHAT,@FAC1
       DINC @FAC
       DSUB @FAC,@XSTLN
       DADD @XCURLI,@XSTLN
       DSUB @CURINC,@CURLIN Next new line #
*
       DDEC @XENLN       Count -1
       BR   COPY00       Loop if not done
       B    TOPL20       Return
*
* Code to pick up line # range and record
* length for LIST routine
*
GTLIST CLR  @XSTLN       Clear for record length
       CLR  @VARC        Force an error, maybe
       CALL AUTO1        Get a number
* If we get here, only one number has
* been entered so just return
       RTN
*
CKLIST CZ   @VARC        Limit check to LIST
       BR   ERRSY
       CEQ  COLON,@CHAT  Record length
       BR   CKLI01       No
       DDEC @PGMPTR      Back up to last CHAT
       XML  PGMCHR       Get it
       CZ   @CHAT        File specified?
       BS   ERRSY        No, error out
       DCH  >FF,@CURLIN  Number OK?
       BS   ERRBL        No, indicate an error
       ST   @CURLIN+1,@XSTLN Everything OK
       DCLR @CURLIN      Set up to get range
       ST   DASH,@VARC
       B    AUTO3        Get range and return
CKLI01 CEQ  DASH,@CHAT   Better be a dash!
       BR   ERRSY        Nope
       B    AUTO5        Finish up
***********************************************************
CTRLS  CEQ  147,@RKEY         CTRL S
       BR   CTRLD             No, check more
       DST  @VARW,@ARG5       Force cursor to start
*                              ARG5 = current position
       BR   RBACK             Now process like FCTN S
CTRLD  CEQ  132,@RKEY         CTRL D
       BR   CTRLE             No, check more
       DST  @VARA,@ARG5       Force cursor to end
       CALL SPACES            Look for space
       BR   RFORW             Process like FCTN D
CTRLE  CEQ  133,@RKEY         CTRL E
       BR   CTRLX             No, check more
       DSUB 32,@ARG5          Up one line
       DCH  @ARG5,@VARW       Check range
       BR   READZ1            Ok, go on
       DADD 32,@ARG5          No, redo
       BR   READZ1            And continue
CTRLX  CEQ  152,@RKEY         CTRL X
       BR   CTRL              Resume where left off
       DADD 32,@ARG5          Next line
       DCHE @ARG5,@VARA       Check range
       BS   READZ1            Ok, continue
       DSUB 32,@ARG5          No, redo
       BR   READZ1            Now, go on
CTRL   CHE  >20,@RKEY         Control character!!!!
       BS   G6BD0
       BR   G6ADC
SPACES CEQ  >80,V*ARG5        SPACE?
       BR   SPACE2
       DDEC @ARG5
       BR   SPACES
SPACE2 CEQ  >7F,V*ARG5        CURSOR?
       BS   SPACE3
       RTN
SPACE3 DSUB 4,@ARG5
       BR   SPACES
       BR   G6A86
************************************
MYRUN  OR   >10,@>83C2        QUIT KEY
       DST  @YPT,@VARY        Save Row/Col values
       BACK >01
       ALL  >80
       FMT
       SCRO >60
       ROW  0
       COL  8
       HTEX 'FIRMWARE CONTROL'
       ROW  1
       COL  0
       HCHA 32,95
       ROW  4
       COL  6                      *******************
       HCHA 19,42                  * version = 2001  *
       ROW  4                      *******************
       COL  6                      *      R X B      *
       VCHA 8,42                   *                 *
       ROW  4                      *     creator     *
       COL  24                     *                 *
       VCHA 8,42                   * RICH GILBERTSON *
       ROW  5                      *******************
       COL  8
       HTEX 'version = 2011'
       ROW  6
       COL  6
       HCHAR 19,42
       ROW  7
       COL  13
       HTEX 'R X B'
       ROW  9
       COL  12
       HTEX 'creator'
       ROW  11
       COL  8
       HTEX 'RICH GILBERTSON'
       ROW  12
       COL  6
       HCHA 19,42
       FEND
       CEQ  '1',[email protected]
 
       BS   SCNKEY
       CZ   [email protected]
       BS   SCNKEY
       CEQ  >3A,[email protected]
       BS   TOPLEV
       SCAN
       CEQ  >FF,@RKEY
       BR   LDKEY
       ST   [email protected],[email protected]>0824
       BR   SRCHLP
SCNKEY FMT
       SCRO >60
       ROW  13
       COL  0
       HTEX '>> press ============= result <<'
       ROW  15
       COL  2
       HTEX 'ANY KEY    = DSK#.LOAD'
       ROW  17
       COL  2
       HTEX 'ENTER      = DSK#.UTIL1'
       ROW  19
       COL  2
       HTEX '(COMMA) ,  = DSK#.BATCH'
       ROW  21
       COL  2
       HTEX 'SPACE BAR  = RXB COMMAND MODE'
       ROW  23
       COL  2
       HTEX '(PERIOD) . = EDITOR ASSEMBLER'
       FEND
       DCEQ >994A,[email protected]>2254
       BS   XBRUN
       DST  >0800,@FAC+14     DELAY VALUE
RSCAN  DST  >0F12,@YPT
       CALL CBKEY
       BS   RSCAN2
       DDEC @FAC+14
       BS   SRCHLP
       BR   RSCAN
RSCAN2 CEQ  >0D,@RKEY         ENTER?
       BS   UTIL1
       CEQ  >2C,@RKEY         COMMA?
       BS   BATCH
       CEQ  >2E,@RKEY         PERIOD?
       BS   UTIL4
LDKEY  CLR  [email protected]
       ST   @RKEY,[email protected]>0824
SRCHLP MOVE 351,[email protected]>019F,[email protected]>01A0
       DCLR [email protected]>2254           Clear flag
       ST   [email protected]>0824,@RKEY
       FMT
       SCRO >60
       ROW  20
       COL  9
       HTEX 'Searching ....'
       ROW  22
       FEND
       CLR  @VAR0             Row=0
       ST   [email protected]>0820,@FAC      Get string length
       CHE  32,@FAC           Higher 32?
       BS   STLFSC            Yes
       ST   32,@VAR0          Row=32
       SUB  @FAC,@VAR0        32-String length
       SRL  1,@VAR0           Divide by 2
STLFSC ST   @VAR0,@XPT        Load Column
       DST  >0821,@FAC2       String address
DLOOP  ST   V*FAC2,@VAR0      Character
       ADD  >60,@VAR0         Offset
       FMT
       BYTE >E0
       BYTE >00
       FEND
       DINC @FAC2             Address+1
       DEC  @FAC              Count-1
       BR   DLOOP
       DST  @VARY,@YPT        Restore YPT/XPT
       B    SZRUNL
XBRUN  MOVE 50,[email protected]>2256,[email protected]>0820
       CLR  [email protected]
       BR   SRCHLP
***********************************************************
UTIL1  CLR  [email protected]>2256
       FMT
       COL  0
       ROW  15
       HCHA 32,32
       FEND
       CLR  @FAC
       DST  >0800,@FAC+14
       ST   >35,@CHAT
UTIL2  DST  >1112,@YPT
       CALL CBKEY
       BS   UTIL3
       DDEC @FAC+14
       BS   UTIL5
       BR   UTIL2
UTIL3  CEQ  >0D,@RKEY         ENTER?
       BS   UTIL2
       CEQ  >20,@RKEY         SPACE?
       BS   LDKEY
       CEQ  >2C,@RKEY         COMMA?
       BS   BATCH
       CEQ  >2E,@RKEY         PERIOD?
       BS   UTIL6
UTIL4  MOVE 12,[email protected],[email protected]>2256
       ST   @RKEY,[email protected]>225A
UTIL5  B    GE025
UTIL6  CLR  @CHAT
       BR   UTIL5
*********************************
BATCH  MOVE 128,[email protected]>01E0,[email protected]>01E1
       DST  >0800,@FAC+14     LOAD DELAY
       CLR  @FAC
BATCH1 DST  >1312,@YPT        ROW/COL
       CALL CBKEY
       BS   BATCH2
       DDEC @FAC+14
       BS   BATCH3
       BR   BATCH1
BATCH2 CEQ  >0D,@RKEY         ENTER?
       BS   SCNKEY
       CEQ  >20,@RKEY         SPACE?
       BS   SCNKEY
       CEQ  >2C,@RKEY         COMMA?
       BS   BATCH1
       CEQ  >2E,@RKEY         PERIOD?
       BS   SCNKEY
       BR   BATCH4
BATCH3 ST   >31,@RKEY         1 IN RKEY
BATCH4 ST   >20,[email protected]>08C0
       MOVE 80,[email protected]>08C0,[email protected]>08C1
       MOVE 20,[email protected],[email protected]>08C0
       ST   @RKEY,[email protected]>08CD
       CLR  [email protected]
       BR   SZNEW
*********************************
CBKEY  CLOG >01,@FAC+15
       BR   CBKEY2
       EX   @>837D,@FAC
       SCAN
CBKEY2 RTNC
*********************************
* RXB USER
*
DUSER  DCEQ >0900,[email protected]>08C2     PAB there?
       BR   NOUSER            No
       CEQ  >02,[email protected]>08C0       READ code?
       BS   RUSER             READ file
       CALL UDSR              OPEN
       BYTE >00
       BS   USEERR
       ST   [email protected]>08C1,@>8356
       SRL  5,@>8356
       CZ   @>8356
       BR   USEERR
       DST  NLNADD,@VARW      Reset screen address
READLP DCLR [email protected]>0956           Clear counter
       CALL UDSR              READ
       BYTE >02
       BS   CUSER
       ST   [email protected]>08C1,@>8356
       SRL  5,@>8356
       CZ   @>8356
       BR   CUSER
RUSER  DST  [email protected]>0956,@>8376    Get counter
       CEQ  @>8377,[email protected]>08C5    Counter= # bytes
       BS   READLP            yes
       MOVE 1,[email protected]>0900(@>8376),@RKEY
       DINC [email protected]>0956           Counter+1
       BR   USERTN            done
UDSR   MOVE 30,@FAC,[email protected]>03C0   Save FAC
       FETCH @>8356           Get opcode
       ST    @>8356,[email protected]>08C0
       ST    >14,[email protected]>08C1      File type
       DST   >08C9,@>8356
       CALL  LINK
       BYTE  >08
       MOVE  30,[email protected]>03C0,@FAC  Restore FAC
       RTNC
CUSER  CALL UDSR              CLOSE
       BYTE >01
       CALL CLRUSR            Clear USER PAB
NOUSER SCAN
       RAND 99
       RTNC
CLRUSR CLR  [email protected]>08C0
       MOVE 80,[email protected]>08C0,[email protected]>08C1
       RTN
USEERR CALL CLRUSR
       MOVE 14,[email protected],[email protected]>02E2
       XML  SCROLL
       ST   >0D,@RKEY
       CALL TONE2
USERTN CEQ  @VAR0,@VAR0
       RTNC
***********************************************************
CHARS  EQU  >9CEA             * GROM ADDRESS FOR CHAR TABLE
CHRTBL DST  CHARS,@FAC4
       DST  >400,@FAC
CHRLP  DCLR V*FAC
       MOVE 7,[email protected](@FAC4),[email protected](@FAC)
       DADD >0008,@FAC
       DADD >0007,@FAC4
       DEC  @FAC2
       BR   CHRLP
       RTN
***********************************************************
* EDITOR ASSEMBLER
EAU1   STRI 'DSK1.UTIL1'
       BYTE >0D
* USER PAB & BATCH FILE
UBATCH BYTE 0,>14,9,0,80,0,0,0,0
       STRI 'DSK1.BATCH'
* USER ERROR *
ERRUSE BYTE 138,128,181,179,165,178,128
       BYTE 165,178,178,175,178,128,128
***************************************
* RXB SEARCH DISK
MYSRCH CZ   [email protected]
       BR   NXTDSK
       AND  >F7,@FLAG
       B    G63E0
NXTDSK INC  [email protected]
       BR   SZNEW
**************************
* RXB TURN SEARCH OFF
SCHOFF CLR  [email protected]
       B    G6A70
**************************************
* MESSAG    'Bytes of Assembly'
MESSAG DATA >A2D9,>D4C5,>D380,>CFC6
       DATA >80A1,>D3D3,>C5CD,>C2CC
       BYTE >D9
* AMSMSG    'K AMS '
AMSK   DATA >AB80,>A1AD,>B380
 
* AMSMSG    'BANKS of 4K Pages '
AMSP   DATA >A2A1,>AEAB,>B380,>CFC6
       DATA >8094,>AB80,>B0C1,>C7C5
       DATA >D380
***********************************************************
* CART   MOVE 32,[email protected],@>8300 * Put assembly into fast R
       ST   >FF,@FAC           * Byte to load and check for
       XML  >F0                * Execute assembly.
       CZ   @FAC               * Is this a RXB Cartridge?
       BS   SZEXIT             * No, exit to reset.
CART   RTN                     * Yes, continue on.
***********************************************************
*            * CPU PROGRAM FOR >8300 FAST RAM SUBROUTINE FO
CPUPGM DATA >8302 * CPUPGM DATA >8302          * First addr
       DATA >D820 *        MOVB @>834A,@>6FFF  * Turn on ba
       DATA >834A *
       DATA >6FFF *
       DATA >9820 *        CB   @>834A,@>6FFF  * Is it a ca
       DATA >834A *
       DATA >6FFF *
       DATA >1302 *        JEQ  CARTOK         * Yes.
       DATA >04E0 *        CLR  @>834A         * No.
       DATA >834A *
       DATA >D820 * CARTOK MOVB @>834A,@>6000  * Turn on ba
       DATA >834A *
       DATA >6000 *
       DATA >04E0 *        CLR  @>837C         * Clear for
       DATA >837C *
       DATA >045B *        RT                  * Return to
***********************************************************
* AMS SIZE
AMSSIZ DCLR @FAC              * ISR ADDRESS BUFFER
ISROFF EQU  >D0FE
       CALL ISROFF            * >D0FE
AMSON  EQU  >D0FA
       CALL AMSON             * >D0FA
       ST   @>5FFE,@FAC12     * SAVE >F000 mapper
       CEQ  >0F,@FAC12        * Initialized
       BR   NOAMS             * Not Initalized, end SIZE.
       DST  512,@FAC8         * PAGE#
       ST   @>401E,@FAC10     * SAVE PAGE #
NXTPG  DST  @>FFFE,@>8300     * Save bytes
       ST   @FAC10,@>401E     * Pass mode page
       DST  >AAAA,@>FFFE      * Test bytes
       DCEQ >AAAA,@>FFFE      * Test for bytes
       BR   NOAMS             * No memory
       DST  @>8300,@>FFFE     * Restore bytes
       DSRL 1,@FAC8           * PAGE # * 2
       DCEQ 32,@FAC8          * Largest page #
       BS   SHOWIT            * Just show it
       DEC  @FAC9             * PAGE # -1
       ST   @FAC9,@>401E      * >F000 mapper
       INC  @FAC9             * PAGE # +1
       DST  @>FFFE,@>8300     * Save bytes
       DST  >9999,@>FFFE      * Test bytes
       DCEQ >9999,@>FFFE      * Test for bytes
       BR   NXTPG             * Continue loop
SHOWIT DST  >8300,@>FFFE      * Restore bytes
       ST   @FAC10,@>401E     * Restore PAGE
NOAMS  DCZ  @FAC              * ISR?
       BS   NOISR             * No
ISRON  EQU  >D0FC
       CALL ISRON             * >D0FC
AMSOFF EQU  >D0F8
NOISR  CALL AMSOFF            * >D0F8
       CEQ  >0F,@FAC12
       BR   NOAMS2
       DSLL 2,@FAC8           * PAGES * 2 = K
       DST  @FAC8,@ARG2       * SHOW K
       CALL SDISO
       MOVE 6,[email protected],[email protected](@VARW)
       XML  SCROLL
       DSRL 2,@FAC8           * PAGE /4
       SUB  17,@FAC9          * PAGES-OS
       DST  @FAC8,@ARG2       * SHOW PAGES
       CALL SDISO
       MOVE 18,[email protected],[email protected](@VARW)
NOAMS2 BR   G6621
***********************************************************
       END
 

Spoiler

***********************************************************
       TITL 'MYXB4'
       GROM >8000
***********************************************************
       TITL 'EQUATES FLMGR-359'
***********************************************************
CPUBAS EQU  >A040             Expansion RAM base
***********************************************************
*           GROM ADDRESSES
MZMSG  EQU  >6038             Start of message area
***********************************************************
GTLIST EQU  >7A06             GKXB address
KEYTAB EQU  >CB00
ERRTAB EQU  >CD77
TRACBK EQU  >CE1F
RETNOS EQU  >CF68
EDTZZ0 EQU  >76EB             Edit a line or display it tab
EDTZ00 EQU  >76F7             Edit a line or display it
SAVLIN EQU  >7795             Save input line address
***********************************************************
*    EQUATES FOR ROUTINES FROM OTHER GROM SECTIONS
 
TOPL15 EQU  >6012             RETURN FROM OLD  or SAVE
INITPG EQU  >6014             Initialize program space
TOPL10 EQU  >601A             Return to main and re-init
KILSYM EQU  >6022             KILL SYMBOL TABLE ROUTINE
AUTO1  EQU  >602E             Get arguments for LIST comman
TOPL02 EQU  >6030             RTN address for failing AUTOL
EDITLN EQU  >6032             Edit a line into the program
GWSUB  EQU  >6036             Write a few bytes of data to
MSGTA  EQU  >6053             Message "try again"
LLIST  EQU  >6A74             List a line
READLN EQU  >6A76             Read a line from keyboard
WARNZZ EQU  >6A82             WARNING MESSAGE ROUTINE
ERRZZ  EQU  >6A84             ERROR MESSAGE ROUTINE
ERRZ   EQU  >6A84             ERRor routine
READL1 EQU  >6A86             Read a line from keyboard
LITS05 EQU  >A002             Literal string common code
EXEC   EQU  >A004
LINE   EQU  >A006             GET LINE NUMBER ROUTINE
DATAST EQU  >A008             SEARCH FOR NEXT "DATA" STATEM
ASC    EQU  >A00A
EXEC1  EQU  >A00C             EXECute a program statememt
EXEC6D EQU  >A00E
DELINK EQU  >A010
CONVER EQU  >A012             CONVERT WITH WARNING
SQUISH EQU  >A014
VALCD  EQU  >A016             CONVERT STRING TO NUMBER
INTRND EQU  >A018             Initilize random number
UBSUB  EQU  >A020             CLEAR BREAKPOINTS IN LN # TAB
LINK1  EQU  >A026             LINK to subprogram
ATNZZ  EQU  >0022             Arctangent routine
***********************************************************
*    Equates for routine in MONITOR
CALDSR EQU  >10               CALL DEVICE SERVICE ROUTINE
CFI    EQU  >12               CONVERT TO TWO BYTE INTEGER
TONE1  EQU  >34               ACCEPT TONE
TONE2  EQU  >36               BAD TONE
CHAR2Z EQU  >18               CHARACTER TABLE ADDRESS
CHAR3Z EQU  >4A               CHARACTER TABLE ADDRESS
***********************************************************
*    Equates for XMLs
SYNCHK EQU  >00               SYNCHK XML selector
FILSPC EQU  >01               Fill-space utility
CSTRIN EQU  >02               Copy-string utility
SEETWO EQU  >03               SEETWO XML selector
COMPCT EQU  >70               PREFORM A GARBAGE COLLECTION
GETSTR EQU  >71               SYSTEM GET STRING
MEMCHK EQU  >72               MEMORY check routine: VDP
CNS    EQU  >73               Convert number to string
* Warning Default changed in >0073
PARSE  EQU  >74               Parse a value
CONT   EQU  >75               Continue parsing
VPUSH  EQU  >77               Push on value stack
VPOP   EQU  >78               Pop off value stack
PGMCHR EQU  >79               GET PROGRAM CHARACTER
SYM    EQU  >7A               Find SYMBOL entry
SMB    EQU  >7B               Also for ARRAYS
ASSGNV EQU  >7C               Assign VARIABLE
SCHSYM EQU  >7D               Search symbol table
SPEED  EQU  >7E               SPEED UP XML
CRUNCH EQU  >7F               Crunch an input line
CIF    EQU  >80               Convert INTEGER to FLOATING P
CONTIN EQU  >81               Continue after a break
SCROLL EQU  >83               SCROLL THE SCREEN
IO     EQU  >84               IO utility (KW table search)
GREAD  EQU  >85               READ DATA FROM ERAM
GWRITE EQU  >86               WRITE DATA TO ERAM
DELREP EQU  >87               REMOVE CONTENT FROM VDP/ERAM
MVDN   EQU  >88               MOVE DATA IN VDP/ERAM
MVUP   EQU  >89               MOVE DATA IN VDP/ERAM
VGWITE EQU  >8A               MOVE DATA FROM VDP TO ERAM
GVWITE EQU  >8B               WRITE DATA FROM GRAM TO VRAM
GREAD1 EQU  >8C               READ DATA FROM ERAM
GDTECT EQU  >8E               ERAM DETECT&ROM PAGE 1 ENABLE
SCNSMT EQU  >8F               SCAN STATEMENT FOR PRESCAN
***********************************************************
*    Temporary workspaces in EDIT
VAR0   EQU  >8300            TEMPORARY
VARV   EQU  >8301            TEMPORARY
ACCUM  EQU  >8302            # OF BYTES ACCUMULATOR (4 BYTE
STPT   EQU  >8302            TWO BYTES
MNUM   EQU  >8302            Ussually a counter
AAA1   EQU  >8302
VARY   EQU  >8304
PABPTR EQU  >8304            Pointer to current PAB
VARY2  EQU  >8306            Use in MVDN only
DFLTLM EQU  >8306            Default array limit (10)
CCPPTR EQU  >8306            OFFSET WITHIN RECORED (1)
*                             or Pointer to current column
RECLEN EQU  >8307            LENGTH OF CURRENT RECORD (1)
CCPADR EQU  >8308            RAM address of current refs
*                             or Actual buffer address or c
VARC   EQU  >8308
CCPADD EQU  >8308            RAM address of current color
CCC1   EQU  >8308
CALIST EQU  >830A            Call list for resolving refs
RAMPTR EQU  >830A            Pointer for crunching
STADDR EQU  >830A            Start address - usually for co
BYTES  EQU  >830C            BYTE COUNTER
*                             or String length for GETSTR
NMPTR  EQU  >830C            Pointer save for pscan
BBB1   EQU  >830C
CHSAV  EQU  >830E
CURINC EQU  >830E            Increment for auto-num mode
VAR4   EQU  >830E
TOPSTK EQU  >8310            Top of data stack pointer
VAR5   EQU  >8310
VAR6   EQU  >8311
LINUM  EQU  >8312            Used to determine end of scan
NMLEN  EQU  >8314            Current line for auto-num
CURLIN EQU  >8314            Current line for auto-num
*                             or Starting line number for L
VAR9   EQU  >8316
XFLAG  EQU  >8316            SCAN FLAG-BITS USED AS BELOW
DSRFLG EQU  >8317            INTERNAL =60, EXTERNAL =0 (1)
OPTFLG EQU  >8317            Option flag byte during OPEN
FORNET EQU  >8317            Nesting level of for/next
FNUM   EQU  >8317            Current file number for search
***********************************************************
*    Permanent workspace variables
STRSP  EQU  >8318            String space begining
STREND EQU  >831A            String space ending
SREF   EQU  >831C            Temporary string pointer
SMTSRT EQU  >831E            Start of current statement
VARW   EQU  >8320            Screen address (CURSOR)
ERRCOD EQU  >8322            Return error code from ALC
STVSPT EQU  >8324            Value-stack base
RTNG   EQU  >8326            Return vector from 9900 code
NUDTAB EQU  >8328            Start of NUD table
VARA   EQU  >832A            Ending display location
PGMPTR EQU  >832C            Program text pointer (TOKEN)
EXTRAM EQU  >832E            Line number table pointer
STLN   EQU  >8330            Start of line number table
ENLN   EQU  >8332            End of line number table
DATA   EQU  >8334            Data pointer for READ
LNBUF  EQU  >8336            Line table pointer for READ
INTRIN EQU  >8338            Add of intrinsic poly constant
SUBTAB EQU  >833A            Subprogram symbol table
IOSTRT EQU  >833C            PAB list/Start of I/O chain
SYMTAB EQU  >833E            Symbol table pointer
FREPTR EQU  >8340            Free space pointer
CHAT   EQU  >8342            Current charater/token
BASE   EQU  >8343            OPTION BASE value
PRGFLG EQU  >8344            Program/imperative flag
FLAG   EQU  >8345            General 8-bit flag
BUFLEV EQU  >8346            Crunch-buffer destruction leve
LSUBP  EQU  >8348            Last subprogram block on stack
* FAC  EQU  >834A            Floating-point ACcurmulator
FAC1   EQU  FAC+1
FAC2   EQU  FAC+2
AAA    EQU  FAC+2
FAC3   EQU  FAC+3
FAC4   EQU  FAC+4
CCC    EQU  FAC+4
FFF    EQU  FAC+4
FAC5   EQU  FAC+5
FAC6   EQU  FAC+6
BBB    EQU  FAC+6
EEE    EQU  FAC+6
FAC7   EQU  FAC+7
FAC8   EQU  FAC+8
FAC9   EQU  FAC+9
FAC10  EQU  FAC+10
DDD1   EQU  FAC+10
FAC11  EQU  FAC+11
FAC12  EQU  FAC+12
FFF1   EQU  FAC+12
FAC13  EQU  FAC+13
FAC14  EQU  FAC+14
EEE1   EQU  FAC+14
FAC15  EQU  FAC+15
FAC16  EQU  FAC+16
FAC17  EQU  FAC+17
* ARG  EQU  >835C             Floating-point ARGument
ARG1   EQU  ARG+1
ARG2   EQU  ARG+2
ARG3   EQU  ARG+3
ARG4   EQU  ARG+4
ARG5   EQU  ARG+5
ARG6   EQU  ARG+6
ARG7   EQU  ARG+7
ARG8   EQU  ARG+8
XSTLN  EQU  >8364            GKXB variable
TEMP5  EQU  >8366
ARG11  EQU  ARG+11
ARG15  EQU  ARG+15
ARG16  EQU  ARG+16
* VSPTR  EQU  >836E          Value stack pointer
***********************************************************
*    GPL Status Block
STACK  EQU  >8372             STACK FOR DATA
KEYBD  EQU  >8374             KEYBOARD SELCTION
RKEY   EQU  >8375             KEY CODE
EXPZ   EQU  >8376             Exponent in floating-point
RANDOM EQU  >8378             RANDOM NUMBER GENERATOR
TIMER  EQU  >8379             TIMING REGISTER
MOTION EQU  >837A             NUMBER OF MOVING SPRITES
VDPSTS EQU  >837B             VDP STATUS REGISTER
ERCODE EQU  >837C             STATUS REGISTER
***********************************************************
RAMTOP EQU  >8384            Highest address in ERAM
RAMFRE EQU  >8386            Free pointer in the ERAM
RSTK   EQU  >8388            Subroutine stack base
*                             (Starts at >8A)
RAMFLG EQU  >8389            ERAM flag
STKMIN EQU  >83AF            Base of data stack
STKMAX EQU  >83BD            Top of data stack
PRTNFN EQU  >83CE            Sound - previous tone finished
***********************************************************
*    VDP addresses
SCRNBS EQU  >02E0             Screen base addr for last lin
NLNADD EQU  >02E2             New LiNe ADDress
ENDSCR EQU  >02FE             END of SCReen address
LODFLG EQU  >0371             Auto-boot needed flag
START  EQU  >0372             Line to start execution at
* Temporary
NOTONE EQU  >0374             NO-TONE for SIZE in ACCEPT us
*                              in FLMGRS (4 bytes used)
SYMBOL EQU  >0376             Saved symbol table pointer
SPGMPT EQU  >0382             Saved PGMPTR for continue
SBUFLV EQU  >0384             Saved BUFLEV for contiue
SEXTRM EQU  >0386             Saved EXTRAM for continue
SAVEVP EQU  >0388             Saved VSPRT for continue
ERRLN  EQU  >038A             On-error line pointer
BUFSRT EQU  >038C             Edit recall start addr (VARW)
BUFEND EQU  >038E             Edit recall end addr (VARA)
CSNTMP EQU  >0390             Use as temporary stored place
*                          or CSN TEMPORARY FOR FAC12
TABSAV EQU  >0392             Saved main symbol table ponte
AUTTMP EQU  >0394             AUTOLD TEMPORARY IN SIDE ERRZ
SLSUBP EQU  >0396             Saved LSUBP for continue
SFLAG  EQU  >0398             Saved on-warning/break bits
SSTEMP EQU  >039A             To save subprogram program ta
SSTMP2 EQU  >039C             Same as above. Used in SUBPRO
MRGPAB EQU  >039E             MERGEd temporary for pab ptr
INPUTP EQU  >03AA             INPUT TEMPORARY FOR PTR TO PR
ACCVRW EQU  >03AC             Temoporary used in ERRZZ, als
*                              used in FLMGRS
*                             or temporary for @VARW, @VARA
ACCVRA EQU  >03AE             TRY AGAIN
VALIDP EQU  >03B0             Use as two values passing fro
*                          or PTR TO STANDARD STRING IN VAL
VALIDL EQU  >03B2             VALIDATE code to READL1
*                          or Length of string in validate
SIZCCP EQU  >03B4             SIZE TEMPORARY FOR CCPADR
SIZREC EQU  >03B6             SIZE TEMPORARY FOR RECLEN
*                            Also used as temporary in RELO
*----------------------------------------------------------
* Added 6/8/81 for NOPSCAN feature
PSCFG  EQU  >03B7
*----------------------------------------------------------
ACCTRY EQU  >03B7             ACCEPT "TRY AGAIN" FLAG
SIZXPT EQU  >03B8             Save XPT in SIZE when "try ag
SAPROT EQU  >03B9             PROTECTION flag in SAVE
CSNTP1 EQU  >03BA             CSN TEMPORARY FOR FAC10
*----------------------------------------------------------
*    Flag 0:  99/4  console, 5/29/81
*         1:  99/4A console
CONFLG EQU  >03BB
*----------------------------------------------------------
OLDTOP EQU  >03BC             Temporary used in ERRZZ, also
*                          or Old top of memory for RELOCA
CPTEMP EQU  >03BC             CCPPTR, RECLEN temp in INPUT
NEWTOP EQU  >03BE             New top of memory for RELOCA
CRNBUF EQU  >0820             CRuNch BUFfer address
CRNEND EQU  >08BE             CRuNch buffer END
RECBUF EQU  >08C0             Edit RECall BUFfer
VRAMVS EQU  >0958             Default base of value stack
***********************************************************
*    IMMEDITATE VALUES
NUMBR  EQU  >00               NUMERIC validate
LISTZ  EQU  >02
OLDZ   EQU  >05
RESEQZ EQU  >06
SAVEZ  EQU  >07
MERGEZ EQU  >08
DWNARR EQU  >0A
UPARR  EQU  >0B
CHRTN  EQU  >0D
BKGD   EQU  >20               BACKGROUND CHARACTER
OFFSET EQU  >60               OFFSET FOR VIDEO TABLES
STRVAL EQU  >65               Value in accum. is string val
***********************************************************
* Editting command equates
BREAK  EQU  >02               Break key
DLETE  EQU  >03               Delete key
INSRT  EQU  >04               Insert key
RECALL EQU  >06               Edit-buffer recall
CLRLN  EQU  >07               Clear-line key
BACK   EQU  >08               Back-space key
FORW   EQU  >09               Forward-space key
DOWN   EQU  >0A               Down-arrow key
UPMV   EQU  >0B               Up-arrow key
VWIDTH EQU  >1C               Screen width (PRINT)
SPACE  EQU  >20               Space key
QUOTE  EQU  >22               "
DOLLAR EQU  >24               $
CURSOR EQU  >1E+OFFSET        CURSOR
EDGECH EQU  >1F+OFFSET        EDGE character
COMMA  EQU  >2C               ,
MINUS  EQU  >2D               -
***********************************************************
* PAB offset
CZOPEN EQU  0                 OPEN CODE
CZCLOS EQU  1                 CLOSE CODE
FIL    EQU  2                 File number within BASIC(0-25
CZREAD EQU  2                 READ CODE
OFS    EQU  3                 Offset within record
CZWRIT EQU  3                 WRITE CODE
COD    EQU  4                 I/O code
CZREST EQU  4                 RESTORE/REWIND CODE
FLG    EQU  5                 I/O mode flag byte
CZLOAD EQU  5                 LOAD CODE
BUF    EQU  6                 Start of data buffer
CZSAVE EQU  6                 SAVE CODE
CZDELE EQU  7                 DELETE CODE
LEN    EQU  8                 Record length
CZSCR  EQU  8                 SCRATCH CODE
CNT    EQU  9                 Character count
CZSTAT EQU  9                 STATUS CODE
RNM    EQU  10                Record number
SCR    EQU  12                Screen base offset
NLEN   EQU  13                Length of file descriptor
PABLEN EQU  14                PAB LENGTH
***********************************************************
*    BASIC TOKEN TABLE
*      EQU  >80               spare token
ELSEZ  EQU  >81               ELSE
SSEPZ  EQU  >82               ::
TREMZ  EQU  >83               $
IFZ    EQU  >84               IF
GOZ    EQU  >85               GO
GOTOZ  EQU  >86               GOTO
GOSUBZ EQU  >87               GOSUB
RETURZ EQU  >88               RETURN
DEFZ   EQU  >89               DEF
DIMZ   EQU  >8A               DIM
ENDZ   EQU  >8B               END
FORZ   EQU  >8C               FOR
LETZ   EQU  >8D               LET
BREAKZ EQU  >8E               BREAK
UNBREZ EQU  >8F               UNBREAK
TRACEZ EQU  >90               TRACE
UNTRAZ EQU  >91               UNTRACE
INPUTZ EQU  >92               INPUT
DATAZ  EQU  >93               DATA
RESTOZ EQU  >94               RESTORE
RANDOZ EQU  >95               RANDOMIZE
NEXTZ  EQU  >96               NEXT
READZ  EQU  >97               READ
STOPZ  EQU  >98               STOP
DELETZ EQU  >99               DELETE
REMZ   EQU  >9A               REM
ONZ    EQU  >9B               ON
PRINTZ EQU  >9C               PRINT
CALLZ  EQU  >9D               CALL
OPTIOZ EQU  >9E               OPTION
OPENZ  EQU  >9F               OPEN
CLOSEZ EQU  >A0               CLOSE
SUBZ   EQU  >A1               SUB
DISPLZ EQU  >A2               DISPLAY
IMAGEZ EQU  >A3               IMAGE
ACCEPZ EQU  >A4               ACCEPT
ERRORZ EQU  >A5               ERROR
WARNZ  EQU  >A6               WARNING
SUBXTZ EQU  >A7               SUBEXIT
SUBNDZ EQU  >A8               SUBEND
RUNZ   EQU  >A9               RUN
LINPUZ EQU  >AA               LINPUT
*      EQU  >AB               spare token (LIBRARY)
*      EQU  >AC               spare token (REAL)
*      EQU  >AD               spare token (INTEGER)
*      EQU  >AE               spare token (SCRATCH)
*      EQU  >AF               spare token
THENZ  EQU  >B0               THEN
TOZ    EQU  >B1               TO
STEPZ  EQU  >B2               STEP
COMMAZ EQU  >B3               ,
SEMICZ EQU  >B4               ;
COLONZ EQU  >B5               :
RPARZ  EQU  >B6               )
LPARZ  EQU  >B7               (
CONCZ  EQU  >B8               &          (CONCATENATE)
*      EQU  >B9               spare token
ORZ    EQU  >BA               OR
ANDZ   EQU  >BB               AND
XORZ   EQU  >BC               XOR
NOTZ   EQU  >BD               NOT
EQUALZ EQU  >BE               =
LESSZ  EQU  >BF               <
GREATZ EQU  >C0               >
PLUSZ  EQU  >C1               +
MINUSZ EQU  >C2               -
MULTZ  EQU  >C3               *
DIVIZ  EQU  >C4               /
CIRCUZ EQU  >C5               ^
*      EQU  >C6               spare token
STRINZ EQU  >C7               QUOTED STRING
UNQSTZ EQU  >C8               UNQUOTED STRING
NUMZ   EQU  >C8               ALSO NUMERICAL STRING
NUMCOZ EQU  >C8               ALSO UNQUOTED STRING
LNZ    EQU  >C9               LINE NUMBER CONSTANT
*      EQU  >CA               spare token
ABSZ   EQU  >CB               ABS
ATNZ   EQU  >CC               ATN
COSZ   EQU  >CD               COS
EXPZZ  EQU  >CE               EXP
INTZ   EQU  >CF               INT
LOGZ   EQU  >D0               LOG
SGNZZ  EQU  >D1               SGN
SINZ   EQU  >D2               SIN
SQRZ   EQU  >D3               SQR
TANZ   EQU  >D4               TAN
LENZ   EQU  >D5               LEN
CHRZZ  EQU  >D6               CHR$
RNDZ   EQU  >D7               RND
SEGZZ  EQU  >D8               SEG$
POSZ   EQU  >D9               POS
VAL    EQU  >DA               VAL
STRZZ  EQU  >DB               STR$
ASCZ   EQU  >DC               ASC
PIZ    EQU  >DD               PI
RECZ   EQU  >DE               REC
MAXZ   EQU  >DF               MAX
MINZ   EQU  >E0               MIN
RPTZZ  EQU  >E1               RPT$
*      EQU  >E2               unused
*      EQU  >E2               unused
*      EQU  >E3               unused
*      EQU  >E4               unused
*      EQU  >E5               unused
*      EQU  >E6               unused
*      EQU  >E7               unused
NUMERZ EQU  >E8               NUMERIC
DIGITZ EQU  >E9               DIGIT
UALPHZ EQU  >EA               UALPHA
SIZEZ  EQU  >EB               SIZE
ALLZ   EQU  >EC               ALL
USINGZ EQU  >ED               USING
BEEPZ  EQU  >EE               BEEP
ERASEZ EQU  >EF               ERASE
ATZ    EQU  >F0               AT
BASEZ  EQU  >F1               BASE
*      EQU  >F2               spare token (TEMPORARY)
VARIAZ EQU  >F3               VARIABLE
RELATZ EQU  >F4               RELATIVE
INTERZ EQU  >F5               INTERNAL
SEQUEZ EQU  >F6               SEQUENTIAL
OUTPUZ EQU  >F7               OUTPUT
UPDATZ EQU  >F8               UPDATE
APPENZ EQU  >F9               APPEND
FIXEDZ EQU  >FA               FIXED
PERMAZ EQU  >FB               PERMANENT
TABZ   EQU  >FC               TAB
NUMBEZ EQU  >FD               #
VALIDZ EQU  >FE               VALIDATE
*      EQU  >FF               ILLEGAL VALUE
***********************************************************
       TITL 'FLMGR-359'
***********************************************************
*                        GROM HEADER
***********************************************************
*    Branch table routines
***********************************************************
       BR   DISPL1            DISPLAY routine
       BR   DELET             DELETE routine
       BR   PRINT             PRINT routine
       BR   INPUT             INPUT routine (not yet impele
       BR   OPEN              OPEN routine
       BR   CLOSE             CLOSE routine
       BR   RESTOR            RESTORE routine
       BR   READ              READ routine
       BR   GETDAT            Get DATA from ERAM/VDP (not u
       BR   CLSALL            CLOSE ALL OPEN FILES subrouti
       BR   SAVE              SAVE routine
       BR   OLD               LOAD routine
       BR   LIST              LIST routine
       BR   OUTREC            Output record routine
       BR   EOF               End of file routine
       BR   ACCEPT            ACCEPT routine
       BR   SRDATA            Search "DATAZ" routine
       BR   SUBREC            RECORD routine
       BR   CHKEND            Check EOS
       BR   OLD1              A subroutine for LOAD
       BR   MERGE             MERGE a program
       BR   GRMLST            List a line out of ERAM
       BR   GRSUB2            Read 2 bytes of data from ERA
       BR   GRSUB3            Read 2 bytes of data from ERA
*                             with resetting possible break
       BR   LINPUT              LINPUT statement
***********************************************************
*               OPEN STATEMENT HANDLER
* Handle the BASIC OPNE statement. A legal syntax can only
* be something like
*      OPEN #{exp}:{string-exp}[,{open-options}]
* in which {open-option} is any of the following
* DISPLAY, INPUT, VARIABLE, RELATIVE, INTERNAL, SEQUENTIAL,
* OUTPUT, UPDATE, APPEND, FIXED or PERMANENT
*
* Each keyword can only be used once, which is being checke
* with an OPTFLG-bit. For each specific option please refer
* to the related routine.
* Scanning stops as soon as no next field starting with a
* comma can be found.
* NOTE: After the actual DSR OPEN has been preformed, the
*       length of the record, whether VARIABLE or FIXED,
*       has to be non-zero. A zero length will cause an
*       INCORRECT STATEMENT error.
***********************************************************
OPEN   CALL CHKFN             See if we specified any file
       BS   ERRFE             Definitely not... no # or #0
       CALL CHKCON            Check and search given filenu
       BS   ERRFE             *** FILE NUMBER EXISTS ***
* ERROR IF NOT STOPPED ON COLON
       XML  SPEED             Must be at a
       BYTE SYNCHK          *  colon or else
       BYTE COLONZ          *   its an error
       CALL PARFN             Parse filename and create PAB
       DDEC @PGMPTR           Backup pgm pointer for next t
OPTION XML  PGMCHR            Get next program character
* Next field should start with a comma
OPTIZ0 CEQ  COMMAZ,@CHAT
       BR   CHECK
* Enter HERE after comma exit in "SEQUENTIAL"
OPTIZ1 XML  PGMCHR            Next token please...
* Treat DISPLAY and INPUT as special cases
       CEQ  DISPLZ,@CHAT
       BS   OPTZ6
       CEQ  INPUTZ,@CHAT
       BS   OPTZ7
       SUB  VARIAZ,@CHAT      Reduce keyword offset to 0
       CHE  9,@CHAT           Keyword to high
       BS   OPERR
       CASE @CHAT             JUST IN CASE
       BR   OPTZ01            Option VARIABLE
       BR   OPTZ02                   RELATIVE
       BR   OPTZ03                   INTERNAL
       BR   OPTZ1                    SEQUENTIAL
       BR   OPTZ2                    OUTPUT
       BR   OPTZ3                    UPDATE
       BR   OPTZ4                    APPEND
       BR   OPTZ5                    FIXED
*      BR   OPTZ0                    PERMANENT       <<<<<<
* CASE 0 - "PERMANENT" ************************************
*  Only check for multiple usage. Since PERMANENT is the
*  default, we might as well ignore it...
OPTZ0  CLOG >04,@OPTFLG
       BR   OPERR
       OR   >04,@OPTFLG       Not used ... use now
       BR   OPTION            Treat as simple default
* CASE 2 - "RELATIVE" *************************************
*  Select relative record file in PAB and fall through in
*  SEQUENTIAL code for multiple usage check. Also handle
*  initial file-size there.
OPTZ02 OR   >01,[email protected](@PABPTR) Indicate RELATIVE RECORD
* CASE 4 - "SEQUENTIAL" ***********************************
*  Checks for multiple usage. Remainder of syntax demads th
*  we have something like:
*                         [{numeric expression}],...
*  In case only a comma is found, we use the default.
*  Everything else has to be evaluated as a numeric
*  expression, convertable to a 16-bit integer value.
OPTZ1  CLOG >08,@OPTFLG
       BR   OPERR
       OR   >08,@OPTFLG       First time usage, ok
       XML  PGMCHR            Check next token for default
* Comma means default has been used
       CEQ  COMMAZ,@CHAT
       BS   OPTIZ1
       CALL CHKEND            Check for end of statement
       BS   CHECK
       CALL CHKPAR            Preform combined checking & p
       DST  @FAC,[email protected](@PABPTR) Non-zero result
       BR   OPTIZ0            Scan other options
* Parse and check a numeric argument in here....
CHKPAR XML  PARSE             If not ... parse up to comma
       BYTE COMMAZ
       CALL CHKCNV            Check and convert to integer
       BS   OPERR             Oops..., someone made a mista
       RTN                    Return to caller
* CASE 5 - "OUTPUT" ***************************************
*  Select mode code "01" and check for multiple usage. Use
*  MFLAG bit in OPTFLG for checking.
OPTZ2  OR   >02,[email protected](@PABPTR)  Mode code = 01
* CASE 6 - "UPDATE" ***************************************
*  Default ... Check for multiple usage only...
*  Test for previous usage of any mode setting
OPTZ3  CLOG >01,@OPTFLG
       BR   OPERR
       OR   >01,@OPTFLG       If not... set "MODE USED" bit
       BR   OPTION            Continue option scan
* CASE 7 - "APPEND" ***************************************
*  Mode code "11" indicates APPEND mode.
OPTZ4  OR   >06,[email protected](@PABPTR)  Mode code = 11
       BR   OPTZ3
* CASE 1 - "VARIABLE" *************************************
*  Change record type to VARIABLE and continue as FIXED
OPTZ01 OR   >10,[email protected](@PABPTR)  Indicate variable length mo
 
* CASE 8 - "FIXED" ****************************************
*  Fixed is default. Don't change anything, unless argument
*  is given. In this case evaluate as numeric expression an
*  check for 8-bit integer range...
*  This routine is also used for VARIABLE !!!!!
OPTZ5  XML  PGMCHR            Get next character
       CEQ  COMMAZ,@CHAT      Could be some argument
       BS   OPTZ55
       CALL CHKEND            Could also be end of statemen
       BS   OPTZ55            It is an EOS
       CALL CHKPAR            Check & parse expression
* Check for byte overflow (records can only be up to 255
* bytes in length)
       CZ   @FAC
       BR   OPERR
       ST   @FAC1,[email protected](@PABPTR) Select non-zero rec-size
OPTZ55 CLOG >10,@OPTFLG
       BR   OPERR
       OR   >10,@OPTFLG       Prevent to much usage of mode
       BR   OPTIZ0             Continue option scan
* CASE 3 - "INTERNAL" *************************************
*  Select INTERANL file type and continue in DIPLAY
OPTZ03 OR   8,[email protected](@PABPTR)  Select INTERNAL type
* CASE 9 - "DISPLAY" **************************************
*  Default. Only check for multiple usage of either DISPLAY
*  or INTERNAL...
OPTZ6  CLOG >02,@OPTFLG
       BR   OPERR
       OR   >02,@OPTFLG       Else set "DISPLAY/INTERAL" fl
       BR   OPTION            Continue... DISPLAY is defaul
* CASE 10 "INPUT" *****************************************
*  Same as any other I/O type definition. Mode code "10" ..
*  Continue in OPTZ3
OPTZ7  OR   >04,[email protected](@PABPTR) Mode code = 10
       BR   OPTZ3
* CLRFRE deallocates previously alocated (parts of) PAB's a
* return with an error message
CLRFRE CLR  @MNUM             Undo any allocation
       ST   [email protected](@PABPTR),@MNUM+1  We need the length for
*                                    that
*      [email protected](@PABPTR) Was set up in PARFN routine
       DADD @MNUM,@FREPTR     Update the first free world
       RTN                    And return
OPERR  CALL CLRFRE            First undo the allocation
ERRSYN CALL ERRZZ             Then give an error
       BYTE 3                 * SYNTAX ERROR
* Continue with CHECK to conplete the actual OPEN
CHECK  CALL CHKEND            Check EOS
       BR   OPERR             Not EOS  : SYNTAX ERROR
* If the user hasn't specified VARIABLE or FIXED, the
* default specification depends on the file type.
* Change current default (=VARIABLE) to FIXED for
* RELATIVE files.
       CLOG >01,[email protected](@PABPTR) RELATIVE RECORD
       BS   G8127
       CLOG >10,[email protected](@PABPTR) VARIABLE RECORD
       BS   G8125
FILZZ  CALL CLRFRE            Undo the PAB allocation
       BR   ERRFE             FILE ERROR
G8125  BR   G8131             Sequential file, check rec. m
G8127  CLOG >10,@OPTFLG       No definition yet
       BR   G8131
       OR   >10,[email protected](@PABPTR) Force VARIABLE mode
G8131  CALL CDSR              Call the DSR, return with err
       BR   ERRZ2B             indication in COND...
       DCLR [email protected](@PABPTR)    Make sure we start with recor
* Check for undefined record length. The record length for
* any type might be defined by the DSR
       CZ   [email protected](@PABPTR)
       BS   FILZZ
       ST   [email protected](@PABPTR),@MNUM+1 Get record length
       CLR  @MNUM             Create two byte result and
       CLR  [email protected](@PABPTR)     allocate - remove offset for
*                              later use
       DST  @MNUM,@FAC        - prepare for space claim
* Check for special case : no PAB's yet
       DCZ  @IOSTRT
       BR   G8157
       DST  @PABPTR,@IOSTRT   Simply enter the first pointe
       BR   G8169
G8157  DST  @IOSTRT,@STADDR   Search for the end of the cha
G815A  DCZ  V*STADDR
       BS   G8165
       DST  V*STADDR,@STADDR  Keep on deferring
       BR   G815A
G8165  DST  @PABPTR,V*STADDR  Update last chain link
G8169  DST  @PABPTR,[email protected](@PABPTR) Set empty buffer first
       XML  MEMCHK            Check memory overflow & strin
       BS   ERRMEM            * MEMORY FULL
       DSUB @MNUM,@FREPTR     Compute buffer entry address
       DSUB @MNUM,[email protected](@PABPTR) Correct buffer address in
       XML  CONT              Return to the parser
***********************************************************
*                    DELETE ROUTINE
* Use file # 0 for this operation. Parse the file name
* string-expression as usual, and delete the PAB before
* actually calling the DSR.
***********************************************************
DELET  CLR  @FNUM             Create file #0 - non-existing
       CALL PARFN             Handle as normal PAB OPEN
       CALL CHKEND            Check EOS first
       BR   OPERR             Not EOS : go undo PAB allocat
*                              and print SYNTAX ERROR
       CLR  @MNUM       *  Delete PAB again before calling
       ST   [email protected](@PABPTR),@MNUM+1  Create double byte PAB
 
       DADD @MNUM,@FREPTR     Update free word pointer
       CALL IOCALL            Preform I/O call for actual d
       BYTE CZDELE
       XML  CONT
***********************************************************
*                    CLOSE ROUTINE
* Syntax could be
* CLOSE #{ num exp }  or CLOSE #{ num exp }:DELETE
*
* Possibly output pending records before closing or
* deleting the file.
***********************************************************
CLOSE  CALL CHKFN             Check for "no #" / "#0" cases
       BS   ERRFE             Not for "CLOSE" you don't
       CALL CHKCON            Check file number etc...
       BR   ERRFE             *** FILE NUMBER NOT IN SYSTEM
       CALL OUTEOF            Output pending records
       ST   CZCLOS,[email protected](@PABPTR) Default to CLOSE I/O code
       CEQ  COLONZ,@CHAT      Check for ":DELETE" spec.
       BR   G81B8
       XML  PGMCHR            Request next input token
       XML  SPEED             Must be at a
       BYTE SYNCHK          *  "DELETE" else
       BYTE DELETZ          *   its an error
       ST   CZDELE,[email protected](@PABPTR) Change CLOSE to DELETE
G81B8  CALL CHKEND            EOS?
       BR   ERRSYN            NO:SYNTAX ERROR
       CALL CDSR              Call DSR with whatever we hav
       BR   CLOSZ1            Reset means error....
       CALL DELPAB            Delete PAB and data-buffer
       XML  CONT              Return to parser routine
CLOSZ1 DST  [email protected](@PABPTR),@ARG Save error code for message
       CALL DELPAB            Now delete the PAB
       DST  @FREPTR,@PABPTR   Store error-code in free memo
       DSUB 6,@PABPTR         Create standard size PAB
       DST  @ARG,[email protected](@PABPTR) Copy error-code
       BR   ERRIO             Exit to error-routine
***********************************************************
*                   CLOSE ALL ROUTINE
* CLOSE all the existing PABs ... ignore errors
*
* NOTE: "CLSLBL" is used in the I/O error routine to
*       determine if a warning should be given rather than
*       an error.
***********************************************************
G81DD  DST  V*PABPTR,@PABPTR
CLSAZ0 DCZ  V*PABPTR          Find last PAB in chain
       BR   G81DD
       CALL OUTEOF            Take care of pending records
CLSLBL ST   CZCLOS,[email protected](@PABPTR) Select CLOSE code
       CALL CDSR              CLOSE to DSR routine
       CALL DELPAB            Delete PAB - ignore CLOSE err
CLSALL DST  @IOSTRT,@PABPTR   Start at beginning of chain
       DCZ  @IOSTRT           Continue until done
       BR   CLSAZ0
       RTN                    And return
***********************************************************
*                   RESTORE ROUTINE
* RESTORE can have any of four forms:
*
* RESTORE                     Restore to first DATA
* RESTORE 20                  Restore DATA pointer
* RESTORE #1                  Rewind file number 1
* RESTORE #1, REC 2           Position file 1 at record 2
***********************************************************
RESTOR DCLR @FAC              Assume simple RESTORE
       CEQ  NUMBEZ,@CHAT
       BR   OLDCD
       CALL CHKFN             Check for #<filenumber>
       DCZ  @FAC              Found equivalent of #0
       BS   OLDCZ0
       CALL CHKCON            Check and decode file #
       BR   ERRFE             Give error if file not there
       CALL OUTEOF            Output pending record
       DCLR [email protected](@PABPTR)    Initialize to record 0
       CALL PARREC            Parse possible record clause
       CALL IOCALL            Call DSR routine with
       BYTE CZREST          *   RESTORE I/O code
       XML  CONT              Return if no error found
* Following code is for handling RESTORE to line number
* within program
OLDCD  CALL CHKEND            Check for start with end
       BS   OLDCZ0            If we have anything else
       CALL LINE               in FAC (double)
OLDCZ0 DCEQ @ENLN,@STLN
       BR   G8233
WRNNPP CALL WARNZZ            * NO PROGRAM PRESENT *
       BYTE 29
       B    TOPL15            Go back to toplevel
G8233  DST  @ENLN,@LNBUF      Start at beginning of program
       DSUB 3,@LNBUF          Backup for first line number
* Check against given line number
OLDCZ1 CALL GRSUB3            Read 2 bytes of line ptr from
*                              line # table which is in ERA
       BYTE LNBUF           * Source address on ERAM/VDP
*                             @EEE1: Destination addr on CP
       DCH  @EEE1,@FAC        Try to get something higher
       BR   G824E
       DCEQ @STLN,@LNBUF      Last line in program
       BS   ERRDAT
       DSUB 4,@LNBUF          Get next entry in line # tabl
       BR   OLDCZ1            Try again with next line
G824E  DADD 3,@LNBUF          Undo subtraction
       CALL DATAST            Setup pointer for READ
       XML  CONT              Continue PARSE
***********************************************************
*                 DISPLAY ROUTINE
* DISPLAY handles all random screen access stuff..
* the AT-clause, and the BEEP, ERASE ALL and SIZE clause.
***********************************************************
DISPL1 CALL DISACC            Evaluate DISPLAY options
       BS   EOLEX             EXIT directly on end-of-state
* If anything is specified it has to be a colon
       CZ   @PABPTR           Nothing was specified
       BS   PRINZ1
* At this point we MUST have a colon, or else we error off
* (SYNTAX ERROR)
       XML  SPEED             Check for a colon
       BYTE SYNCHK          *  and continue
       BYTE COLONZ          *   it approved
       BR   PRINZ1            Continue with PRINT items
***********************************************************
*                    PRINT ROUTINE
* MAIN-HANDLER FOR ALL PRINT-FUNCTIONS
***********************************************************
PRINT  CALL INITKB            Initialize keyboard I/O
       CEQ  NUMBEZ,@CHAT      Could still be anything
       BR   PRINZ1
       CALL CHKFN             Check if default or open chan
       DCZ  @FAC              Default intended
       BS   PRNZ10
       CALL CHKCON            Check and convert expression
       BR   ERRFE             Error if PAB not in system
* PRINT allowed in output, append or update modes
*       Not allowed in input mode
       CLOG >04,[email protected](@PABPTR)
       BS   G8288
       CLOG >02,[email protected](@PABPTR)
       BS   ERRFE
G8288  CEQ  CZREAD,[email protected](@PABPTR)
       BR   G8293
       CLR  [email protected](@PABPTR)    Unpend pending INPUTs
G8293  ST   CZWRIT,[email protected](@PABPTR) uncomplete PRINTs
       CALL PRINIT            Initialize some variables
* Next character has to be either EOL, COMMA, or COLON
       CALL CHKEND
       BS   EOLEX              exit on end of statement
       CALL PARREC            Parse possible record clause
       BS   PRINZ0            found "," but no REC clause
PRNZ10 CALL CHKEND
       BS   EOLEX             Exit on end of statement for
*                       "PRINT #0" or "PRINT file position"
       CEQ  COMMAZ,@CHAT
       BR   G82BE
       XML  PGMCHR            Get next in line
PRINZ0 CZ   @PABPTR           For "PRINT #0"
       BS   USING
*         Interal type of file?
       CLOG >08,[email protected](@PABPTR)
       BR   ERRFE
       BR   USING             Execute USING clause
G82BE  XML  SPEED             Must be at a
       BYTE SYNCHK          *   colon at this point
       BYTE COLONZ          *     and error off on others
       BR   CONPRT            Make it a short branched ELSE
PRINZ1 CEQ  USINGZ,@CHAT
       BS   USING             End standard initialization
* Test standard separators
CONPRT CALL TSTSEP            Test separator character
       CEQ  TABZ,@CHAT        Handle TABs
       BS   PRTAB
* At this point we've checked TAB and ; , :
* The only remaining print items have to be expressions
*  All expressions are being handled below.
* If the result of the expression is a numeric, the string
* is transformed into a string and printed. Strings are
* printed "as is".
*  The code for strings and converted numerics cannot be ma
* common, since numerics may require an extra space behind
* the item, depending upon the current position in the reco
*  Either way, the string is chunked up into little pieces
* it won't fit in an empty record.
       XML  PARSE             Evaluate the expression
       BYTE COLONZ
* Special code for INTERNAL file handling
*  Translate numeric datums into string format and indicate
* length 8. Then check to see if the item fits within the
* current record. If not, it is an error, since each item
* has to fit.
       CALL TSTINT            Test for internal files
       BS   OTHEZ1            Nope, something different
       CEQ  STRVAL,@FAC2      Change numerics
       BS   G82EC
       ST   8,@FAC12          To string length 8
       MOVE 8,@FAC,@ARG       Save in ARG
       ST   ARG,@FAC11        And use this as source
       CALL RSTRING           Reserve some string space
G82EC  ST   @RECLEN,@ARG      Compute remaining space to EO
       SUB  @CCPPTR,@ARG       for space checking
       INC  @ARG              Make it real space
       CHE  @ARG,@FAC7        Not enough!!!!!
       BS   ERRFE
* The = check includes length byte
       ST   @FAC7,V*CCPADR    Prestore string length
       DINC @CCPADR           Update actual RAM address
       INC  @CCPPTR            and internal column pointer
       BR   OTHEZ0
OTHEZ1 CEQ  STRVAL,@FAC2      Print the string result
       BR   G830D
OTHEZ0 CALL OSTRNG            Output the string to the reco
       BR   CHKSEP
G830D  CLR  @FAC11            Select standard BASIC format
       XML  CNS               Convert number to string
       CALL RSTRING           Reserve and copy string
       CALL OSTRNG            Output the string
* Possibly add an extra space if we're not at the end of th
* current record.
       CHE  @CCPPTR,@RECLEN   Enough space left
       BR   CHKSEP
       ST   SPACE,V*CCPADR    Add trailing space
       ADD  @DSRFLG,V*CCPADR  Take care of screen I/O
       DINC @CCPADR           Update current column address
       INC  @CCPPTR            and base 1 pointer
CHKSEP CALL TSTSEP            Check for legal delimiter
       BR   ERRSYN            Illegal delimiter. SYNTAX ERR
*                              Unconditional branch
* PRTAB - Print TAB as part of PRINT command
PRTAB  CALL TSTINT            Watch out for INTERAL file ty
       BR   ERRFE             They can't handle TABs
       XML  PGMCHR            Skip TAB keyword
       CEQ  LPARZ,@CHAT
       BR   ERRSYN
       XML  PARSE             Parse TAB expression
       BYTE RPARZ
       CALL CNVDEF            Check and convert to integer
       ST   @RECLEN,@FAC2     Set modulo number
       CALL COMMOD            Compute remainder
       CH   @FAC1,@CCPPTR     Position on next output recor
       BR   G834F
       CALL OUTREC            Output current record - no pe
       BS   CHKSEP             react on SIZE block!!!
G834F  CEQ  @FAC1,@CCPPTR     Stay here
       BS   CHKSEP
       ST   @FAC1,@MNUM+1     Fill with spaces
       XML  IO                OK, go ahead... fill'r up
       BYTE FILSPC
       BR   CHKSEP            And check separator again
* Comma is similar to TAB, except that it generates at leas
* one space. The exact number of spaces generated depends
* upon the current position within the record. If the next
* fixed tab-position is outside the record, the record, the
* current record is output and the column pointer is reset
* to column 1 of the next record.
PRTCOM ST   @CCPPTR,@MNUM+1   Compute initial # of spaces
       DEC  @MNUM+1           Decrecment for 0 origin
       CLR  @MNUM             Clear high byte of double
       DIV  14,@MNUM          TABs are 14 spaces apart
       INC  @MNUM             Compute next TAB-stop
       MUL  14,@MNUM           and actual position
       CH   @MNUM+1,@RECLEN   Within this record
       BR   PRCOL
       INC  @MNUM+1           Convert to real position
       XML  IO                Fill spaces to new location
       BYTE FILSPC
       BR   PRSEM             Outside current record
* The ":" (colon) separator is used to output the current
* record, and proceed to position 1 of the next record.
PRCOL  CALL OUTREC            Output the current record
* The ";" (semi-colon) generates the null string. Since all
* print items should be separated by a separator, this one
* has been introduced to separate without moving to another
* position. Notice that all separators join up here.
PRSEM  XML  PGMCHR            Skip the separator
       CALL CHKEND            Exit on end of line
       BR   CONPRT            Continue if not end of line
PRSMZ1 CZ   @DSRFLG           For screen output continue
       BS   PREXIT
       CLOG >08,@PABPTR       Check SIZE clause
       BS   PREXIT
       CALL OUTREC            Output current record (blank
       ST   @CCPADR+1,@CCPPTR Compute correct value for CCP
       SUB  >E1,@CCPPTR       Subtract current screen base
       BR   PREXIT             and exit form this command
* End of line exit routine for PRINT statement
EOLEX  CZ   @DSRFLG           I/O - remove blocks if
       BS   G83A1
       CLOG >04,@PABPTR        " AT" clause unused
       BR   G83A1
       AND  >E7,@PABPTR        remove flag 3 (SIZE used)
G83A1  CALL OUTREC            Output pending record
* Continue here if record remains pending
PREXIT CZ   @DSRFLG           Regular file/device I/O
       BR   G83B1
       DEC  @CCPPTR           Back to actual offset
       ST   @CCPPTR,[email protected](@PABPTR) Save for next statement
       XML  CONT              Continue with next statement
*                              End external I/O handling
* Reset of code is for internal I/O handling (VDP)
G83B1  CLOG >04,@PABPTR       Is not used
       BR   G83BB
       ST   @CCPPTR,@XPT      Save current value of pointer
       INCT @XPT              CCPPTR: 1-28
G83BB  CLOG >02,@PABPTR       Used BEEP clause
       BS   G83C3
       CALL TONE1             ---------- BEEP ------------
G83C3  XML  CONT              Continue in PARSE routine
* TSTINT - test for INTERAL type files, set COND if file
*          is NOT INTERNAL
TSTINT CZ   @DSRFLG           Couldn't possibly be INTERNAL
       BR   RTC
       CLOG >08,[email protected](@PABPTR) Set COND according to bit 3
       RTNC                   Return without changing COND
********* PRINT / DISPLAY USING SECTION *******************
* Arrive here after the keyword "USING" has been rejected.
USING  XML  SPEED
       BYTE SYNCHK          * Get first character of format
       BYTE USINGZ          *  after (double) checking USIN
       CEQ  LNZ,@CHAT         Pick up the line number
       BR   G8430
       XML  PGMCHR            Get high address
       ST   @CHAT,@FAC
       XML  PGMCHR             and low address
       ST   @CHAT,@FAC1
       XML  PGMCHR              get next program character
       DST  @EXTRAM,@FAC2        in SEETWO : EXTRAM value w
*                                 changed
       XML  SPEED
       BYTE SEETWO          *  Find the line # in the progr
       DEX  @EXTRAM,@FAC2      result in SEETWO is in EXTRA
*                               and restore EXTRAM value
       BR   USNGZ1               has to match exactly
       DINCT @FAC2            Move up to the pointer field
       DST   @DATA,@FAC8      Save DATA pointer for READ fi
       CALL GRSUB2            Read 2 bytes of data from ERA
       BYTE FAC2           *  @FAC2 : Source address on ERA
       DST  @EEE1,@DATA       @EEE1 : Destination addr. on
*                              Put it in @DATA
       ST   IMAGEZ,@FAC2      Search for an IMAGE token
       CALL SEARCH             at beginning of an statement
       BS   USNGZ1            Error if not found on this li
       CALL GETGFL            Get first part of format stri
       CALL CHKSTR            Prepare data for string assig
       DST  @FAC6,@BYTES      Copy actual string length in
       DST  @FAC8,@DATA       Restore original DATA pointer
       CALL CTSTR             Create a temporary string
       DCZ  @FAC6
       BS   G842E
       CZ   @RAMTOP           Data from RAM
       BR   G8423
       MOVE @FAC6,V*TEMP5,V*SREF
       BR   G842E
G8423  DST  @FAC6,@FFF1       FFF1 : byte count
       DST  @TEMP5,@DDD1      DDD1 : source address in ERAM
       DST  @SREF,@EEE1       EEE1 : destination address on
       XML  GVWITE            Write data from ERAM to VDP
G842E  BR   G8438
G8430  XML  PARSE             Parse up to the ending ":"
       BYTE COLONZ
       CEQ  STRVAL,@FAC2      * IMAGE ERROR *
       BR   USNGZ1
G8438  CEQ  COLONZ,@CHAT      Probably no variable list
       BS   G8448
       CALL CHKEND            We better check that through
       BR   ERRSYN             something sneaky sneaked in
       CZ   @FAC7             End of line exit
       BS   EOLEX
       BR   G8463             Look for format item
G8448  CZ   @FAC7             Exclude null strings
       BS   USNGZ1
       DST  @FAC4,@ARG        Get start address for string
       ST   @FAC7,@ARG2       Get format string length
USNGZ0 CEQ  >23,V*ARG         Found no format item yet
       BS   G8460
       DINC @ARG              Try next address
       DEC  @ARG2             Update address
       BR   USNGZ0            Try up to the end of the stri
USNGZ1 BR   ERRIM             * IMAGE ERROR
* Now we're sure that we have at least one legal format ite
* (anything with a "#" in it)
G8460  ST   COMMAZ,@CHAT      Fake comma seperator for prin
G8463  XML  VPUSH             Current string might be tempo
       DST  @FAC6,@BYTES      Create a workstring for outpu
       INC  @BYTES+1          Create space for end of strin
       CARRY                  String would be too long
       BS   USNGZ1
       XML  GETSTR            Length whold equal format str
       DST  @SREF,@CURLIN     Create a temporary string
       DADD @FAC6,@SREF       Compute last position in stri
       CLR  V*SREF            Set end of string indicator
USNGZ3 DST  [email protected](@VSPTR),@FAC4 Update FAC4 area in case garb
       MOVE @FAC6,V*FAC4,V*CURLIN Copy format
       DST  @CURLIN,@FAC4     Complete preps for VPUSH
       DST  >001C,@FAC        SREF = >001C
       DINC @FAC6             Include 0 in string length
       XML  VPUSH             Make the string temporary
       DST  [email protected](@VSPTR),@CURLIN Update current line pointer
USNGZ4 CEQ  >23,V*CURLIN      Try to locate the next format
       BS   G84C3
       CZ   V*CURLIN          Not end of string yet
       BS   G84A2
       DINC @CURLIN           Update pointer if not found
       BR   USNGZ4             and continue searching
G84A2  CEQ  COMMAZ,@CHAT      Stop on last variable
       BR   USNGZ9
       XML  VPOP              Restore original workstring d
       ST   @FAC7,@BYTES      Pring the current format stri
       DEC  @BYTES            Don't count the last "0"
       ST   1,@MNUM+1         Indicate direct output withou
       CALL CHKRZ0            Copy string to output record
       CALL OUTREC            Also output current record
* FAC still contains the right data, however it is easier j
* to copy the original string again.
       DST  @FAC4,@CURLIN     Reconstruct CRULIN
       XML  VPOP              Copy original string info
       XML  VPUSH             Without actually removing it
       DSUB @FAC6,@CURLIN     Reconstruct start address
       BR   USNGZ3            Continue for the next variabl
G84C3  DCEQ [email protected](@VSPTR),@CURLIN Avoid "#" as count
       BS   USNZ42
       DDEC @CURLIN           Backup to the sign
       CEQ  >2E,V*CURLIN      Used ".#####"
       BR   G84DB
       DCEQ [email protected](@VSPTR),@CURLIN
       BS   USNZ42
       DDEC @CURLIN           Avoid checking count bit
G84DB  CEQ  >2D,V*CURLIN      Check for minus
       BS   USNZ42
       CEQ  >2B,V*CURLIN      Check for plus
       BS   USNZ42
       DINC @CURLIN           It's neither, so we undo
* Check for availability of variables
USNZ42 CEQ  COMMAZ,@CHAT      Exit if no more pt item
       BR   USNGZ9
       XML  PGMCHR            Get next expression
       DSUB [email protected](@VSPTR),@CURLIN Make CURLIN offset for
*                                garbage collection
       XML  PARSE             Parse up to ";" or ","
       BYTE SEMICZ
       DADD [email protected](@VSPTR),@CURLIN Reconstruct new CLN after
*                                garbage collection
       DCLR @FAC8             Start with clean sheet for co
       DCLR @FAC11
       CLR  @FAC13
       DST  @CURLIN,@VAR4     Now start checking process
       CEQ  >2E,V*CURLIN
       BS   USNGZ5
       CEQ  >23,V*CURLIN      Has to be "+" or "-"
       BS   G8527
       CEQ  >2D,V*CURLIN
       BR   G851B
       OR   >02,@FAC11        Set explict sign flag for CNS
G851B  CEQ  >2B,V*CURLIN
       BR   G8527
       OR   >02,@FAC11        Set explict sign flag for CNS
       OR   >04,@FAC11        Set positive sign flag for CN
G8527  CALL ACCNM             Accept first character plus "
       ST   @FAC9,@FAC12      Set up FAC12 for CNS
       CEQ  >2E,V*VAR4        Found decimal point
       BR   G8540
USNGZ5 CLR  @FAC9             Prepare for use as counter of
*                              of # sign after decimal poin
       CALL ACCNM             Accept some more "#"'s
       ST   @FAC9,@FAC13      Set up FAC13 for CNS
       ADD  @FAC12,@FAC9      FAC9 now contains the total n
*                              of "#" sign, decimal point a
*                              maybe a sign bit
       DEC  @FAC9             Exclude the decimal point
G8540  DCEQ >5E5E,V*VAR4      Attempt to decode  ^^
       BR   USNZ55
       DINCT @VAR4            Update address
       DCEQ  >5E5E,V*VAR4
       BR   G8562
       DINCT @VAR4            Update address
       OR   >08,@FAC11        Set E-format bit for CNS
       CEQ  >5E,V*VAR4
       BR   USNZ55
       DINC @VAR4             Update end address
       OR   >10,@FAC11        Set extended E-format bit for
       BR   USNZ55
G8562  DDECT @VAR4            Correct for previous errors
* At this point, CURLIN is pointing at the first item of th
* format, VAR4 is pointing at the character following the i
USNZ55 CHE  >64,@FAC2         Detected numerical argument
       BS   G8596
       CLOG >02,@FAC11        Exclude the sign count
       BS   G8570
       DEC  @FAC9             FAC9 : Number of significant
G8570  CLOG >08,@FAC11        If E-format is used
       BS   G857C
       CGT  >0A,@FAC9         More than 10 significant digi
       BS   ERRIM
       BR   G8581
G857C  CGT  14,@FAC9          More than 14 significant digi
       BS   ERRIM
G8581  OR   >01,@FAC11        Set fixed format output it fo
       XML  CNS               Convert number to fixed forma
* FAC11 points to the beginning of the string after supress
* leading 0's, FAC12 contains the length of the string
       ST   @FAC11,@FAC13     FAC13 now point to beginning
*                              the string
       CLR  @FAC11            Clear high byte
       MOVE @FAC11,*FAC13,V*CURLIN Copy the result string f
*                                   temporary
       DST  @VAR4,@CURLIN     Move pointer behind print fie
       BR   USNGZ4            Continue after printing
G8596  DST  @VAR4,@FAC10      Compute total length
       DSUB @CURLIN,@FAC10
       CH   @FAC11,@FAC7      String exceeds limits
       BR   G85B1
       ST   >2A,@VAR0         Prepare a "*****.." string
G85A4  ST   @VAR0,V*CURLIN    Fill the remainder of field
       DINC @CURLIN           Up to the end
USNZ67 DCEQ @VAR4,@CURLIN     Which is stored in VAR4
       BR   G85A4
       BR   USNGZ4
G85B1  DCZ  @FAC6
       BS   USNZ68
       MOVE @FAC6,V*FAC4,V*CURLIN Copy result string
       DADD @FAC6,@CURLIN     And update address in string
USNZ68 ST   SPACE,@VAR0       Fill remainder with spaces
       BR   USNZ67
USNGZ9 XML  VPOP              Temporary string back out
       ST   @CURLIN+1,@BYTES  Output up to the current
*                              position
       SUB  @FAC5,@BYTES      Create one byte result
       BS   USNZ95            Avoid empty strings
       ST   1,@MNUM+1         Prevent skip if field too sma
       CALL CHKRZ0            Preform all nomal I/O stuff
USNZ95 XML  VPOP              Remove source format string
       CALL CHKEND            Check for end of line exit
       BS   EOLEX             Take end of line exit
       XML  SPEED
       BYTE SYNCHK          * Then it HAS to be a ";"
       BYTE SEMICZ
       CALL CHKEND            Now - must be EOS
       BS   PRSMZ1            Supressed end of record, make
*                              it a pending record
       BR   ERRSYN            SYNTAX ERROR
* Collect string of "#"'s
ACCNM  INC  @FAC9             Update item count
       DINC @VAR4              and item address
       CEQ  >23,V*VAR4        Decode as many "#"'s as
*                              possible
       BS   ACCNM
       RTN                    Return from duty
***********************************************************
*                    INPUT ROUTINE
* First check for file or screen I/O. If file I/O then chec
* for pending output and print that. If screen I/O then
* check for input prompt:
* Next collect the INPUT variable list on the V-stack. Get
* enough input form either file or keyboard, and compare
* types with entries on V-stack. After verification and
* approval, assign the values.
***********************************************************
INPUT  CALL INITKB            Assume keyboard INPUT
       CEQ  NUMBEZ,@CHAT      Might be #0 or #1-255
       BR   G875A
       CALL CHKFN             Check for default #0
       DCZ  @FAC              If luno #0
       BR   G860B
       DST  @PGMPTR,[email protected]  Save PGMPTR for "try again"
       DINC [email protected]          Pass the ":" for the
*                              "prompt" code handler
*                              later, (using #0 will not
*                              take care the prompt in
*                              INPUT)
       CALL INPUZ2            #0 is equivalent to no #
       BR   INPZ2
G860B  CALL INSU1             Get info about file
* INTERNAL files get special treatment
       CLOG >08,[email protected](@PABPTR) INTERNAL file
       BS   G86AD
       CZ   [email protected](@PABPTR)    Fresh start
       BR   G861E
INTRZ0 CALL IOCLZ1            Get a new record through
*                              the DSR
G861E  ST   [email protected](@PABPTR),@VARA+1 Regain possible offset
       CLR  @VARA             Make that a two byte constant
       DST  [email protected](@PABPTR),@TEMP5 Get first address
       DADD @VARA,@TEMP5      Compute actual address
*                              within record
INTRZ1 CALL BUG01             Get the symbol table entry
* Above call fixes bug, of the given variable
       XML  VPUSH             And save it on the stack
       DCLR @BYTES            Assume no data available
       CHE  [email protected](@PABPTR),@VARA+1 Pick up data
       BS   G8643
       ST   V*TEMP5,@BYTES+1  Length byte first
       DINC @TEMP5            Update both actual address
       INC  @VARA+1            and offset
G8643  CEQ  >65,@FAC2         Has to be string variable
       BR   G8650
       DST  @BYTES,@FAC6      Set length of string
       CALL CTMPST            Create temporary string
       BR   G867E
G8650  CEQ  >08,@BYTES+1      * FILE ERROR
       BR   ERRFE
       MOVE @BYTES,V*TEMP5,@FAC  Copy value
       DCZ  @FAC              Watch out for non-scaled stuf
       BS   G867C
       ST   FAC7,@ARG         Test for legal numeric
G8661  CH   99,*ARG           * FILE ERROR
       BS   ERRFE
       DEC  @ARG              Next digit for test
       CEQ  FAC1,@ARG
       BR   G8661
       DST  @FAC,@ARG         Copy in ARG for some testing
       DABS @ARG              Be sure we're positive
* If first byte after expon. byte=0 : incorrect
* normalization has occured : FILE ERROR
* Or >99 : illegal numeric  : FILE ERROR
       DEC  @ARG1             0 would cause underflow here
       CH   98,@ARG1
       BS   ERRFE
       BR   G867E
G867C  DCLR @FAC2             Be sure FAC2 = 0 (no strings)
G867E  DADD @BYTES,@TEMP5     Update address and
       ADD  @BYTES+1,@VARA+1   offset again
       XML  ASSGNV            Assign value to variable
       CLR  [email protected](@PABPTR)    Undo allocated offsets
       CEQ  COMMAZ,@CHAT
       BR   G86AB
       XML  PGMCHR            Get next text character
       CALL CHKEND            Check for end of statement
       BS   INTRZ2            OK, EOS is fine
       CHE  [email protected](@PABPTR),@VARA+1
       BS   INTRZ0
       BR   INTRZ1            Still something left
INTRZ2 CHE  [email protected](@PABPTR),@VARA+1
       BS   G86AB
       ST   @VARA+1,[email protected](@PABPTR) Save value of offset
G86AB  XML  CONT              And CONTINUE
G86AD  CALL GETVAR            Collect variable list on stac
       DST  @STADDR,@CURLIN   Save it in temp
       DST  CRNBUF,@RAMPTR    Initialize crunch buffer poin
       CLR  @RECLEN           Initialize field counter
       ST   CZREAD,[email protected](@PABPTR) Select READ operation
       CZ   [email protected](@PABPTR)
       BR   INPZ31
       BR   INPZ3             Adjust for used record usage
G86C6  ST   COMMAZ,[email protected](@RAMPTR) Fake legal separator
INPZ3  CALL IOCLZ1            Get next input record
       CLR  [email protected](@PABPTR)    Reset offset within record
       CALL RECENT
       ST   [email protected](@PABPTR),@VARA Get record length
G86DB  CZ   @VARA
       BS   INPZ31
       ADD  OFFSET,V*VARW     Add video offset for normal
       DINC @VARW             Screen-type crunch - proceed
       DEC  @VARA              for entire record
       BR   G86DB
INPZ31 CALL RECENT            Compute actual record entry
       ST   [email protected](@PABPTR),@VARA+1  Compute end of record
       CLR  @VARA             Make that a double byte
       DADD [email protected](@PABPTR),@VARA  Add buffer start addr
       DDEC @VARA             Point to last position in rec
       CLR  @VAR6             Assume no values input
       XML  CRUNCH            Scan data fields as in DATA s
       BYTE 1               * Indicate input stmt crunch
       DCZ  @ERRCOD           If some crunch error
       BR   ERRINP
       INC  @VAR6             Get correct # of fields (one
       ADD  @VAR6,@RECLEN     Update # of fields up to now
       CHE  @VAR5,@RECLEN     OK, THAT'S ENOUGH!!!!
       BR   G86C6
       DDECT @PGMPTR          Backup program pointer
       XML  PGMCHR            Re-inspect last token before
       CALL RECENT            Precompute record entry
       CLR  [email protected](@PABPTR)    Assume no pending record
       CEQ  COMMAZ,@CHAT      Make record pending
       BR   G8752
       CEQ  @VAR5,@RECLEN     Enough left pending
       BS   G8752
       SUB  @VAR5,@RECLEN     Compute remaining # of fields
       SUB  @RECLEN,@VAR6     # of fields used in last reco
INPZ32 CEQ  >82,V*VARW        +OFFSET
       BR   G873A             Skip quoted strings
G872E  DINC @VARW
       CEQ  >82,V*VARW        +OFFSET
       BR   G872E
       DINC @VARW
       BR   INPZ32            Search for Nth data item
G873A  DINC @VARW             Update pointer
       CEQ  >8C,[email protected](@VARW) * ","+OFFSET = >8C
       BR   G873A
       DEC  @VAR6             Commas denote end of field
       BR   INPZ32            Continue until done
       DSUB [email protected](@PABPTR),@VARW Compute current offset
       ST   @VARW+1,[email protected](@PABPTR) Store for next round
G8752  ST   @VAR5,@VAR6       Copy # of variables for check
       DST  @CURLIN,@STADDR   Restore from temp
       BR   G8786
G875A  CALL INITKB            Initialize some variables for
       DST  @PGMPTR,[email protected]  Save for "try agian" case
       DST  @CCPPTR,[email protected]  Save CCPPTR, RECLEN for "try
*                         Entry point for "try again" case
INPZ33 CALL INSUB1            Put out prompt
INPZ2  CALL GETVAR            Get variable list on V-stack
INPUZ3 CALL INSUB2            Read from the screen
       CLR  @VAR6             Assume no values input
       XML  CRUNCH            Crunch the input line
       BYTE 1               * Indicate input stmt scan
       DST  @CURLIN,@STADDR   Restore from temp
       DCZ  @ERRCOD           If got some crunch error
       BR   WRNINP
       XML  SCROLL            Scroll up after crunching
       ST   3,@XPT            Reset XPT too - pending recor
       INC  @VAR6             # fields = # of commas + 1
       CEQ  @VAR6,@VAR5       # of variables wrong
       BR   WRNINP
* Once we're here, all information should be availiable
* After type verification for input and variables, push
* all value entries on the V-stack.
* VAR6 = VAR5 = number of variables
G8786  DST  @DATA,@CURLIN     Save current DATA pointer
       DST  CRNBUF,@DATA      Get crunch entry
       DST  @VAR4,@MNUM       Get entry in V-stack before P
INPUZ4 DADD 8,@MNUM           Point to first symbol table e
       DST  V*MNUM,@CCPPTR    Get immedediate result
       CALL GETRAM            Get value descriptor from RAM
       CLOG >80,V*CCPPTR      Numerical value
       BR   G87CF
       CALL CHKNUM            Check entered value against n
       BR   INPUZ5            Found error
       CZ   @DSRFLG           Do not check overflow in file
*                              supply machine infinity with
*                              appropriate sign and continu
       BS   INPUZ6
       CZ   [email protected]          Watch out for overflow in scr
       BS   INPUZ6
       DST  @CURLIN,@DATA     Restore DATA pointer
       BR   WRZZ5             Ask for input re-enter
INPUZ5 CZ   @DSRFLG           FILE I/O IS FATAL
       BS   ERRINP
       DST  @CURLIN,@DATA     Restore DATA pointer on error
WRNINP CALL WARNZZ            Go here for simple warnings t
       BYTE 32              * INPUT ERROR - TRY AGAIN
WRZZ5  CALL SCRZ              Scroll the screen and reset C
       DST  [email protected],@PGMPTR  Restore ptr to "prompt" if an
       DST  [email protected],@CCPPTR  Restore CCPPTR, RECLEN, for t
       DST  @VAR4,@VSPTR      Restore original stack ptr
       BR   INPZ33
G87CF  CALL CHKSTR            Check string input
       BS   INPUZ5            ERROR ... CHECK I/O TYPE
INPUZ6 CALL GETRAM            Get separation character (RAM
       CEQ  COMMAZ,@VAR0+1
       BS   G87E6
       DEC  @VAR6             Has to be end of data
       BR   INPUZ5            If not ... ERROR
       CZ   @VAR0+1
       BR   INPUZ5
       BR   G87EA
G87E6  DEC  @VAR6             Count number of value entries
       BR   INPUZ4            Continue
* Assign cycle - assign values to variables because it resc
* the program line, this code can not be udes for inperativ
* statements , since the crunch buffer get's destroyed on
* input. The rescan is necessary because subscripts should
* evaluated AFTER all previous values have been assigned. i
*        INPUT I,A(I)      with values 2,3
* Should assign value 3 to A(2) !!!!!!!!!
* No error-checking is done here, since types are already
* validated. We might get subscripts out of range though!!!
G87EA  DST  CRNBUF,@DATA      Prepare for input rescan
       DST  @STADDR,@PGMPTR   Restore token pointer for res
       DDEC @PGMPTR           Backup on token
       DST  @VAR4,@VSPTR      Restore original stack pointe
INPZ65 XML  PGMCHR            Get next program characters
       CALL CHKEND            Might have , before EOS
       BS   INPUZ7
       CALL BUG01             Rescan variable name
* Above call fixes bug.       Get correct entry for arrays
       XML  VPUSH             Save on stack for ASSGNV
       CALL GETRAM            Get first token of input valu
       CEQ  STRVAL,@FAC2      Numerical case
       BS   G880F
       CALL CHKNUM            Check for numerical value
       BS   INPZ67            COND should be set (valid num
G880F  CALL CHKSTR            Get the correct string value
       DST  @FAC6,@BYTES      Length for temporary string
       CALL CTMPST            Create temporary string
INPZ67 XML  ASSGNV            Assign value to variable
       CALL GETRAM            Skip separator (already check
       CALL CHKEND            Check for end to statement
       BR   INPZ65            Found it
INPUZ7 DST  @CURLIN,@DATA     Restore DATA pointer
       XML  CONT              Contiue in PARSE
RECENT ST   [email protected](@PABPTR),@VARW+1  Get record offset
       CLR  @VARW             Double byte value required
       DADD [email protected](@PABPTR),@VARW   Got it
       RTN                    AND NOW, THE END IS NEAR...
CHKRM  DCH  SCRNBS+29,@CCPADR Not enough room for "?"
       BR   G8840
SCRZ   XML  SCROLL            Scroll one line for "?"
       DST  SCRNBS+2,@CCPADR   and update CCPADR accordingl
G8840  RTN
***********************************************************
*                LINPUT ROUTINE
* If file-I/O then
*             Get file number and check it
*             Internal file not allowed
* End if
* Get variable info
* Must be string variable
* If file I/O then
*           If no-partial-record of REC clause included
*           Read new record
*     End if
*     Set up copy pointers
* Else
*     Call readline to read from keyboard
*     Copy to crunch buffer adjustin g for screen offset
* End if
* Get string of proper length
* Move data into string
* Assign string
* Done.
***********************************************************
LINPUT CALL INITKB            Assume input from keyboard
       CEQ  NUMBEZ,@CHAT      If "#" - then device
       BR   G885C
       CALL CHKFN             Check for default = 0
       DCZ  @FAC              #0 is assumed
       BS   LINP10
       CALL INSU1             Parse the device #
       CLOG >08,[email protected](@PABPTR)
       BR   ERRFE
       BR   LINP10
G885C  CALL INSUB1            Handle possible prompt
LINP10 DST  @VSPTR,@VAR4      Save original V-pointer
*                              incase BREAK in READLN
       CALL BUG01             Get info about the symbol
* Above call fixes bug.       Get value pointer and type
       CEQ  STRVAL,@FAC2      Must be string
       BR   ERRMUV
       XML  VPUSH
       CZ   @DSRFLG           If device I/O
       BR   G88AF
       CZ   [email protected](@PABPTR)    If new record
       BR   G887B
       CALL IOCLZ1            Read the record
       BR   G8893
G887B  ST   [email protected](@PABPTR),@BYTES Get length of record
       DST  [email protected](@PABPTR),@TEMP5 Get address of buffer
G8885  CZ   @BYTES            While characters in buffer
       BS   G8893
       SUB  OFFSET,V*TEMP5    Remove INPUT's offset
       DINC @TEMP5            Increment pointer
       DEC  @BYTES            Decrement count
       BR   G8885             Drop out directly when done
G8893  CLR  @TEMP5            Need a word value
       ST   [email protected](@PABPTR),@TEMP5+1  Restore value
       CLR  @BYTES            Need a word value
       ST   [email protected](@PABPTR),@BYTES+1  Get the length
       DSUB @TEMP5,@BYTES     Calcualte length
       DADD [email protected](@PABPTR),@TEMP5  Current buffer address
       CLR  [email protected](@PABPTR)    Read next record next time
       BR   G88E1             Else if keyboard input
G88AF  CALL INSUB2            Clear line and call READLN
       DCLR @BYTES            Initialize byte counter
       DST  @RAMPTR,@TEMP5    Initialize "crunch" pointer
       CEQ  SPACE+OFFSET,V*VARA     If space
       BR   G88BF
       DDEC @VARA             Don't include space on end
G88BF  DCGT @VARA,@VARW       While not at end
       BS   G88DC
       ST   V*VARW,@VAR0      Get the character
       CEQ  EDGECH,@VAR0      If not at edge character
       BS   G88D8
       SUB  OFFSET,@VAR0      Subtract screen offset
       ST   @VAR0,V*RAMPTR    And put into crunch buffer
       DINC @BYTES            Count it
       DINC @RAMPTR           And update "crunch" pointer
G88D8  DINC @VARW             Update input pointer
       BR   G88BF
G88DC  XML  SCROLL            Scroll the screen
       ST   3,@XPT            Initialize x-pointer
G88E1  CALL CTMPST            Create temporary string
       XML  ASSGNV            Assign the value to it
       XML  CONT              And continue execution
* Get file number and info about the file
INSU1  CALL CHKCON            Check & convert & search
       BR   ERRFE             Give error if required
* INPUT allowed for input and update modes
       CLOG >02,[email protected](@PABPTR)
       BR   ERRFE
       CALL OUTEOF            Output pending PRINT stuff
       ST   CZREAD,[email protected](@PABPTR)   Ensure read operation
       CALL PARREC            Parse REC clause
       XML  SPEED             Must be at a
       BYTE SYNCHK          *  colon else
       BYTE COLONZ          *   its and error
       CLR  @DSRFLG           Clear keyboard input flag
       RTN
* Parse and put out input prompt
INSUB1 DST  @PGMPTR,@STADDR   Save pointer for prompt check
       DDEC @STADDR           Backup to previous token
*                              Go into a tight loop
G890B  CALL NXTCHR            Get next program character
       BS   INPZ37            Detected end of statement
       CEQ  COLONZ,@CHAT      Stop if we find a colon
       BR   G890B
       DST  @STADDR,@PGMPTR   Backup for actual prompt scan
       XML  PGMCHR            Jump into 1st char of prompt
       XML  PARSE             And try to decode string expr
       BYTE COLONZ
       CEQ  STRVAL,@FAC2      Number prompt illegal
       BR   ERRSNM
       CALL OSTRNG            Output the given prompt
       BR   INPZ39            Exit without prompt backup
INPZ37 DST  @STADDR,@PGMPTR   Backup to beginning of line
       ST   COLONZ,@CHAT      Fake prompt with ":"
INPUZ2 CALL CHKRM             Check for room for ?
       ST   >9F,V*CCPADR      Display ?
       DINCT @CCPADR          Count it too
INPZ39 XML  SPEED             Must be at a
       BYTE SYNCHK          *  colon else
       BYTE COLONZ          *   its an error
       RTN
* Issue 'BEEP' and call read line to read form screen
INSUB2 CALL CHKRM             Check for room for answer
       DST  @CCPADR,@VARW     Copy current cursor position
G8941  ST   >80,V*CCPADR      Clear the remainder
       DINC @CCPADR            of the current line
       DCHE >02FE,@CCPADR     Stop if we're there
       BR   G8941
       DST  >7F7F,[email protected]>02FE     Replace edgechars
       CZ   @PRTNFN           If previous tone finished
       BR   G895A
       CALL TONE1             ---------- BEEP -------------
G895A  DEX  @VAR4,@VSPTR      Don't destroy V-stack on BREA
       CALL READLN            Input a line from the keyboar
       DEX  @VAR4,@VSPTR      Restore V-stack pointer
       DST  @STADDR,@CURLIN   Save in a temp
       DST  CRNBUF,@RAMPTR    Init crunch buffer pointer
       RTN
***********************************************************
*                   ACCEPT STATEMENT
* Accept input anywhere on the screen. The total number of
* input variables is limited to one. On an ACCEPT AT( , ),
* the maximum number that can be accepted is up to the righ
* margin!!!! If SIZE() is used, the maximum number is
* limited to the given SIZE, or to the number of characters
* remaining on the line, whichever is the lesser.
***********************************************************
ACCEPT CLR  [email protected]          Clear "try again" flag
       CALL DISACC            Use common code for DISPLAY/A
       BS   ERRSYN             COND set means end of statem
       ST   >FF,@ARG7         Assume we don't have VALIDATE
************ VALIDATE OPTION HANDLING *********************
       CEQ  VALIDZ,@CHAT      Detected VALIDATE option
       BR   G89FD
       XML  PGMCHR            Next character should start o
       CEQ  LPARZ,@CHAT       "* SYNTAX ERROR *"
       BR   ERRSYN
       OR   >40,@PABPTR       Indicate usage of validate cl
       DST  1,@VARA           Use VARA as length of option
       DCLR @VARW             VARW= options used, VARW+1=#0
*                              stack entries for strings
G898B  XML  PGMCHR            Skip separator token
       CHE  NUMERZ,@CHAT      Could be valid option
       BR   G89AA
       CHE  UALPHZ+1,@CHAT    It is ....
       BS   G89AA
       ST   1,@ARG            Select bit 0 as number option
       SUB  NUMERZ,@CHAT      Create correct offset
       BS   SETVW             Skip the shift stat.
       SLL  @CHAT,@ARG        Then select whatever option w
SETVW  OR   @ARG,@VARW        Remember options in VARW
*                              stack entries for strings
       XML  PGMCHR            Get next token
       B    VLIDZ0            Must use a long branch here
G89AA  XML  PARSE             Try to decode a string expres
       BYTE RPARZ
       CEQ  STRVAL,@FAC2      String-number mismatch
       BR   ERRSNM
       CZ   @FAC7             Only count non-null strings
       BS   VLIDZ0
       ADD  @FAC7,@VARA+1     Now watch out for overflow
       CARRY                  Sting truncated
       BR   G89C0
       CALL ERRZZ             * STRING TRUNCATED ERROR *
       BYTE 19
G89C0  XML  VPUSH             Push the result for future re
       INC  @VARW+1           Count number of entries on st
VLIDZ0 CEQ  COMMAZ,@CHAT      Evaluate all fields
       BS   G898B
       XML  SPEED
       BYTE SYNCHK          * Check for ")" on end
       BYTE RPARZ           * If not, "* SYNTAX ERROR *"
       CALL DISPZ1            Try to evaluate further optio
       BS   ERRSYN            Premature end of statement
       DST  @VARA,@BYTES      Allocate string for character
       XML  GETSTR
       DST  @SREF,@ARG        Get start of allocated string
       ST   @VARW,V*ARG       Get start of allocated string
       DINC @ARG              Leave room form standard opti
G89E0  CZ   @VARW+1           Copy all available informatio
       BS   G89F3
       XML  VPOP              Regain stack-entry
       MOVE @FAC6,V*FAC4,V*ARG Copy string
       DADD @FAC6,@ARG        Update destination address
       DEC  @VARW+1           Count # of stack entries
       BR   G89E0
G89F3  DST  @SREF,[email protected]    Copy start address of string
       DST  @VARA,[email protected]     and total string length
       CLR  @ARG7             Indicate VALIDATE usage of RE
G89FD  DST  @CCPADR,@VARW     Save start address of the fie
       DST  @VARW,@VARA       Set default highest address u
       DST  @CCPADR,@ARG2     Select absolute highest usabl
       DADD 290,@ARG2         290=2+32*9 maximum of 254 cha
       CH   >FC,@VARA+1       Start at the end of line
       BR   G8A13
       DADD 4,@ARG2
G8A13  CZ   @PABPTR           We used some options like AT,
       BS   G8A66
       XML  SPEED
       BYTE SYNCHK          * Should always end on ":"
       BYTE COLONZ
       CLOG >02,@PABPTR       Used BEEP clause
       BS   G8A23
       CALL TONE1             Wake up the user
G8A23  CLOG >04,@PABPTR       Used AT option, SIZE!!!
       BS   G8A35
       CLOG >08,@PABPTR       Use defualt SIZE option
       BR   G8A33
       ST   VWIDTH,@PABPTR+1  Limit current record length
       CALL SIZE1
G8A33  BR   ACCPZ1
G8A35  CLOG >08,@PABPTR       SIZE option used somewhere
       BS   G8A66
* We're sure now that SIZE has been used WITHOUT the AT
* option, this means that we should set XPT to point behind
* the SIZE field. This can be done by adding the record
* length to the current screen base address and the line's
* screen base address
       ST   @CCPADR+1,@XPT    Start of with current address
       ADD  @RECLEN,@XPT      Add in the current record len
       SUB  >DF,@XPT          And subtract the lower base a
*                             Also adjust for edge characte
       ST   @XPT,[email protected]     Save it for "try again" case
*                              in WARNING, XPT gets changed
ACCPZ1 DST  @CCPADR,[email protected]  Save for "try again" case
       ST   @RECLEN,[email protected]  Save for "try again" case
***********************************************************
* ENTRY POINT FOR "TRY AGAIN" CASE WHEN SIZE OR ACCEPT USED
***********************************************************
ACCPZ9 CLOG >80,@PABPTR       Blank current field
       BR   G8A58
       ST   SPACE+OFFSET,V*CCPADR
G8A58  DINC @CCPADR           Update screen address
       DEC  @RECLEN           Reduce count, always at least
       BR   ACCPZ9            Loop until at end of field
       DDEC @CCPADR           Fix end of field for maximum
       DST  @CCPADR,@VARA     Set highest location availabl
       DST  @VARA,@ARG2       Also highest location availab
*                              OK all set to go
G8A66  CEQ  1,[email protected]        Skip if in "try again"
       BS   ACCPZ7
       DST  @VSPTR,@VAR4      Save first entry in V-stack
       CALL BUG01             Collect the symbol designator
* Above call fixes bug.       Take care of arrays too
       XML  VPUSH             Save symbol table entry
ACCPZ7 DST  @VARW,[email protected]    Save for trying again case
       DST  @VARA,[email protected]    Save for trying again case
***********************************************************
* ENTRY POINT FOR "TRY AGAIN" WHEN NEITHER SIZE OR ACCEPT I
***********************************************************
* In case a CALL CLEAR or ERASE ALL or CALL HCHAR has just
* processed, EDGE CHARS, are gone at the bottom line
ACCPZ5 CLOG >0C,@PABPTR       If AT/SIZE used, maximum fiel
       BR   AZ1                is line, so no need to worry
*                              about it
       DST  >7F7F,[email protected]>02FE     Put the EDGE CHAR back
AZ1    DEX  @VSPTR,@VAR4      Don't destroy V-stack on BREA
       CALL READL1            Ask for some input that can b
*                             used
       DEX  @VSPTR,@VAR4      Resote V-stack pointer
* At this point, VARA contains the highest location used,
* and VARW contains the string's start address
ACCPZ2 DCEQ @VARW,@VARA       Only non-empty string
       BS   G8A9E
       DDEC @VARA             Go to the next position
       CEQ  SPACE+OFFSET,V*VARA
       BS   ACCPZ2
       DINC @VARA             Back to the last space
G8A9E  XML  VPOP              Check the symbol designator i
       XML  VPUSH             a string or numeric variable
       CEQ  >65,@FAC2         If numeric : empty string is
       BS   G8AB2
       DCEQ @VARA,@VARW       If an empty string was entere
       BR   G8AB2
       CALL WARNZZ            *** INPUT ERROR ***
       BYTE 32
       BR   ACCPZ8
G8AB2  DCLR @BYTES            Compute length of input strin
       DST  @VARW,@SREF       Use SREF as temporary variabl
G8AB7  DCEQ @VARA,@SREF
       BS   G8AC8
       CEQ  EDGECH,V*SREF     Exclude edge character
       BS   G8AC4
       DINC @BYTES
G8AC4  DINC @SREF             Decrement the counter
       BR   G8AB7
G8AC8  CALL CTSTR0            Create a temporary string
ACCPZ3 DCEQ @VARA,@VARW
       BS   G8AEB
       CEQ  EDGECH,V*VARW     Skip the edge character
       BR   G8ADC
       DADD 4,@VARW
       BR   ACCPZ3
G8ADC  ST   V*VARW,V*SREF     Copy the string
       SUB  OFFSET,V*SREF     Subtract the screen offset
       DINC @VARW             Update pointers
       DINC @SREF
       BR   ACCPZ3            Result can't be 0
G8AEB  CEQ  STRVAL,@FAC2      Numerical variable
       BS   ACCPZ6
       ST   STRVAL,@FAC2      Create temp string
       CALL VALCD             Use VAL code for translation
       BR   ACCPZ6            No error - ok go on
WRNSNM CALL WARNZZ            Error
       BYTE 7               * STRING NUMBER MISMATCH
ACCPZ8 CLOG >08,@PABPTR       If SIZE is used
       BS   G8B0A
       CLOG >04,@PABPTR       Also AT is not used
       BR   G8B0A
       ST   [email protected],@XPT     Restore XPT : in WARNING XPT
G8B0A  DST  [email protected],@VARW    Restore @VARA, @VARW
       DST  [email protected],@VARA
       ST   1,[email protected]        Set the "try again" flag
       CLOG >08,@PABPTR       If SIZE is not used
       BR   G8B20
* IF ACCEPT ALSO NOT USED. GOTO "TRY AGAIN" FORM HERE
       CLOG >04,@PABPTR
       BS   ACCPZ5
* IF "EITHER SIZE OR ACCEPT IS USED" THEN
G8B20  DST  [email protected],@CCPADR  Restore CCPADR
       ST   [email protected],@RECLEN  Restore RECLEN
       BR   ACCPZ9            Go blanking the field and
*                              "try again"
ACCPZ6 XML  ASSGNV            Should be ok now
       CLOG >0C,@PABPTR       Test usage of AT and/or SIZE
       BR   ACCPZ4            At least one of the two used
       XML  SCROLL            Scroll the screen up
       ST   3,@XPT            And reset XPT
ACCPZ4 XML  CONT
***********************************************************
*                  READ STATEMENT
* Assign DATA values to variables in READ-list one at a
* time. Possibly search for new DATA statements if the
* current DATA statement has been used. Be careful with
* null entries...!!!
***********************************************************
G8B38  XML  PGMCHR            Get character following ","
READ   CALL BUG01             Get pointers and correct entr
* Above call fixes bug.        also allow for array variabl
       XML  VPUSH             Push on Vstack for assignment
       CZ   @DATA             DATA ERROR
       BS   ERRDAT
       CALL GETGFL            Get next data item (RAM/GROM)
       CEQ  STRVAL,@FAC2
       BS   G8B6B
       CEQ  NUMZ,@VAR0+1      Not a numeric
       BR   ERRSNM
*                              string-number mismatch error
       CALL CHKSZ0            Build up string info
       DINC @FAC6             Force legal delimiter on end
       CALL LITS05            Copy numeric into string spac
       DST  @SREF,@FAC12      Copy string start address
       DADD @FAC6,@SREF       Compute end address of string
       DDEC @SREF             Back up over delimiter
       CALL CONVER            Convert string to number
       DCEQ @SREF,[email protected]    WRONG!!!!!!!
       BR   ERRDAT
       BR   G8B73
G8B6B  CALL CHKSTR            Check string input
       BS   ERRDAT            Give error on error
       CALL LITS05            Allocate string in string spa
G8B73  XML  ASSGNV            Assign variable
       CALL GETGFL            Get next datum from DATA stmt
       CEQ  COMMAZ,@VAR0+1    Has to be an end of DATA
       BS   G8B8F
       CZ   @VAR0+1           Check for end of data
       BR   ERRDAT
       DDECT @LNBUF           Pointer to line # of DATA stm
       CLR  @DATA             Assume the worst - no more DA
       DCEQ @STLN,@LNBUF
       BS   G8B8F
       DDEC @LNBUF            Next line's 1st token address
       CALL DATAST            Get next DATA statement
G8B8F  CEQ  COMMAZ,@CHAT      Worry about junk in CONT
       BS   G8B38
       XML  CONT
* SRDATA-Search for DATA statements (DATA statement must
* be the only statement on one line)
* SEARCH-also used for searching IMAGE statement.
SRDATA ST   DATAZ,@FAC2       Search for a DATA token
SEARCH DEX  @DATA,@PGMPTR     Exchange with normal PC
       EX   @CHAT,@VAR0+1     Preserve current PGM characte
       CZ   @PRGFLG           If imperative statement
       BR   G8BB3
       CZ   @RAMTOP           With ERAM : text itself in ER
       BS   G8BB3
       ST   >FF,@RAMFLG       Fake RAMFLG in this case
       XML  PGMCHR            Get first character on the li
       CLR  @RAMFLG           Restore it back
       BR   SRDAZ1            Skip that PGMCHR
G8BB3  XML  PGMCHR            Get first character on the li
SRDAZ1 CEQ  @FAC2,@CHAT       Search for specific token
       BS   SRDAZ0
       CEQ  @>8300,@>8300     Set COND if no DATA found
SRDAZ0 DEX  @DATA,@PGMPTR     Exchange won't affect the CON
       EX   @CHAT,@VAR0+1     Situation ok
       RTNC                   Return to caller with COND
***********************************************************
*                     OLD STATEMENT
* A normal load:
*   Get a program from an external device to VDP and
*   reinitialize the program pointers. Also update the line
*   pointer table, since the memory size of the machine on
*   which the program was created doesn't have to be the
*   same as on the current system!!!! Then check if ERAM
*   existed, move it to ERAM if does exist (in relocated
*   from)
* Load a sequential file:
*   When program is bigger than 13.5K and ERAM exists,
*   maximum-length record reads are preformed to read the
*   file and each record is copied into the ERAM as it is
*   read.
***********************************************************
OLD    CALL OLD1              Make OLD1 a subroutine for LO
       B    TOPL15            Go back to top level
OLD1   CALL GPNAME            Get program name & reinitiali
       XML  PGMCHR            Check for EOL
       DST  @PABPTR,@STADDR   Compute memory start address
       DADD [email protected](@PABPTR),@STADDR    Add PAB-name lengt
       DADD PABLEN-4,@STADDR              and PAB length
       DST  @>8370,[email protected](@PABPTR)  Compute # of availiable
       DSUB @STADDR,[email protected](@PABPTR)
       DINC [email protected](@PABPTR)    Include current address
       DST  @STADDR,[email protected](@PABPTR) for copy start
       ST   CZLOAD,[email protected](@PABPTR)   Select LOAD I/O code
       CALL CDSR              Call device service routine
       BR   OLDZ3             Not a program file, may be a
*                              sequential file
* STADDR still points to the info bytes
       DST  [email protected](@STADDR),@MNUM First test checksum
       DXOR [email protected](@STADDR),@MNUM  which is a simple XOR
       DCEQ @MNUM,V*STADDR     Try PROTECTION option
       BS   G8C15
       DNEG @MNUM
       DCEQ @MNUM,V*STADDR    No-ERROR
       BR   OLDER
       OR   >80,@FLAG         Yes, set LIST/EDIT PROTECTION
       BR   G8C17
G8C15  CLR  @FLAG             Otherwise clear protection
G8C17  DST  [email protected](@STADDR),@ENLN  Copy new ENLN,
       DST  [email protected](@STADDR),@STLN   STLN and
       DST  [email protected](@STADDR),[email protected] top of memory info
       DADD 8,@STADDR         Point to program data
       DST  @>8370,[email protected]   Set up the new top
       CALL RELOCA            Relocate according to @>8370
OLDZ5  CZ   @RAMTOP           ERAM present?
       BS   LRTOPZ
*                             No, go back to toplevel
*                             Yes, move from VDP to ERAM
*                             (in relocated form)
************ Move to the ERAM from CPUBAS first ***********
       DST  @>8370,@VAR0
       DSUB @STLN,@VAR0
       DINC @VAR0             # of bytes to move
       DST  @VAR0,@CCC        @CCC : Byte count for VGWITE
       DST  CPUBAS,@BBB       @BBB : Destination addr on ER
       DST  @BBB,@STADDR      For later use as the base of
*                              current program image in REL
       DST  @STLN,@AAA        @AAA : Source address on ERAM
       XML  VGWITE            Move from VDP to ERAM
       DST  @>8370,[email protected]   Set up old memory top
       DST  @RAMTOP,[email protected]  Set up new memory top
       CALL RELOCA            Relocate the program image
OLDZ7  DST  @STLN,@RAMFRE     Reset the RAMFRE on ERAM
       DDEC @RAMFRE
       BR   LRTOPZ            Go back to toplevel
***********************************************************
* At this point : if ERAM not exist - ERROR off else open
* sequential file to load program to ERAM through VDP RAM
***********************************************************
OLDZ3  CZ   @RAMTOP
       BS   OLDER
* Set up PAB for OPEN
* File type : Sequential file,
* Mode of operation : Input
* Date type : internal
* Record type : Variable length records
* Logical record length : 254 maximum
       MOVE 9,[email protected],[email protected](@PABPTR) Build the PAB          <<
       DST  @>8370,@FAC       Compute the data buffer addre
       DSUB 253,@FAC
       DST  @FAC,@AAA         Save it for later use in VGWI
       DST  @FAC,[email protected](@PABPTR)
       CALL CDSR              Call the device service routi
       BR   ERRZ2B            Return with ERROR indication
*                              in COND
* Start to read in file
       CALL IOCALL            Read in the first record
       BYTE CZREAD          *
* Check the control information
       CEQ  10,[email protected](@PABPTR) * 10 bytes contr info
       BR   OLDER
* >ABCD is the flag set at SAVE time indicating a program f
       DCEQ >ABCD,V*FAC
       BR   OLDER
       DINCT @FAC
       DST  V*FAC,@STLN       Copy the new STLN
       DINCT @FAC
       DST  V*FAC,@ENLN       ENLN too
       DST  @ENLN,@MNUM       Test checksum
       DXOR @STLN,@MNUM
       DINCT @FAC
       DCEQ @MNUM,V*FAC       Try PROTECTION option
       BS   G8CBD
       DNEG @MNUM
       DCEQ @MNUM,V*FAC       No, ERROR
       BR   OLDER
       OR   >80,@FLAG         Yes, set LIST/EDIT PROTECTION
       BR   G8CBF
G8CBD  CLR  @FLAG             Otherwise clear protection fl
G8CBF  DINCT @FAC
* Check is there enough memory in ERAM
       DST  V*FAC,@MNUM       Get the old top of memory out
       DST  @MNUM,[email protected]    For later use in RELOCA
       DSUB @STLN,@MNUM
       DINC @MNUM             Total # of bytes in program
       DST  @MNUM,@CCC1       For later use as the byte cou
       DADD CPUBAS,@MNUM      Add the total # of bytes to C
* Check if enough memory in ERAM
       GT                     Greater than >FFFF case
       BS   OLDER
       DCH  @RAMTOP,@MNUM     Greater than >DFFF case
       BS   OLDER
* Move to ERAM starting from CPUBAS first,
* then relocate according the new top of memory in ERAM
OLZZ   DST  CPUBAS,@BBB       @BBB : Destination addr in
*                                    ERAM FOR VGWITE
       DST  @BBB,@STADDR      For later use as base of the
*                      current program image in ERAM RELOCA
*      DST  >8370,@AAA        @AAA has been set up before
*      DSUB 253,@AAA          For copy start on VDP RAM
* @CCC1 : Total # of bytes to move to ERAM, set up above
       CALL IOCALL            Read in the second record
       BYTE CZREAD
* Read in the file and each record
* Should be a full (maximum length 254) record at this time
* because program supposed to be bigger than 13.5K
G8CE9  CEQ  254,[email protected](@PABPTR)
       BR   OLDER
       DST  254,@CCC          @CCC : # of bytes to move
       XML  VGWITE            Move data from VDP to ERAM
       DADD 254,@BBB          Update the destination addres
*                              on ERAM
       DSUB 254,@CCC1         # of bytes left to move
       BS   OLDZ9             No more bytes to move
       CALL IOCALL            Read in the file and each rec
       BYTE CZREAD          * Copied into ERAM as it is rea
       DCHE 254,@CCC1         Leave the last record alone
       BS   G8CE9
* The record length should be the same as the # of bytes le
* to move at this time
       CEQ  @CCC1+1,[email protected](@PABPTR)
       BR   OLDER
       DST  @CCC1,@CCC        Set up byte count for the las
       XML  VGWITE            Move data from VDP to ERAM
OLDZ9  CALL IOCALL            Close the file
       BYTE CZCLOS
       DST  @RAMTOP,[email protected]  New top of memory
* [email protected] : old top of memory, set up above
* @STADDR  : base of current program image in ERAM, set abo
       CALL RELOCA            Relocate the program
       BR   OLDZ7             Go to set the RAMFRE and back
*                              toplevel
PAB3   BYTE >00,>1C,>00,>00,>FE,>00,>00,>00,OFFSET
* OLD error exit code, don't kill machine
OLDER  CALL INITPG            Initialize program space
       BR   ERRZ2             And take error exit
LRTOPZ CALL KILSYM            Release string space/symbol t
       RTN
***********************************************************
* RELOCATE THE PROGRAM IMAGE ACCORDING TO THE NEW TOP OF
* MEMORY:
*         STLN         : old STLN
*         ENLN         : old ENLN
*         [email protected]     : old top of memory
*         [email protected]     : new top of memory
*         @STADDR      : current base for the old image
***********************************************************
RELOCA DST  @PABPTR,[email protected]  Save in temp.
       DST  [email protected],@MNUM    Get the old top of memory
       DST  [email protected],@PABPTR  Get the new top of memory
       DSUB @MNUM,@ENLN       Compute ENLN relative to top
       DSUB @MNUM,@STLN       Compute STLN relative to top
       DSUB @STLN,@STADDR     Highest memory address used
       DCLR @MNUM             Total # of bytes to be moved
       DSUB @STLN,@MNUM       STLN = -(# bytes -1)
       DINC @MNUM             Take care of that one
       DADD @PABPTR,@ENLN     Compute new address of ENLN
       DADD @PABPTR,@STLN      and STLN
* @PABPTR : destination address, @STADDR : source address
       DST  @MNUM,@ARG        @ARG   : byte count
       DST  @STADDR,@VAR0     @VAR0  : source addr for MVDN
       DST  @CCPPTR,@VAR5     Save in temp (CCPPTR, VARY2 E
       DST  @PABPTR,@VARY2    @VARY2 : destination addr for
       DCEQ @RAMTOP,[email protected]  Relocate the program
       BR   G8D6F              in ERAM
       XML  MVDN              Move from lower memory to hig
*                              memory one byte at a time
       BR   G8D7E
G8D6F  DCLR [email protected]          Clear a temporary variable
       DEX  @RAMTOP,[email protected]  Save the RAMTOP, also fake as
*                         if ERAM not exist for MVDN in thi
       XML  MVDN              Move in VDP
       DEX  @RAMTOP,[email protected]  Restore RAMTOP
G8D7E  DST  @VAR5,@CCPPTR     Restore back
* Update line # links according to new size
       DST  [email protected],@MNUM    Old memory top
       DSUB [email protected],@MNUM    Stop if sizes are same
       BS   RELOZ1
       DST  @STLN,@STADDR     Start relocation at STLN
OLDZ2  DCHE @STADDR,@ENLN      and continue up to ENLN
       BR   RELOZ1
       DINCT @STADDR          Skip the line #
       CEQ  @RAMTOP,[email protected]  If in ERAM
       BR   G8DAB
       CALL GRSUB2            Read the link out
       BYTE STADDR
       DSUB @MNUM,@EEE1       Update
       CALL GWSUB             Write it back
       BYTE >0A,>58,>02     * STADDR,EEE1,2
       BR   G8DAF
G8DAB  DSUB @MNUM,V*STADDR    Upadate the link
G8DAF  DINCT @STADDR          Skip the link, next line #
       BR   OLDZ2             And continue until done
RELOZ1 DST  [email protected],@PABPTR  Restore from temp
       RTN
***********************************************************
*                    SAVE STATEMENT
* SAVE "NAME", MERGE : Save in crunched form in program
*  into a file one line at at time with the line number.
*  File opened with sequential accessed, variable-length
*  records (161 max), display type & output mode, move one
*  line number and one in text to the crunch buffer then
*  write to the file one line at a time.
* A normal SAVE : When ERAM not exist or the size of the
*  program and line number table in ERAM can fit in VDP
*  (can be moved into VDP from ERAM once), then the save
*  statement saves a program image to an external device,
*  including all the information the system needs for
*  rebuilding the program image on a machine with a
*  different memory size, also included is a checksum for
*  rudimentary error checking and for PROTECTION VIOLATION
* A sequential SAVE : Maximum-length records are performed
*  to write the file and each record is copied into the VDP
*  from ERAM before it is written.
***********************************************************
SAVE   CLOG >80,@FLAG         * PROTECTION VIOLATION
       BR   ERRPV
       CALL GPNAME            This will also close all file
* Check SAVE "NAME", MERGE or SAVE "NAME", PROTECTED first
       CLR  [email protected]          Clear "PROTECTED" flag
       XML  PGMCHR
       CZ   @CHAT             EOL?
       BS   SAZ1              Yes, no need to check any opt
       CEQ  COMMAZ,@CHAT      Has to be a comma here
       BR   ERRSYN
       DCEQ >C805,V*PGMPTR    Unquoted string with length 5
*                              has to be MERGE at this time
       BR   G8DF4
       DCEQ >4D45,[email protected](@PGMPTR) "ME" of MErge
       BR   ERRSYN             If not : SYNTAX ERROR
       DCEQ >5247,[email protected](@PGMPTR) "RG" of meRGe
       BR   ERRSYN             If not : SYNTAX ERROR
       CEQ  >45,[email protected](@PGMPTR)   "E" of mergE
       BR   ERRSYN             If not : SYNTAX ERROR
       CZ   [email protected](@PGMPTR)      Check for EOL
       BR   ERRSYN            Not EOL : SYNTAX ERROR
       BR   SAVMG             Go to handle this option
* Has to be PROTECTED option here, crunched as unquoted str
G8DF4  DCEQ >C809,V*PGMPTR    Unquoted string with length 9
*                              has to be PROTECTED
       BR   ERRSYN
       DCEQ >5052,[email protected](@PGMPTR) "PR" of PRotected
       BR   ERRSYN             If not : SYNTAX ERROR
       DCEQ >4F54,[email protected](@PGMPTR) "OT" of prOTected
       BR   ERRSYN             If not : SYNTAX ERROR
       DCEQ >4543,[email protected](@PGMPTR) "EC" of protECted
       BR   ERRSYN             If not : SYNTAX ERROR
       DCEQ >5445,[email protected](@PGMPTR) "TE",of protecTEd
       BR   ERRSYN             If not : SYNTAX ERROR
       CEQ  >44,[email protected](@PGMPTR)  "D" of protecteD
       BR   ERRSYN             If not : SYNTAX ERROR
       CZ   [email protected](@PGMPTR)     Check EOL
       BR   ERRSYN
       INC  [email protected]
***********************************************************
SAZ1   CZ   @RAMTOP           If ERAM NOT present then
       BR   G8E42
***** CLEAR THE BREAKPOINT IN VDP ALONE TO SPEED UP *******
       DST  @STLN,@FAC8       End of line # buffer
G8E33  AND  >7F,V*FAC8        Clear the breakpoint
       DADD 4,@FAC8           Move to the next one
       DCH  @ENLN,@FAC8       Until done
       BR   G8E33
       BR   VSAVZ
G8E42  CALL UBSUB             Clear the breakpoint in ERAM
       DST  @RAMTOP,@MNUM     Top of memory in ERAM
       DSUB @STLN,@MNUM
       DINC @MNUM             # of bytes total in ERAM
       DST  @>8370,@VAR0      Top of memory in VDP
       DSUB @MNUM,@VAR0
       DINC @VAR0
* Check is there enough memory in VDP to move the program
*  text and line number table from ERAM to VDP
       GT                  Not enough memory in VDP for sur
       BR   GSAVE
       DST  VRAMVS+64+256,@VAR5 * 64 bytes ar for safety bu
 
* DSR routine give file error when loading a program which
*  VDP maximum size and was saved from VDP to be a program
*  on disk when ERAM not exist. In order to fix this proble
*  restrict the program memory to be 256 bytes less then th
*  real space in VDP when ERAM not exist.
       DCHE @VAR5,@VAR0       Not enough memory in VDP, do
*                              sequential file save
       BR   GSAVE
       DSUB 10,@VAR5        * 10 bytes for control informat
       CALL GVMOV             Enough memory in VDP, move it
*                             over and do the normal save l
**************** Without ERAM, or after GVMOV *************
**************** do the normal save           *************
VSAVZ  DST  @FREPTR,@STADDR   Store additional control info
       DDEC @STADDR           Back up some more for 2 byte
       DST  @>8370,V*STADDR   First current top of memory
       DDECT @STADDR
       DST  @STLN,V*STADDR    Then STLN
       DDECT @STADDR
       DST  @ENLN,V*STADDR    Then ENLN
       DDECT @STADDR          Then
       DST  @STLN,V*STADDR
       DXOR @ENLN,V*STADDR    STLN XORed with ENLN
       CEQ  1,[email protected]        Check is there PROTECTED opti
       BR   G8E91
       DNEG V*STADDR          Negate the CHECKSUM to indica
*                             LIST/EDIT protection
G8E91  DST  @STADDR,[email protected](@PABPTR)  Save start address in P
       DDEC @STADDR
       DST  @>8370,[email protected](@PABPTR)   Compute # of bytes used
       DSUB @STADDR,[email protected](@PABPTR)   and store that in PAB
       CZ   @RAMTOP           If ERAM exists then
       BS   G8EAD
       DST  @BBB1,@STLN       Restore the original STLN, EN
       DST  @CCC1,@ENLN        which points to ERAM
G8EAD  CALL IOCALL            Call Device Service Routine f
       BYTE CZSAVE          * SAVE operation
LRTOPL CALL KILSYM            Release string space/symbol t
       B    TOPL15            Go back to toplevel
***********************************************************
* Open the sequential file, set the PAB
* File type             : sequential file
* Mode of operation     : output
* Data type             : internal
* Record type           : variable length records
* Logical record length : 254 maximum
GSAVE  MOVE 9,[email protected],[email protected](@PABPTR) Build the PAB
       DECT [email protected](@PABPTR)    Put in the correct I/O mode :
* Compute the data buffer address
       DST  @>8370,@FAC
       DSUB 253,@FAC
       DST  @FAC,[email protected](@PABPTR)
       DST  @FAC,@EEE1     Save it for later use in GVWITE
       CALL CDSR           Call device service routine to o
       BR   ERRZ2B         Return with ERROR indication in
*                          Put 8 bytes control info at the
*                          beginning of the data buffer
       DST  >ABCD,V*FAC       >ABCD indentifies a program f
       DINCT @FAC              when doing LOAD later
       DST  @STLN,V*FAC       Save STLN in control info
       DINCT @FAC
       DST  @ENLN,V*FAC       ENLN too
       DINCT @FAC
       DST  @STLN,V*FAC
       DXOR @ENLN,V*FAC       Save the checksum
       CEQ  1,[email protected]        Check is there PROTECTED opti
       BR   G8EFB
       DNEG V*FAC             Negate the CHECKSUM to indica
*                              the LIST/EDIT protection
G8EFB  DINCT @FAC
       DST  @RAMTOP,V*FAC     Save the top of memory info
       ST   10,[email protected](@PABPTR) Set the caracter count in PAB
       CALL IOCALL            Call device service routine
       BYTE CZWRIT          * With I/O opcode : write, to s
*                       the control info for the first reco
* Now start to use maximum-length record to write the file
* and each record is copied into the VDP from ERAM bofore i
* is written
       DST  @STLN,@DDD1       Starting address on ERAM
*      DST  @>8370,@EEE1      @EEE1 has been set up before
*      DST  253,@EEE1         Starting address of the data
*                              buffer on VDP
       DST  @RAMTOP,@CCC1
       DSUB @STLN,@CCC1
       DINC @CCC1
       ST   254,[email protected](@PABPTR) Set the character count of P
G8F1C  DST  254,@FFF1         @FFF1 byte count
       XML  GVWITE            Move data from ERAM to VDP
       CALL IOCALL            Call device service routine
       BYTE CZWRIT
       DADD 254,@DDD1         Update the source addr on ERA
       DSUB 254,@CCC1         # of bytes left to move
       BS   GSAV1             No more bytes to save
       DCHE 254,@CCC1         Leave the last record alone
       BS   G8F1C
* Move the last @CCC1 bytes from ERAM to VDP
       DST  @CCC1,@FFF1       @FFF1 : Byte count
       XML  GVWITE            Write data from ERAM to VDP
       ST   @CCC1+1,[email protected](@PABPTR) Update the character cou
*                                   in PAB
       CALL IOCALL            Call device service routine
       BYTE CZWRIT
GSAV1  CALL IOCALL
       BYTE CZCLOS          * Close the file
       BR   LRTOPL            Continue
***********************************************************
* Move the program text & line # table to VDP, and relocate
GVMOV  DST  @STLN,@BBB1       Save STLN, ENLN for later use
       DST  @ENLN,@CCC1
       DST  @STLN,@DDD1       Source addr on ERAM
       DST  @VAR5,@EEE1       Destination addr on VDP
       DST  @EEE1,@STADDR     Use later for RELOCA
       DST  @RAMTOP,@FFF1
       DSUB @STLN,@FFF1       # of bytes to move
       DINC @FFF1             @FFF1 : byte count for GVWITE
       XML  GVWITE            Move from ERAM to VDP
       DST  @RAMTOP,[email protected]  Set up @RAMTOP for old top
*                             of memory
       DST  @>8370,[email protected]   Set up @>8370 for new top
*                             of memory
       CALL RELOCA            Relocate the program
       DST  @STLN,@FREPTR     Set up @FREPTR
       DDEC @FREPTR
       RTN
***********************************************************
* Save the crunched form of a program into a file.
* Move the line number and text to the crunch buffer, then
* write to the file one line at a time.
***********************************************************
* Open the file with:
*  I/O opcode            : OPEN
*  File type             : SEQUENTIAL file
*  Mode of operation     : OUTPUT
*  Data type             : DISPLAY type data
*  Record type           : VARIABLE LENGTH records
*  Data buffer address   : Crunch buffer address
*  Logical record length : 163 (length of curnch buffer + 2
*                                bytes for line #) maximum
SAVMG  MOVE 9,[email protected],[email protected](@PABPTR) Build PAB
       CALL IOCLZ1         Call the DSR routine to open fil
       DST  @ENLN,@FAC6    Start from the first line #
       DSUB 3,@FAC6        @FAC6 now points to the 1st line
*                          Write to the file from crunch bu
*                           one line at a time
G8F88  CLR  @VAR0             Make it a two byte later
       CZ   @RAMTOP           If ERAM exists then
       BS   G8FB6
       DST  @FAC6,@DDD1       Write the 4 bytes (line # and
*                              line pointer) from ERAM to
*                              crunch buffer
*                             @DDD1 : Source address on ERA
       DST  CRNBUF,@EEE1      @EEE1 : Destination address
*                                      on VDP
       DST  4,@FFF1           @FFF1 : byte count
       XML  GVWITE            Write data from ERAM to VDP
       DST  [email protected]+2,@DDD1  Line pointer now points to
*                              length byte
       DDEC @DDD1             Get the length of this line
*                             @DDD1 : Source address on ERA
       DINC @FFF1             @FFF1 : Byte count, coming ba
*                                     from GVWITE above, =0
       XML  GREAD1            Read the length byte from ERA
       ST   @EEE1,@VAR0+1     @EEE1 : Destination addr on C
       DST  CRNBUF+2,@EEE1    Write the text from ERAM to 3
*                             byte of crunch buffer
*                             @EEE1 : Destination addr on V
*                             @DDD1 : Source addr on ERAM
       DINC @DDD1             Back to point to the text
       DST  @VAR0,@FFF1       @FFF1 : Byte count
       XML  GVWITE            Write data from ERAM to VDP
       BR   G8FCD             ERAM not exist : line # table
*                              and text in VDP
G8FB6  DST  V*FAC6,[email protected]   PUT THE LINE # IN
       DST  [email protected](@FAC6),@FAC2  Get the line pointer out
       DDEC @FAC2             Line pointer now points to th
*                              length byte
       ST   V*FAC2,@VAR0+1    Get the length out
* Move the text into the crunch buffer
       MOVE @VAR0,[email protected](@FAC2),[email protected]+2
G8FCD  AND  >7F,[email protected]      Reset possible breakpoint
       DINCT @VAR0    * Total length=text length+line # len
       ST   @VAR0+1,[email protected](@PABPTR) Store in the cahracter c
       CALL IOCALL            Call the device service routi
       BYTE CZWRIT          * Write
       DSUB 4,@FAC6           Go to the next line #
       DCHE @STLN,@FAC6       Finish moving all
       BS   G8F88
       DST  >FFFF,[email protected]    Set up a EOF for the last rec
       ST   2,[email protected](@PABPTR)  Only write this 2 bytes
       CALL IOCALL            Call the device service routi
       BYTE CZWRIT          * Write
       CALL IOCALL            Call the device service routi
       BYTE CZCLOS          * Close the file
       BR   LRTOPL            Go back to top level
PAB1   BYTE >00,>12,>08,>20,>A3,>00,>00,>00,>60
*           >0820 = CRNBUF
*           >A3   = 163
*           >60   = OFFSET
***********************************************************
*                   MERGE ROUTINE
* MERGE load a file which is in crunched program form into
* the CRNBUF one record (one in) at a time then take the
* line # out in FAC, text length into @CHAT, and edit it
* into the program. Identify EOF by the last record which
* is set up at SAVE time.
***********************************************************
MERGE  CALL GPNAME            Close all file, set up PAB
       CLOG >80,@FLAG         Check PROTECTION VIOLATION
       BR   ERRPV
* To fix the bug #06 in MERGE
       XML  PGMCHR            Check EOL
       CZ   @CHAT
       BR   ERRSYN            Not EOL : SYNTAX ERROR
* Open the file with
*  I/O opcode            : OPEN
*  File type             : SEQUENTIAL file
*  Mode of operation     : INPUT
*  Data type             : DISPLAY type data
*  Record type           : VARIABLE LENGTH records
*  Data buffer address   : crunch address
*  Logical record length : 163 maximum
       MOVE 9,[email protected],[email protected](@PABPTR)  Set up PAB
       INCT [email protected](@PABPTR)    Put in correct I/O mode : >14
       CALL IOCLZ1            Call the device service routi
*                              to open the file
       CALL IOCALL            Call the device service routi
       BYTE CZREAD          *  to read
       DCEQ >FFFF,[email protected]    If 1st rec is EOF
       BS   ERRZ2B
G902A  DCLR @>83D6            Read in one line and edit it
*                              program
       ST   [email protected](@PABPTR),@CHAT Length of this record
       DECT @CHAT             Text length = total length-2
*                                          (line # length)
*                              Put it in @CHAT for EDITLN
       DST  [email protected],@FAC     Put the line # in @FAC for ED
       CLR  @FAC12            Make it a double byte
       ST   @CHAT,@FAC13
* Move the text up 2 bytes
       MOVE @FAC12,[email protected]+2,[email protected]
       DST  @PABPTR,[email protected]  SAVE PAB POINTER
       CALL EDITLN            EDIT IT TO THE PROGRAM
       DCLR @PABPTR           Clear temporary PAB pointer
       DEX  [email protected],@PABPTR  Restore old PAB pointer
       CALL IOCALL            CALL THE DEVICE SERVICE ROUTI
       BYTE CZREAD          *  read another record or anoth
*                              line
       DCEQ >FFFF,[email protected]    End of EOF
       BR   G902A
* Double check EOF record
MERGZ1 CEQ  2,[email protected](@PABPTR)  I/O ERROR
       BR   ERRZ2B
       CALL IOCALL            Call the device service routi
       BYTE CZCLOS          *  close the file
       BR   LRTOPL            Go back to top level
***********************************************************
*                  LIST ROUTINE
* List lists a readable copy of the current program imnage
* to the specified device. In case no device is specified,
* the listing is copied to the screen.
*  This routine uses the fact that ERRZZ returns to the
* caller if the call has been issued in EDIT which will
* reinitiate the variable stuff.
***********************************************************
LIST   CLOG >80,@FLAG         PROTECTION VILOATION ERROR  <
       BR   ERRPV                                         <
       DCLR @CURLIN           Create some kind of control <
       DCLR @CURINC            for defaults               <
       ST   MINUS,@VARC       Select "-" as separator     <
* GKXB GKLIST label
       CALL GTLIST            GKXB pick up length
* If either CURLIN or CURINC is non-zero, use it
* For zero values replace the default (ENLN-3, STLN)
       DCZ  @CURLIN
       BR   G9094
       DST  @ENLN,@DDD1       Get the first lines line #
       DSUB 3,@DDD1           DDD1 : Source address on ERAM
       CALL GRSUB3            Read the line # from ERAM/VDP
       BYTE DDD1            * @DDD1 : Source address on ERA
*                             Reset possible breakpoint too
       DST @EEE1,@CURLIN      Use standard default
       DCZ @CURINC
       BR  G9094
LISTZ0 CALL GRSUB3            Read last line # from ERAM/VD
       BYTE STLN           *  @STLN : Source address on ERA
*                             Reset possible breakpoint too
       DST  @EEE1,@CURINC     @EEE1 : Destination address o
*                             Also default for end line
* Now first evaluate what we've got in CURLIN
G9094  DCZ  @CURINC           Check for combination xxx-
       BR   G90A6
G9098  DDEC @VARW             Backup to the separation mark
       CEQ  SPACE+OFFSET,V*VARW
       BS   G9098
       CEQ  MINUS+OFFSET,V*VARW Select last
       BS   LISTZ0
G90A6  DCHE @CURLIN,@CURINC   If something like LIST 15-11
       BS   G90AE
       DST  @CURLIN,@CURINC   Replace byt LIST 15-15
G90AE  DST  @CURLIN,@FAC      Prepare for line # search
       XML  SPEED             Search the line number table
       BYTE SEETWO
       DST  @EXTRAM,@CURLIN   Get first real line # in CURL
       DST  @CURINC,@FAC
       XML  SPEED
       BYTE SEETWO          * Evaluate second line #
       CALL GRSUB3            Read 2 bytes of data from ERA
       BYTE EXTRAM          * @EXTRAM : Source addr on ERAM
*                             Reset possible breakpoint too
       DCH  @CURINC,@EEE1
       BR   G90CA
       DADD 4,@EXTRAM         Else take next lower line
G90CA  DST  @EXTRAM,@CURINC   Which could be equal to CURLI
       DST  @CURLIN,@EXTRAM   For use below by LIST
       DDEC @PGMPTR           Backup to last CHAT
       XML  PGMCHR            Retrieve last CHAT
       CZ   @CHAT             Device name available
       BS   G9132
       CALL CLSALL            Close all files that are open
       DST  VRAMVS,@VSPTR     Re-initialize the V-stack
       DST  @VSPTR,@STVSPT    And it's base
       XML  PGMCHR            Get name length in CHAT
       DST  VRAMVS+16,@PABPTR Get entrypoint in PAB
       CLR  @DSRFLG           Indicate device I/O
       MOVE 9,[email protected],[email protected](@PABPTR)
       DST  VRAMVS+16+NLEN,@CCPADR Select start address
*                                   for copy
* GKXB GTLENGTH label
       CALL GTLENG            GKXB Set length in PAB
       INC  @FAC2             Plus length byte
LISTZ1 ST   @CHAT,V*CCPADR    Copy the bytes one by one
       XML  PGMCHR            Get next character
       DINC @CCPADR           CCPADR ends up with highest a
       DEC  @FAC2             Count total # of characters
       BR   LISTZ1
       CALL IOCLZ1            Preform OPEN on DSR
       CLR  @FAC              Create double byte PAB length
       ST   [email protected](@PABPTR),@RECLEN Get record length
       ST   @RECLEN,@FAC1     Get highest address used
       DADD @CCPADR,@FAC      Compute record length
       DST  @CCPADR,[email protected](@PABPTR) Store it
       CZ   @RAMTOP           If ERAM exists then
       BS   G9128
       DCH  @>8370,@FAC       Compare with top of
*                    VDP : if higher then 'not enough room'
       BS   ERRIO
       BR   G912D
G9128  DCH  @STLN,@FAC        Not enough room
       BS   ERRIO
G912D  ST   1,@CCPPTR         Clear first line in output
       BR   G9138
G9132  ST   VWIDTH+3,@XPT     For common code usage
       CALL INITKB            Reset current record length
G9138  CZ   @RAMTOP           If ERAM exist then
       BS   G9140
       CALL GRMLST            Fake it : move each line to t
*                              CRUNCH buffer form ERAM
G9140  CALL LLIST             List the current line
       SCAN                   Test for a break key
       BR   LISTZ3            No key
       CEQ  BREAK,@RKEY
       BS   LISTZ4
LISTZ5 SCAN
       BR   LISTZ5
LISTZ3 CZ   @RAMTOP           If ERAM exists
       BS   G9156
       DST  @FAC14,@EXTRAM    Restore the @EXTRAM
G9156  DSUB 4,@EXTRAM         Pointer to next line
       DCH  @EXTRAM,@CURINC   Display all lines in range
       BR   G9138
LISTZ4 CZ   @DSRFLG           Device I/O -> output last rec
       BR   G916D
       CALL OUTREC            Output the last record
       CALL IOCALL            Close the device properly
       BYTE CZCLOS
       B    TOPL10
G916D  B    TOPL15            Restart the variable too
* PAB image used in LIST function
PAB    BYTE 0,>12,0,0,0,0,0,0,OFFSET
* Move each line in ERAM to CRNBUF area, put line number in
* (CRNBUF), put CRNBUF+4 in (CRNBUF+2) which is the line
* pointer field, put the text itself from ERAM to (CRNBUF+4
* before call LLIST, trick it by moving CRNBUF to @EXTRAM
GRMLST CALL GRSUB3            Get line # from ERAM(use GREA
       BYTE EXTRAM          * @EXTRAM : Source address on E
*                             Reset possible breakpoint too
       DST  @EEE1,[email protected]    Put it in CRNBUF
       DST  CRNBUF+4,[email protected]+2 Put CRNBUF+4 into
*                              the line pointer field
       DINCT @DDD1            Get the pointer to the text
*                              from GRAM
       CALL GRSUB4            Read the line pointer in (use
*                              GREAD1)
       DDEC @EEE1             Get the ptr to the length byt
       CALL GRSUB2            Read th length from ERAM, use
       BYTE EEE1           *   GREAD1, @EEE1 : Source addre
*                               on ERAM
       ST   @EEE1,@FFF1+1     Use the length as byte count
*                             to move the text from ERAM to
*                             VDP CRNBUF+4 area
       DST  CRNBUF+4,@EEE1    EEE1 : Destination address on
       DINC @DDD1             DDD1 : Source address on ERAM
       XML  GVWITE            Move data from ERAM to VDP
       DST  @EXTRAM,@FAC14    Save for later use
       DST  CRNBUF,@EXTRAM    Fake it
       RTN
* SUBROUTINE TO READ 2 BYTES OF DATA FROM ERAM OR VDP WITH
* THE OPTION TO RESET THE POSSIBLE BREAKPOINT
GRSUB2 FETCH @FFF1            Fetch the source address on
       DST  *FFF1,@DDD1        ERAM or VDP
 
*                             @DDD1 : Source addr  on ERAM
*                             or VDP
GRSUB4 CZ   @RAMTOP           If ERAM exists
       BS   G91B7
       DST  2,@FFF1           @FFF1 : Byte count
       XML  GREAD1            Read data from ERAM to CPU
       BR   G91BB
G91B7  DST  V*DDD1,@EEE1      Read data from VDP to CPU
G91BB  RTN
GRSUB3 FETCH @FFF1            Fetch the source addr on ERAM
       DST  *FFF1,@DDD1        or VDP
*                             @DDD1 : Source addr on ERAM/V
       CALL GRSUB4            Do the actual read
       DAND >7FFF,@EEE1       Reset possible breakpoint
       RTN
*********** REC ROUTINE ***********************************
* REC(X) returns the current record to which file X is
*  positioned.
SUBREC DST  @PABPTR,@ARG      Save the current PAB & set ne
       CALL SUBEOF            Try to find the correct PAB
       DEX  @PABPTR,@ARG      @ARG : new PAB
*                             @PABPTR : restore current PAB
       BR   EOFZ2             Didn't find the corresponding
       DST  [email protected](@ARG),@FAC  Obtain integer record number
       XML  CIF               Convert integer to floating
       XML  CONT               and continue
***********************************************************
*                         EOF ROUTINE
* EOF(X) returns status codes on file X. The meaning of the
* result codes is:
*           -1  Physical End Of File
*            0  Not at End Of File yet
*            1  Logical End Of File
***********************************************************
EOF    DST  @PABPTR,@ARG      Save the current PAB and set
*                              the new one in SUBEOF
       CALL SUBEOF            Try to find the PAB somewhere
       BR   ERRFE             Can't file
       ST   CZSTAT,@ARG2      Select status code without
       EX   @ARG2,[email protected](@PABPTR) destorying original code
       CALL IOCLZ1            Get the info from DSR
       DEX  @ARG,@PABPTR      Restore original PAB and orig
       ST   @ARG2,[email protected](@ARG)  I/O code
       ST   [email protected](@ARG),@ARG2 And pick up STATUS
       MOVE 8,[email protected],@FAC   Get floating 1
       CLOG 3,@ARG2           Test EOF bits
       BS   EOFZ2             No EOF indication
       CLOG 2,@ARG2           Physical EOF
       BS   G9210
       DNEG @FAC              Make result -1
G9210  XML  CONT
EOFZ2  DCLR @FAC              Create result 0
       XML  CONT
FLOAT1 BYTE >40,1,0,0,0,0,0,0   * Floating point -1
SUBEOF CEQ  LPARZ,@CHAT       * SYNTAX ERROR
       BR   ERRSYN
       XML  PARSE             Parse up to the matching ")"
       BYTE >FF
       CALL CHKCNV            Convert and search for PAB
       BS   ERRBV             Avoid 0's and negatives bad v
       ST   @DSRFLG,@ARG6     @DSRFLG got changed in CHKCON
       CALL CHKCON            Check and search tiven filenu
       ST   @ARG6,@DSRFLG     @DSRFLG to changed CHKCON
       RTNC                   Condition set : file # exists
***********************************************************
*      LOAD / SAVE / MERGE UTILITY ROUTINE
* GPNAME gets program name from OLD and SAVE
* Can also be used for future implementation of REPLACE
* statement. Also gives valuable contribution to updating
* of program pointers (VSPTR, STVSPT, FLAG, etc...) and
* creation of LOAD/SAVE PAB
***********************************************************
GPNAME AND  >80,@FLAG         Avoid returns from ERRZZ rout
       CEQ  STRINZ,@CHAT
       BS   G9242
       CEQ  NUMZ,@CHAT        * SYNTAX ERROR
       BR   ERRSYN
G9242  CALL CLSALL            First close all open files
       CALL KILSYM            Kill the symbol table
       DST  VRAMVS+8,@PABPTR  Create PAB as low as possible
       CLR  V*PABPTR          Clear PAB with ripple-move
       MOVE PABLEN-5,V*PABPTR,[email protected](@PABPTR)
       XML  PGMCHR            Get length of file-specificat
       DSUB 4,@PABPTR         Make it a regular PAB
       ST   @CHAT,[email protected](@PABPTR) Copy name length to PAB
       DST  [email protected](@PABPTR),@STADDR Avoid problems(bugs!)
       CZ   @RAMFLG           If ERAM not exist or imperati
       BR   G9275
       MOVE @STADDR,V*PGMPTR,[email protected]+1(@PABPTR)
       BR   G9284
G9275  DST  @STADDR,@FFF1     @FFF1 : Byte count
       DST  @PGMPTR,@DDD1     Source address on ERAM
       DST  @PABPTR,@EEE1
       DADD NLEN+1,@EEE1      Destination address on VDP
       XML  GVWITE            Write from ERAM to VDP
G9284  DADD @STADDR,@PGMPTR   Skip the string
* OLD and SAVE can only be imperative
       CLR  @DATA             Clear DATA line
       RTN                    That's all folks
***********************************************************
*           READ / INPUT UTILITY ROUTINES
***********************************************************
GETVAR DST  @PGMPTR,@STADDR   Save token pointer to first c
       CLR  @VAR5             Clear # of parsed variables
       DST  @VSPTR,@VAR4      Save first entry in V-stack
* Start parse cycle for IMPUT statement
GETVZ0 CHE  >80,@CHAT         Make sure of varialbe name
       BS   ERRSYN
       XML  SYM               Get correct symbol table entr
       CLR  @VAR6             Start with zero paren nesting
GETVZ1 CEQ  LPARZ,@CHAT       Increment counter for "("
       BR   G92A2
       INC  @VAR6
G92A2  CZ   @VAR6             Watch out for final balance
       BS   G92B6
       CALL CHKEND            Check for unbalenced parenthe
       BS   ERRSYN            Somebody forgot something!!!!
       CEQ  RPARZ,@CHAT       Decrement for ")"
       BR   G92B2
       DEC  @VAR6
G92B2  XML  PGMCHR            Get character following last
       BR   GETVZ1
G92B6  XML  VPUSH             Push entry to V-stack
       INC  @VAR5             Count all pushed variables
       CALL CHKEND            Next should either be EOS or
       BS   GETVZ2            Found it EOS!!!!
       XML  SPEED             Must be at a
       BYTE SYNCHK          *  comma else
       BYTE COMMAZ          *   its an error
       CALL CHKEND            Check for end of statement
       BR   GETVZ0            Haven't found it yet
       CZ   @DSRFLG           Error for keyboard I/O
       BR   ERRSYN
GETVZ2 RTN
* Create a temporary string in memory. BYTES contains the l
CTSTR  DST  >6500,@FAC2       Indicate string in FAC
CTSTR0 DST  @BYTES,@FAC6      Copy string length in FAC6
       XML  GETSTR            Reserve the string
       DST  @SREF,@FAC4       Copy start address of string
       DST  >001C,@FAC        And indicate temp. string >00
       RTN
* Create a temporary string from TEMP5. Length is given
* in BYTES.
CTMPST CALL CTSTR             Create the temporary string
       CZ   @FAC7
       BS   G92EB
       MOVE @BYTES,V*TEMP5,V*SREF
G92EB  RTN                    Non-empty
* CHKNUM - Check for numeric argument
CHKNUM CEQ  NUMZ,@VAR0+1
       BR   G9303
       CALL GETRAM            Get string length
       DST  @DATA,@FAC12      Store entry for conversion
       CLR  @VAR0             Prepare for double action
       DADD @VAR0,@DATA       Get end of data field
       CALL CONVER            Convert data to FAC #
* Conversion should also end at end of field
       DCEQ @DATA,[email protected]    Set COND according to equalit
G9303  RTNC                   Back to caller
GETGFL ST   @RAMTOP,@FAC3     Select target memory
GETDAT CZ   @FAC3             Get everything from RAM
       BR   G9314
GETRAM ST   V*DATA,@VAR0+1    Get data in VAR0+1
       CLR  @FAC3             Be sure FAC3 = 0 !!!!
       BR   G9320
G9314  DST  1,@FFF1           FFF1 : byte count
       DST  @DATA,@DDD1       DDD1 : source addr on ERAM
       XML  GREAD1            Read data from ERAM
       ST   @EEE1,@VAR0+1     EEE1 : Destination addr on CP
G9320  DINC @DATA             Go to next datum for next tim
       RTN
CHKSTR DCLR @FAC6             Assume we'll have an empty st
       CEQ  STRINZ,@VAR0+1
       BS   CHKSZ0
       CEQ  NUMZ,@VAR0+1      See ............
       BR   EMPSTR
CHKSZ0 CALL GETDAT            Next datum is length byte
       CLR  @FAC6             Be sure high byte = 0 !!!!
       ST   @VAR0+1,@FAC7     Prepare FAC for string assign
       DST  @DATA,@TEMP5      Save string addr for assignme
       DADD @FAC6,@DATA       Update DATA for end of field
       RTN
* Empty strings are handled below
EMPSTR CEQ  COMMAZ,@VAR0+1
       BS   G9348
       CALL DATEND            Check for end of data stateme
       BR   RTC               Return with COND if not EOS
G9348  DDEC @DATA             Backup data pointer for empti
       RTN
DATEND EX   @VAR0+1,@CHAT
       CALL CHKEND            Check for EOS (=EOL or "::")
       EX   @VAR0+1,@CHAT     Restore original situation
       RTNC
***********************************************************
*           OPEN / CLOSE / RESTORE UTILITY ROUTNE
* CHKFN - Check for token = "#" and collect and check
* filenumber. Also convert filenumber to (two byte) integer
* and check for range 0<x<256
***********************************************************
CHKFN  XML  SPEED             Must be at a
       BYTE SYNCHK         *   '#' else
       BYTE NUMBEZ         *    its an error
       XML  PARSE             Parse argument up to ":"
       BYTE COLONZ
* Code to check for negative or zero result in floating poi
* accumilator. If not... convert to integer and return two
* byte integer in FAC
CHKCNV CEQ  STRVAL,@FAC2      String/number mismatch
       BS   ERRSNM
       CLR  @FAC10            Clear error-code byte
       XML  CFI               Convert to two byte integer
       CZ   @FAC10            BAD VALUE ERROR
       BR   ERRBV
       CLOG >80,@FAC          Negative result
       BR   RTC
       DCZ  @FAC              And return with COND set/rese
       RTNC
CHKCON ST   @FAC1,@FNUM       Move result into FNUM
* Check for high byte not zero (>0255)
       CZ   @FAC              Bad value error
       BR   ERRBV
* Search routine - Search for a given file number in the
* chain of allocated PABs.
* IOSTRT contains the start of the PAB - chain
       DST  @IOSTRT,@PABPTR   Get first link in the chain
* Check for last PAB in the chain and exit if found
CHKFZ1 DCZ  @PABPTR           Check if file # is correct
       BS   G938F
       CEQ  @FNUM,[email protected](@PABPTR)
       BS   RTC
       DST  V*PABPTR,@PABPTR  Try the next PAB
       BR   CHKFZ1
RTC    CEQ  @>8300,@>8300     Force COND to "SET"
G938F  RTNC                   Exit with no COND change
***********************************************************
* OUTEOF outputs the last record if this record is
* non-empty, and if the PAB is open for non-imput mode
* (UPDATE, APPEND or OUTPUT).
***********************************************************
OUTEOF CLR  @DSRFLG
       CEQ  CZWRIT,[email protected](@PABPTR) Non-input mode
       BR   G93A5
       CZ   [email protected](@PABPTR)    Non-empty record
       BS   G93A5
       CALL PRINIT            Initiate for output
       CALL OUTREC            Output and remove pending con
G93A5  RTN                    Return to whoever called
***********************************************************
* DELPAB routine - delete a given PAB from chain under the
* assumption that the PAB exists
***********************************************************
* First compute start and end address for block move
DELPAB DST  [email protected](@PABPTR),@STADDR Get lowest used address
       DDEC @STADDR           Make that an addr following P
       CLR  @CCPADR           Get highest addr in CCPADR (2
       ST   [email protected](@PABPTR),@CCPADR+1 complete the two byte
       ADD  PABLEN-1,@CCPADR+1 Add PAB length-1
       DADD @PABPTR,@CCPADR   Compute actual addr within RA
       DCEQ @PABPTR,@IOSTRT   Watch out for first PAB
       BS   G93E6
       DST  @IOSTRT,@MNUM     Figure out where link to PAB
G93C2  DCEQ @PABPTR,V*MNUM    Continue while not found
       BS   G93CE
       DST  V*MNUM,@MNUM      Defer to next link in chain
       BR   G93C2             Short end for code-savings
G93CE  DST  V*PABPTR,V*MNUM   Copy link over deleted PAB
       DCZ  V*MNUM            Adjust link only if not done
       BS   G93E0
       DADD @CCPADR,V*MNUM    Add deleted # of bytes for
       DSUB @STADDR,V*MNUM     link correction
G93E0  DST  V*MNUM,@PABPTR    Get new PABPTR
       BR   G93F7
G93E6  DST  V*PABPTR,@IOSTRT  Update first link
       DCZ  @IOSTRT           Only adjust if not last link
       BS   G93F4
       DADD @CCPADR,@IOSTRT   Add deleted # of bytes
       DSUB @STADDR,@IOSTRT
G93F4  DST  @IOSTRT,@PABPTR   Get new PABPTR
* Move the bytes below the deleted block up in memory. This
* includes both variables and PABs
G93F7  DST  @STADDR,@MNUM     Get # of bytes to move
       DSUB @FREPTR,@MNUM
       DST  @CCPADR,@CCPPTR   Save destination address
G9400  DCZ  @MNUM
       BS   G9411
       ST   V*STADDR,V*CCPADR Move byte by byte
       DDEC @STADDR           Update source
       DDEC @CCPADR            and destination pointers
       DDEC @MNUM             Also update counter value
       BR   G9400
G9411  DSUB @STADDR,@CCPADR   Compute # of bytes of old PAB
       DCZ  @PABPTR           Avoid trouble with last PAB
       BS   G9431
G9418  DCZ  V*PABPTR          Ad infinitum (or fundum)
       BS   G942C
       DADD @CCPADR,V*PABPTR  Adjust link to next PAB
       DADD @CCPADR,[email protected](@PABPTR) Update the buffer link
       DST  V*PABPTR,@PABPTR  Get next link in chain
       BR   G9418
G942C  DADD @CCPADR,[email protected](@PABPTR) Update buffer link
* Adjust symbol table links
G9431  DCZ  @SYMTAB
       BS   G94B4
       DCGE @CCPPTR,@SYMTAB   Only update lower links
       BS   G94B4
       DADD @CCPADR,@SYMTAB   Get symbol table pointer back
       DST  @SYMTAB,@PABPTR   Get pointer for update
DELPZ1 CZ   @RAMTOP
       BR   DELPZ2
       DCGE @STLN,[email protected](@PABPTR) If imperative
       BS   G9451
DELPZ2 DADD @CCPADR,[email protected](@PABPTR) Adjust name pointer
G9451  CGE  0,V*PABPTR        If string-fix breakpoints
       BS   G949B
       ST   >07,@FAC          Mask to get # of dims
       AND  V*PABPTR,@FAC     Get # of dims
       DST  @PABPTR,@FAC2     Pointer to 1st dim max
       DADD 6,@FAC2            or string pointer
       DST  1,@FAC6           Number of pointers to change
       CLR  @FAC4             For 2 byte use of option base
G946B  CZ   @FAC              While more dimendions
       BS   G9483
       ST   1,@FAC5           Assume option base 0
       SUB  @BASE,@FAC5       But correct if base 1
       DADD V*FAC2,@FAC4      Get dim maximum
       DMUL @FAC6,@FAC4       Multiply it in
       DEC  @FAC              Next dim
       DINCT @FAC2
       B    G946B
* FAC2 now points at the 1st string pointer
* FAC6 contains the # of pointers that need to be changed
G9483  DCZ  @FAC6             While pointers to cheange
       BS   G949B
       DST  V*FAC2,@FAC       Get pointer to string
       DCZ  @FAC              If sting is non-null
       BS   G9495
       DST  @FAC2,[email protected](@FAC)  Fix backpointer
G9495  DINCT @FAC2            Point to next pointer
       DDEC @FAC6             One less pointer to change
       BR   G9483
G949B  DCZ  [email protected](@PABPTR)
       BS   G94B4
       DCGE @CCPPTR,[email protected](@PABPTR)
       BS   G94B4
       DADD @CCPADR,[email protected](@PABPTR) Adjust next value link
       DST  [email protected](@PABPTR),@PABPTR Next entry
       BR   DELPZ1
G94B4  DADD @CCPADR,@FREPTR   Update free word pointer
       RTN
***********************************************************
* CNVDEF - Convert to 2 byte integer and default to 1 on
*          negative or 0 ....
***********************************************************
CNVDEF CALL CHKCNV            Check and convert
       BR   CNVDZ0
       DST  1,@FAC            Default to 1 or minus and 0
CNVDZ0 RTN                    And return without COND set
***********************************************************
* PARREC parses a possible REC clause in INPUT, PRINT or
* RESTORE. In case a comma is detected without a REC clause
* following it, the COND is set upon return. In case a REC
* clause is specified for a file opened for SEQUENTIAL
* access, a * FILE ERROR is given.
***********************************************************
PARREC CEQ  COMMAZ,@CHAT      Only check if we have a ","
       BR   G94EE
       XML  PGMCHR            Check next token for REC
       CEQ  RECZ,@CHAT        May be USING clause
       BR   RTC
       CLOG 1,[email protected](@PABPTR)
       BS   ERRFE
       XML  PGMCHR            Get first character of expres
       CALL OUTEOF            Output possible pending outpu
       CLR  [email protected](@PABPTR)    Clear record offset
       XML  PARSE             Translate the expression in R
       BYTE COLONZ
       CALL CHKCNV            Check numeric and convert to
       CGE  0,@FAC             2 byte integer, Bad Value
       BR   ERRBV
       DST  @FAC,[email protected](@PABPTR) Store actual record number
G94EE  RTN
***********************************************************
*              DISPLAY / ACCEPT UTILITIES
***********************************************************
DISACC CALL INITKB            PABPTR is used as flag (no DS
DISPZ1 CEQ  ERASEZ,@CHAT      Check for ERASE ALL
       BR   G9518
       CLOG 1,@PABPTR          already used once
       BR   ERRSYN
       XML  PGMCHR            Check next token for ALL
       XML  SPEED
       BYTE SYNCHK          *  has to be ALL
       BYTE ALLZ
       ALL  BKGD+OFFSET       Clear screen to background co
       ST   3,@XPT            Reset pending output pointer
       CLOG 4,@PABPTR         Didn't use AT yet
       BR   G9513
       ST   1,@CCPPTR         Reset column pointer
       DST  SCRNBS+2,@CCPADR   and screen base address
G9513  OR   1,@PABPTR         Set "ERASE USED" flag
       BR   DISPZ1            Try next token
G9518  CEQ  BEEPZ,@CHAT        delay action for BEEP
       BR   G9529
       CLOG 2,@PABPTR         Use it only once
       BR   ERRSYN
       OR   2,@PABPTR         No syntax error detected here
       XML  PGMCHR            Evaluate next token
       BR   DISPZ1            Get set for second pass
G9529  CEQ  ATZ,@CHAT         Generate "AT" clause
       BR   G9571
       CLOG 4,@PABPTR         Second usage not
       BR   ERRSYN
       XML  PGMCHR             allowed....
       XML  SPEED
       BYTE SYNCHK          * Skip left parenthesis
       BYTE LPARZ
       XML  PARSE             Now parse any expression
       BYTE COMMAZ
       XML  SPEED
       BYTE SYNCHK          * Check for "," and skip it
       BYTE COMMAZ
       CALL CNVDEF            Convert to 2 byte numeric
       ST   24,@FAC2          Convert modulo 24 (# screen l
       CALL COMMOD            Compute remainder
       DEC  @FAC1             Convert back to 0 (range was
       MUL  32,@FAC1          Convert to line base address
       DST  @FAC1,@CCPADR     And repalce CCPADR
       XML  PARSE             Parse column expression
       BYTE RPARZ
       XML  SPEED
       BYTE SYNCHK          * Check for ")" at end
       BYTE RPARZ
       CALL CNVDEF            Again convert to two byte int
       ST   VWIDTH,@FAC2      Convert modulo video width
       CALL COMMOD            Compute remainder
       ST   @FAC1,@CCPPTR     Select current column
       DADD @FAC,@CCPADR      Compute full address
       DINC @CCPADR           Adjust for column 0 (offset-1
       OR   4,@PABPTR         Set "AT-CLAUSE" used flag
       OR   32,@PABPTR        Set "NON-STANDARD SCREEN ADDR
       BR   DISPZ1            Continue for next item
G9571  CEQ  SIZEZ,@CHAT       "SIZE" clause
       BR   G95A0
       CLOG 8,@PABPTR         Only use once
       BR   ERRSYN
       XML  PGMCHR            Get character following the S
       CEQ  LPARZ,@CHAT        has to open "("
       BR   ERRSYN
       XML  PARSE             And close again ")"
       BYTE VALIDZ
       CGE  0,@FAC            Change to positive argument
       BS   G958F
       DNEG @FAC              For ACCEPT statement with siz
       OR   >80,@PABPTR        indicate in highest bit
G958F  CALL CHKCNV
       BS   ERRBV             * BAD VALUE
       CZ   @FAC              Also for args >255 (less then
       BR   ERRBV
       ST   @FAC1,@PABPTR+1   Copy to PABPTR (always used)
       OR   8,@PABPTR         Prevent further use
       BR   DISPZ1             and go on
G95A0  CEQ  VALIDZ,@CHAT      Exclude VALIDATE option
       BS   G95B9
* Start evaluating ERASE clause here
       CLOG 8,@PABPTR
       BS   CHKEND
       CALL SIZE1             Evaluate field defined in SIZ
* If it's no DISPLAY keyword ( AT, SIZE, BEEP or USING) it
* has to be a print separator or colon ":"
* If anything is specified is has to be a colon or end of
* line... for end-of-line output current record
* Check for end of statement
CHKEND CLOG >80,@CHAT
       BS   G95B7
       CHE  TREMZ+1,@CHAT
       BR   RTC
G95B7  CZ   @CHAT             Set COND according to CHAT
G95B9  RTNC
***********************************************************
* NXTCHR - Get next program character - skip all strings,
*          numerics and line references...
***********************************************************
NXTCHR CALL CHKEND            Check for end of statements
       BS   RTC               Avoid end of statement
       CEQ  STRINZ,@CHAT      Skip all strings
       BS   NXTCZ0
       CEQ  NUMZ,@CHAT         and numerics/unquoted string
       BR   G95D5
NXTCZ0 XML  PGMCHR            Get string length
       ST   @CHAT,@FAC1       Make that a double please...
       CLR  @FAC              Hic.... Oops, sorry
       DADD @FAC,@PGMPTR      Back to the serious stuff
       BR   G95DC
G95D5  CEQ  LNZ,@CHAT         Line # = skip 2 tokens
       BR   G95DC
       DINCT @PGMPTR          <----------- That's the skip
G95DC  XML   PGMCHR           Get the next token
       RTN
***********************************************************
*                 PRINT / DISPLAY UTILITES
* Use the parameters specified in SIZE for further
* evaluation of the limited field length
***********************************************************
SIZE1  CLOG 4,@PABPTR         Not "AT" clause used
       BR   G95FC
       CEQ  1,@CCPPTR         Might have to print current
       BS   G95FC
       ST   @CCPPTR,@FAC      Compute final position after
       ADD  @PABPTR+1,@FAC     in FAC and compare with reco
       DEC  @FAC
       CH   @RECLEN,@FAC      Size clause too long
       BR   G95FC
* We can't get here for AT( , ) output, since right margin
* limited there
       CALL OUTREC            Advance to next line
       CALL SCRO              Scroll the screeen
G95FC  SUB  @CCPPTR,@RECLEN   Limit field size to available
       INC  @RECLEN            space... including current p
       CH   @PABPTR+1,@RECLEN
       BR   INITZ1
       ST   @PABPTR+1,@RECLEN Only accept if available
       BR   INITZ1            Reinitialize CCPPTR
* Copy (converted) numerical datum in string
RSTRING ST  @FAC12,@BYTES+1   Get actual string length
       CLR  @BYTES            Create double byte value
       CALL CTSTR             Create a temporary string
       MOVE @BYTES,*FAC11,V*SREF Copy value string
       RTN
* COMMOD - Compute FAC module FAC2
COMMOD DIV  @FAC2,@FAC        Compute remainder
       CZ   @FAC1             Avoid zero remainders
       BR   G9624
       ST   @FAC2,@FAC1       Assume maximum remainder
G9624  CLR  @FAC              Clear upper byte
       RTN
* TSTSEP tests for separator in print and branches to the
* correct evaluation routine.
* If no separator is found, simple return.
* Test case end of line
TSTSEP CALL CHKEND
       BR   TSTSZ0
       DST  EOLEX,*SUBSTK     Replace return address with E
TSTSZ0 CHE  COMMAZ,@CHAT
       BR   TSTSZ1
       CH   COLONZ,@CHAT
       BS   TSTSZ1
       DST  PRSEM,*SUBSTK     Expect it to be a ";"
       CALL TSTINT            Test for INTERNAL files
       BR   TSTSZ1            Treat all separators as ";"
       CEQ  COMMAZ,@CHAT
       BR   G964F
       DST  PRTCOM,*SUBSTK
G964F  CEQ  COLONZ,@CHAT
       BR   TSTSZ1
       DST  PRCOL,*SUBSTK
TSTSZ1 RTN
* PARFN - Parse string expression and create PAB automatica
*         continue in CSTRIN for copy string to PAB
* Exit on non-string values
*
* First evaluate string expression
PARFN  XML  PARSE             Parse up to next comma    <<<
       BYTE COMMAZ          *                           <<<
       CEQ  STRVAL,@FAC2      Check for "STRING"        <<<
       BR   ERRSNM
       DST  @FAC6,@MNUM       Copy length byte in MNUM
       ADD  PABLEN,@MNUM+1    Account for PAB length+contro
       XML  VPUSH             Save start of string somewher
       DST  @MNUM,@FAC        Setup for MEMCHK - check for
       XML  MEMCHK             memory overflow
       BS   ERRMEM            * MEMORY FULL
       XML  VPOP              Restore all FAC information a
       DSUB @MNUM,@FREPTR     Update free word pointer
       DST  @FREPTR,@PABPTR   Assign PAB entry address
       DINC @PABPTR           Correct for byte within PAB
       CLR  V*PABPTR          Clear PAB plus control info
       MOVE PABLEN-1,V*PABPTR,[email protected](@PABPTR)  Ripple byte
       ST   @MNUM+1,[email protected](@PABPTR) Save length of PAB
       ST   @FAC7,@MNUM       Compute # of bytes in name
       ST   @FAC7,[email protected](@PABPTR) Store name length
       ST   @FNUM,[email protected](@PABPTR) Copy file number in PAB
       DST  @PABPTR,@CCPADR   Get start addr for string des
       DADD NLEN+1,@CCPADR    Add offset to actual start ad
* TRICKY - OPTFLG also results offset added in CSTRIN
       CLR  @OPTFLG           Clear all option flags
       XML  IO                CSTRIN I/O UTILITY
       BYTE CSTRIN
       RTN
***********************************************************
*                      OUTREC
* OUTREC and INITRC are used to output a record to either
* screen or external I/O devices, and to initiate pointers
* for further I/O.
***********************************************************
OUTREC ST   @RECLEN,@MNUM+1   Compute number of characters
       INC  @MNUM+1            positions we should fill
       CZ   @DSRFLG           Screen I/O
       BS   G96D3
       XML  IO                Fill the remainder of the rec
       BYTE FILSPC          *  with appropriate fillers
       CLOG 8,@PABPTR           block output on size
       BR   RTC
       CLOG 4,@PABPTR         "AT CLAUSE USED"
       BS   SCRO
* Next test for xing the end of screen
       DADD 4,@CCPADR
       CHE  3,@CCPADR
       BR   INITZ1
       DST  2,@CCPADR         Restart at upper left hand
*                              corner of screen
INITZ1 ST   1,@CCPPTR         Reset current column pointer
       RTN
SCRO   XML  SCROLL            Scroll the screen one line
       ST   1,@CCPPTR         Reinitialize CCPPTR
       BR   INTKB0             and reinitialize
* This is also entry for last record output
G96D3  CLOG >10,[email protected](@PABPTR) FIXED records
       BR   G96E2
       ST   @RECLEN,@MNUM+1   Ready for space filling
       INC  @MNUM+1           Move to first position outsid
*                              record
       XML  IO                And do it up to end of record
       BYTE FILSPC
G96E2  DEC  @CCPPTR           Update last character positio
       ST   @CCPPTR,[email protected](@PABPTR) Store # of characters
       CLR  [email protected](@PABPTR)    Undo pending record offsets
       CALL IOCALL            Call DSR
       BYTE CZWRIT          *  for WRITE mode
       CLR  @CCPADR+1         Get address at buffer start
       BR   PRZZ0
* PRINIT initializes the variable CCPADR, CCPPTR, RECLEN an
* DSRFLG, for a given PABPTR.
PRINIT CLR  @DSRFLG           Indicate external I/O in DSRF
       ST   [email protected](@PABPTR),@RECLEN  Pick up record length
       ST   [email protected](@PABPTR),@CCPADR+1 Get offset in record
PRZZ0  ST   @CCPADR+1,@CCPPTR  Compute columnar position
       INC  @CCPPTR           And convert from offset
       CLR  @CCPADR           Clear upper byte
       DADD [email protected](@PABPTR),@CCPADR Compute actual address
       RTN
***********************************************************
* OSTRNG - Copy the value of the string expression to the
*          screen.
***********************************************************
OSTRNG ST   @FAC7,@BYTES      Pick up the string length
G9711  CZ   @BYTES            Output as many records as req
       BS   G973E
* CHKREC check available space in current record.
* If the string to be output is too long, it is chuncked up
* into digestable pieces. If the current record is partly
* filled up, it is output before any chuncking is done.
CHKREC ST   @CCPPTR,@MNUM+1   Use MNUM for current offset i
CHKRZ0 ST   @RECLEN,@MNUM     Compute remaining area
       SUB  @CCPPTR,@MNUM      between column and end
       INC  @MNUM             Also count current column
       CHE  @BYTES,@MNUM      Won't fit in current record
       BS   G9730
       CEQ  1,@MNUM+1         Unused record
       BS   CHKRZ1
       CALL OUTREC            Output whatever we have
       BR   CHKREC            And try again
       RTN
G9730  ST   @BYTES,@MNUM      Use actual count if fit
CHKRZ1 SUB  @MNUM,@BYTES      Update remaining chars count
       ADD  @MNUM,@CCPPTR     Also new column pointer
       XML  IO                Copy string to output
       BYTE CSTRIN
       BR   G9711             Continue as long as needed
G973E  RTN
***********************************************************
* INITKB - Initialize the variable needed for keyboard outp
***********************************************************
INITKB CLR  @PABPTR           Don't use any DISPLAY options
       ST   OFFSET,@DSRFLG    Load for correction of screen
       ST   1,@CCPPTR         Assume un-initialized XPT
       CH   2,@XPT            * Patch for un-initialized XP
       BR   G9751
       ST   @XPT,@CCPPTR      Initialize CCPPTR
       DECT @CCPPTR           Correct for incorrect XPT off
G9751  ST   VWIDTH,@RECLEN    Get video screen width
INTKB0 ST   @CCPPTR,@CCPADR+1 Initialize screen address
       CLR  @CCPADR           Clear upper byte CCPADR
       DADD SCRNBS+1,@CCPADR  Add start-addr plus comenstat
       RTN
IOCALL FETCH @FAC12           I/O code to FAC12 (BUG!!!)
       ST   @FAC12,[email protected](@PABPTR) Pick up the I/O code
IOCLZ1 CALL CDSR              Call the DSR routine
       BR   ERRZ2             Give I/O error on error
       RTN                    Or else return
* DSR CALL ROUTINE - NORMAL ENTRY
CDSR   ST   OFFSET,[email protected](@PABPTR)   Always set screen offse
       MOVE 30,@FAC,[email protected]>03C0   Save FAC area
       DST  @PABPTR,@FAC12    Get PAB pointer in FAC
       DADD NLEN,@FAC12       Get PAB pointer in FAC
       AND  >1F,[email protected](@PABPTR) Clear error bits for ON ERRO
*                       time, I/O process can still be
*                        continued
       CALL CALDSR            Call actual DSR link routine
       BYTE 8
       MOVE 30,[email protected]>03C0,@FAC
* MOVE does not affect status
       BS   CDSRZ0            ERROR = ERROR = ERROR
       CLOG >E0,[email protected](@PABPTR) Set COND if no error
CDSRZ0 RTNC
* ERROR MESSAGES
ERRZ2B CALL CLRFRE            Undo allocation of PAB
* First check is it error coming from AUTOLD
* If it is then do not print the error messege and
*  go back to TOPL02
ERRZ2  MOVE 2,[email protected],[email protected]
       DCEQ [email protected],@RSTK+2
       BR   G97A9
       ST   RSTK+2,@SUBSTK
       RTN
***********************************************************
* Next code is to avoid recursion of errors in CLSALL
* routine. If this entry is taken from CLSALL, the stack
* will contain CLSLBL as a retrun address in the third leve
***********************************************************
G97A9  SUB  4,@SUBSTK
       DCEQ CLSLBL,*SUBSTK
       BR   G97B8
WRNIO  CALL WARNZZ            Give warning to the user
       BYTE 35                * I/O ERROR but warning
       RTN                    And return to close routine
G97B8  ADD  4,@SUBSTK         Back up two levels for OLD/SA
ERRIO  CALL ERRZZ
       BYTE 36                * I/O ERROR
* ERROR messages called in this file
ERRSNM CALL ERRZZ
       BYTE 7                 * STRING-NUMBER MISMATCH
ERRIM  CALL ERRZZ
       BYTE 10                * IMAGE ERROR
ERRMEM CALL ERRZZ
       BYTE 11                * MEMORY FULL
ERRBV  CALL ERRZZ
       BYTE 30                * BAD VALUE
ERRINP CALL ERRZZ
       BYTE 32                * INPUT ERROR
ERRDAT CALL ERRZZ
       BYTE 33                * DATA ERROR
ERRFE  CALL ERRZZ
       BYTE 34                * FILE ERROR
ERRPV  CALL ERRZZ
       BYTE 39                * PROTECTION VIOLATION
ERRMUV CALL ERRZZ
       BYTE 9                 * IMPROPERLY USED NAME
* Other errors called in file
* ERRSYN    * SYNTAX ERROR                        BYTE  3
* ERRST     * STRING TRUNCATED ERROR              BYTE 19
* WRNNPP    * NO PROGRAM PRESENT                  BYTE 29
* WRNINP    * INPUT ERROR            (WARNING)    BYTE 32
* ERRIO     * I/O ERROR                           BYTE 36
* WRNIO     * I/O ERROR              (WARNING)    BYTE 36
* WRNSNM    * STRING NO. MISMATCH    (WARNING)    BYTE  7
***********************************************************
* The following section has been added to fix bugs in INPUT
* ACCEPT, and LINPUT statements.
***********************************************************
BUG01  CHE  >80,@CHAT         Make sure of variable name
       BS   ERRSYN
       XML  SYM               Get the information of the
       XML  SMB                variable.
       RTN
***********************************************************
* GKXB CODE HERE
GTLENG ST   @CHAT,@FAC+2      Moved from LIST routine
       ST   @XSTLN,[email protected](@PABPTR) Store length
       RTN                       and return
***********************************************************
        AORG >1800
***********************************************************
ALCEND  DATA >205A,>24F4,>4000,>AA55
        DATA >2038,>2096,>2038,>217E
        DATA >2038,>21E2,>2038,>234C
        DATA >2038,>2432,>2038,>246E
        DATA >2038,>2484,>2038,>2490
        DATA >2038,>249E,>2038,>24AA
        DATA >2038,>24B8,>2038,>2090
        DATA >0000,>0000,>0000,>0000
        DATA >0000,>0000,>0000,>0000
        DATA >0000,>0000,>0000,>0000
        DATA >0000,>0000,>0000,>0000
        DATA >6520,>C060,>2004,>0281
        DATA >4000,>130E,>C001,>0202
        DATA >834A,>8CB0,>1606,>8CB0
        DATA >1604,>8CB0,>1602,>C030
        DATA >0450,>0221,>0008,>10EF
        DATA >0200,>2500,>C800,>8322
        DATA >02E0,>83E0,>0460,>00CE
        DATA >C81D,>8322,>10F9,>C01D
        DATA >C06D,>0002,>06A0,>20DC
        DATA >C0C1,>0603,>0223,>8300
        DATA >D0D3,>1361,>0983,>0643
        DATA >1612,>C000,>165C,>C0C5
        DATA >05C3,>06A0,>2406,>1653
        DATA >05C3,>06A0,>23CA,>0204
        DATA >834A,>0202,>0008,>DC74
        DATA >0602,>15FD,>0380,>06A0
        DATA >20F8,>10F5,>C041,>1347
        DATA >0A81,>9060,>8312,>1143
        DATA >0981,>C141,>0A35,>0225
        DATA >0008,>A160,>8310,>045B
        DATA >C24B,>0643,>1634,>C0C5
        DATA >06A0,>23CA,>C0C1,>06A0
        DATA >2406,>112D,>06A0,>211C
        DATA >06A0,>23CA,>6004,>0A30
        DATA >A040,>0459,>C28B,>0A51
        DATA >09D1,>C201,>D120,>8343
        DATA >0984,>1303,>0600,>1123
        DATA >0580,>0206,>0001,>C0C5
        DATA >0223,>0004,>06A0,>23CA
        DATA >C0C1,>0643,>05C3,>06A0
        DATA >23CA,>0581,>6044,>3981
        DATA >C186,>1611,>C187,>0608
        DATA >15F5,>0606,>A184,>8180
        DATA >150A,>05C3,>045A,>0200
        DATA >0700,>0460,>2084,>0200
        DATA >1C00,>0460,>2084,>0200
        DATA >1400,>0460,>2084,>C01D
        DATA >C06D,>0002,>06A0,>20DC
        DATA >C0C1,>0603,>0223,>8300
        DATA >D0D3,>0983,>160E,>C000
        DATA >1622,>0202,>0008,>0204
        DATA >834A,>C0C5,>06A0,>23CA
        DATA >CD01,>05C3,>0642,>15FA
        DATA >0380,>0643,>160F,>C000
        DATA >1612,>C0C5,>05C3,>06A0
        DATA >2406,>160B,>05C3,>06A0
        DATA >23CA,>C101,>0201,>834A
        DATA >0460,>20CA,>06A0,>20F8
        DATA >10F8,>0460,>2166,>0460
        DATA >216E,>C81D,>2038,>C82D
        DATA >0002,>83E2,>C82D,>0004
        DATA >2044,>02E0,>83E0,>C80B
        DATA >2040,>C020,>2044,>06A0
        DATA >20DC,>C0C1,>0603,>0223
        DATA >8300,>D0D3,>0983,>0603
        DATA >1332,>0643,>164A,>C2A0
        DATA >2038,>162D,>C0C5,>05C3
        DATA >06A0,>2406,>9801,>2058
        DATA >1620,>0206,>0008,>0204
        DATA >834A,>C0C5,>06A0,>23CA
        DATA >CD01,>05C3,>0646,>15FA
        DATA >06A0,>22DA,>0225,>0004
        DATA >C105,>C046,>06A0,>23E6
        DATA >05C4,>D050,>0981,>06A0
        DATA >23E6,>C2E0,>2040,>C820
        DATA >203E,>830C,>02E0,>2038
        DATA >0380,>0200,>0700,>C2E0
        DATA >2040,>0460,>2084,>0200
        DATA >1C00,>0460,>226E,>C08B
        DATA >0643,>16F3,>C0C5,>06A0
        DATA >23CA,>C0C1,>06A0,>2406
        DATA >1102,>0460,>226A,>C020
        DATA >2038,>06A0,>211C,>6004
        DATA >0A10,>A0C0,>06A0,>23CA
        DATA >0452,>06A0,>227E,>0206
        DATA >834A,>CD83,>DDA0,>2058
        DATA >DD84,>CD81,>C0C1,>1602
        DATA >04D6,>1005,>0603,>06A0
        DATA >2406,>0981,>C581,>C020
        DATA >2044,>06A0,>22DA,>0460
        DATA >225A,>C80B,>203A,>C805
        DATA >203C,>C2E0,>601E,>069B
        DATA >C020,>2044,>C160,>203C
        DATA >D190,>0986,>C820,>830C
        DATA >203E,>C806,>830C,>C806
        DATA >8350,>C2E0,>6012,>069B
        DATA >C020,>2044,>0206,>834A
        DATA >0204,>001C,>CD84,>DDA0
        DATA >2058,>DD84,>C5A0,>831C
        DATA >C0A0,>830C,>1309,>C116
        DATA >C0C0,>0583,>D073,>06A0
        DATA >241A,>0584,>0602,>15FA
        DATA >C2E0,>6028,>069B,>C020
        DATA >2044,>C160,>203C,>C2E0
        DATA >203A,>045B,>C01D,>C06D
        DATA >0002,>06A0,>20DC,>C0C1
        DATA >0603,>0223,>8300,>D0D3
        DATA >0983,>0603,>1302,>0643
        DATA >1623,>C000,>1628,>C02D
        DATA >0004,>C0C5,>05C3,>06A0
        DATA >2406,>9801,>2058,>161D
        DATA >05C3,>06A0,>23CA,>C041
        DATA >1307,>C181,>0601,>C0C1
        DATA >06A0,>2406,>9050,>1A15
        DATA >DC01,>1309,>C0C6,>0981
        DATA >C141,>06A0,>2406,>DC01
        DATA >0583,>0605,>15FA,>0380
        DATA >06A0,>227E,>C02D,>0004
        DATA >10E6,>0460,>2166,>0460
        DATA >216E,>0200,>1300,>0460
        DATA >2084,>06C3,>D803,>8C02
        DATA >06C3,>D803,>8C02,>1000
        DATA >D060,>8800,>06C1,>D060
        DATA >8800,>06C1,>045B,>06C4
        DATA >D804,>8C02,>06C4,>0264
        DATA >4000,>D804,>8C02,>1000
        DATA >D801,>8C00,>06C1,>D801
        DATA >8C00,>06C1,>045B,>06C3
        DATA >D803,>8C02,>06C3,>D803
        DATA >8C02,>1000,>D060,>8800
        DATA >045B,>06C4,>D804,>8C02
        DATA >06C4,>0264,>4000,>D804
        DATA >8C02,>1000,>D801,>8C00
        DATA >045B,>C83E,>83E2,>02E0
        DATA >83E0,>C80B,>204E,>C081
        DATA >0281,>0040,>1B0A,>C0A1
        DATA >6010,>0281,>0004,>1605
        DATA >C0A2,>0002,>0692,>2466
        DATA >1001,>0692,>02E0,>2038
        DATA >C80B,>83F6,>0380,>0200
        DATA >0B00,>0460,>2084,>02E0
        DATA >83E0,>C80B,>204E,>06A0
        DATA >000E,>02E0,>2038,>C80B
        DATA >83F6,>0380,>06A0,>24CA
        DATA >D82D,>0002,>8C00,>0380
        DATA >06A0,>24CA,>D831,>8C00
        DATA >0602,>16FC,>0380,>06A0
        DATA >24D0,>DB60,>8800,>0002
        DATA >0380,>06A0,>24D0,>DC60
        DATA >8800,>0602,>16FC,>0380
        DATA >C05D,>D82D,>0001,>8C02
        DATA >0261,>8000,>D801,>8C02
        DATA >0380,>0201,>4000,>1001
        DATA >04C1,>C09D,>D820,>203D
        DATA >8C02,>E081,>D802,>8C02
        DATA >C06D,>0002,>C0AD,>0004
        DATA >045B
***********************************************************
CHARS  BYTE >00,>00,>00,>00,>00,>00,>00    *      32
       BYTE >20,>20,>20,>20,>20,>00,>20    *      33
       BYTE >50,>50,>50,>00,>00,>00,>00    *      34
       BYTE >50,>50,>F8,>50,>F8,>50,>50    *      35
       BYTE >20,>78,>A0,>70,>28,>F0,>20    *      36
       BYTE >C0,>C8,>10,>20,>40,>98,>18    *      37
       BYTE >40,>A0,>A0,>40,>A8,>90,>68    *      38
       BYTE >C0,>40,>80,>00,>00,>00,>00    *      39
       BYTE >08,>10,>20,>20,>20,>10,>08    *      40
       BYTE >80,>40,>20,>20,>20,>40,>80    *      41
       BYTE >20,>A8,>70,>D8,>70,>A8,>20    *      42
       BYTE >00,>20,>20,>F8,>20,>20,>00    *      43
       BYTE >00,>00,>00,>00,>60,>20,>40    *      44
       BYTE >00,>00,>00,>F8,>00,>00,>00    *      45
       BYTE >00,>00,>00,>00,>00,>60,>60    *      46
       BYTE >00,>08,>10,>20,>40,>80,>00    *      47
       BYTE >70,>88,>98,>A8,>C8,>88,>70    *      48
       BYTE >20,>60,>20,>20,>20,>20,>70    *      49
       BYTE >70,>88,>08,>30,>40,>80,>F8    *      50
       BYTE >70,>88,>08,>30,>08,>88,>70    *      51
       BYTE >10,>30,>50,>90,>F8,>10,>10    *      52
       BYTE >F0,>80,>80,>F0,>08,>88,>70    *      53
       BYTE >70,>80,>80,>F0,>88,>88,>70    *      54
       BYTE >F8,>08,>10,>20,>40,>40,>40    *      55
       BYTE >70,>88,>88,>70,>88,>88,>70    *      56
       BYTE >70,>88,>88,>78,>08,>88,>70    *      57
       BYTE >00,>60,>60,>00,>60,>60,>00    *      58
       BYTE >00,>60,>60,>00,>60,>20,>40    *      59
       BYTE >08,>10,>20,>40,>20,>10,>08    *      60
       BYTE >00,>00,>F8,>00,>F8,>00,>00    *      61
       BYTE >80,>40,>20,>10,>20,>40,>80    *      62
       BYTE >70,>88,>10,>20,>20,>00,>20    *      63
       BYTE >70,>88,>08,>68,>A8,>A8,>58    *      64
       BYTE >70,>88,>88,>F8,>88,>88,>88    *      65
       BYTE >F0,>48,>48,>70,>48,>48,>F0    *      66
       BYTE >70,>88,>80,>80,>80,>88,>70    *      67
       BYTE >F0,>48,>48,>48,>48,>48,>F0    *      68
       BYTE >F8,>80,>80,>F0,>80,>80,>F8    *      69
       BYTE >F8,>80,>80,>F0,>80,>80,>80    *      70
       BYTE >70,>88,>80,>80,>98,>88,>78    *      71
       BYTE >88,>88,>88,>F8,>88,>88,>88    *      72
       BYTE >F8,>20,>20,>20,>20,>20,>F8    *      73
       BYTE >08,>08,>08,>08,>08,>88,>70    *      74
       BYTE >88,>90,>A0,>C0,>A0,>90,>88    *      75
       BYTE >80,>80,>80,>80,>80,>80,>F8    *      76
       BYTE >88,>D8,>A8,>A8,>88,>88,>88    *      77
       BYTE >88,>88,>C8,>A8,>98,>88,>88    *      78
       BYTE >70,>88,>88,>88,>88,>88,>70    *      79
       BYTE >F0,>88,>88,>88,>F0,>80,>80    *      80
       BYTE >70,>88,>88,>88,>A8,>90,>68    *      81
       BYTE >F0,>88,>88,>F0,>A0,>90,>88    *      82
       BYTE >70,>88,>80,>70,>08,>88,>70    *      83
       BYTE >F8,>20,>20,>20,>20,>20,>20    *      84
       BYTE >88,>88,>88,>88,>88,>88,>70    *      85
       BYTE >88,>88,>88,>88,>88,>50,>20    *      86
       BYTE >88,>88,>88,>88,>A8,>A8,>50    *      87
       BYTE >88,>88,>50,>20,>50,>88,>88    *      88
       BYTE >88,>88,>88,>50,>20,>20,>20    *      89
       BYTE >F8,>08,>10,>20,>40,>80,>F8    *      90
       BYTE >78,>40,>40,>40,>40,>40,>78    *      91
       BYTE >00,>80,>40,>20,>10,>08,>00    *      92
       BYTE >F0,>10,>10,>10,>10,>10,>F0    *      93
       BYTE >20,>50,>88,>00,>00,>00,>00    *      94
       BYTE >00,>00,>00,>00,>00,>00,>FF    *      95
       BYTE >18,>10,>08,>00,>00,>00,>00    *      96
       BYTE >00,>00,>60,>10,>70,>90,>68    *      97
       BYTE >00,>40,>40,>70,>48,>48,>B0    *      98
       BYTE >00,>00,>60,>90,>80,>90,>60    *      99
       BYTE >00,>10,>10,>70,>90,>90,>68    *     100
       BYTE >00,>00,>60,>90,>E0,>80,>70    *     101
       BYTE >00,>30,>40,>E0,>40,>40,>40    *     102
       BYTE >00,>00,>70,>90,>70,>10,>60    *     103
       BYTE >00,>80,>80,>E0,>90,>90,>90    *     104
       BYTE >00,>20,>00,>20,>20,>20,>70    *     105
       BYTE >00,>10,>00,>10,>10,>90,>60    *     106
       BYTE >00,>80,>90,>A0,>C0,>A0,>90    *     107
       BYTE >00,>60,>20,>20,>20,>20,>70    *     108
       BYTE >00,>00,>D0,>A8,>A8,>A8,>A8    *     109
       BYTE >00,>00,>B0,>48,>48,>48,>48    *     110
       BYTE >00,>00,>60,>90,>90,>90,>60    *     111
       BYTE >00,>00,>F0,>48,>48,>70,>40    *     112
       BYTE >00,>00,>78,>90,>90,>70,>10    *     113
       BYTE >00,>00,>B0,>C8,>80,>80,>80    *     114
       BYTE >00,>00,>70,>80,>70,>08,>F0    *     115
       BYTE >00,>40,>E0,>40,>40,>50,>20    *     116
       BYTE >00,>00,>90,>90,>90,>90,>68    *     117
       BYTE >00,>00,>88,>88,>88,>50,>20    *     118
       BYTE >00,>00,>88,>88,>A8,>A8,>50    *     119
       BYTE >00,>00,>88,>50,>20,>50,>88    *     120
       BYTE >00,>00,>48,>48,>38,>08,>70    *     121
       BYTE >00,>00,>F8,>10,>20,>40,>F8    *     122
       BYTE >18,>20,>20,>40,>20,>20,>18    *     123
       BYTE >20,>20,>20,>00,>20,>20,>20    *     124
       BYTE >C0,>20,>20,>10,>20,>20,>C0    *     125
       BYTE >00,>00,>40,>A8,>10,>00,>00    *     126
       BYTE >00,>00,>00,>00,>00,>00,>00    *     127
       BYTE >00,>00,>00,>00,>00,>00,>00    *     128
***********************************************************
       END
 

Spoiler

***********************************************************
       TITL 'MYXB5'
***********************************************************
       GROM >A000
***********************************************************
       TITL 'EQUATES EXEC-359'
***********************************************************
*           GROM ADDRESSES
***********************************************************
*    EQUATES FOR ROUTINES FROM OTHER GROM SECTIONS
CHRTBL EQU  >6018             RXB CALL CHRTBL load char set
TOPLEV EQU  >6372             RXB CALL USER branch
SZNEW  EQU  >63A5             RXB CALL NEW branch
TOPL15 EQU  >63DD             RXB CALL USER branch
SZSIZE EQU  >65C9             RXB CALL SIZE branch
CLSALL EQU  >8012             RXB branch
GE025  EQU  >E025             RXB branch EA module
SPRINT EQU  >6016             Initialize sprites
TOPL10 EQU  >601A             Return to main and re-init
CHRTAB EQU  >601C             Load default character set
SZRUN  EQU  >601E
KILSYM EQU  >6022             KILL SYMBOL TABLE ROUTINE
AUTO1  EQU  >602E             Get arguments for LIST comman
TOPL02 EQU  >6030             RTN address for failing AUTOL
EDITLN EQU  >6032             Edit a line into the program
GRSUB1 EQU  >6034             Read data (2 bytes) from ERAM
GWSUB  EQU  >6036             Write a few bytes of data to
MSGBRK EQU  >6048             * BREAKPOINT
MSGTA  EQU  >6053             Message "try again"
CHKEND EQU  >6A78             Check end of statement
DISO   EQU  >6A7C
ENTER  EQU  >6A7E
ENT09  EQU  >6A80
WARNZZ EQU  >6A82             WARNING MESSAGE ROUTINE
ERRZZ  EQU  >6A84             ERROR MESSAGE ROUTINE
ERRZ   EQU  >6A84             ERRor routine
READL1 EQU  >6A86             Read a line from keyboard
DISPL1 EQU  >8000
DELET  EQU  >8002
PRINT  EQU  >8004
INPUT  EQU  >8006
OPEN   EQU  >8008
CLOSE  EQU  >800A
RESTOR EQU  >800C
NREAD  EQU  >800E
EOF    EQU  >801C
ACCEPT EQU  >801E
SRDATA EQU  >8020
REC    EQU  >8022
GRSUB2 EQU  >802C
GRSUB3 EQU  >802E
LINPUT EQU  >8030
GRINT  EQU  >0022             Greatest integer
***********************************************************
*    Equates for XMLs
SYNCHK EQU  >00               SYNCHK XML selector
FILSPC EQU  >01               Fill-space utility
PARCOM EQU  >01               PARse to a COMma selector
CSTRIN EQU  >02               Copy-string utility
RANGE  EQU  >02               RANGE selector
SEETWO EQU  >03               SEETWO XML selector
FADD   EQU  >06               Floating ADD
FMUL   EQU  >08               Floating MULtiply
FDIV   EQU  >09               Floating DIVide
FCOMP  EQU  >0A               Floating COMPare
SADD   EQU  >0B               Stack ADD
SSUB   EQU  >0C               Stack SUBtract
CSNUM  EQU  >10               Convert String to Number
CFI    EQU  >12               Convert to two byte integer
FLTINT EQU  >12               Convert floating to integer
COMPCT EQU  >70               PREFORM A GARBAGE COLLECTION
GETSTR EQU  >71               SYSTEM GET STRING
MEMCHK EQU  >72               MEMORY check routine: VDP
CNS    EQU  >73               Convert number to string
* Warning Defualt changfd in >0079
PARSE  EQU  >74               Parse a value
CONT   EQU  >75               Continue parsing
EXECG  EQU  >76               Execute a XB stmt or program
VPUSH  EQU  >77               Push on value stack
VPOP   EQU  >78               Pop off value stack
PGMCHR EQU  >79               GET PROGRAM CHARACTER
SYM    EQU  >7A               Find SYMBOL entry
SMB    EQU  >7B               Find symbol table entry
ASSGNV EQU  >7C               Assign VARIABLE
SCHSYM EQU  >7D               Search symbol table
SPEED  EQU  >7E               SPEED UP XML
CRUNCH EQU  >7F               Crunch an input line
CIF    EQU  >80               Convert INTEGER to FLOATING P
RTNB   EQU  >82               Return
SCROLL EQU  >83               SCROLL THE SCREEN
IO     EQU  >84               IO utility (KW table search)
GREAD  EQU  >85               READ DATA FROM ERAM
GWRITE EQU  >86               WRITE DATA TO ERAM
DELREP EQU  >87               REMOVE CONTENT FROM VDP/ERAM
MVDN   EQU  >88               MOVE DATA IN VDP/ERAM
MVUP   EQU  >89               MOVE DATA IN VDP/ERAM
VGWITE EQU  >8A               MOVE DATA FROM VDP TO ERAM
GVWITE EQU  >8B               WRITE DATA FROM GRAM TO VRAM
GREAD1 EQU  >8C               READ DATA FROM ERAM
GDTECT EQU  >8E               ERAM DETECT&ROM PAGE 1 ENABLE
SCNSMT EQU  >8F               SCAN STATEMENT FOR PRESCAN
***********************************************************
*    Temporary workspaces in EDIT
VAR0   EQU  >8300            TEMPORARY
SP00   EQU  >8300            SPRITE value
PTFBSL EQU  >8300            Ptr to 1st byte in SPEAK list
PHLEN  EQU  >8300            PHrom data LENgth
VARV   EQU  >8301            TEMPORARY
PHRADD EQU  >8301            PHRom ADDress
ACCUM  EQU  >8302            # OF BYTES ACCUMULATOR (4 BYTE
STPT   EQU  >8302            TWO BYTES
MNUM   EQU  >8302            Ussually a counter
AAA1   EQU  >8302
SP02   EQU  >8302            SPRITE value
PTLBSL EQU  >8302            Ptr to last byte in SPEAK list
VARY   EQU  >8304
PABPTR EQU  >8304            Pointer to current PAB
SP04   EQU  >8304            SPRITE value
PTEBSL EQU  >8304            Ptr to end byte in SPEAK list
* NOTE: PTEBSL points to the end of the temporary speak lis
*       whereas PTLBSL points to the last byte actually use
*       i.e.    PTFBSL <= PTLBSL <= PTEBSL
VARY2  EQU  >8306            Use in MVDN only
DFLTLM EQU  >8306            Default array limit (10)
CCPPTR EQU  >8306            OFFSET WITHIN RECORED (1)
*                             or Pointer to current column
SP06   EQU  >8306            SPRITE value
PTFCIS EQU  >8306            Ptr to 1st character in string
RECLEN EQU  >8307            LENGTH OF CURRENT RECORD (1)
CCPADR EQU  >8308            RAM address of current refs
*                             or Actual buffer address or c
VARC   EQU  >8308
CCPADD EQU  >8308            RAM address of current color
CCC1   EQU  >8308
SPSAL  EQU  >8308            Location of sprite attribute l
PTCCIS EQU  >8308            Ptr to current character in st
CALIST EQU  >830A            Call list for resolving refs
RAMPTR EQU  >830A            Pointer for crunching
STADDR EQU  >830A            Start address - usually for co
SPTMP  EQU  >830A            Temporary variable
PTLCIS EQU  >830A            Ptr to last character in strin
VAR2   EQU  >830B
BYTES  EQU  >830C            BYTE COUNTER
*                             or String length for GETSTR
NMPTR  EQU  >830C            Pointer save for pscan
BBB1   EQU  >830C
PTFCIP EQU  >830C            Ptr to 1st character in phrase
CHSAV  EQU  >830E
CURINC EQU  >830E            Increment for auto-num mode
VAR4   EQU  >830E
PTCCIP EQU  >830E            Ptr to current character in ph
TOPSTK EQU  >8310            Top of data stack pointer
VAR5   EQU  >8310            VAR5 through VAR5+3 used in RA
PTLCIP EQU  >8310            Ptr to last character in phras
VAR6   EQU  >8311
LINUM  EQU  >8312            Used to determine end of scan
PTFBPH EQU  >8312            Ptr to 1st byte in PHrom
VAR7   EQU  >8312            Used in CHARLY
STRPTR EQU  >8312            RXB PATCH CODE
NMLEN  EQU  >8314            Current line for auto-num
CURLIN EQU  >8314            Current line for auto-num
*                             or Starting line number for L
PTCCPH EQU  >8314            Ptr to current byte in PHrom
VAR9   EQU  >8314             Used in CHARLY
XFLAG  EQU  >8316            SCAN FLAG-BITS USED AS BELOW
PTLCPH EQU  >8316            Ptr to last byte in PHrom
DSRFLG EQU  >8317            INTERNAL =60, EXTERNAL =0 (1)
OPTFLG EQU  >8317            Option flag byte during OPEN
FORNET EQU  >8317            Nesting level of for/next
FNUM   EQU  >8317            Current file number for search
***********************************************************
*    Permanent workspace variables
STRSP  EQU  >8318            String space begining
STREND EQU  >831A            String space ending
SREF   EQU  >831C            Temporary string pointer
SMTSRT EQU  >831E            Start of current statement
VARW   EQU  >8320            Screen address (CURSOR)
ERRCOD EQU  >8322            Return error code from ALC
STVSPT EQU  >8324            Value-stack base
RTNG   EQU  >8326            Return vector from 9900 code
NUDTAB EQU  >8328            Start of NUD table
VARA   EQU  >832A            Ending display location
PGMPTR EQU  >832C            Program text pointer (TOKEN)
EXTRAM EQU  >832E            Line number table pointer
STLN   EQU  >8330            Start of line number table
ENLN   EQU  >8332            End of line number table
DATA   EQU  >8334            Data pointer for READ
LNBUF  EQU  >8336            Line table pointer for READ
INTRIN EQU  >8338            Add of intrinsic poly constant
SUBTAB EQU  >833A            Subprogram symbol table
IOSTRT EQU  >833C            PAB list/Start of I/O chain
SYMTAB EQU  >833E            Symbol table pointer
FREPTR EQU  >8340            Free space pointer
CHAT   EQU  >8342            Current charater/token
BASE   EQU  >8343            OPTION BASE value
PRGFLG EQU  >8344            Program/imperative flag
FLAG   EQU  >8345            General 8-bit flag
BUFLEV EQU  >8346            Crunch-buffer destruction leve
LSUBP  EQU  >8348            Last subprogram block on stack
* FAC  EQU  >834A            Floating-point ACcurmulator
CCHAR  EQU  >834A            Current character
FAC1   EQU  FAC+1
SPLFLG EQU  >834B            SPelL out phrase FLaG
FAC2   EQU  FAC+2
AAA    EQU  FAC+2
TOTTIM EQU  >834C            TOTal wait TIMe
* NOTE: DATAD must follow immediately after TOTTIM. The
*       routine STDATA is counting on this fact!
FAC3   EQU  FAC+3
DATAAD EQU  >834D            Speech DATA ADdress
FAC4   EQU  FAC+4
CCC    EQU  FAC+4
FFF    EQU  FAC+4
FAC5   EQU  FAC+5
PTLCIL EQU  >834F            Pointer To Last Character In L
FAC6   EQU  FAC+6
BBB    EQU  FAC+6
EEE    EQU  FAC+6
FAC7   EQU  FAC+7
TIMLEN EQU  >8351             TIMe LENgth of timing charact
FAC8   EQU  FAC+8
PHADDR EQU  >8352             PHrom ADDRess
FAC9   EQU  FAC+9
FAC10  EQU  FAC+10
DDD1   EQU  FAC+10
TEMP1  EQU  >8354            TEMPorary CPU location 1
FAC11  EQU  FAC+11
FAC12  EQU  FAC+12
FFF1   EQU  FAC+12
TEMP2  EQU  >8356            TEMPorary CPU location 2
FAC13  EQU  FAC+13
FAC14  EQU  FAC+14
EEE1   EQU  FAC+14
READ   EQU  >8358            Address of speech peripheral
*                             READ byte interface
FAC15  EQU  FAC+15
FAC16  EQU  FAC+16
WRITE  EQU  >835A            Address of speech peripheral
*                             WRITE byte interface
FAC17  EQU  FAC+17
* ARG  EQU  >835C            Floating-point ARGument
ARG1   EQU  ARG+1
PHDATA EQU  >835D            PHrom DATA
ARG2   EQU  ARG+2
PTCBED EQU  >835E            Ptr To Current Byte Ext Data
ARG3   EQU  ARG+3
ARG4   EQU  ARG+4
LENCST EQU  >8360            LEN of Current ext data STring
ARG5   EQU  ARG+5
ARG6   EQU  ARG+6
LENWST EQU  >8362            LEN of Whole ext data STring
ARG7   EQU  ARG+7
ARG8   EQU  ARG+8
STRLEN EQU  >8364            STRing LENgth
TEMP4  EQU  >8364
TEMP5  EQU  >8366
* NOTE: BYTE1, BYTE2, and BYTE3 must be in consecutive memo
*       locations, and in the following order for SPGET to
*       work!
BYTE1  EQU  >8366            BYTE 1
BYTE2  EQU  >8367            BYTE 2
BYTE3  EQU  >8368            BYTE 3
TEMP6  EQU  >8368
SPKSTS EQU  >8369            SPeaK StaTus
* FPERAD EQU  >836C          Value stack pointer
ARG11  EQU  ARG+11
ARG15  EQU  ARG+15
ARG16  EQU  ARG+16
* VSPTR  EQU  >836E          Value stack pointer
***********************************************************
*    GPL Status Block
* SUBSTK EQU  >8373           SUBROUTINE STACK
KEYBD  EQU  >8374             KEYBOARD SELCTION
RKEY   EQU  >8375             KEY CODE
EXPZ   EQU  >8376             Exponent in floating-point
JOYY   EQU  >8376             JOYSTICK Y POSITION
JOYX   EQU  >8377             JOYSTICK X POSITION
RANDOM EQU  >8378             RANDOM NUMBER GENERATOR
TIMER  EQU  >8379             TIMING REGISTER
MOTION EQU  >837A             NUMBER OF MOVING SPRITES
VDPSTS EQU  >837B             VDP STATUS REGISTER
VDPSTT EQU  >837B             VDP STATUS REGISTER
ERCODE EQU  >837C             STATUS REGISTER
CB     EQU  >837D             Character Buffer
***********************************************************
RAMTOP EQU  >8384            Highest address in ERAM
RAMFRE EQU  >8386            Free pointer in the ERAM
RSTK   EQU  >8388            Subroutine stack base
*                             (Starts at >8A)
RAMFLG EQU  >8389            ERAM flag
GRAMFL EQU  >8389            GRAM / VDP flag
STKMIN EQU  >83AF            Base of data stack
STKMAX EQU  >83BD            Top of data stack
PRTNFN EQU  >83CE            Sound - previous tone finished
***********************************************************
*    VDP addresses
SCRNBS EQU  >02E0             Screen base addr for last lin
NLNADD EQU  >02E2             New LiNe ADDress
ENDSCR EQU  >02FE             END of SCReen address
SPRSAL EQU  >0300             Sprite attribute list
START  EQU  >0372             Line to start execution at
* Temporary
NOTONE EQU  >0374             NO-TONE for SIZE in ACCEPT us
*                              in FLMGRS (4 bytes used)
SYMBOL EQU  >0376             Saved symbol table pointer
ONECHR EQU  >0378             Used for CHRZ
VRMSND EQU  >0379             Sound blocks
SPGMPT EQU  >0382             Saved PGMPTR for continue
SBUFLV EQU  >0384             Saved BUFLEV for contiue
SEXTRM EQU  >0386             Saved EXTRAM for continue
SAVEVP EQU  >0388             Saved VSPRT for continue
ERRLN  EQU  >038A             On-error line pointer
CSNTMP EQU  >0390             Use as temporary stored place
*                          or CSN TEMPORARY FOR FAC12
TABSAV EQU  >0392             Saved main symbol table ponte
AUTTMP EQU  >0394             AUTOLD TEMPORARY IN SIDE ERRZ
SLSUBP EQU  >0396             Saved LSUBP for continue
SFLAG  EQU  >0398             Saved on-warning/break bits
SSTEMP EQU  >039A             To save subprogram program ta
SSTMP2 EQU  >039C             Same as above. Used in SUBPRO
MRGPAB EQU  >039E             MERGEd temporary for pab ptr
RNDX2  EQU  >03A0             Random number generator seed
RNDX1  EQU  >03A5             Random number generator seed
INPUTP EQU  >03AA             INPUT TEMPORARY FOR PTR TO PR
SPNUM  EQU  >03AA             Sprite number temporary, also
*                              in INPUTP in FLMGR
ACCVRW EQU  >03AC             Temoporary used in ERRZZ, als
*                              used in FLMGRS
*                             or temporary for @VARW, @VARA
ACCVRA EQU  >03AE             TRY AGAIN
VALIDP EQU  >03B0             Use as two values passing fro
*                          or PTR TO STANDARD STRING IN VAL
VALIDL EQU  >03B2             VALIDATE code to READL1
*                          or Length of string in validate
SIZCCP EQU  >03B4             SIZE TEMPORARY FOR CCPADR
SIZREC EQU  >03B6             SIZE TEMPORARY FOR RECLEN
*
ACCTRY EQU  >03B7             ACCEPT "TRY AGAIN" FLAG
SIZXPT EQU  >03B8             Save XPT in SIZE when "try ag
CSNTP1 EQU  >03BA             CSN TEMPORARY FOR FAC10
*
OLDTOP EQU  >03BC             Temporary used in ERRZZ, also
*                          or Old top of memory for RELOCA
CPTEMP EQU  >03BC             CCPPTR, RECLEN temp in INPUT
NEWTOP EQU  >03BE             New top of memory for RELOCA
VROAZ  EQU  >03C0             Temporary roll-out area
SPRVB  EQU  >07FF             Sprite velocity block.
CRNBUF EQU  >0820             CRuNch BUFfer address
CRNEND EQU  >08BE             CRuNch buffer END
VRAMVS EQU  >0958             Default base of value stack
***********************************************************
*    IMMEDITATE VALUES
NUMBR  EQU  >00               NUMERIC validate
LISTZ  EQU  >02
X2     EQU  >03
OLDZ   EQU  >05
RESEQZ EQU  >06
SAVEZ  EQU  >07
MERGEZ EQU  >08
DWNARR EQU  >0A
UPARR  EQU  >0B
CHRTN  EQU  >0D
BKGD   EQU  >20               BACKGROUND CHARACTER
OFFSET EQU  >60               OFFSET FOR VIDEO TABLES
STRVAL EQU  >65               Value in accum. is string val
***********************************************************
* Editting command equates & keys or symbols
BREAK  EQU  >02               Break key
DLETE  EQU  >03               Delete key
INSRT  EQU  >04               Insert key
RECALL EQU  >06               Edit-buffer recall
CLRLN  EQU  >07               Clear-line key
BACK   EQU  >08               Back-space key
FORW   EQU  >09               Forward-space key
DOWN   EQU  >0A               Down-arrow key
UPMV   EQU  >0B               Up-arrow key
VWIDTH EQU  >1C               Screen width (PRINT)
SPACE  EQU  >20               Space key
QUOTE  EQU  >22               "
NUMBER EQU  >23               #
DOLLAR EQU  >24               $
CURSOR EQU  >1E+OFFSET        CURSOR
EDGECH EQU  >1F+OFFSET        EDGE character
PLUS   EQU  >2B               +
COMMAT EQU  >2C               ,
MINUS  EQU  >2D               -
HYPEN  EQU  >2D               +
PERIOD EQU  >2E               .
ZERO   EQU  >30               0
NINE   EQU  >39               9
COLON  EQU  >3A               :
SEMICO EQU  >3B               ;
LESS   EQU  >3C               <
GREAT  EQU  >3E               >
A      EQU  >41               A
F      EQU  >46               F
***********************************************************
*    BASIC TOKEN TABLE
*      EQU  >80               spare token
ELSEZ  EQU  >81               ELSE
SSEPZ  EQU  >82               ::
TREMZ  EQU  >83               $
IFZ    EQU  >84               IF
GOZ    EQU  >85               GO
GOTOZ  EQU  >86               GOTO
GOSUBZ EQU  >87               GOSUB
RETURZ EQU  >88               RETURN
DEFZ   EQU  >89               DEF
DIMZ   EQU  >8A               DIM
ENDZ   EQU  >8B               END
FORZ   EQU  >8C               FOR
LETZ   EQU  >8D               LET
BREAKZ EQU  >8E               BREAK
UNBREZ EQU  >8F               UNBREAK
TRACEZ EQU  >90               TRACE
UNTRAZ EQU  >91               UNTRACE
INPUTZ EQU  >92               INPUT
DATAZ  EQU  >93               DATA
RESTOZ EQU  >94               RESTORE
RANDOZ EQU  >95               RANDOMIZE
NEXTZ  EQU  >96               NEXT
READZ  EQU  >97               READ
STOPZ  EQU  >98               STOP
DELETZ EQU  >99               DELETE
REMZ   EQU  >9A               REM
ONZ    EQU  >9B               ON
PRINTZ EQU  >9C               PRINT
CALLZ  EQU  >9D               CALL
OPTIOZ EQU  >9E               OPTION
OPENZ  EQU  >9F               OPEN
CLOSEZ EQU  >A0               CLOSE
SUBZ   EQU  >A1               SUB
DISPLZ EQU  >A2               DISPLAY
IMAGEZ EQU  >A3               IMAGE
ACCEPZ EQU  >A4               ACCEPT
ERRORZ EQU  >A5               ERROR
WARNZ  EQU  >A6               WARNING
SUBXTZ EQU  >A7               SUBEXIT
SUBNDZ EQU  >A8               SUBEND
RUNZ   EQU  >A9               RUN
LINPUZ EQU  >AA               LINPUT
*      EQU  >AB               spare token (LIBRARY)
*      EQU  >AC               spare token (REAL)
*      EQU  >AD               spare token (INTEGER)
*      EQU  >AE               spare token (SCRATCH)
*      EQU  >AF               spare token
THENZ  EQU  >B0               THEN
TOZ    EQU  >B1               TO
STEPZ  EQU  >B2               STEP
COMMAZ EQU  >B3               ,
SEMICZ EQU  >B4               ;
COLONZ EQU  >B5               :
RPARZ  EQU  >B6               )
LPARZ  EQU  >B7               (
CONCZ  EQU  >B8               &          (CONCATENATE)
*      EQU  >B9               spare token
ORZ    EQU  >BA               OR
ANDZ   EQU  >BB               AND
XORZ   EQU  >BC               XOR
NOTZ   EQU  >BD               NOT
EQUALZ EQU  >BE               =
LESSZ  EQU  >BF               <
GREATZ EQU  >C0               >
PLUSZ  EQU  >C1               +
MINUSZ EQU  >C2               -
MULTZ  EQU  >C3               *
DIVIZ  EQU  >C4               /
CIRCUZ EQU  >C5               ^
*      EQU  >C6               spare token
STRINZ EQU  >C7               QUOTED STRING
UNQSTZ EQU  >C8               UNQUOTED STRING
NUMZ   EQU  >C8               ALSO NUMERICAL STRING
NUMCOZ EQU  >C8               ALSO UNQUOTED STRING
LNZ    EQU  >C9               LINE NUMBER CONSTANT
*      EQU  >CA               spare token
ABSZ   EQU  >CB               ABS
ATNZ   EQU  >CC               ATN
COSZ   EQU  >CD               COS
EXPZZ  EQU  >CE               EXP
INTZ   EQU  >CF               INT
LOGZ   EQU  >D0               LOG
SGNZZ  EQU  >D1               SGN
SINZ   EQU  >D2               SIN
SQRZ   EQU  >D3               SQR
TANZ   EQU  >D4               TAN
LENZ   EQU  >D5               LEN
CHRZZ  EQU  >D6               CHR$
RNDZ   EQU  >D7               RND
SEGZZ  EQU  >D8               SEG$
POSZ   EQU  >D9               POS
VAL    EQU  >DA               VAL
STRZZ  EQU  >DB               STR$
ASCZ   EQU  >DC               ASC
PIZ    EQU  >DD               PI
RECZ   EQU  >DE               REC
MAXZ   EQU  >DF               MAX
MINZ   EQU  >E0               MIN
RPTZZ  EQU  >E1               RPT$
*      EQU  >E2               unused
*      EQU  >E2               unused
*      EQU  >E3               unused
*      EQU  >E4               unused
*      EQU  >E5               unused
*      EQU  >E6               unused
*      EQU  >E7               unused
NUMERZ EQU  >E8               NUMERIC
DIGITZ EQU  >E9               DIGIT
UALPHZ EQU  >EA               UALPHA
SIZEZ  EQU  >EB               SIZE
ALLZ   EQU  >EC               ALL
USINGZ EQU  >ED               USING
BEEPZ  EQU  >EE               BEEP
ERASEZ EQU  >EF               ERASE
ATZ    EQU  >F0               AT
BASEZ  EQU  >F1               BASE
*      EQU  >F2               spare token (TEMPORARY)
VARIAZ EQU  >F3               VARIABLE
RELATZ EQU  >F4               RELATIVE
INTERZ EQU  >F5               INTERNAL
SEQUEZ EQU  >F6               SEQUENTIAL
OUTPUZ EQU  >F7               OUTPUT
UPDATZ EQU  >F8               UPDATE
APPENZ EQU  >F9               APPEND
FIXEDZ EQU  >FA               FIXED
PERMAZ EQU  >FB               PERMANENT
TABZ   EQU  >FC               TAB
NUMBEZ EQU  >FD               #
VALIDZ EQU  >FE               VALIDATE
*      EQU  >FF               ILLEGAL VALUE
***********************************************************
* NOTE: FILES EXECSD, SUBS AND PART OF PSCANS ARE IN GROM 5
*       AS BELOW:
*-------NAME------------------ADDRESS---------BYTES LEFT---
*      EXECS                  >A000 - >AD92        5
*      SUBS                   >AD98 - >B4DC        2
*      PSCANS                 >B4E0 - >B7FA        5
*
* Some of the error calls at the end of EXECS file are
* shared and directly addressed by SUBS file. Any change in
* EXECS file which affects the address of error calls will
* affect error reference in SUBS file. Make sure to edit
* SUBS file in that situation.
***********************************************************
       XML  CONT              XML CONT used by subprogram
       BR   LITS05            Build FAC entry and GETSTR
       BR   EXEC              Execute a program
       BR   LINE
       BR   DATAST
       BR   ASC
       BR   EXEC1
       BR   EXEC6D            Save information on a break
       BR   DELINK            Delink symbol table entry
       BR   CONV1
       BR   SQUISH            Called in error routine in PS
       BR   VALCD
       BR   INTRND
       BR   $
GA01C  BR   LNKRTN            Routine to go back to XB prog
GA01E  BR   SPCOL             Clear breakpoint in line # ro
       BR   UBSUB             Spare
       BR   $
       BR   $         ***     Please let me know it you add
*                     ***     branches here since it will a
*                     ***     the address of link list. Sum
LINK1  DATA LINK2
       STRI 'SOUND'
       DATA SOUND
LINK2  DATA LINK3
       STRI 'CLEAR'
       DATA CLEAR
LINK3  DATA LINK4
       STRI 'COLOR'
       DATA COLOR
LINK4  DATA LINK5
       STRI 'GCHAR'
       DATA GCHAR
LINK5  DATA LINK6
       STRI 'HCHAR'
       DATA HCHAR
LINK6  DATA LINK7
       STRI 'VCHAR'
       DATA VCHAR
LINK7  DATA LINKA
       STRI 'CHAR'
       DATA CHARLY
LINKA  DATA LINKB
       STRI 'KEY'
       DATA ZKEY
LINKB  DATA LINKC
       STRI 'JOYST'
       DATA ZJOYST
LINKC  DATA LINKD
       STRI 'SCREEN'
       DATA BORDER
LINKD  DATA LINKE
       STRI 'VERSION'
       DATA VERS
LINKE  DATA LINKS1
       STRI 'ERR'
       DATA ERRWXY
***********************************************************
*        START EXECUTION OF A PROGRAM OR STATEMENT
* DATA:
*      RAM(START) points into line number table at the
*      first line to execute
*      @PGMFLG contains >FF if executing a program or zero
*      if imperative statement
***********************************************************
EXEC   CZ   @PRGFLG           If program
       BS   GA0AE
       DST  [email protected],@EXTRAM   Line to start execution at
       DINCT @EXTRAM          Pointer to text pointer
       CALL INTRND            Initialize random number
EXEC1  ST   X2,@XPT           Initialize screen display
       BR   GA0B2
GA0AE  DST  CRNBUF,@PGMPTR    Executing out of crunch buffe
GA0B2  DST  EXEC20,@RTNG      Address of return from ALC
       DST  NUDTB,@NUDTAB     NUD table address for ALC
       XML  EXECG             Execute XB
EXEC20 CASE @ERRCOD+1         Check type of return
       BR   EXECND            0 - NORMAL END
       BR   EXECBK            1 - BREAKPOINT
       BR   EXECTR            2 - TRACE
       BR   ERORZ             3 - ERROR
       BR   WARNGZ            4 - WARNING
       BR   ONERR             5 - ON ERROR
       BR   UDF               6 - FUNCTION
       BR   ONBRK             7 - ON BREAK
       BR   CONCAT            8 - CONCATENATE STRINGS "&"
       BR   ONWARN            9 - ON WARNING
       BR   GPLCAL            A - CALL STATEMENT
WARNGZ CH   >B0,@SUBSTK
       BS   ERRSO
* Stack overflow
*                    ALLOW ROOM ON STACK FOR WARNING CALLS
WRNN01 CALL WARNZZ        ONLY WARNING MSG FROM XB SUPPORT
       BYTE 2       *         NUMERIC OVERFLOW
       BR   CLRRTN            Clear ERRCOD and return
*                    NORMAL END OF EXECUTION
EXECND CZ   @PRGFLG           If imperative mode
       BR   ERRRDY
       CALL CHRTAB            Load the default character se
       B    TOPL15            Return to top-level
ERRRDY CALL ERRZZ             Display * READY *
       BYTE 0
* TRACE-MODE turned on - display line number
EXECTR CLR  @VARW             Clear upper address byte
       ST   @XPT,@VARW+1      Get current x-pointer
       DADD NLNADD-3,@VARW    Make a valid screen address
       DCH  NLNADD+22,@VARW   If might go off screen
       BR   GA102
       XML  SCROLL            SCROLL to next line
       DST  NLNADD,@VARW      Re-initialize screen address
GA102  ST   LESS+OFFSET,V*VARW Display open bracket "("
       DINC @VARW             Increment screen address
       CALL ASC               Convert line # into ASCII
       ST   GREAT+OFFSET,V*VARW Display close bracket ")"
       DSUB NLNADD-4,@VARW    Update the x-pointer
       ST   @VARW+1,@XPT
CLRRTN DCLR @ERRCOD           Clear the return vector
       XML  RTNB              Return to ALC
* BREAKPOINT OR BREAK-KEY RECIEVED
EXECBK CZ   @PRGFLG           If break or program
       BS   ERRBRK
       DST  @EXTRAM,@FAC8     @FAC8 : Source addr in ERAM
       DDECT @FAC8            Point to the line #
       CALL UBSUB1            Reset the breakpoint
       SCAN                   Get break key out of queue
EXEC6C DST  @PGMPTR,[email protected]  Save text pointer
EXEC6D DST  @EXTRAM,[email protected]  Save line number table pointe
       DST  @VSPTR,[email protected]   Save value stack pointer
       DST  @BUFLEV,[email protected]  Save crunch buffer level
       DST  @LSUBP,[email protected]   Save last subprogram on stack
       ST   @FLAG,[email protected]     Save FLAG for continue
       AND  >63,[email protected]       Only warning and break bits
ERRBRK CALL ERRZZ             * BREAKPOINT
       BYTE 1
***********************************************************
*               NUD / STATEMENT BRANCH TABLE
***********************************************************
NUDTB  BR   RECX              'RECORD'                    0
       BR   NBREAK            'BREAK'                     0
       BR   NUNBRK            'UNBREAK'                   0
       BR   NTRACE            'TRACE'                     0
       BR   NUNTRC            'UNTRACE'                   0
       BR   NREADX            'READ'                      0
       BR   PRINTX            'PRINT'                     0
       BR   SZRUNX            'RUN'                       0
       BR   LINPUX            Reserved for LINPUT         1
       BR   RESTOX            'RESTORE'                   1
       BR   NRNDMZ            'RANDOMIZE'                 1
       BR   INPUTX            'INPUT'                     1
       BR   OPENX             'OPEN'                      1
       BR   CLOSEX            'CLOSE'                     1
       BR   NPI               'PI'                        1
       BR   NMAX              'MAX'                       1
       BR   NMIN              'MIN'                       2
       BR   RPTZ01            'RPT$'                      2
       BR   ACCEPX            'ACCEPT'                    2
       BR   EOFX              'EOF'                       2
       BR   ASC01             'ASC'                       2
       BR   POS01             'POS'                       2
       BR   VAL01             'VAL'                       2
       BR   STRZ01            'STR$'                      2
       BR   SEGZ01            'SEG$'                      3
       BR   DELETX            'DELETE'                    3
       BR   DISPLX            'DISPLAY'                   3
       BR   LEN01             'LEN'                       3
       BR   CHRZ01            'CHR$'                      3
       BR   NRND              'RND'                       3
* The following are long branches to another GROM
EOFX   B    EOF
SZRUNX B    SZRUN
RECX   B    REC
NREADX B    NREAD
PRINTX B    PRINT
RESTOX B    RESTOR
INPUTX B    INPUT
OPENX  B    OPEN
CLOSEX B    CLOSE
ACCEPX B    ACCEPT
DISPLX B    DISPL1
DELETX B    DELET
LINPUX B    LINPUT
***********************************************************
* FLAGS USED IN EXECUTION MODE:    this needs to be checked
*  @FLAG   BIT   RESET               SET
*           0
*           1    Warning PRINT       PRINT off
*           2    Warning NEXT        STOP
*           3    Not in UDF          Executing a UDF
*           4    TRACE mode          Normal mode
*           5
*           6    BREAK allowed       BREAK not allowed
*           7    No LST/EDT protect  LIST/EDIT protected
***********************************************************
* ON WARNING {NEXT | STOP | PRINT}
* ON WARNING NEXT  - Causes warning messages to be ignored
*                    and execution to continue as if a
*                    warning never occurred
* ON WARNING STOP  - Causes a warning to be treated as an
*                    error - i.e. the message is displayed
*                    and execution is halted
* ON WARNING PRINT - Causes the default warning handling to
*                    be in effect, i.e. any warning
*                    messages are printed and execution
*                    continues
***********************************************************
ONWARN XML  PGMCHR            GET OPTION
       CEQ  PRINTZ,@CHAT      If print
       BR   GA1B7
       AND  >F9,@FLAG         Turn on print and contiue
       B    ONWRN5
GA1B7  CEQ  STOPZ,@CHAT
       BR   GA1C4
       AND  >FD,@FLAG         Turn on print
       OR   >04,@FLAG         Turn on stop
       BR   ONWRN5
GA1C4  CEQ  NEXTZ,@CHAT       * SYNTAX ERROR
       BR   ERRSYN
       OR   >02,@FLAG         Turn off print
       AND  >FB,@FLAG         Turn off stop
ONWRN5 XML  PGMCHR            Check for EOS
ONWRN7 CALL CHKEND            Error if not EOS
       BR   ERRSYN            If not EOS
       DCLR @ERRCOD
       XML  CONT              Continue
***********************************************************
* ON ERROR {line number | STOP}
* ON ERROR line number - causes the error routine to build
*                        an error stack entry and pass
*                        control to the line specified in
*                        the most-recently executed
*                        on-error-statement
* ON ERROR STOP - causes the default error handling
*                 conditions to be in effect. i.e. any
*                 errors that occur cause execution to halt
*                 an a message to be displayed
***********************************************************
ONERR  XML  PGMCHR            Get option
       CEQ  LNZ,@CHAT         If line # then find the line
       BR   GA20E
       XML  PGMCHR            Get upper byte
       ST   @CHAT,@FAC
       XML  PGMCHR            Get lower byte
       ST   @CHAT,@FAC1
       DST  @ENLN,@FAC2
       DSUB 3,@FAC2           Pointing to 1st line #
* Consider both ERAM and RAM cases to get line # from the
* line number table. Also reset the break bit.
ONERR2 CALL GRSUB3            Get 2 bytes from either RAM/E
       BYTE FAC2            * FAC2 has the address
       DCEQ @EEE1,@FAC        If found
       BS   ONERR4
       DCH  @STLN,@FAC2       Not found
       BR   ERRLNF
       DSUB 4,@FAC2           Goto next line
       BR   ONERR2
ONERR4 DINCT @FAC2
       DST  @FAC2,[email protected]
       BR   GA216
GA20E  CEQ  STOPZ,@CHAT       * SYNTAX ERROR
       BR   ERRSYN
       DCLR [email protected]           Back to default error handlin
GA216  BR   ONWRN5            Finish up same as ON WARNING
***********************************************************
* ON BREAK {NEXT | STOP}
* ON BREAK NEXT - Causes any breakpoints which have been
*                 set on statements to be ignored when the
*                 statement is encountered and also masks
*                 the shift-C key so that it is ignored
* ON BREAK STOP - Causes the default break handling to be
*                 in force., i.e. execution is halted and
*                 the BREAKPOINT message is displayed on
*                 the screen
***********************************************************
ONBRK  XML  PGMCHR            Get next char to find option
       CEQ  STOPZ,@CHAT       If stop option specified
       BR   GA225
       AND  >BF,@FLAG         break allowed
       B    GA22D             Don't change this to BR GA22D
GA225  CEQ  NEXTZ,@CHAT       If next option number
       BR   ERRSYN            specified then syntax error
       OR   >40,@FLAG         If next option specified then
*                              break NOT allowed
GA22D  BR   ONWRN5            Finish up same as ON WARNING
***********************************************************
* GPLCAL - If a call is made to a subprogram that does not
*  not exist either in the BASIC program itself or in the
*  internal GPL subprogram list then one final attempt is
*  made to find the subprogram at execution time by
*  searching for the subprogram in the console or a
*  peripheral. If not found there, then a
*  *SUBPROGRAM NOT FOUND error occurs
*
*  Input: the subprogram name is in the FAC and the length
*         of the name is in FAC15
***********************************************************
GPLCAL CZ   @RAMFLG           Can't try if CPU program
       BR   ERRSNF
       DSRL 8,@FAC15          Make name length a double
       DSUB @FAC15,@PGMPTR    Point back at name
       DDEC @PGMPTR           Point at name length
       DST  @PGMPTR,@FAC12    Set pointer to name
       CALL LINK              Issue 'Call Program Link'
       BYTE 10              * Search subprogram lists
       BR   ONWRN7            If all ok, check-end and rtn
       BR   ERRSNF            If not found, error
***********************************************************
*                     NUD FOR PI
***********************************************************
NPI    MOVE 8,[email protected],@FAC    Load constant PI
       XML  CONT
CONPI  BYTE >40,3,14,15,92,65,35,90
* 3.1415992653590E+00
***********************************************************
*                     NUD FOR MAX
***********************************************************
NMAX   CALL MAXMIN            Combine MAX and MIN
       GT
       BR   GA263
NMAXZ1 MOVE 8,@ARG,@FAC
GA263  XML  CONT
***********************************************************
*                     NUD FOR MIN
***********************************************************
NMIN   CALL MAXMIN            Combine MAX and MIN again
       GT
       BR   NMAXZ1
       XML  CONT
***********************************************************
*                COMMON MAX / MIN ROUTINE
***********************************************************
MAXMIN CALL LPAR              Skip "(" parse, and insure ,
       CH   >63,@FAC2         Must be numeric
       BS   ERRSNM
       XML  VPUSH             Push l.h. arg on stack
       XML  PARSE             PARSE up to ")"
       BYTE RPARZ
       CH   >63,@FAC2         Must be numeric
       BS   ERRSNM
       XML  SPEED             Must be
       BYTE SYNCHK        *    at a
       BYTE RPARZ         *      right parenthesis
       MOVE 8,@FAC,@ARG       Save in ARG for compare
       XML  VPOP              Get l.h. arg back
       XML  FCOMP             Compare operands
       RTN
* Initialize random number generator
INTRND MOVE 10,[email protected],[email protected]
       RTN
X2SEED BYTE >42,>03,>23,>15,>00 * =   33521, X2 INITIAL VAL
X1SEED BYTE >43,>02,>3E,>2A,>17 * = 2624223, X1 INITIAL VAL
***********************************************************
*           PSEUDO-RANDOM NUMBER GENERATOR
*      X(N+1) = (A*X(N)+C) MOD M;  RND = X/M
*    WHERE:                 X = X2 * 1E7 + X1
*                           A = A2 * 1E7 + A1
*                           C = C2 * 1E7 + C1
*                           M = 1E14
* ASSUMPTIONS:
*  (1) All numbers are integers; fractional parts are
*      truncated
*  (2) If the variables listed below start in the ranges
*     specified. They will also end in the ranges specified
*
* CONSTANTS: 0 <= A2 < 5E6 ; 0 <= C2 < 1E7
*            0 <= A1 < 5E6 ; 0 <= C1 < 1E7
* VARIABLES: 0 <= X2 < 1E7 ; 0 <= T1 <= 1E14 ; 0 <= T2 < 1E
*            0 <= X1 < 1E7 ; 0 <= T3 <= 1E14 ; 0 <= T4 < 1E
*
*        STACK USAGE:
*            CONSTANT REFS      CONTANT REFS    CONTANT REF
* +---------+      IN/OUT            IN/OUT          IN/OUT
* | STACK+4 | X2*A1(F)(H)       --    ----      --    ----
* +---------+
* | STACK+3 |   T2 (C)(J)       --    ----      --    ----
* +---------+
* | STACK+2 |   T1 (B)(D)   new X1   (E)(N)     --    ----
* +---------+
* | STACK+1 |old X1(A)(G)       T3   (K)(L) new X2   (M)(P)
* +---------+
***********************************************************
* COMPUTE NEW VALUE FOR X1, SAVE IT IN [email protected]
*                             STACK
*                               SREFS   FAC CONTENTS
NRND   MOVE 5,[email protected],@FAC        FAC = X1
       CLR  @FAC5                 FAC = CLR
       DCLR @FAC6                 FAC = CLR
       XML  VPUSH          (A)    FAC = X1
       MOVE 8,[email protected],@ARG        ARG = A1
       XML  FMUL                  FAC = X1*A1
       MOVE 8,[email protected],@ARG        ARG = C1
       XML  FADD               T1=FAC = X1*A1+C1
       XML  VPUSH          (B)    FAC = T1
       MOVE 8,[email protected],@ARG        ARG = 1/1E7
       XML  FMUL                  FAC = T1/1E7
       CALL GRINT              T2=FAC = INT(T1/1E7)
       XML  VPUSH          (C)    FAC = T2
       MOVE 8,[email protected],@ARG        ARG = 1E7
       XML  FMUL                  FAC = T2*1E7
       DSUB 8,@VSPTR
       XML  SSUB           (D) X1=FAC = T1-T2*1E7
       MOVE 5,@FAC,[email protected]        FAC = X1 (new)
       XML  VPUSH          (E)    FAC = X1
* COMPUTE NEW VALUE FOR X2, SAVE IT IN [email protected]
       MOVE 5,[email protected],@FAC        FAC = X2
       CLR  @FAC5                 FAC = CLR
       DCLR @FAC6                 FAC = CLR
       MOVE 8,[email protected],@ARG        ARG = A1
       XML  FMUL                  FAC = X2*A1
       DADD 8,@VSPTR
       XML  VPUSH          (F)    FAC = X2*A1
       DSUB 24,@VSPTR
       XML  VPOP           (G)    FAC = X1
       DADD 32,@VSPTR
       MOVE 8,[email protected],@ARG        ARG = A2
       XML  FMUL                  FAC = X1*A2
       XML  SADD           (H)    FAC = X2*A1+X1*A2
       MOVE 8,[email protected],@ARG        ARG = C2
       XML  FADD                  FAC = X2*A1+X1*A2
       XML  SADD           (J) T3=FAC = X2*A1+X1*A2
       DSUB 16,@VSPTR
       XML  VPUSH          (K)    FAC = T3
       MOVE 8,[email protected],@ARG        ARG = 1/1E7
       XML  FMUL                  FAC = T3/1E7
       CALL GRINT              T4=FAC = INT(T3/1E7)
       MOVE 8,[email protected],@ARG        ARG = 1E7
       XML  FMUL                  FAC = T4*1E7
       XML  SSUB           (L) X2=FAC = T3-T4*1E7
       MOVE 5,@FAC,[email protected]        FAC = X2 (new)
* COMPUTE NEW VALUE FOR RND, LEAVE IT IN FAC
       MOVE 8,[email protected],@ARG        ARG = 1/1E7
       XML  FMUL                  FAC = X2/1E7
       XML  VPUSH          (M)    FAC = X2/1E7
       DADD 8,@VSPTR
       XML  VPOP           (N)    FAC = X1
       XML  FMUL                  FAC = X1/1E7
       XML  FMUL                  FAC = X1/1E14
       XML  SADD           (P)RND=FAC = (X2/1E7)+(X1/1E14)
       XML  CONT
***********************************************************
* CONSTANTS FOR THE RANDOM NUMBER ROUTINE
RNDA2  BYTE >43,>01,>2B,>59,>52,>00,>00,>00 * = 1438982
RNDA1  BYTE >42,>2A,>08,>15,>00,>00,>00,>00 * = 0420821
RNDC2  BYTE >43,>02,>0B,>20,>30,>00,>00,>00 * = 2113248
RNDC1  BYTE >43,>06,>36,>05,>13,>00,>00,>00 * = 6540519
RNDEP  BYTE >43,>0A,>00,>00,>00,>00,>00,>00 * = 1E7
RNDEM  BYTE >3C,>0A,>00,>00,>00,>00,>00,>00 * = 1/1E7
***********************************************************
*                   RANDOMIZE STATEMENT
***********************************************************
NRNDMZ CALL CHKEND            Seed provider?
       BS   RNDM1             No
* RANDOMIZE given a see value
* (99,000,000,000,001 possible starting positions)
* (Place-value is ignored in the input number)
       XML  PARSE             Parse the seed
       BYTE TREMZ           * Up to end of statement
       CALL CKSTNM
       DCZ  @FAC              Check FAC for zero
       BS   GA3B6
       ST   >46,@FAC          0 < FAC < 1E14
       XML  VPUSH             Let FAC = X2*1E7+X1
       MOVE 8,[email protected],@ARG        ARG = 1/1E7
       XML  FMUL                  FAC = X2+X1/1E7
       CALL GRINT                 FAC = X2
       MOVE 5,@FAC,[email protected]        FAC = X2
       MOVE 8,[email protected],@ARG        ARG = 1E7
       XML  FMUL                  FAC = X2*1E7
       XML  SSUB                  FAC = X1
       MOVE 5,@FAC,[email protected]        FAC = X1
       XML  CONT                  FAC = X1
GA3B6  DST  @FAC,[email protected]          FAC = 0
       DST  @FAC,[email protected]          FAC = 0
       XML  CONT
* RANDOMIZE given number seed value (use GPL RAND function)
* (16K possible starting positions)
RNDM1  DST  >4201,@FAC            FAC = >4201
       CLR  @FAC4                 FAC4= >00
       CALL RNDMZ
       DATA RNDX1
       CALL RNDMZ             Set up seed
       DATA RNDX2
       XML  CONT              Continue on
RNDMZ  FETCH @FAC8            Fetch address of seed (high b
       FETCH @FAC9            Fetch address of seed (low by
       RAND 99                GPL Randomize
       ST   @RANDOM,@FAC2     >00<=FAC+2<=FF
       SRL  2,@FAC2           >00<=FAC+2<=3F
       RAND 99                GPL Randomize
       ST   @RANDOM,@FAC3     >00<=FAC+3<=FF
       SRL  2,@FAC3           >00<=FAC+3<=3F
       MOVE 5,@FAC,V*FAC8     Put in seed
       RTN
CKSTNM CEQ  >65,@FAC2
       BS   ERRSNM
       RTN
FLT1   BYTE >40,>01,>00,>00,>00,>00,>00,>00
***********************************************************
*                 EXTENDED STRING PACKAGE
* THE ROUTINES ARE:
*  LITS05 - Move a string literal from the program to the
*            string space
*  INTARG - Checks that an argument is a numeric and
*            converts it from floating point to an integer
*  PUSSTR - Checks that an argument is a string and pushes
*            it on the stack
*  CONCAT - Concatenates 2 strings together
*  SEG$   - Segments a string
*  LEN    - Puts the length of a string in the FAC
*  CHR$   - Converts an integer into its ASCII character
*  STR$   - Converts a number into its string equivalent
*  VAL    - Converts a string into its numeric equivalent
*  POS    - Gives the position of one string within another
*  RPT$   - Generates a single string with multiple copies
*            of the original string
*
*      AN ENTRY IN THE FAC LOOKS LIKE:
* +------------+-----+----+-------------+-----------------+
* |addr of ptr | >65 | xx | addr of str | length of str   |
* +------------+-----+----+-------------+-----------------+
*     FAC       FAC2  FAC3   FAC4           FAC6
***********************************************************
* Support routine for functions to build FAC entry
LITS05 CLR  @FAC6             Need as a double-byte value
       DST  @FAC6,@BYTES      LENGTH FOR GETSTR
       ST   @RAMTOP,@FAC8     Copy ERAM flag for later
LITS07 XML  GETSTR            ALLOCATE STRING SPACE
LITS08 DST  >001C,@FAC        SAVE ADDR OF STRING  (SREF)
       DST  @SREF,@FAC4       SAVE ADDR OF STRING
       DST  >6500,@FAC2       INDICATES A STRING CONSTANT
*********** COPY STRING INTO STRING SPACE *****************
LITS09 DCZ  @BYTES            If non-null string
       BS   GA42B
       CZ   @FAC8
       BR   GA420
       MOVE @BYTES,V*TEMP5,V*SREF
       RTN
*                             Else source string in ERAM
GA420  DST  @BYTES,@FFF1      FFF1 : BYTE COUNT
       DST  @SREF,@EEE1       EEE1 : DESTINATION ADDR ON VD
       DST  @TEMP5,@DDD1      DDD1 : Source addr in ERAM
       XML  GVWITE            Move data from ERAM to VDP
GA42B  RTN
LITS06 CLR  @FAC8             SET FLAG TO VDP
       BR   LITS07            JUMP INTO CODE
***********************************************************
* PUSSTR - Insures that the entry in the FAC is a string
*           and pushes it onto the stack.
***********************************************************
PUSSTR CEQ  >65,@FAC2
       BR   ERRSNM
       XML  VPUSH             PUSH THE ARGUMENT
       RTN
***********************************************************
* CONCAT - CONCATENATES TWO STRINGS TOGETHER
*         INPUT  : FLOATING POINT ACCUMULATOR ENTRIES
*         OUTPUT : CONCATENATED STRING AND (POSSIBLE)
*                  ZEROED BACK-POINTERS FOR THE OLD STRINGS
*         USES   : TEMP2, TEMP4 AND TEMP5 AS TEMPORARIES
***********************************************************
CONCAT CLR  @ERRCOD+1         CLEAR THE ERROR CODE
       CALL PUSSTR            Push the string & get next to
       XML  PARSE             GET THE R.H. ARGUMENT
       BYTE CONCZ
       CEQ  >65,@FAC2         If not string - error
       BR   ERRSNM
       DST  @FAC6,@BYTES      GET R.H. LENGTH
       DADD [email protected](@VSPTR),@BYTES    ADD IN L.H. LENGTH
       DCH  255,@BYTES
       BR   GA45B
       DST  255,@BYTES        TRUNCATE IF TOO LONG
WRNST1 CALL WARNZZ            Display warning
       BYTE 19                * STRING TRUNCATED message
GA45B  DST  @BYTES,@TEMP6     Keep length for later
       XML  VPUSH
       XML  GETSTR            Alloccate the result string
       XML  VPOP              Retrieve R.H.
       MOVE 8,@FAC,@ARG
       XML  VPOP              Retrieve L.H.
       DST  @FAC4,@TEMP5      Set ptr to L.H. ARG(for FREST
       DST  @FAC6,@BYTES      Length of L.H. ARG
       CLR  @FAC8             Force VDP mode
       CALL LITS08            Set up FAC & copy L.H. ARG in
       DCZ  @ARG6             If R.H. =0 don't copy
       BS   CONC06
       DST  @SREF,@TEMP4      Get ptr to new string
       DADD @FAC6,@TEMP4      Ptr to where 2nd string begin
       DSUB @FAC6,@TEMP6      Length of 2nd string
*                                      (possibly truncated)
       BS   CONC06
       MOVE @TEMP6,V*ARG4,V*TEMP4     Copy in 2nd string
 
       DADD @TEMP6,@FAC6      Add in length of 2nd ARG
* NOTE: FAC6 already contained length of 1st ARG from the
*       parse that was done on it
CONC06 XML  CONT              Done.
***********************************************************
* SEG$(A$,X,Y) - Extracts the desiginated string from A$.
*     X specifies the character position within A$ at
*     which the extraction begins. Y specifies the number
*     of characters to extract.
*     If X or Y is negative an error occurs. If X=0 an
*     error occurs. If Y=0 or X > Y then a null string is
*     is returned. If the ramaining length in A$ starting
*     at the postion specified by X is less than the length
*     specified by Y, then the remainder of A$ starting at
*     position X is returned.
*   INPUT - Control is turned over to SEG$ from PARSE. The
*     only requirement is that a SEG$ was encountered.
*   OUTPUT - The Floating Point Accumulator is set up with
*     the header for the segmented string.
*   USES - TEMP2 (Others in calls to GETSTR and LITS08)
***********************************************************
SEGZ01 CALL LPAR              Insure "(" parse and check ",
       CALL PUSSTR            Push string and get next toke
       XML  SPEED             Get the position
       BYTE PARCOM       *     within the source string
       CALL INTARG            CHECK & CONVERT ARG TO INTEGE
       DCZ  @FAC               CAN'T HAVE VALUE OF 0
       BS   ERRBV
       XML  VPUSH             PUSH THE ARG
       XML  PARSE             Get extraction length
       BYTE RPARZ
       XML  SPEED             Must have
       BYTE SYNCHK       *     ended on
       BYTE RPARZ        *      a right parenthesis
       CALL INTARG            CHECK & CONVERT ARG TO INTEGE
       DST  @FAC,@ARG         Move extraction length
       XML  VPOP              Get position back
       DST  @FAC,@ARG2        Move position
       XML  VPOP              Retrieve source string
       DST  @ARG2,@TEMP2      Get position within string
       DCH  @FAC6,@TEMP2      If position > length =>null
       BS   SEGZ08
       DADD @ARG,@TEMP2       Compute end of substring
       DSUB @FAC6,@TEMP2      Compute length beyond end
       DDEC @TEMP2             string
       DCGE 0,@TEMP2
       BR   SEGZ06            Fine if substring is shorter
       DST  @FAC6,@ARG        Else, truncate length of
*                              substring
       DSUB @ARG2,@ARG        Subtract position from source
*                              length
       DINC @ARG              Increment to include last cha
SEGZ06 DST  @ARG,@BYTES       # of bytes needed for substri
       XML  VPUSH             Save source string entry
       XML  GETSTR            ALLOCATE RESULT STRING
       XML  VPOP              Restore source string entry
       DST  @FAC4,@TEMP5      Pointer to source for FRESTR
*                              LITS08
       DADD @ARG2,@TEMP5      Pointer to start of substring
       DDEC @TEMP5            Decrement since zero-based
       DST  @BYTES,@FAC6      Set length of string
       CLR  @FAC8             FORCE VDP MODE
       CALL LITS08            Copy in & set up FAC
       XML  CONT
SEGZ08 DCLR @ARG              Extract a null string
       BR   SEGZ06            >>>JUMP ALWAYS<<<
***********************************************************
* LEN(A$) - Calculate the length of a string and leave the
*           result in the FAC.
*  CONTROL - Turned over to NLEN from the parser.
*  USES    - No temporaries.
***********************************************************
LEN01  CALL PARFF             Insure left parenthesis & par
       BR   ERRSNM             If not string value
       DST  @FAC6,@FAC        Length
LEN02  XML  CIF               Convert integer to floating p
       XML  CONT
***********************************************************
* CHR$(X) - Takes integer value X and converts the number
*           into the ASCII representation for that number.
*  CONTROL - Turned over to NCHR by the parser.
*  OUTPUT  - FAC is set up with the string entry
*  USES    - Uses temproraries when invoking LITS06(LITSTR)
***********************************************************
CHRZ01 CALL PARFF             Insure left parenthesis & par
       CALL INTARG            Convert into integer
       DST  1,@BYTES          Create a length 1 string
       ST   @FAC1,[email protected]    Move the value to VDP(for LIT
       DST  ONECHR,@TEMP5     Address of character
       CALL LITS06            Create string and set up FAC
       DST  1,@FAC6           Length of string
       XML  CONT
***********************************************************
* ASC(A$) - Takes the numeric value of the first character
*           in A$.
***********************************************************
ASC01  CALL PARFF             Insure left parenthesis & par
       BR   ERRSNM             If not string
       CZ   @FAC7             Bad Argument?
       BS   ERRBA
       ST   V*FAC4,@FAC1      Get the first character
       CLR  @FAC
       BR   LEN02             USE COMMON CODE >>>JUMP ALWAY
***********************************************************
* STR$(X) - Takes as its imput an integer X and converts it
*           to its string representation.
*  CONTROL - Turned over to STR$ by the parser.
*  USES    - The usual temporaries used by string function
*            when it calls LITS06. Uses the Roll-out area
*            for a temporary storage area when allocating
*            the result string.
*  OUTPUT  - FAC is set up in the usual manner for a string
***********************************************************
STRZ01 CALL PARFF             Insure left parenthesis & par
       BS   ERRSNM             If not numeric-error
       CLR  @FAC11            Select XB floating type
       XML  CNS               Convert the number to string
       CEQ  SPACE,*FAC11      If leading space
       BR   GA53E
       INC  @FAC11            Suppress it out
       DEC  @FAC12            Shorten the length
GA53E  CLR  @BYTES            Prepare for 2-byte value
       ST   @FAC12,@BYTES+1   Get length of string
       MOVE @BYTES,*FAC11,[email protected]    Put the string in VDP
       DST  VROAZ,@TEMP5      Copy-from address(for LITSTR)
       CALL LITS06            Allocate and set up FAC
       DST  @BYTES,@FAC6      Put in the length
       XML  CONT
***********************************************************
* VAL(A$) - Takes as its input a string, A$, and converts
*           the string into a number if the string is a
*           valid representation of a number.
*  CONTROL - From the parser.
*  OUTPUT  - FAC contains the floating point number.
***********************************************************
VAL01  CALL PARFF             Insure left parenthesis & par
       BR   ERRSNM             If not string - error
       CZ   @FAC7             Can't have null string
       BS   ERRBA
       CALL VALCD             So bad argument error
       BS   ERRBA
       XML  CONT
* Short routine to parse a single argument enclosed in
*  parenthesis for a function or a subprogram and set
*  condition based upon whether the value parsed was a
*  string or a numeric.
PARFF  CEQ  LPARZ,@CHAT
       BR   ERRSYN
       XML  PARSE
       BYTE >FF               *
       CEQ  >65,@FAC2
       RTNC
VALCD  DST  @FAC4,@TEMP5      Pointer to string
       DADD @FAC6,@TEMP5      Pointer to trailing length by
       DST  @FAC6,@BYTES      For suppressing trailing blan
       DINC @BYTES            Prepare for undue subtraction
GA57C  DDEC @TEMP5            Keep track of end of string
       DDEC @BYTES            Decrease length of string
       BS   RTNSET            End up with empty string,
       CEQ  SPACE,V*TEMP5     Wild trailing blanks
       BS   GA57C
       DINC @BYTES            Allow for terminator
       XML  VPUSH             Save the ptr to the string
       XML  GETSTR            Get a new string
       XML  VPOP              Retrieve the ptr to the strin
       DST  @FAC4,@TEMP5      Get the ptr to the string
       CLR  @FAC8             Force VDP mode
       CALL LITS09            Copy the string and set up FA
       DADD @SREF,@BYTES      Point to the trailing length
       DDEC @BYTES            Point at the last character
       ST   SPACE,V*BYTES     Put in the terminator
       DST  @SREF,@FAC12      Address for the conversion
GA5A4  CEQ  SPACE,V*FAC12     While leading spaces
       BR   GA5AE
       DINC @FAC12            Skip leading blank
       BR   GA5A4
GA5AE  CLR  @FAC2             Get rid of string (in case=0)
       CLR  @FAC10            Assume no error
       XML  CSNUM             Convert it
       DCEQ @BYTES,@FAC12     Convert all of it?
       BS   WRNNO             Yes, check overflow & return
RTNSET CEQ  @>8300,@>8300     No, return with condition set
       RTNC
***********************************************************
* POS(A$,B$,X) - Attempts to match the string, B$, in A$
*    beginning at character # X in A$. If X is > LEN(A$), a
*    match is not found or A$ is the null string then the
*    returned value is 0. If B$ is the null string then the
*    returned value is 1. Otherwise, the returned value is
*    the column # of the 1st character matched in A$
*  CONTROL - Fromn the parser. Returned through common code
*            IN LEN.
*  USES    - Not temporaries - Utilizes FAC and ARG.
***********************************************************
POS01  CALL LPAR              Insure "(", parse , insure ",
       CALL PUSSTR            STACK THE STRING AND GET TOKE
       XML  SPEED             Parse the match string and
       BYTE PARCOM      *      insure end on comma
       CALL PUSSTR            STACK THE STRING AND GET TOKE
       XML  PARSE             Get position
       BYTE RPARZ
       XML  SPEED             Must have
       BYTE SYNCHK          *  ended on a
       BYTE RPARZ           *   right parenthesis
       CALL INTARG            Check and convert it
       DCZ  @FAC              Value out of range
       BS   ERRBV
       DST  @FAC,@BYTES       Keep the offset
       DDEC @BYTES            Correct for position 0
       XML  VPOP              Get match string back
       MOVE 8,@FAC,@ARG       Put match in ARG
       XML  VPOP              Get source back
       CZ   @FAC7             If source null
       BS   POS12
       CH   @BYTES+1,@FAC7    OFFSET > LENGTH?
       BR   POS12             Yes, no match possible
       CZ   @ARG7             If null string
       BS   POS06
       DADD @BYTES,@FAC4      Adjust ptr for offset
       SUB  @BYTES+1,@FAC7    Adjust length
POS02  CHE  @ARG7,@FAC7       Enough space left for a match
       BR   POS12             No, no match possible
       DST  @FAC4,@FAC        Get first ARG
       DST  @ARG4,@ARG        Get second ARG
       ST   @ARG7,@ARG8       And length of second
POS04  CEQ  V*FAC,V*ARG       Compare the characters
       BR   POS10             Didn't match
       DINC @FAC              Next in source
       DINC @ARG              Next in match
       DEC  @ARG8             Reached end of match?
       BR   POS04             Not yet, so loop
POS06  INC  @BYTES+1          Matched! Correct for 1 index
POS08  DST  @BYTES,@FAC       Character position of match
       BR   LEN02             Convert to floating point
* NOTE: Utilizes the LEN code to do the conversion and
*       finish up.
POS10  INC  @BYTES+1          Step index of match character
       DEC  @FAC7             Move 1 position down 1st
       DINC @FAC4              Argument
       BR   POS02             Try to match again
* JUMP ALWAYS
POS12  CLR  @BYTES+1          NO MATCH POSSIBLE
       BR   POS08
***********************************************************
* RPT$(A$,X) - Creates a string consisting of X copies of
*              A$. If X is negative or non-numeric, an
*              exception occurs. If A$ is not a string, an
*              exception occurs.
***********************************************************
RPTZ01 CALL LPAR              Insure "(", parse, insure ","
       CALL PUSSTR            Insure a string and push it
       XML  PARSE             Parse second argument
       BYTE RPARZ
       XML  SPEED             Must have
       BYTE SYNCHK       *     ended on a
       BYTE RPARZ        *      right parenthesis
       CALL INTARG            Check numeric and convert
       DMUL [email protected](@VSPTR),@FAC  Compute result length
       DCZ  @FAC1
       BS   GA649
WRNST2 CALL WARNZZ            Give truncation message
       BYTE 19                * STRING TRUNCATED message
       DST  255,@FAC2         Make it a maximum string
GA649  DST  @FAC2,@BYTES      Copy requested string length
       XML  GETSTR            Get the new string
       XML  VPOP              Retrieve the original string
* At this point BYTES should still contain the length
       DST  @FAC6,@ARG        Copy original length in ARG
       DCZ  @BYTES            Zero copies requested
       BR   GA659
       DCLR @ARG              So we copy zero!!!!!!!
GA659  DEX  @ARG,@BYTES       Original length to BYTE
       DST  @FAC4,@TEMP5      And also original start addr
       CLR  @FAC8             Clear flag for LITS08
       CALL LITS08            Create FAC and copy on copy
* ARG contains total length now.
       DST  @ARG,@FAC6        Store new length
RPTZ02 DSUB @BYTES,@ARG       Subtract one copy
       DCZ  @ARG              <<<<<THE WAY OUT
       BS   XMLCON
       DADD @BYTES,@SREF      Compute new start address
       DCH  @ARG,@BYTES
       BR   GA679
       DST  @ARG,@BYTES       Truncate string
GA679  MOVE @BYTES,V*TEMP5,V*SREF
       BR   RPTZ02
***********************************************************
*                   TRACE STATEMENT
***********************************************************
NTRACE OR   >10,@FLAG         Set the trace bit
XMLCON XML  CONT              Continue on
***********************************************************
*                 UNTRACE STATEMENT
***********************************************************
NUNTRC AND  >EF,@FLAG         Reset the trace bit
       XML  CONT              Continue on
***********************************************************
*          BREAK AND UNBREAK STATEMENTS
***********************************************************
NBREAK ST   >FF,@ARG          BREAK flag
       CALL CHKEND            Check for end of statement
       BR   LINEGP            If not goto LINEGP
       DDEC @PGMPTR           Back up so CON will rescan en
       CZ   @PRGFLG           Rative without line #
       BR   EXEC6C
ERROLP CALL ERRZZ             Only legal in a program
       BYTE 27
NUNBRK CLR  @ARG              UNBREAK flag for common
       CALL CHKEND            Check for end of statement
       BS   UNBK01            If end then goto UNBK01
LINEGP CALL LINE              Get line #
       DST  @ENLN,@ARG2
       DSUB >03,@ARG2         1st line #
LNGP1  DCHE @STLN,@ARG2       If line not found
       BR   WRNLNF
       CALL GRSUB3            Read line # of data from ERAM
       BYTE >5E           *   (use GREAD1) or VDP
* @ARG2: Source addr in ERAM/VDP, reset possible breakpoint
       DCEQ @FAC,@EEE1        If line found
       BS   LNGP2
       DSUB 4,@ARG2           Next line in VDP or ERAM
       BR   LNGP1
* JUMP ALWAYS
LNGP2  CZ   @RAMTOP           If ERAM exists
       BS   GA6DA
       AND  >7F,@EEE1         Assume UNBREAK flag
       CZ   @ARG              If BREAK flag
       BS   GA6D1
       OR   >80,@EEE1         Set the breakpoint
GA6D1  CALL GWSUB             Write a few bytes of data to
*                              ERAM (use GWRITE)
       BYTE >5E,>58,>01     * ARG2,EEE1,1
*                            @ARG2: Destination addr on ERA
*                            @EEE1: Data
*                            1    : Byte count
       B    LNGP2B
GA6DA  AND  >7F,V*ARG2        Assume UNBREAK flag first
       CZ   @ARG              If BREAK flag
       BS   LNGP2B
       OR   >80,V*ARG2        Set the breakpoint
LNGP2B CALL CHKEND            Check for end of statement
       BS   LNGP4             If end then continue
       XML  SPEED             Must be
       BYTE SYNCHK         *     at a
       BYTE COMMAZ         *       comma now
       BR   LINEGP
* JUMP ALWAYS
WRNLNF CALL WARNZZ            Note: warning not error
       BYTE 38             *  'LINE NOT FOUND'
       BR   LNGP2B            And contiue on
* JUMP ALWAYS
UNBK01 CALL UBSUB             Clear all bkpt in line # tabl
LNGP4  XML  CONT              Contiue
*     CLEAR ALL BREAKPOINTS
UBSUB  DST  @STLN,@FAC8       END OF LINE # BUFFER
GA6FF  CALL UBSUB1            Reset one line # at a time
       DADD 4,@FAC8           Got to the next line
       DCH  @ENLN,@FAC8       End of table
       BR   GA6FF
       RTN
UBSUB1 CALL GRSUB3            Read the line # from ERAM/VDP
*                             Reset possible bkpt too
       BYTE >52            *  @FAC8: Source addr on ERAM/VD
       CALL GWSUB             Write a few bytes of data to
*                              ERAM(use GWRITE) or VDP
       BYTE >52,>58,>01    *  FAC8,EEE1,1
*                          @FAC8: Destination adr in ERAM/V
*                          @EEE1: Data
*                          1    : Byte count
       RTN
***********************************************************
*                USER DEFINED FUNCTIONS
* Subroutine to store away the information of the tokens in
* a function reference, go into the 'DEF' statement,
* calculate the value of the expression and then resume
* execution of the user's program after the reference.
* An entry in the FAC and on the stack for a function
* reference looks like:
* +--------+-----+---------------------+--------+---------+
* | PGMPTR | >68 | string/numeric flag | SYMTAB | FREPTR  |
* +--------+-----+---------------------+--------+---------+
*  FAC      FAC2  FAC3                  FAC4     FAC6
*
* The 'PGMPTR' is where execution resumes after evaluating
* the function. String (80)/numeric(00) flag is function
* type. SYMTAB is the old symbol table pointer and FREPTR
* is the old free space pointer. These are restored after
* the function is evaluated.
***********************************************************
UDF    CZ   @PRGFLG           If imperative
       BR   GA720
       CZ   @RAMTOP+1         And ERAM, error
       BR   ERROLP
GA720  CLR  @FAC7             Assume no args
       DCLR @ERRCOD           Clear the error code for cont
       CLR  @ARG2             Safety for VPUSH
       CLR  @FAC2             Sagety for VPUSH
       CEQ  LPARZ,@CHAT
       BR   GA73B
       XML  VPUSH             Save ptr to function definiti
       XML  PARSE             PARSE to get arg value
       BYTE >FF
       MOVE 8,@FAC,@ARG       Save PARSE result
       XML  VPOP              Get S.T. ptr to function defi
       INC  @FAC7             Indicate theat we have an arg
GA73B  ST   @FAC7,@TEMP5      Move the parmeter count
       DST  @FAC,@TEMP4       S.T. ptr to definition
       XML  VPUSH             Allow room for UDF result
       MOVE 8,@ARG,@FAC       Retrieve parse result
       XML  VPUSH             Save parse result
       ST   V*TEMP4,@FAC2     Get S.T. declarations
       ST   @FAC2,@FAC3       Do this to save string bit
* NOTE: THIS IS TO ALLOW THE CHECKING AFTER THE FUNCTION HA
*       BEEN EVALUATED TO MAKE SURE THE FUNCTION
*       TYPE (STRING/NUMERIC) MATCHES THE RESULT IT PRODUCE
       AND  >07,@FAC2         Mask all but # of parameters
       CEQ  @TEMP5,@FAC2
       BR   ERRIAL
* Incorrect argument list error above.
       DST  @PGMPTR,@FAC      Will resume execution here
       ST   >70,@FAC2         Entering parameter into symbo
*                    table while in UDF statement executing
       AND  >80,@FAC3         Mask all but string bit
       DSUB 16,@VSPTR         Get below parse result
 
       DST  @SYMTAB,@FAC4     Save current symbol table ptr
       DST  @FREPTR,@FAC6     Save current free space ptr
       XML  VPUSH             Save the return info
       DADD 8,@VSPTR          Get back to parse result
*********** SHIFT EXECUTION TO FUNCTION DEFINITION ********
       DST  [email protected](@TEMP4),@PGMPTR    Set text ptr to definiti
       XML  PGMCHR            Get 1st character in the defi
       CH   >A4,@SUBSTK       Stack overflow
       BS   ERRSO
       MOVE 24,@>8300,[email protected]  Roll out temporaries
       OR   >08,@FLAG         Set function flag for ENTER
       ST   >80,@XFLAG        Make calls look like ENTERX
       CEQ  EQUALZ,@CHAT
       BR   GA79C
* NOTE: This is to keep the global/local variables correct
*       the event that a function uses another function in
*       its evaluation.
       CLR  @FAC15            Create a dummy entry in table
       CALL ENT09              for no-paremter function
       DDECT @PGMPTR          Back up to equal sign
       CLR  [email protected](@VSPTR)       This is to keep ASSGNV(called
*                              below) not to screw up in
*                              case FAC2 happens to have a
*                              value (greater) >65
       BR   GA79F
GA79C  CALL ENTER             Enter the parameter
GA79F  XML  PGMCHR            Get the '=' (Checked in PSCAN
       AND  >F7,@FLAG         Reset to normal ENTERs
       MOVE 24,[email protected],@>8300
       ST   >68,[email protected](@VSPTR)  Correct stack entry ID
       DST  [email protected],[email protected](@SYMTAB)  Fudge link to
*                                   get global values
       DST  @SYMTAB,@FAC      Set up for SMB
       XML  SMB               Get value space
       MOVE 8,@FAC,@FAC8      Destination
       XML  VPOP              Get arg back
       MOVE 8,@FAC,@ARG       Argument value
       MOVE 8,@FAC8,@FAC      Destination
       XML  VPUSH             Push to destination
       MOVE 8,@ARG,@FAC       Argument value
       CEQ  >65,@FAC2         If a string
       BR   GA7E2
       DCEQ >001C,@FAC        If not temp
       BS   GA7E2
       DST  V*FAC,@FAC4       Get new location of string
*                             Parameter was allocated in S.
GA7E2  XML  PGMCHR            Skip the '='
       XML  ASSGNV            Assign the value to the param
       XML  PARSE             PARSE to end of function defi
       BYTE TREMZ
**** CHECK FOR TYPE MATCH (STRING/STRING OR NUM/NUM)*******
**** BETWEEN THE RESULT AND THE FUNCTION TYPE *************
       CEQ  >65,@FAC2         If result string
       BR   GA7F6
       CZ   [email protected](@VSPTR)       If functional
       BS   ERRSNM
       BR   GA7FC              not a string
GA7F6  CZ   [email protected](@VSPTR)       If functional
       BR   ERRSNM
***** NOW RESTORE SYMBOL TABLE AND RESUME *****************
***** EXECUTION AT THE ORIGINAL LINE **********************
GA7FC  CALL DELINK            Delink the parameter entry
       DST  [email protected](@VSPTR),@PGMPTR Manual pop to get ptr back
       DDEC @PGMPTR           Back up text pointer
       XML  PGMCHR            Get next token
       XML  CONT
DELINK DST  @SYMTAB,@TEMP5    Save addr of S.T. entry just
*                             in case entry is a string
*                             (must free the string)
       MOVE 4,[email protected](@VSPTR),@SYMTAB  Restore old symbol table
*                             pointer and free space pointe
*                             This handles the freeing of t
*                             string value which was assign
*                             to the parameter.
       CGE  0,V*TEMP5         If string parmeter
       BS   GA84C
       DST  [email protected](@TEMP5),@TEMP5 Where the string is
       DCZ  @TEMP5            If non-null string
       BS   GA833
       DST  [email protected](@TEMP5),@TEMP2 Get backpointer
       DCHE @SYMTAB,@TEMP2    If not used
       BS   GA833
       DCLR [email protected](@TEMP5)      Free up the string
* This handles the special case of F$(X$)=X$
* The result, which was permanent, must be made a temp.
GA833  CEQ  >65,@FAC2         If string result
       BR   GA84A
       DCHE @SYMTAB,@FAC      If came from argument
       BS   GA84A
       DCZ  @FAC4             If non-null
       BS   GA846
       DCLR [email protected](@FAC4)       Clear the backpointer
GA846  DST  >001C,@FAC        Make it a temp
GA84A  BR   GA856             If numeric parameter
GA84C  CZ   @RAMTOP           If ERAM exist
       BS   GA856
       DADD 8,@RAMFRE         Remove 8 bytes of value
GA856  DSUB 8,@VSPTR          Trash the stack entry
       RTN                    And retrun
ATTNUT XML  PARSE
       BYTE RPARZ
       CALL CKSTNM            CHECK FOR NUMERIC OR STRING
       XML  SPEED             Insure argument is in
       BYTE RANGE          *   range of 0-30
       BYTE 0
       DATA 30
       SRL  1,@FAC1           0,1 : 0000        ATTENUATION
*                             2,3 : 0001
*                             4,5 : 0010
*                             6,7 : 0011        ETC...
       OR   >F0,@FAC1         REGISTER BITS
       RTN
***********************************************************
* SUBROUTINE TO SET POINTER TO EACH DATUM
***********************************************************
DATAST DDEC @LNBUF            Point to 1st byte of line ptr
       CALL GRSUB2            Read 2 bytes from VDP or ERAM
       BYTE LNBUF           *  (use GREAD1), @LNBUF: Source
*                           *  address in ERAM or VDP
       DST  @EEE1,@DATA       Put it in @DATA
       CALL SRDATA            Look for 'DATA' on the line
       BR   DATST1            OK, FOUND ANOTHER 'DATA' STMT
       DDECT @LNBUF           NO
       DCEQ  @STLN,@LNBUF
       BS   GA887
       DDEC @LNBUF            Point to 1st token address
       BR   DATAST
GA887  CLR  @DATA             Indicate no data
DATST1 RTN
***********************************************************
* Subroutine to get line number and goto routine to display
* it on the screen.
***********************************************************
ASC    CZ   @RAMFLG
       BR   GA897
       DST  [email protected](@EXTRAM),@ARG2   Get line # in
       BR   GA8A5
GA897  DST  2,@FFF1           @FFF1 : Byte count
       DST  @EXTRAM,@DDD1     @DDD1 : Source addr in ERAM
       DDECT @DDD1
       XML  GREAD1            Read data from ERAM
       DST  @EEE1,@ARG2       @EEE1 : Destination addr on C
GA8A5  AND  >7F,@ARG2         Reset the breakpoint if any
       B    DISO
***********************************************************
* Code to decode error returned from ALC
***********************************************************
ERORZ  CASE @ERRCOD           DECODE ERROR FROM INTERPRETER
       BR   ERRSYN            0 SYNTAX ERROR
       BR   ERRMEM            1 MEMORY FULL
       BR   ERRBV             2 BAD VALUE
       BR   ERRLNF            3 LINE NOT FOUND
       BR   ERRSYN            4 SYNTAX
       BR   ERRBS             5 BAD SUBSCRIPT
       BR   ERRSNM            6 STRING-NUMBER MISMATCH
       BR   ERRSO             7 STACK OVERFLOW
       BR   ERRBA             8 BAD ARGUMENT
       BR   ERRRWG            9 RETURN WITHOUT GOSUB
       BR   ERRIAL            A INCORRECT ARGUMENT LIST
       BR   ERRFNN            B FOR/NEXT NESTING
       BR   ERRNWF            C NEXT WITHOUT FOR
       BR   ERRMUV            D IMPROPERLY USED NAME
       BR   ERRIAL            E INCORRECT ARGUMENT LIST
       BR   ERRRSC            F RECURSIVE SUBPROGRAM CALL
       BR   ERRSNF           10 SUBPROGRAM NOT FOUND
       BR   ERROLP           11 ONLY LEGAL IN A PROGRAM
       BR   ERRSNS           12 MUST BE IN SUBPROGRAM
***********************************************************
* SUBROUTINE TO GET LINE # FOLLOWING 'BREAK', 'UNBREAK',
* 'RESTORE'
***********************************************************
LINE   CEQ  LNZ,@CHAT         Should be line # reference
       BR   ERRSYN
       XML  PGMCHR            Get high order line #
       ST   @CHAT,@FAC        Build result in FAC, FAC1
       XML  PGMCHR
       ST   @CHAT,@FAC1       Low order line #
       XML  PGMCHR            Get token following line #
       RTN
CONV1  CLR  @FAC10
       XML  CSNUM             Convert String to Number
***********************************************************
       ST   @FAC10,[email protected]
       DST  @FAC12,[email protected] Save those in temporary, becaus
*                            in ERROV : WARNING routine hav
*                            FAC12 and FAC10 values changed
***********************************************************
WRNNO  CZ   @FAC10            Numeric overflow
       BS   GA8F9
       CALL WARNZZ
       BYTE 2
GA8F9  RTN
***********************************************************
*                SUBROUTINE FOR 'GCHAR'
***********************************************************
GCHAR  CALL GPHV              Get X,Y values
GCHAR2 CALL NUMVAR            Get pointer to return variabl
       MOVE 8,[email protected],@FAC     Clear FAC
       ST   @CB,@FAC1         Get the character
       SUB  OFFSET,@FAC1      Remove screen offset
       CHE  100,@FAC1
       BR   GA919
       EX   @FAC1,@FAC2
       DIV  100,@FAC1
       INC  @FAC
GA919  XML  ASSGNV            Assign the value to the symbo
* RXB PATCH CODE
       BR   GCHARA
***********************************************************
*               SUBROUTINE FOR 'COLOR'
***********************************************************
COLOR  XML  SPEED             Must be
       BYTE SYNCHK        *     at a
       BYTE LPARZ         *       left parenthesis
* RXB PATCH CODE
COL08  DCLR @VAR0             Clear ALL pointer
       CEQ  ALLZ,@CHAT        ALL?
       BR   COL09             No.
       ST   ALLZ,@VAR0        Yes, store it in pointer
       DCLR @FAC              Set 0
       XML  PGMCHR            Skip ALL token.
       CALL COMMA2            Skip comma.
       BR   COL21             Start ALL RXB routine
COL09  CEQ  NUMBEZ,@CHAT      If sprite number specified
       BR   COL20
       CALL CHAR1             Check sprite number (SPNUM3)
COL10  CALL SPCOL             Put the color in SAL
       CEQ  COMMAZ,@CHAT      More color changes
       BR   LNKRTN
       CALL CHAR2             Skip and get sprite number (S
       BR   COL10
* This part for regular color change routine
COL20  XML  SPEED             Parse the character
       BYTE PARCOM         *   set and insure a comma
       XML  SPEED             Insure in range of
       BYTE RANGE          *   0<= x <= 14
* RXB PATCH CODE
*      BYTE 0,0,14
       BYTE 0,0,16
COL21  DADD >080F,@FAC        Color table addr(>0810 - >081
       XML  VPUSH             Push table set address
       XML  SPEED             Parse the foreground color
       BYTE PARCOM         *   and insure a comma
       CALL RAN16             Error if >16 or <1
       ST   @FAC1,@VAR4       Save it
       SLL  4,@VAR4           Foreground color in 4 MSBits
       XML  PARSE             Get background color
       BYTE RPARZ
       CALL RAN16             Error if >16 or <1
       OR   @FAC1,@VAR4       Background color in 4 LSBits
       XML  VPOP              Get color table address
       ST   @VAR4,V*FAC       Load the colors into the tabl
* RXB PATCH CODE
       CEQ  ALLZ,@VAR0        ALL in pointer.
       BR   COL22             No.
       MOVE 14,V*FAC,[email protected](@FAC) Fill color table with values
COL22  CEQ  COMMAZ,@CHAT      End of call. Go back.
       BR   LNKRTN
       XML  PGMCHR            Skip ","
       BR   COL08             Take care of the next set
*      CALL SPCOL -- Changes color of sprite.
*                    Called also from SPRITE.
SPCOL  XML  PARSE
       BYTE RPARZ          *  Get the color number
       CALL RAN16             Check range 1 - 16
       ST   @FAC1,[email protected](@SPSAL) Store in SAL
       RTN
***********************************************************
* INTARG - Insures that the value in FAC is a numeric,
*          converts it to integer, issues error message if
*          necessary or returns.
***********************************************************
INTARG CH   >63,@FAC2         If string - error
       BS   ERRSNM
       CLR  @FAC10            ASSUME NO ERROR OR WARNING
       DCLR @FPERAD
       XML  FLTINT
       CZ   @FAC10            If error
       BR   ERRBV
       CGE  0,@FAC            Can't be < zero
       BR   ERRBV
       RTN
* FAC IS SET UP WITH F.P. 1
JOYXY  ST   @VAR0,@FAC1
       CZ   @VAR0             If <>0
       BR   GA995
       CLR  @FAC              (>0000000000000000)
       BR   GA99D
GA995  CGE  0,@VAR0
       BS   GA99D
       ST   >BF,@FAC
GA99D  XML  ASSGNV            Assign the value
       RTN
KEYJOY ST   @FAC1,@VAR0       Keyboard selection
       CALL NUMVAR            Get variable for key-code
       CEQ  COMMAZ,@CHAT      If not comma - error
       BR   ERRSYN
       XML  PGMCHR            Get next character
       CALL NUMVAR            Get variable for key-status
       ST   @VAR0,@KEYBD      Keyboard selection
       MOVE 8,[email protected],@FAC     Set up float
* RXB PATCH CODE *************
*      SCAN                   SCAN the keyboard
*      CLR  @KEYBD            Clear the code(No affect on s
       CALL KEYSTR            * RXB KEY STRING COMPARISON *
       RTNC                   Return scan condition code
NUMVAR XML  SYM               Get the symbol name
       CLOG >C0,V*FAC         Can't be string or function
       BR   ERRMUV            It is, IMPROPERLY USED NAME E
       XML  SMB               Get value pointer
       XML  VPUSH             Put on stack for ASSGNV
       RTN                    And return
ATTREG DATA >8000,>A000,>C000,
       BYTE >9F,>BF,>DF,>FF,>00,>06
COMB   CEQ  LPARZ,@CHAT       If not '(' - error
       BR   ERRSYN
       RTN
SQUISH MOVE 8,V*FAC8,@FAC     Sneak it out
       DST  @VSPTR,@FAC14     Now move stack to squish it
       DSUB @FAC8,@FAC14        out - # of bytes to move
       BS   SQU05             If none to move
       MOVE @FAC14,[email protected](@FAC8),[email protected](@FAC8)
SQU05  DSUB 8,@VSPTR
       RTN
***********************************************************
*                 SUBPROGRAM FOR CLEAR
***********************************************************
CLEAR  ALL  SPACE+OFFSET      Clear the screen
       ST   3,@XPT            Initialize screen pointer
       BR   LNKRT2            Return to caller
***********************************************************
*               SUBPROGRAM FOR VERSION
***********************************************************
VERS   CALL COMB              Insure have left parenthesis
       CALL ERRC05            Get symbol information
*----------------------------------------------------------
* Change version number to 110     6/16/81
       DST  2001,@FAC
       XML  CIF               Convert to floating point
*----------------------------------------------------------
       BR   ASSRTN            Assign and return to caller
* INIALIZATION DATA FOR SOUND
FLTS   BYTE >42,>0B,>12,>22,>00,>00,>00,>00
SNDREG BYTE >01,>FF,>01,>04,>9F,>BF,>DF,>FF,>00
***********************************************************
*                SUBPROGRAM FOR 'SOUND'
* Builds 2 blocks in VDP RAM
* 1st BLOCK : >01,<ATTENUATION FOR NOISE>,<INTERRUPT COUNT>
* 2nd BLOCK : >04,>9F,>BF,>DF,>FF,>00
***********************************************************
SOUND  DCEQ VRMSND,@>83CC     Insure previous sound started
       BS   SOUND
       MOVE 9,[email protected],[email protected]
       CALL LPAR              Duration in milliseconds
       CGE  0,@FAC            Don't wait for completion
       BS   GAA39
       DNEG @FAC                of previous sound
       DCLR @PRTNFN           Make GPL interpeters stop pre
GAA39  XML  SPEED             Insure duration
       BYTE RANGE           *  is in range
       BYTE 1               *   of 1 - 4250
       DATA 4250
* Convert duration into 1/60s of a second
       DMUL 6,@FAC            Duration * 6
       DDIV 100,@FAC          (duration * 6) / 100
       CZ   @FAC1             If duration =0
       BR   GAA4D
       INC  @FAC1             Set it to 1/60th of a second
GAA4D  ST   @FAC1,[email protected]+2    3rd byte of the 1st block
*                          | INTERUPT COUNT
***********************************************************
*      SOUND TABLE OF 10 BYTES IN CPU RAM (>00 - >09)
* >00 - >05 : FREQUENCY CONTROL
* >06 - >08 : ATTENUATION CONTROL
* >09       : NOISE CONTROL(non-zero = noise encountered)
* >0A       : POINTER FOR CURRENT FREQENCY CONTROL
* >0B       : POINTER FOR CURRENT ATTENUATION CONTROL
*                    >00 , >01 FOR REG 0;
*                    >02 , >03 FOR REG 1;
*                    >04 , >05 FOR REG 2;
* REG0 : >8000, REG1 : >A000, REG3 : >C000
* INITIALIZE ATTENUATION CONTROL
* REG0 : >9F, REG1 : >BF, REG2 : >DF
***********************************************************
       MOVE 12,[email protected],@>8300
SOUND1 XML  SPEED             Parse the frequency value
       BYTE PARCOM         *   and insure a comma
       CALL CKSTNM            Must be a numeric
       CGE  0,@FAC            Noise if negative
       BR   SOUND2
       MOVE 8,[email protected],@ARG     Constant 111834
       XML  FDIV              P = 111834/FREQUENCY
       XML  SPEED             Insure in range
       BYTE RANGE
       BYTE 3               * Range: 3 - 1023
       DATA 1023
* GET THE 4 L.S.Bits BITS AND 6 M.S.Bits OF 'P'
       DSRC 4,@FAC
       SRL  4,@FAC
       DOR  @FAC,*STADDR  1st byte of frequency control byt
*                         BIT   7   6   5   4   3   2   1
*                               1  <REG>    0  <L.S.B. 4 OF
*                         2nd byte of frequency control byt
*                               0   0   <M.S.B. 6 of 'P'
       INCT @STADDR           Advance ponter for next time
       CALL ATTNUT            Get attenuation
*                        BIT    7   6   5   4   3   2   1
*                               1   <REG>   1   0   0   0
       AND  @FAC1,*VAR2         1   <REG>   1   <ATTN/2 DB>
       INC  @VAR2             Advance pointer for next time
* CHECK FOR END OF SOUND CALL
SOUND3 CEQ  RPARZ,@CHAT       End of statement?
       BS   SOUND5
       XML  SPEED             If not right parenthesis
       BYTE SYNCHK        *    then must be at
       BYTE COMMAZ        *      a comma
       CEQ  6,@STADDR         If not 3 regs yet
       BR   SOUND1
* 3 sound regs already - so must be noise control
       XML  SPEED             Get frequency (should be nois
       BYTE PARCOM        *     and insure a comma
       CALL CKSTNM            Must be a numeric value
       CGE  0,@FAC            If not noise-error
       BS   ERRBV
* NOISE CONTROL
SOUND2 CEQ  >FF,@>8309        * BAD ARGUMENT ERROR
       BR   ERRBA
       DNEG @FAC              -(FREQUENCY)
       XML  SPEED             Insure in range
       BYTE RANGE         *    of 1 - 8
       BYTE 1             *
       DATA 8
       DEC  @FAC1             0 - 7 (2nd BIT: 'T')
*                                           OTH, 1ST BITS:
       ST   @FAC1,@>8309
       OR   >E0,@>8309        Noise control byte:
*                        BIT  7   6   5   4   3   2   1   0
*                             1   1   1   0   0  <T>  < S >
* PUT ATTENUATION IN THE 2ND BYTE OF 1ST BLOCK
       CALL ATTNUT
       ST   @FAC1,[email protected]+1
*                             1   1   1   1   < ATTN/2  DB>
       BR   SOUND3            Go check for end of list
SOUND5 CLR  @VAR5             Pointer to sound table
SND05  CZ   @PRTNFN           Wait untild previous
       BS   SOUND6
       SCAN                   Is finished and
       BR   SND05              look for a break-key
       CEQ  BREAK,@RKEY       If not break-key
       BR   SND05
       BR   EXEC6C            If BREAK-KEY encountered
* LOAD SOUND TABLE
SOUND6 ST   *VAR5,@>8400      SOUND ADDRESS PORT
       INC  @VAR5             Next byte in table
       CEQ  >0A,@VAR5         If not finished
       BR   SOUND6
       DST  VRMSND,@FAC       Where the 2 blocks are
       I/O  1,@FAC            Start sound from VDP list
       BR   LNKRTN            Return to caller
***********************************************************
*                SUBPROGRAM FOR 'HCHAR'
***********************************************************
HCHAR  CALL HVCHR             Get X, Y values character, #
       DCZ  @FAC              If 0 characters
       BS   HCHAR2
HCHAR1 BYTE >08,>E0,>00,>FB  * FMT '@VAR0'   Display horizo
       DDEC @FAC              Done yet?
       BR   HCHAR1            No, finish it
* RXB PATCH CODE
HCHAR2 CEQ  COMMAZ,@CHAT
       BS   HCHAR
XPTRTN ST   @MNUM,@XPT        Restore X-pointer
LNKRTN XML  SPEED             Must be at
       BYTE SYNCHK        *     a right
       BYTE RPARZ         *      parenthesis
LNKRT2 CALL CHKEND            Check end of statement
       BR   ERRSYN            If not end-of-stmt , error
       CALL RETURN            Return to caller
***********************************************************
*                SUBPROGRAM FOR 'VCHAR'
***********************************************************
VCHAR  CALL HVCHR             Get X, Y values character, #
       DCZ  @FAC              If 0 characters
       BS   VCHAR2
VCHAR1 BYTE >08,>E0,>00,>9E,>FB * FMT '@VAR0',>31 Display v
       DDEC @FAC              Done yet?
       BS   VCHAR2            Yes, return
       CZ   @YPT              If not at start of colunm
       BR   VCHAR1
       INC  @XPT              Move X-ptr to right one colun
       B    VCHAR1
* RXB PATCH CODE
VCHAR2 CEQ  COMMAZ,@CHAT
       BS   VCHAR
       BR   XPTRTN
***********************************************************
*               SUBPROGRAM FOR 'CHAR'
***********************************************************
CHARLY CALL COMB
CHAR5  XML  PGMCHR            Skip "(" or ","
* RXB PATCH CODE
       CEQ  ALLZ,@CHAT
       BR   GAB1F
       XML  PGMCHR
       CALL COMMA2
       ST   ALLZ,@VAR0
       DST  32,@FAC
       BR   GAB28
GAB1F  XML  SPEED             Get the first value
       BYTE PARCOM         *    and insure a comma
       XML  SPEED             Insure in range
       BYTE RANGE          *   of 32 - 143
* RXB PATCH CODE
       BYTE 30
       DATA 159
GAB28  DSLL 3,@FAC            Convert chr number to address
       DADD >0300,@FAC        CORRECT FOR OFFSET
       DST  @FAC,@VARY        Save it
       XML  PARSE             Get string
       BYTE RPARZ
       CEQ  >65,@FAC2         MUST BE STRING
       BR   ERRSNM
       MOVE 4,@FAC4,@VAR5     VAR5 pointer to string value
* Start defining character description.
*    VARY    Address of RAM for character description.
*    VAR5    Pointer to string value.
*    VAR7    Length of string value.
*    VAR9    Temporary counter.
*    VAR9+1  Temporary counter.
       DCH  64,@VAR7          Max 4 characters at a time
       BR   CHAR40
       DST  64,@VAR7          IGNORE THE EXCESSES
CHAR40 DCHE SPRVB,@VARY       Don't have space for
       BS   CHARL4
       ST   ZERO,@FAC         Floating Point Accumulator (>
       MOVE 15,@FAC,@FAC1
       DCZ  @VAR7             Fill with zero
       BS   CHAR50
       DCHE 16,@VAR7
       BS   GAB6B
       MOVE @VAR7,V*VAR5,@FAC Move whatever
       DCLR @VAR7
       BR   CHAR50
GAB6B  MOVE 16,V*VAR5,@FAC    Move one character
       DSUB 16,@VAR7          Less num of bytes to move
       DADD 16,@VAR5          Move pointer
CHAR50 ST   >4A,@VAR9         Move pointer (>4A=FAC)
       ST   1,@VAR9+1
       B    GAB84
GAB82  INC  @VAR9+1
GAB84  CGT  8,@VAR9+1
       BS   GABC3
       CLR  @BYTES            Clear dot-building byte
CHARL2 SLL  4,@BYTES          For loop(2 chars per byte)
       ST   *VAR9,@ARG
       CHE  ZERO,@ARG         If < 0
       BR   ERRBV
       CGT  NINE,@ARG         If in 0-9
       BR   CHARL3
       CHE  A,@ARG            If > 9 but < A
       BR   ERRBV
       CH   F,@ARG            If > F
       BS   ERRBV
CHARL3 SUB  ZERO,@ARG         Character - >30
       CH   10,@ARG           If in A-F
       BR   GABB1
       SUB  7,@ARG            Correct for that too
GABB1  OR   @ARG,@BYTES       Dot expression
       INC  @VAR9
       CLOG 1,@VAR9           1st half of row finished?
       BR   CHARL2            Yes, do 2nd half
*                              (each takes half byte)
       ST   @BYTES,V*VARY     Load characters
       DINC @VARY
       BR   GAB82             Load characters on next row
GABC3  DCZ  @VAR7             More char to describe
       BR   CHAR40
* RXB PATCH CODE
       CEQ  ALLZ,@VAR0
       BR   CHARL4
       DCLR @VAR0
CHRFIL MOVE 8,[email protected]>0400,[email protected]>0408(@VAR0)
       DADD 8,@VAR0
       DCEQ 94*8,@VAR0
       BR   CHRFIL
CHARL4 CEQ  COMMAZ,@CHAT      More specified?
       BS   CHAR5
       BR   LNKRTN            Return
***********************************************************
*              SUBPROGRAM FOR 'KEY'
***********************************************************
KEY    CALL SPAR              GET KEY UNIT
* RXB PATCH LABEL ************
GABD1  XML  SPEED             Insure in range
       BYTE RANGE          *   of 0 - 5
       BYTE 0
       DATA 5
       CALL KEYJOY            Get variables for code and st
*                              and scan keyboard
*                             KEYJOY returns key status
       BS   KEY1B             KEY STATUS = 1
       DNEG @FAC              Assume status = -1
       CEQ  >FF,@RKEY         But correct if = 0
       BR   KEY1B
       DCLR @FAC              KEY STATUS = 0
KEY1B  XML  ASSGNV            Assign value in variable
       DST  >4001,@FAC        Re-store F.P. 1 in FAC
       CZ   @RKEY             If key-code = 0
       BS   KEY2
       CEQ  >FF,@RKEY         No key depressed,
       BS   KEY1C              key code assigned to -1
* FORMAT FOR KEYCODES ABOVE 99 ADDED FOR 99/4A HIGHEST
* KEYCODE (OTHER THAN >FF) IS >C6=198
* 5/7/81
       CHE  100,@RKEY
       BR   GAC04
       INC  @FAC
       SUB  100,@RKEY
       ST   @RKEY,@FAC2       FLOATING FORMAT (>4001__00000
       B    GAC07
GAC04  ST   @RKEY,@FAC1       FLOATING FORMAT (>40__0000000
GAC07  BR   KEY2A
KEY1C  DNEG @FAC              KEY CODE ASSIGNED TO -1
       BR   KEY2A
KEY2   DCLR @FAC              (>000000000000000)
KEY2A  XML  ASSGNV            ASSIGN VALUE TO VARIABLE
* RXB PATCH CODE *************
*      BR   LNKRTN
       BR   SUBRTN
***********************************************************
*                  SUBPROGRAM FOR 'JOYSTICK'
***********************************************************
JOYST  CALL SPAR              KEY UNIT
* RXB PATCH LABEL ************
GAC16  XML  SPEED             Insure in range
       BYTE RANGE          *   of 1 - 4
       BYTE 1
       DATA 4
       CALL KEYJOY            GET VARIABLES FOR X, Y
*                              AND SCAN KEYBOARD
       ST   @JOYY,@VAR0       JOYSTICK Y POSITION
       CALL JOYXY             -4 to +4
       DST  >4001,@FAC        Re-store F.P. 1 in FAC
       ST   @JOYX,@VAR0       JOYSTICK X POSITION
       CALL JOYXY             -4 to +4
* RXB PATCH CODE *************
*      BR   LNKRTN
       BR   SUBRTN
***********************************************************
* INSURE LEFT PARENTHESIS AND THEN PARSE TO A COMMA
***********************************************************
* RXB PATCH CODE
LPAR   CEQ  COMMAZ,@CHAT
       BS   CPAR
       XML  SPEED             Must be
       BYTE SYNCHK          *  at a
       BYTE LPARZ           *    left parenthesis
       BR   GAC35
CPAR   XML  SPEED
       BYTE SYNCHK
       BYTE COMMAZ
* RXB PATCH LABEL ***********
GAC35  XML  PARSE             Do the parse
       BYTE COMMAZ          * Stop on a comma
       XML  SPEED             Must be
       BYTE SYNCHK          *  at a
       BYTE COMMAZ          *   comma
       RTN
***********************************************************
* SUBROUTINE FOR 'RANGE' USED IN ALL SOUND AND GRAPHICS
***********************************************************
RAN16  XML  SPEED             Insure in range
       BYTE RANGE          *   of 1 to 16
       BYTE 1
       DATA 16
       DEC  @FAC1             Adjust to internal range
       RTN
***********************************************************
* SUBROUTINE TO GET ROW, COLUMN VALUES
***********************************************************
* RXB PATCH CODE
GPHV   CALL LPAR              Insure '(', parse, insure ','
* RXB PATCH CODE
GPHVRC XML  SPEED             Insure in range
       BYTE RANGE           *  of 1 - 24
       BYTE 1
       DATA 24
       DEC  @FAC1             Adjust to internal range
       ST   @XPT,@MNUM
       ST   @FAC1,@YPT        Set row pointer
       XML  SPEED             Get column value
       BYTE PARCOM          *  and insure a comma
       XML  SPEED             Insure in range
       BYTE RANGE           *  of 1 to 32
       BYTE 1
       DATA 32
       DEC  @FAC1             Internal range: 0 - 31
       ST   @FAC1,@XPT        Set column pointer
       RTN
*  Subroutine to control border color
* Character background is also affected since transparent
*  is used.
BORDER CALL PARFF             Insure '(' , and parse
       CALL RAN16             Check 1 - 16 & put in interna
       MOVE 1,@FAC1,#7        Load VDP register
       BR   LNKRT2            Return to XB program
* Get ROW, COLUMN VALUES AND NUMBER OF CHARACTERS
HVCHR  CALL GPHV              Get X, Y VALUES
       XML  PARSE
       BYTE RPARZ
       CALL INTARG
       ADD  OFFSET,@FAC1
       ST   @FAC1,@VAR0       SAVE THE CHARACTER
       DST  1,@FAC            ASSUME 1 CHARACTER
       CEQ  RPARZ,@CHAT       If not right parenthesis
       BS   GAC95
       XML  SPEED             Must be
       BYTE SYNCHK          *   at a
       BYTE COMMAZ          *    comma
       XML  PARSE             # OF CHARACTERS
       BYTE RPARZ
       CALL INTARG            FLOATING TO INTEGER
GAC95  RTN
***********************************************************
* ERRWXY - Is the subroutine for CALL ERR(W,X,Y,Z)
*  The parameters indicate:
*   W - The error code # of the error
*   X - Indicates whether execution(-1) error or
*       I/O (0-255) error on LUNO 0-255
*   Y - Indicates the severity code of the error
*   Z - Line number of the error
*   ERR Can be called with 2 forms:
*       CALL ERR(W,X,Y,Z) and CALL ERR(W,X)
*   If ERR is called and no error has occured then all
*   values returned are zero.
***********************************************************
ERRWXY DST  @VSPTR,@FAC8      Get a temp VSPTR
GAC99  DCH  @STVSPT,@FAC8     While not a bottom of stack
       BR   GACD0
       ST   [email protected](@FAC8),@ARG   Keep ID code in ARG area
       CEQ  >69,@ARG          *** ERROR entry
       BR   GACAF
       CALL SQUISH            Squish it out of the stack
       XML  VPUSH             Put permanent copy of error
*                              entry on stack
       BR   ERR10             Jump out now
* Jump always
GACAF  CEQ  >67,@ARG          *** FOR entry
       BR   GACBA
       DSUB 32,@FAC8          Skip it
       BR   GACCE
GACBA  CEQ  >66,@ARG          *** GOSUB entry
       BR   GACC5
       DSUB 8,@FAC8           Skip it
       BR   GACCE
GACC5  CEQ  >6A,@ARG          * SYNTAX ERROR
       BR   ERRSYN
       DSUB 16,@FAC8          Skip it
GACCE  BR   GAC99
GACD0  DST  >0080,@FAC        No error entry there so
       DST  >6900,@FAC2        fake one
       DCLR @FAC4
       DCLR @FAC6
ERR10  XML  VPUSH             Push the temporary entry on
*                              top of stack
* Code to get "W" in
       CALL COMB              Check for left parenthesis
       CALL ERRC05            Pick up user's symbol
       ST   [email protected](@VSPTR),@FAC1 Get error code
       XML  CIF               Convert it to floating
       XML  ASSGNV            Assign it
* Code to get "X" in
       CALL ERRCOM            Check syntax & get user's sym
       CLOG >80,[email protected](@VSPTR)  If execution
       BR   GAD03
       MOVE 8,[email protected],@FAC     Make it such
       DNEG @FAC              Make it a negative
       BR   GAD0B
GAD03  ST   [email protected](@VSPTR),@FAC1 Get I/O LUNO number
       XML  CIF               Convert it to floating
GAD0B  XML  ASSGNV
* Code to get "Y" in
       CEQ  RPARZ,@CHAT       If long form of CALL ERR
       BS   GAD42
       CALL ERRCOM            Check syntax & get user's sym
       ST   [email protected](@VSPTR),@FAC1 Get severity code
       AND  >7F,@FAC1         Reset execution  /  I/O flag
       XML  CIF               Convert it
       XML  ASSGNV            Assign it
* Code to get "Z" in
       CALL ERRCOM            Check syntax & get symbol
       DST  [email protected](@VSPTR),@FAC2 Get line pointer
       DST  @FAC2,@FAC
       DCZ  @FAC2             If line number exists
       BS   GAD3E
       DDECT @FAC2            Point to the line #
       CALL GRSUB1            Read line # (2 bytes) from VD
*                              or ERAM (use GREAD)
       BYTE >4C             * @FAC2: Source addr on ERAM/VD
       DST  @EEE,@FAC         Put the line # in FAC
       AND  >7F,@FAC          Reset the breakpoint if any
GAD3E  XML  CIF               Convert it
       XML  ASSGNV            Assign it
GAD42  XML  VPOP              Trash the temporary entry
       B    LNKRTN            Return from subprogram
* Must be long branch because of AND above
ERRCOM CEQ  COMMAZ,@CHAT      Check for comma
       BR   ERRSYN
ERRC05 XML  PGMCHR            Get the next character
       XML  SYM               Collect name & s.t. entry
       XML  SMB               Get value space
       XML  VPUSH             Push it
       CLR  @FAC              Set up for conversion
       RTN
* CHANGE IN ADDRESS OF THE ERROR CALLS WILL AFFECT
* THE FILE SUBS.....
*     ERROR messages called from this file
ERRSYN CALL ERRZZ             * SYNTAX ERROR
       BYTE 3             *   (shared by SUBS)
ERRSNM CALL ERRZZ             * STRING-NUMBER MISMATCH
       BYTE 7             *   (shared by SUBS)
ERRMUV CALL ERRZZ             * IMPROPERLY USED NAME
       BYTE 9
ERRMEM CALL ERRZZ             * MEMORY FULL
       BYTE 11
ERRSO  CALL ERRZZ             * STACK OVERFLOW
       BYTE 12
ERRNWF CALL ERRZZ             * NEXT WITHOUT FOR
       BYTE 13
ERRFNN CALL ERRZZ             * FOR/NEXT NESTING
       BYTE 14
ERRSNS CALL ERRZZ             * MUST BE IN SUBPROGRAM
       BYTE 15
ERRRSC CALL ERRZZ             * RECURSIVE SUBPROGRAM CALL
       BYTE 16
ERRRWG CALL ERRZZ             * RETURN WITHOUT GOSUB
       BYTE 18
ERRBS  CALL ERRZZ             * BAD SUBSCRIPT
       BYTE 20
ERRLNF CALL ERRZZ             * LINE NOT FOUND
       BYTE 22
ERRBA  CALL ERRZZ             * BAD ARGUMENTS
       BYTE 28
ERRBV  CALL ERRZZ             * BAD VALUE
       BYTE 30            *   (shared by SUBS)
ERRIAL CALL ERRZZ             * INCORRECT ARGUMENT LIST
       BYTE 31            *   (shared by SUBS)
ERRSNF CALL ERRZZ             * SUBPROGRAM NOT FOUND
       BYTE 37
* Other error messages appear in this program
* ERRRDY      * READY                        DATA 0
* ERRBRK      * BREAK POINT                  DATA 1
* ERROLP      * ONLY LEGAL IN A PROGRAM      DATA 27
*
* WRNN01      * NUMERIC OVERFLOW             DATA 2
* WRNS02
* WRNST1      * STRING TRUNCATED             DATA 19
* WRNST2
* WRNLNF      * LINE NOT FOUND               DATA 38
*
***********************************************************
       AORG >0E00
* SPRITE SUBROUTINES BRANCH TABLE
CHAR1  BR   SPNUM3            Called in CHARLY.    EXEC
CHAR2  BR   SPNUM2            Called in CHARLY.    EXEC
       BR   $                 Called in CHARLY.    EXEC
* SUBROUTINE LINK LIST
LINKS1 DATA LINKS2
       STRI 'SPRITE'
       DATA SPRTE
LINKS2 DATA LINKS3
       STRI 'DELSPRITE'
       DATA SPRDEL
LINKS3 DATA LINKS4
       STRI 'POSITION'
       DATA SPRPOS
LINKS4 DATA LINKS5
       STRI 'COINC'
       DATA ZSCOI
LINKS5 DATA LINKS6
       STRI 'MAGNIFY'
       DATA SPRMAG
LINKS6 DATA LINKS7
       STRI 'MOTION'
       DATA SPRMOV
LINKS7 DATA LINKS8
       STRI 'LOCATE'
       DATA SPRLOC
LINKS8 DATA LINKS9
       STRI 'PATTERN'
       DATA SPRPAT
LINKS9 DATA LINKSA
       STRI 'DISTANCE'
       DATA ZSDIST
LINKSA DATA LINKSB
       STRI 'SAY'
       DATA SAY
LINKSB DATA LINKSC
       STRI 'SPGET'
       DATA SPGET
LINKSC DATA LINKSD
       STRI 'CHARSET'
       DATA CHRSET
***********************************************************
* CALL SPRITE(#SPRITE,CHAR,COLOR,Y,X,(YSPEED,XSPEED),...)
***********************************************************
SPRTE  CALL SPNUM1            Check sprite mode and skip "(
       CALL SPNUM2            Get sprite number
SPRT3  CALL SPCHR             Put character number for spri
       XML  SPEED
       BYTE SYNCHK
       BYTE COMMAZ         *  Check for comma and skip it
       CALL GA01E             Put sprite color in SAL  (SPC
       XML  SPEED             Insure at a comma
       BYTE SYNCHK
       BYTE COMMAZ
       CALL SPLOC             Put location of sprite in SAL
       DST  @SP04+1,V*SPSAL   Put in location of sprite
* Finish defining SAL. Check if velocity is specified
SPRT4  CEQ  COMMAZ,@CHAT      Finished!!!!!
       BR   GB0F2
       XML  PGMCHR
       CEQ  NUMBEZ,@CHAT      Next sprite specified
       BR   GAEBB
       CALL SPNUM3            Get the next sprite number
       BR   SPRT3             And go!
GAEBB  CALL SPMOVE            Get the velocity first
       BR   SPRT4
***********************************************************
* CALL DELSPRITE(#SPR,.......)  or CALL DESPRITE(ALL)
***********************************************************
SPRDEL CALL SPNUM1            Insure at '('
SPDEL1 XML  PGMCHR            Skip "(" or ","
       CEQ  NUMBEZ,@CHAT      If sprite number
       BR   GAEF6
       XML  PGMCHR            Skip "#"
       XML  PARSE             Parse the sprite number
       BYTE RPARZ
       CALL SPNUM4            Check and convert number
       DCLR [email protected]>0480(@SPSAL)   Stop motion if moving
       DST  >C000,V*SPSAL     Hide the sprite off screen
*----------------------------------------------------------
* Add following 7 lines for speeding up XBASIC
       CEQ  @MOTION,[email protected]   Check current sprite
       BR   SPDEL2
* no. against sprite motion count
* yes, change to as low as possible
GAEE1  DEC  @MOTION
       BS   SPDEL2
       DSUB 4,@SPSAL
       DCZ  [email protected]>0480(@SPSAL)
       BS   GAEE1
*----------------------------------------------------------
SPDEL2 CEQ  COMMAZ,@CHAT      If more sprites
       BS   SPDEL1
       BR   GAEFD
GAEF6  XML  SPEED             Must have 'ALL' else error
       BYTE SYNCHK
       BYTE ALLZ
       CALL SPRINT            Reinitialize all sprites
GAEFD  BR   GB0F2             Return to caller
***********************************************************
* CALL POSTION(#SPR,Y,X,...)
***********************************************************
SPRPOS CALL SPNUM1            Check for sprites and skip "(
SPRP02 CALL SPNUM2            Check sprite number
       CALL PREPN             Prepare Y-position return var
       XML  SPEED             Insure at a comma
       BYTE SYNCHK
       BYTE COMMAZ
       DST  V*SPSAL,@SP00     Read X, Y position
       ST   @SP00,@FAC1       Get Y position
       CEQ  >FE,@FAC1
       BR   GAF1C
       DINCT @FAC             Get 256 as an output
       BR   GAF1E
GAF1C  INCT @FAC1             Regular adjustment for user
GAF1E  CALL SPRP03            Check, convert & assign value
       CALL PREPN             Prepare X-pos return variable
       ST   @SP00+1,@FAC1     Get X position
       DINC @FAC              Adjust for the user
       CALL SPRP03            Check, convert & assign value
       CEQ  COMMAZ,@CHAT      If not finished
       BS   SPRP02
       BR   GB0F2             Return
SPRP03 XML  CIF               Convert integer to float
       DCEQ >C000,@SP00       If hidden sprite
       BR   GAF3D
       DCLR @FAC              Return value zero
GAF3D  XML  ASSGNV            Assign to variable
       RTN
***********************************************************
* CALL COINC(#SPR,#SPR,TOLERANCE,CODE)
* CALL COINC(#SPR,YLOC,XLOC,TOLERANCE,CODE)
* CALL COINC(ALL)
***********************************************************
SPRCOI CALL SPNUM1
       XML  PGMCHR            Skip "("
       CEQ  ALLZ,@CHAT        Check coinc of all sprites
       BR   GAF56
       XML  PGMCHR            Skip "ALL"
       CALL COMMA2            Check and skip ","
       CLOG >20,@VDPSTT       Check VDP status
* RXB PATCH CODE ************
*      BS   NULRTN
       BS   NR
       BR   GAF6C
* RXB PATCH CODE ************
GAF56  CALL CODIST            Get distance of 2 sprites
       CALL COMMA             Get tolerance level
       XML  SPEED
       BYTE RANGE           * Check against range
       BYTE 0               * FAC has tolerance level
       DATA 255
       DCH  @FAC,@SP00        Y-loc out of range
* RXB PATCH CODE ************
*      BS   NULRTN
       BS   NR
       DCH  @FAC,@SP04        X-loc out of range
* RXB PATCH CODE ************
*      BS   NULRTN
       BS   NR
* If no conincidence just return zero
GAF6C  CALL PREPN             Prepare for numeric output
       DST  >BFFF,@FAC        Store -1 in FAC
* RXB PATCH CODE ************
*      BR   ASSRTN
       BR   AR
***********************************************************
* CALL MAGNIFY(magnification factor=1 - 4)
***********************************************************
SPRMAG CALL SPNUM1            Insure at "("
       XML  PGMCHR            Skip the "("
       XML  PARSE             Parse the magnification facto
       BYTE RPARZ
       XML  SPEED
       BYTE RANGE
       BYTE 1
       DATA 4
* Next statement adding >DF to subtract 1 from FAC
       ADD  >DF,@FAC1         Turn on screen and interrupt
       MOVE 1,@FAC1,#1        Store it to VDP register 1
       BR   GB0F2
***********************************************************
* CALL MOTION(#SPR,YSPEED,XSPEED,...)
***********************************************************
SPRMOV CALL SPNUM1            Insure at "("
* RXB PATCH CODE *************
* SPRMV2 CALL SPNUM2            Get sprite number
SPRMV2 B    SPGS              GO or STOP
SPRMV3 CALL SPMOVE            Store velocity
SPRMV4 CEQ  COMMAZ,@CHAT      Loop if more
       BS   SPRMV2
       BR   GB0F2
***********************************************************
* CALL LOCATE(#SPR,YLOC,XLOC,...)
***********************************************************
SPRLOC CALL SPNUM1            Insure at "("
SPRLC2 CALL SPNUM2            Check sprite number
       CALL SPLOC             Read location
       DST  @SP04+1,V*SPSAL   Put in sprite location
       CEQ  COMMAZ,@CHAT      Loop if more
       BS   SPRLC2
       BR   GB0F2
***********************************************************
* CALL PATTERN(#SPR,CHAR,...)
***********************************************************
SPRPAT CALL SPNUM1            Insure at "("
SPRPT2 CALL SPNUM2            Get sprite number
       CALL SPCHR             Set the sprite character
       CEQ  COMMAZ,@CHAT      Loop if more
       BS   SPRPT2
       BR   GB0F2
***********************************************************
* CALL DISTANCE(#1,#2,DISTANCE)
* CALL DISTANCE(#1,Y,X,DISTANCE)
***********************************************************
DIST   CALL SPNUM1            Insure at "("
* RXB PATCH LABEL ************
GAFC4  XML  PGMCHR            Skip "("
       CALL CODIST            Get distance in Y and X
       CALL PREPN             Prepare return variable
       DMUL @SP00,@SP00       X=X*X
       DMUL @SP04,@SP04       Y=Y*Y
       DADD @SP06,@SP02       @SP02=X*X+Y*Y
       OVF                    Checking overflow bit
       BS   OVER              If overflow-indicate maximum
       DST  @SP02,@FAC        Put distance squared in FAC
       DCH  >7FFF,@SP02       If bigger then 128
       BR   GAFE5
OVER   DST  >7FFF,@FAC        Put maximum value
GAFE5  XML  CIF               Convert to floating format
* RXB PATCH CODE
*      BR   ASSRTN            Assign value and return
       BR   AR
***********************************************************
* CODIST routine gets locations of two sprites or one
*  sprite and Y and X position specified by a user and
*  calculates absolute value of Y and X distance.
***********************************************************
CODIST CLR  @SP00
       MOVE 7,@SP00,@SP00+1   Clear up first 8 bytes
       CEQ  NUMBEZ,@CHAT      Check for #
       BR   ERRSYN
       CALL SPNUM3            Get the first sprite
       DST  V*SPSAL,@SP00+1   Location of first sprite
       INC  @SP00+1           Increment to make range 1-256
       ST   @SP02,@SP02+1     Put X in SP02+1
       CLR  @SP02             Y in SP00+1
       CEQ  NUMBEZ,@CHAT      Get 2nd sprite
       BR   GB011
       CALL SPNUM3            Get the next sprite
       DST  V*SPSAL,@SP04+1   Location of second sprite
       BR   GB017
GB011  CALL SPLOC             Get Y and X location
       CALL COMMA2            Check for comma and skip
GB017  INC  @SP04+1           Increment to make range 1-256
       DSUB @SP04,@SP00       Difference in Y at SP00
       DABS @SP00             Get absolute value
       CLR  @SP04+1           Clear byte before X
       DSUB @SP02,@SP04+1     Difference in Y at SP04
       DABS @SP04+1           get the absolute value
       ST   @SP06,@SP04+1     Put in the right place
       RTN
***********************************************************
* CHRSET restores the standard character set and the
*  standard colors for the standard character set
*  (black on transparent)
***********************************************************
CHRSET CALL CHKEND            Must be at EOS now
       BR   ERRSYN            Else its an error
       ST   >40,@FAC2         Number of characters to load
       CALL CHRTBL            Call RXB routine to load
       ST   >10,[email protected]>080F       Set 1st set to black on tranp
       MOVE 16,[email protected]>080F,[email protected]>0810  Ripple for rest
       CALL RETURN            Return to the caller
******************************
* SPNUM1 ROUTINE             *
******************************
SPNUM1 CEQ  LPARZ,@CHAT       Should be "("
       BR   ERRSYN
       RTN
******************************
* SPNUM2 ROUTINE             *
******************************
SPNUM2 XML  PGMCHR            Get the next character
SPNUM6 CEQ  NUMBEZ,@CHAT      Must be "#"
       BR   ERRSYN
SPNUM3 XML  PGMCHR            Get next character
       CALL COMMA             Parse up to comma and skip it
SPNUM4 XML  SPEED
       BYTE RANGE           * Verify the value is in range
       BYTE 1               * Sprite number 1 - 28
       DATA 28
*----------------------------------------------------------
* Insert a line here in sprite handling code for speeeding
*  up XB    5/22/81
* RXB PATCH LABLE ************
SPNUM5 ST   @FAC1,[email protected]     Keep sprite number
*----------------------------------------------------------
       DEC  @FAC1             Adjust for internal use
       DSLL 2,@FAC            Get location of SAL
       DADD >0300,@FAC        Sprite # * 4 + >0300
       DST  @FAC,@SPSAL       Save SAL location
       RTN
******************************
* SPLOC ROUTINE              *
******************************
SPLOC  CALL COMMA             Parse up to comma and skip it
       XML  SPEED
       BYTE RANGE           * Range of Y: 1 - 256
       BYTE 1
       DATA 256
       DECT @FAC1             Adjust for internal use: FF -
       DST  @FAC,@SP04        Store in SP04 area
       XML  PARSE
       BYTE RPARZ           * Parse to ")" or less
       XML  SPEED
       BYTE RANGE           * Get X value. Range: 1 - 256
       BYTE 1
       DATA 256
       DEC  @FAC1             Adjust for internal use: 0 -
       ST   @FAC1,@SP06       SP04+1=Y-loc and SP06=X-loc
       RTN
******************************
* SPCHR ROUTINE              *
******************************
SPCHR  XML  PARSE
       BYTE RPARZ
       XML  SPEED
       BYTE RANGE           * Check upper range
* RXB PATCH CODE
*      BYTE 32              * Character value 32 - 144
*      DATA 143
       BYTE 30
       DATA 159
       ADD  >60,@FAC1         Add offset to character numbe
       ST   @FAC1,[email protected](@SPSAL) Store the character value
       RTN
******************************
* SPMOVE ROUTINE             *
******************************
SPMOVE CALL COMMA             Parse up to comma and skip
       CALL RANGEV            Check if numeric and convert
*                              to integer
       ST   @FAC1,@SPTMP      Store Y velocity
       XML  PARSE             Get X velocity
       BYTE RPARZ           * Check for ")" or less
       CALL RANGEV            Numeric check and convert
*                              to integer
SPMOVF ST   @SPTMP,@FAC     * @FAC=Y velocity, @FAC1=X velo
       DST  @FAC,[email protected]>0480(@SPSAL)  Store velocities in SAL
*----------------------------------------------------------
* Add the following 3 lines for speeding up XB
       CH   @MOTION,[email protected]   Check current sprite
       BR   GB0BD              against sprite motion
*                                counter
       ST   [email protected],@MOTION       higher? Yes, replace it
*----------------------------------------------------------
GB0BD  RTN
RANGEV CH   >63,@FAC2         The same as INTARG
       BS   ERRSNM
       CLR  @FAC10
       DCLR @FPERAD
       XML  FLTINT
       CZ   @FAC10
       BR   ERRBV
       DCGE 0,@FAC            If positive number,
       BR   GB0DB
       DCH  >007F,@FAC         should be 0 - 127
       BS   ERRBV
       BR   GB0E1             If negative number,
GB0DB  DCHE >FF80,@FAC         Should be -1 to -128
       BR   ERRBV
GB0E1  RTN                    Otherwise its ok.
******************************
* COMMA ROUTINE              *
******************************
COMMA  XML  PARSE
       BYTE COMMAZ
COMMA2 CEQ  COMMAZ,@CHAT
       BR   ERRSYN
       XML  PGMCHR            Get next character
       RTN
******************************
* LINK BACK TO XB            *
******************************
NULRTN CALL PREPN
ASSRTN XML  ASSGNV
GB0F2  B    GA01C                               (LNKRTN)
*******************************
* PREPARE FOR PASSING ARGUMENT*
*******************************
PREPN  XML  SYM               Pick up name & search table
       XML  SMB               Evaluate any subscripts
       CH   >63,@FAC2         If not numeric, error
       BS   ERRIAL
       XML  VPUSH             Save entry on stack
       CLR  @FAC              Clear FAC for new value
       MOVE 7,@FAC,@FAC1
       RTN
***********************************************************
* CALL SAY(....................)
*  Decode given parameter(s). Store all data first, then go
*   speak it all at once.
***********************************************************
SAY    CEQ  LPARZ,@CHAT       Must start with "("
       BR   ERRSYN
       DST  @VSPTR,@FAC2      Save current top of stack on
       XML  VPUSH              the stack
       DST  255,@BYTES        255 bytes = 85 3 byte entires
       XML  GETSTR            Get temp speech list string
       DST  >001C,@FAC        Indicate it is temp string (S
       DST  >6500,@FAC2       Indicate it is string entry
       DST  @SREF,@FAC4       Save pointer to temp string
       DST  @BYTES,@FAC6      Length is 255
       XML  VPUSH             Make it semi-permenant
* Set up pointers into the speak list
       DST  @FAC4,@PTFBSL     Front points to begining
       DST  @FAC4,@PTLBSL     Last now points to beginning
       DST  @PTFBSL,@PTEBSL
       DADD @FAC6,@PTEBSL     End points to the end+1
       CALL SETRW             Set PHROM read/write address
       CALL WAIT              Wait till no one is speaking
DIRSPK CALL GETPRM            Get next parameter
       BS   NEXT1             If non-null ASCII string
       DST  @FAC4,@PTFCIS     Set up pointer to first char
       DST  @FAC6,@PTLCIS     Set ptr-to-last-char-in-strin
       DADD @PTFCIS,@PTLCIS    by adding length-of-string
       DDEC @PTLCIS            and subtracting 1
* Make a speech list
       CALL SETRW             Set speech read/write addrs
       DST  @PTFCIS,@PTCCIS   Start at beginning of string
       CLR  @TOTTIM           Clear total time delay
       CALL GETTIM            Get first timing mark
       CALL TIMING            Get any subsequent marks
* The total first time delay is in TOTTIM now
GB158  DCH  @PTLCIS,@PTCCIS   While more string
       BS   GB1A7
       CALL PHRASE            Get next phrase
* If spell flag is 0, try to look the phrase up. If it
* can not be found, then set the spell flag, and it will be
* spelled out. If found, save on speak list.
       CZ   @SPLFLG           There is a phrase
       BR   GB173
       CALL LOOKUP            Try to look it up in the PHRO
       DCZ  @DATAAD           If not found then
       BR   GB170
       ST   1,@SPLFLG         Set the spell flag
       BR   GB173
GB170  CALL STDATA            Store data in list
* If spell flag is 1, set time delay to >3C, and take the
* phrase one character at a time (spell it). Look up each
* character: if not found, use 'UHOH' data instead.
* Regardless, store data on speak list.
GB173  CEQ  1,@SPLFLG         Need to spell it out?
       BR   GB1A0
       DST  @PTLCIP,@PTLCIL   Est last char to spell out
       ST   >3C,@TOTTIM       >3C used because sounds good
*                      Take each single character
* Skip over any embedded spaces encountered in a phrase
GB17E  CEQ  SPACE,V*PTFCIP
       BR   GB188
       DINC @PTFCIP
       BR   GB17E
* Set first and last pointers to same one character
GB188  DST  @PTFCIP,@PTLCIP
       CALL LOOKUP            Try to look it up
* If not found, use data to 'UHOH'
       DCZ  @DATAAD
       BR   GB196
       DST  >71F4,@DATAAD     Put addr of 'UHOH' in
GB196  CALL STDATA            Store data on speak list
       DINC @PTFCIP           Go on to next character
       DCH  @PTLCIL,@PTFCIP   Until done all
       BR   GB17E
* At this point, get next timing group. The first timing
* character has already been found, and it's value is still
* in TIMLEN. Therefore, initiatory call to GETTIM not
* needed. Simply clear TOTTIM and call TIMING.
GB1A0  CLR  @TOTTIM
       CALL TIMING
       BR   GB158
* At this point, finished all the phrases in this string.
* TOTTIM should equal >FE, it indicate end of sting If it
* doesn't equal >FE, it indicates that a timing group was
* put on the end of the string. Therefore, save the timing
* group with a null data address to show it is only timing.
GB1A7  CEQ  >FE,@TOTTIM
       BS   NEXT1
       DCLR @DATAAD
       CALL STDATA
* Next item could be direct string.
NEXT1  CEQ  COMMAZ,@CHAT      If direct string present
       BR   SPEAK
       CALL GETPRM            Get the next parameter
       BS   NEXT2             If non-null direct string
       ST   >FF,@TOTTIM       Mark TOTTIM as direct string
       XML  VPUSH             Save direct string on stack
       DST  @VSPTR,@DATAAD    Store stack addr on string
       CALL STDATA            And add to the speak list
* If the next character is a comma, loop thru it again
NEXT2  CEQ  COMMAZ,@CHAT
       BS   DIRSPK
* If end fall into SPEAK
***********************************************************
* SPEAK will actually speak the speech list. It tests the
* timing byte to see if it is an >FF. If it is, then the
* data following it points to a direct speech data string
* in VDP. If it is not, then the data following it points
* to a PHROM speech data list. In the first case, this
* routine will issue a speak external command to the PHROM
* and then feed bytes out to the PHROM as it requests them.
* In the second case, the address will be loaded out to the
* PHROM, and then a speak command will be issued.
***********************************************************
SPEAK  CALL SETRW             Set read/write address
GB1CE  DCHE @PTLBSL,@PTFBSL   More speech list to go
       BS   GB258
       CALL WAIT              Yes, wait until previous
*                              speech is though
       CEQ  >FF,V*PTFBSL      External speech data
       BS   GB1FE
       ST   V*PTFBSL,@TIMER   No, load timer
       NEG  @TIMER             and neg it to correct
       DST  [email protected](@PTFBSL),@PTFBPH   Put addr into PTFBPH
       DADD 3,@PTFBSL               and skip to next node
LOOP1  CGE  0,@TIMER          Wait for time delay
       BR   LOOP1
       CZ   @PTFBPH           If there is data
       BS   GB1FC
       CALL LOADAD            Load the addr to PHROM
       ST   >50,@>8300(@WRITE)  and issue speak command
GB1FC  BR   CONTIN
GB1FE  DINC @PTFBSL           Speak external, skip over >FF
       DST  V*PTFBSL,@PTCBED  Set up pointer to 1st byte
       DST  [email protected](@PTCBED),@PTCBED    in external speech data
       DINCT @PTFBSL          Skip addr bytes
       ST   [email protected](@PTCBED),@LENWST  Get Len of whole string
DIRSPH SUB  3,@LENWST         Minus 3 bytes overhead
* All external speech strings start with a >60
       CEQ  >60,V*PTCBED      Bad speech string
       BR   ERRBV
       CALL WAIT              Wait for go ahead
       DINCT @PTCBED          Skip spk ext & 1st byte len
       ST   V*PTCBED,@LENCST  Get len of current string
       DINC @PTCBED           Skip len byte to 1st real byt
       ST   16,@TEMP2         Do 1st 16 bytes (fill buff)
       ST   >60,@>8300(@WRITE) Start Speak External
LOOPR  ST   V*PTCBED,@>8300(@WRITE) Write byte to PHROM
       DINC @PTCBED           Go to next byte
       DEC  @LENWST           1 less char in whole string
       BS   CONTIN            Finished whole string?
       DEC  @LENCST           1 less char in curr string
       BS   DIRSPH            Finished current string?
       DEC  @TEMP2            1 less char in this loop
       BR   LOOPR             Not finished curr loop yet?
GB241  ST   @>8300(@READ),@SPKSTS   Read status from PHROM
 
* If the next statement is true, it means that speak was
* probably interupted and that it is shot at this point.
* Therefore, we are going to quit now.
       CLOG >80,@SPKSTS
       BS   CONTIN
       CLOG >40,@SPKSTS       Loop till buff below half
       BS   GB241
       ST   8,@TEMP2          Put 8 more bytes to PHROM
       BR   LOOPR              and go do these
CONTIN B    GB1CE             We've said it all!!
* Now pop all entries off stack that we put on!
GB258  XML  VPOP              Free up a temporary string
       DCEQ @FAC2,@VSPTR
       BR   GB258
       BR   GB0F2             And return to the caller
***********************************************************
* SPGET subprogram. Load speech data from external device.
*       Use standard file I/O
***********************************************************
SPGET  CEQ  LPARZ,@CHAT       Must have left parenthesis
       BR   ERRSYN
       CALL SETRW             Set PHROM read/write address
       CALL WAIT              Wait till no one is speaking
NXTPAR CALL GETPRM            Get the next parameter
       DCZ  @FAC6             If non-null ASCII string
       BS   GB318
       DST  @FAC4,@PTFCIS     Pointer to 1st char in string
       DST  @FAC6,@PTLCIS     Pointer to last-char-in-strin
       DADD @PTFCIS,@PTLCIS    by adding length-of-string
       DDEC @PTLCIS             and subtracting 1
       CALL SETRW             Set the speech read/write add
       DST  @PTFCIS,@PTCCIS   Set curr char to first char
       CLR  @TOTTIM           Clear total time delay
       CALL GETTIM            Get first timing mark
       CALL TIMING            Get any subsquent marks
* Get one phrase, and look it up. If the phrase is not foun
* substitute in 'UHOH'.
       DCH  @PTLCIS,@PTCCIS   Possible phrase
       BS   GB318
       CALL PHRASE            Yes, go get it
       CEQ  1,@SPLFLG         Spell flag set then set
       BR   GB29C
       DST  @PTFCIP,@PTLCIP    last ptr to first (1 char)
GB29C  CALL LOOKUP            Look up the phrase
       DCZ  @DATAAD           If not there,
       BR   GB2AA
       DST  >71F4,@DATAAD      use 'UHOH' data addr
       ST   >51,@STRLEN        'UHOH' data length
* Data must be in PHRADD and PHLEN, so move it
GB2AA  DST  @DATAAD,@PHRADD
       ST   @STRLEN,@PHLEN
       ADD  3,@PHLEN          For overhead info
* There must be a variable to put this data in. If not, err
       XML  SPEED
       BYTE SYNCHK
       BYTE COMMAZ
       XML  SYM               Find symbol in table
       XML  SMB               Evaluate andy subscripts
       XML  VPUSH             Save for assignment
       CLR  @BYTES            Two byte value
       ST   @PHLEN,@BYTES+1   Length of string needed
       XML  GETSTR            Get a string for the data
       CALL SETRW             Set up speech read/write addr
       DST  >001C,@FAC        Now build string FAC entry
       DST  >6500,@FAC2       String ID
       DST  @SREF,@FAC4       Pointer to string
       DST  @BYTES,@FAC6      Length of string
       DST  >6000,V*SREF      Mark string as speech data
       ST   @PHLEN,[email protected](@SREF) Put in string length
       DSUB 3,[email protected](@SREF)       minus thei info
* LOADAD expects addr to be in PTFBPH, so move it.
       DST  @PHRADD,@PTFBPH
       CALL LOADAD
* Going to copy string from PHROM to VDP. The actual data
* from PHROM is in bit-reversed order, so must reverse the
* order after reading in the order. Remember that 3 bytes
* PHLEN are our own overhead, so don't copy all
GB2EB  CH   3,@PHLEN
       BR   GB316
       ST   >10,@>8300(@WRITE) Issue read byte command
       ST   @>8300(@READ),@BYTE3 Read the byte
* the following code is somewhat tricky. It will bit
* reverse the contents of BYTE3 into BYTE1 through
* BYTE2 by means of word shifts. Note the definition of
* BYTE1 , BYTE2, and BYTE3 in EQU's. You might try an
* example if it isn't clear what is going on.
       CLR  @BYTE2
       ST   >08,@TEMP1
RNDAG  DSRC 1,@BYTE2
       DSLL 1,@BYTE1
       DEC  @TEMP1
       BR   RNDAG
* Store the bit-corrected byte into the string & inc str pt
       ST   @BYTE1,[email protected](@SREF)
       DINC @SREF
       DEC  @PHLEN            Dec the string length
       BR   GB2EB             Go do next char if there is o
GB316  XML  ASSGNV            Assign the string to variable
GB318  CEQ  COMMAZ,@CHAT      If more go do
       BS   NXTPAR
       BR   GB0F2
***********************************************************
* GETPAM gets the next string paameter passed to the
* routine. If that parameter is non-exist or null, then
* condition bit is set. If the parameter is there then
* condition bit is reset and the FAC entry describes the
* string. In either case, return with condition is done.
***********************************************************
GETPRM XML  PGMCHR            Get next token
       CEQ  COMMAZ,@CHAT      Go set condition no parm
       BS   SETCB
       XML  PARSE
       BYTE RPARZ
       CEQ  >65,@FAC2         If not string, error
       BR   ERRSNM
       DCZ  @FAC6             Set cond if null string
       RTNC                   Else return
SETCB  CEQ  @>8300,@>8300     Set condition bit
       RTNC
***********************************************************
* Get the next phrase out of the current string. The phrase
* may begin with a #, which means it will continue to the
* next #, or it many begin with an ordinary character, in
* which case it will end with the character just before the
* first timing character encountered. In either case, the
* end of the string will indicate a legal end of phrase if
* it occurs before the usual indicator!
***********************************************************
PHRASE CEQ  NUMBER,@CCHAR     Phrase start with #?
       BR   GB370
       DINC @PTCCIS           Yes, inc CC ptr past #
GB33C  CEQ  SPACE,V*PTCCIS    Skip spaces
       BR   GB346
       DINC @PTCCIS
       BR   GB33C
GB346  CEQ  NUMBER,V*PTCCIS   All spaces?
       BR   GB34F
       DINC @PTCCIS           Yes, skip this # too
       RTN                    And ignore this phrase
GB34F  DST  @PTCCIS,@PTFCIP   Save 1st char in phrase
GB352  DINC @PTCCIS           Go on to next char
* Got to watch for end of string. If encountered before a
* #, act like char after string is #. Then last char will
* be char before, or the last char in the string!!
       DCH  @PTLCIS,@PTCCIS
       BS   FNDNUM
       ST   V*PTCCIS,@CCHAR   No, get char in CCHAR
       CEQ  NUMBER,@CCHAR     If not # continue looking
       BR   GB352
FNDNUM DST  @PTCCIS,@PTLCIP   Last char in phrase is one
       DDEC @PTLCIP            before the #
       DINC @PTCCIS           Point to char after #
       CALL GETTIM            Get 1st timing char after phr
       CLR  @SPLFLG           Indicate don't spell
       BR   GB38B             No # as 1st char in phrase
GB370  DST  @PTCCIS,@PTFCIP   Curr char is 1st char phrase
       CLR  @SPLFLG           Assume don't spell
       CHE  >41,@CCHAR        If not alphabetic   (>41="A")
       BS   GB37C
       INC  @SPLFLG            set spell flag
* Need to find end of phrase, which is char before next
* timing char we find. Therefore, look for a timing char!
GB37C  DINC @PTCCIS
       CALL GETTIM
       CEQ  >FF,@TIMLEN       If not timing, loop
       BS   GB37C
       DST  @PTCCIS,@PTLCIP   Char before curr char is
       DDEC @PTLCIP            the last char in phrase
GB38B  RTN
***********************************************************
* TIMING will loop through chars in string until it finds
* non-timing char. Non-timing chars have TIMLEN values of
* >FE or >FF. GETTIM must be called before this routine to
* establish a correct value of TIMLEN. Also, most likely
* TOTTIM should have been cleared.
***********************************************************
TIMING CHE  >FE,@TIMLEN
       BS   GB39B
       DADD @TIMLEN,@TOTTIM
       DINC @PTCCIS
       CALL GETTIM
       BR   TIMING
GB39B  RTN
***********************************************************
* GETTIM will examine the current char in the string and
* set TIMLEN to the appropriate time delay value. TIMLEN
* can take on the following values:
*           >00 if char is timing '+'
*           >06 if char is timing ' '
*           >0C if char is timing '-'
*           >12 if char is timing ','
*           >1E if char is timing ';'
*           >30 if char is timing ':'
*           >3C if char is timing '.'
*           >FE if char is out of stirng bounds
*           >FF if char is not timing
* Note that to test timing, some manipulation of PTCCIS
* would be neccesary, so it is stored and used in TEMP1
***********************************************************
GETTIM ST   V*PTCCIS,@CCHAR   Get the char
       DST  @PTCCIS,@TEMP1     store curr ptr in TEMP1
       DCH  @PTLCIS,@TEMP1     out of string bounds?
       BR   GB3AC
       ST   >FE,@TIMLEN       Yes, load value and return
       RTN
GB3AC  CH   SEMICO,@CCHAR     Can not be timing
       BS   NOTIME
       CEQ  SPACE,@CCHAR
       BR   GB3C5
       ST   6,@TIMLEN
GB3B9  CEQ  SPACE,[email protected](@PTCCIS) While spaces
       BR   GB3C4
       DINC @PTCCIS           Skip them
       BR   GB3B9
GB3C4  RTN
GB3C5  CEQ  PLUS,@CCHAR
       BR   GB3D4
       DINC @TEMP1            Need to test the next char
       CALL NUMERC            Is it numeric
       BS   NOTIME            Was numeric => not timing cha
       CLR  @TIMLEN           Not numeric => set as no timi
       RTN
GB3D4  CEQ  COMMAT,@CCHAR
       BR   GB3DD
       ST   >12,@TIMLEN
       RTN
GB3DD  CEQ  PERIOD,@CCHAR
       BR   GB3F4
       DDEC @TEMP1            Go back to preceding char
       CALL NUMERC            Is it numeric?
       BR   PTIME             No, so it is timing
       DINCT @TEMP1           Yes, on to following char
       CALL NUMERC            Is it numeric too?
       BS   NOTIME            Yes, both numeric => not timi
PTIME  ST   >3C,@TIMLEN       Both not numeric  => timing
       RTN
GB3F4  CEQ  HYPEN,@CCHAR
       BR   GB404
       DINC @TEMP1            Check next char
       CALL NUMERC            Is it numeric?
       BS   NOTIME            Was numeric => not a timing c
       ST   >0C,@TIMLEN       Was not numeric => set as tim
       RTN
GB404  CEQ  COLON,@CCHAR
       BR   GB40D
       ST   >30,@TIMLEN
       RTN
GB40D  CEQ  SEMICO,@CCHAR
       BR   NOTIME
       ST   >1E,@TIMLEN
       RTN
NOTIME ST   >FF,@TIMLEN       Set as no timing char present
       RTN
***********************************************************
* NUMERC tests the char pointed to by PTCCIS and verifies
* the following:
*  1 - it is within the current string boundaries
*  2 - it is numeric (i.e. between '0' and '9')
* If both of the above conditions are true, COND is set
* upon return, otherwise COND is reset
***********************************************************
NUMERC DCH  @PTLCIS,@TEMP1
       BS   GB430
       DCH  @TEMP1,@PTFCIS
       BS   GB430
       CHE  >30,V*TEMP1
       BR   GB430
       CH   >39,V*TEMP1
       BR   SETCB
GB430  RTNC
***********************************************************
* LOOKUP is a prolong routine to SEARCH. In each PHROM,
* there may be 2 trees, one starting at >0000 and the other
* at >8000. Either may or may not be present. Presences is
* determined if a >AA byte is at the starting location.
* LOOKUP determines if the tree at >0000 is in, and if so,
* calls SEARCH with that addr. If that tree is not present
* or the phrase couldn't be found in it, LOOKUP then checks
* if the tree at >8000 is present, and again, if so, calls
* SEARCH with that tree address. If the word was found in
* the first tree, or after searching the second tree, the
* routine will return.
***********************************************************
LOOKUP DCLR @BYTE1            BYTE1 contains addr of curr t
TRYAGN DST  @BYTE1,@PTFBPH    Look for >AA tree header
       CALL LOADAD            LOADAD expects addr in PTFBPH
       ST   >10,@>8300(@WRITE) Put out read byte command
       CEQ  >AA,@>8300(@READ)  Tree out there?
       BR   GB44E
       DINC @PTFBPH           Skip the tree header
       CALL SEARCH            Go search this PHROM tree
       DCZ  @DATAAD           Phrase found => exit
       BR   FOUND
GB44E  DADD >8000,@BYTE1      Go to start of next PHROM tre
* Note >8000 + >8000 = >0000 => tried both trees
       DCZ  @BYTE1
       BR   TRYAGN
       DCLR @DATAAD           Didnt find phrase in either t
FOUND  RTN
***********************************************************
* SEARCH actually searches the PHROM tree for the phrase.
* The PHROM tree organization is as follows:
*        (i.e. this is one phrase node)
*              phrase ASCII length      1 byte
*              actual ASCII characters  n bytes
*              less then pointer        2 bytes
*              greater then pointer     2 bytes
*              speech data pointer      3 bytes
*              speech data length       1 byte
* The comparison of two words proceeds on a char by char
* basis, where length is secondary to char values, i.e.
* move > answer; number < we; eight < eighty; etc...
***********************************************************
SEARCH CALL LOADAD            Set PHROM to start phrase nod
       ST   >10,@>8300(@WRITE) Issue read byte command
       CLR  @PTLCPH           Length of phrase => PTLCPH
       ST   @>8300(@READ),@PTLCPH+1 (stored as 2 byte value
       DADD @PTFBPH,@PTLCPH   Add front ptr giving end ptr
       DST  @PTFBPH,@PTCCPH   Set up curr char as 1 beyond
       DINC @PTCCPH            length byte
       DST  @PTFCIP,@PTCCIP   Reset current ptr into phrase
* Compare two characters
NEXT   ST   >10,@>8300(@WRITE) Issue read byte command
       ST   @>8300(@READ),@PHDATA Get char in from PHROM
       CEQ  V*PTCCIP,@PHDATA  Compare the char
       BR   GB4D1
       DINC @PTCCPH           Equal, advance both pointers
       DINC @PTCCIP
       CEQ  SPACE,V*PTCCIP    Skip extra spaces
       BR   GB4A1
GB48D  CEQ  SPACE,[email protected](@PTCCIP) While spaces
       BR   GB498
       DINC @PTCCIP           Skip them
       BR   GB48D
* By skipping extra spaces, might have reached end of phras
* If this is true, next char in phrase = #. If so, advance
* the pointer to be beyond end of phrase.
GB498  CEQ  NUMBER,[email protected](@PTCCIP)
       BR   GB4A1
       DINC @PTCCIP
GB4A1  DCH  @PTLCPH,@PTCCPH   End of PHROM word?
       BR   GB4C6
       DCH  @PTLCIP,@PTCCIP   Yes, end of phrase
       BR   GB4C0
       DST  @PTLCPH,@PTFBPH   Yes, word found
* Skip 5 bytes down from last char to data pointer
       DADD 6,@PTFBPH
       CALL READAD            Set data addr => DATAAD
       ST   >10,@>8300(@WRITE) Issue read byte command
       ST   @>8300(@READ),@STRLEN Get length of speech data
       RTN
GB4C0  DST  3,@PTFBPH         Move 3 bytes past PTLCPH
       BR   NXTPHR
GB4C6  DCH  @PTLCIP,@PTCCIP   2 characters
       BR   NEXT
       DST  1,@PTFBPH         Phrase linger: use LT ptr
       BR   NXTPHR
* Two characters compared were not equal
GB4D1  DST  3,@PTFBPH         3 bytes past last to GT
       CH   V*PTCCIP,@PHDATA  After phrase
       BR   NXTPHR
       DDECT @PTFBPH          Back up 2 bytes to LT link
* Go get next phrase out of the PHROM to compare
NXTPHR DADD @PTLCPH,@PTFBPH   Add displacement to last char
       CALL READAD             and get the new address
       DCZ  @DATAAD           More leaves on this tree
       BR   GB4E8
       RTN                    No, return empty handed
GB4E8  DST  @DATAAD,@PTFBPH   Store new addr in PTFBPH
       BR   SEARCH            Go compare this new word!
* The program should never reach this point!! It should
* return somewhere up above.
***********************************************************
* LOADAD will set the addr out in the PHROM to the addr
* found in PTFBPH. Note that the PHROM is expecting five
* nybbles to be written out as the address.
***********************************************************
LOADAD DST  @PTFBPH,@TEMP1    This is destructive, so copy
       DST  @PTFBPH,@TEMP2     address into temporary areas
       SRL  4,@TEMP1          Isolate the MSN of the MSB
       SRL  4,@TEMP1+1        Isolate the MSN of the LSB
       DAND >0F0F,@TEMP2      Isolate the LSN of the MSB, L
       DOR  >4040,@TEMP1      Include a 4 as MSN of all 4 n
       DOR  >4040,@TEMP2       to indicate a Load Address C
       ST   @TEMP2+1,@>8300(@WRITE) Write out the LSN of th
       ST   @TEMP1+1,@>8300(@WRITE) Write out the LSN of th
       ST   @TEMP2,@>8300(@WRITE)   Write out the MSN of th
       ST   @TEMP1,@>8300(@WRITE)   Write out the MSN of th
       ST   >40,@>8300(@WRITE)      Write out 0 as fifth ny
       RTN
***********************************************************
* READAD will read an address from the PHROM and store it
* in DATAAD. Note that PTFBPH should contain the addr of
* the PHROM location to be read so LOADAD will work.
***********************************************************
READAD CALL LOADAD            Set the addr of the PHROM
       ST   >10,@>8300(@WRITE) Get high byte of addr
       ST   @>8300(@READ),@DATAAD Stroe it in DATAAD
       ST   >10,@>8300(@WRITE) Get low byte of addr
       ST   @>8300(@READ),@DATAAD+1 Store it in DATAAD+1
       RTN
***********************************************************
* STDATA will store the data in DATAAD and TOTTIM onto the
* speech list. It will also check that there is room on the
* speech list for this entry, and abort with error if not.
***********************************************************
STDATA DCEQ @PTEBSL,@PTLBSL   Is there room?
       BS   ERRSSL
       MOVE 3,@TOTTIM,V*PTLBSL   Put data in list
       DADD 3,@PTLBSL              and inc top of list
       RTN
***********************************************************
* WAIT loops until the speech peripheral goes idle.
***********************************************************
*    ( Loop until nobody is talking)
WAIT   ST   @>8300(@READ),@SPKSTS  Read status from PHROM
       CLOG >80,@SPKSTS
       BR   WAIT
       RTN
***********************************************************
* SETRW moves addrs of speech read/write from GROM to VDP
***********************************************************
SETRW  MOVE 4,[email protected]>0046,@READ
       RTN
***********************************************************
*                    ERROR MESSAGES
***********************************************************
*      The following calls are in EXECS file.
* ERRSYN CALL ERRZZ           * SYNTAX ERROR
*        BYTE 3
* ERRSNM CALL ERRZZ           * STRING-NUMBER MISMATCH
*        BYTE 7
* ERRBV  CALL ERRZZ           * BAD VALUE
*        BYTE 30
* ERRIAL CALL ERRZZ           * INCORRECT ARGUMENT LIST
*        BYTE 31
***********************************************************
ERRSSL CALL ERRZZ             * SPEECH STRING TOO LONG
       BYTE 21
***********************************************************
* RXB
* GCHAR PATCH FOR COMMA
GCHARA CEQ  COMMAZ,@CHAT      ,?
       BS   GCHAR
       BR   XPTRTN
 
* MOTION PATCH for GO and STOP
SPGS   XML  PGMCHR            ( or ,
       CEQ  ALLZ,@CHAT        ALL?
       BR   SPGS1             No.
       XML  PGMCHR            Skip ALL
       XML  PGMCHR            Skip ,
       DST  1,@FAC            First sprite
       CALL SPNUM5            Get sprite table
       CALL SPMOVE            Store velocity
       ST   28,@FAC           Last sprite
       DCLR @VAR0             Index
SPGSA  MOVE 2,[email protected]>0780,[email protected]>0780(@VAR0)
       DADD 4,@VAR0           Index +4
       DEC  @FAC              Sprite -1
       BR   SPGSA             Done?
       B    SPRMV4            No.
SPGS1  CEQ  NUMBEZ,@CHAT      #?
       BR   SPGS2             No.
       CALL SPNUM6            Standard routine.
       B    SPRMV3
SPGS2  CEQ  GOZ,@CHAT         GO?
       BR   SPGS3             No.
       AND  >BF,@>83C2        GO!!!
       B    SPGS4             Done.
SPGS3  CEQ  STOPZ,@CHAT       STOP?
       BR   ERRSYN            No
       OR   >40,@>83C2        STOP!!!
SPGS4  XML  PGMCHR            Skip GO or STOP
       B    SPRMV4
***********************************************************
* RXB
**************************
SUBRTN RTN
**************************
STRFCH XML  PGMCHR
       XML  PARSE
       BYTE >B6
       RTN
STRGET CALL STRFCH
       CEQ  >65,@FAC2
       BR   ERRSNM      * STRING NUM MISMATCH
       RTN
NUMFCH CALL STRFCH
       CEQ  >65,@FAC2
       BS   ERRSNM      * STRING NUM MISMATCH
       RTN
CFIFCH XML  CFI
       CEQ  >03,@FAC+10
       BS   ERRBV       * NUMERIC OVERFLOW
       RTN
GETNUM CALL SUBLP3
       CEQ  >B3,@CHAT
       BR   ERRSYN
       RTN
ROWCOL CALL GETNUM
       DCGT 24,@FAC
       BS   ERRBV
       DDEC @FAC
       ST   @XPT,@MNUM
       ST   @FAC1,@YPT
       CALL GETNUM
       DCGT 32,@FAC
       BS   ERRBV
       DDEC @FAC
       ST   @FAC1,@XPT
       RTN
NGOOD  XML  PGMCHR
NGOOD1 CHE  >80,@CHAT
       BS   ERRSYN         * ?
       CALL SNDER
       CEQ  >65,@FAC2
       BR   ERRSNM         * STRING NUMBER MISMATCH
       DST  >001C,@FAC
       DST  @SREF,@FAC4
       DST  @BYTES,@FAC6
       BR   SNDASS
SNDER  XML  SYM
       XML  SMB
       XML  VPUSH
       RTN
CIFSND XML  CIF
SNDASS XML  ASSGNV
       RTN
GETLP  ST   @CB,@VAR0
       ST   @CB,@VARV
       SUB  OFFSET,@VARV
       ST   @VARV,[email protected](@STRPTR)
       DINC @STRPTR
       RTN
PUTLP  ST   [email protected](@FAC4),@VAR0
       ADD  OFFSET,@VAR0
       DINC @FAC4
       RTN
HFMT   FMT
       DATA >E000
       FEND
       RTN
VFMT   FMT
       DATA >E000
       BYTE >9E
       FEND
       RTN
SUBLP3 CALL NUMFCH
       CALL CFIFCH
       RTN
CLRFAC CLR  @FAC
       MOVE 7,@FAC,@FAC1
       RTN
**************************
ERRFE  CALL ERRZZ        *
       BYTE 34           *
DSKDSR DCHE 256,@VAR0    *
       BR   DSRDSS       *
       ADD  >10,@>03C1   *
DSRDSS DST  >03C0,@FAC12 *
       CALL LINK         *
       BYTE >0A          *
       ST   @>837C,@VAR2 *
       SRL  4,@FAC6      *
       CZ   @FAC6        *
       BR   ERRFE        *
       CEQ  >20,@VAR2    *
       BS   ERRFE        *
       RTN               *
***********************************************************
* RXB
***********************************************************
ZKEY   CALL KEY          *    KEY
KEYAGN CEQ  COMMAZ,@CHAT *
       BS   ZKEY         *
       BR   LNKRTN       *
**************************
ZJOYST CALL JOYST        *    JOYST
JOYAGN CEQ  COMMAZ,@CHAT *
       BR   LNKRTN       *
       CALL CPAR2        *
       CALL GAC16        *
       BR   JOYAGN       *
*****************************
SPAR   CEQ  LPARZ,@CHAT       (?
       BS   SPAR1             Yes.
       CEQ  COMMAZ,@CHAT      ,?
       BR   ERRSYN            No.
SPAR1  XML  PGMCHR            Skip ( or ,
       XML  PARSE             Get string or value.
       BYTE RPARZ
       CEQ  >65,@FAC2         String?
       BR   SPAR2             No.
       DST  @FAC4,@>8304      Save address.
       DST  @FAC6,@>8306      Save length.
       DST  >994A,@>8310      Set flag.
       CALL LPAR
       RTN
SPAR2  XML  SPEED
       BYTE SYNCHK
       BYTE COMMAZ
       RTN
*****************************
KEYSTR DCEQ >994A,@>8310      Flag set?
       BR   RSCAN3            No.
RSCAN  SCAN                   Any key?
       BR   RSCAN             No.
       DCZ  @>8306            Length 0?
       BS   RSCAN4            Yes.
       DST  @>8304,@>8308     String address.
       DST  @>8306,@>8302     Copy length.
RSCAN2 CEQ  V*>8308,@RKEY     Same?
       BS   RSCAN5            Yes.
       DINC @>8308            Address +1
       DDEC @>8302            Length -1
       BR   RSCAN2            No matcth.
       B    RSCAN             Restart.
RSCAN3 SCAN                   Normal key scan.
RSCAN4 CLR  @KEYBD
       DCLR @>8310            Clear flag.
       RTNC
RSCAN5 CALL RSCAN4
       CEQ  @0,@0             Force condition bit on.
       RTNC
*****************************
CPAR2  XML  SPEED           * Similar to LPAR
       DATA COMMAZ          * Syntax check ,
       BR   GAC35           * Parse value
*****************************
ZSCOI  CALL SPRCOI       *    COINC
COINLP CEQ  >B3,@CHAT    *
       BR   LNKRTN       *
       XML  PGMCHR       *
       CALL GAF56        *
       BR   COINLP       *
**************************
NR     CALL PREPN        *
AR     XML  ASSGNV       *
       RTN               *
**************************
ZSDIST CALL DIST         *    DISTANCE
DISLP  CEQ  >B3,@CHAT    *
       BR   LNKRTN       *
       CALL GAFC4        *
       BR   DISLP        *
***********************************************************
LINKSD DATA LINKSE
       STRI 'GMOTION'
       DATA $+2
       CALL SPNUM1            GMOTOIN
GMAGN  CALL SPNUM2
       ST   >02,@TEMP1
       DST  [email protected]>0480(@SPSAL),@TEMP2
GMO1   CALL PREPN
       ST   @TEMP2,@FAC+1
       CH   >7F,@FAC+1
       BR   GMO2
       NEG  @FAC+1
       DNEG @FAC
GMO2   CALL CIFSND
       CEQ  >01,@TEMP1
       BS   GMO3
       XML  SPEED
       DATA >00B3
GMO3   EX   @TEMP2,@TEMP2+1
       DEC  @TEMP1
       BR   GMO1
       CEQ  >B3,@CHAT
       BS   GMAGN
       BR   LNKRTN
**************************
LINKSE DATA LINKSF
       STRI 'RMOTION'
       DATA $+2
       CALL SPNUM1       *    RMOTION
RMAGN  XML  PGMCHR
       CEQ  >EC,@CHAT
       BR   NOALL
       XML  SPEED
       DATA >00EC
       DST  >001C,@VAR0
NXALL  DST  @VAR0,@FAC
       CALL SPNUM5
       BR   RMALL
NOALL  DST  >0001,@VAR0
       CEQ  >FD,@CHAT
       BR   ERRSYN
       CALL NUMFCH
       CALL SPNUM4
RMALL  DST  [email protected]>0480(@SPSAL),@TEMP1
       ST   >02,@TEMP2
RMOTLP CZ   @TEMP1
       BS   J2
       CEQ  >80,@TEMP1
       BS   J3
       CH   >7F,@TEMP1
       BS   J1
       NEG  @TEMP1
       BR   J2
J1     ABS  @TEMP1
J2     EX   @TEMP1,@TEMP1+1
       DEC  @TEMP2
       BR   RMOTLP
       DST  @TEMP1,[email protected]>0480(@SPSAL)
J3     DDEC @VAR0
       BR   NXALL
       CEQ  >B3,@CHAT
       BS   RMAGN
       BR   LNKRTN
*****************************************
S1ET9F XML  SPEED  * CHECK FROM
       DATA >021E  * 30 TO 159
       DATA >009F  *
       RTN         *
*****************************************
LINKSF DATA LINK10
       STRI 'INVERSE'
       DATA $+2
       CALL SPNUM1            INVERSE(CHAR#)
INVAGN XML  PGMCHR
       CEQ  >EC,@CHAT
       BR   INOALL
       XML  SPEED
       DATA >00EC
       DST  >001E,@FAC
       DSLL 3,@FAC
       DST  >01C8,@TEMP1
       BR   INVLP
INOALL XML  PARSE
       BYTE >B6
       CALL S1ET9F
       DSLL 3,@FAC
       DST  >0004,@TEMP1
INVLP  DINV [email protected]>0300(@FAC)
       DADD >0002,@FAC
       DDEC @TEMP1
       BR   INVLP
INVNOK CEQ  >B3,@CHAT
       BS   INVAGN
       BR   LNKRTN
*****************************************
SSDSLL CALL STRFCH
       CALL S1ET9F
       DSLL 3,@FAC
       RTN
*****************************************
LINK10 DATA LINK11
       STRI 'SWAPCHAR'
       DATA $+2
       CALL SPNUM1            SWAPCHAR(CHAR#,CHAR#)
SWCHAG CALL SSDSLL
       DST  @FAC,@VAR4
       CEQ  >B3,@CHAT
       BR   ERRSYN
       CALL SSDSLL
       DST  @FAC,@VAR5
       MOVE 8,[email protected]>0300(@VAR4),@FAC
       MOVE 8,[email protected]>0300(@VAR5),[email protected]>0300(@VAR4)
       MOVE 8,@FAC,[email protected]>0300(@VAR5)
       CEQ  >B3,@CHAT
       BS   SWCHAG
       BR   LNKRTN
******************************************
LINK11 DATA LINK12
       STRI 'DUPCHAR'
       DATA $+2
       CALL SPNUM1            DUPCHAR(CHAR#,CHAR#)
DCHAGN CALL SSDSLL
       DST  @FAC,@VAR4
       CEQ  >B3,@CHAT
       BR   ERRSYN
       CALL SSDSLL
       MOVE 8,[email protected]>0300(@VAR4),[email protected]>0300(@FAC)
       CEQ  >B3,@CHAT
       BS   DCHAGN
       BR   LNKRTN
******************************************
S00T10 XML  SPEED  * CHECK FROM
       DATA >0200  * 0 TO 16
       DATA >0010  *
       RTN         *
******************************************
LINK12 DATA LINK13
       STRI 'SWAPCOLOR'
       DATA $+2
       XML  SPEED             SWAPCOLOR(SET#,SET#)
       DATA >00B7
SCOL10 CEQ  >FD,@CHAT
       BR   SCOL20
       CALL SPNUM3
       ST   [email protected]>0003(@FAC),@VAR4
       DST  @FAC,@VAR5
       CEQ  >FD,@CHAT
       BR   ERRSYN
       CALL STRFCH
       CALL SPNUM4
       ST   [email protected]>0003(@FAC),[email protected]>0003(@VAR5)
       ST   @VAR4,[email protected]>0003(@FAC)
       CEQ  >B3,@CHAT
       BR   LNKRTN
       XML  PGMCHR
       BR   SCOL10
SCOL20 XML  SPEED
       BYTE >01
       CALL S00T10
       DADD >080F,@FAC
       DST  @FAC,@VAR4
       XML  PARSE
       BYTE >B6
       CALL S00T10
       DADD >080F,@FAC
       ST   V*FAC,@VAR0
       ST   V*VAR4,V*FAC
       ST   @VAR0,V*VAR4
       CEQ  >B3,@CHAT
       BR   LNKRTN
       XML  PGMCHR
       BR   SCOL20
******************************************
LINK13 DATA LINK14
       STRI 'DUPCOLOR'
       DATA $+2
       XML  SPEED             DUPCOLOR(SET#,SET#)
       DATA >00B7
DCOL10 CEQ  >FD,@CHAT
       BR   DCOL20
       CALL SPNUM3
       ST   [email protected]>0003(@FAC),@VAR4
       CEQ  >FD,@CHAT
       BR   ERRSYN
       CALL STRFCH
       CALL SPNUM4
       ST   @VAR4,[email protected]>0003(@FAC)
       CEQ  >B3,@CHAT
       BR   LNKRTN
       XML  PGMCHR
       BR   DCOL10
DCOL20 XML  SPEED
       BYTE >01
       CALL S00T10
       DADD >080F,@FAC
       ST   V*FAC,@VAR0
       XML  PARSE
       BYTE >B6
       CALL S00T10
       DADD >080F,@FAC
       ST   @VAR0,V*FAC
       CEQ  >B3,@CHAT
       BR   LNKRTN
       XML  PGMCHR
       BR   DCOL20
******************************************
LINK14 DATA LINK15
       STRI 'LDIAG'
       DATA $+2
LDIAG  CALL HVCHR             LDIAG(R,C,CHAR#,REP)
       DCZ  @FAC
       BS   XPTRTN
LLPD   CALL VFMT
       DEC  @XPT
       DDEC @FAC
       BS   LCOMMA
       CZ   @YPT
       BR   LLPD
       DEC  @XPT
       BR   LLPD
LCOMMA CEQ  COMMAZ,@CHAT
       BS   LDIAG
       BR   XPTRTN
******************************************
LINK15 DATA LINK16
       STRI 'RDIAG'
       DATA $+2
RDIAG  CALL HVCHR             RDIAG(R,C,CHAR#,REP)
       DCZ  @FAC
       BS   RCOMMA
RLPD   CALL VFMT
       INC  @XPT
       DDEC @FAC
       BS   RCOMMA
       CZ   @YPT
       BR   RLPD
       INC  @XPT
       BR   RLPD
RCOMMA CEQ  COMMAZ,@CHAT
       BS   RDIAG
       BR   XPTRTN
******************************************
LINK16 DATA LINK17
       STRI 'MOVES'
       DATA $+2
       CALL SPNUM1            MOVES(TYPE$,BYTES,$,TO)
*                          or MOVES(TYPE$,BYTES,FROM,$)
MOVESA CALL STRGET          * ( or ,
       DST  V*FAC4,@VAR5    * TYPE "VRG"
       CALL GETNUM          * ,BYTES
       DCZ  @FAC
       BS   ERRBV
       DST  @FAC,@BYTES
       CALL STRFCH          * ,FROM
       CEQ  36,@VAR5
       BR   MOVESX
       CHE  @FAC6,@BYTES+1
       BS   MOVESB
       CLR  @BYTES
       ST   @FAC6,@BYTES+1
       BR   MOVESB
MOVESX CALL CFIFCH
       DST  @FAC,@FAC4
MOVESB DST  @FAC4,@VARY
       CEQ  36,@VAR6
       BR   MOVESN
       DCHE 256,@BYTES
       BS   ERRBV
       XML  GETSTR
       CALL NGOOD
       DST  @SREF,@FAC
       BR   MOVESC
MOVESN CALL SUBLP3          * ,TO
MOVESC DST  @FAC,@VARY2
       CEQ  36,@VAR5        * VDP FROM
       BR   MTYPES
       ST   86,@VAR5
MTYPES CEQ  36,@VAR6
       BR   MTYPE
       ST   86,@VAR6
MTYPE  CEQ  86,@VAR5        * VDP FROM
       BR   MTYPE3
       CEQ  86,@VAR6        * VDP TO
       BR   MTYPE1
MTYPE0 MOVE @BYTES,[email protected](@VARY),[email protected](@VARY2)
MTYPE1 CEQ  82,@VAR6        * RAM TO
       BR   MTYPE2
       MOVE @BYTES,[email protected](@VARY),@0(@VARY2)
MTYPE2 CEQ  71,@VAR6        * GRAM TO
       BR   MTYPE3
       MOVE @BYTES,[email protected](@VARY),[email protected](@VARY2)
MTYPE3 CEQ  82,@VAR5        * RAM FROM
       BR   MTYPE7
       CEQ  86,@VAR6        * VDP TO
       BR   MTYPE5
MTYPE4 MOVE @BYTES,@0(@VARY),[email protected](@VARY2)
MTYPE5 CEQ  82,@VAR6        * RAM TO
       BR   MTYPE6
       MOVE @BYTES,@0(@VARY),@0(@VARY2)
MTYPE6 CEQ  71,@VAR6        * GRAM TO
       BR   MTYPE7
       MOVE @BYTES,@0(@VARY),[email protected](@VARY2)
MTYPE7 CEQ  71,@VAR5        * GRAM FROM
       BR   MOVESD
       CEQ  86,@VAR6        * VDP TO
       BR   MTYPE9
MTYPE8 MOVE @BYTES,[email protected](@VARY),[email protected](@VARY2)
MTYPE9 CEQ  82,@VAR6        * RAM TO
       BR   MTYPEA
       MOVE @BYTES,[email protected](@VARY),@0(@VARY2)
MTYPEA CEQ  71,@VAR6        * GRAM TO
       BR   MOVESD
       MOVE @BYTES,[email protected](@VARY),[email protected](@VARY2)
MOVESD CEQ  >B3,@CHAT
       BS   MOVESA
       BR   LNKRTN
*******************************
LINK17 DATA LINK18
       STRI 'HEX'             HEX
       DATA $+2
       CALL SPNUM1
HEXAGN CALL STRFCH            Get STRING or NUMBER
       CEQ  >65,@FAC2         STRING?
       BS   HEXSTR            Yes
       CALL CFIFCH            No
       DST  @FAC,@TEMP2
       DST  >0004,@BYTES
       XML  GETSTR
       DST  @SREF,@STRPTR
       ST   @TEMP2,@VAR0
       SRL  4,@VAR0
       CALL HEXNS
       ST   @TEMP2,@VAR0
       SLL  4,@VAR0
       SRL  4,@VAR0
       CALL HEXNS
       ST   @TEMP2+1,@VAR0
       SRL  4,@VAR0
       CALL HEXNS
       ST   @TEMP2+1,@VAR0
       SLL  4,@VAR0
       SRL  4,@VAR0
       CALL HEXNS
       CEQ  COMMAZ,@CHAT
       BR   ERRSYN
       CALL NGOOD
       BR   HEXDON
HEXNS  CHE  >0A,@VAR0
       BR   HEXNS2
       ADD  >07,@VAR0
HEXNS2 ADD  >30,@VAR0
       ST   @VAR0,V*STRPTR
       DINC @STRPTR
       RTN
HEXSTR DCLR @TEMP2
       DST  @FAC4,@STRPTR
       DCHE 5,@FAC6
       BS   HEXS4
       CASE @FAC7
       BR   HEXS0
       BR   HEXS1
       BR   HEXS2
       BR   HEXS3
       BR   HEXS4
HEXS4  CALL HEXSN
       SLL  4,@VAR0
       ADD  @VAR0,@TEMP2
HEXS3  CALL HEXSN
       ADD  @VAR0,@TEMP2
HEXS2  CALL HEXSN
       SLL  4,@VAR0
       ADD  @VAR0,@TEMP2+1
HEXS1  CALL HEXSN
       ADD  @VAR0,@TEMP2+1
HEXS0  XML  PGMCHR
       CALL SNDER
       CALL CLRFAC
       DST  @TEMP2,@FAC
       CALL CIFSND
HEXDON CEQ  COMMAZ,@CHAT
       BS   HEXAGN
       BR   LNKRTN
HEXSN  ST   V*STRPTR,@VAR0
       CHE  103,@VAR0         * g ?
       BS   ERRBA
       CHE  97,@VAR0          * a ?
       BR   HEXSN2
       SUB  32,@VAR0          * -32
HEXSN2 CHE  71,@VAR0          * G ?
       BS   ERRBA
       CHE  65,@VAR0          * A ?
       BR   HEXSN3
       SUB  55,@VAR0          * -55
       BR   HEXSN4
HEXSN3 CHE  58,@VAR0          * : ?
       BS   ERRBA
       CHE  48,@VAR0          * 0 ?
       BR   ERRBA
       SUB  48,@VAR0          * -48
HEXSN4 DINC @STRPTR
       RTN
**************************
LINK18 DATA LINK19
       STRI 'IO'              IO
       DATA $+2
       CALL SPNUM1
IOAGN  CALL GETNUM       * TYPE 0-6
       CHE  >07,@FAC1
       BS   ERRBV
       ST   @FAC1,@VARY
       CALL SUBLP3       * ADDRESS/
       CASE @VARY        * BITS/BYTES
       BR   SOG
       BR   SOV
       BR   CRUI
       BR   CRUO
       BR   CSW
       BR   CSR
       BR   CSV
SOG    I/O  0,@FAC
       BR   IODONE
SOV    I/O  1,@FAC
       BR   IODONE
CRUI   CALL CRUSET
       I/O  2,@VAR4
       XML  PGMCHR
       CALL SNDER
       CALL CLRFAC
       ST   @VAR0,@FAC1
       CALL CIFSND       * VARIABLE1
       CHE  >09,@VARY
       BS   CRUI16
       BR   IODONE
CRUI16 XML  PGMCHR
       CALL SNDER
       CALL CLRFAC
       ST   @VARV,@FAC1
       CALL CIFSND       * VARIABLE2
       BR   IODONE
CRUO   CALL CRUSET
       CALL SUBLP3       * VARIABLE1
       DCHE >0100,@FAC
       BS   ERRBV
       CHE  >09,@VARY
       BS   CRUO16
       ST   @FAC1,@VAR0
       BR   CRUO8
CRUO16 DST  @FAC,@VAR0
       CALL SUBLP3       * VARIABLE2
       DCHE >0100,@FAC
       BS   ERRBV
       ST   @FAC1,@VARV
CRUO8  I/O  3,@VAR4
       BR   IODONE
CSW    CALL CSLOAD
       I/O  4,@VAR4
       BR   IODONE
CSR    CALL CSLOAD
       I/O  5,@VAR4
       BR   IODONE
CSV    CALL CSLOAD
       I/O  6,@VAR4
IODONE CEQ  >B3,@CHAT
       BS   IOAGN
       BR   LNKRTN
CRUTMP DST  @FAC,@VAR4
       DCLR @VAR5
       DCLR @VAR0
       RTN
CRUSET CZ   @FAC1
       BS   ERRBV
       CHE  >11,@FAC
       BS   ERRBV
       ST   @FAC1,@VARY
       CALL SUBLP3       * CRU-ADDRESS
       CALL CRUTMP
       ST   @VARY,@VAR5
       RTN
CSLOAD CALL CRUTMP
       CALL SUBLP3       * ADDRESS
       DST  @FAC,@VAR5
       RTN
*******************************
HVPNUM CLR  @FAC11            Select XB FLP
       XML  CNS
       CEQ  SPACE,*FAC11      Leading space?
       BR   HVPUTN
       INC  @FAC11            Supress space out
       DEC  @FAC12            Shorten length
HVPUTN CLR  @BYTES
       ST   @FAC12,@BYTES+1        Length
       XML  GETSTR
       MOVE @BYTES,*FAC11,V*SREF   Store in VDP rollout
       DST  @SREF,@FAC4            VDP rollout address
       DST  @BYTES,@FAC6           Store length
       RTN
*******************************
LINK19 DATA LINK1A
       STRI 'HPUT'
       DATA $+2
       CALL SPNUM1
HPAGIN CALL ROWCOL            Get ROW & COL
       CALL STRFCH            Get string or number
       CEQ  >65,@FAC2         String?
       BS   HPUTS             Yes
       CALL HVPNUM            No, CNS
HPUTS  DCZ  @FAC6
       BS   HPOUT
       DCLR @FAC
HPUTLP CALL PUTLP
       CALL HFMT
       DDEC @FAC6
       BR   HPUTLP
HPOUT  CEQ  >B3,@CHAT
       BS   HPAGIN
       BR   XPTRTN
**************************
LINK1A DATA LINK1B
       STRI 'VPUT'
       DATA $+2
       CALL SPNUM1
VPAGIN CALL ROWCOL            Get ROW & COL
       CALL STRFCH            Get string or number
       CEQ  >65,@FAC2         String?
       BS   VPUTS             Yes
       CALL HVPNUM            No, CNS
VPUTS  DCZ  @FAC6
       BS   VPOUT
       DCLR @FAC
VPUTLP CALL PUTLP
       CALL VFMT
       DDEC @FAC6
       BS   VPOUT
       CZ   @YPT
       BR   VPUTLP
       INC  @XPT
       B    VPUTLP
VPOUT  CEQ  >B3,@CHAT
       BS   VPAGIN
       BR   XPTRTN
****************************
HVGETS CALL ROWCOL
       CALL GETNUM
       DCGT >00FF,@FAC
       BS   ERRBV        * BAD VALUE
       DST  @FAC,@BYTES
       DST  @FAC,@TEMP1
       XML  GETSTR
       DST  @SREF,@STRPTR
       RTN
****************************
LINK1B DATA LINK1C
       STRI 'HGET'
       DATA $+2
       CALL SPNUM1
HAGAIN CALL HVGETS
LP2    CALL GETLP
       CALL HFMT
       DDEC @TEMP1
       BR   LP2
HDONE  CALL NGOOD
       CEQ  >B3,@CHAT
       BS   HAGAIN
       BR   XPTRTN
**************************
LINK1C DATA LINK1D
       STRI 'VGET'
       DATA $+2
       CALL SPNUM1
VAGAIN CALL HVGETS
LP1    CALL GETLP
       CALL VFMT
       DDEC @TEMP1
       BS   VDONE
       CZ   @YPT
       BR   LP1
       INC  @XPT
       B    LP1
VDONE  CALL NGOOD
       CEQ  >B3,@CHAT
       BS   VAGAIN
       BR   XPTRTN
*******************************************************
* CPU PROGRAM FOR >8300 SCATCH PAD SUBROUTINE EXECUTE *
*******************************************************
*                          AORG >8300
CPUPGM DATA >8302 * CPUPGM DATA >8302  First address. *
       DATA >0420 *        BLWP >834A  Switch contex  *
       DATA >834A *                    FAC not used   *
       DATA >04E0 *        CLR  @>837C Clear for GPL  *
       DATA >837C *                                   *
       DATA >045B *        RT          Return to GPL. *
                  *        END                        *
*******************************************************
LINK1D DATA LINK1E
       STRI 'EXECUTE'         EXECUTE
       DATA $+2
       CALL SPNUM1
EXAGN  CALL SUBLP3
       MOVE 12,@>8300,[email protected]>03C0
       MOVE 12,[email protected],@>8300
       DST  @FAC,@>8304
       XML  >F0
       MOVE 12,[email protected]>03C0,@>8300
       CEQ  >B3,@CHAT
       BS   EXAGN
       BR   LNKRTN
***********************************************************
LINK1E DATA LINK1F
       STRI 'SIZE'            SIZE
       DATA $+2
       B    SZSIZE
LINK1F DATA LINK20
       STRI 'CLSALL'          CLSALL
       DATA $+2
       CALL CLSALL
       BR   LNKRT2
LINK20 DATA LINK21
       STRI 'BYE'             BYE
       DATA $+2
       CALL CLSALL
       EXIT
LINK21 DATA LINK22
       STRI 'NEW'             NEW
       DATA $+2
RXBNEW CLR  [email protected]>0371           Clear AUTOLOAD flag
       CALL CLSALL
       B    SZNEW
LINK22 DATA LINK23
       STRI 'BIAS'            BIAS
       DATA $+2
       CALL SPNUM1
BIASAG CALL GETNUM
       DST  @FAC,@VAR0
       CALL STRGET
       DST  @FAC4,@VARY
       DST  @FAC6,@VARY2
BIASLP ST   V*VARY,@FAC1      * Character.
       DCZ  @VAR0             * 0?
       BS   BIASM             * Yes.
       ADD  96,@FAC1          * ADD OFFSET
       BR   BIASSV
BIASM  SUB  96,@FAC1          * MINUS OFFSET
BIASSV ST   @FAC1,V*VARY
       DINC @VARY
       DDEC @VARY2
       BR   BIASLP
       CEQ  >B3,@CHAT
       BS   BIASAG
       BR   LNKRTN
LINK23 DATA LINK24
       STRI 'EALR'            EALR
       DATA $+2
       CALL EASAVE
       BYTE >33
LINK24 DATA LINK25
       STRI 'EAPGM'           EAPGM
       DATA $+2
       CALL EASAVE
       BYTE >35
LINK25 DATA LINK26
       STRI 'EAED'            EAED
       DATA $+2
XEAED  CALL EASAVE
       BYTE >31
LINK26 DATA LINK27
       S