⟦3b46a6ed5⟧

TextFile

{$O+,F+}\r
unit sthint;\r
\r
interface\r
uses pscplm, mpaunit, sthunit, vmmunit, nthunit;\r
const\r
\r
version_no = 600;\r
\r
levelrec_length = 19;\r
\r
maxlength = 56;\r
minlength = 0;\r
external_length = 15;\r
declaration_length = 19;\r
newline_length = 26;\r
st_reserve_offset = 24;\r
st_labeldef_offset = 10;\r
\r
\r
var\r
\r
last_contextaddr, type_addr: st_address;\r
\r
currant_level_ptr, last_created_level_ptr, last_elem : st_elemptr;\r
\r
node_length : array[ carraytype .. cword ] of word;\r
\r
addr0type  : address_type;\r
\r
list_kind  : codes;\r
\r
max_data_size, scalar_count, st_double : word;\r
\r
forward_exist, list_start, save_typekind,\r
first_prog : boolean;\r
\r
\r
\r
procedure elementretrieve( lock_rec, update : boolean;\r
addr : st_address;  var cur_ptr : st_elemptr );\r
\r
\r
procedure elementextend(var cur_ptr: st_elemptr; kind : codes );\r
\r
procedure elementcopy(source: st_address; var cur_ptr: st_elemptr;\r
								 kind : codes );\r
\r
\r
(*** sth help procedure ***)\r
\r
\r
procedure printstars;\r
\r
procedure elem_print( ptr : st_elemptr; addr : st_address );\r
\r
procedure init_element( kind : codes;\r
var ptr : st_elemptr );\r
\r
function st_searchdouble( spix : spixrange;  endcode: codes;\r
var d_addr : st_address ): boolean;\r
\r
procedure update_last( var ptr: st_elemptr);\r
\r
(*** end help procedure ***)\r
\r
implementation\r
\r
function own_equal_addr( addr1, addr2 : st_address ): boolean;\r
begin\r
own_equal_addr:= (addr1.va_low = addr2.va_low) and\r
(addr1.va_high = addr2.va_high )\r
end;\r
\r
procedure elementretrieve( lock_rec, update : boolean;\r
addr : st_address;  var cur_ptr : st_elemptr );\r
var\r
res : word;\r
begin\r
if teststh then\r
begin\r
(*res:= vmmretrieve(stdescriptorptr^, 0, 37541,\r
false, false, cur_ptr );\r
if res <> 8211 then\r
begin\r
if res <> 0 then fatal_error(vmm,res);\r
if (cur_ptr^.st_kind<>ctype) and (cur_ptr^.st_kind<>ctypedecl) then\r
begin\r
writeln(testoutput,'ELEMENT DESTROYED retrieve');\r
elem_print(cur_ptr,addr);\r
printstars;\r
fatal_error(vmm,117);\r
end;\r
end;*)\r
if (addr.va_low=37538) and (addr.va_high=0) then\r
writeln(testoutput,'ELEMENT DESTROYED ');\r
end;\r
\r
\r
res:= vmmretrieve(stdescriptorptr^, addr.va_high, addr.va_low,\r
lock_rec, update, cur_ptr );\r
if res <> 0 then fatal_error(vmm,res);\r
end;\r
\r
\r
\r
\r
procedure elementextend(var cur_ptr: st_elemptr; kind : codes );\r
var\r
res  : word;\r
begin\r
(*if teststh then\r
begin\r
res:= vmmretrieve(stdescriptorptr^, 0, 37541,\r
false, false, cur_ptr );\r
if res <> 8211 then\r
begin\r
if res <> 0 then fatal_error(vmm,res);\r
if (cur_ptr^.st_kind<>ctype) and (cur_ptr^.st_kind<>ctypedecl) then\r
begin\r
writeln(testoutput,'ELEMENT DESTROYED extend');\r
elem_print(cur_ptr,st_nilladdr);\r
printstars;\r
fatal_error(vmm,117);\r
end;\r
end;\r
end;\r
*)\r
res:= vmmextend(stdescriptorptr^, currant_addr, node_length[ kind ],\r
false, cur_ptr );\r
if res <> 0 then fatal_error(vmm,res);\r
init_element( kind, cur_ptr );\r
end;\r
\r
\r
procedure elementcopy(source: st_address; var cur_ptr: st_elemptr;\r
                      kind : codes );\r
