Programmer 7500/MAX_PROGRAMMERS.iso/INFO/PASCAL/PT03.ZIP/TED.AR

Text File | 1983-09-01 | 35.1 KB | 1,513 lines

-h- altpatsi.ted 398
{ patsize -- returns size of pattern entry at pat[n] }
function patsize (var pat : string; n : integer) : integer;
begin
 if (pat[n] = LITCHAR) then
  patsize := 2
 else if (pat[n] in [BOL, EOL, ANY]) then
  patsize := 1
 else if (pat[n] = CCL) or (pat[n] = NCCL) then
  patsize := pat[n+1] + 2
 else if (pat[n] = CLOSURE) then
  patsize := CLOSIZE
 else
  error('in patsize: can''t happen')
end;

-h- amatch.ted 1225
{ amatch -- look for match of pat[j]... at lin[offset]... }
function amatch (var lin : string; offset : integer;
  var pat : string; j : integer) : integer;
var
 i, k : integer;
 done : boolean;
{$include:'locate.ted'}
{$include:'omatch.ted' }
{$include:'patsize.ted'}
begin
 done := false;
 while (not done) and (pat[j] <> ENDSTR) do
  if (pat[j] = CLOSURE) then begin
   j := j + patsize(pat, j); { step over CLOSURE }
   i := offset;
   { match as many as possible }
   while (not done) and (lin[i] <> ENDSTR) do
    if (not omatch(lin, i, pat, j)) then
     done := true;
   { i points to input character that made us fail }
   { match rest of pattern against rest of input }
   { shrink closure by 1 after each failure }
   done := false;
   while (not done) and (i >= offset) do begin
    k := amatch(lin, i, pat, j+patsize(pat,j));
    if (k > 0) then { matched rest of pattern }
     done := true
    else
     i := i - 1
   end;
   offset := k; { if k = 0 failure else success }
   done := true
  end
  else if (not omatch(lin, offset, pat, j)) then begin
   offset := 0;  { non-closure }
   done := true
  end
  else { omatch succeeded on this pattern element }
   j := j + patsize(pat, j);
 amatch := offset
end;

-h- amatch0.ted 296
{ amatch -- with no metacharacters }
function amatch (var lin : string; i : integer;
  var pat : string; j : integer) : integer;
begin
 while (pat[j] <> ENDSTR) and (i > 0) do
  if (lin[i] <> pat[j]) then
   i := 0 { no match }
  else begin
   i := i + 1;
   j := j + 1
  end;
 amatch := i
end;

-h- amatch1.ted 320
{ amatch -- with some metacharacters }
function amatch (var lin : string; i : integer;
  var pat : string; j : integer) : integer;
#include "omatch.p"
begin
 while (pat[j] <> ENDSTR) and (i > 0) do
  if (omatch(lin, i, pat, j)) then
   j := j + patsize(pat, j)
  else
   i := 0; { no match possible }
 amatch := i
end;

-h- append.ted 524
{ append -- append lines after "line" }
function append (line : integer; glob : boolean) : stcode;
var
 inline : string;
 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(inline, STDIN, MAXSTR)) then
    stat := ENDDATA
   else if (inline[1] = PERIOD)
     and (inline[2] = NEWLINE) then
    done := true
   else if (puttxt(inline) = ERR) then
    stat := ERR
 end;
 append := stat
end;

-h- blkmove.ted 295
{ blkmove -- move block of lines n1..n2 to after n3 }
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;

