Oakland CPM Archive/oakcpm.iso/cpm/cpm86/trbtol86.lbr/TOOLU.PQS/TOOLU.PAS

Pascal/Delphi Source File | 1985-10-23 | 13KB | 681 lines

{
        Copyright (c) 1981
        By:     Bell Telephone Laboratories, Inc. and
                Whitesmith's Ltd.,

        This software is derived from the book
                "Software Tools in Pascal", by
                Brian W. Kernighan and P. J. Plauger
                Addison-Wesley, 1981
                ISBN 0-201-10342-7

        Right is hereby granted to freely distribute or duplicate this
        software, providing distribution or duplication is not for profit
        or other commercial gain and that this copyright notice remains
        intact.
}

CONST
  IOERROR=0;
  STDIN=1;
  STDOUT=2;
  STDERR=3;
(*IO RELEATED STUFF*)
  MAXOPEN=7;
  IOREAD=0;
  IOWRITE=1;
  MAXCMD=20;
  ENDFILE=255;
  BLANK=32;
  ENDSTR=0;
  MAXSTR=100;
  BACKSPACE=8;
  TAB=9;
  NEWLINE=10;
  EXCLAM=33;
  DQUOTE=34;
  SHARP=35;
  DOLLAR=36;
  PERCENT=37;
  AMPER=38;
  SQUOTE=39;
  ACUTE=SQUOTE;
  LPAREN=40;
  RPAREN=41;
  STAR=42;
  PLUS=43;
  COMMA=44;
  MINUS=45;
  DASH=MINUS;
  PERIOD=46;
  SLASH=47;
  COLON=58;
  SEMICOL=59;
  LESS=60;
  EQUALS=61;
  GREATER=62;
  QUESTION=63;
  ATSIGN=64;
  ESCAPE=ATSIGN;
  LBRACK=91;
  BACKSLASH=92;
  RBRACK=93;
  CARET=94;
  GRAVE=96;
  UNDERLINE=95;
  TILDE=126;
  LBRACE=123;
  BAR=124;
  RBRACE=125;

TYPE
   CHARACTER=0..255;
   XSTRING=ARRAY[1..MAXSTR]OF CHARACTER;
  STRING80=string[80];
  FILEDESC=IOERROR..MAXOPEN;
  FILTYP=(CLOSED,STDIO,FIL1,FIL2,FIL3,FIL4);

VAR
   KBDN,KBDNEXT:INTEGER;
   KBDLINE:XSTRING;
   CMDARGS:0..MAXCMD;
   CMDIDX:ARRAY[1..MAXCMD] OF 1..MAXSTR;
   CMDLIN:XSTRING;
   CMDLINE:STRING80;
   CMDFIL:ARRAY[STDIN..MAXOPEN]OF FILTYP;
   CMDOPEN:ARRAY[FILTYP]OF BOOLEAN;
   FILE1,FILE2,FILE3,FILE4:TEXT;



FUNCTION GETKBD(VAR C:CHARACTER):CHARACTER;FORWARD;
FUNCTION FGETCF(VAR FIL:TEXT):CHARACTER;FORWARD;
FUNCTION GETCF(VAR C:CHARACTER;FD:FILEDESC):CHARACTER;FORWARD;
FUNCTION GETC(VAR C:CHARACTER):CHARACTER;FORWARD;
PROCEDURE FPUTCF(C:CHARACTER;VAR FIL:TEXT);FORWARD;
PROCEDURE PUTCF(C:CHARACTER;FD:FILEDESC);FORWARD;
PROCEDURE PUTC(C:CHARACTER);FORWARD;
PROCEDURE PUTDEC(N,W:INTEGER);FORWARD;
FUNCTION ITOC(N:INTEGER;VAR S:XSTRING;I:INTEGER):INTEGER;FORWARD;
FUNCTION GETARG(N:INTEGER;VAR S:XSTRING;
  MAXSIZE:INTEGER):BOOLEAN;FORWARD;
  PROCEDURE SCOPY(VAR SRC:XSTRING;I:INTEGER;VAR DEST:XSTRING;J:INTEGER);FORWARD;
