ftp.barnyard.co.uk/2015.02.ftp.barnyard.co.uk.tar/ftp.barnyard.co.uk/cpm/walnut-creek-CDROM/ENTERPRS/CPM/UTILS/S/TURBTOOL.ARC/TOOLU.PAS

Pascal/Delphi Source File | 1989-09-27 | 13KB | 677 lines

{toolu.pas}

{
        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;