    NAM CP68
***********************************************************
* Extracted from the book:
* "CP/68, an M6800 Operating System" by Jack E. Hemenway
*
* Scott LaBombard
* labomb@rochester.rr.com
* 02/29/2019
***********************************************************
*   NAM BIOS
*
* COPYRIGHT 1978 BY HEMENWAY ASSOCIATES INC
* BOSTON MASS. 02111
* ALL RIGHTS RESERVED
***********************************************************
*
* RCB   EQU'S
*
RCBEQT  EQU 0       EQUIPMENT TABLE ADDRESS
RCBGDT  EQU 2       GENERIC DEVICE TYPE
RCBSTA  EQU 5       STATUS
RCBDTT  EQU 6       DATA TRANSFER TYPE
RCBDBA  EQU 7       DATA BUFFER ADDRESS
*
* STATUS EQU'S*
*
BUSY    EQU $80     RCB BUSY STATUS
NTBUSY  EQU $7F     NOT BUSY (ANDED WITH STATUS)
*
        ENT EQTAB
        ENT PDTAB
*
*   BASEQU
DESCRA  EQU $20     DESCRIPTOR ADDRESS(2)
DESCRC  EQU $22     DESCRIPTOR COUNT
CUCHAR  EQU $23     CURRENT CHAR (2)
RC      EQU $25     TOKEN RETURN CODE
CLASS   EQU $26     TOKEN CLASS
VALUE   EQU $27     BIN VALUE/TRANSFER ADDRESS (2)
FCBCHN  EQU $29     TOP OF FCB CHAIN (2)
FRETAB  EQU $2B     DISK FREE SPACE POINTER (8)
BMEM    EQU $33     START OF TRANSIENT AREA(2)
EMEM    EQU $35     END OF TRANSIENT AREA (2)
CMEM    EQU $37     NEXT AVAIL TRANSIENT AREA (2)
BS      EQU $39     BACKSPACE CHAR
DL      EQU $3A     DELETE LINE CHAR
DP      EQU $3B     DEPTH; LINES/PAGE
DPCNT   EQU $3C     DEPTH TEMP
WD      EQU $3D     WIDTH; CHARS/LINE
NL      EQU $3E     NULL COUNT
TB      EQU $3F     TAB CHAR
DX      EQU $40     DUPLEX; FF=H, 00=F
EJ      EQU $41     EJECT COUNT
PS      EQU $42     PAUSE; 00=YES
ES      EQU $43     ESCAPE CHAR
LDP     EQU $44     DEPTH LINES/PAGE
LDPCNT  EQU $45     DEPTH TEMP
LWD     EQU $46     WIDTH CHARS/LINE
*
*
    ORG $100
*
* COLDSTART ENTRY TO THIS LOCATION
    EXT _CLDST
*
*
* SWIHDR SWI INPUT TO CP/68
* THIS IS THE ONLY ENTRY POINT TO BIOS
*
*
SWIHDR TSX          GET SP
    LDX 5,X         PT TO REQUEST CODE
    CLR A
    LDA B 0,X       GET REQUEST CODE
    CMP B #53       VALID RC?
    BLS *+5         YES
*
    JMP $E113       NO
*
    ASL B           *2
    ROL A
*
*
* CALCULATE THE ADDRESS OF THE
* APPROPRIATE PROCESSING ROUTINE
*
    BSR START
*
START TSX
    ADD B 1,X
    ADC A 0,X
*
    ADD B #DSPTAB
    ADC A #DSPTAB/256
*
    STA A 0,X
    STA B 1,X
    LDX 0,X
    ADD B 1,X
    ADC A 0,X
*
    TSX
    STA A 0,X
    STA B 1,X
*
    LDA A 2,X
    TAP
    LDX 0,X
*
    INS
    INS
*
    JSR 0,X         CALL PROCESSING ROUTINE
*
    TSX
    INC 6,X
    BNE *+4
*
    INC 5,X
    RTI         RETURN TO USER
*   USER REGISTER EQUATES:
*
UC  EQU 2
UB  EQU 3
UA  EQU 4
UXH EQU 5
UXL EQU 6
URH EQU 7
URL EQU 8
*
* PROCESSING ROUTINES:
*
* PSHALL: PUSHALL REGISTERS
*
_PSHAL DES
    DES
    DES
    DES
    DES
*
    LDA B #9
    TSX
*
PSHALS LDA A 5,X
    STA A 0,X
    INX
    DEC B
    BNE PSHALS
*
    LDA B #5
    TSX
*
PSHALC LDA A UC,X
    STA A UC+7,X
    INX
    DEC B
    BNE PSHALC
*
    RTS
*
*
* PULALL: PULL ALL REGISTERS
*
_PULAL TSX
    LDA B #5
*
PULAC LDA A UC+7,X
    STA A UC,X
    INX
    DEC B
    BNE PULAC
*
    LDA B #9
*
PULALS LDA A URL-5,X
    STA A URL,X
    DEX
    DEC B
    BNE PULALS
*
    INS
    INS
    INS
    INS
    INS
*
    RTS
*
*
* TXAB: TRANSFER X TO A,B
*
_TXAB TSX
    LDA A UXH,X
    LDA B UXL,X
*
STAB STA A UA,X
    STA B UB,X
*
    RTS
*
*
* TABX: TRANSFER A,B TO X
*
_TABX TSX
    LDA A UA,X
    STA A UXH,X
    LDA A UB,X
    STA A UXL,X
*
    RTS
*
*
* XABX: EXCHANGE A,B AND X
*
_XABX TSX
    LDA A UXH,X
    PSH A
    LDA B UXL,X
    BSR _TABX+1
    PUL A
    BRA STAB
*
*
* PSHX: PUSH X
*
_PSHX DES
    DES
    TSX
    LDA A #9
*
PSHXA LDA B 2,X
    STA B 0,X
    INX
    DEC A
    BNE PSHXA
*
    TSX
    LDA A UXH,X
    STA A UXH+4,X
    LDA A UXL,X
    STA A UXL+4,X
*
    RTS
*
*
* PULX: PULL X
*
_PULX   TSX
    LDA A UXH+4,X
    STA A UXH,X
    LDA A UXL+4,X
    STA A UXL,X
*
    LDA A #9
*
PULXA LDA B 8,X
    STA B 10,X
    DEX
    DEC A
    BNE PULXA
*
    INS
    INS
*
    RTS
*
*
* ADDXAB:   ADD X TO A,B
*
_ADXAB  TSX
    BSR _XABX+1
    BSR _ADABX+1
    BSR _XABX+1
*
*
* ADDABX:   ADD A,B TO X
*
_ADABX  TSX
    LDA A UB,X
    LDA B UA,X
*
ADDAB ADD A UXL,X
    STA A UXL,X
*
    ADC B UXH,X
*
STAUXH TPA
    STA B UXH,X
    TST UXL,X
*
TESTZ BEQ TESTZA
*
    AND A #$FB
*
TESTZA STA A UC,X
*
    RTS
*
*
* ADDAX:   ADD A TO X
*
_ADDAX TSX
    LDA A UA,X
*
ADDZ LDA B #00
    BRA ADDAB
*
*
* ADDBX:   ADD B TO X
*
_ADDBX TSX
    LDA A UB,X
    BRA ADDZ
*
*
* SUBXAB:   SUBTRACT X FORM A,B
*
_SBXAB TSX
    BSR _XABX+1
    BSR _SBABX+1
    BRA _XABX+1
*
*
* SUBABX:   SUBTRACT A,B FROM X
*
_SBABX TSX
    LDA B UXH,X
    LDA A UXL,X
*
    SUB A UB,X
    STA A UXL,X
*
    SBC B UA,X
    BRA STAUXH
*
*
* SUBAX:   SUBTRACT A FROM X
*
_SUBAX TSX
    LDA B UA,X
*
_SUB    LDA A UXL,X
    SBA
    STA A UXL,X
*
    LDA B UXH,X
    SBC B #00
    BRA STAUXH
*
*
* SUBBX: SUBTRACT B FROM X
*
_SUBBX TSX
    LDA B UB,X
    BRA _SUB
*
*
* INDEX:   X:=X+A*B
*
_INDEX BSR MPY8
    PSH B
    TAB
    PUL A
    TSX
    BRA ADDAB
*
*
* MUL8:   A,B:=A*B
*
_MUL8 BSR MPY8
    TSX
    STA B UB,X
    STA A UA,X
    TPA
    TST B
*
JMPTZ BRA TESTZ
*
*
* MUL16:   A,B,X:A,B*X
*
_MUL16 LDA A #16
    PSH A
    TSX
    CLR A
    CLR B
    ROR UXH+1,X
    ROR UXL+1,X
*
MUL16L BCC MUL16S
    ADD B UB+1,X
    ADC A UA+1,X
*
MUL16S ROR A
    ROR B
    ROR UXH+1,X
    ROR UXL+1,X
    DEC 0,X
    BNE MUL16L
*
    INS
    TSX
    STA B UB,X
    STA A UA,X
*
    TPA
    ORA B UXH,X
    ORA A UXL,X
*
    BRA JMPTZ
*
*
* MPY8:  A,B:=UA*UB
*
MPY8 LDA A #8
    PSH A
*
    CLR A
    TSX
    LDA B UB+3,X
    ROR B
*
MPY8L BCC MPY8S
*
    ADD A UA+3,X
*
MPY8S ROR A
    ROR B
    DEC 0,X
    BNE MPY8L
*
    INS
    RTS
*
* UNSIGNED 16-BIT DIVISION
*    A,B / X
*    QUOTIENT IN A,B
*    REMAINDER IN X
*
_DIV16 TSX
    LDA A UA,X
    LDA B UB,X
    LDX UXH,X       GET ARGUMENTS
    PSH B           STACK INPUTS
    PSH A
    PSHX
    DES
    TSX
    LDA A #1
    TST 1,X
    BMI DIV153
*
DIV151 INC A
    ASL 2,X
    ROL 1,X
    BMI DIV153
*
    CMP A #17
    BNE DIV151
*
DIV153 STA A 0,X
    LDA A 3,X
    LDA B 4,X
    CLR 3,X
    CLR 4,X
DIV163 SUB B 2,X
    SBC A 1,X
    BCC DIV165
*
    ADD B 2,X
    ADC A 1,X
    CLC
    BRA DIV167
*
DIV165 SEC
*
DIV167 ROL 4,X
    ROL 3,X
    LSR 1,X
    ROR 2,X
    DEC 0,X
    BNE DIV163
*
    INS             REPLACE STACK POSITION
    INS
    INS
    TSX
    INX             RECOVER POINTER POSITION
    INX
    STA A UXH,X     STORE REMAINDER
    STA B UXL,X
    PUL A
    PUL B
    STA A UA,X      STORE QUOTIENT
    STA B UB,X
    TPA
    TST B
    JMP TESTZ       FIX UP ZERO FLAG
*
*
* MOVC:     FROM,TO ON STACK
*           B=COUNT
*           ON RETURN B=COUNT
*                   TO=TO+COUNT
*                   FROM=FROM+COUNT
*
FROM    EQU 9
TO      EQU 11
*
_MOVC TSX
    LDA B UB,X      GET COUNT
*
MOVC1 LDX FROM,X
    LDA A 0,X       GET CHAR
*
    TSX
    LDX TO,X
    STA A 0,X       MOVE CHAR
*
    TSX
    DEC B           DONE?
    BEQ MOVC3       YES
*
    INC FROM+1,X
    BNE MOVC2
*
    INC FROM,X
*
MOVC2 INC TO+1,X
    BNE MOVC1
*
    INC TO,X
    BRA MOVC1
*
MOVC3 RTS
*
*
*
* CMPC:   COMPARE TWO STRINGS
*
*   PARM1,PARM2 ON STACK, B=COUNT
*   ON MATCH PARMS=NEXT CHAR POSITION
*   ON MISMATCH PARMS=LAST CHAR POSITION
*
PARM1   EQU 9
PARM2   EQU 11
*
_CMPC TSX
    LDA B UB,X
*
CMP0 LDX PARM1,X
    LDA A 0,X       GET A CHAR
    CMP A #$04      TERMINATOR?
    BEQ CDONE       YES
*
    TSX
    LDX PARM2,X
    PSH B
    LDA B 0,X
    CMP B #$04      TERMINATOR?
    PUL B
    BEQ CDONE       YES
*
    CMP A 0,X       MATCH?
    BNE CDONE       NO
*
    TSX
    INC PARM1+1,X
    BNE CMP1
*
    INC PARM1,X
*
CMP1 INC PARM2+1,X
    BNE CMP2
*
    INC PARM2,X
*
CMP2 DEC B          ALL DONE?
    BNE CMP0        NO
*
CDONE TSX
    TPA
    STA A UC,X      SET CC
    STA B UB,X      SET B
*
    RTS
* CMWC:     COMPARE STRINGS WITH WILD CHARACTERS
*           SAME PARMS AS CMPC
*
_CMWC TSX
    LDA B UB,X
*
CMW0 LDX PARM1,X
    LDA A 0,X
    CMP A #4        TERMINATOR?
    BEQ CDONE
*
    TSX
    LDX PARM2,X
    PSH B
    LDA B 0,X
    CMP B #4        TERMINATOR?
    PUL B
    BEQ CDONE       YES
*
    CMP A #'?       WILD CHARACTER?
    BEQ CMW1        YES
*
    CMP A 0,X       MATCH?
    BNE CDONE       NO
*
CMW1 TSX
    INC PARM1+1,X
    BNE *+4
*
    INC PARM1,X
*
    INC PARM2+1,X
    BNE *+4
*
    INC PARM2,X
*
    DEC B           DONE?
    BNE CMW0        NO
*
    BRA CDONE       YES
*
* MOVS:     MOVE A VARIABLE LENGTH STRING TERMINATED (04)
*           FROM, TO ON STACK
*           ON RETURN TO=TO+COUNT
*                   FROM=FROM+COUNT
*
*
_MOVS TSX
*
MOVS1 LDX FROM,X
    LDA A 0,X       GET CHARACTER
*
    TSX
    LDX TO,X
    STA A 0,X       MOVE CHARACTER
*
    TSX
    CMP A #04       DONE?
    BEQ MOVS3       YES
*
    INC FROM+1,X
    BNE MOVS2
*
    INC FROM,X
*
MOVS2 INC TO+1,X
    BNE MOVS1
*
    INC TO,X
    BRA MOVS1
*
MOVS3 RTS
*
* FMTS:  REFORMAT A FILE NAME
*
*       FROM, TO ON STACK
*       B=COUNT OF FROM STRING INCLUDING " "
*
*       B=RC= 00 UNAMBIG
*             01 AMBIG
*             02 BAD FILE NAME
*
*
*
_FMTS TSX
    LDA B UB,X      GET COUNT
    STA B UA,X      SAVE IN UA
    CMP B #12       NAME TOO LONG?
    BLS FMTSA       NO
*
* TOO MANY CHARACTERS
*
FMTS0 TSX
    LDA B #2        SET RC
    STA B UB,X        "
    RTS
*
* FORMAT "TO" STRING
*
FMTSA LDX TO,X      POINT TO "TO"
    LDA A #$20      BLANK
    LDA B #8
*
FMTSB STA A 0,X     STORE BLANK
    INX
    DEC B           DONE?
    BNE FMTSB       NO
*
    LDA A #'.
    STA A 0,X       STORE "."
    INX
    LDA B #3
    LDA A #$20      BLANK
*
FMTSC STA A 0,X     STORE BLANK
    INX
    DEC B           DONE?
    BNE FMTSC       NO
*
FMTS1 TSX
    CLR UB,X        SET DEFAULT RC
*
* FIND " "
*
    LDX FROM,X      POINT TO FROM STRING
    CLR B           CLEAR COUNT
*
FMTS2 LDA A 0,X     GET CHARACTER
    CMP A #'.
    BEQ FMTS3       FOUND
*
    INX
    INC B
    CMP B #9        NAME TO LONG?
    BNE FMTS2       NO
*
    BRA FMTS0       YES FORMAT ERROR
*
* FOUND "." CHECK EXT
*
FMTS3 INC B
    TSX
    LDA A UA,X      GET COUNT
    SBA             GET EXT COUNT
    STA A UA,X      SAVE
    BEQ FMTS0       NO EXT
*
    CMP A #3        TOO LONG?
    BHI FMTS0       YES
*
* EXT FIELD OK!
*
    LDX FROM,X      POINT TO FROM
    LDA A 0,X       GET FIRST CHAR OF NAME
    CMP A #'.       NO NAME?
    BEQ FMTS0       YES
*
    CMP A #'*       WILD CARD?
    BNE FMTS5       NO
*
* WILD CARD FILL WITH "?"
*
    TSX
    LDX TO,X        POINT TO "TO" STRING
    LDA B #8
    LDA A #'?
*
FMTS4 STA A 0,X     STORE "?"
    INX
    DEC B           DONE?
    BNE FMTS4       NO
*
* SET AMBIG RC
*
    TSX
    LDA A #1        RC
    STA A UB,X      STORE
*
* FIX POINTERS
*
    LDA A FROM+1,X
    ADD A #2
    STA A FROM+1,X
*
    LDA A FROM,X
    ADC A #00
    STA A FROM,X
*
    LDA A TO+1,X
    ADD A #8
    STA A TO+1,X
*
    LDA A TO,X
    ADC A #00
    STA A TO,X
*
    BRA FMTS6
*
* MOVE NAME FROM -> TO
*
FMTS5 LDA B #8
*
FMTS5A TSX
    LDX FROM,X
    LDA A 0,X       GET CHARACTER
    TSX
    INC FROM+1,X
    BNE *+4
*
    INC FROM,X
*
    LDX TO,X
    CMP A #'        DONE?
    BEQ FMTS5B      YES
*
    STA A 0,X       STORE CHAR
    TSX
    DEC B
    INC TO+1,X
    BNE *+4
*
    INC TO,X
*
    CMP A #'?       WC?
    BNE FMTS5A      NO
*
    LDA A #1        SET AMBIG RC
    TSX
    STA A UB,X
    BRA FMTS5A
*
FMTS5B TSX          FIX "TO" POINTER
    ADD B TO+1,X
    STA B TO+1,X
    LDA B TO,X
    ADC B #00
    STA B TO,X
*
*
*
* FROM -> EXT
* TO ->
*
* PROCESS EXT
*
FMTS6 TSX
    LDX FROM,X
    LDA A 0,X
    CMP A #'*       WILD CARD?
    BNE FMTS8       NO
*
* YES FILL EXT WITH "?"
*
    TSX
    LDX TO,X
    INX             SKIP OVER ". "
    LDA B #3
    LDA A #'?
*
FMTS7 STA A 0,X     STORE "?"
    INX
    DEC B
    BNE FMTS7
*
* SET AMBIG RC
*
    TSX
    LDA A #1
    STA A UB,X
    RTS             ALL DONE
*
*
* MOVE "FROM" EXT TO "TO" EXT
*
FMTS8 TSX
    INC TO+1,X      FIX TO POINTER
    BNE *+4
*
    INC TO,X
*
    LDA B UA,X      GET EXT COUNT
*
FMTS9 TSX
    LDX FROM,X
    LDA A 0,X
