DataMuseum.dk

Presents historical artifacts from the history of:

DANOSI

This is an automatic "excavation" of a thematic subset of
artifacts from Datamuseum.dk's BitArchive.

See our Wiki for more about DANOSI

Excavated with: AutoArchaeologist - Free & Open Source Software. 

top - download

⟦7c91d3cc9⟧ TextFile

    Length: 62720 (0xf500)
    Types: TextFile
    Names: »RULE066A.PAS«

Derivation

└─⟦037c0ce35⟧ Bits:30010524 DVBS1.SW2114.src.2.6-2 RTP compiler source SW2104+SW2114 Disk#2 30/1-92 HHA
    └─⟦this⟧ »RTP\RULE066A.PAS« 
└─⟦828f0d3dd⟧ Bits:30010527 DVBS1.SW2114.src.2.6-5 RTP Compiler Source SW2104+SW2114 Disk 2 92.02.03 HEJ HHA
    └─⟦this⟧ »RTP\RULE066A.PAS« 
└─⟦891417be1⟧ Bits:30010519 DVBS1.SW2114.src.2-1 SW2114 1/4 Real Time Pascal 2.7 92.06.16
    └─⟦this⟧ »RTP\RULE066A.PAS«

TextFile

\r
BEGIN (* load expression *)\r
\r
\r
WITH e_stck DO\r
BEGIN\r
\r
top:= 1;\r
max_temp_size:= 0;\r
const_expr:= true;\r
last_var_index:= 0; (* start of constant (sub)expression *)\r
end;\r
\r
struc_counter:= 0;\r
arr_elems:= 0;\r
temp_offset:= 0;\r
\r
compare_set:= false;\r
set_operator:= false;\r
inside_set:= false;\r
\r
compare_string:= false;\r
\r
operand1_ix:= 1;\r
operand2_ix:= 1;\r
push_operand(cnocode, cnocode, 0); (* dummy start, used to hold possible prebool\r
information in front of first operand *)\r
\r
in_program_call:= false;\r
end_of_expression:= false;\r
\r
if i_code=cproccall then (* process cproccall before read next *)\r
rule_routinecall(i_code);\r
\r
REPEAT\r
\r
load_code(i_code); (* - read ahead - *)\r
\r
CASE i_code OF\r
\r
cliteral:\r
elementnumber:= elementnumber + 1;\r
\r
cinteger,\r
cword,\r
cbyte:\r
WITH e_stck.stck[ e_stck.top ] DO\r
IF stdcode_to_address(i_code, st_addr) THEN\r
BEGIN\r
load_unsigned_constant(i_code, ww_value);\r
\r
st_retrieve(st_addr, st_ptr);\r
\r
WITH st_ptr^ DO\r
push_operand(csimpleconst, i_code, st_size);\r
\r
WITH e_stck.stck[ e_stck.top - 1 ] DO\r
IF (type_=cinteger) THEN\r
IF (ww_value=rtp86_minint) THEN\r
if next_code<>cusub then\r
(* errormsg(this_pass, e_iliteral_range) !!!!! hha *)\r
else\r
load_code(i_code); (* skip usub, ok because minint equals -minint in 16 bits *)\r
\r
END\r
ELSE\r
\r
fatal_error(this_pass, e_std_code);\r
\r
cchar:\r
WITH e_stck.stck[ e_stck.top ] DO\r
IF stdcode_to_address(i_code, st_addr) THEN\r
BEGIN\r
\r
load_arg_2(literal_lth, ww_value);\r
\r
st_retrieve(st_addr, st_ptr);\r
\r
WITH st_ptr^ DO\r
push_operand(csimpleconst, i_code, st_size)\r
\r
END\r
ELSE\r
\r
fatal_error(this_pass, e_std_code);\r
\r
ctext:\r
WITH e_stck.stck[ e_stck.top ] DO\r
BEGIN\r
load_symbol(st_addr); (* type address *)\r
\r
load_arg_1(literal_lth);\r
\r
IF (rtpstringmax<literal_lth) THEN\r
BEGIN\r
\r
errormsg(this_pass, e_string_size);\r
helplength:= rtpstringmax\r
END\r
ELSE\r
helplength:= literal_lth;\r
\r
plm_string := '';\r
\r
FOR plm_string_ix:= 1 TO helplength DO\r
BEGIN\r
load_arg_1(u_const_value);\r
\r
IF (maxchar < u_const_value) THEN\r
begin\r
errormsg(this_pass, e_char_value);\r
u_const_value:= u_const_value MOD (maxchar + 1);\r
end;\r
\r
plm_string := plm_string + CHR(u_const_value);\r
END;\r
\r
IF (helplength < literal_lth) THEN\r
skip(literal_lth - helplength);\r
\r
Longstring_length:= helplength; (* convert to word *)\r
String_Length := helplength;\r
\r
IF Computer = RC5000 then\r
  helplength := ((helplength + 3) DIV 4) * 4;\r
\r
IF Computer = RC3502 then\r
  helplength := ((helplength + 1) DIV 2) * 2;\r
\r
push_struc_value(helplength+7*wordsize (* room for string family parameter and dope *),\r
st_aux_addr, st_addr, unused);\r
st_strucc_symbol:= sca_current_frgmnt;\r
\r
sca_fill(helplength, ptr_sca_max_string(@plm_string[1]));\r
sca_Integer(Longstring_length);\r
Longlimit:= 1;\r
limit := 1;\r
sca_Integer(Longlimit); (* subrange dope descriptor *)\r
sca_Integer(Longstring_length);\r
sca_Integer(Longstring_length); (* array dope descriptor, total length *)\r
sca_Integer(Longlimit); (* lower bound *)\r
sca_Integer(Longstring_length); (* upper bound *)\r
sca_Integer(Longlimit); (* element size *)\r
\r
st_get(st_addr, st_ptr);\r
with st_ptr^, type_address do\r
begin\r
type_mode:= bound_fam;\r
addrtype_mode:= constaddr;\r
dopeoffset:= helplength;\r
addr_label:= st_aux_addr;\r
end;\r
st_get(st_ptr^.typeref, st_ptr);\r
with st_ptr^, array_addr do\r
begin\r
addrtype_mode:= constaddr;\r
dopeoffset:= helplength+wordsize (* the parameter *) + dope_size_subrange;\r
addr_label:= st_aux_addr;\r
st_size:= string_length;\r
end;\r
st_get(st_ptr^.itype, st_ptr);\r
with st_ptr^, type_address do\r
begin\r
type_mode:= dyn;\r
(*spec_struct:= spec_struct * [dynamictype];*)\r
addrtype_mode:= constaddr;\r
dopeoffset:= helplength;\r
addr_label:= st_aux_addr;\r
st_size:= wordsize;\r
end;\r
st_get(st_ptr^.typeref, st_ptr);\r
with st_ptr^, subr_addr do\r
begin\r
subr_mode:= dyn;\r
(*spec_struct:= spec_struct * [dynamictype];*)\r
addrtype_mode:= constaddr;\r
dopeoffset:= helplength+wordsize;\r
addr_label:= st_aux_addr;\r
st_size:= wordsize;\r
end;\r
\r
push_operand(ccaddr, ctext, string_length);\r
indvar_code:= true;\r
END;\r
\r
creal:\r
fatal_error(this_pass, e_real_not_impl);\r
\r
ctypedecl:  (* family type binding in front of structured value *)\r
begin\r
load_symbol(st_aux_addr);\r
if current_level=program_level then\r
rule_defining_type(i_code, true, st_aux_addr,\r
current_level, current_offset, address_gf,\r
limit (* type-size, not uesed *), dummy_appetite (* eval appetite, not used *),\r
dummy_boolean)\r
else\r
rule_defining_type(i_code, true, st_aux_addr,\r
current_level, current_offset, address_lf,\r
limit (* type-size, not uesed *), dummy_appetite (* eval appetite, not used *),\r
dummy_boolean);\r
St_Retrieve(st_aux_addr,st_ptr);\r
IF   ((st_ptr^.Type_Mode = Bound_Fam) OR\r
      (st_ptr^.Type_Mode = Named_Bound_Fam)) AND\r
     Equal_addr(st_ptr^.St_Family_Ref,St_String_Type_Addr) AND\r
     (st_ptr^.st_size <> 0)  THEN\r
ELSE\r
with e_stck do\r
begin\r
const_expr:= false;\r
last_var_index:= stack_size;\r
end;\r
end; (* typedecl *)\r
\r
cbeginstruc:\r
WITH e_stck DO\r
BEGIN\r
load_symbol(st_aux_addr);\r
st_retrievetype(st_aux_addr, st_ptr);\r
stck[ top ].st_addr:= st_aux_addr;\r
if struc_counter=0 then (* outermost structure *)\r
begin\r
arr_elems:= 0;\r
push_operand(cstrucconst, st_ptr^.st_kind, rep_offset);\r
end\r
else\r
begin\r
stck[ top ].saved_arr_elems:= arr_elems;\r
arr_elems:= 0;\r
push_operand(cbeginstruc, st_ptr^.st_kind, rep_offset);\r
end;\r
struc_counter:= struc_counter+1;\r
if st_ptr^.st_kind=crecordtype then\r
begin\r
stck[ top ].st_addr:= st_ptr^.listref; (* first record field *)\r
rep_offset:= 0;\r
end\r
else\r
if st_ptr^.st_kind=carraytype then\r
begin\r
stck[ top ].st_addr:= st_aux_addr;\r
rep_offset:= temp_offset;\r
temp_offset:= temp_offset+wordsize;\r
if temp_offset>max_temp_size then\r
max_temp_size:= temp_offset;\r
end\r
else\r
pass3_error( e_implemented, word(st_ptr^.st_kind));\r
with stck[ top ] do\r
begin\r
dump_setrep:= st_ptr^.st_kind=carraytype;\r
rep_count_offset:= rep_offset;\r
end;\r
push_monadic_operator(cstrucelem, st_ptr^.st_kind, 0);\r
end; (* beginstruc *)\r
\r
\r
crepstruc,\r
cstrucelem:  WITH e_stck do\r
BEGIN\r
load_code(result_kind); (* endassign/endassignstring/endassignset *)\r
\r
if i_code=crepstruc then\r
saved_op:= operand1_ix\r
else\r
saved_op:= operand2_ix;\r
with stck [ stck[ saved_op ].former_fct ] do\r
(* strucelem node, pushed before the expression *)\r
begin\r
st_aux_addr:= st_addr;\r
op_kind:= type_;\r
end; (* with *)\r
if range_check then\r
begin\r
if op_kind=crecordtype then\r
(* st_aux_addr denotes a field *)\r
st_retrieve(st_aux_addr, st_ptr)\r
else\r
if op_kind=carraytype then\r
(* st_aux_addr denotes the array type *)\r
st_retrievetype(st_aux_addr, st_ptr)\r
else\r
pass3_error(e_expression_stck, word(op_kind));\r
\r
stck[ top ].st_addr:= st_ptr^.typeref; (* saved for a possible range check *)\r
st_retrieve(st_ptr^.typeref, st_ptr);\r
if (stck[ operand2_ix ].kind=csimpleconst) and (st_ptr^.type_mode=stat) then\r
begin\r
if range_error(st_ptr^.typeref, stck[ operand2_ix ].ww_value) then\r
errormsg(this_pass, e_range);\r
stck[ top ].range_chk:= false;\r
end\r
else\r
begin\r
st_retrieve(st_ptr^.typeref, st_ptr);\r
stck[ top ].range_chk:= st_ptr^.st_kind=csubrange;\r
if (stck[ operand2_ix ].kind=cnull) then\r
  stck[ top ].range_chk:= false;\r
