*************************************************************      
       GROM >E000
       AORG >0000
       TITL  'Rich E/A GROM'
*************************************************************
* CPU
*
PAD    EQU   >8300
PAD1   EQU   >8301
PAD2   EQU   >8302
PAD3   EQU   >8303
PAD4   EQU   >8304
PAD6   EQU   >8306
PAD7   EQU   >8307
PAD8   EQU   >8308
BYTES  EQU   >830C           BYTES COUNTER
SCADD  EQU   >8310
SCADE  EQU   >8311
TMPCNT EQU   >8312
SCNADD EQU   >8314
TMP    EQU   >8316
TMP1   EQU   >8317
CHRCUR EQU   >8318
PABPTR EQU   >831C
COUNT  EQU   >831E            CATALOG COUNT FILES
CURADD EQU   >8320
CODE   EQU   >8322
CODE1  EQU   >8323
STLN   EQU   >8324
ENDLN  EQU   >8326
BUFFR  EQU   >8328
PGMPTR EQU   >832C
FREPTR EQU   >8340
XTOKEN EQU   >8342
DSKFLG EQU   >8344
LDFLAG EQU   >8347
FLAG   EQU   >8348
FLAG2  EQU   >8349
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
VPAB   EQU   >8356
ARG    EQU   >835C
ARG1   EQU   >835D
ARG2   EQU   >835E
ARG4   EQU   >8360
ARG6   EQU   >8362
VSTACK EQU   >836E
SUBSTK EQU   >8373
KBNO   EQU   >8374
KEY    EQU   >8375
ITIMER EQU   >8379
VCHAR  EQU   >837D
CHARNM EQU   >83C0
SPRITE EQU   >83C2
********************
* GENERAL
*
AID    EQU   1
CLEAR  EQU   2
REDO   EQU   6
PROCD  EQU   12
ENTER  EQU   13
BEGIN  EQU   14
BACK   EQU   15
SPACE  EQU   32
* XML's ************
*
ROUND  EQU   >02
CIF    EQU   >23
* VDP **************
*
COLOR  EQU   >077F
* GROM *************
*
DSRLNK EQU   >0010
DSRRET EQU   >0012
BERR   EQU   >001C
BGETSS EQU   >0038
RXB    EQU   >6024
***********************************************************
* GROM Header
       BYTE  >AA              * Header byte
       BYTE  16               * Version #
       BYTE  1                * # programs
       BYTE  0                * Reserved
       DATA >0000             * POWER UP
       DATA  MENU             * Cartridge menu
       DATA  EADSR            * DSRs
       DATA  BASICS           * Subroutines
       DATA  >0000            * Interupts
       DATA  >0000            * TI BASIC
MENU   DATA  >0000
       DATA  SETUP
       STRI  'REA VERSION 2022'
*********************************************************
* Set up configure paths       
SETUP  CEQ   >99,V@>0CFF      PREVIOUS RUN FLAG SET?
       BS    SOLDEA           Yes
       ST    >99,V@>0CFF      No, SET PREVIOUS RUN FLAG
       CLR   V@>0D00      
       MOVE  >FF,V@>0D00,V@>0D01
       MOVE  11,G@C1,V@>0D00  DSK1.EDIT1
       MOVE  11,G@C2,V@>0D28  DSK1.ASSM1
       MOVE  12,G@C3,V@>0D50  DSK1.SOURCE 
       MOVE  12,G@C4,V@>0D78  DSK1.OBJECT
       MOVE  10,G@C5,V@>0DA0  DSK1.LIST
       MOVE  2,G@C6,V@>0DC8   L
* NORMAL RXB START OF EA MODULE      
SOLDEA CALL  NESCRN
OLDEA  CHE   >38,@XTOKEN      Flag to high?
       BS    CLREA            Yes
       CHE   >31,@XTOKEN      Flag set?
       BS    NEWEA            yes
CLREA  CALL  CLRREA
       CLR   @XTOKEN          Reset RXB flag
       CLR   V@>3EF0          Clear RXB MENU Flag
NEWEA  DCLR  @>2000
GE029  CALL  EASCRN
       CLR   @DSKFLG           * Disk SEARCH FLAG
       DST   >0B00,@FAC
       CALL  UPCASE
GE056  ST    5,@KBNO
       DST   >0900,@FAC
       CALL  LOCASE
       CLR   V@>0800
       MOVE  >00FF,V@>0800,V@>0801
       MOVE  6,G@VREGS,#1
       CLR   V@>1000          * CLEAR PAB AREAS
       MOVE  >0380,V@>1000,V@>1001
       AND   >EF,@SPRITE        Disable Sprites!
       MOVE  16,G@CURPAT,V@>08F0
       MOVE  16,G@DARROW,V@>0C10
*
*  Display Main Menu
*
MMENU  ST    >7E,@SUBSTK       * Set SUBSTACK
       DCLR  @CODE
       DCLR  @FLAG
       CLR   @LDFLAG
       ALL   SPACE
GE116  CHE   >38,@XTOKEN
       BS    MSCRN
       CHE   >31,@XTOKEN
       BS    MYEAXB
MSCRN  HOME
       FMT
       COL   1
       HTEX  'Rich Editor & Assembler V=2022'
       ROW+  1
       COL   0
       HCHA  32,95
       ROW+  2
       COL   6
       HTEX  'S    SET PATH NAMES'
       ROW+  4
       COL   6
       HTEX  'D    DIRECTORY' 
       ROW+  3
       COL   6
       HTEX  'A    ASSEMBLER'
       ROW+  2
       COL   6
       HTEX  'E    EDITOR'
       ROW+  2
       COL   6
       HTEX  'X    XB PROGRAM'   
       ROW+  2
       COL   6
       HTEX  'L    LOAD and RUN'
       ROW+  2
       COL   6
       HTEX  'P    PROGRAM FILE'
       ROW+  4
       COL   6
       HTEX  '.    R X B'
       FEND
NEWSCN SCAN
       BR    NEWSCN
       CEQ   >2E,@KEY         * .?
       BR    NSCAN            * Yes
       CALL  CLSALL           * Close files 
RTRXB  B     RXB              * Go RXB
MYEAXB DCLR  V@>2250          * Clear Pass flag
       ST    @XTOKEN,@KEY
       ST    >EA,@XTOKEN      * Load Flag
NSCAN  CEQ   'L',@KEY         * L?
       BS    NSCAN1
       CEQ   'l',@KEY         * l?
       BS    NSCAN1
       CEQ   '3',@KEY         * 3?
       BR    NSCAN2
NSCAN1 ST    >33,@KEY         * Set LOAD & RUN
       CEQ   >33,@KEY         * LOAD AND RUN?
       BS    LANDR
NSCAN2 CEQ   'P',@KEY         * P?
       BS    NSCAN3
       CEQ   'p',@KEY         * p?
       BS    NSCAN3
       CEQ   '5',@KEY         * 5
       BR    NSCAN4
NSCAN3 ST    >35,@KEY         * SET RUN PROGRAM
       CEQ   >35,@KEY         * PROGRAM?
       BS    PRGRM
NSCAN4 CEQ   'A',@KEY         * A?
       BS    NSCAN5
       CEQ   'a',@KEY         * a?
       BS    NSCAN5
       CEQ   '2',@KEY         * 2?
       BR    NSCAN6 
NSCAN5 ST    >32,@KEY         * SET ASSEMBLER
       CEQ   >32,@KEY         * ASSEMBLER?
       BS    ASSEM                         
NSCAN6 CEQ   'E',@KEY         * E?
       BS    NSCAN7
       CEQ   'e',@KEY         * e?
       BS    NSCAN7
       CEQ   '1',@KEY         * 1?
       BR    NSCAN8
NSCAN7 ST    >31,@KEY         * SET EDITOR
       CEQ   >31,@KEY         * EDITOR? 
       BS    EDITOR
NSCAN8 CEQ   'D',@KEY         * D?  
       BS    DIRECT
       CEQ   'd',@KEY         * d?
       BS    DIRECT       
       CEQ   'X',@KEY         * X?
       BS    XBINP
       CEQ   'x',@KEY         * x?
       BS    XBINP
       CEQ   'S',@KEY         * S?
       BS    CONFIG
       CEQ   's',@KEY         * s?
       BR    NEWSCN
******************************************************
* CONFIGURE PATHS
*
CONFIG CALL  EASCRN
       CLR   @XTOKEN
       CALL  CLRREA
       ALL   SPACE
       HOME
       FMT
       COL   6
       HTEX  '* CONFIGURE PATHS *'
       FEND
       ST    49,V@65            1
       MOVE  40,V@>0D00,V@67    DSK1.EDIT1
       ST    50,V@161           2
       MOVE  40,V@>0D28,V@163   DSK1.ASSM1
       ST    51,V@257           3
       MOVE  40,V@>0D50,V@259   DSK1.SOURCE
       ST    52,V@353 
       MOVE  40,V@>0D78,V@355   DSK1.OBJECT
       ST    53,V@449           5
       MOVE  40,V@>0DA0,V@451   DSK1.LIST
       FMT
       ROW   17
       COL   1
       HTEX  '6  OPTIONS:'
       ROW   21
       COL   4
       HTEX  'CTRL 1 - 5 DRIVE SELECTION'
       ROW   23
       COL   4
       HTEX  'ANY OTHER KEY TO MAIN MENU'
       FEND
       MOVE  40,V@>0DC8,V@556   OPTIONS: L
CONFIH SCAN
       BR    CONFIH 
       CHE   '7',@KEY        <7?
       BS    CONFIL          Exit out
       CHE   '1',@KEY        1 to 6 only valid
       BR    CLREA           Exit out
       DST   65,@CURADD      Cursor Location 
       CHE   >30,@KEY        KEY>48?
       BR    CONFIH
       SUB   >30,@KEY        KEY-48
       ST    @KEY,@PAD       Save key 0-5
       ST    @KEY,@PAD8      Save key 1-6
       DEC   @PAD            -1
       MUL   96,@PAD         Add 64 Cursor Address
       DADD  @PAD,@CURADD    Cursor address   
       ST    130,V*CURADD    Left Arrow
       DADD  35,@CURADD      Cursor
       DST   @CURADD,@PAD4   Save address 
CONFIJ CALL  GETINP          Get input
       DCZ   @FAC6           Length 0?
       BS    CONFIG
       CHE   39,@FAC         <39?
       BS    CONFIG
       DCLR  @PAD6           Index
CONFIK DADD  40,@PAD6        Index+40 
       DEC   @PAD8           Copy of KEY
       BR    CONFIK
       ST    @FAC7,V@>0CD8(@PAD6)  Length
       MOVE  39,V*PAD4,V@>0CD9(@PAD6) String
       BR    CONFIG
MMMENU ST    >EA,@XTOKEN     Set flag
       BR    MMENU           Exit
* CTRL keys ***************************************
CONFIL CHE   182,@KEY        CTRL 5?
       BS    CONFIG
       CHE   177,@KEY
       BR    CONFIG
       CALL  ACCTON          ACCEPT TONE
       ST    @KEY,@PAD4      SAVE KEY
       SUB   176,@PAD4       CTRL=1 to 5
       DCLR  @ARG
       DST   -25,@PAD        SCREEN ADDRESS
       DST   >0CDC,@ARG      MEMORY ADDRESS