*
    TSX
    INC FROM+1,X
    BNE *+4
*
    INC FROM,X
*
    LDX TO,X
    STA A 0,X
*
    TSX
    INC TO+1,X
    BNE *+4
*
    INC TO,X
*
    CMP A #'?       WC?
    BNE FMTS10      NO
*
    LDA A #1        YES SET AMBIG RC
    STA A UB,X
*
FMTS10 DEC B
    BNE FMTS9
*
    RTS             ALL DONE
* RELATIVE ENTRY TABLE TO PROCESSING ROUTINES
*
DSPTAB  EQU *-START
*
*
    FDB *-_PSHAL*$FFFF  0
    FDB *-_PULAL*$FFFF  1
    FDB *-_TXAB*$FFFF   2
    FDB *-_TABX*$FFFF   3
    FDB *-_XABX*$FFFF   4
    FDB *-_PSHX*$FFFF   5
    FDB *-_PULX*$FFFF   6
    FDB *-_ADXAB*$FFFF  7
    FDB *-_ADABX*$FFFF  8
    FDB *-_ADDAX*$FFFF  9
    FDB *-_ADDBX*$FFFF  10
    FDB *-_SBXAB*$FFFF  11
    FDB *-_SBABX*$FFFF  12
    FDB *-_SUBAX*$FFFF  13
    FDB *-_SUBBX*$FFFF  14
    FDB *-_MUL8*$FFFF   15
    FDB *-_MUL16*$FFFF  16
    FDB *-_MOVC*$FFFF   17
    FDB *-_CMPC*$FFFF   18
    FDB *-_IOHDR*$FFFF  19
    FDB *-_OPEN*$FFFF   20
    FDB *-_CLOSE*$FFFF  21
    FDB *-_REWD*$FFFF   22
    FDB *-_OPEND*$FFFF  23
    FDB *-_READ*$FFFF   24
    FDB *-_WRITE*$FFFF  25
    FDB *-_GETDR*$FFFF  26
    FDB *-_PUTDR*$FFFF  27
    FDB *-_DELETE*$FFFF 28
    FDB *-_CHAIN*$FFFF  29
    FDB *-_PRTERR*$FFFF 30
    FDB *-_WRMST*$FFFF  31
    FDB *-_USR6*$FFFF   32
    FDB *-_USR7*$FFFF   33
    FDB *-_USR8*$FFFF   34
    FDB *-_USR9*$FFFF   35
    FDB *-_USR10*$FFFF  36
    FDB *-_LOADB*$FFFF  37
    FDB *-_LOADR*$FFFF  38
    FDB *-_USR1*$FFFF   39
    FDB *-_USR2*$FFFF   40
    FDB *-_USR3*$FFFF   41
    FDB *-_USR4*$FFFF   42
    FDB *-_USR5*$FFFF   43
    FDB *-_FMTFCB*$FFFF     44
    FDB *-_MOVS*$FFFF   45
    FDB *-_INDEX*$FFFF  46
    FDB *-_NXTOK*$FFFF  47
    FDB *-_GTCMD*$FFFF  48
    FDB *-_PRTMSG*$FFFF     49
    FDB *-_DIV16*$FFFF  50
    FDB *-_INTDK*$FFFF  51
    FDB *-_FMTS*$FFFF   52
    FDB *-_CMWC*$FFFF   53
*   EQUIPMENT TABLE:
*
EQTAB   EQU *
*
CONSOL FDB INLIN
    FDB OTLIN
    FDB $8008
*
PTRDR FDB INRDR
    FDB NULL
    FDB $8010
*
PTPCH FDB NULL
    FDB OTPCH
    FDB $8010
*
DISK FDB .RDSEC
    FDB .WTSEC
    FDB 0
*
LPTR FDB NULL
    FDB OTLPT
    FDB $8002
*
MTAPE FDB .MTIN
    FDB .MTOT
    FDB 0
*
TTYIO FDB INLIN
    FDB OTLIN
    FDB $8010
*
NULLIO FDB NULL
    FDB NULL
    FDB 0000
* PHYSICAL DEVICE TABLE:
*
PDTAB FCC 'CON'
    FDB CONSOL
    FDB CONSOL
*
    FCC 'PTR'
    FDB PTRDR
    FDB PTRDR
*
    FCC 'PTP'
    FDB PTPCH
    FDB PTPCH
*
    FCC 'DSK'
    FDB DISK
    FDB DISK
*
    FCC 'LPT'
    FDB LPTR
    FDB LPTR
*
    FCC 'MTA'
    FDB MTAPE
    FDB MTAPE
*
    FCC 'TTY'
    FDB TTYIO
    FDB TTYIO
*
    FCC 'NUL'
    FDB NULLIO
    FDB NULLIO
*
    FCB 0
* IOHDR: I/O HANDLER
*
_IOHDR TSX
    LDX UXH,X       GET RCB ADDR
    LDA A #BUSY
    STA A RCBSTA,X  INIT BUSY BIT
*
* SEARCH PDTAB FOR EQT
*
    JSR PDSRCH
    BCS IOHDRA      NOT FOUND
*
* FOUND ENTRY;  X=RCBADR; A,B=DRIVER ADR
*
    XABX            X:=DRIVERADR; A,B:=RCBADR
*
    JSR 0,X         CALL DRIVER
*
* ON RETURN X=RCBADR
*
IOHDRA LDA A #NTBUSY
    AND A RCBSTA,X
    STA A RCBSTA,X  TURN OFF BUSY BIT
*
    RTS
* SEARCH PDTAB FOR DEVICE
*
* X=RCBADR
*
PDSRCH PSHX         SAVE RCBADR
    INX             PT TO RCBGDT
    INX
*
    PSHX            SAVE PTR TO RCBGDT
*
    LDX #PDTAB      POINT TO PDTAB
*
PDSRCA PSHX         SAVE ON STACK
    LDA B #3        CHARS TO MATCH
    CMPC
    BEQ PDSRCB      MATCH!
*
* NOMATCH
*
    PULX            GET PD PTR
    ADDBX           POINT TO NEXT ENTRY
    INX
    INX
    INX
    INX
    TXAB            SAVE PD-PTR
    PULX            SKIP RCBGDT
    PULX            GET RCBADR
    PSHX            SAVE
    INX
    INX
    PSHX            SAVE RCBGDT
    TABX            RESTORE PD-PTR
    TST 0,X         END OF TABLE?
    BNE PDSRCA      NO
*
* NOT IN TABLE
*
    PULX            SKIP RCBGDT
    PULX            GET RCBADR
*
    SEC             SET RETURN FLAG
*
    LDA A #5        ERROR CODE
    AND A RCBSTA,X
    STA A RCBSTA,X
*
    RTS
*
* FOUND ENTRY
*
PDSRCB PULX         GET POINTER TO EQT
    LDX 0,X         GET ADDRESS OF EQT
    TXAB            SAVE IN A,B
    PULX            SKIP RCBGDT
    PULX            GET RCBADR
    PSHX            SAVE ON STACK
*
    STA A RCBEQT,X  SAVE EQT ADR
    STA B RCBEQT+1,X
*
    TST RCBDTT,X    INPUT OR OUTPUT?
    BPL *+6         INPUT
*
    ADD B #2        OUTPUT, POINT TO OUTPUT DRIVER
    ADC A #00
*
    TABX
    LDX 0,X         GET DRIVER ADDRESS
    TXAB            SAVE IN A,B
    PULX            GET RCBADR
    CLC             SET RETURN FLAG
*
    RTS
* NULL IE BIT BUCKET
*
NULL XABX           DO NOTHING
    RTS
* INLIN: INPUT A LINE FROM THE CONSOLE
*
* A,B=RCBADR
*
* OBEYS TTYSET PARAMATERS
*
INLIN TABX
*
INLIN1 PSHX         SAVE RCBADR
    LDX RCBDBA,X    GET BUFFER ADDRESS
*
    LDA A #'.       ISSUE PROMPT
    JSR OUTCON
*
INLIN2 JSR INCON    GET A CHARACTER
    CMP A #$0A      LF?
    BEQ INLIN2      YES
*
    TST DX          HALF-DUPLEX?
    BNE *+5         NO
*
    JSR OUTCON      ECHO
    CMP A DL        DELETE LINE?
    BNE INLIN3      NO
*
    PULX            YES, GET RCBADR
    BRA INLIN1
*
INLIN3 CMP A BS     BACK SPACE
    BNE INLIN4      NO
*
    TXAB            YES, SAVE BUFFER PTR
    PULX            GET RCBADR
*
    CMP A RCBDBA,X  AT START OF BUFFER?
    BNE *+6         NO
*
    CMP B RCBDBA+1,X
    BEQ INLIN5      YES
*
    SUB B #1        BACK UP PTR
    SBC A #00
*
INLIN5 PSHX         SAVE RCBADR
    TABX            X POINT TO BUFFER
    BRA INLIN2
*
INLIN4 STA A 0,X    STORE CHAR
    INX             BUMP BUFFER POINTER
    CMP A #$0D      CR?
    BNE INLIN2      NO
*
INLIN6 LDA A #$0A   LF
    JSR OUTCON
*
    PULX            GET RCBADR
    RTS
* OTLIN: OUTPUT A LINE TO CONSOLE
*
* A,B=RCBADR
*
OTLIN TABX          X:=RCBADR
    PSHX            SAVE
*
    LDX RCBDBA,X    GET BUFFER ADDRESS
    LDA B WD        GET CHARS/LINE
*
OTLIN1 LDA A 0,X    GET A CHAR
    CMP A #$04      END-STRING?
    BEQ OTLIN8      YES, DONE
*
    JSR OUTCON      SEND IT
    INX
    DEC B           FULL LINE?
    BNE OTLINC      NO
*
    LDA A #$0D      CR
    JSR OUTCON
    LDA A #$0A      LF
    JSR OUTCON
    LDA A #00
    LDA B NL        NULLS?
    BEQ OTLINB      NO
*
OTLINA JSR OUTCON   NULL
    DEC B
    BNE OTLINA
*
OTLINB LDA B WD     GET LINE WIDTH
*
OTLINC DEX          POINT TO LAST CHAR
    LDA A 0,X
    INX             RESET POINTER
*
    CMP A #$0D      CR?
    BNE OTLIN1      NO
*
    LDA A #$0A      LF
    JSR OUTCON
*
    LDA A #00       NULL
    LDA B NL        NULLS?
    BEQ OTLIN3      NO
*
OTLIN2 JSR OUTCON
    DEC B
    BNE OTLIN2
*
OTLIN3 TST DP       PAGING ON?
    BEQ OTLIN7      NO
*
    DEC DPCNT       PAGE?
    BNE OTLIN7      NO
*
    LDA A DP        RESET DPCNT
    STA A DPCNT
*
    TST PS          PAUSE?
    BNE OTLIN5      NO
*
OTLIN4 JSR INCON    GET A CHAR
    CMP A ES        ESCAPE?
    BNE OTLIN4      NO
*
OTLIN5 LDA B EJ     GET EJECT COUNT
    BEQ OTLIN7      NO EJECTS
*
OTLIN6 LDA A #$0A   LF
    JSR OUTCON
    DEC B           DONE?
    BNE OTLIN6      NO
*
OTLIN7 PULX         GET RCBADR
    PSHX            RESTACK
    LDX RCBEQT,X    GET EQT ADDRESS
    LDX 4,X         GET PHYSICAL ADDRESS
*
    LDA A 0,X       GET STATUS
    ASR A
    BCC OTLIN8      NO BREAK
*
    LDA A 1,X       READ DATA
    JSR INCON       WAIT FOR ANY INPUT
*
OTLIN8 PULX         GET RCBADR
*
    RTS
* INCON: GET A CHAR FROM THE CONSOLE
* X:=BUFFER ADDRESS
* A=CHAR PARITY STRIPPED
*
INCON PSHX          SAVE BUFFER PTR
    TSX
    LDX 4,X         GET RCBADR
    LDX RCBEQT,X    GET EQT ADDRESS
    LDX 4,X         GET PHYSICAL ADDR
*
INCON1 LDA A 0,X    GET STAT
    ASR A
    BCC INCON1      NOT READY
*
    LDA A 1,X       GET CHAR
    AND A #$7F      STRIP PARITY
*
    PULX            GET BUFFER ADDR
*
    RTS
* OUTPUT A CHAR TO CONSOLE
* X:=BUFFER ADDRESS; CHAR IN A
*
OUTCON PSHX         SAVE BUFFER ADDRESS
    TSX
    LDX 4,X         GET RCBADR
    LDX RCBEQT,X    GET EQT ADDR
    LDX 4,X         GET PHYSICAL ADDR
    PSH B
*
OUTCO1 LDA B 0,X    GET STATUS
    ASR B
    ASR B
    BCC OUTCO1      NOT READY
*
    STA A 1,X       SEND CHAR
    PUL B
    PULX            GET BUFFER ADDR
*
    RTS
* READ A LINE FROM PAPER TAPE READER
*
* A,B=RCBADR
*
INRDR TABX          X:=RCBADR
    PSHX            STACK
    LDX RCBDBA,X    GET BUFFER ADDRESS
*
    LDA A #$11      X-ON
    JSR OUTPCH
*
*
INRD1 JSR RDRIN     OET A CHAR
    CMP A #$0A      LF?
    BEQ INRD1       YES
*
    CMP A #$00      NULL?
    BEQ INRD1       YES
*
    STA A 0,X
    INX
    CMP A #$0D      CR?
    BNE INRD1       NO
*
INRD2 LDA A #$13    X-OFF
    JSR OUTPCH
*
    PULX            GET RCBADR
*
    RTS
* READ A CHAR FROM PAPER TAPE READER
*
* X:=BUFFER PTR RETURN IN A
*
RDRIN PSHX          SAVE BUFFER ADDR
    TSX
    LDX 4,X         GET RCBADR
    LDX RCBEQT,X    GET EQT ADDR
    LDX 4,X         GET PHYSICAL ADDRESS
*
RDRIN1 LDA A 0,X
    ASR A
    BCC RDRIN1      NOT READY
*
    LDA A 1,X       GET BYTE
    PULX            GET BUFFER PTR
*
    RTS
* PUNCH A LINE OF PAPER TAPE
*  WITH NULLS BETWEEN LINES
* A,B=RCBADR
*
OTPCH TABX          X:=RCBADR
    PSHX            STACK RCBADR
    LDX RCBDBA,X    GET BUFFER ADDRESS
*
OTPCH1 LDA A 0,X    GET A CHAR
    INX
    JSR OUTPCH
    CMP A #$0D      CR?
    BNE OTPCH1      NO
*
    LDA A #$0A      LF
    JSR OUTPCH
*
    LDA B #4
*
OTPCH3 LDA A #00    NULLS
    JSR OUTPCH
    DEC B
    BNE OTPCH3      NOT DONE
*
    PULX            RESTORE RCBADR
    RTS
* PUNCH A CHARACTER ON PUNCH
* X=BUFFER POINTER
*
OUTPCH PSHX         SAVE BUFFER PTR
    TSX
    LDX 4,X         GET RCBADR
    LDX RCBEQT,X    GET EQT ADR
    LDX 4,X         GET PHYSICAL ADDR
    PSH B
*
OUTPC1 LDA B 0,X    GET STATUS
    ASR B
    ASR B
    BCC OUTPC1      NOT READY
*
    STA A 1,X       SEND BYTE
    PUL B
    PULX            GET BUFFER PTR
*
    RTS
* OUTPUT A LINE TO PRINTER
* A,B=RCBADR
*
OTLPT TABX          X:=RCBADR
    PSHX            STACK
    LDX RCBDBA,X    GET BUFFER ADDRESS
    LDA B LWD       GET CHARS/LINE
*
OTLPT1 LDA A 0,X    GET A CHAR
    INX
    JSR OUTLPT      PRINT
    DEC B           FULL LINE?
    BNE OTLPT2      NO
*
    LDA A #$0D      CR
    JSR OUTLPT
    LDA A #$0A      LF
    JSR OUTLPT
    LDA B LWD       GET CHARS/LINE
*
OTLPT2 DEX
    LDA A 0,X
    INX
    CMP A #$0C      FF ?
    BNE OTLP3       NO
*
    PSH B
    LDA B LDP       RESET LINES/PAGE
    STA B LDPCNT
    PUL B
*
OTLP3 CMP A #$0D    CR?
    BNE OTLPT1      NO
*
    LDA A #$0A      LF
    JSR OUTLPT
    DEC LDPCNT      PAGE?
    BNE OTLPT4      NO
*
    LDA B LDP       INIT LDPCNT
    STA B LDPCNT
*
    LDA A #$0C
    JSR OUTLPT
*
OTLPT4 PULX         GET RCBADR
*
    RTS
* PRINT A CHAR ON LINE PRINTER
*
* X=BUFFER PTR
*
OUTLPT PSHX         SAVE BUFFER PTR
    TSX
    LDX 4,X         GET RCBADR
    LDX RCBEQT,X    GET EQT ADDR
    LDX 4,X         GET PHYSICAL ADDR
    PSH B
*
    LDA B 0,X       CLEAR ACK
    STA A 0,X       OUTPUT
    LDA B 1,X       ACK?
    BPL *-2         NO
*
    PUL B           YES
    PULX
    RTS
* READ A SINGLE SECTOR
* A, B=RCBADR
*
    EXT .RDSEC
*
* WRITE A SINGLE SECTOR
* A, B=RCBADR
*
    EXT .WTSEC
*
* READ A TAPE BLOCK
* A, B=RCBADR
*
    EXT .MTIN
*
* WRITE A TAPE BLOCK
* A, B=RCBADR
*
    EXT .MTOT
*
*
    EXT _OPEN       OPEN SEQUENTIAL FILE
*
    EXT _CLOSE      CLOSE SEQUENTIAL FILE
*
    EXT _REWD       REWIND SEQUENTIAL FILE
*
    EXT _OPEND      OPEN DIRECTORY
*
    EXT _READ       READ A SEQUENTIAL FILE
*
    EXT _WRITE      WRITE A SEQUENTIAL FILE
*
    EXT _GETDR      GET A DIRECTORY ENTRY
*
    EXT _PUTDR      WRITE A DIRECTORY ENTRY
*
    EXT _DELETE     DELETE A FILE
*
    EXT _CHAIN      CHAIN A PROGRAM FILE
*
    EXT _PRTERR     PRINT AN ERROR MESSAGE
*
    EXT _WRMST      WARM START ENTRY
*
    EXT _USR6       USER DEFINED 6
*
    EXT _USR7       USER DEFINED 7
*
    EXT _USR8       USER DEFINED 8
*
    EXT _USR9       USER DEFINED 9
*
    EXT _USR10      USER DEFINED 10
*
    EXT _LOADB      LOAD A BINARY FILE
*
    EXT _LOADR      LOAD A RELOCATABLE FILE
*
    EXT _NXTOK      PARSE A COMMAND LINE
*
    EXT _GTCMD      GET A COMMAND LINE (CALLS @NXTOK)
*
    EXT _PRTMSG     PRINT AN ERROR MESSAGE
*
    EXT _INTDK      INITIALIZE DISK SYSTEM
