DataMuseum.dk

top - download

    Length: 10582 (0x2956)
    Types: TextFile
    Names: »RULE005.PAS«

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

TextFile

{$O+,F+}\r
unit rule005;\r
interface\r
uses pscplm,sthunit,sthcom,sthp34,mpaunit,p3cmmn;\r
\r
PROCEDURE rule_routine_declaration\r
(\r
VAR\r
i_code: codes;\r
current_level: WORD;\r
VAR\r
surrounding_offset,\r
default_create_size: WORD;\r
VAR\r
default_compute: BOOLEAN;\r
outermost_level: BOOLEAN);\r
\r
implementation\r
uses rtp86mpa,p3rw,p3math,p3addr,rule008,rule010,rule018,rule078;\r
\r
\r
PROCEDURE rule_routine_declaration\r
(VAR\r
i_code: codes;\r
current_level: WORD;\r
VAR\r
surrounding_offset,\r
default_create_size: WORD;\r
VAR\r
default_compute: BOOLEAN;\r
outermost_level: BOOLEAN);\r
\r
(* ------------------------------------------------------------------------\r
Pass2Code: 05\r
routine declaration::= <function heading!procedure heading><block>\r
function heading::= FUNCDECL(SYMBOL)<formal parameters>\r
<defining type>ENDFUNCDECL\r
procedure heading::= PROCDECL(SYMBOL)<formal parameters>\r
ENDPROCDECL\r
\r
Pass3Code: 05\r
routine declaration::= <function heading!procedure heading><block>\r
function heading::= FUNCDECL(SYMBOL)<formal parameters>\r
procedure heading::= PROCDECL(SYMBOL)<formal parameters>\r
\r
Symbol Table:\r
-.\r
\r
===========================================================================\r
\r
Error Messages and Warnings:\r
e_param_size\r
e_routine_nesting\r
e_st_inconsistency\r
e_display_vector\r
e_create_size\r
-.\r
External Dependencies:\r
std_routine_list (defined in PASS3CMMN.INC)\r
std_routine (defined in PASS3CMMN.INC)\r
rule_test_set (defined in PASS3CMMN.INC)\r
-.\r
External Effects:\r
std_routine_list (defined in PASS3CMMN.INC)\r
std_routine (defined in PASS3CMMN.INC)\r
rule_test_set (defined in PASS3CMMN.INC)\r
-.\r
Stack Appetite:\r
-.\r
Comments:\r
The Symbol Table field 'prog_createsize' is (mis)used to mark, if an\r
OPENROUTINE is one of the predefined routines relevant to PASS3.\r
-.\r
Outstanding:\r
Sketch the layout of local frame.\r
-.\r
------------------------------------------------------------------------ *)\r
\r
CONST\r
rule_version = 005;\r
(*#BEGINTEST\r
this_rule = 005;\r
(*ENDTEST#*)\r
\r
VAR\r
(*#BEGINTEST\r
rule_test: BOOLEAN;\r
(*ENDTEST#*)\r
current_offset ,\r
no_of_parameters ,\r
return_param_size ,\r
evaluation_appetite ,\r
return_appetite: WORD;\r
\r
local_ref,\r
dynamic_result,\r
code ,\r
block ,\r
return_parameter,\r
Bool: BOOLEAN;\r
\r
routine_kind: codes;\r
\r
param_symbol,\r
return_type_symbol ,\r
routine_symbol: st_address;\r
st_ptr: st_elemptr;\r
FuncResAsParam : Boolean;\r
funcresultoffset : integer;\r
forwardDecl : boolean;\r
BEGIN\r
\r
(* - 'i_code' is 'cfuncdecl' or 'cprocdecl'. *)\r
routine_kind:= i_code;\r
\r
(*#BEGINTEST\r
rule_test:= i_code IN rule_test_set;\r
\r
IF rule_test THEN\r
WRITELN\r
(\r
testoutput, ' Begin Rule ', this_rule:3,\r
' V', ( pass3_version + rule_version ):3\r
);\r
(*ENDTEST#*)\r
\r
elementnumber:= elementnumber + 1;\r
\r
IF winc_ovflw( current_level ) THEN\r
errormsg( this_pass, e_routine_nesting );\r
\r
evaluation_appetite:= 0;\r
\r
load_symbol( routine_symbol );\r
\r
st_get( routine_symbol, st_ptr );\r
(*if (st_ptr^.st_specs <> st_open) AND (st_ptr^.st_specs <> st_extern) THEN\r
writeln('spix size ',st_ptr^.st_Spix,' ',st_ptr^.st_size);*)\r
if st_ptr^.st_size <> 0 then\r
begin\r
st_ptr^.st_spix:= st_ptr^.st_size;\r
st_ptr^.st_size:= 0;\r
end;\r
\r
local_ref := referencetype in st_ptr^.spec_struct;\r
forwarddecl := st_ptr^.st_specs = st_forward;\r
\r
IF ( i_code = cfuncdecl ) THEN\r
BEGIN\r
\r
return_parameter:= true;\r
return_type_symbol:= st_ptr^.typeref\r
\r
END\r
ELSE\r
\r
return_parameter:= false;;\r
\r
CASE st_ptr^.st_specs OF\r
\r
st_forward:\r
BEGIN\r
\r
st_ptr^.st_specs:= st_local;\r
\r
if st_ptr^.st_local_near then\r
return_appetite:= local_return_appetite\r
else\r
return_appetite:= global_return_appetite;\r
\r
block:= false;\r
code:= false\r
\r
END;\r
\r
st_open:\r
BEGIN\r
\r
std_routine_list^[ std_routine_begin ]:= st_ptr^.st_spix;\r
\r
std_routine:= pred( std_routine_end );\r
\r
WHILE ( std_routine_list^[ std_routine ] <> st_ptr^.st_spix ) DO\r
std_routine:= pred( std_routine );\r
\r
st_ptr^.prog_createsize:= WORD( std_routine );\r
\r
return_appetite:= global_return_appetite;\r
block:= false;\r
code:= false\r
\r
END;\r
\r
st_extern:\r
BEGIN\r
if sourcenumber=1 then (* only standard environment routines *)\r
begin\r
std_routine_list^[ std_routine_begin ]:= st_ptr^.st_spix;\r
std_routine:= pred( std_routine_end );\r
WHILE ( std_routine_list^[ std_routine ] <> st_ptr^.st_spix ) DO\r
std_routine:= pred( std_routine );\r
st_ptr^.prog_createsize:= WORD( std_routine );\r
end; (* standard environment external *)\r
return_appetite:= global_return_appetite;\r
block:= false;\r
code:= st_ptr^.st_curno=max_word; (* marked as used, suppress code for unused externals *)\r
END;\r
\r
st_overload,\r
st_local,\r
st_global:\r
begin\r
\r
IF outermost_level THEN\r
BEGIN\r
st_ptr^.st_specs:= st_global;\r
return_appetite:= global_return_appetite\r
END\r
ELSE\r
BEGIN\r
st_ptr^.st_specs:= st_local;\r
if st_ptr^.st_local_near then\r
return_appetite:= local_return_appetite\r
else\r
return_appetite:= global_return_appetite;\r
END;\r
\r
block:= true;\r
code:= true\r
\r
END;\r
\r
(* OTHERWISE *) else\r
fatal_error( this_pass, e_st_inconsistency )\r
\r
END ;\r
\r
current_offset:= static_link_size + return_appetite; (* - no overflow - *)\r
\r
rule_formal_parameters\r
(\r
i_code, code, current_level, current_offset, surrounding_offset,\r
address_lf, st_ptr^.listref,\r
evaluation_appetite, no_of_parameters\r
);\r
\r
return_param_size := 0;\r
\r
IF return_parameter THEN\r
begin\r
rule_defining_type\r
(\r
i_code, code, return_type_symbol,\r
rtp86_wsub(current_level, 1), surrounding_offset, address_lf,\r
return_param_size, evaluation_appetite,\r
dynamic_result\r
);\r
if dynamic_result then (* dynamic type *)\r
errormsg( this_pass,e_func_result);\r
end;\r
\r
IF block THEN\r
BEGIN (* only internal routine declarations produce code *)\r
store_code( routine_kind );\r
store_symbol( routine_symbol )\r
END;\r
\r
st_get( routine_symbol, st_ptr );\r
with st_ptr^ do\r
begin\r
st_level:= current_level;\r
\r
st_paramsize:= current_offset - static_link_size - return_appetite; (* - no overflow - *)\r
if dynamic_result then spec_struct:= spec_struct+[dynamictype];\r
IF not forwarddecl then st_size:= return_param_size;\r
\r
\r
if prog_createsize>0 then (* standard routine *)\r
if (prog_createsize=WORD(std_pred))\r
or (prog_createsize=WORD(std_new))\r
or (prog_createsize=WORD(std_succ)) then\r
 (* one extra compiler generated parameter *)\r
st_paramsize:= st_paramsize+wordsize;\r
FuncResultOffset := st_paramsize;\r
IF (Computer = RC3502) AND (prog_CreateSize = WORD(std_new)) THEN\r
  BEGIN\r
      St_Declaration(CValueParam,AnonymousName,Param_Symbol,St_Ptr);\r
      St_Ptr^.St_Size := 2;\r
      Bool := STDcode_To_Address(cInteger,St_Ptr^.TypeRef);\r
      st_Retrieve( routine_symbol, st_ptr );\r
      St_Get(St_Ptr^.ListRef,st_ptr);\r
      st_Ptr^.ListRef := Param_Symbol;\r
      st_get( routine_symbol, st_ptr );\r
  END;\r
end; (* with st_ptr^ .. *)\r
\r
IF block THEN\r
BEGIN\r
(* traverse the paramter list and produce allocdynparam code for possible\r
dynamic sized value parameters *)\r
param_symbol:= st_ptr^.listref;\r
while not equal_addr(param_symbol, st_stopaddr) do\r
begin\r
st_retrieve(param_symbol, st_ptr);\r
param_symbol:= st_ptr^.listref;\r
if st_ptr^.st_kind=cvalueparam then\r
begin\r
current_offset:= st_ptr^.var_offset; (* current offset used as temporary *)\r
if (dynamictype in st_ptr^.spec_struct)(* or\r
   ( st_ptr^.st_size=0)*) then\r
begin\r
store_code_1(callocdynparam, current_offset);\r
st_retrieve(st_ptr^.typeref, st_ptr);\r
store_symbol(st_ptr^.typeref);\r
end; (* dynamic *)\r
end; (* value param *)\r
end; (* while more parameters do *)\r
\r
(* - size of display vector is 2 * level - *)\r
\r
current_offset:= (WordSize - 1) * current_level;\r
\r
IF wadd_ovflw( current_offset, current_level ) THEN\r
errormsg( this_pass, e_display_vector )\r
ELSE\r
current_offset:= rtp86_wsub( 0, current_offset );\r
\r
IF Computer = RC5000 THEN Current_offset := $FFFF\r
ELSE\r
IF Computer = RC3502 THEN Current_Offset := 8;\r
\r
IF return_parameter THEN\r
begin\r
st_get(routine_symbol, st_ptr);\r
if dynamic_result then st_ptr^.spec_struct:=st_ptr^.spec_struct+[dynamictype];\r
st_ptr^.st_size:= return_param_size;\r
\r
IF (Computer = RC3502) OR\r
   ((Computer = RC5000) AND ( Not SimpelFuncRes(st_ptr) ))\r
 THEN\r
  FuncResAsParam := True\r
 ELSE\r
  FuncResAsParam := False;\r
\r
IF not FuncResAsParam THEN\r
BEGIN\r
if (return_param_size<=4) and not dynamic_result then\r
address_lf( current_offset, st_ptr^.func_result_offset, return_param_size )\r
else address_lf( current_offset, st_ptr^.func_result_offset, address_size);\r
END\r
ELSE\r
  BEGIN\r
    IF Computer = RC5000 THEN st_ptr^.func_result_offset := 8 + FuncResultOffset\r
    ELSE\r
     BEGIN\r
      St_RetrieveType(Return_Type_Symbol,st_ptr);\r
      IF not SimpelFuncRes(st_ptr) THEN\r
        return_param_size := 3;\r
      st_get(routine_symbol, st_ptr);\r
      st_ptr^.Func_result_offset := -(FuncResultOffset + return_Param_Size);\r
     END;\r
  END;\r
end;\r
\r
rule_block\r
(\r
i_code, current_level, current_offset,\r
evaluation_appetite,\r
address_lf,\r
default_create_size, default_compute, local_ref);\r
\r
st_get( routine_symbol, st_ptr );\r
IF Computer = RC5000 THEN\r
 BEGIN\r
   IF Current_Offset = $FFFF THEN\r
     st_Ptr^.st_varsize := 0\r
   ELSE\r
     st_Ptr^.st_varSize := rtp86_wsub(0,Current_Offset);\r
 END\r
ELSE\r
IF Computer = RC3502 THEN\r
  st_Ptr^.st_varSize :=  rtp86_wsub(Current_Offset,8)\r
ELSE\r
BEGIN\r
  st_ptr^.st_varsize:= rtp86_wsub( 0, WordSize * current_level ); (* - no overflow - *)\r
  st_ptr^.st_varsize:= rtp86_wsub( st_ptr^.st_varsize, current_offset ); (* - no overflow - *)\r
END;\r
address_lf( current_offset, current_offset, evaluation_appetite );\r
\r
IF Computer = RC3502 THEN st_Ptr^.Max_Offset := Current_Offset\r
ELSE\r
IF current_Offset = $FFFF THEN st_ptr^.max_offset := 0\r
ELSE\r
 st_ptr^.max_offset:= rtp86_wsub( 0, current_offset );\r
\r
IF default_compute THEN\r
BEGIN\r
IF wadd_ovflw( default_create_size, st_ptr^.max_offset ) THEN\r
default_compute:= false\r
ELSE\r
IF Computer = RC5000 THEN\r
IF wadd_ovflw( default_create_size, 12 + (4 * current_level) + 8 ) THEN\r
default_compute:= false;\r
END;\r
(* - 'i_code' is 'cendblock'. *)\r
\r
store_code( cendcompound );\r
store_symbol( routine_symbol );\r
\r
IF outermost_level THEN\r
begin\r
st_ptr^.st_external_list:= first_external; (* set up external list *)\r
IF (Computer <> RC5000) THEN store_const_area(true);\r
end;\r
store_code( i_code )\r
\r
END;\r
\r
\r
(* - 'i_code' is 'cendfuncdecl', 'cendprocdecl' or 'cendblock'. *)\r
\r
(*#BEGINTEST\r
IF rule_test THEN\r
WRITELN\r
(\r
testoutput, ' - End Rule ', this_rule:3,\r
' V', ( pass3_version + rule_version ),\r
'/ ', WORD( i_code ):3,\r
' Df.App', default_create_size:6\r
);\r
(*ENDTEST#*) \r
\r
END (* procedure rule_routine_declaration *);\r
END.\r
«eof»