$MACRO POP   &P1,&P2
$REM it shouldn't be this hard!
$SET &L1,'(R10)'
&P0    MOV   @&P1&L1,&P2
$END
$MACRO SAVERT
&P0    DECT R10
       MOV  R14,*R10
$END
$MACRO RETN
&P0    MOV  *R10+,R14
       RTWP
$END
$MACRO PUSH &P1
&P0    DECT R10
       MOV  &P1,*R10
$END
       TITL 'c99 FILE I/O ROUTINES'
*      IDT  'cfio20a'
*
*  (C) 1985, 1990 CLINT PULLEY
*
* LAST EDIT 90/07/02  0850
*
       DEF  FOPEN,FCLOSE,GETC,PUTC,FGETS,FPUTS
       DEF  FREAD,FWRITE,FSEEK,REWIND,FDELET,FERRC,FEOF
       REF  VSBW,VMBW,VSBR,VMBR,DSRLNK,VDPWD
       REF  C$HOOK,GETCHA,PUTCHA,GETS,PUTS
       REF  C$WORK
*
* 90/07/02 - ADDED INTERNAL FILETYPE RECOGNITION
*
* FILE INFORMATION TABLE (FIT)
*
* ENTRY FORMAT :
*
* WORD 0 - STATUS (0 IF FREE ELSE RECORD LENGTH)
*      1 - VRAM PAB ADDRESS
*      2 - (MSB) PAB BYTE 1
*          (LSB) ERROR CODE
*      3 - VRAM BUFFER ADDRESS
*      4 - BUFFER POINTER
*      5 - CHAR COUNTER
*
* ENTRY OFFSETS :
*
PABADD EQU  2
PBT1   EQU  4
ERRST  EQU  5
BUFADD EQU  6
BPTR   EQU  8
CCTR   EQU  10
*
* POINTER TABLE TO  FIT ENTRIES
*
FIT    DATA FIT1,FIT2,FIT3,FIT4
*
MAXFLS EQU  4            MAX FILES OPEN
*
* FIT ENTRIES
*
FIT1   DATA 0,>1B70,0,>1C00,0,0  PAB BLOCKS = 36 BYTES
FIT2   DATA 0,>1B94,0,>1D00,0,0  BUFFERS = 256 BYTES
FIT3   DATA 0,>1BB8,0,>1E00,0,0
FIT4   DATA 0,>1BDC,0,>1F00,0,0
FITSP  DATA 1,>1B5D,0    SPECIAL ENTRY FOR DELETE
*
* FOPEN MODE TABLE
* MS BYTE IS MODE CHAR
* LS BYTE IS PAB BYTE 1
*
OPNMTB DATA >7214  r  D/V
       DATA >7510  u
       DATA >7712  w
       DATA >6116  a
       DATA >5204  R  D/F
       DATA >5500  U
       DATA >5702  W
       DATA >4905  I  RELATIVE
       DATA >4F01  O
MAXMDS EQU  9
*
INTPFX DATA >6908  INTERNAL MODE PREFIX    *900702
*                                          *
PABSKL      DATA 0,0,0,0,0  PAB SKELETON
*
* SPECIAL RETURN VALUES
*
EOL    EQU  10           END OF LINE
EOF    EQU  -1           END OF FILE
ERR    EQU  -2           R/W ERROR
*
* OPEN A FILE :
* unit=fopen(filename,mode);
*
FOPEN  DATA C$WORK,$+2        *020602
       SAVERT              *020606
       LI   R0,FIT       SEARCH FOR FREE SLOT
       CLR  R3           FOR SLOT #
FOPN1  INC R3
       CI  R3,MAXFLS
       JGT OCERR         IF NONE FREE
       MOV  *R0+,R9      ENTRY ADDRESS
       MOV  *R9,R2       STATUS
       JNE  FOPN1        SLOT IN USE
*
* R9=FIT ADDR, R3=SLOT #
*
       POP  2,R0         *mode               *020602
       MOVB *R0+,R4      FIRST MODE CHAR
       LI   R2,MAXMDS
       LI   R8,OPNMTB    MODE CODE TABLE
       CLR  R5           SET DISPLAY              *900702
       CB   R4,@INTPFX   TEST FOR INTERNAL        *
       JNE  FOPN2                                 *
       MOVB @INTPFX+1,R5 SET INTERNAL             *
       MOVB *R0+,R4      GET NEXT MODE CHARACTER  *
FOPN2  MOV *R8+,R1
       CB   R4,R1
       JEQ  FOPN3        IF MODE CHAR MATCH
       DEC  R2
       JNE  FOPN2        IF MORE ENTRIES
       JMP  OCERR        IF BAD MODE