CONFLP DADD  40,@ARG         40*VALUE
       DADD  96,@PAD         96*VALUE 
       DEC   @PAD4
       BR    CONFLP 
       ST    30,@PAD6
CONDEU DST   >0160,@PAD2     COUNTER 
CONDEV SCAN
       BS    CONDST 
       DDEC  @PAD2           COUNTER-1
       BR    CONDEV
       EX    V*PAD,@PAD6     SWAP
       B     CONDEU
CONDST CALL  ACCTON
       ST    @KEY,V*PAD      SCREEN ADDRESS #
       ST    @KEY,V*ARG      MEMORY ADDRESS #  
       BR    CONFIG      
**************************************************
*  Main Menu Option 1: EDIT
*
EDITOR CALL  EASCRN
       DCLR  @FLAG
       CLR   @LDFLAG
       ST    >EA,@XTOKEN
       FMT
       COL   >0B
       ROW   1
       HTEX  '* EDITOR *'
       ROW+  3
       COL   3
       HTEX  '1    LOAD'
       ROW+  1
       COL+  23
       HTEX  '2    EDIT'
       ROW+  1
       COL+  23
       HTEX  '3    SAVE'
       ROW+  1
       COL+  23
       HTEX  '4    PRINT'
       ROW+  1
       COL+  22
       HTEX  '5    PURGE'
       ROW+  1
       COL+  22
       FEND
GE19B  SCAN
       BR    GE19B
       CEQ   BACK,@KEY       * BACK KEY
       BS    CLREA
       SUB   >31,@KEY
       CHE   >06,@KEY
       BS    GE19B
       DCLR  @FLAG
       ST    >7E,@SUBSTK
       ST    @KEY,@PAD       * Save KEY
       MUL   >40,@PAD
       DST   >0082,@CURADD
       DADD  @PAD,@CURADD  
       ST    130,V*CURADD    * SHOW ARROW 
       ST    @KEY,@PAD4
       CEQ   4,@KEY          * PURGE?
       BR    GE1E4           * No, next check
*  Edit Menu Option 5: PURGE
       FMT
       ROW+  2
       HTEX  'Are you sure (Y/N)? '
       FEND
       CALL  YESNO
       CEQ   >59,@KEY
       BR    EDITOR
       CALL  CLRXOP
GE1E2  BR    EDITOR
GE1E4  CEQ   >03,@KEY         * PRINT?
       BS    GE237            * YES!
       DCEQ  >55AA,@>2000     * EDIT1 loaded?
       BS    GE1FC            * Yes
       MOVE  99,V@>2250,@>EA00
       ST    @XTOKEN,@>FFFB
       CALL  P1000
       CALL  NPAB       
       MOVE  40,V@>0D00,V@>1009  Get configured path EDIT1
       ST    1,@LDFLAG           Set Editor flag
GE1F6  CALL  PGMLOD
       DCEQ  >55AA,@>2000
       BR    EDITOR
       CALL  CLRXOP
       MOVE  99,@>EA00,V@>2250
       ST    @>FFFB,@XTOKEN
GE1FC  CEQ   >01,@PAD4       * Edit?
       BS    EMOPT2          * Yes
       CEQ   >02,@PAD4       * Save?
       BR    GE237           * No
*  Edit Menu Option 3: SAVE
       CLR   @XTOKEN
       FMT
       COL   2
       ROW   16
       HTEX  'DV80 Format (Y/N)? '
       FEND
       CALL  YESNO
       CEQ   >59,@KEY
       BR    GE22C
       OR    >02,@FLAG2
GE22C  CEQ   BACK,@KEY
       BS    EDITOR
       DST   >0262,@CURADD
       BR    GE23B
GE235  CLR   @XTOKEN          * CLEAR XTOKEN FLAG
GE237  DST   >0202,@CURADD    * Print or Load
       MOVE  255,V@>0200,V@>201
GE23B  MOVE  10,G@FPATH,V*CURADD
       DADD  >0040,@CURADD
* CONFIGURE PATH SOURCE *********************************
       DCLR @TMP
       ST   V@>0D50,@TMP1
       DST  @TMP,V@>2255
       MOVE @TMP,V@>0D51,V@>2257 Save as SOURCE
       ST   >0D,V@>2258(@TMP) 

       CHE   >02,@PAD4       SAVE, PRINT ?
       BS    EINPUT
       CEQ   >EA,@XTOKEN
       BS    EINPUT
       BR    EINPUT
       CALL  BLNKBU
       CALL  BLDPAB
       BR    EMOPT1              
EINPUT CALL  GETALL
EMOPT1 CEQ   BACK,@KEY       * BACK?
       BS    CLREA
       CEQ   >02,@PAD4       * Save?
       BS    GE2B5
       CEQ   >03,@PAD4       * Print?
       BS    GE2D9
       CZ    @PAD4           * Load?
       BS    GE272
*  Edit Menu Option 2: EDIT
EMOPT2 XML   >23
       BS    GE8B0
       CALL  GE8FC
       BR    EDITOR
GE272  ST    >EA,@XTOKEN     SET XTOKEN
       CALL  GE27B
       XML   >21
       BS    GE8B3
       BR    EDITOR
*********************************************
GE27B  ST    >04,V@1(@PABPTR)
       AND   >FD,@FLAG2
GE283  DST   @PABPTR,@VPAB
       DADD  >0009,@VPAB
       CALL  DSRLNK
       BYTE  >08
       BS    CHKERR
       CLOG  >E0,V@1(@PABPTR)
       BR    GE29C
       ST    >02,V*PABPTR
       RTN
**********************************************
GE29C  ST    V@1(@PABPTR),@PAD
       AND   >1F,@PAD
       CEQ   >04,@PAD
       BR    GE2B3
       ST    >14,V@1(@PABPTR)
       OR    >02,@FLAG2
       BR    GE283
GE2B3  BR    CHKERR
GE2B5  ST    >02,V@1(@PABPTR)
       CLOG  >02,@FLAG2
       BS    GE2C4
       ST    >12,V@1(@PABPTR)
GE2C4  CALL  DOIO
       ST    >03,V*PABPTR
       ST    >50,V@5(@PABPTR)
       XML   >22
       BS    GE8B3
       CALL  CLOSE
       BR    EDITOR
* Edit Menu Option 4 : PRINT output
GE2D9  CALL  GE27B
       FMT
       COL   2
       ROW   20
       HTEX  'DEVICE NAME?'
       FEND
       DST   >02C2,@CURADD   * Cursor Address
       DST   >1100,@PABPTR   * PAB address
       CEQ   >04,@PAD4       * VIEW?
       BS    VFILE           * No
       CLR   @XTOKEN
       CALL  CLRREA
VFILE  CALL  GETALL
       CLR   @XTOKEN
       ST    >50,V@5(@PABPTR)
GE30A  ST    >12,V@1(@PABPTR)
       DST   >1080,V@2(@PABPTR)
       CALL  DOIO
       CEQ   >20,V@4(@PABPTR)
       BR    GE322
       OR    >02,@FLAG
GE322  ST    >03,V*PABPTR
       CLOG  >02,@FLAG
       BS    GE38D
GE32B  CALL  P1000
       CALL  BLNKBU
       CALL  DOIO
       DST   >1100,@PABPTR
       DST   >1080,@PAD
       DADD  >004F,@PAD
       ST    >50,@PAD2
GE344  ST    V*PAD,@PAD3
       CEQ   >20,@PAD3
       BS    GE361
       CEQ   >0C,@PAD3
       BR    GE35F
       ST    >20,V*PAD
       CALL  DOIO
       CALL  DOIO
       CALL  DOIO
GE35F  BR    GE367
GE361  DDEC  @PAD
       DEC   @PAD2
       BR    GE344
GE367  CALL  DOIO
       SUB   >20,@PAD2
       CGT   >00,@PAD2
       BR    GE380
       DADD  >0020,V@2(@PABPTR)
       ST    @PAD2,V@5(@PABPTR)
       B     GE367
GE380  DST   >1080,V@2(@PABPTR)
       ST    >20,V@5(@PABPTR)
       BR    GE32B
GE38D  CALL  P1000
       CALL  BLNKBU
       CALL  DOIO
       DST   >1100,@PABPTR
       CALL  DOIO
       BR    GE38D
GETALL CALL  BLNKBU
*  Build PAB with name
BLDPAB CALL  VZERO
       DST   @PABPTR,V@2(@PABPTR)
       DADD  >0080,V@2(@PABPTR)
       ST    >00,V@8(@PABPTR)
       DST   >5000,V@4(@PABPTR)
       DCLR  V@>2250
       CALL  GETINP
       DCZ   @FAC6
       BS    GE3CF
PABNAM MOVE  @FAC6,V*FAC4,V@10(@PABPTR)
       ST    @FAC7,V@9(@PABPTR)
GE3CF  RTN
BLNKBU DADD  >0080,@PABPTR
       ST    >20,V*PABPTR
       MOVE  >004F,V*PABPTR,V@1(@PABPTR)
       DSUB  >0080,@PABPTR
       RTN
CLOSE  ST    >01,V*PABPTR
DOIO   DST   @PABPTR,@VPAB
       DADD  >0009,@VPAB
       CALL  DSRLNK
       BYTE  >08
       BS    CHKERR
       CLOG  >E0,V@1(@PABPTR)
       BR    CHKERR
       RTN
VZERO  CLR   V*PABPTR
       MOVE  >0045,V*PABPTR,V@1(@PABPTR)
       RTN
GETINP CALL  GETKEY
       DST   @STLN,@CURADD
       ST    >3C,@PAD
       DCLR  @FAC6
GE415  CEQ   SPACE,V*CURADD
       BR    GE42B
       DINC  @CURADD
       DEC   @PAD
       BR    GE415
       DST   @STLN,@CURADD
       CLOG  >04,@FLAG
       BR    GE43C
       BR    GETINP
GE42B  DST   @CURADD,@FAC4
GE42E  CEQ   SPACE,V*CURADD
       BS    GE43C
       DINC  @FAC6
       DINC  @CURADD
       DEC   @PAD
       BR    GE42E
GE43C  RTN
*  Key input routine
GETKEY ST    >1F,@CHRCUR
       DST   @CURADD,@ENDLN
       DST   @CURADD,@STLN
GE446  CLR   @ITIMER
       EX    V*CURADD,@CHRCUR
*  REPEAT KEYS
GE44C  SCAN
       BS    GE456
       CHE   7,@ITIMER
       BR    GE44C
       CEQ   >EA,@XTOKEN      * ANYTHING
       BR    GE446
PSCANX DST   V@>2250,@BUFFR
       ST    V@>2257(@BUFFR),@KEY
       DINC  @BUFFR
       DST   @BUFFR,V@>2250
       CEQ   @BUFFR,V@>2256
       BR    GE456
       ST    >0D,@KEY         * Store ENTER
GE456  CEQ   >1F,V*CURADD
       BR    GE460
       EX    V*CURADD,@CHRCUR