PROCEDURE ENDCMD;FORWARD;
PROCEDURE XCLOSE(FD:FILEDESC);FORWARD;
FUNCTION MUSTCREATE(VAR NAME:XSTRING;MODE:INTEGER):
FILEDESC;FORWARD;
FUNCTION CREATE(VAR NAME:XSTRING;MODE:INTEGER):FILEDESC;FORWARD;
FUNCTION XLENGTH(VAR S:XSTRING):INTEGER;FORWARD;
PROCEDURE STRNAME(VAR STR:STRING80;VAR XSTR:XSTRING);FORWARD;
PROCEDURE ERROR(STR:STRING80);FORWARD;
FUNCTION MAX(X,Y:INTEGER):INTEGER;FORWARD;
PROCEDURE REMOVE(NAME:XSTRING);FORWARD;
FUNCTION GETLINE(VAR STR:XSTRING;FD:FILEDESC;
  SIZE:INTEGER):BOOLEAN;FORWARD;
  FUNCTION OPEN(VAR NAME:XSTRING;MODE:INTEGER):
FILEDESC;FORWARD;
FUNCTION FDALLOC:FILEDESC;FORWARD;
FUNCTION FTALLOC:FILTYP;FORWARD;
FUNCTION NARGS:INTEGER;FORWARD;
FUNCTION ADDSTR(C:CHARACTER;VAR OUTSET:XSTRING;
  VAR J:INTEGER;MAXSET:INTEGER):BOOLEAN;FORWARD;
PROCEDURE PUTSTR(STR:XSTRING;FD:FILEDESC);FORWARD;
FUNCTION MUSTOPEN(VAR NAME:XSTRING;MODE:INTEGER):FILEDESC;FORWARD;
FUNCTION MIN(X,Y:INTEGER):INTEGER;FORWARD;
FUNCTION ISUPPER(C:CHARACTER):BOOLEAN;FORWARD;
FUNCTION EQUAL(VAR STR1,STR2:XSTRING):BOOLEAN;FORWARD;
FUNCTION INDEX(VAR S:XSTRING;C:CHARACTER):INTEGER;FORWARD;
FUNCTION ISALPHANUM(C:CHARACTER):BOOLEAN;FORWARD;
FUNCTION ESC(VAR S:XSTRING;VAR I:INTEGER):
     CHARACTER;FORWARD;
PROCEDURE FCOPY(FIN,FOUT:FILEDESC);FORWARD;
FUNCTION CTOI(VAR S:XSTRING;VAR I:INTEGER):INTEGER;FORWARD;
FUNCTION ISDIGIT(C:CHARACTER):BOOLEAN;FORWARD;
FUNCTION ISLOWER(C:CHARACTER):BOOLEAN;FORWARD;
FUNCTION ISLETTER(C:CHARACTER):BOOLEAN;FORWARD;

FUNCTION ISDIGIT;
BEGIN
  ISDIGIT:=C IN [ORD('0')..ORD('9')]
END;

FUNCTION ISLOWER;
BEGIN
  ISLOWER:=C IN [97..122]
END;

FUNCTION ISLETTER;
BEGIN
  ISLETTER:=C IN [65..90]+[97..122]
END;

FUNCTION CTOI;
VAR N,SIGN:INTEGER;
BEGIN
  WHILE (S[I]=BLANK) OR (S[I]=TAB)DO
    I:=I+1;
  IF(S[I]=MINUS) THEN
    SIGN:=-1
  ELSE
    SIGN:=1;
  IF(S[I]=PLUS)OR(S[I]=MINUS)THEN
    I:=I+1;
  N:=0;
  WHILE(ISDIGIT(S[I])) DO BEGIN
    N:=10*N+S[I]-ORD('0');
    I:=I+1
  END;
  CTOI:=SIGN*N
END;

PROCEDURE FCOPY;
VAR
  C:CHARACTER;
BEGIN
  WHILE(GETCF(C,FIN)<>ENDFILE) DO
    PUTCF(C,FOUT)
END;




FUNCTION INDEX;
VAR I:INTEGER;
BEGIN
  I:=1;
  WHILE(S[I]<>C) AND (S[I]<>ENDSTR)DO
    I:=I+1;
  IF (S[I]=ENDSTR) THEN
    INDEX:=0
  ELSE
    INDEX:=I
END;

FUNCTION ESC;
BEGIN
  IF(S[I]<>ATSIGN) THEN
    ESC:=S[I]
  ELSE IF(S[I+1]=ENDSTR) THEN (*@ NOT SPECIAL AT END*)
    ESC:=ATSIGN
  ELSE BEGIN
    I:=I+1;
    IF(S[I]=ORD('N'))THEN ESC:=NEWLINE
    ELSE IF (S[I]=ORD('T')) THEN
      ESC:=TAB
    ELSE
      ESC:=S[I]
  END
