DataMuseum.dk

top - download

    Length: 11493 (0x2ce5)
    Types: TextFile
    Names: »STHCOM.PAS«

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

TextFile

{$O+,F+}\r
unit sthcom;\r
interface\r
\r
uses pscplm, mpaunit,sthunit;\r
(**\r
this context contains types and routines concerning\r
the symbol table handler.\r
**)\r
\r
(****** ROUTINES for manipulating the SYMBOL TABLE *******)\r
\r
function equal_addr( addr1, addr2 : st_address ) : boolean;\r
\r
(** creates a node with name and kind, initialze the node and\r
returns addr and ptr of the node.\r
only used by pass1 **)\r
procedure st_declaration( kind : codes; name : string;\r
var addr : st_address; var ptr : st_elemptr );\r
\r
procedure st_copy_node( source : st_address; var addr : st_address;\r
                  var ptr : st_elemptr);\r
\r
\r
procedure st_insert_symbols( addr : st_address );\r
\r
procedure st_insert_headsymbol( addr : st_address );\r
\r
(** the node with address: addr is retrieved and locked.\r
the pointer to thiss node is returned in ptr.\r
former node is unlocked.\r
**)\r
procedure st_get( addr : st_address;\r
var ptr : st_elemptr );\r
\r
(** works as st_get, only the page is not locked or updated.\r
**)\r
procedure st_retrieve( addr : st_address;\r
var ptr : st_elemptr );\r
\r
function st_spixofname( name: string): spixrange; \r
\r
procedure st_nameofspix( spix : spixrange;\r
var nameptr : ptr_string );\r
\r
(** type_addr is the address of a typenode. Starting from this\r
node, the succeding typestructure nodes are retrieved and stops\r
either when typeaddress is st_nilladdr ( at standardtypes )\r
or when the nodekind is ether crecordtype, cscalar, carraytype\r
or cpointertype.\r
The pointer to thiss node is returned in res_ptr,\r
not locked, and update permitted.\r
**)\r
procedure st_getbasetype( addr: st_address; var res_ptr: st_elemptr );\r
\r
procedure st_gettype( addr : st_address; var ptr :st_elemptr );\r
\r
procedure st_retrievetype( addr : st_address; var ptr :st_elemptr );\r
\r
procedure st_lock( ptr: st_elemptr);\r
\r
procedure st_unlock( ptr : st_elemptr);\r
\r
procedure st_update( ptr : st_elemptr);\r
\r
procedure st_cross_init;\r
(*******************)\r
\r
implementation\r
\r
 uses sthint, vmmunit, nthunit;\r
