DataMuseum.dk

top - download

    Length: 11594 (0x2d4a)
    Types: TextFile
    Names: »STHP1.PAS«

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

TextFile

{$O+,F+}\r
unit sthp1;\r
(**\r
this context contains types and routines concerning\r
the symbol table handler concerning pass1.\r
**)\r
interface\r
uses pscplm,mpaunit,sthunit,sthint,sthcom,vmmunit,nthunit;\r
\r
var\r
pack_info : packedtype;\r
\r
\r
(** creates a levelnode, only used by pass1 **)\r
procedure st_beginlevel1;\r
\r
(** updates currant level, gets former level **)\r
procedure st_endlevel1;    (** used by pass1 **)\r
\r
(** called by pass1 when the pass has finished,\r
currant (first) level is made ready for pass2 by setting the\r
variable 'next_level' to zero **)\r
procedure st_lastend;\r
\r
\r
(** creates a node of a kind, describing a defining type,\r
eventually preseded by a node of kind ctype, if the peseding\r
node is not of thiss kind.\r
the returnparams addr and ptr are address and pointer to the\r
first node.\r
only user by pass1 **)\r
procedure st_newtype( kind : codes; var addr : st_address;\r
var ptr : st_elemptr );\r
\r
(** creates a node of 'kind', initialize the node and link it\r
to the node with address = parameter addr,( using the field\r
listref ), the address to the new node is returned\r
in the parameter addr.\r
only used by pass1   **)\r
procedure st_startlist( kind : codes; var addr : st_address );\r
\r
procedure st_start_reclist( var rec_addr : st_address );\r
\r
\r
(** creates a list element with 'name' and kind given from\r
the preseding startlist call. \r
the list elemens are linked together through the listref field,\r
the last listref has the value = 'st_stopaddr'.\r
only used by pass1   **)\r
procedure st_declarelist( name : string );\r
\r
\r
procedure st_routine_label( addr: st_address; specs: st_declaremode );\r
\r
procedure st_familytypenode( var addr : st_address; var ptr : st_elemptr );\r
\r
procedure st_restore_proglevel;\r
\r
(** the procedure is only used by pass1 **)\r
procedure st_endformal;\r
\r
(* ?? are the following routines necessary ?? *)\r
procedure st_rename(name : string);\r
\r
procedure st_labeldeclare( currentlabelscope: word );\r
\r
procedure st_endfieldlist;\r
\r
procedure st_endrecord;\r
\r
function st_endscalar: word;\r
\r
procedure st_endinclude;\r
\r
(*******************)\r
\r
implementation\r
\r
\r
procedure st_beginlevel1;\r
\r
(********\r
A node of kind cendlevel is created and the address is\r
inserted in level_chain in last_created_level.\r
At the same time, the address of last created node (obj_addr), in\r
current level is inserted in th 'last_inserted' field.\r
A levelnode is a part of the list of objects.\r
*********)\r
\r
var\r
cur_ptr, new_ptr : st_elemptr;\r
begin\r
(*#BEGINTEST\r
if teststh then\r
begin\r
write(testoutput,'--> ST_BEGINLEVEL1');\r
printstars;\r
end;\r
(*ENDTEST#*)\r
\r
elementextend( new_ptr, cendlevel );\r
currant_level_ptr^.last_inserted:= obj_addr;\r
last_created_level_ptr^.level_chain:= currant_addr;\r
\r
st_unlock(currant_level_ptr);\r
st_unlock(last_created_level_ptr);\r
currant_level:= currant_addr;\r
currant_level_ptr:= new_ptr;\r
st_lock(currant_level_ptr);\r
\r
last_created_level:= currant_addr;\r
last_created_level_ptr:= new_ptr;\r
st_lock(last_created_level_ptr);\r
new_ptr^.st_inf.st_former:= obj_addr;\r
(*#begintest\r
if teststh then\r
begin\r
printstars;\r
elem_print( new_ptr, currant_addr );\r
writeln( testoutput,'slut st_beginlevel1');\r
printstars;\r
end;\r
(*endtest#*)\r
obj_addr:= currant_level;\r
(*endproc*)\r
end; (* beginlevel1 *)\r
\r
\r
\r
procedure st_lastend;\r
\r
(********\r
The procedure is called\r
*********)\r
\r
var\r
res : word;\r
ptr : st_elemptr;\r
begin\r
(*#BEGINTEST\r
if teststh then writeln(testoutput,'   start st_lastend');\r
(*endtest#*)\r
st_unlock(currant_level_ptr);\r
st_unlock(last_created_level_ptr);\r
\r
currant_level:= first_level;\r
(* in pass1 first_next_level is the last created level before the next level *)\r
elementretrieve( false, false, first_next_level, last_created_level_ptr);\r
next_level:=last_created_level_ptr^.level_chain;\r
elementretrieve( true, false, currant_level, currant_level_ptr);\r
obj_addr:=currant_level_ptr^.last_inserted;\r
\r
(*#begintest\r
if teststh then\r
begin\r
printstars;\r
writeln(testoutput,'slut st_lastend');\r
printstars;\r
end;\r
(*endtest#*)\r
(*endproc*)\r
end;\r
\r
\r
\r
\r
procedure st_endlevel1;\r
\r
(*******\r
The procedure is closing the current level.\r
The current levelnode is retrieved and last_inserted is updated\r
with the last obj_addr. Then the former levelnode is retrieved,\r
and obj_addr is initiated with last_inserted from this levelnode,\r
who is now current level.\r
********)\r
\r
begin\r
(*#BEGINTEST\r
if teststh then\r
begin\r
writeln(testoutput,'  start st_endlevel1');\r
elem_print(currant_level_ptr,currant_level);\r
end;\r
(*ENDTEST#*)\r
\r
currant_level_ptr^.last_inserted:= obj_addr;\r
if equal_addr( currant_level_ptr^.former_level, st_nilladdr ) then\r
errormsg( pass1, 124 ) else\r
begin\r
st_unlock(currant_level_ptr);\r
currant_level:= currant_level_ptr^.former_level;\r
elementretrieve( true, true, currant_level, currant_level_ptr );\r
(*#BEGINTEST\r
if teststh then\r
elem_print(currant_level_ptr,currant_level);\r
(*ENDTEST#*)\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_endlevel1');\r
printstars;\r
end;\r
(*ENDTEST#*)\r
(*endproc*)\r
end;\r
\r
\r
procedure st_familytypenode( var addr: st_address; var ptr: st_elemptr );\r
\r
(*******\r
Creation of a dummy typenode, used when familytypes are binded.\r
********)\r
 \r
begin\r
elementextend( ptr, ctype );\r
addr:= currant_addr;\r
ptr^.st_spix:= anonymousspix;\r
end;\r
\r
\r
\r
procedure st_newtype( kind : codes; var addr : st_address;\r
\r
(********\r
A new_type_node is a node used for specifying a type.\r
*********)\r
\r
var ptr : st_elemptr );\r
(****  returnvalue of pointer is pointing to defining type_node;\r
  addr is address of the first node, which may be a dummy typenode.\r
****)\r
var\r
new_ptr, rec_ptr : st_elemptr;\r
c  : codes;\r
begin\r
(*#begintest\r
if teststh then writeln(testoutput,'  start st_newtype');\r
(*endtest#*)\r
\r
if type_kind then c:= kind else c:= ctype;\r
\r
elementextend( ptr, c );\r
addr:= currant_addr;\r
if not type_kind then\r
begin\r
if kind=cscalar then type_addr:= addr;\r
new_ptr:= ptr;\r
new_ptr^.st_spix:= anonymousspix;\r
st_lock(new_ptr);\r
elementextend( ptr, kind );\r
new_ptr^.typeref:= currant_addr;\r
st_unlock(new_ptr);\r
end;\r
\r
\r
(*#begintest\r
if teststh then\r
begin\r
printstars;\r
if not type_kind then\r
begin\r
writeln(testoutput,'type ptr');\r
elem_print( new_ptr, addr );\r
end;\r
writeln(testoutput,'ptr');\r
elem_print( ptr, currant_addr );\r
writeln(testoutput,'slut st_newtype');\r
printstars;\r
end;\r
(*endtest#*)\r
type_kind:= false;\r
end;\r
\r
\r
\r
\r
procedure st_startlist( kind : codes; var addr : st_address );\r
var\r
cur_ptr, new_ptr : st_elemptr;\r
begin\r
(*#begintest\r
if teststh then writeln(testoutput,'  start st_startlist');\r
(*endtest#*)\r
elementextend( new_ptr, kind );\r
if not equal_addr( addr, st_nilladdr) then\r
begin\r
st_lock(new_ptr);\r
elementretrieve( false, true, addr, cur_ptr );\r
if type_kind then type_kind:= false else\r
begin\r
while cur_ptr^.st_kind=ctype do\r
begin\r
addr:= cur_ptr^.typeref;\r
elementretrieve( false, true, addr, cur_ptr );\r
end;\r
end;\r
cur_ptr^.listref:= currant_addr;\r
st_unlock(new_ptr);\r
end;\r
list_start:= true;\r
\r
with new_ptr^ do\r
begin\r
list_kind:= st_kind;\r
st_spix:= anonymousspix;\r
end;\r
(*#begintest\r
if teststh then\r
begin\r
printstars;\r
writeln(testoutput,'slut st_startlist');\r
printstars;\r
end;\r
(*endtest#*)\r
addr:= currant_addr;\r
update_last( new_ptr );\r
end; (* startlist *)\r
\r
\r
\r
procedure st_start_reclist(  var rec_addr : st_address );\r
var\r
addr : st_address;\r
ptr, last_ptr : st_elemptr;\r
begin\r
(*#begintest\r
if teststh then writeln(testoutput,'  start st_start_reclist');\r
(*endtest#*)\r
elementretrieve( true, true, currant_rec, last_ptr );\r
pack_info:= last_ptr^.st_packed;\r
if not equal_addr( last_ptr^.last_recfield, st_stopaddr ) then\r
begin\r
addr:= last_ptr^.last_recfield;\r
st_unlock(last_ptr);\r
elementretrieve( true, true, addr, last_ptr );\r
end else addr:=st_nilladdr;\r
elementextend( ptr, crecfield );\r
st_unlock(last_ptr);\r
ptr^.st_spix:= anonymousspix;\r
ptr^.st_inf.st_former:= addr;\r
rec_addr:= currant_addr;\r
list_kind:= crecfield;\r
list_start:= true;\r
last_ptr^.listref:= currant_addr;\r
update_last(ptr);\r
\r
(*#begintest\r
if teststh then\r
begin\r
writeln(testoutput,'  slut st_start_reclist');\r
printstars;\r
end;\r
(*endtest#*)\r
end; (* startlist *)\r
\r
\r
procedure st_routine_label( addr: st_address; specs: st_declaremode );\r
var\r
ptr1, ptr2: st_elemptr;\r
begin\r
(* type, function, procedure or program *)\r
elementretrieve( false, true, addr, ptr1 );\r
if ptr1^.st_listend then ptr1^.st_listend:= false else\r
begin\r
st_lock(ptr1);\r
elementextend( ptr2, clabel );\r
st_unlock(ptr1);\r
ptr2^.st_spix:= ptr1^.st_spix;\r
with ptr1^ do\r
begin\r
st_specs:= specs;\r
if st_kind=ctype then\r
begin\r
type_mode:= fam;\r
type_label:= currant_addr\r
end else st_label:= currant_addr;\r
end;\r
end;\r
end;\r
\r
\r
\r
procedure st_declarelist( name : string );\r
var\r
res     : word;\r
new_ptr : st_elemptr;\r
addr    : st_address;\r
spix    : spixrange;\r
begin\r
(*#begintest\r
if teststh then writeln(testoutput,'  start st_declarelist');\r
(*endtest#*)\r
\r
res:= nthextend( spix, name );\r
if spix = anonymousspix then res:= 0;\r
\r
if not list_start then\r
begin\r
elementextend( new_ptr, list_kind );\r
last_elem^.st_listend:= false;\r
last_elem^.listref:= currant_addr;\r
new_ptr^.st_inf.st_former:=last_addr; (* only recfield *)\r
update_last( new_ptr );\r
end else begin\r
list_start:=false;\r
new_ptr:=last_elem;\r
currant_addr:=last_addr;\r
end;\r
\r
with new_ptr^ do \r
begin\r
st_spix:= spix;\r
st_listend:= true;\r
\r
if list_kind = crecfield then last_recaddr:= currant_addr else\r
begin\r
st_inf.st_former:= obj_addr;\r
obj_addr:= currant_addr;\r
end; (** not recfield **)\r
\r
if res=st_double then\r
begin\r
 (* test double declarations *)\r
addr:= st_inf.st_former;\r
if st_searchdouble( spix, list_kind, addr ) then errormsg( pass1, 109 );\r
end else\r
if res<>0 then fatal_error(vmm,res);\r
end; (** with **)\r
\r
(*#begintest\r
if teststh then\r
begin\r
printstars;\r
elem_print( new_ptr, currant_addr );\r
writeln(testoutput,'slut st_declarelist');\r
printstars;\r
end;\r
(*endtest#*)\r
end; (* end declare list *)\r
\r
\r
procedure st_restore_proglevel;\r
var ptr : st_elemptr;\r
begin\r
elementretrieve( false, true, obj_addr, ptr ); (* get programnode *)\r
if ptr^.st_kind = cprogram then\r
with ptr^ do\r
begin\r
obj_addr:= st_inf.st_former;\r
st_inf.st_former:= last_contextaddr;\r
end;\r
end;\r
\r
procedure st_endformal;\r
begin\r
type_kind:= save_typekind;\r
save_typekind:= false;\r
end;\r
\r
procedure st_rename(name : string);\r
var ptr:st_elemptr;\r
begin\r
elementretrieve(false,true,obj_addr,ptr);\r
ptr^.st_spix:= st_spixofname( name );\r
end;\r
\r
procedure st_labeldeclare( currentlabelscope : word );\r
var ptr:st_elemptr;\r
begin\r
elementretrieve(false,true,obj_addr,ptr);\r
ptr^.label_scope:= currentlabelscope;\r
end;\r
\r
procedure st_endinclude;\r
begin\r
last_contextaddr:= obj_addr;\r
end;\r
\r
function st_endscalar: word;\r
begin\r
st_endscalar:= scalar_count;\r
end;\r
\r
procedure st_endfieldlist;\r
var\r
ptr : st_elemptr;\r
addr: st_address;\r
begin\r
elementretrieve( false, true, currant_rec, ptr );\r
ptr^.last_recfield:= last_recaddr;\r
end;\r
\r
procedure st_endrecord;\r
var\r
ptr : st_elemptr;\r
begin\r
if equal_addr(currant_rec, st_nilladdr) then errormsg(pass1,124)(*end expected*)\r
else begin\r
elementretrieve( false, true, currant_rec, ptr );\r
with ptr^ do\r
begin\r
last_recaddr:= typeref;\r
typeref:= st_nilladdr;\r
currant_rec:= former_rec;\r
pack_info:= notpacked;\r
end;\r
(*\r
elementretrieve( false, false, currant_rec, ptr );\r
last_recaddr:= ptr^.last_recfield;\r
*)\r
end;\r
end;\r
\r
end.\r
\r
«eof»