|
DataMuseum.dkPresents historical artifacts from the history of: DANOSI |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about DANOSI Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 63048 (0xf648)
Types: TextFile
Names: »P5PROC.PAS«
└─⟦b6837b237⟧ Bits:30010500 SW2103 REL 1.11 Sourcer DVBS1.SW2103.rel.1.11-1 MASTER 31-1-192
└─⟦this⟧ »P5PROC.PAS«
procedure code_set_maxstack (reservation : identifier);\r
const lm_regno = -2;\r
\r
begin\r
\r
out_op_id (op_revgw, id_maxstack);\r
(* decrease maxstack by <reservation> *)\r
out_opcode (op_rechw);\r
\r
if reservation = id_exitappetite then\r
out_identifier (id_exitappetite)\r
else\r
(* reservation = id_bonappetite *)\r
if enforced_exception_app < 0 then\r
out_identifier (id_bonappetite)\r
else\r
out_expr( id_exitappetite, (9 (*words for hwstack and count*) + 1 (*word for parameter*)\r
+ enforced_exception_app) * 2); (*in bytes*)\r
\r
out_opcode (op_usub);\r
\r
\r
out_opcode (op_cgreg);\r
out_op_int (op_uadhw, lm_regno);\r
\r
out_opcode (op_crput);\r
end;\r
\r
\r
procedure code_exit;\r
\r
var\r
key : integer;\r
\r
begin\r
\r
code_call_proc (sys_use, ext_lookup (key, '___exit___rc'), key, const_niv_0, 0, 0,0);\r
end; (* procedure code_exit *)\r
\r
\r
procedure code_initvar( kind, offset, type_o : integer;\r
var ref_count : integer; var shadow_count : integer);\r
(* outputs the code for initializing variables of type: pointer, semaphore,\r
reference or shadow *)\r
\r
var\r
o_i, o_c : identifier;\r
key: integer;\r
\r
begin\r
shadow_count := 0;\r
\r
ref_count := 0;\r
\r
\r
case type_o of\r
shadow_typ: begin\r
if kind=1 then\r
out_op_int(op_reald, offset)\r
else\r
if offset<>0 then \r
out_op_int(op_reasd, offset);\r
\r
if heap_init then\r
code_call_proc(sys_use, ext_lookup(key, '_heapsh___rc'), key, const_niv_0, 0, 4, 0)\r
else\r
code_call_proc(sys_use, ext_lookup(key, '_initsh___rc'), key, const_niv_0, 0, 4, 0);\r
out_comment(' initialize shadow object ');\r
shadow_count:= 1;\r
end;\r
\r
pointer_typ:\r
begin\r
if heap_init then\r
begin (* test for enough memory for the NEW call *)\r
(* before initializing the pointer component *)\r
(* The address of the heap element is on the stack, kind = 2 *)\r
out_nl;\r
out_token(zbegin);\r
out_p_id(id_nil_element);\r
out_token(zendlist);\r
out_comment('test result<>nil');\r
out_opcode(op_reaxd);\r
out_op_int(op_reasd, -2);\r
out_opcode(op_tnill);\r
out_op_id(op_jmzne, id_nil_element);\r
end; (* heapinit *)\r
\r
(*push nilvalue on stack. store base_byte in address *)\r
out_op_int(op_rechw,const_nil_var);\r
if kind=1 then\r
out_op_int(op_stvlb,offset)\r
else\r
out_op_int(op_stvsb, offset);\r
out_comment(' initialize pointer object ');\r
if heap_init then\r
begin (* put label for nil test indication no memory *)\r
out_op_id(op_jmprw, id_end_nil_test);\r
out_label(id_nil_element);\r
out_op_int(op_stnhb, 4); (* no context eval *)\r
out_nl;\r
out_label(id_end_nil_test);\r
out_nl;\r
out_token(zend);\r
end;\r
end; (* pointer *)\r
\r
sem_typ: begin\r
if kind=1 then\r
out_op_int(op_reald, offset)\r
else\r
if offset<>0 then \r
out_op_int(op_reasd, offset);\r
code_call_proc(sys_use, ext_lookup(key, '_initsem__rc'), key, const_niv_0, 0, 4, 0);\r
out_comment(' initialize semaphore object ');\r
end;\r
\r
ref_typ:\r
begin\r
if kind=1 then\r
out_op_int(op_reald, offset)\r
else\r
if offset<>0 then \r
out_op_int(op_reasd, offset);\r
if heap_init then\r
code_call_proc(sys_use, ext_lookup(key, '_heapref__rc'), key, const_niv_0, 0, 4, 0)\r
else\r
code_call_proc(sys_use, ext_lookup(key, '_initref__rc'), key, const_niv_0, 0, 4, 0);\r
out_comment(' initialize reference object ');\r
ref_count:= 1;\r
end;\r
else error(pass4code_error);\r
end;\r
\r
end (* code_initvar *);\r
\r
\r
\r
procedure code_stat_to_dyn( size : integer );\r
\r
begin\r
\r
(* this procedure moves ( conceptually !! ) a block of 'size' bytes\r
( which must be one or more sets ) from the static part of the \r
evaluation stack, to the dynamic part. *)\r
\r
context_eval( -size )\r
\r
end;\r
\r
\r
procedure code_dyn_to_stat( size : integer );\r
\r
begin\r
\r
(* this procedure has the opposite effect as 'code_stat_to_dyn' *)\r
\r
context_eval( size )\r
\r
end;\r
\r
procedure code_exception;\r
const\r
hard_size_max = 20;\r
\r
var\r
key, i, j, p, r, w, hard_size,number_of_elem,old_hw_size : integer;\r
hard_set : array [ 0 .. hard_size_max ] of integer;\r
callkind : callmodes;\r
\r
begin\r
\r
if( exc_descr.state = 1 ) and ( epilog_yes ) then\r
begin\r
old_hw_size := hw_stack_size;\r
out_opcode(op_ststc);\r
if measurement_yes then\r
code_call_proc( sys_use, ext_lookup( key, 'trap_code_rc' ), \r
key, const_niv_0, 0, 0 ,0);\r
\r
(*dump the hw_stack and remember the hwstacksize*)\r
\r
out_op_id(op_reaad,id_exit);\r
out_op_id(op_stvga,id_expoint);\r
\r
(*output code to decrease lm (in the reg. set) by exitappetite *)\r
\r
code_set_maxstack(id_exitappetite);\r
out_op_id(op_revgw,id_excode);\r
\r
with exc_descr do\r
begin\r
if internal then\r
callkind := int_call\r
else\r
callkind := getkind (key);\r
code_call_proc (general_use, callkind, key, c.niv, lix, 2,0);\r
end;\r
\r
(* calculate : hard_set[ 0 .. hard_size ] *)\r
\r
if ( c_exc_max div 16 ) > hard_size_max then\r
error(compiler_error);\r
\r
for i := 0 to hard_size_max do hard_set[ i ] := 0;\r
\r
for i := 0 to c_exc_max do\r
if i in exc_hard then\r
begin\r
\r
w := i div 16; p := i mod 16;\r
r := 1; for j := p to 14 do r := r*2;\r
hard_set[ w ] := hard_set[ w ] + r\r
\r
end;\r
\r
hard_size := hard_size_max;\r
while ( hard_set[ hard_size ] = 0 ) and ( hard_size > 0 ) do\r
hard_size := hard_size - 1;\r
number_of_elem := hard_size + 1;\r
\r
out_nl; out_nl;\r
out_token (zbegin);\r
out_p_id (id_hardset);\r
out_token (zendlist);\r
out_nl;\r
\r
(*code for testing if it was a hard execption or not *)\r
out_op_id(op_revgw,id_excode);\r
out_op_id(op_reaad,id_hardset);\r
out_op_int(op_rechw,word_length * number_of_elem + word_length);\r
(*move hardset to the stack*)\r
out_specopcode(op_revsm,word_length * number_of_elem + word_length);\r
(*test membership of hardset*)\r
out_specopcode(op_settm,-(word_length * number_of_elem + word_length));\r
\r
(*jump to exit point if hard exception *)\r
out_op_id(op_jmzgt,id_exit);\r
\r
(*if not hard exception then*)\r
(*reestablish maxstack*)\r
code_set_maxstack(id_bonappetite);\r
(*restore exceptionpoint*)\r
out_op_id(op_reaad,id_exception);\r
out_op_id(op_stvga,id_expoint);\r
(*reestablish hw_stack*)\r
out_opcode(op_restc);\r
hw_stack_size := old_hw_size;\r
(*jump to point where exception occured*)\r
out_op_id(op_jmpga,id_exic);\r
\r
out_nl; out_nl;\r
\r
out_label( id_hardset );\r
out_token(zconst);\r
out_integer(number_of_elem * word_length + word_length);\r
\r
for i := 0 to hard_size do\r
begin\r
out_nl;\r
out_tab( 15 ); out_integer( hard_set[ i ] )\r
end;\r
(*output size of hardset*)\r
out_nl;\r
out_tab(15); out_integer(word_length*number_of_elem);\r
\r
out_nl;\r
out_token (zend); (* end of const *)\r
out_nl;\r
out_token (zend); (* end of block *)\r
out_nl;\r
\r
end\r
\r
else\r
begin\r
\r
if epilog_yes then error(pass4code_error); (* exceptionnot defined *);\r
\r
out_op_id (op_jmprw, id_exception);\r
\r
end\r
\r
end (* code_exception *);\r
procedure code_remove(count : integer; dynamics : boolean; type_o : integer);\r
\r
var\r
work_size ,\r
cont_hw_size ,\r
rep_hw_size : integer;\r
jump : opcode;\r
\r
begin\r
(* if not dynamics then\r
remove ( and check = NIL ) 'count' variables\r
from the chain of shadows or references\r
else \r
remove all shadow or reference variables of local frame from the chain \r
*)\r
\r
out_nl;\r
out_token (zbegin);\r
out_p_id (id_rep);\r
out_p_id (id_cont);\r
out_p_id (id_endrep);\r
out_token (zendlist);\r
if type_o = shadow_typ then\r
out_comment( ' remove and check shadow variables.' )\r
else\r
out_comment( ' remove and check reference variables.' );\r
\r
if dynamics then\r
begin\r
out_op_int (op_reald, -1);\r
out_comment (' get lf ');\r
work_size := 6;\r
jump := op_jmprw;\r
end\r
else\r
if count > 1 then\r
begin\r
work_size := 2;\r
jump := op_jmzne;\r
out_op_int (op_rechw, count);\r
end;\r
\r
out_label (id_rep);\r
rep_hw_size := hw_stack_size;\r
\r
if type_o = shadow_typ then\r
out_op_id (op_revga, id_shadowchain)\r
else\r
out_op_id (op_revga, id_refchain);\r
\r
out_opcode ( op_revpd );\r
\r
if dynamics then\r
begin\r
out_opcode (op_reaxd);\r
out_op_int (op_revsw, -9);\r
out_comment (' push lf.disp ');\r
out_opcode (op_ult);\r
out_op_id (op_jmzne, id_endrep);\r
out_op_int (op_stnhb, 2); (* no context eval here !! *)\r
out_opcode (op_revpd);\r
end;\r
\r
(*field descriptor on top of stack*)\r
if type_o = shadow_typ then\r
out_op_int (op_rechw, c_shadow_field_nil)\r
else\r
out_op_int (op_rechw, c_ref_field_nil);\r
out_opcode (op_revsf);\r
out_op_id (op_jmzne, id_cont);\r
cont_hw_size := hw_stack_size;\r
\r
if type_o = shadow_typ then\r
code_exc_trigger (c_exc_shadow)\r
else\r
code_exc_trigger (c_exc_ref);\r
\r
out_label (id_cont);\r
if cont_hw_size <> hw_stack_size then\r
if type_o = shadow_typ then\r
hw_stack_error (shadow_removal)\r
else\r
hw_stack_error (ref_removal);\r
\r
if type_o = shadow_typ then\r
begin\r
out_op_id (op_revsa, id_oshadow);\r
out_op_id (op_stvga, id_shadowchain);\r
end\r
else\r
begin\r
out_op_id (op_revsa, id_oref);\r
out_op_id (op_stvga, id_refchain);\r
end;\r
\r
if not dynamics then\r
if count > 1 then\r
begin\r
out_op_int (op_uadhw, -1);\r
out_opcode (op_revpw);\r
end;\r
\r
if (count > 1) or dynamics then\r
begin\r
with op_table [jump] do\r
if hw_stack_size <> (rep_hw_size + abs(opappetite)) then\r
out_resta(rep_hw_size + abs(opappetite));\r
out_op_id (jump, id_rep);\r
out_label (id_endrep);\r
out_specopcode (op_stnhb, -work_size);\r
end;\r
\r
out_nl;\r
out_token (zend);\r
out_nl;\r
\r
end (* code_remove *);\r
\r
\r
\r
\r
procedure code_line_tab_header( name : identifier );\r
\r
begin\r
out_token (zname);\r
out_p_id (name);\r
out_nl;\r
out_token (zend);\r
\r
end (* code_line_tab_header *);\r
\r
\r
procedure stat_reset;\r
\r
var\r
i: addr_kind_type;\r
j : integer;\r
\r
begin\r
\r
with stat_acc.assign do\r
begin\r
\r
for i := addr to packed_arr do\r
for j := 0 to 6 do kind_type[ i, j ] := 0;\r
\r
for j := 0 to 15 do size[ j ] := 0\r
\r
end;\r
trap_nr_table := nil;\r
\r
\r
end;\r
\r
\r
procedure stat_print;\r
\r
var\r
i: addr_kind_type;\r
j : integer;\r
\r
begin\r
\r
writeln; writeln;\r
writeln( ' statistics from pass5: ' );\r
writeln;\r
\r
writeln( ' assignment: ' );\r
writeln;\r
with stat_acc.assign do\r
begin\r
\r
for i :=addr to packed_arr do\r
begin\r
for j := 0 to 6 do write( kind_type[ i, j ] );\r
writeln\r
end;\r
writeln;\r
\r
for j := 0 to 7 do write( size[ j ] );\r
writeln;\r
for j := 8 to 15 do write( size[ j ] );\r
writeln;\r
\r
end;\r
\r
writeln\r
\r
end;\r
\r
\r
\r
procedure stat_assign( l_v : varaddr_descr; l_type, l_size : integer;\r
r_v : varvalue_descr );\r
\r
var\r
i_kind : addr_kind_type;\r
i_type : integer;\r
\r
begin\r
\r
if statacc_yes then\r
with stat_acc.assign do\r
begin\r
\r
i_kind := l_v.kind;\r
\r
i_type := l_type;\r
if ( i_type > set_typ ) or ( i_type < 0 ) then i_type := 0;\r
\r
kind_type[ i_kind, i_type] := kind_type[ i_kind, i_type ] + 1;\r
\r
if ( l_type = addr_typ ) or ( l_type = set_typ ) then\r
begin\r
\r
if ( l_size < 0 ) or ( l_size > 15 ) then\r
size[ 0 ] := size[ 0 ] + 1\r
else\r
size[ l_size ] := size[ l_size ] + 1\r
\r
end\r
\r
end\r
\r
end;\r
\r
procedure find_exprs( var v: varvalue_descr);\r
forward;\r
\r
\r
procedure find_operand( var v: varvalue_descr);\r
forward;\r
\r
\r
procedure find_func_call( var v : varvalue_descr);\r
forward;\r
\r
\r
procedure find_call( var size_of_function_result : integer );\r
forward;\r
\r
\r
procedure find_constants;\r
forward;\r
\r
\r
procedure find_std_call(var v: varvalue_descr);\r
forward;\r
\r
\r
procedure find_arglist( call_mode : callmodes; var size_of_function_result : integer );\r
forward;\r
\r
procedure find_statement;\r
forward;\r
procedure find_varvalue( var v: varvalue_descr);\r
forward;\r
procedure find_varaddr( var v: varaddr_descr);\r
forward;\r
\r
\r
procedure find_init;\r
forward;\r
\r
\r
procedure find_processparam( var size_of_function_result : integer );\r
forward;\r
\r
\r
\r
procedure find_assign;\r
\r
\r
var l_v , l_v_stat, templ_v : varaddr_descr;\r
r_v : varvalue_descr;\r
l_type, l_first, l_number, l_size : integer;\r
\r
\r
begin\r
get_token;\r
\r
find_varaddr( l_v); l_v_stat := l_v; \r
if token <> xleft then error(pass4code_error);\r
\r
l_type := in_integer;\r
\r
if l_type = field_typ then\r
begin\r
l_first := in_integer; l_number := in_integer;\r
if l_number = 8 then\r
begin (* optimize 8-bit fields as bytes *)\r
if l_first = 0 then\r
l_type := byte_typ (* left byte, don't change offset *)\r
else\r
if l_first = 8 then\r
begin (* rigth byte, add one to offset *)\r
l_v.offset := l_v.offset + 1;\r
l_type := byte_typ;\r
end;\r
end;\r
end\r
else\r
if ( l_type = addr_typ ) or ( l_type = set_typ ) then l_size := in_integer\r
else\r
if l_type = dyn_typ then\r
get_niv_offset( templ_v );\r
\r
if l_v.kind = packed_arr then\r
begin\r
out_opcode(op_intpa);\r
out_opcode(op_inpdv);\r
end\r
else (*not packed array*)\r
if l_type = field_typ then\r
begin\r
load_address(l_v,true);\r
out_op_int(op_rechw,l_first*256 + l_first +l_number - 1);\r
end (*field_typ*)\r
else\r
if (l_type = addr_typ) or (l_type = set_typ) or\r
(l_type = dyn_typ) or (l_v.access = i_frame) then\r
load_address(l_v,true);\r
\r
\r
get_token;\r
find_exprs( r_v);\r
\r
\r
(* here, tests can be inserted in order to check the \r
consistency of "r_v", "l_v" and "l_type". *)\r
\r
if statacc_yes then\r
stat_assign( l_v_stat, l_type, l_size, r_v ); \r
\r
skip_token (xassign);\r
\r
case l_v.kind of\r
addr: out_op_int(op_stv[conv_frame[l_v.access],conv_type[l_type]],l_v.offset);\r
\r
stack_addr:\r
begin\r
\r
if l_type = set_typ then (* set *)\r
begin\r
\r
if r_v.kind <> 1 then error(pass4code_error);\r
\r
if r_v.size <> ( l_size + 2 ) then\r
begin\r
\r
if r_v.size > 0 then\r
begin\r
\r
code_stat_to_dyn( r_v.size );\r
\r
r_v.size := 0\r
\r
end;\r
\r
out_opcode( op_rechw );\r
out_start_param; out_integer( l_size );\r
out_specopcode(op_setad,l_size + 2 );\r
\r
end;\r
out_specopcode(op_setst,- l_size);\r
\r
end (* l_type = set_typ *)\r
\r
else\r
\r
if l_type = addr_typ then (* static structure *)\r
begin\r
\r
out_opcode( op_rechw );\r
out_start_param; out_integer( l_size );\r
out_opcode (op_moveg)\r
\r
end (* l_type = addr_typ *)\r
\r
else\r
\r
if l_type = dyn_typ then\r
begin (* dynamic structure *)\r
with templ_v do\r
out_op_rev__(access,word_typ,c.niv-niv,offset);\r
out_opcode( op_moveg );\r
end (* l_type = dyn_typ *)\r
\r
else\r
\r
begin\r
(* l_type = byte,word,field or double *)\r
if l_type <> field_typ then\r
out_op_int(op_stv[s,conv_type[l_type]],l_v.offset)\r
else \r
out_opcode(op_stvsf);\r
\r
end\r
\r
end;\r
\r
packed_arr:\r
begin\r
\r
if( r_v.kind <> 1 ) or ( ( r_v.size <> 0 ) and ( r_v.size <> 2 ) )\r
then error(pass4code_error);\r
out_opcode(op_stvsf);\r
\r
end;\r
\r
end (* case l_v.kind of... *)\r
\r
end (* find_assign *);\r
\r
\r
\r
\r
\r
procedure find_expr( var v : varvalue_descr);\r
\r
const\r
\r
max_v_stack = 10;\r
\r
var\r
\r
(* .... for the Stack module : *)\r
\r
v_stack : array [ 1 .. max_v_stack ] of varvalue_descr;\r
\r
top_v_stack,\r
state_v_stack : integer;\r
\r
(* .... for the rest of the procedure : *)\r
\r
v_o1, v_o2, v_r : varvalue_descr;\r
\r
end_expr : boolean;\r
key,\r
type_o, comp, size : integer;\r
\r
template_v : varaddr_descr;\r
\r
\r
procedure push_v_stack( v : varvalue_descr );\r
\r
begin\r
if top_v_stack >= max_v_stack then\r
error (v_stack_size)\r
else\r
begin\r
top_v_stack := top_v_stack + 1;\r
v_stack[ top_v_stack ] := v\r
end\r
end;\r
\r
\r
procedure pop_v_stack( var v : varvalue_descr );\r
\r
begin\r
if top_v_stack <= 0 then error(compiler_error);\r
if state_v_stack = 1 then\r
begin\r
v.kind := 0;\r
v.size := 0\r
end\r
else\r
begin\r
v := v_stack[ top_v_stack ];\r
top_v_stack := top_v_stack - 1\r
end\r
end;\r
\r
\r
begin\r
\r
\r
top_v_stack := 0;\r
state_v_stack := 0;\r
\r
end_expr := false;\r
\r
operand_situation := before_opands;\r
in_kind := settm; (*instruction settm to be used when in is met*)\r
\r
repeat\r
\r
case token of\r
\r
xconst,\r
xlconst,\r
xfunccall,\r
xextfunccall,\r
xstdfunccall,\r
xprocessparam,\r
xsetconst,\r
xset,\r
xaddr,\r
xcaddr:\r
begin\r
\r
(* the next item on input is an operand.\r
find the operand, and push the descriptor on\r
the v_stack :\r
*)\r
\r
if operand_situation = after_short_const then\r
begin\r
out_opcode (op_rechw);\r
out_start_param; out_integer (v_r.val);\r
operand_situation := after_opands;\r
end;\r
\r
find_operand (v_r);\r
\r
if operand_situation = before_opands then\r
operand_situation := after_opands;\r
\r
push_v_stack( v_r )\r
end;\r
\r
(* check the next item to see if it is an operator.\r
generate the proper bis-instructions for the operator.\r
take the descriptors for the operands from the v_stack,\r
and store the descriptor of the result on the v_stack :\r
*)\r
\r
xnot :\r
\r
begin\r
type_o := in_integer;\r
\r
if type_o = bool_typ then\r
\r
out_opcode( op_not )\r
else (* integer *)\r
out_opcode( op_compl );\r
\r
\r
pop_v_stack( v_o1 );\r
if ( v_o1.kind <> 1 ) or ( v_o1.size <> 2 ) then error(compiler_error);\r
\r
v_r.kind := 1; v_r.size := 2;\r
push_v_stack ( v_r );\r
get_token;\r
\r
end;\r
\r
\r
xneg :\r
\r
begin\r
\r
out_opcode( op_neg );\r
\r
pop_v_stack( v_o1 );\r
if ( v_o1.kind <> 1 ) or ( v_o1.size <> 2 ) then error(compiler_error);\r
\r
v_r.kind := 1; v_r.size := 2;\r
push_v_stack( v_r );\r
get_token;\r
\r
end;\r
\r
\r
\r
xcompare :\r
\r
begin\r
\r
comp := in_integer;\r
\r
if ( comp >= 1 ) and ( comp <= 7 ) then\r
begin\r
\r
out_opcode( op_comp[ comp ] );\r
\r
pop_v_stack( v_o2 ); pop_v_stack( v_o1 );\r
if ( v_o1.kind <> 1 ) or ( v_o1.size <> 2 ) or\r
( v_o2.kind <> 1 ) or ( v_o2.size <> 2 ) then error(compiler_error);\r
\r
v_r.kind := 1; v_r.size := 2;\r
push_v_stack( v_r )\r
\r
end\r
\r
else\r
\r
if ( comp >= 8 ) and ( comp <= 11 ) then\r
begin\r
\r
pop_v_stack( v_o2 ); pop_v_stack( v_o1 );\r
if ( v_o1.kind <> 1) or ( v_o2.kind <> 1 ) then error(compiler_error);\r
\r
code_stat_to_dyn( v_o1.size + v_o2.size );\r
(*note! because a lookahead was used to deside wether a setexpression\r
or a simple setvariable was met in order to deside wether a setre or a\r
setatm instruction shold be generated when the compare function is in,\r
then the setre instruction for other setcomparefunctions was also not\r
generated. Therefore it has to be generated BEFORE the compare instruction*)\r
if in_kind = setatm then out_specopcode(op_setre,v_o2.size - word_length );\r
(*note that the v_o2.size includes the lengthword. therefore the size has\r
to be decremented by the size of the lengthword*)\r
\r
out_opcode( op_comp[ comp ] );\r
if comp = 9 then out_opcode( op_not );\r
\r
v_r.kind := 1; v_r.size := 2;\r
\r
push_v_stack( v_r )\r
\r
\r
end\r
\r
else\r
\r
if comp = 12 then\r
begin\r
\r
pop_v_stack( v_o2 ); pop_v_stack( v_o1 );\r
if ( v_o1.kind <> 1 ) or ( v_o1.size <> 2 ) or\r
( v_o2.kind <> 1 ) then error(compiler_error);\r
(*if only a setvariable met then use setatm else use settm*)\r
if in_kind = setatm then \r
out_opcode(op_setatm)\r
else out_specopcode(op_settm,-v_o2.size);\r
\r
v_r.kind := 1; v_r.size := 2;\r
push_v_stack( v_r )\r
\r
end\r
\r
else\r
error(pass4code_error);\r
get_token;\r
\r
end;\r
\r
\r
xcompstruc :\r
\r
begin\r
\r
comp := in_integer; size := in_integer;\r
\r
pop_v_stack (v_o2); pop_v_stack (v_o1);\r
if (v_o1.kind <> v_o2.kind) or\r
(v_o1.size <> v_o2.size) or\r
(v_o1.size <> size) then\r
error (compiler_error);\r
\r
if v_o1.kind = 2 then\r
begin (* compare arrays or records *)\r
out_opcode( op_rechw );\r
out_start_param; out_integer( size );\r
out_opcode(op_stcea);\r
out_op_int(op_rechw,0);\r
if comp = xne_struc then out_opcode(op_ne)\r
else\r
if comp = xeq_struc then out_opcode(op_eq)\r
else\r
error(pass4code_error);\r
end\r
else (* compare pointers *)\r
begin\r
out_opcode(op_teqad);\r
if comp = xne_struc then out_opcode(op_not)\r
else\r
if comp <> xeq_struc then error(pass4code_error);\r
end;\r
\r
\r
v_r.kind := 1; v_r.size := 2;\r
push_v_stack( v_r );\r
get_token;\r
\r
end;\r
\r
\r
xcompdynstruc :\r
\r
begin\r
\r
comp := in_integer;\r
\r
get_niv_offset( template_v );\r
\r
pop_v_stack ( v_o2 ); pop_v_stack ( v_o1 );\r
\r
if v_o1.kind = 2 then\r
begin (* compare arrays or records *)\r
with template_v do\r
out_op_rev__(access,word_typ,c.niv-niv,offset);\r
out_opcode(op_stcea);\r
out_op_int(op_rechw,0);\r
if comp = xne_struc then out_opcode(op_ne)\r
else\r
if comp = xeq_struc then out_opcode(op_eq)\r
else\r
error(pass4code_error);\r
\r
end\r
else\r
error( pass4code_error );\r
\r
v_r.kind := 1; v_r.size := 2;\r
\r
push_v_stack ( v_r );\r
\r
get_token;\r
\r
end; (* comp dyn struc *)\r
\r
\r
xdiv :\r
\r
begin\r
\r
out_opcode( op_div );\r
\r
pop_v_stack( v_o2 ); pop_v_stack( v_o1 );\r
if ( v_o1.kind <> 1 ) or ( v_o1.size <> 2 ) or\r
( v_o2.kind <> 1 ) or ( v_o2.size <> 2 ) then error(compiler_error);\r
\r
v_r.kind := 1; v_r.size := 2;\r
push_v_stack( v_r );\r
get_token;\r
\r
end;\r
\r
\r
xshift:\r
begin\r
code_call_proc(sys_use, ext_lookup(key, '_shift____rc'), key, const_niv_0, 0, 2, 2);\r
out_comment(' shift ');\r
pop_v_stack( v_o2 ); pop_v_stack( v_o1 );\r
if ( v_o1.kind <> 1 ) or ( v_o1.size <> 2 ) or\r
( v_o2.kind <> 1 ) or ( v_o2.size <> 2 ) then error(compiler_error);\r
\r
v_r.kind := 1; v_r.size := 2;\r
push_v_stack( v_r );\r
get_token;\r
end;\r
\r
xrotate:\r
begin\r
out_opcode(op_shc);\r
pop_v_stack( v_o2 ); pop_v_stack( v_o1 );\r
if ( v_o1.kind <> 1 ) or ( v_o1.size <> 2 ) or\r
( v_o2.kind <> 1 ) or ( v_o2.size <> 2 ) then error(compiler_error);\r
\r
v_r.kind := 1; v_r.size := 2;\r
push_v_stack( v_r );\r
get_token;\r
end;\r
\r
xadd,\r
xsub,\r
xmul :\r
\r
begin\r
\r
type_o := in_integer;\r
if type_o = real_typ then\r
error(compiler_error)\r
else\r
if type_o = int_typ then\r
begin\r
\r
if token = xadd then out_opcode( op_add )\r
else\r
if token = xsub then out_opcode( op_sub )\r
else\r
out_opcode( op_mul );\r
\r
pop_v_stack( v_o2 ); pop_v_stack( v_o1 );\r
if ( v_o1.kind <> 1 ) or ( v_o1.size <> 2 ) or\r
( v_o2.kind <> 1 ) or ( v_o2.size <> 2 ) then error(compiler_error);\r
\r
v_r.kind := 1; v_r.size := 2;\r
push_v_stack( v_r )\r
\r
end\r
\r
else\r
\r
if type_o = setof_typ then\r
begin\r
\r
pop_v_stack( v_o2 ); pop_v_stack( v_o1 );\r
if ( v_o1.kind <> 1 ) or ( v_o2.kind <> 1 ) then error(compiler_error);\r
\r
code_stat_to_dyn( v_o1.size + v_o2.size );\r
\r
if token = xadd then out_opcode( op_setun )\r
else\r
if token = xsub then out_opcode( op_setdi )\r
else\r
out_opcode( op_setin );\r
\r
v_r.kind := 1; v_r.size := 0;\r
push_v_stack( v_r )\r
\r
end\r
\r
else\r
error(pass4code_error);\r
get_token;\r
\r
end;\r
\r
\r
xor_,\r
xxor,\r
xand :\r
begin\r
\r
if token = xor_ then out_opcode( op_or )\r
else\r
if token = xxor then out_opcode ( op_xor )\r
else\r
out_opcode( op_and );\r
\r
pop_v_stack( v_o2 ); pop_v_stack( v_o1 );\r
if ( v_o1.kind <> 1 ) or ( v_o1.size <> 2 ) or\r
( v_o2.kind <> 1 ) or ( v_o1.size <> 2 ) then error(compiler_error);\r
\r
v_r.kind := 1; v_r.size := 2;\r
push_v_stack( v_r );\r
get_token;\r
\r
end;\r
\r
\r
xmod :\r
\r
begin\r
\r
out_opcode( op_mod );\r
\r
pop_v_stack( v_o2 ) ; pop_v_stack( v_o1 );\r
if ( v_o1.kind <> 1 ) or ( v_o1.size <> 2 ) or\r
( v_o2.kind <> 1 ) or ( v_o2.size <> 2 ) then error(compiler_error);\r
\r
v_r.kind := 1; v_r.size := 2;\r
push_v_stack( v_r );\r
get_token;\r
\r
end;\r
\r
\r
xrangetest :\r
\r
begin\r
\r
out_opcode( op_reaad );\r
out_start_param; out_lix (c_name, in_integer);\r
\r
out_opcode( op_intrs );\r
get_token;\r
\r
end;\r
\r
xrangemax : \r
\r
begin\r
out_op_int(op_inth0,in_integer);\r
get_token;\r
end;\r
\r
\r
\r
\r
xdynrangetest :\r
\r
begin\r
\r
if operand_situation = after_short_const then\r
begin\r
out_op_int( op_rechw, v_r.val);\r
operand_situation := after_opands;\r
end;\r
\r
get_niv_offset ( template_v );\r
\r
load_address( template_v, true ); (* ?????????????????????????????????? *)\r
out_opcode( op_intrs );\r
\r
get_token;\r
\r
\r
end; (* dyn range test *)\r
\r
\r
xsubdef: (* pop the stack *)\r
begin\r
\r
pop_v_stack( v_o2 );\r
\r
end_expr := true;\r
\r
end;\r
\r
\r
\r
\r
else\r
\r
(* the input item is neither an operand nor an operator.\r
this signals the end of an expression.\r
*)\r
\r
end_expr := true\r
\r
end; (* case token of ...... *)\r
\r
until \r
end_expr;\r
\r
\r
pop_v_stack( v );\r
\r
if top_v_stack <> 0 then error(compiler_error)\r
\r
\r
end; (* find_exprs *)\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
procedure find_operand( var v: varvalue_descr);\r
\r
var size, val : integer;\r
v_c : varvalue_descr;\r
first_set : boolean;\r
\r
\r
begin\r
\r
case token of\r
\r
xconst:\r
begin\r
val := in_integer;\r
if operand_situation = before_opands then\r
begin\r
v.val := val;\r
operand_situation := after_short_const;\r
end\r
else\r
begin\r
out_opcode (op_rechw);\r
out_start_param; out_integer (val);\r
end;\r
\r
v.kind := 1;\r
v.size := 2;\r
get_token;\r
\r
end (* t_const *);\r
\r
xlconst:\r
begin\r
\r
out_opcode( op_reaad );\r
out_start_param; out_lix (c_name, in_integer);\r
\r
v.kind := 2;\r
v.size := in_integer;\r
get_token;\r
\r
end (* t_lconst *);\r
\r
xfunccall,\r
xextfunccall,\r
xstdfunccall,\r
xprocessparam:\r
begin\r
\r
find_func_call( v)\r
\r
end (* func call *);\r
\r
xsetconst :\r
begin\r
val := in_integer; (* lix for the constant *)\r
size := in_integer;\r
\r
out_opcode( op_reaad );\r
out_start_param; out_lix (c_name, val);\r
\r
out_opcode( op_rechw );\r
out_start_param; out_integer( size );\r
\r
v.kind := 1;\r
v.size := size + 2;\r
get_token;\r
(*if setexpression then output setre instruction else note that setatm shall be used*)\r
if token = xcompare then in_kind:=setatm\r
else out_specopcode(op_setre,size);\r
\r
end;\r
\r
xset :\r
begin\r
\r
first_set := true;\r
get_token;\r
\r
repeat\r
begin\r
\r
if token <> xendset then\r
find_exprs (v_c);\r
\r
case token of\r
xendset:\r
begin\r
(* simulate empty set as: (. 1 .. 0 .) *)\r
out_opcode (op_rechd);\r
out_start_param; out_integer (1);\r
out_start_param; out_integer (0);\r
end;\r
xinclude:\r
begin\r
out_opcode (op_revpw);\r
get_token;\r
end;\r
xsetexpr:\r
begin\r
get_token;\r
find_exprs (v_c);\r
skip_token (xincludeint);\r
end;\r
else error(pass4code_error);\r
end;\r
\r
out_opcode( op_setcr );\r
(* force dynamic marking of routine appetite *)\r
dyn_eval_stack:= true;\r
\r
if not( first_set ) then out_opcode( op_setun );\r
\r
first_set := false\r
\r
end\r
\r
until token = xendset;\r
\r
get_token;\r
\r
v.kind := 1;\r
v.size := 0\r
end;\r
\r
\r
else\r
begin\r
\r
find_varvalue( v)\r
\r
end\r
end; (* case token *)\r
\r
\r
end (* find_operand *);\r
\r
\r
procedure find_exprs (var v: varvalue_descr);\r
(* similar to find_expr, but always delivers result on stack *)\r
begin\r
find_expr (v);\r
if operand_situation = after_short_const then\r
begin\r
out_opcode (op_rechw);\r
out_start_param; out_integer (v.val);\r
operand_situation := after_opands;\r
end;\r
end;\r
\r
\r
\r
procedure find_func_call( var v : varvalue_descr);\r
\r
var\r
size_of_function_result, (* used by find process param *)\r
value_size : integer; (* size of result if not yoyo *)\r
\r
begin\r
size_of_function_result := 0;\r
(* used by find process param, changed by find_arglist *)\r
\r
if token = xprocessparam then\r
find_processparam( size_of_function_result )\r
else\r
begin\r
if token = xstdfunccall then\r
find_std_call (v)\r
else\r
find_call( size_of_function_result );\r
skip_token (xfcall);\r
end;\r
\r
if token <> xendfunccall then\r
find_varvalue (v) (* retrieve result of function-call *)\r
\r
else\r
if size_of_function_result <> 0 then\r
with v do\r
begin\r
kind := 1; (* on stack top *)\r
size := size_of_function_result;\r
end; (* with v *)\r
\r
value_size := in_integer;\r
get_token;\r
\r
end (* find_func_call *);\r
\r
\r
\r
procedure find_proc_call( var size_of_function_result : integer );\r
\r
begin\r
\r
if token = xprocessparam then\r
find_processparam( size_of_function_result )\r
else\r
begin\r
\r
find_call( size_of_function_result );\r
\r
skip_token (xendpcall);\r
\r
end\r
\r
end (* find_proc_call *);\r
\r
\r
procedure find_sys_init( var ref_count : integer; var dyn_refs : boolean ;\r
var shadow_count : integer; var dyn_shadows : boolean);\r
forward;\r
\r
procedure find_std_proccall;\r
var\r
dummy_refs, dummy_shadows, (* for system init of heap elements *)\r
size_of_result, key: integer; \r
dummy_dyn_refs, dummy_dyn_shadows: boolean;\r
begin\r
if in_integer<>xnew then\r
error(pass4code_error);\r
\r
out_nl;\r
out_comment(' new call ');\r
find_arglist(ext_call, size_of_result);\r
skip_token(xendnewcall);\r
\r
(* end of new call, make code to test if enough memory (result<>nil),\r
initialize possible system components, and asign the result to the pointer variable *)\r
(* stack picture: \r
-------------------------------\r
addres of pointer variable (actual parameter of new call)\r
-------------------------------\r
room for address of allocated memory\r
-------------------------------\r
wanted size in bytes\r
-------------------------------\r
top-> allign (boolean value)\r
-------------------------------\r
*)\r
code_call_proc(sys_use, ext_lookup(key, '___new____rc'), key, const_niv_0,\r
0, 2+2 (* parameter length *), 4);\r
\r
(* stack picture:\r
-------------------------------\r
address of pointer\r
-------------------------------\r
top -> address of allocated memory\r
-------------------------------\r
*)\r
(*out_nl;\r
out_token(zbegin);\r
out_p_id(id_size_ok);\r
out_token(zendlist);\r
out_comment(' test result <> nil');\r
out_opcode(op_reaxd);\r
out_op_int(op_reasd, -2);\r
out_opcode(op_tnill);\r
out_op_id(op_jmzne, id_size_ok);\r
code_exc_trigger(c_exc_new);\r
out_label(id_size_ok);\r
out_nl;\r
out_token(zend);\r
*)\r
\r
if token=xsysnewinit then\r
begin\r
heap_init:= true; (* flag special chaining of possible references and/or shadows *)\r
find_sys_init(dummy_refs, dummy_dyn_refs, dummy_shadows, dummy_dyn_shadows);\r
heap_init:= false;\r
end;\r
\r
out_op_int(op_stvsa, 0);\r
out_comment(' end new call ');\r
\r
end; (* find std proccall *)\r
\r
\r
procedure find_call( var size_of_function_result : integer );\r
\r
var\r
niv, lix, paramlength, appetite, key : integer;\r
callkind : callmodes;\r
name, id : identifier;\r
\r
begin\r
\r
case token of\r
\r
xproccall,\r
xfunccall:\r
begin (* internal routine *)\r
\r
niv := in_integer;\r
lix := in_integer;\r
\r
callkind := int_call;\r
end;\r
xextproccall,\r
xextfunccall:\r
begin (* external routine *)\r
key := in_integer;\r
niv := const_niv_0;\r
callkind := getkind (key);\r
end;\r
\r
else error(pass4code_error);\r
end; (* case *)\r
\r
paramlength := in_integer;\r
\r
find_arglist( callkind , size_of_function_result );\r
\r
code_call_proc (general_use, callkind, key, niv, lix, paramlength,size_of_function_result);\r
\r
\r
end (* find_call *);\r
\r
\r
\r
procedure find_constants;\r
\r
var\r
n, p, i : integer;\r
\r
begin\r
\r
get_token;\r
while token = xdeflix do\r
begin\r
\r
out_lix_label (c_name, in_integer);\r
\r
get_token; (* skip: xinitconst *)\r
\r
n := in_integer;\r
\r
out_tab( 15 ); out_token (zconst); out_integer( 2*n );\r
\r
p := 0;\r
for i := 1 to n do\r
begin\r
if p mod 5 = 0 then\r
begin\r
out_nl; out_tab( 20 )\r
end\r
else\r
out_char (',');\r
out_integer( in_integer );\r
p := p + 1\r
end; \r
\r
out_nl;\r
out_tab( 15 ); out_token (zend);\r
out_nl;\r
\r
get_token;\r
end;\r
end (* find_constants *);\r
\r
\r
procedure out_make_top_even;\r
(* make top of stack variable even, i.e. round up *)\r
\r
begin\r
\r
out_opcode( op_revpw );\r
out_op_int( op_rechw, 1 );\r
out_opcode( op_and );\r
out_opcode( op_uadd );\r
\r
end;\r
\r
\r
procedure compute_number_of_elements ( dope_start : integer );\r
\r
(* dope_start = ^ record\r
. size,\r
. first_index,\r
. last_index,\r
. element_size : integer;\r
. end\r
\r
*)\r
\r
begin\r
\r
out_nl;\r
out_token (zbegin); out_p_id( id_elems_ready );\r
out_token (zendlist);\r
out_comment( ' compute number of elements ' );\r
\r
out_op_int( op_revld, dope_start + 2 );\r
out_opcode( op_le ); (* 0: first > last, i.e. number of elements = 0 *)\r
out_opcode( op_revpw );\r
out_op_id ( op_jmzeq, id_elems_ready ); (* if first > last then no_of_elems := 0 *)\r
out_op_int( op_revlw, dope_start + 4 ); (* else *)\r
out_op_int( op_revlw, dope_start + 2 ); (* no_of_elems := *)\r
out_opcode( op_msub ); (* last - first *)\r
out_opcode( op_uadd ); (* + 1 *)\r
out_label ( id_elems_ready );\r
out_nl; out_token (zend);\r
out_comment(' last - first + 1 ');\r
\r
end;\r
\r
\r
\r
procedure dyn_type_declaration;\r
\r
var\r
template_v, template1_v : varaddr_descr;\r
size, first, last, dope_start : integer;\r
element_size, fields_pr_word, bits_pr_field : integer;\r
allign : boolean;\r
var_val_v : varvalue_descr;\r
\r
begin\r
\r
case token of\r
xarray1template,\r
xarray2template,\r
xarray3template : begin\r
\r
dope_start := in_integer;\r
get_niv_offset( template_v );\r
case token of\r
xarray1template: begin (* dynamic index range, static comp *)\r
element_size := in_integer;\r
fields_pr_word := in_integer;\r
bits_pr_field := in_integer;\r
\r
with template_v do\r
(*load (first, last) *)\r
out_op_rev__(access,double_typ,c.niv-niv,offset+2);\r
out_op_int( op_stvld, dope_start + 2 );\r
\r
if fields_pr_word = 1 then \r
begin (* unpacked *)\r
\r
out_op_int( op_rechw, element_size );\r
out_comment( ' unpacked dyn array, static comp ' );\r
if element_size > 2 then (* prepare multiplication *)\r
out_opcode( op_revpw );\r
out_op_int( op_stvlw, dope_start + 6 );\r
\r
(* compute the size *)\r
compute_number_of_elements ( dope_start );\r
if element_size > 2 then\r
out_opcode( op_umul )\r
else\r
if element_size = 2 then\r
begin\r
out_opcode( op_revpw ); out_comment( ' * 2 (element size) ' );\r
out_opcode( op_uadd );\r
end;\r
out_op_int( op_stvlw, dope_start );\r
\r
end\r
\r
else\r
\r
begin (* packed array *)\r
\r
out_op_int( op_rechw, fields_pr_word * 256 + bits_pr_field );\r
out_comment( ' packed dyn array, static comp ' );\r
out_op_int( op_stvlw, dope_start + 6 );\r
\r
compute_number_of_elements( dope_start );\r
out_opcode( op_revpw );\r
\r
out_op_int( op_rechw, fields_pr_word );\r
out_opcode( op_udiv );\r
out_opcode( op_revpw ); out_comment( ' * 2 ' );\r
out_opcode( op_uadd );\r
\r
out_opcode( op_reaxd ); (* get number of elements *)\r
out_op_int( op_revsw, -3 );\r
\r
out_op_int( op_rechw, fields_pr_word );\r
out_opcode( op_umod );\r
if bits_pr_field > 2 then\r
begin\r
out_op_int( op_rechw, bits_pr_field );\r
\r
out_opcode( op_umul ); out_comment( ' * bits per field ' );\r
end\r
else\r
if bits_pr_field = 2 then\r
begin\r
out_opcode( op_revpw ); out_comment( ' * bits per field (= 2 ) ' );\r
out_opcode( op_uadd );\r
end;\r
out_op_int( op_uadhw, 7 );\r
out_op_int( op_rechw, 8 );\r
out_opcode( op_udiv );\r
\r
out_opcode( op_uadd );\r
\r
out_op_int( op_stvlw, dope_start );\r
out_specopcode(op_stnhb,-word_length);\r
\r
end; (* packed *)\r
\r
end; (* array1 template *)\r
\r
xarray2template: (* static index, dynamic comp *)\r
begin\r
\r
first := in_integer;\r
last := in_integer;\r
allign := in_integer = 1;\r
\r
out_op_int( op_rechw, first );\r
out_op_int( op_rechw, last );\r
out_op_int( op_stvld, dope_start + 2 );\r
\r
with template_v do\r
out_op_rev__(access,word_typ,c.niv-niv,offset);\r
\r
if allign then out_make_top_even;\r
\r
out_opcode( op_revpw );\r
out_op_int( op_stvlw, dope_start + 6 );\r
\r
out_op_int( op_rechw, last - first + 1 );\r
out_opcode( op_umul );\r
out_op_int( op_stvlw, dope_start );\r
\r
end; (* array2 template *)\r
\r
xarray3template: (* dynamic index, dynamic comp *)\r
begin\r
\r
get_niv_offset( template1_v );\r
allign := in_integer = 1;\r
\r
with template1_v do\r
out_op_rev__(access,double_typ,c.niv-niv,offset + 2);\r
out_op_int( op_stvld, dope_start + 2 );\r
\r
with template_v do\r
out_op_rev__(access,word_typ,c.niv-niv,offset);\r
if allign then out_make_top_even;\r
out_opcode( op_revpw );\r
out_op_int( op_stvlw, dope_start + 6 );\r
\r
compute_number_of_elements( dope_start );\r
out_opcode( op_umul );\r
out_op_int( op_stvlw, dope_start );\r
\r
end; (* array3 template *)\r
\r
end; (* case token of *)\r
\r
get_token;\r
\r
end; (* array 1, 2, 3 template *)\r
\r
\r
xrecordtemplate :\r
begin\r
\r
size := in_integer; (* size of static part *)\r
\r
get_niv_offset( template_v );\r
if size <> 0 then\r
\r
out_op_int( op_rechw, size );\r
with template_v do\r
out_op_rev__(access,word_typ,c.niv-niv,offset);\r
if size <> 0 then\r
out_opcode( op_uadd );\r
\r
get_token;\r
\r
while token <> xendtemplate do\r
begin\r
\r
case token of\r
\r
xincfield: begin\r
out_op_int( op_uadhw, 1 );\r
get_token;\r
end; (* incfield *)\r
\r
xfieldsize, xdynfieldsize :\r
begin\r
\r
allign := in_integer = 1;\r
dope_start := in_integer; (* field template *)\r
\r
if allign then out_make_top_even;\r
(* assign to field template *)\r
out_opcode( op_revpw );\r
out_op_int( op_stvlw, dope_start );\r
\r
if token = xfieldsize then\r
begin\r
size := in_integer;\r
if size <> 0 then\r
out_op_int( op_rechw, size );\r
end\r
else\r
begin\r
size := -1; (* <> 0 !!! *)\r
\r
get_niv_offset( template_v );\r
with template_v do\r
out_op_rev__(access,word_typ,c.niv-niv,offset);\r
end;\r
\r
if size <> 0 then\r
out_opcode( op_uadd );\r
\r
get_token;\r
\r
end ; (* field size, dyn field size *)\r
else\r
\r
\r
dyn_type_declaration;\r
end;\r
\r
end; (* while *)\r
\r
out_op_int( op_stvlw, in_integer ); (* record template *)\r
get_token;\r
\r
end; (* record template *)\r
\r
else\r
if token <> xenddecl then\r
begin (* must be dynamic subrange type definition *)\r
(* ---> expr ---> expr ---> subdef( offset ) ----> *)\r
\r
find_exprs( (* load expr1 and expr2 *) var_val_v );\r
\r
(* initialize template *)\r
out_op_int( op_rechw, 2 );\r
if token <> xsubdef then error ( pass4code_error );\r
dope_start := in_integer;\r
\r
out_op_int( op_stvlw, dope_start );\r
out_op_int( op_stvld, dope_start + 2 );\r
get_token;\r
\r
end; (* subdef .... *)\r
end;\r
\r
end ; (* dyn type declaration *)\r
\r
procedure out_params;\r
(* copy the process parameter description into a constant block: *)\r
var\r
step, param_count: integer;\r
\r
begin\r
param_count := in_integer;\r
out_label (id_param);\r
out_tab (15); out_token (zconst);\r
out_integer( 4 * param_count + 2 );\r
out_nl; out_tab( 20 ); out_integer( param_count );\r
\r
for step := 1 to param_count do\r
begin\r
get_token; (* skip: xparamtype *)\r
\r
out_nl; out_tab( 20 );\r
out_integer( in_integer );\r
out_char (',');\r
out_integer( in_integer )\r
\r
end;\r
\r
out_nl;\r
out_tab (15); out_token (zend);\r
out_nl;\r
end; (* out params *)\r
\r
\r
procedure code_process_init(kind, offset_pd: integer; external_pr: boolean);\r
var\r
key, step: integer;\r
\r
begin\r
out_comment( ' initialize the fields in the Process Descriptor. ' );\r
if external_pr then\r
begin (* call _initproc_rc *)\r
if kind=1 then\r
out_op_int(op_reagd, offset_pd)\r
else\r
if offset_pd<>0 then\r
out_op_int(op_reasd, offset_pd);\r
out_op_id(op_reaad, id_param);\r
code_call_proc(sys_use, ext_lookup(key, '_initproc_rc'), key, const_niv_0, 0, 8, 0);\r
out_comment(' initialize process object ');\r
end\r
else\r
begin\r
\r
(* incarnation count = 0 *)\r
out_op_int(op_rechw,0);\r
out_opcode(op_stvgw);\r
out_expr(id_opd_count,offset_pd);\r
\r
(* param descr ref =address of formal parameters *)\r
out_op_id(op_reaad,id_param);\r
out_opcode(op_stvga);\r
out_expr(id_opd_param,offset_pd);\r
\r
(* linkstate: 0=unlinked, 1=internal linked *)\r
\r
out_op_int(op_rechw,1);\r
out_opcode(op_stvgw);\r
out_expr(id_opd_linked,offset_pd);\r
\r
(* processinf ref : pointer to processinf if internal linked *)\r
\r
out_op_id(op_reaad,id_procinf);\r
out_opcode(op_stvga); out_expr(id_opd_procinf,offset_pd);\r
\r
(* name , 86.09.08: name field not initialized any more !!!\r
the constant is also removed from the code, (find_block)\r
\r
out_opcode(op_reagd); out_expr(id_opd_name,offset_pd);\r
out_op_id(op_reaad,id_name);\r
out_op_id(op_rechw,id_alfalength);\r
out_opcode(op_moveg);\r
(* end of name field init *)\r
\r
(*processdescriptor in remove chain*)\r
out_op_id(op_revga,id_processchain);\r
out_opcode(op_stvga);\r
out_expr(id_opd_process,offset_pd);\r
out_op_int(op_reald,offset_pd);\r
out_op_id(op_stvga,id_processchain);\r
end; (* internal *)\r
end; (* code process init *)\r
\r
\r
procedure find_sys_init( var ref_count : integer; var dyn_refs : boolean ;\r
var shadow_count : integer; var dyn_shadows : boolean);\r
\r
\r
var \r
type_o : integer;\r
kind, w_offset, offset, number, size, lower, upper : integer;\r
stack_save : integer;\r
va, dope_v, template_v : varaddr_descr;\r
\r
\r
procedure component_init( kind, offset : integer; var ref_count : integer ;\r
var shadow_count : integer);\r
\r
(* kind = 1 <=> offset is local frame address of variable to initialize,\r
kind = 2 <=> (offset = 0) and address on top of stack *)\r
\r
var\r
new_kind, new_offset, refs, shadows : integer;\r
\r
\r
procedure code_array_init(dynamic : boolean; kind, offset, w_offset, lower, upper, size : integer;\r
var ref_count : integer; var shadow_count : integer; templ_v : varaddr_descr );\r
\r
var\r
refs,shadows,ixstore_hw,arrayrep_hw : integer;\r
\r
\r
begin\r
\r
out_nl; out_nl;\r
out_token (zbegin);\r
out_p_id (id_arrayrep);\r
out_p_id (id_index_store);\r
out_p_id (id_rep_exit);\r
out_token (zendlist);\r
out_comment( ' initialize an array. ' );\r
out_nl; out_nl;\r
\r
if kind = 1 then\r
begin\r
\r
out_opcode( op_reald );\r
out_start_param; out_integer( offset );\r
kind := 2; offset := 0;\r
\r
\r
end;\r
if dynamic then\r
(*load lower bound from template*)\r
with templ_v do\r
out_op_rev__(access,word_typ,c.niv-niv,offset + 2(*lower bound*))\r
else\r
begin\r
\r
out_opcode( op_rechw );\r
out_start_param; out_integer( lower );\r
end;\r
\r
(* test for at least one array element *)\r
out_opcode(op_revpw); (* lower bound *)\r
out_comment('test for non-empty array');\r
if dynamic then\r
(* load upper bound from template *)\r
with templ_v do\r
out_op_rev__(access, word_typ, c.niv-niv, offset+4) (* upper bound *)\r
else\r
(* load the constant upper bound *)\r
out_op_int(op_rechw, upper);\r
out_opcode(op_gt);\r
out_comment('lower>upper ?');\r
out_op_id(op_jmzeq, id_index_store); (* do not count the first time *)\r
\r
(*make space at stack to do jmzeq arrayrep if stack is full at label*)\r
if hw_stack_size = max_hw_stack then\r
out_resta(max_hw_stack - abs(op_table[op_jmzeq].opappetite));\r
\r
out_op_id( op_jmprw, id_rep_exit );\r
out_comment('if lower>upper then exit array rep');\r
ixstore_hw:= hw_stack_size;\r
arrayrep_hw := hw_stack_size;\r
\r
out_label( id_arrayrep );\r
\r
out_op_int( op_uadhw, 1 );\r
out_label( id_index_store );\r
if ixstore_hw <> hw_stack_size then hw_stack_error(array_init);\r
\r
\r
out_opcode (op_stvlw);\r
out_start_param; out_integer (w_offset);\r
\r
out_opcode( op_revpd );\r
get_token;\r
\r
component_init( kind, offset, refs, shadows );\r
\r
if dynamic then\r
begin\r
(*load size from template*)\r
with templ_v do\r
out_op_rev__(access,word_typ,c.niv-niv,offset + 6(*size*));\r
out_opcode( op_uadd );\r
end\r
else\r
begin\r
\r
out_opcode( op_reasd );\r
out_start_param; out_integer( size );\r
end;\r
out_comment( ' addr := addr + size . ' );\r
\r
out_opcode( op_revlw );\r
out_start_param; out_integer (w_offset);\r
\r
out_opcode( op_revpw );\r
if dynamic then\r
(*load upper bound from template*)\r
with templ_v do\r
out_op_rev__(access,word_typ,c.niv-niv,offset + 4(*upper bound*))\r
else\r
out_op_int( op_rechw, upper );\r
\r
out_opcode( op_ge );\r
out_comment('lower>=upper ? ' );\r
with op_table[op_jmzeq] do\r
if hw_stack_size <> (arrayrep_hw + abs(opappetite)) then\r
out_resta(arrayrep_hw + abs(opappetite));\r
\r
out_op_id( op_jmzeq, id_arrayrep );\r
out_comment(' if lower<upper then goto arrayrep ' );\r
out_label(id_rep_exit);\r
out_specopcode(op_stnhb,-3*word_length);\r
\r
out_nl; out_nl;\r
out_token (zend);\r
out_nl; out_nl;\r
if dynamic then\r
begin\r
shadow_count := shadows;\r
ref_count := refs (* <> 0 if refs defined *)\r
end\r
else\r
begin\r
shadow_count := shadows * (upper - lower + 1);\r
\r
ref_count := refs * ( upper - lower + 1 )\r
end\r
\r
\r
end (* code array init *);\r
\r
begin (* component init *)\r
shadow_count := 0;\r
\r
ref_count := 0;\r
\r
case token of\r
\r
xvarinit :\r
begin\r
\r
type_o := in_integer;\r
code_initvar( kind, offset, type_o, ref_count, shadow_count );\r
get_token;\r
\r
end; (* var init *)\r
\r
\r
xextprocess:\r
begin\r
(* declare labels for process descriptor initialization *)\r
out_nl;\r
out_token(zbegin);\r
out_p_id(id_param);\r
out_p_id(id_continue);\r
out_token(zendlist);\r
\r
out_op_id(op_jmprw, id_continue); \r
out_comment(' jump across the process parameters ');\r
out_nl; out_nl;\r
\r
(* output the process parameters *)\r
out_params;\r
\r
out_label(id_continue);\r
\r
(* generate code for the initialization of the fields in the process descriptor *)\r
code_process_init(kind, offset, true (* external *));\r
\r
out_nl;\r
out_token(zend); out_comment('end of external process init');\r
out_nl;\r
get_token;\r
end; (* extprocess *)\r
\r
xpoolinit :\r
begin\r
\r
number := in_integer;\r
size := in_integer;\r
\r
code_allocpool ( kind, offset, number, size );\r
get_token;\r
\r
end; (* pool init *)\r
\r
xfieldinit,\r
xdynfieldinit : begin\r
repeat\r
if kind = 2 then\r
out_opcode( op_revpd );\r
\r
case token of\r
\r
xfieldinit :\r
begin\r
new_offset := offset + in_integer;\r
new_kind := kind;\r
\r
end; (* field init *)\r
\r
xdynfieldinit :\r
begin\r
\r
if kind = 1 then\r
begin\r
out_op_int( op_reald, offset );\r
new_kind := 2; new_offset := 0;\r
end\r
else\r
begin \r
new_kind := kind; new_offset := offset;\r
end; (* kind = 2 *)\r
get_niv_offset( template_v );\r
with template_v do\r
out_op_rev__(access,word_typ,c.niv-niv,offset);\r
out_opcode( op_uadd );\r
\r
end; (* dyn field init *)\r
else\r
error ( pass4code_error );\r
end; (* case ... *)\r
\r
\r
get_token;\r
component_init( new_kind, new_offset, refs, shadows );\r
shadow_count := shadow_count + shadows;\r
ref_count := ref_count + refs;\r
\r
until token = xendinitfields;\r
\r
get_token;\r
if kind = 2 then out_specopcode(op_stnhb,-2*word_length);\r
\r
\r
end; (* field init and dyn field init *)\r
\r
\r
xarrayinit :\r
begin\r
\r
w_offset := in_integer;\r
lower := in_integer;\r
upper := in_integer;\r
size := in_integer;\r
\r
code_array_init( token = xarraydyninit, kind, offset, w_offset, lower, upper, size,\r
refs, shadows, dope_v );\r
shadow_count := shadow_count + shadows;\r
ref_count := ref_count + refs;\r
\r
end; (* array init *)\r
\r
\r
xarraydyninit :\r
begin\r
\r
w_offset := in_integer;\r
get_niv_offset( dope_v );\r
code_array_init( token = xarraydyninit, kind, offset, w_offset, 0, 0, 0, \r
refs, shadows, dope_v);\r
ref_count := ref_count + refs;\r
dyn_refs := dyn_refs or ( refs > 0 );\r
shadow_count := shadow_count + shadows;\r
dyn_shadows := dyn_shadows or (shadows > 0);\r
\r
end; (* array dyn init *)\r
\r
else error(pass4code_error );\r
end; (* case *)\r
\r
\r
end; (* component init *)\r
\r
\r
\r
\r
\r
begin (* start of: find sys init *)\r
if token<>xsysnewinit then\r
begin\r
offset := in_integer;\r
if token = xsysinit then \r
begin\r
kind := 1;\r
end\r
else\r
begin\r
out_op_int( op_revla, offset );\r
kind := 2;\r
offset := 0;\r
end;\r
end\r
else\r
begin (* heap init, just after new call, i.e. the object address is on top of stack *)\r
out_opcode(op_revpd);\r
kind:= 2;\r
offset:= 0\r
end; (* heap init *)\r
get_token;\r
component_init( kind, offset, ref_count, shadow_count );\r
if not heap_init then\r
if (hw_stack_size <> 0) or (c.stack_size <> 0) then evalstack_error;\r
\r
end; (* find sys init *)\r
\r
\r
\r
\r
\r
procedure find_block (outermost_level: boolean; param_length : integer; name : identifier );\r
type\r
skip_modes = (skip, dont_skip, end_skip, end_skip_block);\r
\r
var\r
i, refcount, refs, shadowcount, shadows : integer;\r
var_length, proc_parlength, param_count,\r
roulix, rouniv : integer;\r
niv_pd, offset_pd : integer;\r
old_default_appetite : integer;\r
old_c : context;\r
external_pr : boolean;\r
name_pd : identifier;\r
line_no : integer;\r
local_dyn_refs,\r
local_dyn_shadows,\r
end_init: boolean;\r
begin_line : integer;\r
jump_state : skip_modes; (* defines current state *)\r
skip_block : boolean; (* true when jump to continue *)\r
pending_entry: boolean; (* true, when entry-point not defined yet *)\r
template_v : varaddr_descr;\r
dyn_var_offset : integer;\r
dyn_yes_or_no : boolean;\r
\r
procedure skip_around (jump: skip_modes);\r
begin\r
if jump <> jump_state then\r
begin\r
if jump = skip then\r
begin\r
skip_block:=true;\r
out_nl;\r
out_token (zbegin);\r
out_identifier (id_continue);\r
out_token (zendlist);\r
out_op_id (op_jmprw, id_continue);\r
end\r
else\r
if pending_entry then\r
begin\r
pending_entry := false;\r
(* define the entry-point *)\r
if outermost_level or (roulix = -1) then\r
out_label (id_entry);\r
if roulix <> -1 then\r
out_lix_label (r_name, roulix);\r
\r
(* generate a prolog for the body *)\r
if prolog_yes or (roulix <> -1) then\r
begin\r
context_eval(-4); (*the lineinformation is part of the activation record*)\r
(*generate link to linetable, but instruction is never carried out *)\r
out_op_id(op_reaad,id_linetab);\r
out_comment('instruction never executed');\r
(* initialize max-stack register *)\r
if roulix = -1 then (* process body *)\r
code_set_maxstack (id_bonappetite);\r
(* allocate room for local variables *)\r
out_op_id (op_renhb, id_appstat);\r
out_nl;\r
end; (* prolog *)\r
end (* pending entry *)\r
else\r
begin\r
if jump <> end_skip_block then\r
begin\r
out_label (id_continue);\r
if jump <> end_skip then\r
begin\r
out_nl;\r
out_token (zend);\r
end;\r
end else\r
begin\r
if skip_block then\r
begin\r
out_nl;\r
out_token(zend);\r
skip_block:=false;\r
end;\r
jump:=dont_skip;\r
end;\r
end;\r
\r
jump_state := jump;\r
end; (* change of jumpstate *)\r
end; (* procedure skip-around *)\r
\r
begin (* body of find block *)\r
\r
if (token = xfunc) or (token = xproc) then\r
begin\r
roulix := in_integer;\r
in_identifier (name);\r
get_token;\r
if outermost_level then\r
with descr do\r
begin\r
exception_point := '0 ';\r
end;\r
end\r
else\r
roulix := -1; (* i.e. process *)\r
if token <> xblock then error (pass4code_error);\r
\r
line_no := in_line_no;\r
rouniv := in_integer;\r
get_token;\r
\r
(* declare global-labels, at outermost level *)\r
if outermost_level then\r
begin\r
out_token (zbegin);\r
out_p_id (id_entry);\r
out_p_id (id_exit);\r
out_p_id (id_exception);\r
out_p_id (c12_name); out_char ('#');\r
out_p_id (e12_name); out_char ('#');\r
out_p_id (r12_name); out_char ('#');\r
out_p_id (l12_name); out_char ('#');\r
out_token (zendlist);\r
out_nl;\r
end;\r
\r
(* two complete different bodies are recognized: *)\r
(* 1. code-bodies, i.e. 'beginbody' *)\r
(* 2. normal-bodies, i.e. pascal80-generated *)\r
\r
if token = xbegincode then\r
begin (* code-body *)\r
(* make proper changes to 'descr' *)\r
i := in_integer;\r
if roulix <> -1 then (* only functions and procedures may be open-routines *)\r
if outermost_level and openroutine_yes then\r
with descr do\r
begin\r
entry_point := '0 ';\r
last_param_offset := i;\r
if kind = 2 then kind := 4\r
else if kind = 3 then kind := 5;\r
out_nl;\r
out_token (zoption);\r
out_integer (6); (* pass no *)\r
out_integer (12); (* option = closed or open body *)\r
out_integer (0); (* value = open body *)\r
out_char('.'); (* end of option *)\r
end\r
else\r
begin (* coderoutine must be closed anyway *)\r
out_nl;\r
out_lix_label (r_name, roulix);\r
end;\r
(* copy the code *)\r
out_nl;\r
get_token;\r
while token = xcodeline do\r
begin\r
for i := in_integer downto 1 do out_char (chr(in_integer));\r
out_nl;\r
get_token;\r
end;\r
skip_token (xendcode);\r
end (* code-body *)\r
else\r
begin (* normal-body *)\r
\r
old_c := c;\r
\r
with c do\r
begin\r
\r
niv := rouniv;\r
stack_size := 0;\r
max_stack_size := 0;\r
hw_stack_size := 0;\r
\r
end;\r
\r
(* declare routine-labels *)\r
out_nl;\r
out_token (zbegin);\r
out_p_id (id_appeval);\r
out_p_id (id_appstat);\r
out_p_id (id_work);\r
out_p_id (id_linetab);\r
out_p_id (id_blockexit);\r
out_token (zendlist);\r
out_nl;\r
\r
refcount := 0;\r
local_dyn_refs := false;\r
shadowcount := 0;\r
local_dyn_shadows := false;\r
dyn_yes_or_no := false;\r
end_init := false;\r
jump_state := skip;\r
skip_block := false;\r
pending_entry := true;\r
\r
if outermost_level and (roulix = -1) then\r
skip_around (dont_skip); (* outermost process must start immediatly *)\r
\r
repeat\r
case token of\r
xextproc,\r
xextfunc:\r
find_ext_routine;\r
xproc,\r
xfunc:\r
begin\r
skip_around (skip);\r
find_block (false, 0-0-0, '****** ');\r
end;\r
\r
xinitialize,\r
xextexception,\r
xexception :\r
begin\r
skip_around (dont_skip);\r
find_init;\r
end;\r
\r
\r
xsysinit,\r
xsysdyninit:\r
begin\r
\r
skip_around( dont_skip );\r
find_sys_init( refs, local_dyn_refs, shadows, local_dyn_shadows );\r
shadowcount := shadowcount + shadows;\r
refcount := refcount + refs;\r
\r
end; (* sysinit and sysdyninit *)\r
\r
\r
\r
xprocess:\r
begin\r
\r
(* declare inter-process labels *)\r
out_nl;\r
out_token (zbegin);\r
out_p_id (id_param);\r
out_p_id (id_procinf);\r
out_p_id( id_default_appetite );\r
(* out_p_id (id_name); 86.09.08 not used any more *)\r
out_token (zendlist);\r
\r
skip_around (skip);\r
out_comment( ' jump across the process declaration. ' );\r
out_nl; out_nl;\r
\r
offset_pd := in_integer;\r
\r
in_identifier( name_pd );\r
\r
proc_parlength := in_integer;\r
\r
out_params;\r
\r
out_token (zbegin);\r
out_p_id (id_entry);\r
out_p_id (id_exception);\r
out_p_id (id_exit);\r
out_token (zendlist);\r
out_label (id_procinf);\r
out_token (zconst); out_integer (2 * pointer_length + 2 * word_length);\r
out_nl; out_token (dollar_a); out_expr(id_entry,jump_across_first);\r
out_nl; out_token (dollar_a); out_p_id (id_exception);\r
out_nl; out_token (dollar_i); out_p_id( id_default_appetite);\r
out_nl; out_token (dollar_i); out_p_int (proc_parlength);\r
out_nl;\r
out_token (zend);\r
out_nl;\r
\r
(* 86.09.08 name not used any more\r
out_label (id_name);\r
out_token (zconst); out_p_int (12);\r
\r
for i := 1 to 12 do\r
begin\r
\r
if ( i mod 2 ) = 1 then\r
begin\r
out_nl; out_tab( 20 )\r
end\r
else\r
out_char (',');\r
\r
out_token (dollar_b);\r
\r
if i <= c_size_identifier then\r
out_integer( ord( name_pd[ i ] ) )\r
else\r
out_integer( ord( ' ' ) )\r
\r
end;\r
out_nl;\r
out_token (zend);\r
out_nl;\r
(* end of name *)\r
\r
(* insert the body of the process declaration: *)\r
\r
get_token;\r
\r
old_default_appetite := descr.default_appetite;\r
descr.default_appetite := 0;\r
find_block (false, proc_parlength, name_pd);\r
out_def( id_default_appetite );\r
out_integer( descr . default_appetite );\r
\r
descr . default_appetite := old_default_appetite;\r
out_nl;\r
out_token (zend); out_comment ('end of internal process body');\r
\r
(* generate code for the initialization of the Process Descriptor: *)\r
skip_around (end_skip);\r
\r
code_process_init(1 (* kind direct addressable *), offset_pd, false(* not external *));\r
\r
skip_around (end_skip_block); out_comment ('end ..continue.. block');\r
out_nl;\r
out_token (zend); out_comment ('end of internal process init');\r
out_nl;\r
\r
trap_code := measurement_yes;\r
current_trap_nr := 0; (* return to surrounding main block *)\r
\r
\r
end;\r
\r
\r
xarray1template, xarray2template, xarray3template,\r
xrecordtemplate :\r
begin\r
skip_around( dont_skip );\r
dyn_type_declaration;\r
end;\r
\r
\r
xallocdynvar :\r
begin\r
skip_around( dont_skip );\r
\r
dyn_var_offset := in_integer; (* local frame adress of pointer to the variable *)\r
\r
out_opcode( op_reaxd ); (* get last used *)\r
out_op_int( op_reasd, 1 ); (* even start address *)\r
\r
out_op_int( op_stvla, dyn_var_offset ); (* initialize the pointer *)\r
\r
(* reserve stack space *)\r
\r
get_niv_offset( template_v );\r
with template_v do\r
out_op_rev__(access,word_typ,c.niv-niv,offset);\r
\r
out_make_top_even;\r
out_opcode( op_renpb );\r
dyn_yes_or_no := true;\r
\r
get_token;\r
\r
end; (* alloc dyn var *)\r
\r
\r
\r
\r
\r
else\r
if token <> xenddecl then\r
begin\r
skip_around( dont_skip );\r
dyn_type_declaration;\r
end\r
else\r
end_init := true;\r
end; (* case in_token of ...... *)\r
\r
until end_init;\r
\r
skip_token (xenddecl);\r
\r
if trap_code then\r
if roulix <> -1 then\r
current_trap_nr := new_trap_entry( roulix )\r
else\r
current_trap_nr := 0; (* main *)\r
\r
\r
(* find statements: *)\r
\r
begin_line := in_line_no;\r
\r
skip_around (dont_skip);\r
if roulix = -1 then (*process*)\r
begin\r
(*exopcode byte set to 0*)\r
out_op_int(op_rechw,0);\r
out_op_id(op_stvgb,id_exopcode);\r
end;\r
dyn_eval_stack:= false;\r
find_statement;\r
dyn_yes_or_no:= dyn_yes_or_no or dyn_eval_stack;\r
out_label(id_blockexit);\r
\r
(* find the appetite of the block: *)\r
\r
var_length := in_integer;\r
\r
param_length := in_integer;\r
\r
\r
(* generate the epilog of the block, depending on process or not: *)\r
\r
if roulix <> -1 then\r
begin (* function or procedure *)\r
if local_dyn_refs or (refcount > 0) then\r
code_remove (refcount, local_dyn_refs, ref_typ);\r
if local_dyn_shadows or (shadowcount>0) then\r
code_remove (shadowcount, local_dyn_shadows, shadow_typ);\r
if trap_code then\r
begin\r
out_op_int(op_mtrh,trapreturn);\r
out_start_param;\r
out_integer(current_trap_nr);\r
end;\r
out_op_int (op_pexit, param_length + 1 );\r
end\r
else\r
begin (* process *)\r
\r
trap_code := false; (* do not generate measurement code after exit point *)\r
\r
\r
out_nl; out_label( id_exit );\r
\r
if epilog_yes then code_exit;\r
\r
out_nl; out_label( id_exception );\r
\r
code_exception;\r
\r
end; (* epilog of process *)\r
\r
(* define 'work' and the appetite symbols of the block: *)\r
\r
out_def( id_work ); out_integer( param_length + var_length - 1 );\r
\r
out_def( id_appstat );\r
out_integer( var_length );\r
\r
out_def( id_appeval );\r
out_integer( c.max_stack_size );\r
\r
(* print a line in the summary : *)\r
\r
if roulix <> -1 then\r
param_length := size_of_return_point; (* include room for display in the appetite *)\r
\r
with descr do\r
default_appetite := default_appetite + ( var_length + \r
c.max_stack_size + param_length ) div 2; (* words !! *)\r
\r
if roulix = -1 then (* process level *)\r
begin\r
if outermost_level and (enforced_create_size <> 0) then\r
i := enforced_create_size\r
else\r
i := descr . default_appetite;\r
end\r
else\r
i := 0; (* suppress printing of create size *)\r
\r
mess_summary_line( name, line_no, begin_line, in_line_no,\r
var_length + c.max_stack_size + param_length, dyn_yes_or_no, i );\r
\r
\r
(* generate the constant section of the block: *)\r
\r
find_constants;\r
\r
(* generate the line tab. header : *)\r
\r
out_nl;\r
out_label( id_linetab );\r
code_line_tab_header( name );\r
(* output an end-of-block *)\r
out_nl;\r
out_token (zend); out_comment ('end of body');\r
if (hw_stack_size <> 0) or (c.stack_size <> 0) then evalstack_error;\r
\r
c := old_c;\r
\r
end; (* closed routine *)\r
\r
if outermost_level then\r
begin\r
out_nl;\r
descr_end;\r
end;\r
\r
(* skip endblock-parameters *)\r
if token <> xendblock then error (pass4code_error);\r
i := in_integer;\r
i := in_integer;\r
get_token;\r
\r
end; (* find_block *)\r
\r
\r
\r
procedure find_program;\r
\r
var\r
p, param_length : integer;\r
\r
begin\r
\r
(* skip environment-declarations *)\r
while (token = xextproc) or (token = xextfunc) do\r
find_ext_routine;\r
\r
repeat\r
\r
case token of\r
xmodule:\r
begin\r
in_identifier (descr.name);\r
param_length := 0;\r
trap_code:= false;\r
end;\r
xprocess:\r
begin\r
(* skip: offset *)\r
p := in_integer;\r
in_identifier (descr.name);\r
param_length := in_integer;\r
trap_code := measurement_yes;\r
if trap_code then init_trap_table;\r
\r
end;\r
else error (pass4code_error);\r
end;\r
(* input and store the parameter list *)\r
descr.no_of_params := in_integer;\r
if descr.no_of_params > descr_max_param then\r
error (param_number);\r
for p := 1 to descr.no_of_params do\r
begin\r
get_token;\r
if token <> xparamtype then error (pass4code_error);\r
with descr.param [ p ] do\r
begin\r
kind := in_integer;\r
size := in_integer;\r
end;\r
end;\r
\r
with descr do\r
begin\r
entry_point := id_entry;\r
exception_point := id_exception;\r
default_appetite := 0;\r
last_param_offset := param_length;\r
for p := 1 to descr_free_words do free_words[p] := 0;\r
end;\r
\r
get_token;\r
case token of\r
xproc:\r
descr.kind := 2;\r
xfunc:\r
descr.kind := 3;\r
else descr.kind := 1;\r
end;\r
\r
find_block (true, param_length, descr.name);\r
\r
until token = xeom;\r
\r
out_nl;\r
out_token (zend);\r
\r
end; (* find_program *)\r
\r
\r
\r
\r
procedure find_std_call (var v:varvalue_descr);\r
\r
var\r
i, no, limit : integer;\r
\r
begin\r
\r
no := in_integer;\r
\r
if ( no = xsucc ) or ( no = xpred ) then\r
limit := in_integer;\r
\r
find_arglist( std_call, i (* size of function result *));\r
\r
\r
\r
case no of\r
xord,\r
xchr: ;\r
\r
xnil, xnilref:\r
begin\r
(* if nilref then skip the count byte, i.e. increase address *)\r
if no = xnilref then\r
out_op_int( op_uadhw, 1 );\r
\r
out_opcode( op_tnill );\r
out_comment(' std. function : nil ');\r
end;\r
\r
\r
xsucc,\r
xpred:\r
begin\r
\r
out_nl; out_nl;\r
out_token (zbegin);\r
out_p_id (id_sucpred);\r
out_token (zendlist);\r
\r
if no = xsucc then\r
out_comment( ' start of std. function : succ . ' )\r
else\r
out_comment( ' start of std. function : pred . ' );\r
\r
out_opcode( op_revpw );\r
\r
out_opcode( op_rechw );\r
out_start_param; out_integer( limit );\r
\r
out_opcode( op_eq );\r
\r
out_op_id (op_jmzeq, id_sucpred);\r
\r
if no = xsucc then\r
code_exc_trigger( c_exc_succ)\r
else\r
code_exc_trigger( c_exc_pred);\r
\r
out_label (id_sucpred);\r
if no = xsucc then\r
out_op_int (op_uadhw, 1)\r
else\r
out_op_int (op_uadhw,-1);\r
\r
out_nl;\r
out_token (zend);\r
end;\r
else error(pass4code_error);\r
end;\r
(* the value descriptor v must describe the function result, i.e. *)\r
with v do\r
begin\r
kind := 1; size := i (* size of function result as set by find arglist *)\r
end;\r
\r
end (* find_std_call *);\r
\r
\r
\r
procedure find_arglist( call_mode : callmodes; var size_of_function_result : integer );\r
(* note: token undef at entry !! *)\r
\r
var\r
type_l, size_l : integer;\r
v_r : varvalue_descr;\r
v_l : varaddr_descr ;\r
end_arglist : boolean;\r
\r
begin\r
\r
end_arglist := false;\r
get_token;\r
repeat\r
case token of\r
xvalueparam:\r
begin\r
\r
type_l := in_integer;\r
\r
if ( type_l = addr_typ ) or ( type_l = set_typ ) then\r
size_l := in_integer\r
else\r
if type_l = point_typ then size_l := 4 else size_l := 2;\r
\r
get_token;\r
find_exprs( v_r);\r
\r
if v_r.kind = 2 then\r
begin\r
\r
if type_l <> addr_typ then error(pass4code_error);\r
\r
if odd( size_l ) then size_l := size_l + 1;\r
\r
if size_l <= 4 then\r
out_op_int(op_rev[s,conv_type[size_l]],0)\r
\r
else\r
\r
begin\r
\r
out_opcode( op_rechw );\r
out_start_param; out_integer( size_l );\r
out_specopcode(op_revsm,size_l);\r
\r
end;\r
\r
end\r
\r
else\r
if type_l = set_typ then\r
begin\r
\r
if v_r.size <> ( size_l + 2 ) then\r
begin\r
\r
if v_r.size > 0 then\r
code_stat_to_dyn( v_r.size );\r
\r
out_opcode( op_rechw );\r
out_start_param; out_integer( size_l );\r
out_specopcode(op_setad,size_l + 2);\r
\r
end;\r
out_specopcode(op_stnhb,-word_length);\r
\r
end\r
\r
else\r
if v_r.size <> size_l then\r
error(pass4code_error);\r
end;\r
xvarparam:\r
begin\r
get_token;\r
find_varaddr (v_l);\r
load_address (v_l, true);\r
end;\r
\r
xreturnparam: (* reserve stack space for function result *)\r
begin\r
size_l := in_integer;\r
size_of_function_result := size_l; (* remember size in case of process params *)\r
if (call_mode <> open_call) and (call_mode <> std_call) then\r
(* closed routine *)\r
begin\r
if size_l = 2 then\r
out_op_int( op_rechw, 0 ) (* assure left byte = 0 in case of byte result !! *)\r
else\r
begin\r
out_op_int(op_rechd (* the function result must be an address *), const_nil_var);\r
out_start_param;\r
out_integer(0);\r
end;\r
size_l := 0; (* context eval (2 or 4) has been done *)\r
\r
out_comment( ' room for function result ' );\r
\r
(* std routines are just a sequence of instructions, therefore the\r
movements on the evaluation stack is made as part of the code\r
generation, and a call of context_eval is not needed *)\r
\r
(*for open routines stackmovement is taken care of by\r
code_call_proc after call of openroutine *)\r
context_eval( size_l );\r
end; (* if closed routine *)\r
get_token;\r
end;\r
\r
\r
else end_arglist := true;\r
end;\r
until end_arglist;\r
\r
end (* find_arglist *);\r
\r
\r
\r
procedure find_while;\r
\r
var v: varvalue_descr;\r
\r
begin\r
\r
out_nl;\r
out_token (zbegin);\r
out_p_id (id_whrep);\r
out_p_id (id_whexit);\r
out_token (zendlist);\r
out_comment( ' start of while_statement. ' );\r
\r
out_label( id_whrep );\r
\r
get_token;\r
find_expr( v);\r
if operand_situation = after_short_const then\r
begin (* optimize on 'while true' *)\r
if v.val = value_false then\r
out_op_id (op_jmprw, id_whexit); (* skip on: 'while false' *)\r
(* don't test on: 'while true' *)\r
end\r
else\r
out_op_id (op_jmzeq, id_whexit);\r
out_comment( ' exit from while_statement. ' );\r
\r
skip_token (xwhileexpr);\r
find_statement;\r
skip_token (xendwhile);\r
\r
out_op_id (op_jmprw, id_whrep);\r
out_label (id_whexit);\r
out_nl;\r
out_token (zend);\r
out_comment( ' end of while_statement. ' );\r
\r
\r
end (* find_while *) ;\r
\r
\r
«eof»