GE460  DST   @CURADD,@PAD
       DSUB  @STLN,@PAD
       CH    >19,@KEY         * SPACE key and higher?
       BS    GE46B
       CEQ   7,@KEY           * FCTN 3?
       BR    GE485
       ST    SPACE,V*STLN
       MOVE  >003F,V*STLN,V@1(@STLN)
       DST   @STLN,@CURADD
       BR    GETKEY
GE46B  CLOG  >01,@FLAG
       BR    GE4DD
GE470  ST    @KEY,V*CURADD
       DCH   @ENDLN,@CURADD
       BR    GE47C
       DST   @CURADD,@ENDLN
GE47C  CH    >3F,@PAD1
       BS    GE446
       DINC  @CURADD
       BR    GE446
GE485  AND   >FE,@FLAG
       CEQ   BACK,@KEY
       BR    GE499
       CLOG  >20,@FLAG
       BR    CLREA            * GE97F
       CLOG  >04,@FLAG
       BR    CLREA
       BR    EDITOR
GE499  CEQ   >09,@KEY
       BS    GE47C
       CEQ   >08,@KEY
       BR    GE4AB
       CZ    @PAD1
       BS    GE446
       DDEC  @CURADD
       BR    GE446
GE4AB  CEQ   >0D,@KEY
       BS    GE503
       CEQ   >03,@KEY
       BR    GE4D3
       ST    SPACE,V*CURADD
       DST   @ENDLN,@PAD
       DSUB  @CURADD,@PAD
       CGT   >00,@PAD1
       BR    GE446
       MOVE  @PAD,V@1(@CURADD),V*CURADD
       ST    SPACE,V*ENDLN
       DDEC  @ENDLN
       BR    GE446
GE4D3  CEQ   >04,@KEY
       BR    GE501
       OR    >01,@FLAG
       BR    GE446
GE4DD  DST   @ENDLN,@PAD
       DSUB  @STLN,@PAD
       CH    >3F,@PAD1
       BS    GE446
       DST   @ENDLN,@PAD
       DSUB  @CURADD,@PAD
       DINC  @PAD
       MOVE  @PAD,V*CURADD,V@>03C0
       MOVE  @PAD,V@>03C0,V@1(@CURADD)
       DINC  @ENDLN
       BR    GE470
GE501  BR    GE446
GE503  RTN
*  Check for Expansion Memory
EXPMEM ST    @>2000,@PAD
       ST    >FF,@>2000
       CEQ   >FF,@>2000
       BR    GE91D
       CLR   @>2000
       CZ    @>2000
       BR    GE91D
       ST    @PAD,@>2000
       RTN
NESCRN BACK  >F4
       ST    >F4,V@COLOR
EASCRN ST    >D0,V@>0300
       ST    V@COLOR,V@>0380
       MOVE  31,V@>0380,V@>0381
       ALL   SPACE
       MOVE  1,V@COLOR,#7
       RTN
USSCRN ST    >13,V@>0380
       MOVE  31,V@>0380,V@>0381
       ALL   SPACE
       RTN
CLRXOP CLR   @>FFD8
       MOVE  5,@>FFD8,@>FFD9
       RTN
***********************************************************
*
* Main Menu Option 2: ASSEMBLER
*
ASSEM  ALL   SPACE
       FMT
   COL   10
   ROW   1
   HTEX  '* ASSEMBLER *'
   FEND
       DCLR  @FLAG
       CLR   @LDFLAG
       ST    >7E,@SUBSTK
       OR    >20,@FLAG
       DCEQ  >AA55,@>2000
       BS    GE687
       MOVE  99,V@>2250,@>EA00
       ST    @XTOKEN,@>FFFB
       CLR   @XTOKEN
* Replacement for LODPGM
*       CALL  LODPGM
*       DATA  DASSM1
*       CALL  DEVICE
*       CEQ   BACK,@KEY
*       BS    CLREA
       CALL  P1000
       MOVE  15,G@PAB,V*PABPTR        
       MOVE  40,V@>0D28,V@>1009  Get configured path ASSM1

       ST    2,@LDFLAG
GE654  CALL  PGMLOD
       DCEQ  >AA55,@>2000
       BR    ASSEM
*  CALL FILES (4)
GE687  DST   >0116,V@>1380
       DST   >1380,@VPAB
       ST    >04,@FAC2
       CALL  DSRLNK
       BYTE  >0A
       MOVE  99,@>EA00,V@>2250
       ST    @>FFFB,@XTOKEN
       ALL   32
       FMT
       COL   10
       ROW   1
       HTEX  '* ASSEMBLER *'
       FEND
       CALL  P1000
** CONFIGURE PATH SOURCE ************************
       CALL  VZERO
       CALL  LPAB
       DST   >1080,V@2(@PABPTR)
       ST    >00,V@8(@PABPTR)
       DST   >5000,V@4(@PABPTR)
       DCLR  V@>2250 
       MOVE  40,V@>0D50,V@9(@PABPTR)   
       DST   >1080,V@2(@PABPTR)
       CALL  GE27B
       CLR   @XTOKEN
       DST   >1100,@PABPTR
       DST   >0142,@CURADD
** CONFIGURE PATH OBJECT *************************
       CALL  VZERO
       CALL  LPAB
       ST    >00,V@1(@PABPTR)
       DST   >1180,V@2(@PABPTR)
       ST    >00,V@8(@PABPTR)
       DST   >5000,V@4(@PABPTR)
       DCLR  V@>2250     
       MOVE  40,V@>0D78,V@9(@PABPTR)
       DST   >1180,V@2(@PABPTR)
       CALL  DOIO
       OR    >40,@FLAG
       DST   >1200,@PABPTR
       OR    >04,@FLAG
** CONFIGURE PATH LIST **************************
       CALL  VZERO
       CALL  LPAB
       ST    >12,V@1(@PABPTR)
       DST  >1280,V@2(@PABPTR)
       ST    >00,V@8(@PABPTR)
       DST   >5000,V@4(@PABPTR)
       DCLR  V@>2250     
       MOVE  40,V@>0DA0,V@9(@PABPTR)
       DCZ   @FAC6
       BS    GE736
       ST    >12,V@1(@PABPTR)
       DST   >1280,V@2(@PABPTR)
       CALL  DOIO
       OR    >80,@FLAG
GE736  FMT
       COL   2
       ROW   16
       HTEX  'Options?'
       FEND
       DST   >0242,@CURADD
** CONFIGURE PATH OPTIONS ********************
       MOVE  20,V@>0DC9,V@>03C0
       AND   >FB,@FLAG
       DCZ   @FAC6
       BR    GE756
GE756  MOVE  15,V@>0DC9,@>20D2
       CALL  CLRXOP
       ALL   SPACE
       XML   >21
       BS    GE8B3
GE767  CALL  CLRXOP
       CALL  P1000
       CALL  CLOSE
       DST   >1100,@PABPTR
       CALL  CLOSE
       CLOG  >80,@FLAG
       BS    GE784
       DST   >1200,@PABPTR
       CALL  CLOSE
GE784  CLR   @FLAG
       CALL  WENTER
       BR    OLDEA
*  Get Yes/No reply
YESNO  ST    >1F,@CHRCUR
GE7A2  CLR   @ITIMER
       EX    @VCHAR,@CHRCUR
GE7A7  SCAN
       BS    GE7B1
       CHE   >06,@ITIMER
       BR    GE7A7
       BR    GE7A2
GE7B1  CEQ   BACK,@KEY
       BS    GE7C0
       CEQ   >59,@KEY
       BS    GE7C0
       CEQ   >4E,@KEY
       BR    GE7A2
GE7C0  ST    @KEY,@VCHAR
       CLR   @XTOKEN
       RTN
***************************************************
*  Main Menu Option 3: LOAD AND RUN
*
LANDR  DCLR  @FLAG
       OR    >01,@FLAG2
       ALL   SPACE
       FMT
       COL   8
       ROW   0
       HTEX  '* LOAD and RUN *'
       COL+  10
       ROW+  2
       HTEX  'PATH.NAME?'
       FEND
       CALL  EXPMEM
       OR    >40,@FLAG2
GE7F2  ST    SPACE,V@162
       MOVE  >003B,V@162,V@163
       DST   162,@CURADD
       OR    >04,@FLAG
       CALL  P1000
       CALL  GETALL
       CLR   @XTOKEN
       DCZ   @FAC6
       BR    GE816
       CALL  BINIT2
       BR    RUN
       BR    GE821
GE816  CLOG  >40,@FLAG2
       BS    GE821
       CALL  BINIT3
       AND   >BF,@FLAG2
GE821  ST    >04,V@1(@PABPTR)
GE826  DST   @PABPTR,@VPAB
       DADD  >0009,@VPAB
       XML   >22
       CLOG  >08,@FLAG
       BR    G6C61                   to subs
       BR    GE7F2                   next file
***************************************************
*  Main Menu Option 4: RUN
*
RUN    ALL   SPACE
GE848  ST    >7E,@SUBSTK
       FMT
       ROW   0
       COL   1
       HTEX  '* RUN *'
       ROW+  2
       COL   1
       HTEX  'SELECT PROGRAM NAME:'
       FEND
       CALL  EXPMEM
       CLR   @XTOKEN       SET XTOKEN=0
       DST   129,@PAD6     * Screen location LOCATION
       DST   >3FF8,@PAD8   * Locataion of LINK TABLE
FNDLNK DST   @PAD8,@PAD2   * Copy it.
       ST    6,@PAD4       * MAX Length of each name.
FNDLP  CHE   128,@0(@PAD2) * ~?
       BS    FNDDON        * Yes, done.
       CHE   32,@0(@PAD2)  * Space or higher?
       BR    FNDDON        * No, done.
       CEQ   32,@0(@PAD2)  * Space?
       BR    FNDSHO        * No.
       CEQ   6,@PAD4       * 6?
       BS    FNDDON        * Yes.
FNDSHO ST    @0(@PAD2),V@0(@PAD6)
       DINC  @PAD6         * COL+1
       DCHE  768,@PAD6     * End of screen?
       BR    MORSCN
       MOVE  20,G@OUTSCN,V@>8
       CALL  BADTON
       BR    FNDDON
*
MORSCN DINC  @PAD2         * Next character.
       DEC   @PAD4         * Length-1
       BR    FNDLP         * No, keep looping.
       DINCT @PAD6         * Reset next column
       DSUB  8,@PAD8       * Link Table Address+8
       CEQ   >2600,@PAD8   * Last Table name?
       BR    FNDLNK        * No
* Get the name by using arrow keys
FNDDON OR    >04,@FLAG      
       DST   >0080,@SCADD  ARROW LOCATION
RUN00  ST    130,V*SCADD   LEFT ARROW
       ST    131,V@7(@SCADD)  RIGHT ARROW
       SCAN
       BR    RUN00
       ST    32,V*SCADD    NO LEFT ARROW
       ST    32,V@7(@SCADD) NO RIGHT ARROW
       CEQ   BACK,@KEY     BACK?
       BS    LANDR
       CEQ   11,@KEY       FCTN UP?
       BS    RUNUP
       CEQ   'E',@KEY      UP (E)?
       BR    RUN01