var\r
res  : word;\r
begin\r
if teststh then\r
begin\r
(*res:= vmmretrieve(stdescriptorptr^, 0, 37541,\r
false, false, cur_ptr );\r
if res <> 8211 then\r
begin\r
if res <> 0 then fatal_error(vmm,res);\r
if (cur_ptr^.st_kind<>ctype) and (cur_ptr^.st_kind<>ctypedecl) then\r
begin\r
writeln(testoutput,'ELEMENT DESTROYED copy');\r
elem_print(cur_ptr,st_nilladdr);\r
printstars;\r
fatal_error(vmm,117);\r
end;\r
end;\r
*)\r
if (source.va_low=37538) and (source.va_high=0) then\r
writeln(testoutput,'ELEMENT DESTROYED copy');\r
\r
end;\r
\r
res:= vmmextendcopy(stdescriptorptr^, currant_addr, node_length[ kind ],\r
false, cur_ptr, source.va_high, source.va_low );\r
if res <> 0 then fatal_error(vmm,res);\r
end;\r
\r
(*** sth help procedure ***)\r
\r
\r
procedure st_kindname( var name :string; kind : codes );\r
\r
begin\r
case kind of\r
carraytype : name:= 'array';\r
cboolean   : name:= 'boolean';\r
cbyte      : name:= 'byte';\r
cchain     : name:= 'chain';\r
cchar      : name:= 'char';\r
cconstant  : name:= 'constant';\r
ccontext   : name:= 'context';\r
cdeclaration:name:= 'cross decl';\r
cerror     : name:= 'error';\r
cendlevel  : name:= 'endlevel';\r
cexternal  : name:= 'external';\r
cforstat   : name:= 'forvar';\r
cfunction  : name:= 'function';\r
cinteger   : name:= 'integer';\r
cinspectparam: name:= 'inspectparam';\r
clabel     : name:= 'label';\r
clockvar   : name:= 'lockvar';\r
cmailbox   : name:= 'mailbox';\r
cnewline   : name:= 'cross line';\r
cformalparamlist: name:= 'formalparam';\r
cpointertype    : name:= 'pointer';\r
cpool      : name:= 'pool';\r
cport      : name:= 'port';\r
cprocedure : name:= 'procedure';\r
cprocess   : name:= 'process';\r
cprogram   : name:= 'program';\r
creal      : name:= 'real';\r
crecfield  : name:= 'recordfield';\r
crecordtype: name:= 'record';\r
creference : name:= 'reference';\r
cscalar    : name:= 'scalar';\r
cscalarelem: name:= 'scalarelem';\r
csettype   : name:= 'set';\r
cshared    : name:= 'shared';\r
csharedparam: name:= 'sharedparam';\r
cstrucconst: name:= 'strucconst';\r
cstrucelem : name:= 'strucelem';\r
csubrange  : name:= 'subrange';\r
ctype      : name:= 'type';\r
cundeclared: name:= 'undeclared';\r
cvalueparam: name:= 'valueparam';\r
cvar       : name:= 'var';\r
cvarparam  : name:= 'varparam';\r
cwithvar   : name:= 'withvar';\r
cwithstat  : name:= 'withstat';\r
cword      : name:= 'word'\r
else (*otherwise*)    name:= '---???---';\r
name[10]:=chr(ord(kind) div 100+ord('0'));\r
name[11]:=chr(ord(kind) div 10 mod 10+ord('0'));\r
name[12]:=chr(ord(kind) mod 10+ord('0'));\r
end;\r
end;\r
\r
\r
\r
procedure printstars;\r
var i : integer;\r
begin\r
for i:= 1 to 35 do write(testoutput,'*');\r
writeln(testoutput);\r
end;\r
\r
\r
\r
\r
procedure elem_print( ptr : st_elemptr; addr : st_address );\r
var\r
res  : word;\r
i, n : integer;\r
kind : codes;\r
cname : ptr_string;\r
vname : string;\r
p_typeref, p_size, p_spix, p_former,\r
p_listref, p_familyref, p_specs, p_spec_struct: boolean;\r
\r
\r
procedure print_typeaddr( t_addr : address_type );\r
begin\r
with t_addr do\r
begin\r
if addrtype_mode=constaddr then\r
write(testoutput,'   Const Label: ',addr_label.va_high,' ',addr_label.va_low)\r
else begin\r
case addrtype_mode of\r
direct :write(testoutput,'   Direct');\r
indirect: write(testoutput,'   Indirect')\r
else (*otherwise*);\r
end; (* case *)\r
write(testoutput,'   Level: ', level,' Offset: ',offset);\r
end;\r
if dopeoffset<>0 then \r
write(testoutput,'   Dope offset: ', dopeoffset);\r
end; (* with *)\r
writeln(testoutput);\r
end;\r
\r
procedure print_symbol( s: st_address );\r
begin\r
  if (s.va_low=st_nilladdr.va_low) and\r
     (s.va_high=st_nilladdr.va_high) then \r
     write(testoutput,'nilladdr') else\r
  if (s.va_low=st_stopaddr.va_low) and\r
     (s.va_high=st_stopaddr.va_high) then\r
     write(testoutput,'stopaddr') else\r
     write(testoutput,s.va_high,' ',s.va_low);\r
