⟦520ad02af⟧

TextFileVerbose

program outcode4(output, pass4file='pass4code');

(*

program call:
                            1               1        1          1
printpass4  (from.<integer>)0 (to.<integer>)0 (names)0 (prelude)0

from.<integer>   print from line <integer>
to.<integer>     print to line <integer>
names            write pass 4 code values
prelude          code from prelude is printed

default: from.0  to.1000000;  and no names and not prelude

*)
const

non=0;   int=1;   name=2;   ty=3;   list=4;
funcno = 5;
newline = 4;   xprocess = 5;   xmodule = 1;

eom=2;
max_token=137;

type

param_type = non..funcno;

token_type = record
code_name: alfa;
p: array [1..6] of param_type;
end;

var

token: array [1..max_token] of token_type;

no,pn,from_line,to_line,line,i_param: integer;

first,ok,prelude,names_out: boolean;

pass4file: file of integer;

value

token = (
('module',         (2,1,<3..6>*0)),
('eom',            (<1..6>*0)),
('option',         (1,1,1,<4..6>*0)),
('newline',        (1,<2..6>*0)),
('process',        (1,2,1,1,0,0)),
('extprocess',     (1,2,1,<4..6>*0)),
('block',          (1,<2..6>*0)),
('length',         (1,1,<3..6>*0)),
('endblock',       (1,1,<3..6>*0)),
('begincode',      (1,<2..6>*0)),
('codeline',       (4,<2..6>*0)),
('endcode',        (<1..6>*0)),
('subdef',         (1,<2..6>*0)),
('array1temp',     (1,1,1,1,1,1)),
('array2temp',     (1,1,1,1,1,1)),
('array3temp',     (1,1,1,1,1,1)),
('recordtemp',     (1,1,1,<4..6>*0)),
('fieldsize',      (1,1,1,<4..6>*0)),
('dfieldsize',     (1,1,1,1,<5..6>*0)),
('incfield',       (<1..6>*0)),
('endtemplate',    (1,<2..6>*0)),
('enddecl',        (<1..6>*0)),
('allocvar',       (1,1,1,<4..6>*0)),
('initialize',     (<1..6>*0)),
('strucinit',      (1,1,<3..6>*0)),
('simpleinit',     (1,1,<3..6>*0)),
('setinit',        (1,1,1,<4..6>*0)),
('exception',      (1,1,<3..6>*0)),
('extexception',   (1,<2..6>*0)),
('sysinit',        (1,<2..6>*0)),
('sysdyninit',     (1,<2..6>*0)),
('fieldinit',      (1,<2..6>*0)),
('dfieldinit',     (1,1,<3..6>*0)),
('endfinit',       (<1..6>*0)),
('arrayinit',      (1,1,1,1,<5..6>*0)),
('arraydinit',     (1,1,1,<4..6>*0)),
('poolinit',       (1,1,<3..6>*0)),
('varinit',        (1,<2..6>*0)),
('export',         (2,1,1,<4..6>*0)),
('proc',           (1,2,<3..6>*0)),
('extproc',        (1,2,1,<4..6>*0)),
('func',           (1,2,<3..6>*0)),
('extfunc',        (1,2,1,<4..6>*0)),
('paramtype',      (1,1,<3..6>*0)),
('deflix',         (1,<2..6>*0)),
('proccall',       (1,1,1,<4..6>*0)),
('endpcall',       (<1..6>*0)),
('extproccall',    (1,1,<3..6>*0)),
('processparam',   (<1..6>*0)),
('endprocessparam',(<1..6>*0)),
('varpointer',     (1,1,1,<4..6>*0)),
('tempointer',     (1,<2..6>*0)),
('arglistsize',    (1,<2..6>*0)),
('varparam',       (<1..6>*0)),
('valueparam',     (3,<2..6>*0)),
('return',         (1,<2..6>*0)),
('assignstat',     (<1..6>*0)),
('left',           (3,<2..6>*0)),
('assign',         (<1..6>*0)),
('casestat',       (<1..6>*0)),
('case',           (<1..6>*0)),
('endcaselist',    (<1..6>*0)),
('endcasestat',    (<1..6>*0)),
('endcase',        (<1..6>*0)),
('caserange',      (1,1,<3..6>*0)),
('caselabel',      (1,<2..6>*0)),
('otherwise',      (<1..6>*0)),
('forstat',        (<1..6>*0)),
('leftfor',        (1,1,3,<4..6>*0)),
('forstore',       (<1..6>*0)),
('do',             (1,<2..6>*0)),
('endfor',         (<1..6>*0)),
('goto',           (1,<2..6>*0)),
('ifstat',         (<1..6>*0)),
('ifexpr',         (<1..6>*0)),
('else',           (<1..6>*0)),
('if',             (<1..6>*0)),
('repeat',         (<1..6>*0)),
('until',          (<1..6>*0)),
('endrepeat',      (<1..6>*0)),
('while',          (<1..6>*0)),
('whileexpr',      (<1..6>*0)),
('endwhile',       (<1..6>*0)),
('withstat',       (<1..6>*0)),
('withvar',        (1,<2..6>*0)),
('endwith',        (<1..6>*0)),
('lockstat',       (<1..6>*0)),
('lockvar',        (1,1,0,0,0,0)),
('dlockvar',       (1,1,1,<4..6>*0)),
('endlock',        (<1..6>*0)),
('channel',        (<1..6>*0)),
('chanvar',        (<1..6>*0)),
('endchannel',     (<1..6>*0)),
('exchstat',       (<1..6>*0)),
('exchange',       (<1..6>*0)),
('not',            (1,<2..6>*0)),
('neg',            (<1..6>*0)),
('compare',        (1,<2..6>*0)),
('compstruc',      (1,1,<3..6>*0)),
('compdyn',        (1,1,1,<4..6>*0)),
('div',            (<1..6>*0)),
('mul',            (1,<2..6>*0)),
('mod',            (<1..6>*0)),
('or',             (<1..6>*0)),
('xor',            (<1..6>*0)),
('add',            (1,<2..6>*0)),
('sub',            (1,<2..6>*0)),
('and',            (<1..6>*0)),
('rangetest',      (1,<2..6>*0)),
('dynrtest',       (1,1,<3..6>*0)),
('const',          (1,<2..6>*0)),
('lconst',         (1,1,<3..6>*0)),
('setconst',       (1,1,<3..6>*0)),
('set',            (<1..6>*0)),
('include',        (<1..6>*0)),
('setexpr',        (<1..6>*0)),
('includeint',     (<1..6>*0)),
('endset',         (<1..6>*0)),
('initconst',      (4,<2..6>*0)),
('indvar',         (3,<2..6>*0)),
('addr',           (1,1,<3..6>*0)),
('caddr',          (1,<2..6>*0)),
('indaddr',        (<1..6>*0)),
('packedarr',      (<1..6>*0)),
('field',          (1,<2..6>*0)),
('dfield',         (1,1,<3..6>*0)),
('indexexpr',      (<1..6>*0)),
('cindex',         (1,<2..6>*0)),
('index',          (1,1,<3..6>*0)),
('stdfunccall',    (5,<2..6>*0)),
('fcall',          (<1..6>*0)),
('endfunccall',    (1,<2..6>*0)),
('funccall',       (1,1,1,<4..6>*0)),
('extfunccall',    (1,1,<3..6>*0)),
('error',          (1,1,<3..6>*0)),
('errorno',        (1,<2..6>*0)),
('errortext',      (1,<2..6>*0))
);

