⟦01e5e817d⟧

TextFile

job jaba 9 600 time 5 0 
mode list.yes
(tprintpif = set 1
tprintpif = copy message.no 25.1
ttt = testgen tprintpif pascalcodes
head cpu
printpif = pascal ttt codesize . 3500 list.no
head cpu
lookup pascalpif
finis
)

(* program printpascal  80.11.24  *)

program tprintpascal(output, testin='pascalpif');

type
$
codeindex = 0 .. $

var

textcodes : array Æ codeindex Å of alfa;
convcodes : array Æ codeindex Å of codes;

testin : file of integer; (* = pascalpif  *)
current_code, code1, code2 : codes;
start_line, current_line, ord_code,
step, number, type_number, name_number, list_number, ndepth : integer;
binout, environment : boolean; (* skip standard environment, unless option envir *)

value
textcodes = ( $

procedure initialize;
var
actcode : codes;
sep, fp_paramno, int : integer;
fp_name : alfa;

begin
reset( testin );

environment := false;
binout := false; (* default: textoutput *)
current_line := 1;
start_line := 0;
textcodes Æ ord( eoff ) Å := 'of';
textcodes Æ ord( efordntoend ) Å := 'fordowntoend';
textcodes Æ ord( evaluenaend ) Å  := 'valuenameend';

for actcode := enone to eoption do
begin
convcodes Æ ord ( actcode ) Å := actcode;
end;

current_code := convcodes Æ - testin ^ Å ; get( testin );

fp_paramno := 1; (* must be first option, no check !! *)
sep := system( fp_paramno, int, fp_name );

while sep > 0 do
begin
if sep <> (4 * 4096 + 10) (* name *) then readln(output); (* force exception *)
if fp_name = 'envir' then environment := true
else 
if fp_name = 'binary' then binout := true
else
if fp_name = 'from' then
begin
fp_paramno := fp_paramno + 1;
sep := system( fp_paramno, start_line, fp_name );
if sep mod 4096 <> 4 then readln(output); (* error *)
end
else
if fp_name = 'names' then
begin
for actcode := enone to eoption do
writeln( ord( actcode ) : 3, ': ', textcodes Æ ord(  actcode ) Å );
page(output);
end;

fp_paramno := fp_paramno + 1;
sep := system ( fp_paramno , int, fp_name );

end; (* while sep > 0 *)

end;


procedure copy_alfa;
var
step, ord_ch : integer;

begin
for step := 1 to alfalength do
begin
read ( testin, ord_ch );
write(chr( ord_ch ) );
end;

end;


procedure nextline;
begin
while (testin ^ >= 0) and not eof(testin) do get(testin); (* skip *)
if not eof(testin) then
begin
current_code := convcodesÆ - testin ^ Å; get( testin );
end
else
current_code := enone;
end;


procedure skip_to_start_line;
begin
while current_line < start_line do
begin
nextline;
if current_code = elinenumber then read( testin, current_line);
end;
end; (* skip to start line *)


procedure emitoption;
var
ch, option : char;
opt_val, ord_ch : integer;

begin
write('option ( ' );
read(testin, ord_ch );

option := chr(ord_ch);

case option of
'f' : (* file name *)
begin
write('filename:');
get(testin); get(testin); (* skip two spaces *)
copy_alfa;
end;

'p': (* option survey *)
begin
write('survey . ');
get(testin); get(testin); (* skip two spaces *)
copy_alfa;
end; (* option p *)

's', 'h': (* code- and heap-size *)
begin
if option = 's' then
write('codesize . ')
else
write('heapsize . ');
read(testin, opt_val );
write(opt_val : 1);
end; (* option s and h *)

'l', 'r', 't', 'c' : begin
write(option);
read(testin, ord_ch);
write(chr(ord_ch));
end;(* option l, r, t, c *)

end (* case *)
otherwise
begin
writeln(' error in option, value is: ', option );
readln(output);(* force exception *)
end;
writeln(' )' );
end;

procedure emitname;

begin
read(testin, number);
write(number, " name '");
copy_alfa;
read(testin, ord_code);
write("' ", textcodes Æ ord_code Å );
code1 := convcodes Æ ord_code Å ;

case code1 of
eprogram, efproc : ; 

econst, etype,evar, efield, etagfield,
evalparam, evarparam, effunc, eproc:
begin
read(testin, number);
write( number );
end;

efunc: begin
read(testin, list_number, type_number);
write(list_number, type_number);
end;

emodule:
begin
write(textcodes Æ testin ^ Å : 13 ); get(testin);
end;

efile: begin
read(testin, ord_code);
write( textcodes Æ ord_code Å : 13);
read(testin, type_number);
write(type_number);
if testin ^ > 0 then
begin
write(" '");
while testin ^ > 0 do
begin
write( chr( testin ^ ) ); get( testin );
end;
write("'");
end; 
end; (* efile *)
end; (* case *)

end;


procedure emitconst;

begin
read(testin, number, type_number);
write( number, ' const ', type_number : 1, " '");
while testin ^ > 0 do
begin
write( chr( testin ^ )); get( testin );
end;
write("'");

end;


procedure emittype;
var
step : integer;
begin
read(testin, number, ord_code);
write(number, ' type ', textcodes Æ ord_code Å : 8 );
code1 := convcodes Æ ord_code Å ;

case code1 of

escalar, eboolean, eascii, estring, epointer :
begin
write(testin ^ ); get(testin);
end;

einteger, ereal: ;

eset: begin
write(textcodes Æ testin ^ Å : 13);
get(testin);
write(testin ^ ); get(testin);
end;

esubrange:
begin
for step := 1 to 3 do
begin
write(testin ^ ); get(testin);
end;
end;

earray, erecord: begin
write( textcodes Æ testin ^ Å : 13 );
get(testin);
for step := 1 to 2 do
begin
write( testin ^ ); get( testin );
end;
end;

efile : begin
for step := 1 to 2 do
begin
read(testin, ord_code);
write(textcodes Æ ord_code Å : 13 );
end;
write(testin ^ );
get(testin);
if convcodes Æ ord_code Å = erandom then
begin
write( testin ^ ); get( testin );
end;
end; (* efile *)

end; (* case *)

end; (* emit type *)


begin  (* main program *)
initialize;

if binout then
begin
skip_to_start_line;
while not eof(testin) do
begin
write(ord(current_code),' ');
while testin^ >= 0 do
begin
write( testin^ : 1, ' '); get( testin );
end;
writeln;
nextline;
end;
end
else
begin (* text mode *)
while current_code = eoption do 
begin
emitoption;
nextline;
end;

if not environment then
begin
while current_code <> eendmodule do nextline;
nextline
end; (* skip environment *)

skip_to_start_line;

while not eof(testin) do
begin
case current_code of
ename: emitname;

econst : emitconst;

elabel : begin
read(testin, number);
write( number, ' label ');
for step := 1 to 4 do
begin
write(chr(testin ^ )); get(testin);
end;
end; (* label *)

etype : emittype;

eforward,
ecaselist : begin
read(testin, number);
write(number, ' ', textcodes Æ ord ( current_code ) Å );
end; 

ebackref,
evarlist : begin
read(testin, number, name_number, list_number);
write(number, ' ', textcodes Æ ord( current_code ) Å, name_number, list_number );
end;


enamelist: begin
read(testin, number, ord_code);
write(number, ' namelist ', textcodes Æ ord_code Å );
if ord_code = ord( efix ) then
begin
write(' ', textcodes Æ testin ^ Å ); get( testin );
end;
end;


etagelement: begin
read(testin, number, name_number, type_number, list_number);
write(number, ' tagelement', name_number, type_number, list_number );
end;


erecordlabel: begin
read(testin, number, name_number );
write(number, ' recordlabel', name_number );
end;


emodule:begin
write('module ' : 20);
copy_alfa;
end;


eendnamelist: begin
read(testin, ord_code, list_number);
write( 'endnamelist ':20, textcodes Æ ord_code Å :13, list_number:3 );
end;


enamecode, efunction, econstcode, eindex, eload,
eset, esetrange, emult, eadd, edif, erealdiv, esetinter,
esetunion, esetdif, eminus, eeq, ene, ele, elt, ege, egt, ein,
eif, ethen, eelse, eendif, elabeldef, egoto, ecase, eoff, eotherwise,
egotoendcase, eendcase, ewhile, ewhiledo, eendwhile, ewith, ewithdo,
ewithvar, ewithname, eendwith,
erepeat, euntil, eendrepeat,
evaluename, efieldbegin,
eblockbegin, eblockend :
begin
read(testin, number);
write( textcodes Æ ord ( current_code ) Å : 20, number);
end;


efield, ereference, estore,
eleftconv, erightconv, ecaselabel,
ecallproc, ecallfunc, eendcall, eformat,
efor, eforinit, efortodo, efordowntodo, efortoend, efordntoend,
eelementbegin:
begin
read(testin, number, name_number);
write(textcodes Æ ord( current_code ) Å : 20, number, name_number);
end;


estorefunc, eparam, estorevalue:
begin
write( textcodes Æ ord ( current_code ) Å : 20 );
for step := 1 to 3 do
begin
write( testin ^ ); get( testin );
end;
end;


eoption : emitoption;


elinenumber: begin
write('linenumber(', testin ^, ' )'); get ( testin );
end;

end (* case *)

otherwise
write(textcodes Æ ord ( current_code ) Å : 20 );

writeln;
nextline;


end; (* while not eof *)

end; (* not binout *)


end.
 
$ $ $






▶EOF◀
DataMuseum.dk

RC4000/8000/9000

⟦01e5e817d⟧ TextFile

Derivation

TextFile