END;

FUNCTION ISALPHANUM;
BEGIN
  ISALPHANUM:=C IN
    [ORD('A')..ORD('Z'),ORD('0')..ORD('9'),
    97..122]
END;

FUNCTION MAX;
BEGIN
  IF(X>Y)THEN
    MAX:=X
  ELSE
    MAX:=Y
END;


FUNCTION MIN;
BEGIN
  IF X<Y THEN
    MIN:=X
  ELSE
    MIN:=Y
END;


FUNCTION ISUPPER;
  BEGIN
    ISUPPER:=C IN [ORD('A')..ORD('Z')]
  END;


FUNCTION XLENGTH;
VAR
  N:INTEGER;
BEGIN
  N:=1;
  WHILE(S[N]<>ENDSTR)DO
    N:=N+1;
  XLENGTH:=N-1
END;

FUNCTION GETARG;
BEGIN
  IF((N<1)OR(CMDARGS<N))THEN
    GETARG:=FALSE
  ELSE BEGIN
    SCOPY(CMDLIN,CMDIDX[N],S,1);
    GETARG:=TRUE
  END
END;(*GETARG*)


  PROCEDURE SCOPY;
  BEGIN
    WHILE(SRC[I]<>ENDSTR)DO BEGIN
      DEST[J]:=SRC[I];
      I:=I+1;
      J:=J+1
    END;
    DEST[J]:=ENDSTR;
  END;



(*$I-*)
FUNCTION CREATE;
VAR
  FD:FILEDESC;
  SNM:STRING80;
BEGIN
  FD:=FDALLOC;
  IF(FD<>IOERROR)THEN BEGIN
  STRNAME(SNM,NAME);
  CASE (CMDFIL[FD])OF
  FIL1:
    begin assign(FILE1,SNM);rewrite(FILE1) end;
  FIL2:begin assign(FILE2,SNM);rewrite(FILE2) end;
  FIL3:begin assign(FILE3,SNM);rewrite(FILE3) end;
  FIL4:begin assign(FILE4,SNM);rewrite(FILE4) end
  END;
  IF(IORESULT<>0)THEN BEGIN
    XCLOSE(FD);
    FD:=IOERROR
  END
END;
CREATE:=FD;
END;
(*$I+*)

PROCEDURE STRNAME;
VAR I:INTEGER;
BEGIN
  STR:='.PAS';
  I:=1;
  WHILE(XSTR[I]<>ENDSTR)DO BEGIN
    INSERT('X',STR,I);
    STR[I]:=CHR(XSTR[I]);
    I:=I+1
  END
END;
PROCEDURE ERROR;
BEGIN
  WRITELN(STR);
  HALT
END;

FUNCTION MUSTCREATE;
VAR
  FD:FILEDESC;
BEGIN
  FD:=CREATE(NAME,MODE);
  IF(FD=IOERROR)THEN BEGIN
    PUTSTR(NAME,STDERR);
    ERROR('  :CAN''T CREATE FILE')
  END;
  MUSTCREATE:=FD
END;

FUNCTION NARGS;
BEGIN
  NARGS:=CMDARGS
END;

PROCEDURE REMOVE;
VAR
  FD:FILEDESC;
BEGIN
  FD:=OPEN(NAME,IOREAD);
  IF(FD=IOERROR)THEN
  WRITELN('CAN''T REMOVE FILE')
  ELSE BEGIN
    CASE (CMDFIL[FD]) OF
    FIL1:CLOSE(FILE1);
    FIL2:CLOSE(FILE2);
    FIL3:CLOSE(FILE3);
    FIL4:CLOSE(FILE4);
    END
  END;
  CMDFIL[FD]:=CLOSED
END;

FUNCTION GETLINE;
VAR I,ii:INTEGER;
    DONE:BOOLEAN;
    CH:CHARACTER;
