DataMuseum.dk

top - download

    Length: 10280 (0x2828)
    Types: TextFile
    Names: »RULE008.PAS«

└─⟦02956c927⟧ Bits:30010510 DVBS1.SW2114.src.2.14-1 SW2114 REAL #1/4 TIME PASCAL SOURCE REL 2.14
    └─⟦this⟧ »RTP\RULE008.PAS« 
└─⟦4f587ad96⟧ Bits:30010518 DVBS1.SW2114.src.2.7-1 SW2114 1/4 Real Time Pascal 2.7 92.06.16
    └─⟦this⟧ »RTP\RULE008.PAS« 
└─⟦a2a9e188c⟧ Bits:30010526 DVBS1.SW2114.src.2.6-4 RTP Compiler Source SW2104+SW2114 Disk 1 92.02.03 HEJ HHA
    └─⟦this⟧ »RTP\RULE008.PAS« 
└─⟦b607d6035⟧ Bits:30010532 RTP compiler Source 1 2.14 26/9(?)-92 DVBS1.SW2114.src.2.14-8
    └─⟦this⟧ »RULE008.PAS« 
└─⟦fd2665794⟧ Bits:30010523 DVBS1.SW2114.src.2.6-1 RTP compiler source SW2104+SW2114 Disk#1 30/1-92 HHA
    └─⟦this⟧ »RTP\RULE008.PAS« 

TextFile