end;\r
end\r
else\r
stck[ top ].range_chk:= false;\r
stck[ top ].rep_struc:= i_code=crepstruc;\r
\r
with stck[ operand2_ix ] do\r
begin\r
if kind=cendstruc then\r
begin\r
st_retrievetype(stck [former_fct+1 ].st_addr, st_ptr); (* carraytype *)\r
if (i_code=crepstruc) or\r
((st_ptr^.st_kind=carraytype) and (st_ptr^.st_packed <> notpacked)) then\r
begin\r
type_:= cendstruc; (* do not suppress cstrucconst and cendstruc *)\r
stck[ former_fct+1 ].kind:= cstrucconst;\r
\r
if (Computer = RC5000) then\r
begin\r
help_Size := st_Ptr^.St_Size;\r
plm_string := '?';\r
st_declaration(cvar, Plm_String, help_addr, St_ptr);\r
st_ptr^.var_level:= current_level;\r
st_ptr^.st_size:= help_size;\r
IF help_Size = 0 THEN\r
  BEGIN\r
    Help_Size := 4;\r
    st_Ptr^.Var_InDir := true;\r
    St_Ptr^.Spec_Struct := [dynamicType];\r
  END;\r
\r
St_ptr^.Var_offset:= temp_offset;\r
temp_offset:= temp_offset+help_size;\r
if temp_offset>max_temp_size then\r
max_temp_size:= temp_offset;\r
\r
St_Ptr^.TypeRef := stck[former_fct + 1].st_addr;\r
stck[former_fct+1].st_Addr := help_Addr;\r
END;\r
end;\r
end;\r
\r
(* endassig after endstruc is suppressed if endstruc is suppressed *)\r
if (type_=cnocode) and (kind=cendstruc) then\r
result_type:= cnocode\r
else\r
result_type:= result_kind;\r
end; (* with op2 *)\r
\r
if i_code=crepstruc then\r
push_operator(result_kind, result_type, 0)\r
else\r
push_monadic_operator(result_kind, result_type, 0);\r
\r
with stck[ operand2_ix ] do\r
begin (* let the predecessor of strucelem be operand1 *)\r
former_fct:= former_fct-1;\r
operand1_ix:= former_fct;\r
end;\r
\r
if op_kind=crecordtype then\r
begin\r
st_retrieve(st_aux_addr, st_ptr);\r
if not equal_addr(st_ptr^.listref, st_stopaddr) then\r
begin\r
with stck[ top ] do\r
begin\r
st_addr:= st_ptr^.listref;\r
dump_setrep:= false;\r
rep_count_offset:= 0; (* not used *)\r
end;\r
push_monadic_operator(cstrucelem, crecordtype, 0);\r
end;\r
end\r
else\r
begin (* array *)\r
if i_code=cstrucelem then\r
(* count single array elements, repeated values are counted at dump- or run-time *)\r
arr_elems:= arr_elems+1;\r
if next_code<>cendstruc then\r
begin (* prepare next element *)\r
with stck[ top ] do\r
begin\r
st_addr:= st_aux_addr;\r
dump_setrep:= false;\r
rep_count_offset:= 0; (* not used *)\r
end;\r
push_monadic_operator(cstrucelem, carraytype, 0);\r
end;\r
end; (* array *)\r
end; (* strucelem/repstruc *)\r
\r
\r
cendstruc:  with e_stck do\r
BEGIN\r
struc_counter:= struc_counter-1;\r
\r
(* find beginstruc *)\r
operand1_ix:= operand2_ix;\r
while monadic(e_stck.stck[operand1_ix].kind) do\r
operand1_ix:= e_stck.stck[operand1_ix].former_fct;\r
saved_op:= operand1_ix;\r
\r
if stck[ operand1_ix ].type_=carraytype then\r
begin\r
st_retrievetype(stck[ operand1_ix ].st_addr, st_ptr);\r
st_retrieve(st_ptr^.itype, st_ptr);\r
if st_ptr^.type_mode=stat then\r
begin\r
st_aux_addr:= st_ptr^.typeref;\r
st_retrieve(st_aux_addr, st_ptr); (* defining type *)\r
case st_ptr^.st_kind of\r
cboolean:\r
range_span:= WORD(true) + 1;\r
\r
cchar:\r
range_span:= maxchar + 1;\r
\r
cinteger:\r
range_span:= max_word + 1;\r
\r
csubrange:\r
BEGIN\r
range_span:= rtp86_wsub(st_ptr^.subr_high, st_ptr^.subr_low);\r
range_span:= range_span + 1;\r
end;\r
\r
cscalar:\r
range_span:= st_ptr^.scalar_no;\r
\r
(* OTHERWISE *) ELSE\r
fatal_error(this_pass, e_st_inconsistency)\r
\r
END; (* case *)\r
if arr_elems>range_span then\r
errormsg(this_pass, e_too_many_elems)\r
else\r
if arr_elems<range_span then\r
push_monadic_operator(cconstchecknumber, cconstchecknumber, range_span-arr_elems);\r
end\r
else\r
begin (* dynamic *)\r
stck[ top ].st_addr:= st_aux_addr;\r
push_monadic_operator(cchecknumber, cchecknumber, arr_elems);\r
const_expr:= false;\r
end;\r
operand1_ix:= saved_op;\r
IF Computer <> RC5000 THEN\r
temp_offset:= temp_offset-wordsize; (* release temporary *)\r
\r
end; (* arraytype *)\r
\r
if struc_counter>0 then\r
begin\r
arr_elems:= stck[ operand1_ix ].saved_arr_elems;\r
stck[ top ].saved_rep_offset:= stck[ operand1_ix ].size_;\r
result_type:= cnocode; (* suppress production of code for internal constants *)\r
end\r
else\r
result_type:= cendstruc;\r
\r
st_retrieve(stck[ saved_op ].st_addr, st_ptr); (* ctype node of structure *)\r
if (last_var_index<operand1_ix) and (\r
   (st_ptr^.type_mode=stat)  OR\r
      (  ((st_ptr^.Type_Mode = Bound_Fam) OR\r
          (st_ptr^.Type_Mode = Named_Bound_Fam)) AND\r
          Equal_addr(st_ptr^.St_Family_Ref,St_String_Type_Addr) AND\r
          (st_ptr^.st_size <> 0) )) THEN\r
begin\r
dump_structured_constant(e_stck, operand1_ix);\r
operand2_ix:= operand1_ix-1;\r
st_retrieve(stck[ saved_op ].st_addr, st_ptr);\r
push_operand(ccaddr, cstrucconst, st_ptr^.st_size);\r
stck[ operand2_ix ].indvar_code:= true; (* force load of constant *)\r
end\r
else\r
begin\r
push_monadic_operator(cendstruc, result_type, st_ptr^.st_size);\r
if (Computer = RC3502) AND (Result_type = cEndStruc) then fatal_error(This_Pass,e_implemented);\r
\r
if (Computer = RC5000) AND (Result_Type = cEndStruc) then\r
begin\r
help_Size := st_Ptr^.St_Size;\r
plm_string := '?';\r
st_declaration(cvar, Plm_String, help_addr, St_ptr);\r
st_ptr^.var_level:= current_level;\r
st_ptr^.st_size:= help_size;\r
IF help_Size = 0 THEN\r
  BEGIN\r
    Help_Size := 4;\r
    st_Ptr^.Var_InDir := true;\r
    St_Ptr^.Spec_Struct := [dynamicType];\r
  END;\r
\r
St_ptr^.Var_offset:= temp_offset;\r
temp_offset:= temp_offset+help_size;\r
if temp_offset>max_temp_size then\r
max_temp_size:= temp_offset;\r
\r
St_Ptr^.TypeRef := stck[operand1_ix ].st_addr;\r
stck[operand1_ix].st_Addr := help_Addr;\r
END;\r
operand1_ix:= stck[ operand1_ix ].former_fct;\r
stck[ operand2_ix ].former_fct:= operand1_ix;\r
end;\r
\r
end; (* cendstruc *)\r
\r
\r
cconst:\r
WITH e_stck.stck[ e_stck.top ] DO\r
BEGIN\r
\r
elementnumber:= elementnumber + 1;\r
\r
load_symbol(st_aux_addr);\r
\r
st_retrieve(st_aux_addr, st_ptr); (* constant name *)\r
st_retrieve(st_ptr^.typeref, st_ptr); (* ctype node *)\r
\r
st_addr:= st_ptr^.typeref; (* defining type *)\r
\r
st_retrieve(st_addr, st_ptr);\r
\r
type_:= st_ptr^.st_kind;\r
\r
st_retrieve(st_aux_addr, st_ptr);\r
\r
WITH st_ptr^ DO\r
\r
if const_kind=csimpleconst then\r
BEGIN\r
ii_value:= const_val;\r
push_operand(csimpleconst, type_, st_size);\r
end\r
else\r
BEGIN\r
st_strucc_symbol:= st_struc_symb;\r
push_operand(ccaddr, type_, st_size);\r
END;\r
\r
end; (* cconst *)\r
\r
\r
cid:\r
WITH e_stck.stck[ e_stck.top ] DO\r
BEGIN\r
\r
elementnumber:= elementnumber + 1;\r
\r
with e_stck do\r
begin\r
const_expr:= false;\r
last_var_index:= top;\r
end;\r
\r
load_symbol(st_addr);\r
st_retrieve(st_addr, st_ptr);\r
(* error report 76\r
if (st_ptr^.st_kind=cwithvar) or (st_ptr^.st_kind=cwithstat) then\r
st_retrievetype(st_ptr^.listref, st_ptr)\r
else\r
*)\r
st_retrievetype(st_ptr^.typeref, st_ptr);\r
\r
WITH st_ptr^ DO\r
BEGIN\r
\r
push_operand(caddr, st_kind, st_size);\r
\r
with e_stck.stck[operand2_ix] do\r
IF access_check THEN\r
access_chk:= st_kind IN [ cshared, csharedparam, cvarparam, cinspectparam ]\r
else\r
access_chk:= false;\r
\r
END\r
\r
end; (* cid *)\r
\r
\r
cnull: (* '?' as operand in structured value *)\r
WITH e_stck.stck[ e_stck.top ] DO\r
BEGIN\r
elementnumber:= elementnumber + 1;\r
load_symbol(st_addr); (* ctype of associated field *)\r
st_retrieve(st_addr, st_ptr);\r
ww_value := 0;\r
push_operand(cnull, cnull, st_ptr^.st_size);\r
end; (* cnull *)\r
\r
\r
ctypeselect,\r
cuparrow,\r
cfield:\r
begin\r
WITH e_stck.stck[ e_stck.top ] DO\r
BEGIN\r
load_symbol(st_addr);\r
st_retrieve(st_addr, st_ptr);\r
precode:= cnocode;\r
if i_code=cfield then\r
if st_ptr^.bit_size<>0 then precode:= cpacked;\r
st_retrievetype(st_ptr^.typeref, st_ptr);\r
\r
(* push typeselect/field/uparrow, i.e. push a monadic operator and an operand in one stack node *)\r
if i_code<>cuparrow then\r
elementnumber:= elementnumber + 1;\r
\r
kind:= i_code;\r
type_:= st_ptr^.st_kind;\r
size_:= st_ptr^.st_size;\r
former_fct:= operand2_ix;\r
operand1_ix:= operand2_ix;\r
operand2_ix:= e_stck.top;\r
indvar_code:= false;\r
prebool:= 0;\r
\r
if e_stck.top<e_stck.stack_size then\r
e_stck.top:= e_stck.top+1\r
else\r
fatal_error(this_pass, e_expression_ovfl);\r
\r
end;\r
end; (* field/uparrow *)\r
\r
cindex:  WITH e_stck.stck[ e_stck.top ] DO\r
BEGIN\r
load_symbol(st_aux_addr); (* ctype node *)\r
st_retrievetype(st_aux_addr, st_ptr); (* carraytype node *)\r
with st_ptr^ do\r
begin\r
helpcode := St_packed;\r
st_addr:= typeref;\r
index_type_symbol:= itype;\r
end;\r
\r
if index_check then\r
begin\r
st_retrieve(index_type_symbol, st_ptr);\r
if (st_ptr^.type_mode=stat) and (e_stck.stck[operand2_ix].kind=csimpleconst) then\r
begin\r
index_chk:= false;\r
IF range_error(st_ptr^.typeref, e_stck.stck[operand2_ix].ww_value) THEN\r
errormsg(this_pass, e_index_expression)\r
END\r
ELSE\r
begin\r
st_retrieve(st_ptr^.typeref, st_ptr);\r
index_chk:= (st_ptr^.st_kind<>cinteger) and (st_ptr^.st_kind<>cchar);\r
if index_chk then\r
IF (Computer = RC3502) then\r
IF ( (helpcode <> notpacked) or ( ( st_ptr^.subr_low <> 0) AND\r
                                  ( st_ptr^.subr_high <> 1))) THEN\r
  BEGIN\r
    st_retrievetype(st_aux_addr, st_ptr); (* carraytype node *)\r
    if  (st_Ptr^.array_Addr.AddrType_Mode = ConstAddr) THEN\r
     BEGIN\r
       st_get(st_Ptr^.st_Family_ref,st_Ptr);\r
       st_Ptr^.used := true;\r
     end;\r
  END;\r