BEGIN
 I:=0;
 REPEAT
   DONE:=TRUE;
   CH:=GETCF(CH,FD);
   IF(CH=ENDFILE) THEN
     I:=0
   ELSE IF (CH=NEWLINE) THEN BEGIN
     I:=I+1;
     STR[I]:=NEWLINE
   END
   ELSE IF (SIZE-2<=I) THEN BEGIN
     WRITELN('LINE TOO LONG');
     I:=I+1;
     STR[I]:=NEWLINE
   END
   ELSE BEGIN
     DONE:=FALSE;
     I:=I+1;
     STR[I]:=CH;
   END
 UNTIL(DONE);
 STR[I+1]:=ENDSTR;
GETLINE:=(0<I)
END;(*GETLINE*)

(*$I-*)
FUNCTION OPEN;
VAR FD:FILEDESC;
SNM:STRING80;
BEGIN
  FD:=FDALLOC;
  IF(FD<>IOERROR) THEN BEGIN
    STRNAME(SNM,NAME);
    CASE (CMDFIL[FD]) OF
    FIL1:begin assign(FILE1,SNM);RESET(FILE1) end;
    FIL2:begin assign(FILE2,SNM);RESET(FILE2) end;
    FIL3:begin assign(FILE3,SNM);RESET(FILE3) end;
    FIL4:begin assign(FILE4,SNM);RESET(FILE4) end
    END;
    IF(IORESULT<>0) THEN BEGIN
      XCLOSE(FD);
      FD:=IOERROR
    END
  END;
  OPEN:=FD
END;
(*$I+*)

FUNCTION FTALLOC;
VAR DONE:BOOLEAN;
   FT:FILTYP;
BEGIN
  FT:=FIL1;
  REPEAT
    DONE:=(NOT CMDOPEN[FT] OR (FT=FIL4));
    IF(NOT DONE) THEN
      FT:=SUCC(FT)
  UNTIL (DONE);
  IF(CMDOPEN[FT]) THEN
    FTALLOC:=CLOSED
  ELSE
    FTALLOC:=FT
END;

FUNCTION FDALLOC;
VAR DONE:BOOLEAN;
FD:FILEDESC;
BEGIN
  FD:=STDIN;
  DONE:=FALSE;
  WHILE(NOT DONE) DO
    IF((CMDFIL[FD]=CLOSED) OR (FD=MAXOPEN))THEN
      DONE:=TRUE
    ELSE FD:=SUCC(FD);
  IF(CMDFIL[FD]<>CLOSED) THEN
    FDALLOC:=IOERROR
  ELSE BEGIN
    CMDFIL[FD]:=FTALLOC;
    IF(CMDFIL[FD]=CLOSED) THEN
      FDALLOC:=IOERROR
    ELSE BEGIN
      CMDOPEN[CMDFIL[FD]]:=TRUE;
      FDALLOC:=FD
    END
  END
END;(*FDALLOC*)

    PROCEDURE ENDCMD;
VAR FD:FILEDESC;
BEGIN
  FOR FD:=STDIN TO MAXOPEN DO
    XCLOSE(FD)
END;

PROCEDURE XCLOSE;
BEGIN
  CASE (CMDFIL[FD])OF
  CLOSED,STDIO:;
  FIL1:CLOSE(FILE1);
  FIL2:CLOSE(FILE2);
  FIL3:CLOSE(FILE3);
  FIL4:CLOSE(FILE4)
  END;
  CMDOPEN[CMDFIL[FD]]:=FALSE;
  CMDFIL[FD]:=CLOSED
END;

FUNCTION ADDSTR;
BEGIN
  IF(J>MAXSET)THEN
    ADDSTR:=FALSE
  ELSE BEGIN
    OUTSET[J]:=C;
    J:=J+1;
    ADDSTR:=TRUE
  END
END;

PROCEDURE PUTSTR;
VAR I:INTEGER;
BEGIN
  I:=1;
  WHILE(STR[I]<>ENDSTR) DO BEGIN
    PUTCF(STR[I],FD);
    I:=I+1
  END
END;
FUNCTION MUSTOPEN;
VAR FD:FILEDESC;
BEGIN
  FD:=OPEN(NAME,MODE);
  IF(FD=IOERROR)THEN BEGIN
    PUTSTR(NAME,STDERR);
    WRITELN(':  CAN''T OPEN FILE')
  END;
  MUSTOPEN:=FD
END;

FUNCTION GETKBD;

VAR
    DONE:BOOLEAN;
    i:integer;
    ch:char;