*
    EXT _USR1       USER DEFINED 1
*
    EXT _USR2       USER DEFINED 2
*
    EXT _USR3       USER DEFINED 3
*
    EXT _USR4       USER DEFINED 4
*
    EXT _USR5       USER DEFINED 5
*
    EXT _FMTFCB

***********************************************************
*   NAM CLI
*
* COMMAND LINE INTERPRETER
* COPYRIGHT 1978 BY HEMENWAY ASSOCIATES INC
* BOSTON MASS. 02111
* ALL RIGHTS RESERVED
***********************************************************

*
* COLD START ENTRY POINT
*
_CLDST JMP COLDST
*
* WARM START ENTRY POINT
*
_WRMST JMP WARMST
*
    EXT EQTAB
    EXT PDTAB
*
    ENT _CLDST
    ENT _WRMST
    ENT _NXTOK
    ENT _PRTMSG
    ENT _PRTERR
    ENT _GTCMD
    ENT _LOADB
    ENT _CHAIN
    ENT _DELETE
    ENT _FMTFCB
    ENT CVHB
    ENT CVDB
    ENT SEMPTY
    ENT SFILE
    ENT SYSFCB
*
* BLOCK ADDRESSING DEFINITIONS
*
*   FCBDEF
FCBEQT  EQU 0           EQUIPMENT TABLE ADDRESS
FCBGDT  EQU 2           GENERIC DEVICE TYPE
FCBSTA  EQU 5           STATUS
FCBDTT  EQU 6           DATA TRANSFER TYPE
FCBDBA  EQU 7           DATA BUFFER ADDRESS
FCBDRV  EQU 9           DRIVE NUMBER
FCBTRK  EQU 10          TRACK NUMBER
FCBSCT  EQU 11          SECTOR NUMBER
FCBFWD  EQU 12          FWD LINK TRACK/SECTOR
FCBBAK  EQU 14          BACK LINK TRACK/SECTOR
FCBNAM  EQU 16          FILE NAME (8.3+EOT=13))
FCBTYP  EQU 29          FILE TYPE
FCBACS  EQU 30          FILE ACCESS CODE
FCBFTS  EQU 31          FIRST TRACK/SECTOR
FCBLTS  EQU 33          LAST TRACK/SECTOR
FCBNMS  EQU 35          NUMBER OF SECTORS
FCBNFB  EQU 37          NEXT FCB IN ACTIVE CHAIN
FCBIND  EQU 39          INDEX INTO DATA BUFFER
FCBSCF  EQU 41          SPACE COMPRESSION FLAG
*   FIBDEF
FIBNAM  EQU 0           FILE NAME (8.3 + EOT=13)
FIBTYP  EQU 13          FILE TYPE
FIBACS  EQU 14          FILE ACCESS CODE
FIBFTS  EQU 15          FIRST TRACK/SECTOR
FIBLTS  EQU 17          LAST TRACK/SECTOR
FIBNMS  EQU 19          NUMBER OF SECTORS
*
* DISK ATTRIBUTES
*
SECSIZ  EQU 128         128 BYTES/SECTOR
*
* SYSTEM FILE-CONTROL BLOCK
*
SYSFCB  RMB 2
        FCC 'DSK'
        RMB 2
        FDB BUFFER
        RMB 33
*
BUFFER  RMB SECSIZ      DATA SPACE
*
* STACK SPACE FOR SYSTEM
*
        RMB 256
STACK   RMB 1
* COMMAND TABLE
*
CMDTAB  FCC 'DIR'       DIRECTORY
    FDB DIRCMD
*
    FCC 'PIP'           PERIPHERAL INTERCHANGE PROGRAM
    FDB PIPCMD
*
    FCC 'REN'           RENAME
    FDB RENCMD
*
    FCC 'DEL'           DELETE
    FDB DELCMD
*
    FCC 'SAV'           SAVE
    FDB SAVCMD
*
    FCC 'ASS'           ASSIGN
    FDB ASNCMD
*
    FCC 'LOA'           LOAD
    FDB LODCMD
*
    FCC 'JUM'           JUMP
    FDB JMPCMD
*
    FCC 'INI'           INITIALIZE
    FDB INICMD
*
    FCC 'EXI'           EXIT
    FDB $E0E3           MONITOR
*
    FCC 'SEC'           SECURITY
    FDB SECCMD
*
    FCC 'SET'           SETCON
    FDB SETCMD
*
    FCC 'STA'           STATUS
    FDB STACMD
*
    FCC 'BOO'           BOOTSTRAP
    FDB BOOTCD
*
    FCC 'LIN'           LINK
    FDB LNKCMD
*
    FCC 'SUB'           SUBMIT
    FDB SUBCMD
*
    FCB 00              END OF TABLE
* CHARACTER TABLE
*
CHRTAB  FCB $00         SPACE
    FCB $00             !
    FCB $00             "
    FCB $00             #
    FCB $04             $
    FCB $00             %
    FCB $00             &
    FCB $00             '
    FCB $00             (
    FCB $00             )
    FCB $81             *
    FCB $04             +
    FCB $04             ,
    FCB $04             -
    FCB $04             .
    FCB $04             /
    FCB $42             0
    FCB $42             1
    FCB $42             2
    FCB $42             3
    FCB $42             4
    FCB $42             5
    FCB $42             6
    FCB $42             7
    FCB $42             8
    FCB $42             9
    FCB $04             :
    FCB $04             ;
    FCB $00             <
    FCB $04             =
    FCB $00             >
    FCB $81             ?
    FCB $00             @
    FCB $82             A
    FCB $82             B
    FCB $82             C
    FCB $82             D
    FCB $82             E
    FCB $82             F
    FCB $80             G
    FCB $80             H
    FCB $80             I
    FCB $80             J
    FCB $80             K
    FCB $80             L
    FCB $80             M
    FCB $80             N
    FCB $80             O
    FCB $80             P
    FCB $80             Q
    FCB $80             R
    FCB $80             S
    FCB $80             T
    FCB $80             U
    FCB $80             V
    FCB $80             W
    FCB $80             X
    FCB $80             Y
    FCB $80             Z
    FCB $04             [
    FCB $00             \
    FCB $04             ]
    FCB $00             CAROT
    FCB $00             UNDERLINE
CONBUF  RMB 80          CONSOLE BUFFER
CONRCB  RMB 11          CONSOLE RCB
*
COLDST LDS #STACK       INITIALIZE STACK POINTER
    CLR SUBFLG          INIT. 'SUBMIT' FLAG
    LDX >EQTAB+1        POINT TO EQTAB
    LDA B #4            POINT TO CONSOLE ENTRY
    ADDBX
    LDX 0,X             GET ACIA ADDRESS
    LDA A #3
    STA A 0,X           RESET ACIA
    LDA A #$15
    STA A 0,X           INIT ACIA
*
    LDX >EQTAB+1        POINT TO EQTAB
    LDA B #40           POINT TO TTY ENTRY
    ADDBX
    LDX 0,X             GET ACIA ADDRESS
    LDA A #3
    STA A 0,X           RESET ACIA
    LDA A #1
    STA A 0,X           INIT ACIA
*
    LDX >EQTAB+1        POINT TO EQTAB
    LDA B #28           POINT TO LPT ENTRY
    ADDBX
    LDX 0,X             GET PIA ADDRESS
    LDA A #$FF
    STA A 0,X           DDRB:=OUTPUT
    LDA A #$2C
    STA A 1,X           INIT PIA
*
    INTDK               INITIALIZE DISK SYSTEM
*
* INIT CONSOLE RCB
*
    LDX #CONRCB
    LDA A #'C
    STA A RCBGDT,X
    LDA A #'0
    STA A RCBGDT+1,X
    LDA A #'N
    STA A RCBGDT+2,X
*
    LDX #CRLF           ISSUE A CR,LF
    PRTMSG
    LDX #BANNER         PRINT HEADLINE
    PRTMSG
    LDX #0              INIT. ACTIVE FCB CHAIN
    STX FCBCHN
    BRA WARM3           NOW PROCESS COMMANDS
*
CRLF FDB $0A0D          LF,CR
BANNER FCB $0A
    FCC 'HEMENWAY ASSOCIATES CP/68-1.0'
    FDB $0A0D
*
WARMST LDS #STACK       REINIT STACK POINTER
    CLR SUBFLG          INIT. 'SUBMIT' FLAG
WARM1 LDX FCBCHN        ANY ACTIVE FCBS?
    BEQ WARM3           NO
*
* CLOSE ALL ACTIVE (OPEN) FCBS
*
WARM2 CLOSE
    LDX FCBNFB,X    POINT TO NEXT FCB
    BNE WARM2
*
WARM3 LDX #0
    STX FRETAB      INIT. FREE-SPACE TABLE
    STX FRETAB+2    4 DRIVES
    STX FRETAB+4
    STX FRETAB+6
*
CLI0 GTCMD          GET COMMAND
    LDA B RC        CHECK RC
    CMP B #1        UNAMBIG. NAME?
    BEQ CLI2        YES
*
    CMP B #3        NUMBER?
    BEQ TFILE       IF SO, FILENAME
*
CLI1 LDX #FORMAT    NO
    PRTMSG          PRINT ERROR
    BRA CLI0
*
* LOOK UP COMMAND
*
CLI2 LDX DESCRA
    PSHX            STACK PARM
    LDX #CMDTAB
*
CMDSRA PSHX         STACK PARM
    LDA B #3        COUNT OF THREE
    CMPC
    BEQ CMDSRB      MATCH
*
* NO MATCH
*
    PULX            GET CMDTAB PTR
    ADDBX           POINT TO NEXT ENTRY
    INX
    INX
    TXAB            SAVE PTR TO CMDTAB
    PULX            GET DESCRA
    LDX DESCRA
    PSHX            STACK PARM
    TABX            RESTORE CMDTAB PTR
    TST 0,X         END OF TABLE?
    BNE CMDSRA      NO
*
* NOT IN TABLE
*
    PULX            SKIP DESCRA PARM
*
* PROCESS AS A TRANSIENT COMMAND FILE-NAME
*
TFILE LDX DESCRA
    STX CUCHAR      BACK UP ONE TOKEN ON CLI
    JSR LODCMD      TRY TO LOAD TRANSIENT
    LDX #SAVFCB
    TST FCBSTA,X    GOOD LOAD?
    BNE WARM3       IF NOT, QUIT
*
    LDX VALUE       HAVE TRANSFER ADDRESS?
    BEQ WARM3       IF NOT, QUIT
*
    JSR 0,X         IF SO, CALL IT
    BRA WARM3       DONE
*
*
* FOUND ENTRY
*
CMDSRB PULX         GET PTR TO ROUTINE
    LDX 0,X         GET ADDRESS OF ROUTINE
    TXAB            TRANSFER TO A,B
    PULX            SKIP DESCRA PARM
    TABX            RESTORE ROUTINE ADDRESS
    JSR 0,X         CALL ROUTINE
*
    BRA WARM3
*
* PRINT ERROR MESSAGE; X=A(MESSAGE)
*
_PRTMSG TSX
    LDA A UXH,X     SAVE ADDRESS IN A,B
    LDA B UXL,X
    LDX #CONRCB     POINT TO CONSOLE RCB
    STA A RCBDBA,X
    STA B RCBDBA+1,X
    LDA A #$80
    STA A RCBDTT,X  DIRECTION:=OUTPUT
*
    IOHDR           OUTPUT MESSAGE
*
    RTS
*
* MESSAGES
*
FORMAT  FCC 'FORMAT ERROR'
    FCB $0D
*
NUMBER  FCC 'NUMBER ERROR'
    FCB $0D
*
DEVERR  FCC ' '
DEVNAM  RMB 3
    FCC ' ERROR: '
DERNUM  RMB 2
    FDB $0A0D
*
*
* PRINT AN ERROR MESSAGE ON RCB OR FCB STATUS
* INDEX POINTS TO CONTROL BLOCK
*
* PRINT DEVICE NAME AND STATUS
*
_PRTERR TSX
    LDX UXH,X       POINT TO CONTROL BLOCK
    LDA A FCBSTA,X  GET DEVICE STATUS
    BEQ PRTER2      IF ZERO, QUIT
*
    JSR OUTHL       CONVERT LEFT DIGIT TO ASCII
    STA A DERNUM
    LDA A FCBSTA,X
    JSR OUTHR       CONVERT RIGHT DIGIT
    STA A DERNUM+1
    LDA A RCBGDT,X  GET DEVICE NAME
    STA A DEVNAM
    LDA A RCBGDT+1,X
    STA A DEVNAM+1
    LDA A RCBGDT+2,X
    STA A DEVNAM+2
    LDX #DEVERR
    PRTMSG          PRINT ERROR LINE
*
PRTER2 RTS
*
* GET A COMMAND FROM THE CONSOLE
* PARSE THE FIRST TOKEN FROM THE COMMAND LINE
*
_GTCMD LDX #CONRCB  POINT TO RCB
    CLR RCBDTT,X    SET FOR INPUT
    LDA A #'C       'CON' SOLE DEVICE
    STA A RCBGDT,X
    LDA A #'0
    STA A RCBGDT+1,X
    LDA A #'N
    STA A RCBGDT+2,X
    TXAB
    LDX #CONBUF     POINT TO BUFFER
    XABX
    STA A RCBDBA,X  INIT DATA BUFFER ADDRESS
    STA B RCBDBA+1,X
    TST SUBFLG      IN 'SUBMIT'?
    BEQ GTCD2       NO
*
* GET COMMAND FROM 'SUBMIT' FILE
*
    LDX #CONBUF
    STX SUBTMP      -SAVE BUFFER POINTER
SUBMT1 LDX #SUBFCB
    READ            READ A CHARACTER
    LDA B FCBSTA,X
    CMP B #8        END-FILE?
    BEQ SUBEOF      YES
*
    TST B           ERROR STATUS?
    BEQ SUBMT2      NO
*
    JSR SUBERR      ISSUE ERROR MESSAGE AND CLOSE FILE
    CLR SUBFLG      RESET 'SUBMIT' FLAG
    BRA _GTCMD      GET CONSOLE COMMAND
*
SUBEOF LDX #SUBFCB
    CLOSE           CLOSE FILE
    CLR SUBFLG      RESET 'SUBMIT' FLAG
    BRA _GTCMD      GET CONSOLE COMMAND
*
SUBMT2 LDX SUBTMP   POINT TO BUFFER
    STA A 0,X       STORE CHARACTER
    INX
    STX SUBTMP
    CMP A #$0D      C.R.?
    BNE SUBMT3      NO
*
    LDX #CONBUF
    PRTMSG          ECHO COMMAND LINE
    STX CUCHAR      INIT. POINTER FOR NXTOK
    BRA _NXTOK
SUBMT3 CMP A #'&    'DIVERSION'?
    BNE SUBMT4      NO
*
    LDX #CONRCB
    BRA GTCD2       GET A LINE FROM CONSOLE
*
SUBMT4 CMP A #$04   CNTL-D? (EOF IN TEXT FILE)
    BEQ SUBEOF
*
    BRA SUBMT1      GET NEW CHARACTER
*
GTCD2 IOHDR         GET A LINE FROM THE CONSOLE
    LDX #CONBUF
    STX CUCHAR      INIT PARMS FOR NXTOK
*
* FALL INTO 'NXTOK' ROUTINE
*
* NEXT TOKEN ROUTINE *
* SCANS A LINE OF SOURCE CODE AND RETURNS
* THE NEXT TOKEN CLASS AND RC
* THE ADDRESS OF THE TOKEN IS RETURNED IN
* DESCRA AND THE # OF BYTES IN THE TOKEN IS
* RETURNED IN DESCRC.
* THE RC AND CLASS ARE:
* 
* TYPE:     RC [B]  CLASS [A]
* 
* NAME      01      02 SUBSTRINGS
* WCARD     02      02
* NUMBER    03      02
* 
* DELIMS    (ASCII) 04 DELIMITERS
* 
* CR        0D      0D EOL
* 
* ERROR     00      00 ERRORS
*
*
_NXTOK CLR DESCRC
    INC DESCRC      DESCRC:=1
NXT0 LDX CUCHAR     POINT TO CURRENT CHAR
    STX DESCRA      INIT DESCRA
    LDA A 0,X       GET CHAR
    INX
    STX CUCHAR      POINT TO NEXT CHAR
    CMP A #$20      LESS THAN 20 HEX?
    BEQ NXT0        BLANK, SKIP OVER
    BHI NXT1        >20
*
    CMP A #$0D      CR?
    BNE NXTER       NO, UNRECOG. CHAR
    TAB             YES, SET RC
    BRA NXT7
*
NXT1 CMP A #$5F     >5F?
    BLS NXT3        NO
    BRA NXTER       YES, UNRECOG. CHAR
*
NXT3 JSR GCHRTB     GET BYTE FROM CHARTAB
*
NXT4 BIT A #$80     NAME?
    BEQ NXT5        NO
*
    LDA B #1
    BIT A #$01      WILDCARD CHAR?
    BEQ *+4         NO
*
    LDA B #2        YES
*
    JSR NSCAN       YES SCAN NAME STRING
    BRA NXT7
*
NXT5 BIT A #$40     DECIMAL?
    BEQ NXT6        NO
*
    JSR DSCAN       YES, SCAN DECIMAL STRING
    BRA NXT7
*
NXT6 BIT A #$04     DELIMITERS?
    BEQ NXTER       NO, UNRECOG. CHAR
*
    LDX DESCRA      GET CHAR
    LDA B 0,X
    CMP B #$24      $? (HEX)
    BNE NXT7        NO, GET RC AND RTN
*
    JSR HSCAN       YES, SCAN HEX STRING
*
NXT7 STA A CLASS
    STA B RC
    RTS
*
NXTER CLR CLASS     TROUBLE, SET RC,CLASS=00
    CLR RC
    RTS
* DSCAN SCAN DECIMAL STRING STOP AT
* FIRST NON-DECIMAL CHAR
*
DSCAN LDX CUCHAR    POINT TO NEXT CHAR
    LDA A 0,X       GET CHAR
    INC DESCRC      BUMP COUNT
    INX
    STX CUCHAR      POINT TO NEXT CHAR
    JSR GCHRTB      GET BYTE IN CHARTAB
    BIT A #$40      DECIMAL?
    BNE DSCAN       YES CONTINUE SCAN
*
    LDA B DESCRC    CHECK LENGTH OF TOKEN
    DEC B
    STA B DESCRC    WENT ONE CHAR. TOO FAR
    CMP B #6
    BLT DSCAN2      LENGTH OK?
*
    JMP NUMERR      NO, ERROR
*
DSCAN2 JSR CVDB     CONVERT TO BINARY
    STX VALUE       SAVE VALUE
    LDA B #3
    BRA ENDSCN      FINISH UP
*
*
* NSCAN SCAN NAME STRING STOP AT
* FIRST NON-ALPHANUMERIC CHAR
*
NSCAN LDX CUCHAR    POINT TO NEXT CHAR
    LDA A 0,X       GET CHAR
    INC DESCRC      BUMP COUNT
    INX
    STX CUCHAR      POINT TO NEXT CHAR
    JSR GCHRTB      GET BYTE IN CHARTAB
    BIT A #$01      WILDCARD?
    BEQ *+4         NO