RUNUP  DSUB  32,@SCADD     ARROW-8
       DCHE  >007F,@SCADD  TOP LINE LEFT?
       BR    FNDDON
RUN01  CEQ   10,@KEY       FCTN DOWN?
       BS    RUNDN
       CEQ   'X',@KEY      DOWN (X)?
       BR    RUN02
RUNDN  DADD  32,@SCADD     ARROW+8
       DCHE  767,@SCADD    BOTTON LINE RIGHT?
       BS    FNDDON
       DCEQ  >2020,V@1(@SCADD) SPACE SPACE?
       BR    RUN02
       DSUB  32,@SCADD     ARROW-8
RUN02  CEQ   8,@KEY        FCTN LEFT?
       BS    RUNLT
       CEQ   83,@KEY       LEFT (S)?
       BR    RUN03
RUNLT  DSUB  8,@SCADD      ARROW-32
       DCHE  >007F,@SCADD  TOP LINE LEFT?
       BR    FNDDON
RUN03  CEQ   9,@KEY        FCTN RIGHT?
       BS    RUNRT
       CEQ   68,@KEY       RIGHT (D)?
       BR    RUN04
RUNRT  DADD  8,@SCADD      ARROW+8
       DCHE  767,@SCADD    BOTTOM LINE RIGHT? 
       BS    FNDDON
       DCEQ  >2020,V@1(@SCADD) SPACE SPACE?
       BR    RUN04
       DSUB  8,@SCADD      ARROW-8
RUN04  CEQ   ENTER,@KEY    ENTER?
       BS    RUN05   
       BR    RUN00
* Fetch the name match and address
RUN05  MOVE  6,V@1(@SCADD),@FAC          
       DST   >4000,@TMP   * Locataion of LINK TABLE
RUN06  DSUB  8,@TMP       * MINUS offset 
       MOVE  8,@0(@TMP),@ARG * Copy it.
       DCEQ  @FAC,@ARG     * First two characters?
       BR    RUN06
       DCEQ  @FAC2,@ARG2   * Secod two characters?
       BR    RUN06
       DCEQ  @FAC4,@ARG4   * Third two characters?
       BR    RUN06 
       MOVE  2,@ARG6,@>2022
* Normal EA 3 start up    
GE883  DCEQ  >A55A,@>2000
       BR    GE916
       CALL  USSCRN
GE88E  DCLR  @CODE
       XML   >21
       BS    GE8E3
       CLOG  >20,@FLAG2
       BS    GE8A3
       INCT  @SUBSTK
       DST   GE88E,*SUBSTK
       INCT  @SUBSTK
       RTN
GE8A3 CLOG  >08,@FLAG
      BR    G6DDE                   to subs
GE8A8 CALL  SOLDEA                  vdp setup
      CALL  WENTER                   wait for enter
      BR    GE029                   to start
***************************************************
*
*  Main Menu Option 5: RUN PROGRAM FILE
*
PRGRM  ALL   SPACE
       FMT
       COL   6
       ROW   1
       HTEX  '* RUN PROGRAM FILE *'
       FEND
       CEQ   >FF,@XTOKEN         RXB flag set?  
       BR    NOEABF              No
       MOVE  64,V@>2400,V@>2255  Get RXB buffer
       ST    >EA,@XTOKEN         Set RXB flag
NOEABF CALL  BINIT2              * INITILIZE LOW8K
       OR    >08,@FLAG2          Set flag  
       DST   >0102,@CURADD       Cursor address   
       MOVE  10,G@FPATH,V*CURADD * FILE NAME?
       DADD  >0040,@CURADD       Cursor address+64
       OR    >04,@FLAG           Set flag
       CALL  GETINP              Get path.file
       CEQ   1,@FAC7             Length=1?           
       BR    NO1KEY              No
       DST   >000B,V@>2400       Length 
       CALL  GDDSK               Load DSK1. Address
       MOVE  6,G@DUTIL1,V@>2407  Load UTIL1
       ST    >FF,@XTOKEN         Set RXB flag
       BR    PRGRM               Restart 
NO1KEY DCZ   @FAC6               * ENTER?
       BR    GE597               * No
       ST    '1',@DSKFLG          * Search flag
MYSRCH CALL  LODPGM              * Load DATA
       DATA  DUTIL1              * DSK1.UTIL1
       BR    GE5A6               
GE597  CALL  LODUSR
       CALL  PABNAM
       DCEQ  >4353,V*FAC4        * CS ??
       BR    GE5A6               * No
       ALL   SPACE
GE5A6  CALL  PGMLOD
       CALL  USSCRN
       XML   >F0
       BS    GE8E3
       BR    GE8A8
LODPGM FETCH @SCADD
       FETCH @SCADE
       MOVE  5,G@0(@SCADD),V@>100F
LODUSR DCLR  @PAD
       CALL  P1000
       CALL  NPAB
       CZ    @DSKFLG               * Check Search flag
       BS    PMSG                 * No, go on
       ST    @DSKFLG,V@13(@PABPTR) * Yes, store next drive #
PMSG   MOVE  15,G@PLEASE,V@>02A2
       RTN
*  Load Program
PGMLOD CALL  DOIO
       MOVE  6,V@>1380,@SCADD
       DCZ   @PAD
       BR    GE5E5
       DST   @SCNADD,@PAD
GE5E5  DSUB  PAD,@SCNADD
       MOVE  @TMPCNT,V@>1386,@PAD(@SCNADD)
       DCZ   @SCADD
       BS    GE605
       DCLR  @PAD2
       ST    V@>1009,@PAD3
       DADD  >1009,@PAD2
       INC   V*PAD2
       BR    PGMLOD
GE605  ST    SPACE,V@>02A2
       MOVE  19,V@>02A2,V@>02A3
       CALL  VZERO
       RTN
********************************************************
* RXB Loader
XBINP  ALL   SPACE
       ST    1,@FAC
XBAGN  FMT
       COL   8
       ROW   1
       HTEX  '* R X B *'
       ROW+  4
       COL   2
       HTEX  'PATH.NAME?'
       FEND
       DEC   @FAC
       BR    XBAGN
       CEQ   >FF,@XTOKEN       XTOKEN=>EA?
       BR    XBINP1
       MOVE  64,V@>2400,V@>2255
       ST    >EA,@XTOKEN       SET XTOKEN=>EA
XBINP1 DST   >0102,@CURADD
       DST   >1000,@PABPTR
       OR    >20,@FLAG
       CALL  GETALL
       DCZ   @FAC6
       BS    XBINP3
       CEQ   1,@FAC7
       BR    XBINP2
       DST   >000A,V@>2400
       MOVE  5,G@DDSK1,V@>2402
       ST    V*STLN,V@>2405
       MOVE  5,G@DLOAD,V@>2407
       ST    >FF,@XTOKEN      SET XTOKEN=>FF
       BR    XBINP
XBINP2 CALL  CLRREA
       DST   >994A,V@>2254
       MOVE  80,V@9(@PABPTR),V@>2256
XBINP3 CLR   @PAD
       MOVE  >006E,@PAD,@PAD1
       B     RXB
***********************************************************
CLRREA CLR   V@>2250                Clear RXB buffer
       MOVE 80,V@>2250,V@>2251      Ripple
       RTN
ONEKEY CEQ  1,V@9(@PABPTR)    One character for drive#?
       BR   TWOKEY            No, normal continue
       ST   V@10(@PABPTR),@CHARNM    Yes, save # character
       MOVE 5,G@DDSK1,V@10(@PABPTR) DSK1. loaded into pab
       ST   >05,V@9(@PABPTR)        DSK1. has 5 characters
       ST   @CHARNM,V@13(@PABPTR)    Load charcter drive#/le
TWOKEY RTN
*
NPAB   MOVE  20,G@PAB,V*PABPTR
       RTN
* 
LPAB   MOVE  10,G@PAB80,V*PABPTR
       RTN
*
GDDSK  CEQ   '0',V@>0142
       BR    GDDSKN
       MOVE  5,G@WDS1,V@>2402
       ST    '1',V@>0142
       BR    GDWDS 
GDDSKN MOVE  5,G@DDSK1,V@>2402
GDWDS  ST    V*STLN,V@>2405
       RTN
***********************************************************
*
* CATALOG HARD/DISK
*
DIRECT CALL DMENU
       BR   DIREC2
DMENU  ALL  SPACE             Clear screen
       FMT
       COL 9
       ROW 0
       HTEX '* DIRECTORY *  '
       ROW+ 4
       COL+ 10
       HTEX 'Device? (# or path)'
       ROW+ 7
       COL  2
       HTEX 'ACTIVE KEYS: CLEAR, BEGIN,'
       ROW+ 2
       COL  2
       HTEX 'BACK, PROCEED, REDO, AID,'
       ROW+ 2
       COL  2
       HTEX '(Arrows), E,e,X,x,S,s,D,d,'
       ROW+ 2
       COL  2
       HTEX '1 (Editor), 2 (Assembler),'
       ROW+ 2
       COL  2
       HTEX 'ENTER (Program Image autorun)'
       ROW+ 2
       COL  2
       HTEX 'SPACE BAR (XB autorun only)'
       FEND
       RTN
DIREC2 DST  >0102,@CURADD     Prompt location
       DST  >1000,@PABPTR     Use first PAB area
       OR   >20,@FLAG         Set return bit for error
       CALL GETALL            Input the filename
DIREC3 CLR  @XTOKEN
       CALL CLRREA
       MOVE 9,G@CATDAT,V*PABPTR Prepare PAB
       CALL ONEKEY
       CALL DOIO              Open the file
       DST  >020D,V*PABPTR    Read opcode to PAB
       CALL DOIO              Read first record
       ALL  SPACE             Clear screen again
       CALL SCREEN            Set up header
       ST   >20,V@>2500
       MOVE >1100,V@>2500,V@>2501
       DST  >2580,@FREPTR
       ST   >59,@PAD2         Y
TSTKEY SCAN                   Scan the keyboard
       BR   TSTKE5            Any key?
       CEQ  SPACE,@KEY        SPACE KEY?
       BS   TSTKE4            Yes, wait.
       CEQ  BACK,@KEY         BACK key?
       BR   TSTKE3            No
TSTKE2 CLR  @XTOKEN           Yes, so restart
       CALL CLOSE             Close disk
       BR   DIRECT            Start Catalog again
TSTKE3 CLR  @XTOKEN           Clear flag
       BR   ARROWS
TSTKE4 SCAN                   Wait for any key.
       BR   TSTKE4            Loop
TSTKE5 CALL DOIO              Read file info
       CALL FILNAM            Put it on screen
       BR   TSTKEY            Loop till done
       DEC  @COUNT            COUNT-1
ARROWS CALL CLRFAC
       ST   @COUNT,@FAC1
       DCHE 100,@FAC
       BR   ARROW1
       DSUB 100,@FAC
       ST   49,V@28           Show it 1__
ARROW1 DCHE 9,@FAC
       BR   ARROW2
       DIV  10,@FAC
       ADD  >30,@FAC
       ST   @FAC,V@29         Show it _#_
       ADD  >30,@FAC1
       ST   @FAC1,V@30        Show it __#
       BR   ARROW3