procedure get_parameters;
const equal = 6;   space = 4;   name = 10;
      dot = 8;     int = 4;     power12 = 4096;

var i,separator,param_no: integer;
    id: alfa;

procedure param_error;
begin
write('*** printpass4, param error ');
repeat
if separator div power12 = space then
write(' ') else write('.');
if separator mod power12 = name then
write(id) else write(i:1);
param_no:=param_no+1;
separator:=system(param_no,i,id);
if separator=0 then separator:=space*power12;
until separator div power12 = space;
ok:=false;  writeln;
param_no:=param_no-1;
end;

function get_integer_value: integer;
var p: integer;
begin
p:=system(param_no+1,i,id);
if p = dot*power12 + int then
begin
get_integer_value:=i;
param_no:=param_no+1;
end
else
begin
param_error;
get_integer_param:=0;
end;
end;

begin
(* ignore left side *)
separator:=system(0,i,id);
if separator div power12 = equal then
param_no:=2 else param_no:=1;
separator:=system(param_no,i,id);
while separator>0 do begin
if separator <> space*power12 + name then param_error
else begin
if id='prelude' then prelude:=true
else
if id='names' then names_out:=true
else
if id='from' then from_line:=get_integer_value
else
if id='to' then to_line:=get_integer_value
else
param_error;
end;
param_no:=param_no+1;
separator:=system(param_no,i,id);
end;
end;