*
    LDA B #2        YES
*
    BIT A #$80      ALPHA?
    BNE NSCAN       YES CONTINUE SCAN
*
    BIT A #$40      NUMERIC?
    BNE NSCAN       YES CONTINUE SCAN
*
    LDA A DESCRC
    DEC A
    STA A DESCRC    WENT ONE CHAR. TOO FAR
    BRA ENDSCN      FINISH UP
*
*
* HSCAN SCAN HEX STRING STOP AT
* FIRST NON-HEX CHAR
*
HSCAN CLR DESCRC    DESCRC:=0
    LDX CUCHAR      POINT TO NEXT CHAR
    STX DESCRA      INIT DESCRA
HSCAN1 LDX CUCHAR   POINT TO NEXT CHAR
    LDA A 0,X       GET CHAR
    INC DESCRC      BUMP COUNT
    INX
    STX CUCHAR      POINT TO NEXT CHAR
    JSR GCHRTB      GET BYTE IN CHRTAB
    BIT A #$02      HEX?
    BNE HSCAN1      YES CONTINUE SCAN
*
    LDA B DESCRC    CHECK TOKEN LENGTH
    DEC B
    STA B DESCRC    WENT ONE CHAR. TOO FAR
    CMP B #5
    BLT HSCAN2      LENGTH OK?
*
    JMP NUMERR      NO, ERROR
*
HSCAN2 JSR CVHB     CONVERT HEX TO BINARY
    STX VALUE       SAVE BINARY VALUE
    LDA B #3
*
ENDSCN LDX CUCHAR
    DEX
    STX CUCHAR      CUCHAR:= CORRECT VALUE
    LDA A 2         LOAD CLASS RC
    RTS             ALL DONE
*
*
NUMERR LDX #NUMBER  PRINT 'NUMBER ERROR' MESSAGE
    PRTMSG
    INS             CLEAN STACK
    INS
    JMP NXTER       RETURN ERROR TOKEN
* GET BYTE IN CHRTAB INDEXED BY VALUE OF
* CHAR IN REG A
*
GCHRTB CMP A #$20   VALID CHAR ?
    BCS GCHRTR      NO < 20
    CMP A #$5F      VALID CHAR ?
    BHI GCHRTR      NO, > 5F
*
    LDX #CHRTAB-$20
    ADDAX           ADD IN CHARACTER OFFSET
    LDA A 0,X       GET BYTE
    RTS
*
GCHRTR CLR A
    RTS
*
* CVHB CONVERT HEX TO BINARY
*
* ON ENTRY DESCRA ADDRESS OF STRING
*   DESCRC = # OF BYTES IN STRING
*   ON RETURN (X]-VALUE
*
HVAL RMB 2          TEMP STORAGE
*
CVHB LDX DESCRA     GET ADDRESS OF STRING
    CLR HVAL
    CLR HVAL+1
    LDA B           DESCRC GET COUNT
    DEX             DECREMENT PTR TO STRING
CVHB1 INX           POINT TO RIGHT MOST
    DEC B           BYTE OF THE
    BNE CVHB1       STRING
*
    LDA B           DESCRC GET COUNT
    JSR CVHBS       CONVERT
    STA A HVAL+1    SAVE
    DEC B           DECREMENT COUNT
    BEQ CVHBD       (1 HEX DIGIT)
    DEX             POINT TO NEXT LEFT BYTE
    JSR CVHBS       CONVERT
    ASL A           SHIFT TO LEFT NIBBLE
    ASL A
    ASL A
    ASL A
    ORA A HVAL+1    CONVERT TO BYTE
    STA A HVAL+1    SAVE
    DEC B           DECREMENT COUNT
    BEQ CVHBD       (2 HEX DIGITS)
    DEX             POINT TO NEXT LEFT BYTE
    JSR CVHBS       CONVERT
    STA A HVAL      SAVE
    DEC B           DECREMENT COUNT
    BEQ CVHBD       (3 HEX DIGITS)
*
    DEX             POINT TO NEXT LEFT BYTE
    JSR CVHBS       CONVERT
    ASL A           SHIFT TO LEFT NIBBLE
    ASL A
    ASL A
    ASL A
    ORA A HVAL      CONVERT TO BYTE
    STA A HVAL      SAVE
CVHBD LDX HVAL      GET FINAL VALUE
    RTS             RETURN
*
* ROUTINE TO CONVERT ASCII TO BINARY
*
CVHBS LDA A 0,X     GET BYTE
    SUB A #$30      CONVERT
    CMP A #$09      0 - 9 ?
    BLE *+4         YES
    SUB A #$07      NO, 10 - 15
    RTS
*
* CVDB: CONVERT DECIMAL TO BINARY
* ON ENTRY DESCRA = ADDRESS OF DECIMAL STRING
*          DESCRC = # BYTES IN DECIMAL STRING
* ON RETURN {X] = VALUE IN BINARY
*
DVAL    RMB 2       TEMP STORAGE FOR BINARY
DCOUNT  RMB 1       DIGIT COUNT
TENVL   RMB 2       POWER OF TEN
*
CVDB CLR DVAL       DVAL:=0
    CLR DVAL+1
    CLR TENVL
    CLR TENVL+1
    INC TENVL+1     TENVL:=1
    LDX DESCRA      POINT TO STRING
    DEX
    LDA B DESCRC
    STA B DCOUNT    INIT DCOUNT
*
CVDB1 INX           POINT TO
    DEC B           LEAST SIGNIFICANT
    BNE CVDB1       DIGIT
*
CVDB2 PSHX          SAVE POINTER
    LDA B 0,X       GET DIGIT
    AND B #$0F      CONVERT TO BCD
    CLR A           CLEAR ACCUMULATOR
    LDX TENVL       POINT TO POWER OF TEN
    MUL16           (X):=TENVL*DIGIT
    TXAB            (A,B)=(X)
    ADD B DVAL+1    DVAL:=DVAL+TENVL*DIGIT
    ADC A DVAL
    STA A DVAL
    STA B DVAL+1
    CLR A
    LDA B #$0A
    LDX TENVL       POINT TO POWER OF TEN
    MUL16           (X):=TENVL*10
    STX TENVL
    PULX            RESTORE POINTER TO STRING
    DEX             POINT NEXT LEFT DIGIT
    DEC DCOUNT      DONE?
    BNE CVDB2       NO
    LDX DVAL        GET FINAL VALUE
    RTS             RETURN
*
*
* PROCESS 'JUMP' COMMAND
*
JMPCMD NXTOK        GET ADDRESS
    LDA B RC        CHECK RC
    CMP B #3        VALID NUMBER?
    BEQ JMPC2       YES
*
    LDX #FORMAT     NO, ERROR
    PRTMSG
    RTS             RETURN TO CLI
*
JMPC2 INS           CLEAN STACK
    INS
    LDX VALUE       LOAD ADDRESS
    JMP 0,X         THERE
*
* PROCESS TRANSIENT COMMANDS
*
* 'DELETE'  'PIP'       'SECURITY'  'SETCON'
* 'ASSIGN'  'STATUS'    'LINK'      'BOOT'
*
DELCMD LDX #DELLIN
    BRA TRANS
*
PIPCMD LDX #PIPLIN
    BRA TRANS
*
SECCMD LDX #SECLIN
    BRA TRANS
*
SETCMD LDX #SETLIN
    BRA TRANS
*
ASNCMD LDX #ASNLIN
    BRA TRANS
*
STACMD LDX #STALIN
    BRA TRANS
*
BOOTCD LDX #BOOTLN
    BRA TRANS
*
LNKCMD LDX #LNKLIN
*
*
TRANS TXAB
    LDX CUCHAR      SAVE OLD CUCHAR
    PSHX
    TABX
    STX CUCHAR      SET UP DUMMY CLI
    JSR LODCMD      ISSUE 'LOAD' COMMAND
    PULX
    STX CUCHAR      RESTORE OLD CUCHAR
    LDX #SAVFCB
    TST FCBSTA,X    GOOD LOAD?
    BNE TRANS2      NO, QUIT
*
    LDX VALUE       TRANSFER ADDRESS?
    BEQ TRANS2      NO, QUIT
*
* FOR 'ASSIGN' TRANSIENT, PASS "PDTAB" ADDRESS IN (A,B)
    LDA A >PDTAB+1
    LDA B >PDTAB+2
    JMP 0,X         YES, GO THERE
*
TRANS2 RTS
*
DELLIN FCC '0:DELETE.CMD'
    FCB $0D
*
PIPLIN FCC '0:PIP.CMD'
    FCB $0D
*
SECLIN FCC '0:SECURITY.CMD'
    FCB $0D
*
SETLIN FCC '0:SET.CMD'
    FCB $0D
*
ASNLIN FCC '0:ASSIGN.CMD'
    FCB $0D
*
STALIN FCC '0:STATUS.CMD'
    FCB $0D
*
BOOTLN FCC '0:BOOT.CMD'
    FCB $0D
*
LNKLIN FCC '0:LINK.CMD'
    FCB $0D
* PROCESS 'SUBMIT' COMMAND
*
* SYNTAX: SUBMIT [DRIVE:] FILENAME.EXT
* FILE MUST BE 'TEXT' TYPE
*
SUBCMD LDX #SUBFCB
    CLR FCBDTT,X    MAKE INPUT FILE
    LDA A #$FF
    STA A FCBSCF,X  BLANK EXPANSION ON
    FMTFCB          FORMAT [DRIVE:] FILENAME.EXT
    PRTERR          PRINT ERROR MESSAGES
    TST FCBSTA,X    ERROR?
    BNE SUBERR      YES
*
    OPEN            OPEN FILE
    TST FCBSTA,X    ERROR?
    BNE SUBERR
*
    LDA A FCBTYP,X  'TEXT' FILE?
    CMP A #3
    BNE SUBERR      IF NOT, ERROR
*
    INC SUBFLG      SET 'SUBMIT' FLAG
    RTS             DONE!
*
SUBERR LDX #SUBLIN  'SUBMIT' ERROR
    PRTMSG
    LDX #SUBFCB
    PRTERR          PRINT ERROR MESSAGE
    CLOSE           TRY TO CLOSE FILE
    RTS
*
SUBLIN FCC ' SUBMIT FILE ERROR'
    FCB $0D
*
SUBFLG RMB 1
SUBTMP RMB 2
*
SUBFCB RMB 2
    FCC 'DSK'
    RMB 2
    FDB SUBBUF
    RMB 33
*
SUBBUF  RMB SECSIZ
* PROCESS 'SAVE' COMMAND
*
* STORE MEMORY CONTENTS ON DISK IN BINARY FORMAT
*
* SYNTAX: SAVE [DRIVE:] FILENAME.EXT,STARTAD,ENDAD, ETC...
*
SAVCMD LDX #SAVFCB      POINT TO FCB
    CLR FCBTYP,X        BINARY TYPE
    CLR FCBSCF,X        NO COMPRESSION
    CLR FCBACS,X        ACCESS-TYPE=0
    LDA A #$FF
    STA A FCBDTT,X  OUTPUT
    FMTFCB          FORMAT [DRIVE:] FILE.EXT
    PRTERR          PRINT ERROR MESSAGES
    TST FCBSTA,X    ERROR?
    BEQ *+3
*
    RTS             IF SO, RETURN
*
    NXTOK           GET TOKEN FROM CLI
    LDA A CLASS
    CMP A #4        DELIMITER?
    BEQ SAV5B       YES
*
SAV5 LDX #FORMAT    NO. FORMAT ERROR
    PRTMSG
    RTS
*
SAV5B NXTOK         GET TOKEN FROM CLI
    LDA B RC        CHECK RC
    CMP B #3        NUMBER?
    BNE SAV5        NO, ERROR
    LDX VALUE
    STX SAVEX       SAVE STARTING ADDRESS
    NXTOK           GET TOKEN FROM CLI
    LDA A CLASS
    CMP A #4        DELIMITER?
    BNE SAV5        NO, ERROR
*
    NXTOK           GET TOKEN FROM CLI
    LDA B RC        CHECK RC
    CMP B #3        NUMBER?
    BNE SAV5        NO. ERROR
*
    LDX VALUE
    STX SAVEX1      SAVE ENDING ADDRESS
    NXTOK           GET TOKEN FROM CLI
    LDA A CLASS
    CMP A #$0D      END OF LINE?
    BEQ SAV6        YES (NO TRANSFER ADDRESS)
*
    CMP A #4        DELIMITER?
    BNE SAV5        NO, ERROR
*
    NXTOK           GET A TOKEN FROM CLI
    LDA B RC        CHECK RC
    CMP B #3        NUMBER?
    BNE SAV5        NO, ERROR
*
* OUTPUT TRANSFER-ADDRESS RECORD HERE
*
    LDX #SAVFCB     POINT TO FCB
    INC FCBTYP,X    COMMMAND TYPE
    OPEN            OPEN SAVE FILE
    TST FCBSTA,X    CHECK STATUS
    BEQ *+5         GOOD?
*
    JMP SAVERR      BAD
*
    LDA A #$16      HEADER BYTE
    JSR PUTBYT
    LDA A VALUE     HIGH-BYTE OF ADDRESS
    JSR PUTBYT
    LDA A VALUE+1   LOW-BYTE OF ADDRESS
    JSR PUTBYT
    BRA SAV7
*
*
*
SAV6 LDX #SAVFCB    POINT TO FCB
    OPEN
    TST FCBSTA,X    FSAVE-FILE OPEN GOOD?
    BNE SAVERR      BAD
*
* NOW WRITE OUT BINARY RECORDS
*
SAV7 LDA A SAVEX1
    LDA B SAVEX1+1  GET END-ADDRESS
    SUB B SAVEX+1
    SBC A SAVEX
    BEQ SAV9        ARE THERE > 256 BYTES LEFT?
*
    LDA B #$FF      WRITE FULL RECORD (256 BYTES)
    LDX #SAVFCB     POINT TO FCB
    LDA A #$02      HEADER BYTE
    BSR PUTBYT
    LDA A SAVEX     HIGH-BYTE OF ADDRESS
    BSR PUTBYT
    LDA A SAVEX+1   LOW-BYTE OF ADDRESS
    BSR PUTBYT
    TBA             256 BYTES IN COUNT
    BSR PUTBYT
SAV8 LDX SAVEX      POINT TO MEMORY ADDRESS
    LDA A 0,X       GET BYTE
    INX
    STX SAVEX
    LDX #SAVFCB     POINT TO FCB
    BSR PUTBYT
    DEC B           DONE?
    BNE SAV8
*
    BRA SAV7        KEEP GOING
SAV9 LDX #SAVFCB    POINT TO FCB 
* WRITE OUT LAST RECORD HERE
    LDA A #$02      HEADER BYTE
    BSR PUTBYT
    LDA A SAVEX     HIGH-BYTE OF ADDRESS
    BSR PUTBYT
    LDA A SAVEX+1   LOW-BYTE OF ADDRESS
    BSR PUTBYT
    TBA             COUNT
    BSR PUTBYT
SAV10 LDX SAVEX     POINT TO MEMORY ADDRESS
    LDA A 0,X       GET BYTE
    INX
    STX SAVEX
    LDX #SAVFCB     POINT TO FCB
    BSR PUTBYT
    DEC B           DONE?
    BNE SAV10
*
    CLOSE           CLOSE SAVE-FILE
    TST FCBSTA,X    CHECK STATUS
    BNE SAVERR      BAD?
*
    RTS             RETURN TO CLI
*
SAVERR LDX #SAVFCB
    PRTERR          PRINT ERROR MESSAGE
    CLOSE           MUST CLOSE FILE
    RTS
*
PUTBYT WRITE        WRITE BYTE TO FILE
    TST FCBSTA,X    CHECK STATUS
    BEQ PUTB2       GOOD
*
    INS
    INS             REMOVE SUB-RETURN
    BRA SAVERR      ERROR AND QUIT
*
PUTB2 RTS           GOOD RETURN
*
SAVFCB RMB 2
    FCC 'DSK'
    RMB 2
    FDB SAVBUF
    RMB 33
SAVBUF RMB SECSIZ
*
* PROCESS 'LOAD' COMMAND
*
* LOAD MEMORY FROM BINARY OR COMMAND DISK FILE
* IF TRANSFER ADDRESS IN FILE (COMMAND TYPE), SAVE IT
* IN "VALUE" BASE-PAGE LOCATION
* OTHERWISE, "VALUE"=0
*
LODCMD LDX #SAVFCB  POINT TO FCB
    FMTFCB          FORMAT [DRIVE:] FILE.EXT
    PRTERR          PRINT ERROR MESSAGES
    TST FCBSTA,X    ERROR?
    BNE LOD5        IF SO, QUIT
*
    LOADB           PERFORM LOAD BINARY
    PRTERR          PRINT ERROR MESSAGE
LOD5 RTS            RETURN TO CLI
*
*
*
* LOAD-BINARY PROCESSING
*
_LOADB CLR VALUE    NO XFER-ADDRESS YET
    CLR VALUE+1
    TSX
    LDX UXH,X       POINT TO FCB
    CLR FCBDTT,X    INPUT
    CLR FCBSCF,X    NO COMPRESSION
    CLR FCBSTA,X    GOOD STATUS
    OPEN            OPEN SAVE-FILE
    TST FCBSTA,X    CHECK STATUS
    BEQ LOADB2      GOOD
*
    RTS             BAD, QUIT
*
LOADB2 LDA A FCBTYP,X   CHECK FILE TYPE
    BEQ LOADB3      (0) BINARY TYPE, OK
*
    CMP A #1        (1) COMMAND TYPE, OK
    BEQ LOADB3
*
    LDX #TYPMSG     FILE-TYPE ERROR
    PRTMSG
    TSX
    LDX UXH,X       POINT TO FCB
    CLOSE           CLOSE FILE
    RTS             RETURN
*
TYPMSG FCC ' ILLEGAL FILE-TYPE'
    FCB $0D
*
LOADB3 TSX
    LDX UXH,X       POINT TO FCB
    BSR GETBYT      GET A BYTE FROM FILE
    CMP A #$16      XFER-ADDR. MARK?
    BNE LOADB4      NO
*
* HANDLE TRANSFER ADDRESS HERE
*
    BSR GETBYT      GET ADDRESS-HIGH
    STA A VALUE
    BSR GETBYT      GET ADDRESS-LOW
    STA A VALUE+1
    BRA LOADB3      GET NEW FRAME
*
LOADB4 CMP A #$02   FRAME HEADER MARK?
    BEQ LOADB5      YES
*
    CLOSE           CLOSE FILE
    RTS             DONE WITH LOAD
*
* HANDLE BINARY RECORD HERE
*
LOADB5 BSR GETBYT   GET ADDRESS-HIGH
    STA A SAVEX
    BSR GETBYT      GET ADDRESS-LOW
    STA A SAVEX+1
    BSR GETBYT      GET FRAME COUNT
    STA A SAVEA
