Trailing-Edge
-
PDP-10 Archives
-
decuslib10-12
-
43,50552/forvio.pas
There are no other files named forvio.pas in the archive.
{$m-}
program forvio {>>>> I/O for FORVER <<<<};
include 'sym6c.def';
include 'filstk.def';
include 'fnames.def';
const
compile_date= '8-Oct-84'; { date this FORVER was compiled }
help_file = 'HLP:FORVER.HLP'; { name of FORVER help file }
linespp = 66; { 66 lines per line-printer page }
version = '2.6'; {$v:200000006b - FORVER version }
ch_bol = 012b; { BOL is Line Feed }
ch_eol = 015b; { EOL is Carriage return }
ch_eof = 200b; { EOF pseudo-char (for LEXI) }
ff = 014b; { Form Feed }
type
charset = set of char;
asciz = packed array [1..500] of char;
char3 = packed array [1..3] of char;
char6 = packed array [1..6] of char;
var
line : asciz;
llen : integer;
pageno,
lineno,
ppageno,
plineno : integer;
today : packed array [1..9] of char;
subtitle,
header : asciz;
sublength,
headerlength: integer;
default_for,
default_vtr,
default_lsv,
file_for,
file_vtr,
file_lsv : filename;
ttyin : text;
listing_on : boolean;
crbefore : boolean;
echo : boolean;
lstchar : char;
pc : integer;
line_typed,
page_typed : integer;
bc,
ec : char;
foptions : charset;
i : integer;
procedure upcase (var f : text; map : boolean); extern;
procedure arrow (var f : text; c : char); extern;
procedure rclose (var f : file); extern;
procedure analys (var f : file); extern;
procedure quit; extern;
{*** listing (output) procedures ***}
(*
procedure eject;
begin
do_eject := true;
end;
*)
procedure eject;
begin
page (output);
ppageno := ppageno + 1; { next page }
plineno := 3; { first line after header }
write ('LNEC: FORVER version ',version,' ':5,file_for.spec:25,
today, ' ':5, 'Page ');
if pageno = 0
then writeln (ppageno:0)
else writeln (pageno:0,'-',ppageno:0);
if sublength <> 0 then begin
writeln (subtitle:sublength);
plineno := 4; { in case of subtitle }
end;
writeln;
if headerlength <> 0 then begin
writeln (header:headerlength);
writeln;
plineno := plineno + 2; { in case of headers }
end;
end;
procedure nextline;
begin
writeln;
plineno := plineno + 1; { next listing line }
if plineno>linespp then eject; { reached end of page? }
end;
procedure lston (forced : boolean);
begin
listing_on := ('L' in foptions) or forced;
end;
procedure lstoff;
begin
listing_on := false;
end;
procedure echon;
begin
echo := true;
end;
procedure echoff;
begin
echo := false;
end;
procedure lstnl;
begin
if listing_on then nextline;
end;
procedure lstxch (c : char);
begin
lstchar := c;
end;
procedure lstsubttl (s : asciz; l : integer);
begin
for i := 1 to l do subtitle[i] := s[i];
sublength := l;
end;
procedure lstheader (s : asciz; l : integer);
begin
for i := 1 to l do header[i] := s[i];
headerlength := l;
end;
function fvpage : integer; begin fvpage := pageno; end;
function fvline : integer; begin fvline := lineno; end;
procedure cron (on : boolean); begin crbefore := on; end;
procedure initio (var vtr_file : text; var options : charset;
var st : asciz; stl : integer);
begin
writeln (tty, 'LNEC: FORVER version ', version, ' (compiled on ',
compile_date, ').');
writeln (tty);
reset (ttyin, 'TTY:', '/E/I/U');
blankspec (default_for); default_for.ext := 'FOR';
blankspec (default_vtr); default_vtr.ext := 'VTR';
blankspec (default_lsv); default_lsv.ext := 'LSV';
loop
write (tty, 'FVR>');
readln (ttyin); read (ttyin, file_for.spec:i:[' ','/',' ']);
while ttyin^ in [' ',' '] do get (ttyin);
options := ['V'];
while ttyin^ = '/' do begin { scan all the options }
get (ttyin); { skip over the '/' }
if ttyin^ = 'F' then options := ['V','A','L','U','D','I']
else if ttyin^ in ['V','A','L','U','D','I','H']
then if ttyin^ in options { act as a toggle }
then options := options - [ttyin^]
else options := options + [ttyin^]
else writeln (tty, '% Unknown switch "/',ttyin^,'". Ignored.');
while ttyin^ in ['A'..'Z', '0'..'9'] do get (ttyin);
end;
exit if (i <> 0) and not ('H' in options);
if 'H' in options
then begin
reset (input, help_file);
if eof
then writeln (tty, '%FVRNHF Can''t find file "',help_file,'".')
else begin
writeln (tty, '[FVRHLP Contents of file "',help_file,'"]');
writeln (tty);
while not eof do begin
if eoln then begin
readln;
writeln (tty);
end
else begin
ttyoutput^ := input^;
put (ttyoutput);
get (input);
end;
end;
end;
close (input);
end
else writeln (tty, '[FVRTHN Type /HELP if you need it]');
writeln (tty);
end { loop };
anspec (file_for); defspec (file_for, default_for); genspec (file_for);
reset (input, file_for.spec, true);
if eof (input) then begin
analys (input);
quit;
end;
file_lsv := file_for; forspec (file_lsv, default_lsv); genspec (file_lsv);
rewrite (output, file_lsv.spec);
if not eof (output) then begin
analys (output);
quit;
end;
file_vtr := file_for; forspec (file_vtr, default_vtr); genspec (file_vtr);
if 'V' in options
then rewrite (vtr_file, file_vtr.spec)
else rewrite (vtr_file, 'NUL:');
if not eof (vtr_file) then begin
analys (vtr_file);
quit;
end;
listing_on := 'L' in options;
lineno := 0; { source line }
pageno := 0; { source page }
plineno := 0; { listing line }
ppageno := 0; { listing page }
today := date;
for i := 1 to stl do subtitle[i] := st[i];
sublength := stl;
headerlength := 0; { no headers }
eject; { title of first page }
spush (file_for.spec);
lstchar := ' ';
line[1] := chr(0); { start with empty line buffer }
llen := 1;
pc := 1;
foptions := options;
echo := true;
end;
function lexchar : integer;
begin
if line [pc] = chr(0) { passed eol? }
then begin
if sbot and seof
then lexchar := ch_eof
else begin
repeat /* skip comments right here */
if seof then begin
listing_on := 'L' in foptions;
spop;
lstchar := ' ';
lstnl;
end;
sgetline (line, llen);
lineno := lineno+1;
if listing_on then begin
write (lineno:5,':',lstchar,' ',line:llen);
nextline;
end;
until (sbot and seof) or not (line[1] in ['C','c','D','d','*','!','/']);
if sbot and seof and (line[1] in ['C','c','D','d','*','!','/'])
then begin
lexchar := ch_eof;
pc := 1;
line[1] := chr(0); /* next will be eof */
end
else begin
lexchar := ch_bol; /* start w/ <LF> */
pc := 1;
line [llen+1] := chr (ch_eol); /* end with <CR> */
line [llen+2] := chr (0);
end;
end;
end
else begin
lexchar := ord (line [pc]);
pc := pc + 1;
end;
end;
function lexeof : boolean;
begin
lexeof := (line[pc] = chr(0)) and sbot and seof;
end;
procedure wrlabeled (var f : text;
number : integer;
message : asciz;
length : integer);
begin
if number = 0
then write (f, 'no')
else write (f, number:0);
write (f, message:length);
if number <> 1 then write (f, 's');
end;
procedure fverr ( level : integer;
mnemonic : char3;
message : asciz;
length : integer);
begin
case level of
0: begin
bc := '[';
ec := ']';
end;
1: begin
bc := '%';
ec := '.';
end;
2: begin
bc := '?';
ec := '.';
end;
3: begin
bc := '*';
ec := '.';
end;
end;
if listing_on then
write ('(',level:0,') ',mnemonic,' ',message:length);
if ((pageno <> page_typed) or (lineno <> line_typed)) and echo then begin
if crbefore then writeln (tty);
crbefore := false;
page_typed := pageno;
writeln (tty, lineno:5, ': ', line:llen);
end;
write (tty, bc, 'FVR', mnemonic, ' ',message:length);
line_typed := lineno;
end;
procedure fvstring ( message : asciz;
length : integer);
begin
if listing_on then
write (message:length);
write (tty, message:length);
end;
procedure fvxstring ( message : asciz;
rlength : integer;
length : integer);
begin
fvstring (message, length);
end;
procedure fvinteger ( number : integer;
base : integer;
width : integer);
begin
case base of
8: begin
if listing_on then
write (number:width:o);
write (tty, number:width:o);
end;
16: begin
if listing_on then
write (number:width:h);
write (tty, number:width:h);
end;
others: begin
if listing_on then
write (number:width);
write (tty, number:width);
end;
end;
end;
procedure fvchar (c : char);
begin
if listing_on then arrow (output, c);
arrow (ttyoutput, c);
end;
procedure fvname ( name : name_type);
var
name7 : char_name;
begin
sf6name (name, name7);
i := 1;
while name7[i] <> ' ' do begin
fvchar (name7[i]);
i := i+1;
end;
end;
procedure fvnl;
begin
if ec <> chr(0) then fvchar (ec);
if listing_on then nextline;
writeln (tty);
ec := chr(0);
end.