FOPN3  SWPB R1           PAB BYTE 1
       SOCB R5,R1        SET DISPLAY OR INTERNAL  *900702
       MOVB R1,@PBT1(R9) PUT IN FIT
       LI   R4,>5000     DEFAULT RECLEN (80)
       MOVB *R0,R1       2ND MODE CHAR
       JEQ  FOPND        IF DEFAULT RECLEN
       CLR  R4           RECLEN ACCUMULATOR
       LI   R5,10        FOR MPY
FOPN4  MOVB *R0+,R1      NEXT MODE CHAR
       SRL  R1,8
       AI   R1,-48
       JLT  FOPN5        IF CHAR < '0'
       CI   R1,9
       JGT  FOPN5        IF CHAR > '9'
       MOV  R4,R8
       MPY  R5,R8        PREV VAL * 10
       A    R1,R4        + NEXT DIGIT
       JMP  FOPN4
FOPN5  SLA  R4,8         RECLEN TO MSB
FOPND  MOV  R4,@PABSKL+4
       MOV  @BUFADD(R9),@PABSKL+2
       MOV  @4(R10),R4   *filename           *020602
       BL   @BLDPAB      SETUP PAB IN VRAM
       CLR  R1           OPEN OPCODE
       BL   @DSRACC      OPEN THE FILE
       JEQ  OCERR        IF ERROR
       AI   R0,-5        PAB RECLEN
       BLWP @VSBR
       MOVB R1,@ERRST(R9) ACTUAL RECLEN
       SRL  R1,8
       MOV  R1,*R9       SET IN FIT
       MOV  @BUFADD(R9),@BPTR(R9) INIT BUF PTR
       CLR  @CCTR(R9)    CLEAR COUNTER
*      LI   R0,CLSALL    SET EXIT TO CLOSE ALL FILES
*      MOV  R0,@C$HOOK
       RETN              * RESTORE RETURN
*                        SLOT # IN R3        *020602
*
OCERR  CLR  R3           RETURN 0 ON ERROR
       RETN