*
LOADB6 TSX
    LDX UXH,X       POINT TO FCB
    BSR GETBYT      GET DATA BYTE
    LDX SAVEX       GET ADDRESS
    STA A 0,X       STORE DATA BYTE
    INX
    STX SAVEX
    DEC SAVEA       COUNT DOWN FRAME
    BNE LOADB6
*
    BRA LOADB3      GET NEW FRAME
*
*
GETBYT READ         READ BYTE FROM FILE
    LDA B FCBSTA,X  CHECK STATUS
    BEQ GETB3       GOOD
*
    CMP B #8        END-FILE?
    BNE GETB2       NO
*
    CLR FCBSTA,X    END-FILE IS NOT ERROR HERE
*
GETB2 INS           REMOVE SUB-RETURN
    INS             (WILL RETURN TO CALL)
    CLOSE           CLOSE FILE
*
GETB3 RTS
* PROCESS 'RENAME' COMMAND
*
* SYNTAX: RENAME [DRIVE:] OLDNAME.EXT, NEWNAME.EXT
*
RENCMD LDX #SAVFCB  POINT TO FCB
    CLR FCBDTT,X    INPUT
    FMTFCB          FORMAT [DRIVE:] FILE.EXT
    PRTERR          PRINT ERROR MESSAGES
    TST FCBSTA,X    ERROR?
    BNE RENAM5      YES, QUIT
*
    JSR SFILE       SEARCH DIRECTORY
    LDX #SYSFCB     GET DIRECTORY POINTERS
    LDA A FCBTRK,X  TRACK
    LDA B FCBSCT,X  SECTOR
    STA A FCBFTS,X
    STA B FCBFTS+1,X
    LDA A FCBIND,X  BLOCK POINTER
    LDA B FCBIND+1,X
    STA A FCBLTS,X
    STA B FCBLTS+1,X
    LDX FCBIND,X    GET DIRECTORY BLOCK POINTER
    LDA A FIBACS,X  CHECK ACCESS CODE
    CMP A #$02      RENAME-ABLE?
    BNE *+5         YES
*
    JMP SECERR      NO, ERROR
*
    LDX #SAVFCB
    TST FCBSTA,X    ERROR CHECK
    BEQ RENAM6      NO ERROR
*
RENAM5 LDX #RENMSG  RENAME ERROR
    PRTMSG
    RTS
*
RENMSG FCC ' RENAMING ERROR'
    FCB $00
*
RENAM6 NXTOK        GET TOKEN FROM CLI
    LDA A CLASS
    CMP A #4        DELIMITER?
    BEQ RENAM8      YES
*
RENAM7 LDX #FORMAT  NO, FORMAT ERROR
    PRTMSG  
    RTS
*
RENAM8 NXTOK        GET TOKEN FROM CLI
    LDA B RC        CHECK RC
    CMP B #1        UNAMBIG. NAME?
    BNE RENAM7      NO, ERROR
*
    LDX DESCRA      GET NAME POINTER
    STX SAVEX       SAVE IT
    LDA A DESCRC    GET LENGTH
    STA A SAVEA     SAVE IT
    NXTOK           GET TOKEN FROM CLI
    LDA B RC        CHECK RC
    CMP B #'.       PERIOD?
    BNE RENAM7      NO, ERROR
*
    INC SAVEA       COUNT PERIOD
    NXTOK           GET TOKEN FROM CLI
    LDA B RC        CHECK RC
    CMP B #1        UNAMBIG. NAME?
    BNE RENAM7      NO, ERROR
*
    LDA B DESCRC    GET LENGTH OF EXT
    ADD B SAVEA     TOTAL LENGTH
    LDX #SAVFCB+FCBNAM  POINT TO NAME FIELD IN FCB
    PSHX
    LDX SAVEX       POINT TO NAME IN CLI
    PSHX
    FMTS            FORMAT NAME INTO FCB
    INS
    INS             CLEAN STACK
    INS
    INS
    TST B           ERROR?
    BNE RENAM7      YES
*
    LDX #SAVFCB
    JSR SFILE       SEARCH DIRECTORY
    LDX #SAVFCB
    LDA A FCBSTA,X  CHECK STATUS
    BNE *+5         NOT FOUND?
*
    JMP RENAM9      YES, DUPLICATE NAME
*
    CMP A #1        NOT FOUND (GOOD)?
    BEQ *+5         YES
*
RENM5 JMP RENAM5    NO, ERROR
*
    LDX #SYSFCB     POINT TO DIRECTORY FCB
    CLR FCBSTA,X
    LDA A FCBFTS,X  SET UP TO SAVED T/S
    LDA B FCBFTS+1,X
    STA A FCBTRK,X
    STA B FCBSCT,X
    IOHDR           READ DIRECTORY SECTOR
    TST A           ERROR?
    BNE RENM5       YES
*
    LDX FCBLTS,X    POINT TO OLD NAME IN SECTOR
    PSHX
    LDX #SAVFCB+FCBNAM  POINT TO NEW NAME
    PSHX
    LDA B #12
    MOVC            MOVE NAME INTO DIRECTORY
    INS
    INS
    INS             CLEAN STACK
    INS
    LDX #SYSFCB     POINT TO SYSTEM FCB
    LDA A #$FF
    STA A FCBDTT,X  MAKE 'OUTPUT'
    IOHDR           WRITE NEW NAME INTO DIRECTORY
    CLR FCBDTT,X    MAKE 'INPUT' AGAIN
    RTS
*
RENAM9 LDX #DUPERR  DUPLICATE NAME ERROR
    PRTMSG
    RTS
*
DUPERR FCC ' DUPLICATE NAME'
    FCB $00
*
SECERR LDX #SECURE  SECURITY ERROR
    PRTMSG
    RTS
*
SECURE FCC ' SECURITY ERROR'
    FCB $0D
* PROCESS 'INITIALIZE' COMMAND
* CALL TRANSIENT FILE TO PROCESS THIS COMMAND
*
INICMD NXTOK        GET NEXT TOKEN FROM COMMAND LINE
    LDA B RC        CHECK RC
    CMP B #3        NUMBER?
    BEQ INICD2      YES
*
    LDA A CLASS     CHECK CLASS OF TOKEN
    CMP A #4        DELIMITER?
    BEQ INICMD      IF SO, PARSE AGAIN
*
    LDX #FORMAT     IF NOT, PRINT ERROR MESSAGE
    PRTMSG
    RTS             RETURN TO CLI
*
INICD2 TST VALUE    CHECK NUMBER
    BNE INIERR      BAD (>255)
*
    LDA A VALUE+1   CHECK NUMBER
    CMP A #3        (4 DRIVES)
    BHI INIERR      BAD
*
    PSH A           SAVE NUMBER
    LDX #INITLN
    STX CUCHAR      SET UP DUMMY CLI
    JSR LODCMD      ISSUE 'LOAD' COMMAND FOR TRANSIENT
    PUL A           RESTORE NUMBER
    LDX #SAVFCB
    TST FCBSTA,X    CHECK FOR ERRORS
    BNE INICD3      YES, QUIT
*
    LDX VALUE       IS THERE XFER-ADDRESS?
    BEQ INICD3      NO, QUIT
*
    STA A VALUE+1   PASS DRIVE NO. TO TRANSIENT
    JMP 0,X         START IT UP
*
INICD3 RTS          DONE!
*
INIERR LDX #NUMBER  PRINT ERROR MESSAGE
    PRTMSG
    RTS             RETURN TO CLI
*
INITLN FCC '0:INIT.CMD'
    FCB $0D
* PROCESS 'DIRECTORY' COMMAND
*
DIRHDR FCC 'DIRECTORY OF DRIVE '
DIRDRV RMB 1
    FDB $0A0D
*
DIRFLD FCC '    NAME       T   A  FT-FS  LT-LS   NS'
    FDB $0A0D
*
DIRLIN RMB 40       DIRECTORY LINE BUFFER
    FCB $0D
*
NSEC RMB 2          NUMBER OF SECTORS USED
BUFLIN RMB 13       STORAGE FOR FORMATTED FILE NAME
*
ALLFIL FCC '*.*'    DEFAULT FILE NAME
*
DIRLN2 FCB $0A
    RMB 5           SPACE FOR COUNT OF SECTORS
    FCC '. SECTORS USED'
    FDB $0A0D
*
KIOK FDB 10000      POWERS-OF-10 TABLE
    FDB 1000
    FDB 100
    FDB 10
    FDB 1
*
SAVEX   RMB 2       TEMP. STORAGE
SAVEX1  RMB 2
TMPX    RMB 2
LPTFLG  RMB 1
SAVEA   RMB 1
*
*
*
DIRCMD CLR SAVEA    DEFAULT DRIVE=0
    CLR LPTFLG      DEFAULT TO CONSOLE
    LDA A #12       DEFAULT NAME HAS 12 CHARS.
    STA A SAVEX     SAVE IT
    LDX #BUFLIN
    PSHX
    LDX #ALLFIL     DEFAULT FILE NAME=*.*
    PSHX
    LDA B #3
    FMTS            FORMAT *.* INTO BUFLIN
    INS
    INS             CLEAN STACK
    INS
    INS
DIRCD0 NXTOK        GET TOKEN FROM CLI
    LDA B RC        CHECK RC
    CMP B #$0D      END OF LINE?
    BNE *+5         NO
*
    JMP DIRCD3      YES, USE DEFAULTS
*
    CMP B #'/       SWITCH INDICATOR?
    BNE DIRCD1      NO
*
    NXTOK           GET SWITCH
    LDX DESCRA
    LDA A 0,X
    CMP A #'L       LINE-PRINTER ('L')?
    BNE DIR3        NO, FORMAT ERROR
    INC LPTFLG      YES, SET FLAG
    BRA DIRCD0      GET NEW TOKEN
*
DIRCD1 CMP B #3     TOKEN=NUMBER?
    BNE DIR2        NO
*
    TST VALUE       CHECK FOR VALID DRIVE NO.
    BNE DIR1        BAD?
*
    LDA A VALUE+1   CHECK DRIVE NO.
    CMP A #3        DRIVE NO. 0,1,2,3
    BHI DIR1        BAD?
*
    STA A SAVEA     SAVE DRIVE NO.
    BRA DIR1A
*
DIR1 LDX #NUMBER    NUMBER ERROR
    PRTMSG
    RTS             RETURN TO CLI
DIR1A NXTOK         GET NEXT TOKEN FROM CLI
    LDA B RC        CHECK RC
    CMP B #$0D      END OF LINE?
    BEQ DIRCD3      YES, USE DEFAULT FILE NAME
*
    CMP B #':       COLON?
    BNE DIR1        IF NOT, BAD DRIVE NO.
*
    NXTOK           GET NEXT TOKEN FROM CLI
    LDA B RC        CHECK RC
*
DIR2 CMP B #1       NAME?
    BEQ DIR4        YES
*
    CMP B 2         WILD-CARD NAME?
    BEQ DIR4        YES
*
DIR3 LDX #FORMAT    OTHERWISE FORMAT ERROR
    PRTMSG
    RTS             RETURN TO CLI
*
DIR4 LDX DESCRA     POINT TO NAME
    STX SAVEX1      SAVE POINTER
    LDA A DESCRC    GET LENGTH
    STA A SAVEX     SAVE IT
    NXTOK           GET NEXT TOKEN FROM CLI
    LDA B RC        CHECK RC
    CMP B #'.       PERIOD?
    BNE DIR3        NO, ERROR
*
DIR5 INC SAVEX      COUNT PERIOD
    NXTOK           GET NEXT TOKEN FROM CLI
    LDA B RC        CHECK RC
    CMP B #1        NAME?
    BEQ DIR6        YES
*
    CMP B 2         WILD-CARD NAME?
    BEQ DIR6        YES
*
    BRA DIR3        FORMAT ERROR
*
DIR6 LDA B DESCRC
    ADD B SAVEX     GET TOTAL LENGTH
    LDX #BUFLIN
    PSHX
    LDX SAVEX1
    PSHX
    FMTS            FORMAT NAME INTO BUFLIN
    INS
    INS             CLEAN STACK
    INS
    INS
    CMP B 2         BAD NAME?
    BEQ DIR3        FORMAT ERROR
*
DIRCD3 CLR NSEC
    CLR NSEC+1      NO USED SECTORS YET
    TST LPTFLG      WANT LINE-PRINTER?
    BEQ DIR7        NO
*
    LDX #CONRCB     MAKE CONSOLE INTO 'LPT'
    LDA A #'L
    STA A RCBGDT,X
    LDA A #'P
    STA A RCBGDT+1,X
    LDA A #'T
    STA A RCBGDT+2,X
*
DIR7 LDA A SAVEA    GET DRIVE NO.
    ADD A #$30      MAKE ASCII
    STA A DIRDRV
    LDX #DIRHDR     PRINT HEADER LINE 1
    PRTMSG
    LDX #DIRFLD     PRINT HEADER LINE 2
    PRTMSG
    LDX #SYSFCB     POINT TO SYSTEM FCB
    TXAB
    LDX #BUFFER     PUT BUFFER ADDRESS IN
    XABX
    STA A FCBDBA,X
    STA B FCBDBA+1,X
    LDA A SAVEA
    STA A FCBDRV,X  PUT DRIVE NO. IN
    OPEND           OPEN DIRECTORY
*
DIRCD4 LDA A FCBSTA,X   CHECK STATUS
    BEQ DIRLST      VALID ENTRY?
*
    CMP A #1        END-OF-DIRECTORY?
    BNE DIRERR      IF NOT, ERROR
*
    LDA A NSEC      OUTPUT NUMBER OF SECTORS USED
    LDA B NSEC+1
    LDX #DIRLN2+1
*
* CONVERT BINARY (16 BITS) TO 5 DECIMAL CHARS.
* (A,B)=BINARY VALUE
* (X)= ADDRESS TO PLACE CHARS IN ASCII
*
CVBTD STX SAVEX     SAVE DATA POINTER
    LDX #KIOK       POINT TO CONSTANT TABLE
CVDEC1 CLR SAVEA    INIT. CHAR
CVDEC2 SUB B 1,X
    SBC A 0,X
    BCS CVDEC5      OVERFLOW?
*
    INC SAVEA       NO, BUMP CHAR.
    BRA CVDEC2
*
CVDEC5 ADD B 1,X    RESTORE PARTIAL RESULT
    ADC A 0,X
    PSH A
    STX SAVEX1      SAVE REGISTERS
    LDX SAVEX       GET POINTER
    LDA A SAVEA     GET CHAR.
    ADD A #$30      MAKE ASCII
    STA A 0,X       STORE CHAR.
    PUL A
    INX
    STX SAVEX       SAVE POINTER
    LDX SAVEX1      RECOVER REGISTER
    INX             MOVE TO NEXT TABLE ENTRY
    INX
    CPX #KIOK+10    DONE?
    BNE CVDEC1      NO
*
    LDX #DIRLN2     PRINT END LINE
    PRTMSG
    RTS             DONE!!.
*
DIRERR PRTERR       PRINT ERROR MESSAGE
    RTS             RETURN TO CLI
*
* OUTPUT FORMATTED DIRECTORY RECORD HERE
*
DIRLST LDX FCBIND,X GET FIRST CHAR. OF BLOCK
    LDA A 0,X
    CMP A #$20      FIRST CHAR=BLANK?
    BNE *+5         NO
*
    JMP DIRNXT      GET NEXT ENTRY
*
    PSHX
    LDX #BUFLIN
    PSHX
    LDA B #12
    CMWC            COMPARE NAMES (WITH WILD-CARDS)
    INS
    INS
    INS
    INS
    BEQ *+5         NAMES MATCH
*
    JMP DIRNXT      NO MATCH, GET NEXT NAME
*
    LDX #DIRLIN+39
    LDA B #$20      BLANK OUT DIRECTORY LINE
    LDA A #39
DIRCD5 STA B 0,X
    DEX
    DEC A
    BNE DIRCD5
*
    PSHX            STACK 'TO' ADDRESS
    LDX #SYSFCB
    LDX FCBIND,X
    PSHX            STACK 'FROM' ADDRESS
    LDA B #12       SET UP FOR MOVE (FROM DATA BLOCK)
    MOVC            TO DIRECTORY LINE, 12 CHARACTER
    PULX
    PULX            RECOVER LINE POINTER
    INX
    INX
    INX             POINT TO LINE (15)
    PSHX
    LDX #SYSFCB     POINT TO FCB
    LDX FCBIND,X    POINT TO DATA BLOCK
    LDA A FIBTYP,X  GET FILE TYPE
    TAB
    JSR OUTHL       CONVERT TO ASCII
    PULX
    STA A 0,X       PUT INTO LINE
    INX
    TBA
    JSR OUTHR
    STA A 0,X
    INX
    INX
    INX             POINT TO LINE (19)
    PSHX
    LDX #SYSFCB
    LDX FCBIND,X
    LDA A FIBACS,X  GET FILE ACCESS CODE
    TAB
    JSR OUTHL       CONVERT TO ASCII
    PULX
    STA A 0,X       PUT INTO LINE
    INX
    TBA
    JSR OUTHR
    STA A 0,X
    INX
    INX
    INX             POINT TO LINE (23)
    PSHX
    LDX #SYSFCB
    LDX FCBIND,X
    LDA A FIBFTS,X  GET FIRST TRACK
    TAB
    JSR OUTHL       CONVERT HIGH NIBBLE
    PULX
    STA A 0,X       PUT INTO LINE
    INX             POINT TO LINE (24)
    TBA
    JSR OUTHR       CONVERT LOW NIBBLE
    STA A 0,X       PUT INTO LINE
    INX
    INX             POINT TO LINE (26)
    PSHX
    LDX #SYSFCB
    LDX FCBIND,X
    LDA A FIBFTS+1,X    GET FIRST SECTOR
    TAB
    JSR OUTHL       CONVERT HIGH NIBBLE
    PULX
    STA A 0,X       PUT INTO LINE
    INX             POINT TO LINE (27)
    TBA
    JSR OUTHR       CONVERT LOW NIBBLE
    STA A 0,X       PUT INTO LINE
    INX
    INX
    INX             POINT TO LINE (30)
    PSHX
    LDX #SYSFCB
    LDX FCBIND,X
    LDA A FIBLTS,X  GET LAST TRACK
    TAB
    BSR OUTHL       CONVERT HIGH NIBBLE
    PULX
    STA A 0,X       PUT INTO LINE
    INX             POINT TO LINE (31)
    TBA
    BSR OUTHR       CONVERT LOW NIBBLE
    STA A 0,X       PUT INTO LINE
    INX
    INX             POINT TO LINE (33)
    PSHX
    LDX #SYSFCB
    LDX FCBIND,X
    LDA A FIBLTS+1,X    GET LAST SECTOR
    TAB
    BSR OUTHL       CONVERT HIGH NIBBLE
    PULX
    STA A 0,X       PUT INTO LINE
    INX             POINT TO LINE (34)
    TBA
    BSR OUTHR       CONVERT LOW NIBBLE
    STA A 0,X       PUT INTO LINE
    INX
    INX
    INX             POINT TO LINE (37)
    PSHX
    LDX #SYSFCB
    LDX FCBIND,X
    LDX FIBNMS,X    GET SECTOR COUNT
    TXAB
    LDX NSEC
    ADDABX          ADD NSEC TO COUNT
    STX NSEC
    PULX
    PSH A           SAVE 'A'
    BSR OUTHL       CONVERT HIGH NIBBLE
    STA A 0,X       PUT INTO LINE
    INX             POINT TO LINE (38)
    PUL A           RESTORE 'A'
    BSR OUTHR       CONVERT LOW NIBBLE
    STA A 0,X       PUT INTO LINE
    INX             POINT TO LINE (39)
    TBA
    BSR OUTHL       CONVERT HIGH NIBBLE (LOW BYTE)
    STA A 0,X       PUT INTO LINE
    INX             POINT TO LINE (40)
    TBA
    BSR OUTHR       CONVERT LOW NIBBLE (LOW BYTE)
    STA A 0,X       PUT INTO LINE
    LDX #DIRLIN     PRINT LINE OF DIRECTORY
    PRTMSG
