Google
 

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.