⟦bbb33e000⟧

TextFile


(*  VERSION 0019 *)
(* COPYRIGHT 1981,1982,1983 BY DIGITAL RESEARCH, INC. *)
(* ALL RIGHTS RESERVED *)

(*$S+*)

MODULE IOMODULE;

(* INTERFACE TO CP/M-86 FOR PASCAL/MT+86 *)

(*$I FIBDEF.LIB*)
const
  maxfcbs = 9;

TYPE
  FPTR = ^FIB;
  FCBLK = PACKED ARRAY Æ0..36Å OF CHAR;
  SECTOR = PACKED ARRAY Æ0..127Å OF CHAR;
  DUMMY = PACKED ARRAYÆ0..0Å OF CHAR;
  PTR = ^DUMMY;

  FCBREC = RECORD
             ACTIVE : BOOLEAN;
             FCB    : FCBLK;
             BUFIDX : INTEGER;
             BUFFER : SECTOR;
             ENDFILE: BOOLEAN
           END;

  PTRIX = RECORD
            CASE BOOLEAN OF
                TRUE : (LO_VAL:INTEGER;
                        HI_VAL:INTEGER);
                FALSE: (P:PTR)
          END;


VAR
  @LFB : FPTR;
  RESULTI : INTEGER;


@FCBS : ARRAY Æ0..maxfcbsÅ OF FCBREC; 
(* ALLOWS 10 SIMULTANEOUSLY OPEN FILES *)
(* THE CONSOLE TAKES TWO FILE SLOTS *)
(* FOR CON: AS INPUT AND CON: AS OUTPUT *)

EXTERNAL FUNCTION @BDOS86(FUNC:INTEGER; PARM:PTR):BYTE;
EXTERNAL FUNCTION @BDOS86A(FUNC:INTEGER; FIRST,SECOND:INTEGER):BYTE;
(* @BDOS86A WILL RESOLVE TO @BDOS86 AT LINK TIME BUT USE DIFFERENT PARMS *)
EXTERNAL PROCEDURE @BDOSX(FUNC:INTEGER; CH:CHAR);
EXTERNAL PROCEDURE @CHN(P:PTR);
EXTERNAL PROCEDURE @HLT;

(*$E-*)
FUNCTION GET_AN_FCB:INTEGER;
VAR
  I : INTEGER;
BEGIN
  I := 0;
  WHILE I <= maxfcbs DO
    BEGIN
      IF NOT(@FCBSÆIÅ.ACTIVE) THEN (* WE FOUND ONE! *)
        BEGIN
          GET_AN_FCB := I;
          @FCBSÆIÅ.ACTIVE := TRUE;
          EXIT
        END
      ELSE
        I := I + 1
    END;
  I := -1;
  WRITELN('FCB Table Exhausted!');
  @HLT;
END;

PROCEDURE FREE_AN_FCB(FCBNUM:INTEGER);
BEGIN
  @FCBSÆFCBNUMÅ.ACTIVE := FALSE
END;

PROCEDURE PUTSECTOR(I:INTEGER);
BEGIN
  RESULTI := @BDOS86(26,ADDR(@FCBSÆIÅ.BUFFER));
  RESULTI := @BDOS86(21,ADDR(@FCBSÆIÅ.FCB));
END;

FUNCTION  GETSECTOR(I:INTEGER):BOOLEAN;
BEGIN
  GETSECTOR := TRUE;    (* FALSE MEANS EOF *)
  RESULTI := @BDOS86(26,ADDR(@FCBSÆIÅ.BUFFER));
  RESULTI := @BDOS86(20,ADDR(@FCBSÆIÅ.FCB));
  IF RESULTI <> 0 THEN
    GETSECTOR := FALSE;
END;



FUNCTION @SPN(VAR F:FIB):BOOLEAN;
BEGIN
  @SPN := FALSE;
  IF F.FNAME = 'CON:' THEN
    BEGIN
      F.OPTION := FCONIO;
      @SPN := TRUE
    END
  ELSE
    IF F.FNAME = 'LST:' THEN
      BEGIN
        F.OPTION := FLSTOUT;
        @SPN := TRUE
      END
    ELSE
      IF (F.FNAME = 'KBD:') OR (F.FNAME = 'TRM:') THEN
        BEGIN
          F.OPTION := FTRMIO;
          @SPN := TRUE
        END
      ELSE
        IF (F.FNAME = 'RDR:') OR (F.FNAME = 'PUN:') THEN
          BEGIN
            F.OPTION := FAUXIO;
            @SPN := TRUE
          END
