⟦9b238bcde⟧

TextFile

{$O+,F+}\r
unit rtp86p2;\r
interface\r
uses pscplm,files,mpaunit,sthunit,sthcom,sthp2,rtp86mpa,p2code;\r
procedure rtp86pass2;\r
implementation\r
(*************************************************************************\r
*                                                                        * \r
*                                                                        * \r
*                                                                        * \r
*    Module: pass 2 of the RTP compiler for the RC 3900 computer         *\r
*    =======                                                             *\r
*                                                                        * \r
*    Version: 9  (according to the compiler project plan)                *\r
*    ========                                                            *\r
*                                                                        * \r
*                                                                        * \r
*                                                                        *\r
*    Copyright (C) by A/S Regnecentralen af 1979                         *\r
*                                                                        *\r
*                                                                        *\r
**************************************************************************)\r
\r
(*\r
\r
Testpatterns: the global integer type variable testpass2, as assigned\r
.             according to the call of the compiler, has the following\r
.             effect (0 means off, 1 means on):\r
.             bit0: test output concerning the use of the internal\r
.                   stack (p2stack)\r
.             bit1: dump internal stack contents in case of fatal error\r
.             bit2: dump symbol table contents, change from off to on means\r
.                   remember last inserted element as the start of a dump,\r
.                   change from on to off means dump symbol table elements\r
.                   processed since test bit was turned on (the bit is\r
.                   implicitly turned off at program end)\r
.             bit3: local tests\r
.             bit4: pass1code\r
.             bit8: testoutput concerning use of symbol table\r
.             bit9: no testoutput concerning use of symbol table\r
.             bit10:the option $test(vmm = x) assign x to testvmm\r
.             bit11:the option $test(vmm = x) is ignored\r
.             bit12:testoutput concerning use of st_search\r
.             bit13:no testoutput concerning use of st_search\r
\r
*)\r
(*\r
\r
$include(pscplm.ext)\r
$include(files.ext)\r
$include(rtp86mpa.ext)\r
$include(sthcommo.ext)\r
$include(sthp2.ext)\r
*)\r
\r
\r
(*****)\r
(*** MAIN PROCEDURE ***)\r
\r
\r
(* !!! TURBO !!! *)\r
var\r
(* #begintest \r
procname: string[12];\r
(* endtest# *)\r
in_program_head,\r
in_type_decl, bind_of_family_allowed, (* bind of family only allowed after *)\r
                                 (* after context or in family declaration *)\r
                                 (* and not in program head *)\r
found, ok, boo: boolean; (* help booleans *)\r
current: ptr_p2stack; (* used for p2 stack traversal *)\r
cur_kind: syntaxtype; (* kind of current during traversal *)\r
count, result_spix, length, nextinp: word;\r
st2_type: codes;\r
with_address,linkref: st_address;\r
symbol_chain_ptr:ptr_symbol_chain;\r
\r
\r
function do_actualparam: boolean;\r
var callbyaddress : boolean;\r
(* dump p2code *)\r
begin\r
case p2stacktop^.former^.syntaxkind of\r
sindex: with p2stacktop^.former^ do\r
begin\r
st_getbasetype(p2_typeref, st2_cur_ptr);\r
with st2_cur_ptr^ do\r
if st_kind<>carraytype then\r
begin\r
if not equal_addr(former^.nodeaddress, st_undeclared_addr) then\r
errormsg(pass2, 134)\r
(* not array type *)\r
end\r
else\r
begin\r
put_byte(ord(cindex));\r
putaddress(p2_typeref);\r
p2_typeref:= typeref; (* element type *)\r
if not compatible(itype, p2stacktop^.p2_typeref) then\r
errormsg(pass2, 150);\r
(* index and expression types not compatible *)\r
end;\r
pop_p2stack; (* index expression *)\r
end; (* with p2stacktop^.former^ *)\r
sactualparam: begin\r
\r
within_opencall := opencount > 0;\r
\r
if (p2stacktop^.former^.former^.syntaxkind <> sopenfunccall) and\r
   (p2stacktop^.former^.former^.syntaxkind <> sopenfunccalle) and\r
   (p2stacktop^.former^.former^.syntaxkind <> sopenproccall) then\r
(* access formal parameter *)\r
if equal_addr(p2stacktop^.former^.p2_listref,st_stopaddr) then\r
begin\r
errormsg(pass2, 136);\r
(* too many actual parameters *)\r
pop_p2stack;\r
end\r
else\r
begin\r
st_retrieve(p2stacktop^.former^.p2_listref, st2_cur_ptr);\r
with st2_cur_ptr^ do\r
begin\r
nextinp:= st_spix; (* saved for possible error messages *)\r
p2stacktop^.former^.p2_listref:= listref; (* next parameter *)\r
st2_cur_address:= typeref; (* save type address *)\r
\r
callbyaddress := st_kind <> cvalueparam;\r
if st_kind=cvalueparam then\r
begin\r
put_byte(ord(cvalueparam));\r
putaddress(typeref); (* formal type *)\r
if not compatible(typeref, p2stacktop^.p2_typeref) then\r
begin\r
elementspix:= nextinp;\r
if p2stacktop^.syntaxkind=snull then\r
errormsg(pass2, 167)\r
(* '?' only allowed as address transfer parameter *)\r
else\r
errormsg(pass2, 135);\r
(* formal and actual types of valueparameter are not compatible *)\r
end;\r
\r
end\r
else\r
(* address transfer parameter *)\r
begin\r
put_byte(ord(st_kind)); (* varparam/sharedparam/inspectparam *)\r
\r
with p2stacktop^ do\r
if (syntaxkind<>svar) and (syntaxkind<>svarprog) and (syntaxkind<>snull) and\r
((st_kind<>cinspectparam) or (syntaxkind<>sconst)) then\r
begin\r
elementspix:= nextinp;\r
errormsg(pass2, 170);\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
(* see if formal is of a super-type *)\r
(* ptype *)\r
if equal_addr(st2_cur_address, st_ptype_addr) then\r
begin\r
if not (st_kind = cpointertype) then\r
errormsg(pass2,184);\r
(* actualparameter has to be a pointertype  *)\r
end\r
else\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
errormsg(pass2, 182);\r
(* actual parameter has to be reference or chain *)\r
end else\r
(*if not (equal_addr(st2_cur_address, st_program_type_addr) and\r
       (st_kind = cprogram)) then\r
*)\r
begin\r
elementspix:= nextinp;\r
errormsg(pass2, 137);\r
(* types of formal and actual parameters must be identical*)\r
end;\r
end;\r
end;\r
end;\r
(** 'p2stacktop^.p2_typeref' points out type of actual parameter **)\r
(** 'st2_cur_address' points out type of formal parameter **)\r
(* in case of formal parameter is specified as an open-family binding *)\r
(* pass2-code is to be dumped:                                    *)\r
(*      -----> FAMILYTYPE(actual-SYMBOL) ------------>            *)\r
st_retrieve(st2_cur_address, st2_hlp_ptr);\r
if st2_hlp_ptr^.type_mode = open_fam then\r
begin\r
put_byte(ord(cfamilytype));\r
if p2stacktop^.syntaxkind=snull then\r
putaddress(st2_cur_address) (* no actual type, use formal *)\r
else\r
begin\r
(* if actuel type not family then array( ) of char *)\r
st_retrieve(p2stacktop^.p2_typeref,st2_hlp_ptr);\r
if (st2_hlp_ptr^.type_mode<>stat) and (st2_hlp_ptr^.type_mode<>dyn)\r
then putaddress(p2stacktop^.p2_typeref)\r
else putaddress(st2_hlp_ptr^.typeref);\r
end;\r
end\r
ELSE\r
  IF Maybe_fam_type OR (Maybe_string_type AND callbyaddress) then\r
    BEGIN\r
      put_byte(ord(cCheckparam));\r
      PutAddress(typeref);\r
      PutAddress(p2stacktop^.p2_typeref);\r
    END;\r
pop_p2stack;\r
end; (* with st2 cur ptr^ *)\r
end\r
else\r
push_opencall;\r
end; (* parameter list *)\r
\r
stypeid: begin (* after repaired start of structure *)\r
token:= cstrucelem;\r
(*goto 9876; (* after read next token *)\r
do_actualparam:= true; exit;\r
end (* element of strucured value *)\r
\r
\r
else\r
\r
if within_opencall then\r
push_opencall\r
else\r
p2_fatal_error(1);\r
(* inconsistency in pass2stack *)\r
end; (* case kind ... *)\r
\r
do_actualparam:= false;\r
Set_Result := false;\r
end; (* actualparam *)\r
\r
procedure do_beginstruc;\r
begin\r
with p2stacktop^ do\r
if syntaxkind=sinitobj then\r
begin\r
st2_cur_address:= p2_typeref;\r
(****\r
put_byte(ord(cid));\r
putaddress(p2_typeref);\r
*****)\r
push_p2stack;\r
end\r
else\r
if syntaxkind=stypeid then\r
begin\r
st2_cur_address:= p2_typeref;\r
if not equal_addr(p2_listref, st_stopaddr) then\r
errormsg(pass2, 112);\r
(* too few actual parameters *)\r
\r
(** check that:  -----------  *)\r
(* variable and typename are the same  *)\r
(* structure element and typename (if mentioned) are the same *)\r
(** 3-4 cases !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!*)\r
\r
if (former^.syntaxkind = sinitobj) then\r
if not sametype(p2_typeref, former^.p2_typeref) then\r
errormsg(pass2, 157);\r
(* wrong typename *)\r
\r
end (* syntaxkind = stypeid *)\r
else\r
if syntaxkind=sstrucarrval then\r
begin\r
(***\r
put_byte(ord(cid));\r
putaddress(nodeaddress); (* type information *)\r
\r
st2_cur_address:= nodeaddress;\r
push_p2stack;\r
end\r
else\r
if syntaxkind=sstrucrecval then\r
begin\r
(***\r
put_byte(ord(cid));\r
***)\r
st_retrieve(p2_listref, st2_cur_ptr); (* the field name *)\r
st2_cur_address:= st2_cur_ptr^.typeref; (* the field type *)\r
(***\r
putaddress(st2_cur_address);\r
***)\r
push_p2stack;\r
end\r
else\r
if (syntaxkind=sexpression) or (syntaxkind=svar) or (syntaxkind=sconst) then\r
if former^.syntaxkind=sstrucarrval then\r
begin (* part of repstruc construction *)\r
(***\r
put_byte(ord(cid));\r
***)\r
\r
st2_cur_address:= former^.nodeaddress;\r
\r
(***\r
putaddress(st2_cur_address); (* type name *)\r
\r
push_p2stack;\r
end\r
else\r
begin (* error recovery: act as if the name was a type name *)\r
if (former^.syntaxkind=svar) or (former^.syntaxkind=sconst) then\r
(* var := var (: ... *)\r
errormsg(pass2, 178)\r
(* object in front of '(:' must be a type name *)\r
else (* var := (: .... *)\r
begin\r
errormsg(pass2, 179);\r
(* type name in front of '(:' missing *)\r
push_p2stack;\r
end;\r
st2_cur_address:= p2_typeref;\r
end\r
else\r
p2_fatal_error(1);\r
(* inconsistency in pass2stack *)\r
st_retrievetype(st2_cur_address, st2_cur_ptr);\r
\r
with p2stacktop^, st2_cur_ptr^ do\r
begin\r
p2_typeref:= st2_cur_address;\r
if st_kind=crecordtype then\r
begin\r
syntaxkind:= sstrucrecval;\r
p2_listref:= listref; (* field list *)\r
end\r
else\r
if st_kind=carraytype then\r
begin\r
syntaxkind:= sstrucarrval;\r
nodeaddress:= typeref; (* element type *)\r
end\r
else\r
begin\r
errormsg(pass2, 158);\r
(* not structered type *)\r
syntaxkind:= sstrucrecval; (* error recovery: assume record init *)\r
p2_listref:= st_stopaddr;\r
end;\r
end; (* with top^ *)\r
st_retrieve(st2_cur_address, st2_cur_ptr); (* type name *)\r
\r
(* REMOVED becource pass3 must have ctype node \r
while (st2_cur_ptr^.st_kind=ctype) do\r
begin\r
st2_cur_address:= st2_cur_ptr^.typeref;\r
st_retrieve(st2_cur_address, st2_cur_ptr); (* type name ? \r
end;\r
*)\r
\r
put_byte(ord(cbeginstruc));\r
putaddress(st2_cur_address);\r
\r
end; (* beginstruc *)\r
\r
procedure do_endblock;\r
begin\r
if getcode<>cendlevel then\r
p2_fatal_error(4);\r
(* inconsistent pass1 code *)\r
end_level_action; (* exit parameter level *)\r
if getcode<>cendlevel then\r
p2_fatal_error(4);\r
(* inconsistent pass1 code *)\r
end_level_action; (* exit parameter level *)\r
\r
case p2stacktop^.syntaxkind of\r
\r
sprogdecl:\r
begin \r
if p2stacktop^.former^.former^.syntaxkind=scompunit then\r
(* leaving a program declaration on program level *)\r
begin\r
open_counter:= first_program_open;\r
cur_block_level:= context_level;\r
end;\r
st_end_program;\r
end;\r
\r
sprocdecl,sfuncdecl:\r
begin\r
if p2stacktop^.former^.former^.syntaxkind=scompunit then\r
(* leaving a routine at program level i. e. seperately\r
  compiled routine *)\r
begin\r
open_counter:= first_program_open;\r
cur_block_level:= context_level;\r
end\r
else\r
begin\r
(* routinedecl at inner level *)\r
cur_block_level:= cur_block_level -1;\r
if p2stacktop^.syntaxkind=sfuncdecl then\r
begin\r
if p2stacktop^.misc_field=0 then\r
warning(pass2, 132);\r
(* no function result *)\r
end;\r
end;\r
\r
(*** updating specstruc inf in routine-node ***)\r
st_get(p2stacktop^.nodeaddress, st2_cur_ptr);\r
st2_cur_ptr^.spec_struct := routine_specstruc;\r
routine_specstruc := [];\r
\r
if cur_block_level > context_level then\r
(* get specstruc-inf from sourrounding routine (not program) - if any *)\r
(* for possibly adding further information *)\r
begin\r
st_retrieve(p2stacktop^.former^.former^.former^.nodeaddress, st2_cur_ptr);\r
st2_type := st2_cur_ptr^.st_kind;\r
if (st2_type = cprocedure) or\r
   (st2_type = cfunction) then\r
routine_specstruc := st2_cur_ptr^.spec_struct\r
else\r
if test_local then\r
begin\r
warning(pass2, 223);\r
(* testwarning - endblock *)\r
writeln(testoutput, 'st_kind: ', ord(st2_type));\r
end;\r
end;\r
(*** ***)\r
\r
end\r
else\r
begin\r
p2_fatal_error(1);\r
(* inconsistency in pass2stack *)\r
end;\r
end;\r
pop_p2stack;\r
put_byte(ord(cendblock));\r
declare_state:= true;\r
before_assign:=false;\r
end; (* endblock *)\r
\r
procedure do_familytype;\r
begin\r
push_p2stack;\r
with p2stacktop^ do\r
begin\r
syntaxkind:= stype;\r
nextinp:= get_2_byte;  (* spix of the type *)\r
elementnumber:= elementnumber+1;\r
st2_cur_address:= st_nilladdr;\r
if not st_search(nextinp, st2_cur_address, with_address, st2_cur_ptr) then\r
begin\r
elementspix:= nextinp;\r
if cross then st_cross_line(st2_cur_address,cnocode);\r
errormsg(pass2, 105);\r
(* undeclared type *)\r
boo := stdcode_to_address(cerror, p2_listref);\r
end\r
else\r
begin\r
if st2_cur_ptr^.st_kind<>ctype then\r
begin\r
if cross then st_cross_line(st2_cur_address,cnocode);\r
st2_cur_address:= st_nilladdr;\r
elementspix:= nextinp;\r
errormsg(pass2, 133);\r
(* unknown type *)\r
end\r
else   (* st_kind = ctype **)\r
begin\r
if st2_cur_ptr^.st_t_seg_nr<>segment_nr then\r
st2_cur_ptr^.st_t_local_near:=false;\r
with st2_cur_ptr^ do\r
(*if not odd(fam_used div comp_used_bit) then*)\r
fam_used:=fam_used OR comp_used_bit;\r
(** get "spec_struct" - inf. from underlying structure - into p2stack **)\r
p2_specstruc := st2_cur_ptr^.spec_struct;\r
\r
p2_listref:= st2_cur_ptr^.listref;\r
st2_hlp_address:=st2_cur_ptr^.typeref;\r
\r
if not equal_addr(st2_cur_ptr^.st_family_ref,st_nilladdr) then\r
begin\r
st_get(st2_cur_ptr^.st_family_ref,st2_cur_ptr);\r
with st2_cur_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
\r
if cross then st_cross_line(st2_cur_address,cnocode);\r
\r
if former^.former^.syntaxkind = stypedecl then\r
(** do not copy ctype-node **)\r
(* i.e. skip ctype-node and copy following nodes *)\r
begin\r
\r
st_get(former^.former^.nodeaddress, st2_hlp_ptr);\r
(* access node of type to be declared *)\r
\r
st2_hlp_ptr^.st_family_ref := st2_cur_address;\r
(* 'st2_cur_address' contains family-type-name *)\r
\r
if st2_hlp_ptr^.type_mode <> fam then\r
st2_hlp_ptr^.type_mode := bound_fam;\r
\r
copy_type(st2_hlp_address, nodeaddress);\r
(*\r
st2_hlp_ptr^.typeref := nodeaddress;\r
(** is done by 'cendtypedecl'  **)\r
end\r
else  (** do make a copy of ctype-node **)\r
begin\r
copy_type(st2_cur_address, nodeaddress);\r
\r
st_get(nodeaddress, st2_hlp_ptr);\r
st2_hlp_ptr^.type_mode := bound_fam;\r
end;\r
if (not bind_of_family_allowed) THEN\r
 BEGIN\r
   IF (Not Equal_Addr(st_String_type_Addr,St_Undeclared_addr)) AND\r
     (Not Equal_Addr(st2_hlp_ptr^.st_Family_ref,st_String_type_Addr)) then\r
  begin\r
    elementspix:= nextinp;\r
    errormsg(pass2, 193);\r
  end;\r
 END;\r
\r
end;\r
end;\r
\r
put_byte(ord(ctypeid));\r
putaddress(nodeaddress);\r
end; (* with *)\r
\r
(***** TEST *****)\r
if test_stack then\r
begin\r
writeln(testoutput, '**** START familytype test ****');\r
write_stacktop(1);\r
write_p2stack;\r
writeln(testoutput, '**** END familytype test ****');\r
end;\r
end; (* cfamilytype *)\r
\r
procedure do_id;\r
begin\r
nextinp:= get_2_byte;\r
elementnumber:= elementnumber+1;\r
boo := true;    (** used to tell whether or not address is to be dumped *)\r
(* at end of 'cid'. - This depends on situation when 'ctype' is handled *)\r
\r
if declare_state or local_declare_state then\r
st2_cur_address:= st2_start_search (* search from last inserted *)\r
else\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 else cross_addr:=st2_cur_address;\r
push_p2stack;\r
with  p2stacktop^ do\r
begin\r
case st2_cur_ptr^.st_kind of\r
cscalarelem,\r
cconstant:\r
begin\r
syntaxkind:= sconst;\r
put_byte(ord(cconst));\r
end;\r
cinspectparam:\r
begin\r
syntaxkind:= sconst;\r
put_byte(ord(cid));\r
end;\r
cfunction:\r
if before_assign then\r
begin\r
(* test inside proper function definition *)\r
found:= false;\r
current:= p2stacktop;\r
cur_kind:= current^.syntaxkind;\r
while not found and (cur_kind<>scompunit) do\r
begin\r
found:= (cur_kind=sfuncdecl) AND\r
        equal_addr(current^.nodeaddress, st2_cur_address);\r
if not found then\r
begin\r
current:= current^.former;\r
cur_kind:= current^.syntaxkind;\r
end; (* not found yet *)\r
end; (* while *)\r
if not found then\r
begin\r
elementspix:= nextinp;\r
  errormsg(pass2, 130);\r
(* illegal use of function variable *)\r
end\r
else\r
current^.misc_field:= 1; (* function result assigned *)\r
\r
p2stacktop^.syntaxkind:= svar(* TOG !!! func*) ;\r
put_byte(ord(cid));\r
end\r
else (* not before assign *)\r
with st2_cur_ptr^ do\r
begin\r
if st_specs = st_open then\r
begin\r
syntaxkind := sopenfunccall;\r
opencount := opencount + 1;\r
end\r
else\r
begin\r
syntaxkind:= sfunccall; (* call of function *)\r
st_get(st2_cur_address, st2_cur_ptr);\r
st2_cur_ptr^.st_curno := max_word;\r
with st2_cur_ptr^ do\r
begin\r
  if st_seg_nr<>segment_nr then\r
  begin\r
  st_local_near:=false;\r
  if (st_seg_nr>segment_nr) and (st_logic_nr=0) then\r
  begin\r
    new(symbol_chain_ptr);\r
    symbol_chain_ptr^.symbol:=st2_cur_address;\r
    symbol_chain_ptr^.next:=segment_info[st_seg_nr].list;\r
    segment_info[st_seg_nr].list:=symbol_chain_ptr;\r
    st_logic_nr:=segment_info[st_seg_nr].no_of_symbol+1;\r
    segment_info[st_seg_nr].no_of_symbol:=st_logic_nr;\r
  end;\r
  end;\r
end;\r
end;\r
if declare_state then\r
if st_specs<>st_open then\r
begin\r
elementspix:= st_spix;\r
errormsg(pass2, 145);\r
(* only call of predefined functions allowed *)\r
end; (* error *)\r
put_byte(ord(cfunccall));\r
p2_listref:= listref;\r
if equal_addr(st2_cur_address, st_create_addr) then\r
create_call:= true;\r
if equal_addr(listref, st_stopaddr) then\r
begin\r
  if syntaxkind=sfunccall then syntaxkind:=sfunccalle else\r
  syntaxkind:=sopenfunccalle; (* TOG, maybe index *)\r
end;\r
end;\r
cprocedure:\r
begin\r
if st2_cur_ptr^.st_specs = st_open then\r
begin\r
opencount := opencount + 1;\r
syntaxkind := sopenproccall;\r
end\r
else\r
begin\r
syntaxkind:= sproccall;\r
st_get(st2_cur_address, st2_cur_ptr);\r
st2_cur_ptr^.st_curno := max_word;\r
with st2_cur_ptr^ do\r
begin\r
  if st_seg_nr<>segment_nr then\r
  begin\r
  st_local_near:=false;\r
  if (st_seg_nr>segment_nr) and (st_logic_nr=0) then\r
  begin\r
    new(symbol_chain_ptr);\r
    symbol_chain_ptr^.symbol:=st2_cur_address;\r
    symbol_chain_ptr^.next:=segment_info[st_seg_nr].list;\r
    segment_info[st_seg_nr].list:=symbol_chain_ptr;\r
    st_logic_nr:=segment_info[st_seg_nr].no_of_symbol+1;\r
    segment_info[st_seg_nr].no_of_symbol:=st_logic_nr;\r
  end;\r
  end;\r
end;\r
end;\r
\r
put_byte(ord(cproccall));\r
p2_listref:= st2_cur_ptr^.listref;\r
end;\r
cundeclared,\r
cvarparam,\r
cvalueparam,\r
clockvar,\r
cwithvar:\r
begin\r
syntaxkind:= svar;\r
put_byte(ord(cid));\r
end;\r
\r
cvar:\r
begin\r
syntaxkind:= svar;\r
put_byte(ord(cid));\r
p2_specstruc:= st2_cur_ptr^.spec_struct;\r
if ( programtype in p2_specstruc ) then\r
begin\r
  st2_hlp_address:=st2_cur_ptr^.typeref;\r
  st_retrieve(st2_hlp_address, st2_cur_ptr);\r
  if st2_cur_ptr^.st_kind=ctype then\r
  begin\r
    st2_hlp_address:=st2_cur_ptr^.typeref;\r
    st_retrieve(st2_hlp_address, st2_cur_ptr);\r
  end;\r
  if st2_cur_ptr^.st_kind=cprogram then\r
  begin\r
  (* program variable *)\r
    if create_call then\r
    begin\r
      syntaxkind:= sprogcall;\r
      putaddress(st2_cur_address);\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
    putaddress(st2_cur_address);\r
    boo:= false;\r
    st2_cur_address:=st2_hlp_address;\r
  end else st_retrieve(st2_cur_address, st2_cur_ptr);\r
end;\r
end;\r
\r
cwithstat:\r
begin\r
syntaxkind:=sconst;\r
put_byte(ord(cid));\r
end;\r
cforstat: begin\r
(* ??? TOG, forvariable er blot en konstant \r
syntaxkind:= sforvar;*)\r
syntaxkind:= sconst;\r
put_byte(ord(cid));\r
end;\r
\r
crecfield:\r
begin\r
st_retrieve(with_address,st2_cur_ptr);\r
if st2_cur_ptr^.st_kind=cwithstat then syntaxkind:= sconst else\r
syntaxkind:= svar;\r
st_retrieve(st2_cur_address,st2_cur_ptr);\r
put_byte(ord(cid)); (* simulate  withvar.field *)\r
putaddress(with_address);\r
put_byte(ord(cfield));\r
p2_specstruc:= st2_cur_ptr^.spec_struct;\r
if ( programtype in p2_specstruc ) then\r
begin\r
st2_hlp_address:=st2_cur_ptr^.typeref;\r
st_retrieve(st2_hlp_address, st2_cur_ptr);\r
if st2_cur_ptr^.st_kind=ctype then\r
begin\r
st2_hlp_address:= st2_cur_ptr^.typeref;\r
st_retrieve(st2_hlp_address, st2_cur_ptr);\r
end;\r
if st2_cur_ptr^.st_kind=cprogram then\r
begin\r
(* program variable *)\r
if create_call then\r
begin\r
syntaxkind:= sprogcall;\r
putaddress(st2_cur_address);\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
putaddress(st2_cur_address);\r
boo:= false;\r
st2_cur_address:= st2_hlp_address;\r
end else st_retrieve(st2_cur_address, st2_cur_ptr);\r
end;\r
end;\r
\r
ctype:\r
begin\r
syntaxkind:= stypeid;\r
if (st2_cur_ptr^.type_mode = fam) then\r
begin\r
if st2_cur_ptr^.st_t_seg_nr<>segment_nr then\r
begin\r
st_get(st2_cur_address, st2_cur_ptr);\r
st2_cur_ptr^.st_t_local_near:=false;\r
end;\r
copy_type(st2_cur_address, st2_cur_address);\r
st_get(st2_cur_address, st2_cur_ptr);\r
st2_cur_ptr^.type_mode := bound_fam;\r
(* TOG  850426 *)\r
put_byte(ord(ctypedecl));\r
putaddress(st2_cur_address);\r
put_byte(ord(ctypeid));\r
end\r
else\r
boo := false;\r
(** i.e. do not dump address at end of 'cid'  **)\r
p2_listref:= st2_cur_ptr^.listref;\r
end; (* ctype *)\r
cprogram: (* TOG, not used, to be removed !!!! *)\r
if create_call then\r
begin\r
syntaxkind:= sprogcall;\r
put_byte(ord(cprogramcall));\r
create_call:= false;\r
p2_listref:= st2_cur_ptr^.listref;\r
end\r
else\r
begin\r
syntaxkind:= svarprog;\r
put_byte(ord(cid));\r
end;\r
cshared, csharedparam: begin\r
syntaxkind:= svar;\r
put_byte(ord(cid));\r
(* check legal use of the shared object,\r
i.e. shared parameter or inside REGION statement *)\r
found:= false; \r
current:= former;\r
while not found do\r
with current^ do\r
case syntaxkind of\r
sprocdecl, sfuncdecl,\r
sprogdecl: begin\r
found:= true; (* stop *)\r
elementspix:= nextinp;\r
errormsg(pass2, 177);\r
(* use of SHARED object must be inside REGION statement *)\r
end;\r
sproccall, sfunccalle, sopenfunccalle, sfunccall, sopenfunccall, sopenproccall: \r
begin (* parameter passing, ok *)\r
found:= true;\r
end;\r
sregion: begin\r
found:= equal_addr(st2_cur_address, nodeaddress) or (* inside proper region *)\r
 equal_addr(st_nilladdr, nodeaddress); (* start of region statement *)\r
current:=former;\r
end\r
else current:= former;\r
end; (* case *)\r
end (* shared, sharedparam *)\r
\r
else \r
begin\r
with st2_cur_ptr^ do\r
if (st_kind=cconstdecl) or (st_kind=ctypedecl) or\r
(st_kind=cshareddecl) or (st_kind=cvardecl) then\r
begin\r
elementspix:= nextinp;\r
errormsg(pass2, 173)\r
(* recursive declaration not allowed *)\r
end\r
else\r
begin\r
elementspix:= nextinp;\r
errormsg(pass2, 141);\r
(* illegal kind of operand *)\r
end;\r
syntaxkind:= svar; (* try to avoid cascaded errors *)\r
put_byte(ord(cid));\r
st2_cur_address:= st_undeclared_addr;\r
end;\r
\r
end; (* case *)\r
if boo then  (* cf.: action at 'ctype' *)\r
putaddress(st2_cur_address);\r
nodeaddress:=st2_cur_address;\r
with st2_cur_ptr^ do\r
if st_kind=ctype then\r
p2_typeref:= st2_cur_address (* the type name *)\r
else\r
p2_typeref:= typeref;\r
end;\r
if help_boolean and cross then st_cross_line(cross_addr,cnocode);\r
before_assign:= false;\r
end; (* cid *)\r
\r
procedure do_endprogdecl; \r
begin\r
(*# BEGINTEST   *)\r
if p2stacktop^.former^.syntaxkind<>sprogdecl then\r
p2_fatal_error(1);\r
(* inconsistency in pass2stack *)\r
(* ENDTEST# *)\r
\r
in_program_head:=false;\r
bind_of_family_allowed:=after_context;\r
put_byte(ord(cendprogdecl));\r
\r
(* TOG type !!! *)\r
st_gettype(p2stacktop^.former^.nodeaddress, st2_cur_ptr);\r
st2_cur_ptr^.typeref:= st_program_type_addr; \r
(*** ***)\r
(* updating specstruc-inf in program-node - telling whether or not *)\r
(* pool's in program parameterlist        *)\r
st2_cur_ptr^.spec_struct := routine_specstruc;\r
routine_specstruc := [];\r
(*** ***)\r
\r
(* lookahead to see if body present or if it is an external program *)\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
(* routines and programs in context must be external *)\r
end;\r
if new_comp_unit 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
begin_level_action;\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
if token=cexternal then \r
begin\r
st_end_program;\r
(* tog !!!!! not nessesary to set st_extern *)\r
st2_cur_ptr^.st_specs:= st_extern;\r
end\r
else\r
if token=cforward then\r
begin\r
elementspix:= st2_cur_ptr^.st_spix;\r
errormsg(pass2, 103);\r
(* forward declared programs not allowed *)\r
end\r
else\r
if token=copenroutine then\r
begin\r
elementspix:= st2_cur_ptr^.st_spix;\r
errormsg(pass2, 104);\r
(* program cant be declared as open routine *)\r
end\r
else\r
p2_fatal_error(2);\r
(* pass1 code error *)\r
\r
pop_p2stack;\r
end; (* not internal program *)\r
new_comp_unit:=false;\r
end; (* cendprogdecl *)\r
\r
procedure do_endvariable;\r
begin\r
with p2stacktop^ do\r
begin\r
(* same test at cuparrow / TOG *)\r
if (syntaxkind=svar) or (syntaxkind=sconst) or (syntaxkind=sexpression) or\r
   (syntaxkind=svarprog) then\r
put_byte(ord(cendvariable))\r
else if (syntaxkind=sfunccall) or (syntaxkind = sopenfunccall) or\r
        (syntaxkind=sfunccalle) or (syntaxkind = sopenfunccalle) 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 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\r
else\r
if syntaxkind=sprogcall then\r
begin\r
if not equal_addr(p2_listref, st_stopaddr) then\r
errormsg(pass2, 112);\r
(* too few actual parameters *)\r
syntaxkind := svar;\r
put_byte(ord(cendprogramcall));\r
putaddress(nodeaddress);\r
end\r
else\r
if (syntaxkind = sproccall) or (syntaxkind = sopenproccall) then\r
begin\r
st_retrieve(nodeaddress, st2_cur_ptr);\r
elementspix:= st2_cur_ptr^.st_spix;\r
errormsg(pass2, 191);\r
(** procedure used as variable **)\r
\r
if not equal_addr(p2_listref, st_stopaddr) then\r
errormsg(pass2, 112);\r
(* too few actual parameters *)\r
\r
syntaxkind := svar;\r
boo := stdcode_to_address(cerror, p2_typeref);\r
end\r
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
\r
end;\r
end; (* cendvariable *)\r
\r
FUNCTION do_endactual : BOOLEAN;\r
(* reducing: *)\r
(* actual parameters: *)\r
(*             ---------<----------------   *)\r
(*             !                        !   *)\r
(* BEGINACTUAL---->unit--->ACTUALPARAM----->ENDACTUAL *)\r
(* unit: *)\r
(* ---->expression----------> *)\r
(*  !               !        *)\r
(*  ----NULL---->----        *)\r
\r
(* dump p2code *)\r
begin\r
do_endactual := false;\r
if p2stacktop^.syntaxkind=sindex then\r
with p2stacktop^ do\r
begin\r
 former^.p2_typeref:= p2_typeref;\r
 pop_p2stack;\r
 help_boolean:= (programtype in p2stacktop^.p2_specstruc);\r
 if help_boolean then with p2stacktop^ do\r
 begin\r
  st_retrieve(p2_typeref, 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 else st2_cur_address:= p2_typeref;\r
  if st2_cur_ptr^.st_kind=cprogram then\r
  begin\r
   if create_call then\r
   begin\r
    syntaxkind:= sprogcall;\r
    put_byte(ord(cprogramcall));\r
    putaddress(st2_cur_address);\r
    create_call:= false;\r
    p2_listref:= st2_cur_ptr^.listref;\r
   end else syntaxkind:= svarprog;\r
   nodeaddress:= st2_cur_address;\r
   p2_typeref:= st2_cur_ptr^.typeref;\r
  end;\r
 end;\r
end\r
else\r
(* no repair\r
if p2stacktop^.syntaxkind=stypeid then (* after repaired structured value *)\r
(*begin\r
warning(pass2, 165);\r
(* ')' was repaired to ':)' *)\r
(*token:= cendstruc;\r
(*goto 9876; *)(* after read next token *)\r
(*do_endactual := true; exit;*)\r
(*end (* repair end of structured value *)\r
(*else\r
*)\r
if p2stacktop^.syntaxkind=sactualparam then\r
with p2stacktop^ do\r
begin\r
former^.p2_listref:= p2_listref;\r
put_byte(ord (cendactual));\r
pop_p2stack;\r
\r
if p2stacktop^.syntaxkind = stypeid then\r
(** binding family within expression -     **)\r
(*  simulate that 'cendtype' is read from pass1code  *)\r
put_byte(ord(cendtype));\r
end\r
else\r
if within_opencall then\r
(** end of open routinecall **)\r
begin\r
bind_open;\r
\r
st_retrieve(p2stacktop^.former^.former^.nodeaddress,st2_cur_ptr);\r
(* i.e. access routine-node **)\r
\r
 \r
if (st2_cur_ptr^.st_spix = pred_spix) or\r
(st2_cur_ptr^.st_spix = succ_spix) then\r
(* resulttype of pred/succ-call is type of the actual parameter *)\r
(* both has got ONE parameter *)\r
(* resulttype  of call is to be placed  in 'p2_typeref' of *)\r
(* 'sopenfunccall' or 'sopenproccall'-node in p2stack   *)\r
p2stacktop^.former^.former^.p2_typeref := p2stacktop^.p2_typeref;\r
\r
put_byte(ord (cendactual));\r
\r
pop_opencall;\r
end;\r
\r
end; (* endactual *)\r
\r
PROCEDURE do_endarray;\r
begin\r
with p2stacktop^ do  (* element type *)\r
begin\r
st2_cur_address:= nodeaddress;\r
(* "spec_struct" - inf. is to put into array-type-node: **)\r
former^.former^.p2_specstruc :=  former^.former^.p2_specstruc + p2_specstruc;\r
end;\r
pop_p2stack; (* element type *)\r
st_retrievetype(p2stacktop^.nodeaddress, st2_cur_ptr);\r
if not ordinaltype(st2_cur_ptr^.st_kind) then\r
errormsg(pass2, 146);\r
(* index type must be an ordinal type *)\r
st_gettype(p2stacktop^.former^.nodeaddress, st2_cur_ptr);\r
with st2_cur_ptr^ do\r
begin\r
typeref:= st2_cur_address; (* element type *)\r
itype:= p2stacktop^.nodeaddress; (* index type *)\r
end; (* with *)\r
pop_p2stack;  (* index type *)\r
\r
(* p2stacktop now points out 'carraytype'\r
- update 'spec_struct' in ST and in '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
st2_cur_ptr^.spec_struct := p2_specstruc;\r
\r
routine_specstruc := routine_specstruc + p2_specstruc;\r
\r
if test_stack then write_p2stack;\r
end;\r
\r
put_byte(ord(cendarray));\r
end; (* cendarray *)\r
\r
FUNCTION do_beginactual : boolean;\r
BEGIN\r
do_beginactual := false;\r
(* start of actual paramlist *)\r
(* dump p2code *)\r
with p2stacktop^ do\r
begin\r
if (syntaxkind=svar) or (syntaxkind = sconst) then\r
begin\r
push_p2stack;\r
with p2stacktop^ do\r
begin\r
syntaxkind:= sindex;\r
p2_typeref:= former^.p2_typeref; (* array type *)\r
end; (* with *)\r
end (* array *)\r
else\r
if (syntaxkind=sproccall) or\r
(syntaxkind=sfunccall) or\r
(syntaxkind=sfunccalle) or\r
(syntaxkind=sprogcall) or\r
(syntaxkind = sopenfunccall) or\r
(syntaxkind = sopenfunccalle) or\r
(syntaxkind = sopenproccall) or\r
(syntaxkind=stype) then\r
begin\r
push_p2stack;\r
with p2stacktop^ do\r
begin\r
syntaxkind:= sactualparam;\r
p2_listref:= former^.p2_listref;\r
end; (* with *)\r
put_byte(ord(cbeginactual));\r
end\r
else\r
if syntaxkind=stypeid then \r
(* no repair\r
begin\r
if not equal_addr(p2_listref, st_stopaddr) then\r
*)\r
begin\r
push_p2stack;\r
with p2stacktop^ do\r
begin\r
syntaxkind:= sactualparam;\r
p2_listref:= former^.p2_listref;\r
end; (* with *)\r
put_byte(ord(cbeginactual));\r
end\r
(*\r
else\r
begin  (* repair structured value *)\r
(*warning(pass2, 166);\r
(* '(' after type name was repaired to '(:' *)\r
(*token:= cbeginstruc;\r
goto 9876; (* after read next token *)\r
(*do_beginactual := true; exit;\r
(*end;  (* structured value repair *)\r
(*end *)\r
else\r
errormsg(pass2, 0);\r
(* not implemented *)\r
\r
end; (* beginactual *)\r
end;\r
\r
FUNCTION do_lockvar : Boolean;\r
var helpptr : st_elemPtr;\r
begin\r
do_lockvar := false;\r
with p2stacktop^ do\r
if (syntaxkind<>svar) then\r
errormsg(pass2, 199)\r
(* only variable allowed *)\r
else\r
if (not equal_addr(p2_typeref, st_chaintype_addr)) and\r
(not equal_addr(p2_typeref, st_referencetype_addr)) then\r
errormsg(pass2, 169);\r
(* object of LOCK/LOCKBUF must be of type chain or reference *)\r
pop_p2stack; (* the variable *)\r
put_byte(ord(clockvar));\r
getaddress(st2_cur_address);\r
putaddress(st2_cur_address);\r
if cross then st_cross_decl(st2_cur_address,token,true);\r
p2stacktop^.former^.nodeaddress := st2_cur_address; (* remember lockvar-addr *)\r
st_get(st2_cur_address, st2_cur_ptr);\r
token := getcode;\r
with st2_cur_ptr^ do\r
(* TOG lock with retype *)\r
if token=cnolocaldecl then\r
begin\r
{$IFDEF RTP86}\r
if p2stacktop^.former^.syntaxkind=slock then\r
begin\r
copy_type(st_dataarea_type_addr, typeref);\r
st2_cur_address := typeref;\r
if segment_nr<>1 (* declared in segment 1 *) then\r
begin\r
st_get(st_dataarea_type_addr, st2_cur_ptr);\r
st2_cur_ptr^.st_t_local_near:=false;\r
end;\r
end\r
else\r
begin\r
copy_type(st_buffer_type_addr, typeref);\r
st2_cur_address := typeref;\r
if segment_nr<>1 (* declared in segment 1 *) then\r
begin\r
st_get(st_buffer_type_addr, st2_cur_ptr);\r
st2_cur_ptr^.st_t_local_near:=false;\r
end;\r
end;\r
\r
st_get(st2_cur_address, st2_cur_ptr);\r
st2_cur_ptr^.type_mode := bound_fam;\r
{$ELSE}\r
 st_declaration(crecordtype,anonymousname,typeref,st2_cur_ptr);\r
 st2_cur_ptr^.spec_struct := [SimpelType];\r
{$ENDIF}\r
in_lock_state:= false;\r
put_byte(ord(cnolocaldecl));\r
{$IFDEF RTP86}\r
put_byte(ord(ctypeid));\r
putaddress(st2_cur_address);\r
put_byte(ord(cendtype));\r
{$ENDIF}\r
st_insert_headsymbol(p2stacktop^.former^.nodeaddress);  (* insert 'lockvar' *)\r
end else begin\r
st_insert_headsymbol(p2stacktop^.former^.nodeaddress);  (* insert 'lockvar' *)\r
\r
(*goto 9876;*)  (* i.e. skip reading next token - which is  already done ! *)\r
do_lockvar := true; exit;\r
end;\r
end; (* clockvar *)\r
\r
procedure do_endassign;\r
(* reducing assignment statement <-\r
  variable --> expression --> ENDASSIGN *)\r
(* pass2code:                                *)\r
(*            ----> ENDASSIGN -------------> *)\r
(*              +-> ENDASSIGNSET -----+      *)\r
(*              +-> ENDASSIGNSTRING --+      *)\r
(* check assignment compatability between expression(stacktop) *)\r
(* and variable (former) *)\r
begin\r
with p2stacktop^ do\r
if (former^.syntaxkind<>svar) and (former^.syntaxkind<>svarfunc) then\r
begin\r
errormsg(pass2, 111);\r
put_byte(ord(cendassign));\r
(* lefthandside of statement is not a variable *)\r
end\r
else\r
if not compatible(former^.p2_typeref, p2_typeref) then\r
begin\r
errormsg(pass2, 110);\r
put_byte(ord(cendassign));\r
(* variable and expression not compatible *)\r
end\r
else\r
begin\r
st_retrieve(former^.p2_typeref, st2_cur_ptr);\r
\r
if st2_cur_ptr^.spec_struct * shielded_types<>[] then\r
errormsg(pass2, 131);\r
(* assignment to variable of shielded type not allowed *)\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\r
  BEGIN\r
  put_byte(ord(cendassign));\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; (* with p2stacktop *)\r
\r
if cross then st_cross_line(p2stacktop^.Former^.nodeaddress,cassignstat);\r
pop_p2stack; (* right hand side *)\r
pop_p2stack; (* left hand side *)\r
before_assign:= true;\r
end; (* cendassign *)\r
\r
{$I rtp86p2a.pas}\r
end.\r
\r
\r
«eof»
DataMuseum.dk

DANOSI

⟦9b238bcde⟧ TextFile

Derivation

TextFile