end;\r
\r
begin\r
p_typeref:=true;\r
p_size:=true;\r
p_spix:=true;\r
p_former:=active_module<=pass2;\r
p_listref:=true;\r
p_familyref:=true;\r
p_specs:=true;\r
p_spec_struct:=true;\r
\r
if ptr <> nil then with ptr^ do\r
begin\r
case st_kind of\r
\r
cendlevel,\r
cexternal,\r
cdeclaration,\r
cnewline: begin\r
p_typeref:=false; p_spix:=false; p_size:=false; p_listref:=false;\r
p_familyref:=false; p_specs:=false; p_spec_struct:=false;\r
if st_kind<>cexternal then p_former:=false;\r
end;\r
\r
cconstant,\r
cscalarelem: begin\r
p_familyref:=false; p_specs:=false;\r
if st_kind=cconstant then p_listref:=false;\r
end;\r
\r
ctype:;\r
\r
clabel: begin\r
p_typeref:=false; p_size:=false; p_familyref:=false; p_specs:=false;\r
end;\r
\r
cprogram: begin\r
p_size:=false; (*p_specs:=false;*)\r
end;\r
\r
cfunction: ;\r
\r
cprocedure: begin\r
p_size:=false; (*p_specs:=false;*) p_typeref:=false;\r
end;\r
\r
cvar, cwithvar, cwithstat, cforstat, cshared, cinspectparam,\r
cvalueparam, cvarparam, csharedparam, clockvar: begin\r
p_specs:=false; p_familyref:=false;\r
end;\r
\r
cscalar: begin\r
p_spix:=false; p_former:=false; p_specs:=false;\r
end;\r
\r
crecfield: p_specs:=false;\r
\r
csubrange,csettype: begin\r
p_spix:=false; p_former:=false; p_listref:=false; p_specs:=false;\r
end;\r
\r
carraytype: begin\r
p_spix:=false; p_former:=false; p_listref:=false; p_specs:=false;\r
end;\r
\r
crecordtype: begin\r
p_spix:=false; p_former:=false; p_specs:=false;\r
end;\r
\r
cstrucelem, cstrucconst: begin\r
p_spix:=false; p_former:=false; p_familyref:=false; p_specs:=false;\r
end\r
\r
else (*otherwise*) \r
\r
end;\r
\r
\r
writeln(testoutput);\r
st_kindname(vname,st_kind);\r
write(testoutput,'Kind: ', vname);\r
if p_spix then begin\r
res:=nthretrieve( st_spix, cname );\r
write(testoutput,'   spix: ',st_spix,' name ');\r
if (res=0) or (res=st_double) then\r
write(testoutput,cname^) else\r
write(testoutput,'not found');\r
end;\r
write(testoutput,'   Current: ');\r
print_symbol(addr);\r
if p_former then with st_inf do\r
begin\r
write(testoutput,'   Former: ');\r
print_symbol(st_former);\r
if p_spix and (active_module=pass2) then\r
begin\r
write(testoutput,'   Cross: ');\r
print_symbol(st_cross_addr);\r
end;\r
end;\r
writeln(testoutput);\r
if p_typeref then\r
begin\r
write(testoutput,'   Typeref: ');\r
print_symbol(typeref);\r
end;\r
if p_listref then\r
begin\r
write(testoutput,'   Listref: ');\r
print_symbol(listref);\r
if st_listend then write(testoutput,' E');\r
end;\r
if p_familyref then\r
begin\r
write(testoutput,'   Familyref: ');\r
print_symbol(st_family_ref);\r
if st_node_copy then write(testoutput,' C');\r
end;\r
if p_typeref or p_listref or p_familyref then writeln(testoutput);\r
if p_size then write(testoutput,'   Size: ',st_size);\r
if p_specs then\r
begin\r
write(testoutput,'   Specs: ');\r
case st_specs of\r
st_forward : write(testoutput,'forward');\r
st_extern  : write(testoutput,'external');\r
st_open    : write(testoutput,'open');\r
st_overload: write(testoutput,'overload name');\r
st_global  : write(testoutput,'global');\r
st_local   : write(testoutput,'local')\r
else (*otherwise*)    write(testoutput,'none');\r
end;\r
end;\r
if p_spec_struct then\r
begin\r
write(testoutput,'  ');\r
if (spec_struct=[simpeltype]) or (spec_struct=[])\r
then writeln(testoutput,' Simpel') else\r
begin\r
if xpackedtype in spec_struct then write(testoutput,' Packed');\r
if pointertype in spec_struct then write(testoutput,' Pointer');\r
if mailboxtype in spec_struct then write(testoutput,' Mailbox');\r
if mailboxpointer in spec_struct then write(testoutput,' Mailboxpointer');\r
if referencetype in spec_struct then write( testoutput,' Reference');\r
if programtype in spec_struct then write( testoutput, ' Program');\r
if pooltype in spec_struct then write( testoutput,' Pool');\r
if processtype in spec_struct then write( testoutput,' Process');\r
if porttype in spec_struct then write( testoutput,' Port');\r
if chaintype in spec_struct then write( testoutput,' Chain');\r
end;\r
if staticfamilytype in spec_struct then write( testoutput,' StaticFamily')\r
else if dynamictype in spec_struct then write( testoutput,' Dynamic');\r
end;\r
if p_size or p_specs or p_spec_struct then writeln(testoutput);\r
\r
\r
case st_kind of\r
\r
cendlevel:\r
begin\r
write( testoutput,'    Last inserted: ');\r
print_symbol(last_inserted);\r
write( testoutput,'   Former level: ');\r
print_symbol(former_level);\r
write(testoutput,'   Chain: ');\r
print_symbol(level_chain);\r
writeln(testoutput);\r
end;\r
\r
cdeclaration:\r
begin\r
write(testoutput,'   Cross spix: ',st_cross_spix,'   Cross Symbol: ');\r
print_symbol(st_cross_symbol);\r
writeln(testoutput);\r
write(testoutput,'   Next decl: ');\r
print_symbol(st_next_decl);\r
write(testoutput,'   First line: ');\r
print_symbol(st_first_line);\r
write(testoutput,'   Last line: ');\r
print_symbol(st_last_line);\r
writeln(testoutput);\r
end;\r
\r
cnewline:\r
begin\r
write(testoutput,'   Next line: ');\r
print_symbol(st_next_line);\r
writeln(testoutput);\r
for i:=1 to st_line_no do\r
writeln(testoutput,'   Line: ',st_line[i],'   Source: ',st_source[i],\r
'   Mode: ',ord(st_line_mode[i]));\r
end;\r
\r
cconstant:\r
begin\r
case const_kind of\r
csimpleconst : writeln(testoutput,'   Const value: ',const_val );\r
cstrucconst  : begin\r
writeln(testoutput,'   Struct symbol: ');\r
print_symbol(st_struc_symb);\r
end\r
else (*otherwise*) \r
end; (* case *)\r
end;\r
\r
cscalarelem:\r
writeln(testoutput,'   Ordinal value: ', const_val);\r
\r
ctype:\r
begin\r
if type_mode = stat then\r
writeln(testoutput,'   Static' ) else\r
begin\r
case type_mode of\r
dyn:\r
writeln(testoutput,'   Dynamic');\r
bound_fam:\r
writeln(testoutput,'   Bound family');\r
open_fam:\r
writeln(testoutput,'   Open family');\r
named_bound_fam:\r
writeln(testoutput,'   Named bound family');\r
fam:\r
begin\r
write(testoutput,'   Family');\r
writeln(testoutput,'   First: ',t_first_offset,'   Last: ',t_last_offset);\r
write(testoutput,'   Name entry list: ');\r
print_symbol(t_name_entry_list);\r
write(testoutput,'   Seg: ',st_t_seg_nr,'   Used: ',fam_used);\r
if st_t_local_near then write(testoutput,'   Local')\r
else write(testoutput,'   Far');\r
writeln(testoutput,' segment calls   Mark: ',st_file_mark);\r
end\r
else (*otherwise*);\r
end; (* case *)\r
if (type_mode<>fam) and (st_file_mark<>0) then\r
begin\r
write(testoutput,'   Family');\r
writeln(testoutput,'   First: ',t_first_offset,'   Last: ',t_last_offset);\r
write(testoutput,'   Name entry list: ');\r
print_symbol(t_name_entry_list);\r
write(testoutput,'   Seg: ',st_t_seg_nr,'   Used: ',fam_used);\r
if st_t_local_near then write(testoutput,'   Local')\r
else write(testoutput,'   Far');\r
writeln(testoutput,' segment calls   Mark: ',st_file_mark);\r
end;\r
print_typeaddr( type_address );\r
end;\r
write(testoutput,'   Param size: ',type_paramsize,'   Max offset: ',\r
st_type_maxoffset );\r
write(testoutput,'   Type label: ');\r
print_symbol(type_label);\r
writeln(testoutput);\r
end; (** ctype **)\r
\r
clabel:\r
begin\r
write(testoutput,'   Label scope: ',label_scope,'   Offset: ',label_offset,\r
'   Def as label: ');\r
print_symbol(DefAsLabel);\r
writeln(testoutput,'   Label low: ',label_low,'   Label high: ',label_high);\r
end;\r
\r
cexternal:\r
begin\r
write(testoutput, '   Fixup_no: ',fixup_no,'   Fixup_offset: ',\r
fixup_offset, '  Reference: ');\r
print_symbol(ext_ref);\r
write(testoutput,'   Owner: ');\r
print_symbol(ext_owner);\r
writeln(testoutput);\r
end;\r
\r
\r
cfunction, cprogram, cprocedure:\r
begin\r
writeln(testoutput,',  level: ',st_level, '  label: ',\r
st_label.va_high, ' ', st_label.va_low,\r
' param size: ',st_paramsize,'  varsize: ',st_varsize,\r
'  no: ',st_curno,' max offset: ',max_offset);\r
write(testoutput,'   first: ',first_offset,'   last: ',last_offset);\r
writeln(testoutput,'   name entry list: ',name_entry_list.va_high,' ',\r
                   name_entry_list.va_low);\r