-h- catsub.ted 437
{ catsub -- add replacement text to end of new }
procedure catsub (var lin : string; s1, s2 : integer;
  var sub : string; var new : string;
  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;

-h- change.ted 570
{ change -- change "from" into "to" on each line }
procedure change;
{$include:'findcons.fnd'}
 DITTO = 1;
var
 lin, pat, sub, arg : string;
{$include:'getpat.ted'}
{$include:'getsub.ted'}
{$include:'subline.ted'}
begin
 if (not getarg(1, arg, MAXSTR)) then
  error('usage: change from [to]');
 if (not getpat(arg, pat)) then
  error('change: illegal "from" pattern');
 if (not getarg(2, arg, MAXSTR)) then
  arg[1] := ENDSTR;
 if (not getsub(arg, sub)) then
  error('change: illegal "to" string');
 while (getline(lin, STDIN, MAXSTR)) do
  subline(lin, pat, sub)
end;

-h- ckglob.ted 755
{ ckglob -- if global prefix, mark lines to be affected }
function ckglob (var lin : string; var i : integer;
  var status : stcode) : stcode;
var
 n : integer;
 gflag : boolean;
 temp : string;
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; { mark affected lines }
   for n := line1 to line2 do begin
    gettxt(n, temp);
    putmark(n, (match(temp, pat) = gflag))
   end;
   for n := 1 to line1-1 do { erase other marks }
    putmark(n, false);
   for n := line2+1 to lastln do
    putmark(n, false);
   status := OK
  end
 end;
 ckglob := status
end;

-h- ckp.ted 338
{ ckp -- check for "p" after command }
function ckp (var lin : string; 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;

-h- clrbuf1.ted 176
{ clrbuf (in memory) -- initialize for new file }
procedure clrbuf;
var
 i : integer;
begin
 for i := 0 to MAXLINES do
  if (buf[i].txt <> NIL) then dispose(buf[i].txt);
end;

-h- clrbuf2.ted 134
{ clrbuf (scratch file) -- dispose of scratch file }
procedure clrbuf;
begin
 xclose(scrin);
 xclose(scrout);
 remove(edittemp)
end;

-h- default.ted 292
{ default -- set defaulted line numbers }
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;

-h- docmd.ted 2897
{ docmd -- handle all commands except globals }
function docmd (var lin : string; var i : integer;
  glob : boolean; var status : stcode) : stcode;
var
 fil, sub : string;
 line3 : integer;
 gflag, pflag : boolean;
begin
 pflag := false; { may be set by d, m, s }
 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;
 { else status is ERR }

 if (status = OK) and (pflag) then
  status := doprint(curln, curln);
 docmd := status
end;

-h- dodash.ted 818
{ dodash - expand set at src[i] into dest[j], stop at delim }
procedure dodash (delim : character; var src : string;
  var i : integer; var dest : string;
  var j : integer; maxset : integer);
var
 k : integer;
 junk : boolean;
begin
 while (src[i] <> delim) and (src[i] <> ENDSTR) do begin
  if (src[i] = ESCAPE) then
   junk := addstr(esc(src, i), dest, j, maxset)
  else if (src[i] <> DASH) then
   junk := addstr(src[i], dest, j, maxset)
  else if (j <= 1) or (src[i+1] = ENDSTR) then
   junk := addstr(DASH,dest,j,maxset) { literal - }
  else if (isalphanum(src[i-1]))
    and (isalphanum(src[i+1]))
    and (src[i-1] <= src[i+1]) then begin
   for k := src[i-1]+1 to src[i+1] do
    junk := addstr(k, dest, j, maxset);
   i := i + 1
  end
  else
   junk := addstr(DASH, dest, j, maxset);
  i := i + 1
 end
end;

-h- doglob.ted 592
{ doglob -- do command at lin[i] on all marked lines }
function doglob (var lin : string; 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 (getlist(lin, i, status) = OK) then
     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;

-h- doprint.ted 297
{ doprint -- print lines n1 through n2 }
function doprint (n1, n2 : integer) : stcode;
var
 i : integer;
 line : string;
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;

-h- doread.ted 573
{ doread -- read "fil" after line n }
function doread (n : integer; var fil : string) : stcode;
var
 count : integer;
 t : boolean;
 stat : stcode;
 fd : filedesc;
 inline : string;
begin
 fd := open(fil, IOREAD);
 if (fd = IOERROR) then
  stat := ERR
 else begin
  curln := n;
  stat := OK;
  count := 0;
  repeat
   t := getline(inline, fd, MAXSTR);
   if (t) then begin
    stat := puttxt(inline);
    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;

-h- dowrite.ted 402
{ dowrite -- write lines n1..n2 into file }
function dowrite (n1, n2 : integer; var fil : string) : stcode;
var
 i : integer;
 fd : filedesc;
 line : string;
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;

-h- editcons.ted 659
{ editcons -- const declarations for edit }
const
 MAXLINES = 2000; {a file this big would require about 200k on the heap}
 MAXPAT = MAXSTR;
 CLOSIZE = 1; { size of a closure entry }
 DITTO = ENDFILE;
 CLOSURE = STAR;
 BOL = PERCENT;
 EOL = DOLLAR;
  ANY = QUESTION;
 CCL = LBRACK;
 CCLEND = RBRACK;
 NEGATE = CARET;
 NCCL = EXCLAM;
 LITCHAR = LETC;
 CURLINE = PERIOD;
 LASTLINE = DOLLAR;
 SCAN = SLASH;
  BACKSCAN = BACKSLASH;

 ACMD = LETA; { = ord('a') }
 CCMD = LETC;
 DCMD = LETD;
 ECMD = LETE;
 EQCMD = EQUALS;
 FCMD = LETF;
 GCMD = LETG;
 ICMD = LETI;
 MCMD = LETM;
 PCMD = LETP;
 QCMD = LETQ;
 RCMD = LETR;
 SCMD = LETS;
 WCMD = LETW;
  XCMD = LETX;

-h- editproc.ted 767
{ editproc -- procedures for edit }
{$include:'edprim.ted'  } { editor buffer primitives }
{$include:'amatch.ted'  }
{$include:'match.ted'   }
{$include:'skipbl.ted'  }
{$include:'optpat.ted'  }
{$include:'nextln.ted'  }
{$include:'prevln.ted'  }
{$include:'patscan.ted' }
{$include:'getnum.ted'  }
{$include:'getone.ted'  }
{$include:'getlist.ted' }
{$include:'append.ted'  }
{$include:'lndelete.ted'}
{$include:'doprint.ted' }
{$include:'doread.ted'  }
{$include:'dowrite.ted' }
{$include:'move.ted'    }
{$include:'makesub.ted' }
{$include:'getrhs.ted'  }
{$include:'catsub.ted'  }
{$include:'subst.ted'   }
{$include:'ckp.ted'     }
{$include:'default.ted' }
{$include:'getfn.ted'   }
{$include:'docmd.ted'   }
{$include:'ckglob.ted'  }
{$include:'doglob.ted'  }
-h- edittype.ted 26
{$include:'edtype1.ted'}

-h- editvar.ted 25
{$include:'edvar1.ted'}

-h- edprim.ted 26
{$include:'edprim1.ted'}

-h- edprim1.ted 201
{$include:'setbuf1.ted'}
{$include:'clrbuf1.ted'}
{$include:'getmark.ted'}
{$include:'putmark.ted'}
{$include:'gettxt1.ted'}
{$include:'reverse.ted'}
{$include:'blkmove.ted'}
{$include:'puttxt1.ted'}

-h- edprim2.ted 226
{$include:'seek.ted'   }
{$include:'setbuf2.ted'}
{$include:'clrbuf2.ted'}
{$include:'getmark.ted'}
{$include:'putmark.ted'}
{$include:'gettxt2.ted'}
{$include:'reverse.ted'}
{$include:'blkmove.ted'}
{$include:'puttxt2.ted'}

-h- edtype1.ted 255
{ edittype -- types for in-memory version of edit }
type
 stcode = (ENDDATA, ERR, OK); { status returns }
 strptr = ^string;
 buftype = { in-memory edit buffer entry }
  record
   txt : strptr; { text of line }
   mark : boolean { mark for line }
  end;

-h- edtype2.ted 189
{ edittype -- types for scratch-file version of edit }
type
 stcode = (ENDDATA, ERR, OK);
 buftype =
  record
   txt : integer; { text of line }
   mark : boolean { mark for line }
  end;

-h- edvar1.ted 412
{ editvar -- variables for edit }
var
 buf : array [0..MAXLINES] of buftype;

 line1 : integer; { first line number }
 line2 : integer; { second line number }
 nlines : integer; { # of line numbers specified }
 curln : integer; { current line -- value of dot }
 lastln : integer; { last line -- value of $ }

 pat : string;    { pattern }
 lin : string;    { input line }
 savefile : string; { remembered file name }

-h- edvar2.ted 649
{ editvar -- variables for edit }
var
 buf : array [0..MAXLINES] of buftype;
 scrout : filedesc; { scratch input fd }
 scrin : filedesc; { scratch output fd }
 recin : integer; { next record to read from scrin }
 recout : integer; { next record to write on scrout }
 edittemp : string; { temp file name 'edtemp' }

 line1 : integer; { first line number }
 line2 : integer; { second line number }
 nlines : integer; { # of line numbers specified }
 curln : integer; { current line -- value of dot }
 lastln : integer; { last line -- value of $ }

 pat : string;    { pattern }
 lin : string;    { input line }
 savefile : string; { remembered file name }

-h- getccl.ted 545
{ getccl -- expand char class at arg[i] into pat[j] }
function getccl (var arg : string; var i : integer;
   var pat : string; var j : integer) : boolean;
var
 jstart : integer;
 junk : boolean;
begin
 i := i + 1; { skip over '[' }
 if (arg[i] = NEGATE) then begin
  junk := addstr(NCCL, pat, j, MAXPAT);
  i := i + 1
 end
 else
  junk := addstr(CCL, pat, j, MAXPAT);
 jstart := j;
 junk := addstr(0, pat, j, MAXPAT); { room for count }
 dodash(CCLEND, arg, i, pat, j, MAXPAT);
 pat[jstart] := j - jstart - 1;
 getccl := (arg[i] = CCLEND)
end;

-h- getfn.ted 599
{ getfn -- get file name from lin[i]... }
function getfn (var lin : string; var i : integer;
  var fil : string) : stcode;
var
 k : integer;
 stat : stcode;
{$include:'getword.ted'}
begin
 stat := ERR;
 if (lin[i+1] = BLANK) then begin
  k := getword(lin, i+2, fil); { get new filename }
  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); { save if no old one }
 getfn := stat
end;

-h- getlist.ted 719
{ getlist -- get list of line nums at lin[i], increment i }
function getlist (var lin : string; 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 := imin(nlines, 2);
 if (nlines = 0) then
  line2 := curln;
 if (nlines <= 1) then
  line1 := line2;
 if (status <> ERR) then
  status := OK;
 getlist := status
end;

-h- getmark.ted 116
{ getmark -- get mark from nth line }
function getmark (n : integer) : boolean;
begin
 getmark := buf[n].mark
end;

-h- getnum.ted 681
{ getnum -- get single line number component }
function getnum (var lin : string;  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 { move back; to be advanced at end }
 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  { build pattern }
   status := ERR
  else
   status := patscan(lin[i], num)
 end
 else
  status := ENDDATA;
 if (status = OK) then
  i := i + 1; { next character to be examined }
 getnum := status
end;

-h- getone.ted 815
{ getone -- get one line number expression }
function getone (var lin : string; 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  { 1st term }
  repeat { + or - terms }
   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;

-h- getpat.ted 178
{ getpat -- convert argument into pattern }
function getpat (var arg, pat : string) : boolean;
{$include:'makepat.ted'}
begin
 getpat := (makepat(arg, 1, ENDSTR, pat) > 0)
end;

-h- getrhs.ted 470
{ getrhs -- get right hand side of "s" command }
function getrhs (var lin : string; var i : integer;
   var sub : string; 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;

-h- getsub.ted 181
{ getsub -- get substitution string into sub }
function getsub (var arg, sub : string) : boolean;
{$include:'makesub.ted'}
begin
 getsub := (makesub(arg, 1, ENDSTR, sub) > 0)
end;

-h- gettxt1.ted 196
{ gettxt (in memory) -- get text from line n into s }
procedure gettxt (n : integer; var s : string);
begin
 if (buf[n].txt <> NIL) then
  scopy(buf[n].txt^, 1, s, 1)
 else
  s[1] := ENDSTR
end;

-h- gettxt2.ted 275
{ gettxt (scratch file) -- get text from line n into s }
procedure gettxt (n : integer; var s : string);
var
 junk : boolean;
begin
 if (n = 0) then
  s[1] := ENDSTR
 else begin
  xseek(buf[n].txt, scrin);
  recin := recin + 1;
  junk := getline(s, scrin, MAXSTR)
 end
end;

-h- getword.ted 407
{ getword -- get word from s[i] into out }
function getword (var s : string; i : integer;
   var out : string) : 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;

-h- lndelete.ted 299
{ lndelete -- delete lines n1 through n2 }
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;

-h- locate.ted 430
{ locate -- look for c in character class at pat[offset] }
function locate (c : character; var pat : string;
  offset : integer) : boolean;
var
 i : integer;
begin
 { size of class is at pat[offset], characters follow }
 locate := false;
 i := offset + pat[offset]; { last position }
 while (i > offset) do
  if (c = pat[i]) then begin
   locate := true;
   i := offset { force loop termination }
  end
  else
   i := i - 1
end;

-h- makepat.ted 1339
{ makepat -- make pattern from arg[i], terminate at delim }
function makepat (var arg : string; start : integer;
  delim : character; var pat : string) : integer;
var
 i, j, lastj, lj : integer;
 done, junk : boolean;
{$include:'dodash.ted'}
{$include:'getccl.ted' }
{$include:'stclose.ted'}
begin
 j := 1; { pat index }
 i := start; { arg index }
 lastj := 1;
 done := false;
 while (not done) and (arg[i] <> delim)
   and (arg[i] <> ENDSTR) do begin
  lj := j;
  if (arg[i] = ANY) then
   junk := addstr(ANY, pat, j, MAXPAT)
  else if (arg[i] = BOL) and (i = start) then
   junk := addstr(BOL, pat, j, MAXPAT)
  else if (arg[i] = EOL) and (arg[i+1] = delim) then
   junk := addstr(EOL, pat, j, MAXPAT)
  else if (arg[i] = CCL) then
   done := (getccl(arg, i, pat, j) = false)
  else if (arg[i] = CLOSURE) and (i > start) then begin
   lj := lastj;
   if (pat[lj] in [BOL, EOL, CLOSURE]) then
    done := true { force loop termination }
   else
    stclose(pat, j, lastj)
  end
  else begin
   junk := addstr(LITCHAR, pat, j, MAXPAT);
   junk := addstr(esc(arg, i), pat, j, MAXPAT)
  end;
  lastj := lj;
  if (not done) then
   i := i + 1
 end;
 if (done) or (arg[i] <> delim) then  { finished early }
  makepat := 0
 else if (not addstr(ENDSTR, pat, j, MAXPAT)) then
  makepat := 0    { no room }
 else
  makepat := i    { all is well }
end;

-h- makesub.ted 583
{ makesub -- make substitution string from arg in sub }
function makesub (var arg : string; from : integer;
  delim : character; var sub : string) : 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  { missing delimiter }
  makesub := 0
 else if (not addstr(ENDSTR, sub, j, MAXPAT)) then
  makesub := 0
 else
  makesub := i
end;

-h- match.ted 291
{ match -- find match anywhere on line }
function match (var lin, pat : string) : boolean;
var
 i, pos : integer;
{$include:'amatch.ted'}
begin
 pos := 0;
 i := 1;
 while (lin[i] <> ENDSTR) and (pos = 0) do begin
  pos := amatch(lin, i, pat, 1);
  i := i + 1
 end;
 match := (pos > 0)
end;

-h- move.ted 329
{ move -- move line1 through line2 after line3 }
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;

-h- nextln.ted 145
{ nextln -- get line after n }
function nextln (n : integer) : integer;
begin
 if (n >= lastln) then
  nextln := 0
 else
  nextln := n + 1
end;

-h- omatch.ted 877
{ omatch -- match one pattern element at pat[j] }
function omatch (var lin : string; var i : integer;
  var pat : string; j : integer) : boolean;
var
 advance : -1..1;
begin
 advance := -1;
 if (lin[i] = ENDSTR) then
  omatch := false
 else if (not (pat[j] in
   [LITCHAR, BOL, EOL, ANY, CCL, NCCL, CLOSURE])) then
  error('in omatch: can''t happen')
 else
  case pat[j] of
   LITCHAR:
    if (lin[i] = pat[j+1]) then
     advance := 1;
   BOL:
    if (i = 1) then
     advance := 0;
   ANY:
    if (lin[i] <> NEWLINE) then
     advance := 1;
   EOL:
    if (lin[i] = NEWLINE) then
     advance := 0;
   CCL:
    if (locate(lin[i], pat, j+1)) then
     advance := 1;
   NCCL:
    if (lin[i] <> NEWLINE)
       and (not locate(lin[i], pat, j+1)) then
     advance := 1
  end;
 if (advance >= 0) then begin
  i := i + advance;
  omatch := true
 end
 else
  omatch := false
end;

-h- optpat.ted 509
{ optpat -- get optional pattern from lin[i], increment i }
function optpat (var lin : string; var i : integer) : stcode;
{$include:'makepat.ted'}
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  { repeated delimiter }
  i := i + 1 { leave existing pattern alone }
 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;

-h- patscan.ted 415
{ patscan -- find next occurrence of pattern after line n }
function patscan (way : character; var n : integer) : stcode;
var
 done : boolean;
 line : string;
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;

-h- patsize.ted 412
{ patsize -- returns size of pattern entry at pat[n] }
function patsize (var pat : string; n : integer) : integer;
begin
 if (not (pat[n] in
   [LITCHAR, BOL, EOL, ANY, CCL, NCCL, CLOSURE])) then
  error('in patsize: can''t happen')
 else
  case pat[n] of
   LITCHAR:
    patsize := 2;
   BOL, EOL, ANY:
    patsize := 1;
   CCL, NCCL:
    patsize := pat[n+1] + 2;
   CLOSURE:
    patsize := CLOSIZE
  end
end;

-h- prevln.ted 146
{ prevln -- get line before n }
function prevln (n : integer) : integer;
begin
 if (n <= 0) then
  prevln := lastln
 else
  prevln := n - 1
end;

-h- putmark.ted 113
{ putmark -- put mark m on nth line }
procedure putmark(n : integer; m : boolean);
begin
 buf[n].mark := m
end;

-h- putsub.ted 320
{ putsub -- output substitution text }
procedure putsub (var lin : string; s1, s2 : integer;
  var sub : string);
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
    putc(lin[j])
  else
   putc(sub[i]);
  i := i + 1
 end
end;

-h- puttxt1.ted 384
{ puttxt (in memory) -- put text from lin after curln }
function puttxt (var lin : string) : stcode;
begin
 puttxt := ERR;
 if (lastln < MAXLINES) then begin
  lastln := lastln + 1;
  if (buf[lastln].txt = NIL) then new(buf[lastln].txt);
  scopy(lin, 1, buf[lastln].txt^, 1);
  putmark(lastln, false);
  blkmove(lastln, lastln, curln);
  curln := curln + 1;
  puttxt := OK
 end
end;

-h- puttxt2.ted 369
{ puttxt (scratch file) -- put text from lin after curln }
function puttxt (var lin : string) : stcode;
begin
 puttxt := ERR;
 if (lastln < MAXLINES) then begin
  lastln := lastln + 1;
  putstr(lin, scrout);
  putmark(lastln, false);
  buf[lastln].txt := recout;
  recout := recout + 1;
  blkmove(lastln, lastln, curln);
  curln := curln + 1;
  puttxt := OK
 end
end;

-h- reverse.ted 234
{ reverse -- reverse buf[n1]...buf[n2] }
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;

-h- seek.ted 479
{ xseek (PC) -- special version of primitive for edit }
procedure xseek (recno : integer; var fd : filedesc);
var
 junk : boolean;
 temp : string;
begin
 flush(scrout);
 {This could be REAL slow unless just moving sequentially thru file}
 if (recno < recin) then begin
  xclose(fd);
  { cheat: open scratch file by name }
  fd := mustopen(edittemp, IOREAD);
  recin := 1;
 end;
 while (recin < recno) do begin
  junk := getline(temp, fd, MAXSTR);
  recin := recin + 1
 end
end;

-h- setbuf1.ted 222
{ setbuf (in memory) -- initialize line storage buffer }
procedure setbuf;
var
 i : integer;
begin
 new(buf[0].txt);
 buf[0].txt^[1] := ENDSTR;
 for i := 1 to MAXLINES do buf[i].txt := NIL;
 curln := 0;
 lastln := 0
end;

-h- setbuf2.ted 450
{ setbuf (scratch file) -- create scratch file, set up line 0 }
procedure setbuf;
begin
 { setstring(edittemp, 'edtemp'); }
  edittemp[1] := ord('e');
  edittemp[2] := ord('d');
  edittemp[3] := ord('t');
  edittemp[4] := ord('e');
  edittemp[5] := ord('m');
  edittemp[6] := ord('p');
  edittemp[7] := ENDSTR;
 scrout := mustcreate(edittemp, IOWRITE);
 scrin := mustopen(edittemp, IOREAD);
 recout := 1;
 recin := 1;
 curln := 0;
 lastln := 0
end;

-h- skipbl.ted 164
{ skipbl -- skip blanks and tabs at s[i]... }
procedure skipbl (var s : string; var i : integer);
begin
 while (s[i] = BLANK) or (s[i] = TAB) do
  i := i + 1
end;

-h- stclose.ted 355
{ stclose -- insert closure entry at pat[j] }
procedure stclose (var pat : string; var j : integer;
  lastj : integer);
var
 jp, jt : integer;
 junk : boolean;
begin
 for jp := j-1 downto lastj do begin
  jt := jp + CLOSIZE;
  junk := addstr(pat[jp], pat, jt, MAXPAT)
 end;
 j := j + CLOSIZE;
 pat[lastj] := CLOSURE    { where original pattern began }
end;

-h- subline.ted 559
{ subline -- substitute sub for pat in lin and print }
procedure subline (var lin, pat, sub : string);
var
 i, lastm, m : integer;
 junk : boolean;
{$include:'amatch.ted'}
{$include:'putsub.ted'}
begin
 lastm := 0;
 i := 1;
 while (lin[i] <> ENDSTR) do begin
  m := amatch(lin, i, pat, 1);
  if (m > 0) and (lastm <> m) then begin
   { replace matched text }
   putsub(lin, i, m, sub);
   lastm := m
  end;
  if (m = 0) or (m = i) then begin
   { no match or null match }
   putc(lin[i]);
   i := i + 1
  end
  else { skip matched text }
   i := m
 end
end;

-h- subst.ted 1284
{ subst -- substitute "sub" for occurrences of pattern }
function subst (var sub : string; gflag, glob : boolean) : stcode;
var
 new, old : string;
 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
    { replace matched text }
    subbed := true;
    catsub(old, k, m, sub, new, j, MAXSTR);
    lastm := m
   end;
   if (m = 0) or (m = k) then begin
    { no match or null match }
    junk := addstr(old[k], new, j, MAXSTR);
    k := k + 1
   end
   else { skip matched text }
    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;
-h- ted.ted 936
{ edit -- main routine for text editor }
procedure edit;
{$include:'editcons.ted'}
{$include:'edittype.ted'}
{$include:'editvar.ted' }
 cursave, i : integer;
 status : stcode;
 more : boolean;
{$include:'editproc.ted'}
begin
 setbuf;
 pat[1] := ENDSTR;
 savefile[1] := ENDSTR;
 if (getarg(1, savefile, MAXSTR)) then
  if (doread(0, savefile) = ERR) then
   message('?');
 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)
   { else ERR, do nothing }
  end;
  if (status = ERR) then begin
   message('?');
   curln := imin(cursave, lastln)
  end
  else if (status = ENDDATA) then
   more := false;
  { else OK }
  if (more) then
   more := getline(lin, STDIN, MAXSTR)
 end;
 clrbuf
end;

-h- ted.pas 740
{$debug-}
program outer (input,output);

{$include:'globcons.inc'}
{$include:'globtyps.inc'}

{$include:'initio.dcl'}
{$include:'flush.dcl' }

{$include:'isdigit.dcl' }
{$include:'isalphan.dcl'}
{$include:'ctoi.dcl'    }
{$include:'addstr.dcl'  }
{$include:'esc.dcl'     }
{$include:'error.dcl'   }
{$include:'message.dcl' }
{$include:'open.dcl'    }
{$include:'close.dcl'   }
{$include:'create.dcl'  }
{$include:'mustopen.dcl'}
{$include:'mustcrea.dcl'}
{$include:'remove.dcl'  }
{$include:'getline.dcl' }
{$include:'putstr.dcl'  }
{$include:'putdec.dcl'  }
{$include:'putc.dcl'    }
{$include:'imin.dcl'    }
{$include:'scopy.dcl'   }
{$include:'getarg.dcl'  }

{$include:'ted.ted'     }
BEGIN
  minitio; initio;
  edit;
  flush(0);
END.
-h- ted.mak 190
ted+initio+getfcb+flush+isdigit+ctoi+itoc+addstr+esc+
error+message+mustopen+mustcrea+open+create+close+
remove+getline+getcf+getc+putstr+putdec+putcf+putc+
imin+scopy+getarg+nargs+isalphan
-h- change.pas 430
{$debug-}
program outer (input,output);

{$include:'globcons.inc'}
{$include:'globtyps.inc'}

{$include:'initio.dcl'}
{$include:'flush.dcl' }

{$include:'isalphan.dcl'}
{$include:'addstr.dcl'  }
{$include:'esc.dcl'     }
{$include:'error.dcl'   }
{$include:'getline.dcl' }
{$include:'putstr.dcl'  }
{$include:'putc.dcl'    }
{$include:'getarg.dcl'  }

{$include:'change.ted'  }
BEGIN
  minitio; initio;
  change;
  flush(0);
END.
-h- change.mak 105
change+initio+getfcb+flush+addstr+esc+
error+getline+getcf+getc+isalphan+getarg+nargs+
putstr+putcf+putc