⟦2ebd7b488⟧

TextFile

{$O+,F+}\r
unit sthp2;\r
interface\r
\r
uses pscplm, mpaunit, sthunit, sthint, sthcom, vmmunit, nthunit;\r
(**\r
this context contains types and routines concerning\r
the symbol table handler for pass2.\r
**)\r
\r
\r
(** updates currant level, gets former level **)\r
procedure st_endlevel;     (** used by pass2 **)\r
\r
\r
(** from currant level, next successor is made currant level **)\r
(**  used by pass2 only **)\r
procedure st_beginlevel2;\r
\r
\r
procedure st_end_program;\r
\r
procedure st_begin_program;\r
\r
\r
\r
(** the function is searching for a node with spix equal to the\r
parametervalue starting at a node with address = addr.\r
if the node is found, the value of st_searchlist is thue and\r
the addres and pointer to th node is returned to the parameters\r
addr and ptr, otherwise thei are refering to 'undeclared'.\r
only used by pass2    **)\r
function st_searchlist( spix : spixrange; var addr : st_address;\r
var ptr : st_elemptr ): boolean;\r
\r
(*\r
function st_doublefield( addr : st_address ): spixrange;\r
*)\r
\r
procedure st_insert_withsymbols( with_addr : st_address );\r
\r
\r
(** a node spix equal to the parametervalue is searched for.\r
if the node is found the value of the funtion is true and address\r
and pointer of the node are returned in the parameters: addr and\r
ptr.  If the node found in a with statement, the address with_addr\r
is the address of the corresponding withvar node, otherwise\r
with_addr is set to st_nilladdr.\r
if spix is not found, addr is the address of the undeclared node.\r
only used by pass2  **)\r
function st_search( spix : spixrange;\r
var addr, with_addr : st_address; var ptr : st_elemptr ): boolean;\r
\r
(**  searchs for a node with spix.\r
the result is true if found, and the pointer to nodeaddress is\r
returned in the parameter : ptr.\r
*)\r
function st_search_level( spix : spixrange; var ptr : st_elemptr ):\r
boolean;\r
\r
(** addr must be the address of the first node in a list.\r
the typereference: typeval is inserted in typeref in all listnodes,\r
stopping when listref is st_stopaddr.\r
the address of the last listnode is returned in the parameter addr.\r
**)\r
procedure st_insert_typeref( var addr : st_address;\r
typeval : st_address );\r
\r
(** it is checked if two parameter lists are equal, the one\r
starting in addr1, the other in addr2.\r
the function is used when checking forward declared procedures\r
and functions.\r
the result is true if the checking wass ok.\r
*)\r
function st_check_params( addr1, addr2: st_address ): boolean;\r
\r
(* two nodes with addresses addr and nextaddr are linked together\r
*)\r
\r
(*\r
procedure st_linknodes( addr, nextaddr : st_address );\r
*)\r
procedure st_beginrec;\r
\r
procedure st_endrec;\r
\r
procedure st_cross_decl( symbol: st_address; mode: codes; only_one: boolean );\r
\r
procedure st_cross_line( symbol: st_address; mode: codes );\r
\r
(*******************)\r
\r
implementation\r
\r
procedure st_endlevel;\r
var\r
res     : word;\r
cur_ptr : st_elemptr;\r
begin\r
(*#BEGINTEST\r
if teststh then writeln(testoutput,'  start st_endlevel');\r
(*ENDTEST#*)\r
\r
if equal_addr( currant_level_ptr^.former_level, st_nilladdr ) then\r
errormsg( pass1, 40 ) else\r
begin\r
res:= nthendlevel;\r
if res <> 0 then fatal_error(vmm,res);\r
st_unlock(currant_level_ptr);\r
currant_level:= currant_level_ptr^.former_level;\r
elementretrieve( true, false, currant_level, currant_level_ptr );\r
obj_addr:=currant_level_ptr^.last_inserted;\r
end;\r
(*#BEGINTEST\r
if teststh then\r
begin\r
printstars;\r
elem_print( currant_level_ptr, currant_level );\r
writeln(testoutput,'slut st_endlevel');\r
printstars;\r
end;\r
(*ENDTEST#*)\r
(*endproc*)\r
end;\r
\r
\r
\r
procedure st_beginlevel2;\r
var\r
res      : word;\r
cur_ptr  : st_elemptr;\r
addr     : st_address;\r
kind     : codes;\r
begin\r
(*#begintest\r
if teststh then writeln(testoutput,'  start beginlevel2');\r
(*endtest#*)\r
st_unlock(currant_level_ptr);\r
\r
currant_level:=next_level;\r
\r
elementretrieve( true, false, currant_level, currant_level_ptr );\r
\r
next_level:=currant_level_ptr^.level_chain;\r
obj_addr:=currant_level_ptr^.last_inserted;\r
(*#begintest\r
if teststh then\r
begin\r
printstars;\r
elem_print( currant_level_ptr, currant_level);\r
printstars;\r
end;\r
(*endtest#*)\r
res:= nthbeginlevel;\r
if res <> 0 then fatal_error(vmm, res);\r
addr:= obj_addr;\r
repeat\r
elementretrieve( false, false, addr, cur_ptr );\r
with cur_ptr^ do\r
begin\r
if int_kind=cendlevel then\r
begin\r
if not equal_addr(addr, st_nilladdr ) then\r
kind:= clabel (* jump around endlevel and continue *)\r
end\r
else begin\r
kind:= st_kind;\r
if kind = clabel then st_insert_headsymbol( addr );\r
end;\r
addr:=st_inf.st_former;\r
end; (* with *)\r
until kind <> clabel;\r
(*endproc*)\r
end;\r
\r
procedure st_end_program;\r
var\r
res     : word;\r
begin\r
(*#BEGINTEST\r
if teststh then writeln(testoutput,'  start st_end_program');\r
(*ENDTEST#*)\r
res:= nthendprogram;\r
if res <> 0 then fatal_error(vmm,res);\r
(*#BEGINTEST\r
if teststh then\r
begin\r
printstars;\r
writeln(testoutput,'slut st_end_program');\r
printstars;\r
end;\r
(*ENDTEST#*)\r
(*endproc*)\r
end;\r
\r
procedure st_begin_program;\r
var\r
res     : word;\r
begin\r
(*#BEGINTEST\r
if teststh then writeln(testoutput,'  start st_begin_program');\r
(*ENDTEST#*)\r
res:= nthbeginprogram;\r
if res <> 0 then fatal_error(vmm,res);\r
(*#BEGINTEST\r
if teststh then\r
begin\r
printstars;\r
writeln(testoutput,'slut st_begin_program');\r
printstars;\r
end;\r
(*ENDTEST#*)\r
(*endproc*)\r
end;\r
\r
\r
\r
\r
function searchlist( spix : spixrange; var addr : st_address;\r
var ptr : st_elemptr ): boolean;\r
var\r
found : boolean;\r
begin\r
found:= false;\r
elementretrieve( false,false,addr,ptr );\r
while ptr^.st_kind = ctype do\r
begin\r
addr:= ptr^.typeref;\r
elementretrieve( false,false,addr,ptr );\r
end;\r
\r
while not found do\r
begin\r
if ( ptr^.st_spix = spix ) or\r
equal_addr( ptr^.listref, st_stopaddr ) then found:= true\r
else begin\r
addr:= ptr^.listref;\r
elementretrieve( false,false,addr, ptr );\r
end;\r
end;\r
searchlist:= ptr^.st_spix = spix;\r
end;\r
\r
\r
function st_searchlist( spix : spixrange;\r
var addr : st_address; var ptr : st_elemptr ): boolean;\r
begin\r
if not equal_addr( addr, st_nilladdr ) and\r
   not equal_addr( addr, st_stopaddr ) then\r
begin\r
if searchlist( spix, addr, ptr ) then st_searchlist:= true else\r
begin\r
st_searchlist:= false;\r
addr:= st_undeclared_addr;\r
elementretrieve( false, false, addr, ptr );\r
end;\r
end else st_searchlist:= false;\r
end;\r
\r
(*function st_doublefield( addr: st_address ): spixrange;\r
type\r
recptr_type = ^rec;\r
\r
rec = record\r
former : recptr_type;\r
rec_spix: spixrange;\r
end;\r
\r
var\r
cont    : boolean;\r
spix    : spixrange;\r
ptr     : st_elemptr;\r
top, recptr: recptr_type;\r
\r
begin\r
recptr:= nil;\r
cont:= true;\r
elementretrieve( false, false, addr, ptr );\r
spix:= ptr^.st_spix;\r
while cont do\r
begin\r
if equal_addr( ptr^.listref, st_stopaddr ) then\r
begin\r
cont:= false;\r
st_doublefield:= anonymousspix;\r
end else\r
begin\r
new( top );\r
top^.former:= recptr;\r
top^.rec_spix:= spix;\r
addr:= ptr^.listref;\r
elementretrieve(false, false, addr, ptr );\r
spix:= ptr^.st_spix;\r
recptr:= top;\r
while recptr <> nil do\r
begin\r
if recptr^.rec_spix = spix then\r
begin\r
recptr:= nil;\r
cont:= false;\r
st_doublefield:= spix;\r
end else recptr:= recptr^.former;\r
end;\r
end;\r
end;\r
recptr:= top;\r
while recptr <> nil do\r
begin\r
recptr:= top^.former;\r
dispose( top );\r
top:= recptr;\r
end;\r
end;\r
*)\r
\r
\r
procedure st_insert_withsymbols( with_addr : st_address );\r
var\r
res  : word;\r
addr : st_address;\r
ptr  : st_elemptr;\r
\r
begin\r
(** get withvar_node **)\r
elementretrieve( false, false, with_addr, ptr );\r
(*\r
if (ptr^.st_kind <> cwithvar) and teststh\r
then elem_print( ptr, with_addr);\r
*)\r
res:= nthinsertsymbol( ptr^.st_spix, with_addr.va_high, with_addr.va_low );\r
if res <> 0 then fatal_error(vmm,res);\r
\r
(* only open fields when no renaming *)\r
if ptr^.st_spix = anonymousspix then begin\r
if not equal_addr( ptr^.typeref, st_nilladdr ) then\r
repeat\r
addr:= ptr^.typeref;\r
elementretrieve( false, false, addr, ptr );\r
until ptr^.st_kind <> ctype;\r
\r
if ptr^.st_kind = crecordtype then\r
begin\r
addr:= ptr^.listref;\r
while not equal_addr( addr, st_stopaddr ) do\r
begin\r
elementretrieve( false, false, addr, ptr );\r
(** with_addr, the start of the list, is inserted in stead of the\r
    address of the inserted spix **)\r
res:= nthinsertsymbol( ptr^.st_spix, with_addr.va_high, with_addr.va_low );\r
addr := ptr^.listref;\r
if res <> 0 then fatal_error(vmm,res);\r
end; (* not stop *)\r
end;\r
end;\r
end;\r
\r
\r
\r
\r
function st_search( spix : spixrange;\r
var addr, with_addr : st_address; var ptr: st_elemptr ): boolean;\r
var\r
cur_ptr  : st_elemptr;\r
list_addr,\r
cur_with_addr: st_address;\r
found,nyok, ok: boolean;\r
res      : word;\r
begin\r
(*#BEGINTEST\r
if teststh then\r
begin\r
writeln(testoutput);\r
writeln(testoutput,'  start search');\r
if equal_addr(addr, st_nilladdr) then\r
write(testoutput,'cur level : ',currant_level.va_high,' ',currant_level.va_low) \r
else\r
write(testoutput,'start addr : ', addr.va_high,' ',addr.va_low );\r
writeln( testoutput,'   spix : ', spix );\r
end;\r
(*ENDTEST#*)\r
\r
if equal_addr( currant_level, st_nilladdr) then nyok:= false else\r
begin\r
found:= false;\r
with_addr:= st_nilladdr;\r
ok:= true;\r
nyok:= true;\r
cur_with_addr := st_nilladdr;\r
\r
\r
\r
(****** new search ******)\r
res:= nthfindsymbol( spix, addr );\r
if res <> 0 then\r
begin\r
if res=st_nonexist then nyok:= false\r
else fatal_error(vmm,res);\r
end else\r
begin\r
elementretrieve( false, false, addr, ptr );\r
if (ptr^.st_kind = cwithvar) or (ptr^.st_kind = cwithstat) then\r
begin\r
if ptr^.st_spix <> spix then\r
begin\r
with_addr:= addr;\r
addr:= ptr^.listref;\r
nyok:= searchlist( spix, addr, ptr );\r
end;\r
\r
end; (** withvar **)\r
end;\r
if not nyok then\r
begin\r
addr:= st_undeclared_addr;\r
elementretrieve( false, false, addr, ptr );\r
end;\r
(*#BEGINTEST\r
if teststh then\r
begin\r
printstars;\r
writeln(testoutput,'NEW SEARCH');\r
elem_print(ptr, addr );\r
writeln(testoutput,'NEW WITH ADDR: ', with_addr.va_high,' ',with_addr.va_low);\r
writeln( testoutput,' slut  st_search');\r
printstars;\r
end;\r
(*ENDTEST#*)\r
 \r
end; (*  currant level <> nilladdr *)\r
st_search:= nyok;\r
end;\r
\r
\r
function st_search_level( spix : spixrange; var ptr : st_elemptr ):\r
boolean;\r
var\r
addr : st_address;\r
found: boolean;\r
begin\r
if teststh then\r
begin\r
writeln(testoutput);\r
writeln(testoutput,' search level');\r
end;\r
found:= false;\r
addr:= obj_addr;\r
while not found do\r
begin\r
elementretrieve( false, false, addr, ptr );\r
with ptr^ do\r
begin\r
if (st_spix = spix) or (int_kind = cendlevel ) then\r
found:= true else addr:= ptr^.st_inf.st_former;\r
end; (** with **)\r
end; (** not found **)\r
st_search_level:= ptr^.int_kind  <> cendlevel;\r
st_get( addr, ptr );\r
end;\r
\r
\r
procedure st_insert_typeref( var addr: st_address;\r
typeval : st_address );\r
\r
var\r
ptr : st_elemptr;\r
p_spec: st_protect_type;\r
begin\r
elementretrieve( false, false, typeval, ptr);\r
p_spec:= ptr^.spec_struct;\r
repeat\r
elementretrieve( false, true, addr, ptr );\r
with ptr^ do\r
begin\r
typeref:= typeval;\r
spec_struct:= p_spec;\r
if equal_addr( listref, st_stopaddr) or st_listend then st_listend:= true\r
else addr:= listref;\r
end; (* with *)\r
until ptr^.st_listend;\r
end;\r
\r
\r
function st_check_params( addr1, addr2 : st_address ): boolean;\r
var\r
ptr1, ptr2 : st_elemptr;\r
b1, stop   : boolean;\r
begin\r
(*#begintest\r
if teststh then writeln(testoutput,' start check params');\r
(*endtest#*)\r
if equal_addr(addr1, st_nilladdr) or equal_addr( addr2, st_nilladdr) then\r
st_check_params:= false else\r
begin\r
st_check_params:= true;\r
repeat\r
stop:= equal_addr( addr1, st_stopaddr);\r
b1  := equal_addr( addr2, st_stopaddr);\r
if stop <> b1 then\r
begin\r
st_check_params:= false;\r
stop:= true;\r
end else\r
if not stop then\r
begin\r
elementretrieve( true, false, addr1, ptr1 );\r
elementretrieve( false, false, addr2, ptr2 );\r
st_unlock(ptr1);\r
if ( ptr1^.st_spix = ptr2^.st_spix ) and \r
   ( ptr1^.st_kind = ptr2^.st_kind ) then\r
begin\r
  addr1:= ptr1^.listref;\r
  addr2:= ptr2^.listref;\r
  if not equal_addr( ptr1^.typeref, ptr2^.typeref ) then\r
  begin\r
    (* may be family, ^, subrange or set *)\r
    elementretrieve( true, false, ptr1^.typeref, ptr1 );\r
    elementretrieve( false, false, ptr2^.typeref, ptr2 );\r
    st_unlock(ptr1);\r
    if (ptr1^.st_spix=anonymousspix) and (ptr2^.st_spix=anonymousspix) then\r
    begin (* ^, subrange, or set *)\r
      elementretrieve( true, false, ptr1^.typeref, ptr1 );\r
      elementretrieve( false, false, ptr2^.typeref, ptr2 );\r
      st_unlock(ptr1);\r
      if (((ptr1^.st_kind=cpointertype) and (ptr2^.st_kind=cpointertype)) (*or\r
         ((ptr1^.st_kind=csubrange) and (ptr2^.st_kind=csubrange)) or\r
         ((ptr1^.st_kind=csettype) and (ptr2^.st_kind=csettype))   *) ) \r
         and equal_addr(ptr1^.typeref, ptr2^.typeref) then (* ok *)\r
      else begin\r
        st_check_params:= false;\r
        stop:=true;\r
      end;\r
    end else\r
      if (ptr1^.st_kind=ctype) and (ptr2^.st_kind=ctype) and\r
        ptr1^.st_node_copy and ptr2^.st_node_copy and\r
         equal_addr( ptr1^.st_family_ref, ptr2^.st_family_ref) then (* ok *)\r
      else begin\r
        st_check_params:= false;\r
        stop:=true;\r
      end;\r
  end; \r
end else\r
begin \r
st_check_params:= false;\r
stop:= true;\r
end; (* error *)\r
end; (* not stop *)\r
until stop;\r
end; (* ok *)\r
(*#begintest\r
if teststh then writeln(testoutput,'slut check params');\r
(*endtest#*)\r
end;\r
\r
\r
procedure st_beginrec;\r
var\r
res : word;\r
begin\r
res:= nthbeginlevel;\r
if res <> 0 then fatal_error(vmm,res);\r
end;\r
\r
procedure st_endrec;\r
var res : word;\r
begin\r
res:= nthendlevel;\r
if res <> 0 then fatal_error(vmm,res);\r
end;\r
\r
procedure st_cross_decl(symbol: st_address; mode: codes; only_one: boolean);\r
var symbol1, symbol2 : st_address;\r
    cur1_ptr, cur2_ptr : st_elemptr;\r
    next_symbol: st_address;\r
    line: word;\r
begin\r
repeat\r
(*#BEGINTEST\r
if teststh then\r
begin\r
printstars;\r
writeln(testoutput,'start st_cross_decl');\r
end;\r
(*ENDTEST#*)\r
  elementretrieve(true,true,symbol,cur1_ptr);\r
(*#BEGINTEST\r
if teststh then\r
begin\r
elem_print( cur1_ptr, symbol );\r
end;\r
(*ENDTEST#*)\r
  if mode=cnocode then\r
  begin\r
    line:=0;\r
    mode:=cur1_ptr^.st_kind;\r
  end \r
  else line:=linenumber;\r
  only_one:=only_one or cur1_ptr^.st_listend;\r
  next_symbol:=cur1_ptr^.listref;\r
  if cur1_ptr^.st_spix<>anonymousspix then\r
  begin\r
  if equal_addr(cur1_ptr^.st_cross_addr, st_nilladdr) then\r
  begin\r
    elementextend(cur2_ptr, cdeclaration);\r
    st_lock(cur2_ptr);\r
    symbol2:=currant_addr;\r
    cur1_ptr^.st_cross_addr:= symbol2;\r
    cur2_ptr^.st_cross_spix:=cur1_ptr^.st_spix;\r
    cur2_ptr^.st_cross_symbol:= symbol;\r
    st_unlock(cur1_ptr);\r
    elementextend(cur1_ptr, cnewline);\r
    symbol1:=currant_addr;\r
    with cur2_ptr^ do\r
    begin\r
      st_next_decl:= last_cross;\r
      st_first_line:= symbol1;\r
      st_last_line:= symbol1;\r
    end;\r
    last_cross:= symbol2;\r
    st_unlock( cur2_ptr );\r
    cur1_ptr^.st_next_line:= st_nilladdr;\r
    cur1_ptr^.st_line_no:=1;\r
(*#BEGINTEST\r
if teststh then\r
begin\r
printstars;\r
elem_print( cur2_ptr, symbol2 );\r
writeln(testoutput,'st_cross_decl');\r
end;\r
(*ENDTEST#*)\r
  end else\r
  begin\r
    st_unlock(cur1_ptr);\r
    elementretrieve(false,false,cur1_ptr^.st_cross_addr, cur2_ptr );\r
    elementretrieve(false,true,cur2_ptr^.st_first_line, cur1_ptr );\r
  end;\r
  with cur1_ptr^ do\r
  begin\r
    st_line[1]:= line;\r
    st_source[1]:= sourcenumber;\r
    st_line_mode[1]:= mode;\r
  end;\r
(*#BEGINTEST\r
if teststh then\r
begin\r
printstars;\r
elem_print( cur1_ptr, symbol1 );\r
writeln(testoutput,'slut st_cross_decl');\r
printstars;\r
end;\r
(*ENDTEST#*)\r
end;\r
symbol:=next_symbol;\r
until only_one or equal_addr(symbol,st_stopaddr);\r
end;\r
\r
procedure st_cross_line( symbol: st_address; mode: codes);\r
var symbol1, symbol2: st_address;\r
    cur1_ptr, cur2_ptr, help_ptr: st_elemptr;\r
    line_no:0..6;\r
begin\r
(*#BEGINTEST\r
if teststh then\r
begin\r
printstars;\r
writeln(testoutput,'start st_cross_line');\r
end;\r
(*ENDTEST#*)\r
  elementretrieve( false,false, symbol, cur1_ptr );\r
(*#BEGINTEST\r
if teststh then\r
begin\r
elem_print( cur1_ptr, symbol );\r
end;\r
(*ENDTEST#*)\r
  if cur1_ptr^.st_spix <> anonymousspix then\r
  begin\r
  symbol2:= cur1_ptr^.st_cross_addr;\r
  if equal_addr(symbol2, st_nilladdr) then\r
  begin\r
    st_cross_decl( symbol, cnocode ,true);\r
    elementretrieve( false,false, symbol, cur1_ptr );\r
    symbol2:= cur1_ptr^.st_cross_addr;\r
  end;\r
  elementretrieve( true, false, symbol2, cur2_ptr);\r
  symbol1:=cur2_ptr^.st_last_line;\r
  elementretrieve( false, true, symbol1, cur1_ptr);\r
  line_no:=cur1_ptr^.st_line_no+1;\r
  if mode = cassignstat THEN line_no:=line_no-1;\r
  if line_no>5 then\r
  begin\r
   st_lock(cur1_ptr);\r
   st_update(cur2_ptr);\r
   elementextend(help_ptr,cnewline);\r
   symbol1:=currant_addr;\r
   cur1_ptr^.st_next_line:=symbol1;\r
   cur2_ptr^.st_last_line:=symbol1;\r
   st_unlock(cur1_ptr);\r
   cur1_ptr:=help_ptr;\r
   cur1_ptr^.st_line_no:=1;\r
   line_no:=1;\r
  end else cur1_ptr^.st_line_no:=line_no;\r
  st_unlock(cur2_ptr);\r
  with cur1_ptr^ do\r
  begin\r
    st_line[line_no]:= linenumber;\r
    st_source[line_no]:= sourcenumber;\r
    st_line_mode[line_no]:= mode;\r
    st_next_line:= st_nilladdr;\r
  end;\r
(*#BEGINTEST\r
if teststh then\r
begin\r
printstars;\r
elem_print( cur1_ptr, symbol1 );\r
end;\r
(*ENDTEST#*)\r
end;\r
end;\r
\r
end.\r
\r
«eof»
DataMuseum.dk

DANOSI

⟦2ebd7b488⟧ TextFile

Derivation

TextFile