END;

FUNCTION @NOK(VAR S:STRING):BOOLEAN;
VAR
  I : INTEGER;
  ST: SET OF CHAR;
BEGIN
  @NOK := FALSE;
  ST := Æ' '..CHR($7E)Å;
  IF (LENGTH(S) > 14) OR (LENGTH(S) < 1) THEN
    EXIT;

  FOR I := 1 TO LENGTH(S) DO
    IF NOT(SÆIÅ IN ST) THEN
      EXIT;
  @NOK := TRUE
END;


FUNCTION UPPERCASE(CH:CHAR):CHAR;
BEGIN
  IF (CH >= 'a') AND (CH <= 'z') THEN
    CH := CHR(CH & $DF);
  UPPERCASE := CH
END;



(*$E+*)
PROCEDURE @PARSE(VAR F:FCBLK;VAR S:STRING);
VAR
  DISK : CHAR;
  NAME : PACKED ARRAY Æ1..8Å OF CHAR;
  EXT  : PACKED ARRAY Æ1..3Å OF CHAR;
  I,J,MAX: INTEGER;

BEGIN
  (* PARSE CP/M FILE NAME *)

  WHILE (LENGTH(S) <> 0) AND (SÆ1Å = ' ') DO
    DELETE(S,1,1);              (* REMOVE LEADING BLANKS *)

  IF LENGTH(S) <> 0 THEN
    BEGIN
      DISK := '@';      (* DEFAULT *)
      NAME := '        ';
      EXT  := '   ';

      IF SÆ2Å = ':' THEN
        BEGIN
          I := 3;
          DISK := UPPERCASE(SÆ1Å)
        END
      ELSE
        I := 1;
      MAX := I + 8;
      J := 1;

      WHILE (NOT(SÆIÅ IN Æ'.',':'Å)) AND (I < MAX) 
             AND (I <= LENGTH(S)) DO
        BEGIN
          NAMEÆJÅ := UPPERCASE(SÆIÅ);
          J := J + 1;
          I := I + 1
        END; (* WHILE *)

      IF (SÆIÅ = '.') AND (I <= LENGTH(S)) THEN
        BEGIN
          I := I + 1;
          J := 1;
          WHILE (J < 4) AND (I <= LENGTH(S)) DO
            BEGIN
              EXTÆJÅ := UPPERCASE(SÆIÅ);
              J := J + 1;
              I := I + 1
            END (* WHILE *)
        END; (* IF *)

      FILLCHAR(F,SIZEOF(FCBLK)-18,CHR(0));
      FÆ0Å := CHR(ORD(DISK) - ORD('@'));
      MOVE(NAME,FÆ1Å,8);
      MOVE(EXT,FÆ9Å,3);
    END (* IF *)
  
END;



PROCEDURE @INI2;        (* INIT @FCBS *)
BEGIN
  FILLCHAR(@FCBS,SIZEOF(@FCBS),CHR(0))
END;


FUNCTION @OPEN(VAR F:FIB; MODE:INTEGER):INTEGER;

(* NOTE: THIS CODE IS DEPENDENT UPON THE FACT THAT THE FIRST FIELD *)
(* OF THE FIB DEFINITION IS FNAME! *)

VAR
  I : INTEGER;
BEGIN
  I := GET_AN_FCB;
  @OPEN := I;
  IF I <> -1 THEN
    BEGIN
      FILLCHAR(@FCBSÆIÅ.FCB,36,CHR(0));
      @PARSE(@FCBSÆIÅ.FCB,F.FNAME);
      IF NOT @NOK(F.FNAME) THEN
        BEGIN
          @OPEN := -1;
          RESULTI := 255;
          FREE_AN_FCB(I);       (* DONT NEED FCB IF BAD NAME *)
          EXIT
        END;

      IF @SPN(F) THEN
        BEGIN
          RESULTI := 0;
          @FCBSÆIÅ.FCBÆ0Å := CHR($FF); æMARK SPECIAL FILEå
          FREE_AN_FCB(I);       
