|
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: 29570 (0x7382)
Types: TextFile
Names: »P5EXIT.PAS«
└─⟦b6837b237⟧ Bits:30010500 SW2103 REL 1.11 Sourcer DVBS1.SW2103.rel.1.11-1 MASTER 31-1-192
└─⟦this⟧ »P5EXIT.PAS«
procedure find_lock;\r
\r
var\r
v : varaddr_descr;\r
lock_offset, size : integer;\r
lockmesstat: boolean;\r
\r
begin\r
lockmesstat:= token=xlockmesstat;\r
out_nl;\r
out_comment ('start of lock statement');\r
get_token;\r
\r
find_varaddr( v);\r
load_address( v, true);\r
while (token <> xlockvar) and (token <> xlockdynvar) do\r
dyn_type_declaration;\r
\r
if token = xlockvar then\r
size := in_integer\r
else\r
get_niv_offset( v );\r
lock_offset:= in_integer;\r
\r
if lockmesstat then\r
begin\r
(* initialize anonymous object in conjunction with lockmesstat *)\r
\r
out_nl;\r
out_token (zbegin);\r
out_p_id (id_size_ok);\r
out_token (zendlist);\r
out_opcode(op_revpd);\r
out_comment(' lockmes_statement descriptor.');\r
out_op_int(op_revsa, 1);\r
out_op_id(op_revsd, id_mstart);\r
out_op_id(op_revsd, id_mfirst);\r
out_op_int(op_uadhw, 1);\r
out_op_int(op_stvld, lock_offset+lockmes_first_offset);\r
out_comment(' save (first, last+1) ');\r
out_op_int(op_revlw, lock_offset+lockmes_first_offset);\r
if token=xlockvar then (* static sized type *)\r
out_op_int(op_uadhw, size)\r
else\r
begin\r
with v do\r
out_op_rev__(access, word_typ, c.niv-niv, offset);\r
out_opcode(op_uadd);\r
end; (* dynamic sized buffer type *)\r
out_op_int(op_stvlw, lock_offset+lockmes_top_offset);\r
out_comment(' save computed top ');\r
out_op_int(op_revld, lock_offset+lockmes_last_offset);\r
out_comment(' size test, top inside buffer area ');\r
out_opcode(op_ult);\r
out_op_id(op_jmzeq, id_size_ok);\r
out_op_int(op_revlw, lock_offset+lockmes_top_offset); (* extra parameter for print exception *)\r
context_eval(-word_length); (* remove from internal stack size computation *)\r
hw_stack_size:= hw_stack_size-word_length; (* adjust hw_stack *)\r
code_exc_trigger(c_exc_lock);\r
out_label(id_size_ok);\r
out_op_int(op_revlw, lock_offset+lockmes_top_offset);\r
out_op_int(op_uadhw, 1);\r
out_op_int(op_rechw, 2);\r
out_opcode(op_udiv); (* convert size from bytes to words *)\r
out_nl;\r
out_token(zend);\r
out_comment(' end of lockmes descriptor init ');\r
end (* lockmesstat *)\r
else\r
if token = xlockvar then\r
out_op_int( op_rechw, (size + 1) div 2 )\r
else\r
begin (* dyn lock var *)\r
with v do\r
out_op_rev__(access,word_typ,c.niv-niv,offset);\r
(* convert size from bytes to words *)\r
out_op_int( op_uadhw, 1 ); out_comment( ' convert to words ' );\r
out_op_int( op_rechw, 2 );\r
out_opcode( op_udiv );\r
end; (* dyn lock var *)\r
\r
out_op_int (op_llock, lock_offset);\r
out_opcode(op_revpd);\r
out_opcode (op_lrese);\r
out_resta (0);\r
if lockmesstat then\r
begin\r
out_op_int(op_revla, lock_offset);\r
out_op_int(op_revlw, lock_offset+lockmes_first_offset);\r
out_opcode(op_uadd); \r
out_comment(' compute start address of visible buffer part ');\r
out_op_int(op_stvla, lock_offset);\r
end;\r
\r
get_token;\r
find_statement;\r
skip_token (xendlock);\r
out_opcode(op_lrele);\r
out_comment( ' end of a lock_statement.' );\r
\r
end (* find_lock *);\r
\r
procedure find_exitlock;\r
begin\r
get_token;\r
out_opcode(op_lrele);\r
context_eval(-op_table[op_lrele].opappetite); (* undo stack movement effect of the operation *)\r
if token=xchannel then\r
begin\r
out_comment(' forced exit of channel statement ');\r
out_opcode(op_csell);\r
context_eval(-op_table[op_csell].opappetite); (* undo stack movement effect of the operation *)\r
end\r
else\r
out_comment(' forced exit of lock statement');\r
get_token;\r
end; (* find exitlock/exitchannel *)\r
\r
\r
\r
procedure find_with;\r
\r
var\r
v, v1 : varaddr_descr;\r
offset, size, new_size: integer;\r
static_object: boolean;\r
\r
begin\r
get_token;\r
find_varaddr(v1);\r
\r
if token=xwithvar then\r
begin\r
size:= in_integer;\r
static_object:= true;\r
end\r
else\r
begin (* dynamic sized object *)\r
get_niv_offset(v);\r
static_object:= false;\r
end;\r
offset:= in_integer;\r
\r
get_token;\r
if offset<>0 then\r
begin (* temporary with address necessary *)\r
load_address(v1, true);\r
out_op_int(op_stvla, offset);\r
out_comment( ' save the with_addr. ' );\r
end;\r
\r
while (token<>xnoretype) and (token<>xretype) and (token<>xdynretype) do\r
dyn_type_declaration;\r
\r
if token<>xnoretype then\r
begin\r
out_nl;\r
out_token (zbegin);\r
out_p_id (id_size_ok);\r
out_token (zendlist);\r
if static_object then\r
out_op_int(op_rechw, size)\r
else\r
with v do\r
out_op_rev__(access, word_typ, c.niv-niv, offset);\r
out_comment(' compare sizes of types.');\r
if token=xretype then (* static retyping type *)\r
begin\r
new_size:= in_integer;\r
out_op_int(op_rechw, new_size);\r
end\r
else\r
begin\r
get_niv_offset(v1);\r
with v1 do\r
out_op_rev__(access, word_typ, c.niv-niv, offset);\r
end;\r
out_opcode(op_ult);\r
out_op_id(op_jmzeq, id_size_ok);\r
(* load size values for print exception *)\r
if static_object then \r
out_op_int(op_rechw, size)\r
else\r
with v do\r
out_op_rev__(access, word_typ, c.niv-niv, offset);\r
out_comment(' size of with object.');\r
if token=xretype then (* static retyping type *)\r
out_op_int(op_rechw, new_size)\r
else\r
with v1 do\r
out_op_rev__(access, word_typ, c.niv-niv, offset);\r
out_comment(' size of retyped object.');\r
context_eval(-2*word_length); (* adjust internal stack size, size values not unstacked *)\r
hw_stack_size:= hw_stack_size-2*word_length; (* adjust hw_stack *)\r
code_exc_trigger(c_exc_with);\r
out_label(id_size_ok);\r
out_nl;\r
out_token(zend);\r
end; (* token<>noretype *)\r
\r
get_token;\r
find_statement;\r
skip_token (xendwith);\r
\r
end (* find_with *);\r
\r
procedure find_exchange;\r
\r
var\r
type_o, key, size : integer;\r
v1, v2 : varaddr_descr;\r
\r
begin\r
get_token;\r
find_varaddr( v1);\r
load_address (v1, true);\r
if token <> xleft then error(pass4code_error);\r
\r
type_o := in_integer;\r
if (type_o<>ref_typ) and (type_o<>shadow_typ) then\r
error(pass4code_error);\r
get_token;\r
find_varaddr( v2);\r
load_address (v2, true);\r
skip_token (xexchange);\r
if type_o=shadow_typ then\r
code_call_proc(sys_use, ext_lookup(key, '_exchange_rc'), key, const_niv_0, 0,\r
4 (* left hand address *) + 4 (* right hand address *), 0)\r
else\r
out_opcode (op_cexch);\r
\r
end (* find_exchange *);\r
\r
\r
\r
\r
procedure find_label;\r
\r
begin\r
out_lix_label (l_name, in_integer);\r
get_token;\r
\r
end (* find_label *);\r
\r
\r
procedure find_goto;\r
\r
begin\r
\r
out_opcode( op_jmprw );\r
out_start_param; out_lix (l_name, in_integer);\r
get_token;\r
\r
end (* find_goto *);\r
\r
\r
procedure find_if;\r
\r
var \r
v : varvalue_descr;\r
\r
begin\r
out_nl;\r
out_token (zbegin);\r
out_p_id (id_ifelse);\r
out_p_id (id_ifexit);\r
out_token (zendlist);\r
out_comment( ' start of if_statement. ' );\r
\r
get_token;\r
find_exprs( v);\r
\r
if ( v.kind <> 1 ) or\r
( ( v.size >= 0 ) and ( v.size <> 2 ) ) then\r
error(pass4code_error);\r
out_op_id (op_jmzeq, id_ifelse);\r
\r
skip_token (xifexpr);\r
find_statement;\r
\r
if token = xelse then\r
begin\r
(* else_part : *)\r
out_op_id (op_jmprw, id_ifexit);\r
out_label (id_ifelse);\r
\r
get_token;\r
find_statement;\r
\r
out_label( id_ifexit )\r
\r
end\r
\r
else\r
\r
begin\r
(* no else_part *)\r
out_label (id_ifelse);\r
end;\r
out_nl;\r
out_token (zend);\r
out_comment( ' end of if_statement. ' );\r
\r
skip_token (xif);\r
\r
end (* find_if *);\r
\r
\r
\r
procedure find_repeat;\r
\r
var\r
v : varvalue_descr;\r
\r
begin\r
out_nl;\r
out_token (zbegin);\r
out_p_id (id_rprep);\r
out_p_id (id_rpcont);\r
out_p_id (id_rpexit);\r
out_token (zendlist);\r
out_comment( ' start of repeat_statement. ' );\r
\r
out_label( id_rprep );\r
\r
get_token;\r
find_statement;\r
\r
out_label(id_rpcont);\r
skip_token(xuntil);\r
find_expr( v);\r
\r
if ( v.kind <> 1 ) or\r
( ( v.size >= 0 ) and ( v.size <> 2 ) ) then\r
error(pass4code_error);\r
if operand_situation = after_short_const then\r
begin (* optimize on 'repeat ... until false' *)\r
if v.val = value_false then\r
out_op_id (op_jmprw, id_rprep); (* don't test on: '... until false' *)\r
(* exit immediatly on ' ... until true' *)\r
end\r
else\r
out_op_id (op_jmzeq, id_rprep);\r
\r
out_label(id_rpexit);\r
out_nl;\r
out_token (zend);\r
out_comment( ' end of repeat_statement. ' );\r
\r
skip_token (xendrepeat);\r
\r
end (* find_repeat *);\r
\r
\r
procedure find_loop;\r
begin\r
out_nl;\r
out_token (zbegin);\r
out_p_id (id_loop);\r
out_p_id (id_loopexit);\r
out_token (zendlist);\r
out_comment( ' start of loop_statement. ' );\r
\r
out_label( id_loop );\r
\r
get_token;\r
find_statement;\r
\r
skip_token(xendloopstat);\r
out_op_id (op_jmprw, id_loop);\r
\r
out_label(id_loopexit);\r
out_nl;\r
out_token (zend);\r
out_comment( ' end of loop_statement. ' );\r
end; (* find loop *)\r
\r
procedure find_loop_goto(cont_or_exit: pass4codes);\r
var\r
destination: identifier;\r
begin\r
get_token;\r
case token of\r
xforstat: if cont_or_exit=xcontloopstat then\r
destination:= id_forcont\r
else\r
destination:= id_loopexit;\r
xwhile: if cont_or_exit=xcontloopstat then\r
destination:= id_whrep\r
else\r
destination:= id_whexit;\r
xrepeat: if cont_or_exit=xcontloopstat then\r
destination:= id_rpcont\r
else\r
destination:= id_rpexit;\r
xloopstat: if cont_or_exit=xcontloopstat then\r
destination:= id_loop\r
else\r
destination:= id_loopexit;\r
else error(pass4code_error);\r
end; (* case *)\r
\r
out_op_id(op_jmprw, destination);\r
if cont_or_exit=xcontloopstat then\r
out_comment(' continueloop statement ')\r
else\r
out_comment(' exitloop statement');\r
get_token;\r
end; (* find loop goto *)\r
\r
\r
procedure find_exit;\r
begin\r
out_op_id(op_jmprw, id_blockexit);\r
out_comment(' exit statement ');\r
get_token;\r
end; (* find exit *)\r
\r
\r
procedure find_for;\r
\r
var\r
v_l : varaddr_descr;\r
v_r : varvalue_descr;\r
offset, type_v, mode, w_offset, remainder : integer;\r
\r
begin\r
get_token;\r
out_nl;\r
out_token (zbegin);\r
out_p_id (id_forrep);\r
out_p_id (id_forstore);\r
out_p_id(id_forcont);\r
out_p_id (id_forexit);\r
out_p_id (id_loopexit);\r
out_token (zendlist);\r
\r
find_varaddr( v_l);\r
(* let intermidiate_frame be indirect-addressed *)\r
if v_l.access = i_frame then\r
load_address( v_l, true);\r
\r
offset := in_integer; w_offset := in_integer; type_v := in_integer;\r
\r
if ( type_v <> byte_typ ) and ( type_v <> word_typ ) then\r
error(pass4code_error);\r
\r
if v_l.kind <> addr then\r
begin\r
(* neither global nor local fram *)\r
\r
out_opcode( op_revpd );\r
\r
out_opcode( op_stvla );\r
out_start_param; out_integer( offset );\r
out_comment( ' store addr. of the contr. var. ' );\r
end;\r
\r
get_token;\r
find_exprs( v_r);\r
if ( v_r.kind <> 1 ) or ( ( v_r.size >= 0 ) and ( v_r.size <> 2 ) ) then\r
error(pass4code_error);\r
\r
out_opcode( op_revpw );\r
\r
get_token;\r
find_exprs( v_r);\r
\r
if ( v_r.kind <> 1 ) or ( ( v_r.size >= 0 ) and ( v_r.size <> 2 ) ) then\r
error(pass4code_error);\r
\r
out_opcode( op_revpw );\r
\r
out_opcode( op_stvlw );\r
out_start_param; out_integer(w_offset);\r
out_comment( ' save the limit value. ' );\r
(* precisely 3 words must be on the registerstack *)\r
(* at this point *)\r
hw_stack_adjust (6, 0);\r
\r
\r
mode := in_integer;\r
if ( mode <> 1 ) and ( mode <> 2 ) then\r
error(pass4code_error);\r
\r
if mode = 1 then out_opcode( op_le ) else out_opcode( op_ge );\r
out_comment( ' compare the limit with the initial value . ' );\r
out_op_id (op_jmzgt, id_forstore);\r
out_op_id (op_jmprw, id_forexit);\r
out_label (id_forrep);\r
\r
out_opcode ( op_uadhw ); (* increase or decrease *)\r
out_start_param;\r
if mode = 1 then out_integer (1)\r
else out_integer (-1);\r
\r
out_label (id_forstore);\r
(*type_v = byte_typ or word_typ*)\r
with v_l do\r
out_op_int(op_stv[conv_frame[access],conv_type[type_v]],offset);\r
\r
get_token;\r
find_statement;\r
skip_token (xendfor);\r
out_label(id_forcont);\r
\r
if v_l.access = s_frame then\r
\r
begin\r
\r
out_opcode( op_revla );\r
out_start_param; out_integer( offset );\r
out_comment( ' increment the contr. var. ' );\r
\r
out_opcode( op_revpd );\r
\r
end;\r
(*type_v is either byte_typ or word_typ*)\r
with v_l do\r
out_op_int(op_rev[conv_frame[access],conv_type[type_v]],offset);\r
\r
out_opcode( op_revpw );\r
\r
out_opcode( op_revlw );\r
out_start_param; out_integer(w_offset);\r
if mode = 1 then\r
out_opcode ( op_lt )\r
else\r
out_opcode ( op_gt );\r
out_comment( ' check if limit is reached. ' );\r
out_op_id (op_jmzgt, id_forrep);\r
out_label (id_forexit);\r
\r
if v_l.access <> s_frame then\r
remainder := 2\r
else\r
remainder := 6;\r
out_specopcode(op_stnhb,-remainder);\r
out_label (id_loopexit);\r
\r
out_nl;\r
out_token (zend);\r
out_comment( ' end of for_statement. ' );\r
\r
\r
end (* find_for *);\r
\r
\r
\r
procedure find_channel;\r
\r
var\r
v : varaddr_descr;\r
\r
begin\r
get_token;\r
out_op_id (op_revgb, id_level); (* save oldlevel *)\r
find_varaddr( v);\r
load_address (v, true);\r
out_opcode(op_revpd);\r
out_opcode (op_lrese);\r
out_opcode (op_revpd);\r
\r
out_opcode( op_iocda );\r
\r
out_opcode( op_csell );\r
out_resta (0);\r
\r
skip_token (xchanvar);\r
find_statement;\r
skip_token (xendchannel);\r
out_opcode(op_lrele);\r
\r
out_opcode( op_csell ); (* restore oldlevel *)\r
\r
end (* find_channel *);\r
\r
\r
\r
\r
procedure find_case;\r
\r
var\r
first_entry, last_entry: case_table_ptr; (* list of case table entries *)\r
v_r : varvalue_descr;\r
first, last , contents_of_table : integer;\r
otherwise_found : boolean;\r
\r
\r
procedure add_to_table( f, l : integer);\r
var\r
i,j : integer;\r
cur_entry, help_entry: case_table_ptr;\r
begin\r
cur_entry:= last_entry;\r
i:= contents_of_table; (* number of elements *)\r
\r
(* create range descriptor and insert it into the sorted list of case table entries *)\r
while (i>0) and (cur_entry^.last>f) do (* search from high end *)\r
begin \r
i:= i-1;\r
cur_entry:= cur_entry^.former_entry;\r
end;\r
\r
if (cur_entry=nil) and (first_entry<>nil) and (first_entry^.first<=l) or\r
(cur_entry<>nil) and ((cur_entry^.last=f) or\r
(cur_entry<>last_entry) and (cur_entry^.next_entry^.first<=l)) then\r
error (case_label_error)\r
else\r
begin (* the entry is ok *)\r
(* now insert a new entry after cur_entry *)\r
if case_tab_freelist=nil then\r
begin (* allocate an element to the free list *)\r
new(case_tab_freelist);\r
case_tab_freelist^.next_entry:= nil;\r
end;\r
\r
if cur_entry=nil then\r
begin (* insert in front of list *)\r
cur_entry:= case_tab_freelist;\r
case_tab_freelist:= case_tab_freelist^.next_entry;\r
cur_entry^.next_entry:= first_entry;\r
if first_entry=nil then (* first element *)\r
begin\r
last_entry:= cur_entry;\r
last_entry^.next_entry:= nil;\r
end\r
else\r
first_entry^.former_entry:= cur_entry;\r
first_entry:= cur_entry;\r
cur_entry^.former_entry:= nil;\r
end\r
else\r
begin (* not in front of list *)\r
help_entry:= case_tab_freelist;\r
case_tab_freelist:= case_tab_freelist^.next_entry;\r
help_entry^.next_entry:= cur_entry^.next_entry;\r
cur_entry^.next_entry:= help_entry;\r
help_entry^.former_entry:= cur_entry;\r
if cur_entry=last_entry then\r
last_entry:= help_entry\r
else\r
help_entry^.next_entry^.former_entry:= help_entry;\r
cur_entry:= help_entry;\r
end;\r
\r
contents_of_table := contents_of_table + 1;\r
with cur_entry^ do\r
begin\r
first := f;\r
last := l;\r
x_index := contents_of_table;\r
end;\r
out_lix_label (x_name, contents_of_table);\r
end;\r
end; (* procedure add-to-table *)\r
\r
\r
procedure out_table;\r
\r
var\r
cur_entry: case_table_ptr;\r
i, j, min, max, next : integer;\r
position_found : boolean;\r
\r
begin\r
\r
(* output the sorted table as a single constant : *)\r
if contents_of_table <= 0 then\r
begin (* empty case-table, simulate inconsistent case-range! *)\r
min := 1;\r
max := 0;\r
end\r
else\r
begin\r
min := first_entry^.first;\r
max := last_entry^.last;\r
end;\r
\r
out_label( id_casetab ); out_tab( 15 );\r
out_token(zconst);\r
out_integer( (max - min + 1) * pointer_length + 2*word_length + pointer_length);\r
out_comment( ' start of case_jump table. ' );\r
out_nl; out_token (dollar_i); out_integer (min);\r
out_nl; out_token (dollar_i); out_integer (max);\r
out_nl; out_token (dollar_a); out_identifier (id_otherwise);\r
\r
\r
next := min;\r
cur_entry:= first_entry;\r
for i := 1 to contents_of_table do\r
with cur_entry^ do\r
begin\r
\r
while next < first do\r
begin\r
out_nl; out_token (dollar_a); out_identifier (id_otherwise);\r
next := next + 1\r
\r
end;\r
\r
while next <= last do\r
begin\r
out_nl; out_token (dollar_a); out_lix (x_name, x_index);\r
next := next + 1\r
\r
end;\r
cur_entry:= next_entry;\r
end; (* for i ... with cur ... *)\r
\r
out_nl; out_tab( 15 ); out_token (zend);\r
out_comment( ' end of case_jump table. ' );\r
\r
out_nl;\r
\r
(* return case entry descriptors to case tab freelist *)\r
if first_entry<>nil then\r
begin\r
last_entry^.next_entry:= case_tab_freelist;\r
case_tab_freelist:= first_entry;\r
end;\r
end; (* out table *)\r
\r
begin\r
\r
contents_of_table := 0;\r
first_entry:= nil;\r
last_entry:= nil;\r
out_nl;\r
out_token (zbegin);\r
out_p_id (id_casetab);\r
out_p_id (id_otherwise);\r
out_p_id (id_caseexit);\r
out_p_id (x12_name); out_char('#');\r
out_token (zendlist);\r
\r
get_token;\r
find_exprs( v_r);\r
\r
if ( v_r.kind <> 1 ) or\r
( ( v_r.size >= 0 ) and ( v_r.size <> 2 ) ) then\r
error(pass4code_error);\r
out_op_id (op_jmcht, id_casetab);\r
\r
skip_token (xcase);\r
\r
otherwise_found := false;\r
\r
while token <> xendcase do\r
begin\r
\r
repeat \r
\r
case token of\r
\r
xcaselabel :\r
begin\r
\r
first := in_integer;\r
last := first;\r
\r
add_to_table( first, last);\r
\r
end;\r
\r
xcaserange :\r
begin\r
\r
first := in_integer;\r
last := in_integer;\r
\r
if last < first then error(case_label_error);\r
\r
add_to_table( first, last);\r
\r
end;\r
\r
xotherwise :\r
begin\r
\r
if otherwise_found then error(pass4code_error);\r
\r
otherwise_found := true;\r
\r
out_label( id_otherwise );\r
\r
end;\r
\r
else\r
error(pass4code_error);\r
\r
end;\r
\r
get_token;\r
\r
until ( token = xendcaselist );\r
\r
get_token;\r
find_statement;\r
skip_token (xendcasestat);\r
out_op_id (op_jmprw, id_caseexit);\r
\r
end;\r
\r
\r
if not otherwise_found then\r
begin\r
\r
out_label( id_otherwise );\r
\r
code_exc_trigger( c_exc_case);\r
out_op_id (op_jmprw, id_caseexit);\r
\r
end;\r
\r
\r
out_table;\r
out_label (id_caseexit);\r
out_nl;\r
out_token (zend);\r
\r
get_token;\r
\r
\r
end (* find_case *);\r
\r
\r
\r
procedure find_statement;\r
var\r
size_of_function_result, oldstack : integer;\r
end_stat : boolean;\r
begin\r
\r
end_stat := false;\r
repeat\r
oldstack := c.stack_size;\r
case token of\r
xassignstat: find_assign;\r
xwhile: find_while;\r
xproccall,\r
xextproccall,\r
xprocessparam: begin\r
size_of_function_result := 0;\r
(* used by find process param, changed by find arglist *)\r
find_proc_call(size_of_function_result);\r
end;\r
xstdproccall: find_std_proccall;\r
xlockmesstat,\r
xlockstat: find_lock;\r
xwithstat: find_with;\r
xexchstat: find_exchange;\r
xdeflix: find_label;\r
xgoto: find_goto;\r
xifstat: find_if;\r
xrepeat: find_repeat;\r
xloopstat: find_loop;\r
xcontloopstat,\r
xexitloopstat: find_loop_goto(token);\r
xexitlock: find_exitlock;\r
xexitstat: find_exit;\r
xforstat: find_for;\r
xchannel: find_channel;\r
xcasestat: find_case;\r
else end_stat := true;\r
end;\r
if c.stack_size <> oldstack then evalstack_error;\r
until end_stat;\r
end;\r
\r
\r
\r
\r
\r
procedure find_varvalue( var v:varvalue_descr);\r
\r
var type_v, first, number, size, niv, offset : integer;\r
access : frame_kind;\r
templ_v, va : varaddr_descr;\r
\r
begin\r
\r
find_varaddr( va);\r
\r
if va.kind = packed_arr then\r
begin\r
(* push the value of an element in a packed array : *)\r
out_opcode(op_intpa);\r
out_opcode(op_inpdv);\r
out_opcode(op_revsf);\r
\r
v.kind := 1; v.size := 2\r
\r
end\r
\r
else\r
\r
if token = xindvar then\r
begin\r
\r
type_v := in_integer;\r
\r
if type_v = field_typ then\r
begin\r
first := in_integer; number := in_integer;\r
if number = 8 then\r
begin (* optimize 8-bit fields as bytes *)\r
if first = 0 then\r
type_v := byte_typ (* left byte, don't change offset *)\r
else\r
if first = 8 then\r
begin (* rigth byte, add one to offset *)\r
va.offset := va.offset + 1;\r
type_v := byte_typ;\r
end;\r
end;\r
end\r
else\r
if( type_v = addr_typ ) or ( type_v = set_typ ) then size := in_integer\r
\r
else\r
if type_v = dyn_typ then\r
begin\r
get_niv_offset( templ_v );\r
size := 0; (* not used !!! *)\r
end;\r
\r
case type_v of\r
byte_typ,\r
word_typ,\r
point_typ:\r
begin\r
with va do\r
out_op_rev__(access,type_v,c.niv-niv,offset);\r
\r
v.kind := 1;\r
if type_v = point_typ then v.size := 4 else v.size := 2\r
\r
end;\r
field_typ:\r
begin\r
\r
(*address on top of stack*)\r
with va do\r
case access of\r
g_frame:out_op_int(op_reagd,offset);\r
l_frame:out_op_int(op_reald,offset);\r
s_frame:out_op_int(op_reasd,offset);\r
i_frame:out_op_rea(c.niv-niv,offset);\r
end; (*case*)\r
(*field descriptor on top of stack*)\r
out_op_int(op_rechw,first*256 + first + number -1);\r
out_opcode(op_revsf);\r
v.kind := 1;\r
v.size := 2;\r
end;\r
addr_typ,\r
dyn_typ:\r
begin\r
\r
load_address( va, true);\r
v.kind := 2; v.size := size\r
\r
end;\r
\r
set_typ: begin\r
\r
load_address( va, true);\r
out_opcode( op_rechw );\r
out_start_param; out_integer( size );\r
\r
v.kind := 1; v.size := size + 2\r
\r
end\r
end; (* case type_v *)\r
get_token;\r
if (type_v = set_typ) then\r
begin (* if a single setvariable met then note setatm*)\r
(* if a setexpression met then output setre*)\r
if token = xcompare then in_kind:= setatm\r
else out_specopcode(op_setre,size);\r
end;\r
\r
end; (* xindvar *)\r
\r
\r
end (* find_varvalue *);\r
\r
\r
\r
\r
\r
procedure find_varaddr( var v: varaddr_descr);\r
var\r
r_v: varvalue_descr;\r
dope_v: varaddr_descr;\r
get_next_token, end_addr : boolean;\r
min,max,length:integer;\r
\r
\r
begin\r
\r
get_next_token := true;\r
\r
\r
case token of\r
xaddr:\r
get_niv_offset (v);\r
xcaddr:\r
begin\r
v.kind := stack_addr; v.offset := 0; v.access := s_frame;\r
v.size := 0;\r
\r
out_opcode( op_reaad );\r
out_start_param; out_lix (c_name, in_integer);\r
end;\r
else\r
begin\r
get_next_token := false; (* after fcall *)\r
(* initialize v as address on stack *)\r
with v do\r
begin\r
kind := stack_addr; offset := 0; access := s_frame;\r
size := 0;\r
end; (* with *)\r
end;\r
end;\r
\r
end_addr := false;\r
repeat\r
if get_next_token then\r
get_token\r
else\r
get_next_token := true;\r
\r
case token of\r
\r
xfield:\r
\r
begin\r
v.offset := v.offset + in_integer\r
end;\r
\r
\r
xdynfield :\r
begin\r
\r
load_address( v, true );\r
get_niv_offset( dope_v );\r
\r
with dope_v do\r
out_op_rev__(access,word_typ,c.niv-niv,offset);\r
out_opcode( op_uadd );\r
\r
end; (* dyn field *)\r
\r
\r
xindexexpr:\r
\r
begin\r
load_address (v, false);\r
\r
get_token;\r
find_exprs( r_v);\r
\r
case token of\r
xindex:\r
begin\r
get_niv_offset (dope_v);\r
load_address (dope_v, true);\r
out_opcode(op_index);\r
end;\r
xcindex:\r
begin\r
\r
out_opcode( op_reaad );\r
out_start_param; out_lix (c_name, in_integer);\r
out_opcode(op_index);\r
end;\r
xhindex:\r
begin\r
min := in_integer;\r
max := in_integer;\r
length := in_integer;\r
if length > 2 then\r
begin\r
out_op_int(op_indh[min,0],max);\r
out_p_int(length);\r
end else\r
out_op_int(op_indh[min,length],max);\r
end;\r
else error(pass4code_error);\r
end;\r
\r
\r
end (* t_indexexpr *);\r
\r
xindaddr:\r
with v do\r
begin\r
out_op_rev__(access,point_typ,c.niv-niv,offset);\r
kind := stack_addr;\r
offset:= 0;\r
access:=s_frame;\r
end (*with v do*)\r
\r
else end_addr := true;\r
end;\r
until end_addr;\r
\r
if token = xpackedarr then\r
begin\r
load_address (v, true);\r
\r
get_token;\r
find_exprs( r_v);\r
case token of\r
xindex:\r
begin\r
get_niv_offset(dope_v);\r
load_address(dope_v,true);\r
end;\r
xcindex:\r
begin\r
out_opcode(op_reaad);\r
out_start_param;\r
out_lix(c_name,in_integer);\r
end;\r
xhindex:\r
begin\r
min := in_integer;\r
max := in_integer;\r
length := in_integer;\r
if length > 2 then\r
begin\r
out_op_int(op_indh[min,0],max);\r
out_p_int(length);\r
end else\r
out_op_int(op_indh[min,length],max);\r
end;\r
else error(pass4code_error);\r
end;\r
\r
v.kind := packed_arr; v.size := 0;\r
\r
get_token;\r
\r
end\r
\r
\r
end (* find_varaddr *) ;\r
\r
\r
\r
\r
procedure find_init;\r
\r
var\r
type_o : integer;\r
i : integer;\r
w_offset, offset, number, size, size_l, size_c, lower, upper : integer;\r
stack_save : integer;\r
va : varaddr_descr;\r
\r
\r
\r
begin\r
\r
stack_save := c.stack_size;\r
\r
case token of\r
\r
xinitialize :\r
begin\r
get_token;\r
find_varaddr( va);\r
case token of\r
xstrucinit:\r
begin\r
\r
size := in_integer;\r
i := in_integer; (* lix *)\r
\r
load_address( va, true);\r
\r
out_opcode( op_reaad );\r
out_start_param; out_lix (c_name, i);\r
\r
out_opcode( op_rechw );\r
out_start_param; out_integer( size );\r
out_opcode (op_moveg)\r
end;\r
xsimpleinit:\r
begin\r
\r
type_o := in_integer;\r
i := in_integer;\r
\r
out_opcode( op_rechw );\r
out_start_param; out_integer( i );\r
\r
if va.kind = addr then\r
begin\r
\r
if va.niv <> c.niv then error(pass4code_error);\r
\r
if ( type_o = scalar_typ ) or ( type_o = bool_typ ) then\r
out_opcode( op_stvlb )\r
else\r
if type_o = int_typ then\r
out_opcode( op_stvlw )\r
else\r
error(pass4code_error);\r
\r
out_start_param; out_integer( va.offset )\r
\r
end\r
\r
else\r
if va.kind = stack_addr then\r
begin\r
\r
if ( type_o = scalar_typ ) or ( type_o = bool_typ ) then\r
out_opcode( op_stvsb )\r
else\r
if type_o = int_typ then\r
out_opcode( op_stvsw )\r
else\r
error(pass4code_error);\r
\r
out_start_param; out_integer( va.offset )\r
\r
end\r
\r
else\r
error(pass4code_error);\r
end;\r
xsetinit:\r
begin\r
\r
load_address( va, true);\r
\r
size_l := in_integer;\r
i := in_integer; (*lix *)\r
size_c := in_integer;\r
\r
out_opcode( op_reaad );\r
out_start_param; out_lix (c_name, i);\r
\r
out_opcode( op_rechw );\r
out_start_param; out_integer( size_c );\r
out_specopcode(op_setre,size_c);\r
\r
if size_l <> size_c then\r
begin\r
\r
code_stat_to_dyn( size_c + 2 );\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_setst,-size_l);\r
end;\r
else error(pass4code_error);\r
end;\r
end;\r
\r
xextexception:\r
with exc_descr do\r
begin\r
\r
state := 1;\r
internal := false;\r
key := in_integer;\r
\r
end;\r
\r
xexception :\r
with exc_descr do\r
begin\r
\r
state := 1;\r
internal := true;\r
niv := in_integer; lix := in_integer\r
\r
end;\r
\r
\r
else\r
error(pass4code_error);\r
end; (* case token of ....... *)\r
\r
if stack_save <> c.stack_size then evalstack_error;\r
\r
get_token;\r
\r
end (* find_init *);\r
\r
\r
\r
\r
procedure find_processparam( var size_of_function_result : integer );\r
\r
var\r
offset_1, offset_2, offset_3,\r
stack_size, param_length : integer;\r
v: varaddr_descr;\r
\r
begin\r
\r
get_token; (* skip: xprocessparam *)\r
if token <> xvarpointer then error(pass4code_error);\r
\r
offset_1 := in_integer;\r
\r
get_token;\r
find_varaddr(v);\r
with v do\r
if kind=addr then\r
begin\r
if niv = const_niv_0 then\r
out_op_int(op_reagd,offset)\r
else\r
if niv = c.niv then\r
out_op_int(op_reald,offset)\r
else\r
begin\r
out_op_rea(c.niv-niv,offset);\r
end;\r
end (* kind=addr *)\r
else (* stack_addr *)\r
if offset<>0 then\r
out_op_int(op_reasd, offset);\r
out_comment( ' start of process param. list . ' );\r
\r
out_opcode( op_stvla );\r
out_start_param; out_integer( offset_1 );\r
\r
out_opcode( op_reaxd );\r
\r
out_opcode( op_reasd );\r
out_start_param; out_integer( 1 );\r
\r
if token <> xtempointer then error(pass4code_error);\r
\r
offset_2 := in_integer;\r
\r
out_opcode( op_stvla );\r
out_start_param; out_integer( offset_2 );\r
\r
stack_size := c.stack_size;\r
\r
find_arglist( pred(open_call) (* closed object *), size_of_function_result );\r
\r
param_length := c.stack_size - stack_size;\r
\r
if token <> xarglistsize then error(pass4code_error);\r
\r
offset_3 := in_integer;\r
\r
out_opcode( op_rechw );\r
out_start_param; out_integer( param_length );\r
\r
out_opcode( op_stvlw );\r
out_start_param; out_integer( offset_3 );\r
out_comment( ' end of process param. list . ' );\r
\r
get_token;\r
case token of\r
xproccall,\r
xextproccall:\r
find_proc_call( size_of_function_result );\r
xfunccall,\r
xextfunccall:\r
begin\r
\r
find_call( size_of_function_result );\r
skip_token (xfcall);\r
end;\r
xprocessparam:\r
find_processparam( size_of_function_result );\r
else error(pass4code_error);\r
end;\r
\r
if size_of_function_result <> 0 then (* must be 2 or 4 *)\r
out_op_int(op_stv[l,conv_type[size_of_function_result]],offset_2);\r
out_specopcode(op_stnhb,-param_length);\r
\r
if size_of_function_result <> 0 then\r
(* load the function result again *)\r
out_op_int(op_rev[l,conv_type[size_of_function_result]],offset_2);\r
\r
\r
skip_token (xendprocessparam);\r
\r
end (* find_processparam *);\r
\r
\r
\r
\r
\r
(* body of pass5: *)\r
\r
begin\r
\r
(* initialize the set of hard exceptions : *)\r
\r
exc_hard := [ 0 .. c_exc_max ];\r
\r
(* initialize pass5 options to the default values : *)\r
\r
preserve_option:= false; (* preserve.no, i.e. remove pass4code after use *)\r
prolog_yes := true;\r
epilog_yes := true;\r
compress_yes := true;\r
callpass6_yes := true;\r
statacc_yes := false;\r
measurement_yes := false;\r
summary_yes := false;\r
enforced_exception_app := -1; (* use symbolic value from lambdaenv *)\r
enforced_create_size := 0; (* i.e. use computed value *)\r
heap_init:= false;\r
openroutine_yes := true;\r
dyn_eval_stack:= false;\r
\r
(* initialize the pseudo classes: *)\r
\r
mess_summ_state := 0; (* before heading *)\r
out_init;\r
in_init;\r
ext_init;\r
stat_reset;\r
\r
(* initialize free list of case table entry nodes *)\r
case_tab_freelist:= nil;\r
\r
\r
(* generate code for one program: *)\r
\r
find_program;\r
\r
(* terminate the pseudo classes: *)\r
if statacc_yes then stat_print;\r
\r
\r
1: (* exit from fatal errors *)\r
\r
pass5_ok := pass5_ok and callpass6_yes;\r
eom;\r
\r
if summary_yes then\r
begin\r
writeln(output);\r
heapfree := memavail;\r
release(heaporg);\r
writeln(output, 'Heep space used in bytes: ',\r
memavail - heapfree);\r
writeln;\r
end;\r
\r
end (* pass5 *);\r
\r
begin\r
needed_size := ext_tab_max;\r
needed_size := needed_size * sizeof(ext_descr);\r
if maxavail >= ord(needed_size) then\r
begin\r
getmem(p_ext_tab, needed_size);\r
pass5(p_ext_tab^, pass5_ok);\r
end else\r
begin\r
writeln(output, 'too many externals ', ext_tab_max);\r
writeln(output, ' available ', maxavail div sizeof(ext_descr));\r
end;\r
end;\r
«eof»