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

Pascal/Delphi Source File | 1992-11-30 | 17KB | 838 lines

{chapter6.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.
}

procedure edit;
const
  maxlines=1000;
  ditto=255;
  curline=period;
  lastline=dollar;
  scan=47;
  backscan=92;
  acmd=97;
  ccmd=99;
  dcmd=100;
  ecmd=101;
  eqcmd=equals;
  fcmd=102;
  gcmd=103;
  icmd=105;
  mcmd=109;
  pcmd=112;
  qcmd=113;
  rcmd=114;
  scmd=115;
  wcmd=119;
  xcmd=120;

type
  stcode=(enddata,err,ok);
  buftype=record
    txt:integer;
    mark:boolean;
  end;

var
  editfid:file of character;
  buf:array[0..maxlines]of buftype;
  recin:integer;
  recout:integer;
  line1,line2,nlines,curln,lastln:integer;
  pat,lin,savefile:xstring;
  cursave,i:integer;
  status:stcode;
  more:boolean;







procedure gettxt(n:integer;var s:xstring);
var
  ch:char;junk:boolean;i:integer;
begin
  if(n=0) then
    s[1]:=endstr
  else begin
    i:=0;
    seek(editfid,buf[n].txt);
    repeat
      i:=succ(i);
      read(editfid,s[i]);
      recin:=recin+1;
    until s[i]=endstr;
  end
end;


function getmark(n:integer):boolean;
begin
  getmark:=buf[n].mark
end;

procedure putmark(n:integer;m:boolean);
begin
  buf[n].mark:=m
end;

function doprint(n1,n2:integer):stcode;
var
  i:integer;
  line:xstring;
begin
  if(n1<=0)then
    doprint:=err
  else begin
    for i:=n1 to n2 do begin
      gettxt(i,line);
      putstr(line,stdout)
    end;
    curln:=n2;
    doprint:=ok
  end
end;

function default(def1,def2:integer;
  var status:stcode):stcode;
begin
  if(nlines=0)then begin
    line1:=def1;
    line2:=def2
  end;
  if(line1 > line2)or(line1 <=0)then
    status:=err
  else
    status:=ok;
  default:=status
end;

function prevln(n:integer):integer;
begin
  if(n<=0)then
    prevln:=lastln
  else
    prevln:=n-1
end;

function nextln(n:integer):integer;
begin
  if(n>=lastln)then
    nextln:=0
  else
    nextln:=n+1
end;

function patscan(way:character;var n:integer):stcode;
var
  done:boolean;
  line:xstring;
begin
  n:=curln;
  patscan:=err;
  done:=false;
  repeat
    if(way=scan)then
      n:=nextln(n)
    else
      n:=prevln(n);
    gettxt(n,line);
    if(match(line,pat))then begin
      patscan:=ok;
      done:=true
    end
  until(n=curln)or(done)
end;

function esc(var s:xstring; var i:integer):character;
begin
  if(s[i]<>escape) then
    esc:=s[i]
  else if (s[i+1]=endstr) then
    esc:=escape
  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 optpat(var lin:xstring;var i:integer):stcode;
begin
  if(lin[i]=endstr)then
    i:=0
  else if(lin[i+1]=endstr)then
    i:=0
  else if(lin[i+1]=lin[i])then
    i:=i+1
  else
    i:=makepat(lin,i+1,lin[i],pat);
  if(pat[1]=endstr)then
    i:=0;
  if(i=0)then begin
    pat[1]:=endstr;
    optpat:=err
  end
  else
    optpat:=ok
end;

procedure skipbl(var s:xstring;var i:integer);
begin
  while(s[i]=blank)or(s[i]=tab)do
    i:=i+1
end;

function getnum(var lin:xstring;var i,num:integer;
  var status:stcode):stcode;
