|
DataMuseum.dkPresents historical artifacts from the history of: DANOSI |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about DANOSI Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 11823 (0x2e2f)
Types: TextFile
Names: »RULE037.PAS«
└─⟦02956c927⟧ Bits:30010510 DVBS1.SW2114.src.2.14-1 SW2114 REAL #1/4 TIME PASCAL SOURCE REL 2.14
└─⟦this⟧ »RTP\RULE037.PAS«
└─⟦4f587ad96⟧ Bits:30010518 DVBS1.SW2114.src.2.7-1 SW2114 1/4 Real Time Pascal 2.7 92.06.16
└─⟦this⟧ »RTP\RULE037.PAS«
└─⟦a2a9e188c⟧ Bits:30010526 DVBS1.SW2114.src.2.6-4 RTP Compiler Source SW2104+SW2114 Disk 1 92.02.03 HEJ HHA
└─⟦this⟧ »RTP\RULE037.PAS«
└─⟦b607d6035⟧ Bits:30010532 RTP compiler Source 1 2.14 26/9(?)-92 DVBS1.SW2114.src.2.14-8
└─⟦this⟧ »RULE037.PAS«
└─⟦fd2665794⟧ Bits:30010523 DVBS1.SW2114.src.2.6-1 RTP compiler source SW2104+SW2114 Disk#1 30/1-92 HHA
└─⟦this⟧ »RTP\RULE037.PAS«
{$O+,F+}\r
unit rule037;\r
interface\r
uses pscplm,sthunit,sthcom,sthp34,mpaunit,p3cmmn;\r
PROCEDURE init_systemtype\r
(\r
addr : st_address;\r
mode : integer;\r
Var evaluation_app : word;\r
VAR Current_offset : word\r
);\r
\r
PROCEDURE rule_variable_declaration\r
(\r
VAR\r
i_code : codes;\r
current_level : WORD;\r
VAR\r
current_offset ,\r
evaluation_appetite : WORD;\r
address : addressprocedure\r
)\r
;\r
\r
implementation\r
uses p3math,p3rw,rule018,rule066;\r
\r
PROCEDURE init_systemtype\r
(\r
addr : st_address;\r
mode : integer;\r
Var evaluation_app : word;\r
VAR Current_offset : word\r
);\r
\r
VAR\r
st_ptr : st_elemptr;\r
hlp_addr : st_address;\r
hlp_kind : codes;\r
initsystem_types : st_protect_type;\r
app : word;\r
\r
(* $SUBTITLE('------------ PROCEDURE component_init') *)\r
PROCEDURE component_init(type_addr:st_address);\r
VAR\r
st_ptr ,\r
st_hlpptr : st_elemptr;\r
rec_field_addr : st_address;\r
\r
BEGIN\r
(* type_addr points to a node (ctype-node) which is either a protected type or\r
an array or a record containing a protected component *)\r
(* pass3code: 37.3, 38.3\r
component init\r
*)\r
if equal_addr(type_addr, st_mailboxtype_addr) then\r
store_code(cmailbox)\r
else\r
if equal_addr(type_addr, st_pooltype_addr) then\r
store_code(cpool)\r
else\r
if equal_addr(type_addr, st_chaintype_addr) then\r
store_code(cchain)\r
else\r
if equal_addr(type_addr, st_processtype_addr) then\r
store_code(cprocess)\r
else\r
if equal_addr(type_addr, st_porttype_addr) then\r
store_code(cport)\r
else\r
if equal_addr(type_addr, st_referencetype_addr) then begin\r
if mode=2 then store_code(cnewtype);\r
store_code(creference)\r
end else\r
begin\r
st_retrievetype(type_addr, st_ptr);\r
\r
WITH st_ptr^ DO\r
CASE st_kind OF\r
\r
cpointertype:\r
if (mode<>1) OR (Computer = RC5000) then store_code(st_kind);\r
\r
carraytype:\r
BEGIN\r
\r
store_code(carrayinit);\r
store_symbol(type_addr);\r
IF Computer = RC3502 THEN\r
BEGIN\r
Store_arg_1(Current_offset);\r
Current_offset := Current_offset + wordsize;\r
Max_Block_Offset := Current_offset;\r
END;\r
init_systemtype(typeref, mode, app,Current_offset);\r
(* points to ctype node of element type, which\r
contains protected component *)\r
If Computer = RC5000 THEN App := App + 8;\r
\r
store_code(cendarrayinit);\r
store_symbol(type_addr);\r
IF Computer = RC3502 THEN\r
BEGIN\r
Current_offset := Current_offset - wordsize;\r
END;\r
\r
END;\r
\r
crecordtype:\r
BEGIN\r
\r
store_code(crecordinit);\r
rec_field_addr:= listref; (* first field in record *)\r
WHILE NOT equal_addr(rec_field_addr,st_stopaddr) DO\r
BEGIN\r
init_systemtype(rec_field_addr, mode, app,Current_offset);\r
(* points to node with kind crecfield*)\r
st_retrieve(rec_field_addr,st_hlpptr);\r
rec_field_addr:= st_hlpptr^.listref (* next field or stopaddr*)\r
\r
END;\r
\r
IF Computer = RC5000 THEN App := App + 4;\r
\r
store_code(cendrecordinit);\r
store_symbol(type_addr);\r
\r
END;\r
\r
cprogram: begin\r
store_code(cprogram);\r
store_symbol(type_addr);\r
end;\r
\r
(*OTHERWISE*) ELSE\r
fatal_error(this_pass,150) (* illegal code in component_init*)\r
END;\r
end; (* pointer or structure *)\r
\r
END; (*component_init*)\r
\r
BEGIN\r
(* init_systemtype *)\r
(* init_systemtype is called first time when endvar, endshared or init is\r
met in pass2code. IF type is not protected nor contains protected\r
components init_systemtype does nothing.\r
IF type is protected init_systemtype dumps initcodes and calls component\r
init.\r
It is again called from component init, IF an array or a record is met in\r
a component.These recursive calls traverses the whole type definition of\r
the variable or shared variable in question and initiates the systemtypes\r
which may occour.\r
Addr points to a node with kind cvar/cshared (first time) or crecfield\r
(IF record is met in component init) or ctype (element type of array with\r
protected component *)\r
\r
app := 0;\r
\r
if (mode=1) AND (Computer <> RC5000) then\r
BEGIN\r
initsystem_types:= protected_types - [ pointertype, mailboxpointer ]\r
END ELSE initsystem_types:= protected_types;\r
\r
hlp_addr:= addr;\r
st_retrieve(addr, st_ptr);\r
\r
WITH st_ptr^ DO\r
CASE st_kind OF\r
\r
cvar,\r
cshared,\r
crecfield:\r
BEGIN\r
\r
hlp_kind:= st_kind;\r
addr:= typeref;\r
st_retrieve(addr, st_ptr) (* points to ctype node of type of var or shared or\r
ctype node of type of field *)\r
END;\r
\r
ctype:\r
hlp_kind:= ctype; (*array: point already to ctype node of element type*)\r
\r
(*OTHERWISE*) ELSE\r
fatal_error(this_pass, 151)\r
(* mismatch in symboltable:occoured in system init at mark 1 *)\r
END;\r
\r
WITH st_ptr^ DO\r
BEGIN\r
\r
IF (st_kind <> ctype) THEN\r
fatal_error(this_pass,152) (* mark 2 *); (* kind must be ctype *)\r
\r
IF initsystem_types*spec_struct <> [] THEN\r
CASE hlp_kind OF\r
\r
cshared,\r
cvar:\r
(* this_passcode: 37.2,38.2 system init *)\r
BEGIN\r
\r
store_code(cinit);\r
store_code(caddr);\r
store_symbol(hlp_addr); (* cvar/cshared node *)\r
\r
component_init(addr) (* ctype node*)\r
\r
END;\r
\r
crecfield:\r
(* pass3code: part of 37.3,38.3\r
component init:\r
FIELDINIT(SYMBOL) ----> component init\r
*)\r
BEGIN\r
\r
store_code(cfieldinit);\r
store_symbol(hlp_addr); (* crecfield node*)\r
\r
component_init(addr) (* ctype node*)\r
\r
END;\r
\r
ctype:\r
component_init(addr); (* ctype node of array element type *)\r
\r
(*OTHERWISE*) ELSE\r
fatal_error(this_pass, 153) (*mark 3*)\r
END;\r
\r
END; (* with st_ptr *)\r
\r
IF App > Evaluation_app THEN Evaluation_app := app;\r
\r
END; (* procedure init_systemtype *)\r
\r
(* $SUBTITLE('------------ PROCEDURE rule_variable_declaration')*)\r
PROCEDURE rule_variable_declaration\r
( (* Call Return *)\r
VAR\r
i_code : codes; (* *)\r
current_level : WORD; (* *)\r
VAR\r
current_offset , (* *)\r
evaluation_appetite : WORD; (* *)\r
address : addressprocedure(* *)\r
);\r
\r
(* ------------------------------------------------------------------------\r
Pass2Code: 37\r
variable declaration ::= VARDECL(SYMBOL)<defining type><endvar>\r
endvar ::= ENDVAR!<INIT(SYMBOL)<expression>ENDINIT>\r
\r
Pass3Code: 37\r
variable declaration ::= <defining type><allocdynvar><init>\r
allocdynvar ::= !<allocdynvar>\r
!ALLOCDYNVAR(OFFSET,SYMBOL)\r
\r
---------------------------------------------------------------------------\r
Pass2Code: 38\r
shared declaration ::= SHAREDDECL(SYMBOL)<defining type><endshared>\r
endshared ::= ENDSHARED!<INIT(SYMBOL)<expression>ENDINIT>\r
\r
Pass3Code: 38\r
shared declaration ::= <defining type><alloc dyn shared><init>\r
alloc dyn shared ::= !ALLOCDYNSHARED(OFFSET,SYMBOL)\r
\r
---------------------------------------------------------------------------\r
init ::= !<system type init>\r
!<initialize>\r
initialize ::= INIT<variable><expression>ENDINIT\r
\r
Symbol Table:\r
-.\r
\r
===========================================================================\r
\r
Error Messages and Warnings:\r
fatal_error(this_pass, 150)\r
fatal_error(this_pass, 151)\r
fatal_error(this_pass, 152)\r
fatal_error(this_pass, 153)\r
fatal_error(this_pass, 154)\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
(*#BEGINTEST\r
rule_version = 005;\r
this_rule = 037;\r
(*ENDTEST#*)\r
code = true;\r
\r
VAR\r
aux_symbol,\r
st_init_symbol ,\r
st_var_symbol : st_address;\r
\r
st_var_ptr : st_elemptr;\r
\r
object_size : WORD;\r
object_dynamic: boolean;\r
\r
object_kind: codes; (* var or shared *)\r
\r
alloc_dyn,\r
init_expression : BOOLEAN;\r
\r
(*#BEGINTEST\r
rule_test : BOOLEAN;\r
(*ENDTEST#*)\r
\r
(* $SUBTITLE('------------ FUNCTION protected')*)\r
FUNCTION protected\r
(\r
spec_struct : st_protect_type\r
) : BOOLEAN;\r
BEGIN\r
\r
protected:= protected_types * spec_struct <> []\r
\r
END (* function protected *);\r
\r
\r
(* $SUBTITLE('------------ PROCEDURE rule_variable_declaration') *)\r
BEGIN\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
'/ ', WORD(i_code):3\r
);\r
(*ENDTEST#*)\r
\r
load_symbol(st_var_symbol);\r
\r
object_kind:= i_code;\r
\r
st_retrieve(st_var_symbol, st_var_ptr);\r
\r
rule_defining_type\r
(\r
i_code, code, st_var_ptr^.typeref,\r
current_level, current_offset, address,\r
object_size, evaluation_appetite,\r
object_dynamic\r
);\r
\r
alloc_dyn:= object_dynamic;\r
(* TOG alloc_dyn := (object_size=0); *)\r
\r
load_code(i_code);\r
(* - 'i_code' is 'cendvar', 'cendshared' or 'cinit'. ??? *)\r
\r
if i_code=cinit then\r
BEGIN\r
load_symbol(st_init_symbol);\r
load_expression(i_code, e_stck^, current_level, current_offset);\r
init_expression:= true;\r
(* - 'i_code' is endinit/endassignstring/endassignset *)\r
IF computer <> RC3502 THEN\r
if i_code=cendassignset then\r
with e_stck^, stck[ last_fct ] do\r
stck[ former_fct ].precode:= cpreset;\r
END\r
else\r
init_expression:= false;\r
\r
if object_kind=cshareddecl then\r
object_size:= object_size+shared_var_size\r
else if alloc_dyn(* TOG object_dynamic or (object_size=0) *) then\r
(* dynamic sized object, reserve room for a pointer to the object;\r
for shared objects the shared header pointer is used, i.e. allocation of\r
an extra pointer is not necessary *)\r
object_size:= address_size;\r
\r
REPEAT\r
\r
st_get(st_var_symbol, st_var_ptr);\r
\r
st_var_ptr^.var_level:= current_level;\r
st_var_ptr^.st_size:= object_size;\r
IF (Computer = RC3502) AND ( ( (st_var_Ptr^.spec_Struct * ShieldType35 ) <> []) OR\r
( object_kind = cshareddecl) ) THEN\r
Current_offset := Current_Offset + ord(odd(Current_Offset));\r
address(current_offset, st_var_ptr^.var_offset, object_size);\r
\r
if alloc_dyn then\r
begin\r
if object_kind=cvardecl then\r
begin\r
st_var_ptr^.var_indir:= true;\r
store_code_1(callocdynvar, st_var_ptr^.var_offset);\r
end\r
else\r
store_code(callocdynshared);\r
store_symbol(st_var_ptr^.typeref);\r
end; (* allocate dyn object *)\r
\r
(* If shared then initialize shared*)\r
\r
IF (st_var_ptr^.st_kind = cshared) THEN\r
BEGIN\r
\r
store_code(cinit);\r
store_code(caddr);\r
store_symbol(st_var_symbol); (* addr of shared node *)\r
\r
st_retrieve(st_var_ptr^.typeref, st_var_ptr); (* ctype node of type of shared object *)\r
\r
WITH st_var_ptr^ DO\r
BEGIN\r
\r
IF (st_kind <> ctype) THEN\r
fatal_error(pass3, 154);\r
(*mismatch in symboltable. occoured when init shared variable*)\r
\r
IF (type_mode = dyn) THEN\r
store_code(cinitdynshar)\r
ELSE\r
\r
store_code(cinitshar)\r
\r
END;\r
st_retrieve(st_var_symbol, st_var_ptr); (* reestablish st state *)\r
END;\r
\r
IF init_expression THEN\r
BEGIN\r
\r
store_code(cinit);\r
\r
store_code_symbol(caddr, st_var_symbol);\r
\r
dump_expression(e_stck^, evaluation_appetite, current_level, current_offset);\r
\r
if range_check then\r
begin\r
st_retrieve(st_var_ptr^.typeref, st_var_ptr);\r
if (e_stck^.stck[ e_stck^.last_fct ].kind=csimpleconst) and\r
(st_var_ptr^.type_mode=stat) then\r
begin\r
if range_error(st_var_ptr^.typeref, e_stck^.stck[ e_stck^.last_fct ].ww_value) then\r
errormsg(this_pass, e_range);\r
end\r
else\r
begin\r
aux_symbol:= st_var_ptr^.typeref; (* defining type address *)\r
st_retrieve(aux_symbol, st_var_ptr);\r
if st_var_ptr^.st_kind=csubrange then\r
store_code_symbol(crangecheck, aux_symbol);\r
end;\r
\r
st_retrieve(st_var_symbol, st_var_ptr); (* reestablish st state *)\r
end; (* if rangecheck *)\r
\r
store_code(i_code); (* endinit/endassignstring/endassignset *)\r
\r
END;\r
\r
(*IF protected component in type THEN initialize component*)\r
\r
if init_expression\r
then init_systemtype(st_var_symbol, 1,evaluation_appetite,Current_offset)\r
else init_systemtype(st_var_symbol, 0,evaluation_appetite,Current_offset);\r
(*addr of var or shared var*)\r
\r
\r
st_var_symbol:= st_var_ptr^.listref\r
\r
UNTIL st_var_ptr^.st_listend;\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
);\r
(*ENDTEST#*)\r
\r
END (* - PROCEDURE rule_variable_declaration - *);\r
END.\r
«eof»