write(testoutput,'   seg: ',st_seg_nr,'   nr: ',st_logic_nr);\r
if st_local_near then writeln(testoutput,'   local segment calls')\r
else writeln(testoutput,'   far segment calls');\r
if st_kind = cfunction then\r
writeln(testoutput,'result offset: ', func_result_offset)\r
else\r
begin\r
if st_kind=cprogram then\r
writeln(testoutput,'createsize: ',prog_createsize,\r
'  descriptor offset: ',prog_descr_offset);\r
end;\r
if not own_equal_addr(st_external_list,st_nilladdr) then\r
writeln('external list: ',st_external_list.va_high,' ',\r
st_external_list.va_low);\r
end;\r
\r
cvar, cvarparam, cinspectparam, cshared,\r
cforstat, csharedparam, cvalueparam, cwithvar, cwithstat,\r
clockvar:  \r
begin\r
write(testoutput,'   Level: ',var_level,'   Offset: ',var_offset,'   ');\r
if var_indir then writeln(testoutput,'Indirect address')\r
else writeln(testoutput,'Direct address');\r
if ord(var_indir)>1 then writeln(testoutput,'var_indir: ',ord(var_indir));\r
end;\r
\r
cscalar:\r
writeln(testoutput,'   Number: ',scalar_no);\r
\r
crecfield:\r
begin\r
case field_mode of\r
stat:\r
writeln(testoutput,'   Static   Field offset: ',field_offset);\r
dyn :\r
begin\r
write(testoutput,'   Dynamic   ');\r
print_typeaddr( field_addr );\r
end (* dyn *)\r
else (*otherwise*)\r
write(testoutput,'   Family   ');\r
print_typeaddr( field_addr );\r
end;\r
writeln(testoutput,'   Bit_size: ', bit_size, '   Bit offset: ', bit_offset);\r
end;\r
\r
csubrange, csettype:\r
begin\r
case subr_mode of\r
stat: writeln(testoutput,'   High: ',subr_high,'   Low: ',subr_low);\r
dyn_low: begin\r
write(testoutput,'   High: ',subr_high);   \r
print_typeaddr( subr_addr );\r
end;\r
dyn_high: begin\r
write(testoutput,'   Low:  ',subr_high);   \r
print_typeaddr( subr_addr );\r
end;\r
dyn:\r
print_typeaddr( subr_addr )\r
else (*otherwise*) print_typeaddr( subr_addr );\r
end; (* case *)\r
end;\r
\r
carraytype:\r
begin\r
if st_packed = ispacked then write(testoutput,'   Packed');\r
write(testoutput,'   Index type: ');\r
print_symbol(itype);\r
writeln(testoutput,'   Ebit_size: ', ebit_size );\r
print_typeaddr( array_addr );\r
end;\r
\r
crecordtype:\r
begin\r
if packed_rec=ispacked then write( testoutput,'   Packed');\r
write(testoutput,'   Former rec: ');\r
print_symbol(former_rec);\r
write(testoutput,'   Last field:  ');\r
print_symbol(last_recfield);\r
writeln(testoutput);\r
print_typeaddr( record_addr );\r
end;\r
\r
cstrucconst:\r
begin\r
write(testoutput,'   Label: ');\r
print_symbol(st_const_label);\r
write(testoutput,'   Chain: ');\r
print_symbol(strucchain);\r
end\r
\r
else (*otherwise*);\r
end; (** case kind **)\r
\r
\r
end;\r
end;\r
\r
\r
\r
\r
procedure init_element( kind : codes;\r
var ptr : st_elemptr );\r
var i : integer;\r
\r
begin\r
with ptr^ do\r
begin\r
st_kind:= kind;\r
\r
case kind of\r
\r
cendlevel:\r
begin\r
level_chain := st_nilladdr;\r
former_level := currant_level;\r
last_inserted:= obj_addr;\r
end;\r
\r
cexternal:\r
begin\r
ext_ref:= st_nilladdr;\r
fixup_no:= 0;\r
fixup_offset:= 0;\r
ext_owner:=st_nilladdr;\r
end;\r
\r
cdeclaration:\r
begin\r
st_next_decl:= st_nilladdr;\r
st_first_line:= st_nilladdr;\r
st_last_line:= st_nilladdr;\r
st_cross_symbol:= st_nilladdr;\r
st_cross_spix:= anonymousspix;\r
end;\r
\r
cnewline:\r
begin\r
st_line_no:=0;\r
st_next_line:= st_nilladdr;\r
end;\r
\r
cconstant:\r
begin\r
spec_struct:= [simpeltype];\r
typeref:= st_nilladdr;\r
st_size:= 0;\r
listref:= st_stopaddr;\r
st_listend:= false;\r
st_cross_addr:= st_nilladdr;\r
\r
const_kind:=csimpleconst;\r
const_val:=0;\r
end;\r
\r
ctype:\r
begin\r
spec_struct:= [simpeltype];\r
typeref:= st_nilladdr;\r
st_size:= 0;\r
listref:= st_stopaddr;\r
st_listend:= false;\r
st_cross_addr:= st_nilladdr;\r
st_family_ref:= st_nilladdr;\r
st_node_copy:= false;\r
st_specs:= no_specs;\r
\r
type_label:= st_nilladdr;\r
type_address := addr0type;\r
type_paramsize:= 0;\r
st_type_maxoffset:= 0;\r
type_mode:= stat;\r
t_name_entry_list:= st_nilladdr;\r
st_t_seg_nr:=0;\r
fam_used:=0;\r
st_t_local_near:=true;\r
st_file_mark:=0;\r
end;\r
\r
clabel:\r
begin\r
spec_struct:= [simpeltype];\r
listref:= st_stopaddr;\r
st_listend:= false;\r
st_cross_addr:= st_nilladdr;\r
\r
label_scope:= 0;\r
label_offset:= 0;\r
DefAsLabel:= st_nilladdr;\r
IF (Computer = RC5000) OR (Computer = RC3502) THEN MegaLabel_Offset := 0;\r
end;\r
\r
cfunction, cprogram, cprocedure:\r
begin\r
st_size := 0;\r
spec_struct:= [simpeltype];\r
typeref:= st_nilladdr;\r
listref:= st_stopaddr;\r
st_listend:= false;\r
st_cross_addr:= st_nilladdr;\r
st_family_ref:= st_nilladdr;\r
st_specs:= st_local;\r
\r
st_label:= st_stopaddr;\r
st_level:= 0;\r
st_curno:= 0;\r
prog_createsize:= 0;\r
if kind<>cprocedure then prog_descr_offset:= 0; (* func_result_offset:= 0; *)\r
max_offset:= 0;\r
first_offset:= 0;\r
last_offset:= 0;\r
name_entry_list:= st_nilladdr;\r
st_logic_nr:=0;\r
st_local_near:=true;\r
st_external_list:=st_nilladdr;\r
end;\r
\r
cvar, cwithvar, cwithstat, cforstat, cshared,\r
cinspectparam, cvalueparam, cvarparam, csharedparam,\r
clockvar:\r
begin\r
spec_struct:= [simpeltype];\r
typeref:= st_nilladdr;\r
st_size:= 0;\r
listref:= st_stopaddr;\r
st_listend:= false;\r
st_cross_addr:= st_nilladdr;\r
\r
var_indir:= false;\r
end;\r
\r
cscalar:\r
begin\r
spec_struct:= [simpeltype];\r
typeref:= type_addr;\r
st_size:= 0;\r
listref:= st_stopaddr;\r
st_listend:= false;\r
\r
scalar_count:= 0;\r
scalar_no   := 0;\r
end;\r
\r
cscalarelem:\r
begin\r
spec_struct:= [simpeltype];\r
typeref:= type_addr;\r
st_size:= 0;\r
listref:= st_stopaddr;\r
st_listend:= false;\r
st_cross_addr:= st_nilladdr;\r
\r
const_kind:= csimpleconst;\r
const_val:= scalar_count;\r
scalar_count:= scalar_count + 1;\r
end;\r
\r
crecfield:\r
begin\r
spec_struct:= [simpeltype];\r
typeref:= st_nilladdr;\r
st_size:= 0;\r
listref:= st_stopaddr;\r
st_listend:= false;\r
st_cross_addr:= st_nilladdr;\r
st_family_ref:= st_nilladdr;\r
st_node_copy:= false;\r
field_mode:= stat;\r
field_addr:=addr0type;\r
end;\r
\r
csubrange, csettype:\r
begin\r
spec_struct:= [simpeltype];\r
typeref:= st_nilladdr;\r
st_family_ref:= st_nilladdr;\r
st_node_copy:= false;\r
\r
subr_addr:= addr0type;\r
subr_mode:= stat;\r
subr_high:= 0;\r
subr_low:= 0;\r
end;\r
\r
carraytype:\r
begin\r
spec_struct:= [simpeltype];\r
typeref:= st_nilladdr;\r
st_size:= 0;\r
st_family_ref:= st_nilladdr;\r
st_node_copy:= false;\r
\r
st_packed:= notpacked;(* canonymous;*)\r
itype:= st_nilladdr;\r
ebit_size:= 0;\r
array_addr:= addr0type;\r
end;\r
\r
crecordtype:\r
begin\r
spec_struct:= [simpeltype];\r
typeref:= last_recaddr;\r
st_size:= 0;\r
listref:= st_stopaddr;\r
st_listend:= false;\r
st_cross_addr:= st_nilladdr;\r
st_family_ref:= st_nilladdr;\r
st_node_copy:= false;\r
\r
packed_rec:= notpacked; (*canonymous;*)\r
former_rec:= currant_rec;\r
last_recfield:= st_stopaddr;\r
record_addr:= addr0type;\r
currant_rec:= currant_addr;\r
end;\r
\r
cstrucelem,\r
cstrucconst:\r
begin\r
spec_struct:= [simpeltype];\r
typeref:= st_nilladdr;\r
st_size:= 0;\r
listref:= st_stopaddr;\r
st_listend:= false;\r
\r
used:= false;\r
st_const_label:= st_nilladdr;\r
strucchain := st_stopaddr;\r
end\r
\r
else(*otherwise*);\r
spec_struct:= [simpeltype];\r
typeref:= st_nilladdr;\r
st_size:= 0;\r
st_spix:=anonymousspix;\r
listref:= st_stopaddr;\r
st_listend:= false;\r
st_cross_addr:= st_nilladdr;\r
st_family_ref:= st_nilladdr;\r
st_node_copy:= false;\r
st_specs:= no_specs;\r
end; (* case *)\r
end; (* with *)\r
end;\r
\r
\r
procedure update_last( var ptr: st_elemptr );\r
var\r
res : word;\r
begin\r
res:= vmmunlock( stdescriptorptr^, last_elem );\r
if res = 0 then\r
begin\r
last_addr:= currant_addr;\r
last_elem:= ptr;\r
res:= vmmlock( stdescriptorptr^, last_elem );\r
end;\r
if res<>0 then fatal_error(vmm,res);\r
end;\r
\r
(*** end help procedure ***)\r
\r
(****** ROUTINES for manipulating the SYMBOL TABLE *******)\r
\r
\r
function st_searchdouble( spix: spixrange; endcode: codes;\r
var d_addr : st_address): boolean;\r
\r
(***\r
the function is checking double declarations.\r
endcode is the kind of a just created node with spix.\r
double declarations are alloved for forward declared types,\r
procedures and functions, and further for open functions,\r
else the result of the procedure is false and the addres of the\r
erronious node is returned in d_addr.\r
open procedures with same spix are linked together.\r
***)\r
var\r
save: st_address;\r
ptr    : st_elemptr;\r
found  : boolean;\r
begin\r
(*#BEGINTEST\r
if teststh then\r
begin\r
write(testoutput,'--> ST_SEARCHDOUBLE');\r
printstars;\r
end;\r
(*ENDTEST#*)\r
found:= false;\r
save:= d_addr;\r
while not found do\r
begin\r
elementretrieve( false, false, save, ptr );\r
(*#BEGINTEST\r
(*\r
if teststh then\r
begin\r
elem_print( ptr, save );\r
end;\r
*)\r
(*ENDTEST#*)\r
with ptr^ do\r
begin\r
if ( st_kind = cendlevel ) or (st_kind = ccontext) or ( st_spix = spix ) then\r
found:= true else save:= ptr^.st_inf.st_former;\r
end; (* with ptr *)\r
end; (* not found *)\r
\r
with ptr^ do\r
begin\r
if (st_kind = cendlevel) or (st_kind = ccontext) then\r
begin\r
found:= false;\r
d_addr:= st_nilladdr;\r
end else\r
if (endcode=ctype) or (endcode=cfunction) or (endcode=cprocedure) then\r
begin\r
d_addr:= save;\r
if st_kind=endcode then\r
begin\r
if st_specs = st_open then found:= false else\r
if st_specs = st_forward then\r
begin\r
found := false;\r
forward_exist:= true;\r
elementretrieve( false, true, save, ptr );\r
if endcode=ctype then ptr^.st_specs := no_specs else\r
ptr^.st_specs:= st_local;\r
end;\r
end;\r
end;\r
end;\r
st_searchdouble:= found;\r
(*#BEGINTEST\r
if teststh then\r
begin\r
write(testoutput,'<-- ST_SEARCHDOUBLE');\r
printstars;\r
end;\r
(*ENDTEST#*)\r
end;\r
\r
begin\r
end.\r
\r
«eof»
DataMuseum.dk

DANOSI

⟦3b46a6ed5⟧ TextFile

Derivation

TextFile
