|
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: 39678 (0x9afe)
Types: TextFile
Names: »RULE018.PAS«
└─⟦4f587ad96⟧ Bits:30010518 DVBS1.SW2114.src.2.7-1 SW2114 1/4 Real Time Pascal 2.7 92.06.16
└─⟦this⟧ »RTP\RULE018.PAS«
└─⟦a2a9e188c⟧ Bits:30010526 DVBS1.SW2114.src.2.6-4 RTP Compiler Source SW2104+SW2114 Disk 1 92.02.03 HEJ HHA
└─⟦this⟧ »RTP\RULE018.PAS«
└─⟦fd2665794⟧ Bits:30010523 DVBS1.SW2114.src.2.6-1 RTP compiler source SW2104+SW2114 Disk#1 30/1-92 HHA
└─⟦this⟧ »RTP\RULE018.PAS«
{$O+,F+}\r
unit rule018;\r
interface\r
uses pscplm,sthunit,sthcom,sthp34,mpaunit,rtp86mpa,p3cmmn,p3rw,p3math,p3addr;\r
\r
\r
PROCEDURE rule_defining_type\r
(\r
VAR\r
i_code: codes;\r
emit_code: BOOLEAN;\r
type_symbol: st_address;\r
current_level: WORD;\r
VAR\r
current_offset: WORD;\r
address : addressprocedure;\r
VAR\r
type_size,\r
evaluation_appetite: WORD;\r
var type_dynamic: boolean\r
);\r
\r
\r
\r
Implementation\r
uses rule004,rule010,rule066,rule078;\r
\r
\r
function rtp86_bitsize(lower, upper: word): word; forward;\r
\r
\r
\r
\r
PROCEDURE rule_defining_type\r
(\r
VAR\r
i_code : codes;\r
emit_code : BOOLEAN;\r
type_symbol : st_address; (* ST address of 'ctype'-node*)\r
current_level : WORD;\r
VAR\r
current_offset : WORD;\r
address : addressprocedure;\r
VAR\r
type_size,\r
evaluation_appetite: WORD;\r
var type_dynamic: boolean\r
);\r
\r
(* ------------------------------------------------------------------------\r
Pass2Code: 18\r
defining type ::= !TYPEID(SYMBOL)<!<actual parameters>>ENDTYPE\r
!POINTERTYPE(SYMBOL)<defining type>ENDPOINTER\r
!SUBRANGETYPE(SYMBOL)<expression><expression>ENDSUBRANGE\r
!ARRAYTYPE(SYMBOL)<defining type><defining type>ENDARRAY\r
!RECORDTYPE(SYMBOL)<recfield declaration>ENDRECORD\r
!SETTYPE(SYMBOL)<defining type>ENDSET\r
recfield declaration ::= <recfield declaration>\r
!RECFIELD(SYMBOL)<defining type>ENDFIELDLIST\r
\r
Pass3Code: 18\r
-.\r
\r
Symbol Table:\r
-.\r
\r
===========================================================================\r
\r
Error Messages and Warnings:\r
e_subrange\r
e_array_size\r
e_record_size\r
e_record_level\r
e_token_018\r
e_st_inconsistency\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
If the Defining Type node is updated (size a.s.o.), it is assured in\r
this module, that the corresponding 'ctype' node receives the same\r
values.\r
The local variables larger than 16 bits have been arranged on\r
even addresses.\r
-.\r
Outstanding:\r
-.\r
------------------------------------------------------------------------ *)\r
\r
(*#BEGINTEST\r
CONST\r
rule_version = 005;\r
this_rule = 018;\r
(*ENDTEST#*)\r
\r
VAR\r
dope_symbol, (* address of symbol table node which denotes a dope descriptor *)\r
integer_addr, (* used during production of code for dope descriptors *)\r
index_symbol,\r
element_symbol,\r
st_field_symbol,\r
last_rec_field,\r
field_type_symbol,\r
def_type_symbol : st_address;\r
\r
st_ptr : st_elemptr;\r
\r
range_spann : LONGINT;\r
\r
packed_bit_offset,\r
byte_offset,\r
bit_quantity,\r
scalar_number,\r
\r
lower,ilower,\r
upper,iupper,\r
\r
element_size,\r
rec_descr_offset,\r
next_byte_offset,\r
descriptor_size,\r
field_size,\r
type_param_size,\r
paramsize: WORD;\r
\r
LongLower,LongUpper,LongElement_Size,LongType_Size : LongInt;\r
dyn_sub_limit,\r
next_bit_offset : BYTE;\r
\r
mode_of_address: st_addrtype;\r
mode_of_type: st_modes;\r
\r
local_type_dynamic,\r
packed_structure,\r
packed3502structure,\r
lock_var,\r
FieldPacked,\r
step_variable,\r
end_of_list,\r
defining_type ,\r
allign,AllignRecordLength : BOOLEAN;\r
local_e_stck: expr_stack_ptr; (* for recursive call of load expression *)\r
\r
procedure traverse_type_binding(start_symbol: st_address; var type_size: word;\r
descr_offset: word; mode_of_address: st_addrtype);\r
var\r
st_ptr: st_elemptr;\r
dope_offset,\r
f_offset,\r
f_bit_offset,\r
packed_elem_size,\r
size_of_type: word;\r
pack_info: packedtype;\r
f_mode: st_modes;\r
f_packed : packedtype;\r
field_symbol,\r
family_symbol,\r
index_type, elem_type: st_address;\r
type_kind: codes;\r
local_mode_of_type: st_modes;\r
type_dynamic: boolean;\r
begin\r
st_retrieve(start_symbol, st_ptr);\r
case st_ptr^.st_kind of\r
csubrange: begin\r
st_retrieve(st_ptr^.st_family_ref, st_ptr);\r
dope_offset:= st_ptr^.subr_addr.dopeoffset;\r
st_get(start_symbol, st_ptr);\r
with st_ptr^ do\r
begin\r
st_size:= wordsize;\r
subr_mode:= dyn;\r
(*spec_struct:= spec_struct * [ dynamictype ]; *)\r
with subr_addr do\r
begin\r
addrtype_mode:= mode_of_address;\r
level:= current_level;\r
if (computer = RC3502) and fam_type_declaration THEN\r
dopeoffset := descr_offset + dope_offset - 8;\r
if mode_of_address=direct then\r
offset:= descr_offset+dope_offset\r
else\r
if fam_type_declaration then\r
begin\r
offset:= dope_addr_offset;\r
dopeoffset:= descr_offset+dope_offset;\r
\r
end\r
else\r
if mode_of_Address=ConstAddr THEN\r
BEGIN\r
subr_mode:= stat;\r
subr_low := LongLower;\r
Subr_high := LongUpper;\r
Addr_Label := Dope_Symbol;\r
dopeoffset:= dope_offset;\r
END\r
ELSE\r
begin\r
offset:= descr_offset;\r
dopeoffset:= dope_offset;\r
end;\r
end; (* with subr addr *)\r
end; (* with st ptr *)\r
type_size:= type_size+wordsize;\r
end; (* subrange *)\r
\r
cscalar: ;\r
\r
ctype: if st_ptr^.st_node_copy then\r
begin\r
elem_type:= st_ptr^.typeref; (* the copied defining type node *)\r
st_retrieve(st_ptr^.st_family_ref, st_ptr);\r
with st_ptr^ do\r
begin (* get some information from the original node *)\r
type_dynamic:= dynamictype in st_ptr^.spec_struct;\r
size_of_type:= st_size;\r
dope_offset:= type_address.dopeoffset;\r
family_symbol:= typeref;\r
end; (* with *)\r
if st_ptr^.type_mode=stat then\r
begin\r
st_retrieve(family_symbol, st_ptr); (* defining type *)\r
type_kind:= st_ptr^.st_kind;\r
size_of_type:= st_ptr^.st_size; (* typenode contains dope vector size *)\r
type_size:= type_size+size_of_type;\r
st_get(start_symbol, st_ptr);\r
with st_ptr^ do\r
begin\r
if type_dynamic then spec_struct:=spec_struct + [dynamictype];\r
typeref:= family_symbol;\r
st_size:= size_of_type;\r
end; (* with *)\r
if (type_kind=crecordtype) or (type_kind=cpointertype) or\r
(type_kind=carraytype) or (type_kind=csettype) then\r
begin\r
size_of_type:=0;\r
traverse_type_binding(elem_type, size_of_type, descr_offset, mode_of_address);\r
end;\r
end (* static sub type *)\r
else\r
begin\r
size_of_type:= 0;\r
traverse_type_binding(elem_type, size_of_type, descr_offset, mode_of_address);\r
st_get(start_symbol, st_ptr);\r
with st_ptr^ do\r
begin\r
st_size:= size_of_type;\r
type_mode:= dyn;\r
if type_dynamic then spec_struct:= spec_struct + [ dynamictype ];\r
type_size:= type_size+size_of_type;\r
type_paramsize:= 0;\r
with type_address do\r
begin\r
addrtype_mode:= mode_of_address;\r
level:= current_level;\r
(*#BEGINTEST\r
if rule_test then\r
writeln(testoutput,'***1*** travel: ',descr_offset:6,dope_offset:6);\r
(*ENDTEST#*)\r
\r
if (computer = RC3502) and fam_type_declaration THEN\r
dopeoffset := descr_offset + dope_offset - 8;\r
if mode_of_address=direct then\r
offset:= descr_offset+dope_offset\r
else\r
if fam_type_declaration then\r
begin\r
offset:= dope_addr_offset;\r
dopeoffset:= descr_offset+dope_offset;\r
end\r
else\r
if mode_of_Address=ConstAddr THEN\r
BEGIN\r
type_size := LongType_size;\r
st_size:= LongType_Size;\r
type_mode:= Stat;\r
spec_struct:= spec_struct - [ dynamictype ];\r
Addr_Label := Dope_Symbol;\r
dopeoffset:= dope_offset;\r
END\r
ELSE\r
begin\r
offset:= descr_offset;\r
dopeoffset:= dope_offset;\r
end;\r
(*#BEGINTEST\r
if rule_test then writeln(testoutput,'***2*** travel');\r
(*ENDTEST#*)\r
end; (* with type address *)\r
end; (* with st_ptr *)\r
end; (* update of dynamic node copies *)\r
end (* node copy *)\r
else\r
type_size:= st_ptr^.st_size;\r
(* end of ctype *)\r
\r
cpointertype: begin\r
size_of_type:= 0;\r
traverse_type_binding(st_ptr^.typeref, size_of_type, descr_offset, mode_of_address);\r
st_get(start_symbol, st_ptr);\r
st_ptr^.st_size:= pointersize;\r
type_size:= pointersize;\r
end; (* cpointertype *)\r
\r
\r
crecordtype: begin\r
st_retrieve(st_ptr^.st_family_ref, st_ptr);\r
dope_offset:= st_ptr^.record_addr.dopeoffset;\r
size_of_type:= st_ptr^.st_size;\r
type_size:=type_size + size_of_type;\r
type_dynamic:= dynamictype in st_ptr^.spec_struct;\r
st_get(start_symbol, st_ptr);\r
with st_ptr^ do\r
begin\r
st_size:= size_of_type;\r
if type_dynamic then spec_struct:= spec_struct + [dynamictype];\r
with record_addr do\r
begin\r
addrtype_mode:= mode_of_address;\r
level:= current_level;\r
if (computer = RC3502) and fam_type_declaration THEN\r
dopeoffset := descr_offset + dope_offset - 8;\r
if mode_of_address=direct then\r
offset:= descr_offset+dope_offset\r
else\r
if fam_type_declaration then\r
begin\r
offset:= dope_addr_offset;\r
dopeoffset:= descr_offset+dope_offset;\r
end\r
else\r
begin\r
offset:= descr_offset;\r
dopeoffset:= dope_offset;\r
end;\r
end; (* with record addr *)\r
field_symbol:= listref;\r
end; (* with st ptr *)\r
\r
(* update the field nodes *)\r
repeat\r
st_retrieve(field_symbol, st_ptr);\r
elem_type:= st_ptr^.typeref;\r
st_retrieve(st_ptr^.st_family_ref, st_ptr);\r
with st_ptr^ do\r
begin\r
f_mode:= field_mode;\r
f_bit_offset:= bit_offset;\r
f_packed := st_packedFiel;\r
packed_elem_size:= bit_size;\r
if f_mode=stat then\r
f_offset:= field_offset\r
else\r
dope_offset:= field_addr.dopeoffset;\r
end; (* with family node *)\r
\r
size_of_type:= 0;\r
traverse_type_binding(elem_type, size_of_type, descr_offset, mode_of_address);\r
\r
st_get(field_symbol, st_ptr);\r
with st_ptr^ do\r
begin\r
field_mode:= f_mode;\r
bit_offset:= f_bit_offset;\r
bit_size:= packed_elem_size;\r
st_packedFiel := f_packed;\r
if f_mode=stat then\r
begin\r
st_size:= size_of_type;\r
field_offset:= f_offset;\r
end\r
else\r
begin\r
st_size:= 0;\r
with field_addr do\r
begin\r
addrtype_mode:= mode_of_address;\r
level:= current_level;\r
if (computer = RC3502) and fam_type_declaration THEN\r
dopeoffset := descr_offset + dope_offset - 8;\r
if mode_of_address=direct then\r
offset:= descr_offset+dope_offset\r
else\r
if fam_type_declaration then\r
begin\r
offset:= dope_addr_offset;\r
dopeoffset:= descr_offset+dope_offset;\r
end\r
else\r
begin\r
offset:= descr_offset;\r
dopeoffset:= dope_offset;\r
end;\r
end; (* with field addr *)\r
end; (* dynamic field *)\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 traverse field binding(',\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
end; (* with st ptr *)\r
field_symbol:= st_ptr^.listref; (* note: test output mode may have changed st_ptr *)\r
\r
until equal_addr(field_symbol, st_stopaddr);\r
\r
end; (* recordtype *)\r
\r
\r
carraytype: begin\r
elem_type:= st_ptr^.typeref;\r
index_type:= st_ptr^.itype;\r
st_retrieve(st_ptr^.st_family_ref, st_ptr);\r
with st_ptr^ do\r
begin\r
type_size:= st_size;\r
type_dynamic:= dynamictype in spec_struct;\r
dope_offset:= array_addr.dopeoffset;\r
pack_info:= st_packed;\r
packed_elem_size:= ebit_size;\r
end; (* with *)\r
size_of_type:= 0;\r
traverse_type_binding(index_type, size_of_type, descr_offset, mode_of_address);\r
size_of_type:= 0;\r
traverse_type_binding(elem_type, size_of_type, descr_offset, mode_of_address);\r
st_get(start_symbol, st_ptr);\r
with st_ptr^ do\r
begin\r
if type_dynamic then spec_struct:=spec_struct+[dynamictype];\r
st_size:= type_size (* TOG 0*);\r
st_packed:= pack_info;\r
ebit_size:= packed_elem_size;\r
with array_addr do\r
begin\r
addrtype_mode:= mode_of_address;\r
level:= current_level;\r
if (computer = RC3502) and fam_type_declaration THEN\r
dopeoffset := descr_offset + dope_offset - 8;\r
if mode_of_address=direct then\r
offset:= descr_offset+dope_offset\r
else\r
if fam_type_declaration then\r
begin\r
offset:= dope_addr_offset;\r
dopeoffset:= descr_offset+dope_offset;\r
end\r
else\r
if mode_of_Address=ConstAddr THEN\r
BEGIN\r
type_size := LongType_Size;\r
st_size:= LongType_Size;\r
type_mode:= Stat;\r
spec_struct:= spec_struct - [ dynamictype ];\r
Addr_Label := Dope_Symbol;\r
dopeoffset:= dope_offset;\r
END\r
ELSE\r
begin\r
offset:= descr_offset;\r
dopeoffset:= dope_offset;\r
end;\r
end; (* with array addr *)\r
end; (* with st ptr *)\r
(* TOG type_size:= 0; *)\r
end; (* carraytype *)\r
\r
\r
csettype: begin\r
st_retrieve(st_ptr^.st_family_ref, st_ptr);\r
size_of_type:= st_ptr^.st_size;\r
type_size:= type_size+size_of_type;\r
st_get(start_symbol, st_ptr);\r
if dynamictype in st_ptr^.spec_struct then\r
st_ptr^.spec_struct:= st_ptr^.spec_struct + [dynamictype];\r
st_ptr^.st_size:=size_of_type;\r
end;\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 traverse type binding(',\r
start_symbol.va_high:6, ', ', start_symbol.va_low:6, ' )' );\r
st_retrieve(start_symbol, st_ptr);\r
teststh:= false;\r
end;\r
(* ENDTEST# *)\r
\r
end; (* traverse type binding *)\r
\r
\r
\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
step_variable := (i_code = cforstat);\r
lock_var:= i_code=clockvar;\r
\r
st_retrieve(type_symbol, st_ptr); (* ctype node *)\r
\r
WITH st_ptr^ DO\r
BEGIN\r
type_size := st_size;\r
mode_of_type:= type_mode;\r
if mode_of_type=fam then\r
type_param_size:= type_paramsize;\r
END;\r
\r
(*tog* ) if mode_of_type<>dyn then mode_of_type:= stat; (**)\r
defining_type := true;\r
type_dynamic:= false;\r
\r
repeat\r
\r
load_code(i_code);\r
\r
CASE i_code OF\r
\r
(* $SUBTITLE('------------ Scalar Definition')*)\r
cscalartype:\r
BEGIN\r
\r
load_symbol(def_type_symbol);\r
\r
st_get(def_type_symbol, st_ptr);\r
\r
\r
IF ((maxbyte + 1) < st_ptr^.scalar_no) THEN\r
type_size := integersize\r
ELSE\r
\r
type_size := bytesize;\r
\r
st_ptr^.st_size := type_size;\r
\r
FOR scalar_number := 1 TO st_ptr^.scalar_no DO\r
BEGIN\r
\r
st_get(st_ptr^.listref, st_ptr);\r
\r
st_ptr^.st_size := type_size\r
\r
END;\r
\r
defining_type := false;\r
END;\r
\r
(* $SUBTITLE('------------ Parameterized Type Binding')*)\r
ctypeid:\r
BEGIN\r
\r
load_symbol(def_type_symbol);\r
elementnumber:= elementnumber+1;\r
new(local_e_stck (*, 1*));\r
local_e_stck^.stack_size:= 100;\r
\r
load_expression(i_code, local_e_stck^, current_level, current_offset);\r
(*- i_code=cendtype -*)\r
\r
st_retrieve(type_symbol, st_ptr);\r
dope_symbol:= st_ptr^.st_family_ref;\r
st_retrieve(dope_symbol, st_ptr);\r
descriptor_size:= st_ptr^.st_size;\r
paramsize := st_ptr^.type_address.dopeoffset;\r
type_dynamic:= dynamictype in st_ptr^.spec_struct;\r
\r
st_get(type_symbol, st_ptr);\r
if type_dynamic then st_ptr^.spec_struct:= st_ptr^.spec_struct + [dynamictype];\r
with st_ptr^.type_address do\r
begin\r
level:= current_level;\r
if (local_e_stck^.last_fct=1) (* empty actual parameter list, i.e. family type formal param *)\r
and not lock_var then\r
begin\r
mode_of_address:= indirect;\r
(* change current level to be routine level *)\r
current_level:= rtp86_wadd(current_level, 1); (* current_level is surrounding level *)\r
level:= current_level;\r
offset:= 0; (* correct offset is defined by rule formal parameter *)\r
i_code:= ctypeid; (* return information for rule formal parameter *)\r
dopeoffset:= 0;\r
end\r
else\r
if fam_type_declaration then\r
begin\r
IF Computer = RC3502 THEN\r
BEGIN\r
mode_of_address := direct;\r
offset := Current_offset + 8;\r
END\r
ELSE\r
BEGIN\r
mode_of_address:= indirect;\r
offset:= dope_addr_offset;\r
END;\r
dopeoffset:= current_offset;\r
current_offset:= current_offset+descriptor_size;\r
end (* family type definition *)\r
ELSE\r
IF Equal_Addr(St_String_Type_Addr,Dope_Symbol) AND\r
(local_e_stck^.Const_expr) THEN\r
BEGIN\r
LongType_size := local_e_Stck^.Stck[2].ww_Value;\r
LongLower := 1;\r
LongUpper := LongType_Size;\r
\r
push_struc_value(wordsize+dope_size_subrange+dope_size_array,Dope_Symbol,st_NillAddr,false);\r
st_ptr^.type_label := sca_current_frgmnt; (* FUSK addr of const *)\r
sca_Integer(Longtype_size);\r
sca_Integer(Longlower);\r
sca_Integer(Longupper);\r
sca_Integer(Longtype_size);\r
sca_Integer(Longlower);\r
sca_Integer(Longupper);\r
Longelement_size:= 1;\r
sca_Integer(Longelement_size);\r
Addr_Label := Dope_Symbol;\r
Mode_Of_Address := ConstAddr;\r
DopeOffset := 0;\r
st_ptr^.spec_struct:= st_ptr^.spec_struct - [dynamictype];\r
st_ptr^.St_Size := LongType_Size;\r
type_Dynamic := false;\r
END\r
else\r
begin\r
mode_of_address:= direct;\r
IF Computer = RC3502 THEN\r
Current_offset := Current_Offset + ord(odd(Current_Offset));\r
address(current_offset, offset, descriptor_size);\r
IF st_ptr^.Type_mode = bound_fam THEN\r
offset := offset - paramsize; (* Gris ??? *)\r
end;\r
addrtype_mode:= mode_of_address;\r
end; (*with st_ptr^.type_address *)\r
\r
(* traverse the type binding and insert proper information for all sub types *)\r
type_size:= 0;\r
if fam_type_declaration then\r
BEGIN\r
IF Computer = RC3502 THEN\r
traverse_type_binding(def_type_symbol, type_size,\r
st_ptr^.type_address.dopeoffset + 8, Direct)\r
ELSE\r
traverse_type_binding(def_type_symbol, type_size,\r
st_ptr^.type_address.dopeoffset, mode_of_address);\r
END\r
else\r
traverse_type_binding(def_type_symbol, type_size,\r
st_ptr^.type_address.offset, mode_of_address);\r
\r
if ((local_e_stck^.last_fct>1) or lock_var) AND\r
( Mode_of_Address <> ConstAddr) then\r
begin (* dump code for thunk call *)\r
store_code(cinit);\r
(* reserve room for call of thunk *)\r
if evaluation_appetite>=static_link_size+global_return_appetite+address_size then\r
evaluation_appetite:= evaluation_appetite-\r
static_link_size-global_return_appetite-address_size\r
(* return point + address of type descriptor *)\r
else\r
evaluation_appetite:= 0;\r
dump_expression(local_e_stck^, evaluation_appetite, current_level, current_offset);\r
store_code_symbol(caddr, type_symbol);\r
store_code_symbol(ccallthunk, dope_symbol);\r
evaluation_appetite:= evaluation_appetite+\r
static_link_size+global_return_appetite+address_size;\r
end\r
else\r
IF Mode_Of_Address <> ConstAddr THEN\r
(* open family binding *)\r
(* reset current level *)\r
current_level:= rtp86_wsub(current_level, 1);\r
\r
\r
st_retrieve(def_type_symbol, st_ptr);\r
\r
type_size := st_ptr^.st_size;\r
\r
dispose(local_e_stck (* TURBO,1*));\r
\r
defining_type:= false;\r
\r
END; (* typeid *)\r
\r
(* $SUBTITLE('------------ Pointer Definition')*)\r
cpointertype:\r
BEGIN\r
\r
load_symbol(def_type_symbol);\r
\r
st_retrieve(def_type_symbol, st_ptr);\r
\r
rule_defining_type (* - of component type - *)\r
(\r
i_code, emit_code, st_ptr^.typeref,\r
current_level, current_offset, address,\r
type_size, evaluation_appetite,\r
local_type_dynamic);\r
\r
END;\r
\r
cendpointer:\r
BEGIN\r
\r
type_size := pointersize;\r
\r
st_get(def_type_symbol, st_ptr);\r
st_ptr^.st_size := type_size;\r
\r
defining_type := false\r
\r
END;\r
\r
(* $SUBTITLE('------------ Subrange Definition')*)\r
csubrangetype:\r
BEGIN\r
\r
load_symbol(def_type_symbol);\r
\r
load_expression(i_code, e_stck^, current_level, current_offset);\r
\r
(* - 'i_code' is 'cendsubrange' - *)\r
\r
st_get(def_type_symbol, st_ptr);\r
\r
WITH e_stck^, stck[ last_fct ] DO\r
(* meaning of dyn_sub_limit:\r
0: - static -\r
1: constant upper bound, variable lower bound\r
2: variable upper bound, constant lower bound\r
3: variable upper bound, variable lower bound\r
*)\r
dyn_sub_limit :=\r
(2 * ORD(kind <> csimpleconst))\r
+\r
ORD(e_stck^.stck[ former_fct ].kind <> csimpleconst);\r
\r
IF dyn_sub_limit=0 then\r
BEGIN (* static subrange *)\r
with e_stck^, stck[ last_fct ] do\r
begin\r
upper:= ww_value;\r
lower:= stck[ former_fct ].ww_value;\r
end;\r
\r
IF step_variable THEN\r
type_size:= integersize\r
ELSE\r
BEGIN\r
\r
IF (maxbyte < lower) OR (maxbyte < upper) THEN\r
type_size := integersize\r
ELSE\r
type_size := bytesize;\r
\r
\r
IF rtp86_ilt(upper, lower) then\r
if upper+1<>lower then\r
begin (* tog *)\r
errormsg(this_pass, e_subrange);\r
upper:=lower-1;\r
end;\r
\r
END;\r
\r
with st_ptr^ do\r
begin\r
subr_high:= upper;\r
\r
subr_low:= lower;\r
st_size:= type_size;\r
end;\r
\r
if (Computer = RC3502) AND (Lower <> 0) then\r
begin\r
LongLower := Swap(Lower);\r
LongUpper := swap(Upper);\r
\r
push_struc_value(2*wordsize,dope_symbol,def_type_symbol,false);\r
sca_fill(wordsize, ptr_sca_max_string(@Longlower));\r
sca_fill(wordsize, ptr_sca_max_string(@Longupper));\r
\r
st_get(def_type_symbol, st_ptr);\r
st_ptr^.st_family_Ref := sca_current_frgmnt; (* FUSK addr of const *)\r
with st_ptr^.Subr_addr do\r
begin\r
addrtype_mode:= constaddr;\r
dopeoffset:= 0;\r
addr_label:= dope_symbol;\r
end;\r
end;\r
\r
END\r
else\r
BEGIN (* dynamic subrange *)\r
\r
(* - step variable dope: temporary - *)\r
if step_variable then\r
begin\r
type_size:= integersize;\r
push_stmnt(cendsubrange, current_offset, def_type_symbol);\r
end\r
else\r
begin\r
st_retrieve(st_ptr^.typeref (* base type *), st_ptr);\r
type_size:= st_ptr^.st_size;\r
st_get(def_type_symbol, st_ptr);\r
end;\r
with st_ptr^, subr_addr do\r
begin\r
subr_mode:= dyn;\r
(*spec_struct:= spec_struct * [ dynamictype ];*)\r
st_size:= type_size;\r
if fam_type_declaration then\r
begin\r
if mode_of_type<>fam then\r
mode_of_type:= dyn;\r
addrtype_mode:= indirect;\r
level:= current_level;\r
offset:= dope_addr_offset;\r
dopeoffset:= current_offset;\r
IF Computer = RC3502 THEN\r
BEGIN\r
AddrType_Mode := Direct;\r
offset := Current_Offset + 8;\r
END;\r
current_offset:= current_offset+dope_size_subrange;\r
end (* family type definition *)\r
else\r
begin\r
addrtype_mode:= direct;\r
level := current_level;\r
IF Computer = RC3502 THEN\r
Current_offset := Current_Offset + ord(odd(Current_Offset));\r
address(current_offset, offset, dope_size_subrange);\r
mode_of_type:= dyn;\r
end;\r
end; (* with st_ptr *)\r
\r
\r
(* dump code for subrange descriptor *)\r
IF emit_code THEN\r
BEGIN\r
store_code(cinit);\r
dump_expression(e_stck^, evaluation_appetite, current_level, current_offset);\r
store_code_symbol(cendsubrange, def_type_symbol);\r
\r
if not step_variable then\r
(* code for dynamic test of limits *)\r
store_code(csubrange);\r
END;\r
END;\r
\r
defining_type := false;\r
\r
END; (* subrangetype *)\r
\r
(* $SUBTITLE('------------ Array Definition')*)\r
carraytype:\r
BEGIN\r
load_symbol(def_type_symbol);\r
\r
st_retrieve(def_type_symbol, st_ptr);\r
\r
index_symbol := st_ptr^.itype;\r
element_symbol := st_ptr^.typeref;\r
\r
packed_structure := (st_ptr^.st_packed <> notpacked);\r
packed3502Structure := st_ptr^.st_packed = packed3502;\r
dyn_sub_limit:= 0; (* 0: static, 1: dynamic index type, 2: dynamic element size\r
3: dynamic index type and dynamic element size *)\r
\r
rule_defining_type (* - of index type - *)\r
(\r
i_code, emit_code, index_symbol,\r
current_level, current_offset, address,\r
type_size, evaluation_appetite,\r
local_type_dynamic\r
);\r
\r
st_retrieve(index_symbol, st_ptr);\r
dope_symbol:= st_ptr^.typeref;\r
st_retrieve(dope_symbol, st_ptr);\r
\r
lower := 0;\r
\r
CASE st_ptr^.st_kind OF\r
\r
cboolean:\r
upper := 1;\r
\r
cchar:\r
upper := maxchar;\r
\r
cinteger:\r
begin\r
lower := rtp86_minint;\r
upper := maxint;\r
end;\r
\r
cscalar:\r
upper := st_ptr^.scalar_no-1;\r
\r
csubrange:\r
if st_ptr^.subr_mode=stat then\r
BEGIN\r
lower:= st_ptr^.subr_low;\r
upper:= st_ptr^.subr_high;\r
END\r
else\r
begin\r
lower:=1;\r
upper:=0;\r
mode_of_type:= dyn;\r
dyn_sub_limit:= 1;\r
type_dynamic:= true;\r
end;\r
\r
(* OTHERWISE*) ELSE\r
fatal_error(this_pass, e_st_inconsistency)\r
\r
END;\r
\r
range_spann := rtp86_wsub(upper, lower);\r
\r
IF (range_spann < max_word) THEN\r
range_spann := range_spann + 1\r
ELSE\r
if lower<upper then (* tog *)\r
errormsg(this_pass, e_array_size)\r
else range_spann:=0;\r
\r
\r
rule_defining_type (* - of element type - *)\r
(\r
i_code, emit_code, element_symbol,\r
current_level, current_offset, address,\r
type_size, evaluation_appetite,\r
local_type_dynamic\r
);\r
type_dynamic:=type_dynamic or local_type_dynamic;\r
\r
st_Retrieve(element_Symbol,st_ptr);\r
if (Computer = RC3502) AND (st_ptr^.spec_struct*ShieldType35 <> []) THEN\r
If Odd(Type_size) THEN Type_size := Type_size + 1;\r
\r
if local_type_dynamic then\r
(*if (dynamictype in st_ptr^.spec_struct) then\r
(* TOG (st_ptr^.st_size=0) then *)\r
begin\r
st_get(element_symbol, st_ptr);\r
st_ptr^.spec_struct:= st_ptr^.spec_struct+[dynamictype];\r
mode_of_type:= dyn;\r
dyn_sub_limit:= dyn_sub_limit+2;\r
end;\r
\r
IF packed_structure THEN\r
begin\r
bit_quantity := 0;\r
if dyn_sub_limit<>0 then\r
packed_structure:= false\r
else begin\r
st_retrievetype(element_symbol, st_ptr);\r
case st_ptr^.st_kind of\r
cboolean: begin ilower:=0; iupper:=1; end;\r
cscalar: begin ilower:=0; iupper:=st_ptr^.scalar_no-1; end;\r
csubrange:\r
if st_ptr^.subr_mode=stat\r
then\r
begin\r
ilower:= st_ptr^.subr_low; iupper:= st_ptr^.subr_high;\r
if (Packed3502Structure) AND (ilower > Maxint) then\r
BEGIN\r
if (computer = RC3502) THEN packed_structure := false\r
else bit_quantity := 16;\r
END;\r
end\r
else (* dynamic *) packed_structure:= false;\r
cinteger :\r
if Packed3502Structure AND (computer <> RC3502) THEN\r
bit_quantity := wordsize * 8\r
else packed_structure:= false;\r
(*otherwise*) else packed_structure:= false;\r
end;\r
end;\r
st_get(def_type_symbol, st_ptr);\r
\r
\r
if packed_structure then\r
begin\r
if bit_quantity = 0 then bit_quantity:= rtp86_bitsize(ilower, iupper);\r
if ((bit_quantity>=13) or (bit_quantity=8)\r
and (ilower<=maxint (* positive *))) OR\r
(( packed3502structure) AND (Bit_quantity >=6)) then\r
begin\r
if packed3502structure AND (Computer <> RC3502) AND (bit_quantity > 8) THEN\r
begin\r
bit_quantity := (Bit_quantity + 7) DIV 8 * 8;\r
end\r
ELSE\r
BEGIN\r
IF (Computer = RC5000) AND (Bit_quantity >= 13) THEN\r
BEGIN\r
type_size := 2;\r
st_ptr^.ebit_size:= 16;\r
Bit_quantity := 16;\r
END\r
ELSE\r
BEGIN\r
packed_structure:= false;\r
st_ptr^.st_packed:= notpacked;\r
END;\r
END;\r
end\r
else\r
BEGIN\r
st_ptr^.ebit_size:= bit_quantity;\r
END;\r
IF packed_structure and packed3502structure and (computer <> RC3502)\r
THEN\r
BEGIN\r
(* test that rc3502packed is implementet *)\r
if (bit_quantity <> 1) AND (bit_quantity <> 2)\r
AND (bit_quantity <> 4) THEN\r
errormsg(this_pass, 125);\r
END;\r
end\r
else\r
st_ptr^.st_packed:= notpacked;\r
end; (* packed *)\r
\r
\r
\r
if mode_of_type=dyn then\r
begin (* produce code for dope vector *)\r
\r
(* reserve room for array descriptor *)\r
st_get(def_type_symbol, st_ptr);\r
with st_ptr^, array_addr do\r
begin\r
level:= current_level;\r
if fam_type_declaration then\r
begin\r
addrtype_mode:= indirect;\r
offset:= dope_addr_offset;\r
dopeoffset:= current_offset;\r
\r
IF Computer = RC3502 THEN\r
BEGIN\r
AddrType_mode := Direct;\r
offset := Current_Offset + 8;\r
END;\r
current_offset:= current_offset+dope_size_array;\r
end\r
else\r
begin\r
addrtype_mode:= direct;\r
IF Computer = RC3502 THEN\r
Current_offset := Current_Offset + ord(odd(Current_Offset));\r
address(current_offset, offset, dope_size_array);\r
end;\r
end; (* with st_ptr *)\r
\r
store_code(cinit);\r
\r
if odd(dyn_sub_limit) then store_code_symbol(caddr, dope_symbol);\r
\r
(* get address of type integer *)\r
if stdcode_to_address(cinteger, integer_addr) then ;\r
\r
if not odd(dyn_sub_limit) then (* static index type, dump bounds *)\r
begin\r
store_code_1(csimpleconst, lower);\r
store_symbol(integer_addr);\r
store_code_1(csimpleconst, upper);\r
store_symbol(integer_addr);\r
end;\r
if dyn_sub_limit=1 then\r
begin (* constant element size *)\r
store_code_1(csimpleconst, type_size);\r
store_symbol(integer_addr);\r
end\r
else\r
begin\r
st_retrieve(element_symbol, st_ptr);\r
store_code_symbol(caddr, st_ptr^.typeref);\r
end;\r
if odd(dyn_sub_limit) then\r
store_code_symbol(cendarray, def_type_symbol)\r
else\r
store_code_symbol(carraytype, def_type_symbol);\r
\r
end; (* dope descriptor code *)\r
\r
element_size:=type_size;\r
\r
if packed_structure then\r
begin\r
element_size:=bit_quantity;\r
packed_array_offset(0, range_spann, type_size, bit_quantity, byte_offset, packed_bit_offset);\r
if packed_bit_offset>0 then\r
type_size:= byte_offset+1\r
else\r
type_size:= byte_offset;\r
end (* packed *)\r
else\r
IF wmul_ovflw(type_size, range_spann) THEN\r
errormsg(this_pass, e_array_size);\r
\r
if mode_of_type<>dyn then\r
begin (* static dope *)\r
\r
if (Computer = RC3502) AND\r
( ((Lower <> 0) AND (Lower <> 1)) OR\r
(Packed_Structure) ) then\r
begin\r
LongLower := Swap(Lower);\r
LongUpper := swap(Upper);\r
\r
push_struc_value(3*wordsize,dope_symbol,def_type_symbol,false);\r
sca_fill(wordsize, ptr_sca_max_string(@Longlower));\r
sca_fill(wordsize, ptr_sca_max_string(@Longupper));\r
IF Packed_Structure THEN\r
BEGIN\r
Longelement_Size := (Element_Size SHL 8) + (16 DIV Element_Size);\r
END\r
ELSE\r
Longelement_size:= swap(element_size);\r
sca_fill(wordsize, ptr_sca_max_string(@Longelement_size));\r
\r
st_get(def_type_symbol, st_ptr);\r
with st_ptr^.array_addr do\r
begin\r
addrtype_mode:= constaddr;\r
dopeoffset:= 0;\r
addr_label:= dope_symbol;\r
end;\r
st_ptr^.st_family_Ref := sca_current_frgmnt; (* FUSK addr of const *)\r
end;\r
end;\r
\r
st_get(def_type_symbol, st_ptr);\r
\r
if type_dynamic then st_ptr^.spec_struct:= st_ptr^.spec_struct + [dynamictype];\r
st_ptr^.st_size := type_size;\r
\r
(* - 'i_code' is 'cendarray' - *)\r
\r
END; (* arraytype *)\r
\r
(* $SUBTITLE('------------ Record Definition')*)\r
crecordtype:\r
BEGIN\r
load_symbol(def_type_symbol);\r
\r
st_retrieve(def_type_symbol, st_ptr);\r
packed_structure:= st_ptr^.packed_rec <> notpacked;\r
packed3502Structure := st_ptr^.packed_rec = Packed3502;\r
\r
next_byte_offset := 0;\r
next_bit_offset := 0;\r
\r
dyn_sub_limit:= 0; (* # of dynamic sized fields *)\r
AllignRecordLength := false;\r
\r
END;\r
\r
crecfield:\r
BEGIN\r
\r
load_symbol(st_field_symbol); (* - first field in list - *)\r
\r
st_retrieve(st_field_symbol, st_ptr);\r
field_type_symbol := st_ptr^.typeref;\r
\r
st_retrieve(field_type_symbol, st_ptr);\r
if ((computer = RC5000) AND ((shieldType*St_Ptr^.Spec_Struct) <> [])) OR\r
((computer = RC3502) AND (( shieldType35 *St_Ptr^.Spec_Struct) <> [])) THEN\r
begin\r
Allign := true;\r
Allignrecordlength := true;\r
end\r
ELSE Allign := false;\r
\r
rule_defining_type\r
(\r
i_code, emit_code, field_type_symbol,\r
current_level, current_offset, address,\r
type_size, evaluation_appetite,\r
local_type_dynamic\r
);\r
type_dynamic:= type_dynamic or local_type_dynamic;\r
\r
IF packed_structure and (dyn_sub_limit=0 (* not after dynamic *)) THEN\r
begin\r
FieldPacked := true;\r
st_retrievetype(field_type_symbol, st_ptr);\r
case st_ptr^.st_kind of\r
cboolean: bit_quantity:= 1;\r
cbyte,\r
cchar: bit_quantity:= 8;\r
cscalar: bit_quantity:= rtp86_bitsize(0, st_ptr^.scalar_no-1);\r
csubrange: if st_ptr^.subr_mode=stat then\r
BEGIN\r
bit_quantity:= rtp86_bitsize(st_ptr^.subr_low, st_ptr^.subr_high);\r
IF (packed3502structure) AND (st_ptr^.Subr_low > MaxInt) THEN\r
BEGIN\r
IF computer = RC3502 THEN fieldpacked := false\r
ELSE bit_quantity := 16;\r
END;\r
END\r
else\r
(* dynamic *)\r
Fieldpacked := false;\r
cinteger :\r
if packed3502structure and (computer <> RC3502) then\r
bit_quantity := wordsize * 8\r
else FieldPacked := false;\r
(*otherwise*) else FieldPacked := false;\r
END; (* Case *)\r
if not FieldPacked THEN\r
begin\r
bit_quantity:= 0; (* element not packed *)\r
if next_bit_offset>0 then\r
IF wadd_ovflw(next_byte_offset, bytesize) THEN\r
errormsg(this_pass, e_record_size);\r
next_bit_offset:= 0;\r
end;\r
\r
end; (* packed *)\r
\r
field_size := type_size;\r
\r
REPEAT\r
\r
st_get(st_field_symbol, st_ptr);\r
last_rec_field:= st_field_symbol;\r
st_field_symbol:= st_ptr^.listref; (* - next field in list - *)\r
\r
elementnumber := elementnumber + 1;\r
\r
if local_type_dynamic then st_ptr^.spec_struct:=st_ptr^.spec_struct+[dynamictype];\r
st_ptr^.st_size := field_size;\r
st_ptr^.bit_size := 0;\r
st_ptr^.st_packedFiel := notpacked;\r
st_ptr^.bit_offset := 0;\r
\r
if (local_type_dynamic) (* TOG (field_size=0)*) or (dyn_sub_limit>0) then\r
dyn_sub_limit:= dyn_sub_limit+1;\r
if dyn_sub_limit>1 then\r
begin\r
st_ptr^.field_mode:= dyn;\r
(*st_ptr^.spec_struct:= st_ptr^.spec_struct * [ dynamictype ];*)\r
end\r
(* offset in dynamic record descriptor is allocated at ENDRECORD *)\r
else\r
begin\r
if Allign then\r
next_byte_offset :=((next_byte_offset+(wordsize-1))DIV wordsize)*wordsize;\r
st_ptr^.field_offset:= next_byte_offset;\r
\r
if packed_structure and (bit_quantity>0) then\r
begin\r
st_ptr^.bit_size:= bit_quantity;\r
IF packed3502Structure THEN st_ptr^.st_packedFiel := packed3502;\r
IF packed3502structure and (computer <> RC3502)\r
THEN\r
BEGIN\r
(* test that rc3502packed is implementet *)\r
if ((next_bit_offset + bit_quantity) > 8) AND\r
(bit_quantity <> 16) THEN errormsg(this_pass, 125)\r
END;\r
if next_bit_offset+bit_quantity>16 then (* skip an unused field *)\r
begin\r
next_bit_offset:= 0;\r
next_byte_offset:= next_byte_offset+1;\r
st_ptr^.field_offset:= next_byte_offset;\r
end;\r
st_ptr^.bit_offset:= next_bit_offset;\r
next_bit_offset:= next_bit_offset+bit_quantity;\r
if next_bit_offset>7 then\r
begin\r
IF wadd_ovflw(next_byte_offset, next_bit_offset div 8) THEN\r
errormsg(this_pass, e_record_size);\r
next_bit_offset:= next_bit_offset mod 8;\r
end; (* next bit offset > 7 *)\r
end (* packed element *)\r
else\r
IF wadd_ovflw(next_byte_offset, field_size) THEN\r
errormsg(this_pass, e_record_size);\r
\r
end; (* static part of record *)\r
\r
UNTIL st_ptr^.st_listend\r
\r
END;\r
\r
cendfieldlist:;\r
\r
cendrecord:\r
BEGIN\r
\r
IF packed_structure THEN\r
IF (0 < next_bit_offset) THEN\r
IF wadd_ovflw(next_byte_offset, bytesize) THEN\r
errormsg(this_pass, e_record_size);\r
\r
st_get(def_type_symbol, st_ptr);\r
if type_dynamic then st_ptr^.spec_struct:= st_ptr^.spec_struct + [dynamictype];\r
\r
if dyn_sub_limit>0 then\r
begin\r
mode_of_type:= dyn;\r
type_size:= 0;\r
if stdcode_to_address(cinteger, integer_addr) then ;\r
\r
(* code for record descriptor *)\r
with st_ptr^, record_addr do\r
begin\r
level:= current_level;\r
if fam_type_declaration then\r
begin\r
addrtype_mode:= indirect;\r
offset:= dope_addr_offset;\r
\r
IF Computer = RC3502 THEN\r
BEGIN\r
AddrType_Mode := Direct;\r
offset := Current_Offset + 8;\r
END;\r
(* reserve room for total size and field descriptors *)\r
dopeoffset:= current_offset;\r
current_offset:= current_offset+wordsize+(dyn_sub_limit-1)*wordsize;\r
rec_descr_offset:= dopeoffset;\r
end\r
else\r
begin\r
addrtype_mode:= direct;\r
(* reserve room for total size and field descriptors *)\r
IF Computer = RC3502 THEN\r
Current_offset := Current_Offset + ord(odd(Current_Offset));\r
address(current_offset, offset, wordsize+(dyn_sub_limit-1)*wordsize);\r
rec_descr_offset:= offset;\r
end;\r
end; (* with st_ptr... *)\r
store_code(cinit);\r
store_code_symbol(crecordtype, def_type_symbol);\r
\r
if dyn_sub_limit>1 then\r
begin\r
st_retrieve(st_ptr^.listref, st_ptr); (* first field *)\r
while st_ptr^.field_mode=stat do (* search for first dynamic sized field *)\r
with st_ptr^ do\r
begin\r
next_byte_offset:= field_offset;\r
field_type_symbol:= typeref;\r
st_field_symbol:= listref; (* next field *)\r
st_retrieve(st_field_symbol, st_ptr);\r
end;\r
end (* more than one dynamic sized field *)\r
else\r
begin\r
st_retrieve(last_rec_field, st_ptr); (* the only dynamic sized field *)\r
with st_ptr^ do\r
begin\r
next_byte_offset:= field_offset;\r
field_type_symbol:= typeref;\r
st_field_symbol:= listref; (* next field *)\r
end;\r
end;\r
\r
store_code_1(csimpleconst, next_byte_offset);\r
store_symbol(integer_addr);\r
\r
element_Symbol := integer_addr;\r
repeat (* descriptor information for the dynamic addressed fields *)\r
store_code(crecfield);\r
IF (computer = RC5000) OR (Computer = RC3502) THEN store_symbol(element_Symbol);\r
st_retrieve(field_type_symbol, st_ptr);\r
if (*(dynamictype in st_ptr^.spec_struct) or*)\r
(st_ptr^.st_size=0) then (* dynamic size *)\r
store_code_symbol(caddr, st_ptr^.typeref)\r
else\r
begin\r
store_code_1(csimpleconst, st_ptr^.st_size);\r
store_symbol(integer_addr);\r
end;\r
\r
element_symbol := st_field_symbol;\r
if equal_addr(st_field_symbol, st_stopaddr) then\r
defining_type:= false\r
else\r
begin\r
st_get(st_field_symbol, st_ptr);\r
with st_ptr^, field_addr do\r
begin\r
level:= current_level;\r
rec_descr_offset:= rec_descr_offset+wordsize;\r
if fam_type_declaration then\r
begin\r
addrtype_mode:= indirect;\r
offset:= dope_addr_offset;\r
dopeoffset:= rec_descr_offset;\r
\r
IF Computer = RC3502 THEN\r
BEGIN\r
AddrType_Mode := Direct;\r
offset := rec_descr_Offset + 8;\r
END;\r
end\r
else\r
begin\r
addrtype_mode:= direct;\r
offset:= rec_descr_offset;\r
end;\r
st_field_symbol:= listref;\r
field_type_symbol:= typeref;\r
end;\r
end;\r
\r
until not defining_type;\r
\r
store_code(cendrecord);\r
end (* dynamic record *)\r
else\r
begin\r
if (computer = RC5000) AND Allignrecordlength THEN\r
begin\r
next_byte_offset :=((next_byte_offset+(wordsize-1))DIV wordsize)*wordsize;\r
end;\r
st_ptr^.st_size := next_byte_offset;\r
\r
type_size := next_byte_offset;\r
\r
defining_type := false\r
end; (* static record *)\r
\r
END;\r
\r
(* $SUBTITLE('------------ Set Definition')*)\r
csettype:\r
BEGIN\r
\r
load_symbol(def_type_symbol);\r
\r
st_retrieve(def_type_symbol, st_ptr);\r
\r
rule_defining_type (* - of set element type - *)\r
(\r
i_code, emit_code, st_ptr^.typeref,\r
current_level, current_offset, address,\r
type_size, evaluation_appetite,\r
local_type_dynamic\r
);\r
type_dynamic:= type_size=0;\r
\r
st_get(def_type_symbol, st_ptr); (* csettype *)\r
if type_dynamic then st_ptr^.spec_struct:=st_ptr^.spec_struct+[dynamictype];\r
st_retrieve(st_ptr^.typeref, st_ptr);\r
dope_symbol:= st_ptr^.typeref;\r
st_retrieve(st_ptr^.typeref, st_ptr);\r
\r
case st_ptr^.st_kind of\r
cboolean: begin\r
upper:= 1;\r
lower:= 0;\r
end;\r
cchar: begin\r
upper:= maxchar;\r
lower:= 0;\r
end;\r
cinteger: begin\r
upper:= maxint;\r
lower:= rtp86_minint;\r
end;\r
cscalar: begin\r
upper:= st_ptr^.scalar_no-1;\r
lower:= 0;\r
end;\r
csubrange: if st_ptr^.subr_mode=stat then\r
begin\r
upper:= st_ptr^.subr_high;\r
lower:= st_ptr^.subr_low;\r
end\r
else\r
begin (* dynamic *)\r
mode_of_type:= dyn;\r
errormsg(this_pass, e_set_not_impl);\r
end;\r
(*otherwise*) else\r
fatal_error(this_pass, e_st_inconsistency);\r
end; (* case *)\r
\r
IF (lower > maxint) or (upper > maxint) then\r
errormsg(this_pass,e_set_negelem);\r
\r
st_get(def_type_symbol, st_ptr);\r
\r
with st_ptr^ do\r
begin\r
subr_mode:= mode_of_type;\r
if mode_of_type=stat then\r
begin\r
subr_high:= upper;\r
subr_low:= lower;\r
IF (Computer = RC3502) OR (Computer = RC5000) THEN\r
BEGIN\r
type_Size := (upper Div 8) + 1;\r
IF (Computer = RC3502) THEN type_Size := Type_Size + ord(odd(type_Size));\r
END\r
else\r
type_size:= rtp86_wsub(upper, rtp86_wand(lower, $fff8))div 8 + 1 +\r
(WordSize * 2); (* room for length and start *)\r
end\r
\r
else (* dynamic *)\r
begin\r
type_size:= 0;\r
end;\r
\r
st_size := type_size\r
end; (* with st_ptr^ *)\r
END;\r
\r
cprogdecl: begin\r
rule_program_declaration\r
(i_code, program_level, current_offset, current_offset, false);\r
type_size := program_descr_size;\r
defining_type:= i_code<>cendblock;\r
end;\r
\r
cendprogdecl,\r
cendtypedecl,\r
cendtype,\r
cendarray,\r
cendset:\r
defining_type := false;\r
\r
\r
(*OTHERWISE*) ELSE\r
fatal_error(this_pass, e_token_018)\r
\r
END\r
\r
until not defining_type;\r
\r
st_get(type_symbol, st_ptr);\r
type_dynamic:= type_dynamic or (dynamictype in st_ptr^.spec_struct);\r
\r
st_ptr^.st_size := type_size;\r
st_ptr^.type_mode:= mode_of_type;\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
' C.Offs.', current_offset:6,\r
' Type S.', type_size:6,\r
' mode:', ord(mode_of_type):2\r
);\r
(*ENDTEST#*) \r
\r
END (* - PROCEDURE rule_defining_type - *);\r
\r
\r
function rtp86_bitsize(lower, upper: word): word;\r
\r
function log2(val: word): word;\r
var\r
conv_wrd_to_int: record\r
case boolean of\r
true: (w_val: word);\r
false: (i_val: integer)\r
end;\r
result: word;\r
begin (* log 2 *)\r
with conv_wrd_to_int do\r
begin\r
w_val:= val;\r
if i_val<0 then\r
i_val:= -i_val-1;\r
result:= 0;\r
while i_val>0 do\r
begin\r
result:= result+1;\r
w_val:= w_val div 2;\r
end;\r
log2:= result;\r
end; (* with conv... *)\r
end; (* log2 *)\r
\r
begin (* rtp86 bitsize *)\r
if lower>maxint then (* negative lower bound *)\r
if upper>maxint then (* negative upper bound *)\r
rtp86_bitsize:= log2(lower)+1\r
else\r
begin\r
if log2(lower)>log2(upper) then\r
rtp86_bitsize:= log2(lower)+1\r
else\r
rtp86_bitsize:= log2(upper)+1 (* for the sign *);\r
end\r
else\r
rtp86_bitsize:= log2(upper);\r
end; (* rtp86 bitsize *)\r
END\r
.\r
«eof»