begin
  status:=ok;
  skipbl(lin,i);
  if(isdigit(lin[i]))then begin
    num:=ctoi(lin,i);
      i:=i-1
  end
  else if(lin[i]=curline)then
    num:=curln
  else if(lin[i]=lastline)then
    num:=lastln
  else if(lin[i]=scan)or(lin[i]=backscan)then begin
    if(optpat(lin,i)=err)then
      status:=err
    else
      status:=patscan(lin[i],num)
  end
  else
    status:=enddata;
  if(status=ok)then
    i:=i+1;
  getnum:=status
end;

function getone(var lin:xstring;var i,num:integer;
  var status:stcode):stcode;
  var
    istart,mul,pnum:integer;
  begin
    istart:=i;
    num:=0;
    if(getnum(lin,i,num,status)=ok)then
      repeat
        skipbl(lin,i);
        if(lin[i]<>plus)and(lin[i]<>minus)then
          status:=enddata
        else begin
          if(lin[i]=plus)then
            mul:=+1
          else
            mul:=-1;
          i:=i+1;
          if(getnum(lin,i,pnum,status)=ok)then
            num:=num+mul*pnum;
          if(status=enddata)then
            status:=err
        end
      until(status<>ok);
    if(num<0)or(num > lastln)then
      status:=err;
    if(status<>err)then begin
      if(i<=istart)then
        status:=enddata
      else
        status:=ok
    end;
    getone:=status
  end;


function getlist(var lin:xstring;var i:integer;
  var status:stcode):stcode;
var
  num:integer;
  done:boolean;
begin
  line2:=0;
  nlines:=0;
  done:=(getone(lin,i,num,status)<>ok);
  while(not done)do begin
    line1:=line2;
    line2:=num;
    nlines:=nlines+1;
    if(lin[i]=semicol)then
      curln:=num;
    if(lin[i]=comma)or(lin[i]=semicol)then begin
      i:=i+1;
      done:=(getone(lin,i,num,status)<>ok)
    end
    else
      done:=true
  end;
  nlines:=min(nlines,2);
  if(nlines=0)then
    line2:=curln;
  if(nlines<=1)then
    line1:=line2;
  if(status<>err)then
    status:=ok;
  getlist:=status
end;

procedure reverse(n1,n2:integer);
var
  temp:buftype;
begin
  while(n1<n2)do begin
    temp:=buf[n1];
    buf[n1]:=buf[n2];
    buf[n2]:=temp;
    n1:=n1+1;
    n2:=n2-1
  end
end;
procedure blkmove(n1,n2,n3:integer);
begin
  if(n3<n1-1)then begin
    reverse(n3+1,n1-1);
    reverse(n1,n2);
    reverse(n3+1,n2)
  end
  else if(n3>n2)then begin
    reverse(n1,n2);
    reverse(n2+1,n3);
    reverse(n1,n3)
  end
end;

function move(line3:integer):stcode;
begin
  if(line1<=0)or((line3>=line1)and(line3<line2))then
    move:=err
  else begin
    blkmove(line1,line2,line3);
    if(line3>line1)then
      curln:=line3
    else
       curln:=line3+(line2-line1+1);
     move:=ok
   end
 end;

function lndelete(n1,n2:integer;var status:stcode):
stcode;
begin
  if(n1<=0)then
    status:=err
  else begin
    blkmove(n1,n2,lastln);
    lastln:=lastln-(n2-n1+1);
    curln:=prevln(n1);
    status:=ok
  end;
  lndelete:=status
end;

function ckp(var lin:xstring;i:integer;
  var pflag:boolean;var status:stcode):stcode;
begin
  skipbl(lin,i);
  if(lin[i]=pcmd)then begin
    i:=i+1;
    pflag:=true
  end
  else
    pflag:=false;
  if(lin[i]=newline)then
    status:=ok
  else
    status:=err;
  ckp:=status
end;

function puttxt(var lin:xstring):stcode;
var i:integer;
begin
  puttxt:=err;
  if(lastln<maxlines) then begin
    i:=0;
    seek(editfid,recout);
    lastln:=lastln+1;
    buf[lastln].txt:=recout;
    repeat
      i:=succ(i);
      write(editfid,lin[i]);
      recout:=recout+1
    until lin[i]=endstr;
    write(editfid,lin[i]);
    putmark(lastln,false);
    blkmove(lastln,lastln,curln);
    curln:=curln+1;
    puttxt:=ok
  end
