{$O+,F+}
unit p2code;

interface
uses pscplm,files,mpaunit,sthunit,sthcom,sthp2,rtp86mpa;
(*** CONSTANTS ***)
const
pass2_version= 500; (* 100*main version + sub version *)
demanded_pass1_version= 5; (* demanded pass 1 version number *)
(***
demanded_pass1_sub_version= 0; (* least acceptable sub version number *)

(*
.    Main version numbers must be updated according to the version numbers
.    of the project plan. Sub version numbers are updated when the pass is 
.    changed. Demanded sub version number MUST be changed when the interface
.    between pass1 and pass2 is changed 
*)


(*** TYPES ***)
type
syntaxtype =
(
sactualparam,
scase, scompunit, sconst, sconstdecl, scontext,
sempty, sexpression,
sfield, sformallist, sforvar, sfunccall, sfunccalle, sfuncdecl,
sindex, sinitobj,
slevel, slock, slockbuf,
snull,
sopenfunccall, sopenfunccalle, sopenproccall,
sproccall, sprocdecl, sprogcall, sprogdecl,
sregion,
ssetlist, sshared, sstrucarrval, sstrucrecval,
stype, stypedecl, stypeid,
svar, svarfunc, svarprog,
swith
);


ptr_p2stack=^ p2stackelement;

p2stackelement=record
                 former,
                 next: ptr_p2stack;
                 syntaxkind: syntaxtype;
                 nodeaddress,
                 p2_typeref,
                 p2_listref: st_address;
                 (* special components *)
                 misc_field: integer;
                             (* svar, 1 if assign to function *)
                             (* stype, 2 if typeid *)
                 p2_specstruc: st_protect_type;
               end;


(***VARIABLES ***)
var

testpass2open,
test_stack,          (* booleans telling which of the different kinds of *)
test_out_2,           (* test output to produce *)
test_local,
test_pass1code : boolean;

p2stacktop,                            (* pointer to stacktop *)
p2stackbase: ptr_p2stack;              (* pointer to stackbottom *)

init_p2stackelement: p2stackelement;   (* well defined p2stack element used
                                       for initialization of new elements *)


before_assign,           (* indicates whether a function variable is used
*                 as a call of the function or it is for a function result *)
program_decl,            (* definition of a program heading *)
family_type_params,      (* set at TYPEDECL and reset at EDNTYPEDECL *)
declare_state,
in_lock_state,
local_declare_state,     (* indicating declaration within for-, lock- and with-statement *)
create_call,             (* indicate if a possible function call is a
*                           createcall                          *)
within_opencall,         (* indicate  openroutinecall   *)
global_level,
firstcontext,            (* true in first context false else *)
help_boolean,
set_result,
maybe_string_type,
is_string_Type,
maybe_set_type,
maybe_fam_type,
after_context: boolean;  (* true: in program part
                           false: in context part *)
new_comp_unit:boolean;
comp_unit,
comp_used_bit,
segment_nr: word;
opencount,               (* counting nested openroutinecalls **)
first_program_open,     (* start of opens at outermost program level *)
open_counter,           (* number of next open routine *) 
repetitive_counter,     (* number of nested repetitive statements *)
record_nest_counter,    (* number of nested record declarations *)
cur_block_level: integer;   (* determines current block level *)
token: codes;              (* holds the current pass1 code i.e.
                              the last code read from input *)
temp_token: codes;
current_labelscope: word;

erroraddress,
st2_start_search, (* start of backwards search chain inside current level,
*                    when searching for constants, types, variables, or shared
*                    elements during the declaration part handling *)
cross_addr,
st2_hlp_address,
st2_cur_address: st_address;
st2_hlp_ptr,
st2_cur_ptr: st_elemptr;
routine_specstruc,  (* holds special structures declared within current *)
(*                     routine declaration     *)
ill_shared_types, (* SHARED declarations must not contain process or chain *)
ill_routine_types, (* SHIELDED types except REFERENCE may not be declared 
                      in routines  *)
protected_types,  (* shielded or pointer *)
shielded_types: st_protect_type;

helpstr: string;
string_spix,
pred_spix,
succ_spix: spixrange;
help_specs: st_declaremode;
cross,compile_info: boolean;

procedure write_p2stack;
procedure p2_fatal_error(error_no: word);
procedure write_kind(skind: syntaxtype);
procedure write_specstruc(struc: st_protect_type);
procedure write_stacktop(push: integer);
procedure init_p2stack;
procedure push_p2stack;
procedure pop_p2stack;
procedure pushresult(operator: codes);
procedure decode_test_options;
function getcode: codes;
procedure getaddress(var addr: st_address);
procedure putaddress(addr: st_address);
procedure dump_cnull_and_check(addr:st_address);
procedure read_push_dump(token: codes; stoken: syntaxtype);
procedure read_push_dump_type(token: codes);
procedure dump_info(addr: st_address);
procedure initialize;
procedure std_context_init;
procedure original_node(var node_addr: st_address;
                        var node_ptr: st_elemptr);
function sametype(tl,tr: st_address): boolean;
function int_word_byte(node_addr: st_address): boolean;
function compatible(tl,tr: st_address): boolean;
function ordinaltype(code: codes): boolean;
function machinetype(code: codes): boolean;
function protectedtype(code: codes): boolean;
procedure begin_level_action;
procedure end_level_action;
procedure check_legal_param_type(param_ref, type_ref: st_address);
procedure routine_block_lookahead;
procedure push_opencall;
procedure bind_open;
procedure pop_opencall;
procedure copy_type(original_symb: st_address; var copy_symb: st_address);

implementation
(*** ROUTINES ***)

function btype(taddr: st_address; tptr: st_elemptr; tkind: codes):boolean;
forward;
function wtype(taddr: st_address; tptr: st_elemptr; tkind: codes):boolean;
forward;

procedure write_p2stack;
var
p2_ptr: ptr_p2stack;
begin
p2_ptr:= p2stackbase;
writeln(testoutput,'CONTENTS OF PASS2 STACK: ');
repeat
with p2_ptr^ do
begin
writeln(testoutput,'*********************************');
write(testoutput,'SYNTAXKIND: ');
write_kind(syntaxkind);
end;
p2_ptr:= p2_ptr^.next;
until p2_ptr= nil;
writeln(testoutput,'*********************************');
end;

procedure p2_fatal_error(error_no: word);
begin
if test_out_2 then 
write_p2stack;
fatal_error(pass2, error_no);
end; (* p2 fatal error *)


(*** P2 STACK ROUTINES***)


procedure write_kind(skind: syntaxtype);
begin
case skind of
sactualparam: writeln(testoutput, 'actualparam');
scase       : writeln(testoutput, 'case');
scompunit   : writeln(testoutput, 'compunit');
sconst      : writeln(testoutput, 'const');
sconstdecl  : writeln(testoutput, 'constdecl');
scontext    : writeln(testoutput, 'context');
sempty      : writeln(testoutput, 'empty');
sexpression : writeln(testoutput, 'expression');
sfield      : writeln(testoutput, 'field');
sformallist : writeln(testoutput, 'formallist');
sforvar     : writeln(testoutput, 'forvar');
sfunccalle,
sfunccall   : writeln(testoutput, 'funccall');
sfuncdecl   : writeln(testoutput, 'funcdecl');
sindex      : writeln(testoutput, 'index');
sinitobj    : writeln(testoutput, 'initobj');
slevel      : writeln(testoutput, 'level');
slock       : writeln(testoutput, 'lock');
slockbuf    : writeln(testoutput, 'lockbuf');
snull       : writeln(testoutput, 'null');
sopenfunccalle,
sopenfunccall: writeln(testoutput, 'openfunccall');
sopenproccall: writeln(testoutput, 'openproccall');
sproccall   : writeln(testoutput, 'proccall');
sprocdecl   : writeln(testoutput, 'procdecl');
sprogcall   : writeln(testoutput, 'progcall');
sprogdecl   : writeln(testoutput, 'progdecl');
sregion     : writeln(testoutput, 'region');
ssetlist    : writeln(testoutput, 'setlist');
sshared     : writeln(testoutput, 'shared');
sstrucarrval: writeln(testoutput, 'strucarrval');
sstrucrecval: writeln(testoutput, 'strucrecval');
stype       : writeln(testoutput, 'type');
stypedecl   : writeln(testoutput, 'typedecl');
stypeid     : writeln(testoutput, 'typeid');
svar        : writeln(testoutput, 'var');
svarfunc    : writeln(testoutput, 'varfunc');
svarprog    : writeln(testoutput, 'varprog');
swith       : writeln(testoutput, 'with')
else     writeln(testoutput, 'unknown syntax kind: ', ord(skind));
end;
end;

procedure write_specstruc(struc: st_protect_type);
var
step: protect_spec;
begin
if struc <> [] then
begin
writeln(testoutput);
write(testoutput, 'p2_specstruc: ');
for step := simpeltype to programtype do
if step in struc then
case step of
simpeltype:  writeln(testoutput, 'simpel');
xpackedtype: writeln(testoutput, 'packed');
pointertype:      writeln(testoutput, 'pointer');
mailboxtype: writeln(testoutput, 'mailbox');
referencetype:   writeln(testoutput, 'reference');
pooltype: writeln(testoutput, 'pool');
processtype: writeln(testoutput, 'process');
programtype: writeln(testoutput, 'program');
porttype: writeln(testoutput, 'port');
chaintype: writeln(testoutput, 'chain');
mailboxpointer: writeln(testoutput, 'mailboxpointer')
else
writeln(testoutput, 'unknown spec-struc.')
end; (* case *)
end;
end; (* output specstruc *)

procedure write_stacktop(push: integer);
begin
with p2stacktop^ do
begin
if (push=1) then
writeln(testoutput,
'********************STACKTOP before PUSH P2STACK******************')
else
if (push=0) then
writeln(testoutput,
'********************STACKTOP after POP  P2STACK******************')
else
writeln(testoutput,
'********************STACKTOP*************************************');
writeln(testoutput, 'linenumber: ', linenumber,'     token: ',ord(token));
write(testoutput,
'syntaxkind   : '); write_kind(syntaxkind);
write(testoutput,
'nodeaddress: ',nodeaddress.va_high: 3,nodeaddress.va_low: 4);
write(testoutput,
', p2-typeref: ',p2_typeref.va_high: 3,p2_typeref.va_low: 4);
writeln(testoutput);
write(testoutput,
', p2-listref: ',p2_listref.va_high: 3,p2_listref.va_low: 4);
if misc_field<>0 then
write(testoutput,
', misc_field   : ',ord(misc_field): 3);

if p2_specstruc <> [] then
write_specstruc(p2_specstruc)
else
writeln(testoutput);
end;
end; (* write stacktop *)


procedure init_p2stack;
begin
new(p2stackbase);
p2stackbase^:= init_p2stackelement;
with p2stackbase^ do
syntaxkind:= scompunit;
p2stacktop:= p2stackbase;
end; (* init_p2stack *)

procedure push_p2stack;
var
helpptr: ptr_p2stack;
begin
if test_stack then write_stacktop(1);
new(helpptr);
helpptr^:= init_p2stackelement;
helpptr^.former:= p2stacktop;
p2stacktop^.next:= helpptr;
p2stacktop:= helpptr;
end;

procedure pop_p2stack;
var
helpptr: ptr_p2stack;
begin
if p2stacktop <> p2stackbase then
begin
helpptr:= p2stacktop;
p2stacktop:= helpptr^.former;
p2stacktop^.next:= nil;
dispose(helpptr);
end
else 
begin
writeln('p2stack underflow');
p2_fatal_error(1);
end;
if test_stack then write_stacktop(0);
end; (* pop_p2stack *)


procedure pushresult(operator: codes);
(* pop the operands (type information nodes) and push the type of the expression *)
var
(* #begintest 
procname: string[12];
(* endtest# *)
tl,tr: st_address;
boo: boolean;
expr_kind: syntaxtype;
begin
(* #begintest 
procname:= 'pushresult  ';
(* endtest# *)
with p2stacktop^ do
begin
tl:= former^.p2_typeref; (* type of left operand *)
tr:= p2_typeref;         (* type of right operand *)
expr_kind:= syntaxkind;
end;
pop_p2stack; (* remove right operand *)
with p2stacktop^ do (* reuse the leftoperand element as result *)
begin
case operator of
ceq,cne,cle,cge,cgt,clt,cle,cin: 
(*type of expression is boolean *)
boo:= stdcode_to_address(cboolean,p2_typeref);

cadd,csub,cslash,cmul,cdiv,cmod,
(* type of expression is either word,byte or integer *)
(* in case of integer result left operand must be of kind integer *)
cand,cor,cxor: 
(* type of expression is either word byte or boolean *)
if code_of_address(tr)=cword then
p2_typeref:= tr;
(* all other cases tl equals type of expression so no action *)

cshift:; (* no action since tl equals type of expression *)

cerror: boo:= stdcode_to_address(cerror, p2_typeref)

else p2_fatal_error(6); (* pass2 inconsistency *)

end; (* case *)
if (syntaxkind<>expr_kind) or (expr_kind=svar) or (expr_kind = ssetlist) then
syntaxkind:= sexpression;
end; (* with *)
end; (* push result *)


procedure decode_test_options;
var
test2: integer;
begin
if testpass2open then 
begin
test2:= testpass2;
test_stack:= odd(test2); (* test bit0 *)
test2:= test2 div 2;
test_out_2:= odd(test2); (* test bit1 *)
test2:= test2 div 2;
(* test bit 2 *)
test2:= test2 div 2;
test_local:= odd(test2); (* test bit3 *)
test2:= test2 div 2;
test_pass1code:= odd(test2); (* test bit4 *)
end;

test2 := testpass2 div 256;
if odd(test2) and testpass2open (* test bit 8 *) then teststh:=true;
test2 := test2 div 2;
if odd(test2) (* test bit 9 *) then teststh:=false;
test2 := test2 div 2;
if odd(test2) and (original_testvmm>=0) (* test bit 10 *)
then testvmmupdate := true;
test2 := test2 div 2;
if odd(test2) (* test bit 11 *) then testvmmupdate:=false;
test2 := test2 div 2;
if odd(test2) and testpass2open (* test bit 12 *) then teststhsearch:=true;
test2 := test2 div 2;
if odd(test2) (* test bit 13 *) then teststhsearch:=false;


end; (* decode test options *)


function getcode: codes;
label 0; (* start of procedure, pseudo recursive call *)
var
nextinp: codes;
opt_val: word;
opt_dest: modulerange;
opt: option_tokens;
begin
0:
(* reads the next word of infile and converts it to a code i. e.
  next token *)
nextinp:= codes(get_byte);

case nextinp of
cnewline: 
begin
linenumber:= get_2_byte;
elementnumber:= 0;
put_byte(ord(cnewline));
put_2_byte(linenumber);
goto 0; (* skip to next code *)
end;

coption: 
begin
opt_dest:= modulerange(get_2_byte);
opt:= option_tokens(get_2_byte);
opt_val:= get_2_byte;
if opt_dest<>pass2 then
begin
if opt_dest=allpass then
begin
case opt of
versionpass1: begin
if (opt_val div 100 <> demanded_pass1_version) then
(**
 or (opt_val mod 100 < demanded_pass1_sub_version) then
**)
p2_fatal_error(5);
(* wrong pass1/pass2 pair *)
end;
sourceno_: begin
sourcenumber:= opt_val;
if call_options.savecode then opt_val := 1;
end
else
warning(pass2, 174);
(* unknown option *)
end; (* case *)
end (* all pass option *)
else
if (opt_dest=vmm) and (opt=test_) and testvmmupdate then
testvmm:= opt_val;

put_byte(ord(coption)); (* send option to next pass *)
put_2_byte(ord(opt_dest));
put_2_byte(ord(opt));
put_2_byte(opt_val);
end
else (* pass2 options *)
case opt of
test_: begin
testpass2:= opt_val;
decode_test_options;
end
else 
warning(pass2, 174);
(* unknown option *)
end; (* case *)

goto 0; (* skip to next code *)
end (* coption *)

else getcode:= nextinp;
end; (* case *)
end;

procedure getaddress(var addr: st_address);
begin
(* reads two words and converts them to an st_address *)
with addr do
begin
va_low:= get_2_byte;
va_high:= get_2_byte;
end;
end;


procedure putaddress(addr: st_address);
begin
(* convert an st_address to two words and write them to outfile *)
with addr do
begin
put_2_byte(va_low);
put_2_byte(va_high);
end;
end;

procedure dump_cnull_and_check(addr:st_address);
begin
(**** HHA
if not equal_addr(addr,st_mailboxtype_addr) then
if not equal_addr(addr,st_referencetype_addr) then
if not equal_addr(addr,st_pooltype_addr) then
if not equal_addr(addr,st_processtype_addr) then
if not equal_addr(addr,st_porttype_addr) then
if not equal_addr(addr,st_chaintype_addr) then
begin
st_retrievetype(addr,st2_cur_ptr);
if not protectedtype(st2_cur_ptr^.st_kind) then
errormsg(pass2,168);
end;
*****)
put_byte(ord(cnull));
putaddress(addr);
end;

procedure read_push_dump(token: codes; stoken: syntaxtype);
(* used to handle rule: *)
(* TOKEN(ST_ADDRESS)---> *)
(* when pass2code and pass1code are identical *)
(* and the only actions to be taken are: *)
(* read rule, push syntaxkind to stack,
increment element counter, and write rule *)
(* #begintest 
var
procname: string[12];
(* endtest# *)
begin
(* #begintest 
procname:= 'read push du';
(* endtest# *)
push_p2stack;
with p2stacktop^ do
begin
syntaxkind:= stoken;
getaddress(nodeaddress);
elementnumber:= elementnumber+1;
put_byte(ord(token));
putaddress(nodeaddress);
end;
end;


procedure read_push_dump_type(token: codes);
(* used to handle rule: *)
(* TOKEN(ST_ADDRESS)---> *)
(* when pass2code and pass1code are identical *)
(* and the only actions to be taken are: *)
(* read rule, push syntaxkind to stack, write code followed by address of
defining type (typeref of the read symbol *)
(* #begintest 
var
procname: string[12];
(* endtest# *)
begin
(* #begintest 
procname:= 're pu du typ';
(* endtest# *)
push_p2stack;
with p2stacktop^ do
begin
syntaxkind:= stype;
getaddress(nodeaddress);
put_byte(ord(token));
st_retrieve(nodeaddress, st2_cur_ptr);
if st2_cur_ptr^.st_kind=ctype then
begin
putaddress(st2_cur_ptr^.typeref);
p2_specstruc := st2_cur_ptr^.spec_struct;
end
else
putaddress(nodeaddress);
end;
end; (* read push dump type *)

procedure dump_info(addr: st_address);
begin
(*
  comm^:=sourcenumber; put(comm);
  comm^:=linenumber mod 256; put(comm);
  comm^:=linenumber div 256; put(comm);
  comm^:=addr.va_low mod 256; put(comm);
  comm^:=addr.va_low div 256; put(comm);
  comm^:=addr.va_high mod 256; put(comm);
  comm^:=addr.va_high div 256; put(comm);
*)
  blockwrite( comm, sourcenumber, 1);
  blockwrite( comm, linenumber, 2);
(*  blockwrite( comm, hi(linenumber), 1);*)
  blockwrite( comm,addr,4);
(*
  blockwrite( comm, lo(addr.va_low), 1);
  blockwrite( comm, hi(addr.va_low), 1);
  blockwrite( comm, lo(addr.va_high), 1);
  blockwrite( comm, hi(addr.va_high), 1);
*)

end;


(*** INITIALIZATION PROCEDURE ***)
procedure initialize;
begin
cross:=(call_options.listing=2) and (call_options.xref<>1);
compile_info:=true;
set_result:=false;
before_assign:= false;
global_level:= true;
cur_block_level:= context_level;
new_comp_unit:=false;
comp_unit:=0;
comp_used_bit:=0; (*last_comp_unit_bit;*)
segment_nr:=1;
after_context:= false;
create_call:= false;
opencount := 0;
within_opencall := false;
local_declare_state := false;
in_lock_state := false;
declare_state:= true;
family_type_params:= false;
test_stack := false;
test_out_2 := false;
test_local := false;
test_pass1code := false;
st2_start_search:= st_nilladdr;
open_counter:= 0; (* first open routine has number 0 *)
repetitive_counter:= 0; (* outside repetitive statements *)
routine_specstruc := [];
ill_shared_types:= [processtype, programtype, chaintype];
shielded_types:= [mailboxtype, referencetype, pooltype, processtype,
porttype, chaintype, programtype];
ill_routine_types:=shielded_types-[ referencetype ];
protected_types:= shielded_types+[pointertype,mailboxpointer];
if call_options.loadcode<=1 then
firstcontext := false
else
begin
firstcontext:= true;
st_dataarea_type_addr:= st_undeclared_addr;
st_buffer_type_addr:= st_undeclared_addr;
st_string_type_addr:= st_undeclared_addr;
end;
if not stdcode_to_address(cerror,erroraddress) then 
p2_fatal_error(7);
(* mismatch in stdnames *)
(** spix of string **)
helpstr:= 'STRING';

string_spix := st_spixofname(helpstr);



(** ad PRED AND SUCC **)
helpstr:= 'PRED';
pred_spix := st_spixofname(helpstr);

helpstr:='SUCC';
succ_spix := st_spixofname(helpstr);
(**  ****************** **)

with init_p2stackelement do
begin
syntaxkind:= sempty;
nodeaddress:= st_nilladdr;
p2_typeref:= st_nilladdr;
p2_listref:= st_nilladdr;
misc_field:= 0;
p2_specstruc := [];
former:= nil;
next:= nil;
end;

init_p2stack;

(* initalize test output booleans *)
testpass2open:=testpass2>=0;
decode_test_options;
if testpass2open then testvmm:= original_testvmm;

(* output version number option *)
put_byte(ord(coption));
put_2_byte(ord(allpass));
put_2_byte(ord(versionpass2));
put_2_byte(pass2_version);

end; (* initialize *)


procedure std_context_init;
(* called after processing of standard environment *)
type
pres_or_eras= (preserve_name, erase_name);
var
temp_addr: st_address;

procedure get_std_addr(obj_name: string;
var result_addr: st_address; erase: pres_or_eras);
(* Get spix of obj_name and search the associated st-object, return spix and
address. If erase equals erase_name then change the spix in the symbol table
to anonymousspix, making the name invisible for user programs *)
var
result_spix: spixrange;
begin

result_spix:= st_spixofname(obj_name);

result_addr:= st_nilladdr;
if not st_search(result_spix, result_addr, st2_cur_address, st2_cur_ptr) then
begin
elementspix:= result_spix;
writeln;
writeln(' ', obj_name, ' missing');
fatal_error(pass2, 7);
(* mismatch in stdnames *)
end
else
if erase=erase_name then
begin
st_get(result_addr, st2_cur_ptr);
st2_cur_ptr^.st_spix:= anonymousspix;
end;
end; (* get spix and address *)

begin
get_std_addr('CREATE', st_create_addr, preserve_name);
get_std_addr('PROGRAM_DESCRIPTOR', st_program_type_addr, erase_name);
get_std_addr('BTYPE', st_btype_addr, erase_name);
get_std_addr('WTYPE', st_wtype_addr, erase_name);
get_std_addr('PTYPE', st_ptype_addr, erase_name);
get_std_addr('RTYPE', st_rtype_addr, erase_name);
get_std_addr('STRING', st_string_type_addr, preserve_name);
{$IFDEF RTP86}
get_std_addr('DATAAREA', st_dataarea_type_addr, preserve_name);
get_std_addr('BUFFER', st_buffer_type_addr, preserve_name);
{$ENDIF}
(*** st_emptyset_addr  initialiseret af pass0  **)

(** Short cutting of the following std-names:        **)
(* MAILBOX, POOL, PROCESS, REFERENCE, CHAIN           *)

(* MAILBOX *)
get_std_addr('MAILBOX_', temp_addr, erase_name);
temp_addr := st2_cur_ptr^.typeref;
get_std_addr('MAILBOX', st_mailboxtype_addr, preserve_name);
st_get(st_mailboxtype_addr, st2_cur_ptr);
st2_cur_ptr^.typeref := temp_addr;

(* POOL *)
get_std_addr('POOL_', temp_addr, erase_name);
temp_addr := st2_cur_ptr^.typeref;
get_std_addr('POOL', st_pooltype_addr, preserve_name);
st_get(st_pooltype_addr, st2_cur_ptr);
st2_cur_ptr^.typeref := temp_addr;

(* PROCESS *)
get_std_addr('PROCESS_', temp_addr, erase_name);
temp_addr := st2_cur_ptr^.typeref;
get_std_addr('PROCESS', st_processtype_addr, preserve_name);
st_get(st_processtype_addr, st2_cur_ptr);
st2_cur_ptr^.typeref := temp_addr;

(* REFERENCE *)
get_std_addr('REFERENCE_', temp_addr, erase_name);
temp_addr := st2_cur_ptr^.typeref;
get_std_addr('REFERENCE', st_referencetype_addr, preserve_name);
st_get(st_referencetype_addr, st2_cur_ptr);
st2_cur_ptr^.typeref := temp_addr;

(* CHAIN *)
get_std_addr('CHAIN_', temp_addr, erase_name);
temp_addr := st2_cur_ptr^.typeref;
get_std_addr('CHAIN', st_chaintype_addr, preserve_name);
st_get(st_chaintype_addr, st2_cur_ptr);
st2_cur_ptr^.typeref := temp_addr;

(* PORT *)
get_std_addr('PORT_', temp_addr, erase_name);
temp_addr := st2_cur_ptr^.typeref;
get_std_addr('PORT', st_porttype_addr, preserve_name);
st_get(st_porttype_addr, st2_cur_ptr);
st2_cur_ptr^.typeref := temp_addr;

end; (* std context init *)


(********* help procedures ******)

procedure original_node(var node_addr: st_address;
                        var node_ptr: st_elemptr);
begin
(* TOG , st_retrievetype to st_retrieve *)
st_retrieve(node_addr, node_ptr);
while node_ptr^.st_node_copy do
begin
node_addr := node_ptr^.st_family_ref;
st_retrieve(node_addr, node_ptr);
end;
end; (* original_node *)

function sametype(tl,tr: st_address): boolean;
(* checks if the two types denoted by the two st addresses *)
(* tl and tr are the same type *)
(* two types are said to be the same type if and only if: *)
(* a. both are the same predefined type.
(* b. both are specified as the same bound type name, or  *)
(* c. both are specified as a binding of the same parame- *)
(*    trized type name and the values of the actual para- *)
(*    meters are pairwise equal.                          *)

(* a and b is true iff tl=tr *)
(* c is true iff TYPE(tl)=TYPE(tr) and PARAM(tl)=PARAM(tr) *)
(*   where TYPE(X) denotes the st address of the family node   *)
(*   the address is stored in the node pointed out by x.       *)
(*   and PARAM(X) denotes the values of the parameter list.    *)
(*   The parameter checking must be done by pass3 !!!!!!!!!    *)

(*  maybe_string_type and maybe_fam_type are updated           *)

var
(* #begintest
procname: string[12];
(* endtest# *)
same : boolean;
is_family: boolean;

begin
(* #begintest
procname:= 'same type   ';
(* endtest# *)
maybe_string_type:=false;
maybe_fam_type:=false;
same:= equal_addr(tl,tr);

st_retrieve(tl, st2_cur_ptr);
if (st2_cur_ptr^.type_mode = bound_fam) or
   (st2_cur_ptr^.type_mode = open_fam) or
   (st2_cur_ptr^.type_mode = named_bound_fam) then
begin
   IF (st2_cur_ptr^.type_mode = named_bound_fam) THEN
     tl := st2_cur_ptr^.st_Family_Ref
   ELSE
     original_node(tl, st2_cur_ptr);
is_family:= true;
end else is_family:=false;
is_string_type:=equal_addr(st_string_type_addr,tl);

if not same then
begin
if is_family then
begin
st_retrieve(tr, st2_cur_ptr);
if (st2_cur_ptr^.type_mode = bound_fam) or
   (st2_cur_ptr^.type_mode = open_fam) or
   (st2_cur_ptr^.type_mode = named_bound_fam) then
begin
   IF (st2_cur_ptr^.type_mode = named_bound_fam) THEN
     tr := st2_cur_ptr^.st_Family_Ref
   ELSE
     original_node(tr, st2_cur_ptr);
end else is_family:=false;

if is_family then
begin
same := equal_addr(tl, tr);
maybe_string_type:=equal_addr(st_string_type_addr,tr);
maybe_fam_type:=not maybe_string_type;
end;
end;
end;
sametype:= same;
end;

function int_word_byte(node_addr: st_address): boolean;
var node_ptr: st_elemptr;
begin
  (* TOG !!! new rtp86 !!! , integer compatible with word and byte *)
  (* st_retrievetype(node_addr, node_ptr);
  if node_ptr^.st_kind=csubrange then
  st_retrievetype(node_ptr^.typeref, node_ptr);
  int_word_byte:= (node_ptr^.st_kind=cinteger) or
                  (node_ptr^.st_kind=cword) or
                  (node_ptr^.st_kind=cbyte);
  *)
  int_word_byte:= false;
end;

function compatible(tl,tr: st_address): boolean;
(* two types are said to be compatible, iff: *)
(* 1. they are the same type (cf. FUNCTION sametype), or *)
(* 2. one is a subrange of the other or both are subranges *)
(*    of the same type, or                                    *)
(* 3. both are set types, and the base types are compatible, or *)
(* 4. both are specified as ^tname, where tname is a typename *)

(*  maybe_string_type, maybe_fam_type and maybe_set_type updated *)

var
comp,oldcomp,oldfamtype: boolean;
strptr,
tlptr,
trptr: st_elemptr;
tlkind,trkind: codes;
tltype,trtype: st_address;
begin
maybe_set_type:=false;
(* 1 *) comp:= sametype(tl,tr);
if (not comp) or maybe_fam_type then
begin
oldcomp := comp;
comp := false;
oldfamtype := maybe_fam_type;
(* 2 *) (* 3 *) (* 4 *)
st_retrievetype(tl,tlptr);
tlkind:= tlptr^.st_kind;
tltype:= tlptr^.typeref;
st_retrievetype(tr,trptr);
trkind:= trptr^.st_kind;
trtype:= trptr^.typeref;

if trkind<>cerror then
case tlkind of
(* 2 *) csubrange: comp:= sametype(tltype,tr) or  (* tl subrange of tr *)
                 ( (trkind=csubrange) and sametype(tltype,trtype));
                 (* tl and tr subranges of the same type *)

(* 3 *) csettype:  if trkind = csettype then
                    begin
                     comp := equal_addr(tr, st_emptyset_addr) or
                             equal_addr(tl, st_emptyset_addr);
                     if not comp then
                      comp := compatible(tltype, trtype);
                      maybe_set_type:=true;
                    end;

(* 4 *) cpointertype: comp:= (trkind=cpointertype) and
                    sametype(tltype,trtype);

(* error *) cerror: comp:= true (* avoid error cascades *)

(* 2 *) else
            if (trkind=csubrange) THEN comp := sametype(tl,trtype);
                       (* tr subrange of tl *)
end (* case *)
else
comp:= true; (* avoid error cascades in case right operand is of kind error *)

maybe_string_type:=false;
maybe_fam_type:=false;
IF oldfamtype then
  BEGIN
    if not comp then
      BEGIN
        comp := oldcomp;
        maybe_fam_type := oldfamtype;
      END;
  END;
end; (* if not comp .... *)

if not comp then (* see if left is of a "super" type *)
if equal_addr(tl, st_btype_addr) then
comp := btype(tr, trptr, trkind)
else
if equal_addr(tl, st_wtype_addr) then
comp := wtype(tr, trptr, trkind)
else
if equal_addr(tl, st_ptype_addr) then
comp:= trkind=cpointertype
else if int_word_byte(tl) then comp:=int_word_byte(tr);
compatible:= comp;
end; (* compatible *)


function ordinaltype(code: codes): boolean;
begin
ordinaltype:= true; (* assume ok *)
if code<>cchar then 
if code<>cboolean then 
if code<>cinteger then 
if code<>cscalar then 
if code<>csubrange then
ordinaltype:= false;
end;

function machinetype(code: codes): boolean;
begin
machinetype:= (code=cbyte) or (code=cword);
end;

function protectedtype(code: codes): boolean;
begin
protectedtype:= true; (* assume ok *)
if code<>cpointertype then 
if code<>cmailbox then 
if code<>creference then 
if code<>cpool then 
if code<>cprocess then
if code<>cprogram then 
if code<>cport then 
if code<>cchain then
protectedtype:= false;
end;

function btype(taddr: st_address; tptr: st_elemptr; tkind: codes):boolean;
begin
btype := ordinaltype(tkind);

if tkind <> cboolean then
if tkind <> cchar then
if tkind = cscalar then
btype := tptr^.scalar_no <= 256
else
if tkind = csubrange then
begin
st_getbasetype(taddr, tptr);
(** returns a node of kind: basictype, arraytype, recordtype, scalartype **)
(** i.e. a typespecification <> subrange !!!                      **)

tkind := tptr^.st_kind;
btype := btype(taddr,tptr,tkind);
end (* subrange *)
else
btype := false;

if test_local then
begin
(***** ***) write(testoutput, 'btype found - ');
writeln(testoutput, ord(tkind));
end;

end; (* btype *)

function wtype(taddr: st_address; tptr: st_elemptr; tkind: codes):boolean;
begin
wtype := ordinaltype(tkind);

if tkind <> cinteger then
if tkind = cscalar then
wtype := tptr^.scalar_no > 256
else
if tkind = csubrange then
begin
st_getbasetype(taddr, tptr);
(** returns a node of kind: basictype, arraytype, recordtype, scalartype **)
(** i.e. a typespecification <> subrange !!!                      **)

tkind := tptr^.st_kind;
wtype := wtype(taddr,tptr,tkind);
end (* subrange *)
else
wtype := false;

if test_local then
begin
(***** ***) write(testoutput, 'wtype found - ');
writeln(testoutput, ord(tkind));
end;

end; (* wtype *)

procedure begin_level_action;
(* remember symbol table location of last inserted named element 
and change level *)
begin
push_p2stack;
with p2stacktop^ do
begin
syntaxkind:= slevel;
nodeaddress:= st2_start_search;
end;
st_beginlevel2;
end; (* begin level action *)


procedure end_level_action;
(* return to former symbol table level at the appropriate point for search start *)
begin
with p2stacktop^ do
begin
(* #begintest 
if syntaxkind<>slevel then
p2_fatal_error(1);
(* inconsistency in pass2stack *)
(* endtest# *)
st2_start_search:= nodeaddress;
end; (* with *)
pop_p2stack;
st_endlevel;
end; (* end level action *)


procedure check_legal_param_type(param_ref, type_ref: st_address);
var
(* #begintest 
procname: string[12];
(* endtest# *)
paramkind: codes;
type_spix: word;
type_ptr: st_elemptr;
components: st_protect_type;
begin
(* #begintest 
procname:= 'chck leg par';
(* endtest# *)
if not equal_addr(type_ref, st_undeclared_addr) then
(* not after error *)
begin
st_retrieve(param_ref, type_ptr (* used as temporary !! *));
paramkind:= type_ptr^.st_kind;
st_retrieve(type_ref, type_ptr);
with type_ptr^ do
begin
components:= spec_struct;
routine_specstruc:= routine_specstruc + components;
type_spix:= st_spix; (* saved for use in case of error *)
end;

if test_local then 
(***** ***)  write_specstruc(components);

if program_decl then
begin
if (paramkind=cvarparam) then
begin
if not ( equal_addr(type_ref,st_mailboxtype_addr) or
         equal_addr(type_ref,st_pooltype_addr) or
         equal_addr(type_ref,st_porttype_addr) ) then
begin
elementspix:= type_spix;
errormsg(pass2, 139);
(* illegal program parameter type *)
end; (* error *)
end; (* if program decl *)

if pointertype in components then 
errormsg(pass2, 183);
(* pointer-element type of varparam has to be mailbox *)

end; (* program declaration *)
if paramkind=cvalueparam then
begin
if components*shielded_types<>[] then
if not (pointertype in components) then
begin
elementspix:= type_spix;
errormsg(pass2, 140);
(* illegal (component) type of value parameter *)
end
else
warning(pass2, 100);

if family_type_params and (not program_decl) then
begin
st_retrievetype(type_ref, type_ptr);
if not ordinaltype(type_ptr^.st_kind) then
errormsg(pass2, 171);
(* type specified for formal type parameter(s) must be ordinal *)
end; (* family type param check *)
end; (* value paramter check *)
end; (* not after error *)
end; (* check legal param type *)


procedure routine_block_lookahead;
(* common actions about routine blocks, i.e. lookahead and find out
whether the block is forward, external, openroutine, or real code block *)
var
(* #begintest 
procname: string[12];
(* endtest# *)
forward_seg_nr:byte;
forw_name: word; (* name of forward declared routine *)
with_address: st_address;
begin
(* #begintest 
procname:= 'rout bl look';
(* endtest# *)
routine_specstruc := [];
st_get(p2stacktop^.former^.nodeaddress, st2_cur_ptr); (* routine node *)
token:= getcode;
if token=cbeginlevel then
begin
if not after_context then
begin
elementspix:= st2_cur_ptr^.st_spix;
errormsg(pass2, 114);
(* routine in context must be external *)
end;
if st2_cur_ptr^.st_specs=st_forward then
begin
with p2stacktop^.former^ do
begin

(******** OBS !!!!!!!!!!!! OBS !!!!!!!!!!!!!! ******)
if (**) st_check_params(st2_cur_ptr^.listref, former^.p2_listref) and (**)
sametype(p2_typeref, former^.p2_typeref) then
begin
st_get(nodeaddress, st2_cur_ptr);
st2_cur_ptr^.st_spix:= anonymousspix; (* erase st-node *)

(* insert parameterlist from actual declaration into "listref" *)
(* of forward declaration       **)
former^.p2_listref := st2_cur_ptr^.listref;
st_get(former^.nodeaddress, st2_cur_ptr);
st2_cur_ptr^.listref := former^.p2_listref;

end
else
errormsg(pass2, 143);
(* parameter lists of forward and actual routine declaration must be identical *)
(* pop next top, i.e. the FORWARD mark, top is a level mark *)
syntaxkind:= slevel;
nodeaddress:= p2stacktop^.nodeaddress;
end; (* with *)

pop_p2stack;
end; (* actual definition of a forward declared routine *)

begin_level_action;
if cur_block_level<routine_level then 
begin
if cur_block_level=context_level then
begin 
if (comp_unit>0) and make_segmentation then
errormsg(pass2,301);
(* using $SEGMENT only one compilation unit allowed *)
comp_unit:=comp_unit+1;
if (comp_used_bit=last_comp_unit_bit) OR
   (comp_used_bit = 0) then comp_used_bit:=1
else comp_used_bit:=2*comp_used_bit;
end;
cur_block_level:=routine_level;
end
else cur_block_level:= cur_block_level+1;
(* internal routines has cur_block_level>routine_level *)
(* routines in context are routines in pass2, FORKERT !!!! *)
put_byte(ord(cblock));
end
else
begin
if getcode<>cendlevel then
p2_fatal_error(4);
(* inconsistent pass1 code *)
end_level_action; (* exit parameter level *)
case token of
cexternal: 
begin
if segment_nr>1 then 
errormsg(pass2,300);
(* external declaration is only allowed before $SEGMENT *)
if (cur_block_level = program_level) or (cur_block_level = routine_level)
or (not after_context) then
(* external declaration in context, in program or in separately
  compiled routine *)
with st2_cur_ptr^ do
st_specs:= st_extern
else
begin
elementspix:= st2_cur_ptr^.st_spix;
errormsg(pass2,109);
(* external declaration is only allowed in the outer level of a
  block *)
end; (* error *)
end; (* external *)

cforward: 
begin
if cur_block_level >= program_level then
begin
if st2_cur_ptr^.st_specs=st_forward then
begin
elementspix:= st2_cur_ptr^.st_spix;
errormsg(pass2, 113);
(* FORWARD announcement not followed by actual routine definition *)
end
else
begin
with st2_cur_ptr^ do
begin
st_specs:= st_forward; (* let pass3 know that the routine was forward declared *)
forw_name:= st_spix;
forward_seg_nr:=st_seg_nr;
end;
if not st_search_level(forw_name, st2_cur_ptr) then
p2_fatal_error(3)
(* st mismatch *)
else
begin
with st2_cur_ptr^ do
begin
st_specs:= st_forward;
(* the label field is used as a link to the forward announcement *)
st_label:= p2stacktop^.nodeaddress;
end; (* with *)
if forward_seg_nr<>st2_cur_ptr^.st_seg_nr then
begin
forward_seg_nr:=st2_cur_ptr^.st_seg_nr;
st_get(p2stacktop^.nodeaddress,st2_cur_ptr);
st2_cur_ptr^.st_seg_nr:=forward_seg_nr;
end;
end;
end; (* ok *)
end (* cur block level >= program level *)
else
begin
elementspix:= st2_cur_ptr^.st_spix;
errormsg(pass2, 107);
(* FORWARD declaration is not allowed in contexts *)
end;
end; (* forward *)

copenroutine: 
begin
if firstcontext then
with st2_cur_ptr^ do
begin
st_curno:= open_counter;
open_counter:= open_counter+1;
st_specs:= st_open;
end (* if first context *)
else
begin
elementspix:= st2_cur_ptr^.st_spix;
errormsg(pass2, 108);
(* openroutines only allowed in standardcontext *)
end;
end;

end; (* lookahead *)
pop_p2stack;
end; (* not internal routine *)
end; (* routine block lookahead *)


procedure push_opencall;
(** actual parameter to an openroutine-call is to stay on p2stack -**)
(** pass2code is dumped.                                    **)
begin
if equal_addr(p2stacktop^.former^.p2_listref,st_stopaddr) then
begin
errormsg(pass2, 136);     (** ???? 2 inc af openrout har sm antal params ?? **)
(* too many actual parameters *)
end
else
begin
st_retrieve(p2stacktop^.former^.p2_listref, st2_cur_ptr);
(** access current formal parameter **)
with st2_cur_ptr^ do
begin
p2stacktop^.p2_listref:= listref; (* next parameter *)

(** 'p2-typeref' contains type of actual parameter **)

if st_kind=cvalueparam then
begin
put_byte(ord(cvalueparam));
putaddress(typeref); (* formal type *)
end
else
(* address transfer parameter *)
put_byte(ord(st_kind)); (* varparam/sharedparam/inspectparam *)
end; (* with st2 cur ptr^ *)
end;
if test_stack then
begin
writeln(testoutput,'*****-------> OPENROUTINE TEST *************');
write_p2stack;
writeln(testoutput,'*********** OPENROUTINE TEST ------->*******');
end;
end; (* push-opencall *)

procedure bind_open;
var
open_found: boolean;
open_error: boolean;
st2_formaladdr: st_address;
p2_actualptr: ptr_p2stack;

procedure backtrack_p2stack;
(* go backwards in p2stack to find  *)
(* pointer to current candidate *)
begin
p2_actualptr := p2stacktop;
while p2_actualptr^.syntaxkind <> sactualparam do
p2_actualptr := p2_actualptr^.former;
end;

procedure setup_ptrs;
(* set up st-address of the first formal parameter 'st2_formaladdr' *)
(* and pointer to p2stack holding the corresponding (first) actual *)
(* parameter 'p2_actualptr'        *)
(* AT ENTRY to procedure:  'p2_actualptr^.former^.nodeaddress' holds  *)
(* candidate to be examined!! *)
begin
if (p2_actualptr^.former^.syntaxkind <> sopenfunccall) and
   (p2_actualptr^.former^.syntaxkind <> sopenfunccalle) and
   (p2_actualptr^.former^.syntaxkind <> sopenproccall) then
p2_fatal_error(6);
(** pass2 inconsistency **)
st_retrieve(p2_actualptr^.former^.nodeaddress, st2_cur_ptr);
st2_formaladdr := st2_cur_ptr^.listref;
(* 1. formal parameter of candidate *)
p2_actualptr := p2_actualptr^.next;
(* 1. actual parameter to checked *)
end;

procedure check_openparams;
var
stop: boolean;

begin
stop := false;
open_error:= false;

repeat
if equal_addr(st2_formaladdr, st_stopaddr) then
stop := true
else
begin
st_retrieve(st2_formaladdr, st2_cur_ptr);
(* i.e. access formal parameter *)
with st2_cur_ptr^ do
begin
st2_cur_address := typeref;
(* save formal type address *)

st2_formaladdr := listref;
(* set up ptr to next formal parameter *)

if st_kind=cvalueparam then
begin
if not compatible(typeref, p2_actualptr^.p2_typeref) then
begin
if p2_actualptr^.syntaxkind=snull then
begin
open_error := true;
(**
errormsg(pass2, 167)
elementspix:= nextinp;
 '?' only allowed as address transfer parameter *)
end
else
begin
open_error := true;
(**
errormsg(pass2, 135);
 formal and actual types of valueparameter are not compatible *)
end
end;

end
else
(* address transfer parameter *)
with p2_actualptr^ do
if (syntaxkind<>svar) and (syntaxkind<>snull) and 
((st_kind<>cinspectparam) or 
((syntaxkind<>sconst) and 
(syntaxkind<>sstrucrecval) and
(syntaxkind<>sstrucarrval) )) then
begin   
open_error := true;
(**
errormsg(pass2, 170);
elementspix:= nextinp;
 address transfer parameter; actual parameter must be a variable *)
end
else
begin
if not sametype(typeref, p2_typeref) then
if syntaxkind<>snull then
begin
st_retrievetype(p2_typeref, st2_cur_ptr);
with st2_cur_ptr^ do
begin

(* see if formal is of a "super" type *)
(* rtype *)
if equal_addr(st2_cur_address, st_rtype_addr) then 
begin
if not (equal_addr(p2_typeref, st_referencetype_addr) or
        equal_addr(p2_typeref, st_chaintype_addr))   then
begin
open_error := true;
(**
errormsg(pass2,182);
 actualparameter has to be reference or chain  *)
end
end else
(* ptype *)
if equal_addr(st2_cur_address, st_ptype_addr) then 
begin
if not (st_kind = cpointertype) then
begin
open_error := true;
(**
errormsg(pass2,184);
 actualparameter has to be a pointertype  *)
end
end 
else
begin
open_error := true;
(**
errormsg(pass2, 137);
elementspix:= nextinp;
 types of formal and actual parameters must be identical*)
end;
end;
end;
end;
end;  (* with st2-cur-ptr *)
end;

if p2_actualptr <> p2stacktop then
begin
p2_actualptr := p2_actualptr^.next;
if stop (** i.e. no more formal parameters **)  and 
(p2_actualptr <> p2stacktop) then
begin
open_error := true;
(* too many actual parameters *)
(**
warning(pass2,200);
**)
end
end
else stop := true;

until stop or open_error;

open_found := not open_error;
end; (* check_openparameters *)

begin   (*** bind_open **)
open_found := false;

backtrack_p2stack;

repeat

setup_ptrs;

check_openparams;

backtrack_p2stack;
(* p2_actualptr^.former^ now points out sopenfunccall or sopenproccall - node *)

(* reetableret fra rtp86p2 d. 28 feb. 89 *)

if not open_found (* i.e. 'open_error = true *) then
begin
(** follow open_chain backwards to next candidate **)
with p2_actualptr^.former^ do
begin
st_retrieve(nodeaddress, st2_cur_ptr);
(* get just examined candidate **)
(** to follow chain to possible next candidate **)
if not equal_addr(st2_cur_ptr^.st_label, st_stopaddr) then
begin  (* i.e. more candidates *)
open_error := false;
nodeaddress := st2_cur_ptr^.st_label;
end;
end;
end;
until open_found or open_error;

if not open_found then
(* open_error *)
begin
errormsg(pass2,137);
(** types of formal and actual parameters must be identical **)
end else with p2_actualptr^.former^ do
if (syntaxkind=sopenfunccall) or (syntaxkind=sopenfunccalle) then
begin
  st_retrieve(nodeaddress, st2_cur_ptr);
  p2_typeref:= st2_cur_ptr^.typeref;
end;

end; (** bind_open **)

procedure pop_opencall;
begin
while p2stacktop^.syntaxkind <> sactualparam do
begin
p2stacktop^.former^.p2_listref := p2stacktop^.p2_listref;
pop_p2stack;     (* !!!! PAS PAA ved 2. gennemlqb !!*)
end;
p2stacktop^.former^.p2_listref := p2stacktop^.p2_listref;
pop_p2stack;   (* pop actualparam *)
(** see whether wee still are within an openroutinecall **)
(** if not : then within_opencall := false    **)
opencount := opencount - 1;
within_opencall := opencount > 0;
(** 'within_opencall' is to be reset after last openroutinecall in a row **)
end;

procedure copy_type(original_symb: st_address; var copy_symb: st_address);
(* make a copy of the sub types of a family type *)

var
original_ptr,
copy_ptr: st_elemptr;
def_type_symb,
field_symb,
field_list_symb: st_address;

procedure copy_node(original_symb: st_address; var copy_symb: st_address;
var copy_ptr: st_elemptr);
begin
st_copy_node(original_symb, copy_symb, copy_ptr);
with copy_ptr^ do
begin
st_node_copy:= true;
st_family_ref:= original_symb;
end;
end; (* copy node *)

begin (* copy type *)
st_get(original_symb, original_ptr);
with original_ptr^ do
case st_kind of
ctype:
if (st_spix=anonymousspix) or (type_mode=bound_fam) or
   (type_mode=fam) or (type_mode = open_fam) then
begin
if st_spix<>anonymousspix then
begin
if type_mode<>fam then begin
st2_hlp_address:=original_symb;
original_node(st2_hlp_address,original_ptr);
st_get(st2_hlp_address,original_ptr);
end;
with original_ptr^ do
(*if not odd(fam_used div comp_used_bit) then
fam_used:=fam_used+comp_used_bit;  *)
fam_used:=fam_used OR comp_used_bit;
end;
copy_node(original_symb, copy_symb, copy_ptr);
copy_type(copy_ptr^.typeref, def_type_symb);
st_get(copy_symb, copy_ptr);
copy_ptr^.typeref:= def_type_symb;
end
else
copy_symb:= original_symb;

cscalar,
csubrange: copy_node(original_symb, copy_symb, copy_ptr);

cpointertype: begin
copy_node(original_symb, copy_symb, copy_ptr);
copy_type(copy_ptr^.typeref, def_type_symb);
st_get(copy_symb, copy_ptr);
copy_ptr^.typeref:= def_type_symb;
end; (* pointertype *)

carraytype: begin
copy_node(original_symb, copy_symb, copy_ptr);
copy_type(copy_ptr^.itype, def_type_symb);
st_get(copy_symb, copy_ptr);
copy_ptr^.itype:= def_type_symb;
copy_type(copy_ptr^.typeref, def_type_symb);
st_get(copy_symb, copy_ptr);
copy_ptr^.typeref:= def_type_symb;
end; (* arraytype *)

crecordtype: begin
copy_node(original_symb, copy_symb, copy_ptr);
field_symb:= copy_symb;

repeat (* traverse the field list *)
copy_node(copy_ptr^.listref, field_list_symb, copy_ptr);
def_type_symb:= copy_ptr^.typeref;
st_get(field_symb, copy_ptr);
copy_ptr^.listref:= field_list_symb;
field_symb:= field_list_symb;
copy_type(def_type_symb, def_type_symb);
st_get(field_symb, copy_ptr);
copy_ptr^.typeref:= def_type_symb;
until equal_addr(copy_ptr^.listref, st_stopaddr);

end; (* recordtype *)

csettype: ;

cundeclared: copy_symb := st_undeclared_addr;

else 
begin
if test_local then writeln('st_kind: ', ord(st_kind));
fatal_error(pass2, 08);
(** copy-type error **)
end;
end; (* case *)

end; (* copy type *)

end.