*
DIRNXT LDX #SYSFCB  POINT TO FCB
    GETDR           GET NEW DIRECTORY BLOCK
    JMP DIRCD4      CONTINUE
*
OUTHL LSR A         CONVERT LEFT NIBBLE TO ASCII
    LSR A
    LSR A
    LSR A
*
OUTHR AND A #$0F    CONVERT RIGHT NIBBLE TO ASCII
    ADD A #$30
    CMP A #$39
    BLS *+4
*
    ADD A #$07
*
    RTS
*
* LOAD AND RUN A TRANSIENT FILE
* INDEX (STACKED) POINTS TO FCB WITH FILENAME AND DRIVE
*
_CHAIN LDX #SAVFCB  MOVE DATA TO SYSTEM FCB
    PSHX
    TSX
    LDX UXH+2,X     PASSED FCB ADDRESS
    PSHX
    LDA B #30       MOVE 30 CHARACTERS
    MOVC
    INS
    INS             CLEAN STACK
    INS
    INS
    LDX #SAVFCB
    TXAB
    LDX #SAVBUF     USE SYSTEM BUFFER
    XABX
    STA A FCBDBA,X
    STA B FCBDBA+1,X
    CLR FCBSTA,X
    LOADB           LOAD BINARY FILE
    TST FCBSTA,X    CHECK STATUS
    BNE CHANER      ERROR?
*
    LDX VALUE       TRANSFER ADDRESS?
    BEQ CHANER      IF NOT, ERROR
*
    INS
    INS
    INS             CLEAN STACK (9 BYTES)
    INS
    INS             7 BYTES FROM SWI
    INS             2 BYTES FROM JSR
    INS
    INS
    INS
    JMP 0,X         GO TO TRANS. ADDRESS
*
CHANER LDX #CHANME  CHAIN ERROR
    PSHX
    LDX #SAVFCB+FCBNAM  NAME OF FILE
    PSHX
    LDA B #12       12 CHARACTERS
    MOVC
    INS
    INS             CLEAN STACK
    INS
    INS
    LDX #CHANLN
    PRTMSG
    INS
    INS
    INS
    INS             CLEAN STACK (SWI+JSR)
    INS
    INS
    INS
    INS
    INS
    LDX #SAVFCB
    CLOSE           CLOSE FILE
    RTS             QUIT--WILL GO TO CLI
*
CHANLN FCC ' UNABLE TO CHAIN: '
CHANME RMB 12
    FDB $0A0D
* SEARCH DIRECTORY FILE FOR EMPTY SLOT
* USES SYSTEM FCB AND BUFFER
* PASS DRIVE NO. IN 'A' REGISTER
* RETURNS TRACK, SECTOR OF SLOT IN FCBTRK,FCBSCT
* RETURNS ADDRESS OF DIR. SLOT IN FCBIND
* RETURNS ERROR STATUS IN FCBSTA
*   0=FOUND SLOT
*   1=NO AVAILABLE SLOT
* OTHERWISE = ERROR VALUE
*
* DISK ATTRIBUTES:
*
TRKSIZ EQU 26       26 SECTORS/TRACK
*
SEMPTY LDX #SYSFCB  POINT TO SYSTEM FCB
    STA A FCBDRV,X  SET DRIVE NO.
    TXAB
    LDX #BUFFER     SET BUFFER ADDRESS
    XABX
    STA A FCBDBA,X
    STA B FCBDBA+1,X
    CLR FCBSTA,X    INIT. STATUS
    OPEND           OPEN DIRECTORY
*
SEMPT2 LDA A FCBSTA,X   CHECK STATUS
    BEQ SEMPT3      STATUS O.K.
*
    CMP A #1        END-DIRECTORY?
    BEQ SEMPT4      YES
*
    JMP DIRERR      OTHERWISE ERROR
*
SEMPT3 LDX FCBIND,X
    LDA A 0,X       CHECK FIRST CHAR. OF SLOT
    CMP A #$20      BLANK?
    BNE *+3         NO
*
    RTS             YES, FOUND EMPTY SLOT
*
    LDX #SYSFCB     POINT TO FCB
    GETDR           GET NEXT DIR. BLOCK
    BRA SEMPT2      KEEP LOOKING FOR EMPTY
SEMPT4 LDA A FCBSCT,X
    CMP A #TRKSIZ   END OF TRACK?
    BNE *+3         NO, FOUND EMPTY
*
    RTS             YES, OUT OF SPACE
*
    CLR FCBSTA,X    RETURN GOOD STATUS
    RTS
*
* SEARCH DIRECTORY FOR UNAMBIGUOUS FILE REFERENCE
* PASS IN INDEX REGISTER THE ADDRESS OF AN FCB
* CONTAINING DESIRED FILE NAME AND DRIVE NO.
* RETURNS ADDRESS OF DIRECTORY BLOCK IN FCBIND
* RETURNS STATUS IN FCBSTA
*   0=FOUND FILE
*   1=FILE NOT FOUND
* OTHERWISE=ERROR CODE
*
SFILE PSHX          SAVE FCB ADDRESS
    LDA A FCBDRV,X  GET DRIVE NO.
    LDX #SYSFCB
    STA A FCBDRV,X  PUT INTO SYSTEM FCB
    TXAB
    LDX #BUFFER     PROVIDE A BUFFER ADDRESS
    XABX
    STA A FCBDBA,X
    STA B FCBDBA+1,X
    CLR FCBSTA,X    INIT. STATUS
    OPEND           OPEN THE DIRECTORY ON DRIVE
*
SFILE2 LDA A FCBSTA,X   CHECK STATUS
    BEQ SFILE3      STATUS OK?
*
    CMP A #1        END OF DIRECTORY?
    BEQ SFILE5      YES
*
    PULX
    STA A FCBSTA,X  NO, ERROR STATUS
    JMP DIRERR      ISSUE ERROR MESSAGE
*
SFILE3 LDX FCBIND,X
    LDA A 0,X       CHECK DIRECTORY BLOCK
    CMP A #$20      FIRST CHAR. OF NAME=BLANK?
    BNE SFILE4
*
SFNEXT LDX #SYSFCB  POINT TO SYSTEM FCB
    GETDR           GET NEXT DIRECTORY BLOCK
    BRA SFILE2      KEEP SEARCHING
*
SFILE4 PSHX         STACK DIRECTORY NAME ADDRESS
    TSX
    LDX 2,X         POINT TO SAVED FCB ADDRESS
    LDA A #FCBNAM
    ADDAX           POINT TO NAME FIELD IN FCB
    PSHX            STACK SEARCH NAME ADDRESS
    LDA B #12       12 CHARACTER COMPARISON
    CMPC            COMPARE NAMES
    INS             CLEAN STACK
    INS
    INS
    INS
    BNE SFNEXT      NO MATCH, KEEP LOOKING
*
SFOUND LDX #SYSFCB
    LDX FCBIND,X    RECOVER DIR. BLOCK ADDRESS
    TXAB
    PULX            RECOVER FCB ADDRESS
    STA A FCBIND,X
    STA B FCBIND+1,X
    CLR FCBSTA,X    GOOD STATUS
    RTS             RETURN TO CLI
*
SFILE5 PULX         RECOVER 'X'
    STA A FCBSTA,X  RETURN STATUS
    RTS
*
* DELETE A FILE FROM DISK
* INDEX (STACKED) POINTS TO FCB WITH FILENAME AND DRIVE NO.
* RETURN ERROR STATUS IN FCBSTA
* CHECK ACCESS CODE FOR PROTECTION ERRORS
* MUST HAVE ALL OUTPUT FILES ON THIS DISK CLOSED
*
_DELETE TSX
    LDX UXH,X       POINT TO FCB
    BSR SFILE       SEARCH DIRECTORY
    TSX
    LDX UXH,X
    TST FCBSTA,X    FOUND FILE?
    BEQ DEL2        YES
*
    RTS             NO, QUIT
*
DEL2 LDX FCBIND,X   POINT TO DIR. ENTRY
    TST FIBACS,X    ACCESS CODE=0?
    BEQ DEL3        O.K.
*
    LDX #DELERR     NO, CANNOT DELETE
    PRTMSG
    TSX
    LDX UXH,X       POINT TO FCB
    LDA A #18       ERROR CODE
    STA A FCBSTA,X
    RTS
*
DELERR FCC ' FILE DELETE-PROTECTED'
    FCB $00
*
DEL3 LDX FCBCHN     SEARCH OPEN FCBS
    BEQ DEL33
*
DEL30 TST FCBDTT,X  FCB OUTPUT?
    BEQ DEL31       NO, KEEP LOOKING
*
    LDA A FCBDRV,X  GET DRIVE NO.
    PSHX            SAVE FCB POINTER
    TSX
    LDX UXH+2,X     POINT TO THIS FCB
    CMP A FCBDRV,X  SAME DRIVE?
    BEQ DEL32       YES
*
    PULX            RESTORE POINTER
DEL31 LDX FCBNFB,X  GET NEXT FCB
    BNE DEL30       KEEP LOOKING
*
    BRA DEL33       DONE
*
DEL32 INS           CLEAN STACK
    INS
    LDX #FOPERR     ERROR MESSAGE
    PRTMSG
    LDA A #18       ERROR CODE
    TSX
    LDX UXH,X
    STA A FCBSTA,X  RETURN ERROR CODE
    RTS
*
FOPERR FCC ' DELETE ERROR-OPEN OUTPUT FILES'
    FCB $0D
*
DEL33 TSX
    LDX UXH,X           POINT TO FCB
    LDX FCBIND,X        POINT TO DIRECTORY ENTRY
    LDA A FIBFTS,X
    LDA B FIBFTS+1,X    GET FIRST T/S OF FILE
    TSX
    LDX UXH,X
    STA A FCBFTS,X      SAVE IN FCB
    STA B FCBFTS+1,X
    LDX FCBIND,X        POINT TO DIRECTORY ENTRY
    LDA A FIBLTS,X
    LDA B FIBLTS+1,X    GET LAST T/S OF FILE
    TSX
    LDX UXH,X
    STA A FCBLTS,X      STORE IN FCB
    STA B FCBLTS+1,X
    LDX FCBIND,X        POINT TO DIRECTORY ENTRY
    LDA A #$20
    STA A 0,X           PUT BLANK INTO NAME FIELD
    LDX #SYSFCB
    LDA A #$FF
    STA A FCBDTT,X      MAKE 'OUTPUT'
    IOHDR               WRITE UPDATED DIRECTORY
    CLR FCBDTT,X        RESTORE 'INPUT' STATE
DEL3A TST FCBSTA,X      CHECK STATUS
    BEQ DEL4            GOOD STATUS?
*
    RTS                 IF NOT, QUIT
*
DEL4 LDA A FCBDRV,X     GET DRIVE NO.
    LDX #SAVFCB         USE SYSTEM FCB
    STA A FCBDRV,X      SET DRIVE NO.
    LDA A #0            GET FREE-SPACE SECTOR
    LDA B #3
    STA A FCBTRK,X      TRACK=0
    STA B FCBSCT,X      SECTOR=3
    CLR FCBDTT,X        INPUT
    IOHDR               READ SECTOR
    LDA A FCBSTA,X      ERRORS?
    BNE DEL3A           YES
*
    LDX FCBDBA,X        POINT TO SECTOR BUFFER
    LDA A SECSIZ-2,X    GET T/S OF FREE-SECTOR
    LDA B SECSIZ-1,X
    STA A SAVEX         SAVE THEM
    STA B SAVEX+1
    TSX
    LDX UXH,X
    LDA A FCBFTS,X      GET FIRST T/S OF FILE
    LDA B FCBFTS+1,X
    LDX #SAVFCB         USE SYSTEM FCB
    LDX FCBDBA,X        POINT TO SECTOR BUFFER
    STA A SECSIZ-2,X    UPDATE LINKAGE
    STA B SECSIZ-1,X
    PSH A               SAVE 'A'
    LDX #SAVFCB         USE SYSTEM FCB
    LDA A FCBDRV,X      GET DRIVE NUMBER
    ASL A               TIMES 2
    LDX #FRETAB         ACCESS FREE-SPACE TABLE
    ADDAX
    PUL A               RESTORE 'A'
    STA A 0,X           UPDATE TABLE
    STA B 1,X
    LDX #SAVFCB         USE SYSTEM FCB
    COM FCBDTT,X        MAKE FCB 'OUTPUT'
    IOHDR               WRITE UPDATED FREE-SPACE SECTCOR
    CLR FCBDTT,X        MAKE FCB 'INPUT'
    LDA A FCBSTA,X      ERRORS?
    BNE DEL3A           YES
*
    TSX
    LDX UXH,X           POINT TO USER FCB
    LDA A FCBLTS,X      GET LAST T/S OF FILE
    LDA B FCBLTS+1,X
    LDX #SAVFCB         USE SYSTEM FCB
    STA A FCBTRK,X
    STA B FCBSCT,X
    IOHDR               READ THAT SECTOR
    LDA A FCBSTA,X      ERRORS?
    BNE DEL3A           YES
*
    LDX FCBDBA,X        POINT TO SECTOR BUFFER
    LDA A SAVEX         GET T/S OF OLD FREE-SPACE
    LDA B SAVEX+1
    STA A 0,X           UPDATE LINKAGES
    STA B 1,X
    LDX #SAVFCB         USE SYSTEM FCB
    COM FCBDTT,X        MAKE FCB 'OUTPUT'
    IOHDR               WRITE UPDATED SECTOR
    CLR FCBDTT,X        MAKE FCB 'INPUT'
    RTS
*
* ROUTINE TO PARSE AN UNAMBIGUOUS FILE NAME
*
* [DRIVE:] FILENAME.EXT
*
* ADDRESS OF TEXT STRING IN 'CUCHAR'
* FCB ADDRESS PASSED IN INDEX REGISTER
* ERRORS RETURN '21' IN STATUS
*
_FMTFCB TSX
    LDX UXH,X       POINT TO FCB
    CLR FCBSTA,X    NO ERRORS YET
    CLR FCBDRV,X    DEFAULT DRIVE=0
    NXTOK           GET A TOKEN
    LDA B RC        CHECK RC
    CMP B #3        NUMBER?
    BNE PARS2       NO
*
    TST VALUE       VALID DRIVE NO.?
    BNE PARS1       NO
*
    LDA A VALUE+1   VALID DRIVE NO.?
    CMP A #3        (4 DRIVES)
    BHI PARS1       NOT VALID
*
    STA A FCBDRV,X  INIT. DRIVE
    BRA PARS1A
*
PARS1 TSX
    LDX UXH,X       POINT TO FCB
    LDA A #21
    STA A FCBSTA,X  RETURN ERROR CODE 21
    CLR VALUE
    CLR VALUE+1     RETURN NO VALUE
    RTS
*
PARS1A NXTOK        GET A TOKEN FROM CLI
    LDA B RC        CHECK RC
    CMP B #':       COLON?
    BNE PARS1       NO, ERROR
*
    NXTOK           GET A TOKEN FROM CLI
    LDA B RC        CHECK RC
PARS2 CMP B #1      UNAMBIG. NAME?
    BEQ PARS4       YES
*
PARS3 TSX
    LDX UXH,X       POINT TO FCB
    LDA A #21
    STA A FCBSTA,X  RETURN ERROR STATUS 21
    RTS
*
PARS4 LDX DESCRA    POINT TO NAME
    STX SAVEX       SAVE POINTER
    LDA A DESCRC    GET LENGTH
    STA A SAVEA     SAVE IT
    NXTOK           GET A TOKEN FROM CLI
    LDA B RC        CHECK RC
    CMP B #'.       PERIOD?
    BNE PARS3       NO, ERROR
*
    INC SAVEA       COUNT PERIOD
    NXTOK           GET A TOKEN FROM CLI
    LDA B RC        CHECK RC
    CMP B #1        UNAMBIG. NAME?
    BNE PARS3       NO, ERROR
*
    LDA B DESCRC    GET LENGTH OF EXT
    ADD B SAVEA     TOTAL LENGTH
    TSX
    LDX UXH,X       POINT TO FCB
    LDA A #FCBNAM
    ADDAX           POINT TO NAME FIELD IN FCB
    PSHX
    LDX SAVEX       POINT TO NAME IN CLI
    PSHX
    FMTS            FORMAT NAME INTO FCB
    INS
    INS             CLEAN STACK
    INS
    INS
    TST B           ERRORS?
    BNE PARS3       YES
*
    RTS

***********************************************************
*   NAM DIRECTORY
*
* OPEN, READ, WRITE DIRECTORY RECORDS ON DISK
* CP-68 AND ICOM 8 INCH FLOPPIES
*   
* @OPEND OPENS DIRECTORY TO FIRST DATA BLOCK
* @GETDR GETS NEXT DATA BLOCK
* @PUTDR WRITES A DATA BLOCK
*
* ADDRESS OF FCB TO USE PASSED IN 'X' (ON STACK)
* MUST SET UP DRIVE NUMBER IN FCB
* MUST SET UP FCB AS 'DSK'
*
* RETURN STATUS IN FCBSTA:  0=BLOCK FOUND
*               1=END OF DIRECTORY
*               ELSE ERROR
*
* ADDRESS OF DATA BLOCK IN FCBIND
***********************************************************

*
* DISK ATTRIBUTES
*
DIRBLK  EQU 32          32 BYTES/DIRECTORY BLOCK
*
    ENT _OPEND
    ENT _GETDR
    ENT _PUTDR
*
    EXT SYSFCB          SYSTEM FCB LOCATION
*
_OPEND TSX
    LDX UXH,X           POINT TO FCB
    CLR FCBDTT,X        INPUT
    CLR FCBTRK,X        TRACK=0
    LDA A #4            SECTOR=4 (START OF DIRECTORY)
*
OPEND0 STA A FCBSCT,X
    CLR FCBSTA,X        ERRORS
    LDA A FCBDBA,X
    LDA B FCBDBA+1,X    POINTER TO BUFFER START
    STA A FCBIND,X      INIT. DIR. BLOCK POINTER
    STA B FCBIND+1,X
    IOHDR               READ SECTOR
    TST A               ERRORS?
    BNE OPEND2          YES
*
OPEND1 LDX FCBIND,X     POINT TO DATA BLOCK
    TST 0,X             FIRST CHAR=0?
    BEQ OPEND3          YES, EOF
