{$O+,F+}
unit  rule037;
interface
uses pscplm,sthunit,sthcom,sthp34,mpaunit,p3cmmn;
PROCEDURE init_systemtype
(
addr : st_address;
mode : integer;
Var evaluation_app : word;
VAR Current_offset : word
);

PROCEDURE rule_variable_declaration
	(
	VAR
		i_code					:	codes;
		current_level			:	WORD;
	VAR
		current_offset			,
		evaluation_appetite		:	WORD;
		address : addressprocedure
	)
;

implementation
uses p3math,p3rw,rule018,rule066;

PROCEDURE init_systemtype
(
addr : st_address;
mode : integer;
Var evaluation_app : word;
VAR Current_offset : word
);

VAR
st_ptr : st_elemptr;
hlp_addr : st_address;
hlp_kind : codes;
initsystem_types : st_protect_type;
app : word;

(* $SUBTITLE('------------ PROCEDURE component_init') *)
PROCEDURE component_init(type_addr:st_address);
VAR
st_ptr ,
st_hlpptr  : st_elemptr;
rec_field_addr  : st_address;

BEGIN
(* type_addr points to a node (ctype-node) which is either a protected type or
an array or a record containing a protected component *)
(* pass3code: 37.3, 38.3
component init
*)
if equal_addr(type_addr, st_mailboxtype_addr) then
store_code(cmailbox)
else
if equal_addr(type_addr, st_pooltype_addr) then
store_code(cpool)
else
if equal_addr(type_addr, st_chaintype_addr) then
store_code(cchain)
else
if equal_addr(type_addr, st_processtype_addr) then
store_code(cprocess)
else
if equal_addr(type_addr, st_porttype_addr) then
store_code(cport)
else
if equal_addr(type_addr, st_referencetype_addr) then begin
if mode=2 then store_code(cnewtype);
store_code(creference)
end else
begin
st_retrievetype(type_addr, st_ptr);

WITH st_ptr^ DO
CASE st_kind OF

cpointertype:
if (mode<>1) OR (Computer = RC5000) then store_code(st_kind);

carraytype:
BEGIN

store_code(carrayinit);
store_symbol(type_addr);
IF Computer = RC3502 THEN
  BEGIN
    Store_arg_1(Current_offset);
    Current_offset := Current_offset + wordsize;
    Max_Block_Offset := Current_offset;
  END;
init_systemtype(typeref, mode, app,Current_offset);
         (* points to ctype node of element type, which
            contains protected component *)
If Computer = RC5000 THEN App := App + 8;

store_code(cendarrayinit);
store_symbol(type_addr);
IF Computer = RC3502 THEN
  BEGIN
    Current_offset := Current_offset - wordsize;
  END;

END;

crecordtype:
BEGIN

store_code(crecordinit);
rec_field_addr:= listref; (* first field in record *)
WHILE NOT equal_addr(rec_field_addr,st_stopaddr) DO
BEGIN
init_systemtype(rec_field_addr, mode, app,Current_offset);
               (* points to node with kind crecfield*)
st_retrieve(rec_field_addr,st_hlpptr);
rec_field_addr:= st_hlpptr^.listref (* next field or stopaddr*)

END;

IF Computer = RC5000 THEN App := App + 4;

store_code(cendrecordinit);
store_symbol(type_addr);

END;

cprogram: begin
store_code(cprogram);
store_symbol(type_addr);
end;

(*OTHERWISE*) ELSE
fatal_error(this_pass,150) (* illegal code in component_init*)
END;
end; (* pointer or structure *)

END; (*component_init*)

