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

⟦868825858⟧ TextFile

    Length: 30446 (0x76ee)
    Types: TextFile
    Names: »RULE010.PAS«

Derivation

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

TextFile

{$O+,F+}\r
unit rule010;\r
interface\r
uses pscplm,sthunit,sthcom,sthp34,mpaunit,p3cmmn;\r
\r
PROCEDURE push_stmnt\r
(code : codes;\r
offset : WORD;\r
symbol : st_address);\r
\r
PROCEDURE pop_stmnt\r
(VAR\r
code : codes;\r
VAR\r
offset : WORD;\r
VAR\r
symbol : st_address);\r
\r
PROCEDURE rule_block\r
(VAR\r
i_code : codes;\r
current_level : WORD;\r
VAR\r
max_var_offset ,\r
max_eval_appetite : WORD;\r
address : addressprocedure;\r
VAR\r
default_create_size : WORD;\r
VAR\r
default_compute: BOOLEAN;\r
local_ref: boolean);\r
\r
implementation\r
uses p3rw,p3math,rule004,rule005,rule015,rule016,rule018,rule037,rule066,\r
     rule078;\r
\r
PROCEDURE push_stmnt\r
(\r
code : codes;\r
offset : WORD;\r
symbol : st_address\r
);\r
\r
BEGIN\r
\r
IF (max_stmnt_nesting < stmnt_stck_top) THEN\r
fatal_error(this_pass, e_stmnt_nesting)\r
ELSE\r
\r
BEGIN\r
\r
stmnt_stck[ stmnt_stck_top ].code := code;\r
stmnt_stck[ stmnt_stck_top ].offset := offset;\r
stmnt_stck[ stmnt_stck_top ].symbol := symbol;\r
\r
stmnt_stck_top := stmnt_stck_top + 1\r
\r
END\r
\r
END (* - PROCEDURE push_stmnt - *);\r
\r
(* $SUBTITLE('------------ PROCEDURE pop_stmnt') *)\r
PROCEDURE pop_stmnt\r
(\r
VAR\r
code : codes;\r
VAR\r
offset : WORD;\r
VAR\r
symbol : st_address\r
);\r
\r
BEGIN\r
\r
stmnt_stck_top := stmnt_stck_top - 1;\r
\r
code := stmnt_stck[ stmnt_stck_top ].code;\r
offset := stmnt_stck[ stmnt_stck_top ].offset;\r
symbol := stmnt_stck[ stmnt_stck_top ].symbol\r
\r
END (* - PROCEDURE pop_stmnt - *);\r
\r
(* $SUBTITLE('------------ PROCEDURE rule_block') *)\r
PROCEDURE rule_block\r
((* Call Return *)\r
VAR\r
i_code : codes;\r
current_level : WORD;\r
VAR\r
max_var_offset ,\r
max_eval_appetite : WORD;\r
address : addressprocedure;\r
VAR\r
default_create_size : WORD;\r
VAR\r
default_compute: BOOLEAN;\r
local_ref: boolean);\r
\r
(* ------------------------------------------------------------------------\r
Pass2Code: 10, 11\r
block ::= !<BLOCK<declarations><exception>INITBLOCK\r
<compound statement>ENDBLOCK>\r
declarations ::= !<declarations>\r
!<constant declaration>\r
!<type declaration>\r
!<variable declaration>\r
!<shared declaration>\r
!<routine declaration>\r
!<program declaration>\r
exception ::= !EXCEPTION(SYMBOL)\r
-.\r
Pass3Code: 10, 11\r
block ::= !<BLOCK<declarations><compound statement>\r
ENDCOMPOUND(SYMBOL)<long constants>ENDBLOCK>\r
declarations ::= !<declarations>\r
!<constant declaration>\r
!<type declaration>\r
!<variable declaration>\r
!<shared declaration>\r
!<routine declaration>\r
!<program declaration>\r
long constants ::= \r
-.\r
Symbol Table: 10, 11\r
-.\r
===========================================================================\r
\r
Error Messages and Warnings\r
e_stmnt_nesting\r
e_case_label\r
e_range\r
e_with_variable\r
e_eval_appetite\r
e_token_010\r
-.\r
External Dependencies:\r
anomymousname (defined in RTP86MPA.EXT)\r
stmnt_stck (defined in PASS3CMMN.INC)\r
stmnt_stck_top (defined in PASS3CMMN.INC)\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
stmnt_stck (defined in PASS3CMMN.INC)\r
stmnt_stck_top (defined in PASS3CMMN.INC)\r
rule_test_set (defined in PASS3CMMN.INC)\r
-.\r
Stack Appetite:\r
-.\r
Comments:\r
Case Statement: Erroneous labels are dumped.\r
-.\r
Outstanding:\r
Consider two statement stack: one for o offset, one for symbol.\r
check param.\r
Inspect case statement: suspect superfluous code.\r
-.\r
------------------------------------------------------------------------ *)\r
\r
CONST\r
(*#BEGINTEST\r
rule_version = 005;\r
this_rule = 010; (* - 10 is program, 11 routine block - *)\r
(*ENDTEST#*) \r
\r
code = TRUE;\r
\r
VAR\r
aux_addr ,\r
stmnt_addr : st_address;\r
\r
help_code: codes;\r
lock_kind: codes;\r
\r
stmnt_ptr : st_elemptr;\r
\r
object_size : WORD;\r
\r
object_dynamic: boolean;\r
\r
var_p_index: integer;\r
\r
end_of_block ,\r
end_of_list : BOOLEAN;\r
\r
conststringsize : integer;\r
\r
Old_Max_Offset : word;\r
\r
(*#BEGINTEST\r
rule_test : BOOLEAN;\r
(*ENDTEST#*)\r
\r
(* $SUBTITLE('------------ PROCEDURE rule_047d1') *)\r
PROCEDURE rule_047d1;\r
\r
VAR\r
label_low_ix ,\r
label_high_ix : expr_stack_range;\r
\r
BEGIN\r
\r
end_of_list := false;\r
\r
REPEAT\r
\r
load_expression(i_code, e_stck^, current_level, max_var_offset);\r
\r
label_high_ix := e_stck^.last_fct;\r
\r
IF (i_code = ccaselabel) THEN\r
label_low_ix := label_high_ix\r
ELSE\r
\r
label_low_ix := e_stck^.stck[ label_high_ix ].former_fct;\r
\r
\r
CASE i_code OF\r
\r
ccaselabel,\r
ccaselabelrange:\r
\r
BEGIN\r
\r
IF NOT st_caselabel\r
(\r
e_stck^.stck[ label_low_ix ].ii_value,\r
e_stck^.stck[ label_high_ix ].ii_value,\r
stmnt_stck[ stmnt_stck_top - 1 ].symbol,\r
stmnt_addr\r
)\r
THEN\r
errormsg(this_pass, e_case_label);\r
\r
store_code(ccaserange);\r
store_symbol(stmnt_addr);\r
\r
if not e_stck^.const_expr then\r
errormsg(this_pass, e_not_constant_expr) else\r
WITH stmnt_stck[ stmnt_stck_top - 2 ] DO\r
BEGIN\r
\r
st_get(symbol, stmnt_ptr);\r
\r
WITH e_stck^.stck[ label_low_ix ] DO\r
(* TOG *) IF rtp86_ilt(ww_value, stmnt_ptr^.subr_low) THEN (**)\r
(* if w_value<stmnt_ptr^.subr_low then *)\r
stmnt_ptr^.subr_low := e_stck^.stck[ label_low_ix ].ww_value;\r
\r
WITH e_stck^.stck[ label_high_ix ] DO\r
(* TOG *) IF rtp86_ilt(stmnt_ptr^.subr_high, ww_value) THEN (**)\r
(* if w_value>stmnt_ptr^.subr_high then *)\r
stmnt_ptr^.subr_high := ww_value\r
\r
END\r
\r
END;\r
\r
ccaselist:\r
BEGIN\r
\r
store_code(ccaselist);\r
end_of_list := true\r
\r
END;\r
\r
cotherwise:\r
BEGIN\r
\r
store_code(i_code);\r
\r
store_symbol(stmnt_stck[ stmnt_stck_top - 1 ].symbol);\r
\r
stmnt_stck[ stmnt_stck_top - 1 ].code := i_code;\r
\r
end_of_list := true\r
\r
END;\r
\r
cendcase:\r
BEGIN\r
\r
IF (stmnt_stck[ stmnt_stck_top - 1 ].code <> cotherwise) THEN\r
BEGIN\r
\r
store_code(cotherwise);\r
\r
store_symbol(stmnt_stck[ stmnt_stck_top - 1 ].symbol);\r
\r
store_code(cotherwiseexc)\r
\r
END;\r
\r
store_code(i_code);\r
\r
pop_stmnt(i_code, max_var_offset, stmnt_addr);\r
\r
WITH stmnt_stck[ stmnt_stck_top - 1 ] DO\r
BEGIN\r
\r
st_get(symbol, stmnt_ptr);\r
\r
(* TOG *)\r
IF (stmnt_ptr^.subr_low<0) or \r
(maxbyte < stmnt_ptr^.subr_low) OR (maxbyte < stmnt_ptr^.subr_high) THEN\r
(* DOUBLE !!! if (stmnt_ptr^.subr_low<minint) or \r
(maxint  < stmnt_ptr^.subr_low) or (maxint < stmnt_ptr^.subr_high) then\r
stmnt_ptr^.st_size := doublesize\r
else *)\r
stmnt_ptr^.st_size := integersize\r
ELSE\r
\r
stmnt_ptr^.st_size := bytesize\r
\r
END;\r
\r
pop_stmnt(i_code, max_var_offset, stmnt_addr);\r
\r
end_of_list := true\r
\r
END;\r
\r
(*OTHERWISE*) ELSE\r
fatal_error(this_pass, e_token)\r
\r
END;\r
\r
skip_expression(e_stck^)\r
\r
UNTIL end_of_list\r
\r
END (* - PROCEDURE rule_047d1 - *);\r
\r
(* $SUBTITLE('------------ PROCEDURE rule_block')*)\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\r
);\r
(*ENDTEST#*) \r
\r
stmnt_stck_top := 1;\r
\r
Old_Max_Offset := Max_Block_Offset;\r
max_Block_offset := max_var_offset;\r
\r
(* - 'i_code' is 'cendprogdecl', 'cendprocdecl', 'cendfuncdecl'\r
or a separator - *)\r
\r
end_of_block := false;\r
\r
REPEAT (* - ... UNTIL 'i_code' is 'cendblock' ... - *)\r
\r
(*#BEGINTEST\r
rule_test := i_code IN rule_test_set;\r
IF rule_test THEN\r
WRITELN\r
(\r
testoutput, '   ... Rule ', this_rule:3,\r
'/ ', WORD(i_code):3\r
);\r
(*ENDTEST#*)\r
IF (current_level = program_level) OR (Computer = RC3502) THEN\r
BEGIN\r
IF (max_block_offset < max_var_offset) THEN\r
max_block_offset := max_var_offset\r
END\r
ELSE\r
BEGIN\r
IF (max_var_offset < max_block_offset) THEN\r
max_block_offset := max_var_offset\r
END;\r
\r
load_code(i_code); (* - read ahead - *)\r
\r
CASE i_code OF\r
\r
csegment: begin\r
store_code(cendsegment);\r
store_const_area(false);\r
store_code(csegment);\r
end;\r
\r
cblock:\r
store_code(i_code);\r
\r
cconstdecl:\r
rule_constant_declaration(i_code, current_level, max_var_offset);\r
\r
ctypedecl:\r
rule_type_declaration\r
(i_code,\r
current_level, max_var_offset, address,\r
max_eval_appetite\r
);\r
\r
cvardecl,\r
cshareddecl:\r
rule_variable_declaration\r
(i_code, current_level, max_var_offset,\r
max_eval_appetite, address\r
);\r
\r
cfuncdecl, \r
cprocdecl:\r
rule_routine_declaration\r
(i_code, current_level, max_var_offset,\r
default_create_size, default_compute,\r
false);\r
\r
cprogdecl:\r
BEGIN\r
\r
rule_program_declaration\r
(i_code, program_level, max_var_offset,\r
max_var_offset, (* - program descriptor address in GF - *)\r
false);\r
\r
address(max_var_offset, max_var_offset, program_descr_size)\r
\r
END;\r
\r
\r
cinitblock:\r
begin\r
if local_ref AND (Computer <> RC5000) AND (Computer <> RC3502)  then\r
begin\r
plm_string := '?';\r
(*plm_string.length:=1;\r
plm_string.name[1]:='?'; TURBO*)\r
st_declaration(cvar, plm_string, stmnt_addr, stmnt_ptr);\r
stmnt_ptr^.var_level:= current_level;\r
stmnt_ptr^.st_size:= referencesize + 2; (* mark *)\r
address(max_var_offset,stmnt_ptr^.var_offset, referencesize + 2);\r
store_code(cinit);\r
store_code(caddr);\r
store_symbol(stmnt_addr);\r
store_code(creference);\r
end;\r
store_code(i_code);\r
end;\r
\r
cendtypedecl,\r
cendfuncdecl,\r
cendprocdecl, (* ? *)\r
cendprogdecl,\r
cenddeclarations:;\r
\r
cexception:\r
BEGIN\r
\r
store_code(i_code);\r
copy_symbol\r
\r
END (* - ?stack appetite in 'default_create_size'? - *);\r
\r
\r
(* ------------------------------------------------------------------------\r
Pass2Code: 40\r
compound statement ::= compound statement!statement\r
statement ::= !compound statement\r
!assignment statement\r
!exchange statement\r
!if statement\r
!case statement\r
!for statement\r
!loop statement\r
!while statement\r
!repeat statement\r
!procedure call\r
!exitloop statement\r
!continueloop statement\r
!exit statement\r
!goto statement\r
!labelled statement\r
!with statement\r
!lock statement\r
!region statement\r
\r
Pass3Code: 40\r
compound statement ::= compound statement!statement\r
statement ::= !compound statement\r
!assignment statement\r
!exchange statement\r
!if statement\r
!case statement\r
!for statement\r
!loop statement\r
!while statement\r
!repeat statement\r
!procedure call\r
!exitloop statement\r
!continueloop statement\r
!exit statement\r
!goto statement\r
!labelled statement\r
!with statement\r
!lock statement\r
!region statement\r
\r
Symbol Table:\r
- see below.\r
-.\r
------------------------------------------------------------------------ *)\r
\r
\r
(* $SUBTITLE('------------ Assignment/ Exchange Statement') *)\r
(* --------------------------------------------------------------------\r
Pass2Code: 42\r
assignment statement ::= <variable><expression>ENDASSIGN\r
\r
Pass3Code: 42\r
assignment statement ::= <check parameter>ASSIGNSTAT\r
<variable><expression>\r
<!RANGECHECK(SYMBOL)>\r
ENDASSIGN\r
\r
-----------------------------------------------------------------------\r
Pass2Code: 44\r
exchange statement ::= <variable><variable>ENDEXCHANGE\r
\r
Pass3Code: 44\r
exchange statement ::= <check parameter>EXCHANGESTAT\r
<variable><variable>ENDEXCHANGE\r
\r
-----------------------------------------------------------------------\r
42.1,44.1:\r
check parameter ::= !CADDR(SYMBOL) CHECKPARAM( symbol )\r
\r
Symbol Table:\r
-.\r
-------------------------------------------------------------------- *)\r
\r
cid:\r
BEGIN\r
\r
load_symbol(stmnt_addr);\r
\r
elementnumber := elementnumber + 1;\r
\r
load_expression(i_code, e_stck^, current_level, max_var_offset);\r
(* - 'i_code' is 'cendassign(set/string)' or 'cendexchange(string)' - *)\r
\r
IF (max_eval_appetite < address_size) THEN\r
max_eval_appetite := address_size; (* OBS!!! *)\r
with e_stck^.stck[1] do\r
begin (* let stack element [1] be "id" *)\r
st_addr:= stmnt_addr;\r
kind:= caddr;\r
st_retrieve(st_addr, stmnt_ptr);\r
st_retrievetype(stmnt_ptr^.typeref, stmnt_ptr);\r
size_:= stmnt_ptr^.st_size;\r
type_:= stmnt_ptr^.st_kind;\r
end;\r
\r
(* Dump checkparam *)\r
IF next_code = ccheckparam then\r
  BEGIN\r
    help_code := i_code;\r
    load_code(i_code);\r
    store_code(i_code);\r
    Copy_Symbol;\r
    Copy_Symbol;\r
    i_code := help_code;\r
  END;\r
\r
IF (i_code=cendassign) or (i_code=cendassignset) or (i_code=cendassignstring) THEN\r
with e_stck^ do\r
BEGIN\r
\r
if  ((i_code = cendassignString)\r
      AND ( stck[last_fct].Kind <> cendstruc))\r
 then\r
begin\r
with stck[ last_fct ] do\r
begin\r
with stck[ former_fct ] do\r
case kind (* left hand side *) of\r
cfield, caddr: begin\r
st_retrieve(st_addr, stmnt_ptr);\r
aux_addr:= stmnt_ptr^.typeref;\r
end;\r
cindex, cuparrow: aux_addr:= st_addr;\r
(*otherwise*) else pass3_error(e_token_010, WORD(kind));\r
end; (* case *)\r
   st_retrievetype(aux_addr, stmnt_ptr);\r
   ConstStringSize := stmnt_ptr^.St_Size;\r
\r
case kind (* right hand side *) of\r
ccaddr, cfield, caddr: begin\r
st_retrieve(st_addr, stmnt_ptr);\r
aux_addr:= stmnt_ptr^.typeref;\r
end;\r
cindex, cuparrow: aux_addr:= st_addr;\r
(*otherwise*) else pass3_error(e_token_010, WORD(kind));\r
end; (* case *)\r
end; (* with stck[ last_fct-1 ] *)\r
\r
   st_retrievetype(aux_addr, stmnt_ptr);\r
   IF (ConstStringSize <> 0) AND (ConstStringSize = stmnt_ptr^.St_Size)\r
     THEN i_code := cendAssign;\r
end;\r
\r
store_code(cassignstat);\r
\r
IF Computer <> RC3502 THEN\r
if (i_code=cendassignset) then\r
with stck[ last_fct ] do\r
stck[ former_fct ].precode:= cpreset;\r
\r
dump_expression(e_stck^, max_eval_appetite, current_level, max_var_offset);\r
\r
IF (Computer = RC5000) AND\r
   ( max_eval_appetite < 12) AND\r
   ( i_Code = cEndAssignSet) THEN\r
  Max_eval_Appetite := 12;\r
IF range_check THEN\r
with stck [ stck [ last_fct ]. former_fct ] (* left hand side *) do\r
begin\r
case kind of\r
cfield,\r
caddr: (* st_addr denotes an object *)\r
begin\r
st_retrieve(st_addr, stmnt_ptr);\r
st_retrieve(stmnt_ptr^.typeref, stmnt_ptr);\r
end;\r
cindex,\r
cuparrow: (* st_addr denotes a ctype node *)\r
st_retrieve(st_addr, stmnt_ptr);\r
(*otherwise*) else\r
begin\r
writeln;\r
writeln('kind = ', ord(kind));\r
fatal_error(this_pass, e_range);\r
end;\r
end; (* case *)\r
\r
if (stck [ last_fct ].kind=csimpleconst) and (stmnt_ptr^.type_mode=stat) then\r
begin\r
IF range_error(stmnt_ptr^.typeref, stck[ last_fct ].ww_value) THEN\r
errormsg(this_pass, e_range);\r
end\r
ELSE\r
\r
BEGIN\r
aux_addr:= stmnt_ptr^.typeref; (* virtual address of defining type *)\r
st_retrieve(aux_addr, stmnt_ptr);\r
if stmnt_ptr^.st_kind=csubrange then\r
BEGIN\r
  store_code_symbol(crangecheck, aux_addr);\r
  IF Computer = RC3502 THEN\r
   BEGIN\r
    IF (stmnt_Ptr^.Subr_Low <> 0) AND\r
       (stmnt_Ptr^.Subr_Addr.AddrType_Mode = ConstAddr) THEN\r
     BEGIN\r
       st_get(stmnt_Ptr^.St_Family_ref,stmnt_Ptr);\r
       stmnt_Ptr^.used := true;\r
     END;\r
   END;\r
END;\r
END; (* if range check *)\r
end; (*  with .... *)\r
\r
END (* end assign *)\r
ELSE\r
BEGIN (* exchange(string) *)\r
\r
(* - check param ... - *)\r
\r
store_code(cexchangestat);\r
\r
dump_expression(e_stck^, max_eval_appetite, current_level, max_var_offset)\r
\r
END;\r
\r
store_code(i_code) (* - cendassign/packedassignment or cendexchange(string) - *)\r
\r
END;\r
\r
(* $SUBTITLE('------------ If Statement') *)\r
(* ----------------------------------------------------------------\r
Pass2Code: 45\r
if statement ::= IFSTAT<expression>IFEXPR\r
<statement><else part>\r
else part ::= ENDIF!ELSE<statement>ENDELSE\r
\r
Pass3Code: 45\r
if statement ::= IFSTAT<expression>IFEXPR\r
<statement><else part>\r
else part ::= ENDIF!ELSE<statement>ENDELSE\r
---------------------------------------------------------------- *)\r
\r
cifstat:\r
BEGIN\r
\r
store_code(i_code);\r
\r
load_expression(i_code, e_stck^, current_level, max_var_offset);\r
\r
dump_expression(e_stck^, max_eval_appetite, current_level, max_var_offset);\r
\r
store_code(i_code) (* - i_code is 'cifexpr' - *)\r
\r
END;\r
\r
(* ... statement ... *)\r
\r
cendif:\r
store_code(i_code);\r
\r
celse:\r
store_code(i_code);\r
\r
(* ... statement ... *)\r
\r
cendelse:\r
store_code(i_code);\r
\r
\r
(* $SUBTITLE('------------ Case Statement') *)\r
(* ----------------------------------------------------------------\r
Pass2Code: 46\r
case statement ::= CASESTAT<expression>CASEEXPR\r
<caseelementlist><endcase>\r
caseelementlist ::= !<caseelementlist>\r
!<caselabellist>\r
CASELIST<statement>CASEELEMENT\r
caselabellist ::= <caselabellist>\r
!<expression><caselabel>\r
caselabel ::= CASELABEL!<expression>CASELABELRANGE\r
endcase  ::= ENDCASE\r
!OTHERWISE CASELIST<statement>CASEELEMENT\r
\r
Pass3Code: 46\r
case statement ::= CASESTAT(SYMBOL)<expression>\r
CASEEXPR<caseelementlist>\r
<endcase>\r
caseelementlist ::= !<caselabellist>CASELIST\r
 <statement>CASEELEMENT\r
caselabellist ::= !<caselabellist>\r
!CASERANGE(SYMBOL)\r
endcase ::= <OTHERWISE<statement>!OTHERWISEEXC>\r
ENDCASE\r
---------------------------------------------------------------- *)\r
\r
ccasestat:\r
BEGIN\r
\r
store_code(i_code);\r
\r
st_declaration(csubrange, anonymousname, stmnt_addr, stmnt_ptr);\r
\r
stmnt_ptr^.subr_high := rtp86_minint; (* mindouble; (* TOG rtp86_minint;*)\r
stmnt_ptr^.subr_low := maxint; (* maxdouble;  (* maxint; *)\r
\r
store_symbol(stmnt_addr);\r
\r
push_stmnt(ccaselabelrange, max_var_offset, stmnt_addr);\r
\r
load_expression(i_code, e_stck^, current_level, max_var_offset);\r
\r
dump_expression(e_stck^, max_eval_appetite, current_level, max_var_offset);\r
\r
push_stmnt(cendcase, max_var_offset, st_nilladdr);\r
\r
store_code(i_code); (* - 'i_code' is 'ccaseexpr' - *)\r
\r
rule_047d1\r
\r
END;\r
\r
ccaselist:;\r
\r
(* ... statement ... *)\r
\r
ccaseelement:\r
BEGIN\r
\r
IF (stmnt_stck[ stmnt_stck_top - 1 ].code <> cotherwise) THEN\r
store_code(i_code);\r
\r
rule_047d1\r
\r
END;\r
\r
cotherwise:\r
BEGIN\r
\r
store_code(i_code);\r
\r
store_symbol(stmnt_stck[ stmnt_stck_top - 1 ].symbol);\r
\r
stmnt_stck[ stmnt_stck_top - 1 ].code := i_code\r
\r
END;\r
\r
cendcase:\r
BEGIN\r
\r
WITH stmnt_stck[ stmnt_stck_top - 1 ] DO\r
IF (code <> cotherwise) THEN\r
BEGIN\r
\r
store_code(cotherwise);\r
\r
store_symbol(symbol);\r
\r
store_code(cotherwiseexc)\r
\r
END;\r
\r
store_code(i_code);\r
\r
pop_stmnt(i_code, max_var_offset, stmnt_addr);\r
\r
WITH stmnt_stck[ stmnt_stck_top - 1 ] DO\r
BEGIN\r
\r
st_get(symbol, stmnt_ptr);\r
\r
(* TOG *)\r
IF (stmnt_ptr^.subr_low<0) or\r
(maxbyte < stmnt_ptr^.subr_low) OR (maxbyte < stmnt_ptr^.subr_high) THEN\r
(* DOUBLE !!! IF (stmnt_ptr^.subr_low<minint) or\r
(maxint < stmnt_ptr^.subr_low) OR (maxint < stmnt_ptr^.subr_high) THEN\r
stmnt_ptr^.st_size := doublesize\r
else *)\r
stmnt_ptr^.st_size := integersize\r
ELSE\r
\r
stmnt_ptr^.st_size := bytesize\r
\r
END;\r
\r
pop_stmnt(i_code, max_var_offset, stmnt_addr)\r
\r
END;\r
\r
(* $SUBTITLE('------------ For Statement')*)\r
(* ----------------------------------------------------------------\r
Pass2Code: 49\r
for statement ::= FORSTAT(SYMBOL)<defining type>\r
<UP(SYMBOL)!DOWN(SYMBOL)>\r
<statement>ENDFOR\r
\r
Pass3Code: 49\r
for statement ::= FORSTAT<address><defining type>\r
<UP!DOWN><statement>\r
ENDFOR(SYMBOL)\r
\r
Symbol Table: 49\r
for statement ::= <defining type>\r
PUT(SYMBOL,LEVEL,OFFSET)\r
---------------------------------------------------------------- *)\r
\r
cforstat:\r
BEGIN\r
\r
store_code(i_code);\r
\r
store_code(caddr);\r
load_store_symbol(stmnt_addr); (* - of step variable - *)\r
\r
elementnumber := elementnumber + 1;\r
\r
st_retrieve(stmnt_addr, stmnt_ptr);\r
\r
push_stmnt(cendfor, max_var_offset, stmnt_addr); (* - save offset - *)\r
\r
rule_defining_type\r
(\r
i_code, code, stmnt_ptr^.typeref,\r
current_level, max_var_offset, address,\r
object_size, max_eval_appetite,\r
object_dynamic\r
);\r
(* - 'i_code' is 'cendsubrange' - *)\r
\r
\r
st_get(stmnt_addr, stmnt_ptr);\r
stmnt_ptr^.var_level := current_level;\r
stmnt_ptr^.st_size := object_size;\r
\r
address\r
(max_var_offset, stmnt_ptr^.var_offset, object_size)\r
\r
\r
END;\r
\r
cup,\r
cdown:\r
BEGIN\r
\r
store_code(i_code);\r
skip_symbol\r
\r
END;\r
\r
(* ... statement ... *)\r
\r
cendfor:\r
BEGIN\r
\r
IF (stmnt_stck[ stmnt_stck_top - 1 ].code = cendsubrange) THEN\r
pop_stmnt(i_code, max_var_offset, stmnt_addr); (* - restore offset - *)\r
\r
pop_stmnt(i_code, max_var_offset, stmnt_addr); (* - restore offset - *)\r
\r
store_code_symbol(i_code, stmnt_addr) (* - step variable identification - *)\r
\r
END;\r
\r
(* $SUBTITLE('------------ Loop Statement')*)\r
(* ----------------------------------------------------------------\r
Pass2Code: 51\r
loop statement ::= LOOPSTAT<statement>ENDLOOP\r
\r
Pass3Code: 51\r
loop statement ::= LOOPSTAT<statement>ENDLOOP\r
\r
---------------------------------------------------------------- *)\r
\r
cloopstat,\r
\r
(* ... statement *)\r
\r
cendloop:\r
store_code(i_code);\r
\r
(* $SUBTITLE('------------ While Statement')*)\r
(* --------------------------------------------------------------------\r
Pass2Code: 52\r
while statement ::= WHILESTAT<expression>WHILEEXPR\r
<statement>ENDWHILE\r
\r
Pass3Code: 52\r
while statement ::= WHILESTAT<expression>WHILEEXPR\r
<statement>ENDWHILE\r
\r
-------------------------------------------------------------------- *)\r
\r
cwhilestat:\r
BEGIN\r
 \r
store_code(i_code); (* - read ahead - *)\r
\r
load_expression(i_code, e_stck^, current_level, max_var_offset);\r
\r
dump_expression(e_stck^, max_eval_appetite, current_level, max_var_offset);\r
\r
store_code(i_code) (* - i_code is 'cwhileexpr' - *)\r
\r
END;\r
\r
\r
(* ... statement ... *)\r
\r
cendwhile:\r
store_code(i_code);\r
\r
(* $SUBTITLE('------------ Repeat Statement')*)\r
(* ----------------------------------------------------------------\r
Pass2Code: 53\r
repeat statement ::= REPEATSTAT<statement>\r
UNTIL<expression>ENDREPEAT\r
\r
Pass3Code: 53\r
repeat statement ::= REPEATSTAT<statement>\r
UNTIL<expression>ENDREPEAT\r
\r
---------------------------------------------------------------- *)\r
\r
crepeatstat:\r
store_code(i_code);\r
\r
(* ... statement ... *)\r
\r
cuntil:\r
BEGIN\r
\r
store_code(i_code);\r
 \r
load_expression(i_code, e_stck^, current_level, max_var_offset);\r
 \r
dump_expression(e_stck^, max_eval_appetite, current_level, max_var_offset);\r
\r
store_code(i_code) (* - i_code is 'cendrepeat' - *)\r
\r
END;\r
\r
(* $SUBTITLE('------------ Procedure Call')*)\r
(* ----------------------------------------------------------------\r
Pass2Code: 54\r
procedure call ::= PROCCALL(SYMBOL)\r
<actual parameters>\r
ENDPROCCALL\r
\r
Pass3Code: 54\r
procedure call ::= PROCCALL<actual parameters>\r
ENDPROCCALL(SYMBOL)\r
---------------------------------------------------------------- *)\r
\r
cproccall:\r
BEGIN\r
std_routine:= std_routine_begin; (* load expression may change the value\r
of this variable in case of a call of NEW which must be followed by some\r
initialization of system component(s) *)\r
 \r
load_expression(i_code, e_stck^, current_level, max_var_offset);\r
dump_expression(e_stck^, max_eval_appetite, current_level, max_var_offset);\r
\r
(* - 'i_code' is 'cendproccall' - *)\r
\r
if std_routine=std_new then\r
with e_stck^ do\r
begin (* see if protected types in the new element *)\r
var_p_index:= 3; (* [1] = new_call, [2] = address *)\r
while stck[ var_p_index ].kind<>cvarparam do\r
var_p_index:= var_p_index+1;\r
\r
(* st_addr of varparam denotes the ctype node of the object to be created by new *)\r
(* tell the result type to pass4 by means of a typeparam-code *)\r
store_code_symbol(ctypeparam, stck[ var_p_index ].st_addr);\r
IF computer = rc5000 then store_code(cAccessCheck);\r
IF computer = rc3502 then store_code(cuparrow);\r
(* code for initializing the system components *)\r
st_retrieve(stck[ var_p_index ].st_addr, stmnt_ptr);\r
init_systemtype(stmnt_ptr^.typeref,2,Max_Eval_appetite,Max_Var_offset);\r
end; (* new with system components *)\r
\r
END;\r
\r
(* $SUBTITLE('------------ Exit Loop/Continue Loop/Exit Statement')*)\r
(* --------------------------------------------------------------------\r
Pass2Code: 57\r
exit loop statement ::= EXITLOOP\r
\r
Pass3Code: 57\r
exit loop statement ::= EXITLOOP\r
- as Pass2Code.\r
\r
-------------------------------------------------------------------\r
Pass2Code: 58\r
continue loop statement ::= CONTLOOP\r
\r
Pass3Code: 58\r
continue loop statement ::= CONTLOOP\r
\r
-------------------------------------------------------------------\r
Pass2Code: 59\r
exit statement ::= EXITSTAT\r
\r
Pass3Code: 59\r
exit statement ::= EXITSTAT\r
\r
---------------------------------------------------------------- *)\r
\r
cexitloop,\r
ccontloop,\r
cexitstat:\r
\r
store_code(i_code);\r
 \r
(* $SUBTITLE('------------ Goto Statement')*)\r
(* ----------------------------------------------------------------\r
Pass2Code: 60\r
goto statement ::= GOTO(SYMBOL)\r
\r
Pass3Code: 60\r
goto statement ::= GOTO(SYMBOL)\r
\r
---------------------------------------------------------------- *)\r
\r
cgoto:\r
BEGIN\r
 \r
store_code(i_code);\r
copy_symbol\r
\r
END;\r
 \r
(* $SUBTITLE('------------ Label Definition')*)\r
(* ----------------------------------------------------------------\r
Pass2Code: 61\r
labelled statement ::= LABELDEF(SYMBOL)<statement>\r
\r
Pass3Code: 61\r
labelled statement ::= LABELDEF(SYMBOL)<statement>\r
\r
Symbol Table: 61\r
labelled statement ::= PUT(SYMBOL,LIX)<statement>\r
---------------------------------------------------------------- *)\r
\r
clabeldef:\r
BEGIN\r
 \r
store_code(i_code);\r
 \r
copy_symbol  \r
\r
END;\r
\r
(* $SUBTITLE('------------ With Statement')*)\r
(* ----------------------------------------------------------------\r
Pass2Code: 62\r
with statement ::= <beginwith><statement><endwith>\r
beginwith ::= beginwith!WITHSTAT<withvar>\r
withvar ::= <variable>WITHSTAT(SYMBOL)\r
<local declarations>\r
local declarations ::= !<defining type>ENDLOCALDECL\r
CHECKSIZE(SYMBOL)\r
endwith ::= <endwith>!ENDWITH\r
\r
Pass3Code: 62,63\r
with statement ::= !WITHSTAT<variable>\r
<defining type>WITHVAR(SYMBOL) CHECKSIZE(SYMBOL)\r
<statement>\r
\r
Symbol Table:\r
-.\r
---------------------------------------------------------------- *)\r
\r
cwithstat:\r
BEGIN\r
\r
store_code(i_code);\r
\r
load_expression(i_code, e_stck^, current_level, max_var_offset);\r
\r
if e_stck^.stck [ e_stck^.top-1 ].kind = csimpleconst then\r
errormsg(this_pass,e_simpleconst)\r
(* tog *)\r
else if e_stck^.stck [ e_stck^.top -1].precode=cpacked\r
then errormsg(this_pass, e_irregular);\r
dump_expression(e_stck^, max_eval_appetite, current_level, max_var_offset);\r
\r
(* - 'i_code' is 'cwithvar' - *)\r
\r
load_symbol(stmnt_addr); (* - of with variable - *)\r
\r
push_stmnt(cendwith, max_var_offset, stmnt_addr); (* - save offset - *)\r
\r
st_retrieve(stmnt_addr, stmnt_ptr);\r
if stmnt_ptr^.st_spix<>anonymousspix then (* renaming WITH statement *)\r
elementnumber:= elementnumber+1;\r
aux_addr := stmnt_ptr^.typeref;\r
\r
if next_code<>cnolocaldecl then (* look ahead *)\r
rule_defining_type\r
(\r
i_code, code, aux_addr,\r
current_level, max_var_offset, address,\r
object_size, max_eval_appetite,\r
object_dynamic\r
);\r
\r
load_code(i_code);\r
(* - 'i_code' is 'cendlocaldecl' or 'cnolocaldecl' - *)\r
\r
store_code(cwithvar);\r
store_symbol(stmnt_addr);\r
\r
st_get(stmnt_addr, stmnt_ptr);\r
stmnt_ptr^.var_level := current_level;\r
stmnt_ptr^.st_size := object_size;\r
stmnt_ptr^.var_indir := true;\r
\r
address\r
(max_var_offset, stmnt_ptr^.var_offset, address_size)\r
\r
END;\r
\r
cendlocaldecl:;\r
\r
cchecksize:\r
BEGIN\r
\r
load_symbol(stmnt_addr); (* - type of original object - *)\r
\r
st_retrieve(stmnt_addr, stmnt_ptr);\r
if (*object_dynamic or (dynamictype in stmnt_ptr^.spec_struct) or*)\r
   (object_size = 0) or (stmnt_ptr^.st_size=0)\r
 (* at least one dynamic sized type *) then\r
store_code_symbol(cchecksize, stmnt_addr)\r
else\r
IF (stmnt_ptr^.st_size < object_size) THEN\r
errormsg(this_pass, e_with_variable)\r
\r
END;\r
\r
(* ... statement ... *)\r
\r
cendwith:\r
pop_stmnt(i_code, max_var_offset, stmnt_addr) (* - restore offset - *);\r
\r
(* $SUBTITLE('------------ Lock/Lock Buffer Statement')*)\r
(* ----------------------------------------------------------------\r
Pass2Code: 64\r
lock statement ::= <beginlock><lockvar><statement>\r
ENDLOCK\r
beginlock ::= LOCKSTAT!LOCKBUFSTAT\r
lockvar ::= <variable>LOCKVAR(SYMBOL)\r
\r
Pass3Code: 64\r
lock statement ::= <variable><beginlock>(SYMBOL) <address> CALLTHUNK(SYMBOL)\r
<statement>ENDLOCK\r
beginlock ::= LOCKSTAT!LOCKBUFSTAT\r
--------------------------------------------------------------------- *)\r
\r
clockstat,\r
clockbufstat: begin\r
lock_kind:= i_code;\r
\r
load_expression(i_code, e_stck^, current_level, max_var_offset);\r
(* - i_code is lockvar *)\r
\r
dump_expression(e_stck^, max_eval_appetite, current_level, max_var_offset);\r
\r
IF (Computer = RC5000) AND\r
   ( max_eval_appetite < 12) THEN\r
  Max_eval_Appetite := 12;\r
load_symbol(stmnt_addr); (* of buffer variable *)\r
elementnumber:= elementnumber+1;\r
\r
push_stmnt(cendlock, max_var_offset, stmnt_addr); (* - save offset - *)\r
\r
st_retrieve(stmnt_addr, stmnt_ptr);\r
aux_addr := stmnt_ptr^.typeref;\r
\r
if next_code=cnolocaldecl then\r
begin\r
load_code(help_code);\r
store_code_symbol(lock_kind, stmnt_addr);\r
store_code(cnolocaldecl);\r
{$IFDEF RTP86}\r
rule_defining_type\r
(\r
i_code, code, aux_addr,\r
current_level, max_var_offset, address,\r
object_size, max_eval_appetite,\r
object_dynamic\r
);\r
{$ELSE}\r
\r
st_Retrieve(stmnt_addr, stmnt_ptr);\r
st_get(stmnt_ptr^.TypeRef,stmnt_ptr);\r
stmnt_ptr^.record_addr.level := current_level;\r
stmnt_ptr^.record_addr.dopeoffset := 0;\r
stmnt_ptr^.record_addr.AddrType_mode := Direct;\r
stmnt_ptr^.spec_struct := [dynamictype];\r
\r
address\r
(max_var_offset, stmnt_ptr^.Record_addr.offset, Integersize)\r
{$ENDIF}\r
end\r
ELSE\r
rule_defining_type\r
(\r
i_code, code, aux_addr,\r
current_level, max_var_offset, address,\r
object_size, max_eval_appetite,\r
object_dynamic\r
);\r
if next_code=cendlocaldecl then begin\r
load_code(i_code);\r
object_size:=0; (* dynamic size !!!!!!! *)\r
store_code_symbol(lock_kind, stmnt_addr);\r
end;\r
\r
st_get(stmnt_addr, stmnt_ptr);\r
stmnt_ptr^.var_level := current_level;\r
stmnt_ptr^.st_size := object_size;\r
stmnt_ptr^.var_indir := true;\r
\r
address\r
(max_var_offset, stmnt_ptr^.var_offset, address_size)\r
\r
end; (* lock/lockbuf *)\r
\r
(* ... statement ... *)\r
\r
cendlock: begin\r
pop_stmnt(i_code, max_var_offset, stmnt_addr); (* - restore offset *)\r
store_code(cendlock);\r
end; (* endlock *)\r
\r
\r
(* $SUBTITLE('------------ Region Statement')*)\r
(* ----------------------------------------------------------------\r
Pass2Code: 65\r
region statement ::= REGIONSTAT(SYMBOL)\r
<statement>ENDREGION\r
\r
Pass3Code: 65\r
region statement ::= REGIONSTAT(SYMBOL)\r
<statement>ENDREGION\r
\r
---------------------------------------------------------------- *)\r
\r
cregionstat:\r
BEGIN\r
store_code(i_code);\r
copy_symbol;\r
END;\r
\r
\r
(* ... statement ... *)\r
\r
cendregion:\r
store_code(i_code);\r
\r
cendblock:\r
end_of_block := true;\r
\r
(* OTHERWISE*) ELSE\r
fatal_error(this_pass, e_token_010)\r
\r
END (* - CASE 'i_code' OF ......... - *)\r
\r
UNTIL end_of_block;\r
\r
(* $SUBTITLE('------------ PROCEDURE rule_block')*)\r
\r
IF ODD(max_block_offset) THEN\r
address(max_block_offset, max_block_offset, 1);\r
\r
max_var_offset := max_block_offset;\r
Max_Block_Offset := Old_Max_Offset;\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
' C.Lvl.', current_level:6,\r
' Max.Offs.', max_offset:6,\r
' Df.C.Sz.', default_create_size:6,\r
' Max.EA', max_eval_appetite:6\r
);\r
(*ENDTEST#*)\r
\r
END (* - PROCEDURE rule_block - *);\r
END.\r
«eof»