ARROW2 ADD  >30,@FAC1
       ST   @FAC1,V@30
ARROW3 DST  >0081,@SCADD      Arrows location
       DST  >2580,@PAD4       Recall buffer
OKKEY  MOVE >0260,V*PAD4,V@>0080 Fill screen
NOKEY  ST   130,V*SCADD       Left arrow
       ST   131,V@11(@SCADD)  Right arrow
       SCAN
       CEQ  AID,@KEY          AID
       BR   NAID
       MOVE 768,V@0,V@>2000   Save screen
       CALL DMENU
YAID   SCAN                   Any key?
       BR   YAID              No.
       MOVE 768,V@>2000,V@0   Restore screen
WAID   SCAN                   Any key?
       BR   WAID
NAID   CEQ  CLEAR,@KEY        CLEAR
       BS   TSTKE2
       CEQ  PROCD,@KEY        PROCEED
       BS   ENTER0
       CEQ  REDO,@KEY         REDO
       BS   TSTKE2
BACK0  CEQ  BACK,@KEY         BACK
       BR   BEGIN0
       DCEQ 'DS',V@>100A      DS?   DISK ONLY?
       BS   TSTKE2
       CALL CLRBUF            Clear buffers and FAC
       DST  V@>1008,@FAC      Get length
       DCEQ 5,@FAC            DSK#. or SCS#. or WDS#.
       BS   BEGIN3
       DCHE 4,@FAC
       BR   BEGIN3
       CALL CLRBUF            Clear buffers and FAC
       DST  V@>1008,@FAC      Get length
BACK1  DDEC @FAC              Length -1
       CEQ  >2E,V@>1009(@FAC) .?
       BR   BACK1             No, keep searching
       DCHE 5,@FAC            DSK. or SCS. or WDS. or DSK#.
       BS   BEGIN3
BACK3  ST   BEGIN,@KEY
BEGIN0 CEQ  BEGIN,@KEY        BEGIN
       BR   FCTNUP
       CALL CLRFAC            Clear buffers and FAC
       DST  V@>1008,@FAC      Get length
       DCEQ 5,@FAC            DSK#. or SCS#. or WDS#.
       BS   BEGIN2
       DCLR @FAC              Clear FAC
BEGIN1 DINC @FAC              COUNT +1
       CEQ  >2E,V@>1009(@FAC) .?
       BR   BEGIN1            No, keep searching
       DCEQ 4,@FAC            DSK. Length?
       BS   BEGIN1            Yes, look for Volume.
BEGIN2 DINC @FAC              LENGTH+1
       DST  >0D0D,V@>1009(@FAC)
BEGIN3 DST  @FAC,V@>1008
       DADD 2,@FAC
       MOVE @FAC,V@>1008,V@>2255
       MOVE @FAC,V@>1008,V@>2400
       ST   >37,@XTOKEN
       B    OLDEA
FCTNUP CEQ  11,@KEY           FCTN UP?
       BS   UPKEY
       CEQ  'E',@KEY          E?
       BS   UPKEY
       CEQ  'e',@KEY          e?
       BS   UPKEY
       CEQ  10,@KEY           FCTN DOWN?
       BS   DKEY
       CEQ  'X',@KEY          X?
       BS   DKEY
       CEQ  'x',@KEY          x?
       BS   DKEY
       CEQ  8,@KEY            FCTN LEFT?
       BS   LKEY
       CEQ  'S',@KEY          S?
       BS   LKEY
       CEQ  's',@KEY          s?
       BS   LKEY
       CEQ  9,@KEY            FCTN RIGHT?
       BS   RKEY
       CEQ  'D',@KEY          D?
       BS   RKEY
       CEQ  'd',@KEY          d?
       BS   RKEY
       CEQ  ' ',@KEY          SPACE BAR
       BS   ENTER0
       CEQ  'A',@KEY          A?
       BS   ENTER0
       CEQ  'a',@KEY          a?
       BS   ENTER0
       CEQ  'G',@KEY          G?
       BS   ENTER0
       CEQ  'g',@KEY          g?
       BS   ENTER0
       CEQ  ENTER,@KEY        ENTER
       BS   ENTER0
       CEQ  '1',@KEY          1=EDITOR
       BR   NOKEY
ENTER0 CALL CLRBUF
ENTR   DST  V@>1008,@PAD6    Get length of device
       ST   >2E,V@>1009(@PAD6)
       MOVE @PAD6,V@>100A,V@>2402
       DST  @SCADD,@FAC2
       INC  @SCADE
ENTER1 INC  @FAC3             Index+1
       INC  @FAC1             Count+1
       CEQ  SPACE,V*FAC2      Space?
       BS   ENTER2            Yes
       CEQ  11,@FAC1          To long?
       BR   ENTER1
ENTER2 ST   ENTER,V*FAC2      cr
       DCEQ 'Di',V@16(@SCADD) Directory?
       BR   NODIR             No
       CEQ  'r',V@18(@SCADD)
       BR   NODIR
       DST  >2E0D,V*FAC2      .cr
       INC  @FAC              Count+1
NODIR  MOVE @FAC,V*SCADD,V@>100A(@PAD6)
       DADD @PAD6,@FAC
       MOVE @FAC,V@>100A,V@>2257
       DST  @FAC,V@>2255
       INC  @PAD7
       DST  @PAD6,V@>2400
       CALL CLOSE
       ST   >EA,@XTOKEN       Set flag
       CEQ  32,@KEY           SPACE BAR
       BS   XBPGM
       DCEQ 'Di',V@16(@SCADD) Directory?
       BR   PORVI
       CEQ  'r',V@18(@SCADD)
       BS   DIRECT
PORVI  CEQ  'P',V@16(@SCADD)  Program?
       BS   PRGRM
       CEQ  'V',V@20(@SCADD)  Variable?
       BR   DORF80
       CEQ  'I',V@16(@SCADD)  Internal?
       BR   DORF80
       DCEQ '25',V@24(@SCADD) Length 25_?
       BR   DORF80
       CEQ  '4',V@26(@SCADD)  Length 254?
       BS   XBINP
DORF80 DCEQ '80',V@25(@SCADD) Length 80?
       BR   DF80      
************************** Save as SOURCE *******
       DCLR @TMP
       ST   @TMP,V@>0D50      clear byte at setup
       MOVE 39,V@>0D50,V@>0D51 Ripple it
       ST   V@>2256,@TMP1     Get length byte
       DEC  @TMP1             Length-1
       ST   @TMP1,V@>0D50     Get length byte
       MOVE @TMP,V@>2257,V@>0D51 Save as SOURCE 
       CALL CLRXOP             CLEAR EDIT BUFFER
******************************
DF80   CEQ  'F',V@20(@SCADD)  Fixed?
       BS   LANDR
LEAASM CEQ  'A',@KEY          Assemble file
       BS   ASSEM
       CEQ  'G',@KEY          GPL Assemble file
       BS   ASSEM
       BR   MMENU
XBPGM  CEQ  'P',V@16(@SCADD)  Program?
       BS   XBINP
       CEQ  'V',V@20(@SCADD)  Variable?
       BR   MMENU
       CEQ  'I',V@16(@SCADD)  Internal?
       BR   MMENU
       DCEQ '25',V@24(@SCADD) Length 25_?
       BR   MMENU
       CEQ  '4',V@26(@SCADD)  Length 254?
       BS   XBINP
       BR   MMENU
UPKEY  DCEQ >0081,@SCADD      Top of screen?
       BS   GLESS             So scroll screen down
       DSUB 32,@SCADD         Up one.
       BR   GLESS2            Return
GLESS  DCEQ >2580,@PAD4      Start of buffer?
       BS   OKKEY             Yes
       DSUB >20,@PAD4         One more line down
GLESS2 BR   OKKEY
DKEY   CEQ  >20,V@1(@SCADD)   Blank line?
       BS   UPKEY
       DCEQ >02C1,@SCADD      Bottom of screen?
       BS   GMORE             So scroll screen up
       DADD 32,@SCADD         Down one.
       BR   OKKEY             No
GMORE  DCEQ @FREPTR,@PAD4      End of buffer?
       BS   OKKEY             Yes
       CEQ  >20,V@>00A2       Last line in buffer?
       BS   OKKEY             Yes
       DADD >20,@PAD4         One more line up
       BR   OKKEY
LKEY   ST   18,@BUFFR         Line Counter
LUPKEY DCEQ >0081,@SCADD      Top of screen?
       BS   LGLESS            So scroll screen down
       DSUB 32,@SCADD         Up one.
       BR   LGLES2            Return
LGLESS DCEQ >2580,@PAD4       Start of buffer?
       BS   LOKKEY            Yes
       DSUB >20,@PAD4         One more line down
LGLES2 BR   LOKKEY
LOKKEY CALL FLSCR
       DEC  @BUFFR            Line counter -1
       BR   LUPKEY            Continue Loop
       B    NOKEY             Done.
RKEY   ST   18,@BUFFR         Line Counter
RDKEY  CEQ  >20,V@1(@SCADD)   Blank line?
       BS   UPKEY
       DCEQ >02C1,@SCADD      Bottom of screen?
       BS   RGMORE            So scroll screen up
       DADD 32,@SCADD         Down one.
       BR   ROKKEY            No
RGMORE DCEQ @FREPTR,@PAD4      End of buffer?
       BS   ROKKEY            Yes
       CEQ  >20,V@>00A2       Last line in buffer?
       BS   ROKKEY            Yes
       DADD >20,@PAD4         One more line up
       BR   ROKKEY
ROKKEY CALL FLSCR
       DEC  @BUFFR            Line counter -1
       BR   RDKEY             Continue Loop
       B    NOKEY             Done.
FLSCR  MOVE >0260,V*PAD4,V@>0080 Fill screen
       ST   130,V*SCADD       Left arrow
       ST   131,V@11(@SCADD)  Right arrow
       RTN
CLRBUF ST   ENTER,V@>2257     Clear buffer
       MOVE 63,V@>2257,V@>2258
       MOVE 63,V@>2257,V@>2402
       CALL CLRFAC
       RTN
*
* PAB data
*
CATDAT BYTE 0,>D,8,>36,0,0,0,0,0
*
HALVE  BYTE >40,>02,0,0,0,0,0,0
*
* Screen - prints initial screen and disk info
*
SCREEN FMT
        ROW  0
        COL  2
        HTEX 'Directory=           Files000'
        ROW+ 1
        COL  2
        HTEX 'Free=           Used='
        ROW+ 1
        COL  2
        HTEX ' Filename  Size    Type     P'
        ROW+ 1
        COL  2
        HTEX '---------- ---- ----------- -'
       FEND
       CLR  @COUNT            Clear file counter
       CALL DISSTR            Get string into FAC
       CZ   @FAC1             Skip if zero length
       BS   CAT3
       FMT
        ROW 0
        COL 12
        HSTR 10,@FAC2
       FEND