{$O+,F+}\r
unit rule008;\r
interface\r
uses pscplm,sthunit,sthcom,sthp34,mpaunit,p3cmmn,p3rw,p3math,p3addr;\r
\r
\r
PROCEDURE rule_formal_parameters\r
(\r
VAR\r
i_code: codes;\r
emit_code: BOOLEAN;\r
current_level: WORD;\r
VAR\r
current_offset, surrounding_offset: WORD;\r
address : addressprocedure;\r
first_param: st_address;\r
VAR\r
evaluation_appetite,\r
no_of_params: WORD\r
);\r
\r
\r
implementation\r
uses rule018;\r
(* $SUBTITLE('------------ PROCEDURE rule_formal_parameters') *)\r
PROCEDURE rule_formal_parameters\r
((* Call Return *)\r
VAR\r
i_code: codes;\r
emit_code: BOOLEAN;\r
current_level: WORD;\r
VAR\r
current_offset, surrounding_offset: WORD;\r
address : addressprocedure;\r
first_param: st_address;\r
VAR\r
evaluation_appetite,\r
no_of_params: WORD\r
);\r
\r
(* ------------------------------------------------------------------------\r
Pass2Code: 08\r
formal parameters ::= <formal list>ENDFORMAL\r
formal list ::= !<formal list>\r
!FORMALPARAMLIST(SYMBOL)<defining type>\r
ENDFORMALLIST\r
\r
Pass3Code: 08\r
formal parameters ::= !<formal parameters>\r
!ALLOCDYNPARAM(OFFSET,DOPE_OFFSET)\r
\r
Symbol Table:\r
- fetch (kind and) size of formal parameters.\r
- store level, offset (and parameter type identification).\r
\r
===========================================================================\r
\r
Error Messages and Warnings:\r
e_st_inconsistency\r
e_param_size\r
e_param_appetite\r
e_param_count\r
e_token\r
-.\r
External Dependencies:\r
rule_test_set (defined in PASS3CMMN.INC)\r
-.\r
External Effects:\r
rule_test_set (defined in PASS3CMMN.INC)\r
-.\r
Stack Appetite:\r
-.\r
Comments:\r
-.\r
Outstanding:\r
-.\r
------------------------------------------------------------------------ *)\r
\r
CONST\r
rule_version = 005;\r
(*#BEGINTEST\r
this_rule = 008;\r
(*ENDTEST#*)\r
\r
VAR\r
(*#BEGINTEST\r
rule_test: BOOLEAN;\r
(*ENDTEST#*)\r
\r
direct_address ,\r
end_of_list,\r
rc5000paramvalue: BOOLEAN;\r
\r
param_size: WORD;\r
param_kind: codes; (* shared params of a program are changed to shared *)\r
param_dynamic: boolean;\r
st_symbol: st_address;\r
st_ptr: st_elemptr;\r
\r
PROCEDURE insert_param_offset(v_offset: word; addr: st_address);\r
VAR\r
type_addr,addr1: st_address;\r
st_ptr: st_elemptr;\r
\r
procedure insert_type_offset(type_addr: st_address; descr_offset: word);\r
(* traverse type copy and insert correct OFFSET of the descriptor *)\r
var\r
st_ptr: st_elemptr;\r
field_symbol, element_type: st_address;\r
begin\r
st_get(type_addr, st_ptr);\r
case st_ptr^.st_kind of\r
csubrange: if st_ptr^.st_node_copy then\r
(* static sub type copies are eliminated by traverse type binding *)\r
st_ptr^.subr_addr.offset:= descr_offset;\r
\r
cscalar: ;\r
\r
ctype: if st_ptr^.st_node_copy then\r
begin\r
st_ptr^.type_address.offset:= descr_offset;\r
insert_type_offset(st_ptr^.typeref, descr_offset);\r
end; (* type *)\r
\r
cpointertype: insert_type_offset(st_ptr^.typeref, descr_offset);\r
\r
crecordtype: begin\r
st_ptr^.record_addr.offset:= descr_offset;\r
field_symbol:= st_ptr^.listref;\r
repeat\r
st_get(field_symbol, st_ptr);\r
if st_ptr^.field_mode<>stat then\r
if st_ptr^.field_addr.addrtype_mode=indirect then\r
st_ptr^.field_addr.offset:= descr_offset;\r
\r
(* #begintest\r
if rule_test then\r
if not teststh then\r
begin\r
teststh:= true; { force sth testoutput }\r
writeln(testoutput, 'end insert type offset into field (',\r
field_symbol.va_high:6, ', ', field_symbol.va_low:6, ' )' );\r
st_retrieve(field_symbol, st_ptr);\r
teststh:= false;\r
end;\r
(* ENDTEST# *)\r
\r
field_symbol:= st_ptr^.listref;\r
insert_type_offset(st_ptr^.typeref, descr_offset);\r
until equal_addr(field_symbol, st_stopaddr);\r
end; (* recordtype *)\r
\r
carraytype: begin\r
with st_ptr^.array_addr do\r
if addrtype_mode=indirect then\r
offset:= descr_offset;\r
element_type:= st_ptr^.typeref;\r
insert_type_offset(st_ptr^.itype, descr_offset);\r
insert_type_offset(element_type, descr_offset);\r
end; (* arraytype *)\r
\r
csettype: ;\r
\r
(* otherwise *) else\r
pass3_error(e_implemented, ord(st_ptr^.st_kind));\r
end; (* case *)\r
\r
(* #begintest\r
if rule_test then\r
if not teststh then\r
begin\r
teststh:= true; { force sth testoutput }\r
writeln(testoutput, 'end insert type offset(',\r
type_addr.va_high:6, ', ', type_addr.va_low:6, ' )' );\r
st_retrieve(type_addr, st_ptr);\r
teststh:= false;\r
end;\r
(* ENDTEST# *)\r
\r
end; (* insert type offset *)\r
\r
\r
BEGIN\r
IF Computer = RC5000 THEN\r
      v_offset := Static_Link_Size + Global_Return_Appetite\r
ELSE\r
IF Computer = RC3502 THEN\r
BEGIN\r
  IF Current_Level = Program_Level THEN v_offset := Process_descr_size\r
  ELSE v_offset := -v_Offset + Static_Link_Size + Global_Return_Appetite;\r
END;\r
WHILE NOT equal_addr(addr, st_stopaddr) DO\r
BEGIN\r
st_get(addr, st_ptr);\r
WITH st_ptr^ DO\r
BEGIN\r
IF Computer = RC5000 THEN\r
BEGIN\r
  IF (st_size > 4) AND (Current_level <> Program_level) AND\r
     ( v_Offset < ( Static_Link_Size + Global_Return_Appetite + 8)) THEN\r
     v_Offset := Static_Link_Size + Global_Return_Appetite + 8;\r
END;\r
\r
IF (Computer = RC5000) OR (Computer = RC3502) THEN\r
BEGIN\r
  IF Computer = RC5000 THEN var_offset:= v_offset\r
                       ELSE var_offset:= v_offset + 1;\r
  v_offset:= v_offset + st_size;\r
END\r
ELSE\r
BEGIN\r
  v_offset:= v_offset - st_size;\r
  var_offset:= v_offset;\r
END;\r
addr1 := Addr;\r
addr:= listref;\r
type_addr:= typeref;\r
IF (Computer = RC3502) AND (st_Ptr^.St_Kind = cValueParam) THEN\r
  BEGIN\r
    st_retrievetype(type_addr, st_ptr);\r
    IF ((St_Ptr^.St_Size = 1) AND\r
        (  (St_Ptr^.St_Kind = CSubrange) OR\r
           (St_Ptr^.St_Kind = CChar) OR\r
           (St_Ptr^.St_Kind = CScalar) OR\r
           (St_Ptr^.St_Kind = CBoolean) )  ) OR\r
       (St_Ptr^.St_Kind = CPointerType) OR\r
       (St_ptr^.St_Size = 0) THEN\r
     BEGIN\r
     END\r
    ELSE\r
     BEGIN\r
       st_get(addr1, st_ptr);\r
       St_Ptr^.var_offset := St_ptr^.Var_offset - 1;\r
     END;\r
  END;\r
IF (Computer = RC3502) AND (st_Ptr^.St_Kind = cshared) THEN\r
     BEGIN\r
       st_get(addr1, st_ptr);\r
       St_Ptr^.var_offset := St_ptr^.Var_offset - 1;\r
     END;\r
st_retrieve(type_addr, st_ptr);\r
if st_ptr^.type_mode=open_fam then\r
begin\r
IF (Computer = RC5000) OR (Computer = RC3502) THEN\r
BEGIN\r
IF Computer = RC5000 THEN insert_type_offset(type_addr, v_offset)\r
                     ELSE insert_type_offset(type_addr, v_offset + 1);\r
v_offset:= v_offset+address_size;\r
END\r
ELSE\r
BEGIN\r
v_offset:= v_offset-address_size;\r
insert_type_offset(type_addr, v_offset);\r
END;\r
end;\r
END;\r
END;\r
END;\r
\r
BEGIN\r
\r
(*#BEGINTEST\r
rule_test:= i_code IN rule_test_set;\r
IF rule_test THEN\r
WRITELN\r
(\r
testoutput, ' Begin Rule ', this_rule: 3,\r
' V', (pass3_version + rule_version): 3, '/ ', WORD(i_code): 3\r
);\r
(*ENDTEST#*)\r
\r
no_of_params:= 0;\r
rc5000paramvalue := false;\r
\r
REPEAT\r
\r
load_code(i_code);\r
\r
CASE i_code OF\r
\r
cformalparamlist:\r
BEGIN\r
\r
load_symbol(st_symbol);\r
\r
st_retrieve(st_symbol, st_ptr); (* - Param Node -. *)\r
\r
if current_level=program_level+1 then\r
rule_defining_type\r
(\r
i_code, emit_code, st_ptr^.typeref,\r
rtp86_wsub(current_level, 1), surrounding_offset, address_gf,\r
param_size, evaluation_appetite,\r
param_dynamic\r
)\r
else\r
rule_defining_type\r
(\r
i_code, emit_code, st_ptr^.typeref,\r
rtp86_wsub(current_level, 1), surrounding_offset, address,\r
param_size, evaluation_appetite,\r
param_dynamic\r
);\r
(*- i_code=ctypeid means open family type -*)\r
\r
st_get(st_symbol, st_ptr);\r
\r
param_kind:= st_ptr^.st_kind;\r
CASE param_kind OF\r
\r
cvalueparam: begin\r
(* dynamic value parameters are addressed indirect *)\r
(* tog if param_size=0 then  *)\r
direct_address:= false;\r
IF Computer <> RC3502 THEN\r
BEGIN\r
  St_Retrieve(st_ptr^.TypeRef,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)) THEN\r
     param_dynamic := true;\r
END;\r
st_get(st_symbol, st_ptr);\r
\r
if param_dynamic then\r
begin\r
  param_size:= address_size;\r
end\r
(* TOG if (param_size=0) then\r
param_size:= address_size *)\r
else direct_address:= true;\r
end; (* valueparam *)\r
\r
cvarparam,\r
cinspectparam:\r
BEGIN\r
\r
direct_address:= false;\r
param_size:= address_size\r
\r
END;\r
\r
csharedparam:\r
IF (current_level = program_level) THEN\r
BEGIN\r
\r
param_kind:= cshared;\r
\r
direct_address:= true;\r
param_size:= gf_shared_param_size\r
\r
END\r
ELSE\r
\r
BEGIN\r
\r
direct_address:= false;\r
param_size:= lf_shared_param_size\r
\r
END;\r
\r
(*OTHERWISE*) ELSE\r
fatal_error(this_pass, e_st_inconsistency)\r
END;\r
\r
IF (Param_Size MOD WordSize) <> 0 THEN\r
if wadd_ovflw(param_Size,wordsize - (Param_size MOD WordSize)) THEN\r
errormsg(this_pass, e_param_size);\r
\r
end_of_list:= false;\r
\r
REPEAT\r
\r
elementnumber:= elementnumber+1;\r
with st_ptr^ do\r
begin\r
if param_kind=cshared then\r
begin\r
st_kind:= cshared;\r
if emit_code then\r
store_code_symbol(cshareddecl, st_symbol);\r
st_symbol:= listref; (* prepare a possible next parameter *)\r
end; (* change param kind *)\r
\r
var_level:= current_level;\r
st_size:= param_size;\r
var_indir:= NOT direct_address;\r
IF Param_Dynamic THEN\r
  spec_struct:= spec_struct + [dynamictype];\r
end; (* with st_ptr^ *)\r
\r
IF wadd_ovflw(current_offset, param_size) THEN\r
errormsg(this_pass, e_param_appetite);\r
\r
if i_code=ctypeid then (* open family typed parameter, reserve space for\r
address of actual dope descriptor *)\r
IF wadd_ovflw(current_offset, address_size) THEN\r
errormsg(this_pass, e_param_appetite);\r
\r
\r
IF winc_ovflw(no_of_params) THEN\r
errormsg(this_pass, e_param_count);\r
\r
IF computer = RC5000 then\r
IF (no_of_params < 3) AND\r
   (param_kind = cValueParam) AND\r
   (param_size > 4) AND\r
   (Current_Level <> Program_Level) AND\r
   (Rc5000ParamValue = false) THEN\r
   BEGIN\r
     Rc5000ParamValue := True;\r
     IF wadd_ovflw(current_offset, (3 - no_of_Params) * address_Size) THEN\r
       errormsg(this_pass, e_param_appetite);\r
   END;\r
\r
IF not st_ptr^.st_listend THEN\r
st_get(st_ptr^.listref, st_ptr)\r
ELSE\r
end_of_list:= true;\r
\r
UNTIL end_of_list;\r
\r
END;\r
\r
cendformallist:;\r
\r
cendformal:\r
insert_param_offset(current_offset, first_param);\r
\r
\r
(* OTHERWISE *) else\r
fatal_error(this_pass, e_token_008)\r
\r
END\r
\r
UNTIL (i_code = cendformal);\r
\r
(*#BEGINTEST\r
IF rule_test THEN\r
WRITELN\r
(\r
testoutput, ' - End Rule ', this_rule: 3,\r
' V', (pass3_version + rule_version): 3,\r
'/ ', WORD(i_code): 3,\r
' #Param', no_of_params: 6,\r
' EA', evaluation_appetite: 6\r
);\r
(*ENDTEST#*)\r
\r
END (* procedure rule_formal_parameters *);\r
END.\r
«eof»