function equal_addr( addr1, addr2 : st_address ): boolean;\r
begin\r
equal_addr:= (addr1.va_low = addr2.va_low) and\r
(addr1.va_high = addr2.va_high )\r
end;\r
\r
\r
procedure st_get( addr : st_address;\r
var ptr : st_elemptr );\r
\r
(***\r
Retrieve the node with address 'addr' and deliver the pointer to\r
the element in ptr. \r
***)\r
\r
var\r
res : word;\r
begin\r
\r
(*#begintest\r
if teststh then \r
begin\r
write(testoutput,'--> ST_GET');\r
printstars;\r
end;\r
(*endtest#*)\r
\r
\r
\r
res:= vmmretrieve(stdescriptorptr^, addr.va_high, addr.va_low, false, true, ptr);\r
if res <> 0 then fatal_error(vmm,res);\r
(*#begintest\r
if teststh then\r
begin\r
elem_print( ptr, addr );\r
write(testoutput,'<-- ST_GET');\r
printstars;\r
end;\r
(*endtest#*)\r
\r
(* endproc*)\r
end;\r
\r
\r
procedure st_retrieve( addr : st_address;\r
var ptr : st_elemptr );\r
\r
(***\r
Retrieve the node with address 'addr' and deliver the pointer to\r
the element in ptr.\r
***)\r
\r
var\r
res : word;\r
begin\r
\r
(*#begintest\r
if teststh then \r
begin\r
write(testoutput,'--> ST_RETRIEVE');\r
printstars;\r
end;\r
(*endtest#*)\r
\r
res:= vmmretrieve(stdescriptorptr^, addr.va_high, addr.va_low,\r
false, false, ptr);\r
if res <> 0 then fatal_error(vmm,res);\r
(*#begintest\r
if teststh then\r
begin\r
elem_print( ptr, addr );\r
write(testoutput,'<-- ST_RETRIEVE');\r
printstars;\r
end;\r
(*endtest#*)\r
\r
(* endproc*)\r
end;\r
\r
procedure st_lock( ptr: st_elemptr);\r
var\r
res : word;\r
begin\r
\r
(*#begintest\r
if teststh then\r
begin\r
writeln(testoutput,'--- ST_LOCK');\r
end;\r
(*endtest#*)\r
\r
res:=vmmlock(stdescriptorptr^, ptr);\r
if res <> 0 then writeln('fejl');\r
if res <> 0 then fatal_error(vmm,res);\r
\r
(* endproc*)\r
end;\r
\r
procedure st_unlock( ptr: st_elemptr);\r
var\r
res : word;\r
begin\r
\r
(*#begintest\r
if teststh then\r
begin\r
writeln(testoutput,'--- ST_UNLOCK');\r
end;\r
(*endtest#*)\r
\r
res:=vmmunlock(stdescriptorptr^, ptr);\r
if res <> 0 then fatal_error(vmm,res);\r
\r
(* endproc*)\r
end;\r
\r
procedure st_update( ptr: st_elemptr);\r
var\r
res : word;\r
begin\r
\r
(*#begintest\r
if teststh then \r
begin\r
writeln(testoutput,'--- ST_UPDATE');\r
end;\r
(*endtest#*)\r
\r
res:=vmmupdate(stdescriptorptr^, ptr);\r
if res <> 0 then fatal_error(vmm,res);\r
\r
(* endproc*)\r
end;\r
\r
procedure st_declaration( kind : codes; name : string;\r
var addr : st_address; var ptr : st_elemptr );\r
\r
(********\r
A new node of param: kind is created and initialized.\r
name is converted to a spix and saved in the node, who is\r
locked. Spix is checked for doubledeclaration. Eventually\r
open routines with equal names are linked.\r
Address and pointer for the node are returned in addr and ptr.\r
********)\r
\r
var\r
res    : word;\r
d_addr : st_address;\r
spix   : spixrange;\r
begin\r
(*#BEGINTEST\r
if teststh then\r
begin\r
write(testoutput,'--> ST_DECLARE');\r
printstars;\r
end;\r
(*ENDTEST#*)\r
forward_exist:= false;\r
res:= nthextend( spix, name );\r
if spix = anonymousspix then res:= 0;\r
elementextend( ptr, kind );\r
with ptr^ do\r
begin\r
st_spix:= spix;\r
st_inf.st_former:= obj_addr;\r
end;\r
addr:= currant_addr;\r
if res=st_double then\r
if kind<>ccontext then\r
begin\r
d_addr:= obj_addr;\r
if st_searchdouble( spix, kind, d_addr ) then errormsg( pass1, 109 )\r
else if not equal_addr( d_addr, st_nilladdr ) then\r
with ptr^ do\r
begin\r
st_listend:= forward_exist;\r
if not forward_exist then st_label:= d_addr (** only open routines **)\r
else (*** forward decl ***)\r
if kind=ctype then \r
begin\r
st_spix:= anonymousspix;\r
listref:= d_addr; (* forward *)\r
end; \r
end;  (**with ptr**)\r
end (** double **)\r
else if res<>0 then fatal_error(vmm,res);\r
obj_addr:= currant_addr;\r
type_kind:= kind = ctype;\r
if type_kind then\r
begin\r
type_addr:= addr;\r
save_typekind:= true;\r
end;\r
(*#begintest\r
if teststh then\r
begin\r
elem_print( ptr, currant_addr );\r
write(testoutput,'<-- ST_DECLARATION');\r
printstars;\r
end;\r
(*endtest#*)\r
(*endproc*)\r
end;\r
\r
procedure st_copy_node(source: st_address; var addr: st_address;\r
                  var ptr: st_elemptr);\r
var source_ptr: st_elemptr;\r
begin\r
(*#begintest\r
if teststh then\r
begin\r
write(testoutput,'--> ST_COPY_NODE');\r
printstars;\r
end;\r
(*endtest#*)\r
  elementretrieve(false,false,source,source_ptr);\r
  elementcopy(source,ptr,source_ptr^.st_kind);\r
  addr:= currant_addr;\r
(*#begintest\r
if teststh then\r
begin\r
elem_print( ptr, addr );\r
write(testoutput,'<-- ST_COPY_NODE');\r
printstars;\r
end;\r
(*endtest#*)\r
end;\r
\r
\r
procedure st_insert_symbols( addr : st_address );\r
var\r
res : word;\r
ptr : st_elemptr;\r
begin\r
(*#begintest\r
if teststh then\r
begin\r
write(testoutput,'--> ST_INSERT_SYMBOLS');\r
end;\r
(*endtest#*)\r
repeat\r
elementretrieve( false, false, addr, ptr );\r
if teststh then\r
begin\r
printstars;\r
elem_print(ptr, addr);\r
end;\r
res:= nthinsertsymbol( ptr^.st_spix, addr.va_high, addr.va_low );\r
if res <> 0 then fatal_error(vmm,res);\r
addr:= ptr^.listref;\r
until (addr.va_low=st_stopaddr.va_low) and \r
      (addr.va_high=st_stopaddr.va_high);\r
(*#begintest\r
if teststh then\r
begin\r
write(testoutput,'<-- ST_INSERT_SYMBOLS');\r
printstars;\r
end; \r
(*endtest#*)\r
end;\r
\r
procedure st_insert_headsymbol( addr : st_address );\r
var\r
res : word;\r
ptr : st_elemptr;\r
begin\r
(*#begintest\r
if teststh then\r
begin\r
write(testoutput,'--> ST_INSERT_HEADSYMBOL');\r
end;\r
(*endtest#*)\r
elementretrieve( false, false, addr, ptr );\r
res:= nthinsertsymbol( ptr^.st_spix, addr.va_high, addr.va_low );\r
if res <> 0 then fatal_error(vmm,res);\r
(*#begintest\r
if teststh then\r
begin\r
elem_print( ptr, addr );\r
write(testoutput,'--> ST_INSERT_SYMBOLS');\r
printstars;\r
end;\r
(*endtest#*)\r
\r
end;\r
\r
\r
\r
\r
procedure st_getbasetype( addr: st_address; var res_ptr: st_elemptr);\r
\r
(*******\r
Starting at addr, a typespec-node is searched for with kind\r
different from carraytype, cpointertype, crecordtype or cscalar.\r
In this case or if next typeref is nill, the searching is stoped,\r
and the pointer to this element is returned in res_ptr.\r
*******)\r
\r
var\r
c   : codes;\r
stop: boolean;\r
begin\r
(*#BEGINTEST\r
if teststh then\r
begin\r
write(testoutput,'--> ST_GETBASETYPE');\r
printstars;\r
end;\r
(*ENDTEST#*)\r
stop:=false;\r
if not equal_addr(addr,st_nilladdr) then\r
repeat\r
elementretrieve( false, false, addr, res_ptr );\r
c:= res_ptr^.st_kind;\r
stop:= (c=carraytype) or (c=crecordtype) or (c=cscalar) or\r
(c=cpointertype) or equal_addr(res_ptr^.typeref, st_nilladdr);\r
if not stop then addr:= res_ptr^.typeref;\r
until stop;\r
(*#BEGINTEST\r
if teststh then\r
begin\r
if stop then elem_print( res_ptr, addr );\r
write(testoutput,'<-- ST_GETBASETYPE');\r
printstars;\r
end;\r
(*ENDTEST#*)\r
end;\r
\r
procedure st_retrievetype( addr : st_address; var ptr : st_elemptr );\r
\r
(*****\r
Starting at addr , a node of kind different from ctype is searched\r
for. The pointer to this node is returned in ptr.\r
******)\r
\r
begin\r
(*#BEGINTEST\r
if teststh then\r
begin\r
write(testoutput,'--> ST_RETRIEVETYPE');\r
printstars;\r
end;\r
(*ENDTEST#*)\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
(*#BEGINTEST\r
if teststh then\r
begin\r
elem_print( ptr, addr );\r
write(testoutput,'<-- ST_RETRIEVETYPE');\r
printstars;\r
end;\r
(*ENDTEST#*)\r
end;\r
\r
procedure st_gettype( addr : st_address; var ptr : st_elemptr );\r
\r
(*****\r
Starting at addr , a node of kind different from ctype is searched\r
for. The pointer to this node is returned in ptr.\r
The node element is updated.\r
******)\r
\r
var res : word;\r
begin\r
(*#BEGINTEST\r
if teststh then\r
begin\r
write(testoutput,'--> ST_GETTYPE'); \r
printstars;\r
end;\r
(*ENDTEST#*)\r
st_retrievetype( addr, ptr );\r
res:=vmmupdate(stdescriptorptr^, ptr);\r
(*#BEGINTEST\r
if teststh then\r
begin\r
writeln(testoutput,'<-- ST_GETTYPE');\r
printstars;\r
end;\r
(*ENDTEST#*)\r
\r
end;\r
\r
\r
\r
\r
function st_spixofname( name: string): spixrange;  (*integer!?*)\r
\r
(******\r
Name is searched for in the nametable. If it is not found, a new\r
name-element is created. Spix is a kind of index to this element.\r
The spix indexing the new or the found element is retuned\r
in st_spixofname.\r
******)\r
\r
var spix : spixrange;\r
res : word;\r
begin\r
(*#BEGINTEST\r
if teststh then\r
begin\r
write(testoutput, '--> ST_SPIXOFNAME');\r
printstars;\r
end;\r
(*ENDTEST#*)\r
res:= nthextend( spix, name );\r
if (res<>0) and (res<>st_double) then fatal_error( vmm, res );\r
(*#BEGINTEST\r
if teststh then\r
begin\r
write(testoutput,'   Spix :', spix,'   Name: ');\r
writeln( testoutput, name);\r
write(testoutput,'<-- ST_SPIXOFNAME');\r
printstars;\r
end;\r
(*ENDTEST#*)\r
st_spixofname := spix;\r
end;\r
\r
\r
procedure st_nameofspix( spix : spixrange;\r
var nameptr : ptr_string );\r
\r
(*******\r
The name corresponding to spix is found in the nametable, and\r
a pointer to the name is returned in nameptr.\r
********)\r
\r
var\r
res : word;\r
begin\r
(*#BEGINTEST\r
if teststh then\r
begin\r
write(testoutput,'--- ST_NAMEOFSPIX');\r
write(testoutput,'   Spix: ', spix);\r
end;\r
(*ENDTEST#*)\r
res:= nthretrieve( spix, nameptr );\r
if (res<>0) then begin\r
nameptr:=anonymousstr;\r
end;\r
(*#BEGINTEST\r
if teststh then\r
begin\r
write(testoutput,'   Name: ');\r
writeln( testoutput, nameptr^);\r
end;\r
(*ENDTEST#*)\r
end;\r
\r
\r
procedure st_cross_init;\r
var res: word;\r
begin\r
(*#BEGINTEST\r
if teststh then\r
begin\r
write(testoutput,'--> ST_CROSS_INIT');\r
printstars;\r
end;\r
(*ENDTEST#*)\r
  res:=nthcrosssort(stdescriptorptr,last_cross,\r
                     st_nilladdr.va_high,st_nilladdr.va_low);\r
  if res <> 0 then fatal_error(vmm,res);\r
(*#BEGINTEST\r
if teststh then\r
begin\r
write(testoutput,'--> ST_CROSS_INIT');\r
printstars;\r
end;\r
(*ENDTEST#*)\r
end;\r
\r
end.\r
\r
«eof»