BEGIN
(* init_systemtype *)
(* init_systemtype is called first time when endvar, endshared or init is
met in pass2code. IF type is not protected nor contains protected
components init_systemtype does nothing.
IF type is protected init_systemtype dumps initcodes and calls component
init.
It is again called from component init, IF an array or a record is met in
a component.These recursive calls traverses the whole type definition of
the variable or shared variable in question and initiates the systemtypes
which may occour.
Addr points to a node with kind cvar/cshared (first time) or crecfield
(IF record is met in component init) or ctype (element type of array with
protected component *)

app := 0;

if (mode=1) AND (Computer <> RC5000) then
BEGIN
  initsystem_types:= protected_types -  [ pointertype, mailboxpointer ]
END ELSE initsystem_types:= protected_types;

hlp_addr:= addr;
st_retrieve(addr, st_ptr);

WITH st_ptr^ DO
CASE st_kind OF

cvar,
cshared,
crecfield:
BEGIN

hlp_kind:= st_kind;
addr:= typeref;
st_retrieve(addr, st_ptr) (* points to ctype node of type of var or shared or
ctype node of type of field *)
END;

ctype:
hlp_kind:= ctype; (*array: point already to ctype node of element type*)

(*OTHERWISE*) ELSE
fatal_error(this_pass, 151)
(* mismatch in symboltable:occoured in system init at mark 1 *)
END;

WITH st_ptr^ DO
BEGIN

IF (st_kind <> ctype) THEN
fatal_error(this_pass,152) (* mark 2 *); (* kind must be ctype *)

IF initsystem_types*spec_struct <> [] THEN
CASE hlp_kind OF

cshared,
cvar:
(* this_passcode: 37.2,38.2  system init *)
BEGIN

store_code(cinit);
store_code(caddr);
store_symbol(hlp_addr); (* cvar/cshared node *)

component_init(addr) (* ctype node*)

END;

crecfield:
(* pass3code: part of 37.3,38.3
component init:
FIELDINIT(SYMBOL) ----> component init
*)
BEGIN

store_code(cfieldinit);
store_symbol(hlp_addr); (* crecfield node*)

component_init(addr) (* ctype node*)

END;

ctype:
component_init(addr); (* ctype node of array element type *)

(*OTHERWISE*) ELSE
fatal_error(this_pass, 153) (*mark 3*)
END;

END; (* with st_ptr *)

IF App > Evaluation_app THEN Evaluation_app := app;

END; (* procedure init_systemtype *)

(* $SUBTITLE('------------ PROCEDURE rule_variable_declaration')*)
PROCEDURE rule_variable_declaration
(  (*  Call  Return  *)
VAR
i_code  : codes; (*  *)
current_level : WORD; (*  *)
VAR
current_offset , (*  *)
evaluation_appetite  : WORD; (*  *)
address   : addressprocedure(*  *)
);

(* ------------------------------------------------------------------------
Pass2Code: 37
variable declaration ::= VARDECL(SYMBOL)<defining type><endvar>
endvar  ::= ENDVAR!<INIT(SYMBOL)<expression>ENDINIT>

Pass3Code: 37
variable declaration ::= <defining type><allocdynvar><init>
allocdynvar ::= !<allocdynvar>
!ALLOCDYNVAR(OFFSET,SYMBOL)

---------------------------------------------------------------------------
Pass2Code: 38
shared declaration  ::= SHAREDDECL(SYMBOL)<defining type><endshared>
endshared ::= ENDSHARED!<INIT(SYMBOL)<expression>ENDINIT>

Pass3Code: 38
shared declaration  ::= <defining type><alloc dyn shared><init>
alloc dyn shared  ::= !ALLOCDYNSHARED(OFFSET,SYMBOL)

---------------------------------------------------------------------------
init  ::= !<system type init>
!<initialize>
initialize ::= INIT<variable><expression>ENDINIT

Symbol Table:
-.

===========================================================================

Error Messages and Warnings:
fatal_error(this_pass, 150)
fatal_error(this_pass, 151)
fatal_error(this_pass, 152)
fatal_error(this_pass, 153)
fatal_error(this_pass, 154)
e_token
-.
External Dependencies:
rule_test_set (defined in PASS3CMMN.INC)
-.
External Effects:
rule_test_set (defined in PASS3CMMN.INC)
-.
Stack Appetite:
-.
Comments:
-.
Outstanding:
-.
------------------------------------------------------------------------ *)

CONST
(*#BEGINTEST
rule_version = 005;
this_rule  = 037;
(*ENDTEST#*)
code = true;

VAR
aux_symbol,
st_init_symbol ,
st_var_symbol : st_address;

st_var_ptr  : st_elemptr;

object_size  : WORD;
object_dynamic: boolean;

object_kind: codes; (* var or shared *)

alloc_dyn,
init_expression : BOOLEAN;

(*#BEGINTEST
rule_test  : BOOLEAN;
(*ENDTEST#*)

(* $SUBTITLE('------------ FUNCTION protected')*)
FUNCTION protected
(
spec_struct : st_protect_type
) : BOOLEAN;
BEGIN

protected:= protected_types * spec_struct <> []

END (* function protected *);


(* $SUBTITLE('------------ PROCEDURE rule_variable_declaration') *)
BEGIN

(*#BEGINTEST
rule_test:= i_code IN rule_test_set;

IF rule_test THEN
WRITELN
(
testoutput, ' Begin Rule ', this_rule:3,
' V', (pass3_version + rule_version):3,
'/ ', WORD(i_code):3
);
(*ENDTEST#*)

load_symbol(st_var_symbol);

object_kind:= i_code;

st_retrieve(st_var_symbol, st_var_ptr);

rule_defining_type
(
i_code, code, st_var_ptr^.typeref,
current_level, current_offset, address,
object_size, evaluation_appetite,
object_dynamic
);

alloc_dyn:= object_dynamic;
(* TOG alloc_dyn := (object_size=0); *)

load_code(i_code);
(* - 'i_code' is 'cendvar', 'cendshared' or 'cinit'. ??? *)

if i_code=cinit then
BEGIN
load_symbol(st_init_symbol);
load_expression(i_code, e_stck^, current_level, current_offset);
init_expression:= true;
(* - 'i_code' is endinit/endassignstring/endassignset  *)
IF computer <> RC3502 THEN
if i_code=cendassignset then
with e_stck^, stck[ last_fct ] do
stck[ former_fct ].precode:= cpreset;
END
else
init_expression:= false;

if object_kind=cshareddecl then
object_size:= object_size+shared_var_size
else if alloc_dyn(* TOG object_dynamic or (object_size=0) *)  then
(* dynamic sized object, reserve room for a pointer to the object;
for shared objects the shared header pointer is used, i.e. allocation of
an extra pointer is not necessary *)
object_size:= address_size;

REPEAT

st_get(st_var_symbol, st_var_ptr);

st_var_ptr^.var_level:= current_level;
st_var_ptr^.st_size:= object_size;
IF (Computer = RC3502) AND ( ( (st_var_Ptr^.spec_Struct  * ShieldType35 ) <> [])  OR
                             ( object_kind = cshareddecl) ) THEN
  Current_offset := Current_Offset + ord(odd(Current_Offset));
address(current_offset, st_var_ptr^.var_offset, object_size);

if alloc_dyn then
begin
if object_kind=cvardecl then
begin
st_var_ptr^.var_indir:= true;
store_code_1(callocdynvar, st_var_ptr^.var_offset);
end
else
store_code(callocdynshared);
store_symbol(st_var_ptr^.typeref);
end; (* allocate dyn object *)

(* If shared then initialize shared*)

IF (st_var_ptr^.st_kind = cshared) THEN
BEGIN

store_code(cinit);
store_code(caddr);
store_symbol(st_var_symbol); (* addr of shared node *)

st_retrieve(st_var_ptr^.typeref, st_var_ptr); (* ctype node of type of shared object *)

WITH st_var_ptr^ DO
BEGIN

IF (st_kind <> ctype) THEN
fatal_error(pass3, 154);
(*mismatch in symboltable. occoured when init shared variable*)

IF (type_mode = dyn) THEN
store_code(cinitdynshar)
ELSE

store_code(cinitshar)

END;
st_retrieve(st_var_symbol, st_var_ptr); (* reestablish st state *)
END;

IF init_expression THEN
BEGIN

store_code(cinit);

store_code_symbol(caddr, st_var_symbol);

dump_expression(e_stck^, evaluation_appetite, current_level, current_offset);

if range_check then
begin
st_retrieve(st_var_ptr^.typeref, st_var_ptr);
if (e_stck^.stck[ e_stck^.last_fct ].kind=csimpleconst) and
(st_var_ptr^.type_mode=stat) then
begin
if range_error(st_var_ptr^.typeref, e_stck^.stck[ e_stck^.last_fct ].ww_value) then
errormsg(this_pass, e_range);
end
else
begin
aux_symbol:= st_var_ptr^.typeref; (* defining type address *)
st_retrieve(aux_symbol, st_var_ptr);
if st_var_ptr^.st_kind=csubrange then
store_code_symbol(crangecheck, aux_symbol);
end;

st_retrieve(st_var_symbol, st_var_ptr); (* reestablish st state *)
end; (* if rangecheck *)

store_code(i_code); (* endinit/endassignstring/endassignset  *)

END;

(*IF protected component in type THEN initialize component*)

if init_expression
then init_systemtype(st_var_symbol, 1,evaluation_appetite,Current_offset)
else init_systemtype(st_var_symbol, 0,evaluation_appetite,Current_offset);
(*addr of var or shared var*)


st_var_symbol:= st_var_ptr^.listref

UNTIL st_var_ptr^.st_listend;

(*#BEGINTEST
IF rule_test THEN
WRITELN
(
testoutput, ' - End Rule ', this_rule:3,
' V', (pass3_version + rule_version):3,
'/ ', WORD(i_code):3
);
(*ENDTEST#*)

END (* - PROCEDURE rule_variable_declaration - *);
END.