*
    TSX
    LDX UXH,X           POINT TO FCB
    CLR FCBSTA,X        RETURN NO ERRORS
    RTS                 RETURN
*
OPEND2 STA A FCBSTA,X   RETURN ERROR CODE
    RTS
*
OPEND3 TSX
    LDX UXH,X           POINT TO FCB
    LDA A #1
    STA A FCBSTA,X      RETURN STATUS=1
    RTS
*
*
*
_GETDR TSX
    LDX UXH,X           POINT TO FCB
    LDA A FCBIND,X
    LDA B FCBIND+1,X
    ADD B #DIRBLK       MOVE INDEX TO NEXT BLOCK
    ADC A #0
    STA A FCBIND,X
    STA B FCBIND+1,X
    LDX FCBDBA,X        BUFFER ADDRESS
    PSH A               SAVE 'A'
    LDA A #SECSIZ
    ADDAX               BUFFER END ADDRESS
    PUL A               RESTORE 'A'
    SUBXAB              COMPARE INDEX TO END-ADDRESS
    BEQ GETDR2          NEED NEW SECTOR?
*
    TSX                 NO
    LDX UXH,X           POINT TO FCB
    CLR A
    STA A FCBSTA,X      CLEAR ERROR STATUS
    BRA OPEND1          FINISH UP
*
GETDR2 TSX
    LDX UXH,X           POINT TO FCB
    LDA A FCBSCT,X
    INC A               NEXT SECTOR
    CMP A #TRKSIZ+1     END OF TRACK?
    BEQ OPEND3          YES, RETURN EOF
*
    JMP OPEND0          NO, GET NEW SECTOR
*
*
_PUTDR TSX
    LDX UXH,X           POINT TO FCB
    LDX FCBIND,X        GET ADDRESS OF DIR. BLOCK
    PSHX                STACK IT
    TSX
    LDX UXH+2,X         GET ADDRESS OF FCB
    LDA A #FCBNAM
    ADDAX               POINT TO NAME FIELD IN FCB
    PSHX                STACK IT
    LDA B #21           21 BYTES TO MOVE
    MOVC                MOVE FROM FCB TO DIR. BLOCK
    INS
    INS                 CLEAN STACK
    INS
    INS
    LDX >SYSFCB+1       POINT TO SYSTEM FCB
    COM FCBDTT,X        MAKE OUTPUT
    IOHDR               ISSUE I/O REQUEST
    TSX
    LDX UXH,X           POINT TO FCB
    STA A FCBSTA,X      RETURN STATUS
    RTS
*

***********************************************************
*   NAM SFIO
*
* SEQUENTIAL FILE I/O PACKAGE
* @OPEN     OPEN SEQUENTIAL FILE FOR R/W
* @CLOSE    CLOSE SEQUENTIAL FILE
* @READ     READ A BYTE FROM SEQUENTIAL FILE
* @WRITE    WRITE A BYTE INTO A SEQUENTIAL FILE
* @REWD     REWIND A SEQUENTIAL FILE
*
* INDEX REGISTER (STACKED) POINTS TO FCB
* CHARACTERS PASSED IN 'A' REGISTER
*
* STATUS CODES: (IN FCBSTA)
*
*    0=GOOD
*    1=END OF DIRECTORY
*    2=FILE IN USE
*    3=FILE ALREADY EXISTS
*    4=NO SUCH FILE
*    5=I/0 ERROR
*    6=TOO MANY FILES FOR DIRECTORY
*    7=DISK FULL
*    8=END-FILE FOUND
*    9=BAD SECTOR
*   10=DEVICE NOT READY
*   13=ILLEGAL USE OF FCB
*   18=ILLEGAL OPERATION (WRITE TO READ FILE, ETC.)
*   21=BAD FILE NAME
***********************************************************

*
* DISK ATTRIBUTES:
*
BUFSIZ  FDB SECSIZ
*
*
    ENT _OPEN
    ENT _CLOSE
    ENT _READ
    ENT _WRITE
    ENT _REWD
*
    EXT SEMPTY
    EXT SFILE
    EXT SYSFCB
*
_OPEN TSX
    LDX UXH,X           POINT TO FCB
    TXAB
    LDX FCBCHN          START OF ACTIVE-FCB CHAIN
    BEQ OPEN3           EMPTY CHAIN?
*
OPEN1 PSHX
    SUBABX              FOUND FCB?
    PULX
    BEQ OPEN2           YES, ERROR
*
    LDX FCBNFB,X        GET NEXT CHAINED FCB
    BNE OPEN1           IF NOT END OF CHAIN, LOOP
*
    BRA OPEN3           IF END, OK
*
OPEN2 TABX              POINT TO FCB
    LDA A #13           ERROR STATUS (FILE ALREADY 0PEN)
    STA A FCBSTA,X
    RTS
*
OPEN3 TABX              POINT TO FCB
    TST FCBDTT,X        READ OR WRITE?
    BEQ OPENR           READ
*
    JMP OPENW           WRITE
*
* OPEN SEQUENTIAL FILE FOR INPUT
*
OPENR JSR SFILE         SEARCH DIRECTORY
    TST FCBSTA,X        CHECK STATUS
    BEQ OPENR1          GOOD?
*
    LDA A #4            ERROR STATUS (NO SUCH FILE)
    STA A FCBSTA,X
    RTS
*
OPENR1 LDA A #FCBTYP
    ADDAX               POINT TO TYPE FIELD IN FCB
    PSHX                STACK ADDRESS
    TSX
    LDX UXH+2,X         POINT TO FCB
    LDX FCBIND,X        POINT TO DIRECTORY BLOCK
    LDA A #FIBTYP
    ADDAX               POINT TO TYPE FIELD IN DIR. BLOCK
    PSHX                STACK ADDRESS
    LDA B #8            8 BYTES TO MOVE FROM DIR. TO FCB.
    MOVC
    INS
    INS                 CLEAN STACK
    INS
    INS
    TSX
    LDX UXH,X           POINT TO FCB
    LDA A FCBFTS,X
    LDA B FCBFTS+1,X
    STA A FCBTRK,X      INIT. TRACK/SECTOR
    STA B FCBSCT,X
    IOHDR               READ FIRST SECTOR OF FILE
    TST A               ERROR?
    BEQ OPENR2          NO
*
    STA A FCBSTA,X      RETURN ERROR STATUS
    RTS
*
OPENR2 LDX FCBDBA,X     POINT TO SECTOR BUFFER
    LDA A 0,X           GET FORWARD LINKS
    LDA B 1,X
    TSX
    LDX UXH,X           POINT TO FCB
    STA A FCBFWD,X      PUT IN LINKS
    STA B FCBFWD+1,X
    LDX FCBDBA,X        POINT TO SECTOR BUFFER
    LDA A 2,X           GET BACKWARD LINKS
    LDA B 3,X
    TSX
    LDX UXH,X           POINT TO FCB
    STA A FCBBAK,X      PUT IN BACKWARD LINKS
    STA B FCBBAK+1,X
OPENR3 LDA A FCBDBA,X
    LDA B FCBDBA+1,X
    ADD B #4            INIT. BUFFER INDEX
    ADC A #0
    STA A FCBIND,X
    STA B FCBIND+1,X
*   
* PUT FCB ONTO ACTIVE-FCB CHAIN
* COMMON TO READ AND WRITE
* (X) POINTS TO FCB
*
OPEN4 CLR FCBNFB,X      MAKE FCB END OF CHAIN
    CLR FCBNFB+1,X
    LDX FCBCHN          SEARCH CHAIN FOR END LINK
    BNE OPEN5           EMPTY CHAIN?
*
    TSX
    LDA A UXH,X         GET FCB ADDRESS INTO (A,B)
    LDA B UXL,X
    STA A FCBCHN        INIT. CHAIN
    STA B FCBCHN+1
    TABX                RESTORE FCB ADDRESS
    CLR FCBSTA,X        GOOD STATUS
    RTS
*
OPEN5 TST FCBNFB,X      AT END OF CHAIN?
    BNE OPEN6           NO
    TST FCBNFB+1,X      AT END OF CHAIN?
    BNE OPEN6           NO
*
    PSHX                SAVE END OF CHAIN ADDRESS
    TSX
    LDA A UXH+2,X       GET FCB ADDRESS INTO (A,B)
    LDA B UXL+2,X
    PULX
    STA A FCBNFB,X      PATCH CHAIN
    STA B FCBNFB+1,X
    TABX                RESTORE FCB ADDRESS
    CLR FCBSTA,X        GOOD STATUS
    RTS
*
OPEN6 LDX FCBNFB,X      GET NEXT LINK IN CHAIN
    BRA OPEN5
*
*
* OPEN SEQUENTIAL FILE FOR OUTPUT
*
OPENW JSR SFILE         SEARCH DIRECTORY
    LDA A FCBSTA,X      CHECK STATUS
    CMP A #1            FILE FOUND?
    BEQ OPENW1          NO
*
    LDA A #3            ERROR STATUS (FILE EXISTS)
    STA A FCBSTA,X
    RTS
*
OPENW1 LDA A FCBDRV,X   GET DRIVE NO.
    JSR SEMPTY          SEARCH FOR DIR. SPACE
    LDX >SYSFCB+1       POINT TO SYSTEM FCB
    LDA A FCBSTA,X      CHECK STATUS
    BEQ OPENW4          GOOD?
*
    CMP A #1            NO ROOM IN DIRECTORY?
    BEQ OPENW3          YES
*
OPENW2 TSX
    LDX UXH,X           POINT TO FCB
    STA A FCBSTA,X      RETURN ERROR STATUS
    RTS
*
OPENW3 LDA A #6         ERROR STATUS (NO ROOM)
    BRA OPENW2
*
OPENW4 LDA A FCBIND,X   GET DIR. BLOCK ADDRESS FROM SYS.
    LDA B FCBIND+1,X
    TSX
    LDX UXH,X           POINT TO FCB
    STA A FCBIND,X      SAVE ADDRESS
    STA B FCBIND+1,X
    CLR FCBNMS,X        INIT. NO. SECTORS=0
    CLR FCBNMS+1,X
    CLR FCBLTS,X        INIT. LAST T/S=0,0
    CLR FCBLTS+1,X
    CLR FCBBAK,X        INIT. BACKWARD POINTERS
    CLR FCBBAK+1,X
    LDA A FCBDRV,X      GET DRIVE NO.
    AND A #$03          LIMIT RANGE (0-3)
    ASL A               2 BYTES PER ENTRY
    LDX #FRETAB         ACCESS FREE-SPACE TABLE
    ADDAX
    PSHX                SAVE TABLE POINTER
    LDA A 0,X           GET FREE T/S
    LDA B 1,X
    TST A               TABLE INIT. YET?
    BEQ OPNW4           NO
*
    TST B               TABLE INIT. YET?
    BNE OPENW6          YES
*
* MUST READ IN FREE-SPACE SECTOR AND INIT. FREE-SPACE TABLE
*
OPNW4 TSX
    LDX UXH+2,X         POINT TO FCB
    CLR FCBDTT,X        MAKE 'INPUT'
    LDA A #0            TRACK=0
    LDA B #3            SECTOR=3 (FREE-SPACE RECORD)
    STA A FCBTRK,X
    STA B FCBSCT,X
    IOHDR               ISSUE READ COMMAND
    COM FCBDTT,X        PUT 'OUPUT' BACK
    TST A               ERROR?
    BEQ OPENW5          NO
*
    STA A FCBSTA,X      RETURN ERROR CODE
    INS                 CLEAN STACK
    INS
    RTS                 QUIT
*
OPENW5 LDX FCBDBA,X     POINT TO DATA BUFFER
    LDA A SECSIZ-2,X    GET T/S OF FREE SPACE
    LDA B SECSIZ-1,X
    PULX                RECOVER FREE-SPACE TABLE POINTER
    PSHX                PUT BACK ON STACK
    STA A 0,X           INIT. FREE-SPACE TABLE
    STA B 1,X
*
OPENW6 TSX
    LDX UXH+2,X         POINT TO FCB
    TST A               AT END OF DISK?
    BEQ OPNW6A          YES
*
    TST B               AT END OF DISK?
    BNE OPNW6B          NO
*
OPNW6A LDA A #7         END OF DISK ERROR
    STA A FCBSTA,X
    INS
    INS
    RTS
*
OPNW6B STA A FCBFTS,X   INIT. FIRST T/S
    STA B FCBFTS+1,X
    STA A FCBTRK,X      POINT TO THAT T/S
    STA B FCBSCT,X
    PUTDR               UPDATE DIRECTORY
    TST FCBSTA,X        CHECK STATUS
    BEQ OPENW7          GOOD
*
    INS
    INS                 CLEAN STACK
    RTS                 QUIT
*
OPENW7 CLR FCBDTT,X     MAKE 'INPUT'
    IOHDR               ISSUE READ COMMAND
    COM FCBDTT,X        RESTORE 'OUTPUT'
    TST A               CHECK FOR ERROR
    BEQ OPENW8          GOOD
*
    STA A FCBSTA,X      RETURN ERROR CODE
    INS
    INS                 CLEAN STACK
    RTS                 QUIT
*
OPENW8 LDX FCBDBA,X     POINT TO DATA BUFFER
    LDA A 0,X           GET FORWARD POINTERS
    LDA B 1,X
    PULX                RECOVER FREE-SPACE TABLE POINTER
    TST A               OUT OF SPACE?
    BNE OPENW9          NO
*
    TST B               OUT OF SPACE?
    BNE OPENW9          NO
*
    LDA A #7            RETURN ERROR CODE (OUT OF SPACE)
    TSX
    LDX UXH,X           POINT TO FCB
    STA A FCBSTA,X
    RTS
*
OPENW9 STA A 0,X        UPDATE FREE-SPACE TABLE
    STA B 1,X
    TSX
    LDX UXH,X           POINT TO FCB
    LDX FCBDBA,X        POINT TO DATA BUFFER
    LDA B #SECSIZ-4
OPNW9A CLR 4,X          CLEAR OUT BUFFER
    INX
    DEC B
    BNE OPNW9A
*
    TSX
    LDX UXH,X           POINT TO FCB
    JMP OPENR3          FINISH UP LIKE READ
_CLOSE  TSX
    LDA A UXH,X
    LDA B UXL,X         GET FCB ADDRESS
    LDX FCBCHN          GET HEAD OF FCB CHAIN
    BEQ NOCHN           NO ACTIVE FCBS?
*
    PSHX                SAVE X
    SUBABX              AT DESIRED FCB?
    PULX                RESTORE X
    BNE NOTFND          NO
*
    LDA A FCBNFB,X
    LDA B FCBNFB+1,X
    STA A FCBCHN        NEW CHAIN HEAD
    STA B FCBCHN+1
    BRA CLOSE2          FINISH
*
NOTFND CMP A FCBNFB,X   AT DESIRED FCB?
    BNE NXTFCB          NO
*
    CMP B FCBNFB+1,X    AT DESIRED FCB?
    BNE NXTFCB          NO
*
* FIX ACTIVE FCB CHAIN TO GO AROUND THIS FCB
* (X) POINTS TO PREVIOUS FCB
* (A,B) POINTS TO THIS FCB
*
    PSHX
    TABX                POINT TO THIS FCB
    LDA A FCBNFB,X      GET ITS LINKAGE
    LDA B FCBNFB+1,X
    PULX                POINT TO PREVIOUS FCB
    STA A FCBNFB,X      UPDATE ITS LINKAGE
    STA B FCBNFB+1,X
    BRA CLOSE2          FINISH PROCESSING
*
NXTFCB LDX FCBNFB,X     GET NEXT FCB ADDRESS
    BNE NOTFND          IF NOT END OF CHAIN, KEEP GOING
*
NOCHN TABX              POINT TO THIS FCB
    LDA A #13           RETURN ERROR CODE (CAN'T FIND FCB)
    STA A FCBSTA,X
    RTS
*
*
*
CLOSE2 TSX
    LDX UXH,X           POINT TO THIS FCB
    TST FCBDTT,X        READ OR WRITE?
    BNE CLOSEW          WRITE
*
    RTS                 READ IS DONE
*
CLOSEW TST FCBTRK,X     AT END OF DISK?
    BEQ CLSW1           YES
*
    TST FCBSCT,X        AT END OF DISK?
    BNE CLSW2           NO
*
CLSW1 LDA A FCBBAK,X
    LDA B FCBBAK+1,X
    STA A FCBTRK,X
    STA B FCBSCT,X
    BRA CLSW3           ERROR FIX-UP FOR END-OF-DISK
*
CLSW2 IOHDR             WRITE OUT LAST SECTOR OF FILE
    LDA A FCBNMS,X
    LDA B FCBNMS+1,X
    ADD B #1            ONE MORE SECTOR IN COUNT
    ADC A #0
    STA A FCBNMS,X
    STA B FCBNMS+1,X
*
* LAST SECTOR NOW ON DISK
* UPDATE DIRECTORY INFORMATION
*
CLSW3 CLR FCBDTT,X      MAKE 'INPUT'
    JSR SFILE           FIND DIRECTORY SLOT
    TSX
    LDX UXH,X           POINT TO FCB
    COM FCBDTT,X        RESTORE 'OUTPUT'
    TST FCBSTA,X        CHECK STATUS
    BEQ CLOSE3          GOOD
*
    RTS                 IF NO GOOD, PUNT!!!
*
CLOSE3 LDA A FCBTRK,X   GET LAST TRACK WRITTEN
    LDA B FCBSCT,X      SECTOR
    STA A FCBLTS,X      PUT INTO FCB POSITION
    STA B FCBLTS+1,X
    PUTDR               WRITE DATA INTO DIRECTORY
    TST FCBSTA,X        GOOD WRITE?
    BEQ CLOSE4          YES
*
    RTS                 NO GOOD, QUIT!!
*
CLOSE4 CLR FCBDTT,X     MAKE 'INPUT'
    LDA A #0            TRACK=0
    LDA B 3             SECTOR=3 (FREE-SPACE RECORD)
    STA A FCBTRK,X
    STA B FCBSCT,X
    IOHDR               READ FREE-SPACE RECORD
    COM FCBDTT,X        RESTORE 'OUTPUT'
    TST A               ERROR?
    BEQ CLOSE5          NO
*
    RTS                 BAD READ, QUIT!!
*
CLOSE5 LDA A FCBDRV,X   GET DRIVE NO.
    AND A #$03          LIMIT RANGE (0-3)
    ASL A               2 BYTES/ENTRY
    LDX #FRETAB         ACCESS FREE-SPACE TABLE
    ADDAX
    LDA A 0,X           GET TRACK/SECTOR
    LDA B 1,X
    TSX
    LDX UXH,X           POINT TO FCB
    LDX FCBDBA,X        POINT TO DATA BUFFER
    STA A SECSIZ-2,X    PUT NEW T/S INTO BUFFER
    STA B SECSIZ-1,X
    TSX
    LDX UXH,X           POINT TO FCB
    IOHDR               WRITE OUT UPDATED SECTOR
    STA A FCBSTA,X      SAVE STATUS
    RTS
_READ TSX
    LDX UXH,X           POINT TO FCB
    TST FCBDTT,X        INPUT REQUESTED?
    BEQ READ2           OK