(* fix for micropro bug. using LST: as file causes fcb overflow. NOT TESTED*)
          æsince on 1/16/82 we implemented i/o redirection å
          æspecial files now need an fcb allocated to them! å
          EXIT
        END;

      RESULTI := @BDOS86(15,ADDR(@FCBSÆIÅ.FCB));
      IF RESULTI = 255 THEN
        BEGIN
          @OPEN := -1;
          FREE_AN_FCB(I);       (* DONT NEED FCB IF NOT FOUND *)
        END
      ELSE
        BEGIN
          @FCBSÆIÅ.BUFIDX := SIZEOF(SECTOR);
          @FCBSÆIÅ.ENDFILE:= FALSE
        END
    END
  ELSE
    RESULTI := 255
END; (* @OPEN *)

FUNCTION @CREAT(VAR F:FIB; MODE:INTEGER):INTEGER;
VAR
  I : INTEGER;
BEGIN
  I := GET_AN_FCB;
  @CREAT := I;
  IF I <> -1 THEN
    BEGIN
      FILLCHAR(@FCBSÆIÅ.FCB,36,CHR(0));
      @PARSE(@FCBSÆIÅ.FCB,F.FNAME);
      IF NOT @NOK(F.FNAME) THEN
        BEGIN
          @CREAT := -1;
          RESULTI := 255;
          FREE_AN_FCB(I);       (* DONT NEED FCB IF BAD NAME *)
          EXIT
        END;

      IF @SPN(F) THEN
        BEGIN
          RESULTI := 0;
          @FCBSÆIÅ.FCBÆ0Å := CHR($FF); æMARK SPECIAL FILEå
          æFREE_AN_FCB(I);       (* DONT NEED AN FCB ON SPECIAL FILES *)å
          æsince on 1/16/82 we implemented i/o redirection å
          æspecial files now need an fcb allocated to them! å
          EXIT
        END;

      RESULTI := @BDOS86(19,ADDR(@FCBSÆIÅ.FCB)); (* DELETE ANY OLD ONES *)
      RESULTI := @BDOS86(22,ADDR(@FCBSÆIÅ.FCB)); (* AND CREATE A NEW ONE *)
      IF RESULTI = 255 THEN
        BEGIN
          @CREAT := -1;
          FREE_AN_FCB(I);       (* DONT NEED FCB IF ERROR *)
        END;
      @FCBSÆIÅ.BUFIDX := 0;
    END
  ELSE
    RESULTI := 255
END; (* @CREAT *)


FUNCTION @UNLINK(VAR F:FIB):INTEGER;
BEGIN
  IF F.SYSID = 0 THEN (* WE MUST ALLOCATE AN FCB FIRST *)
    F.SYSID := @OPEN(F,2);
  IF F.SYSID <> -1 THEN (* VALID FILE *)
    BEGIN
      IF F.OPTION <= FRANDOM THEN (* IT IS A DISK FILE *)
        RESULTI := @BDOS86(19,ADDR(@FCBSÆF.SYSIDÅ.FCB));
      @UNLINK := 0;
      FREE_AN_FCB(F.SYSID)
    END;
END;

PROCEDURE @CLOSE(I:INTEGER; an_infile:boolean);
VAR
  J : INTEGER;
BEGIN
  if (not an_infile) and (@FCBSÆIÅ.FCBÆ0Å <> CHR($FF)) then
    begin (* check to see if stuff to flush *)
      IF (@FCBSÆIÅ.BUFIDX <> 0) THEN
    IL : BOOLEAN):BYTE;
BEGIN
  WITH @FCBSÆIÅ DO
    BEGIN
      IF BUFIDX >= SIZEOF(SECTOR) THEN (* GOT TO GO READ SOME DATA *)
        BEGIN
          ENDFIL := NOT GETSECTOR(I);
          BUFIDX := 0
        END;
      GETBYTE := BUFFERÆBUFIDXÅ;
      BUFIDX := BUFIDX + 1
    END
END;

