⟦12e683a4b⟧

TextFile

{$O+,F+}\r
unit p2code;\r
\r
interface\r
uses pscplm,files,mpaunit,sthunit,sthcom,sthp2,rtp86mpa;\r
(*** CONSTANTS ***)\r
const\r
pass2_version= 500; (* 100*main version + sub version *)\r
demanded_pass1_version= 5; (* demanded pass 1 version number *)\r
(***\r
demanded_pass1_sub_version= 0; (* least acceptable sub version number *)\r
\r
(*\r
.    Main version numbers must be updated according to the version numbers\r
.    of the project plan. Sub version numbers are updated when the pass is \r
.    changed. Demanded sub version number MUST be changed when the interface\r
.    between pass1 and pass2 is changed \r
*)\r
\r
\r
(*** TYPES ***)\r
type\r
syntaxtype =\r
(\r
sactualparam,\r
scase, scompunit, sconst, sconstdecl, scontext,\r
sempty, sexpression,\r
sfield, sformallist, sforvar, sfunccall, sfunccalle, sfuncdecl,\r
sindex, sinitobj,\r
slevel, slock, slockbuf,\r
snull,\r
sopenfunccall, sopenfunccalle, sopenproccall,\r
sproccall, sprocdecl, sprogcall, sprogdecl,\r
sregion,\r
ssetlist, sshared, sstrucarrval, sstrucrecval,\r
stype, stypedecl, stypeid,\r
svar, svarfunc, svarprog,\r
swith\r
);\r
\r
\r
ptr_p2stack=^ p2stackelement;\r
\r
p2stackelement=record\r
                 former,\r
                 next: ptr_p2stack;\r
                 syntaxkind: syntaxtype;\r
                 nodeaddress,\r
                 p2_typeref,\r
                 p2_listref: st_address;\r
                 (* special components *)\r
                 misc_field: integer;\r
                             (* svar, 1 if assign to function *)\r
                             (* stype, 2 if typeid *)\r
                 p2_specstruc: st_protect_type;\r
               end;\r
\r
\r
(***VARIABLES ***)\r
var\r
\r
testpass2open,\r
test_stack,          (* booleans telling which of the different kinds of *)\r
test_out_2,           (* test output to produce *)\r
test_local,\r
test_pass1code : boolean;\r
\r
p2stacktop,                            (* pointer to stacktop *)\r
p2stackbase: ptr_p2stack;              (* pointer to stackbottom *)\r
\r
init_p2stackelement: p2stackelement;   (* well defined p2stack element used\r
                                       for initialization of new elements *)\r
\r
\r
before_assign,           (* indicates whether a function variable is used\r
*                 as a call of the function or it is for a function result *)\r
program_decl,            (* definition of a program heading *)\r
family_type_params,      (* set at TYPEDECL and reset at EDNTYPEDECL *)\r
declare_state,\r
in_lock_state,\r
local_declare_state,     (* indicating declaration within for-, lock- and with-statement *)\r
create_call,             (* indicate if a possible function call is a\r
*                           createcall                          *)\r
within_opencall,         (* indicate  openroutinecall   *)\r
global_level,\r
firstcontext,            (* true in first context false else *)\r
help_boolean,\r
set_result,\r
maybe_string_type,\r
is_string_Type,\r
maybe_set_type,\r
maybe_fam_type,\r
after_context: boolean;  (* true: in program part\r
                           false: in context part *)\r
new_comp_unit:boolean;\r
comp_unit,\r
comp_used_bit,\r
segment_nr: word;\r
opencount,               (* counting nested openroutinecalls **)\r
first_program_open,     (* start of opens at outermost program level *)\r
open_counter,           (* number of next open routine *) \r
repetitive_counter,     (* number of nested repetitive statements *)\r
record_nest_counter,    (* number of nested record declarations *)\r
cur_block_level: integer;   (* determines current block level *)\r
token: codes;              (* holds the current pass1 code i.e.\r
                              the last code read from input *)\r
temp_token: codes;\r
current_labelscope: word;\r
\r
erroraddress,\r
st2_start_search, (* start of backwards search chain inside current level,\r
*                    when searching for constants, types, variables, or shared\r
*                    elements during the declaration part handling *)\r
cross_addr,\r
st2_hlp_address,\r
st2_cur_address: st_address;\r
st2_hlp_ptr,\r
st2_cur_ptr: st_elemptr;\r
routine_specstruc,  (* holds special structures declared within current *)\r
(*                     routine declaration     *)\r
ill_shared_types, (* SHARED declarations must not contain process or chain *)\r
ill_routine_types, (* SHIELDED types except REFERENCE may not be declared \r
                      in routines  *)\r
protected_types,  (* shielded or pointer *)\r
shielded_types: st_protect_type;\r
\r
helpstr: string;\r
string_spix,\r
pred_spix,\r
succ_spix: spixrange;\r
help_specs: st_declaremode;\r
cross,compile_info: boolean;\r
\r
procedure write_p2stack;\r
procedure p2_fatal_error(error_no: word);\r
procedure write_kind(skind: syntaxtype);\r
procedure write_specstruc(struc: st_protect_type);\r
procedure write_stacktop(push: integer);\r
procedure init_p2stack;\r
procedure push_p2stack;\r
procedure pop_p2stack;\r
procedure pushresult(operator: codes);\r
procedure decode_test_options;\r
function getcode: codes;\r
procedure getaddress(var addr: st_address);\r
procedure putaddress(addr: st_address);\r
procedure dump_cnull_and_check(addr:st_address);\r
procedure read_push_dump(token: codes; stoken: syntaxtype);\r
procedure read_push_dump_type(token: codes);\r
procedure dump_info(addr: st_address);\r
procedure initialize;\r
procedure std_context_init;\r
procedure original_node(var node_addr: st_address;\r
                        var node_ptr: st_elemptr);\r
function sametype(tl,tr: st_address): boolean;\r
function int_word_byte(node_addr: st_address): boolean;\r
function compatible(tl,tr: st_address): boolean;\r
function ordinaltype(code: codes): boolean;\r
function machinetype(code: codes): boolean;\r
function protectedtype(code: codes): boolean;\r
procedure begin_level_action;\r
procedure end_level_action;\r
procedure check_legal_param_type(param_ref, type_ref: st_address);\r
procedure routine_block_lookahead;\r
procedure push_opencall;\r
procedure bind_open;\r
procedure pop_opencall;\r
procedure copy_type(original_symb: st_address; var copy_symb: st_address);\r
\r
implementation\r
(*** ROUTINES ***)\r
\r
function btype(taddr: st_address; tptr: st_elemptr; tkind: codes):boolean;\r
forward;\r
function wtype(taddr: st_address; tptr: st_elemptr; tkind: codes):boolean;\r
forward;\r
\r
procedure write_p2stack;\r
var\r
p2_ptr: ptr_p2stack;\r
begin\r
p2_ptr:= p2stackbase;\r
writeln(testoutput,'CONTENTS OF PASS2 STACK: ');\r
repeat\r
with p2_ptr^ do\r
begin\r
writeln(testoutput,'*********************************');\r
write(testoutput,'SYNTAXKIND: ');\r
write_kind(syntaxkind);\r
end;\r
p2_ptr:= p2_ptr^.next;\r
until p2_ptr= nil;\r
writeln(testoutput,'*********************************');\r
end;\r
\r
procedure p2_fatal_error(error_no: word);\r
begin\r
if test_out_2 then \r
write_p2stack;\r
fatal_error(pass2, error_no);\r
end; (* p2 fatal error *)\r
\r
\r
(*** P2 STACK ROUTINES***)\r
\r
\r
procedure write_kind(skind: syntaxtype);\r
begin\r
case skind of\r
sactualparam: writeln(testoutput, 'actualparam');\r
scase       : writeln(testoutput, 'case');\r
scompunit   : writeln(testoutput, 'compunit');\r
sconst      : writeln(testoutput, 'const');\r
sconstdecl  : writeln(testoutput, 'constdecl');\r
scontext    : writeln(testoutput, 'context');\r
sempty      : writeln(testoutput, 'empty');\r
sexpression : writeln(testoutput, 'expression');\r
sfield      : writeln(testoutput, 'field');\r
sformallist : writeln(testoutput, 'formallist');\r
sforvar     : writeln(testoutput, 'forvar');\r
sfunccalle,\r
sfunccall   : writeln(testoutput, 'funccall');\r
sfuncdecl   : writeln(testoutput, 'funcdecl');\r
sindex      : writeln(testoutput, 'index');\r
sinitobj    : writeln(testoutput, 'initobj');\r
slevel      : writeln(testoutput, 'level');\r
slock       : writeln(testoutput, 'lock');\r
slockbuf    : writeln(testoutput, 'lockbuf');\r
snull       : writeln(testoutput, 'null');\r
sopenfunccalle,\r
sopenfunccall: writeln(testoutput, 'openfunccall');\r
sopenproccall: writeln(testoutput, 'openproccall');\r
sproccall   : writeln(testoutput, 'proccall');\r
sprocdecl   : writeln(testoutput, 'procdecl');\r
sprogcall   : writeln(testoutput, 'progcall');\r
sprogdecl   : writeln(testoutput, 'progdecl');\r
sregion     : writeln(testoutput, 'region');\r
ssetlist    : writeln(testoutput, 'setlist');\r
sshared     : writeln(testoutput, 'shared');\r
sstrucarrval: writeln(testoutput, 'strucarrval');\r
sstrucrecval: writeln(testoutput, 'strucrecval');\r
stype       : writeln(testoutput, 'type');\r
stypedecl   : writeln(testoutput, 'typedecl');\r
stypeid     : writeln(testoutput, 'typeid');\r
svar        : writeln(testoutput, 'var');\r
svarfunc    : writeln(testoutput, 'varfunc');\r
svarprog    : writeln(testoutput, 'varprog');\r
swith       : writeln(testoutput, 'with')\r
else     writeln(testoutput, 'unknown syntax kind: ', ord(skind));\r
end;\r
end;\r
\r
procedure write_specstruc(struc: st_protect_type);\r
var\r
step: protect_spec;\r
begin\r
if struc <> [] then\r
begin\r
writeln(testoutput);\r
write(testoutput, 'p2_specstruc: ');\r
for step := simpeltype to programtype do\r
if step in struc then\r
case step of\r
simpeltype:  writeln(testoutput, 'simpel');\r
xpackedtype: writeln(testoutput, 'packed');\r
pointertype:      writeln(testoutput, 'pointer');\r
mailboxtype: writeln(testoutput, 'mailbox');\r
referencetype:   writeln(testoutput, 'reference');\r
pooltype: writeln(testoutput, 'pool');\r
processtype: writeln(testoutput, 'process');\r
programtype: writeln(testoutput, 'program');\r
porttype: writeln(testoutput, 'port');\r
chaintype: writeln(testoutput, 'chain');\r
mailboxpointer: writeln(testoutput, 'mailboxpointer')\r
else\r
writeln(testoutput, 'unknown spec-struc.')\r
end; (* case *)\r
end;\r
end; (* output specstruc *)\r
\r
procedure write_stacktop(push: integer);\r
begin\r
with p2stacktop^ do\r
begin\r
if (push=1) then\r
writeln(testoutput,\r
'********************STACKTOP before PUSH P2STACK******************')\r
else\r
if (push=0) then\r
writeln(testoutput,\r
'********************STACKTOP after POP  P2STACK******************')\r
else\r
writeln(testoutput,\r
'********************STACKTOP*************************************');\r
writeln(testoutput, 'linenumber: ', linenumber,'     token: ',ord(token));\r
write(testoutput,\r
'syntaxkind   : '); write_kind(syntaxkind);\r
write(testoutput,\r
'nodeaddress: ',nodeaddress.va_high: 3,nodeaddress.va_low: 4);\r
write(testoutput,\r
', p2-typeref: ',p2_typeref.va_high: 3,p2_typeref.va_low: 4);\r
writeln(testoutput);\r
write(testoutput,\r
', p2-listref: ',p2_listref.va_high: 3,p2_listref.va_low: 4);\r
if misc_field<>0 then\r
write(testoutput,\r
', misc_field   : ',ord(misc_field): 3);\r
\r
if p2_specstruc <> [] then\r
write_specstruc(p2_specstruc)\r
else\r
writeln(testoutput);\r
end;\r
end; (* write stacktop *)\r
\r
\r
procedure init_p2stack;\r
begin\r
new(p2stackbase);\r
p2stackbase^:= init_p2stackelement;\r
with p2stackbase^ do\r
syntaxkind:= scompunit;\r
p2stacktop:= p2stackbase;\r
end; (* init_p2stack *)\r
\r
procedure push_p2stack;\r
var\r
helpptr: ptr_p2stack;\r
begin\r
if test_stack then write_stacktop(1);\r
new(helpptr);\r
helpptr^:= init_p2stackelement;\r
helpptr^.former:= p2stacktop;\r
p2stacktop^.next:= helpptr;\r
p2stacktop:= helpptr;\r
end;\r
\r
procedure pop_p2stack;\r
var\r
helpptr: ptr_p2stack;\r
begin\r
if p2stacktop <> p2stackbase then\r
begin\r
helpptr:= p2stacktop;\r
p2stacktop:= helpptr^.former;\r
p2stacktop^.next:= nil;\r
dispose(helpptr);\r
end\r
else \r
begin\r
writeln('p2stack underflow');\r
p2_fatal_error(1);\r
end;\r
if test_stack then write_stacktop(0);\r
end; (* pop_p2stack *)\r
\r
\r
procedure pushresult(operator: codes);\r
(* pop the operands (type information nodes) and push the type of the expression *)\r
var\r
(* #begintest \r
procname: string[12];\r
(* endtest# *)\r
tl,tr: st_address;\r
boo: boolean;\r
expr_kind: syntaxtype;\r
begin\r
(* #begintest \r
procname:= 'pushresult  ';\r
(* endtest# *)\r
with p2stacktop^ do\r
begin\r
tl:= former^.p2_typeref; (* type of left operand *)\r
tr:= p2_typeref;         (* type of right operand *)\r
expr_kind:= syntaxkind;\r
end;\r
pop_p2stack; (* remove right operand *)\r
with p2stacktop^ do (* reuse the leftoperand element as result *)\r
begin\r
case operator of\r
ceq,cne,cle,cge,cgt,clt,cle,cin: \r
(*type of expression is boolean *)\r
boo:= stdcode_to_address(cboolean,p2_typeref);\r
\r
cadd,csub,cslash,cmul,cdiv,cmod,\r
(* type of expression is either word,byte or integer *)\r
(* in case of integer result left operand must be of kind integer *)\r
cand,cor,cxor: \r
(* type of expression is either word byte or boolean *)\r
if code_of_address(tr)=cword then\r
p2_typeref:= tr;\r
(* all other cases tl equals type of expression so no action *)\r
\r
cshift:; (* no action since tl equals type of expression *)\r
\r
cerror: boo:= stdcode_to_address(cerror, p2_typeref)\r
\r
else p2_fatal_error(6); (* pass2 inconsistency *)\r
\r
end; (* case *)\r
if (syntaxkind<>expr_kind) or (expr_kind=svar) or (expr_kind = ssetlist) then\r
syntaxkind:= sexpression;\r
end; (* with *)\r
end; (* push result *)\r
\r
\r
procedure decode_test_options;\r
var\r
test2: integer;\r
begin\r
if testpass2open then \r
begin\r
test2:= testpass2;\r
test_stack:= odd(test2); (* test bit0 *)\r
test2:= test2 div 2;\r
test_out_2:= odd(test2); (* test bit1 *)\r
test2:= test2 div 2;\r
(* test bit 2 *)\r
test2:= test2 div 2;\r
test_local:= odd(test2); (* test bit3 *)\r
test2:= test2 div 2;\r
test_pass1code:= odd(test2); (* test bit4 *)\r
end;\r
\r
test2 := testpass2 div 256;\r
if odd(test2) and testpass2open (* test bit 8 *) then teststh:=true;\r
test2 := test2 div 2;\r
if odd(test2) (* test bit 9 *) then teststh:=false;\r
test2 := test2 div 2;\r
if odd(test2) and (original_testvmm>=0) (* test bit 10 *)\r
then testvmmupdate := true;\r
test2 := test2 div 2;\r
if odd(test2) (* test bit 11 *) then testvmmupdate:=false;\r
test2 := test2 div 2;\r
if odd(test2) and testpass2open (* test bit 12 *) then teststhsearch:=true;\r
test2 := test2 div 2;\r
if odd(test2) (* test bit 13 *) then teststhsearch:=false;\r
\r
\r
end; (* decode test options *)\r
\r
\r
function getcode: codes;\r
label 0; (* start of procedure, pseudo recursive call *)\r
var\r
nextinp: codes;\r
opt_val: word;\r
opt_dest: modulerange;\r
opt: option_tokens;\r
begin\r
0:\r
(* reads the next word of infile and converts it to a code i. e.\r
  next token *)\r
nextinp:= codes(get_byte);\r
\r
case nextinp of\r
cnewline: \r
begin\r
linenumber:= get_2_byte;\r
elementnumber:= 0;\r
put_byte(ord(cnewline));\r
put_2_byte(linenumber);\r
goto 0; (* skip to next code *)\r
end;\r
\r
coption: \r
begin\r
opt_dest:= modulerange(get_2_byte);\r
opt:= option_tokens(get_2_byte);\r
opt_val:= get_2_byte;\r
if opt_dest<>pass2 then\r
begin\r
if opt_dest=allpass then\r
begin\r
case opt of\r
versionpass1: begin\r
if (opt_val div 100 <> demanded_pass1_version) then\r
(**\r
 or (opt_val mod 100 < demanded_pass1_sub_version) then\r
**)\r
p2_fatal_error(5);\r
(* wrong pass1/pass2 pair *)\r
end;\r
sourceno_: begin\r
sourcenumber:= opt_val;\r
if call_options.savecode then opt_val := 1;\r
end\r
else\r
warning(pass2, 174);\r
(* unknown option *)\r
end; (* case *)\r
end (* all pass option *)\r
else\r
if (opt_dest=vmm) and (opt=test_) and testvmmupdate then\r
testvmm:= opt_val;\r
\r
put_byte(ord(coption)); (* send option to next pass *)\r
put_2_byte(ord(opt_dest));\r
put_2_byte(ord(opt));\r
put_2_byte(opt_val);\r
end\r
else (* pass2 options *)\r
case opt of\r
test_: begin\r
testpass2:= opt_val;\r
decode_test_options;\r
end\r
else \r
warning(pass2, 174);\r
(* unknown option *)\r
end; (* case *)\r
\r
goto 0; (* skip to next code *)\r
end (* coption *)\r
\r
else getcode:= nextinp;\r
end; (* case *)\r
end;\r
\r
procedure getaddress(var addr: st_address);\r
begin\r
(* reads two words and converts them to an st_address *)\r
with addr do\r
begin\r
va_low:= get_2_byte;\r
va_high:= get_2_byte;\r
end;\r
end;\r
\r
\r
procedure putaddress(addr: st_address);\r
begin\r
(* convert an st_address to two words and write them to outfile *)\r
with addr do\r
begin\r
put_2_byte(va_low);\r
put_2_byte(va_high);\r
end;\r
end;\r
\r
procedure dump_cnull_and_check(addr:st_address);\r
begin\r
(**** HHA\r
if not equal_addr(addr,st_mailboxtype_addr) then\r
if not equal_addr(addr,st_referencetype_addr) then\r
if not equal_addr(addr,st_pooltype_addr) then\r
if not equal_addr(addr,st_processtype_addr) then\r
if not equal_addr(addr,st_porttype_addr) then\r
if not equal_addr(addr,st_chaintype_addr) then\r
begin\r
st_retrievetype(addr,st2_cur_ptr);\r
if not protectedtype(st2_cur_ptr^.st_kind) then\r
errormsg(pass2,168);\r
end;\r
*****)\r
put_byte(ord(cnull));\r
putaddress(addr);\r
end;\r
\r
procedure read_push_dump(token: codes; stoken: syntaxtype);\r
(* used to handle rule: *)\r
(* TOKEN(ST_ADDRESS)---> *)\r
(* when pass2code and pass1code are identical *)\r
(* and the only actions to be taken are: *)\r
(* read rule, push syntaxkind to stack,\r
increment element counter, and write rule *)\r
(* #begintest \r
var\r
procname: string[12];\r
(* endtest# *)\r
begin\r
(* #begintest \r
procname:= 'read push du';\r
(* endtest# *)\r
push_p2stack;\r
with p2stacktop^ do\r
begin\r
syntaxkind:= stoken;\r
getaddress(nodeaddress);\r
elementnumber:= elementnumber+1;\r
put_byte(ord(token));\r
putaddress(nodeaddress);\r
end;\r
end;\r
\r
\r
procedure read_push_dump_type(token: codes);\r
(* used to handle rule: *)\r
(* TOKEN(ST_ADDRESS)---> *)\r
(* when pass2code and pass1code are identical *)\r
(* and the only actions to be taken are: *)\r
(* read rule, push syntaxkind to stack, write code followed by address of\r
defining type (typeref of the read symbol *)\r
(* #begintest \r
var\r
procname: string[12];\r
(* endtest# *)\r
begin\r
(* #begintest \r
procname:= 're pu du typ';\r
(* endtest# *)\r
push_p2stack;\r
with p2stacktop^ do\r
begin\r
syntaxkind:= stype;\r
getaddress(nodeaddress);\r
put_byte(ord(token));\r
st_retrieve(nodeaddress, st2_cur_ptr);\r
if st2_cur_ptr^.st_kind=ctype then\r
begin\r
putaddress(st2_cur_ptr^.typeref);\r
p2_specstruc := st2_cur_ptr^.spec_struct;\r
end\r
else\r
putaddress(nodeaddress);\r
end;\r
end; (* read push dump type *)\r
\r
procedure dump_info(addr: st_address);\r
begin\r
(*\r
  comm^:=sourcenumber; put(comm);\r
  comm^:=linenumber mod 256; put(comm);\r
  comm^:=linenumber div 256; put(comm);\r
  comm^:=addr.va_low mod 256; put(comm);\r
  comm^:=addr.va_low div 256; put(comm);\r
  comm^:=addr.va_high mod 256; put(comm);\r
  comm^:=addr.va_high div 256; put(comm);\r
*)\r
  blockwrite( comm, sourcenumber, 1);\r
  blockwrite( comm, linenumber, 2);\r
(*  blockwrite( comm, hi(linenumber), 1);*)\r
  blockwrite( comm,addr,4);\r
(*\r
  blockwrite( comm, lo(addr.va_low), 1);\r
  blockwrite( comm, hi(addr.va_low), 1);\r
  blockwrite( comm, lo(addr.va_high), 1);\r
  blockwrite( comm, hi(addr.va_high), 1);\r
*)\r
\r
end;\r
\r
\r
(*** INITIALIZATION PROCEDURE ***)\r
procedure initialize;\r
begin\r
cross:=(call_options.listing=2) and (call_options.xref<>1);\r
compile_info:=true;\r
set_result:=false;\r
before_assign:= false;\r
global_level:= true;\r
cur_block_level:= context_level;\r
new_comp_unit:=false;\r
comp_unit:=0;\r
comp_used_bit:=0; (*last_comp_unit_bit;*)\r
segment_nr:=1;\r
after_context:= false;\r
create_call:= false;\r
opencount := 0;\r
within_opencall := false;\r
local_declare_state := false;\r
in_lock_state := false;\r
declare_state:= true;\r
family_type_params:= false;\r
test_stack := false;\r
test_out_2 := false;\r
test_local := false;\r
test_pass1code := false;\r
st2_start_search:= st_nilladdr;\r
open_counter:= 0; (* first open routine has number 0 *)\r
repetitive_counter:= 0; (* outside repetitive statements *)\r
routine_specstruc := [];\r
ill_shared_types:= [processtype, programtype, chaintype];\r
shielded_types:= [mailboxtype, referencetype, pooltype, processtype,\r
porttype, chaintype, programtype];\r
ill_routine_types:=shielded_types-[ referencetype ];\r
protected_types:= shielded_types+[pointertype,mailboxpointer];\r
if call_options.loadcode<=1 then\r
firstcontext := false\r
else\r
begin\r
firstcontext:= true;\r
st_dataarea_type_addr:= st_undeclared_addr;\r
st_buffer_type_addr:= st_undeclared_addr;\r
st_string_type_addr:= st_undeclared_addr;\r
end;\r
if not stdcode_to_address(cerror,erroraddress) then \r
p2_fatal_error(7);\r
(* mismatch in stdnames *)\r
(** spix of string **)\r
helpstr:= 'STRING';\r
\r
string_spix := st_spixofname(helpstr);\r
\r
\r
\r
(** ad PRED AND SUCC **)\r
helpstr:= 'PRED';\r
pred_spix := st_spixofname(helpstr);\r
\r
helpstr:='SUCC';\r
succ_spix := st_spixofname(helpstr);\r
(**  ****************** **)\r
\r
with init_p2stackelement do\r
begin\r
syntaxkind:= sempty;\r
nodeaddress:= st_nilladdr;\r
p2_typeref:= st_nilladdr;\r
p2_listref:= st_nilladdr;\r
misc_field:= 0;\r
p2_specstruc := [];\r
former:= nil;\r
next:= nil;\r
end;\r
\r
init_p2stack;\r
\r
(* initalize test output booleans *)\r
testpass2open:=testpass2>=0;\r
decode_test_options;\r
if testpass2open then testvmm:= original_testvmm;\r
\r
(* output version number option *)\r
put_byte(ord(coption));\r
put_2_byte(ord(allpass));\r
put_2_byte(ord(versionpass2));\r
put_2_byte(pass2_version);\r
\r
end; (* initialize *)\r
\r
\r
procedure std_context_init;\r
(* called after processing of standard environment *)\r
type\r
pres_or_eras= (preserve_name, erase_name);\r
var\r
temp_addr: st_address;\r
\r
procedure get_std_addr(obj_name: string;\r
var result_addr: st_address; erase: pres_or_eras);\r
(* Get spix of obj_name and search the associated st-object, return spix and\r
address. If erase equals erase_name then change the spix in the symbol table\r
to anonymousspix, making the name invisible for user programs *)\r
var\r
result_spix: spixrange;\r
begin\r
\r
result_spix:= st_spixofname(obj_name);\r
\r
result_addr:= st_nilladdr;\r
if not st_search(result_spix, result_addr, st2_cur_address, st2_cur_ptr) then\r
begin\r
elementspix:= result_spix;\r
writeln;\r
writeln(' ', obj_name, ' missing');\r
fatal_error(pass2, 7);\r
(* mismatch in stdnames *)\r
end\r
else\r
if erase=erase_name then\r
begin\r
st_get(result_addr, st2_cur_ptr);\r
st2_cur_ptr^.st_spix:= anonymousspix;\r
end;\r
end; (* get spix and address *)\r
\r
begin\r
get_std_addr('CREATE', st_create_addr, preserve_name);\r
get_std_addr('PROGRAM_DESCRIPTOR', st_program_type_addr, erase_name);\r
get_std_addr('BTYPE', st_btype_addr, erase_name);\r
get_std_addr('WTYPE', st_wtype_addr, erase_name);\r
get_std_addr('PTYPE', st_ptype_addr, erase_name);\r
get_std_addr('RTYPE', st_rtype_addr, erase_name);\r
get_std_addr('STRING', st_string_type_addr, preserve_name);\r
{$IFDEF RTP86}\r
get_std_addr('DATAAREA', st_dataarea_type_addr, preserve_name);\r
get_std_addr('BUFFER', st_buffer_type_addr, preserve_name);\r
{$ENDIF}\r
(*** st_emptyset_addr  initialiseret af pass0  **)\r
\r
(** Short cutting of the following std-names:        **)\r
(* MAILBOX, POOL, PROCESS, REFERENCE, CHAIN           *)\r
\r
(* MAILBOX *)\r
get_std_addr('MAILBOX_', temp_addr, erase_name);\r
temp_addr := st2_cur_ptr^.typeref;\r
get_std_addr('MAILBOX', st_mailboxtype_addr, preserve_name);\r
st_get(st_mailboxtype_addr, st2_cur_ptr);\r
st2_cur_ptr^.typeref := temp_addr;\r
\r
(* POOL *)\r
get_std_addr('POOL_', temp_addr, erase_name);\r
temp_addr := st2_cur_ptr^.typeref;\r
get_std_addr('POOL', st_pooltype_addr, preserve_name);\r
st_get(st_pooltype_addr, st2_cur_ptr);\r
st2_cur_ptr^.typeref := temp_addr;\r
\r
(* PROCESS *)\r
get_std_addr('PROCESS_', temp_addr, erase_name);\r
temp_addr := st2_cur_ptr^.typeref;\r
get_std_addr('PROCESS', st_processtype_addr, preserve_name);\r
st_get(st_processtype_addr, st2_cur_ptr);\r
st2_cur_ptr^.typeref := temp_addr;\r
\r
(* REFERENCE *)\r
get_std_addr('REFERENCE_', temp_addr, erase_name);\r
temp_addr := st2_cur_ptr^.typeref;\r
get_std_addr('REFERENCE', st_referencetype_addr, preserve_name);\r
st_get(st_referencetype_addr, st2_cur_ptr);\r
st2_cur_ptr^.typeref := temp_addr;\r
\r
(* CHAIN *)\r
get_std_addr('CHAIN_', temp_addr, erase_name);\r
temp_addr := st2_cur_ptr^.typeref;\r
get_std_addr('CHAIN', st_chaintype_addr, preserve_name);\r
st_get(st_chaintype_addr, st2_cur_ptr);\r
st2_cur_ptr^.typeref := temp_addr;\r
\r
(* PORT *)\r
get_std_addr('PORT_', temp_addr, erase_name);\r
temp_addr := st2_cur_ptr^.typeref;\r
get_std_addr('PORT', st_porttype_addr, preserve_name);\r
st_get(st_porttype_addr, st2_cur_ptr);\r
st2_cur_ptr^.typeref := temp_addr;\r
\r
end; (* std context init *)\r
\r
\r
(********* help procedures ******)\r
\r
procedure original_node(var node_addr: st_address;\r
                        var node_ptr: st_elemptr);\r
begin\r
(* TOG , st_retrievetype to st_retrieve *)\r
st_retrieve(node_addr, node_ptr);\r
while node_ptr^.st_node_copy do\r
begin\r
node_addr := node_ptr^.st_family_ref;\r
st_retrieve(node_addr, node_ptr);\r
end;\r
end; (* original_node *)\r
\r
function sametype(tl,tr: st_address): boolean;\r
(* checks if the two types denoted by the two st addresses *)\r
(* tl and tr are the same type *)\r
(* two types are said to be the same type if and only if: *)\r
(* a. both are the same predefined type.\r
(* b. both are specified as the same bound type name, or  *)\r
(* c. both are specified as a binding of the same parame- *)\r
(*    trized type name and the values of the actual para- *)\r
(*    meters are pairwise equal.                          *)\r
\r
(* a and b is true iff tl=tr *)\r
(* c is true iff TYPE(tl)=TYPE(tr) and PARAM(tl)=PARAM(tr) *)\r
(*   where TYPE(X) denotes the st address of the family node   *)\r
(*   the address is stored in the node pointed out by x.       *)\r
(*   and PARAM(X) denotes the values of the parameter list.    *)\r
(*   The parameter checking must be done by pass3 !!!!!!!!!    *)\r
\r
(*  maybe_string_type and maybe_fam_type are updated           *)\r
\r
var\r
(* #begintest\r
procname: string[12];\r
(* endtest# *)\r
same : boolean;\r
is_family: boolean;\r
\r
begin\r
(* #begintest\r
procname:= 'same type   ';\r
(* endtest# *)\r
maybe_string_type:=false;\r
maybe_fam_type:=false;\r
same:= equal_addr(tl,tr);\r
\r
st_retrieve(tl, st2_cur_ptr);\r
if (st2_cur_ptr^.type_mode = bound_fam) or\r
   (st2_cur_ptr^.type_mode = open_fam) or\r
   (st2_cur_ptr^.type_mode = named_bound_fam) then\r
begin\r
   IF (st2_cur_ptr^.type_mode = named_bound_fam) THEN\r
     tl := st2_cur_ptr^.st_Family_Ref\r
   ELSE\r
     original_node(tl, st2_cur_ptr);\r
is_family:= true;\r
end else is_family:=false;\r
is_string_type:=equal_addr(st_string_type_addr,tl);\r
\r
if not same then\r
begin\r
if is_family then\r
begin\r
st_retrieve(tr, st2_cur_ptr);\r
if (st2_cur_ptr^.type_mode = bound_fam) or\r
   (st2_cur_ptr^.type_mode = open_fam) or\r
   (st2_cur_ptr^.type_mode = named_bound_fam) then\r
begin\r
   IF (st2_cur_ptr^.type_mode = named_bound_fam) THEN\r
     tr := st2_cur_ptr^.st_Family_Ref\r
   ELSE\r
     original_node(tr, st2_cur_ptr);\r
end else is_family:=false;\r
\r
if is_family then\r
begin\r
same := equal_addr(tl, tr);\r
maybe_string_type:=equal_addr(st_string_type_addr,tr);\r
maybe_fam_type:=not maybe_string_type;\r
end;\r
end;\r
end;\r
sametype:= same;\r
end;\r
\r
function int_word_byte(node_addr: st_address): boolean;\r
var node_ptr: st_elemptr;\r
begin\r
  (* TOG !!! new rtp86 !!! , integer compatible with word and byte *)\r
  (* st_retrievetype(node_addr, node_ptr);\r
  if node_ptr^.st_kind=csubrange then\r
  st_retrievetype(node_ptr^.typeref, node_ptr);\r
  int_word_byte:= (node_ptr^.st_kind=cinteger) or\r
                  (node_ptr^.st_kind=cword) or\r
                  (node_ptr^.st_kind=cbyte);\r
  *)\r
  int_word_byte:= false;\r
end;\r
\r
function compatible(tl,tr: st_address): boolean;\r
(* two types are said to be compatible, iff: *)\r
(* 1. they are the same type (cf. FUNCTION sametype), or *)\r
(* 2. one is a subrange of the other or both are subranges *)\r
(*    of the same type, or                                    *)\r
(* 3. both are set types, and the base types are compatible, or *)\r
(* 4. both are specified as ^tname, where tname is a typename *)\r
\r
(*  maybe_string_type, maybe_fam_type and maybe_set_type updated *)\r
\r
var\r
comp,oldcomp,oldfamtype: boolean;\r
strptr,\r
tlptr,\r
trptr: st_elemptr;\r
tlkind,trkind: codes;\r
tltype,trtype: st_address;\r
begin\r
maybe_set_type:=false;\r
(* 1 *) comp:= sametype(tl,tr);\r
if (not comp) or maybe_fam_type then\r
begin\r
oldcomp := comp;\r
comp := false;\r
oldfamtype := maybe_fam_type;\r
(* 2 *) (* 3 *) (* 4 *)\r
st_retrievetype(tl,tlptr);\r
tlkind:= tlptr^.st_kind;\r
tltype:= tlptr^.typeref;\r
st_retrievetype(tr,trptr);\r
trkind:= trptr^.st_kind;\r
trtype:= trptr^.typeref;\r
\r
if trkind<>cerror then\r
case tlkind of\r
(* 2 *) csubrange: comp:= sametype(tltype,tr) or  (* tl subrange of tr *)\r
                 ( (trkind=csubrange) and sametype(tltype,trtype));\r
                 (* tl and tr subranges of the same type *)\r
\r
(* 3 *) csettype:  if trkind = csettype then\r
                    begin\r
                     comp := equal_addr(tr, st_emptyset_addr) or\r
                             equal_addr(tl, st_emptyset_addr);\r
                     if not comp then\r
                      comp := compatible(tltype, trtype);\r
                      maybe_set_type:=true;\r
                    end;\r
\r
(* 4 *) cpointertype: comp:= (trkind=cpointertype) and\r
                    sametype(tltype,trtype);\r
\r
(* error *) cerror: comp:= true (* avoid error cascades *)\r
\r
(* 2 *) else\r
            if (trkind=csubrange) THEN comp := sametype(tl,trtype);\r
                       (* tr subrange of tl *)\r
end (* case *)\r
else\r
comp:= true; (* avoid error cascades in case right operand is of kind error *)\r
\r
maybe_string_type:=false;\r
maybe_fam_type:=false;\r
IF oldfamtype then\r
  BEGIN\r
    if not comp then\r
      BEGIN\r
        comp := oldcomp;\r
        maybe_fam_type := oldfamtype;\r
      END;\r
  END;\r
end; (* if not comp .... *)\r
\r
if not comp then (* see if left is of a "super" type *)\r
if equal_addr(tl, st_btype_addr) then\r
comp := btype(tr, trptr, trkind)\r
else\r
if equal_addr(tl, st_wtype_addr) then\r
comp := wtype(tr, trptr, trkind)\r
else\r
if equal_addr(tl, st_ptype_addr) then\r
comp:= trkind=cpointertype\r
else if int_word_byte(tl) then comp:=int_word_byte(tr);\r
compatible:= comp;\r
end; (* compatible *)\r
\r
\r
function ordinaltype(code: codes): boolean;\r
begin\r
ordinaltype:= true; (* assume ok *)\r
if code<>cchar then \r
if code<>cboolean then \r
if code<>cinteger then \r
if code<>cscalar then \r
if code<>csubrange then\r
ordinaltype:= false;\r
end;\r
\r
function machinetype(code: codes): boolean;\r
begin\r
machinetype:= (code=cbyte) or (code=cword);\r
end;\r
\r
function protectedtype(code: codes): boolean;\r
begin\r
protectedtype:= true; (* assume ok *)\r
if code<>cpointertype then \r
if code<>cmailbox then \r
if code<>creference then \r
if code<>cpool then \r
if code<>cprocess then\r
if code<>cprogram then \r
if code<>cport then \r
if code<>cchain then\r
protectedtype:= false;\r
end;\r
\r
function btype(taddr: st_address; tptr: st_elemptr; tkind: codes):boolean;\r
begin\r
btype := ordinaltype(tkind);\r
\r
if tkind <> cboolean then\r
if tkind <> cchar then\r
if tkind = cscalar then\r
btype := tptr^.scalar_no <= 256\r
else\r
if tkind = csubrange then\r
begin\r
st_getbasetype(taddr, tptr);\r
(** returns a node of kind: basictype, arraytype, recordtype, scalartype **)\r
(** i.e. a typespecification <> subrange !!!                      **)\r
\r
tkind := tptr^.st_kind;\r
btype := btype(taddr,tptr,tkind);\r
end (* subrange *)\r
else\r
btype := false;\r
\r
if test_local then\r
begin\r
(***** ***) write(testoutput, 'btype found - ');\r
writeln(testoutput, ord(tkind));\r
end;\r
\r
end; (* btype *)\r
\r
function wtype(taddr: st_address; tptr: st_elemptr; tkind: codes):boolean;\r
begin\r
wtype := ordinaltype(tkind);\r
\r
if tkind <> cinteger then\r
if tkind = cscalar then\r
wtype := tptr^.scalar_no > 256\r
else\r
if tkind = csubrange then\r
begin\r
st_getbasetype(taddr, tptr);\r
(** returns a node of kind: basictype, arraytype, recordtype, scalartype **)\r
(** i.e. a typespecification <> subrange !!!                      **)\r
\r
tkind := tptr^.st_kind;\r
wtype := wtype(taddr,tptr,tkind);\r
end (* subrange *)\r
else\r
wtype := false;\r
\r
if test_local then\r
begin\r
(***** ***) write(testoutput, 'wtype found - ');\r
writeln(testoutput, ord(tkind));\r
end;\r
\r
end; (* wtype *)\r
\r
procedure begin_level_action;\r
(* remember symbol table location of last inserted named element \r
and change level *)\r
begin\r
push_p2stack;\r
with p2stacktop^ do\r
begin\r
syntaxkind:= slevel;\r
nodeaddress:= st2_start_search;\r
end;\r
st_beginlevel2;\r
end; (* begin level action *)\r
\r
\r
procedure end_level_action;\r
(* return to former symbol table level at the appropriate point for search start *)\r
begin\r
with p2stacktop^ do\r
begin\r
(* #begintest \r
if syntaxkind<>slevel then\r
p2_fatal_error(1);\r
(* inconsistency in pass2stack *)\r
(* endtest# *)\r
st2_start_search:= nodeaddress;\r
end; (* with *)\r
pop_p2stack;\r
st_endlevel;\r
end; (* end level action *)\r
\r
\r
procedure check_legal_param_type(param_ref, type_ref: st_address);\r
var\r
(* #begintest \r
procname: string[12];\r
(* endtest# *)\r
paramkind: codes;\r
type_spix: word;\r
type_ptr: st_elemptr;\r
components: st_protect_type;\r
begin\r
(* #begintest \r
procname:= 'chck leg par';\r
(* endtest# *)\r
if not equal_addr(type_ref, st_undeclared_addr) then\r
(* not after error *)\r
begin\r
st_retrieve(param_ref, type_ptr (* used as temporary !! *));\r
paramkind:= type_ptr^.st_kind;\r
st_retrieve(type_ref, type_ptr);\r
with type_ptr^ do\r
begin\r
components:= spec_struct;\r
routine_specstruc:= routine_specstruc + components;\r
type_spix:= st_spix; (* saved for use in case of error *)\r
end;\r
\r
if test_local then \r
(***** ***)  write_specstruc(components);\r
\r
if program_decl then\r
begin\r
if (paramkind=cvarparam) then\r
begin\r
if not ( equal_addr(type_ref,st_mailboxtype_addr) or\r
         equal_addr(type_ref,st_pooltype_addr) or\r
         equal_addr(type_ref,st_porttype_addr) ) then\r
begin\r
elementspix:= type_spix;\r
errormsg(pass2, 139);\r
(* illegal program parameter type *)\r
end; (* error *)\r
end; (* if program decl *)\r
\r
if pointertype in components then \r
errormsg(pass2, 183);\r
(* pointer-element type of varparam has to be mailbox *)\r
\r
end; (* program declaration *)\r
if paramkind=cvalueparam then\r
begin\r
if components*shielded_types<>[] then\r
if not (pointertype in components) then\r
begin\r
elementspix:= type_spix;\r
errormsg(pass2, 140);\r
(* illegal (component) type of value parameter *)\r
end\r
else\r
warning(pass2, 100);\r
\r
if family_type_params and (not program_decl) then\r
begin\r
st_retrievetype(type_ref, type_ptr);\r
if not ordinaltype(type_ptr^.st_kind) then\r
errormsg(pass2, 171);\r
(* type specified for formal type parameter(s) must be ordinal *)\r
end; (* family type param check *)\r
end; (* value paramter check *)\r
end; (* not after error *)\r
end; (* check legal param type *)\r
\r
\r
procedure routine_block_lookahead;\r
(* common actions about routine blocks, i.e. lookahead and find out\r
whether the block is forward, external, openroutine, or real code block *)\r
var\r
(* #begintest \r
procname: string[12];\r
(* endtest# *)\r
forward_seg_nr:byte;\r
forw_name: word; (* name of forward declared routine *)\r
with_address: st_address;\r
begin\r
(* #begintest \r
procname:= 'rout bl look';\r
(* endtest# *)\r
routine_specstruc := [];\r
st_get(p2stacktop^.former^.nodeaddress, st2_cur_ptr); (* routine node *)\r
token:= getcode;\r
if token=cbeginlevel then\r
begin\r
if not after_context then\r
begin\r
elementspix:= st2_cur_ptr^.st_spix;\r
errormsg(pass2, 114);\r
(* routine in context must be external *)\r
end;\r
if st2_cur_ptr^.st_specs=st_forward then\r
begin\r
with p2stacktop^.former^ do\r
begin\r
\r
(******** OBS !!!!!!!!!!!! OBS !!!!!!!!!!!!!! ******)\r
if (**) st_check_params(st2_cur_ptr^.listref, former^.p2_listref) and (**)\r
sametype(p2_typeref, former^.p2_typeref) then\r
begin\r
st_get(nodeaddress, st2_cur_ptr);\r
st2_cur_ptr^.st_spix:= anonymousspix; (* erase st-node *)\r
\r
(* insert parameterlist from actual declaration into "listref" *)\r
(* of forward declaration       **)\r
former^.p2_listref := st2_cur_ptr^.listref;\r
st_get(former^.nodeaddress, st2_cur_ptr);\r
st2_cur_ptr^.listref := former^.p2_listref;\r
\r
end\r
else\r
errormsg(pass2, 143);\r
(* parameter lists of forward and actual routine declaration must be identical *)\r
(* pop next top, i.e. the FORWARD mark, top is a level mark *)\r
syntaxkind:= slevel;\r
nodeaddress:= p2stacktop^.nodeaddress;\r
end; (* with *)\r
\r
pop_p2stack;\r
end; (* actual definition of a forward declared routine *)\r
\r
begin_level_action;\r
if cur_block_level<routine_level then \r
begin\r
if cur_block_level=context_level then\r
begin \r
if (comp_unit>0) and make_segmentation then\r
errormsg(pass2,301);\r
(* using $SEGMENT only one compilation unit allowed *)\r
comp_unit:=comp_unit+1;\r
if (comp_used_bit=last_comp_unit_bit) OR\r
   (comp_used_bit = 0) then comp_used_bit:=1\r
else comp_used_bit:=2*comp_used_bit;\r
end;\r
cur_block_level:=routine_level;\r
end\r
else cur_block_level:= cur_block_level+1;\r
(* internal routines has cur_block_level>routine_level *)\r
(* routines in context are routines in pass2, FORKERT !!!! *)\r
put_byte(ord(cblock));\r
end\r
else\r
begin\r
if getcode<>cendlevel then\r
p2_fatal_error(4);\r
(* inconsistent pass1 code *)\r
end_level_action; (* exit parameter level *)\r
case token of\r
cexternal: \r
begin\r
if segment_nr>1 then \r
errormsg(pass2,300);\r
(* external declaration is only allowed before $SEGMENT *)\r
if (cur_block_level = program_level) or (cur_block_level = routine_level)\r
or (not after_context) then\r
(* external declaration in context, in program or in separately\r
  compiled routine *)\r
with st2_cur_ptr^ do\r
st_specs:= st_extern\r
else\r
begin\r
elementspix:= st2_cur_ptr^.st_spix;\r
errormsg(pass2,109);\r
(* external declaration is only allowed in the outer level of a\r
  block *)\r
end; (* error *)\r
end; (* external *)\r
\r
cforward: \r
begin\r
if cur_block_level >= program_level then\r
begin\r
if st2_cur_ptr^.st_specs=st_forward then\r
begin\r
elementspix:= st2_cur_ptr^.st_spix;\r
errormsg(pass2, 113);\r
(* FORWARD announcement not followed by actual routine definition *)\r
end\r
else\r
begin\r
with st2_cur_ptr^ do\r
begin\r
st_specs:= st_forward; (* let pass3 know that the routine was forward declared *)\r
forw_name:= st_spix;\r
forward_seg_nr:=st_seg_nr;\r
end;\r
if not st_search_level(forw_name, st2_cur_ptr) then\r
p2_fatal_error(3)\r
(* st mismatch *)\r
else\r
begin\r
with st2_cur_ptr^ do\r
begin\r
st_specs:= st_forward;\r
(* the label field is used as a link to the forward announcement *)\r
st_label:= p2stacktop^.nodeaddress;\r
end; (* with *)\r
if forward_seg_nr<>st2_cur_ptr^.st_seg_nr then\r
begin\r
forward_seg_nr:=st2_cur_ptr^.st_seg_nr;\r
st_get(p2stacktop^.nodeaddress,st2_cur_ptr);\r
st2_cur_ptr^.st_seg_nr:=forward_seg_nr;\r
end;\r
end;\r
end; (* ok *)\r
end (* cur block level >= program level *)\r
else\r
begin\r
elementspix:= st2_cur_ptr^.st_spix;\r
errormsg(pass2, 107);\r
(* FORWARD declaration is not allowed in contexts *)\r
end;\r
end; (* forward *)\r
\r
copenroutine: \r
begin\r
if firstcontext then\r
with st2_cur_ptr^ do\r
begin\r
st_curno:= open_counter;\r
open_counter:= open_counter+1;\r
st_specs:= st_open;\r
end (* if first context *)\r
else\r
begin\r
elementspix:= st2_cur_ptr^.st_spix;\r
errormsg(pass2, 108);\r
(* openroutines only allowed in standardcontext *)\r
end;\r
end;\r
\r
end; (* lookahead *)\r
pop_p2stack;\r
end; (* not internal routine *)\r
end; (* routine block lookahead *)\r
\r
\r
procedure push_opencall;\r
(** actual parameter to an openroutine-call is to stay on p2stack -**)\r
(** pass2code is dumped.                                    **)\r
begin\r
if equal_addr(p2stacktop^.former^.p2_listref,st_stopaddr) then\r
begin\r
errormsg(pass2, 136);     (** ???? 2 inc af openrout har sm antal params ?? **)\r
(* too many actual parameters *)\r
end\r
else\r
begin\r
st_retrieve(p2stacktop^.former^.p2_listref, st2_cur_ptr);\r
(** access current formal parameter **)\r
with st2_cur_ptr^ do\r
begin\r
p2stacktop^.p2_listref:= listref; (* next parameter *)\r
\r
(** 'p2-typeref' contains type of actual parameter **)\r
\r
if st_kind=cvalueparam then\r
begin\r
put_byte(ord(cvalueparam));\r
putaddress(typeref); (* formal type *)\r
end\r
else\r
(* address transfer parameter *)\r
put_byte(ord(st_kind)); (* varparam/sharedparam/inspectparam *)\r
end; (* with st2 cur ptr^ *)\r
end;\r
if test_stack then\r
begin\r
writeln(testoutput,'*****-------> OPENROUTINE TEST *************');\r
write_p2stack;\r
writeln(testoutput,'*********** OPENROUTINE TEST ------->*******');\r
end;\r
end; (* push-opencall *)\r
\r
procedure bind_open;\r
var\r
open_found: boolean;\r
open_error: boolean;\r
st2_formaladdr: st_address;\r
p2_actualptr: ptr_p2stack;\r
\r
procedure backtrack_p2stack;\r
(* go backwards in p2stack to find  *)\r
(* pointer to current candidate *)\r
begin\r
p2_actualptr := p2stacktop;\r
while p2_actualptr^.syntaxkind <> sactualparam do\r
p2_actualptr := p2_actualptr^.former;\r
end;\r
\r
procedure setup_ptrs;\r
(* set up st-address of the first formal parameter 'st2_formaladdr' *)\r
(* and pointer to p2stack holding the corresponding (first) actual *)\r
(* parameter 'p2_actualptr'        *)\r
(* AT ENTRY to procedure:  'p2_actualptr^.former^.nodeaddress' holds  *)\r
(* candidate to be examined!! *)\r
begin\r
if (p2_actualptr^.former^.syntaxkind <> sopenfunccall) and\r
   (p2_actualptr^.former^.syntaxkind <> sopenfunccalle) and\r
   (p2_actualptr^.former^.syntaxkind <> sopenproccall) then\r
p2_fatal_error(6);\r
(** pass2 inconsistency **)\r
st_retrieve(p2_actualptr^.former^.nodeaddress, st2_cur_ptr);\r
st2_formaladdr := st2_cur_ptr^.listref;\r
(* 1. formal parameter of candidate *)\r
p2_actualptr := p2_actualptr^.next;\r
(* 1. actual parameter to checked *)\r
end;\r
\r
procedure check_openparams;\r
var\r
stop: boolean;\r
\r
begin\r
stop := false;\r
open_error:= false;\r
\r
repeat\r
if equal_addr(st2_formaladdr, st_stopaddr) then\r
stop := true\r
else\r
begin\r
st_retrieve(st2_formaladdr, st2_cur_ptr);\r
(* i.e. access formal parameter *)\r
with st2_cur_ptr^ do\r
begin\r
st2_cur_address := typeref;\r
(* save formal type address *)\r
\r
st2_formaladdr := listref;\r
(* set up ptr to next formal parameter *)\r
\r
if st_kind=cvalueparam then\r
begin\r
if not compatible(typeref, p2_actualptr^.p2_typeref) then\r
begin\r
if p2_actualptr^.syntaxkind=snull then\r
begin\r
open_error := true;\r
(**\r
errormsg(pass2, 167)\r
elementspix:= nextinp;\r
 '?' only allowed as address transfer parameter *)\r
end\r
else\r
begin\r
open_error := true;\r
(**\r
errormsg(pass2, 135);\r
 formal and actual types of valueparameter are not compatible *)\r
end\r
end;\r
\r
end\r
else\r
(* address transfer parameter *)\r
with p2_actualptr^ do\r
if (syntaxkind<>svar) and (syntaxkind<>snull) and \r
((st_kind<>cinspectparam) or \r
((syntaxkind<>sconst) and \r
(syntaxkind<>sstrucrecval) and\r
(syntaxkind<>sstrucarrval) )) then\r
begin   \r
open_error := true;\r
(**\r
errormsg(pass2, 170);\r
elementspix:= nextinp;\r
 address transfer parameter; actual parameter must be a variable *)\r
end\r
else\r
begin\r
if not sametype(typeref, p2_typeref) then\r
if syntaxkind<>snull then\r
begin\r
st_retrievetype(p2_typeref, st2_cur_ptr);\r
with st2_cur_ptr^ do\r
begin\r
\r
(* see if formal is of a "super" type *)\r
(* rtype *)\r
if equal_addr(st2_cur_address, st_rtype_addr) then \r
begin\r
if not (equal_addr(p2_typeref, st_referencetype_addr) or\r
        equal_addr(p2_typeref, st_chaintype_addr))   then\r
begin\r
open_error := true;\r
(**\r
errormsg(pass2,182);\r
 actualparameter has to be reference or chain  *)\r
end\r
end else\r
(* ptype *)\r
if equal_addr(st2_cur_address, st_ptype_addr) then \r
begin\r
if not (st_kind = cpointertype) then\r
begin\r
open_error := true;\r
(**\r
errormsg(pass2,184);\r
 actualparameter has to be a pointertype  *)\r
end\r
end \r
else\r
begin\r
open_error := true;\r
(**\r
errormsg(pass2, 137);\r
elementspix:= nextinp;\r
 types of formal and actual parameters must be identical*)\r
end;\r
end;\r
end;\r
end;\r
end;  (* with st2-cur-ptr *)\r
end;\r
\r
if p2_actualptr <> p2stacktop then\r
begin\r
p2_actualptr := p2_actualptr^.next;\r
if stop (** i.e. no more formal parameters **)  and \r
(p2_actualptr <> p2stacktop) then\r
begin\r
open_error := true;\r
(* too many actual parameters *)\r
(**\r
warning(pass2,200);\r
**)\r
end\r
end\r
else stop := true;\r
\r
until stop or open_error;\r
\r
open_found := not open_error;\r
end; (* check_openparameters *)\r
\r
begin   (*** bind_open **)\r
open_found := false;\r
\r
backtrack_p2stack;\r
\r
repeat\r
\r
setup_ptrs;\r
\r
check_openparams;\r
\r
backtrack_p2stack;\r
(* p2_actualptr^.former^ now points out sopenfunccall or sopenproccall - node *)\r
\r
(* reetableret fra rtp86p2 d. 28 feb. 89 *)\r
\r
if not open_found (* i.e. 'open_error = true *) then\r
begin\r
(** follow open_chain backwards to next candidate **)\r
with p2_actualptr^.former^ do\r
begin\r
st_retrieve(nodeaddress, st2_cur_ptr);\r
(* get just examined candidate **)\r
(** to follow chain to possible next candidate **)\r
if not equal_addr(st2_cur_ptr^.st_label, st_stopaddr) then\r
begin  (* i.e. more candidates *)\r
open_error := false;\r
nodeaddress := st2_cur_ptr^.st_label;\r
end;\r
end;\r
end;\r
until open_found or open_error;\r
\r
if not open_found then\r
(* open_error *)\r
begin\r
errormsg(pass2,137);\r
(** types of formal and actual parameters must be identical **)\r
end else with p2_actualptr^.former^ do\r
if (syntaxkind=sopenfunccall) or (syntaxkind=sopenfunccalle) then\r
begin\r
  st_retrieve(nodeaddress, st2_cur_ptr);\r
  p2_typeref:= st2_cur_ptr^.typeref;\r
end;\r
\r
end; (** bind_open **)\r
\r
procedure pop_opencall;\r
begin\r
while p2stacktop^.syntaxkind <> sactualparam do\r
begin\r
p2stacktop^.former^.p2_listref := p2stacktop^.p2_listref;\r
pop_p2stack;     (* !!!! PAS PAA ved 2. gennemlqb !!*)\r
end;\r
p2stacktop^.former^.p2_listref := p2stacktop^.p2_listref;\r
pop_p2stack;   (* pop actualparam *)\r
(** see whether wee still are within an openroutinecall **)\r
(** if not : then within_opencall := false    **)\r
opencount := opencount - 1;\r
within_opencall := opencount > 0;\r
(** 'within_opencall' is to be reset after last openroutinecall in a row **)\r
end;\r
\r
procedure copy_type(original_symb: st_address; var copy_symb: st_address);\r
(* make a copy of the sub types of a family type *)\r
\r
var\r
original_ptr,\r
copy_ptr: st_elemptr;\r
def_type_symb,\r
field_symb,\r
field_list_symb: st_address;\r
\r
procedure copy_node(original_symb: st_address; var copy_symb: st_address;\r
var copy_ptr: st_elemptr);\r
begin\r
st_copy_node(original_symb, copy_symb, copy_ptr);\r
with copy_ptr^ do\r
begin\r
st_node_copy:= true;\r
st_family_ref:= original_symb;\r
end;\r
end; (* copy node *)\r
\r
begin (* copy type *)\r
st_get(original_symb, original_ptr);\r
with original_ptr^ do\r
case st_kind of\r
ctype:\r
if (st_spix=anonymousspix) or (type_mode=bound_fam) or\r
   (type_mode=fam) or (type_mode = open_fam) then\r
begin\r
if st_spix<>anonymousspix then\r
begin\r
if type_mode<>fam then begin\r
st2_hlp_address:=original_symb;\r
original_node(st2_hlp_address,original_ptr);\r
st_get(st2_hlp_address,original_ptr);\r
end;\r
with original_ptr^ do\r
(*if not odd(fam_used div comp_used_bit) then\r
fam_used:=fam_used+comp_used_bit;  *)\r
fam_used:=fam_used OR comp_used_bit;\r
end;\r
copy_node(original_symb, copy_symb, copy_ptr);\r
copy_type(copy_ptr^.typeref, def_type_symb);\r
st_get(copy_symb, copy_ptr);\r
copy_ptr^.typeref:= def_type_symb;\r
end\r
else\r
copy_symb:= original_symb;\r
\r
cscalar,\r
csubrange: copy_node(original_symb, copy_symb, copy_ptr);\r
\r
cpointertype: begin\r
copy_node(original_symb, copy_symb, copy_ptr);\r
copy_type(copy_ptr^.typeref, def_type_symb);\r
st_get(copy_symb, copy_ptr);\r
copy_ptr^.typeref:= def_type_symb;\r
end; (* pointertype *)\r
\r
carraytype: begin\r
copy_node(original_symb, copy_symb, copy_ptr);\r
copy_type(copy_ptr^.itype, def_type_symb);\r
st_get(copy_symb, copy_ptr);\r
copy_ptr^.itype:= def_type_symb;\r
copy_type(copy_ptr^.typeref, def_type_symb);\r
st_get(copy_symb, copy_ptr);\r
copy_ptr^.typeref:= def_type_symb;\r
end; (* arraytype *)\r
\r
crecordtype: begin\r
copy_node(original_symb, copy_symb, copy_ptr);\r
field_symb:= copy_symb;\r
\r
repeat (* traverse the field list *)\r
copy_node(copy_ptr^.listref, field_list_symb, copy_ptr);\r
def_type_symb:= copy_ptr^.typeref;\r
st_get(field_symb, copy_ptr);\r
copy_ptr^.listref:= field_list_symb;\r
field_symb:= field_list_symb;\r
copy_type(def_type_symb, def_type_symb);\r
st_get(field_symb, copy_ptr);\r
copy_ptr^.typeref:= def_type_symb;\r
until equal_addr(copy_ptr^.listref, st_stopaddr);\r
\r
end; (* recordtype *)\r
\r
csettype: ;\r
\r
cundeclared: copy_symb := st_undeclared_addr;\r
\r
else \r
begin\r
if test_local then writeln('st_kind: ', ord(st_kind));\r
fatal_error(pass2, 08);\r
(** copy-type error **)\r
end;\r
end; (* case *)\r
\r
end; (* copy type *)\r
\r
end.\r
«eof»
DataMuseum.dk

DANOSI

⟦12e683a4b⟧ TextFile

Derivation

TextFile