CAT3   DADD @FAC,@SCADD       Go to next field
       DADD 19,@SCADD         Continue to last field
       DST  >28,@SCNADD        Set up screen addr
       DCEQ >4453,V@>100A     DSK?
       BR   CAT4              No, must be HARD
       CALL DISNUM            Display available DSK space
       B    CAT4A
CAT4   MOVE 8,V*SCADD,@ARG    Get Available space *2
       MOVE 8,G@HALVE,@FAC    Get divisor 
       XML  ROUND
       CALL DISNU1            Display available HARD space
* Display used space
CAT4A  MOVE 8,V*SCADD,@FAC    Get Available space
       DSUB 9,@SCADD          Point to formatted space
       MOVE 8,V*SCADD,@ARG    Move it to ARG
       XML  FSUB              Develop used value *2
       DST  >38,@SCNADD        Set up screen addr
       DCEQ >4453,V@>100A     DSK?
       BS   CAT4B             Yes, must be DISK
       MOVE 8,@FAC,@ARG       Get Unused space *2
       MOVE 8,G@HALVE,@FAC    Get divisor
       XML  FDIV
       XML  ROUND
CAT4B  CALL DISNU1            Display used space
       RTN                    Return
*
* Display one file on screen
*
FILNAM CALL DISSTR            Get string into FAC
       INC  @COUNT            FILE COUNT +1
       CZ   @FAC1             Skip display if zero
       BS   CAT5              length
       FMT                    Put disk name on screen
        ROW   23              .
        COL   02              .
        HSTR 10,@FAC2         .
       FEND                   .
CAT5   DADD @FAC,@SCADD       Go to next field
       DADD 10,@SCADD         Continue another field
       DCZ  V*SCADD           Time to get out if
       BS   FILNA1            zero file size
       DST  >2EA,@SCNADD       Set up screen address
       CALL DISNUM            Display file length
       DSUB 9,@SCADD          Back a field
       MOVE 8,V*SCADD,@FAC    Move it into FAC
       XML  CFI               Convert it to an int.
       CZ   @FAC              Non-negative?
       BS   CAT5A             YES! File not protected
       ST   @PAD2,V@>2FE      Put a 'Y' on screen
       DNEG @FAC              Make number positive
CAT5A  DEC  @FAC1             Adjust for CASE
       CASE @FAC1             Show file type
       BR   DF                .
       BR   DV                .
       BR   IF                .
       BR   IV                .
       BR   PR                .
       BR   DI
DF     FMT
        ROW   23
        COL   18
        HTEX 'Dis/Fix'
       FEND
       BR   CAT6
DV     FMT
        ROW   23
        COL   18
        HTEX 'Dis/Var'
       FEND
       BR   CAT6
IF     FMT
        ROW   23
        COL   18
        HTEX 'Int/Fix'
       FEND
       BR   CAT6
IV     FMT
        ROW   23
        COL   18
        HTEX 'Int/Var'
       FEND
       BR   CAT6
PR     FMT
        ROW   23
        COL   18
        HTEX 'Program'
       FEND
       BR   CAT7              Return
DI     FMT
        ROW    23
        COL    18
        HTEX 'Directory'
       FEND
       BR   CAT7
CAT6   DADD 18,@SCADD         Advavce two fields
       DST  >2F6,@SCNADD       Set up screen address
       CALL DISNUM            Display record length
CAT7   MOVE >1F,V@>02E0,V@0(@FREPTR)
       DADD >20,@FREPTR
 
*
* Scroll the screen
*
SCROLL MOVE >260,V@>A0,V@>80  Scroll screen
       ST   SPACE,V@>2E0      Clear last line
       MOVE >1F,V@>2E0,V@>2E1
       RTN                    Return
FILNA1 DCLR @TMPCNT            Clear a byte
       CZ   @TMPCNT            Set COND bit
       RTNC                   Return w/COND
* Display number subroutine
*  ENTER: Floating number in FAC for DISNU1
*         Screen address in SCNADD
*
DISNUM MOVE 8,V*SCADD,@FAC    Move FLP number to FAC
DISNU1 CLR  @FAC11            Indicate a free format
       CALL CNS               Convert FAC to a string
       DST  7,@TMP          Right justify number
       S    @FAC12,@TMP1
       DADD @TMP,@SCNADD
DISNU2 ST   *FAC11,V*SCNADD   Put a char on the screen
       DINC @SCNADD           Increment screen addr.
       INC  @FAC11            Increment FAC addr.
       DEC  @FAC12            Decrement string length count
       BR   DISNU2            Loop until done
       RTN                    Return to caller
*
* Prepare a VDP string for FORMAT statement
*  LEAVE: FAC has string length (word)
*         FAC2  has string
*         SCADD pointing to next string in record
*
DISSTR DST  >0836,@SCADD      Get buffer address
       CLR  @FAC              Clear MSB of FAC word
       ST   V*SCADD,@FAC1     Store disk name length
       DINC @SCADD            Point to string
       ST   >20,@FAC2         Clear out string space
       MOVE 9,@FAC2,@FAC3     .
       MOVE @FAC,V*SCADD,@FAC2 Move disk name into FAC
       RTN
***********************************************************
* ERRORS 
***********************************************************
GE8B0  CALL  EASCRN
GE8B3  CALL  GE8FC
       CHE   >08,@CODE
       BR    CHKERR
       SUB   >08,@CODE
       CH    >05,@CODE
       BS    GE8D4
       CALL  CLSALL
       CASE  @CODE
       BR    GE90F
       BR    GE908
       BR    GE928
       BR    GE92F
       BR    GE936
       BR    GE93D
GE8D4  CLOG  >20,@FLAG
       BR    GE767
       CLOG  >01,@FLAG2
       BR    LANDR
       CALL  CLSPAB
       BR    EDITOR
GE8E3  CALL  GE8FC
       CALL  EASCRN
       CEQ   >0F,@CODE
       BR    GE8F5
       CALL  ERRMSG
       DATA  ERRPNF  * ERROR PROGRAM NOT FOUND
       BR    GE949
GE8F5  CALL  ERRMSG
       DATA  ERRC
       BR    GE029
       CALL  GE8FC
       B     GE029
GE8FC  MOVE  1,G@VREGS,#1
GE907  RTN
GE908  CALL  WRNMSG
       DATA  CCRMSG  * WARNING CONTROL CHARACTERS REMOVED
       BR    GE8D4
GE90F  CALL  ERRMSG
       DATA  ERRMF   * ERROR MEMORY FULL
       BR    GE8D4
GE916  CALL  ERRMSG
       DATA  ERRPNF  * ERROR PROGRAM NOT FOUND
       BR    OLDEA
GE91D  CLOG  >08,@FLAG
       BR    GE9E2
GE9E2  CALL  ERRMSG
       DATA  ERRNME  * ERROR NO MEMORY EXPANSION
       EXIT
GE928  CALL  ERRMSG
       DATA  ERRIT   * ERROR ILLEGAL TAG
       BR    LANDR
GE92F  CALL  ERRMSG
       DATA  ERRCE   * CHECKSUM ERROR
       BR    LANDR
GE936  CALL  ERRMSG
       DATA  ERRDD   * ERROR DUPLICATE DEFINITION
       BR    LANDR
GE93D  CALL  ERRMSG
       DATA  ERRUR   * ERROR UNRESOLVED REFERENCE
       BR    LANDR
GE944  CALL  ERRMSG
       DATA  ERRNTL  * ERROR NAME TO LONG
GE949  DCZ   @FAC6
       BS    GE958
       ST    SPACE,V*FAC4
       MOVE  @FAC6,V*FAC4,V@1(@FAC4)
GE958  CALL  CLRMSG
       BR    GE848
CHKERR CZ    @DSKFLG           * Check Search flag
       BS    CHKER2           * Yes, normal error
       INC   @DSKFLG           * Drive # + 1
       CHE   58,@DSKFLG        * Last drive?
       BR    MYSRCH           * No, continue Search
CHKER2 ST    V@1(@PABPTR),@FAC4
       AND   >E0,@FAC4
       SRL   >05,@FAC4
       OR    >30,@FAC4
       AND   >1F,V@1(@PABPTR)
       CEQ   >35,@FAC4        Error Read past EOF
       BR    GE97A
       CALL  CLSALL
       CEQ   1,@LDFLAG
       BR    EDITOR           EDITOR
       CEQ   2,@LDFLAG
       BR    ASSEM            ASSEMBLER
GE97A  CALL  ERRMSG
       DATA  ERRIOC         * I O ERROR CODE
       CEQ   1,@LDFLAG
       BS    EDITOR
       CEQ   2,@LDFLAG
       BS    ASSEM
GE97F  CALL  CLSALL
       CLOG  >20,@FLAG
       BR    OLDEA
       CLOG  >01,@FLAG2
       BR    LANDR
       CLOG  >08,@FLAG2
       BR    OLDEA
       BR    EDITOR
CLSALL CALL  P1000
       CALL  CLSPAB
       DST   >1100,@PABPTR
       CALL  CLSPAB
       DST   >1200,@PABPTR
       CALL  CLSPAB
       DST   >1300,@PABPTR
       CALL  CLSPAB
       RTN
CLSPAB DST   @PABPTR,@VPAB
       DADD  >0009,@VPAB
       ST    >01,V*PABPTR
       CALL  DSRLNK
       BYTE  >08
       CLR   V@>0009(@PABPTR)
       RTN
WRNMSG CALL  CLRMSG
       MOVE  11,G@WARN,V@>02A2
       BR    GE9DA
ERRMSG CALL  CLRMSG
       MOVE  9,G@ERROR,V@>02A2
GE9DA  FETCH @FAC
       FETCH @FAC1
       CLR   @FAC2
       MOVE  1,G@0(@FAC),@FAC3
       MOVE  @FAC2,G@1(@FAC),V@>02C2
       DCEQ  ERRIOC,@FAC
       BR    GE9F8
       ST    @FAC4,V@>02D2
GE9F8  DCEQ  ERRC,@FAC
       BR    WENTER
       DSRL  >0004,@CODE
       SRL   >04,@CODE1
       CH    >09,@CODE
       BR    GEA12
       CH    >0F,@CODE
       BS    WENTER
       ADD   >07,@CODE
GEA12  CH    >09,@CODE1
       BR    GEA1F
       CH    >0F,@CODE1
       BS    WENTER
       ADD   >07,@CODE1
GEA1F  DADD  >3030,@CODE
       DST   @CODE,V@>02D0
*  Wait for ENTER
WENTER MOVE  23,G@PRESS,V@>02E2
GEA2E  SCAN
       BR    GEA2E
       CEQ   >0D,@KEY
       BR    GEA2E
       B     SETUP  cHANGED FROM RETURN
***************************************
CLRMSG ST    SPACE,V@>02A0
       MOVE  >005F,V@>02A0,V@>02A1
       RTN
********************************************
* INIT
*
BINIT2 DCEQ  >A55A,@>2000
       BS    GEBBD
BINIT3 CALL  EXPMEM
       ST    >03,@FAC
       ST    >6004,@>6004       * Set ROM3
       XML   >8B                * EAINIT
       BR    CLRXOP
GEBBD  RTN
*******************************
CLRFAC CLR   @FAC
       MOVE  7,@FAC,@FAC1
       RTN