end;\r
end\r
else\r
index_chk:= false;\r
\r
st_retrievetype(st_addr, st_ptr);\r
push_monadic_operator(cindex, st_ptr^.st_kind, st_ptr^.st_size);\r
(* tog *)\r
if helpcode <> notpacked\r
then e_stck.stck[ e_stck.top - 1 ].precode:= cpacked;\r
END; (* index *)\r
\r
\r
cendvariable:\r
WITH e_stck.stck[ operand2_ix ] DO\r
BEGIN\r
indvar_code:= true;\r
if monadic(kind) then\r
begin\r
while monadic(e_stck.stck[operand1_ix].kind) do\r
operand1_ix:= e_stck.stck[operand1_ix].former_fct;\r
\r
operand1_ix:= e_stck.stck[operand1_ix].former_fct;\r
former_fct:= operand1_ix;\r
end; (* monadic operand 2 *)\r
\r
END; (* endvariable *)\r
\r
\r
csetlist:  with e_stck, stck[ top ] do\r
begin\r
if inside_set then\r
fatal_error(this_pass, e_set_not_impl);\r
inside_set:= true;\r
func_call_in_set:= false;\r
set_lower:= maxint;\r
set_upper:= -maxint;\r
load_symbol(st_addr);\r
push_operand(csetlist, csetlist, 0);\r
end; (* setlist *)\r
\r
cs_element:  with e_stck, stck[ operand2_ix ] do\r
begin\r
if kind=csimpleconst then\r
begin\r
if ii_value<set_lower then\r
set_lower:= ii_value;\r
if ii_value>set_upper then\r
set_upper:= ii_value;\r
end;\r
push_monadic_operator(cs_element, cs_element, 0);\r
end; (* s_element *)\r
\r
cm_element: with e_stck do\r
begin\r
with stck[ operand2_ix ] do\r
begin\r
if (kind=csimpleconst) and (stck[ former_fct ].kind=csimpleconst) then\r
if ii_value>=stck[ former_fct ].ii_value then (* non empty interval *)\r
begin\r
if ii_value>set_upper then\r
set_upper:= ii_value;\r
if stck[ former_fct ].ii_value<set_lower then\r
set_lower:= stck[ former_fct ].ii_value;\r
end;\r
end; (* with op2 *)\r
\r
push_monadic_operator(cm_element, cm_element, 0);\r
with stck[ operand2_ix ] do\r
former_fct:= stck[ former_fct ].former_fct;\r
end; (* cm_element *)\r
\r
cendsetlist: with e_stck, stck[ top ] do\r
begin\r
operand1_ix:= operand2_ix; (* find setlist node *)\r
set_elem_count:= 0;\r
while monadic(stck[ operand1_ix ].kind) do\r
begin\r
set_elem_count:= set_elem_count+1;\r
operand1_ix:= stck[ operand1_ix ]. former_fct;\r
end;\r
if last_var_index<operand1_ix then\r
dump_set_const\r
else\r
begin\r
operand1_ix:= stck[ operand1_ix ].former_fct;\r
push_monadic_operator(cendsetlist, csettype, 0);\r
stck[ operand2_ix ].former_fct:= operand1_ix;\r
end;\r
inside_set:= false;\r
end; (* endsetlist *)\r
\r
\r
cfunccall,\r
cproccall:\r
BEGIN\r
rule_routinecall(i_code);\r
END;\r
cprogramcall:  begin\r
elementnumber:=elementnumber+1;\r
WITH e_stck.stck[ operand2_ix ] DO\r
BEGIN\r
if monadic(kind) then\r
begin\r
while monadic(e_stck.stck[operand1_ix].kind) do\r
operand1_ix:= e_stck.stck[operand1_ix].former_fct;\r
\r
operand1_ix:= e_stck.stck[operand1_ix].former_fct;\r
former_fct:= operand1_ix;\r
end; (* monadic operand 2 *)\r
END;\r
with e_stck do\r
load_symbol(stck[ top ].st_addr);\r
push_operator(cprogramcall, cprogramcall, address_size);\r
in_program_call:=true;\r
end; (* cprogramcall *)\r
\r
\r
ctypesizecall,\r
cvarsizecall:\r
with e_stck, stck[ top ] do\r
begin\r
load_symbol(st_addr);\r
st_retrieve(st_addr, st_ptr);\r
if i_code=cvarsizecall then\r
st_retrieve(st_ptr^.typeref, st_ptr);\r
if (st_ptr^.type_mode=stat) OR\r
 (((st_ptr^.type_mode = named_bound_fam) OR\r
   (st_ptr^.type_mode = bound_fam)) AND\r
   (st_ptr^.type_address.addrtype_mode = ConstAddr)) then\r
begin\r
ww_value:= st_ptr^.st_size;\r
if stdcode_to_address(cinteger, st_addr) then ;\r
push_operand(csimpleconst, cinteger, wordsize);\r
end\r
else (* dynamic *)\r
begin\r
st_addr:= st_ptr^.typeref; (* address of node with dope descriptor *)\r
push_operand(caddr, cinteger, wordsize);\r
stck[ operand2_ix ].indvar_code:= true;  (* load the value *)\r
end;\r
 \r
end; (* typesizecall/varsizecall *)\r
\r
\r
cbeginactual:\r
(* TOG *) start_of_actual_param:=e_stck.top;\r
\r
cendactual:  ;\r
\r
\r
cendtype:\r
end_of_expression:= true;\r
\r
\r
cvalueparam:\r
with e_stck.stck[e_stck.top] do\r
begin\r
load_symbol(st_addr); (* type of formal parameter *)\r
st_retrieve(st_addr, st_ptr);\r
limit:= st_ptr^.st_size; (* saved in case of set value parameter *)\r
\r
IF (((st_ptr^.Type_Mode = Bound_Fam) OR\r
     (st_ptr^.Type_Mode = Named_Bound_Fam)) AND\r
     Equal_addr(st_ptr^.St_Family_Ref,St_String_Type_Addr)) THEN\r
     BEGIN\r
       IF (Computer = RC3502) AND (Limit <> 0)\r
       THEN (*e_stck.stck[ operand2_ix ].Size_ := limit*)\r
       ELSE limit := 0;\r
     END;\r