PROCEDURE PUTBYTE(B:BYTE; I:INTEGER);
BEGIN
  WITH @FCBSÆIÅ DO
    BEGIN
      IF BUFIDX >= SIZEOF(SECTOR) THEN
        BEGIN
          PUTSECTOR(I);
          BUFIDX := 0
        END;
      BUFFERÆBUFIDXÅ := B;
      BUFIDX := BUFIDX + 1
    END
END;

(*$E+*)
PROCEDURE @RNB;
VAR
  I : INTEGER;
  J : INTEGER;
  CH: CHAR;
  ENDFILE:BOOLEAN;
BEGIN
  RESULTI := 0;
  IF @LFB^.OPTION = FCONIO THEN (* READ CONSOLE NOT A DISK FILE *)
    BEGIN
      CH := @BDOS86(1,ADDR(I)); (* SECOND PARM IS A DUMMY *)
      IF CH = CHR(8) THEN
        BEGIN
          @BDOSX(2,' ');
          @BDOSX(2,CHR(8))
        END
      ELSE
        IF CH = CHR($0D) THEN
          @BDOSX(2,CHR($0A));
      @LFB^.FBUFFERÆ0Å := CH;
      @LFB^.FEOF := (CH = CHR($1A));
      EXIT
    END;

  IF @LFB^.OPTION = FTRMIO THEN
    BEGIN
      repeat
        CH := @BDOS86A(6,$FFFF,$FFFF);
      until ch <> chr(0);
      @LFB^.FBUFFERÆ0Å := CH;
      EXIT
    END;

  IF @LFB^.OPTION = FAUXIO THEN
    BEGIN
      CH := @BDOS86(3,ADDR(I));
      @LFB^.FBUFFERÆ0Å := CH;
      EXIT
    END;


  (* ELSE NON-CONSOLE, READ USING GETBYTE *)

  I := @LFB^.SYSID;
  ENDFILE := @LFB^.FEOF;
  J := 1;
  WHILE (J <= @LFB^.BUFLEN) AND (NOT ENDFILE) DO
    BEGIN
      WITH @LFB^ DO
        FBUFFERÆJ-1Å := GETBYTE(I,ENDFILE);
      J := J + 1
    END;
  @LFB^.FEOF := ENDFILE;
  @LFB^.IOSIZE := J-1;  (* THIS IS SO GNB CAN TELL THE DIFFERENCE *)
                        (* BETWEEN A PARTIALLY FULL BUFFER AND    *)
                        (* TRUE EOF                               *)
END;

PROCEDURE @WNB;
VAR
  I : INTEGER;
  J : INTEGER;
  CH: CHAR;
BEGIN
  RESULTI := 0;
  IF @LFB^.OPTION = FCONIO THEN (* WRITE TO THE CONSOLE *)
    BEGIN
      @BDOSX(2,@LFB^.FBUFFERÆ0Å);
      EXIT
    END;

  IF @LFB^.OPTION = FTRMIO THEN (* USE FUNCTION 6 *)
    BEGIN
      @BDOSX(6,@LFB^.FBUFFERÆ0Å);
      EXIT
    END;
    
  if @lfb^.option = flstout then (* use function 5 *)
    begin
      @bdosx(5,@lfb^.fbufferÆ0Å);
      exit
    end;

  if @lfb^.option = fauxio then (* use function 4 *)
    begin
      @bdosx(4,@lfb^.fbufferÆ0Å);
      exit
    end;

  (* ELSE NON-CONSOLE, WRITE USING PUTBYTE *)
  I := @LFB^.SYSID;
  FOR J := 1 TO @LFB^.BUFLEN DO
    WITH @LFB^ DO
      PUTBYTE(FBUFFERÆJ-1Å,I);
  @LFB^.BUFIDX := 0; (* SO CLOSE ON A WNB FILE WORKS PROPERLY *)
END;


PROCEDURE CHAIN(VAR F:FIB; SZ:INTEGER);
BEGIN
  @CHN(ADDR(@FCBSÆF.SYSIDÅ.FCB))
END;


MODEND.
«eof»
DataMuseum.dk

CP/M

⟦bbb33e000⟧ TextFile

Derivation

TextFile