*
    LDA A #18           ERROR CODE
    STA A FCBSTA,X
    RTS                 QUIT
*
READ2 LDA A FCBIND,X    CHECK FOR END OF BUFFER
    LDA B FCBIND+1,X
    SUB B FCBDBA+1,X
    SBC A FCBDBA,X
    CMP A >BUFSIZ       AT END?
    BNE READ2A          NO
*
    CMP B >BUFSIZ+1     AT END?
    BEQ READ3           YES
*
READ2A LDX FCBIND,X     POINT TO BUFFER
    LDA A 0,X           GET BYTE
*
* CHECK FOR SPACE COMPRESSION
* IN SPACE-COMPRESSION MODE, BYTE= NEGATIVE SPACE COUNT
*
    BPL READ2C          NOT A COMPRESSED SPACE
*
    TSX
    LDX UXH,X           POINT TO FCB
    TST FCBSCF,X        IN COMPRESSED MODE?
    BEQ READ2B          NO
*
    LDX FCBIND,X        POINT TO BUFFER
    INC A               ONE FEWER SPACE
    BNE NOTLST          LAST SPACE?
*
    LDA A #$20          IF SO, REPLACE WITH SPACE
    BRA READ2C
*
NOTLST STA A 0,X        PUT NEW CHAR. IN BUFFER
    LDA A #$20          OUTPUT A SPACE
    TSX
    STA A UA,X
    LDX UXH,X           POINT TO FCB
    CLR FCBSTA,X        GOOD STATUS
    RTS                 DONE
*
READ2B  LDX FCBIND,X    POINT TO BUFFER
*
READ2C INX              MOVE BUFFER POINTER
    PSHX                STACK IT
    TSX
    STA A UA+2,X        RETURN BYTE
    PUL A               GET POINTER FROM STACK
    PUL B
    TSX
    LDX UXH,X           POINT TO FCB
    STA A FCBIND,X      SAVE NEW POINTER
    STA B FCBIND+1,X
    CLR FCBSTA,X        GOOD STATUS
    RTS                 DONE
*
*
*
READ3 LDA A FCBTRK,X
    CMP A FCBLTS,X      AT END OF FILE?
    BNE READ4           NO
*
    LDA A FCBSCT,X
    CMP A FCBLTS+1,X    AT END OF FILE?
    BNE READ4           NO
*
    LDA A #8            RETURN END-FILE STATUS
READ3A  STA A FCBSTA,X
    RTS
*
READ4 LDA A FCBFWD,X    GET FORWARD LINK T/S
    LDA B FCBFWD+1,X
    STA A FCBTRK,X      PUT LINK INTO T/S
    STA B FCBSCT,X
    IOHDR               READ LINKED SECTOR
    TST A               ERROR CHECK
    BNE READ3A          RETURN ERROR CODE
*
    LDA A FCBDBA,X
    LDA B FCBDBA+1,X
    ADD B #4            RE-INIT. INDEX
    ADC A #0            SKIP FOUR BYTES OF LINK
    STA A FCBIND,X
    STA B FCBIND+1,X
    LDX FCBDBA,X        POINT TO BUFFER
    LDA A 0,X           GET NEW FORWARD LINKS
    LDA B 1,X
    TSX
    LDX UXH,X           POINT TO FCB
    STA A FCBFWD,X      STORE FORWARD LINKS
    STA B FCBFWD+1,X
    LDX FCBDBA,X        POINT TO BUFFER
    LDA A 2,X           GET NEW BACKWARD LINKS
    LDA B 3,X
    TSX
    LDX UXH,X           POINT TO FCB
    STA A FCBBAK,X      STORE BACKWARD LINKS
    STA B FCBBAK+1,X
    JMP READ2A          NOW READ BYTE
*
_WRITE  TSX
    LDX UXH,X           POINT TO FCB
    TST FCBDTT,X        CHECK FOR OUTPUT
    BNE WRITE2          OK
*
    LDA A #18
    STA A FCBSTA,X      RETURN ERROR CODE
    RTS                 QUIT
*
WRITE2 LDA A FCBIND,X   CHECK FOR END OF BUFFER
    LDA B FCBIND+1,X
WRIT20 SUB B FCBDBA+1,X
    SBC A FCBDBA,X
    CMP A >BUFSIZ       END OF BUFFER?
    BNE WRIT2A          NO
*
    CMP B >BUFSIZ+1     END OF BUFFER?
    BEQ WRITE3          YES
*
WRIT2A TSX
    LDA A UA,X          GET CHARACTER TO BE WRITTEN
    LDX UXH,X           POINT TO FCB
    TST FCBSCF,X        IN SPACE-COMPRESSION MODE?
    BEQ WRIT2B          NO
*
*
* HANDLE COMPRESSION OF SPACES HERE
* USE NEGATIVE COUNT OF SPACES
*
    AND A #$7F          STRIP HIGH BIT
    CMP A #$20          SPACE?
    BNE WRIT2B          NO
*
    LDX FCBIND,X        POINT TO BUFFER
    LDA B 0,X           GET BYTE FROM BUFFER
    BPL NEWSPC          FIRST SPACE?
*
    DEC B               ONE MORE SPACE ADDED
    BPL SPC128          SPACE COUNT>128?
*
STRSPC STA B 0,X        PUT COUNT BACK
    TSX
    LDX UXH,X           POINT TO FCB
    CLR FCBSTA,X        GOOD STATUS
    RTS                 DONE
*
NEWSPC LDA B #$FF       FIRST COMPRESSED SPACE
    BRA STRSPC
*
SPC128 INX              MOVE POINTER
    TXAB
    TSX
    LDX UXH,X           POINT TO FCB
    STA A FCBIND,X      SAVE NEW POINTER
    STA B FCBIND+1,X    
    BRA WRIT20          CONTINUE WITH SPACE
*
*
*
WRIT2B LDX FCBIND,X     POINT TO BUFFER
    TST 0,X             CHAR. ALREADY THERE?
    BNE SPC128          YES
*
    STA A 0,X           STORE CHARACTER IN BUFFER
    INX                 MOVE POINTER
    TXAB
    TSX
    LDX UXH,X           POINT TO FCB
    STA A FCBIND,X      PUT NEW INDEX IN FCB
    STA B FCBIND+1,X
    CLR FCBSTA,X        GOOD STATUS
    RTS                 DONE
*
WRITE3 LDA A FCBDRV,X   GET DRIVE NO.
    AND A #$03          LIMIT RANGE (0-3)
    LDX #FRETAB         ACCESS FREE-SPACE TABLE
    ASL A               TWO BYTES/ENTRY
    ADDAX
    LDA A 0,X           GET FREE-TRACK
    BEQ WRIT3A          END OF DISK?
*
    LDA B 1,X           GET FREE-SECTOR
    BEQ WRIT3A          END OF DISK?
*
    TSX
    LDX UXH,X           POINT TO FCB
    LDX FCBDBA,X        POINT TO DATA BUFFER
    STA A 0,X           NEW FORWARD LINK TRACK
    STA B 1,X           NEW FORWARD LINK SECTOR
    TSX
    LDX UXH,X           POINT TO FCB
    IOHDR               WRITE OUT SECTOR
    TST A               ERROR?
    BEQ WRITE4          NO
*
    STA A FCBSTA,X      RETURN ERROR STATUS
    RTS
*
WRIT3A JMP WRITE7       MAKE ERROR RETURN
*
WRITE4 LDA A FCBNMS,X   GET SECTOR COUNT
    LDA B FCBNMS+1,X
    ADD B #1            INCREMENT IT
    ADC A #0
    STA A FCBNMS,X
    STA B FCBNMS+1,X
    LDA A FCBTRK,X      GET TRACK JUST WRITTEN
    LDA B FCBSCT,X      GET SECTOR
    STA A FCBBAK,X      PUT IN BACK LINK
    STA B FCBBAK+1,X    
    LDA A FCBDRV,X      GET DRIVE NO.
    AND A #$03          LIMIT RANGE (0-3)
    LDX #FRETAB         ACCESS FREE-SPACE TABLE
    ASL A               2 BYTES/ENTRY
    ADDAX
    LDA A 0,X           GET NEXT TRACK
    LDA B 1,X           GET NEXT SECTOR
    PSHX                SAVE INDEX TO FREE-SPACE TABLE
    TSX
    LDX UXH+2,X         POINT TO FCB
    STA A FCBTRK,X      NEW TRACK TO GET
    STA B FCBSCT,X      NEW SECTOR
    CLR FCBDTT,X        MAKE INPUT
    IOHDR               READ IN SECTOR
    COM FCBDTT,X        REPLACE 'OUTPUT'
    TST A               ERROR?
    BEQ WRITE5          NO
*
    STA A FCBSTA,X      RETURN ERROR CODE
    INS                 CLEAN STACK
    INS
    RTS
*
WRITE5 LDX FCBDBA,X     POINT TO BUFFER
    LDA A 0,X           GET-NEW LINK TRACK
    LDA B 1,X           GET NEW SECTOR
    PULX                RECOVER FREE-SPACE INDEX
    STA A 0,X           PUT LINK INTO TABLE
    STA B 1,X
    TSX
    LDX UXH,X           POINT TO FCB
    STA A FCBFWD,X      SET FORWARD LINKS
    STA B FCBFWD+1,X
    LDA A FCBDBA,X      GET BUFFER ADDRESS
    LDA B FCBDBA+1,X
    ADD B #4            RE-INIT. BUFFER INDEX
    ADC A #0
    STA A FCBIND,X
    STA B FCBIND+1,X
    LDA A FCBBAK,X      GET BACKWARD LINK
    LDA B FCBBAK+1,X
    LDX FCBDBA,X        POINT TO BUFFER
    STA A 2,X           PUT IN BACKWARD LINKS
    STA B 3,X
    LDA B #SECSIZ-4
WRITE6 CLR 4,X          ZERO OUT REST OF BUFFER
    INX
    DEC B
    BNE WRITE6
*
    JMP WRIT2A          CONTINUE WITH NEW SECTOR
*
WRITE7 LDA A #7         DISK FULL ERROR
    TSX
    LDX UXH,X           POINT TO FCB
    STA A FCBSTA,X
    RTS
_REWD TSX
    LDX UXH,X           POINT TO FCB
    TST FCBDTT,X        CHECK FOR INPUT
    BEQ REWD2           OK?
*
    LDA A #18           ERROR CODE (REWIND OUTPUT FILE)
    STA A FCBSTA,X
    RTS
*
REWD2 CLR FCBSTA,X
    CLOSE               CLOSE FILE
    TST FCBSTA,X        CHECK STATUS
    BEQ REWD3           OK?
*
    RTS                 RETURN ERROR STATUS
*
REWD3 OPEN              RE-OPEN FILE
    RTS
*

***********************************************************
*   NAM ICOMDRV
*
* DISK DRIVERS FOR ICOM
* SINGLE-SECTOR READ/WRITE
* TO BE USED WITH CP-68 SYSTEM
***********************************************************

        ENT _INTDK      INITIALIZE INTERFACE
        ENT .RDSEC      READ A SECTOR
        ENT .WTSEC      WRITE A SECTOR
*
* PIA DEFINTIONS
*
INDAT   EQU $EC00       DATA/STATUS INPUT
INCTL   EQU $EC01       DATA/STATUS CONTROL
CMDDAT  EQU $EC02       COMMAND OUTPUT
CMDCTL  EQU $EC03       COMMAND CONTROL
OUTDAT  EQU $EC06       DATA OUTPUT
OUTCTL  EQU $EC07       DATA OUTPUT CONTROL
*
* CONTROL COMMAND DEFINTIONS
*
READX   EQU $02         READ
WRITEX  EQU $04         WRITE
RDCRC   EQU $06         READ CRC
SEEK    EQU $08         SEEK
CLRERF  EQU $0A         RESET ERROR FLAGS
SEEKT0  EQU $0C         SEEK TRACK 0
LDTRAD  EQU $10         LOAD TRACK ADDRESS
LDUS    EQU $20         LOAD UNIT/SECTOR
LDWBF   EQU $30         LOAD WRITE BUFFER
SHFTRB  EQU $40         SHIFT READ BUFFER
CLEAR   EQU $80         CLEAR
*
* NOTE: .RDSEC AND .WTSEC CALLED AS SUBROUTINES
*
* INITIALIZE DISK INTERFACE
*
_INTDK CLR INCTL        CLEAR CONTROL REGISTER
    CLR CMDCTL
    CLR OUTCTL
    CLR INDAT           DDR=INPUT
*
    LDA A #$FF
    STA A CMDDAT        DDR=OUTPUT
    STA A OUTDAT
*
    LDA A #$04
    STA A INCTL         INIT. CREG
    STA A OUTCTL
    LDA A #$2C
    STA A CMDCTL        INIT. CREG
*
    LDA A #CLEAR
    STA A CMDDAT        ISSUE CLEAR COMMAND
*
    LDA A #SEEKT0
    JSR OUTCMD          SEEK TRACK 0
*
    RTS
*
* SET UP FOR SINGLE-SECTOR READ
* GET DATA FROM FCB
* FCB ADDRESS IN (A,B)
*
.RDSEC TABX             POINT X TO FCB
    LDA A FCBDRV,X
    CLC
    ROR A               MOVE UNIT BITS
    ROR A
    ROR A
    ORA A FCBSCT,X
    LDA B FCBTRK,X
    LDX FCBDBA,X
*
* READ A SECTOR INTO BUFFER
*
* A=U/S
* B=TRACK
* X=BUFFER ADDRESS
*
GETBUF JSR XMITUS       SEND UNIT/SECTOR
    JSR DRIVCK          DRIVE OK?
    BCC GETBF0          YES
*
    BRA QUIT            NO, DRIVE BAD
*
GETBF0 TBA              A=TRACK
    JSR SEEKTK          SEEK TRACK
*
    LDA B #5            5 RETRIES
*
GETBF1 LDA A #READX
    JSR OUTCMD          ISSUE READ COMMAND
    LDA A INDAT         GET STATUS
    BIT A #$08          CRC ERROR?
    BEQ GETBF2          NO
*
    JSR ERFRST          RESET ERROR FLAGS
    DEC B               TRIED ENOUGH?
    BNE GETBF1          NO. KEEP TRYING
*
    LDA A #5            RETURN ERROR CODE=5
    BRA QUIT
*
GETBF2 BIT A #$80       DDAM?
    BEQ GETBF3          NO
*
    LDA A #9            RETURN ERROR CODE=9
    BRA QUIT
*
GETBF3  LDA B #128      128 BYTES IN SECTOR
*
GETBF4  LDA A #$3C
    STA A CMDCTL        INIT. COMMAND CONTROL REGISTER
    LDA A #SHFTRB
    STA A CMDDAT        READ DATA COMMAND
*
    LDA A INDAT         GET A BYTE
    PSH A               SAVE IT
*
    LDA A #$2C
    STA A CMDCTL        RESET COMMAND CONTROL
*
    LDA A #SHFTRB       STROBE
    STA A CMDDAT        READ
    CLR CMDDAT          BUFFER
*
    PUL A               GET DATA BYTE
    STA A 0,X           MOVE TO BUFFER
    INX
    DEC B               DONE WITH BUFFER?
    BNE GETBF4          NO
*
    CLR A               YES, SET RC
*
QUIT TSX
    STA A UA,X          RETURN 'A' CONTENTS
    LDX UXH,X           GET RCBADR
    ORA A FCBSTA,X
    STA A FCBSTA,X      RETURN STATUS
    RTS
*
* SET UP FOR SINGLE SECTOR WRITE
* ADDRESS OF FCB PASSED IN (A,B)
*
.WTSEC  TABX            POINT X TO FCB
    LDA A FCBDRV,X
    CLC
    ROR A
    ROR A
    ROR A               MOVE UNIT BITS
    ORA A FCBSCT,X
    LDA B FCBTRK,X
    LDX FCBDBA,X
*
* WRITE A SECTOR TO DISK
*
* A=U/S
* B=TRACK
* X=BUFFER ADDRESS
*
WRTBUF PSH A        SAVE U/S
    PSH B           SAVE TRACK
*
    LDA B #128      128 BYTES IN BUFFER
*
WRTBF0 LDA A 0,X    GET A BYTE
    INX
    STA A OUTDAT    OUTPUT BYTE
    LDA A #LDWBF
    STA A CMDDAT    LOAD WRITE BUFFER
    DEC B
    BNE WRTBF0      LOOP UNTIL DONE
*
    PUL B           RESTORE TRACK
    PUL A           RESTORE U/S
*
    JSR XMITUS      SEND U/S
    JSR DRIVCK      DRIVE OK?
    BCC WRTBF1      YES
*
    BRA QUIT        NO. DRIVE BAD
*
WRTBF1 TBA          A=TRACK
    JSR SEEKTK      SEEK TRACK
*
    LDA B #5        5 RETRIES
*
WRTBF2 LDA A #WRITEX
    JSR OUTCMD      SEND WRITE COMMAND
*
    LDA A #RDCRC
    JSR OUTCMD      SEND CHECK CRC COMMAND
    LDA A INDAT     GET STATUS
    BIT A #$08      OK?
    BEQ WRTBF3      YES
*
    JSR ERFRST      RESET ERROR FLAGS
    DEC B
    BNE WRTBF2      RETRIED 5 TIMES YET?
*
    LDA A #5        YES, ERROR CODE=5
    BRA QUIT
*
WRTBF3 CLR A        SET RC
    BRA QUIT
*
* TRANSMIT UNIT/SECTOR FROM 'A'
*
XMITUS JSR ERFRST   CLEAR ERROR FLAGS
    STA A OUTDAT    OUTPUT U/S
    LDA A #LDUS
    STA A CMDDAT    SEND LOAD U/S COMMAND
    RTS
*
* OUTPUT COMMAND FROM 'A'
*
OUTCMD PSH A        SAVE COMMAND
    LDA A INDAT     CLEAR BUSY FLAG
    PUL A           RESTORE COMMAND
    STA A CMDDAT    OUTPUT COMMAND
*
OUTCM1 LDA A INCTL  DONE?
    BPL OUTCM1      WAIT FOR DONE
*
    LDA A INDAT     CLEAR BUSY
    RTS
*
* CLEAR ERROR FLAGS
*
ERFRST PSH A        SAVE U/S
    LDA A #CLRERF
    STA A CMDDAT    ISSUE RESET-FLAGS COMMAND
    PUL A           RESTORE U/S
    RTS
*
* SEEK TRACK IN 'A'
*
SEEKTK STA A OUTDAT OUTPUT TRACK
    LDA A #LDTRAD
    STA A CMDDAT    SEND LOAD-TRACK-ADDRESS COMMAND
    LDA A #SEEK
    JSR OUTCMD      SEND SEEK COMMAND
    RTS
*
* DRIVE CHECK
*
DRIVCK LDA A INDAT  GET STATUS
    AND A #$20      DISK READY?
    BNE DRVCK1      NO
*
    CLR A           DRIVE OK
    CLC
    RTS
*
DRVCK1 SEC
    LDA A #10       RETURN ERROR=10
    RTS
*
    END

