{$O+,F+}
unit rtp86p2;
interface
uses pscplm,files,mpaunit,sthunit,sthcom,sthp2,rtp86mpa,p2code;
procedure rtp86pass2;
implementation
(*************************************************************************
*                                                                        * 
*                                                                        * 
*                                                                        * 
*    Module: pass 2 of the RTP compiler for the RC 3900 computer         *
*    =======                                                             *
*                                                                        * 
*    Version: 9  (according to the compiler project plan)                *
*    ========                                                            *
*                                                                        * 
*                                                                        * 
*                                                                        *
*    Copyright (C) by A/S Regnecentralen af 1979                         *
*                                                                        *
*                                                                        *
**************************************************************************)

(*

Testpatterns: the global integer type variable testpass2, as assigned
.             according to the call of the compiler, has the following
.             effect (0 means off, 1 means on):
.             bit0: test output concerning the use of the internal
.                   stack (p2stack)
.             bit1: dump internal stack contents in case of fatal error
.             bit2: dump symbol table contents, change from off to on means
.                   remember last inserted element as the start of a dump,
.                   change from on to off means dump symbol table elements
.                   processed since test bit was turned on (the bit is
.                   implicitly turned off at program end)
.             bit3: local tests
.             bit4: pass1code
.             bit8: testoutput concerning use of symbol table
.             bit9: no testoutput concerning use of symbol table
.             bit10:the option $test(vmm = x) assign x to testvmm
.             bit11:the option $test(vmm = x) is ignored
.             bit12:testoutput concerning use of st_search
.             bit13:no testoutput concerning use of st_search

*)
(*

$include(pscplm.ext)
$include(files.ext)
$include(rtp86mpa.ext)
$include(sthcommo.ext)
$include(sthp2.ext)
*)


(*****)
(*** MAIN PROCEDURE ***)


