⟦074162b01⟧

TextFileVerbose

program pass5prog (in_pass5, out_pass5, ext_pass5, output);

const

default_lambda_version = 3;  (* determines micro-program version *)



var

pass5_ok :  boolean;
in_pass5 : file of integer;
out_pass5 : file of char;
ext_pass5 : file of integer;
lambda_version : integer;


value

pass5_ok = true;
lambda_version = default_lambda_version;



procedure  pass5( var pass5_ok : boolean );

label

   1 ;                   (*  exit on fatal error  *)

const

(*   const.   global for pass5:       *)

ownpassno = 5;  (* pass number of this pass *)
versionpass4 = 300;
versionpass5 = 215; (* 81.05.06 *)

const_niv_0 = 0;
const_size_nn = 16;

(*  repr. of standard values in pascal80 :  *)

const_nil_msp = 16384;    (*  01xxxxxxxxxxxxxx  *)
value_false = 0;
value_true = 1;
(*  masks for ps in reg. set *  *)
ps_mask_resume = 16;


(*  fields in the base_word of a pointer :  *)


c_field_lock = 0;  (*  the field [ 0 .. 0 ] , i.e.  16 * 0 + 0  *)
c_field_nl = 1;    (*  the field [ 0 .. 1 ] , i.e.  16 * 0 + 1  *)
c_field_nil = 17;  (*  the field [ 1 .. 1 ] , i.e.  16 * 1 + 1  *)

(* definition of pass6-tokens *)
zbegin = 'b';
zendlist = '.'; (* end of declaration-list *)
zconst = 'c';
zend   = 'e';
zline  = 'l';
zoption= 'o';
zname  = 'z';
dollar_a = '1'; (* => $a *)
dollar_b = '2'; (* => $b *)
dollar_i = '3'; (* => $i *)

(* definition of identifiers for pass6 *)
c_name = 'c';  (* long constants, dope vectors *)
e_name = 'e';  (* external routines *)
l_name = 'l';  (* labels *)
r_name = 'r';  (* internal routine entries *)
x_name = 'x';  (* case labels *)

(* definition of used identifiers *)
id_entry = 'entry';
id_exit  = 'exit';
id_exception = 'exception';
id_param = 'param';
id_procinf = 'procinf';
id_name  = 'name';
id_except= 'exception';
id_appeval = 'appeval';
id_appstat = 'appstat';
id_default_appetite = 'defapp' ;
id_work    = 'work';
id_linetab = 'linetab';
id_continue= 'continue';
id_rep    = 'rep';
id_endrep   = 'endrep';
(* stdcall *)
id_sucpred = 'sucpred';
(* while *)
id_whrep = 'whrep';
id_whexit= 'whexit';
(* lock *)
id_cont  = 'cont';
id_exc   = 'exc';
(* if *)
id_ifelse = 'ifelse';
id_ifexit = 'ifexit';
(* repeat *)
id_rprep = 'rprep';
(* for *)
id_forrep   = 'forrep';
id_forstore = 'forstore';
id_forexit  = 'forexit';
(* case *)
id_casetab = 'casetab';
id_otherwise= 'otherwise';
id_caseexit= 'caseexit';
(* array-init *)
id_arrayrep = 'arrayrep';
id_index_store = 'ixstore';
(* names from lambda-environment *)
id_level       = 'level';
id_exmask      = 'exmask';
id_expoint     = 'expoint';
id_exic        = 'exic';
id_mkind       = 'mkind';
id_msize       = 'msize';
id_mstart      = 'mstart';
id_semchain    = 'semchain';
id_refchain    = 'refchain';
id_shadowchain = 'shadowchain';
id_osem        = 'osem';
id_oref        = 'oref';
id_oshadow     = 'oshadow';
id_cpexcfirst  = 'cpexcfirst';
id_exappetite  = 'exappetite';
id_exitappetite= 'exitappetite';
id_maxstack    = 'maxstack';
id_bonappetite = 'bonappetite';
id_plinetab    = 'plinetab';
id_rlinetab    = 'rlinetab';
(* misc *)
id_hardset     = 'hardset';

descr_max_param = 30;

c_size_opcode = 5;
c_size_identifier = 12;
c_size_string = 60;
c_size_option_list = 10;


(*  exception no.  , relative to the symbol  cpexcfirst ( see: lambdaenv ) :  *)
c_exc_case = 0;
c_exc_succ = 1;
c_exc_pred = 2;
c_exc_exch = 3;
c_exc_lock = 4;
c_exc_ref = 5;

c_exc_max = 47;

(* constants in pass 4 code *)

(* value of type_v in pass4 code *)

byte_typ = 1;   addr_typ = 5;
word_typ = 2;   set_typ  = 6;
field_typ= 3;
double_typ = 4;

(* values of type_o in pass 4 code *)

bool_typ = 1;      int_typ = 2;     real_typ = 3;     setof_typ = 4;
pointer_typ = 5;   sem_typ = 6;     ref_typ = 7;      shadow_typ = 8;
scalar_typ = 9;

(* compare function number in pass 4 code *)

xeq = 2;        xne = 3;         xlt = 4;
xgt = 5;        xle = 6;         xge = 7;
xeq_set = 8;    xne_set = 9;     xle_set = 10;
xge_set = 11;   xin = 12;        xeq_struc = 13;
xne_struc = 14;

(* std function number in pass 4 code *)

xord = 1;    xsucc = 2;     xpred = 3;     xchr = 4;

(* mode for for statement *)

xup = 1;     xdown = 2;
(* end pass 4 code constants *)


(*   offsets in the Process Descriptor :      *)

pd_count    =  0;
pd_param    =  2;
pd_linked   =  6;
pd_procinf  =  8;
pd_name     = 12;



(*   const. local to modules:       *)

ext_cat_name = 'platonlib';

ext_tab_max = 150;
max_param_table = 500;
ext_max_routine = 150; (* max no of words (of 2 chars each) pr inline routine *)
ext_max_charbuf = 5000; (* number of words in charbuf *)


(*   type definitions global for pass5:     *)

type

option_list = record
  no_of_options : integer;
options : array [ 1 .. c_size_option_list ] of
record
pno, p1, p2 : integer;
end;
              end;

opcode = (
op_aaaaa,
op_pexit, op_pcals,
op_revgb, op_revlb, op_revib,
op_revgw, op_revlw, op_reviw,
op_revgf, op_revlf, op_revif,
op_revgd, op_revld, op_revid,
op_revsb, op_revsw, op_revsf,
op_revsd, op_revsm,
op_revpd, op_revpw,
op_reaxd,
op_reagd, op_reald, op_reaid,
op_reaad, op_reasd,
op_uadhw, (* unsigned add *)
op_rechw, op_rechd,
op_renpb,
op_renhb, op_stnhb,
op_setst, op_setcr,
op_index, op_inprs, op_inpss,
op_intrs,
op_jmppd, op_jmcht,
op_jmzne, op_jmzeq, op_jmprw,
op_jmzgt, op_jmzlt,
op_stbsa, op_stwsa, op_stxsa,
op_moveg, op_moveb,
op_stvgb, op_stvlb, op_stvib,
op_stvgw, op_stvlw, op_stviw,
op_stvgf, op_stvlf, op_stvif,
op_stvgd, op_stvld, op_stvid,
op_stvsb, op_stvsw, op_stvsf,
op_stvsd,
op_ult  , op_eq   , op_ne   ,
op_lt   , op_gt   , op_le   ,
op_ge   ,
op_seteq, op_setsb, op_setsp,
op_setun, op_setdi, op_setin,
op_not  , op_and  , op_or   ,
op_xor,
op_settm, op_setad, op_stcea,
op_teqad,
op_compl,
op_neg  , op_div  , op_add  ,
op_sub  , op_mul  , op_mod  ,
op_udiv, op_uadd,
op_usub, op_umul, op_umod,
op_mxept, op_mbset, op_mbtes,
op_iocda,
op_csell,
op_cexch,
op_llock, op_lrese,
op_cgreg, op_crget, op_crput,
op_xxxxx);

opcode_range = op_aaaaa .. op_xxxxx;

identifier = packed array [ 1 .. c_size_identifier ] of char;

exc_code = 0 .. c_exc_max;

string = packed array [ 1 .. c_size_string ] of char;

context = record
niv : integer;
stack_size : integer;
max_stack_size : integer;
work : integer;
max_work : integer
end;

frame_kind = (g_frame, l_frame, i_frame, s_frame);

addr_kind_type = ( addr, stack_addr, packed_arr );

varvalue_descr = record
kind : integer;
size : integer;
val  : integer;
end;

varaddr_descr = record
kind : addr_kind_type;
access : frame_kind;
niv : integer;
offset : integer;
size : integer
end;

opcode_def = record
opname : packed array [ 1 .. c_size_opcode ] of char;
opappetite : integer;
end;

pass4codes =
(
xfirstcode,
xmodule,        xeom,           xprocess,       xblock,
xlength,        xendblock,      xbody,          xinitialize,
xstrucinit,     xsimpleinit,    xextexception,    xexception,
xallocpool,     xinitvar,       xinitrecord,    xendinitrec,
xinitarray,     xendinitarr,    xpoolfield,     xinitfield,
xstrucfield,    xendfield,      xelement,       xpoolcomp,
xreccomp,       xendreccomp,    xarraycomp,     xendarray,
xproc,          xextproc,       xfunc,          xextfunc,
xparamtype,     xendbody,       xproccall,      xextproccall,
xendproccall,   xprocessparam,  xendprocessparam,xvarpointer,
xtempointer,    xvalueparam,    xvarparam,      xassignstat,
xleft,          xassign,        xcasestat,      xcase,
xendcase,       xcaserange,     xcaselabel,     xotherwise,
xforstat,       xleftfor,       xforstore,      xdo,
xendfor,        xgoto,
xifstat,        xifexpr,        xelse,          xif,
xrepeat,        xuntil,         xendrepeat,     xwhile,
xwhileexpr,     xendwhile,      xwithstat,      xendwith,
xlockstat,      xlockvar,       xendlock,       xchannel,
xchanvar,       xendchannel,    xexchstat,      xexchange,
xnot,           xneg,           xcompare,       xcompstruc,
xdiv,           xmul,           xmod,           xor,
xadd,           xsub,           xand,           xrangetest,
xconst,         xlconst,        xset,           xinclude,
xincludeint,    xendset,        xdeflix,        xinitconst,
xvar,           xindvar,        xpackedrec,     xaddr,
xindaddr    ,   xpackedarr,     xdope,          xfield,
xindexexpr,     xcindex,        xfunccall,      xfcall,
xextfunccall,   xnewline,       xerror,         xerrortext,
xerrorno,     xoption,
xextprocess,    xcaddr,         xwithvar,       xendfunccall,
xendcaselist,   xendcasestat,   xbegincode,     xendcode,
xcodeline,      xsetconst,       xarglistsize,   xstdfunc,
xsetinit,       xsetexpr,
xlastcode);

pass4codeindex = 0..150;  (* number of pass4codes *)
(* end pass 4 codes *)