end;

procedure setbuf;
begin
(*$I-*)
  assign(editfid,'edtemp');
  reset(editfid);
  if (ioresult<>0) then rewrite(editfid);
(*$I+*)

  recout:=0;
  recin:=0;
  curln:=0;
  lastln:=0
end;


procedure clrbuf;
begin
  close(editfid);erase(editfid)
end;

function append(line:integer;glob:boolean):stcode;
var
  einline:xstring;
  stat:stcode;
  done:boolean;
begin
  if(glob)then
    stat:=err
  else begin
    curln:=line;
    stat:=ok;
    done:=false;
    while(not done)and(stat=ok)do
      if(not getline(einline,stdin,maxstr))then
        stat:=enddata
      else if(einline[1]=period)
        and(einline[2]=newline)then
          done:=true
      else if(puttxt(einline)=err)then
        stat:=err
  end;
  append:=stat
end;

function dowrite(n1,n2:integer;var fil:xstring):stcode;
var
  i:integer;
  fd: filedesc;
  line: xstring;
begin
  fd:=create(fil,iowrite);
  if(fd=ioerror)then
    dowrite:=err
  else begin
    for i:=n1 to n2 do begin
      gettxt(i,line);
      putstr(line,fd)
    end;
    xclose(fd);
    putdec(n2-n1+1,1);
    putc(newline);
    dowrite:=ok
  end
end;

function doread(n:integer;var fil:xstring):stcode;
var
  count:integer;
  t:boolean;
  stat:stcode;
  fd:filedesc;
  einline:xstring;
begin
  fd:=open(fil,ioread);
  if(fd=ioerror)then
    stat:=err
  else begin
    curln:=n;
    stat:=ok;
    count:=0;
    repeat
      t:=getline(einline,fd,maxstr);
      if(t)then begin
        stat:=puttxt(einline);
        if(stat<>err)then
          count:=count+1
      end
    until(stat<>ok)or(t=false);
    xclose(fd);
    putdec(count,1);
    putc(newline)
  end;
  doread:=stat
end;

function getfn(var lin:xstring;var i:integer;
  var fil:xstring):stcode;
var
  k:integer;
  stat:stcode;

function getword(var s:xstring;i:integer;var out:
  xstring):integer;
var
  j:integer;
begin
  while(s[i]in [blank,tab,newline])do
    i:=i+1;
  j:=1;
  while(not(s[i]in [endstr,blank,tab,
    newline]))do begin
    out[j]:=s[i];
    i:=i+1;
    j:=j+1
  end;
  out[j]:=endstr;
  if(s[i]=endstr)then
    getword:=0
  else
    getword:=i
end;

begin(*getfn*)
  stat:=err;
  if(lin[i+1]=blank)then begin
    k:=getword(lin,i+2,fil);
    if(k>0)then
      if(lin[k]=newline)then
        stat:=ok
  end
  else if(lin[i+1]=newline)
    and(savefile[1]<>endstr)then begin
      scopy(savefile,1,fil,1);
      stat:=ok;
  end;
  if(stat=ok)and(savefile[1]=endstr)then
    scopy(fil,1,savefile,1);
  getfn:=stat
end;

procedure catsub(var lin:xstring;s1,s2: integer;
  var sub: xstring;var new:xstring;
  var k:integer;maxnew:integer);
var
  i,j:integer;
  junk:boolean;
begin
  i:=1;
  while(sub[i]<>endstr)do begin
    if(sub[i]=ditto)then
      for j:=s1 to s2-1 do
        junk:=addstr(lin[j],new,k,maxnew)
      else
        junk:=addstr(sub[i],new,k,maxnew);
      i:=i+1
  end
end;

function subst( var sub:xstring;gflag,glob:boolean):stcode;
var
  new,old:xstring;
  j,k,lastm,line,m:integer;
  stat:stcode;
  done,subbed,junk:boolean;