*******************************
P1000  DST   >1000,@PABPTR
       RTN
*******************************
DEVICE CALL  EXPMEM               Clear expansion memory
       MOVE  128,V@>027F,V@>0280
       ST    @KEY,@PAD6           Save key
       FMT
       ROW   16
       COL   2
       HTEX  'Select DSK#.'
       FEND
       MOVE  5,V@>100F,V@>020E     EDIT1 or ASSM1
DEV1   SCAN                        KEY?
       BR    DEV1                  No.
       CEQ   SPACE,@KEY            SPACE BAR?
       BS    DEV4                  Yes
       CEQ   BACK,@KEY             BACK?
       BS    DEV3                  Yes
       ST    @KEY,V@>020C          Any other key SAVE
       ST    @KEY,V@>100D          Put into PAB
DEVNO  ST    @PAD6,@KEY            Restore old key
DEV2   CALL  PMSG                  PLEASE WAIT...
DEV3   RTN
DEV4   FMT
       ROW   16
       COL   2
       HTEX  'Example: WDS1.EA.'
       ROW   18
       COL   2
       HTEX  'FULL PATH?'
       FEND
       MOVE  5,V@>100F,V@>0213     EDIT1 or ASSM1
       DST   >0282,@CURADD
       CLR   @DSKFLG                Clear search flag
       OR    >04,@FLAG             Set return flag
       CALL  GETINP
       DST   @CURADD,@PAD
       SUB   >82,@PAD1
       ST    @PAD1,V@>1009
       MOVE  @PAD,V@>0282,V@>100A
       ST    >20,@FLAG
       B     DEVNO
**********************************************************
EADSR  DATA SEADSR
       DATA SETUP
       STRI 'EA'
SEADSR DATA XBDSR
       DATA SETUP
       STRI 'ea'
************************************
XBDSR  DATA SXBDSR
       DATA RXB
       STRI 'XB'
SXBDSR DATA BASIC
       DATA RXB
       STRI 'xb'
************************************
BASIC  DATA SBASIC
       DATA >216F
       STRI 'BASIC'
SBASIC DATA >0000
       DATA >216F
       STRI 'basic'
***********************************************************
C1     STRI  'DSK1.EDIT1'
C2     STRI  'DSK1.ASSM1'
C3     STRI  'DSK1.SOURCE'
C4     STRI  'DSK1.OBJECT'
C5     STRI  'DSK1.LIST'
C6     STRI  'L'
PAB    BYTE  >05,>00,>13,>80,>00,>00,>21,>00
DLEN   BYTE  >00,>0A
DDSK1  TEXT  'DSK1.'
DEDIT1 TEXT  'EDIT1'
DASSM1 TEXT  'ASSM1'
DUTIL1 TEXT  'UTIL1'
       BYTE  >0D
DLOAD  TEXT  'LOAD'
       BYTE  >0D
PAB80  BYTE  >00,>12,>10,>00,>50,>00,>00,>00,>00,>00
ERROR  TEXT  '* ERROR *'
OUTSCN TEXT  '* 72 NAMES SHOWN *'
PRESS  TEXT  'Press ENTER to continue'
WARN   TEXT  '* WARNING *'
ERRMF  STRI  'MEMORY FULL'
ERRIOC STRI  'I/O ERROR CODE'
ERRNME STRI  'NO MEMORY EXPANSION'
ERRNTL STRI  'NAME TOO LONG'
ERRC   STRI  'ERROR CODE'
CCRMSG STRI  'CONTROL CHARACTER REMOVED'
ERRIT  STRI  'ILLEGAL TAG'
ERRCE  STRI  'CHECKSUM ERROR'
ERRDD  STRI  'DUPLICATE DEFINITION'
ERRUR  STRI  'UNRESOLVED REFERENCE'
ERRPNF STRI  'PROGRAM NOT FOUND'
FPATH  TEXT  'PATH.NAME?'
PLEASE TEXT  'Please wait ...'
WDS1   TEXT  'WDS1.'
CURPAT BYTE  >FF,>FF,>FF,>FF,>FF,>FF,>FF,>FF
       BYTE  >FF,>FF,>FF,>FF,>FF,>FF,>FF,>FF
DARROW DATA  >0010,>18FC,>1810,>0000 * RIGHT ARROW
       DATA  >0020,>60FC,>6020,>0000 * LEFT ARROW
VREGS  BYTE  >E0,>00,>0E,>01,>06,>00
**********************************************************
* TI BASIC SUPPORT ROUTINES
**********************************************************
BASICS DATA  G6B47,G6B82           * INIT
       STRI  'INIT'
G6B47  DATA  G6B50,G6BD8           * LOAD
       STRI  'LOAD'
G6B50  DATA  G6B59,G6CF4           * LINK 
       STRI  'LINK'
G6B59  DATA  G6B62,G6C6F           * PEEK
       STRI  'PEEK'
G6B62  DATA  G6B6C,G6C6A           * PEEKV
       STRI  'PEEKV'
G6B6C  DATA  G6B76,G6BD3           * POKEV
       STRI  'POKEV'
G6B76  DATA  >0000,G6DFE           * CHARPAT
       STRI  'CHARPAT'
**********************************************************
* CALL INIT
**********************************************************
G6B82 OR    >08,@FLAG              ====
      DADD  >0005,@PGMPTR            token pointer
      CALL  BINIT3                  load 9900 subs
      BR    G6DED                   return
*                                   skip sub name
G6BBE CLR   @FAC                  -------------
      ST    V*PGMPTR,@FAC1           size
      DADD  @FAC,@PGMPTR
      DINC  @PGMPTR                  e o name
      XML   >1B                     next token
      CEQ   >B7,@XTOKEN
      BR    G6EF3                   not ( incor statement
      XML   >1B                     next token
      RTN
**********************************************************
* CALL POKEV
**********************************************************
G6BD3 OR    >01,@FLAG              =====
      BR    G6BDD                   load
G6BD8 DCLR  @FLAG                  ====
      OR    >08,@FLAG
**********************************************************
* CALL LOAD
**********************************************************
G6BDD CALL  G6BBE                   skip sub name
G6BE0 PARS  >B6                     address
      CEQ   >65,@FAC2
      BS    G6C29                   string: file
      XML   >12                     real->integer
      CEQ   >03,@ERCODE
      BS    G6F07                   number too big
      DST   @FAC,@PAD4           save adress
G6BF1 CEQ   >B3,@XTOKEN
      BR    G6DE8                   no , => exit
      XML   >1B                     get next token
      PARS  >B6                   * data
      CEQ   >65,@FAC2
      BR    G6C05
      DCZ   @FAC6                   string
      BS    G6C61                   empty: new addr
      BR    G6F11                   bad argument
G6C05 XML   >12                     real->int
      CEQ   >03,@ERCODE
      BS    G6F07                   number too big
      CLOG  >01,@FLAG
      BS    G6C17
      ST    @FAC1,V*PAD4           write to vdp
      BR    G6C24
G6C17 DSUB  PAD,@PAD4            write to cpu
      ST    @FAC1,@PAD(@PAD4)
      DADD  PAD,@PAD4
G6C24 DINC  @PAD4                  next addr
      B     G6BF1
G6C29 DCZ   @FAC6                   load file
      BS    G6C61                   empty: new addr
      CLOG  >01,@FLAG
      BR    G6F0C                   string-number err
      DST   @FAC6,@BYTES
      DADD  >005A,@BYTES
      XML   >17                     assign var
      CALL  BINIT2                  load 9900 subs
      CALL  GETSPACE                get space
      XML   >18                     pop value from stack
      CALL  VZERO                   clear 70 bytes
      CALL  PABNAM                  copy file name
      ST    >60,V@>0008(@PABPTR)    screen offset
      ST    >04,V@>0001(@PABPTR)    df input
      DADD  @PABPTR,@FAC6
      DADD  >000A,@FAC6
      DST   @FAC6,V@>0002(@PABPTR)  buffer
      BR    GE826
G6C61 CEQ   >B3,@XTOKEN
      BR    G6DE8                   no , => exit
      XML   >1B                     next token
      BR    G6BE0                   loop
**********************************************************
* CALL PEEKV
**********************************************************
G6C6A OR    >01,@FLAG              =====
      BR    G6C71                   peek
G6C6F DCLR  @FLAG                  ====
**********************************************************
* CALL PEEK
**********************************************************
G6C71 CALL  G6BBE                   skip sub name
G6C74 PARS  >B6                     address
      CEQ   >65,@FAC2
      BS    G6C98                   string
      XML   >12                     real->integer
      CEQ   >03,@ERCODE
      BS    G6F07                   number too big
      DST   @FAC,@PAD4           save address
      CEQ   >B3,@XTOKEN
      BR    G6DE8                   no , => exit
G6C8A XML   >1B                     get next token
      CEQ   >C7,@XTOKEN              data
      BR    G6CA5
      PARS  >B6                     'string'
      CEQ   >65,@FAC2
      BR    G6CA5
G6C98 DCZ   @FAC6                   string
      BR    G6F0C                   empty: err
      CEQ   >B3,@XTOKEN
      BR    G6DE8                   no , => exit
      XML   >1B                     next token
      BR    G6C74                   new address
G6CA5 CHE   >80,@XTOKEN
      BS    G6DE8                   instr => exit
      XML   >13                     get symbol addr
      XML   >14                     get symb value
      XML   >17                     put it on stack
      CLOG  >01,@FLAG
      BS    G6CBB
      ST    V*PAD4,@ARG1           read from vdp
      BR    G6CC8
G6CBB DSUB  PAD,@PAD4            read from cpu mem
      ST    @PAD(@PAD4),@ARG1
      DADD  PAD,@PAD4
G6CC8 CALL  G6DF6                   clear 4A-51
      CZ    @ARG1
      BS    G6CE8                   =0
      ST    >40,@FAC              exponent 0
      CLR   @ARG
      DIV   >64,@ARG
      ST    @ARG,@FAC1             div by 100
      ST    @ARG1,@FAC2             remainder
      CZ    @FAC1
      BR    G6CE6                   >100
      EX    @FAC1,@FAC2            result in 4C
      BR    G6CE8
G6CE6 INC   @FAC                  inc exponent
G6CE8 XML   >15                     assign variable
      CEQ   >B3,@XTOKEN
      BR    G6DE8                   no , => exit
      DINC  @PAD4                  next address
      B     G6C8A                   one more
*********************************************************
* CALL LINK
*********************************************************
G6CF4 OR    >08,@FLAG              ====
      CALL  G6BBE                   skip sub name
      CALL  EXPMEM                   check mem
      DCEQ  >A55A,@>2000
      BR    G6EEE                   prog not found
      OR    >08,@FLAG
      DST   @VSTACK,@SCADD          value stack ptr
      PARS  >B6                     parse program name
      CEQ   >65,@FAC2
      BR    G6F0C                   string-number err
      CH    >06,@FAC7
      BS    G6F11                   size > 6 bad argum
      XML   >17                     push value on stack
      CLR   @TMPCNT                  # of params
      DST   >9D0A,@TMP            >200A: list of params types
G6D1F CEQ   >B6,@XTOKEN
      BS    G6DC1                   char ) => start
      CEQ   >B3,@XTOKEN
      BR    G6EF3                   incorrect statement
      DST   @PGMPTR,@CODE           char , => param
      XML   >1B                     next token
      CHE   >80,@XTOKEN
      BS    G6D84                   instruction
      CALL  G6DF6                   clear 4A-51
      XML   >13                     get symbol addr
      CLOG  >40,V*FAC
      BR    G6D84
      CEQ   >B3,@XTOKEN
      BS    G6D9D                   next token is ,
      CEQ   >B6,@XTOKEN
      BS    G6D9D                   next token is )
      CEQ   >B7,@XTOKEN
      BS    G6D54                   next token is (
      CHE   >80,@XTOKEN
      BS    G6D84                   next token is an instruction
      BR    G6EF3                   incorrect statement
G6D54 XML   >1B                     get next token
      CEQ   >B6,@XTOKEN
      BS    G6D67                   it's )
      CEQ   >B3,@XTOKEN
      BS    G6D54                   it's ,
      DDEC  @PGMPTR                  back to previous token
      ST    >B7,@XTOKEN              make it a )
      BR    G6D9D
