⟦e2989caed⟧

TextFile

{$O+,F+}\r
unit  rule066;\r
interface\r
uses pscplm,sthunit,sthcom,sthp34,mpaunit,rtp86mpa,p3cmmn,rule077,\r
     rule078,p3math,p3addr,p3rw;\r
\r
\r
PROCEDURE load_expression\r
(\r
VAR\r
i_code: codes;\r
VAR\r
e_stck: expr_stack_descr;\r
current_level: word;\r
var current_offset: word\r
);\r
\r
PROCEDURE dump_expression\r
(\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
PROCEDURE skip_expression\r
(\r
VAR\r
e_stck: expr_stack_descr\r
);\r
\r
\r
\r
VAR Max_Block_Offset : Word;\r
Implementation\r
uses rule018;\r
(* ------------------------------------------------------------------------\r
Pass2Code:  66\r
expression::= <simple expression>\r
<!<simple expression><relational operator>>\r
ENDEXPRESSION\r
simple expression::= <term><!USUB><!<add term>>\r
add term::= <add term>\r
!<term><addition operator>\r
term::= <factor><!<mult factor>>\r
mult factor::= <mult factor>\r
!<factor><multiplication operator>\r
factor::= <unsigned constant>\r
!<setlist>\r
!<variable>ENDVARIABLE\r
!<variable><struc value denotation>\r
!<expression>\r
!<factor>NOT\r
!<function call>\r
relational operator::= EQ!NE!LT!LE!GT!GE!IN\r
addition operator::= ADD!SUB!OR!XOR\r
multiplication operator::= MUL!DIV!MOD!AND!SHIFT\r
\r
Pass3Code:  66\r
expression::=\r
\r
Symbol Table: \r
-.\r
\r
===========================================================================\r
\r
Error Messages and Warnings:\r
e_expression_ovfl\r
e_eval_appetite\r
e_index_expression\r
e_string_size\r
e_char_value\r
e_real_not_impl\r
e_expression_stck\r
e_std_code\r
e_token\r
-.\r
External Dependencies: \r
access_check  (defined in PASS3CMMN.INC)\r
range_check (defined in PASS3CMMN.INC)\r
index_check (defined in PASS3CMMN.INC)\r
overflow_check  (defined in PASS3CMMN.INC)\r
rule_test_set  (defined in PASS3CMMN.INC)\r
-.\r
External Effects:\r
linenumber (defined in RTP86MPA.EXT)\r
elementnumber  (defined in RTP86MPA.EXT)\r
plm_string (defined in PASS3CMMN.INC)\r
rule_test_set  (defined in PASS3CMMN.INC)\r
-.\r
Stack Appetite:\r
-.\r
Comments:\r
Procedure calls are pushed onto the expression stack.\r
\r
The value of a simple constant is held in the Symbol Table and in\r
the Expression Stack by a field of WORD type, regardless the type of\r
the constant. Conversion to INTEGER representation is done through\r
a CASE variant record.\r
\r
The field 'prog_createsize' in the Symbol Table node of a routine\r
declaration is (mis)used to identify the routine as a predefined\r
routine, that Pass3 must take special action upon.\r
-.\r
------------------------------------------------------------------------ *)\r
\r
\r
\r
PROCEDURE dump_structured_constant(VAR e_stck:  expr_stack_descr; start_ix:  expr_stack_range);\r
var\r
(*#BEGINTEST\r
rule_test:  BOOLEAN;\r
(*ENDTEST#*)\r
st_ptr:  st_elemptr;\r
label_addr:  st_address;\r
stck_ix:  expr_stack_range;\r
rep, no_of_repetitions,\r
repeated_arr_elems:  integer;\r
packed_dump:  boolean;\r
packed_dump3502 : boolean;\r
packed_arr_elems: longint;\r
elem_size, start_offset, elem_offset, packed_bit_offset: word;\r
byte_value: byte;\r
shift_count: integer;\r
step: word;\r
wd_Value : LongInt;\r
helpinteger : integer;\r
bitsinfirstbyte,bitsinlastbyte : integer;\r
DoAllignArray : boolean;\r
begin\r
(*#BEGINTEST\r
rule_test:= cendstruc IN rule_test_set;\r
\r
IF rule_test THEN\r
begin\r
WRITELN\r
(\r
testoutput, ' Begin Dump structured constant',\r
' top=',\r
e_stck.top:  6,\r
' first=',\r
start_ix:  6\r
);\r
\r
writeln(testoutput, 'stck_ix  kind  type_ former_fct');\r
end;\r
(*ENDTEST#*)\r
\r
repeated_arr_elems:= 0;\r
packed_dump:= false;\r
packed_arr_elems:= 0;\r
start_offset:= 0;\r
with e_stck do\r
begin\r
st_retrieve(stck[ start_ix ].st_addr, st_ptr); (* type of structure *)\r
stck[ start_ix ].size_:= st_ptr^.st_size;\r
push_struc_value(st_ptr^.st_size, label_addr, stck[ start_ix ].st_addr, false (* unsued *));\r
stck[ start_ix ].st_strucc_symbol:= sca_current_frgmnt;\r
for stck_ix:= start_ix+1 to top-1 do\r
with stck[ stck_ix ] do\r
begin\r
(*#BEGINTEST\r
if rule_test then\r
writeln(testoutput, stck_ix: 6, WORD(kind): 6, WORD(type_): 6, former_fct: 6);\r
(*ENDTEST#*)\r
\r
case kind of\r
cstrucelem:  begin\r
doallignArray := false;\r
if type_=crecordtype then\r
begin\r
st_retrieve(st_addr, st_ptr); (* field node *)\r
packed_dump:= st_ptr^.bit_size<>0;\r
if packed_dump then\r
begin\r
packed_dump3502 := (packed3502 = st_ptr^.st_packedFiel);\r
elem_size:= st_ptr^.bit_size;\r
elem_offset:= st_ptr^.field_offset+start_offset;\r
packed_bit_offset:= st_ptr^.bit_offset;\r
end\r
ELSE\r
 BEGIN\r
  byte_value := St_ptr^.Field_offset - (sca_total_bytes - start_offset);\r
  helpinteger := 32;\r
  for step := 1 to byte_value do\r
     sca_fill(1, ptr_sca_max_string(@helpinteger))\r
 END;\r
end\r
else\r
begin\r
IF Computer = RC3502 THEN\r
  BEGIN\r
    st_retrieve(st_addr, st_ptr); (* arraytype node *)\r
    doallignarray := (st_ptr^.Spec_Struct * Shieldtype35) <> [];\r
  END;\r
st_retrievetype(st_addr, st_ptr); (* arraytype node *)\r
packed_dump:= st_ptr^.st_packed <> notpacked;\r
if packed_dump then\r
begin\r
packed_dump3502 := (packed3502 = st_ptr^.st_packed);\r
elem_size:= st_ptr^.ebit_size;\r
packed_array_offset(0, packed_arr_elems, elem_size div 8 + 1, elem_size,\r
elem_offset, packed_bit_offset);\r
end;\r
end;\r
\r
if not packed_dump then\r
begin\r
st_retrieve(st_ptr^.typeref, st_ptr); (* ctype node of element type *)\r
elem_size:= st_ptr^.st_size;\r
end;\r
end; (* cstrucelem *)\r
\r
csimpleconst,\r
cnull,\r
ccaddr:  ;\r
\r
cbeginstruc,\r
cstrucconst: begin\r
(* save repeated arr elems in endstruc's former fct *)\r
stck[ former_fct ].size_:= repeated_arr_elems;\r
repeated_arr_elems:= 0;\r
packed_arr_elems:= 0;\r
start_offset:= sca_total_bytes; (* current offset in structure *)\r
end; (* beginstruc, strucconst *)\r
\r
\r
cendstruc: (* reestablish repeated arr elems *)\r
repeated_arr_elems:= stck[ former_fct ].size_;\r
\r
\r
cendassign,\r
cendassignset,\r
cendassignstring:  begin\r
if rep_struc then\r
begin\r
no_of_repetitions:= stck[ stck[ stck_ix-1 ].former_fct ].ii_value;\r
repeated_arr_elems:= repeated_arr_elems+no_of_repetitions;\r
end\r
else\r
no_of_repetitions:= 1;\r
with stck[ stck_ix-1 ] do\r
begin\r
if kind=cendstruc then\r
no_of_repetitions:= no_of_repetitions-1; (* first element have been dumped *)\r
\r
IF (Computer = RC3502) AND DoallignArray AND odd(sca_total_bytes)\r
 THEN  sca_fill(1, ptr_sca_max_string(@helpinteger));\r
\r
for rep:= 1 to no_of_repetitions do\r
BEGIN\r
case kind of\r
cnull,\r
csimpleconst:  if packed_dump then\r
begin\r
(*#BEGINTEST\r
if  rule_test then\r
writeln(testoutput, ' packed dump:          ',\r
packed_bit_offset: 6, sca_total_bytes: 6, elem_size: 6, w_value: 6);\r
(*ENDTEST#*)\r
if ww_value>maxint then\r
ww_value:= rtp86_wshift(rtp86_wshift(ww_value, 16-elem_size),\r
rtp86_imap(elem_size)-16);\r
IF not packed_dump3502(*Computer <> RC3502*) THEN\r
BEGIN\r
byte_value:= rtp86_wshift(ww_value, packed_bit_offset) mod 256;\r
if packed_bit_offset=0 then\r
sca_fill(1, ptr_sca_max_string(@byte_value))\r
else\r
sca_put_byte(sca_total_bytes (* current byte *), byte_value);\r
if packed_bit_offset+elem_size>8 then\r
begin\r
byte_value:= rtp86_wshift(ww_value, packed_bit_offset) div 256;\r
sca_fill(1, ptr_sca_max_string(@byte_value));\r
end;\r
END\r
ELSE\r
BEGIN\r
IF packed_bit_offset + elem_Size > 8 THEN\r
  BEGIN\r
    BitsInLastByte := elem_size + packed_bit_offset - 8;\r
    BitsInFirstByte := 8 -packed_bit_offset;\r
    byte_value:= rtp86_wshift(ww_value, -BitsInLastByte);\r
    helpInteger:=  ww_value AND ( (1 SHL BitsInLastByte) -1);\r
\r
  END\r
 ELSE\r
  BEGIN\r
   BitsInLastByte := 0;\r
   BitsInFirstByte := elem_Size;\r
   byte_value := ww_value\r
  END;\r
byte_value:= rtp86_wshift(byte_value, 8 - packed_bit_offset - bitsinfirstbyte) ;\r
if packed_bit_offset=0 then\r
sca_fill(1, ptr_sca_max_string(@byte_value))\r
else\r
sca_put_byte(sca_total_bytes (* current byte *), byte_value);\r
if packed_bit_offset+elem_size>8 then\r
begin\r
byte_value:= rtp86_wshift(helpinteger, 8 - bitsinlastbyte);\r
sca_fill(1, ptr_sca_max_string(@byte_value));\r
end;\r
END;\r
packed_arr_elems:= packed_arr_elems+1;\r
if rep<no_of_repetitions then\r
(* prepare next array element, compute bit offset *)\r
packed_array_offset(0, packed_arr_elems, elem_size div 8 + 1, elem_size,\r
elem_offset, packed_bit_offset);\r
end (* packed dump *)\r
else\r
begin\r
if kind=cnull then\r
begin\r
if computer = RC3502 THEN ww_value := $ffff;\r
for step:=1 to elem_size do sca_fill(1, ptr_sca_max_string(@ww_value))\r
end else\r
BEGIN\r
 helpinteger := ww_Value;\r
 wd_Value := helpinteger;\r
 IF (Computer = RC3502) AND (elem_size = wordsize)\r
 THEN\r
  sca_Integer(wd_Value)\r
 ELSE\r
  sca_fill(elem_size, ptr_sca_max_string(@wd_value));\r
END;\r
end;\r
\r
cendstruc:  sca_duplicate_bytes(size_);\r
\r
ccaddr:  (* copy constant *)\r
BEGIN\r
sca_copy_structured_constant(st_strucc_symbol,elem_size);\r
END;\r
(* otherwise *) else\r
pass3_error(e_implemented, WORD(kind));\r
end; (* case *)\r
\r
IF (Computer = RC3502) AND DoallignArray AND odd(sca_total_bytes)\r
 THEN  sca_fill(1, ptr_sca_max_string(@helpinteger));\r
END;\r
end; (* with stck[ ix-1 ] *)\r
\r
end; (* cendassign *)\r
\r
cconstchecknumber:  if size_<>repeated_arr_elems then\r
errormsg(this_pass, e_wrong_number_of_elems);\r
(* otherwise *) else\r
pass3_error(e_implemented, WORD(kind));\r
end; (* case *)\r
end; (* for ... *)\r
\r
(* pop constant expression *)\r
top:= start_ix;\r
end; (* with e_stck *)\r
\r
(*#BEGINTEST\r
IF rule_test THEN\r
WRITELN\r
(\r
testoutput, ' - End dump structured constant '\r
);\r
(*ENDTEST#*)\r
end; (* dump structured constant *)\r
\r
\r
PROCEDURE load_expression\r
(   (*  Call Return  *)\r
VAR\r
i_code: codes;\r
VAR\r
e_stck: expr_stack_descr;\r
current_level: word;\r
var current_offset: word\r
);\r
\r
CONST\r
(*#BEGINTEST\r
rule_version=005;\r
this_rule =066;\r
(*ENDTEST#*)\r
unused=FALSE;\r
\r
VAR\r
help_size : integer;\r
help_addr,\r
result_type_addr,\r
st_aux_addr: st_address;\r
\r
st_ptr : st_elemptr;\r
\r
dummy_boolean: boolean;\r
\r
NoFuncCall,NoVarParams : integer;\r
\r
mark1, (* stack mark used during interchanging parameters of CREATE *)\r
mark2, (* stack mark used during interchanging parameters of CREATE *)\r
mark3, (* stack mark used during interchanging parameters of CREATE *)\r
markRC5000,\r
set_lower, (* lower limit of constant set *)\r
set_upper, (* upper limit of constant set *)\r
saved_op:  integer;\r
\r
struc_counter, (* current level of nested structures *)\r
arr_elems,  (* number of array elements defined at current structure level *)\r
rep_offset, (* offset of repeat counter in case of run time repetitions *)\r
temp_offset, (* current offset in block of temporaries for repeated elements\r
during the definition of a structured object *)\r
dummy_appetite,\r
limit,\r
string_length,\r
literal_lth  ,\r
u_const_value: WORD;\r
LongLimit, LongString_Length : LongInt;\r
\r
helplength : byte;\r
\r
range_span:  longint;  (* number of elements in current array of a structure *)\r
\r
(* TOG *) start_of_actual_param,\r
operand1_ix  ,\r
operand2_ix: expr_stack_range;\r
\r
op_kind,\r
result_kind,\r
result_type :codes;\r
helpcode: packedtype;\r
\r
plm_string_ix: plm_string_range;\r
\r
dynamic_subrange,\r
fold_function,\r
inside_set,\r
func_call_in_set,\r
set_operator,\r
compare_string,\r
compare_set,\r
in_program_call,\r
end_of_expression,\r
OpenRout: BOOLEAN;\r
\r
(*#BEGINTEST\r
rule_test: BOOLEAN;\r
(*ENDTEST#*)\r
\r
PROCEDURE push_operand\r
(\r
code ,\r
result_type: codes;\r
result_size: WORD\r
);\r
\r
BEGIN\r
with e_stck do\r
IF (top<stack_size) THEN\r
WITH stck[ top ] DO\r
BEGIN\r
\r
kind:= code;\r
type_:= result_type;\r
size_:= result_size;\r
\r
former_fct:= operand2_ix;\r
\r
operand1_ix:= operand2_ix;\r
operand2_ix:= top;\r
\r
indvar_code:= code=csimpleconst;\r
prebool:= 0;\r
precode:= cnocode; (* not used for operands *)\r
prestr := cnocode;\r
\r
top:= top + 1\r
\r
END\r
ELSE (* - the last element is unavailable - *)\r
\r
fatal_error(this_pass, e_expression_ovfl)\r
\r
END (* - PROCEDURE push_operand - *);\r
\r
\r
PROCEDURE push_operator\r
(\r
code ,\r
result_type: codes;\r
result_size: WORD\r
);\r
\r
BEGIN\r
\r
with e_stck do\r
IF (top<stack_size) THEN\r
WITH stck[ top ] DO\r
BEGIN\r
\r
kind:= code;\r
type_:= result_type;\r
size_:= result_size;\r
\r
former_fct:= stck[ operand1_ix ].former_fct;\r
\r
\r
operand1_ix:= former_fct;\r
operand2_ix:= top;\r
indvar_code:= false; (* not used for operator nodes *)\r
prebool:= 0; (* not used for operator nodes *)\r
precode:= cnocode;\r
prestr:= cnocode;\r
\r
top:= top + 1\r
\r
END\r
ELSE (* - the last element is unavailable - *)\r
\r
fatal_error(this_pass, e_expression_ovfl)\r
\r
END (* - PROCEDURE push_operator - *);\r
\r
\r
PROCEDURE push_monadic_operator\r
(\r
code ,\r
result_type: codes;\r
result_size: WORD\r
);\r
\r
BEGIN\r
\r
with e_stck do\r
IF (top<stack_size) THEN\r
WITH stck[ top ] DO\r
BEGIN\r
\r
kind:= code;\r
type_:= result_type;\r
size_:= result_size;\r
\r
former_fct:= stck[ operand2_ix ].former_fct;\r
\r
operand2_ix:= top;\r
indvar_code:= false; (* not used for operator nodes *)\r
prebool:= 0; (* not used for operator nodes *)\r
precode:= cnocode;\r
prestr := cnocode;\r
\r
top:= top + 1\r
END\r
ELSE (* - the last element is unavailable - *)\r
\r
fatal_error(this_pass, e_expression_ovfl)\r
\r
END (* - PROCEDURE push_monadic_operator - *);\r
\r
\r
PROCEDURE pop_operand;\r
\r
VAR\r
stck_ix: expr_stack_range;\r
\r
BEGIN\r
operand2_ix:= operand1_ix;\r
operand1_ix:= e_stck.stck[ operand1_ix ].former_fct;\r
e_stck.top:= operand2_ix+1;\r
END (* - PROCEDURE pop_operand - *);\r
\r
\r
function monadic(code:  codes):  boolean;\r
begin\r
monadic:= code in [cindex, cusub, cnot, cfield, cvalueparam, cvarparam,csetvalueparam,\r
cendassign, cendassignset, cendassignstring, (* TOG cpackedassignment, *)\r
cs_element, cm_element, ctypeselect, cuparrow, csharedparam, cinspectparam];\r
end; (* monadic *)\r
\r
\r
procedure rule_routinecall(i_code:  codes);\r
Var openrout : boolean;\r
begin\r
elementnumber:= elementnumber + 1;\r
with e_stck, stck[ top ] do\r
BEGIN\r
load_symbol(st_addr);\r
st_retrieve(st_addr, st_ptr);\r
with st_ptr^ do\r
if (st_specs=st_local) and st_local_near then\r
size_:= static_link_size+local_return_appetite\r
else\r
begin\r
if st_specs=st_extern then\r
BEGIN\r
if (Computer = RC5000) AND (St_CurNo <> max_Word) THEN\r
   ST_CurNo := Current_Comp_Unit_Number;\r
if (st_curno<>current_comp_unit_number) (* first call in this compilation unit *) then\r
begin (* add new external node in symbol table *)\r
st_update(st_ptr);\r
st_curno:= current_comp_unit_number;\r
st_externallist(st_spix, st_addr, first_external, last_external);\r
end;\r
END;\r
size_:= static_link_size+global_return_appetite;\r
end;\r
\r
IF (Computer = RC5000) THEN\r
BEGIN\r
size_ := 0;\r
help_addr := St_Ptr^.ListRef;\r
openrout := (St_Ptr^.St_Specs = St_Open);\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
           size_ := Size_ + (2 * Address_Size);\r
      end;\r
  end;\r
\r
END;\r
\r
push_operand(i_code, i_code, size_);\r
END; (* with *)\r
end; (* rule routinecall *)\r
\r
\r
procedure dump_set_const;\r
(* set_lower and set_upper are set bounds, if set_upper<set_lower it is the empty set\r
operand1_ix denotes the setlist node which is changed to ccaddr and the set\r
element expressions are poped, the constant set is dumped as a symbol table\r
entry of kind structured const *)\r
var\r
bit_nr: longint;\r
byte_nr, m_val: integer;\r
set_byte: byte;\r
stack_index: expr_stack_range;\r
st_lab, structure: st_address;\r
struct_ptr: st_elemptr;\r
step,\r
set_size: word;\r
set_low : integer;\r
helpint : longint;\r
extraleng : integer;\r
begin\r
(*#BEGINTEST\r
if rule_test then\r
writeln(testoutput, 'Begin dump set const, (op1, op2)= ',\r
operand1_ix:6, operand2_ix:6,\r
'(set_low, set_high)= ', set_lower:6, set_upper:6);\r
(*ENDTEST#*)\r
IF set_lower < 0 THEN fatal_error(This_pass,e_Set_negElem);\r
IF (Computer <> RC3502) AND (Computer <> RC5000) THEN\r
BEGIN\r
extraLeng := wordsize * 2;\r
set_low:= rtp86_wand(rtp86_wmap(set_lower), $fff8);\r
if (set_lower=maxint) and (set_upper=(-maxint)) then\r
set_size:= 0 (* the empty set *)\r
else\r
set_size:= rtp86_wsub(rtp86_wmap(set_upper), set_low)div 8 + 1;\r
END\r
ELSE\r
  BEGIN\r
    extraLeng := 0;\r
    set_low := 0;\r
    if (set_lower=maxint) and (set_upper=(-maxint)) then\r
    BEGIN\r
      IF Computer = RC3502 THEN set_size:= 2\r
      ELSE set_Size := 1;(* the empty set *)\r
    END\r
    else\r
     set_Size :=  (set_upper div 8) + 1;\r
    IF Computer = RC3502 THEN set_size := set_Size + ord(odd(set_Size));\r
  END;\r
ST_Get(e_stck.stck[ operand1_ix ].st_addr,Struct_ptr);\r
Struct_ptr^.St_Size := Set_Size + extraLeng;\r
\r
push_struc_value(set_size+ extraleng (* room for length and start *),\r
st_lab, e_stck.stck[ operand1_ix ].st_addr, unused);\r
structure:= sca_current_frgmnt;\r
(* create the empty set *)\r
IF (Computer <> RC3502) AND (Computer <> RC5000) THEN\r
BEGIN\r
helpint := set_Size;\r
sca_fill(wordsize, ptr_sca_max_string(@helpint)); (* length, excl the header *)\r
helpint := set_low;\r
sca_fill(wordsize, ptr_sca_max_string(@helpint));  (* least value *)\r
END;\r
with e_stck do\r
begin\r
stack_index:= top-1;\r
while stack_index>operand1_ix do\r
begin\r
case stck[ stack_index ].kind of\r
cs_element: begin\r
bit_nr:= stck[ stack_index-1 ].ii_value-rtp86_imap(set_low);\r
IF Computer <> RC3502 THEN\r
  set_byte:= rtp86_bshift(1, bit_nr mod 8)\r
ELSE\r
  set_byte:= rtp86_bshift(1, 7 - bit_nr mod 8);\r
\r
byte_nr:= bit_nr div 8 + 1 + extraleng (* bypass length and low *);\r
sca_put_byte(byte_nr, set_byte);\r
end;\r
\r
cm_element:\r
for m_val:= stck[ stack_index-2 ].ii_value\r
to stck[ stack_index-1 ].ii_value do\r
begin\r
bit_nr:= m_val-rtp86_imap(set_low);\r
IF Computer <> RC3502 THEN\r
  set_byte:= rtp86_bshift(1, bit_nr mod 8)\r
ELSE\r
  set_byte:= rtp86_bshift(1, 7 - bit_nr mod 8);\r
byte_nr:= bit_nr div 8 + 1 + extraleng (* bypass length and low *);\r
sca_put_byte(byte_nr, set_byte);\r
end;\r
\r
(*otherwise*) else\r
pass3_error(e_implemented, ord(stck[ stack_index ].kind));\r
end; (* case *)\r
stack_index:= stck[ stack_index ].former_fct;\r
end; (* while *)\r
(* pop set construction *)\r
top:= operand1_ix;\r
operand2_ix:= operand1_ix-1;\r
push_operand(ccaddr, csettype, address_size); (* always pushed as address *)\r
stck[ operand2_ix ].st_strucc_symbol:= structure;\r
end; (* with *)\r
end; (* dump set const *)\r
\r
\r
FUNCTION fold: BOOLEAN;\r
\r
VAR\r
result_size: WORD;\r
\r
pre_bool: BOOLEAN;\r
pre_code: codes;\r
\r
BEGIN\r
\r
pre_code:= cnocode;\r
pre_bool:= false;\r
\r
WITH e_stck.stck[ operand1_ix ] DO\r
BEGIN\r
\r
IF (size_ < e_stck.stck[ operand2_ix ].size_) THEN\r
WITH e_stck.stck[ operand2_ix ] DO\r
BEGIN\r
\r
result_type:= type_;\r
result_size:= size_\r
\r
END\r
ELSE\r
\r
BEGIN\r
\r
result_type:= type_;\r
result_size:= size_\r
\r
end;\r
\r
WITH e_stck.stck[ operand2_ix ] DO\r
CASE i_code OF\r
\r
ceq,\r
cne,\r
clt,\r
cle,\r
cgt,\r
cge: \r
BEGIN\r
\r
result_type:= cboolean;\r
result_size:= booleansize\r
\r
end;\r
\r
cin: \r
BEGIN\r
\r
result_type:= cboolean;\r
result_size:= booleansize\r
\r
end;\r
\r
cadd,\r
csub:;\r
\r
cor: \r
IF (result_type=cboolean) THEN\r
BEGIN\r
\r
pre_bool:= true;\r
pre_code:= cpreor\r
\r
end;\r
\r
cxor:  ;\r
\r
cmul,\r
cdiv,\r
cmod:  ;\r
\r
cshift:  result_type:= e_stck.stck[ operand1_ix ].type_;\r
\r
cand: \r
IF (result_type=cboolean) THEN\r
BEGIN\r
\r
pre_bool:= true;\r
pre_code:= cpreand\r
\r
end;\r
\r
(*OTHERWISE*) ELSE\r
fatal_error(this_pass, e_expression_stck)\r
\r
end;\r
\r
IF ((kind=csimpleconst) AND\r
(e_stck.stck[ operand2_ix ].kind=csimpleconst))\r
or ((kind=cstrucconst) and\r
(e_stck.stck[ operand2_ix ].kind=cstrucconst))\r
THEN\r
fold:= true\r
\r
ELSE\r
\r
BEGIN\r
if pre_bool then\r
with e_stck do\r
begin\r
stck[operand1_ix].precode:= pre_code;\r
with stck[stck[operand1_ix].former_fct] do\r
prebool:= prebool+1;\r
end;\r
if compare_string then\r
with e_stck do with stck[stck[operand1_ix].former_fct] do\r
prestr := cprestring;\r
\r
if set_operator or compare_set then\r
begin\r
(*if func_call_in_set then\r
pre_code:= cpresetfunc\r
else*)\r
pre_code:= cpreset;\r
e_stck.stck[ operand1_ix ].precode:= pre_code;\r
end (* if pre set *)\r
else\r
if i_code=cin then\r
e_stck.stck[ operand1_ix ].precode:= cprein;\r
\r
push_operator(i_code, result_type, result_size);\r
if (i_code=cadd) or (i_code=csub) or (i_code=cmul) then\r
begin\r
e_stck.stck[ operand2_ix ].set_operation:= set_operator;\r
set_operator:= false;\r
end\r
else\r
if (i_code=ceq) or (i_code=cne) or (i_code=clt) or (i_code=cgt) or (i_code=cle) or (i_code=cge) then\r
begin\r
with e_stck.stck[ operand2_ix ] do\r
begin\r
comp_set:= compare_set;\r
comp_string:= compare_string;\r
end;\r
compare_set:= false;\r
compare_string:= false;\r
end;\r
\r
fold:= false\r
\r
END\r
END\r
END; (* - FUNCTION fold - *)\r
\r
\r
function fold_function_call(res_type_:  codes; res_size_, res_value:  word):  boolean;\r
begin\r
if e_stck.stck[ operand2_ix-1 ].kind=csimpleconst then\r
with e_stck, stck[ operand1_ix ] (* the new operand node *) do\r
begin (* fold constant function call, i.e. remove the call *)\r
fold_function_call:= true;\r
kind:= csimpleconst;\r
type_:= res_type_;\r
if not stdcode_to_address(type_, st_addr) then\r
errormsg(this_pass, e_std_code);\r
size_:= res_size_;\r
ww_value:= res_value;\r
top:= operand1_ix+1; (* pop "valueparam" and actual parameter *)\r
end (* with operand 1 *)\r
else\r
fold_function_call:= false;\r
end; (* fold function call *)\r
\r
{$I rule066a.pas}\r
\r
END.\r
«eof»
DataMuseum.dk

DANOSI

⟦e2989caed⟧ TextFile

Derivation

TextFile