begin
  if(glob)then
    stat:=ok
  else
    stat:=err;
    done:=(line1<=0);
    line:=line1;
    while(not done)and(line<=line2)do begin
      j:=1;
      subbed:=false;
      gettxt(line,old);
      lastm:=0;
      k:=1;
      while(old[k]<>endstr)do begin
        if(gflag)or(not subbed)then
          m:=amatch(old,k,pat,1)
        else
          m:=0;
        if(m>0)and(lastm<>m)then begin
          subbed:=true;
          catsub(old,k,m,sub,new,j,maxstr);
          lastm:=m
        end;
        if(m=0)or(m=k)then begin
          junk:=addstr(old[k],new,j,maxstr);
          k:=k+1
        end
        else
          k:=m
      end;
      if(subbed)then begin
        if(not addstr(endstr,new,j,maxstr))then begin
          stat:=err;
          done:=true
        end
        else begin
          stat:=lndelete(line,line,status);
          stat:=puttxt(new);
          line2:=line2+curln-line;
          line:=curln;
          if(stat=err)then
            done:=true
          else
            stat:=ok
          end
        end;
        line:=line+1
      end;
      subst:=stat
    end;
function makesub(var arg:xstring;from:integer;
  delim:character;var sub:xstring):integer;
var i,j:integer;
   junk:boolean;
begin
  j:=1;
  i:=from;
  while(arg[i]<>delim)and(arg[i]<>endstr)do begin
    if(arg[i]=ord('&'))then
      junk:=addstr(ditto,sub,j,maxpat)
    else
      junk:=addstr(esc(arg,i),sub,j,maxpat);
    i:=i+1
  end;
  if(arg[i]<>delim) then
    makesub:=0
  else if (not addstr(endstr,sub,j,maxpat))then
    makesub:=0
  else
    makesub:=i
end;
function getrhs(var lin:xstring;var i:integer;
  var sub:xstring;var gflag:boolean):stcode;
begin
  getrhs:=ok;
  if(lin[i]=endstr)then
    getrhs:=err
  else if(lin[i+1]=endstr)then
    getrhs:=err
  else begin
    i:=makesub(lin,i+1,lin[i],sub);
    if(i=0)then
      getrhs:=err
    else if(lin[i+1]=ord('g'))then begin
      i:=i+1;
      gflag:=true
    end
    else
      gflag:=false
  end
end;

function docmd(var lin:xstring;var i:integer;
  glob:boolean;var status:stcode):stcode;
var
  fil,sub:xstring;
  line3:integer;
  gflag,pflag:boolean;