if limit=0 then\r
(* dynamic sized valueparameter, parameter passing is done by address *)\r
begin\r
i_code:= cvarparam;\r
e_stck.stck[ operand2_ix ].indvar_code:= false;\r
range_chk:= false;\r
end\r
else\r
if range_check then\r
if (e_stck.stck[operand2_ix].kind=csimpleconst)\r
and (st_ptr^.type_mode=stat) then\r
begin\r
if range_error(st_ptr^.typeref, e_stck.stck[operand2_ix].ww_value) THEN\r
errormsg(this_pass, e_range);\r
range_chk:= false;\r
END\r
else\r
begin\r
range_chk:= st_ptr^.type_mode<>open_fam; (* no range check in case of open family parameter *)\r
st_retrieve(st_ptr^.typeref, st_ptr);\r
range_chk:= range_chk and (st_ptr^.st_kind=csubrange);\r
end\r
ELSE\r
range_chk:= false;\r
family_type:= false;\r
\r
with e_stck.stck[ operand2_ix ] do\r
if type_=csettype then\r
begin\r
size_:= limit; (* size of formal type *)\r
if computer = RC5000 then size_ := size_ + 40;\r
i_code:= csetvalueparam;\r
indvar_code := true;\r
end;\r
\r
push_monadic_operator(i_code, cvalueparam, 0);\r
(* tog *) start_of_actual_param:=e_stck.top;\r
end; (* value param *)\r
\r
\r
cvarparam,\r
cinspectparam,\r
csharedparam:\r
begin\r
with e_stck,stck [ operand2_ix ] do\r
begin\r
indvar_code:= false;\r
if kind=csimpleconst then\r
errormsg(this_pass,e_simpleconst)\r
(* tog *)\r
else if precode=cpacked then errormsg(this_pass,e_irregular)\r
else if in_program_call then\r
begin\r
(* TOG *) st_retrieve(stck[start_of_actual_param].st_addr,st_ptr);\r
if (st_ptr^.var_level<>program_level) or\r
(type_=clockvar) or (type_=cwithvar) or (type_=cwithstat) or (type_=cforstat)\r
then errormsg(this_pass,e_tempvar);\r
end;\r
end;\r
\r
with e_stck, stck[ top ] do\r
begin\r
family_type:= false;\r
range_chk:= false;\r
end;\r
push_monadic_operator(i_code, i_code, address_size);\r
(* TOG *) start_of_actual_param:=e_stck.top;\r
end; (* address transfer parameter *)\r
\r
\r
cfamilytype:  with e_stck.stck[ operand2_ix ] do\r
begin\r
family_type:= true;\r
load_symbol(param_type_symbol);\r
end; (* familytype *)\r
\r
\r
cendfunccall:\r
BEGIN\r
load_symbol(st_aux_addr);\r
st_retrieve(st_aux_addr, st_ptr);\r
(* find routine call *)\r
operand1_ix:= operand2_ix;\r
while monadic(e_stck.stck[operand1_ix].kind) do\r
operand1_ix:= e_stck.stck[operand1_ix].former_fct;\r
\r
fold_function:= false;\r
std_routine:= standard_routines(st_ptr^.prog_createsize);\r
\r
case std_routine of\r
\r
std_routine_begin:\r
BEGIN\r
END;\r
\r
std_ord,\r
std_int:\r
fold_function:= fold_function_call(cinteger, wordsize,\r
e_stck.stck[ operand2_ix-1 ].ww_value);\r
\r
std_wrd:\r
fold_function:= fold_function_call(cword, wordsize,\r
e_stck.stck[ operand2_ix-1 ].ww_value);\r
\r
\r
std_chr:\r
fold_function:= fold_function_call(cchar, bytesize,\r
e_stck.stck[ operand2_ix-1 ].ww_value);\r
\r
std_byt:\r
fold_function:= fold_function_call(cbyte, bytesize,\r
e_stck.stck[ operand2_ix-1 ].ww_value mod (maxbyte+1));\r
\r
\r
std_abs:\r
fold_function:= fold_function_call(cinteger, wordsize,\r
rtp86_abs(e_stck.stck[ operand2_ix-1 ].ww_value));\r
\r
\r
std_pred,\r
std_succ:\r
if e_stck.stck[ operand2_ix-1 ].kind=csimpleconst then\r
with e_stck, stck[ operand2_ix-1 ] (* the actual parameter node *) do\r
begin (* fold constant function call, i.e. remove the call *)\r
fold_function:= true;\r
stck[ operand1_ix ].st_addr:= st_addr;\r
stck[ operand1_ix ].kind:= csimpleconst;\r
stck[ operand1_ix ].type_:= type_;\r
stck[ operand1_ix ].size_:= size_;\r
if std_routine=std_succ then\r
begin\r
stck[ operand1_ix ].ww_value:= rtp86_wadd(ww_value, 1);\r
if type_=cscalar then\r
begin\r
st_retrievetype(st_addr, st_ptr);\r
limit:= st_ptr^.scalar_no-1;\r
end\r
else\r
if type_=cboolean then\r
limit:= 1\r
else\r
if type_=cchar then\r
limit:= maxbyte\r
else\r
limit:= maxint;\r
if ww_value=limit then\r
errormsg(this_pass, e_overflow);\r
end\r
else (* pred *)\r
begin\r
stck[ operand1_ix ].ww_value:= rtp86_wsub(ww_value, 1);\r
if (ww_value=0) and ((type_=cscalar) or (type_=cchar) or (type_=cboolean)) then\r
if ww_value=0 then\r
errormsg(this_pass, e_overflow);\r
end;\r
top:= top-2; (* pop "valueparam" and actual parameter *)\r
end (* with actual parameter;  fold succ/pred *)\r
else\r
begin\r
with e_stck, stck[ operand2_ix-1 ] (* the actual parameter node *) do\r
begin\r
result_type:= type_;\r
result_type_addr:= st_addr;\r
op_kind:= kind;\r
case op_kind of\r
cadd, csub, cmul, cdiv, cmod, cusub:\r
begin\r
result_type:= cinteger;\r
if stdcode_to_address(result_type, result_type_addr) then ;\r
end; (* integer operator *)\r
cge, cle, cgt, clt, ceq, cne, cnot, cin: (* boolean result operators *)\r
begin\r
result_type:= cboolean;\r
if stdcode_to_address(result_type, result_type_addr) then ;\r
end; (* boolean operator *)\r
caddr,\r
cfield:  begin\r
st_retrieve(result_type_addr, st_ptr);\r
result_type_addr:= st_ptr^.typeref;\r
st_retrievetype(result_type_addr, st_ptr);\r
end;\r
ctypeparam, (* after succ or pred *)\r
cindex,\r
cuparrow:  st_retrievetype(result_type_addr, st_ptr);\r
cendfunccall:\r
begin\r
st_retrieve(result_type_addr, st_ptr);\r
st_retrievetype(st_ptr^.typeref, st_ptr);\r
end; (* endfunccall *)\r
(*otherwise*) else\r
fatal_error(this_pass, e_token_066);\r
end; (* case *)\r
end; (* with actual parameter *)\r
\r
dynamic_subrange:= false;\r
case result_type of\r
cinteger:\r
if std_routine=std_succ then\r
limit:= maxint\r
else\r
limit:= rtp86_minint;\r
cboolean:\r
if std_routine=std_succ then\r
limit:= 1\r
else\r
limit:= 0;\r
cchar:\r
if std_routine=std_succ then\r
limit:= maxbyte\r
else\r
limit:= 0;\r
csubrange:\r
begin\r
st_retrieve(result_type_addr, st_ptr);\r
st_retrievetype(st_ptr^.typeref, st_ptr);\r
with st_ptr^ do\r
(* tog *) if subr_mode=stat then\r
if std_routine=std_succ then\r
limit:= subr_high\r
else\r
limit:= subr_low\r
else begin\r
(* dynamic type *)\r
dynamic_subrange:= true;\r
if std_routine=std_succ then\r
limit:= subr_addr.offset+2\r
else\r
limit:= subr_addr.offset;\r
end;\r
end; (* subrange *)\r
cscalar:\r
if std_routine=std_pred then\r
limit:= 0\r
else\r
limit:= st_ptr^.scalar_no-1;\r
(*otherwise *) else\r
fatal_error(this_pass, e_token_066);\r
end; (* case result_type *)\r
\r
(* add parameter denoting upper/lower limit of type *)\r
saved_op:= operand1_ix;\r
e_stck.stck[ e_stck.top ].ww_value:= limit;\r
e_stck.stck[ e_stck.top ].St_addr:= Result_Type_Addr;\r
if dynamic_subrange then\r
push_operand(caaddr, cinteger, wordsize) else\r
push_operand(csimpleconst, cinteger, wordsize);\r
e_stck.stck[ operand2_ix ].indvar_code:= true; (* force load of constant *)\r
(* save type address for possible surrounding succ/pred *)\r
with e_stck.stck[ e_stck.top ] do\r
begin\r
st_addr:= result_type_addr;\r
family_type:= false;\r
range_chk:= false;\r
end;\r
push_monadic_operator(cvalueparam, cvalueparam, 0);\r
operand1_ix:= saved_op;\r
\r
st_retrieve(st_aux_addr, st_ptr); (* reestablish st_ptr to denote the function *)\r
end; (* succ/pred *)\r
\r
\r
std_inc:\r
with e_stck, stck[ operand2_ix-1 ] (* the actual parameter node *) do\r
if size_=bytesize then\r
fold_function:= fold_function_call(type_, size_, (ww_value+1) mod (maxbyte+1))\r
else\r
fold_function:= fold_function_call(type_, size_, ww_value+1);\r
\r
\r
std_dec:\r
with e_stck, stck[ operand2_ix-1 ] (* the actual parameter node *) do\r
if size_=bytesize then\r
fold_function:= fold_function_call(type_, size_, (ww_value-1) mod (maxbyte+1))\r
else\r
fold_function:= fold_function_call(type_, size_, ww_value-1);\r
\r
\r
{$IFNDEF RTP86}\r
std_GetBufDelay,\r
std_waitDelay :\r
  IF (Computer <> RC5000) AND (Computer <> RC3502) THEN\r
  WITH e_Stck DO\r
  BEGIN\r
    (* exchange parameters *)\r
    (* move nodes of the first parameter and the Cvarparam-node on top of stack *)\r
    mark1:= operand1_ix;\r
    mark2:= 0;\r
    nofunccall := 0;\r
    repeat\r
     if top+mark2>stack_size then\r
       fatal_error(this_pass, e_expression_ovfl);\r
     mark1:= mark1+1;\r
     stck[ top+mark2 ]:= stck[ mark1 ];\r
     IF stck[mark1].kind = cfunccall then nofunccall := nofunccall + 1;\r
     IF stck[mark1].kind = cendfunccall then nofunccall := nofunccall - 1;\r
     mark2:= mark2+1;\r
    until (stck[ mark1 ].kind=cVarParam) AND (NoFuncCall = 0);\r
    (* mark2 is # of moved elements *)\r
    (* move nodes of the next 1 or 2 parameters as first parameters *)\r
    mark3 := mark1;\r
    mark1:= operand1_ix;\r
    if std_routine = std_getbufdelay then NoVarParams := 0\r
                                    else NoVarParams := 1;\r
    repeat\r
     mark1:= mark1+1;\r
     mark3 := mark3 + 1;\r
     stck[ mark1 ]:= stck[ mark3 ];\r
     IF stck[mark1].kind = cfunccall then nofunccall := nofunccall + 1;\r
     IF stck[mark1].kind = cendfunccall then nofunccall := nofunccall - 1;\r
     IF (NoFuncCall = 0) AND (stck[mark1].kind = cVarParam) THEN\r
        NoVarParams := NoVarParams + 1;\r
    until  (stck[mark3].kind = cVARParam) AND\r
           (NoVarParams = 2) AND (NoFunccall = 0) ;\r
    (* move nodes of the first parameter as 2.or 3. parameter *)\r
    FOR mark3 := 1 TO Mark2 DO\r
      stck[mark3 + mark1] := stck[top + mark3 - 1];\r
\r
  END;\r
{$ENDIF}\r
std_link:  ;\r
\r
std_unlink:  ;\r
\r
std_create:  with e_stck do\r
begin\r
(* move no.des of the first parameter and the programcall-node on top of stack *)\r
mark1:= operand1_ix;\r
IF computer = RC3502 THEN mark1 := mark1 - 1;\r
mark2:= 0;\r
repeat\r
if top+mark2>stack_size then\r
fatal_error(this_pass, e_expression_ovfl);\r
mark1:= mark1+1;\r
IF Computer <> RC5000 THEN\r
stck[ top+mark2 ]:= stck[ mark1 ];\r
mark2:= mark2+1;\r
until stck[ mark1 ].kind=cprogramcall;\r
(* mark2 is # of moved elements *)\r
markRC5000 := mark1;\r
(* move actual program parameters down as first part of the CREATE parameters *)\r
mark1:=mark1+1;\r
mark3:=1;\r
IF computer = RC3502 THEN mark3 := 0;\r
while stck[ mark1 ].kind<>cendprogramcall do\r
begin\r
IF Computer <> RC5000 THEN stck[ operand1_ix+mark3 ]:= stck[ mark1 ];\r
mark3:=mark3+1;\r
mark1:=mark1+1;\r
end;\r
(* mark3 is # of moved elements + 1 *)\r
\r
IF Computer <> RC5000 THEN\r
BEGIN\r
(* move first parameter of CREATE down as successor to the actual program parameters *)\r
MarkRC5000 := operand1_ix + mark3;\r
for mark2:= 0 to mark2-1 do\r
begin\r
stck[ operand1_ix+mark3 ]:= stck[ top+mark2 ];\r
mark3:=mark3+1;\r
end;\r
\r
\r
(* push programcall node on top of stack *)\r
IF Computer <> RC3502 THEN\r
BEGIN\r
 stck[ top ]:= stck[ operand1_ix+mark3-1 ];\r
 operand2_ix:= top;\r
 top:=top+1;\r
 (* delete program call node *)\r
  stck[ operand1_ix+mark3-1 ].kind:= cnocode;\r
END;\r
\r
(* delete endprogram call node *)\r
stck[ operand1_ix+mark3 ].kind:= cnocode;\r
IF Computer = RC3502 THEN\r
  BEGIN\r
   Mark3 := operand1_ix+mark3 -1;\r
   operand1_ix := MarkRC5000;\r
\r
  END;\r
END;\r
\r
IF Computer = RC5000 THEN\r
BEGIN\r
(* Make copy of last create paramertes *)\r
mark3 := mark1;\r
mark2:= 0;\r
repeat\r
if top+mark2>stack_size then\r
fatal_error(this_pass, e_expression_ovfl);\r
mark1:= mark1+1;\r
stck[ top+mark2 ]:= stck[ mark1 ];\r
mark2:= mark2+1;\r
until (mark1 = Top -1);\r
(* mark2 is # of moved elements *)\r
(* move actual program parameters down as last part of the CREATE parameters *)\r
repeat\r
stck[ mark1 ]:= stck[ mark3 ];\r
mark3:=mark3-1;\r
mark1:=mark1-1;\r
until (MarkRC5000 = (mark3 + 1));\r
(* move last parameter of CREATE down as predecessor to the actual program parameters *)\r
for mark2:= 0 to mark2-1 do\r
begin\r
stck[ markrc5000 + mark2 ]:= stck[ top+mark2 ];\r
end;\r
\r
END;\r
\r
(* normal endfunccall action followed by push endprogramcall *)\r
\r
end; (* std create *)\r
\r
\r
(*otherwise*) else\r
fatal_error(this_pass, e_std_routine);\r
\r
end; (* case *)\r
\r
if fold_function then\r
begin\r
operand2_ix:= operand1_ix;\r
operand1_ix:= e_stck.stck[operand2_ix].former_fct;\r
end\r
else\r
with e_stck.stck[ e_stck.top ] do\r
begin\r
st_addr:= st_aux_addr;\r
operand1_ix:= e_stck.stck[operand1_ix].former_fct;\r
with e_stck do\r
begin\r
stck[operand2_ix].former_fct:= operand1_ix;\r
const_expr:= false;\r
if last_var_index<operand2_ix then\r
last_var_index:= operand2_ix;\r
end;\r
\r
\r
param_size_:= static_link_size+st_ptr^.st_paramsize;\r
if (st_ptr^.st_specs=st_local) and st_ptr^.st_local_near then\r
param_size_:= param_size_+local_return_appetite\r
else\r
param_size_:=param_size_+global_return_appetite;\r
\r
\r
IF (Computer = RC5000) THEN\r
BEGIN\r
param_size_ := st_ptr^.st_paramsize;\r
help_addr := st_ptr^.listRef;\r
openrout := (St_Ptr^.St_Specs = St_Open);\r
IF st_ptr^.St_ParamSize > 8 THEN\r
  BEGIN\r
   st_retrieve(St_ptr^.ListRef, st_ptr);\r
   IF St_ptr^.St_Size > 4 THEN param_Size_ := param_Size_ - 8\r
   ELSE\r
     BEGIN\r
       st_retrieve(St_ptr^.ListRef, st_ptr);\r
       IF St_ptr^.St_Size > 4 THEN Param_Size_ := param_Size_ - 4;\r
     END;\r
  END;\r
while not equal_addr(help_Addr,st_stopaddr) do\r
  begin\r
    st_Retrieve(help_addr,St_ptr);\r
    help_addr := St_Ptr^.ListRef;\r
    if st_ptr^.St_kind = cvarparam then\r
      begin\r
        st_RetrieveType(St_Ptr^.TypeRef,St_Ptr);\r
        IF (St_ptr^.St_size = 4) OR OpenRout THEN\r
            Param_Size_ := Param_Size_ + 8;\r
      end;\r
  end;\r
   St_Retrieve(st_Aux_Addr,St_ptr);\r
\r
END;\r
func_call_in_set:= inside_set;\r
if (std_routine=std_succ) or (std_routine=std_pred) then\r
st_retrievetype(result_type_addr, st_ptr) (* the resulting type *)\r
else\r
st_retrievetype(st_ptr^.typeref, st_ptr);\r
push_monadic_operator(cendfunccall, st_ptr^.st_kind, st_ptr^.st_size);\r
end; (* not fold function call *)\r
\r
(* special end action in case of CREATE call *)\r
\r
if (std_routine=std_create) AND (Computer <> RC5000) then\r
with e_stck, stck[ top ] do\r
begin\r
(* push endprogramcall node with same address as programcall *)\r
(* programcall is found as nexttop element *)\r
IF Computer = RC3502 THEN  st_addr:= stck[ Mark3 ].st_addr\r
ELSE st_addr:= stck[ operand2_ix-1 ].st_addr;\r
st_retrieve(st_addr, st_ptr);\r
while st_ptr^.st_kind<>cprogram do\r
st_retrievetype(st_ptr^.typeref, st_ptr);\r
param_size_:= st_ptr^.st_paramsize;\r
push_monadic_operator(cendprogramcall, cendprogramcall, 0);\r
end (* special end action for CREATE *)\r
else\r
if (std_routine=std_succ) or (std_routine=std_pred) then\r
if not fold_function then\r
(* special end action for succ/pred, i.e. dump the function result type\r
which may be found as st_addr of pass3 generated value parameter node\r
(next to operand2) *)\r
with e_stck, stck[ top ] do\r
begin\r
st_addr:= stck[ operand2_ix-1 ].st_addr;\r
push_monadic_operator(ctypeparam, result_type, 0);\r
end;\r
\r
END; (* endfunccall *)\r
\r
\r
cendprogramcall:  with e_stck, stck[ top ] do\r
begin\r
in_program_call:= false;\r
load_symbol(st_addr);\r
\r
(* find programcall node and change possible sharedparam to shared *)\r
operand1_ix:= operand2_ix;\r
while monadic(stck[ operand1_ix ].kind) do\r
begin\r
if stck[ operand1_ix ].kind=csharedparam then\r
stck[ operand1_ix ].kind:= cshared;\r
operand1_ix:= stck[ operand1_ix ].former_fct;\r
end;\r
\r
operand1_ix:= stck[ operand1_ix ].former_fct;\r
stck[ operand2_ix ].former_fct:= operand1_ix;\r
IF computer = RC5000 THEN\r
BEGIN\r
  st_retrieve(st_addr, st_ptr);\r
  while st_ptr^.st_kind<>cprogram do\r
    st_retrievetype(st_ptr^.typeref, st_ptr);\r
  param_size_:= st_ptr^.st_paramsize;\r
END;\r
push_monadic_operator(cendprogramcall, cendprogramcall, 0);\r
end; (* cendprogramcall *)\r
\r
\r
cendproccall:\r
BEGIN\r
\r
load_symbol(st_aux_addr);\r
\r
st_retrieve(st_aux_addr, st_ptr);\r
\r
(* find routine call *)\r
operand1_ix:= operand2_ix;\r
while monadic(e_stck.stck[operand1_ix].kind) do\r
operand1_ix:= e_stck.stck[operand1_ix].former_fct;\r
\r
CASE Standard_Routines(st_ptr^.prog_createsize) of\r
std_new:\r
with e_stck do\r
begin\r
saved_op:= operand1_ix;\r
\r
with stck[ operand2_ix-1 ] (* the actual parameter *) do\r
if (kind=caddr) or (kind=cfield) then\r
begin\r
st_retrieve(st_addr, st_ptr);\r
st_retrieve(st_ptr^.typeref, st_ptr);\r
end\r
else (* kind=index or kind=uparrow *)\r
st_retrieve(st_addr, st_ptr);\r
\r
(* st_ptr^.typeref denotes an object of kind cpointertype *)\r
(* save address of pointer type for a later system init *)\r
(* the address is saved in the stack node of kind varparam *)\r
stck[ operand2_ix ].st_addr:= st_ptr^.typeref;\r
\r
(* add extra parameter the value of which is the object size *)\r
st_retrieve(st_ptr^.typeref, st_ptr);\r
st_retrieve(st_ptr^.typeref, st_ptr); (* ctype node of pointed object *)\r
\r
IF (Computer = RC3502) THEN\r
if st_ptr^.spec_struct*protected_types <> [] then\r
    stck[top - 1 ].precode := cinteger; (*FUSK tag kopi af stack top*)\r
\r
if st_ptr^.type_mode<>stat then\r
begin\r
stck[ top ].st_addr:= st_ptr^.typeref;\r
(* defining type of pointed type, i.e. the node which describes the dope vector *)\r
push_operand(caddr, cnocode, wordsize);\r
stck[ operand2_ix ].indvar_code:= true;\r
end\r
else\r
with stck[ top ] do\r
begin\r
ww_value:= st_ptr^.st_size;\r
if stdcode_to_address(cinteger, st_addr) then ;\r
push_operand(csimpleconst, cinteger, wordsize);\r
end;\r
\r
(* push valueparam node *)\r
with stck[ top ] do\r
begin\r
if stdcode_to_address(cinteger, st_addr) then ;\r
range_chk:= false;\r
family_type:= false;\r
push_monadic_operator(cvalueparam, cvalueparam, 0);\r
end;\r
\r
if st_ptr^.spec_struct*protected_types <> [] then\r
begin\r
(* set mark for rule_block in order to perform a call of systeminit *)\r
std_routine:= std_new;\r
\r
(* change i_code to endfunccall according to pass3/pass4 conventions for NEW *)\r
i_code:= cendfunccall;\r
\r
end; (* new with init *)\r
\r
\r
st_retrieve(st_aux_addr, st_ptr); (* reestablish st_ptr *)\r
operand1_ix:= saved_op;\r
end; (* new *)\r
\r
\r
{$IFNDEF RTP86}\r
std_GetBuf,\r
std_ChainDeQueue,\r
std_ChainEnQueue,\r
std_pop,\r
std_push,\r
std_signal,\r
std_wait :\r
  IF (Computer <> RC5000) AND (Computer <> RC3502) THEN\r
  WITH e_Stck DO\r
  BEGIN\r
    (* exchange parameters *)\r
    (* move nodes of the first parameter and the Cvarparam-node on top of stack *)\r
    mark1:= operand1_ix;\r
    mark2:= 0;\r
    nofunccall := 0;\r
    repeat\r
     if top+mark2>stack_size then\r
       fatal_error(this_pass, e_expression_ovfl);\r
     mark1:= mark1+1;\r
     stck[ top+mark2 ]:= stck[ mark1 ];\r
     IF stck[mark1].kind = cfunccall then nofunccall := nofunccall + 1;\r
     IF stck[mark1].kind = cendfunccall then nofunccall := nofunccall - 1;\r
     mark2:= mark2+1;\r
    until (stck[ mark1 ].kind=cVarParam) AND (NoFuncCall = 0);\r
    (* mark2 is # of moved elements *)\r
    (* move nodes of the last parameters as first parameters *)\r
    mark3 := mark1;\r
    mark1:= operand1_ix;\r
    repeat\r
     mark1:= mark1+1;\r
     mark3 := mark3 + 1;\r
     stck[ mark1 ]:= stck[ mark3 ];\r
    until  mark3 = (top - 1);\r
    (* move nodes of the first parameter as last parameter *)\r
    FOR mark1 := 1 TO Mark2 DO\r
      stck[mark3 + mark1 - mark2] := stck[top + mark1 - 1];\r
\r
  END;\r
{$ENDIF}\r
ELSE ;\r
END;\r
WITH e_stck, stck[ top ] DO\r
BEGIN\r
st_addr:= st_aux_addr;\r
operand1_ix:= stck[operand1_ix].former_fct;\r
stck[operand2_ix].former_fct:= operand1_ix;\r
\r
param_size_:= static_link_size+st_ptr^.st_paramsize;\r
if (st_ptr^.st_specs=st_local) and st_ptr^.st_local_near then\r
param_size_:= param_size_+local_return_appetite\r
else\r
param_size_:=param_size_+global_return_appetite;\r
\r
push_monadic_operator(i_code, cendproccall, 0);\r
\r
end_of_expression:= true;\r
\r
const_expr:= false;\r
if last_var_index<operand2_ix then\r
last_var_index:= operand2_ix;\r
IF (Computer = RC5000) THEN\r
begin\r
param_size_ := St_ptr^.st_paramSize;\r
help_addr := st_ptr^.listRef;\r
openrout := (St_Ptr^.St_Specs = St_Open);\r
IF st_ptr^.St_ParamSize > 8 THEN\r
  BEGIN\r
   st_retrieve(St_ptr^.ListRef, st_ptr);\r
   IF St_ptr^.St_Size > 4 THEN param_Size_ := param_Size_ - 8\r
   ELSE\r
     BEGIN\r
       st_retrieve(St_ptr^.ListRef, st_ptr);\r
       IF St_ptr^.St_Size > 4 THEN Param_Size_ := param_Size_ - 4;\r
     END;\r
  END;\r
while not equal_addr(help_Addr,st_stopaddr) do\r
  begin\r
    st_Retrieve(help_addr,St_ptr);\r
    help_addr := St_Ptr^.ListRef;\r
    if st_ptr^.St_kind = cvarparam then\r
      begin\r
        st_RetrieveType(St_Ptr^.TypeRef,St_Ptr);\r
        IF (St_ptr^.St_size = 4) OR OpenRout THEN\r
           Param_Size_ := Param_Size_ + 8;\r
      end;\r
  end;\r
st_retrieve(st_aux_addr, st_ptr); (* reestablish st_ptr *)\r
\r
END;\r
end; (* with stck[ top ] .. *)\r
\r
END; (* endproccall *)\r
\r
\r
cusub:\r
WITH e_stck.stck[ operand2_ix ] DO\r
IF (kind=csimpleconst) THEN (* - Fold - *)\r
BEGIN\r
IF (type_=cinteger) THEN\r
rtp86_iusub(ii_value)\r
ELSE\r
IF (type_=cword) THEN\r
ww_value:= rtp86_wsub(0, ww_value)\r
ELSE\r
IF (type_=cbyte) THEN\r
ww_value:= rtp86_bsub(0, ww_value)\r
ELSE\r
fatal_error(this_pass, e_expression_stck)\r
END\r
ELSE\r
begin\r
e_stck.stck[ e_stck.top ].overflow_chk:= overflow_check and (type_=cinteger);\r
push_monadic_operator(cusub, type_, size_);\r
end; (* cusub *)\r
\r
cnot:\r
WITH e_stck.stck[ operand2_ix ] DO\r
IF (kind=csimpleconst) THEN (* - Fold - *)\r
CASE type_ OF\r
\r
cword,\r
cinteger:   (* !!! hha *)\r
ww_value:= rtp86_wnot(ww_value);\r
\r
cbyte:\r
ww_value:= rtp86_bnot(ww_value);\r
\r
cboolean:\r
ww_value:= WORD(ww_value=0);\r
\r
(* OTHERWISE *) else\r
fatal_error(this_pass, e_expression_stck)\r
\r
END\r
ELSE\r
push_monadic_operator(cnot, type_, size_);\r
\r
ccompareset: compare_set:= true;\r
\r
ccomparestring: compare_string:= true;\r
\r
csetoperator: set_operator:= true;\r
\r
ceq:\r
IF fold THEN\r
WITH e_stck.stck[ operand1_ix ] DO\r
IF stdcode_to_address(cboolean, st_addr) THEN\r
BEGIN\r
\r
st_retrieve(st_addr, st_ptr);\r
\r
IF (type_=ctext) THEN\r
ELSE\r
\r
ww_value:= WORD(ww_value=e_stck.stck[ operand2_ix ].ww_value);\r
\r
st_addr:= st_ptr^.typeref;\r
\r
st_retrieve(st_addr, st_ptr);\r
\r
type_:= cboolean;\r
size_:= booleansize;\r
\r
pop_operand\r
\r
END\r
ELSE\r
\r
fatal_error(this_pass, e_std_code);\r
\r
cne:\r
IF fold THEN\r
WITH e_stck.stck[ operand1_ix ] DO\r
IF stdcode_to_address(cboolean, st_addr) THEN\r
BEGIN\r
\r
IF (type_=ctext) THEN\r
ELSE\r
\r
ww_value:= WORD(ww_value <> e_stck.stck[ operand2_ix ].ww_value);\r
\r
type_:= cboolean;\r
size_:= booleansize;\r
\r
pop_operand\r
\r
END\r
ELSE\r
\r
fatal_error(this_pass, e_std_code);\r
\r
clt:\r
IF fold THEN\r
WITH e_stck.stck[ operand1_ix ] DO\r
IF stdcode_to_address(cboolean, st_addr) THEN\r
BEGIN\r
\r
IF (type_=cinteger) THEN\r
ww_value:= WORD(ii_value < e_stck.stck[ operand2_ix ].ii_value)\r
ELSE\r
\r
IF (type_=ctext) THEN\r
ELSE\r
\r
ww_value:= WORD(ww_value < e_stck.stck[ operand2_ix ].ww_value);\r
\r
type_:= cboolean;\r
size_:= booleansize;\r
\r
pop_operand\r
\r
\r
END\r
ELSE\r
\r
fatal_error(this_pass, e_std_code);\r
\r
cle:\r
IF fold THEN\r
WITH e_stck.stck[ operand1_ix ] DO\r
IF stdcode_to_address(cboolean, st_addr) THEN\r
BEGIN\r
\r
IF (type_=cinteger) THEN\r
ww_value:= WORD(ii_value <= e_stck.stck[ operand2_ix ].ii_value)\r
ELSE\r
\r
IF (type_=ctext) THEN\r
ELSE\r
\r
ww_value:= WORD(ww_value <= e_stck.stck[ operand2_ix ].ww_value);\r
\r
type_:= cboolean;\r
size_:= booleansize;\r
\r
pop_operand\r
\r
END\r
ELSE\r
\r
fatal_error(this_pass, e_std_code);\r
\r
cgt:\r
IF fold THEN\r
WITH e_stck.stck[ operand1_ix ] DO\r
IF stdcode_to_address(cboolean, st_addr) THEN\r
BEGIN\r
\r
IF (type_=cinteger) THEN\r
ww_value:= WORD(ii_value > e_stck.stck[ operand2_ix ].ii_value)\r
ELSE\r
\r
IF (type_=ctext) THEN\r
ELSE\r
\r
ww_value:= WORD(ww_value > e_stck.stck[ operand2_ix ].ww_value);\r
\r
type_:= cboolean;\r
size_:= booleansize;\r
\r
pop_operand\r
\r
END\r
ELSE\r
\r
fatal_error(this_pass, e_std_code);\r
\r
cge:\r
IF fold THEN\r
WITH e_stck.stck[ operand1_ix ] DO\r
IF stdcode_to_address(cboolean, st_addr) THEN\r
BEGIN\r
\r
IF (type_=cinteger) THEN\r
ww_value:= WORD(e_stck.stck[ operand2_ix ].ii_value >= ii_value)\r
ELSE\r
\r
IF (type_=ctext) THEN\r
ELSE\r
\r
ww_value:= WORD(ww_value >= e_stck.stck[ operand2_ix ].ww_value);\r
\r
type_:= cboolean;\r
size_:= booleansize;\r
\r
pop_operand\r
\r
END\r
ELSE\r
\r
fatal_error(this_pass, e_std_code);\r
\r
cin:\r
if fold then\r
BEGIN  (* not implemented !!!!!!!!!!!!!!!! *)\r
push_operator(cin, cin, 0);\r
end;\r
\r
cadd:\r
IF fold THEN\r
BEGIN\r
WITH e_stck.stck[ operand1_ix ] DO\r
CASE result_type OF\r
\r
cinteger: \r
rtp86_iadd(ii_value, e_stck.stck[ operand2_ix ].ii_value);\r
\r
cword:\r
BEGIN\r
\r
IF (type_ <> result_type) THEN\r
BEGIN\r
\r
type_:= e_stck.stck[ operand2_ix ].type_;\r
st_addr:= e_stck.stck[ operand2_ix ].st_addr\r
\r
END;\r
\r
ww_value:= rtp86_wadd\r
(\r
ww_value,\r
e_stck.stck[ operand2_ix ].ww_value\r
)\r
\r
END;\r
\r
cbyte: \r
ww_value:= rtp86_badd\r
(\r
ww_value,\r
e_stck.stck[ operand2_ix ].ww_value\r
);\r
\r
(*OTHERWISE *) else\r
fatal_error(this_pass, e_expression_stck)\r
\r
end;\r
\r
pop_operand\r
\r
END\r
ELSE\r
\r
e_stck.stck[operand2_ix].overflow_chk:= overflow_check and (result_type=cinteger);\r
\r
csub:\r
IF fold THEN\r
BEGIN\r
\r
WITH e_stck.stck[ operand1_ix ] DO\r
CASE result_type OF\r
cinteger: \r
rtp86_isub(ii_value, e_stck.stck[ operand2_ix ].ii_value);\r
\r
cword:\r
BEGIN\r
\r
IF (type_ <> result_type) THEN\r
BEGIN\r
\r
type_:= e_stck.stck[ operand2_ix ].type_;\r
st_addr:= e_stck.stck[ operand2_ix ].st_addr\r
\r
END;\r
\r
ww_value:= rtp86_wsub(ww_value, e_stck.stck[ operand2_ix ].ww_value)\r
\r
END;\r
\r
cbyte: \r
ww_value:= rtp86_bsub(ww_value, e_stck.stck[ operand2_ix ].ww_value);\r
\r
(*OTHERWISE*) else\r
fatal_error(this_pass, e_expression_stck)\r
\r
end;\r
\r
pop_operand\r
\r
END\r
ELSE\r
\r
e_stck.stck[operand2_ix].overflow_chk:= overflow_check and (result_type=cinteger);\r
\r
cor:\r
IF fold THEN\r
BEGIN\r
\r
WITH e_stck.stck[ operand1_ix ] DO\r
CASE result_type OF\r
\r
cword,\r
cbyte,\r
cboolean,\r
cinteger:  (* hha *)\r
BEGIN\r
\r
IF (type_ <> result_type) THEN\r
BEGIN\r
\r
type_:= e_stck.stck[ operand2_ix ].type_;\r
st_addr:= e_stck.stck[ operand2_ix ].st_addr\r
\r
END;\r
\r
ww_value:= rtp86_wor\r
(\r
ww_value,\r
e_stck.stck[ operand2_ix ].ww_value\r
)\r
\r
END;\r
\r
(*OTHERWISE*) else\r
fatal_error(this_pass, e_expression_stck)\r
\r
end;\r
\r
pop_operand\r
\r
end;\r
\r
cxor:\r
IF fold THEN\r
BEGIN\r
\r
WITH e_stck.stck[ operand1_ix ] DO\r
CASE result_type OF\r
\r
cword,\r
cbyte,\r
cboolean,\r
cinteger:  (* hha *)\r
BEGIN\r
\r
IF (type_ <> result_type) THEN\r
BEGIN\r
\r
type_:= e_stck.stck[ operand2_ix ].type_;\r
st_addr:= e_stck.stck[ operand2_ix ].st_addr\r
\r
END;\r
\r
ww_value:= rtp86_wxor\r
(\r
ww_value,\r
e_stck.stck[ operand2_ix ].ww_value\r
)\r
\r
END;\r
\r
(*OTHERWISE*) else\r
fatal_error(this_pass, e_expression_stck)\r
\r
end;\r
\r
pop_operand\r
\r
end;\r
\r
cmul:\r
IF fold THEN\r
BEGIN\r
\r
WITH e_stck.stck[ operand1_ix ] DO\r
CASE result_type OF\r
\r
cinteger: \r
rtp86_imul(ii_value, e_stck.stck[ operand2_ix ].ii_value);\r
\r
cword:\r
BEGIN\r
\r
IF (type_ <> result_type) THEN\r
BEGIN\r
\r
type_:= e_stck.stck[ operand2_ix ].type_;\r
st_addr:= e_stck.stck[ operand2_ix ].st_addr\r
\r
END;\r
\r
ww_value:= rtp86_wmul\r
(\r
ww_value,\r
e_stck.stck[ operand2_ix ].ww_value\r
)\r
\r
END;\r
\r
cbyte: \r
ww_value:= rtp86_bmul\r
(\r
ww_value,\r
e_stck.stck[ operand2_ix ].ww_value\r
);\r
\r
(*OTHERWISE*) else\r
fatal_error(this_pass, e_expression_stck)\r
end;\r
\r
pop_operand\r
\r
\r
END\r
ELSE\r
\r
e_stck.stck[operand2_ix].overflow_chk:= overflow_check and (result_type=cinteger);\r
\r
cdiv:\r
IF fold THEN\r
BEGIN\r
\r
WITH e_stck.stck[ operand1_ix ] DO\r
CASE result_type OF\r
\r
cinteger: \r
rtp86_idiv(ii_value, e_stck.stck[ operand2_ix ].ii_value);\r
\r
cword:\r
BEGIN\r
\r
IF (type_ <> result_type) THEN\r
BEGIN\r
\r
type_:= e_stck.stck[ operand2_ix ].type_;\r
st_addr:= e_stck.stck[ operand2_ix ].st_addr\r
\r
END;\r
\r
ww_value:= rtp86_wdiv\r
(\r
ww_value,\r
e_stck.stck[ operand2_ix ].ww_value\r
)\r
\r
END;\r
\r
cbyte: \r
ww_value:= rtp86_wdiv\r
(\r
ww_value,\r
e_stck.stck[ operand2_ix ].ww_value\r
);\r
\r
(*OTHERWISE*) else\r
fatal_error(this_pass, e_expression_stck)\r
\r
end;\r
\r
pop_operand\r
\r
end;\r
\r
cmod:\r
IF fold THEN\r
BEGIN\r
\r
WITH e_stck.stck[ operand1_ix ] DO\r
CASE result_type OF\r
\r
cinteger: \r
rtp86_imod(ii_value, e_stck.stck[ operand2_ix ].ii_value);\r
\r
cword:\r
BEGIN\r
\r
IF (type_ <> result_type) THEN\r
BEGIN\r
\r
type_:= e_stck.stck[ operand2_ix ].type_;\r
st_addr:= e_stck.stck[ operand2_ix ].st_addr\r
\r
END;\r
\r
ww_value:= rtp86_wmod\r
(\r
ww_value,\r
e_stck.stck[ operand2_ix ].ww_value\r
)\r
\r
END;\r
\r
cbyte: \r
ww_value:= rtp86_wmod\r
(\r
ww_value,\r
e_stck.stck[ operand2_ix ].ww_value\r
);\r
\r
(*OTHERWISE*) else\r
fatal_error(this_pass, e_expression_stck)\r
\r
end;\r
\r
pop_operand\r
\r
end;\r
\r
cand:\r
IF fold THEN\r
BEGIN\r
\r
WITH e_stck.stck[ operand1_ix ] DO\r
CASE result_type OF\r
\r
cword,\r
cbyte,\r
cboolean,\r
cinteger:  (* hha *)\r
BEGIN\r
\r
IF (type_ <> result_type) THEN\r
BEGIN\r
\r
type_:= e_stck.stck[ operand2_ix ].type_;\r
st_addr:= e_stck.stck[ operand2_ix ].st_addr\r
\r
END;\r
\r
ww_value:= rtp86_wand\r
(\r
ww_value,\r
e_stck.stck[ operand2_ix ].ww_value\r
)\r
\r
END;\r
\r
(*OTHERWISE*) ELSE\r
fatal_error(this_pass, e_expression_stck)\r
\r
end;\r
\r
pop_operand\r
\r
end;\r
\r
cshift:\r
IF fold THEN\r
BEGIN\r
\r
WITH e_stck.stck[ operand1_ix ] DO\r
CASE result_type OF\r
\r
cword,\r
cinteger: (* hha *)\r
ww_value:= rtp86_wshift(ww_value, e_stck.stck[ operand2_ix ].ii_value);\r
\r
cbyte:\r
ww_value:= rtp86_bshift(ww_value, e_stck.stck[ operand2_ix ].ii_value);\r
\r
(*OTHERWISE*) else\r
fatal_error(this_pass, e_expression_stck)\r
\r
end;\r
\r
pop_operand\r
\r
end;\r
\r
\r
cskipparam:\r
push_operand(i_code, cnocode, address_size);\r
\r
ccheckparam:\r
begin\r
   Store_Code(ccheckparam);\r
   copy_symbol;\r
   copy_symbol;\r
end;\r
cendexchange,\r
cendexchangestring:\r
  BEGIN\r
  if monadic(e_stck.stck[operand2_ix].kind) then\r
   begin\r
    while monadic(e_stck.stck[operand1_ix].kind) do\r
       operand1_ix:= e_stck.stck[operand1_ix].former_fct;\r
\r
    operand1_ix:= e_stck.stck[operand1_ix].former_fct;\r
   end;\r
    IF e_stck.stck[ operand1_ix ].precode <> cpacked then\r
       e_stck.stck[ operand1_ix ].precode:= cpreexchange;\r
    end_of_expression:= true;\r
  END;\r
cendconstdecl,\r
cendtypedecl,\r
cendsubrange, (* - Rule010, Rule018 - *)\r
cendvar,\r
cendshared,\r
cinit,\r
cendinit,\r
cwithvar,\r
clockvar,\r
cendassign,\r
cendassignset,\r
cendassignstring,\r
\r
ccaseexpr,  (* - Rule010 - *)\r
ccaselabel,  (* - Rule010 - *)\r
ccaselabelrange,(* - Rule010 - *)\r
ccaselist,  (* - Rule010 - *)\r
cotherwise,  (* - Rule010 - *)\r
cendcase,  (* - Rule010 - *)\r
\r
cifexpr,  (* - Rule010 - *)\r
cwhileexpr,  (* - Rule010 - *)\r
cendrepeat:   (* - Rule010 - *)\r
\r
end_of_expression:= true;\r
\r
\r
(*OTHERWISE*) ELSE\r
pass3_error(e_token_066, word(i_code))\r
\r
end;\r
\r
\r
UNTIL end_of_expression;\r
\r
e_stck.last_fct:= operand2_ix;\r
\r
\r
end; (* - PROCEDURE load_expression - *)\r
\r
\r
\r
PROCEDURE dump_expression\r
(           (* Call  Return *)\r
VAR\r
e_stck: expr_stack_descr; (*      *)\r
VAR\r
max_eval_appetite: WORD;\r
current_level,\r
current_offset: word\r
);\r
\r
CONST\r
\r
cnst_used    = TRUE;\r
\r
VAR\r
st_ptr: st_elemptr;\r
\r
func_result_address,\r
rep_offset,\r
start_temp,\r
evaluation_appetite: WORD;\r
\r
operand1_ix    ,\r
operand2_ix    ,\r
\r
stck_ix: expr_stack_range;\r
\r
step:  integer;\r
\r
helpAddr : St_Address;\r
OpenRout : Boolean;\r
\r
PROCEDURE inc_appetite\r
(\r
size_: WORD\r
);\r
\r
BEGIN\r
\r
IF (Size_ MOD WordSize) <> 0 THEN\r
if wadd_ovflw(evaluation_appetite,wordsize - (size_ MOD WordSize)) THEN\r
errormsg(this_pass, e_eval_appetite);\r
\r
IF wadd_ovflw(evaluation_appetite, size_) THEN\r
errormsg(this_pass, e_eval_appetite);\r
\r
IF (max_eval_appetite < evaluation_appetite) THEN\r
max_eval_appetite:=  evaluation_appetite\r
\r
end; (* - PROCEDURE inc_appetite - *)\r
\r
PROCEDURE dec_appetite\r
(\r
size_: WORD\r
);\r
\r
BEGIN\r
\r
\r
IF wsub_ovflw(evaluation_appetite, size_) THEN\r
errormsg(this_pass, e_expression_stck);\r
\r
\r
IF (Size_ MOD WordSize) <> 0 THEN\r
if wsub_ovflw(evaluation_appetite,wordsize - (size_ MOD WordSize)) THEN\r
errormsg(this_pass, e_expression_stck)\r
\r
end; (* - PROCEDURE dec_appetite - *)\r
\r
BEGIN\r
\r
\r
\r
operand1_ix:= 1;\r
operand2_ix:= 1;\r
\r
with e_stck do\r
if max_temp_size>0 then\r
begin\r
if current_level=program_level then\r
address_gf(current_offset, start_temp, max_temp_size)\r
else\r
address_lf(current_offset, start_temp, max_temp_size);\r
\r
    IF (current_level = program_level) OR (Computer = RC3502) THEN\r
    BEGIN\r
       IF (max_block_offset < Current_offset) THEN\r
          max_block_offset := Current_offset;\r
    END\r
    ELSE\r
      BEGIN\r
       IF (Current_offset < max_block_offset) THEN\r
         max_block_offset := Current_offset;\r
      END;\r
(*evaluation_appetite:= max_temp_size;*)\r
end;\r
\r
evaluation_appetite:= 0;\r
rep_offset:= 0;\r
\r
FOR stck_ix:= 1 TO (e_stck.top - 1)DO\r
WITH e_stck.stck[ stck_ix ] DO\r
begin\r
\r
CASE kind OF\r
csimpleconst:\r
BEGIN\r
\r
operand1_ix:= operand2_ix;\r
operand2_ix:= stck_ix;\r
\r
store_code_1(csimpleconst, ww_value);\r
store_symbol(st_addr);\r
\r
if indvar_code then\r
inc_appetite(size_)\r
else\r
inc_appetite(address_size); (* constant INSPECT parameter *)\r
end;\r
\r
cbeginstruc,\r
cstrucconst:\r
BEGIN\r
\r
\r
if kind=cstrucconst then (* outermost structure *)\r
BEGIN\r
store_code_symbol(cstrucconst, st_addr);\r
IF Computer = RC5000 THEN\r
  BEGIN\r
    St_Retrieve(st_Addr,St_Ptr);\r
    St_Ptr^.Var_Offset := start_temp + St_Ptr^.Var_Offset;\r
  END;\r
END;\r
end; (* beginstruc, strucconst *)\r
\r
\r
cstrucelem:  begin\r
\r
if dump_setrep then\r
begin\r
store_code_1(csetrep, rep_count_offset+start_temp);\r
rep_offset:= rep_count_offset;\r
end;\r
store_code_symbol(cstrucelem, st_addr);\r
operand2_ix:= stck_ix;\r
end; (* strucelem *)\r
\r
\r
cendassignstring,\r
cendassignset,\r
cendassign:  begin\r
if struc_range_chk then\r
BEGIN\r
store_code_symbol(crangecheck, st_addr);\r
IF Computer = RC3502 THEN\r
  BEGIN\r
    st_Retrievetype(st_Addr,st_Ptr);\r
    IF (st_Ptr^.Subr_Low <> 0) AND\r
       (st_Ptr^.Subr_Addr.AddrType_Mode = ConstAddr) THEN\r
     BEGIN\r
       st_get(st_Ptr^.st_Family_ref,st_Ptr);\r
       st_Ptr^.used := true;\r
     END;\r
  END;\r
END;\r
if rep_struc then\r
store_code_1(csaverep, rep_offset+start_temp);\r
if type_<>cnocode then\r
store_code(kind);\r
if rep_struc then\r
begin\r
store_code(crepstruc);\r
dec_appetite(integersize); (* pop repetition counter *)\r
operand1_ix:= former_fct;\r
end;\r
\r
IF (Computer= RC5000) AND (Kind = cendAssignSet) THEN\r
  BEGIN\r
    inc_Appetite(12);\r
    dec_Appetite(12);\r
  END;\r
dec_appetite(e_stck.stck[operand2_ix].size_); (* pop value *)\r
operand2_ix:= stck_ix;\r
end; (* cendassign, cendassignstring, cendassignset *)\r
\r
\r
cconstchecknumber,\r
cchecknumber:  begin\r
\r
if kind=cconstchecknumber then\r
store_code(cconstchecknumber)\r
else\r
store_code_symbol(cchecknumber, st_addr);\r
store_arg_1(rep_offset+start_temp);\r
store_arg_1(size_);\r
operand2_ix:= stck_ix;\r
end; (* constchecnumber, checknumber *)\r
\r
\r
cendstruc:  begin\r
\r
if type_=cendstruc then (* outermost structure *)\r
store_code(cendstruc);\r
inc_appetite(size_); (* push the structure *)\r
rep_offset:= saved_rep_offset;\r
operand2_ix:= stck_ix;\r
operand1_ix:= former_fct;\r
end; (* endstruc *)\r
\r
\r
ccaddr:  BEGIN\r
\r
operand1_ix:= operand2_ix;\r
operand2_ix:= stck_ix;\r
\r
st_get(st_strucc_symbol, st_ptr);\r
st_ptr^.used:= cnst_used;\r
\r
store_code_symbol(ccaddr, st_strucc_symbol);\r
\r
inc_appetite(address_size);\r
if indvar_code then\r
begin\r
dec_appetite(address_size);\r
store_code(cindvar);\r
inc_appetite(size_);\r
end;\r
end; (* ccaddr *)\r
\r
\r
caddr:\r
BEGIN\r
\r
operand1_ix:= operand2_ix;\r
operand2_ix:= stck_ix;\r
\r
store_code_symbol(caddr, st_addr);\r
\r
inc_appetite(address_size);\r
if indvar_code then\r
begin\r
dec_appetite(address_size);\r
inc_appetite(size_);\r
store_code(cindvar);\r
end;\r
END; (* caddr *)\r
\r
caaddr: \r
BEGIN\r
\r
operand1_ix:= operand2_ix;\r
operand2_ix:= stck_ix;\r
\r
store_code_1(caaddr, ww_value);\r
\r
inc_appetite(address_size);\r
if indvar_code then\r
begin\r
dec_appetite(address_size);\r
inc_appetite(size_);\r
store_code(cindvar);\r
end;\r
END; (* caaddr *)\r
\r
\r
cnull:\r
BEGIN\r
\r
operand1_ix:= operand2_ix;\r
operand2_ix:= stck_ix;\r
store_code_1(cnull, size_);\r
inc_appetite(size_);\r
END; (* cnull *)\r
\r
\r
cskipparam:\r
BEGIN\r
\r
operand1_ix:= operand2_ix;\r
operand2_ix:= stck_ix;\r
\r
store_code(cskipparam);\r
\r
inc_appetite(address_size);\r
END; (* cskipparam *)\r
\r
\r
cfield:\r
BEGIN\r
\r
store_code_symbol(cfield, st_addr);\r
IF (Computer = RC5000) AND\r
   (PreCode = cPacked) THEN\r
  BEGIN\r
    inc_Appetite(16);\r
    dec_Appetite(16);\r
  END;\r
if indvar_code then\r
begin\r
store_code(cindvar);\r
dec_appetite(address_size);\r
inc_appetite(size_);\r
end;\r
operand1_ix:= former_fct;\r
operand2_ix:= stck_ix;\r
END; (* field *)\r
\r
\r
ctypeselect:\r
BEGIN\r
\r
store_code_symbol(ctypeselect, st_addr);\r
dec_appetite(address_size);\r
inc_appetite(size_);\r
operand1_ix:= former_fct;\r
operand2_ix:= stck_ix;\r
END; (* tyepselect *)\r
\r
\r
csetlist: begin\r
operand1_ix:= operand2_ix;\r
operand2_ix:= stck_ix;\r
\r
store_code(csetlist);\r
END; (* setlist *)\r
\r
\r
cs_element,\r
cm_element:\r
BEGIN\r
(* !!!!!!!!!!!!\r
if range_chk then\r
store_code_symbol(crangecheck, st_addr);\r
*)\r
store_code(kind);\r
operand2_ix:= stck_ix;\r
if kind= cs_element then\r
inc_appetite(integersize); (* the element will be pushed as a range *)\r
END; (* s_element and m_element *)\r
\r
cendsetlist:\r
BEGIN\r
operand2_ix:= stck_ix;\r
operand1_ix:= former_fct;\r
\r
dec_appetite(set_elem_count*2*integersize); (* pop the element ranges *)\r
(*inc_appetite(address_size);\r
size_:= address_size;*)\r
inc_appetite(size_);\r
IF Computer = RC5000 THEN\r
BEGIN\r
  inc_appetite(size_);\r
  dec_appetite(size_);\r
END;\r
store_code_1(cendsetlist, set_elem_count);\r
END; (* end set list *)\r
\r
cprogramcall:\r
BEGIN\r
IF Computer = RC3502 THEN\r
BEGIN\r
st_declaration(cvar, Anonymousname, Helpaddr, st_ptr);\r
st_ptr^.var_level:= current_level;\r
st_ptr^.st_size:= 8; (* mark *)\r
st_ptr^.TypeRef := st_Addr;\r
address_gf(Current_offset,st_ptr^.var_offset, 8);\r
\r
IF (max_block_offset < Current_offset) THEN\r
  max_block_offset := Current_offset;\r
\r
St_Addr := HelpAddr;\r
END;\r
store_code_symbol(cprogramcall, st_addr);\r
(*??dec_appetite(e_stck.stck[ operand1_ix ].size_);\r
  inc_appetite(size_); (* address parameter *)\r
inc_appetite(wordsize * 2);\r
operand1_ix:= former_fct;\r
operand2_ix:= stck_ix;\r
END;\r
\r
\r
cproccall,\r
cfunccall:\r
BEGIN\r
\r
operand1_ix:= operand2_ix;\r
operand2_ix:= stck_ix;\r
\r
inc_appetite(size_);\r
\r
IF (computer = rc3502) AND (Kind = cfunccall) THEN\r
BEGIN\r
st_retrieve(st_addr, st_ptr);\r
openrout :=  st_ptr^.st_specs = st_Open;\r
st_retrievetype(st_ptr^.Typeref, st_ptr);\r
\r
IF Not simpelFuncRes(St_Ptr)  then\r
begin\r
if current_level=program_level then\r
address_gf(current_offset, func_result_address, st_Ptr^.st_Size)\r
else address_lf(current_offset, func_result_address, st_ptr^.st_Size);\r
\r
IF (max_block_offset < Current_offset) THEN\r
  max_block_offset := Current_offset;\r
\r
store_code_1(kind,0);\r
store_code_1(caaddr, func_result_address);\r
\r
end\r
ELSE\r
 BEGIN\r
  IF Not OpenRout THEN\r
  Store_code_1(CFuncCall,St_Ptr^.St_size);\r
 END;\r
END\r
ELSE\r
 store_code(kind);\r
\r
END; (* funccall, proccall *)\r
\r
\r
cindex:\r
begin\r
if index_chk then\r
store_code_symbol(cindexcheck, index_type_symbol);\r
store_code(cindex);\r
IF (Computer = RC5000) AND\r
   (PreCode = cPacked) THEN\r
  BEGIN\r
    inc_Appetite(20);\r
    dec_Appetite(20);\r
  END;\r
dec_appetite(e_stck.stck[operand2_ix].size_); (* expression size *)\r
if indvar_code then\r
begin\r
store_code(cindvar);\r
dec_appetite(address_size);\r
inc_appetite(size_);\r
end;\r
operand1_ix:= former_fct;\r
operand2_ix:= stck_ix;\r
end; (* index *)\r
\r
\r
cvalueparam,\r
csetvalueparam,\r
cvarparam,\r
cinspectparam,\r
cshared, (* shared param of a program *)\r
csharedparam:\r
BEGIN\r
if range_chk then\r
BEGIN\r
store_code_symbol(crangecheck, st_addr);\r
IF Computer = RC3502 THEN\r
  BEGIN\r
    st_Retrievetype(st_Addr,st_Ptr);\r
    IF (st_Ptr^.Subr_Low <> 0) AND\r
       (st_Ptr^.Subr_Addr.AddrType_Mode = ConstAddr) THEN\r
    BEGIN\r
      st_get(st_Ptr^.st_Family_Ref,st_Ptr);\r
      st_Ptr^.used := true;\r
    END;\r
  END;\r
END;\r
store_code(kind);\r
if (kind=csetvalueparam)  then\r
begin\r
  store_symbol(st_addr); (* formal set type *)\r
  if computer = RC5000 then dec_appetite(40);\r
end;\r
operand2_ix:= stck_ix;\r
if kind=cshared then (* pop address and push shared descriptor *)\r
inc_appetite(gf_shared_param_size-address_size);\r
if family_type then\r
begin\r
store_code_symbol(cfamilytype, param_type_symbol);\r
\r
st_Retrieve(param_type_symbol,st_Ptr);\r
IF (st_Ptr^.type_Address.AddrType_Mode = ConstAddr) THEN\r
  BEGIN\r
    st_get(st_Ptr^.type_label,st_Ptr);\r
    st_Ptr^.used := true;\r
  END;\r
inc_appetite(address_size);\r
end;\r
END; (* params *)\r
\r
\r
ctypeparam:  BEGIN\r
\r
store_code_symbol(ctypeparam, st_addr);\r
operand2_ix:= stck_ix;\r
END; (* params *)\r
\r
\r
cendprogramcall,\r
cendproccall,\r
cendfunccall:\r
BEGIN\r
if kind = cendprogramcall THEN dec_appetite(wordsize * 2);\r
operand2_ix:= stck_ix;\r
operand1_ix:= former_fct;\r
\r
dec_appetite(param_size_ ); (* param size *)\r
if kind=cendfunccall then\r
begin\r
IF computer <> rc3502 THEN\r
BEGIN\r
st_retrieve(st_addr, st_ptr);\r
if (size_>4) or ((Computer = RC5000) AND (Not simpelFuncRes(St_Ptr) ) ) then\r
begin\r
if current_level=program_level then\r
address_gf(current_offset, func_result_address, size_)\r
else address_lf(current_offset, func_result_address, size_);\r
\r
    IF (current_level = program_level) THEN\r
    BEGIN\r
       IF (max_block_offset < Current_offset) THEN\r
          max_block_offset := Current_offset;\r
    END\r
    ELSE\r
      BEGIN\r
       IF (Current_offset < max_block_offset) THEN\r
         max_block_offset := Current_offset;\r
      END;\r
\r
store_code_1(caaddr, func_result_address);\r
\r
end;\r
END;\r
inc_appetite(size_);\r
end;\r
store_code_symbol(kind, st_addr);\r
\r
END; (* end call *)\r
\r
cusub,\r
cnot:\r
BEGIN\r
\r
store_code(kind);\r
operand2_ix:= stck_ix;\r
if kind=cusub then\r
if overflow_chk then\r
store_code(coverflowcheck);\r
END; (* monadic *)\r
\r
\r
cuparrow:\r
BEGIN\r
\r
store_code(kind);\r
if indvar_code then\r
begin\r
store_code(cindvar);\r
dec_appetite(address_size);\r
inc_appetite(size_);\r
end;\r
operand1_ix:= former_fct;\r
operand2_ix:= stck_ix;\r
\r
END; (* uparrow *)\r
\r
\r
ceq,\r
cne,\r
clt,\r
cle,\r
cgt,\r
cge,\r
cin,\r
cadd,\r
csub,\r
cor,\r
cxor,\r
cmul,\r
cdiv,\r
cmod,\r
cand,\r
cshift:\r
BEGIN\r
\r
if comp_set and ((kind=ceq) or (kind=cne) or (kind=cle) or (kind=cge)) then\r
store_code(ccompareset)\r
else\r
if comp_string and ((kind=ceq) or (kind=cne) or (kind=clt) or (kind=cgt) or (kind=cle) or (kind=cge)) then\r
store_code(ccomparestring)\r
else\r
if set_operation and ((kind=cadd) or (kind=csub) or (kind=cmul)) then\r
store_code(csetoperator);\r
IF (Computer = RC5000) AND (set_operation OR comp_set) THEN\r
  BEGIN\r
    inc_appetite(16);\r
    dec_appetite(16);\r
  END;\r
\r
store_code(kind);\r
\r
dec_appetite(e_stck.stck[ operand1_ix ].size_);\r
dec_appetite(e_stck.stck[ operand2_ix ].size_);\r
\r
operand2_ix:= stck_ix;\r
operand1_ix:= former_fct;\r
\r
inc_appetite(size_);\r
if (kind=cadd) or (kind=csub) or (kind=cmul) then\r
if overflow_chk then\r
store_code(coverflowcheck);\r
\r
END; (* dyadic operators *)\r
\r
cnocode:\r
;\r
\r
\r
(*OTHERWISE*) else\r
fatal_error(this_pass, e_expression_stck)\r
\r
END;\r
if (precode<>cnocode) and (precode<>cpacked) then\r
BEGIN\r
  store_code(precode);\r
END;\r
IF Computer = RC3502 then\r
if (prestr = cprestring) then\r
BEGIN\r
  store_code(cprestring);\r
END;\r
\r
for step:= 1 to prebool do\r
store_code(cprebool);\r
\r
end; (* with .... *)\r
\r
end; (* - PROCEDURE dump_expression - *)\r
\r
PROCEDURE skip_expression\r
(\r
VAR\r
e_stck: expr_stack_descr\r
);\r
\r
VAR\r
stck_ix: expr_stack_range;\r
\r
BEGIN\r
(*\r
FOR stck_ix:= 1 TO (e_stck.top - 1) DO\r
WITH e_stck.stck[ stck_ix ] DO\r
*)\r
end; (* - PROCEDURE skip_expression - *)\r
«eof»