*
* CLOSE A FILE :
* fclose(unit);
*
FCLOSE DATA C$WORK,$+2                       *020602
       SAVERT            (020606
       POP  2,R9   GET UNIT #          *020602
       MOV  R9,R3        NORMAL RETURN VALUE
       BL   @GETFIT
       JMP  OCERR        IF BAD UNIT #
       LI   R1,1         CLOSE OPCODE
       BL   @DSRACC      CLOSE FILE
       CLR  *R9          RELEASE FIT ENTRY
       RETN         * RESTORE RT        *020606
*
* c=getc(unit); RETURNS NEXT CHAR FROM UNIT
* RETURNS EOL AFTER LAST CHAR IN RECORD
* RETURNS EOF AT END OF FILE
* RETURNS ERR ON ERROR
* IF unit<=0, DOES getchar();
*
GETC   DATA C$WORK,$+2                       *020602
       SAVERT
       POP  2,R9         UNIT #
       JGT  GETCF        IF NOT KBD
*      BL   *R12
*      DATA GETCHA
       BLWP @GETCHA                          *020602
       RETN              * RESTORE RT        *020606
GETCF  BL   @GETFIT      GETC FROM FILE
       JMP  GPCERR       IF BAD UNIT
GETC1  DEC  @CCTR(R9)    CHAR CTR
       JLT  GETC3        GET NEXT RECORD
       JEQ  GETC2        END OF LINE
       MOV  @BPTR(R9),R0 GET BUF ADDR
       BLWP @VSBR
       SRL  R1,8
       MOV  R1,R3        RETURN CHAR
       INC  @BPTR(R9)    BUMP BUF PTR
       RETN              * RESTORE RT        *020606
GETC2  LI   R3,EOL       RETURN LF
       RETN              * RESTORE RT        *020606
GETC3  LI   R1,2         READ OPCODE
       BL   @DSRACC
       JEQ  GETC4        IF EOF OR ERR
       MOV  @PABADD(R9),R0
       AI   R0,5         CHAR CTR PTR
       BLWP @VSBR        GET COUNT
       SRL  R1,8
       INC  R1           AS TEST PRECEDES
       MOV  R1,@CCTR(R9) STORE COUNT
       MOV  @BUFADD(R9),@BPTR(R9)
       JMP  GETC1        GET CHAR & RETURN
GETC4  MOVB R0,@ERRST(R9)
       SRL  R0,8         ERROR CODE TO INT
       CI   R0,5         TEST IF EOF
       JNE  GPCERR       IF READ ERROR
       LI   R3,EOF
       RETN              * RESTORE RT        *020606
*
GPCDSE MOVB R0,@ERRST(R9)
GPCERR LI   R3,ERR       GETC/PUTC ERROR RETURN
       RETN              * RESTORE RT        *020606
*
* putc(c,unit); SEND CHAR TO UNIT
* IF c=EOL, WRITES RECORD
* RETURNS c OR ERR
* IF unit <=0, DOES putchar(c);
*
PUTC0  DATA C$WORK,$+2                       *020602
       SAVERT            *020606
       B    @PC0
PUTC1  DATA C$WORK,$+2                       *020602
       SAVERT            *020606
       B    @PC1
*
PUTC   DATA C$WORK,$+2                       *020602
       SAVERT
       POP  2,R9      UNIT #              *020602
       JGT  PUTCF        IF NOT SCREEN
       POP  4,R3         CHAR VAL            *020602
*      BL   R15          PUSH
*      BL   *R12
*      DATA PUTCHA                           *020602
*      INCT R14
       PUSH R3
       BLWP @PUTCHA                          *020602
       INCT R10                              *020602
       RETN              *020606
PUTCF  BL   @GETFIT      PUTC TO FILE
       JMP  GPCERR       IF BAD UNIT
       POP  4,R1                       *020602
PC0    MOV  R1,R3        FOR RETURN
       CI   R1,EOL
       JEQ  PC1          IF END OF RECORD    *binary??
       SWPB R1
       MOV  @BPTR(R9),R0
       BLWP @VSBW        CHAR TO BUF
       INC  @CCTR(R9)    CHAR CTR
       C    @CCTR(R9),R2
       JEQ  PC1          IF BUF FULL
       INC  @BPTR(R9)    BUF PTR
       RETN              *020606
PC1    MOV  @CCTR(R9),R1
       SWPB R1
       MOV  @PABADD(R9),R0
       AI   R0,5         CHAR CNT PTR
       BLWP @VSBW        STORE COUNT
       LI   R1,3         WRITE OPCODE
       BL   @DSRACC
       JEQ  GPCDSE       IF ERROR
       MOV  @BUFADD(R9),@BPTR(R9)
       CLR  @CCTR(R9)
       RETN              *020606
*
* c=fgets(str,len,unit); READS STRING FROM unit INTO str
* str CONTAINS AT MOST len-1 CHAR + 0-BYTE
* RETURNS str
* RETURNS NULL (0) ON ERROR OR EOF
* IF unit<=0, DOES gets(str); (NO LENGTH LIMIT)
*
FGETS  DATA C$WORK,$+2                       *020602
       SAVERT
       CLR  @FRWFLG                          *020602
       POP  2,R9   UNIT #              *020602
       JGT  FGTSF        IF NOT KBD
       POP  4,R3   BUFF ADDR           *020602
*      BL   R15          PUSH
*      BL   *R12
*      DATA GETS
*      INCT R14
*      B    *R13
       PUSH R3                               *020602
       BLWP @GETS                            *020602
       INCT R10                              *020602
FGTSF  BL   @GETFIT      GETS FROM FILE
       JMP  FGPERR       IF BAD UNIT
       LI   R1,2         READ OPCODE
       BL   @DSRACC
       JEQ  FGPDSE       IF ERR OR EOF
       MOV  @PABADD(R9),R0
       AI   R0,5         CHAR CT PTR
       BLWP @VSBR        GET COUNT
       SRL  R1,8
       POP  4,R2         LEN                 *020602
       ABS  @FRWFLG
       JNE  FGTS0        IF FREAD
       DEC  R2           FOR 0-BYTE
FGTS0  C    R2,R1
       JLT  FGTS1        IF RECLEN<LEN
       MOV  R1,R2
FGTS1  MOV  @BUFADD(R9),R0
       POP  6,R1   BUFFER ADDR         *020602
       MOV  R2,R2
       JEQ  FGTS2        IF NULL RECORD
       BLWP @VMBR        MOVE RECORD TO STR
FGTS2  ABS  @FRWFLG
       JNE  FGTS3        IF FREAD
       MOV  R1,R3        RETURN STR
       A    R2,R1        STRING+1
       MOVB R2,*R1       SET 0-BYTE
       RETN              *020606
FGTS3  MOV  R2,R3        RETURN BYTE COUNT
       RETN              *020606
*
FGPDSE MOVB R0,@ERRST(R9)
FGPERR CLR  R3           ERROR EXIT
       ABS  @FRWFLG
       JEQ  FGPERX       IF FGETS/FPUTS
       LI   R3,ERR
FGPERX RETN              *020606             *020602
FRWFLG DATA 0            NON-ZERO IF FREAD/FWRITE
*
* c=fputs(str,unit); WRITES STRING FROM str TO unit
* RETURNS str
* RETURNS 0 ON ERROR
* IF unit<=0, DOES puts(str);
*
FPUTS  DATA C$WORK,$+2                       *020602
       SAVERT
       CLR  @FRWFLG
       POP  2,R9   UNIT #              *020602
       JGT  FPTSF        IF NOT SCREEN
       POP  4,R3   STRING ADDR         *020602
*      BL   R15
*      BL   *R12
*      DATA PUTS
*      INCT R14
*      B    *R13
*      push                                  *020602
       PUSH R3           *020606 ??
       BLWP @PUTS                            *020602
       INCT R10                              *020602
       RETN                                  *020602
FPTSF  BL   @GETFIT      PUTS TO FILE
       JMP  FGPERR       IF BAD UNIT #
       POP  4,R5   str ADDRESS         *020602
FPTS1  MOVB *R5+,R1      NEXT CHAR
       JEQ  FPTS2        IF END OF STRING
       SRL  R1,8
*      BL   *R12
*      DATA PUTC0        SPECIAL ENTRY IN PUTC
       BLWP @PUTC0                           *020602???
       MOV  R3,R3
       JLT  FGPERR       IF ERROR
       JMP  FPTS1
FPTS2  BLWP @PUTC1                           *020602
*FPTS2  BL   *R12
*      DATA PUTC1        WRITE RECORD
       MOV  R3,R3
       JLT  FGPERR
       POP  4,R3   RETURN str          *020602
       RETN              *020606
*
* c=fread(buf,len,unit); READS BINARY RECORD
* OF len BYTES MAX FROM unit TO buf
* RETURNS ACTUAL BYTES READ
* RETURNS ERR IF ERROR
*
FREAD  DATA C$WORK,$+2                       *020602
       SAVERT
       SETO @FRWFLG
       POP  2,R9   UNIT #              *020602
       JMP  FGTSF        USE FGETS CODE
*
* c=fwrite(buf,len,unit); WRITES BINARY RECORD OF len BYTES
*                         FROM buf TO unit
* RETURNS ACTUAL BYTES WRITTEN
* RETURNS ERR IF ERROR
*
FWRITE DATA C$WORK,$+2                       *020602
       SAVERT
       SETO @FRWFLG
       POP  2,R9   UNIT #              *020602
       BL   @GETFIT
       JMP  FGPERR       IF BAD UNIT
       POP  4,R1   len                 *020602
       C    R1,R2        COMPARE TO RECLEN
       JGT  FPUTB1       IF len>RECLEN, USE RECLEN
       MOV  R1,R2        WRITE len BYTES
FPUTB1 POP  6,R1   buf ADDRESS         *020602
       MOV  @BUFADD(R9),R0
       BLWP @VMBW        COPY BUFFER TO VRAM
       MOV  @PABADD(R9),R0
       AI   R0,5         CHAR COUNT PTR
       MOV  R2,R1        BYTE COUNT
       MOV  R2,R3        FOR RETURN
       SWPB R1
       BLWP @VSBW        STORE COUNT
       LI   R1,3         WRITE OPCODE
       BL   @DSRACC
       JEQ  FGPDSE
       RETN                                  *020602
*
* fseek(unit,recno); SET RECORD # FOR NEXT OPERATION
* IGNORED IF unit NOT OPEN OR NOT RELATIVE
* recno=-1 SETS SEQUENTIAL ACCESS
*
FSEEK0 DATA C$WORK,$+2
       SAVERT
       B    @FS0
FSEEK  DATA C$WORK,$+2                       *020602
       SAVERT
       POP  4,R9   UNIT #              *020602
       BL   @GETFIT
       JMP  FSEEKX       IF ERROR
       POP  2,R1   recno               *020602
FS0    MOV  @PABADD(R9),R0
       AI   R0,6         REC # FIELD
       BLWP @VSBW
       SWPB R1
       MOVB R1,@VDPWD
FSEEKX RETN              *020606             *020602
*
* fdelete(filename); DELETE FILE
*
FDELET DATA C$WORK,$+2                       *020602
       SAVERT          *020606
       CLR  @PABSKL+2    CLEAR PAB
       CLR  @PABSKL+4
       POP  2,R4   FILENAME PTR        *020602
       LI   R9,FITSP     FIT PTR
       BL   @BLDPAB
       LI   R1,7         DELETE OPCODE
       BL   @DSRACC
       RETN
*
* c=ferrc(unit); RETURN ERROR CODE
* ONLY VALID AFTER ERROR
*
FERRC  DATA C$WORK,$+2                       *020602
       SAVERT
       POP  2,R9                       *020602
       BL   @GETFIT
       JMP  FERRCX
       MOVB @ERRST(R9),R3     GET CODE
       SRL  R3,8
FERRCX RETN             *020606              *020602
*
* c=feof(unit); RETURNS TRUE IF UNIT IS AT EOF
*
FEOF   DATA C$WORK,$+2                       *020602
       SAVERT
       CLR  R3           DEFAULT RETURN
       POP  2,R9                       *020602
       BL   @GETFIT
       JMP  FEOFX
       LI   R1,9         STATUS OPCODE
       BL   @DSRACC
       MOV  @PABADD(R9),R0
       AI   R0,8         STATUS BYTE PTR
       BLWP @VSBR
       ANDI R1,>0100     MASK EOF BIT
       JEQ  FEOFX        IF NOT EOF
       INC  R3           SET TRUE
FEOFX  RETN             *020606              *020602
*
* rewind(unit); REWINDS FILE
* IGNORED IF NOT OPEN FILE
*
REWIND DATA C$WORK,$+2                       *020602
       SAVERT
       POP  2,R9   UNIT #              *020602
       BL   @GETFIT
       JMP  REWX         IF BAD UNIT
       CLR  R1
*      BL   *R12
*      DATA FSEEK0       SEEK RECORD 0
       BLWP @FSEEK0
       LI   R1,4         REWIND OPCODE
       BL   @DSRACC
REWX   RETN             *020606              *020602
*
* CLSALL - CLOSE ALL FILES (USED BY EXIT PROCESSING)
*
CLSALL MOV  R11,R9                           *020602 10->9
       LI   R5,MAXFLS    DO ALL ENTRIES
CLSAL1 PUSH R5           PUSH UNIT #         *020602
*      BL   *R12
*      DATA FCLOSE
*      INCT R14
       BLWP @FCLOSE                          *020602
       INCT R10                              *020602
       DEC  R5           NEXT UNIT
       JNE  CLSAL1       IF MORE ENTRIES
       B    *R9
*
* DSRACC - SETS BYTES 0,1 IN PAB & CALLS DSRLNK
*
* ENTRY - R1 = I/O OPCODE
*         R9 = FIT PTR
*
* EXIT  - IF ERROR, EQ IS SET & EC IS IN
*         MSB R0
*
DSRACC MOV  @PABADD(R9),R0
       SWPB R1           OPCODE
       BLWP @VSBW
       INC  R0
       MOVB @PBT1(R9),R1 PAB BYTE 1
       BLWP @VSBW
       AI   R0,8         PTR TO NAME LEN
       MOV  R0,@>8356
       BLWP @DSRLNK
       DATA 8
       RT
*
* BLDPAB - BUILDS PAB IN VRAM
*
* ENTRY - R4 = PTR TO FILENAME
*         R9 = FIT PTR
* BUFADD AND PABSKL MUST BE SET IN PABSKL
*
BLDPAB MOV  @PABADD(R9),R0    PAB ADDR
       LI   R1,PABSKL
       LI   R2,10
       BLWP @VMBW        WRITE PAB
       CLR  R8
       CLR  R1           CHAR CTR
BLDP1  MOVB *R4+,R8      GET NEXT CHAR
       CI   R8,>6100     MAKE UPPER CASE
       JL   BLDP2
       CI   R8,>7A00
       JH   BLDP2
       ANDI R8,>5F00
BLDP2  MOVB R8,@VDPWD    MOVE CHAR TO PAB
       JEQ  BLDP3        IF END IF STRING
       INC  R1           COUNT
       JMP  BLDP1
BLDP3  AI   R0,9         PAB NAME LEN
       SWPB R1           CHAR CT IN MSB
       BLWP @VSBW
       RT
*
* GETFIT - FIND FIT ENTRY
*
* ENTRY - R9 = UNIT #
*
* EXIT  - AT P IF BAD UNIT # OR NOT OPEN
*         AT P+2 IF NO ERROR, WITH
*         R2 = RECORD LENGTH
*         R9 = FIT ENTRY PTR
*
GETFIT DEC  R9
       JLT  GTFERR       IF UNIT <= 0
       CI   R9,MAXFLS
       JHE  GTFERR       IF UNIT > MAX FILES
       SLA  R9,1
       MOV  @FIT(R9),R9  FIT ENTRY PTR
       MOV  *R9,R2       ENTRY STATUS
       JEQ  GTFERR       IF UNIT NOT OPEN
       INCT R11          P+2 RETURN
GTFERR RT
*
       END