begin
  pflag:=false;
  status:=err;
  if(lin[i]=pcmd)then begin
    if(lin[i+1]=newline)then
      if(default(curln,curln,status)=ok)then
        status:=doprint(line1,line2)
  end
  else if(lin[i]=newline)then begin
    if(nlines=0)then
      line2:=nextln(curln);
    status:=doprint(line2,line2)
  end
  else if(lin[i]=qcmd)then begin
    if( lin[i+1]=newline)and(nlines=0)and(not glob)then
  status:=enddata
  end
  else if(lin[i]=acmd)then begin
    if(lin[i+1]=newline)then
      status:=append(line2,glob)
  end
  else if(lin[i]=ccmd)then begin
    if(lin[i+1]=newline)then
      if(default(curln,curln,status)=ok)then
      if(lndelete(line1,line2,status)=ok)then
        status:=append(prevln(line1),glob)
  end
  else if(lin[i]=dcmd)then begin
    if(ckp(lin,i+1,pflag,status)=ok)then
     if(default(curln,curln,status)=ok)then
     if(lndelete(line1,line2,status)=ok)then
     if(nextln(curln)<>0)then
       curln:=nextln(curln)
  end
  else if(lin[i]=icmd)then begin
    if(lin[i+1]=newline)then begin
      if(line2=0)then
        status:=append(0,glob)
      else
        status:=append(prevln(line2),glob)
    end
  end
  else if(lin[i]=eqcmd)then begin
    if(ckp(lin,i+1,pflag,status)=ok)then begin
      putdec(line2,1);
      putc(newline)
    end
  end
  else if(lin[i]=mcmd)then begin
    i:=i+1;
    if(getone(lin,i,line3,status)=enddata)then
      status:=err;
    if(status =ok)then
      if(ckp(lin,i,pflag,status)=ok)then
      if(default(curln,curln,status)=ok)then
        status:=move(line3)
  end
  else if(lin[i]=scmd)then begin
    i:=i+1;
    if(optpat(lin,i)=ok)then
    if(getrhs(lin,i,sub,gflag)=ok)then
    if(ckp(lin,i+1,pflag,status)=ok)then
    if(default(curln,curln,status)=ok)then
      status:=subst(sub,gflag,glob)
  end
  else if(lin[i]=ecmd)then begin
    if(nlines =0)then
      if(getfn(lin,i,fil)=ok)then begin
        scopy(fil,1,savefile,1);
        clrbuf;
        setbuf;
        status:=doread(0,fil)
      end
  end
  else if(lin[i]=fcmd)then begin
    if(nlines =0)then
      if(getfn(lin,i,fil)=ok)then begin
        scopy(fil,1,savefile,1);
        putstr(savefile,stdout);
        putc(newline);
        status:=ok
    end
  end
  else if(lin[i]=rcmd)then begin
    if(getfn(lin,i,fil)=ok)then
      status:=doread(line2,fil)
  end
  else if(lin[i]=wcmd)then begin
    if(getfn(lin,i,fil)=ok)then
      if(default(1,lastln,status)=ok)then
        status:=dowrite(line1,line2,fil)
  end;
  if(status =ok)and(pflag)then
    status:=doprint(curln,curln);
  docmd:=status
end;(*docmd*)

function ckglob(var lin: xstring;var i:integer;
  var status:stcode): stcode;
var
  n:integer;
  gflag:boolean;
  temp: xstring;
begin
  if(lin[i]<>gcmd)and(lin[i]<>xcmd)then
    status:=enddata
  else begin
    gflag:=(lin[i]=gcmd);
    i:=i+1;
    if(optpat(lin,i)=err)then
      status:=err
    else if( default(1,lastln,status)<>err)then begin
      i:=i+1;
      for n:=line1 to line2 do begin
        gettxt(n,temp);
        putmark(n,(match(temp,pat)=gflag))
      end;

      for n:=1 to line1-1 do
        putmark(n,false);
      for n:=line2+1 to lastln do
        putmark(n,false);
      status:=ok
    end
  end;
  ckglob:=status
end;

function doglob(var lin:xstring;var i,cursave:integer;
  var status: stcode):stcode;
var
  count,istart,n: integer;
begin
  status:=ok;
  count:=0;
  n:=line1;
  istart:=i;
  repeat
    if(getmark(n))then begin
      putmark(n,false);
      curln:=n;
      cursave:=curln;
      i:=istart;
      if(docmd(lin,i,true,status)=ok)then
        count:=0
    end
    else begin
      n:=nextln(n);
      count:=count + 1
    end
  until(count > lastln)or(status <> ok);
  doglob:=status
end;

begin
  setbuf;
  pat[1]:=endstr;
  savefile[1]:=endstr;
  if(getarg(2,savefile,maxstr))then
    if(doread(0,savefile)=err)then
      writeln('?');
  more:=getline(lin,stdin,maxstr);
  while(more)do begin
    i:=1;
    cursave:=curln;
    if(getlist(lin,i,status)=ok)then begin
      if(ckglob(lin,i,status)=ok)then
        status:=doglob(lin,i,cursave,status)
      else if(status<>err)then
        status:=docmd(lin,i,false,status)
    end;
    if(status=err)then begin
      writeln('?');
      curln:=min(cursave,lastln)
    end
    else if(status=enddata)then
      more:=false;
    if(more)then
      more:=getline(lin,stdin,maxstr)
  end;
  clrbuf
end;