BEGIN
IF (KBDN<=0)
THEN
    BEGIN
    KBDNEXT:=1;
    DONE:=FALSE;
    if (kbdn=-2)
    then
        begin
        readln;
        kbdn:=0
        end
    else if (kbdn<0)
    then
        done:=true;
    WHILE(NOT DONE)
    DO
        BEGIN
        kbdn:=kbdn+1;
        DONE:=TRUE;
        if (eof(TRM))
        then
            kbdn:=-1
        else if eoln(TRM)
        then
            begin
            kbdline[kbdn]:=NEWLINE;
            readln(TRM);
            end
        else if (MAXSTR-1<=kbdn)
        then
            begin
            writeln('Line too long');
            kbdline[kbdn]:=newline
            end
        ELSE
            begin
            read(TRM,ch);
            kbdline[kbdn]:=ord(ch);
            if (ord(ch)in [0..7,9..12,14..31])
            then
                write('^',chr(ord(ch)+64))
            else if (kbdline[kbdn]<>BACKSPACE)
            then
                {do nothing}
            ELSE
                begin
                write(ch,' ',ch);
                if (1<kbdn)
                then
                    begin
                    kbdn:=kbdn-2;
                    if kbdline[kbdn+1]in[0..31]
                    then
                        write(ch,' ',ch)
                    end
                ELSE
                    kbdn:=kbdn-1
                end;
            done:=false
            end;
        END
    END;
reset(TRM);
IF(KBDN<=0)
THEN
    C:=ENDFILE
ELSE
    BEGIN
    C:=KBDLINE[KBDNEXT];
    KBDNEXT:=KBDNEXT+1;
    if (c=NEWLINE)
    then
        begin
        reset(TRM);
        kbdn:=-2;
        end
    ELSE
        KBDN:=KBDN-1
    END;
    GETKBD:=C
END;

 FUNCTION FGETCF;
 VAR CH:CHAR;
 BEGIN
   IF(EOF(FIL))THEN
      FGETCF:=ENDFILE
   ELSE IF(EOLN(FIL)) THEN BEGIN
      READLN(FIL);
      FGETCF:=NEWLINE
   END
   ELSE BEGIN
     READ(FIL,CH);
     FGETCF:=ORD(CH);
   END;
 END;

 FUNCTION GETCF;
 BEGIN
   CASE(CMDFIL[FD])OF
   STDIO:C:=GETKBD(C);
   FIL1:C:=FGETCF(FILE1);
   FIL2:C:=FGETCF(FILE2);
   FIL3:C:=FGETCF(FILE3);
   FIL4:C:=FGETCF(FILE4);
   END;

   GETCF:=C
 END;

FUNCTION GETC;
BEGIN
  GETC:=GETCF(C,STDIN)
END;

 PROCEDURE FPUTCF;
 BEGIN
  IF(C=NEWLINE)THEN
    WRITELN(FIL)
  ELSE
    WRITE(FIL,CHR(C))
END;

PROCEDURE PUTCF;
BEGIN
  CASE (CMDFIL[FD]) OF
  STDIO:FPUTCF(C,CON);
  FIL1:FPUTCF(C,FILE1);
  FIL2:FPUTCF(C,FILE2);
  FIL3:FPUTCF(C,FILE3);
  FIL4:FPUTCF(C,FILE4)
  END
END;


PROCEDURE PUTC;
BEGIN
  PUTCF(C,STDOUT);
END;

FUNCTION ITOC;
BEGIN
  IF(N<0)THEN BEGIN
    S[I]:=ORD('-');
    ITOC:=ITOC(-N,S,I+1);
  END
  ELSE BEGIN
    IF (N>=10)THEN
      I:=ITOC(N DIV 10,S, I);
    S[I]:=N MOD 10 + ORD('0');
    S[I+1]:=ENDSTR;
    ITOC:=I+1;
  END
END;

PROCEDURE PUTDEC;
VAR I,ND:INTEGER;
  S:XSTRING;
BEGIN
  ND:=ITOC(N,S,1);
  FOR I:=ND TO W DO
    PUTC(BLANK);
  FOR I:=1 TO ND-1 DO
    PUTC(S[I])
END;

FUNCTION EQUAL;
VAR
  I:INTEGER;
BEGIN
  I:=1;
  WHILE(STR1[I]=STR2[I])AND(STR1[I]<>ENDSTR) DO
    I:=I+1;
  EQUAL:=(STR1[I]=STR2[I])
END;