⟦f053785ab⟧

TextFile

\r
procedure rtp86pass2;\r
(*********body of pass2*********)\r
var\r
  help : integer;\r
label\r
9876; (* after read next token, used after error-repair *)\r
\r
begin\r
(* #begintest \r
procname:= 'rtp86 pass 2';\r
(* endtest# *)\r
in_type_decl:=false;\r
in_program_head:=false;\r
bind_of_family_allowed:=false;\r
initialize;\r
token:= getcode; (* read first code of infile *)\r
\r
repeat\r
(* #begintest\r
if test_pass1code then\r
if test_stack then write_stacktop(2) else\r
writeln(testoutput,'linenumber: ',linenumber,'     token: ',ord(token));\r
(* #endtest *)\r
case token of\r
\r
\r
cactualparam: if do_actualparam then goto 9876;\r
\r
\r
cendactual: if do_endactual then goto 9876; \r
\r
carraytype:\r
begin\r
read_push_dump_type(carraytype);\r
end;\r
\r
\r
cendarray: do_endarray;\r
\r
\r
cbeginactual: if do_beginactual then goto 9876; \r
\r
\r
cbeginlevel: \r
begin_level_action;\r
\r
\r
cbeginstruc: do_beginstruc;\r
\r
\r
ccaseelement:\r
begin\r
put_byte(ord(ccaseelement));\r
before_assign:= false;\r
end; (* ccaseelement *)\r
\r
\r
ccaseexpr:\r
with p2stacktop^ do\r
begin\r
st_retrievetype(p2_typeref, st2_cur_ptr);\r
if not ordinaltype(st2_cur_ptr^.st_kind) then\r
errormsg(pass2, 153);\r
(* type of case expression must be an ordinal type *)\r
former^.p2_typeref:= p2_typeref;\r
pop_p2stack;\r
put_byte(ord(ccaseexpr));\r
before_assign:= false;\r
end; (* ccaseexpr *)\r
\r
\r
ccaselabel:\r
begin\r
with p2stacktop^ do\r
if not compatible(p2_typeref, former^.p2_typeref) then\r
errormsg(pass2, 154);\r
(* case-expression/case label(s) not of compatible types *)\r
put_byte(ord(ccaselabel));\r
pop_p2stack;\r
end; (* ccaselabel *)\r
\r
\r
ccaselabelrange:\r
begin\r
with p2stacktop^ do\r
if not compatible(p2_typeref, former^.former^.p2_typeref) or\r
not compatible(former^.p2_typeref, former^.former^.p2_typeref) then\r
errormsg(pass2, 154);\r
(* case-expression/case label(s) not of compatible types *)\r
pop_p2stack;\r
pop_p2stack;\r
put_byte(ord(ccaselabelrange));\r
end;\r
\r
\r
ccaselist:\r
begin\r
put_byte(ord(ccaselist));\r
before_assign:= true;\r
end;\r
\r
\r
ccasestat:\r
begin\r
push_p2stack;\r
p2stacktop^.syntaxkind:= scase;\r
put_byte(ord(ccasestat));\r
before_assign:= false;\r
end; (* ccasestat *)\r
\r
\r
cendcase:\r
begin\r
put_byte(ord(cendcase));\r
pop_p2stack;\r
before_assign:= true;\r
end;\r
\r
\r
cchangelabelscope: \r
current_labelscope:= get_2_byte;\r
\r
\r
cconstdecl: \r
(* read and write --> constdecl(st_address) ---> *)\r
(* push element on p2stack *)\r
begin\r
read_push_dump(cconstdecl,sconstdecl);\r
if cross then st_cross_decl(p2stacktop^.nodeaddress,token,true);\r
st_insert_headsymbol(p2stacktop^.nodeaddress);\r
st2_start_search:= p2stacktop^.nodeaddress;\r
st_get(st2_start_search, st2_cur_ptr);\r
st2_cur_ptr^.st_kind:= cconstdecl; (* avoid recursive use of constant *)\r
end;\r
\r
\r
cendconstdecl: \r
(* constant declaration <- *)\r
(* CONSTDECL(NODEADDRESS) ---> expression ---> ENDCONSTDECL *)\r
(* update symbol table node with type of expression *)\r
(* p2stacktop contains expression and former contains constdecl *)\r
begin\r
(*** ***)\r
if test_local then\r
begin\r
 write_p2stack;\r
end;\r
(*** ***)\r
put_byte(ord(cendconstdecl));\r
with p2stacktop^ do\r
if (former^.syntaxkind=sconstdecl) then\r
begin\r
st_get(former^.nodeaddress, st2_cur_ptr);\r
with st2_cur_ptr^ do\r
begin\r
st_kind:= cconstant; (* change back from constdecl to const *)\r
typeref:= p2_typeref;\r
end; (* with *)\r
pop_p2stack; (* expression *)\r
pop_p2stack; (* constdecl *)\r
end\r
else\r
p2_fatal_error(1);\r
(* inconsistency in pass2stack *)\r
end; (* cendconstdecl *)\r
\r
\r
ccontext: \r
begin\r
getaddress(st2_cur_address);\r
if cross then st_cross_decl(st2_cur_address,token,true);\r
push_p2stack;\r
with p2stacktop^ do\r
begin\r
syntaxkind:= scontext;\r
nodeaddress:= st2_cur_address;\r
end;\r
elementnumber:= elementnumber+1;\r
end; (* ccontext *)\r
\r
\r
cendcontext: \r
(* reducing: *)\r
(* CONTEXTDECL(NODEADDRESS)--->declarations---->ENDCONTEXT *)\r
begin\r
if firstcontext then\r
begin\r
firstcontext:= false;\r
std_context_init; (* get addresses of standard name entries *)\r
end;\r
if p2stacktop^.syntaxkind <> scontext then\r
p2_fatal_error(1)\r
(* mismatch in pass2stack *)\r
else\r
pop_p2stack;\r
end; (* cendcontext *)\r
\r
ceos:\r
if call_options.savecode then\r
begin\r
put_byte(ord(ceos));\r
save_specs(true);\r
token := ceom;\r
goto 9876; (* after read next token - i.e. exit pass2 *)\r
end;\r
\r
ccontloop,\r
cexitloop: (* reduce statement *)\r
begin\r
if repetitive_counter=0 then\r
errormsg(pass2, 115);\r
(* not inside repetitive statement *)\r
put_byte(ord(token));\r
end; (* contloop, exitloop *)\r
\r
\r
cdo:\r
before_assign:= true;\r
\r
\r
\r
cdown,\r
cup: \r
(* reducing: FORSTAT(ST_ADDRESS)-->subrange definition-->BEGINLEVEL-->DOWN(ST_ADDRESS)\r
       or: FORSTAT(ST_ADDRESS)-->subrange definition-->BEGINLEVEL-->UP(ST_ADDRESS) *)\r
(* action: increase repetitive counter *)\r
begin\r
before_assign:= true;\r
getaddress(st2_cur_address);\r
put_byte(ord(token));\r
putaddress(st2_cur_address);\r
st_insert_headsymbol(st2_cur_address);\r
with p2stacktop^.former^ do\r
begin\r
st_get(st2_cur_address,st2_cur_ptr);\r
st2_cur_ptr^.typeref:= nodeaddress; (* defining type *)\r
(* pop subrange definition, i.e. move level element *)\r
syntaxkind:=slevel;\r
nodeaddress:=p2stacktop^.nodeaddress;\r
end;\r
pop_p2stack; (* subrange definition *)\r
repetitive_counter:= repetitive_counter+1;\r
local_declare_state:= false;\r
end; (* down and up *)\r
\r
\r
cendassign: do_endassign; \r
\r
\r
cendblock: do_endblock; \r
(* reducing: *)\r
(* program declaration <- *)\r
(* PROGDECL(NODEADDRESS) ---> formal parameters --->ENDPROGDECL *)\r
(* or: *)\r
(* procedure declaration <- *)\r
(* PROCDECL(NODEADDRESS) ---> formal parameters --->ENDPROCDECL *)\r
(* --->block <- *)\r
(* BLOCK ---> declarations --->label scope ----> endblock <- *)\r
(* ENDBLOCK --->ENDLEVEL --->ENDLEVEL *)\r
\r
\r
cenddeclarations: \r
begin\r
put_byte(ord(cenddeclarations));\r
\r
(** the two topmost elements of pass2stack are 'levels' **)\r
if p2stacktop^.former^.former^.syntaxkind=sprogdecl then \r
begin\r
st2_cur_address:= st_nilladdr;\r
if st_search(st_spix_of_exception, st2_cur_address, with_address, st2_cur_ptr) then\r
with st2_cur_ptr^ do\r
if ((st_specs=st_local) or (st_specs=st_forward)) and\r
(st_kind=cprocedure) then (* internal defined exception procedure *)\r
if not equal_addr(listref, st_stopaddr) then\r
begin\r
st_retrieve(listref, st2_cur_ptr);\r
with st2_cur_ptr^ do\r
if (st_kind=cvalueparam) and equal_addr(listref, st_stopaddr) and\r
(* exactly one value parameter *)\r
(code_of_address(typeref)=cinteger) (* of type integer *) then\r
begin\r
put_byte(ord(cexception));\r
putaddress(st2_cur_address);\r
end; (* one value parameter of type integer *)\r
end; (* internal exception routine *)\r
end; (* program declaration *)\r
put_byte(ord(cinitblock));\r
declare_state:= false;\r
before_assign:= true;\r
end; (* cenddeclarations *)\r
\r
\r
(*cendelse:  see cendif *)\r
\r
cendexchange:\r
(* reducing exchagen statement <-\r
variable --> variable --> ENDEXCHANGE *)\r
(* pass2code: ---> ENDEXCHANGE -----------> *)\r
(*             +-> ENDEXCHANGESTRING --+    *)\r
(* check same type of variables *)\r
begin\r
with p2stacktop^ do\r
begin\r
if (former^.syntaxkind<>svar) or (syntaxkind<>svar) then\r
errormsg(pass2, 116);\r
(* exchange: variables only *)\r
if not sametype(former^.p2_typeref, p2_typeref) then\r
begin\r
errormsg(pass2, 117);\r
put_byte(ord(cendexchange));\r
(* exchange: variables must be of the same type *)\r
end\r
else\r
begin\r
st_retrieve(p2_typeref, st2_cur_ptr);\r
if st2_cur_ptr^.spec_struct*\r
[mailboxtype, pooltype, chaintype, porttype, referencetype]<>[] then\r
begin\r
if st2_cur_ptr^.spec_struct*\r
[mailboxtype, pooltype, chaintype, porttype]<>[] then\r
errormsg(pass2, 118)\r
(* exchange of mailbox, pool, chain or port not allowed *)\r
else if not equal_addr(p2_typeref, st_referencetype_addr) then\r
errormsg(pass2,303);\r
(* exchange of references in structures not implemented *)\r
end;\r
if maybe_string_type then put_byte(ord(cendexchangestring))\r
else\r
  BEGIN\r
    put_byte(ord(cendexchange));\r
  IF Maybe_fam_type then\r
    BEGIN\r
      put_byte(ord(cCheckparam));\r
      PutAddress(p2_typeref);\r
      PutAddress(former^.p2_typeref);\r
    END;\r
  END;\r
end;\r
end; (* with *)\r
pop_p2stack;\r
pop_p2stack;\r
before_assign:= true;\r
end; (* endexchange *)\r
\r
\r
cendfieldlist:\r
begin\r
with p2stacktop^ do\r
begin\r
former^.p2_typeref:= nodeaddress;\r
former^.p2_specstruc :=former^.p2_specstruc + p2_specstruc;\r
end;\r
(****** ***)\r
if test_stack then write_p2stack;\r
pop_p2stack;\r
put_byte(ord(cendfieldlist));\r
end; (* cendfieldlist *)\r
\r
\r
cendfor, cendloop,\r
cendwhile:\r
(* reducing endfor, endloop, and endwhile *)\r
begin\r
put_byte(ord(token));\r
repetitive_counter:= repetitive_counter-1;\r
end; (* endfor, endloop, endwhile *)\r
\r
cendinclude:\r
begin\r
if p2stacktop^.syntaxkind <> scompunit then\r
p2_fatal_error(1);\r
(* inconsistency  in pass2stack *)\r
after_context:= true;\r
bind_of_family_allowed:=true;\r
(* bind of family always allowed after context *)\r
first_program_open:= open_counter;\r
put_byte(ord(cendinclude));\r
end; (* cendinclude *)\r
\r
\r
cendlevel:\r
end_level_action;\r
\r
\r
cendproccall:\r
(* reducing procedure call: *)\r
(* ---->variable------>ENDPROCCALL *)\r
(* pop the call element *)\r
(* dump p2code *)\r
begin\r
before_assign:= true;\r
with p2stacktop^ do\r
begin\r
if (syntaxkind<>sproccall) and\r
(syntaxkind <> sopenproccall) then\r
begin\r
if not equal_addr(nodeaddress, st_undeclared_addr) then\r
errormsg(pass2, 138)\r
(* the statement is not a procedure call *)\r
end\r
else\r
if not equal_addr(p2_listref, st_stopaddr) then\r
errormsg(pass2, 112);\r
(* too few actual parameters *)\r
\r
put_byte(ord(cendproccall));\r
putaddress(nodeaddress);\r
pop_p2stack;\r
end; (* with stacktop .. *)\r
end; (* endproccall *)\r
\r
\r
cendvariable: do_endvariable;\r
(* reducing factor <--- *)\r
(* variable ---> ENDVARIABLE *)\r
(* change syntaxkind *)\r
(* dump pass2code: ENDVARIABLE/ENDFUNCCALL *)\r
\r
\r
cexitstat: (* reduce statement: \r
--> EXITSTAT --> *)\r
begin\r
put_byte(ord(cexitstat));\r
end; (* exitstat *)\r
\r
\r
cfamilytype: do_familytype;\r
(* familitype(spix) *)\r
\r
\r
cendtype: (* end of familytype binding *)\r
begin\r
with p2stacktop^ do\r
begin\r
if syntaxkind<>stype then\r
begin\r
p2_fatal_error(1);\r
(* inconsistency in pass2stack *)\r
end\r
else\r
if not equal_addr(p2_listref, st_stopaddr) then\r
errormsg(pass2, 112);\r
(* too few actual parameters *)\r
end; (* with stacktop .. *)\r
put_byte(ord(cendtype));\r
end; (* endtype *)\r
\r
\r
\r
cfield:\r
(* reducing: CFIELD(SPIX)\r
code: CFIELD(SYMBOL)\r
*)\r
with p2stacktop^ do\r
begin\r
nextinp:= get_2_byte;\r
elementnumber:= elementnumber+1;\r
st_getbasetype(p2_typeref, st2_cur_ptr);\r
if (syntaxkind<>sconst) and (syntaxkind<>svar) then begin\r
st_retrieve(nodeaddress, st2_cur_ptr);\r
elementspix:= st2_cur_ptr^.st_spix;\r
errormsg(pass2, 197);\r
(* only constart or variable allowed *)\r
end\r
else if st2_cur_ptr^.st_kind<>crecordtype then\r
begin\r
st_retrieve(nodeaddress, st2_cur_ptr);\r
elementspix:= st2_cur_ptr^.st_spix;\r
errormsg(pass2, 151);\r
(* variable not of record type *)\r
end\r
else\r
begin\r
st2_cur_address:= st2_cur_ptr^.listref; (* start of fieldlist *)\r
help_boolean:= st_searchlist(nextinp, st2_cur_address, st2_cur_ptr);\r
nodeaddress:= st2_cur_address;\r
p2_typeref:= st2_cur_ptr^.typeref;\r
if not help_boolean then\r
begin\r
elementspix:= nextinp;\r
errormsg(pass2, 152);\r
(* no such field in this record *)\r
end else\r
begin\r
p2_specstruc:= st2_cur_ptr^.spec_struct;\r
help_boolean:= programtype in p2_specstruc;\r
if cross then st_cross_line(st2_cur_address,cnocode);\r
put_byte(ord(cfield));\r
if help_boolean then \r
begin\r
st2_cur_address:=p2_typeref;\r
st_retrieve(st2_cur_address, st2_cur_ptr);\r
if st2_cur_ptr^.st_kind=ctype then\r
begin\r
st2_cur_address:=st2_cur_ptr^.typeref;\r
st_retrieve(st2_cur_address, st2_cur_ptr);\r
end;\r
if st2_cur_ptr^.st_kind=cprogram then\r
(* program variable *)\r
begin\r
if create_call then\r
begin\r
syntaxkind:= sprogcall;\r
putaddress(nodeaddress);\r
put_byte(ord(cprogramcall));\r
create_call:= false;\r
p2_listref:= st2_cur_ptr^.listref;\r
end\r
else syntaxkind:= svarprog;\r
p2_typeref:= st2_cur_ptr^.typeref;\r
end else st2_cur_address:= nodeaddress;\r
end;\r
putaddress(nodeaddress);\r
nodeaddress:= st2_cur_address;\r
end;\r
end;\r
end; (* cfield *)\r
\r
\r
cformalparamlist: \r
(* FORMALPARAMLIST(NODEADDRESS) -----> *)\r
(* read address and push it on to the stack *)\r
(* p2code: as p1code *)\r
begin\r
read_push_dump(cformalparamlist,sformallist);\r
if cross then st_cross_decl(p2stacktop^.nodeaddress,token,false);\r
st2_start_search:= p2stacktop^.nodeaddress;\r
end;\r
\r
cendformal: \r
(* reducing formal parameters <--BEGINLEVEL ------>ENDFORMAL  or *)\r
(* formal parameters <--BEGINLEVEL--------<------->ENDFORMAL\r
(*                                !             !            *)\r
(*                                !-formal list-!              *)\r
(* a formallist element contains the following information *)\r
(* syntaxkind: sformallist\r
nodeaddress: st_address of first parameter in list\r
p2_typeref: st_address of the corresponding type node.\r
p2_listref: st_address of first parameter in next parameter list *)\r
(* the actions is: insert a typeref in the node in the symboltable *)\r
(* for each parameter in the formal list *)\r
(* link the last parameter in a preceding list to the first parameter *)\r
(* of the formal list *)\r
(* code: ENDFORMAL --> *)\r
\r
begin\r
if p2stacktop^.syntaxkind=sformallist then\r
begin\r
bind_of_family_allowed := (after_context or in_type_decl) and \r
                          not in_program_head;\r
(* after context or inside family declaration *)\r
repeat\r
with p2stacktop^ do\r
begin\r
linkref:= nodeaddress;\r
st_insert_typeref(linkref,p2_typeref);\r
(* for each node in ST starting at node linkref a link is made to the\r
type node denoted by typeref *)\r
(* after the call linkref contains the address of the last node \r
(parameter) *)\r
if not equal_addr(p2_listref, st_nilladdr) then\r
begin (* make a link from linkref to listref (i.e. from last parameter in\r
former list to first parameter in this formal list *)\r
(* TOG type !!! *)\r
st_gettype(linkref,st2_cur_ptr);\r
st2_cur_ptr^.listref:= p2_listref;\r
end;\r
former^.p2_listref:= nodeaddress;\r
pop_p2stack;\r
end;(* with *)\r
until p2stacktop^.syntaxkind=slevel;\r
\r
st2_start_search := linkref;\r
\r
(* Now 'p2stacktop^.listref' points out the first formal parameter  *)\r
(* of the parameter-list. ----- Make the formal parameters visible  *)\r
(* at end of parameterlist definition       -------                 *)\r
st_insert_symbols(p2stacktop^.p2_listref);\r
end\r
else\r
begin\r
if p2stacktop^.syntaxkind<>slevel then\r
p2_fatal_error(1);\r
(* inconsistency in pass2stack *)\r
end;\r
put_byte(ord (cendformal));\r
in_type_decl := false; (* if in type declarations left side then leaving it *)\r
end; (* cendformal *)\r
\r
cendformallist: \r
(* reducing formallist<--\r
FORMALPARAMLIST(NODEADDRESS) --> defining type --> ENDFORMALLIST *)\r
(* stacktop holds the defining type information and former^ holds *)\r
(* the information of the first parameter of formallist *)\r
begin\r
with p2stacktop^ do\r
former^.p2_typeref:= nodeaddress;\r
\r
pop_p2stack;\r
with p2stacktop^ do\r
check_legal_param_type(nodeaddress, p2_typeref);\r
\r
put_byte(ord(cendformallist));\r
end; (* cendformallist *)\r
\r
\r
cforstat: \r
(* FORSTAT(ST_ADDRESS) --> *)\r
begin\r
put_byte(ord(cforstat));\r
getaddress(st2_cur_address);\r
putaddress(st2_cur_address);\r
if cross then st_cross_decl(st2_cur_address,token,true);\r
before_assign:= false;\r
local_declare_state:= true;\r
end;\r
\r
cfuncdecl,\r
cprocdecl: \r
(* PROCDECL(ST_ADDRESS) ----> *)\r
(*       or                   *)\r
(* FUNCDECL(ST_ADDRESS) ----> *)\r
(* read address and stack it *)\r
(* special action in case of actual definition of a forward announced routine *)\r
(* dump pass2code *)\r
begin\r
(*** ***)\r
program_decl:= false;\r
if cur_block_level > program_level then\r
(* i.e.: inner routine declaration - *)\r
(* get sourrounding routine or program-description *)\r
begin\r
st_get(p2stacktop^.former^.former^.nodeaddress,st2_hlp_ptr);\r
st2_type := st2_hlp_ptr^.st_kind;\r
if (st2_type = cfunction) or\r
   (st2_type = cprocedure) then\r
st2_hlp_ptr^.spec_struct := routine_specstruc\r
else\r
if test_local then\r
begin\r
warning(pass2, 222);\r
(* testwarning  - routinedecl *)\r
writeln(testoutput, 'st_kind: ', ord(st2_type));\r
end;\r
end;\r
\r
routine_specstruc := [];\r
(*** ***)\r
push_p2stack;\r
with p2stacktop^ do\r
begin\r
if token=cfuncdecl then\r
syntaxkind:= sfuncdecl\r
else\r
syntaxkind:= sprocdecl;\r
getaddress(nodeaddress);\r
st2_start_search:= nodeaddress;\r
st_retrieve(nodeaddress, st2_cur_ptr);\r
help_specs:=st2_cur_ptr^.st_specs;\r
if help_specs=st_forward then\r
begin (* actual definition of a FORWARD announced routine or\r
unsolved FORWARD announcement *)\r
st2_cur_address:= st2_cur_ptr^.st_label; (* link to FORWARD announcement *)\r
st_retrieve(st2_cur_address, st2_cur_ptr);\r
with st2_cur_ptr^ do\r
if ((token=cfuncdecl) and (st_kind=cfunction)) or\r
((token=cprocdecl) and (st_kind=cprocedure)) then\r
begin (* actual definition of a FORWARD .... *)\r
push_p2stack; (* insert a reference to FORWARD announcement as nexttop *)\r
with p2stacktop^.former^ do\r
begin\r
p2stacktop^.syntaxkind:= syntaxkind;\r
p2stacktop^.nodeaddress:= nodeaddress;\r
nodeaddress:= st2_cur_address; (* of FORWARD declaration *)\r
p2_listref:= st2_cur_ptr^.listref; (* parameter list *)\r
if token=cfuncdecl then  (* superfluous test ????? *)\r
p2_typeref:= st2_cur_ptr^.typeref;\r
end; (* with former ... *)\r
end (* successful search *)\r
else\r
errormsg(pass2, 113);\r
(* FORWARD announcement not followed by actual routine definition *)\r
end (* specs=st_forward *)\r
else\r
begin\r
st2_cur_address:= nodeaddress;\r
st_insert_headsymbol(nodeaddress);\r
end;\r
put_byte(ord(token));\r
putaddress(st2_cur_address);\r
if compile_info then \r
begin\r
if (help_specs=st_local) or (help_specs=st_global) then \r
dump_info(st2_cur_address);\r
end;\r
\r
if cross then\r
begin\r
if help_specs<>st_forward\r
then st_cross_decl(st2_cur_address,token,true)\r
else st_cross_line(st2_cur_address,cforward);\r
end;\r
\r
end; (* with p2stacktop *)\r
end; (* cfuncdecl/cprocdecl *)\r
\r
\r
cendfuncdecl:\r
(* reducing function heading <-\r
  FUNCDECL(STADDRESS)-->formal parameters-->defining type-->ENDFUNCDECL -- *)\r
(* bind the result type to the function node in the symbol table *)\r
(* if formal parameters exist then check that the function node\r
  is linked to the formal parameters *)\r
(* unstack the formal parameters if any *)\r
(* update blocklevel *)\r
(* lookahead to see if block, EXTERNAL or FORWARD or OPENROUTINE is\r
  present *)\r
(* code: ENDFUNCDECL -- *)\r
begin\r
with p2stacktop^ do\r
begin\r
\r
(* #BEGINTEST \r
if (syntaxkind<>stype) or { former is the level node }\r
(former^.former^.syntaxkind<>sfuncdecl) then\r
p2_fatal_error(1);\r
(* inconsistency in pass2 stack *)\r
(* ENDTEST# *)\r
\r
(* TOG, test move to pass3 *)\r
(*st_retrievetype(nodeaddress, st2_cur_ptr);\r
with st2_cur_ptr^ do\r
if not (ordinaltype(st_kind) or machinetype(st_kind) or\r
(st_kind=cpointertype) or (st_kind=cdo)) then\r
begin\r
(*  undefined/ TOG    elementspix:= st_spix; *)\r
(*errormsg(pass2, 142);\r
(* illegal type of function result *)\r
(*end;*)\r
\r
st_get(former^.former^.nodeaddress, st2_cur_ptr); (* the function element *)\r
st2_cur_ptr^.typeref:= nodeaddress;\r
former^.former^.p2_typeref:= nodeaddress;\r
end; (* with p2stacktop^ *)\r
\r
pop_p2stack; (* defining type *)\r
\r
put_byte(ord(cendfuncdecl));\r
\r
routine_block_lookahead;\r
\r
end; (* cendfuncdecl *)\r
\r
\r
cendprocdecl:\r
(* reducing procedure heading <-\r
  PROCDECL(STADDRESS)-->-formal parameters-->ENDPROCDECL -- *)\r
(* if formal parameters exist then check that the procedure node\r
  is linked to the formal parameters *)\r
(* unstack the formal parameters if any *)\r
(* update blocklevel *)\r
(* lookahead to see if block, EXTERNAL or FORWARD or OPENROUTINE is\r
  present *)\r
(* code: ENDPROCDECL -- *)\r
\r
begin\r
(* #BEGINTEST\r
if (p2stacktop^.former^.syntaxkind<>sprocdecl) then\r
p2_fatal_error(1);\r
(* inconsistency in pass2 stack *)\r
(* ENDTEST#  *)\r
\r
put_byte(ord(cendprocdecl));\r
\r
(* lookahead *)\r
routine_block_lookahead;\r
\r
Program_decl := false;\r
end; (* cendprocdecl *)\r
\r
cgoto: (* reduce\r
--> GOTO(spix) -->\r
code: GOTO(symbol)\r
test: label defined inside current label scope *)\r
begin\r
nextinp:= get_2_byte;\r
elementnumber:= elementnumber+1;\r
st2_cur_address:= st_nilladdr; (* search inside entire level *)\r
if not st_search(nextinp, st2_cur_address, with_address, st2_cur_ptr) then\r
begin\r
elementspix:= nextinp;\r
errormsg(pass2, 127);\r
(* undefined label *)\r
end\r
else\r
begin\r
if st2_cur_ptr^.st_kind<>clabel then\r
begin\r
elementspix:= nextinp;\r
errormsg(pass2, 127);\r
(* undefined label *)\r
end\r
else\r
if st2_cur_ptr^.label_scope<>current_labelscope then\r
errormsg(pass2, 128);\r
(* illegal goto statement *)\r
if cross then st_cross_line(st2_cur_address,cnocode);\r
end;\r
put_byte(ord(cgoto));\r
putaddress(st2_cur_address);\r
end; (* gotostat *)\r
\r
\r
cvarsizecall,\r
ctypesizecall:\r
(* reduce: ----> TYPESIZECALL(SPIX) --->     *)\r
(* or      ----> VARSIZECALL(SPIX) --->      *)\r
(* code:  ----> TYPESIZECALL(SYMBOL) --->    *)\r
(* or     ----> VARSIZECALL(SYMBOL) --->     *)\r
(* test: that 'spix' is name of type or variable *)\r
begin\r
elementnumber := elementnumber + 1;\r
nextinp := get_2_byte;\r
elementnumber := elementnumber + 1;\r
\r
if not st_search(nextinp,st2_cur_address, with_address, st2_cur_ptr) then\r
begin\r
elementspix := nextinp;\r
errormsg(pass2, 106);\r
(* undefined *)\r
end\r
else\r
begin\r
with st2_cur_ptr^ do\r
if token = cvarsizecall then\r
begin\r
(* check at 'st_kind' svarer til 'svar' *)\r
if (st_kind<>cvar) and\r
   (st_kind<>cshared) and\r
   (st_kind<>cinspectparam) and\r
   (st_kind<>cvarparam) and\r
   (st_kind<>cwithvar) AND\r
   (st_kind<>clockvar) AND\r
   (st_kind<>crecfield) AND\r
   (st_kind<>cvalueparam) then\r
begin\r
elementspix := nextinp;\r
errormsg(pass2, 185);\r
(* parameter of varsize-call has to be name of variable *)\r
end;\r
end\r
else  (* ctypesizecall *)\r
if st_kind <> ctype then\r
begin\r
elementspix := nextinp;\r
errormsg(pass2, 186);\r
(* parameter of typesize-call has to be a typename *)\r
end else\r
if (type_mode=fam) or (type_mode=open_fam) then\r
begin\r
elementspix := nextinp;\r
errormsg(pass2, 302);\r
(* family parameter of typesize-call not allowed *)\r
end;\r
\r
if cross then st_cross_line(st2_cur_address,cnocode);\r
end;\r
\r
push_p2stack;\r
with p2stacktop^ do\r
begin\r
syntaxkind := sconst;\r
boo := stdcode_to_address(cinteger,p2_typeref);\r
(* nodeaddress := st2_cur_address; *)\r
end;\r
put_byte(ord(token));\r
putaddress(st2_cur_address);\r
end;\r
\r
\r
cid: do_id;\r
(* ID(SPIX) -----> *)\r
(* read spix, find st_address, push on stack *)\r
(* decide wether var,const,proccall or funccall *)\r
(* dump pass2code: *)\r
(* var or funccall: ----> ID(ST_ADDRESS)--------> *)\r
(* const          : ----> CONST(ST_ADDRESS)------> *)\r
(* proccall       : ----> PROCCALL(ST_ADDRESS)---> *)\r
\r
\r
\r
\r
cifexpr: \r
(* reducing IFSTAT---->expression--->IFEXPR *)\r
begin\r
if code_of_address(p2stacktop^.p2_typeref)<>cboolean then\r
errormsg(pass2, 123);\r
(* type of if expression is not boolean *)\r
pop_p2stack; (* expression *)\r
put_byte(ord(cifexpr));\r
before_assign:= true;\r
end;\r
\r
\r
cifstat: \r
(* start of ifstatement *)\r
begin\r
put_byte(ord(cifstat));\r
before_assign:= false;\r
end; (* ifstat *)\r
\r
\r
celse,\r
cendelse,\r
cendif: \r
(* reducing ifstatement: \r
IFSTAT--->expression--->IFEXPR--->statement---------------->ENDIF *)\r
(* or *)\r
(* IFSTAT--->expression->IFEXPR->statement->ELSE->statement->ENDELSE *)\r
(* or *)\r
(*  -->ELSE --> *)\r
put_byte(ord(token));\r
\r
\r
cin: (* dyadic operator IN, test types and put code CIN *)\r
begin\r
st_retrievetype(p2stacktop^.p2_typeref, st2_cur_ptr);\r
\r
with st2_cur_ptr^ do\r
if (st_kind = csettype) and\r
( compatible(p2stacktop^.former^.p2_typeref, typeref )  or\r
equal_addr(p2stacktop^.p2_typeref, st_emptyset_addr) ) then\r
pushresult(cin)\r
else\r
begin\r
pushresult(cerror);\r
errormsg(pass2, 124);\r
(* operands not compatible *)\r
end;\r
put_byte(ord(cin));\r
set_result:=false;\r
end; (* cin *)\r
\r
\r
cinit: (* reduce  CINIT(symbol) *)\r
(* action: connect type as for ENDVAR/ENDSHARED but do not pop variable *)\r
(* code: cinit(symbol) *)\r
begin\r
with p2stacktop^ do\r
begin\r
st_get(former^.nodeaddress, st2_cur_ptr);\r
with st2_cur_ptr^ do\r
if st_kind=cshareddecl then \r
st_kind:= cshared (* change back from shareddecl to shared *)\r
else\r
st_kind:= cvar; (* change back from vardecl to var *)\r
st_insert_typeref(former^.nodeaddress, nodeaddress);\r
st2_start_search := former^.nodeaddress;\r
former^.p2_typeref:= nodeaddress; (* prepare assignment *)\r
end; (* with ... *)\r
pop_p2stack; (* defining type *)\r
\r
st_retrieve(p2stacktop^.p2_typeref, st2_cur_ptr);\r
routine_specstruc := routine_specstruc + st2_cur_ptr^.spec_struct;\r
\r
if p2stacktop^.syntaxkind = sshared then\r
begin\r
if st2_cur_ptr^.spec_struct*ill_shared_types<>[] then\r
errormsg(pass2, 144);\r
(* process or chain not allowed in SHARED declaration *)\r
end; (* shared *)\r
if (cur_block_level<>program_level) and\r
   (st2_cur_ptr^.spec_struct*ill_routine_types<>[]) then\r
begin\r
  errormsg(pass2,196);\r
  (* shielded type, except referencei, not allowed in routine *)\r
end;\r
getaddress(st2_cur_address);\r
put_byte(ord(cinit));\r
putaddress(st2_cur_address);\r
before_assign:= false;\r
p2stacktop^.syntaxkind:= sinitobj;\r
end; (* cinit *)\r
\r
\r
cendinit: (* reduce INIT(symbol) expression ENDINIT\r
action: compatibility test, pop VAR/SHARED and expression\r
code: ENDINIT or ENDASSIGNSET or ENDASSIGNSTRING  *)\r
begin\r
with p2stacktop^ do\r
if not compatible(former^.p2_typeref, p2_typeref (* result type of expression *)) then\r
errormsg(pass2, 110);\r
(* variable and expression not compatible *)\r
if maybe_set_type or set_result then\r
begin\r
set_result:=false;\r
put_byte(ord(cendassignset));\r
end\r
else if maybe_string_type then put_byte(ord(cendassignstring))\r
else put_byte(ord(cendinit));\r
pop_p2stack; (* expression *)\r
pop_p2stack; (* VAR/SHARED *)\r
end; (* cendinit *)\r
\r
\r
clabeldef: (* reduce: \r
--> LABELDEF(symbol) --> *)\r
begin\r
getaddress(st2_cur_address);\r
put_byte(ord(clabeldef));\r
putaddress(st2_cur_address);\r
if cross then st_cross_decl(st2_cur_address,token,true);\r
elementnumber:= elementnumber+1;\r
end; (* labeldef *)\r
\r
\r
cliteral:\r
begin\r
(* read and write -->literal(st2_type,length)"string" --> *)\r
(* push the literal to p2stack kind is sconst *)\r
\r
elementnumber:= elementnumber+1;\r
\r
st2_type:= codes(get_byte);\r
length := get_2_byte;\r
put_byte(ord(cliteral));\r
(* !!! new rtp  hha  10.08.89 *********)\r
{$IFNDEF RTP86}\r
if (st2_type = cword) or (st2_type = cbyte) then\r
if computer <> oldpi3 then st2_type := cinteger;\r
{$ENDIF}\r
put_byte(ord(st2_type));\r
\r
(* st2_type is one of the following: cinteger,cword,cbyte,cchar or\r
  ctext. ctext is a string type and the others are basic types *)\r
\r
if st2_type <> ctext then\r
(* find the st_address from the std_code *)\r
boo:=stdcode_to_address(st2_type,st2_cur_address)\r
 else\r
begin\r
(* bind text to a parametrisized string-type *)\r
copy_type(st_string_type_addr, st2_cur_address);\r
st_get(st2_cur_address, st2_cur_ptr);\r
st2_cur_ptr^.type_mode := bound_fam;\r
putaddress(st2_cur_address);\r
end;\r
\r
(* to optimize pass3 *)\r
if st2_type = cinteger then\r
begin\r
help := get_2_byte;\r
if help <> ord('#') then\r
begin\r
put_2_byte(length + 2);\r
put_2_byte(ord('#'));\r
put_2_byte(ord('d'));\r
end else\r
put_2_byte(length);\r
\r
put_2_byte(help);\r
\r
for count:= 2 to length do put_2_byte(get_2_byte);\r
end\r
else\r
begin\r
  (* st2_type <> cinteger *)\r
  put_2_byte(length);\r
  for count:= 1 to length do put_2_byte(get_2_byte);\r
end;\r
push_p2stack;\r
with p2stacktop^ do\r
begin\r
syntaxkind:= sconst;\r
p2_typeref:= st2_cur_address;\r
end;\r
end; (* cliteral *)\r
\r
\r
clockstat, clockbufstat:\r
begin\r
before_assign:= false;\r
put_byte(ord(token));\r
push_p2stack;\r
with p2stacktop^ do\r
if token=clockstat then\r
syntaxkind:= slock\r
else\r
syntaxkind:= slockbuf;\r
in_lock_state:= true;\r
local_declare_state:= true;\r
end; (* clockstat, clockbufstat *)\r
\r
\r
cendlock:\r
begin\r
if getcode <> cendlevel then\r
p2_fatal_error(4); \r
(* inconsistent pass1 code *)\r
end_level_action;\r
pop_p2stack;   (* lock/lockbuf *)\r
put_byte(ord(cendlock));\r
end;\r
\r
\r
clockvar: if do_lockvar then goto 9876;\r
\r
cloopstat: (* reduce loopstat <-\r
--> LOOPSTAT --> *)\r
begin\r
put_byte(ord(cloopstat));\r
repetitive_counter:= repetitive_counter+1;\r
end; (* loopstat *)\r
\r
\r
cnolocaldecl:\r
begin\r
local_declare_state:= false;\r
put_byte(ord(cnolocaldecl));\r
if in_lock_state then in_lock_state:=false\r
else st_insert_withsymbols(p2stacktop^.former^.nodeaddress);\r
end;\r
\r
\r
cnot:\r
(* topmost element contains operand *)\r
begin\r
st2_type:= code_of_address(p2stacktop^.p2_typeref);\r
if (st2_type <> cboolean) and (st2_type <> cbyte) and (st2_type <> cword)\r
and (st2_type <> cinteger)\r
then begin\r
st_getbasetype(p2stacktop^.p2_typeref, st2_cur_ptr);\r
if   (st2_cur_ptr^.st_kind<>cinteger) then\r
begin\r
boo:= stdcode_to_address(cerror,p2stacktop^.p2_typeref);\r
errormsg(pass2, 125);\r
(* type of operand illegal when not is going to be used as operator *)\r
end\r
 else boo:= stdcode_to_address(cinteger, p2stacktop^.p2_typeref);\r
end;\r
put_byte(ord(cnot));\r
end;\r
\r
\r
cnull:\r
(* a '?' read as actual parameter *)\r
(* or as initialization-value  *)\r
begin\r
(*******  *****) if test_stack then\r
write_p2stack;\r
\r
elementnumber:= elementnumber+1;\r
if (p2stacktop^.syntaxkind = sstrucrecval) or\r
   (p2stacktop^.syntaxkind = sstrucarrval) or\r
   (p2stacktop^.former^.syntaxkind = sstrucarrval) then\r
begin\r
(**  ????????????????? !!!!!!!!!!!!!!!\r
eventuelle test paa formelle parameter - shielded or not \r
**)\r
(* dump of cnull and check that elements are shielded or pointer\r
   are made in strucelem and repstruc *)\r
\r
end\r
else\r
begin\r
if p2stacktop^.syntaxkind<>sactualparam then\r
errormsg(pass2, 168);\r
(* '?' not allowed at this place *)\r
\r
put_byte(ord(cskipparam));\r
if test_local then \r
begin\r
writeln(testoutput, 'syntaxkind: ');\r
write_kind(p2stacktop^.syntaxkind);\r
writeln(testoutput, 'former syntaxkind: ');\r
write_kind(p2stacktop^.former^.syntaxkind);\r
end;\r
end;\r
\r
push_p2stack;\r
with p2stacktop^ do\r
begin\r
syntaxkind:= snull;\r
nodeaddress:= st_nilladdr;\r
end;\r
end;\r
\r
\r
ceq,cne,clt,cle,cgt,cge,\r
cadd,csub,cor,cxor,\r
cmul,cdiv,cmod,cand:\r
(* two topmost stackelements contains the operands *)\r
(* section numbers refer to sections of the Reference Manual *)\r
with p2stacktop^ do\r
begin\r
st_retrievetype(former^.p2_typeref, st2_cur_ptr);\r
st2_type:= st2_cur_ptr^.st_kind;\r
\r
if not compatible(former^.p2_typeref,p2_typeref) then\r
begin\r
if machinetype(st2_type) and\r
machinetype(code_of_address(p2_typeref)) then\r
(* if section 3.5 operands then ok *)\r
pushresult(token)\r
else\r
begin\r
pushresult(cerror);\r
errormsg(pass2, 124);\r
(* operands not compatible *)\r
end;\r
end (* not compatible *)\r
else\r
begin\r
(* if section 3.5 operands then ok *)\r
ok:= machinetype(st2_type);\r
if not ok then\r
begin\r
(* if section 3.4 operands and operator allowed then ok *)\r
if token in [ceq, cne, cle, cge, cgt, clt] then\r
ok:= ordinaltype(st2_type);\r
if not ok then\r
begin\r
(* if section 3.6 operands and operator allowed then ok *)\r
if token in [cle, cge, ceq, cne, cadd, csub, cmul] then\r
ok:= st2_type=csettype;\r
if not ok then\r
begin\r
(* if section 3.7 or section 3.9 operands and operator allowed then ok *)\r
if (token=ceq) or (token=cne) then\r
ok:= (st2_type=cpointertype) or (st2_type=carraytype) or (st2_type=crecordtype);\r
if not ok then\r
begin\r
(* if section 3.4.1 operands and operator allowed then ok *)\r
if (token=cor) or (token=cxor) or (token=cand) then\r
ok:= st2_type=cboolean;\r
if not ok then\r
begin\r
(* if section 3.4.3 operands and operator allowed then ok *)\r
(* and AND, OR and XOR *)\r
if token in [cadd, csub, cmul, cdiv, cmod, cand, cor, cxor] then\r
begin\r
ok:= st2_type=cinteger;\r
if not ok then (* see if operation on subrange variable *)\r
with former^ do\r
begin\r
st_getbasetype(p2_typeref, st2_cur_ptr);\r
if st2_cur_ptr^.st_kind=cinteger then\r
ok:= stdcode_to_address(cinteger, p2_typeref);\r
(* resulting type is integer *)\r
end; (* with former .... *)\r
end; (* 3.4.3 *)\r
if not ok then\r
begin\r
if (token=cle) or (token=clt) or (token=cge) or (token=cgt) then\r
begin\r
st2_cur_address:=p2_typeref;\r
original_node(st2_cur_address,st2_cur_ptr);\r
ok:= equal_addr(st_string_type_addr, st2_cur_address);\r
end;\r
end; (* not string *)\r
end; (* not 3.4.3 *)\r
end; (* not ok 3.7 or 3.9 *)\r
end; (* not ok 3.6 *)\r
end; (* not ok 3.4 *)\r
end; (* not ok 3.5 *)\r
if not ok then\r
begin\r
pushresult(cerror);\r
errormsg(pass2, 129);\r
(* illegal type of operands *)\r
end\r
else\r
pushresult(token);\r
end; (* compatible *)\r
\r
set_result:=false;\r
(* all sets, not only maybe_set *)\r
if st2_type = csettype then\r
(** case ud paaa operand and dump 'csetoperator' or 'ccompareset' to pass3 **)\r
case token of\r
cle, cge, ceq, cne : put_byte(ord(ccompareset));\r
cmul, cadd, csub : begin put_byte(ord(csetoperator)); set_result:=true; end\r
else\r
end else\r
if maybe_string_type or\r
   (is_string_Type AND (token <> ceq) AND (token <> cne))\r
    then (* is string *) put_byte(ord(ccomparestring));\r
\r
put_byte(ord(token));\r
end; (* with p2stacktop, for most of the dyadic operators *)\r
\r
\r
cotherwise:\r
put_byte(ord(cotherwise));\r
\r
\r
(* cprocdecl: see cfuncdecl *)\r
\r
cpointertype:\r
begin\r
read_push_dump_type(cpointertype);\r
end; (* cpointer *)\r
\r
\r
cendpointer:\r
begin\r
with p2stacktop^ do\r
begin\r
(**** hha   **)\r
if p2_specstruc = [mailboxtype] then former^.p2_specstruc := [mailboxpointer]\r
(*  HHA\r
else\r
begin\r
if programtype in p2_specstruc then\r
        former^.p2_specstruc := [pointertype, programtype]  *)\r
else\r
former^.p2_specstruc :=  [pointertype];\r
\r
st_gettype(former^.nodeaddress, st2_cur_ptr); (* cpointer *)\r
st2_cur_ptr^.typeref:= nodeaddress; (* element type *)\r
(*st2_cur_ptr^.spec_struct := former^.p2_specstruc*)\r
end; (* with top *)\r
pop_p2stack;\r
with p2stacktop^ do\r
begin\r
if (former^.syntaxkind = slevel) AND\r
   (former^.former^.syntaxkind <> sFuncdecl) then\r
(* typedeclaration - skip 'slevel'-node *)\r
begin\r
st_get(former^.former^.nodeaddress, st2_cur_ptr);\r
former^.former^.p2_specstruc := p2_specstruc;\r
end\r
else\r
(* inline typedefinition *)\r
begin\r
st_get(nodeaddress, st2_cur_ptr);  (*** ?? former^ ??***)\r
former^.p2_specstruc := p2_specstruc;\r
end;\r
\r
\r
st2_cur_ptr^.spec_struct := p2_specstruc;\r
routine_specstruc := routine_specstruc + p2_specstruc;\rend;\r
\r
put_byte(ord(cendpointer));\r
end; (* cendpointer *)\r
\r
\r
cprogdecl: \r
begin\r
in_program_head:=true;\r
bind_of_family_allowed:=false;\r
if after_context and (cur_block_level=context_level) then\r
(* first PROGRAM met after a context !!!!!!! ?????? TOG*)\r
begin\r
cur_block_level:= program_level;\r
global_level:= false;\r
new_comp_unit:=true;\r
end;\r
\r
read_push_dump(cprogdecl,stype);\r
with p2stacktop^ do\r
begin\r
st_retrieve(nodeaddress, st2_cur_ptr);\r
misc_field:= 3;\r
if st2_cur_ptr^.st_kind=ctype then\r
begin\r
p2_typeref:= st2_cur_ptr^.typeref;\r
p2_specstruc:= st2_cur_ptr^.spec_struct;\r
end else p2_typeref:= nodeaddress;\r
(* TOG, insert by vardecl\r
st_insert_headsymbol(nodeaddress);\r
st2_start_search:= nodeaddress;\r
*)\r
end;\r
push_p2stack;\r
with p2stacktop^ do\r
begin\r
syntaxkind:=sprogdecl;\r
nodeaddress:=former^.p2_typeref;\r
\r
\r
if compile_info then\r
begin\r
st_retrieve(nodeaddress,st2_cur_ptr);\r
if (st2_cur_ptr^.st_specs=st_local) or (st2_cur_ptr^.st_specs=st_global)\r
then dump_info(nodeaddress);\r
end;\r
\r
if cross then st_cross_decl(nodeaddress,token,true);\r
\r
end;\r
\r
if cur_block_level<>program_level then \r
if cur_block_level=context_level then\r
errormsg(pass2, 101)\r
(* program declaration in context not allowed *)\r
else\r
errormsg(pass2, 102);\r
(* program declaration in routine not allowed *)\r
program_decl:= true;\r
(*** ***)\r
routine_specstruc := [];\r
st_begin_program;\r
end;(* cprogdecl *)\r
\r
\r
cendprogdecl: do_endprogdecl;\r
\r
\r
crecfield:\r
begin\r
read_push_dump(crecfield, sfield);\r
if cross then st_cross_decl(p2stacktop^.nodeaddress,token,false);\r
(* !!!!! error, insert all fields becaurce error in pass1 \r
st_insert_symbols(p2stacktop^.nodeaddress);\r
*)\r
end;\r
\r
\r
crecordtype:\r
begin\r
read_push_dump_type(crecordtype);\r
st_beginrec;\r
end;\r
\r
\r
cendrecord:\r
(* a field list element contains the following information *)\r
(* syntaxkind: sfield\r
nodeaddress: st_address of first field in list\r
p2_typeref: st_address of the corresponding type node.\r
p2_listref: st_address of first field in next field list *)\r
(* the actions is: insert a typeref in the node in the symboltable *)\r
(* for each field in the field list *)\r
(* code: ENDRECORD --> *)\r
\r
begin\r
while p2stacktop^.syntaxkind=sfield do\r
with p2stacktop^ do\r
begin\r
linkref:= nodeaddress;\r
st_insert_typeref(linkref,p2_typeref);\r
(* for each node in ST starting at node linkref a link is made to the\r
type node denoted by typeref *)\r
(* after the call linkref contains the address of the last node\r
(field) *)\r
former^.p2_specstruc := former^.p2_specstruc + p2_specstruc;\r
(* union of "spec_struct" from all fields in record *)\r
st2_start_search := linkref;\r
(*** i.e. fields are visible just after introduction **)\r
st_retrieve(p2_typeref, st2_cur_ptr);\r
with st2_cur_ptr^ do\r
if st_spix=anonymousspix (* inline type def *) then\r
begin\r
st_retrievetype(typeref, st2_cur_ptr);\r
if st_kind=cscalar then\r
errormsg(pass2, 147);\r
(* enumeration type definition not allowed as field type *)\r
end;\r
\r
former^.p2_listref:= nodeaddress;\r
pop_p2stack;\r
end;(* with *)\r
\r
(* Now p2stacktop describes a record-type - i.e. sytaxtype = stype -*)\r
(* 'nodeaddress' points out a ST-element of kind 'crecordtype' *)\r
(* Action: update 'spec_struct' in ST from 'p2_specstruc'.  *)\r
(*         and update 'typedeclnode' in p2stack *)\r
with p2stacktop^ do\r
begin\r
if former^.syntaxkind = slevel then\r
(* typedeclaration - skip 'slevel'-node *)\r
begin\r
st_get(former^.former^.nodeaddress, st2_cur_ptr);\r
former^.former^.p2_specstruc := p2_specstruc;\r
end\r
else\r
(* inline typedefinition *)\r
begin\r
st_get(nodeaddress, st2_cur_ptr);  (*** ?? former^ ??***)\r
former^.p2_specstruc := p2_specstruc;\r
end;\r
\r
\r
st2_cur_ptr^.spec_struct := p2_specstruc;\r
routine_specstruc := routine_specstruc + p2_specstruc;\r
\r
(****** ***)\r
if test_stack then write_p2stack;\r
end;\r
\r
put_byte(ord(cendrecord));\r
st_endrec;\r
\r
(* 'p2_listref' points out first recordfield in the record-field list *)\r
with p2stacktop^ do\r
(* empty RECORD allowed !!!!!\r
if equal_addr(p2_listref, st_nilladdr) then\r
errormsg(pass2, 175);\r
(* empty RECORD definition not allowed *)\r
\r
end; (* cendrecord *)\r
\r
\r
cregionstat:\r
begin\r
push_p2stack;\r
p2stacktop^.syntaxkind:= sregion;\r
\r
nextinp:= get_2_byte;\r
elementnumber:= elementnumber+1;\r
st2_cur_address:= st_nilladdr; (* search inside entire level *)\r
help_boolean:=st_search(nextinp,st2_cur_address,with_address,st2_cur_ptr);\r
if not help_boolean then\r
begin\r
elementspix:= nextinp;\r
errormsg(pass2, 106);\r
(* undefined *)\r
end\r
else\r
begin\r
cross_addr:=st2_cur_address;\r
with st2_cur_ptr^ do\r
if (st_kind<>cshared) and (st_kind<>csharedparam) then\r
errormsg(pass2, 162);\r
(* object of REGION must be of kind SHARED *)\r
\r
p2stacktop^.nodeaddress := st2_cur_address;\r
end;\r
put_byte(ord(cregionstat));\r
putaddress(st2_cur_address);\r
(* the value of 'st2_cur_address' is either 'undefined-addr' or *)\r
(* addr of the (perhabs shared) variable.. *)\r
if help_boolean and cross then st_cross_line(cross_addr,cnocode);\r
end; (* regionstat *)\r
\r
\r
cendregion: begin\r
(* #beginstest *)\r
if p2stacktop^.syntaxkind<>sregion then\r
p2_fatal_error(1);\r
(* inconsistency in pass2 stack *)\r
(* ENDTEST# *)\r
put_byte(ord(cendregion));\r
pop_p2stack;\r
end; (* endregion *)\r
\r
\r
crepeatstat: (* reduce repeatstat: \r
--> REPEATSTAT --> *)\r
begin\r
repetitive_counter:= repetitive_counter+1;\r
put_byte(ord(crepeatstat));\r
end; (* repeatstat *)\r
\r
\r
cendrepeat: (* reduce endrepeat: \r
--> expression --> ENDREPEAT -->\r
test: type of expression must be boolean *)\r
begin\r
st2_type:= code_of_address(p2stacktop^.p2_typeref);\r
if st2_type<>cboolean then\r
begin\r
boo:= stdcode_to_address(cerror, p2stacktop^.p2_typeref);\r
errormsg(pass2, 119);\r
(* type of expression must be boolean *)\r
end;\r
pop_p2stack;\r
put_byte(ord(cendrepeat));\r
before_assign:= true;\r
end; (* endrepeat *)\r
\r
\r
crepstruc:\r
begin\r
st2_type:=cendassign; (* assume not stringassign or setassign *)\r
with p2stacktop^ do\r
if syntaxkind=snull then dump_cnull_and_check(former^.former^.nodeaddress)\r
else\r
if not compatible(former^.former^.nodeaddress, p2_typeref) then\r
errormsg(pass2, 110);\r
(* variable and expression not compatible *)\r
if maybe_set_type or set_result then\r
begin\r
  set_result:=false;\r
  st2_type:=cendassignset;\r
end\r
else if maybe_string_type then st2_type:=cendassignstring;\r
\r
pop_p2stack; (* value expression *)\r
with p2stacktop^ do\r
begin\r
st_getbasetype(p2_typeref, st2_cur_ptr);\r
if st2_cur_ptr^.st_kind<>cinteger then\r
errormsg(pass2, 159);\r
(* repetition expression must be of type integer *)\r
end;\r
pop_p2stack;\r
if p2stacktop^.syntaxkind<>sstrucarrval then\r
errormsg(pass2, 160);\r
(* repetition only allowed for array types *)\r
put_byte(ord(crepstruc));\r
put_byte(ord(st2_type));\r
end; (* crepstruc *)\r
\r
\r
cscalartype:\r
begin\r
read_push_dump_type(cscalartype);\r
if p2stacktop^.former^.syntaxkind=svar then\r
begin (* skip anonymous type *)\r
st_retrieve(p2stacktop^.nodeaddress,st2_cur_ptr);\r
st2_cur_address:=st2_cur_ptr^.typeref;\r
end\r
else st2_cur_address:=p2stacktop^.nodeaddress;\r
st_retrieve(st2_cur_address,st2_cur_ptr); (* skip scalar *)\r
if cross then st_cross_decl(st2_cur_ptr^.listref,token,false);\r
st_insert_symbols(st2_cur_ptr^.listref);\r
end;\r
\r
\r
csetlist:\r
begin\r
getaddress(st2_cur_address);\r
\r
put_byte(ord(token));\r
putaddress(st2_cur_address);\r
\r
st_retrieve(st2_cur_address, st2_cur_ptr);\r
push_p2stack;\r
with p2stacktop^ do\r
begin\r
syntaxkind := ssetlist;\r
nodeaddress := st2_cur_address;\r
p2_typeref := st2_cur_ptr^.typeref;\r
\r
end;\r
end; (* csetlist *)\r
\r
cendsetlist:\r
begin\r
put_byte(ord(token));\r
if p2stacktop^.syntaxkind <> ssetlist then\r
p2_fatal_error(1);\r
(* inconsistency in pass2 stack *)\r
\r
(* "p2_typeref" holds settype - identified by "nodeaddress" *)\r
(* "p2_listref" holds element type of the set *)\r
\r
if not equal_addr(p2stacktop^.p2_typeref, st_emptyset_addr) then\r
begin\r
(** insert element-type into typeref of 'csettype'-node **)\r
st_retrieve(p2stacktop^.p2_typeref, st2_hlp_ptr);\r
st_get(st2_hlp_ptr^.typeref, st2_cur_ptr);\r
st2_cur_ptr^.typeref := p2stacktop^.p2_listref;\r
end;\r
\r
end; (* cendsetlist *)\r
\r
cs_element,\r
cm_element:\r
begin\r
if token = cm_element then\r
begin\r
(** check that 2 topmost elements are of the same type *)\r
with p2stacktop^ do \r
if not sametype(former^.p2_typeref, p2_typeref) then\r
errormsg(pass2, 188);\r
(* set elements has to be of the same type *)\r
\r
pop_p2stack;\r
put_byte(ord(cm_element));\r
end (* cm_element *)\r
else \r
put_byte(ord(cs_element));\r
\r
(** check that 2 topmost elements are of the same type *)\r
with p2stacktop^ do \r
if not equal_addr(former^.p2_listref, st_nilladdr) then\r
(** 1. time is former^.p2_listref = st_nilladdr **)\r
begin\r
if not sametype(former^.p2_listref, p2_typeref) then\r
errormsg(pass2, 188)\r
(* set elements has to be of the same type *)\r
else\r
begin\r
st_retrievetype(p2_typeref, st2_cur_ptr);\r
if not ordinaltype(st2_cur_ptr^.st_kind) then\r
errormsg(pass2, 189);\r
(* set element type has to be ordinal *)\r
end;\r
end;\r
\r
p2stacktop^.former^.p2_listref := p2stacktop^.p2_typeref;\r
\r
\r
pop_p2stack;\r
end; (* cs_element and cm_element *)\r
\r
csettype:\r
begin\r
read_push_dump_type(csettype);\r
end; (* csettype *)\r
\r
\r
cendset: \r
begin\r
with p2stacktop^ do\r
begin\r
st_gettype(former^.nodeaddress, st2_cur_ptr);\r
st2_cur_ptr^.typeref:= nodeaddress;\r
st_retrievetype(nodeaddress, st2_cur_ptr);\r
if not ordinaltype(st2_cur_ptr^.st_kind) then\r
errormsg(pass2, 148);\r
(* element type of set must be ordinal *)\r
end; (* with *)\r
pop_p2stack;\r
\r
put_byte(ord(cendset));\r
end; (* cendset *)\r
\r
\r
cshareddecl: \r
(* rule *)\r
(* SHAREDDECL(ST_ADDRESS) ---> *)\r
(* read address and stack element *)\r
(* dump p2code *)\r
begin\r
if not after_context then errormsg(pass2, 163);\r
read_push_dump(cshareddecl,sshared);\r
if cross then st_cross_decl(p2stacktop^.nodeaddress,token,false);\r
st_insert_symbols(p2stacktop^.nodeaddress);\r
st2_start_search:= p2stacktop^.nodeaddress;\r
st_get(st2_start_search, st2_cur_ptr);\r
st2_cur_ptr^.st_kind:= cshareddecl; (* avoid recursive use of shared *)\r
end; (* cshareddecl *)\r
\r
\r
(* cendshared:  see under cendvar *)\r
\r
\r
cshift:\r
(* dyadic operator SHIFT, test operand types and put_byte(ord(CSHIFT)) *)\r
begin\r
ok:= true;\r
with p2stacktop^ do\r
begin\r
st_getbasetype(p2_typeref, st2_cur_ptr);\r
if st2_cur_ptr^.st_kind=cinteger then\r
begin\r
st_retrievetype(former^.p2_typeref, st2_cur_ptr);\r
if machinetype(st2_cur_ptr^.st_kind) then\r
pushresult(cshift)\r
else\r
begin\r
ok:=false;\r
  (* TOG !!! new rtp86 !!! , integer shift *)\r
if st2_cur_ptr^.st_kind=csubrange then\r
st_getbasetype(st2_cur_ptr^.typeref, st2_cur_ptr);\r
if st2_cur_ptr^.st_kind=cinteger then\r
begin\r
ok:=true;\r
pushresult(cshift);\r
end;\r
end;\r
end\r
else\r
ok:= false;\r
if not ok then\r
begin\r
pushresult(cerror);\r
errormsg(pass2, 129);\r
(* illegal type of operands *)\r
end;\r
put_byte(ord(cshift));\r
end; (* with *)\r
end; (* cshift *)\r
\r
\r
cstrucelem:\r
begin\r
(**** ***) if test_stack then write_p2stack;\r
\r
st2_type:=cendassign; (* assume not stringassign or setassign *)\r
with p2stacktop^.former^ do\r
begin\r
if syntaxkind=sstrucrecval then\r
begin\r
if equal_addr(p2_listref, st_stopaddr) then\r
errormsg(pass2, 156)\r
(* too many fields in structured value *)\r
else\r
begin\r
st_retrieve(p2_listref, st2_cur_ptr);\r
p2_listref := st2_cur_ptr^.listref;   (* next element *)\r
\r
(* TOG, to remove skip ?\r
if st2_cur_ptr^.st_spix <> anonymousspix then *)\r
if p2stacktop^.syntaxkind <> snull then\r
begin\r
if not compatible(st2_cur_ptr^.typeref, p2stacktop^.p2_typeref) then\r
errormsg(pass2, 110);\r
(* variable and expression not compatible *)\r
if maybe_set_type or set_result then\r
begin\r
  set_result:=false;\r
  st2_type:=cendassignset;\r
end\r
else if maybe_string_type then st2_type:=cendassignstring;\r
end\r
else dump_cnull_and_check(st2_cur_ptr^.typeref);\r
\r
(* TOG, to remove skip ? \r
boo := true;\r
while (not equal_addr(p2_listref, st_stopaddr)) and boo do\r
begin\r
st_retrieve(p2_listref, st2_cur_ptr);\r
boo := st2_cur_ptr^.st_spix = anonymousspix;\r
if boo then\r
p2_listref := st2_cur_ptr^.listref;\r
end;\r
*)\r
end;\r
end\r
else\r
(* struc array value *)\r
begin\r
if p2stacktop^.syntaxkind=snull then\r
dump_cnull_and_check(nodeaddress) else\r
if not compatible(nodeaddress, p2stacktop^.p2_typeref) then\r
errormsg(pass2, 110);\r
(* variable and expression not compatible *)\r
if maybe_set_type or set_result then\r
begin\r
  set_result:=false;\r
  st2_type:=cendassignset;\r
end\r
else if maybe_string_type then st2_type:=cendassignstring;\r
end;\r
end;\r
pop_p2stack;\r
\r
put_byte(ord(cstrucelem));\r
put_byte(ord(st2_type));\r
end; (* cstrucelem *)\r
\r
\r
cendstruc: \r
with p2stacktop^ do\r
begin\r
if  syntaxkind=sstrucrecval then\r
if not equal_addr(p2_listref, st_stopaddr) then\r
errormsg(pass2, 161);\r
(* too few field values *)\r
syntaxkind:= sexpression;\r
put_byte(ord(cendstruc));\r
end; (* cendstruc *)\r
\r
\r
csubrangetype: \r
(* rule *)\r
(* SUBRANGETYPE(ST_ADDRESS)-----> *)\r
begin\r
read_push_dump_type(csubrangetype);\r
end;\r
\r
\r
cendsubrange: \r
(* reducing: *)\r
(* Defining type: *)\r
(* SUBRANGETYPE(ST_ADDRESS)--->expression--->expression-->ENDSUBRANGE *)\r
begin\r
if compatible(p2stacktop^.former^.p2_typeref, p2stacktop^.p2_typeref) then\r
begin\r
st_retrievetype(p2stacktop^.p2_typeref, st2_cur_ptr);\r
with st2_cur_ptr^ do\r
if not ordinaltype(st_kind) then\r
begin\r
st2_cur_address:= erroraddress;\r
errormsg(pass2, 120);\r
(* basetype in subrange is not ordinal type *)\r
end\r
else\r
if st_kind=csubrange then\r
st2_cur_address:= typeref (* the base type *)\r
else\r
st2_cur_address:= p2stacktop^.p2_typeref;\r
end\r
else\r
begin\r
st2_cur_address:= erroraddress;\r
errormsg(pass2, 121);\r
(* high and low bound types are not the same type *)\r
end;\r
\r
pop_p2stack; (* high bound *)\r
pop_p2stack; (* low bound *)\r
\r
with p2stacktop^ do\r
begin\r
st_gettype(nodeaddress, st2_cur_ptr);\r
st2_cur_ptr^.typeref:= st2_cur_address;\r
end;\r
\r
put_byte(ord(cendsubrange));\r
end; (* cendsubrange *)\r
\r
cforward:\r
(* rule: FORWARD --->  *  concerning forward types *)\r
begin\r
st_get(p2stacktop^.nodeaddress, st2_cur_ptr);\r
with st2_cur_ptr^ do\r
begin\r
if st_specs = st_forward then\r
errormsg(pass2, 181)\r
(* forward announcement not followed by actual declaration *)\r
else\r
begin\r
st_specs := st_forward; (* to be used in 'cendtypedecl' and pass3 *)\r
spec_struct := [pointertype];  (* only pointertypes may be forward-decl. *)\r
end;\r
\r
st_kind := ctype;\r
end; (* with *)\r
pop_p2stack;\r
\r
put_byte(ord(cendformal));\r
put_byte(ord(cendtypedecl));\r
\r
family_type_params := false;\r
\r
end; (* cforward  - for types *)\r
\r
cforwardtype:\r
(* rule: FORWARDTYPE(ST_ADDRESS) ---> *)\r
(** Now actual declaration - earlier preceeded by **)\r
(** a forward announcement     **)\r
(** ajust "st2_start_search" and clear uctual name (spix) **)\r
begin\r
getaddress(st2_start_search); \r
st_get(st2_start_search, st2_cur_ptr);\r
st2_cur_ptr^.st_spix := anonymousspix;\r
end;\r
\r
\r
ctypedecl: \r
(* rule: TYPEDECL(ST_ADDRESS) ---> *)\r
begin\r
read_push_dump(ctypedecl,stypedecl);\r
st2_start_search:= p2stacktop^.nodeaddress;\r
st_get(st2_start_search, st2_cur_ptr);\r
st2_cur_ptr^.st_kind:= ctypedecl; (* avoid recursive use of type *)\r
family_type_params:= true;\r
in_type_decl:=true; (* true only in left side of type declaration *)\r
                    (* set to false by cendformal                 *)\r
\r
token := getcode; (* lookahead *)\r
if token <> cforwardtype then\r
st_insert_headsymbol(p2stacktop^.nodeaddress);\r
(* else *)\r
(* actual declaration of forward declared type *)\r
(* st_insert_symbols is NOT to to be called at this point *)\r
if compile_info then\r
begin\r
  if token <> cforwardtype then \r
  begin\r
    st_retrieve(p2stacktop^.nodeaddress,st2_cur_ptr);\r
    if st2_cur_ptr^.type_mode=fam then\r
      dump_info(p2stacktop^.nodeaddress);\r
  end;\r
end;\r
if cross then\r
begin\r
  if token <> cforwardtype then \r
    st_cross_decl(p2stacktop^.nodeaddress,ctypedecl,true)\r
  else st_cross_line(p2stacktop^.nodeaddress,cforward);\r
end;\r
\r
\r
goto 9876;  (* i.e. skip reading next token - which is  already done ! *)\r
\r
end;\r
\r
\r
cendtypedecl:\r
(* reducing: *)\r
(* type declaration: *)\r
(* TYPEDECL(ST_ADDRESS)-->formal parameters-->defining type-->ENDTYPEDECL \r
 --> ENDLEVEL *)\r
begin\r
bind_of_family_allowed:= after_context;\r
(* if family declaration then leaving it *)\r
with p2stacktop^ do\r
begin\r
st2_cur_address:= nodeaddress;\r
(* TOG allias types allowed   hha 900830*)\r
if misc_field=2 then errormsg(pass2,194);\r
(* bound type name not allowed as defining type specificatioon *)\r
end;\r
if p2stacktop^.syntaxkind<>slevel then (* not after Program decl TOG *)\r
  pop_p2stack; (* defining type *)\r
if getcode<>cendlevel then\r
p2_fatal_error(4);\r
(* inconsistent pass1 code *)\r
end_level_action; (* exit parameter level *)\r
st_get(p2stacktop^.nodeaddress, st2_cur_ptr);\r
with st2_cur_ptr^ do\r
begin\r
st_kind:= ctype; (* change back from typedecl to type *)\r
(* TOG 13 may 85 *)\r
typeref:= st2_cur_address;\r
if type_mode=bound_fam then type_mode:=named_bound_fam;\r
\r
if st_specs = st_forward then\r
begin\r
st_retrieve(st2_cur_address, st2_cur_ptr);\r
if st2_cur_ptr^.st_kind <> cpointertype then\r
errormsg(pass2,180);\r
(* forward declared type has to be of pointertype *)\r
end (* forward *)\r
else\r
spec_struct := spec_struct + p2stacktop^.p2_specstruc;\r
\r
routine_specstruc := routine_specstruc + p2stacktop^.p2_specstruc;\r
\r
end; (* with *)\r
pop_p2stack; (* typedecl *)\r
put_byte(ord(cendtypedecl));\r
family_type_params:= false;\r
\r
(* special action concerning scalartypes *)\r
st_retrieve(st2_cur_address, st2_cur_ptr);  (** ??? kan dette kald undgaas **)\r
if st2_cur_ptr^.st_kind = cscalar then\r
st_insert_symbols(st2_cur_ptr^.listref);\r
\r
end; (* cendtypedecl *)\r
\r
ctypeid:\r
(* TYPEID(SPIX) -----> *)\r
(* read spix and find address of type node *)\r
begin\r
help_boolean:=false;\r
nextinp:=get_2_byte;\r
elementnumber:= elementnumber+1;\r
(* search for standard removed *)\r
(*\r
if stdspix_to_address(nextinp,st2_cur_address) then\r
st_retrieve(st2_cur_address, st2_cur_ptr)\r
else\r
begin\r
*)\r
st2_cur_address:= st2_start_search;\r
help_boolean:=st_search(nextinp,st2_cur_address,with_address,st2_cur_ptr);\r
if not help_boolean then\r
begin\r
elementspix:= nextinp;\r
errormsg(pass2, 105);\r
(* undeclared type *)\r
end\r
else\r
begin\r
cross_addr:=st2_cur_address;\r
if st2_cur_ptr^.st_kind<>ctype then\r
begin\r
st2_cur_address:= st_nilladdr;\r
elementspix:= nextinp;\r
if st2_cur_ptr^.st_kind=ctypedecl then\r
errormsg(pass2, 173)\r
(* recursive declaration not allowed *)\r
else\r
errormsg(pass2, 133);\r
(* unknown type *)\r
end;\r
end;\r
(* end; *)\r
push_p2stack;\r
with p2stacktop^ do\r
begin\r
syntaxkind:= stype;\r
misc_field:=2;\r
nodeaddress:= st2_cur_address;\r
\r
if st2_cur_ptr^.st_kind = ctype then\r
begin\r
p2_specstruc := st2_cur_ptr^.spec_struct;\r
\r
with st2_cur_ptr^ do\r
if type_mode = fam  then\r
if (former^.syntaxkind = sformallist) then\r
(* binding familytype in formal param type *)\r
begin\r
(** former^.nodeaddress holds first parameter of list - if any list **)\r
st_retrieve(former^.nodeaddress, st2_hlp_ptr);\r
if equal_addr(st2_hlp_ptr^.listref, st_stopaddr) then\r
begin\r
copy_type(st2_cur_address, nodeaddress);\r
st_get(nodeaddress, st2_cur_ptr);\r
st2_cur_ptr^.type_mode := open_fam;\r
end\r
else\r
errormsg(pass2, 192);\r
(** when familytype: list of formal parameters not allowed  **)\r
\r
(** dump pass2-code **)\r
put_byte(ord(ctypeid));\r
putaddress(nodeaddress);\r
end\r
else\r
errormsg(pass2, 190);\r
(** defining type has to be a bound type **)\r
\r
end; (* if kind = ctype *)\r
if help_boolean and cross then st_cross_line(cross_addr,cnocode);\r
end;\r
if getcode<>cendtype then\r
p2_fatal_error(4);\r
(* inconsistent pass1 code *)\r
put_byte(ord(cendtype));\r
\r
(***** TEST *****)\r
if test_stack then\r
begin\r
writeln(testoutput, '**** START typeid test ****');\r
write_stacktop(1);\r
write_p2stack;\r
writeln(testoutput, '**** END typeid test ****');\r
end;\r
\r
end; (* ctypeid *)\r
\r
\r
ctypeselect:\r
begin\r
(*** ****) if test_stack then\r
write_p2stack;\r
\r
nextinp:= get_2_byte;\r
help_boolean:=false;\r
with p2stacktop^ do\r
begin\r
if (syntaxkind<>svar) and (syntaxkind<>sconst) then begin\r
st_retrieve(nodeaddress, st2_cur_ptr);\r
elementspix:= st2_cur_ptr^.st_spix;\r
errormsg(pass2, 197);\r
(* only constant or variable allowed *)\r
end;\r
st_retrieve(p2_typeref, st2_cur_ptr);\r
\r
if (st2_cur_ptr^.type_mode = bound_fam) or\r
   (st2_cur_ptr^.type_mode = named_bound_fam) or \r
   (st2_cur_ptr^.type_mode = open_fam) then\r
begin\r
st2_cur_address := st2_cur_ptr^.listref;\r
help_boolean:=st_searchlist(nextinp, st2_cur_address, st2_cur_ptr);\r
if not help_boolean then\r
begin\r
elementspix:= nextinp;\r
errormsg(pass2, 164);\r
(* unknown type parameter name *)\r
end else cross_addr:=st2_cur_address; \r
\r
end\r
else\r
begin\r
errormsg(pass2, 187);\r
(** type of variable before typeselect (!) must be member of a familytype *)\r
st2_cur_address := p2_typeref;\r
end;\r
\r
put_byte(ord(ctypeselect));\r
putaddress(st2_cur_address);\r
syntaxkind:= svar;\r
nodeaddress:= st2_cur_address;\r
p2_typeref:= st2_cur_ptr^.typeref;\r
end;\r
if help_boolean and cross then st_cross_line(cross_addr,cnocode);\r
\r
end; (* ctypeselect *)\r
\r
\r
cuntil: (* reduce until: \r
--> UNTIL --> *)\r
begin\r
repetitive_counter:= repetitive_counter-1;\r
put_byte(ord(cuntil));\r
before_assign:= false;\r
end; (* cuntil *)\r
\r
\r
(* cup: see cdown above *)\r
\r
\r
cuparrow:\r
with p2stacktop^ do\r
begin\r
(* uparrow may follow functioncall *)\r
(* same test at cendvariable / TOG *)\r
if (syntaxkind=svar) or (syntaxkind=sconst) then else\r
if (syntaxkind=sfunccall) or (syntaxkind = sopenfunccall) then \r
begin\r
if not equal_addr(p2_listref, st_stopaddr) then\r
errormsg(pass2, 112);\r
(* too few actual parameters *)\r
put_byte(ord(cendfunccall));\r
putaddress(nodeaddress);\r
end\r
else if syntaxkind=stypeid then\r
begin\r
st_retrieve(nodeaddress, st2_cur_ptr);\r
elementspix:= st2_cur_ptr^.st_spix;\r
errormsg(pass2, 195);\r
(* illegal use of type *)\r
end else\r
begin\r
st_retrieve(nodeaddress, st2_cur_ptr);\r
elementspix:= st2_cur_ptr^.st_spix;\r
errormsg(pass2, 198);\r
(* not allowed in expression *)\r
end;\r
st_retrievetype(p2_typeref, st2_cur_ptr);\r
if st2_cur_ptr^.st_kind<>cpointertype then\r
errormsg(pass2, 149)\r
(* variable not of pointer type *)\r
else begin\r
syntaxkind:=svar;\r
p2_typeref:= st2_cur_ptr^.typeref;\r
put_byte(ord(cuparrow));\r
if (programtype in p2_specstruc) then\r
begin\r
st2_cur_address:= p2_typeref;\r
st_retrieve(st2_cur_address, st2_cur_ptr);\r
if st2_cur_ptr^.st_kind=ctype then\r
begin \r
st2_cur_address:= st2_cur_ptr^.typeref; \r
st_retrieve(st2_cur_address,st2_cur_ptr); \r
end;\r
if st2_cur_ptr^.st_kind=cprogram then\r
begin\r
if create_call then\r
begin\r
syntaxkind:= sprogcall;\r
putaddress(p2_typeref);\r
put_byte(ord(cprogramcall));\r
(* TOG  last object !?! putaddress(st2_cur_address); *)\r
putaddress(nodeaddress);\r
p2_listref:= st2_cur_ptr^.listref;\r
create_call:= false;\r
end else begin\r
syntaxkind:= svarprog;\r
putaddress(st2_cur_ptr^.typeref);\r
end;\r
p2_typeref:= st2_cur_ptr^.typeref;\r
nodeaddress:= st2_cur_address;\r
end else putaddress(p2_typeref);\r
end else putaddress(p2_typeref);\r
end;\r
end; (* with p2stacktop; cuparrow *)\r
\r
\r
cusub: \r
(* topmost element contains operand *)\r
with p2stacktop^ do\r
begin\r
st2_type:= code_of_address(p2_typeref);\r
if (st2_type<>cinteger) and (st2_type<>cword) and (st2_type<>cbyte) then\r
begin\r
st_getbasetype(p2_typeref, st2_cur_ptr);\r
if st2_cur_ptr^.st_kind<>cinteger then\r
begin\r
boo:= stdcode_to_address(cerror, p2_typeref);\r
errormsg(pass2, 126);\r
(* operand of usub was not of apropriate type *)\r
end\r
else (* change type to integer *)\r
boo:= stdcode_to_address(cinteger, p2_typeref);\r
end;\r
if syntaxkind<>sconst then\r
syntaxkind:= sexpression;\r
put_byte(ord(cusub));\r
end;\r
\r
\r
cvardecl: \r
(* rule *)\r
(* VARDECL(ST_ADDRESS) ---> *)\r
(* read address and stack element *)\r
(* dump p2code *)\r
begin\r
if not after_context then errormsg(pass2, 163);\r
read_push_dump(cvardecl,svar);\r
if cross then st_cross_decl(p2stacktop^.nodeaddress,token,false);\r
st_insert_symbols(p2stacktop^.nodeaddress);\r
st2_start_search:= p2stacktop^.nodeaddress;\r
st_get(st2_start_search, st2_cur_ptr);\r
st2_cur_ptr^.st_kind:= cvardecl; (* avoid recursive use of var *)\r
end;\r
\r
\r
cendshared,\r
cendvar: \r
(* rule: *)\r
(* shared/variable declaration: *)\r
(* SHAREDDECL/VARDECL(st_address) --> defining type --> ENDSHARED/ENDVAR *)\r
(* typeinf on top of stack. variableinf on top^.former *)\r
(* bind stnode of typeinf to stnode of variable *)\r
(* dump p2code *)\r
begin\r
with p2stacktop^ do\r
begin\r
st_get(former^.nodeaddress, st2_cur_ptr);\r
if token=cendshared then\r
st2_cur_ptr^.st_kind:= cshared (* change back from shareddecl to shared *)\r
else\r
st2_cur_ptr^.st_kind:= cvar; (* change back from vardecl to var *)\r
st_insert_typeref(former^.nodeaddress, nodeaddress);\r
st2_start_search := former^.nodeaddress;\r
end; (* with top *)\r
\r
st_retrieve(p2stacktop^.nodeaddress, st2_cur_ptr);\r
routine_specstruc := routine_specstruc + st2_cur_ptr^.spec_struct;\r
\r
if token=cendshared then\r
begin\r
with st2_cur_ptr^ do\r
if spec_struct*ill_shared_types<>[] then\r
errormsg(pass2, 144);\r
(* process or chain not allowed in SHARED declaration *)\r
end; (* shared *)\r
if (cur_block_level<>program_level) and\r
   (st2_cur_ptr^.spec_struct*ill_routine_types<>[]) then\r
begin\r
  errormsg(pass2,196);\r
  (* shielded type, except referencei, not allowed in routine *)\r
end;\r
pop_p2stack; (* typeinf *)\r
pop_p2stack; (* sharedinf/varinf *)\r
put_byte(ord(token));\r
end; (* cendshared/cendvar *)\r
\r
\r
cwhileexpr: \r
(* reduce whileexpr\r
--> expression --> WHILEEXPR -->\r
test: type of expression must be boolean *)\r
begin\r
st2_type:= code_of_address(p2stacktop^.p2_typeref);\r
if st2_type<>cboolean then\r
begin\r
boo:= stdcode_to_address(cerror, p2stacktop^.p2_typeref);\r
errormsg(pass2, 119);\r
(* type of expression must be boolean *)\r
end;\r
pop_p2stack; (* expression *)\r
put_byte(ord(cwhileexpr));\r
before_assign:= true;\r
end; (* whileexpr *)\r
\r
\r
cwhilestat: (* reduce whilestat: \r
--> WHILESTAT --> *)\r
begin\r
put_byte(ord(cwhilestat));\r
repetitive_counter:= repetitive_counter+1;\r
before_assign:= false;\r
end; (* whilestat *)\r
\r
\r
cwithstat:\r
begin\r
put_byte(ord(cwithstat));\r
push_p2stack;\r
p2stacktop^.syntaxkind:= swith;\r
before_assign:= false;\r
end; (* cwithstat *)\r
\r
\r
cwithvar:\r
begin\r
st2_cur_address:= p2stacktop^.p2_typeref;\r
if (p2stacktop^.syntaxkind<>svar) and (p2stacktop^.syntaxkind<>sconst) then\r
begin\r
st_retrieve(p2stacktop^.nodeaddress, st2_cur_ptr);\r
elementspix:= st2_cur_ptr^.st_spix;\r
errormsg(pass2, 197);\r
(* only constart or variable allowed *)\r
end;\r
help_boolean:=p2stacktop^.syntaxkind=sconst;\r
pop_p2stack; (* var or const *)\r
with p2stacktop^.former^ do  (* skip 'slevel' *)\r
begin\r
getaddress(nodeaddress);\r
st2_start_search:= nodeaddress;\r
st_get(nodeaddress, st2_cur_ptr);\r
st2_cur_ptr^.typeref:= st2_cur_address;   (** unnecessary ?? !! **)\r
st2_cur_ptr^.listref:= st2_cur_address;     (** remember the original type --\r
----   in case of retyping the original type has still to be visible     **)\r
if help_boolean then st2_cur_ptr^.st_kind:=cwithstat; (* with on constant *)\r
if st2_cur_ptr^.st_spix <> anonymousspix then\r
begin\r
elementnumber := elementnumber + 1;\r
if cross then st_cross_decl(nodeaddress,token,true);\r
end;\r
local_declare_state:= true;\r
put_byte(ord(cwithvar));\r
putaddress(nodeaddress);\r
end; (* with p2stacktop^ .. *)\r
end; (* cwithvar *)\r
\r
cendlocaldecl:\r
begin\r
if not in_lock_state then\r
begin\r
st_insert_withsymbols(p2stacktop^.former^.former^.nodeaddress);\r
end;\r
st_get(p2stacktop^.former^.former^.nodeaddress, st2_cur_ptr);\r
st2_cur_address:= st2_cur_ptr^.typeref;\r
st2_cur_ptr^.typeref:= p2stacktop^.nodeaddress;\r
put_byte(ord(cendlocaldecl));\r
st_retrieve(p2stacktop^.nodeaddress, st2_cur_ptr);\r
if st2_cur_ptr^.spec_struct*protected_types<>[] then\r
errormsg(pass2, 155)\r
(* retyping of/with protected type not allowed *)\r
else if not in_lock_state then\r
begin\r
st_retrieve(st2_cur_address, st2_cur_ptr);\r
if st2_cur_ptr^.spec_struct*protected_types<>[] then\r
errormsg(pass2, 155)\r
(* retyping of/with protected type not allowed *)\r
end else st2_cur_address:=st2_cur_ptr^.typeref;\r
put_byte(ord(cchecksize));\r
putaddress(st2_cur_address);\r
pop_p2stack;\r
local_declare_state:= false;\r
in_lock_state:=false;\r
end; (* cendlocaldecl *)\r
\r
\r
cendwith:\r
(* reducing   ENDWITH --> ENDLEVEL --> *)\r
begin\r
if getcode<>cendlevel then\r
p2_fatal_error(4);\r
(* inconsistent pass1 code *)\r
end_level_action; (* exit parameter level *)\r
(* #BEGINTEST \r
if p2stacktop^.syntaxkind<>swith then\r
p2_fatal_error(1);\r
(* inconsistency in pass2 stack *)\r
(* ENDTEST# *)\r
pop_p2stack;\r
put_byte(ord(cendwith));\r
end; (* cendwith *)\r
\r
csegment:\r
begin\r
  put_byte(ord(csegment));\r
  segment_nr:=segment_nr+1;\r
end\r
\r
else\r
begin\r
writeln('++++++++++++++++++++++++++++++++++++++++++++++++++');\r
writeln('not implemented:  ', ' ': 30, ord(token));\r
writeln('++++++++++++++++++++++++++++++++++++++++++++++++++');\r
p2_fatal_error(0);\r
end; (* otherwise *)\r
\r
end; (* case *)\r
\r
token:= getcode; (* read next code from infile *)\r
\r
9876: (* after read next token, used after repair of errors *)\r
\r
until token=ceom;\r
\r
(* reverse lists in segment_info *)\r
for count:=2 to last_segment do\r
begin\r
symbol_chain_ptr:=segment_info[count].list;\r
if symbol_chain_ptr<>nil then\r
begin\r
while symbol_chain_ptr<>nil do\r
begin\r
segment_info[count].list:=symbol_chain_ptr^.next;\r
symbol_chain_ptr^.next:=segment_info[1].list;\r
segment_info[1].list:=symbol_chain_ptr;\r
symbol_chain_ptr:=segment_info[count].list;\r
end;\r
segment_info[count].list:=segment_info[1].list;\r
segment_info[1].list:=nil;\r
end;\r
end;\r
\r
(* ceom: *)\r
\r
\r
\r
if p2stacktop^.syntaxkind <> scompunit then\r
p2_fatal_error(1);\r
(* inconsistency in p2stack *)\r
\r
while p2stacktop<>p2stackbase do\r
pop_p2stack;\r
dispose(p2stackbase);\r
\r
\r
if repetitive_counter<>0 then\r
p2_fatal_error(6);\r
(* pass2 inconsistency *)\r
\r
put_byte(ord(ceom));\r
(* end ceom *)\r
end;\r
«eof»
DataMuseum.dk

DANOSI

⟦f053785ab⟧ TextFile

Derivation

TextFile