(* !!! TURBO !!! *)
var
(* #begintest 
procname: string[12];
(* endtest# *)
in_program_head,
in_type_decl, bind_of_family_allowed, (* bind of family only allowed after *)
                                 (* after context or in family declaration *)
                                 (* and not in program head *)
found, ok, boo: boolean; (* help booleans *)
current: ptr_p2stack; (* used for p2 stack traversal *)
cur_kind: syntaxtype; (* kind of current during traversal *)
count, result_spix, length, nextinp: word;
st2_type: codes;
with_address,linkref: st_address;
symbol_chain_ptr:ptr_symbol_chain;


function do_actualparam: boolean;
var callbyaddress : boolean;
(* dump p2code *)
begin
case p2stacktop^.former^.syntaxkind of
sindex: with p2stacktop^.former^ do
begin
st_getbasetype(p2_typeref, st2_cur_ptr);
with st2_cur_ptr^ do
if st_kind<>carraytype then
begin
if not equal_addr(former^.nodeaddress, st_undeclared_addr) then
errormsg(pass2, 134)
(* not array type *)
end
else
begin
put_byte(ord(cindex));
putaddress(p2_typeref);
p2_typeref:= typeref; (* element type *)
if not compatible(itype, p2stacktop^.p2_typeref) then
errormsg(pass2, 150);
(* index and expression types not compatible *)
end;
pop_p2stack; (* index expression *)
end; (* with p2stacktop^.former^ *)
sactualparam: begin

within_opencall := opencount > 0;

if (p2stacktop^.former^.former^.syntaxkind <> sopenfunccall) and
   (p2stacktop^.former^.former^.syntaxkind <> sopenfunccalle) and
   (p2stacktop^.former^.former^.syntaxkind <> sopenproccall) then
(* access formal parameter *)
if equal_addr(p2stacktop^.former^.p2_listref,st_stopaddr) then
begin
errormsg(pass2, 136);
(* too many actual parameters *)
pop_p2stack;
end
else
begin
st_retrieve(p2stacktop^.former^.p2_listref, st2_cur_ptr);
with st2_cur_ptr^ do
begin
nextinp:= st_spix; (* saved for possible error messages *)
p2stacktop^.former^.p2_listref:= listref; (* next parameter *)
st2_cur_address:= typeref; (* save type address *)

callbyaddress := st_kind <> cvalueparam;
if st_kind=cvalueparam then
begin
put_byte(ord(cvalueparam));
putaddress(typeref); (* formal type *)
if not compatible(typeref, p2stacktop^.p2_typeref) then
begin
elementspix:= nextinp;
if p2stacktop^.syntaxkind=snull then
errormsg(pass2, 167)
(* '?' only allowed as address transfer parameter *)
else
errormsg(pass2, 135);
(* formal and actual types of valueparameter are not compatible *)
end;

end
else
(* address transfer parameter *)
begin
put_byte(ord(st_kind)); (* varparam/sharedparam/inspectparam *)

with p2stacktop^ do
if (syntaxkind<>svar) and (syntaxkind<>svarprog) and (syntaxkind<>snull) and
((st_kind<>cinspectparam) or (syntaxkind<>sconst)) then
begin
elementspix:= nextinp;
errormsg(pass2, 170);
(* 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
(* see if formal is of a super-type *)
(* ptype *)
if equal_addr(st2_cur_address, st_ptype_addr) then
begin
if not (st_kind = cpointertype) then
errormsg(pass2,184);
(* actualparameter has to be a pointertype  *)
end
else
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
errormsg(pass2, 182);
(* actual parameter has to be reference or chain *)
end else
(*if not (equal_addr(st2_cur_address, st_program_type_addr) and
       (st_kind = cprogram)) then
*)
begin
elementspix:= nextinp;
errormsg(pass2, 137);
(* types of formal and actual parameters must be identical*)
end;
end;
end;
end;
(** 'p2stacktop^.p2_typeref' points out type of actual parameter **)
(** 'st2_cur_address' points out type of formal parameter **)
(* in case of formal parameter is specified as an open-family binding *)
(* pass2-code is to be dumped:                                    *)
(*      -----> FAMILYTYPE(actual-SYMBOL) ------------>            *)
st_retrieve(st2_cur_address, st2_hlp_ptr);
if st2_hlp_ptr^.type_mode = open_fam then
begin
put_byte(ord(cfamilytype));
if p2stacktop^.syntaxkind=snull then
putaddress(st2_cur_address) (* no actual type, use formal *)
else
begin
(* if actuel type not family then array( ) of char *)
st_retrieve(p2stacktop^.p2_typeref,st2_hlp_ptr);
if (st2_hlp_ptr^.type_mode<>stat) and (st2_hlp_ptr^.type_mode<>dyn)
then putaddress(p2stacktop^.p2_typeref)
else putaddress(st2_hlp_ptr^.typeref);
end;
end
ELSE
  IF Maybe_fam_type OR (Maybe_string_type AND callbyaddress) then
    BEGIN
      put_byte(ord(cCheckparam));
      PutAddress(typeref);
      PutAddress(p2stacktop^.p2_typeref);
    END;
pop_p2stack;
end; (* with st2 cur ptr^ *)
end
else
push_opencall;
end; (* parameter list *)

stypeid: begin (* after repaired start of structure *)
token:= cstrucelem;
(*goto 9876; (* after read next token *)
do_actualparam:= true; exit;
end (* element of strucured value *)


else

if within_opencall then
push_opencall
else
p2_fatal_error(1);
(* inconsistency in pass2stack *)
end; (* case kind ... *)

do_actualparam:= false;
Set_Result := false;
end; (* actualparam *)

procedure do_beginstruc;
begin
with p2stacktop^ do
if syntaxkind=sinitobj then
begin
st2_cur_address:= p2_typeref;
(****
put_byte(ord(cid));
putaddress(p2_typeref);
*****)
push_p2stack;
end
else
if syntaxkind=stypeid then
begin
st2_cur_address:= p2_typeref;
if not equal_addr(p2_listref, st_stopaddr) then
errormsg(pass2, 112);
(* too few actual parameters *)

(** check that:  -----------  *)
(* variable and typename are the same  *)
(* structure element and typename (if mentioned) are the same *)
(** 3-4 cases !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!*)

if (former^.syntaxkind = sinitobj) then
if not sametype(p2_typeref, former^.p2_typeref) then
errormsg(pass2, 157);
(* wrong typename *)

end (* syntaxkind = stypeid *)
else
if syntaxkind=sstrucarrval then
begin
(***
put_byte(ord(cid));
putaddress(nodeaddress); (* type information *)

st2_cur_address:= nodeaddress;
push_p2stack;
end
else
if syntaxkind=sstrucrecval then
begin
(***
put_byte(ord(cid));
***)
st_retrieve(p2_listref, st2_cur_ptr); (* the field name *)
st2_cur_address:= st2_cur_ptr^.typeref; (* the field type *)
(***
putaddress(st2_cur_address);
***)
push_p2stack;
end
else
if (syntaxkind=sexpression) or (syntaxkind=svar) or (syntaxkind=sconst) then
if former^.syntaxkind=sstrucarrval then
begin (* part of repstruc construction *)
(***
put_byte(ord(cid));
***)

st2_cur_address:= former^.nodeaddress;

(***
putaddress(st2_cur_address); (* type name *)

push_p2stack;
end
else
begin (* error recovery: act as if the name was a type name *)
if (former^.syntaxkind=svar) or (former^.syntaxkind=sconst) then
(* var := var (: ... *)
errormsg(pass2, 178)
(* object in front of '(:' must be a type name *)
else (* var := (: .... *)
begin
errormsg(pass2, 179);
(* type name in front of '(:' missing *)
push_p2stack;
end;
st2_cur_address:= p2_typeref;
end
else
p2_fatal_error(1);
(* inconsistency in pass2stack *)
st_retrievetype(st2_cur_address, st2_cur_ptr);

with p2stacktop^, st2_cur_ptr^ do
begin
p2_typeref:= st2_cur_address;
if st_kind=crecordtype then
begin
syntaxkind:= sstrucrecval;
p2_listref:= listref; (* field list *)
end
else
if st_kind=carraytype then
begin
syntaxkind:= sstrucarrval;
nodeaddress:= typeref; (* element type *)
end
else
begin
errormsg(pass2, 158);
(* not structered type *)
syntaxkind:= sstrucrecval; (* error recovery: assume record init *)
p2_listref:= st_stopaddr;
end;
end; (* with top^ *)
st_retrieve(st2_cur_address, st2_cur_ptr); (* type name *)

(* REMOVED becource pass3 must have ctype node 
while (st2_cur_ptr^.st_kind=ctype) do
begin
st2_cur_address:= st2_cur_ptr^.typeref;
st_retrieve(st2_cur_address, st2_cur_ptr); (* type name ? 
end;
*)

put_byte(ord(cbeginstruc));
putaddress(st2_cur_address);

end; (* beginstruc *)

procedure do_endblock;
begin
if getcode<>cendlevel then
p2_fatal_error(4);
(* inconsistent pass1 code *)
end_level_action; (* exit parameter level *)
if getcode<>cendlevel then
p2_fatal_error(4);
(* inconsistent pass1 code *)
end_level_action; (* exit parameter level *)

case p2stacktop^.syntaxkind of

sprogdecl:
begin 
if p2stacktop^.former^.former^.syntaxkind=scompunit then
(* leaving a program declaration on program level *)
begin
open_counter:= first_program_open;
cur_block_level:= context_level;
end;
st_end_program;
end;

sprocdecl,sfuncdecl:
begin
if p2stacktop^.former^.former^.syntaxkind=scompunit then
(* leaving a routine at program level i. e. seperately
  compiled routine *)
begin
open_counter:= first_program_open;
cur_block_level:= context_level;
end
else
begin
(* routinedecl at inner level *)
cur_block_level:= cur_block_level -1;
if p2stacktop^.syntaxkind=sfuncdecl then
begin
if p2stacktop^.misc_field=0 then
warning(pass2, 132);
(* no function result *)
end;
end;

(*** updating specstruc inf in routine-node ***)
st_get(p2stacktop^.nodeaddress, st2_cur_ptr);
st2_cur_ptr^.spec_struct := routine_specstruc;
routine_specstruc := [];

if cur_block_level > context_level then
(* get specstruc-inf from sourrounding routine (not program) - if any *)
(* for possibly adding further information *)
begin
st_retrieve(p2stacktop^.former^.former^.former^.nodeaddress, st2_cur_ptr);
st2_type := st2_cur_ptr^.st_kind;
if (st2_type = cprocedure) or
   (st2_type = cfunction) then
routine_specstruc := st2_cur_ptr^.spec_struct
else
if test_local then
begin
warning(pass2, 223);
(* testwarning - endblock *)
writeln(testoutput, 'st_kind: ', ord(st2_type));
end;
end;
(*** ***)

end
else
begin
p2_fatal_error(1);
(* inconsistency in pass2stack *)
end;
end;
pop_p2stack;
put_byte(ord(cendblock));
declare_state:= true;
before_assign:=false;
end; (* endblock *)

procedure do_familytype;
begin
push_p2stack;
with p2stacktop^ do
begin
syntaxkind:= stype;
nextinp:= get_2_byte;  (* spix of the type *)
elementnumber:= elementnumber+1;
st2_cur_address:= st_nilladdr;
if not st_search(nextinp, st2_cur_address, with_address, st2_cur_ptr) then
begin
elementspix:= nextinp;
if cross then st_cross_line(st2_cur_address,cnocode);
errormsg(pass2, 105);
(* undeclared type *)
boo := stdcode_to_address(cerror, p2_listref);
end
else
begin
if st2_cur_ptr^.st_kind<>ctype then
begin
if cross then st_cross_line(st2_cur_address,cnocode);
st2_cur_address:= st_nilladdr;
elementspix:= nextinp;
errormsg(pass2, 133);
(* unknown type *)
end
else   (* st_kind = ctype **)
begin
if st2_cur_ptr^.st_t_seg_nr<>segment_nr then
st2_cur_ptr^.st_t_local_near:=false;
with st2_cur_ptr^ do
(*if not odd(fam_used div comp_used_bit) then*)
fam_used:=fam_used OR comp_used_bit;
(** get "spec_struct" - inf. from underlying structure - into p2stack **)
p2_specstruc := st2_cur_ptr^.spec_struct;

p2_listref:= st2_cur_ptr^.listref;
st2_hlp_address:=st2_cur_ptr^.typeref;

if not equal_addr(st2_cur_ptr^.st_family_ref,st_nilladdr) then
begin
st_get(st2_cur_ptr^.st_family_ref,st2_cur_ptr);
with st2_cur_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;

if cross then st_cross_line(st2_cur_address,cnocode);

if former^.former^.syntaxkind = stypedecl then
(** do not copy ctype-node **)
(* i.e. skip ctype-node and copy following nodes *)
begin

st_get(former^.former^.nodeaddress, st2_hlp_ptr);
(* access node of type to be declared *)

st2_hlp_ptr^.st_family_ref := st2_cur_address;
(* 'st2_cur_address' contains family-type-name *)

if st2_hlp_ptr^.type_mode <> fam then
st2_hlp_ptr^.type_mode := bound_fam;

copy_type(st2_hlp_address, nodeaddress);
(*
st2_hlp_ptr^.typeref := nodeaddress;
(** is done by 'cendtypedecl'  **)
end
else  (** do make a copy of ctype-node **)
begin
copy_type(st2_cur_address, nodeaddress);

st_get(nodeaddress, st2_hlp_ptr);
st2_hlp_ptr^.type_mode := bound_fam;
end;
if (not bind_of_family_allowed) THEN
 BEGIN
   IF (Not Equal_Addr(st_String_type_Addr,St_Undeclared_addr)) AND
     (Not Equal_Addr(st2_hlp_ptr^.st_Family_ref,st_String_type_Addr)) then
  begin
    elementspix:= nextinp;
    errormsg(pass2, 193);
  end;
 END;

end;
end;

put_byte(ord(ctypeid));
putaddress(nodeaddress);
end; (* with *)

(***** TEST *****)
if test_stack then
begin
writeln(testoutput, '**** START familytype test ****');
write_stacktop(1);
write_p2stack;
writeln(testoutput, '**** END familytype test ****');
end;
end; (* cfamilytype *)

procedure do_id;
begin
nextinp:= get_2_byte;
elementnumber:= elementnumber+1;
boo := true;    (** used to tell whether or not address is to be dumped *)
(* at end of 'cid'. - This depends on situation when 'ctype' is handled *)

if declare_state or local_declare_state then
st2_cur_address:= st2_start_search (* search from last inserted *)
else
st2_cur_address:= st_nilladdr; (* search inside entire level *)
help_boolean:=st_search(nextinp,st2_cur_address,with_address,st2_cur_ptr);
if not help_boolean then
begin
elementspix:= nextinp;
errormsg(pass2, 106);
(* undefined *)
end else cross_addr:=st2_cur_address;
push_p2stack;
with  p2stacktop^ do
begin
case st2_cur_ptr^.st_kind of
cscalarelem,
cconstant:
begin
syntaxkind:= sconst;
put_byte(ord(cconst));
end;
cinspectparam:
begin
syntaxkind:= sconst;
put_byte(ord(cid));
end;
cfunction:
if before_assign then
begin
(* test inside proper function definition *)
found:= false;
current:= p2stacktop;
cur_kind:= current^.syntaxkind;
while not found and (cur_kind<>scompunit) do
begin
found:= (cur_kind=sfuncdecl) AND
        equal_addr(current^.nodeaddress, st2_cur_address);
if not found then
begin
current:= current^.former;
cur_kind:= current^.syntaxkind;
end; (* not found yet *)
end; (* while *)
if not found then
begin
elementspix:= nextinp;
  errormsg(pass2, 130);
(* illegal use of function variable *)
end
else
current^.misc_field:= 1; (* function result assigned *)

p2stacktop^.syntaxkind:= svar(* TOG !!! func*) ;
put_byte(ord(cid));
end
else (* not before assign *)
with st2_cur_ptr^ do
begin
if st_specs = st_open then
begin
syntaxkind := sopenfunccall;
opencount := opencount + 1;
end
else
begin
syntaxkind:= sfunccall; (* call of function *)
st_get(st2_cur_address, st2_cur_ptr);
st2_cur_ptr^.st_curno := max_word;
with st2_cur_ptr^ do
begin
  if st_seg_nr<>segment_nr then
  begin
  st_local_near:=false;
  if (st_seg_nr>segment_nr) and (st_logic_nr=0) then
  begin
    new(symbol_chain_ptr);
    symbol_chain_ptr^.symbol:=st2_cur_address;
    symbol_chain_ptr^.next:=segment_info[st_seg_nr].list;
    segment_info[st_seg_nr].list:=symbol_chain_ptr;
    st_logic_nr:=segment_info[st_seg_nr].no_of_symbol+1;
    segment_info[st_seg_nr].no_of_symbol:=st_logic_nr;
  end;
  end;
end;
end;
if declare_state then
if st_specs<>st_open then
begin
elementspix:= st_spix;
errormsg(pass2, 145);
(* only call of predefined functions allowed *)
end; (* error *)
put_byte(ord(cfunccall));
p2_listref:= listref;
if equal_addr(st2_cur_address, st_create_addr) then
create_call:= true;
if equal_addr(listref, st_stopaddr) then
begin
  if syntaxkind=sfunccall then syntaxkind:=sfunccalle else
  syntaxkind:=sopenfunccalle; (* TOG, maybe index *)
end;
end;
cprocedure:
begin
if st2_cur_ptr^.st_specs = st_open then
begin
opencount := opencount + 1;
syntaxkind := sopenproccall;
end
else
begin
syntaxkind:= sproccall;
st_get(st2_cur_address, st2_cur_ptr);
st2_cur_ptr^.st_curno := max_word;
with st2_cur_ptr^ do
begin
  if st_seg_nr<>segment_nr then
  begin
  st_local_near:=false;
  if (st_seg_nr>segment_nr) and (st_logic_nr=0) then
  begin
    new(symbol_chain_ptr);
    symbol_chain_ptr^.symbol:=st2_cur_address;
    symbol_chain_ptr^.next:=segment_info[st_seg_nr].list;
    segment_info[st_seg_nr].list:=symbol_chain_ptr;
    st_logic_nr:=segment_info[st_seg_nr].no_of_symbol+1;
    segment_info[st_seg_nr].no_of_symbol:=st_logic_nr;
  end;
  end;
end;
end;

put_byte(ord(cproccall));
p2_listref:= st2_cur_ptr^.listref;
end;
cundeclared,
cvarparam,
cvalueparam,
clockvar,
cwithvar:
begin
syntaxkind:= svar;
put_byte(ord(cid));
end;

cvar:
begin
syntaxkind:= svar;
put_byte(ord(cid));
p2_specstruc:= st2_cur_ptr^.spec_struct;
if ( programtype in p2_specstruc ) then
begin
  st2_hlp_address:=st2_cur_ptr^.typeref;
  st_retrieve(st2_hlp_address, st2_cur_ptr);
  if st2_cur_ptr^.st_kind=ctype then
  begin
    st2_hlp_address:=st2_cur_ptr^.typeref;
    st_retrieve(st2_hlp_address, st2_cur_ptr);
  end;
  if st2_cur_ptr^.st_kind=cprogram then
  begin
  (* program variable *)
    if create_call then
    begin
      syntaxkind:= sprogcall;
      putaddress(st2_cur_address);
      put_byte(ord(cprogramcall));
      create_call:= false;
      p2_listref:= st2_cur_ptr^.listref;
    end
    else syntaxkind:= svarprog;
    p2_typeref:= st2_cur_ptr^.typeref;
    putaddress(st2_cur_address);
    boo:= false;
    st2_cur_address:=st2_hlp_address;
  end else st_retrieve(st2_cur_address, st2_cur_ptr);
end;
end;

cwithstat:
begin
syntaxkind:=sconst;
put_byte(ord(cid));
end;
cforstat: begin
(* ??? TOG, forvariable er blot en konstant 
syntaxkind:= sforvar;*)
syntaxkind:= sconst;
put_byte(ord(cid));
end;

crecfield:
begin
st_retrieve(with_address,st2_cur_ptr);
if st2_cur_ptr^.st_kind=cwithstat then syntaxkind:= sconst else
syntaxkind:= svar;
st_retrieve(st2_cur_address,st2_cur_ptr);
put_byte(ord(cid)); (* simulate  withvar.field *)
putaddress(with_address);
put_byte(ord(cfield));
p2_specstruc:= st2_cur_ptr^.spec_struct;
if ( programtype in p2_specstruc ) then
begin
st2_hlp_address:=st2_cur_ptr^.typeref;
st_retrieve(st2_hlp_address, st2_cur_ptr);
if st2_cur_ptr^.st_kind=ctype then
begin
st2_hlp_address:= st2_cur_ptr^.typeref;
st_retrieve(st2_hlp_address, st2_cur_ptr);
end;
if st2_cur_ptr^.st_kind=cprogram then
begin
(* program variable *)
if create_call then
begin
syntaxkind:= sprogcall;
putaddress(st2_cur_address);
put_byte(ord(cprogramcall));
create_call:= false;
p2_listref:= st2_cur_ptr^.listref;
end
else syntaxkind:= svarprog;
p2_typeref:= st2_cur_ptr^.typeref;
putaddress(st2_cur_address);
boo:= false;
st2_cur_address:= st2_hlp_address;
end else st_retrieve(st2_cur_address, st2_cur_ptr);
end;
end;

ctype:
begin
syntaxkind:= stypeid;
if (st2_cur_ptr^.type_mode = fam) then
begin
if st2_cur_ptr^.st_t_seg_nr<>segment_nr then
begin
st_get(st2_cur_address, st2_cur_ptr);
st2_cur_ptr^.st_t_local_near:=false;
end;
copy_type(st2_cur_address, st2_cur_address);
st_get(st2_cur_address, st2_cur_ptr);
st2_cur_ptr^.type_mode := bound_fam;
(* TOG  850426 *)
put_byte(ord(ctypedecl));
putaddress(st2_cur_address);
put_byte(ord(ctypeid));
end
else
boo := false;
(** i.e. do not dump address at end of 'cid'  **)
p2_listref:= st2_cur_ptr^.listref;
end; (* ctype *)
cprogram: (* TOG, not used, to be removed !!!! *)
if create_call then
begin
syntaxkind:= sprogcall;
put_byte(ord(cprogramcall));
create_call:= false;
p2_listref:= st2_cur_ptr^.listref;
end
else
begin
syntaxkind:= svarprog;
put_byte(ord(cid));
end;
cshared, csharedparam: begin
syntaxkind:= svar;
put_byte(ord(cid));
(* check legal use of the shared object,
i.e. shared parameter or inside REGION statement *)
found:= false; 
current:= former;
while not found do
with current^ do
case syntaxkind of
sprocdecl, sfuncdecl,
sprogdecl: begin
found:= true; (* stop *)
elementspix:= nextinp;
errormsg(pass2, 177);
(* use of SHARED object must be inside REGION statement *)
end;
sproccall, sfunccalle, sopenfunccalle, sfunccall, sopenfunccall, sopenproccall: 
begin (* parameter passing, ok *)
found:= true;
end;
sregion: begin
found:= equal_addr(st2_cur_address, nodeaddress) or (* inside proper region *)
 equal_addr(st_nilladdr, nodeaddress); (* start of region statement *)
current:=former;
end
else current:= former;
end; (* case *)
end (* shared, sharedparam *)

else 
begin
with st2_cur_ptr^ do
if (st_kind=cconstdecl) or (st_kind=ctypedecl) or
(st_kind=cshareddecl) or (st_kind=cvardecl) then
begin
elementspix:= nextinp;
errormsg(pass2, 173)
(* recursive declaration not allowed *)
end
else
begin
elementspix:= nextinp;
errormsg(pass2, 141);
(* illegal kind of operand *)
end;
syntaxkind:= svar; (* try to avoid cascaded errors *)
put_byte(ord(cid));
st2_cur_address:= st_undeclared_addr;
end;

end; (* case *)
if boo then  (* cf.: action at 'ctype' *)
putaddress(st2_cur_address);
nodeaddress:=st2_cur_address;
with st2_cur_ptr^ do
if st_kind=ctype then
p2_typeref:= st2_cur_address (* the type name *)
else
p2_typeref:= typeref;
end;
if help_boolean and cross then st_cross_line(cross_addr,cnocode);
before_assign:= false;
end; (* cid *)

procedure do_endprogdecl; 
begin
(*# BEGINTEST   *)
if p2stacktop^.former^.syntaxkind<>sprogdecl then
p2_fatal_error(1);
(* inconsistency in pass2stack *)
(* ENDTEST# *)

in_program_head:=false;
bind_of_family_allowed:=after_context;
put_byte(ord(cendprogdecl));

(* TOG type !!! *)
st_gettype(p2stacktop^.former^.nodeaddress, st2_cur_ptr);
st2_cur_ptr^.typeref:= st_program_type_addr; 
(*** ***)
(* updating specstruc-inf in program-node - telling whether or not *)
(* pool's in program parameterlist        *)
st2_cur_ptr^.spec_struct := routine_specstruc;
routine_specstruc := [];
(*** ***)

(* lookahead to see if body present or if it is an external program *)
token:= getcode;
if token=cbeginlevel then
begin
if not after_context then
begin
elementspix:= st2_cur_ptr^.st_spix;
errormsg(pass2, 114);
(* routines and programs in context must be external *)
end;
if new_comp_unit 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;
begin_level_action;
put_byte(ord(cblock));
end
else
begin
if getcode<>cendlevel then
p2_fatal_error(4);
(* inconsistent pass1 code *)
end_level_action; (* exit parameter level *)
if token=cexternal then 
begin
st_end_program;
(* tog !!!!! not nessesary to set st_extern *)
st2_cur_ptr^.st_specs:= st_extern;
end
else
if token=cforward then
begin
elementspix:= st2_cur_ptr^.st_spix;
errormsg(pass2, 103);
(* forward declared programs not allowed *)
end
else
if token=copenroutine then
begin
elementspix:= st2_cur_ptr^.st_spix;
errormsg(pass2, 104);
(* program cant be declared as open routine *)
end
else
p2_fatal_error(2);
(* pass1 code error *)

pop_p2stack;
end; (* not internal program *)
new_comp_unit:=false;
end; (* cendprogdecl *)

procedure do_endvariable;
begin
with p2stacktop^ do
begin
(* same test at cuparrow / TOG *)
if (syntaxkind=svar) or (syntaxkind=sconst) or (syntaxkind=sexpression) or
   (syntaxkind=svarprog) then
put_byte(ord(cendvariable))
else if (syntaxkind=sfunccall) or (syntaxkind = sopenfunccall) or
        (syntaxkind=sfunccalle) or (syntaxkind = sopenfunccalle) then
begin
if not equal_addr(p2_listref, st_stopaddr) then
errormsg(pass2, 112);
(* too few actual parameters *)
put_byte(ord(cendfunccall));
putaddress(nodeaddress);
end
else if syntaxkind=stypeid then begin
st_retrieve(nodeaddress, st2_cur_ptr);
elementspix:= st2_cur_ptr^.st_spix;
errormsg(pass2, 195);
(* illegal use of type *)
end
else
if syntaxkind=sprogcall then
begin
if not equal_addr(p2_listref, st_stopaddr) then
errormsg(pass2, 112);
(* too few actual parameters *)
syntaxkind := svar;
put_byte(ord(cendprogramcall));
putaddress(nodeaddress);
end
else
if (syntaxkind = sproccall) or (syntaxkind = sopenproccall) then
begin
st_retrieve(nodeaddress, st2_cur_ptr);
elementspix:= st2_cur_ptr^.st_spix;
errormsg(pass2, 191);
(** procedure used as variable **)

if not equal_addr(p2_listref, st_stopaddr) then
errormsg(pass2, 112);
(* too few actual parameters *)

syntaxkind := svar;
boo := stdcode_to_address(cerror, p2_typeref);
end
else
begin
st_retrieve(nodeaddress, st2_cur_ptr);
elementspix:= st2_cur_ptr^.st_spix;
errormsg(pass2, 198);
(* not allowed in expression *)
end;

end;
end; (* cendvariable *)

FUNCTION do_endactual : BOOLEAN;
(* reducing: *)
(* actual parameters: *)
(*             ---------<----------------   *)
(*             !                        !   *)
(* BEGINACTUAL---->unit--->ACTUALPARAM----->ENDACTUAL *)
(* unit: *)
(* ---->expression----------> *)
(*  !               !        *)
(*  ----NULL---->----        *)

(* dump p2code *)
begin
do_endactual := false;
if p2stacktop^.syntaxkind=sindex then
with p2stacktop^ do
begin
 former^.p2_typeref:= p2_typeref;
 pop_p2stack;
 help_boolean:= (programtype in p2stacktop^.p2_specstruc);
 if help_boolean then with p2stacktop^ do
 begin
  st_retrieve(p2_typeref, st2_cur_ptr);
  if st2_cur_ptr^.st_kind=ctype then
  begin 
   st2_cur_address:= st2_cur_ptr^.typeref; 
   st_retrieve(st2_cur_address,st2_cur_ptr);
  end else st2_cur_address:= p2_typeref;
  if st2_cur_ptr^.st_kind=cprogram then
  begin
   if create_call then
   begin
    syntaxkind:= sprogcall;
    put_byte(ord(cprogramcall));
    putaddress(st2_cur_address);
    create_call:= false;
    p2_listref:= st2_cur_ptr^.listref;
   end else syntaxkind:= svarprog;
   nodeaddress:= st2_cur_address;
   p2_typeref:= st2_cur_ptr^.typeref;
  end;
 end;
end
else
(* no repair
if p2stacktop^.syntaxkind=stypeid then (* after repaired structured value *)
(*begin
warning(pass2, 165);
(* ')' was repaired to ':)' *)
(*token:= cendstruc;
(*goto 9876; *)(* after read next token *)
(*do_endactual := true; exit;*)
(*end (* repair end of structured value *)
(*else
*)
if p2stacktop^.syntaxkind=sactualparam then
with p2stacktop^ do
begin
former^.p2_listref:= p2_listref;
put_byte(ord (cendactual));
pop_p2stack;

if p2stacktop^.syntaxkind = stypeid then
(** binding family within expression -     **)
(*  simulate that 'cendtype' is read from pass1code  *)
put_byte(ord(cendtype));
end
else
if within_opencall then
(** end of open routinecall **)
begin
bind_open;

st_retrieve(p2stacktop^.former^.former^.nodeaddress,st2_cur_ptr);
(* i.e. access routine-node **)

 
if (st2_cur_ptr^.st_spix = pred_spix) or
(st2_cur_ptr^.st_spix = succ_spix) then
(* resulttype of pred/succ-call is type of the actual parameter *)
(* both has got ONE parameter *)
(* resulttype  of call is to be placed  in 'p2_typeref' of *)
(* 'sopenfunccall' or 'sopenproccall'-node in p2stack   *)
p2stacktop^.former^.former^.p2_typeref := p2stacktop^.p2_typeref;

put_byte(ord (cendactual));

pop_opencall;
end;

end; (* endactual *)

PROCEDURE do_endarray;
begin
with p2stacktop^ do  (* element type *)
begin
st2_cur_address:= nodeaddress;
(* "spec_struct" - inf. is to put into array-type-node: **)
former^.former^.p2_specstruc :=  former^.former^.p2_specstruc + p2_specstruc;
end;
pop_p2stack; (* element type *)
st_retrievetype(p2stacktop^.nodeaddress, st2_cur_ptr);
if not ordinaltype(st2_cur_ptr^.st_kind) then
errormsg(pass2, 146);
(* index type must be an ordinal type *)
st_gettype(p2stacktop^.former^.nodeaddress, st2_cur_ptr);
with st2_cur_ptr^ do
begin
typeref:= st2_cur_address; (* element type *)
itype:= p2stacktop^.nodeaddress; (* index type *)
end; (* with *)
pop_p2stack;  (* index type *)

(* p2stacktop now points out 'carraytype'
- update 'spec_struct' in ST and in 'typedeclnode' in p2stack *)
with p2stacktop^ do
begin
if former^.syntaxkind = slevel then
(* typedeclaration - skip 'slevel'-node *)
begin
st_get(former^.former^.nodeaddress, st2_cur_ptr);
former^.former^.p2_specstruc := p2_specstruc;
end
else
(* inline typedefinition *)
begin
st_get(nodeaddress, st2_cur_ptr);    (*** ??? former^ ?? ***)
former^.p2_specstruc := p2_specstruc;
end;

st2_cur_ptr^.spec_struct := p2_specstruc;

routine_specstruc := routine_specstruc + p2_specstruc;

if test_stack then write_p2stack;
end;

put_byte(ord(cendarray));
end; (* cendarray *)

FUNCTION do_beginactual : boolean;
BEGIN
do_beginactual := false;
(* start of actual paramlist *)
(* dump p2code *)
with p2stacktop^ do
begin
if (syntaxkind=svar) or (syntaxkind = sconst) then
begin
push_p2stack;
with p2stacktop^ do
begin
syntaxkind:= sindex;
p2_typeref:= former^.p2_typeref; (* array type *)
end; (* with *)
end (* array *)
else
if (syntaxkind=sproccall) or
(syntaxkind=sfunccall) or
(syntaxkind=sfunccalle) or
(syntaxkind=sprogcall) or
(syntaxkind = sopenfunccall) or
(syntaxkind = sopenfunccalle) or
(syntaxkind = sopenproccall) or
(syntaxkind=stype) then
begin
push_p2stack;
with p2stacktop^ do
begin
syntaxkind:= sactualparam;
p2_listref:= former^.p2_listref;
end; (* with *)
put_byte(ord(cbeginactual));
end
else
if syntaxkind=stypeid then 
(* no repair
begin
if not equal_addr(p2_listref, st_stopaddr) then
*)
begin
push_p2stack;
with p2stacktop^ do
begin
syntaxkind:= sactualparam;
p2_listref:= former^.p2_listref;
end; (* with *)
put_byte(ord(cbeginactual));
end
(*
else
begin  (* repair structured value *)
(*warning(pass2, 166);
(* '(' after type name was repaired to '(:' *)
(*token:= cbeginstruc;
goto 9876; (* after read next token *)
(*do_beginactual := true; exit;
(*end;  (* structured value repair *)
(*end *)
else
errormsg(pass2, 0);
(* not implemented *)

end; (* beginactual *)
end;

FUNCTION do_lockvar : Boolean;
var helpptr : st_elemPtr;
begin
do_lockvar := false;
with p2stacktop^ do
if (syntaxkind<>svar) then
errormsg(pass2, 199)
(* only variable allowed *)
else
if (not equal_addr(p2_typeref, st_chaintype_addr)) and
(not equal_addr(p2_typeref, st_referencetype_addr)) then
errormsg(pass2, 169);
(* object of LOCK/LOCKBUF must be of type chain or reference *)
pop_p2stack; (* the variable *)
put_byte(ord(clockvar));
getaddress(st2_cur_address);
putaddress(st2_cur_address);
if cross then st_cross_decl(st2_cur_address,token,true);
p2stacktop^.former^.nodeaddress := st2_cur_address; (* remember lockvar-addr *)
st_get(st2_cur_address, st2_cur_ptr);
token := getcode;
with st2_cur_ptr^ do
(* TOG lock with retype *)
if token=cnolocaldecl then
begin
{$IFDEF RTP86}
if p2stacktop^.former^.syntaxkind=slock then
begin
copy_type(st_dataarea_type_addr, typeref);
st2_cur_address := typeref;
if segment_nr<>1 (* declared in segment 1 *) then
begin
st_get(st_dataarea_type_addr, st2_cur_ptr);
st2_cur_ptr^.st_t_local_near:=false;
end;
end
else
begin
copy_type(st_buffer_type_addr, typeref);
st2_cur_address := typeref;
if segment_nr<>1 (* declared in segment 1 *) then
begin
st_get(st_buffer_type_addr, st2_cur_ptr);
st2_cur_ptr^.st_t_local_near:=false;
end;
end;

st_get(st2_cur_address, st2_cur_ptr);
st2_cur_ptr^.type_mode := bound_fam;
{$ELSE}
 st_declaration(crecordtype,anonymousname,typeref,st2_cur_ptr);
 st2_cur_ptr^.spec_struct := [SimpelType];
{$ENDIF}
in_lock_state:= false;
put_byte(ord(cnolocaldecl));
{$IFDEF RTP86}
put_byte(ord(ctypeid));
putaddress(st2_cur_address);
put_byte(ord(cendtype));
{$ENDIF}
st_insert_headsymbol(p2stacktop^.former^.nodeaddress);  (* insert 'lockvar' *)
end else begin
st_insert_headsymbol(p2stacktop^.former^.nodeaddress);  (* insert 'lockvar' *)

(*goto 9876;*)  (* i.e. skip reading next token - which is  already done ! *)
do_lockvar := true; exit;
end;
end; (* clockvar *)

procedure do_endassign;
(* reducing assignment statement <-
  variable --> expression --> ENDASSIGN *)
(* pass2code:                                *)
(*            ----> ENDASSIGN -------------> *)
(*              +-> ENDASSIGNSET -----+      *)
(*              +-> ENDASSIGNSTRING --+      *)
(* check assignment compatability between expression(stacktop) *)
(* and variable (former) *)
begin
with p2stacktop^ do
if (former^.syntaxkind<>svar) and (former^.syntaxkind<>svarfunc) then
begin
errormsg(pass2, 111);
put_byte(ord(cendassign));
(* lefthandside of statement is not a variable *)
end
else
if not compatible(former^.p2_typeref, p2_typeref) then
begin
errormsg(pass2, 110);
put_byte(ord(cendassign));
(* variable and expression not compatible *)
end
else
begin
st_retrieve(former^.p2_typeref, st2_cur_ptr);

if st2_cur_ptr^.spec_struct * shielded_types<>[] then
errormsg(pass2, 131);
(* assignment to variable of shielded type not allowed *)
if maybe_set_type or set_result then
begin
set_result:=false;
put_byte(ord(cendassignset));
end
else if maybe_string_type then put_byte(ord(cendassignstring))
else
  BEGIN
  put_byte(ord(cendassign));
  IF Maybe_fam_type then
    BEGIN
      put_byte(ord(cCheckparam));
      PutAddress(p2_typeref);
      PutAddress(former^.p2_typeref);
    END;
  END;
end; (* with p2stacktop *)

if cross then st_cross_line(p2stacktop^.Former^.nodeaddress,cassignstat);
pop_p2stack; (* right hand side *)
pop_p2stack; (* left hand side *)
before_assign:= true;
end; (* cendassign *)

{$I rtp86p2a.pas}
end.