(Message 209)
Subject: Ecce.pas MTS version
From: Harry_Whitfield <CL11 @ UK.AC.NEWCASTLE.MTS>
Date: Thu, 25 Jun 87 15:50:49 GMT
To: P.D.Stephens @ UK.AC.EDINBURGH
Via: UK.AC.EDINBURGH.EMAS-A ; (to uk.ac.edinburgh.emas-b) 25 Jun 87 15:51:36 bst
Via: UK.AC.NEWCASTLE.MTS ; (to uk.ac.edinburgh.emas-a) 25 Jun 87 15:51:16 bst
Msg ID: <sent 25 Jun 87 15:50:49 GMT via NCL.MTS>
{*****************************************************************************}
{** **}
{** Title: Edinburgh Editor Ecce for MTS **}
{** Author: H.Whitfield **}
{** Date: 17 November 1985 **}
{** Copyright (c) H.Whitfield 1985 **}
{** **}
{*****************************************************************************}
PROGRAM Ecce( input, output, InFile, OutFile );
LABEL
999; { stop }
CONST
cmax = 121;
stop = -5000;
inv = -5001;
lmax = 2048; { maximum line length }
FirstCol = 1;
LastCol = 80;
LineLength = 80;
ParsLength = 20;
TYPE
ComIndex = 0..cmax;
ComBuff = ARRAY [ ComIndex ] OF integer;
ColIndex = FirstCol..Lastcol;
Lines = PACKED ARRAY [ ColIndex ] OF char;
VAR
InFile, OutFile : text;
InFileName, OutFileName : Lines;
nl, lastsymbol, prompt, sym : char;
mon : integer;
clim : ComIndex;
prompted : boolean;
C : ComBuff;
FUNCTION FNnextsymbol : char;
BEGIN
IF ( lastsymbol = nl ) AND ( NOT prompted ) THEN
BEGIN
IF prompt <> ' ' THEN writeln( prompt );
prompted := true; get( input )
END;
IF eoln THEN FNnextsymbol := nl ELSE FNnextsymbol := input@
END; { FNnextsymbol }
FUNCTION FNreadsymbol : char;
VAR
sym : char;
BEGIN
sym := FNnextsymbol;
lastsymbol := sym; IF sym = nl THEN prompted := false ELSE get( input );
FNreadsymbol := sym
END; { FNreadsymbol }
PROCEDURE PROCskipsymbol;
VAR
sym : char;
BEGIN
sym := FNreadsymbol
END; { PROCskipsymbol }
PROCEDURE PROCreadcommand;
CONST
tbase = 1;
TYPE
itemtype = -1..10;
VAR
itype, i : itemtype;
code, quote : char;
num, matchlim, chain : integer;
done, again, error : boolean;
Ti, Ci, txt : ComIndex;
FUNCTION FNlower( ch : char ) : char; { Ascii and Ebcdic }
BEGIN
IF ( ( 'a' <= ch ) AND ( ch <= 'i' ) ) OR
( ( 'j' <= ch ) AND ( ch <= 'r' ) ) OR
( ( 's' <= ch ) AND ( ch <= 'z' ) )
THEN FNlower := chr( ord(ch)-ord('a')+ord('A') ) ELSE
IF ch = '`' THEN FNlower := '@' ELSE
IF ch = '{' THEN FNlower := '[' ELSE
IF ch = '|' THEN FNlower := '\' ELSE
IF ch = '}' THEN FNlower := ']' ELSE
IF ch = '~' THEN FNlower := '^' ELSE FNlower := ch
END; { FNlower }
FUNCTION FNnextitemtype : itemtype;
VAR
result : itemtype;
PROCEDURE PROCreadnum;
VAR
ch : char;
BEGIN
num := ord(sym)-ord('0'); ch := FNnextsymbol;
WHILE ( '0' <= ch ) AND ( ch <= '9' ) DO
BEGIN
num := 10*num + ord(ch) - ord('0');
PROCskipsymbol;
ch := FNnextsymbol
END
END; { PROCreadnum }
BEGIN { FNnextitemtype }
REPEAT sym := FNreadsymbol UNTIL sym <> ' ';
sym := FNlower( sym );
IF sym < ' ' THEN result := 1 ELSE
CASE sym OF
';' : result := 1;
'(' : result := 2;
',' : BEGIN IF FNnextsymbol=nl THEN PROCskipsymbol; result := 3 END;
')' : result := 4;
'I', 'S' : result :=5;
'D' : result := 6;
'F', 'T', 'U' : result := 7;
'V' : result := 8;
'E', 'M' : BEGIN
IF FNnextsymbol = '-' THEN
BEGIN
PROCskipsymbol;
IF sym = 'E' THEN sym := 'O' ELSE sym := 'W'
END;
result := 9
END;
'B', 'G', 'J', 'K', 'L', 'P', 'R' : result :=9;
'A', 'C', 'H', 'N', 'O', 'Q', '-', 'W', 'X', 'Y', 'Z' : result := 10;
'0', '1', '2', '3', '4', '5', '6', '7', '8', '9' :
BEGIN PROCreadnum; result := 0 END;
'*' : BEGIN num := 0; result := 0 END;
'?' : BEGIN num := stop + 1; result := 0 END;
'\', '^' : BEGIN num := inv + 1; result := 0 END;
'!', '"', '#', '$', '%', '&', '''', '+', '.', '/', ':', '<','=','>',
'@', '[', ']', '_' : result := -1
END; { CASE }
FNnextitemtype := result
END; { FNnextitemtype }
PROCEDURE PROCunchain;
VAR
finished : boolean;
BEGIN
txt := chain;
IF txt <> 0 THEN
BEGIN
finished := false;
REPEAT
chain := C[ txt ]; C[ txt ] := Ci;
IF C[ txt + 1 ] <> ord( 'Y' ) THEN txt := chain ELSE finished := true
UNTIL ( txt = 0 ) OR finished
END
END; { PROCunchain }
PROCEDURE PROCstack( v : integer );
BEGIN
Ci := Ci - 1; C[ Ci ] := v
END; { PROCstack }
PROCEDURE PROCpush;
BEGIN
PROCstack( 256*matchlim + ord(code) ); PROCstack( txt ); PROCstack( num )
END; { PROCpush }
PROCEDURE PROCerror( n : integer );
BEGIN
IF n <> 6 THEN
BEGIN
CASE n OF
0 : BEGIN write( ' ', code ); code := sym END;
1 : code := sym;
2 : code := '(';
3 : write( ' Text for' );
5 : ;
END; { CASE }
writeln( ' ', code, '?' )
END ELSE writeln( ' Too Long' );
IF Ci <> cmax THEN clim := 0;
WHILE sym <> nl DO sym := FNreadsymbol;
error := true
END; { PROCerror }
PROCEDURE PROCqstring;
BEGIN
IF ( itype >= 0 ) OR ( txt <> 0 ) THEN PROCerror( 3 ) ELSE
BEGIN
quote := sym; txt := Ti;
WHILE ( FNnextsymbol <> quote ) AND ( FNnextsymbol <> nl ) AND
( NOT error ) DO
BEGIN
sym := FNreadsymbol; C[ Ti ] := ord( sym ); Ti := Ti+1;
IF Ti = Ci THEN PROCerror( 6 );
END;
IF NOT error THEN
BEGIN
IF FNnextsymbol = nl THEN
BEGIN
IF ( code <> 'I' ) AND ( code <> 'S' ) THEN PROCerror( 3 )
END ELSE sym := FNreadsymbol;
IF NOT error THEN
BEGIN
IF ( Ti = txt ) AND ( code <> 'S' ) THEN PROCerror( 3 ) ELSE
BEGIN
C[ Ti ] := 0; Ti := Ti+1;
itype := FNnextitemtype;
IF itype = 0 THEN itype := FNnextitemtype;
PROCpush
END
END
END
END
END; { PROCqstring }
BEGIN { PROCreadcommand }
done := false;
REPEAT
again := false; error := false;
prompt := '>';
REPEAT itype := FNnextitemtype UNTIL itype <> 1;
Ci := cmax; Ti := tbase; chain := 0;
IF ( itype = 0 ) AND ( clim <> 0 ) THEN { repeat last command }
BEGIN
C[ clim ] := num;
IF FNnextitemtype = 1 THEN done := true ELSE PROCerror( 1 )
END ELSE
IF sym = '%' THEN
BEGIN
sym := FNlower( FNreadsymbol ); code := sym; matchlim := 0;
itype := FNnextitemtype;
IF itype <> 1 THEN PROCerror( 1 ) ELSE
IF code = 'C' THEN PROCpush ELSE
IF ( code = 'Q' ) OR ( code = 'M' ) OR ( code = 'F' ) THEN
BEGIN mon := ord('M')-ord(code); again := true END ELSE PROCerror( 1)
END ELSE
REPEAT
IF itype <= 0 THEN PROCerror( 1 ) ELSE
IF Ci-4 <= Ti THEN PROCerror( 6 ) ELSE
BEGIN
code := sym; matchlim :=0; txt := 0;
IF code = 'F' THEN num := 0 ELSE num := 1;
i := itype; itype := FNnextitemtype;
CASE i OF
2 : BEGIN { left bracket }
code := 'Y';
txt := chain; chain := Ci - 2;
PROCpush
END;
3 : BEGIN { comma }
num := inv; code := 'Z';
txt := chain; chain := Ci - 2;
PROCpush
END;
4 : BEGIN { right bracket }
PROCunchain;
IF txt = 0 THEN PROCerror( 5 ) ELSE
BEGIN
C[ txt ] := Ci - 3; txt := txt -1;
C[ txt ] := num; code := 'Z';
IF itype = 0 THEN itype := FNnextitemtype;
PROCpush
END
END;
5 : PROCqstring; { insert,substitute }
6 , { delete }
7 : BEGIN { find,traverse,uncover }
matchlim := num; num := 1;
IF itype = 0 THEN itype := FNnextitemtype;
PROCqstring
END;
8 : PROCqstring; { verify }
9 : IF itype < 0 THEN PROCerror( 0 ) ELSE { all the others }
BEGIN
IF itype = 0 THEN itype := FNnextitemtype;
PROCpush
END;
10: PROCerror( 5 ) { invalid letters }
END { CASE }
END
UNTIL ( itype = 1 ) OR error;
IF ( NOT done ) AND ( NOT again ) AND ( NOT error ) THEN
BEGIN
PROCunchain;
IF txt <> 0 THEN PROCerror ( 2 ) ELSE
BEGIN
PROCstack( ord('Z') ); PROCstack( cmax ); PROCstack( 1 );
clim := Ci; PROCstack( 0 ); done := true
END
END
UNTIL done
END; { PROCreadcommand }
PROCEDURE PROCedit;
LABEL
99; { return }
CONST
amax = 65535;
TYPE
BuffIndex = 0..amax;
Buffer = PACKED ARRAY [ BuffIndex ] OF char;
VAR
top, pe, pp, fp, bottom, pp1, ms, ml, lim, p : BuffIndex;
Ci, txt, i : Comindex;
num, codelim, matchlim, k : integer;
code, last, term, ch : char;
printed, ok, done, failed : boolean;
A : Buffer;
PROCEDURE PROCmakespace;
VAR
k : char;
p1, p2 : BuffIndex;
BEGIN
IF fp-pp-240 <= 0 THEN
BEGIN
p1 := top;
IF code = 'C' THEN p2 := pe ELSE p2 := (p1+pe) DIV 2;
IF p2 = top THEN
BEGIN writeln( 'Fatal error in PROCmakespace' ); GOTO 999 END;
REPEAT
k := A[ p1 ];
IF k <> nl THEN write( OutFile, k ) ELSE writeln( OutFile );
p1 := p1+1
UNTIL ( k = nl ) AND ( p1-p2 >= 0 );
pe := top+pe-p1; p2 := pp; pp := top;
WHILE p1 <> p2 DO
BEGIN
A[ pp ] := A[ p1 ]; pp := pp+1; p1 := p1+1
END
END
END; { PROCmakespace }
PROCEDURE PROCprintline;
VAR
p : BuffIndex;
BEGIN
printed := true;
IF fp = bottom THEN writeln( '**END**' ) ELSE
BEGIN
IF pe = pp THEN p := fp ELSE p := pe;
IF A[ p ] <> nl THEN write( A[ p ] ) ELSE writeln;
WHILE A[ p ] <> nl DO
BEGIN
p := p + 1;
IF ( p = pp ) AND ( num=0 ) THEN write ( '^' );
IF p = pp THEN p := fp;
IF A[ p ] <> nl THEN write( A[ p ] ) ELSE writeln;
END
END
END; { PROCprintline }
PROCEDURE PROCreadline;
VAR
k : char;
BEGIN
printed := false;
IF fp = bottom THEN
BEGIN
fp := lim - lmax; ms := 0;
IF eof( InFile ) THEN
BEGIN
fp := lim; bottom := fp; A[ fp ] := nl
END
ELSE
BEGIN
REPEAT
IF eoln( InFile ) THEN k := nl ELSE k := InFile@; get( InFile );
A[ fp ] := k; fp :=fp + 1
UNTIL ( k = nl ) OR eof( InFile ) OR ( fp = lim );
IF k = nl THEN
BEGIN
bottom := fp; fp := lim - lmax
END ELSE
IF eof( InFile ) THEN
BEGIN
fp := lim; bottom := fp; A[ fp ] := nl
END ELSE
BEGIN
IF eoln( InFile ) THEN get( InFile );
A[ fp ] := nl; fp := fp + 1; bottom := fp; fp := lim - lmax
END
END
END
END; { PROCreadline }
PROCEDURE PROClefttab;
BEGIN
WHILE pp <> pe DO
BEGIN
fp := fp-1; pp := pp-1; A[ fp ] := A[ pp ]
END
END; { PROClefttab }
PROCEDURE PROCmove;
VAR
k : char;
BEGIN
PROCmakespace;
REPEAT
k := A[ fp ]; A[ pp] := k; pp := pp+1; fp := fp+1
UNTIL k = nl;
pe := pp;
PROCreadline
END; { PROCmove }
PROCEDURE PROCmoveback;
VAR
k : char;
BEGIN
k := A[ pp-1 ];
WHILE ( k <> nl ) OR ( pp = pe ) DO
BEGIN
fp := fp-1; pp := pp-1; A[ fp ] := k; k := A[ pp-1 ]
END;
pe := pp; ms := 0; printed :=false
END; { PROCmoveback }
FUNCTION FNmatched : boolean;
LABEL
1, 2, 5, 6, 7, 10, 15, 16, 99;
VAR
i, l, ind, t1 : integer;
k : char;
fp1 : Buffindex;
BEGIN
pp1 := pp; fp1 := fp; ind := matchlim; t1 := C[ txt ];
IF ( fp <> ms ) OR ( ( code <> 'F' ) AND ( code <> 'U' ) ) THEN GOTO 2;
k := A[ fp ];
1: A[ pp ] := k; pp := pp+1; fp := fp+1;
2: k := A[ fp ]; IF k = chr( t1 ) THEN GOTO 5;
IF k <> nl THEN GOTO 1 ELSE GOTO 10;
5: l := 1;
6: i := C[ txt+l ]; IF i=0 THEN GOTO 7;
IF A[ fp+l ] <> chr( i ) THEN GOTO 1;
l := l+1; GOTO 6;
7: ms := fp; ml := fp+l; FNmatched := true; GOTO 99;
10: ind := ind-1;
IF ind = 0 THEN GOTO 15;
IF fp = bottom THEN GOTO 16;
IF code <> 'U' THEN
BEGIN
A[ pp ] := k; pp := pp+1; pe := pp
END ELSE pp := pp1;
fp := fp+1; PROCmakespace; PROCreadline; pp1 := pp; fp1 :=fp; GOTO 2;
15: pp := pp1; fp :=fp1;
16: FNmatched := false;
99: END; { FNmatched }
PROCEDURE PROCfail;
BEGIN
write( 'Failure: ');
IF code = 'O' THEN BEGIN write( 'E' ); code := '-' END ELSE
IF code = 'W' THEN BEGIN write( 'M' ); code := '-' END;
IF code <> 'Z' THEN
BEGIN
write( code );
IF txt > 0 THEN
BEGIN
write( '''' );
WHILE C[ txt ] <> 0 DO
BEGIN
write( chr( C[ txt ] ) ); txt := txt+1
END;
write( '''' )
END
END;
IF num = inv THEN write( '\' );
writeln
END; { PROCfail }
PROCEDURE PROCinsert;
VAR
i : ComIndex;
BEGIN
PROCmakespace;
IF ( pp-pe > 80 ) OR ( fp = bottom ) THEN ok := false ELSE
BEGIN
i := txt;
WHILE C[ i ] <> 0 DO
BEGIN
A[ pp ] := chr( C[ i ] ); pp := pp+1; i := i+1
END
END
END; { PROCinsert }
BEGIN { PROCedit }
nl := chr( 13 ); lastsymbol := nl; prompted := false;
mon := 0; printed := false;
fp := 0; bottom := 0; ms := 0; ml := 0;
top := 1; lim := amax; clim := 0;
pp := top-1; A[ pp ] := nl; pp := pp+1; pe := pp;
writeln( 'Ecce Editor' );
PROCreadline;
REPEAT
failed := false;
PROCreadcommand; term := sym;
Ci := cmax; last := chr( 0 );
codelim := C[ Ci-1 ];
WHILE ( codelim <> 0 ) AND ( NOT failed ) DO
BEGIN
code := chr( codelim MOD 256 ); matchlim := codelim DIV 256;
txt := C[ Ci-2 ]; num := C[ Ci-3 ]; Ci := Ci-3;
done := false; ok := true;
REPEAT
num := num-1;
CASE code OF { 'A' to 'Z' }
'A' : { dummy };
'B' : BEGIN
A[ pp ] := nl; pp := pp+1; pe :=pp
END;
'C' : BEGIN
WHILE fp <> bottom DO PROCmove;
WHILE top <> pp DO
BEGIN
ch := A[ top ];
IF ch <> nl THEN write( OutFile, ch ) ELSE writeln( OutFile );
top := top+1
END;
GOTO 99
END;
'D' : BEGIN
ok := FNmatched; IF ok THEN fp := ml
END;
'E' : IF A[ fp ] = nl THEN ok := false ELSE fp := fp+1;
'F' : ok := FNmatched;
'G' : BEGIN
IF prompt = '>' THEN prompt := ':' ELSE prompt := ' ';
PROCmakespace; sym := FNreadsymbol;
IF sym = ':' THEN ok := false ELSE
BEGIN
PROClefttab;
A[ pp ] := sym; pp := pp+1; pe := pp;
WHILE sym <> nl DO
BEGIN
sym := FNreadsymbol;
A[ pp ] := sym; pp := pp+1; pe := pp
END
END
END;
'H' : { dummy };
'I' : PROCinsert;
'J' : IF fp = bottom THEN ok := false ELSE
BEGIN
REPEAT
ch := A[ fp ]; A[ pp ] := ch; pp := pp+1; fp := fp+1
UNTIL ch = nl;
PROCreadline; pp := pp-1;
IF ( pp-pe > 80 ) OR ( ( fp = bottom ) AND ( pp <> pe ) ) THEN
BEGIN
pp := pp+1; pe := pp; ok := false
END
END;
'K' : IF fp = bottom THEN ok := false ELSE
BEGIN
pp := pe; REPEAT fp := fp+1 UNTIL A[ fp-1 ] = nl;
PROCreadline
END;
'L' : IF pp = pe THEN ok := false ELSE
BEGIN
fp := fp-1; pp := pp-1; A[ fp ] := A[ pp ]; ms := 0
END;
'M' : IF fp = bottom THEN ok := false ELSE PROCmove;
'N' : { dummy };
'O' : IF pp = pe THEN ok := false ELSE pp := pp-1;
'P' : IF last <> 'P' THEN PROCprintline ELSE
IF fp = bottom THEN ok := false ELSE
BEGIN
PROCmove; PROCprintline
END;
'Q' : { dummy };
'R' : BEGIN
ch := A[ fp ];
IF ch = nl THEN ok := false ELSE
BEGIN
A[ pp ] := ch; pp := pp+1; fp := fp+1
END
END;
'S' : IF fp <> ms THEN ok := false ELSE
BEGIN
fp := ml; PROCinsert
END;
'T' : IF NOT FNmatched THEN ok := false ELSE
BEGIN
fp := ml; PROCinsert
END;
'U' : IF NOT FNmatched THEN ok := false ELSE pp := pp1;
'V' : BEGIN
p := fp; i := txt;
k := C[ i ];
WHILE ( k <> 0 ) AND ok DO
BEGIN
IF A[ p ] <> chr( k ) THEN ok := false ELSE
BEGIN
p := p+1; i := i+1; k := C[ i ]
END
END;
IF ok THEN
BEGIN
ms := fp; ml :=p
END
END;
'W' : BEGIN
PROCmakespace;
IF pe = top THEN ok := false ELSE PROCmoveback
END;
'X' : { dummy };
'Y' : BEGIN
C[ txt ] := num+1; done := true
END;
'Z' : BEGIN
IF num = inv THEN ok := false ELSE
BEGIN
IF ( num <> 0 ) AND ( num <> stop ) THEN
BEGIN
C[ Ci ] := num; Ci := txt
END
END;
done := true
END
END; { CASE }
IF ok AND ( NOT done ) THEN last := code;
UNTIL ( num = 0 ) OR ( num = stop ) OR ( num = inv ) OR done OR NOT ok;
IF ( ( ok <> done ) AND ( num = inv ) ) OR
NOT ( done OR ok OR ( num < 0 ) ) THEN
BEGIN
REPEAT
k := C[ Ci-1 ]; Ci := Ci-3;
IF chr( k ) = 'Y' THEN Ci := C[ Ci+1 ]
UNTIL ( k = 0 ) OR ( ( chr( k ) = 'Z' ) AND ( C[ Ci ] <= 0 ) );
IF k = 0 THEN BEGIN PROCfail; failed := true END
END;
IF NOT failed THEN codelim := C[ Ci-1 ]
END;
IF term = nl THEN
BEGIN
num := 0;
IF ( ( mon = 0 ) AND ( NOT printed ) ) OR
( ( mon > 0 ) AND ( last <> 'P' ) ) THEN PROCprintline
END
UNTIL false; { forever }
99:
END; { PROCedit }
{*****************************************************************************}
{** **}
{** The procedures in this section are likely to be operating system **}
{** dependent. **}
{** **}
{*****************************************************************************}
PROCEDURE PROCcom( s : Lines );
PROCEDURE CmdNoE( CONST s : Lines; CONST len : integer );
fortran;
BEGIN
CmdNoE( s, 80 );
END; { PROCcom }
PROCEDURE OpenFiles;
VAR
Options : string(80);
i : ColIndex;
CmdStr : Lines;
BEGIN
InFileName := parms;
OutFileName :=
'-ecceecce ';
Options :=
' ';
FOR i := FirstCol TO LastCol DO Options[ i ] := InFileName[ i ];
reset( InFile, 'File=' || Options );
FOR i := FirstCol TO LastCol DO Options[ i ] := OutFileName[ i ];
rewrite( OutFile, 'File=' || Options || ' Nocc' );
reset( input, 'File=*MSOURCE* Interactive' );
rewrite( output, 'File=*MSINK*' )
END; { OpenFiles }
PROCEDURE CloseFiles( NormalEnd : boolean );
VAR
CmdStr : Lines;
i : ColIndex;
BEGIN
close( InFile ); close( OutFile );
IF NormalEnd THEN
BEGIN
Cmdstr :=
'EMPTY 12345678901234567890 OK ';
FOR i := FirstCol TO ParsLength DO Cmdstr[ i + 6 ] := InFileName[ i ];
PROCCom( Cmdstr );
Cmdstr :=
'COPY 12345678901234567890 TO 12345678901234567890 ';
FOR i := FirstCol TO ParsLength DO Cmdstr[ i + 5 ] := OutFileName[ i ];
FOR i := FirstCol TO ParsLength DO Cmdstr[ i + 29 ] := InFileName[ i ];
PROCcom( Cmdstr );
Cmdstr :=
'DESTROY 12345678901234567890 OK ';
FOR i := FirstCol TO ParsLength DO Cmdstr[ i + 8 ] := OutFileName[ i ];
PROCCom( Cmdstr );
END;
END; { CloseFiles }
BEGIN { main program }
OpenFiles;
PROCedit;
CloseFiles( true );
999:
END. { main program }