procedure initialize;
var i: integer;
begin
from_line:=0;   to_line:=1000000;   line:=1;
prelude:=false; names_out:=false;   ok:=true;
get_parameters;
if ok then begin
begin
reset(pass4file);
first:=true;
if names_out then
begin
writeln('Pass 4 code name values');
writeln;
for i:=1 to max_token do
writeln(i:4,' = ',token[i].code_name);
page(output);
end;
end;
end;
end;

procedure out_name(id: alfa);
var n: integer; ch: char;
begin
n:=1;
repeat
ch:=id[n];
if ch<>' ' then write(ch)
else n:=alfalength;
n:=n+1;
until n>alfalength;
end;

procedure name_parameter;
const shift8 = 256;
var i,p: integer; id: alfa;
begin
if first then write('(') else write(', ');
first:=false;
p:=1;
repeat
read(pass4file,i);
id[p]:=chr(i);
p:=p+1;
until p>alfalength;
out_name(id);
end;

procedure integer_parameter;
begin
if first then write('(') else write(', ');
first:=false;
read(pass4file,i_param);
write(i_param:1);
end;

procedure type_v_parameter;
var n,st,number,size: integer;
begin
if first then write('(') else write(', ');
first:=false;
read(pass4file,n);
write(n:1);
if (n=3) or (n=7) then begin
read(pass4file,st,number);
write('(',st:1,', ',number:1,')');
end else
if (n=5) or (n=6) then begin
read(pass4file,size);
write('(',size:1,')');
end;
end;

procedure integer_list_param;
const max_pr_line = 4;
var l,no,n,w: integer;
begin
if first then write('(') else write(', ');
first:=false;
read(pass4file,l);
writeln(l:4);
no:=1;
for n:=1 to l do begin
read(pass4file,w);
write(w);
no:=no+1;
if no>max_pr_line then begin
writeln; no:=1;
end;
end;
end;

procedure std_function_number;
var n,m: integer;
begin
if first then write('(') else write(', ');
first:=false;
read(pass4file,n);
write(n:1);
if (n=2) or (n=3) then begin
read(pass4file,m);
write(', ',m:1);
end
end;

procedure skip_token;
var pn,i,x,y,n: integer;
begin
with token[no] do
for pn:=1 to 6 do
case p[pn] of
non: ; (*no parameter*)
name: for i:=1 to 12 do read(pass4file,x);
int: read(pass4file,i_param);
ty: begin
read(pass4file,n);
case n of
3: read(pass4file,x,y);
5,6: read(pass4file,x);
end;
end;
list: begin
read(pass4file,n);
for i:=1 to n do read(pass4file,x);
end;
funcno: begin
read(pass4file,n);
if (n=2) or (n=3) then read(pass4file,x);
end;
end;
end;


begin
initialize;
if ok then begin
repeat
read(pass4file,no);
if (no=xprocess) or (no=xmodule) then prelude:=true;
if prelude then begin
if (line<from_line) or (line>=to_line) then
skip_token
else
with token[no] do begin
out_name(code_name);
for pn:=1 to 6 do
case p[pn] of
non: (*no parameter*) ;
name: name_parameter;
int:  integer_parameter;
ty:   type_v_parameter;
list: integer_list_param;
funcno: std_function_number;
end;
if first then writeln else
begin
writeln(')'); first:=true;
end;
end;
end else skip_token;
if no=newline then line:=i_param;
until (no=eom) or eof(pass4file);
close(pass4file);
end; (* ok *)
end.

«eof»
DataMuseum.dk

RC3500

⟦520ad02af⟧ TextFileVerbose

Derivation

TextFileVerbose