G6D67 XML   >1B                     get next token
      CLOG  >80,V*FAC
      BR    G6D76
      ST    >04,@PAD(@TMP)
      BR    G6D7B
G6D76 ST    >05,@PAD(@TMP)
G6D7B DST   @FAC,@FAC4
      DADD  >0006,@FAC4
      BR    G6DB4
G6D84 DST   @CODE,@PGMPTR           token pointer
      XML   >1B                     next token
      PARS  >B6
      CEQ   >65,@FAC2
      BR    G6D97
      ST    >01,@PAD(@TMP)      string
      BR    G6D9B
G6D97 CLR   @PAD(@TMP)          number
G6D9B BR    G6DB4
G6D9D XML   >14                     get symbol value
*PA
      CHE   >B8,@XTOKEN
      BS    G6D84                   token is & :loop
      CZ    @FAC2
      BR    G6DAF
      ST    >02,@PAD(@TMP)        numeric variable
      BR    G6DB4
G6DAF ST    >03,@PAD(@TMP)        string variable
G6DB4 INC   @TMPCNT
      CH    >10,@TMPCNT              max 10 param
      BS    G6F11                   bad argumemt
      DINC  @TMP
      XML   >17                     push on stack
      BR    G6D1F
*
G6DC1 ST    >20,@FAC              blank 4A-4E
      MOVE  >0005,@FAC,@FAC1
      MOVE  >0004,V@>000C(@SCADD),@PAD address of link name in VDP mem
      DCZ   @PAD2
      BS    GE88E                   none
G6DD4 MOVE  @PAD2,V*PAD,@FAC   copy name to scratch-pad
      DST   @PAD2,@FAC6            name length
      BR    GE88E
*---------------------------------------------------------
*
G6DDE DCH   @SCADD,@VSTACK
      BR    G6DE8
*
G6DE3 XML   >18                     pop from stack
      B     G6DDE
*                                   exit
G6DE8 CEQ   >B6,@XTOKEN              ----
      BR    G6EF3                   no ) incor statement
G6DED XML   >1B                     next token
      CZ    @XTOKEN
      BR    G6EF3                   incorrect statement
      CALL  RETURN                  00 ret to basic
*
G6DF6 CLR   @FAC                  clear >4A-51
      MOVE  >0007,@FAC,@FAC1
      RTN
***********************************************************
* CALL CHARPAT
***********************************************************
G6DFE CALL  G6BBE                   =======
G6E01 PARS  >B6                     skip sub name
      CEQ   >65,@FAC2
      BS    G6F0C                   string-number err
      XML   >12                     real->int
      CEQ   >03,@ERCODE
      BS    G6F07                   number too big
      DCGE  >0020,@FAC
      BR    G6F11                   bad arg if <32
      DCGT  >009F,@FAC
      BS    G6F11                   bad arg if >159
      DSLL  >0003,@FAC
      DST   >0300,@SCADD
      DADD  @FAC,@SCADD             address in vdp
      DST   >0010,@BYTES
      CALL  GETSPACE                get 16 bytes free
      DST   @PABPTR,@TMPCNT         save pointer
      ST    >08,@PAD4               8 bytes
G6E33 ST    V*SCADD,@PAD
      DSRL  >0004,@PAD              first nibble
      ADD   >30,@PAD                to ascii
      CGT   >39,@PAD
      BR    G6E46
      ADD   >07,@PAD                A-F
G6E46 SRL   >04,@PAD1               second nibble
      ADD   >30,@PAD1               to ascii
      CGT   >39,@PAD1
      BR    G6E54
      ADD   >07,@PAD1               A-F
G6E54 DST   @PAD,V*TMPCNT
G6E58 DINC  @SCADD                  next vdp byte
      DINCT @TMPCNT                  next 2 chars
      DEC   @PAD4
      BR    G6E33                   loop
      XML   >1B                     next token
      CHE   >80,@XTOKEN
      BS    G6EF3                   incorrect statement
      XML   >13                     get symbol addr
      XML   >14                     get symbol value
      XML   >17                     push it on stack
      CEQ   >65,@FAC2
      BR    G6F0C                   string-number err
      DST   >001C,@FAC              string exp flag
      DST   @PABPTR,@FAC4           vdp address
      DST   >0010,@FAC6             size
      XML   >15                     assign var
      CEQ   >B3,@XTOKEN
      BR    G6DE8                   no , => exit
      XML   >1B                     next token
      BR    G6E01                   one more char
**********************************************************
*                                   error handling
G6E88 DECT  @SUBSTK                 --------------
      CHE   >08,@CODE
      BR    G6F4D                   1-7: io error
      CHE   >0F,@CODE
      BS    G6E97
      CALL  CLSPAB                   8-14: close pab
G6E97 CH    >21,@CODE
      BS    G6F48                   >33: unknown
      SUB   >08,@CODE
      CASE  @CODE
      BR    G6ED5                   8
      BR    G6EF3                   9
      BR    G6EDA                   10
      BR    G6EDF                   11
      BR    G6EE4                   12
      BR    G6EE9                   13
      BR    G6EF3                   14
      BR    G6EEE                   15
      BR    G6EF3                   16
      BR    G6EF8                   17
      BR    G6EFD                   18
      BR    G6F02                   19
      BR    G6F07                   20
      BR    G6F0C                   21
      BR    G6F11                   22
      BR    G6F16                   23
      BR    G6F1B                   24
      BR    G6F20                   25
      BR    G6F25                   26
      BR    G6F2A                   27
      BR    G6F54                   28
      BR    G6F2F                   29
      BR    G6F34                   30
      BR    G6F39                   31
      BR    G6F3E                   32
      BR    G6ED5                   33
G6ED5 CALL  BERR                    error routine
      DATA  >2049                 * 33, 8: memory full
G6EDA CALL  BERR
      DATA  G6F59                 * 10: illegal tag
G6EDF CALL  BERR
      DATA  G6F65                 * 11: checksum error
G6EE4 CALL  BERR
      DATA  G6F74                 * 12: duplicate def
G6EE9 CALL  BERR
      DATA  G6F89                 * 13: unresolved ref
G6EEE CALL  BERR
      DATA  G6F9E                 * 15: prog not found
G6EF3 CALL  BERR
      DATA  >202C                 * 9,14,16: incorrect statement
G6EF8 CALL  BERR
      DATA  >2040                 * 17: bad name
G6EFD CALL  BERR
      DATA  >2055                 * 18: can't continue
G6F02 CALL  BERR
      DATA  >2064                 * 19: bad value
G6F07 CALL  BERR
      DATA  >206E                 * 20: number too big
G6F0C CALL  BERR
      DATA  >207D                 * 21: string number mismatch
G6F11 CALL  BERR
      DATA  >2094                 * 22: bad argument
G6F16 CALL  BERR
      DATA  >20A1                 * 23: bad subscript
G6F1B CALL  BERR
      DATA  >20AF                 * 24: name conflict
G6F20 CALL  BERR
      DATA  >20BD                 * 25: can't do that
G6F25 CALL  BERR
      DATA  >20D9                 * 26: bad line number
G6F2A CALL  BERR
      DATA  >20F9                 * 27: for-next error
G6F2F CALL  BERR
      DATA  >211D                 * 29: file error
G6F34 CALL  BERR
      DATA  >2128                 * 30: input error
G6F39 CALL  BERR
      DATA  >2134                 * 31: data error
G6F3E CALL  BERR
      DATA  >213F                 * 32: line too long
G6F43 CALL  BERR
      DATA  G6FB0                 * no mem expansion (called by G6922)
G6F48 CALL  BERR
      DATA  G6FC4                 * 33+: unknown err
G6F4D DST   @PABPTR,@PAD4
      DSUB  >0004,@PAD4
G6F54 CALL  BERR
      DATA  >2113                 * 1-7,28: i/o error
*
G6F59 BYTE  >0B,>A9,>AC,>AC,>A5,>A7,>A1,>AC
      BYTE  >80,>B4,>A1,>A7
*     'CHECKSUM ERROR'
G6F65 BYTE  >0E,>A3,>AB,>A5,>A3,>AB,>B3,>B5
      BYTE  >AD,>80,>A5,>B2,>B2,>AF,>B2
*     'DUPLICATE DEFINITION'
G6F74 BYTE  >14,>A4,>B5,>B0,>AC,>A9,>A3,>A1
      BYTE  >B4,>A5,>80,>A4,>A5,>A6,>A9,>AE
      BYTE  >A9,>B4,>A9,>AF,>AE
*     'UNRESOLVED REFERENCE'
G6F89 BYTE  >14,>B5,>AE,>B2,>A5,>B3,>AF,>AC
      BYTE  >B6,>A5,>A4,>80,>B2,>A5,>A6,>A5
      BYTE  >B2,>A5,>AE,>A3,>A5
*     'PROGRAM NOT FOUND'
G6F9E BYTE  >11,>B0,>B2,>AF,>A7,>B2,>A1,>AD
      BYTE  >80,>AE,>AF,>B4,>80,>A6,>AF,>B5
      BYTE  >AE,>A4
*     'NO MEMORY EXPANSION'
G6FB0 BYTE >13,>AE,>AF,>80,>AD,>A5,>AD,>AF
      BYTE >B2,>B9,>80,>A5,>B8,>B0,>A1,>AE
      BYTE >B3,>A9,>AF,>AE
*     'UNKNOWN ERROR CODE'
G6FC4 BYTE >12,>B5,>AE,>AB,>AE,>AF,>B7,>AE
      BYTE >80,>A5,>B2,>B2,>AF,>B2,>80,>A3
      BYTE >AF,>A4,>A5
*---------------------------------------------------------
*                                   load (c) def
G6FD7 CALL  EXPMEM                   ------------
      MOVE  >0008,G@G6FE2,V@>0850
      RTN
G6FE2 DATA  >3C42,>99A1,>A199,>423C
*
G6FEA DATA  0,0,0,0,0,0,0,0,0,0,0   * up to G6FFF
************************************************************
      END