pass5errors = (
ext_table_size,      (* ext_tab_max too small *)
ext_param_number,    (* error in user program *)
case_table_size,     (* size_case_table too small *)
case_table_empty,    (* error in user program *)
param_number,        (* error in user program *)
v_stack_size,        (* max_v_stack too small *)
case_label_error,    (* error in user program *)
compiler_error,      (* error in this pass *)
wrong_version,       (* wrong pass4-pass5 combination *)
unknown_lib,         (* platonlib does'nt exist *)
inconsistent_use,    (* error in user program *)
param_error,         (* inconsistent params in open routine *)
param_table_full,    (* max_param_table too small *)
pass4code_error      (* error in input data from pass4 *)
);


(*    type definitions from modules:     *)

usemodes = (sys_use, general_use);
ext_states = (ext_unused, ext_declared, ext_open, ext_closed);

param_index = 1 .. max_param_table;

param_descr = record
kind : integer;
size : integer;
end;

ext_index = 1 .. ext_tab_max;

ext_descr = packed record
state : ext_states;
mode  : usemodes;
id    : identifier;

(* parameter description *)
no_of_param : integer;
paramptr    : param_index;  (* index in param_table *)

(* special variables for open routines *)
appetite  : integer;
wordcount : integer;  (* no of words (of 2 chars each) in open routine *)
firstword : integer;  (* < 0: file position, > 0: index in char buf *)

(* special variables for closed routines *)
no_of_uses : integer;

(* link through ext_declared entries *)
decl_link : integer;
end;

callmodes = (int_call, ext_call, open_call);


  stat_acc_rec =
record

assign :
record

kind_type : array [ addr_kind_type, 0 .. 6 ] of integer;
size : array [ 0 .. 15 ] of integer

end;

end;



(*   var. declarations global for pass5:      *)


var

prolog_yes, epilog_yes, compress_yes, callpass6_yes, statacc_yes, summary_yes :  boolean;
old_create : boolean;
openroutine_yes: boolean;


op_table : array [ opcode_range ] of opcode_def;


descr : record

(* in this variable the Descriptor Segment, part 1 is accumulated. *)

kind :  integer;
name :  identifier;

entry_point,
exit_point,
exception_point :  identifier;

default_appetite : integer;

appetite  : integer;

no_of_params  :  integer;
param  :  array [ 1 .. descr_max_param ] of
record

kind  :  integer;
size  :  integer

end

end   (*  descr  *);


exc_hard : set of exc_code;

exc_descr : record

state : integer;
internal : boolean;
key : integer;
niv,
lix : integer

end;

c : context;

operand_situation: ( before_opands, after_short_const, after_opands );

op_load : array [ 1..6 (* type_v *) , frame_kind ] of opcode;
op_store: array [ 1..4 (* type_? *) , frame_kind ] of opcode;
op_comp : array [ 1..11 ] of opcode;






(*    var. declarations from the modules:      *)

 in_item_count, in_line_no : integer;
in_options : option_list;
token: pass4codes;
convert_in_code : array [ pass4codeindex ] of pass4codes;


mess_summ_state : integer;

out_state, out_pos : integer;

out_line_state : boolean;
out_special : boolean;

ext_tab :   array [ 1 .. ext_tab_max ] of ext_descr;

not_resolved : integer;  (* links through all ext_declared *)
file_position: integer;  (* < 0: before reset, else positin in library file *)
global_paramptr: integer; (* index in param_table, of first free entry *)

param_table : array [ param_index ] of param_descr;

ext_open_codes:
record
cur_word_ptr : integer; (* points at first free word in charbuf *)
charbuf : array [ 1 .. ext_max_charbuf ] of integer;
end;


stat_acc :  stat_acc_rec;


value

op_table = (
('aaaaa',  0),
('pexit',  0), ('pcals',  0),                 (* no adjustment *)
('revgb',  2), ('revlb',  2), ('revib',  2),
('revgw',  2), ('revlw',  2), ('reviw',  2),
('revgf',  2), ('revlf',  2), ('revif',  2),
('revgd',  4), ('revld',  4), ('revid',  4),
('revsb', -2), ('revsw', -2), ('revsf', -2),
('revsd',  0), ('revsm', -6),                 (* adjust for <addr> and <size> *)
('revpd',  4), ('revpw',  2),
('reaxd',  4),
('reagd',  4), ('reald',  4), ('reaid',  4),
('reaad',  4), ('reasd',  0),
('uadhw',  0),                                (* unsigned add constant *)
('rechw',  2), ('rechd',  4),
('renpb', -2),
('renhb',  0), ('stnhb',  0),                 (* no adjustment *)
('setst', -6), ('setcr', -4),                 (* adjust for <addr> and(or) <size> *)
('index', -6), ('inprs', -8), ('inpss',-12),
('intrs', -4),
('jmppd', -4), ('jmcht', -2),
('jmzne', -2), ('jmzeq', -2), ('jmprw',  0),
('jmzgt', -2), ('jmzlt', -2),
('stbsa',-10), ('stwsa',-10), ('stxsa',-10),  (* adjust for 2*<addr> and <size > *)
('moveg',-10), ('moveb',-10),                 (* adjust for 2*<addr> and <size> *)
('stvgb', -2), ('stvlb', -2), ('stvib', -2),
('stvgw', -2), ('stvlw', -2), ('stviw', -2),
('stvgf', -2), ('stvlf', -2), ('stvif', -2),
('stvgd', -4), ('stvld', -4), ('stvid', -4),
('stvsb', -6), ('stvsw', -6), ('stvsf', -6),
('stvsd', -8),
('ult  ', -2), ('eq   ', -2), ('ne   ', -2),
('lt   ', -2), ('gt   ', -2), ('le   ', -2),
('ge   ', -2),
('seteq',  2), ('setsb',  2), ('setsp',  2),  (* add result *)
('setun',  0), ('setdi',  0), ('setin',  0),  (* no adjustment *)
('not  ',  0), ('and  ', -2), ('or   ', -2),
('xor ', -2),
('settm',  0),                                (* no adjustment *)
('setad', -2),                                (* remove <newsize> *)
('stcea', -8),
('teqad', -6),                                (* remove 2*<addr>, add boolean *)
('compl',   0),
('neg  ',  0), ('div  ', -2), ('add  ', -2),
('sub  ', -2), ('mul  ', -2), ('mod  ', -2),
('udiv', -2), ('uadd', -2),
('usub', -2), ('umul', -2), ('umod', -2),
('mxept', -2), ('mbset', -2), ('mbtes',  2),
('iocda', -2),
('csell', -2),
('cexch', -8),
('llock', -2), ('lrese',  0),
('cgreg',  2), ('crget',  0), ('crput', -4),
('xxxxx',  0) );

op_load  = (
(op_revgb, op_revlb, op_revib, op_revsb),
(op_revgw, op_revlw, op_reviw, op_revsw),
(op_revgf, op_revlf, op_revif, op_revsf),
(op_revgd, op_revld, op_revid, op_revsd),
(op_reagd, op_reald, op_reaid, op_xxxxx),
(op_reagd, op_reald, op_reaid, op_xxxxx) );

op_store = (
(op_stvgb, op_stvlb, op_stvib, op_stvsb),
(op_stvgw, op_stvlw, op_stviw, op_stvsw),
(op_stvgf, op_stvlf, op_stvif, op_stvsf),
(op_stvgd, op_stvld, op_stvid, op_stvsd) );

op_comp  = (
op_ult, op_eq, op_ne, op_lt, op_gt, op_le, op_ge,
op_seteq, op_seteq,
op_setsb, op_setsp );



(*    procedure declarations global for pass5:      *)



procedure eom;
begin
writeln (out_pass5);
close (in_pass5);
close (out_pass5);
close (ext_pass5);
end;


procedure printhead;
begin
write ('*** pass 5 line ', in_line_no:4, ',  ');
end;


procedure printstatus;
begin
writeln ('   token      =', ord(token));
writeln ('   no of items=', in_item_count);
writeln ('   stack      =', c.stack_size);
writeln ('   work       =', c.work);
end;


procedure error_this_pass (e: pass5errors);
begin
write('compiler error, error code = ', ord(e):1);
end;


procedure abort (e: pass5errors);
begin
write ('compilation terminated by ');
case e of
ext_table_size:         writeln ('external routine table overflow');
ext_param_number:       writeln ('too many params in declaration');
case_table_size:        writeln ('case label table overflow');
v_stack_size:           writeln ('operand stack overflow');
pass4code_error:        writeln ('pass 4 code error');
param_table_full:       writeln ('external routine param table full');
compiler_error:         writeln ('inconsistency in pass5');
wrong_version:          writeln ('wrong pass4/pass5 combination');
end
otherwise error_this_pass(e);
printstatus;
eom; eom;
end;


procedure error (e: pass5errors);
begin
printhead;
case e of
case_table_empty:     writeln ('no labels in case statement');
case_label_error:     writeln ('+decl caselabel');
param_number:         writeln ('too many formal parameters');
unknown_lib:          writeln ('platonlib does not exist');
inconsistent_use:     writeln ('user is not allowed to call system-routines');
end
otherwise abort(e);
pass5_ok := false;
end;


procedure evalstack_error;
begin
printhead;
writeln ('evaluation stack error');
printstatus;
c.stack_size := 0;
end;



procedure  context_eval(  change : integer );

begin

with c do
begin

stack_size := stack_size + change;
if stack_size > max_stack_size then  max_stack_size := stack_size

end

end;



procedure  context_work( change : integer );

begin

with c do
begin

work := work + change;
if work > max_work then max_work := work

end

end;




(*     procedure declarations from the modules:      *)


procedure get_token;

var
found : boolean;
pass5_yes : boolean;
no1, no2, passno : integer;

begin

found := false;

repeat
begin

read (in_pass5, no1);
token := convert_in_code [ no1 ];
in_item_count := in_item_count + 1;

case token of
xoption:
begin

read( in_pass5, passno );
read( in_pass5, no1 );
read( in_pass5, no2 );
in_item_count := in_item_count + 3;
pass5_yes := no2 <> 0;

if passno = 5 then
case no1 of
1: prolog_yes := pass5_yes;
2: epilog_yes := pass5_yes;
3: statacc_yes := pass5_yes;
4: compress_yes := pass5_yes;
5: callpass6_yes := pass5_yes;
6: summary_yes := pass5_yes;
7: old_create := pass5_yes;
8: lambda_version := no2;
9: openroutine_yes := pass5_yes;
end
otherwise (* blind *)
else
with in_options do
begin

if passno = 0 then (* version identification *)
if no1 = 4 (* pass 4 *) then
if (no2 div 100 <> versionpass4 div 100) or
(no2 mod 100 < versionpass4 mod 100) then
error (wrong_version);

if out_state = 1 (* after newline *) then
writeln (out_pass5, 'o.', passno, no1, no2, '.')
else

if no_of_options < c_size_option_list then
begin

out_special := true;

no_of_options := no_of_options + 1;
with options [ no_of_options ] do
begin
pno := passno;
p1  := no1;
p2  := no2;
end;

end

end
end;
xnewline:
begin

read( in_pass5, in_line_no);
in_item_count := in_item_count + 1;

out_special := true;
out_line_state := true;
end;
end
otherwise found := true;

end
until  found;

end; (* get_token *)


procedure skip_token (t: pass4codes);
begin
if token <> t then error (pass4code_error);
get_token;
end;


function  in_integer : integer;

var   i : integer;

begin
read( in_pass5, i );
in_item_count := in_item_count + 1;
in_integer := i;
end;


procedure  in_identifier( var  ident : identifier );

var
i, j, w : integer;

begin

i := 1;

for j := 1 to 12 do
begin

read( in_pass5, w );
in_item_count := in_item_count + 1;

if i <= c_size_identifier then
begin

ident[ i ] := chr( w );
i := i + 1

end;

end;

while i <= c_size_identifier do
begin

ident[ i ] := ' ';
i := i + 1

end;

end (* in_identifier *);


procedure  in_init;

begin
open( in_pass5, 'pass4code' );
reset( in_pass5 );
in_item_count := 0;
in_line_no := 0;
in_options.no_of_options := 0;

(* initialize conversion-table *)
for token := xfirstcode to xlastcode do
convert_in_code [ ord (token ) ] := token;
(* read first token *)
get_token;

out_line_state := false;  (* suppress previous reading of linenumbers *)
end;




procedure  mess_summary_line( name : identifier;  head_line, begin_line, end_line : integer;
                              appetite : integer; dynamic_variables : boolean ; process_appetite : integer );

var
dyn_mark : alfa;

begin

if summary_yes then
begin

if mess_summ_state = 0 then
begin

(*  print a header for the summary :  *)
writeln;
writeln( '   name        headline beginline endline  appetite(words) default create-size');
writeln;

mess_summ_state := 1

end;
if dynamic_variables then
dyn_mark := '+ dynamic'
else
dyn_mark := ' ';

write( '   ', name, head_line : 6, begin_line : 10, end_line : 8, '  :  ', appetite div 2 : 6 
, dyn_mark  );
if process_appetite <> 0 then
write( process_appetite : 12 );
writeln;

end

end;

procedure out_nl;
var
i : integer;

begin
   writeln( out_pass5 );

   out_state := 1;   out_pos := 0;

if out_special then
begin

out_special := false;

with in_options do
if no_of_options > 0 then
begin
for i := 1 to no_of_options do
with options [ i ] do
writeln (out_pass5, 'o.', pno, p1, p2, '.');
no_of_options := 0;
end;

if out_line_state then
begin
writeln( out_pass5, 'l. ', in_line_no : 1);
out_line_state := false
end;

end;

end;


procedure  out_char( chr : char );

begin
write( out_pass5, chr );
out_pos := out_pos + 1
end;

procedure out_tab( pos : integer );

begin
if out_pos < pos then
begin
write( out_pass5, ' ' : pos - out_pos);
out_pos := pos;
end
end;


procedure out_integer( i : integer );

begin
if (i > 999) or (i < -99) then
begin
write (out_pass5, i : 6);  out_pos := out_pos + 6;
end
else
begin
write (out_pass5, i : 4);  out_pos := out_pos + 4;
end;
end;


procedure out_identifier( id : identifier );

var
       i, n : integer;

begin

n := c_size_identifier;
while ( id[ n ] = ' ' ) and ( n > 1 ) do n := n - 1;

write( out_pass5, ' ', id : n );
out_pos := out_pos + n + 1;

end;


procedure out_def( id : identifier );

begin
   if out_state <> 1 then  out_nl;

   out_identifier ( id );
write( out_pass5, '= ' );  out_pos := out_pos + 2;

   out_state := 6
end;


procedure out_label( id : identifier );

begin
   if out_state <> 1 then  out_nl;

   out_identifier( id );
write( out_pass5, ': ' );  out_pos := out_pos + 2;

   out_state := 2
end;


procedure out_lix (id_letter: char; index: integer);
begin
write (out_pass5, id_letter:2, '#', index:1);
out_pos := out_pos + 4;  (* assume normally two-digit indices... *)
end;


procedure out_lix_label (id_letter: char; index: integer);
begin
out_nl;
out_lix (id_letter, index);
out_label (' ');
end;


procedure  out_comment( str : string );
var n: integer;

begin
   if out_state <> 5 then 
   begin
      if not compress_yes then  out_tab( 25 );
write( out_pass5, '; ' );  out_pos := out_pos + 2;
   end;
if not compress_yes then
begin
n := c_size_string;
while (str [ n ] = ' ') and (n > 1) do n := n-1;
write (out_pass5, str:n);
out_pos := out_pos + n;
end;

   out_state := 5
end;


procedure out_start_param;

begin
case out_state of
3: out_state := 4;
4: out_char(',');
end otherwise error (compiler_error);
end;


procedure out_opcode( op : opcode );

var
      i   : integer;

begin
   if ( out_state <> 1 ) and ( out_state <> 2 ) then  out_nl;

   if not compress_yes then  out_tab( 5 );
with op_table [ op ] , c do
begin
stack_size := stack_size + opappetite;
if stack_size > max_stack_size then max_stack_size := stack_size;
write (out_pass5, opname);
end;
out_pos := out_pos + c_size_opcode;
   out_state := 3
end;


procedure out_p_id (id: identifier);
begin
out_start_param;
out_identifier (id);
end;


procedure out_p_int (i: integer);
begin
out_start_param;
out_integer (i);
end;


procedure out_expr (id: identifier; i: integer);
begin
out_start_param;
out_identifier (id);
if i >= 0 then out_char ('+');
out_integer (i);
end;


procedure out_op_id (op: opcode; id: identifier);
begin
out_opcode (op);
out_identifier (id);
out_state := 4;
end;


procedure out_op_int (op: opcode; i: integer);
begin
out_opcode (op);
out_integer (i);
out_state := 4;
end;


procedure out_token (t: char);
begin
case t of
dollar_a: begin out_char ('$'); out_char ('a'); end;
dollar_b: begin out_char ('$'); out_char ('b'); end;
dollar_i: begin out_char ('$'); out_char ('i'); end;
end
otherwise
begin
if t <> zendlist then
out_char (t);
out_char ('.');
end;
out_state := 3;
end;


procedure out_init;

begin
open( out_pass5, 'pass5code' );
rewrite( out_pass5 );

out_state := 1;    out_pos := 0;

out_special := false;
out_line_state := false;
writeln (out_pass5, 'o.', 0 (* version id *), ownpassno, versionpass5, '.');

out_nl;

end;


procedure ext_init;
var
key : integer;
begin
not_resolved := -1;
ext_open_codes.cur_word_ptr := 1;
global_paramptr := 1;
file_position := -1;  (* before reset *)
open (ext_pass5, ext_cat_name);
for key := 1 to ext_tab_max do
with ext_tab [ key ] do
state := ext_unused;
end;


procedure find_ext_routine;
var
key : integer;
begin

key := in_integer;
if key > ext_tab_max then error (ext_table_size);

with ext_tab [ key ] do
begin
in_identifier (id);
no_of_param := in_integer;
no_of_uses := 0;
paramptr := global_paramptr;

get_token;
while token = xparamtype do
begin
if global_paramptr > max_param_table then error (param_table_full);
with param_table [ global_paramptr ] do
begin
kind := in_integer;
size := in_integer;
end;
global_paramptr := global_paramptr + 1;
get_token;
end;

state := ext_declared;
decl_link := not_resolved;
not_resolved := key;
end;
end;  (* procedure find_ext_routine *)


procedure ext_copy_code (key : integer);
var
i, c, w : integer;
begin
with ext_tab [ key ] do
with ext_open_codes do
begin

if firstword < 0 then
begin (* text not in charbuf, position the library-file *)
if (file_position = -1) or (-firstword < file_position) then
begin
reset (ext_pass5);
file_position := 0;
end;
for i := 1 to -(file_position + firstword) do get (ext_pass5);
end;

out_nl;

for i := 1 to wordcount do
begin
if firstword > 0 then
w := charbuf [ i + firstword - 1 ]
else
read (ext_pass5, w);
c := w div 256;  if c = 10 then out_nl else out_char (chr(c));
c := w mod 256;  if c = 10 then out_nl else out_char (chr(c));
end;
end;
end; (* procedure ext_copy_code *)


procedure ext_scan;
const
size_of_codedescr = 8; (* no of words in descr, containing date etc *)
var
i, codewords, skipwords, codepos,
descr_length, no_of_pages, size_of_page, bytes_on_last_page, kind_of_obj,
app, pno,
curkey, prevkey : integer;
ident : identifier;
paramtab : array [ 1 .. descr_max_param ] of param_descr;
found : boolean;

begin

reset (ext_pass5);
file_position := 0;

with ext_open_codes do
while not eof(ext_pass5) and (not_resolved > 0) do
begin
read (ext_pass5,
descr_length,
no_of_pages,
size_of_page,
bytes_on_last_page,
kind_of_obj);

(* read name *)
for i := 1 to 6 do
begin
read (ext_pass5, app);
ident [ i*2-1 ] := chr (app div 256);
ident [ i*2   ] := chr (app mod 256);
end;
for i := 13 to c_size_identifier do ident [ i ] := ' ';

(* skip entry points etc *)
for i := 1 to 7 do get (ext_pass5);

read (ext_pass5, app, pno);
if pno > descr_max_param then error (ext_param_number);
for i := 1 to pno do
with paramtab [ i ] do
read (ext_pass5, kind, size);

file_position := descr_length div 2 + file_position;
codewords := ((no_of_pages - 1) * size_of_page + bytes_on_last_page + 1) div 2;
skipwords := codewords;

if (kind_of_obj = 4) or (kind_of_obj = 5) then
begin (* open routine in library *)

for i := 1 to size_of_codedescr do
begin
get (ext_pass5); (* skip date etc *)
skipwords := skipwords - 1;
codewords := codewords - 1;
end;

curkey := not_resolved;
prevkey := -1;
codepos := - file_position;

repeat
with ext_tab [ curkey ] do
begin
(* total match is: same name and paramlist *)
if no_of_param = pno then
if id        = ident then
begin
found := true;  (* assume same param-descr *)
for i := 1 to pno do
if param_table [ paramptr - 1 + i ] <> paramtab [ i ] then
found := false;
if found then
begin
state := ext_open;
appetite := app;
wordcount := codewords;

if prevkey = -1 then
not_resolved := decl_link
else
ext_tab [ prevkey ] . decl_link := decl_link;
curkey := prevkey;

if skipwords > 0 then
if skipwords <= ext_max_routine then
(* routine is not too large *)
if cur_word_ptr + skipwords <= ext_max_charbuf then
begin (* there is room in charbuf *)
codepos := cur_word_ptr;
for i := 1 to skipwords do
read (ext_pass5, charbuf [ i + codepos - 1 ]);
cur_word_ptr := cur_word_ptr + skipwords;
skipwords := 0;
end;

firstword := codepos;
end;
end;
prevkey := curkey;
curkey := decl_link;
end;
until curkey <= 0;
end;

(* skip any remaining part of code-body *)
for i := 1 to skipwords do get(ext_pass5);
file_position := file_position + codewords;
(* skip external link part *)
read (ext_pass5, pno);
file_position := file_position + 1;
for i := 1 to pno do
begin
(* skip external name *)
for pno := 1 to 6 do get (ext_pass5);
file_position := file_position + 6;
(* skip parameter list *)
read (ext_pass5, pno); (* number of params *)
file_position := file_position + 2*pno + 1;
for pno := 2*pno downto 1 do get (ext_pass5);
(* skip number of uses *)
get (ext_pass5);
file_position := file_position + 1;
end;
(* skip internal link part *)
read (ext_pass5, pno);
pno := pno * 4; (* four words per entry *)
for i := 1 to pno do get (ext_pass5);
file_position := file_position + pno + 1;

(* now the libraryfile is positioned at start of next entry *)
end; (* scan of library file *)

(* classify all remaining ext_declared as closed-routines *)
while not_resolved > 0 do
with ext_tab [ not_resolved ] do
begin
state := ext_closed;
not_resolved := decl_link;
end;

end; (* procedure extscan *)


function getkind (key: integer) : callmodes;
begin
with ext_tab [ key ] do
begin
if state = ext_declared then ext_scan;
if state = ext_open then
getkind := open_call
else
getkind := ext_call;
end;
end; (* procedure getkind *)


function ext_lookup (var key: integer; look_id: identifier) : callmodes;
var
i : integer;
found : boolean;
begin
i := 1;
found := false;
repeat
with ext_tab [ i ] do
if state = ext_unused then
i := ext_tab_max + 1
else
if id = look_id then found := true
else
i := i + 1;
until found or (i > ext_tab_max);
if not found then error (compiler_error);
key := i;
ext_lookup := getkind (i);
end; (* procedure getkind *)


procedure  descr_end;

var
i, j, no_of_entries : integer;

begin

writeln (out_pass5, 'd.');
writeln (out_pass5, descr.name);
writeln (out_pass5, descr.kind);
writeln (out_pass5);

writeln (out_pass5, descr.entry_point);
writeln (out_pass5, descr.exception_point);
writeln (out_pass5, descr.exit_point);
writeln (out_pass5);

writeln (out_pass5, descr.default_appetite);
writeln (out_pass5, descr.appetite);
writeln (out_pass5);

writeln (out_pass5, descr.no_of_params);
for i := 1 to descr.no_of_params do
with descr.param [ i ] do
writeln (out_pass5, kind, ',', size);
writeln (out_pass5);

no_of_entries := 0;
for i := 1 to ext_tab_max do
with ext_tab [ i ] do
if state = ext_closed (* closed routine *) then
begin
if no_of_uses > 0 then
no_of_entries := no_of_entries + 1
end;

writeln( out_pass5, no_of_entries );

for i := 1 to ext_tab_max do
with ext_tab [ i ] do
begin
if state = ext_closed (* closed routine *) then
begin
if no_of_uses > 0 then
begin
writeln (out_pass5);
writeln (out_pass5, id);
writeln (out_pass5, no_of_param);
for j := 1 to no_of_param do
with param_table [ paramptr + j - 1 ] do
writeln (out_pass5, kind, ',', size);
writeln (out_pass5, no_of_uses);
writeln (out_pass5, e_name, '#', i:1);
end;
end;
no_of_uses := 0;
end;
end; (* descr_end *)



procedure code_call_proc
(use: usemodes; callkind: callmodes; key, niv, lix, paramlength: integer);

begin

if callkind <> int_call then
with ext_tab [ key ] do
begin
no_of_uses := no_of_uses + 1;
if no_of_uses = 1 then
mode := use;
if mode <> use then
error(inconsistent_use);
end;

case callkind of

open_call:
begin
ext_copy_code (key);
with ext_tab [ key ] do
begin
context_eval (appetite);
context_eval (-appetite-paramlength);
end;
end;

int_call,
ext_call:
begin
out_opcode (op_pcals);  context_eval ( - const_size_nn - paramlength);
out_p_int (const_size_nn - 2 + paramlength);
out_p_int (c.niv - niv);
out_start_param;
if callkind = int_call then
out_lix (r_name, lix)
else
out_lix (e_name, key);

end;

end; (* case *)

end; (* procedure code_call_proc *)


procedure  code_initvar( kind, offset, type_o : integer;
       var ref_count : integer);
forward;


procedure get_niv_offset ( var v : varaddr_descr );

begin
with v do
begin

kind := addr;
niv := in_integer; offset := in_integer;
size := 0;

if niv = const_niv_0 then access := g_frame
else
if niv = c.niv then access := l_frame
else
access := i_frame;

end;
end; (* get niv, offset *)



procedure  load_address( var  v : varaddr_descr; offset_zero : boolean);

(* the execution of this procedure enforces  'v.kind' = 'addr'    *)

begin

case  v.kind  of

addr:
  begin

out_opcode (op_load [ 5, v.access ] );

if v.access = i_frame then
begin
out_p_int( c.niv - v.niv )
end;

out_p_int( v.offset );

v.kind := stack_addr;   v.offset := 0;   v.access := s_frame;
end;

stack_addr:
  if  ( offset_zero ) and ( v.offset <> 0 ) then
begin
out_opcode( op_reasd );
out_p_int( v.offset );

v.offset := 0
end;

packed_arr: error (compiler_error);

end

end;



procedure  code_exc_trigger( exception_no : integer);

begin

out_opcode( op_rechw );
out_expr (id_cpexcfirst, exception_no);

out_opcode( op_mxept );
out_comment( '   trigger exception no. : ' ); out_integer( exception_no )


end;


procedure  code_allocpool( kind, offset, number, size : integer);

var
w_offset, stack_size, paramlength, key, refs : integer;

begin

(*  init. the semaphore of the pool to nil :  *)

if kind = 2 then
begin

out_opcode( op_revpd )

end;

code_initvar( kind, offset, 6, refs);

out_comment( '   start init. of pool. ' );


(*  prepare call of the routine: _initpool_rc  :  *)

if kind = 2 then
begin

(*  save the address on the stack in a working location:   *)

if offset <> 0 then
begin

out_opcode( op_reasd );
out_p_int (offset);

end;

w_offset := c.work;  context_work( 4 );

out_opcode( op_stvld );
out_expr (id_work, w_offset);
out_comment( '   save address of the pool. ' )

end;
out_op_int (op_renhb, const_size_nn);  context_eval (const_size_nn);
out_comment( '   prepare call of _initpool_rc  . ' );

stack_size := c.stack_size;

(*  generate the actual parameters:  *)

if kind = 1 then 
begin
out_op_int (op_reald, offset);

end

else
if kind = 2 then
begin

out_opcode( op_revld );
out_expr (id_work, w_offset);

context_work( -4 )

end

else
error(compiler_error);

out_op_int (op_rechw, number);

if odd( size ) then size := size + 1;
size := size div 2;
if size = 32768 then size := - size;

out_op_int (op_rechw, size);

paramlength := c.stack_size - stack_size;

code_call_proc (sys_use, ext_lookup (key, '_initpool_rc'), key, const_niv_0, 0, paramlength);

end (* code_allocpool *);


procedure code_set_maxstack (reservation : identifier);
const lm_regno = -7;

begin

out_op_id (op_revgw, id_maxstack);

if reservation <> ' ' then
begin (* decrease maxstack by <reservation> *)
out_op_id (op_uadhw, reservation);
end;

out_opcode (op_cgreg);
out_op_int (op_uadhw, lm_regno);

out_opcode (op_crput);
end;


procedure code_exit;

var
key : integer;

begin

(* let the process use all of the allocated stack!!! *)
code_set_maxstack (' ');

out_op_int (op_renhb, const_size_nn);  context_eval (const_size_nn);

code_call_proc (sys_use, ext_lookup (key, '___exit___rc'), key, const_niv_0, 0, 0);
end; (* procedure code_exit *)


procedure  code_initvar( kind, offset, type_o : integer;
  var ref_count : integer);

var
o_i, o_c : identifier;

begin

ref_count := 0;

case type_o of

5 :   ;

6 :
begin
o_i := id_semchain;  o_c := id_osem
end;

7 :
begin
o_i := id_refchain;  o_c := id_oref;
ref_count := 1
end;

8 :
begin
o_i := id_shadowchain  ; o_c := id_oshadow
end

end
otherwise
error(pass4code_error);

if kind = 1 then
begin

out_op_int (op_rechw, const_nil_msp);
out_op_int (op_stvlw, offset);

if type_o <> 5 then
begin
out_op_id (op_revgd, o_i);
out_opcode (op_stvld);  out_expr (o_c, offset);
out_op_int (op_reald, offset);
out_op_id  (op_stvgd, o_i);
end;

end

else
if kind = 2 then
begin

if type_o <> 5 then
begin

out_opcode( op_revpd )

end;

out_op_int (op_rechw, const_nil_msp);
out_op_int (op_stvsw, offset);

if type_o <> 5 then
begin

if offset <> 0 then
begin
out_op_int (op_reasd, offset);
end;

out_opcode( op_revpd );
out_op_id (op_revgd, o_i);
out_op_id (op_stvsd, o_c);
out_op_id (op_stvgd, o_i);

end

end

else
error(compiler_error);

end  (*  code_initvar  *);



procedure  code_stat_to_dyn( size : integer );

begin

(*  this procedure moves ( conceptually !! ) a block of 'size' bytes
( which must be one or more sets ) from the static part of the 
evaluation stack, to the dynamic part.  *)

context_eval( -size )

end;


procedure  code_dyn_to_stat( size : integer );

begin

(* this procedure has the opposite effect as 'code_stat_to_dyn' *)

context_eval( size )

end;



procedure  code_exception;

const
hard_size_max = 20;

var
key, i, j, p, r, w, hard_size : integer;
hard_set : array [ 0 .. hard_size_max ] of integer;
callkind : callmodes;

begin

if( exc_descr.state = 1 ) and ( epilog_yes ) then
begin
out_op_id (op_reaad, id_exit);
out_op_id (op_stvgd, id_expoint);

(* read current value of 'resume bit' *)
out_op_int (op_mbtes, ps_mask_resume);
out_op_int (op_rechw, value_false);
out_op_int (op_mbset, ps_mask_resume);

(*  output code to decrease lm ( in the reg. set ) by -exitappetite :  *)

code_set_maxstack (id_exitappetite);

out_op_int (op_renhb, const_size_nn);  context_eval (const_size_nn);
out_op_id  (op_revgw, id_exmask);

with exc_descr do
begin
if internal then
callkind := int_call
else
callkind := getkind (key);
code_call_proc (general_use, callkind, key, c.niv, lix, 2);
end;

(*  calculate :  hard_set[ 0 .. hard_size ]       *)

if ( c_exc_max div 16 ) > hard_size_max then
error(compiler_error);

for i := 0 to hard_size_max do  hard_set[ i ] := 0;

for i := 0 to c_exc_max do
if i in exc_hard then
begin

w := i div 16;  p := i mod 16;
r := 1;  for j := p to 14 do r := r*2;
hard_set[ w ] := hard_set[ w ] + r

end;

hard_size := hard_size_max;
while ( hard_set[ hard_size ] = 0 ) and ( hard_size > 0 ) do
hard_size := hard_size - 1;

out_nl;  out_nl;
out_token (zbegin);
out_p_id (id_hardset);
out_token (zendlist);
out_nl;

out_op_id  (op_revgw, id_exmask);
out_op_id  (op_reaad, id_hardset);
out_op_int (op_rechw, 2 * hard_size + 2);

out_opcode( op_revsm );  context_eval( 2 * hard_size + 2 );
out_op_int (op_rechw, 2 * hard_size + 2);

code_stat_to_dyn( 2 * hard_size + 2 + 2 );

out_opcode( op_settm );

out_op_id  (op_jmzgt, id_exit);

(* reestablish maxstack *)

code_set_maxstack (id_bonappetite);

(* restore 'resume bit' *)
out_op_int (op_mbset, ps_mask_resume);

(* prepare return, load address before restoring 'expoint' *)
out_op_id  (op_revgd, id_exic);
out_op_id  (op_reaad, id_exception);
out_op_id  (op_stvgd, id_expoint);

out_opcode( op_jmppd );

out_nl;  out_nl;

out_label( id_hardset );
out_token (zconst);  out_integer( 2 * hard_size + 2 );

for i := 0 to hard_size do
begin
out_nl;
out_tab( 15 );  out_integer( hard_set[ i ] )
end;

out_nl;
out_token (zend);  (* end of const *)
out_nl;
out_token (zend);  (* end of block *)
out_nl;

end

else
begin

if epilog_yes then error(pass4code_error); (* exceptionnot defined *);

out_op_id (op_jmprw, id_exception);

end

end (* code_exception  *);





procedure  code_ref_remove(ref_count : integer; dyn_refs : boolean);

var
work_size : integer;
jump : opcode;

begin

(* if not dyn_refs then
 remove ( and check = NIL ) 'ref_count' reference_type variables
from the chain of references 
else 
remove all reference type variables of local frame from the chain 
  *)

out_nl;
out_token (zbegin);
out_p_id (id_rep);
out_p_id (id_cont);
out_p_id ( id_endrep );
out_token (zendlist);
out_comment( '   remove and check reference_type variables.' );
if dyn_refs then
begin
out_op_int ( op_reald, -1 );
out_comment ( ' get lf ');
work_size := 6; jump := op_jmprw;
end
else

if ref_count > 1 then
begin
work_size := 2; jump := op_jmzne;
out_op_int (op_rechw, ref_count);
end;
out_label (id_rep);
out_op_id  (op_revgd, id_refchain);

out_opcode ( op_revpd );
if dyn_refs then
begin
out_opcode(op_reaxd);
out_op_int(op_revsw, -9);
out_comment(' push lf.disp ');
out_opcode( op_ult );
out_op_id ( op_jmzne, id_endrep );
out_op_int( op_stnhb, 2 ); (* no context eval here !! *)

out_opcode( op_revpd );
end;

out_opcode( op_revsf );
out_start_param;  out_integer( 0 );
out_start_param;  out_integer( c_field_nil );

out_op_id  (op_jmzne, id_cont);

code_exc_trigger( c_exc_ref);

out_label (id_cont);
out_op_id  (op_revsd, id_oref);
out_op_id  (op_stvgd, id_refchain);
if not dyn_refs then
if ref_count > 1 then
begin
out_op_int (op_uadhw, -1);
out_opcode (op_revpw);
end;
if (ref_count > 1) or dyn_refs then
begin
out_op_id  (jump, id_rep);
out_label(id_endrep);
out_op_int (op_stnhb, work_size);  context_eval (-work_size);
end;

out_nl;
out_token (zend);
out_nl;

end  (* code_ref_remove  *);




procedure  code_line_tab_header( name : identifier );

begin
out_token (zname);
out_p_id (name);
out_nl;
out_token (zend);

end  (*  code_line_tab_header  *);


procedure  stat_reset;

var
i: addr_kind_type;
j : integer;

begin

with stat_acc.assign do
begin

for i := addr to packed_arr do
for j := 0 to 6 do  kind_type[ i, j ] := 0;

for j := 0 to 15 do size[ j ] := 0

end

end;


procedure  stat_print;

var
i: addr_kind_type;
j : integer;

begin

writeln;  writeln;
writeln( '   statistics from pass5: ' );
writeln;

writeln( '     assignment: ' );
writeln;
with stat_acc.assign do
begin

for i :=addr to packed_arr do
begin
for j := 0 to 6 do write( kind_type[ i, j ] );
writeln
end;
writeln;

for j := 0 to 7 do write( size[ j ] );
writeln;
for j := 8 to 15 do write( size[ j ] );
writeln;

end;

writeln

end;



procedure  stat_assign( l_v : varaddr_descr; l_type, l_size : integer;
      r_v : varvalue_descr );

var
i_kind : addr_kind_type;
i_type : integer;

begin

if statacc_yes then
with  stat_acc.assign do
begin

i_kind := l_v.kind;

i_type := l_type;
if ( i_type > 6 ) or ( i_type < 0 ) then i_type := 0;

kind_type[ i_kind, i_type] := kind_type[ i_kind, i_type ] + 1;

if ( l_type = 5 ) or ( l_type = 6 ) then
begin

if ( l_size < 0 ) or ( l_size > 15 ) then
size[ 0 ] := size[ 0 ] + 1
else
size[ l_size ] := size[ l_size ] + 1

end

end

end;

procedure   find_exprs( var  v: varvalue_descr);
forward;


procedure   find_operand( var v: varvalue_descr);
forward;
 
 
procedure  find_func_call( var v : varvalue_descr);
forward;


procedure  find_call;
forward;


procedure  find_constants;
forward;


procedure  find_std_call(var v: varvalue_descr);
forward;


procedure  find_arglist;
forward;

procedure   find_statement;
forward;
procedure   find_varvalue( var  v: varvalue_descr);
forward;
procedure   find_varaddr( var  v: varaddr_descr);
forward;


procedure find_init;
forward;


procedure find_processparam;
forward;



procedure   find_assign;


var    l_v  , l_v_stat, templ_v :  varaddr_descr;
       r_v  :  varvalue_descr;
       l_type, l_first, l_number, l_size  : integer;


begin
get_token;

   find_varaddr( l_v);      l_v_stat := l_v;  
if token <> xleft then error(pass4code_error);

   l_type := in_integer;

   if l_type = 3 then
   begin
l_first := in_integer;  l_number := in_integer;
if l_number = 8 then
begin (* optimize 8-bit fields as bytes *)
if l_first = 0 then
l_type := 1   (* left byte, don't change offset *)
else
if l_first = 8 then
begin (* rigth byte, add one to offset *)
l_v.offset := l_v.offset + 1;
l_type := 1;
end;
end;
   end
   else
   if ( l_type = 5 )  or  ( l_type = 6 ) then  l_size := in_integer
else
if l_type = 7 then
get_niv_offset( templ_v );


   if ( l_type = 5 )  or  ( l_type = 6 ) or (l_type = 7) then
          load_address( l_v, true);


   get_token;
find_exprs( r_v);


 (*   here, tests can be inserted in order to check the
      consistency of  "r_v", "l_v" and "l_type".
 *)

  stat_assign( l_v_stat, l_type, l_size, r_v );  

skip_token (xassign);

   case l_v.kind of

 addr:
   begin

      out_opcode( op_store[ l_type, l_v.access ] );

      if l_v.access = i_frame then
      begin
         out_start_param;  out_integer( c.niv - l_v.niv )
      end;

      out_start_param;  out_integer( l_v.offset );

      if l_type = 3 then
      begin
         out_start_param;  out_integer( l_first*16 + l_first + l_number -1 )
      end

end;

stack_addr:
   begin

      if l_type = 6 then (* set *)
      begin

if r_v.kind <> 1 then  error(pass4code_error);

if r_v.size <> ( l_size + 2 ) then
begin

if r_v.size > 0 then
begin

code_stat_to_dyn( r_v.size );

r_v.size := 0

end;

out_opcode( op_rechw );
out_start_param;  out_integer( l_size );

out_opcode( op_setad );

code_dyn_to_stat( l_size + 2 )

end;

out_opcode( op_setst );  context_eval( - l_size );

      end  (* l_type = 6 *)

      else

      if l_type = 5 then (* static structure *)
      begin

         out_opcode( op_rechw );
         out_start_param;   out_integer( l_size );
out_opcode (op_moveg)

      end  (* l_type = 5 *)

else

if l_type = 7 then
begin (* dynamic structure *)
with templ_v do
begin
out_opcode( op_load [ word_typ, access ] );
if access = i_frame then
out_p_int( c.niv - niv );
out_p_int( offset );
end; (* with *)
out_opcode( op_moveg );
end (* l_type = 7 *)

      else

      begin

      (*   l_type = 1, 2, 3 or 4 .  *)

out_opcode (op_store [ l_type, s_frame ]);

         out_start_param;  out_integer( l_v.offset );

         if l_type = 3 then
         begin

            out_start_param;  out_integer( l_first*16 + l_first + l_number -1 )
         end

      end

end;

packed_arr:
   begin

if( r_v.kind <> 1 ) or ( ( r_v.size <> 0 ) and ( r_v.size <> 2 ) )
         then   error(pass4code_error);

      out_opcode( op_inpss )

end;

   end  (*  case l_v.kind of...  *)

end  (*  find_assign  *);





procedure  find_expr( var  v : varvalue_descr);

const

max_v_stack = 10;

var

(* .... for the Stack module :    *)

v_stack : array [ 1 .. max_v_stack ] of varvalue_descr;

top_v_stack,
state_v_stack : integer;

(* .... for the rest of the procedure :    *)

v_o1, v_o2, v_r : varvalue_descr;

end_expr : boolean;

type_o, comp, size : integer;

template_v : varaddr_descr;



value

top_v_stack = 0;
state_v_stack = 0;

end_expr = false;


procedure  push_v_stack( v : varvalue_descr );

begin
if top_v_stack >= max_v_stack then
error (v_stack_size)
else
begin
top_v_stack := top_v_stack + 1;
v_stack[ top_v_stack ] := v
end
end;


procedure  pop_v_stack( var  v : varvalue_descr );

begin
if top_v_stack <= 0 then error(compiler_error);
if state_v_stack = 1 then
begin
v.kind := 0;
v.size := 0
end
else
begin
v := v_stack[ top_v_stack ];
top_v_stack := top_v_stack - 1
end
end;


begin

operand_situation := before_opands;

repeat

case token of

xconst,
xlconst,
xfunccall,
xextfunccall,
xstdfunccall,
xprocessparam,
xsetconst,
xset,
xaddr,
xcaddr:
begin

(*   the next item on input is an operand.
     find the operand, and push the descriptor on
     the v_stack :
*)

if operand_situation = after_short_const then
begin
out_opcode (op_rechw);
out_start_param;  out_integer (v_r.val);
operand_situation := after_opands;
end;

find_operand (v_r);

if operand_situation = before_opands then
operand_situation := after_opands;

push_v_stack( v_r )
end;

(*   check the next item to see if it is an operator.
     generate the proper bis-instructions for the operator.
     take the descriptors for the operands from the v_stack,
     and store the descriptor of the result on the v_stack :
*)

xnot :

begin
type_o := in_integer;

if type_o = bool_typ then

out_opcode( op_not )
else (* integer *)
out_opcode( op_compl );


pop_v_stack( v_o1 );
if ( v_o1.kind <> 1 ) or ( v_o1.size <> 2 ) then error(compiler_error);

v_r.kind := 1;   v_r.size := 2;
push_v_stack ( v_r );
get_token;

end;


xneg :

begin

out_opcode( op_neg );

pop_v_stack( v_o1 );
if ( v_o1.kind <> 1 ) or ( v_o1.size <> 2 ) then error(compiler_error);

v_r.kind := 1;  v_r.size := 2;
push_v_stack( v_r );
get_token;

end;



xcompare :

begin

comp := in_integer;

if ( comp >= 1 ) and ( comp <= 7 ) then
begin

out_opcode( op_comp[ comp ] );

pop_v_stack( v_o2 );   pop_v_stack( v_o1 );
if ( v_o1.kind <> 1 ) or ( v_o1.size <> 2 ) or
   ( v_o2.kind <> 1 ) or ( v_o2.size <> 2 ) then error(compiler_error);

v_r.kind := 1;  v_r.size := 2;
push_v_stack( v_r )

end

else

if ( comp >= 8 ) and ( comp <= 11 ) then
begin

pop_v_stack( v_o2 );  pop_v_stack( v_o1 );
if ( v_o1.kind <> 1) or ( v_o2.kind <> 1 ) then error(compiler_error);

code_stat_to_dyn( v_o1.size + v_o2.size );

out_opcode( op_comp[ comp ] );
if comp = 9 then  out_opcode( op_not );

v_r.kind := 1;  v_r.size := 2;

push_v_stack( v_r )


end

else

if comp = 12 then
begin

pop_v_stack( v_o2 );   pop_v_stack( v_o1 );
if ( v_o1.kind <> 1 ) or ( v_o1.size <> 2 ) or
   ( v_o2.kind <> 1 )   then  error(compiler_error);

code_stat_to_dyn( v_o2.size );

out_opcode( op_settm );

v_r.kind := 1;  v_r.size := 2;
push_v_stack( v_r )

end

else
error(pass4code_error);
get_token;

end;


xcompstruc :

begin

comp := in_integer;   size := in_integer;

pop_v_stack (v_o2);  pop_v_stack (v_o1);
if (v_o1.kind <> v_o2.kind) or
(v_o1.size <> v_o2.size) or
(v_o1.size <> size) then
error (compiler_error);

if v_o1.kind = 2 then
begin (* compare arrays or records *)
out_opcode( op_rechw );
out_start_param;   out_integer( size );

out_opcode( op_stcea );
end
else (* compare pointers *)
out_opcode (op_teqad);
if comp = 14 then
out_opcode( op_not )
else
if comp <> 13 then
error(pass4code_error);


v_r.kind := 1;   v_r.size := 2;
push_v_stack( v_r );
get_token;

end;


xcompdynstruc :

begin

comp := in_integer;

get_niv_offset( template_v );

pop_v_stack ( v_o2 ); pop_v_stack ( v_o1 );

if v_o1.kind = 2 then
begin (* compare arrays or records *)
with template_v do
begin
out_opcode( op_load [ word_typ, access ] );
if access = i_frame then
out_p_int( c.niv - niv );
out_p_int( offset );
end; (* with *)

out_opcode( op_stcea );

end
else
error( pass4code_error );

if comp = 14 then  (* <> *)
out_opcode( op_not )
else
if comp <> 13 then error( pass4code_error );

v_r.kind := 1; v_r.size := 2;

push_v_stack ( v_r );

get_token;

end; (* comp dyn struc *)


xdiv :

begin

out_opcode( op_div );

pop_v_stack( v_o2 );   pop_v_stack( v_o1 );
if ( v_o1.kind <> 1 ) or ( v_o1.size <> 2 ) or
   ( v_o2.kind <> 1 ) or ( v_o2.size <> 2 ) then error(compiler_error);

v_r.kind := 1;  v_r.size := 2;
push_v_stack( v_r );
get_token;

end;


xadd,
xsub,
xmul :

begin

type_o := in_integer;
if type_o = 3 then
error(compiler_error)
else
if type_o = 2 then
begin

if token = xadd then out_opcode( op_add )
else
if token = xsub then out_opcode( op_sub )
else
out_opcode( op_mul );

pop_v_stack( v_o2 );   pop_v_stack( v_o1 );
if ( v_o1.kind <> 1 ) or ( v_o1.size <> 2 ) or
   ( v_o2.kind <> 1 ) or ( v_o2.size <> 2 ) then error(compiler_error);

v_r.kind := 1;  v_r.size := 2;
push_v_stack( v_r )

end

else

if type_o = 4 then
begin

pop_v_stack( v_o2 );  pop_v_stack( v_o1 );
if ( v_o1.kind <> 1 ) or ( v_o2.kind <> 1 ) then error(compiler_error);

code_stat_to_dyn( v_o1.size + v_o2.size );

if token = xadd then out_opcode( op_setun )
else
if token = xsub then out_opcode( op_setdi )
else
out_opcode( op_setin );

v_r.kind := 1;   v_r.size := 0;
push_v_stack( v_r )

end

else
error(pass4code_error);
get_token;

end;


xor,
xxor,
xand :
begin

if token = xor then out_opcode( op_or )
else
if token = xxor then out_opcode ( op_xor )
else
out_opcode( op_and );

pop_v_stack( v_o2 );   pop_v_stack( v_o1 );
if ( v_o1.kind <> 1 ) or ( v_o1.size <> 2 ) or
   ( v_o2.kind <> 1 ) or ( v_o1.size <> 2 ) then error(compiler_error);

v_r.kind := 1;   v_r.size := 2;
push_v_stack( v_r );
get_token;

end;


xmod :

begin

out_opcode( op_mod );

pop_v_stack( v_o2 ) ;  pop_v_stack( v_o1 );
if ( v_o1.kind <> 1 ) or ( v_o1.size <> 2 ) or
   ( v_o2.kind <> 1 ) or ( v_o2.size <> 2 ) then error(compiler_error);

v_r.kind := 1;  v_r.size := 2;
push_v_stack( v_r );
get_token;

end;


xrangetest :

begin

out_opcode( op_reaad );
out_start_param;  out_lix (c_name, in_integer);

out_opcode( op_intrs );
get_token;

end;



xdynrangetest :

begin

if operand_situation = after_short_const then
begin
out_op_int( op_rechw, v_r.val);
operand_situation := after_opands;
end;

get_niv_offset ( template_v );

load_address( template_v, true );   (* ?????????????????????????????????? *)
 out_opcode( op_intrs );

get_token;


end; (* dyn range test *)


xsubdef: (* pop the stack *)
begin

pop_v_stack( v_o2 );

end_expr := true;

end;



end  (*  case  token of ......  *)

otherwise

(*  the input item is neither an operand nor an operator.
    this signals the end of an expression.
*)

end_expr := true

until  
end_expr;


pop_v_stack( v );

if top_v_stack <> 0 then error(compiler_error)


end;  (*  find_exprs  *)









procedure  find_operand( var v: varvalue_descr);

var   size, val   : integer;
v_c : varvalue_descr;
first_set : boolean;


begin

   case token of

 xconst:
   begin
val := in_integer;
if operand_situation = before_opands then
begin
v.val := val;
operand_situation := after_short_const;
end
else
begin
out_opcode (op_rechw);
out_start_param;  out_integer (val);
end;

      v.kind := 1;
      v.size := 2;
get_token;

   end  (* t_const *);

 xlconst:
   begin

      out_opcode( op_reaad );
out_start_param;  out_lix (c_name, in_integer);

      v.kind := 2;
      v.size := in_integer;
get_token;

   end  (* t_lconst *);

xfunccall,
xextfunccall,
xstdfunccall,
xprocessparam:
begin

find_func_call( v)

end  (*  func call  *);

xsetconst :
begin
val  := in_integer;  (* lix for the constant *)
size := in_integer;

out_opcode( op_reaad );
out_start_param;  out_lix (c_name, val);

out_opcode( op_rechw );
out_start_param;  out_integer( size );

out_opcode( op_revsm );  context_eval( size );
out_op_int (op_rechw, size);

v.kind := 1;
v.size := size + 2;
get_token;

end;

xset :
begin

first_set := true;
get_token;

repeat
begin

if token <> xendset then
find_exprs (v_c);

case token of
xendset:
begin
(* simulate empty set as:  (. 1 .. 0 .) *)
out_opcode (op_rechd);
out_start_param;  out_integer (1);
out_start_param;  out_integer (0);
end;
xinclude:
begin
out_opcode (op_revpw);
get_token;
end;
xsetexpr:
begin
get_token;
find_exprs (v_c);
skip_token (xincludeint);
end;
end
otherwise error(pass4code_error);

out_opcode( op_setcr );

if not( first_set ) then  out_opcode( op_setun );

first_set := false

end

until token = xendset;

get_token;

v.kind := 1;
v.size := 0
end;

end (* case token *)

otherwise
begin

         find_varvalue( v)

      end


end  (*   find_operand   *);


procedure find_exprs (var v: varvalue_descr);
(* similar to find_expr, but always delivers result on stack *)
begin
find_expr (v);
if operand_situation = after_short_const then
begin
out_opcode (op_rechw);
out_start_param;  out_integer (v.val);
operand_situation := after_opands;
end;
end;



procedure  find_func_call( var v : varvalue_descr);

begin

if token = xprocessparam then
find_processparam
else
begin

if token = xstdfunccall then
find_std_call (v)
else
find_call;

skip_token (xfcall);

end;

if token <> xendfunccall then
find_varvalue (v);  (* retrieve result of function-call *)

skip_token (xendfunccall);

end (*  find_func_call  *);



procedure  find_proc_call;

begin

if token = xprocessparam then
find_processparam
else
begin

find_call;

skip_token (xendpcall);

end

end  (*  find_proc_call  *);



procedure  find_call;

var
niv, lix, paramlength, appetite, key, stack_size : integer;
callkind : callmodes;
name, id : identifier;

begin

case token of

xproccall,
xfunccall:
begin (* internal routine *)

niv := in_integer;
lix := in_integer;

callkind := int_call;
end;
xextproccall,
xextfunccall:
begin (* external routine *)
key := in_integer;
niv := const_niv_0;
callkind := getkind (key);
end;

end (* case *)
otherwise error(pass4code_error);

if callkind <> open_call then
begin
(*  push anonymous parameters on the stack:  *)

out_opcode( op_renhb );  context_eval( const_size_nn );
out_start_param;   out_integer( const_size_nn );
out_comment( '   prepare call of closed routine. ' )

end;

stack_size := c.stack_size;

find_arglist;

paramlength := c.stack_size - stack_size;

code_call_proc (general_use, callkind, key, niv, lix, paramlength);


end (*  find_call  *);



procedure  find_constants;

var
n, p, i : integer;

begin

get_token;
while token = xdeflix do
begin

out_lix_label (c_name, in_integer);

get_token;  (* skip: xinitconst *)

n := in_integer;

out_tab( 15 ); out_token (zconst);  out_integer( 2*n );

p := 0;
for i := 1 to n do
begin
if p mod 5 = 0 then
begin
out_nl;   out_tab( 20 )
end
else
out_char (',');
out_integer( in_integer );
p := p + 1
end; 

out_nl;
out_tab( 15 );   out_token (zend);
out_nl;

get_token;
end;
end (*  find_constants  *);


procedure out_make_top_even;
(* make top of stack variable even, i.e. round up *)

begin

out_opcode( op_revpw );
out_op_int( op_rechw, 1 );
out_opcode( op_and );
out_opcode( op_uadd );

end;


procedure compute_number_of_elements ( dope_start : integer );

(* dope_start = ^ record
.                   size,
.                   first_index,
.                   last_index,
.                   element_size : integer;
.                 end

*)

const
one_shift_fifteen = -32768;

begin

out_op_int( op_revlw, dope_start + 4 );
out_comment(' compute no of elems ');
out_op_int( op_rechw, one_shift_fifteen );
out_opcode( op_xor );

out_op_int( op_revlw, dope_start + 2 );
out_op_int( op_rechw, one_shift_fifteen );
out_opcode( op_xor );

out_opcode( op_usub );
out_op_int( op_uadhw, 1 );
out_comment(' last - first + 1 ');

end;



procedure dyn_type_declaration;

var
template_v, template1_v : varaddr_descr;
size, first, last, dope_start : integer;
element_size, fields_pr_word, bits_pr_field : integer;
allign : boolean;
var_val_v : varvalue_descr;

begin

case token of
xarray1template,
xarray2template,
xarray3template : begin

dope_start := in_integer;
get_niv_offset( template_v );
case token of
xarray1template: begin (* dynamic index range, static comp *)
element_size := in_integer;
fields_pr_word := in_integer;
bits_pr_field := in_integer;

with template_v do
begin
(* load (first , last )  *)
out_opcode( op_load [ double_typ, access ] );
if access = i_frame then
out_p_int( c.niv - niv );
out_p_int( offset + 2 );
end; (* with *)
out_op_int( op_stvld, dope_start + 2 );

if fields_pr_word = 1 then 
begin (* unpacked *)

out_op_int( op_rechw, element_size );
out_comment( ' unpacked dyn array, static comp ' );
if element_size > 2 then (* prepare multiplication *)
out_opcode( op_revpw );
out_op_int( op_stvlw, dope_start + 6 );

(* compute the size *)
compute_number_of_elements ( dope_start );
if element_size > 2 then
out_opcode( op_umul )
else
if element_size = 2 then
begin
out_opcode( op_revpw ); out_comment( ' * 2 (element size) ' );
out_opcode( op_uadd  );
end;
out_op_int( op_stvlw, dope_start );

end

else

begin (* packed array *)

out_op_int( op_rechw, fields_pr_word * 256 + bits_pr_field );
out_comment( ' packed dyn array, static comp ' );
out_op_int( op_stvlw, dope_start + 6 );

compute_number_of_elements( dope_start );
out_opcode( op_revpw );

out_op_int( op_rechw, fields_pr_word );
out_opcode( op_udiv );
out_opcode( op_revpw ); out_comment( ' * 2  ' );
out_opcode( op_uadd );

out_opcode( op_reaxd );  (* get number of elements *)
out_op_int( op_revsw, -3 );

out_op_int( op_rechw, fields_pr_word );
out_opcode( op_umod );
out_op_int( op_uadhw, 1 );
if bits_pr_field > 2 then
begin
out_op_int( op_rechw, bits_pr_field );

out_opcode( op_umul ); out_comment( ' * bits per field ' );
end
else
if bits_pr_field = 2 then
begin
out_opcode( op_revpw ); out_comment( ' * bits per field  (= 2 ) ' );
out_opcode( op_uadd );
end;
out_op_int( op_uadhw, -1 );
out_op_int( op_rechw, 8 );
out_opcode( op_umod );

out_opcode( op_uadd );

out_op_int( op_stvlw, dope_start );

out_op_int( op_stnhb, 2 ); context_eval( -2 );

end; (* packed *)

end; (* array1 template *)

xarray2template: (* static index, dynamic comp *)
begin

first := in_integer;
last  := in_integer;
allign := in_integer = 1;

out_op_int( op_rechw, first );
out_op_int( op_rechw, last  );
out_op_int( op_stvld, dope_start + 2 );

with template_v do
begin
out_opcode( op_load [ word_typ, access ] );
if access = i_frame then
out_p_int( c.niv - niv );
out_p_int( offset );
end; (* with *)

if allign then out_make_top_even;

out_opcode( op_revpw );
out_op_int( op_stvlw, dope_start + 6 );

out_op_int( op_rechw, last - first + 1 );
out_opcode( op_umul );
out_op_int( op_stvlw, dope_start );

end; (* array2 template *)

xarray3template: (* dynamic index, dynamic comp *)
begin

get_niv_offset( template1_v );
allign := in_integer = 1;

with template1_v do
begin
out_opcode( op_load [ double_typ, access ] );
if access = i_frame then
out_p_int( c.niv - niv );
out_p_int( offset + 2 );
end; (* wiht template1 *)
out_op_int( op_stvld, dope_start + 2 );

with template_v do
begin
out_opcode( op_load [ word_typ, access ] );
if access = i_frame then
out_p_int( c.niv - niv );
out_p_int( offset );
end; (* with template *)
if allign then out_make_top_even;
out_opcode( op_revpw );
out_op_int( op_stvlw, dope_start + 6 );

compute_number_of_elemnts( dope_start );
out_opcode( op_umul );
out_op_int( op_stvlw, dope_start );

end; (* array3 template *)

end; (* case token of *)

get_token;

end; (* array 1, 2, 3 template *)


xrecordtemplate :
begin

size := in_integer; (* size of static part *)

get_niv_offset( template_v );

out_op_int( op_rechw, size );
with template_v do
begin
out_opcode( op_load [ word_typ, access ] );
if access = i_frame then
out_p_int( c.niv - niv );
out_p_int( offset );
end; (* with template v *)
out_opcode( op_uadd );

get_token;

while token <> xendtemplate do
begin

case token of

xincfield: begin
out_op_int( op_uadhw, 1 );
get_token;
end; (* incfield *)

xfieldsize, xdynfieldsize :
begin

allign := in_integer = 1;
dope_start := in_integer;  (* field template *)

if allign then out_make_top_even;
(* assign to field template *)
out_opcode( op_revpw );
out_op_int( op_stvlw, dope_start );

if token = xfieldsize then
begin
size := in_integer;
if size <> 0 then
out_op_int( op_rechw, size );
end
else
begin
size := -1;  (* <> 0 !!! *)

get_niv_offset( template_v );
with template_v do
begin
out_opcode( op_load [ word_typ, access ] );
if access = i_frame then
out_p_int( c.niv - niv );
out_p_int( offset );
end; (* with template v *)
end;

if size <> 0 then
out_opcode( op_uadd );

get_token;

end ; (* field size, dyn field size *)
end
otherwise


dyn_type_declaration;

end; (* while  *)

out_op_int( op_stvlw, in_integer );   (* record template *)
get_token;

end; (* record template *)

end
otherwise
if token <> xenddecl then
begin (* must be dynamic subrange type definition *)
(* ---> expr ---> expr ---> subdef( offset )  ---->   *)

find_exprs(  (* load expr1 and expr2  *) var_val_v );

(* initialize template *)
out_op_int( op_rechw, 2 );
if token <> xsubdef then error ( pass4code_error );
dope_start := in_integer;

out_op_int( op_stvlw, dope_start );
out_op_int( op_stvlw, dope_start + 4 );
out_op_int( op_stvlw, dope_start + 2 );
get_token;

end; (* subdef .... *)

end ; (* dyn type declaration *)



procedure find_sys_init( var ref_count : integer; var dyn_refs : boolean );

var 
type_o : integer;
kind, w_offset, offset, number, size, lower, upper : integer;
stack_save : integer;
va, dope_v, template_v : varaddr_descr;


procedure component_init( kind, offset : integer; var ref_count : integer );
(* kind = 1 <=> offset is local frame address of variable to initialize,
kind = 2  <=> (offset = 0) and address on top of stack  *)

var
new_kind, new_offset, refs : integer;



procedure  code_array_init(dynamic : boolean; kind, offset, w_offset, lower, upper, size : integer;
                        var ref_count : integer; templ_v : varaddr_descr );

var
refs : integer;

procedure load_from_template ( template_offset : integer );
begin
with templ_v do
begin
out_opcode( op_load [ word_typ, access ] );
if access = i_frame then
out_p_int( c.niv - niv );
out_p_int( offset + template_offset );
end; (* with *)
end; (* load from template *)


begin

out_nl;  out_nl;
out_token (zbegin);
out_p_id (id_arrayrep);
out_p_id (id_index_store);
out_token (zendlist);
out_comment( '   initialize an array. ' );
out_nl;  out_nl;
(* pre condition:  lower  <=  upper   !!!   *)

if kind = 1 then
begin

out_opcode( op_reald );
out_start_param;  out_integer( offset );
kind := 2; offset := 0;


end;
if dynamic then
load_from_template ( 2 (* lower bound *) )
else
begin

out_opcode( op_rechw );
out_start_param;  out_integer( lower );
end;

out_op_id( op_jmprw, id_index_store ); (* do not count first time *)

out_label( id_arrayrep );

out_op_int( op_uadhw, 1 );
out_label( id_index_store );


out_opcode (op_stvlw);
out_start_param;  out_integer (w_offset);

out_opcode( op_revpd );
get_token;

component_init( kind, offset, refs );

if dynamic then
begin
load_from_template( 6 (* size *) );
out_opcode( op_uadd );
end
else
begin

out_opcode( op_reasd );
out_start_param;  out_integer( size );
end;
out_comment( '   addr := addr + size  . ' );

out_opcode( op_revlw );
out_start_param;  out_integer (w_offset);

out_opcode( op_revpw );
if dynamic then
load_from_template( 4 (* upper bound *) )
else
out_op_int( op_rechw, upper );

out_opcode( op_ge );
out_comment(' i >= upper ? ' );

out_op_id( op_jmzeq, id_arrayrep );
out_comment(' if i < upper then goto arrayrep ' );


out_opcode( op_stnhb );   context_eval (-6);
out_start_param;  out_integer(6);

out_nl;  out_nl;
out_token (zend);
out_nl;  out_nl;
if dynamic then
ref_count := refs  (* <> 0 if refs defined  *)
else

ref_count :=  refs * ( upper - lower + 1 )


end  (* code array init   *);

begin (* component init *)

ref_count := 0;

case token of

xvarinit :
begin

type_o := in_integer;
code_initvar( kind, offset, type_o, ref_count );
get_token;

end; (* var init *)


xpoolinit :
begin

number := in_integer;
size := in_integer;

code_allocpool ( kind, offset, number, size );
get_token;
 
end; (* pool init *)

xfieldinit,
xdynfieldinit : begin
repeat
if kind = 2 then
out_opcode( op_revpd );

case token of

xfieldinit :
begin
new_offset := offset + in_integer;
new_kind := kind;

end; (* field init *)

xdynfieldinit :
begin

if kind = 1 then
begin
out_op_int( op_reald, offset );
new_kind := 2; new_offset := 0;
end
else
begin 
new_kind := kind; new_offset := offset;
end; (* kind = 2 *)
get_niv_offset( template_v );
with template_v do
begin
out_opcode( op_load [ word_typ, access ] );
if access = i_frame then
out_p_int( c.niv - niv );
out_p_int( offset );
end; (* with template v *)
out_opcode( op_uadd );

end; (* dyn field init *)
end (* case ... *)
otherwise
error ( pass4code_error );


get_token;
component_init( new_kind, new_offset, refs );
ref_count := ref_count + refs;

until token = xendinitfields;

get_token;

if kind = 2 then
begin
out_op_int( op_stnhb, 4 ); context_eval( -4 );
end;


end; (* field init and dyn field init *)


xarrayinit :
begin

w_offset := in_integer;
lower := in_integer;
upper := in_integer;
size := in_integer;

code_array_init( token = xarraydyninit, kind, offset, w_offset, lower, upper, size,
 refs, dope_v );
ref_count := ref_count + refs;

end; (* array init *)


xarraydyninit :
begin

w_offset := in_integer;
get_niv_offset( dope_v );
code_array_init( token = xarraydyninit, kind, offset, w_offset, 0, 0, 0, refs, dope_v);
ref_count := ref_count + refs;
dyn_refs := dyn_refs or ( refs > 0 );

end; (* array dyn init *)

end (* case *)
otherwise  error(pass4code_error );


end; (* component init *)





begin (* start of: find sys init *)
offset := in_integer;
if token = xsysinit then 
begin
kind := 1;
end
else
begin
out_op_int( op_revld, offset );
kind := 2;
offset := 0;
end;
get_token;
component_init( kind, offset, ref_count );

if (c.work <> 0) or (c.stack_size <> 0) then evalstack_error;

end; (* find sys init *)





procedure  find_block (outermost_level: boolean; param_length : integer; name : identifier );
type
skip_modes = (skip, dont_skip, end_skip, end_skip_block);

var
i, refcount, refs : integer;
var_length, proc_parlength, param_count,
roulix, rouniv : integer;
niv_pd, offset_pd : integer;
old_default_appetite : integer;
old_c : context;
external_pr : boolean;
name_pd : identifier;
line_no : integer;
local_dyn_refs,
end_init: boolean;
begin_line : integer;
jump_state : skip_modes; (* defines current state *)
pending_entry: boolean; (* true, when entry-point not defined yet *)
template_v : varaddr_descr;
dyn_var_offset : integer;
dyn_yes_or_no : boolean;

procedure skip_around (jump: skip_modes);
begin
if jump <> jump_state then
begin
if jump = skip then
begin
out_nl;
out_token (zbegin);
out_identifier (id_continue);
out_token (zendlist);
out_op_id (op_jmprw, id_continue);
end
else
if pending_entry then
begin
pending_entry := false;
(* define the entry-point *)
if outermost_level or (roulix = -1) then
out_label (id_entry);
if roulix <> -1 then
out_lix_label (r_name, roulix);

(* generate a prolog for the body *)
if prolog_yes or (roulix <> -1) then
begin
if old_create and (roulix = -1) then
out_op_int (op_renhb, param_length); (* move past inc-descr and params *)
(* insert link to line-table *)
out_op_id (op_reaad, id_linetab);
if roulix = -1 then
out_op_id (op_stvgd, id_plinetab)
else
out_op_id (op_stvld, id_rlinetab);
(* initialize max-stack register *)
if roulix = -1 then (* process body *)
code_set_maxstack (id_bonappetite);
(* allocate room for local variables *)
out_op_id (op_renhb, id_appstat);
out_nl;
end; (* prolog *)
end (* pending entry *)
else
begin
if jump <> end_skip_block then
out_label (id_continue);
if jump <> end_skip then
begin
out_nl;
out_token (zend);
end;
if jump = end_skip_block then
jump := dont_skip;
end;

jump_state := jump;
end; (* change of jumpstate *)
end; (* procedure skip-around *)

begin (* body of find block *)

if (token = xfunc) or (token = xproc) then
begin
roulix := in_integer;
in_identifier (name);
param_length := in_integer;
get_token;
if outermost_level then
with descr do
begin
exception_point := '0';
exit_point      := '0';
end;
end
else
roulix := -1;  (* i.e. process *)
if token <> xblock then error (pass4code_error);

line_no := in_line_no;
rouniv := in_integer;
get_token;

(* declare global-labels, at outermost level *)
if outermost_level then
begin
out_token (zbegin);
out_p_id (id_entry);
out_p_id (id_exit);
out_p_id (id_exception);
out_p_id (c_name); out_char ('#');
out_p_id (e_name); out_char ('#');
out_p_id (r_name); out_char ('#');
out_p_id (l_name); out_char ('#');
out_token (zendlist);
out_nl;
end;

(* two complete different bodies are recognized: *)
(*   1. code-bodies, i.e. 'beginbody'            *)
(*   2. normal-bodies, i.e. pascal80-generated   *)

if token = xbegincode then
begin (* code-body *)
(* make proper changes to 'descr' *)
i := in_integer;
if roulix <> -1 then (* only functions and procedures may be open-routines *)
if outermost_level and openroutine_yes then
with descr do
begin
entry_point := '0';
appetite    := i;
if kind = 2 then kind := 4
else if kind = 3 then kind := 5;
out_nl;
out_token (zoption);
out_integer (6);  (* pass no *)
out_integer (12); (* option = closed or open body *)
out_integer (0);  (* value = open body *)
out_char('.');    (* end of option *)
end
else
begin (* coderoutine must be closed anyway *)
out_nl;
out_lix_label (r_name, roulix);
end;
(* copy the code *)
out_nl;
get_token;
while token = xcodeline do
begin
for i := in_integer downto 1 do out_char (chr(in_integer));
out_nl;
get_token;
end;
skip_token (xendcode);
end (* code-body *)
else
begin (* normal-body *)

old_c := c;

with c do
begin

niv := rouniv;
stack_size := 0;
max_stack_size := 0;
work := 0;
max_work := 0

end;

(* declare routine-labels *)
out_nl;
out_token (zbegin);
out_p_id (id_appeval);
out_p_id (id_appstat);
out_p_id (id_work);
out_p_id (id_linetab);
out_token (zendlist);
out_nl;

refcount := 0;
local_dyn_refs := false;
dyn_yes_or_no := false;
end_init := false;
jump_state := skip;
pending_entry := true;

if outermost_level and (roulix = -1) then
skip_around (dont_skip);  (* outermost process must start immediatly *)

repeat
case token of
xextproc,
xextfunc:
find_ext_routine;
xproc,
xfunc:
begin
skip_around (skip);
find_block (false, 0-0-0, '******');
end;

xinitialize,
xextexception,
xexception :
begin
skip_around (dont_skip);
find_init;
end;


xsysinit,
xsysdyninit:
begin

skip_around( dont_skip );
find_sys_init( refs, local_dyn_refs );
refcount := refcount + refs;

end; (* sysinit and sysdyninit *)



xprocess,
xextprocess :
begin

external_pr := token = xextprocess;

(* declare inter-process labels *)
out_nl;
out_token (zbegin);
out_p_id (id_param);
out_p_id (id_procinf);
out_p_id( id_default_appetite );
out_p_id (id_name);
out_token (zendlist);

skip_around (skip);
out_comment( '   jump across the process declaration. ' );
out_nl;   out_nl;

offset_pd := in_integer;

in_identifier( name_pd );

if not ( external_pr ) then
begin
proc_parlength := in_integer

end;

(*  copy the parameter description into a constant block:  *)

param_count := in_integer;
out_label (id_param);
out_tab (15); out_token (zconst);
out_integer( 4 * param_count + 2 );
out_nl;   out_tab( 20 );   out_integer( param_count );

for i := 1 to param_count do
begin
get_token;  (* skip: xparamtype *)

out_nl;   out_tab( 20 );
out_integer( in_integer );
out_char (',');
out_integer( in_integer )

end;

out_nl;
out_tab (15); out_token (zend);
out_nl;

if not ( external_pr ) then
begin
out_token (zbegin);
out_p_id (id_entry);
out_p_id (id_exception);
out_p_id (id_exit);
out_token (zendlist);
out_label (id_procinf);
out_token (zconst); out_integer (16);
out_nl;  out_token (dollar_a);  out_p_id (id_entry);
out_nl;  out_token (dollar_a);  out_p_id (id_exception);
out_nl;  out_token (dollar_a);  out_p_id (id_exit);
out_nl;  out_token (dollar_i);  out_p_id( id_default_appetite);
out_nl;  out_token (dollar_i);  out_p_int (proc_parlength);
out_nl;
out_token (zend);
out_nl;

end;

if not ( external_pr ) then
begin
out_label (id_name);
out_token (zconst);  out_p_int (12);

for i := 1 to 12 do
begin

if ( i mod 2 ) = 1 then
begin
out_nl;   out_tab( 20 )
end
else
out_char (',');

out_token (dollar_b);

if i <= c_size_identifier then
out_integer( ord( name_pd[ i ] ) )
else
out_integer( ord( ' ' ) )

end (*  i  ....  *);
out_nl;
out_token (zend);
out_nl

end;

(*  insert the body of the process declaration:  *)

get_token;
if not ( external_pr ) then
begin
old_default_appetite := descr.default_appetite;
descr.default_appetite := 0;
find_block (false, proc_parlength, name_pd);
out_def( id_default_appetite );
out_integer( descr . default_appetite );

descr . default_appetite := old_default_appetite;
out_nl;
out_token (zend);  out_comment ('end of internal process body');
end;

(*  generate code for the initialization of the Process Descriptor:  *)
skip_around (end_skip);
out_comment( '   initialize the fields in the Process Descriptor. ' );

out_opcode( op_rechw );
out_start_param;   out_integer( 0 );
out_opcode( op_stvgw );
out_start_param;   out_integer( offset_pd + pd_count );

out_op_id (op_reaad, id_param);
out_opcode( op_stvgd );
out_start_param;   out_integer( offset_pd + pd_param );

out_opcode( op_rechw );
out_start_param;
if external_pr then out_integer( 0 )
else out_integer( 1 );
out_opcode( op_stvgw );
out_start_param;   out_integer( offset_pd + pd_linked );

if not ( external_pr ) then
begin
out_op_id (op_reaad, id_procinf);
out_opcode( op_stvgd );
out_start_param;   out_integer( offset_pd + pd_procinf )

end;


if not ( external_pr ) then
begin

out_opcode( op_reagd );
out_start_param;   out_integer( offset_pd + pd_name );
out_op_id (op_reaad, id_name);
out_opcode( op_rechw );
out_start_param;   out_integer( 12 );
out_opcode (op_moveg);

end;

skip_around (end_skip_block);  out_comment ('end ..continue.. block');
out_nl;
out_token (zend);  out_comment ('end of internal process init');
out_nl;

end;


xarray1template, xarray2template, xarray3template,
xrecordtemplate :
begin
skip_around( dont_skip );
 dyn_type_declaration;
end;


xallocdynvar :
begin
skip_around( dont_skip );

dyn_var_offset := in_integer;  (* local frame adress of pointer to the variable *)

out_opcode( op_reaxd );  (* get last used *)
out_op_int( op_reasd, 1 ); (* even start address *)

out_op_int( op_stvld, dyn_var_offset ); (* initialize the pointer *)

(* reserve stack space *)

get_niv_offset( template_v );
with template_v do
begin
out_opcode( op_load [ word_typ, access ] );
if access = i_frame then
out_p_int( c.niv - niv );
out_p_int( offset );
end; (* with *)

out_make_top_even;
out_opcode( op_renpb );
dyn_yes_or_no := true;

get_token;

end; (* alloc dyn var *)




end (*  case in_token of ......  *)

otherwise
if token <> xenddecl then
begin
skip_around( dont_skip );
dyn_type_declaration;
end
else
end_init := true;
until end_init;

skip_token (xenddecl);

(*  find statements:  *)

begin_line := in_line_no;

skip_around (dont_skip);
find_statement;

(*  find the appetite of the block:  *)

var_length := in_integer;

(*  generate the epilog of the block, depending on process or not:  *)

if roulix <> -1 then
begin (* function or procedure *)
if local_dyn_refs or (refcount > 0) then
code_ref_remove (refcount, local_dyn_refs);
out_opcode (op_pexit);
end
else
begin (* process *)

out_nl;  out_label( id_exit );

if epilog_yes then code_exit;

out_nl;  out_label( id_exception );

code_exception;

end; (* epilog of process *)

(*  define 'work' and the appetite symbols of the block:  *)

out_def( id_work );  out_integer( param_length + var_length - 1 );

out_def( id_appstat );
out_integer( var_length + c.max_work );

out_def( id_appeval );
out_integer( c.max_stack_size );

(*  print a line in the summary :  *)

if roulix <> -1 then
param_length := 0; (* don't include routine params in appetite *)

with descr do
default_appetite := default_appetite + ( var_length + c.max_work + 
  c.max_stack_size + param_length ) div 2;  (* words !! *)
mess_summary_line( name, line_no, begin_line, in_line_no,
 var_length + c.max_work + c.max_stack_size + param_length, dyn_yes_or_no ,
ord( roulix = -1 ) (* if  process *) * descr . default_appetite );


(*  generate the constant section of the block:  *)

find_constants;

(*  generate the line tab. header :  *)

out_nl;
out_label( id_linetab );
code_line_tab_header( name );
(* output an end-of-block *)
out_nl;
out_token (zend);  out_comment ('end of body');
if (c.work <> 0) or (c.stack_size <> 0) then evalstack_error;

c := old_c;

end; (* closed routine *)

if outermost_level then
begin
out_nl;
descr_end;
end;

(* skip endblock-parameters *)
if token <> xendblock then error (pass4code_error);
i := in_integer;
i := in_integer;
get_token;

end; (* find_block *)



procedure find_program;

var
p, param_length : integer;

begin

(* skip environment-declarations *)
while (token = xextproc) or (token = xextfunc) do
find_ext_routine;

repeat

case token of
xmodule:
begin
in_identifier (descr.name);
param_length := 0;
end;
xprocess:
begin
(* skip: offset *)
p := in_integer;
in_identifier (descr.name);
param_length := in_integer;
end;
end otherwise error (pass4code_error);

(* input and store the parameter list *)
descr.no_of_params := in_integer;
if descr.no_of_params > descr_max_params then
error (param_number);
for p := 1 to descr.no_of_params do
begin
get_token;
if token <> xparamtype then error (pass4code_error);
with descr.param [ p ] do
begin
kind := in_integer;
size := in_integer;
end;
end;

with descr do
begin
entry_point     := id_entry;
exit_point      := id_exit;
exception_point := id_exception;
default_appetite := 0;
appetite        := param_length;
end;

get_token;
case token of
xproc:
descr.kind := 2;
xfunc:
descr.kind := 3;
end
otherwise descr.kind := 1;

find_block (true, param_length, descr.name);

until token = xeom;

out_nl;
out_token (zend);

end; (* find_program *)




procedure  find_std_call (var v:varvalue_descr);

var
i, no, limit : integer;

begin

no := in_integer;

if ( no = xsucc ) or ( no = xpred ) then
limit := in_integer;

(* read the arglist by hand... *)
get_token;
if token <> xvarparam then error (pass4code_error);
get_token;
repeat
case token of
xaddr:
begin
i := in_integer; i := in_integer;
end;
xindaddr: ;
end otherwise error (pass4code_error);
get_token;
until token = xvalueparam;

if in_integer <> 2 (* wordsize *) then error (compiler_error);
get_token;
find_exprs(v);
if v.kind <> 1 then error(compiler_error);

case no of
xord,
xchr: ;

xsucc,
xpred:
begin

out_nl;  out_nl;
out_token (zbegin);
out_p_id (id_sucpred);
out_token (zendlist);

if no = 2 then
out_comment( '   start of std. function :  succ . ' )
else
out_comment( '   start of std. function :  pred . ' );

out_opcode( op_revpw );

out_opcode( op_rechw );
out_start_param;  out_integer( limit );

out_opcode( op_eq );

out_op_id  (op_jmzeq, id_sucpred);

if no = 2 then
code_exc_trigger( c_exc_succ)
else
code_exc_trigger( c_exc_pred);

out_label (id_sucpred);
if no = xsucc then
out_op_int (op_uadhw, 1)
else
out_op_int (op_uadhw,-1);

out_nl;
out_token (zend);
end;
end otherwise error(pass4code_error);

end (*  find_std_call  *);



procedure  find_arglist;
(* note: token undef at entry !! *)

var
type_l, size_l : integer;
v_r : varvalue_descr;
v_l : varaddr_descr ;
end_arglist : boolean;

begin

end_arglist := false;
get_token;
repeat
case token of
xvalueparam:
begin

type_l := in_integer;

if ( type_l = 5 ) or ( type_l = 6 ) then
size_l := in_integer
else
if type_l = 4 then  size_l := 4 else size_l := 2;

get_token;
find_exprs( v_r);

if v_r.kind = 2 then
begin

if type_l <> 5 then error(pass4code_error);

if odd( size_l ) then size_l := size_l + 1;

if size_l <= 4 then
begin
out_opcode (op_load [ size_l, s_frame ] );
out_start_param;  out_integer (0);
end

else

begin

out_opcode( op_rechw );
out_start_param;  out_integer( size_l );

out_opcode( op_revsm );  context_eval( size_l )

end;

end

else
if type_l = 6 then
begin

if v_r.size <> ( size_l + 2 ) then
begin

if v_r.size > 0 then
code_stat_to_dyn( v_r.size );

out_opcode( op_rechw );
out_start_param;  out_integer( size_l );

out_opcode( op_setad );

code_dyn_to_stat( size_l + 2 )

end;

out_opcode( op_stnhb );   context_eval (-2);
out_start_param;  out_integer( 2 )

end

else
if v_r.size <> size_l then
error(pass4code_error);
end;
xvarparam:
begin
get_token;
find_varaddr (v_l);
load_address (v_l, true);
end;

end
otherwise end_arglist := true;
until end_arglist;

end  (* find_arglist *);







procedure  find_while;

var  v: varvalue_descr;

begin

out_nl;
out_token (zbegin);
out_p_id (id_whrep);
out_p_id (id_whexit);
out_token (zendlist);
out_comment( '   start of while_statement. ' );

out_label( id_whrep );

get_token;
find_expr( v);
if operand_situation = after_short_const then
begin (* optimize on 'while true' *)
if v.val = value_false then
out_op_id (op_jmprw, id_whexit); (* skip on: 'while false' *)
(* don't test on: 'while true' *)
end
else
out_op_id (op_jmzeq, id_whexit);
out_comment( '   exit from while_statement. ' );

skip_token (xwhileexpr);
find_statement;
skip_token (xendwhile);

out_op_id (op_jmprw, id_whrep);
out_label (id_whexit);
out_nl;
out_token (zend);
out_comment( '   end of while_statement. ' );


end  (* find_while *) ;


procedure  find_lock;

var
v : varaddr_descr;
offset, size : integer;

begin
out_nl;
out_comment ('start of lock statement');
get_token;

find_varaddr( v);
load_address( v, true);
while (token <> xlockvar) and (token <> xlockdynvar) do
dyn_type_declaration;

if token = xlockvar then
begin
size := in_integer;
out_op_int( op_rechw, (size + 1) div 2 );
end
else
begin (* dyn lock var *)
get_niv_offset( v );
with v do
begin
out_opcode( op_load [ word_typ, access ] );
if access = i_frame then
out_p_int( c.niv - niv );
out_p_int( offset );
end; (* with *)
(* convert size from bytes to words *)
out_op_int( op_uadhw, 1 ); out_comment( ' convert to words ' );
out_op_int( op_rechw, 2 );
out_opcode( op_udiv );
end; (* dyn lock var *)

out_op_int (op_llock, in_integer);
out_opcode (op_lrese);

get_token;
find_statement;
skip_token (xendlock);

out_opcode( op_rechw );
out_start_param;  out_integer( 0 );

out_opcode( op_stvsf );
out_start_param;  out_integer( 0 );
out_start_param;  out_integer( c_field_lock );
out_comment( '   end of a lock_statement.' );

end  (*  find_lock  *);



procedure  find_with;

var
v : varaddr_descr;

begin
get_token;
find_varaddr( v);
load_address (v, true);
if token <> xwithvar then error(pass4code_error);

out_opcode( op_stvld );
out_start_param;  out_integer( in_integer );
out_comment( '   save the with_addr. ' );

get_token;
find_statement;
skip_token (xendwith);

end  (*  find_with  *);


procedure  find_exchange;

var
type_v, size : integer;
v1, v2 : varaddr_descr;

begin
get_token;
find_varaddr( v1);
load_address (v1, true);
if token <> xleft then error(pass4code_error);

type_v := in_integer;
if type_v <> 4 then  error(pass4code_error);
get_token;
find_varaddr( v2);
load_address (v2, true);
skip_token (xexchange);
out_opcode (op_cexch);

end  (*  find_exchange  *);




procedure  find_label;

begin
out_lix_label (l_name, in_integer);
get_token;

end  (* find_label *);


procedure  find_goto;

begin

out_opcode( op_jmprw );
out_start_param;  out_lix (l_name, in_integer);
get_token;

end  (*  find_goto  *);


procedure  find_if;

var 
v : varvalue_descr;

begin
out_nl;
out_token (zbegin);
out_p_id (id_ifelse);
out_p_id (id_ifexit);
out_token (zendlist);
out_comment( '   start of if_statement. ' );

get_token;
find_exprs( v);

if ( v.kind <> 1 ) or
   ( ( v.size >= 0 ) and ( v.size <> 2 ) ) then
error(pass4code_error);
out_op_id  (op_jmzeq, id_ifelse);

skip_token (xifexpr);
find_statement;

if token = xelse then
begin
(*    else_part :  *)
out_op_id  (op_jmprw, id_ifexit);
out_label (id_ifelse);

get_token;
find_statement;

out_label( id_ifexit )

end

else

begin
(*    no else_part   *)
out_label (id_ifelse);
end;
out_nl;
out_token (zend);
out_comment( '   end of if_statement. ' );

skip_token (xif);

end (*  find_if  *);



procedure  find_repeat;

var
v : varvalue_descr;

begin
out_nl;
out_token (zbegin);
out_p_id (id_rprep);
out_token (zendlist);
out_comment( '   start of repeat_statement. ' );

out_label( id_rprep );

get_token;
find_statement;

skip_token(xuntil);
find_expr( v);

if ( v.kind <> 1 ) or
   ( ( v.size >= 0 ) and ( v.size <> 2 ) ) then
error(pass4code_error);
if operand_situation = after_short_const then
begin (* optimize on 'repeat ... until false' *)
if v.val = value_false then
out_op_id (op_jmprw, id_rprep); (* don't test on: '... until false' *)
(* exit immediatly on ' ... until true' *)
end
else
out_op_id  (op_jmzeq, id_rprep);

out_nl;
out_token (zend);
out_comment( '   end of repeat_statement. ' );

skip_token (xendrepeat);

end  (*  find_repeat  *);





procedure  find_for;

var
v_l : varaddr_descr;
v_r : varvalue_descr;
offset, type_v, mode, w_offset, remainder : integer;

begin
get_token;
out_nl;
out_token (zbegin);
out_p_id (id_forrep);
out_p_id (id_forstore);
out_p_id (id_forexit);
out_token (zendlist);

find_varaddr( v_l);
(* let intermidiate_frame be indirect-addressed *)
if v_l.access = i_frame then
load_address( v_l, true);

offset := in_integer;   w_offset := in_integer;   type_v := in_integer;

if ( type_v <> 1 ) and ( type_v <> 2 ) then
error(pass4code_error);

if v_l.kind <> addr then
begin
(* neither global nor local fram *)

out_opcode( op_revpd );

out_opcode( op_stvld );
out_start_param;   out_integer( offset );
out_comment( '   store addr. of the contr. var. ' );
end;

get_token;
find_exprs( v_r);
if ( v_r.kind <> 1 ) or ( ( v_r.size >= 0 ) and ( v_r.size <> 2 ) ) then
error(pass4code_error);

out_opcode( op_revpw );

get_token;
find_exprs( v_r);

if ( v_r.kind <> 1 ) or ( ( v_r.size >= 0 ) and ( v_r.size <> 2 ) ) then
error(pass4code_error);

out_opcode( op_revpw );

out_opcode( op_stvlw );
out_start_param;  out_integer(w_offset);
out_comment( '   save the limit value. ' );

mode := in_integer;
if ( mode <> 1 ) and ( mode <> 2 ) then
error(pass4code_error);

if mode = 1 then  out_opcode( op_le ) else  out_opcode( op_ge );
out_comment( '   compare the limit with the initial value . ' );
out_op_id  (op_jmzgt, id_forstore);
out_op_id  (op_jmprw, id_forexit);
out_label (id_forrep);

out_opcode ( op_uadhw );  (* increase or decrease *)
out_start_param;
if mode = 1 then out_integer (1)
else out_integer (-1);

out_label (id_forstore);
out_opcode (op_store [ type_v, v_l.access ] );
out_start_param;  out_integer( v_l.offset );

get_token;
find_statement;
skip_token (xendfor);

if v_l.access = s_frame then

begin

out_opcode( op_revld );
out_start_param;  out_integer( offset );
out_comment( '   increment the contr. var. ' );

out_opcode( op_revpd );

end;

out_opcode (op_load [ type_v, v_l.access ] );
out_start_param;  out_integer (v_l.offset);

out_opcode( op_revpw );

out_opcode( op_revlw );
out_start_param;  out_integer(w_offset);
if mode = 1 then
out_opcode ( op_lt )
else
out_opcode ( op_gt );
out_comment( '   check if limit is reached. ' );
out_op_id  (op_jmzgt, id_forrep);
out_label (id_forexit);

if v_l.access <> s_frame then
remainder := 2
else
remainder := 6;

out_opcode( op_stnhb );  context_eval( -remainder );
out_start_param; out_integer( remainder );

out_nl;
out_token (zend);
out_comment( '   end of for_statement. ' );


end  (*  find_for  *);



procedure  find_channel;

var
v : varaddr_descr;

begin
get_token;
out_op_id (op_revgb, id_level);  (* save oldlevel *)
find_varaddr( v);
load_address (v, true);
out_opcode (op_lrese);
out_opcode (op_revpd);

out_opcode( op_iocda );

out_opcode( op_csell );

skip_token (xchanvar);
find_statement;
skip_token (xendchannel);

out_opcode( op_rechw );
out_start_param;  out_integer( 0 );
out_op_int (op_stvsf, 0);
out_p_int (c_field_lock);

out_opcode( op_csell );  (* restore oldlevel *)

end  (*  find_channel  *);




procedure  find_case;

const
size_case_table = 30;

type
table_entry = record
first : integer;
last : integer;
x_index : integer;
end;

var
table : array [ 1 .. size_case_table ] of table_entry;
v_r : varvalue_descr;
first, last , contents_of_table : integer;
otherwise_found : boolean;


procedure  add_to_table( f, l : integer);
var
i,j : integer;
begin
if f > l then
error (case_label_error)
else
begin
i := contents_of_table + 1;

repeat
i := i - 1;
until (i = 0) or (table [ i ] . last < f);

if (i >= 0) and (i < contents_of_table) and (table [ i+1 ] . first <= l) then
error (case_label_error)
else
begin (* the new entry is ok, so insert it between 'i' and 'i+1' *)
if contents_of_table = size_case_table then
error (case_table_size);
for j := contents_of_table downto i+1 do
table [ j+1 ] := table [ j ];
contents_of_table := contents_of_table + 1;
with table [ i+1 ] do
begin
first := f;
last  := l;
x_index := contents_of_table;
end;
out_lix_label (x_name, contents_of_table);
end;
end;
end; (* procedure add-to-table *)


procedure  out_table;

var
t : table_entry;
i, j, min, max, next : integer;
position_found : boolean;

begin

(*  output the sorted table as a single constant :  *)
if contents_of_table <= 0 then
begin (* empty case-table, simulate inconsistent case-range! *)
min := 1;
max := 0;
end
else
begin
min := table [ 1 ] . first;
max := table [ contents_of_table ] . last;
end;

out_label( id_casetab );   out_tab( 15 );
out_token (zconst);   out_integer( ( max - min + 1 ) * 4 + 8 );
out_comment( '   start of case_jump table. ' );
out_nl; out_token (dollar_i); out_integer (min);
out_nl; out_token (dollar_i); out_integer (max);
out_nl; out_token (dollar_a); out_identifier (id_otherwise);


next := min;

for i := 1 to contents_of_table do
with table [ i ] do
begin

while next < first do
begin
out_nl; out_token (dollar_a); out_identifier (id_otherwise);
next := next + 1

end;

while next <= last do
begin
out_nl; out_token (dollar_a); out_lix (x_name, x_index);
next := next + 1

end

end;

out_nl;   out_tab( 15 );   out_token (zend);
out_comment( '   end of case_jump table. ' );

out_nl



end;

begin

contents_of_table := 0;
out_nl;
out_token (zbegin);
out_p_id (id_casetab);
out_p_id (id_otherwise);
out_p_id (id_caseexit);
out_p_id (x_name);  out_char('#');
out_token (zendlist);

get_token;
find_exprs( v_r);

if ( v_r.kind <> 1 ) or
   ( ( v_r.size >= 0 ) and ( v_r.size <> 2 ) ) then
error(pass4code_error);
out_op_id  (op_jmcht, id_casetab);

skip_token (xcase);

otherwise_found := false;

while  token <> xendcase do
begin

repeat 

case  token  of

xcaselabel :
begin

first := in_integer;
last := first;

add_to_table( first, last);

end;

xcaserange :
begin

first := in_integer;
last := in_integer;

if last < first then  error(case_label_error);

add_to_table( first, last);

end;

xotherwise :
begin

if otherwise_found then  error(pass4code_error);

otherwise_found := true;

out_label( id_otherwise );

end;

end

otherwise
error(pass4code_error);

get_token;

until ( token = xendcaselist );

get_token;
find_statement;
skip_token (xendcasestat);
out_op_id  (op_jmprw, id_caseexit);

end;


if not otherwise_found then
begin

out_label( id_otherwise );

code_exc_trigger( c_exc_case);
out_op_id  (op_jmprw, id_caseexit);

end;


out_table;
out_label (id_caseexit);
out_nl;
out_token (zend);

get_token;


end  (*  find_case  *);



procedure find_statement;
var
oldwork, oldstack : integer;
end_stat : boolean;
begin

end_stat := false;
repeat
oldwork := c.work;  oldstack := c.stack_size;
case token of
xassignstat:   find_assign;
xwhile:        find_while;
xproccall,
xextproccall,
xprocessparam: find_proc_call;
xlockstat:     find_lock;
xwithstat:     find_with;
xexchstat:     find_exchange;
xdeflix:       find_label;
xgoto:         find_goto;
xifstat:       find_if;
xrepeat:       find_repeat;
xforstat:      find_for;
xchannel:      find_channel;
xcasestat:     find_case;
end
otherwise end_stat := true;
if (c.work <> oldwork) or (c.stack_size <> oldstack) then evalstack_error;
until end_stat;
end;





procedure  find_varvalue( var  v:varvalue_descr);

var  type_v, first, number, size, niv, offset  : integer;
access : frame_kind;
     templ_v, va  : varaddr_descr;

begin

      find_varaddr( va);

      if va.kind = packed_arr then
      begin
         (*  push the value of an element in a packed array :  *)

          out_opcode( op_inprs );

          v.kind := 1;  v.size := 2

      end
      
      else

if token = xindvar then
      begin

         type_v := in_integer;

         if type_v = 3 then
         begin
first := in_integer;  number := in_integer;
if number = 8 then
begin (* optimize 8-bit fields as bytes *)
if first = 0 then
type_v := 1  (* left byte, don't change offset *)
else
if first = 8 then
begin  (* rigth byte, add one to offset *)
va.offset := va.offset + 1;
type_v := 1;
end;
end;
         end
         else
         if( type_v = 5 ) or ( type_v = 6 ) then  size := in_integer

else
if type_v = 7 then
begin
get_niv_offset( templ_v );
size := 0;  (* not used !!! *)
end;

         case type_v of

1, 2, 3, 4 :
begin

out_opcode (op_load [ type_v, va.access ]);

if va.access = i_frame then
begin
out_start_param;  out_integer( c.niv - va.niv )
end;

out_start_param;  out_integer( va.offset );

if type_v = 3 then
begin
out_start_param;  out_integer( first * 16 + first + number - 1 )
end;

v.kind := 1;
if type_v = 4 then v.size := 4 else v.size := 2

end;

   5, 7:    begin

            load_address( va, true);
            v.kind := 2;  v.size := size

         end;

   6:    begin

            load_address( va, true);
            out_opcode( op_rechw );
            out_start_param;  out_integer( size );

            out_opcode( op_revsm );  context_eval (size);
out_op_int (op_rechw, size);

            v.kind := 1;   v.size := size + 2

         end
end; (* case type_v *)
get_token;

end; (* xindvar *)


end  (*  find_varvalue  *);





procedure   find_varaddr( var  v: varaddr_descr);
var
     r_v: varvalue_descr;
     dope_v: varaddr_descr;
end_addr : boolean;


begin

case token of
xaddr:
get_niv_offset (v);
xcaddr:
   begin
      v.kind := stack_addr;    v.offset := 0;    v.access := s_frame;
      v.size := 0;

      out_opcode( op_reaad );
out_start_param;  out_lix (c_name, in_integer);
end;
end
otherwise error(pass4code_error);

end_addr := false;
repeat
get_token;
case token of

 xfield:

      begin
         v.offset := v.offset + in_integer
      end;


xdynfield :
begin

load_address( v, true );
get_niv_offset( dope_v );

with dope_v do
begin
out_opcode( op_load [ word_typ, access ] );
if access = i_frame then
out_p_int( c.niv - niv );
out_p_int( offset );
end; (* with *)
out_opcode( op_uadd );

end; (* dyn field *)


 xindexexpr:

      begin
load_address (v, false);

         get_token;
find_exprs( r_v);

case token of
xindex:
begin
get_niv_offset (dope_v);
load_address (dope_v, true);
end;
xcindex:
         begin

            out_opcode( op_reaad );
out_start_param;  out_lix (c_name, in_integer);
end;
end
otherwise error(pass4code_error);


         out_opcode( op_index )

        
      end  (*  t_indexexpr  *);

xindaddr:

      begin

out_opcode (op_load [ 4, v.access ] );

if v.access = i_frame then
begin
              out_start_param;   out_integer( c.niv - v.niv );
           end;
            out_start_param;  out_integer( v.offset );

         v.kind := stack_addr;   v.offset := 0;   v.access := s_frame;

      end   (*  t_pushinda  *)

end
otherwise end_addr := true;
until end_addr;

if token = xpackedarr then
begin
load_address (v, true);

      get_token;
find_exprs( r_v);

if token = xcindex then
begin

      out_opcode( op_reaad );
out_start_param;  out_lix (c_name, in_integer);
end
else
begin (* xindex *)
get_niv_offset( dope_v );
load_address( dope_v, true );
end;

      v.kind := packed_arr;   v.size := 0;

get_token;

   end


end   (*  find_varaddr  *) ;




procedure  find_init;

var
type_o : integer;
i : integer;
w_offset, offset, number, size, size_l, size_c, lower, upper : integer;
stack_save : integer;
va : varaddr_descr;



begin

stack_save := c.stack_size;

case token of

xinitialize :
begin
get_token;
find_varaddr( va);
case token of
xstrucinit:
begin

size := in_integer;
i    := in_integer;  (* lix *)

load_address( va, true);

out_opcode( op_reaad );
out_start_param;  out_lix (c_name, i);

out_opcode( op_rechw );
out_start_param;  out_integer( size );
out_opcode (op_moveg)
end;
xsimpleinit:
begin

type_o := in_integer;
i := in_integer;

out_opcode( op_rechw );
out_start_param;  out_integer( i );

if va.kind = addr then
begin

if va.niv <> c.niv then  error(pass4code_error);

if ( type_o = 9 ) or ( type_o = 1 ) then
out_opcode( op_stvlb )
else
if type_o = 2 then
out_opcode( op_stvlw )
else
error(pass4code_error);

out_start_param;  out_integer( va.offset )

end

else
if va.kind = stack_addr then
begin

if ( type_o = 9 ) or ( type_o = 1 ) then
out_opcode( op_stvsb )
else
if type_o = 2 then
out_opcode( op_stvsw )
else
error(pass4code_error);

out_start_param;  out_integer( va.offset )

end

else
error(pass4code_error);
end;
xsetinit:
begin

load_address( va, true);

size_l := in_integer;
i      := in_integer;  (*lix *)
size_c := in_integer;

out_opcode( op_reaad );
out_start_param;  out_lix (c_name, i);

out_opcode( op_rechw );
out_start_param;  out_integer( size_c );

out_opcode( op_revsm );  context_eval( size_c );
out_op_int (op_rechw, size_c);

if size_l <> size_c then
begin

code_stat_to_dyn( size_c + 2 );

out_opcode( op_rechw );
out_start_param;  out_integer( size_l );

out_opcode( op_setad );

code_dyn_to_stat( size_l + 2 )

end;

out_opcode( op_setst );  context_eval( - size_l )
end;
end otherwise error(pass4code_error);

end;

xextexception:
with exc_descr do
begin

state := 1;
internal := false;
key := in_integer;

end;

xexception :
with exc_descr do
begin

state := 1;
internal := true;
niv := in_integer;   lix := in_integer

end;

end  (*  case  token  of .......  *)

otherwise
error(pass4code_error);

if stack_save <> c.stack_size then  evalstack_error;

get_token;

end  (*  find_init  *);




procedure  find_processparam;

var
niv_1,
offset_1, offset_2, offset_3, offset_4,
stack_size, param_length : integer;

begin

get_token;  (* skip: xprocessparam *)
if token <> xvarpointer then error(pass4code_error);

niv_1 := in_integer;   offset_1 := in_integer;
offset_2 := in_integer;

if niv_1 = const_niv_0 then
out_opcode( op_reagd )
else
if niv_1 = c.niv then
out_opcode( op_reald )
else
begin
out_opcode( op_reaid );
out_start_param;  out_integer( c.niv - niv_1 )
end;
out_start_param;  out_integer( offset_1 );
out_comment( '   start of process param. list . ' );

out_opcode( op_stvld );
out_start_param;  out_integer( offset_2 );

out_opcode( op_reaxd );

out_opcode( op_reasd );
out_start_param;  out_integer( 1 );

get_token;
if token <> xtempointer then error(pass4code_error);

offset_3 := in_integer;

out_opcode( op_stvld );
out_start_param;  out_integer( offset_3 );

stack_size := c.stack_size;

find_arglist;

param_length := c.stack_size - stack_size;

if token <> xarglistsize then error(pass4code_error);

offset_4 := in_integer;

out_opcode( op_rechw );
out_start_param;  out_integer( param_length );

out_opcode( op_stvlw );
out_start_param;  out_integer( offset_4 );
out_comment( '   end of process param. list . ' );

get_token;
case token of
xproccall,
xextproccall:
find_proc_call;
xfunccall,
xextfunccall:
begin

find_call;
skip_token (xfcall);
end;
xprocessparam:
find_processparam;
end
otherwise error(pass4code_error);

out_opcode( op_stnhb );  context_eval( -param_length );
out_start_param;  out_integer( param_length );

skip_token (xendprocessparam);

end  (*  find_processparam  *);





(*       body of pass5:      *)

begin

(*  initialize the set of hard exceptions :  *)

exc_hard := [ 0 .. c_exc_max ];

(*     initialize pass5 options to the default values :   *)

prolog_yes := true;
epilog_yes := true;
compress_yes := true;
callpass6_yes := true;
statacc_yes := false;
summary_yes := true;
old_create := false;
openroutine_yes := true;

(*  initialize the pseudo classes:  *)

mess_summ_state := 0;  (* before heading *)
out_init;
in_init;
ext_init;
  stat_reset;  


(*      generate code for one program:      *)

find_program;

(*     terminate the pseudo classes:        *)
if statacc_yes then stat_print;


1:      (*     exit from fatal errors      *)

pass5_ok := pass5_ok and callpass6_yes;
eom;

end     (*  pass5  *);


(*    body of the program:     *)

begin

pass5( pass5_ok );

if pass5_ok then
if lambda_version < 3 then
replace ('pass6v2')
else
replace( 'platonpass6' )
else
writeln( '*** compilation terminated after pass5' )

end.


«eof»
DataMuseum.dk

RC3500

⟦074162b01⟧ TextFileVerbose

Derivation

TextFileVerbose
