⟦c9d3c3743⟧

TextFileVerbose


(*QQQ*)

(* procedures used for testoutput purposes *)

procedure changeline;
begin
testlinecnt := testlinecnt + 1;
if testlinecnt mod lines_pr_page = 1 then
begin
page (output);
writeln (output);
write (cur_date, '   ', cur_time, '      platon, pass3, version ', version);
end;
writeln (output);
end;



procedure continue_line;
begin
(* used for alligning testoutput on consequtive lines *)
changeline;
write (output, '   ');
end;

(*QQQ*)

(* procedures for reading pass1-code file *)

function passin : integer;
(* delivers the next pass1-code as integer value *)
var i: integer;
begin
read (pass1file, i);
passin := i;
if testinput then
write (output, ' ', i:1, '*');
end;



function password : codes;
(* delivers the next pass1-code as code value *)
var i: integer;
begin
read (pass1file, i);
password := convtable [ i ];
if testinput then
write (output, ' ', i:1, '>');
end;

(*QQQ*)

(* procedures for reading the pass1-label file *)

function labelin : integer;
(* delivers the next pass1-label-value as integer value *)
var i: integer;
begin
read (pass1labels, i);
labelin := i;
if testinput then
write (output, ' ', i:1, '+');
end;

(*QQQ*)

(* procedures for writing the pass3file *)

procedure emitin (i: integer);
(* outputs the value as integer value *)
begin
write (pass3file, i); 
if testoutput then
write (output, ' ', i:1, ' ');
end;



procedure emit (code: pass3codes);
(* outputs the codeword as integer value *)
var i: integer;
begin
i := ord (code);
write (pass3file, i);
if testoutput then
write (output, ' ', i:1, '<');
end;



procedure emitid (xcode: pass3codes; xnix: nameptr);
begin
emit (xcode);
emitin (ord (xnix) );
end;



procedure terminate;
var
err: pass3errors;
ch : char;
begin
(* terminate use of files *)

emit (xeom);
close (pass3file);

close (pass1file);
close (pass1labels);

(* if any errormessages then print the descriptions *)
if no_of_errors > 0 then
begin
(* at least one error, therefor prepare the errorlist *)
changeline;
write (output, 'error   description');
changeline;
open (input, 'pass3errors');
reset (input);
(* find the start of error-table *)
repeat
readln (input, ch);
until ch = '(';

for err := noerror to lastpass3error do
begin
if error_bitmap [ err ] then
begin
write (ord (err) : 4, ' =  ');
while not eoln (input) do
begin
read (input, ch); write (output, ch);
end;
changeline;
end;
readln (input);
end; (* scan when errors *)
end; (* if any errors *)

end;

(*QQQ*)

(* procedures for error-handling etc *)

procedure warning (error: pass3errors);
begin
if (no_of_errors = 0) or testing then changeline;
write (output, '*** pass ', own_passno:1,
' line ', cur_lineno:4, '.', cur_opandno:1,
', error ', ord (error):2);
changeline;
no_of_errors := no_of_errors + 1;
error_bitmap [ error ] := true;
end;



procedure error (err: pass3errors);
begin
call_pass4 := false;  (* avoid calling pass4 automaticly *)
emit (xerror);
emitin (own_passno);
emitin (ord (err));
emit (xerrorno);
emitin (cur_opandno);
warning (err);
error_bitmap [ err ] := true;
end;



procedure suppress_error (kind: codes; err: pass3errors);
(* the error-message will be suppressed, if already after error *)
(* the typename if stacktop will be set to error-type *)
begin
if kind <> cerrorkind then error (err);
with opands [ stacktop ] do
op_typename := error_typename;
end;



procedure break;
(* used when a call-trace is wanted *)
begin
terminate; (* terminate the files etc *)
writeln;
writeln ('***** intentionally error...');
emit (xeom); (* this will provoke an error, which will produce the trace *)
(* the program is terminated *)
end;



procedure stop (cause: stopcodes);
begin
writeln (output);
writeln ('*** error found in pass3, at sourceline: ', cur_lineno:1);

case cause of
too_many_names:
writeln ('max_names exceeded', max_names);
too_many_types:
writeln ('max_types exceeded', max_types);
too_many_strings:
writeln ('max_strings exceeded', max_strings);
too_many_labels:
writeln ('max_labels exceeded', max_labels);
too_many_opands:
writeln ('max_opands exceeded', max_opands);
too_many_levels:
writeln ('max_levels exceeded', max_levels);
too_many_pushnames:
writeln ('max_pushnames exceeded', max_pushnames);
too_many_nested_calls:
writeln ('max_nested_calls exceeded', max_nested_calls);
end
otherwise writeln ('??? stop-cause = ', ord (cause):1);

call_pass4 := false;  (* suppress automatic call of next pass *)

goto 999; (* terminate program *)
end;



procedure comp_error (cause: comp_errorcodes);
begin
writeln;
writeln ('*** program inconsistency in pass3, at sourceline ', cur_lineno:1);
write   ('    cause is: ');
case cause of
unknown_namekind: write ('unknown-namekind');
unknown_argkind: write ('unknown-argkind');
unknown_opcode: write ('unknown-opcode');
unknown_paramkind: write ('unknown-paramkind');
unknown_routinekind: write ('unknown-routinekind');
unknown_spix: write ('unknown-spix');
unknown_stdtype_name: write ('unknown-stdtype-name');
unknown_typekind: write ('unknown-typekind');
unknown_rectype: write ('unknown-rectype');
inconsist_alloc: write ('inconsistent-alloc');
unstack_nontype: write ('unstack-nontype');
end
otherwise write ('??? = ', ord(cause):1 );

break; (* terminate program, with call-trace *)

end; (* procedure comp_error *)



procedure readoption;
(* reads: passno, option number, option value *)
(* if passno is not current pass then emit the option *)

var passno, optno, optvalue: integer;

begin

passno   := passin;
optno    := passin;
optvalue := passin;

if passno <> own_passno then
begin
emit   (xoption);
emitin (passno);
emitin (optno);
emitin (optvalue);
end
else
begin
case optno of
1: testinput   := optvalue = 1;
2: testoutput  := optvalue = 1;
3: call_pass4  := optvalue = 1;
4: lambda_version := optvalue = 1;
end otherwise; (* case, otherwise blind *)
end;
testing := testinput or testoutput;

end; (* procedure readoption *)

(*QQQ*)

(* procedures for allocating/releasing structures *)



function alloc_string: stringptr;
(* deliver a stringnode *)

var string: stringptr;

begin

string := freestrings;
if string = nilstring then
stop (too_many_strings);

with strings [ string ] do
begin
alloc_string := string;
freestrings  := nextstr;
nextstr      := nilstring;
end;

end;



procedure release_string (xstring: stringptr);
(* releases a whole list, constituting a literal *)

var string: stringptr;

begin

string := xstring;

(* scan the list to find the termination *)
repeat
with strings [ string ] do
begin
string := nextstr;
if string = nilstring then
nextstr := freestrings; (* insert in front of free nodes *)
end;
until string = nilstring;

freestrings := xstring;  (* first free in the list *)

end;



function alloc_opand: opandptr;
(* delivers an opand node, initialized with cur_lineno *)

var opand: opandptr;

begin

opand := freeopands;
if opand = nilopand then
stop (too_many_opands);

with opands [ opand ] do
begin
alloc_opand := opand;
freeopands  := next;
next        := nilopand;
op_lineno   := cur_lineno;
op_name     := nilname;
op_value    := nilstring;
op_packflag := false;
end;

end;



procedure release_expr (expr: opandptr);
(* works as 'emitexpr', but does only the releasing *)

begin

while expr <> nilopand do
with opands [ expr ] do
begin
if left <> nilopand then
release_expr (left);
if op_value <> nilstring then
release_string (op_value);
next := freeopands;
freeopands := expr;
expr := rigth;
end;

end; (* procedure release-expr *)



function alloc_namenode: nameptr;
(* delivers a namenode, initialized as dummy *)

var name: nameptr;
begin
name := freenames;
if name = nilname then
stop (too_many_names);

(* initialize *)
with names [ name ] do
begin
alloc_namenode := name;
freenames := nextname; (* unlink from free-chain *)
nextname  := nilname;

forward_decl  := false;
external_decl := false;
func_assigned := false;
usedlevel := lowestlevel - 1; (* i.e. not used *)
params := nilname;
typ := dummy_typenode;
end;

end;



procedure release_typenode (xtype: typeptr); forward;

procedure releasenames (xnamelist : nameptr);
(* releases all namenodes in the list *)
(* if a namenode is a typename, the corresponding typenode *)
(*   will be released too *)

var name: nameptr;

begin

while xnamelist <> nilname do
with names [ xnamelist ] do
begin
if params <> nilname then
releasenames (params); (* release paramlists of inner routines *)
if typ <> dummy_typenode then
if namekind <> cundeclared then
release_typenode (typ); (* release typenode of local type *)

(* insert in free-chain *)
name := nextname;
nextname := freenames;
freenames := xnamelist;

xnamelist := name;

end; (* with xnamelist *)

end;



function alloc_typenode : typeptr;
(* delivers a typenode, initialized as dummy *)

var name : nameptr;

begin

name := freetypename;
if name = nilname then
stop (too_many_types);


with names [ name ] do
with types [ typ ] do

begin
alloc_typenode := typ;
freetypename := nextname;
nextname := nilname;
typ := dummy_typenode;
releasenames (name);

(* initialize typenode *)
element := nilname;
index   := nilname;
subexpr := nilopand;
typekind := cnocode;
contents:= [];
packflag:= false;
emitted := false;

end; (* with typenode *)

end;



procedure release_typenode (xtype: typeptr);

var name: nameptr;

begin
with types [ xtype ] do
begin
if typekind = crecord then
releasenames (element); (* release field-list of record *)
if subexpr <> nilopand then
release_expr (subexpr);
end; (* with xtype *)
name := alloc_namenode;
with names [ name ] do
begin
namekind := ctype;
typ := xtype;
nextname := freetypename;
freetypename := name;
end;

end;



function alloc_label: labelptr;
(* delivers a labelnode *)

var lab: labelptr;

begin

lab := freelabels;
if lab = nillabel then
stop (too_many_labels);

with labels [ lab ] do
begin
alloc_label := lab;
freelabels  := prevlabel;
prevlabel   := nillabel;
end;

end;

(*QQQ*)



function readstring: stringptr;
(* reads: length, char [ 1 .. length ] from pass1file *)
(*  and packs into stringnodes *)

var
length: integer;
curstr: stringptr;
i, portion: str_index;

begin

length := passin; (* get length of string *)

curstr := alloc_string;
readstring := curstr; (* result is (first) stringnode *)

portion := maxstring;

while length > 0 do
with strings [ curstr ] do
begin

(* read a portion of the string *)
stringlgt := length;
if length < portion then portion := length;
length := length - portion;
for i := 1 to portion do
str [ i ] := chr (passin);

if length > 0 then
nextstr := alloc_string;

curstr := nextstr;

end; (* with curstr *)

end; (* procedure readstring *)



procedure emitstring (string: stringptr);

var
length: integer;
curstr: stringptr;
i, portion: str_index;

begin

curstr := string;
portion := maxstring;

with strings [ curstr ] do
length := stringlgt;

emitin (length);

if length > 0 then
repeat
with strings [ curstr ] do
begin
if portion > stringlgt then portion := stringlgt;

for i := 1 to portion do
emitin ( ord ( str [ i ] ) );

curstr := nextstr;
end; (* with curstr *)

until curstr = nilstring;

end; (* procedure emitstring *)



procedure emit_extname (opand: opandptr);

begin

emit (xname);
with opands [ opand ] do
emitstring (op_value);
release_expr (opand);

end;



procedure stdspix (xspix: integer; xstdname: stdname_range);

(* inserts the value 'xspix' in stdspix-table *)
(* ... the value -1 is <dummy-value> *)

var i: stdname_range;

begin

stdspix_table [ xstdname ] := xspix;

maxstdspix := -1; (* assume all entries are dummy *)
(* maxstdspix is used when determining a spix to be 'special' *)

for i := canonymous to cord do
if maxstdspix < stdspix_table [ i ] then
maxstdspix := stdspix_table [ i ];

end;



procedure standardname;
(* called from initialization and mainloop *)
(*   it will read: (spix,stdname) , and insert in tabel *)

begin
stdspix (passin (* = spix *), password (* = stdname *) );

anonymous_spix := stdspix_table [ canonymous ];
exception_spix := stdspix_table [ cexception ];
end;



procedure specialspix (xname: nameptr);
(* called from mainloop, when a 'special'-spix has been defined *)
(*   the action depends on the spix *)

label 99;
var i: stdname_range;

begin

with names [ xname ] do    (* namenode of special interest *)
with types [ typ ] do    (* the corresponding typenode (in case of type...) *)
for i := canonymous to cord do
(* scan the stdspix-table to find the rigth spix *)
if stdspix_table [ i ] = spix (* of namenode *) then
begin

(* remove it from table (... optimalization ...) *)
stdspix (-1, i);

case i of

canonymous: ; (* empty *)

cboolean:
begin
boolean_typename := xname;
emitid (xboolean, xname);
end;

cchar:
begin
char_typename    := xname;
emitid (xchar, xname);
end;

cshadow:
begin
shadow_typename := xname;
contents         := [ t_shadow ];  (* force this special content *)
emitid (xshadow, xname);
end;

creference:
begin
reference_typename := xname;
contents         := [ t_reference ];  (* force this special content *)
emitid (xreference, xname);
end;

csemaphore:
begin
contents         := [ t_semaphore ];  (* force this special content *)
emitid (xsemaphore, xname);
end;

cson:
son_typename     := xname;

cprocessrec:
processrec_typename := xname;

cexception:
exception_procname := xname;

cabs:
abs_procname     := xname;

csucc:
begin
succ_procname    := xname;
emitid (xsucc, xname);
end;

cpred:
begin
pred_procname    := xname;
emitid (xpred, xname);
end;

cchr:
emitid (xchr, xname);

cord:
begin
ord_procname     := xname;
emitid (xord, xname);
end;

end
otherwise
if compilertest then
comp_error (unknown_stdtype_name);

goto 99; (* goto found *)

end; (* for i in stdspix_range *)

(* in case the loop terminates: severe error *)
if compilertest then
comp_error (unknown_spix);

99: ; (* found: *)

end; (* procedure specialspix *)



procedure set_error_type;
(* if the current type was an implicit type definition,    *)
(*   it will be released at block-end                      *)

begin
cur_typename := error_typename;
cur_typenode := error_typenode;
end;

(* procedures for inserting/retrieving names *)



procedure searchspix (xspix: spixrange; firstlevel, lastlevel: levelrange);
(* searches among all names in the levels to find 'xspix' *)

(* the global variables 'retrieved_name'/'retrieved_level' *)
(*   describe the result of the procedure: *)

(* xspix not found: 'retrieved_name' = nilname (-level undef) *)
(* xspix found:     'retrieved_name/level' identifies the namenode *)

label 99;
var
name: nameptr;
level: levelrange;

begin

for level := lastlevel downto firstlevel do
with namestack [ level ] do
begin
name := firstname;
while name <> nilname do
with names [ name ] do
begin
if spix (* of name *) = xspix then
goto 99; (* found *)
name := nextname; (* follow chain *)
end;
end; (* for level *)
name := nilname; (* name not found *)

99:; (* found *)
retrieved_level := level; (* undef, if not found *)
retrieved_name  := name;  (* nilname, if not found *)

end; (* procedure searchspix *)



function findname (xspix: spixrange) : nameptr;
(* delivers the namenode with the searched spix *)
(* if the spix was'nt found, the result is 'nilname' *)

begin
searchspix (xspix, processparamlevel, namelevel);
if retrieved_name = nilname then
searchspix (xspix, lowestlevel, lastgloballevel);
findname := retrieved_name;
end;



function newname (xspix: spixrange) : nameptr;
(* a new namenode is inserted at current namelevel *)
(* the namenode is initialized as dummy *)

label 99;
var name : nameptr;

begin

if xspix <> anonymous_spix then
begin
(* explicit spix'es may not exist already at current namelevel *)
(*   ... except forward declared routine-names ... *)

name := findname (xspix);
if name <> nilname then
begin
(* the name already existed at some level *)
(* check the consistency *)
with names [ name ] do  (* namenode of just found name *)
if retrieved_level = namelevel then
begin
(* double-declaration is suppressed, in case the previous decl was forward *)
if forward_decl then
(* it was really forward declared *)
(* now test that it is similar to the new one *)
if namekind = cur_namekind then
goto 99; (* skip initialization etc *)

(* otherwise is will be flagged as error *)
error (double_declaration);
xspix := anonymous_spix; (* i.e. this name can never be retrieved *)

end (* if already on namelevel *)
else
begin
(* test that this (global) name has'nt been used previously on this level *)
if usedlevel (* of name *) = namelevel then
error (inconsistent_use);
end;

end; (* if existing name *)

end; (* if explicit spix *)

(* allocate and initialize a new namenode *)

name := alloc_namenode;

with names [ name ] do
begin
spix     := xspix;
namekind := cur_namekind;
typename := nil_typename;

(* insert in list of names of same level *)
with namestack [ namelevel ] do
if insert_in_front then
begin (* only function-return-value are inserted in front ... *)
with names [ name ] do
nextname := firstname; (* insert in front of existing list *)
if firstname = nilname then
lastname := name;
firstname := name;
end
else
begin
if firstname = nilname then
firstname := name
else
with names [ lastname ] do
nextname := name; (* insert in rear of existing list *)
lastname := name;
end; (* with namelevel *)

end; (* with name *)

99:; (* after init of namenode *)
newname := name;

end; (* procedure newname *)



function new_undecl (xspix: spixrange): nameptr;
(* the routine creates a new namenode with the spix given *)
(* and marks it as undeclared *)

var name: nameptr;

begin

name := newname (xspix);
with names [ name ] do
begin
namekind := cundeclared;
typename := error_typename;
typ      := error_typenode;
end;

(* nbnbnb: make a 'pseudo'-declaration of the name *)
emitid (xundeclid, name);

new_undecl := name;

end; (* procedure new-undecl *)



function usename (xspix: spixrange) : nameptr;
(* the routine will search for the given spix, and mark the namenode *)
(*   as being used on current namelevel *)

(* if the name does'nt exist, a new namenode will be created *)

var name: nameptr;

begin

cur_opandno := cur_opandno + 1;

name := findname (xspix);

if name = nilname then
begin
(* the name did'nt exist, create e new namenode *)
error (undeclared);
name := new_undecl (xspix);

end; (* if undeclared *)

(* test for recursive use of constants, i.e. using before defining *)
with names [ name ] do
if namekind = cconstant then
if usedlevel = lowestlevel - 1 (* i.e. just after declaration *) then
begin
error (recursive_constant_use);
name := new_undecl (xspix);
end;

(* mark the name as being used on current level *)
with names [ name ] do
usedlevel := namelevel;

usename := name; (* deliver the used name node *)

end; (* procedure usename *)



procedure end_level_use (firstlevel, lastlevel: levelrange);
(* all names in the outpointed namelevels are tested for use *)
(* on current namelevel *)

(* if a name was used on current namelevel, it will be flagged *)
(*   as if it had been used on preceding namelevel *)

var
name: nameptr;
level: levelrange;

begin

for level := lastlevel downto firstlevel do
with namestack [ level ] do
begin
name := firstname;
while name <> nilname do
with names [ name ] do
begin
if usedlevel = namelevel then
if namelevel = processparamlevel then
usedlevel := lastgloballevel
else
usedlevel := usedlevel - 1;
name := nextname;  (* follow chain *)
end;
end;

end; (* procedure end_level_use *)



procedure end_global_use;
(* called when terminating a namelevel *)
(* if global variables have been used at this namelevel *)
(*   their uselevel will be decreased as is they were used at *)
(*   preceding namelevel *)

begin
end_level_use (processparamlevel, namelevel - 1);
end_level_use (lowestlevel, lastgloballevel);
end;

(*QQQ*)

(* procedures for handling push/pop of names *)

procedure pushname (xname: nameptr);
begin
pushnamestack [ pushnameindex ] := xname;
if pushnameindex = max_pushnames then
stop (too_many_pushnames);
pushnameindex := pushnameindex + 1;
end;



function popname : nameptr;
begin
pushnameindex := pushnameindex - 1;
popname := pushnamestack [ pushnameindex ];
end;



(* pushlist/poplist are used for handling of nested namelists *)

procedure pushlist;
begin
pushname (listfirst);
pushname (listlast);
listfirst := nilname;
listlast  := nilname;
end;

procedure poplist;
begin
listlast  := popname;
listfirst := popname;
end;



(* pushtype/poptype are used for handling of nested types *)

procedure pushtype;
begin
pushname (cur_typename);
end;

procedure poptype;
begin
cur_typename := popname;
with names [ cur_typename ] do
cur_typenode := typ;

if compilertest then
if cur_typenode = dummy_typenode then
begin
comp_error (unstack_nontype);
set_error_type;
end;
end;



(* procedures for handling of nested procedure calls (or indexing etc) *)

procedure pushcall;
begin
if callindex = max_nested_calls then
stop (too_many_nested_calls);

with calls [ callindex ] do
begin
callkind      := argkind;
callformal    := curformal;
callowner     := arglist_owner;
call_afterfunc:= after_funccall;
call_functemp := functempvar;
call_countprocess := count_processparam;
end;

after_funccall := false; (* assume not function call *)

count_processparam := 0;

callindex := callindex + 1;

end; (* procedure pushcall *)



procedure popcall;
(* works opposite of pushcall *)

begin

callindex := callindex - 1;

with calls [ callindex ] do
begin
argkind       := callkind;
curformal     := callformal;
arglist_owner := callowner;
after_funccall:= call_afterfunc;
functempvar   := call_functemp;
count_processparam := call_countprocess;
end;

end; (* procedure popcall *)


(* procedures for creating new opand-nodes, whether operators or operands *)

procedure oper (mode: opmodes; xopcode: codes; xtypename: nameptr);
(* inserts an opandnode as unary or binary operator *)

var
oldtop: opandptr;

begin

(* move stacktop to another opand, and use the stacktop for the new one *)
(* this makes it possible to 'insert' in the middle of the opand-tree   *)
oldtop := alloc_opand;
opands [ oldtop ] := opands [ stacktop ];

with opands [ stacktop ] do  (* new opand node *)
begin

opcode := xopcode;

if mode = unary then
begin
left   := nilopand;
rigth  := oldtop;
next   := nexttop;
end
else
begin (* binary*)
left   := nexttop;
rigth  := oldtop;
next   := opands [ left ] . next;

nexttop := next;

end;

op_lineno   := 0;  (* dummy *)
op_name     := nilname;
op_value    := nilstring;
op_typename := xtypename;

end; (* with (new) stacktop *)

end; (* procedure oper *)



procedure newopand (xcode: codes; xtypename: nameptr);
(* insert an operand at stacktop *)

var
oldtop: opandptr;

begin

if retain_top then
begin
(* if insertion in middle of list then don't 'move' stacktop *)
oldtop := alloc_opand;
opands [ oldtop ] := opands [ stacktop ];
with opands [ stacktop ] do
begin
op_lineno := 0;
op_name   := nilname;
op_value  := nilstring;
end;
end
else
begin

oldtop := stacktop;
stacktop := alloc_opand;

end;

with opands [ stacktop ] do  (* new opand node *)
begin

opcode      := xcode;
left        := nilopand;
rigth       := nilopand;
next        := oldtop;
op_typename := xtypename;

end;

nexttop := oldtop;

end; (* procedure newopand *)



function take_stacktop : opandptr;
(* used when the top-expression is to be saved a while *)
begin
take_stacktop := stacktop;
stacktop      := nexttop;
nexttop       := opands [ stacktop ] . next;
end;



procedure insert_functype (xtypename: nameptr);
begin
with names [ functempvar ] do
typename := xtypename;
end;



procedure prepare_call (opand: opandptr);
(* used to prepare a routine-call *)
(* nb: 'pushcall' must have been called previously *)

var
saved_stacktop : opandptr;
saved_nexttop  : opandptr;

begin

with opands [ opand ] do   (* opand contains id, holding routine *)
with names [ op_name ] do   (* namenode of routine *)

begin
(* initialize global variables, describing arguments to this routine *)

argkind     := cargument;
curformal   := params;     (* first of formal list *)
arglist_owner := op_name;    (* set this routine as owner of formal list *)

if namekind (* of routine *) = cfunction then
begin
(* save stacktop etc and restore later *)
(* simulate that 'opand' is stacktop *)
saved_stacktop := stacktop;
saved_nexttop  := nexttop;
stacktop       := opand;
nexttop        := opands [ stacktop ] . next;

retain_top := true;

(* reserve temp name, for identifying temp-return-value *)
functempvar := alloc_namenode;
insert_functype (typename (* of function *) );

(* insert opand, pointing at this temp-name *)
oper (unary, cfunctrailer, nilname (* irrell typename *) );
with opands [ stacktop ] do
op_name := functempvar;

(* insert operand, to be used as actual argument for the return-value *)
newopand (cfunctemp, nilname (* irrell typename *) );
with opands [ stacktop ] do
op_name := functempvar;

(* bind this actual-argument onto the function *)
(* ... see also 'actparam' ... *)
oper (binary, argkind, nilname (* irrell typename *) );
with opands [ stacktop ] do
op_name := curformal;  (* let opname point at first formal name, i.e. 'funcval' *)

if compilertest then
if (stacktop <> opand) or (nexttop <> opands [ opand ] . next) then
begin
writeln(stacktop,opand,nexttop, opands[opand].next);
break;
end;

retain_top := false;

stacktop       := saved_stacktop;
nexttop        := saved_nexttop;
end;

end; (* with namenode of routine *)

end; (* procedure prepare-call *)



procedure terminate_call (opand: opandptr);
(* used by 'endactual' to test total match of formal lists etc *)

label 10;

var
saved_stacktop : opandptr;
saved_nexttop  : opandptr;

begin

(* save stacktop etc and restore later *)
(* simulate that 'opand' is stacktop   *)
saved_stacktop := stacktop;
saved_nexttop  := nexttop;
stacktop       := opand;
nexttop        := opands [ stacktop ] . next;

case argkind of

cstrucrecord,
cargument:
begin
(* test that all recfields (respectively all formals) have been matched *)
while curformal <> nilname do
with names [ curformal ] do
case namekind (* of curformal *) of
crecfield,
cvarp,
cvaluep:
begin
error (too_few_parameters);
goto 10;
end;
cfuncval,
cundeclared,  (* undeclared typename *)
cscalarelem,
ctype:
curformal := nextname;  (* i.e. skip in formal-list *)
end
otherwise
if compilertest then
comp_error (unknown_namekind);

10:;
end; (* argkind = strucrecord or argument *)

end (* case argkind *)
otherwise; (* no check *)

(* insert opands, describing the proper end-list *)
case argkind of

cindex: ; (* nothing *)

cstrucarray,
cstrucrecord:
oper (unary, cendstruc, arglist_owner);

cargument:
with names [ arglist_owner ] do
case namekind of
cprocess:
begin
oper (unary, ccallprocess, nilname (* no type *) );
with opands [ stacktop ] do
op_name := nextname (* of process *);  (* remember the sonvar-name, for later use *)
end;
cprocedure,
cfunction:
begin
(* first insert operators for later counting in opand-stack *)
while count_processparam > 0 do
begin
count_processparam := count_processparam - 1;
oper (unary, cendprocessparam, nilname (* irrell typename *) );
end;
case namekind (* of arglist-owner *) of
cprocedure:
oper (unary, cendproc, nilname (* irrell typename *) );
cfunction:
begin
with names [ functempvar ] do  (* namenode, containing function-type *)
oper (unary, cfcall, typename (* of function-type *) );
with calls [ callindex - 1 ] do  (* i.e. determine the value to be unstacked *)
call_afterfunc := true;
end;
end otherwise (* not possible *); (* case procedure or function *)
end;
end otherwise; (* case namekind *)

cerrorarg: ; (* don't care anyway *)

end (* case argkind *)

otherwise
if compilertest then
comp_error (unknown_argkind);

(* unstack nested call *)
popcall;

if compilertest then
if (opand <> stacktop) or (nexttop <> opands[opand].next) then
begin
writeln(stacktop,opand,nexttop,opands[opand].next);
break;
end;
(* restore thereal stacktop and nexttop *)
stacktop := saved_stacktop;
nexttop  := saved_nexttop;

end; (* procedure terminate-call *)



procedure terminate_funccall (opand: opandptr);
(* ensures that the 'endfunccall' is emitted (as late as possible) after a function call *)

var
saved_stacktop : opandptr;
saved_nexttop  : opandptr;

begin
if after_funccall then
begin
(* save stacktop etc and restore later *)
(* simulate that 'opand' is stacktop   *)
saved_stacktop := stacktop;
saved_nexttop  := nexttop;
stacktop       := opand;
nexttop        := opands [ stacktop ] . next;
with opands [ stacktop ] do
oper (unary, cendvariable, op_typename (* continue with op-type *) );
(* unstack from call-stack *)
after_funccall := false;
if compilertest then
if (opand <> stacktop) or (nexttop <> opands[opand].next) then
begin
write(stacktop,opand,nexttop,opands[opand].next);
break;
end;
(* restore the real stacktop and nexttop *)
stacktop := saved_stacktop;
nexttop  := saved_nexttop;
end;
end;



procedure make_call (opand: opandptr);
(* if the operand is a routine-ident, a (parameter-less) call will be made *)

begin
with opands [ opand ] do
if opcode = cid then
with names [ op_name ] do
case namekind of
cprocess,
cprocedure,
cfunction:
begin
pushcall;
prepare_call (opand);
terminate_call (opand);
terminate_funccall (opand);
end;
end otherwise; (* other namekinds are not routine-calls *)

end; (* procedure make-call *)

(*QQQ*)

(* procedures for handling level-change etc *)

procedure newnamelevel;
(* initializes a new namelevel, with an empty namelist *)
begin
if namelevel = max_levels then
stop (too_many_levels);
namelevel := namelevel + 1;
with namestack [ namelevel ] do
begin
firstname := nilname;
namelistkind := levelkind;
withname := nilname;  (* assume normal level *)
if namelistkind = processlevel then
processparamlevel := namelevel;
end;
levelkind := irrell_level;  (* prepare for next level to be normal *)

end;


procedure insert_namelist (first: nameptr);
(* initializes current namelevel with the namelist given *)
begin
with namestack [ namelevel ] do
begin
firstname := first;
lastname := firstname;
while names [ lastname ] . nextname <> nilname do
lastname := names [ lastname ] . nextname;
end;
end;


procedure endnamelevel;
begin
(* the variable 'processparamlevel' must be reinitialized, when *)
(*   leaving a process. *)
if namelevel = processparamlevel then
repeat
processparamlevel := processparamlevel - 1;
until
(namestack [ processparamlevel ] . namelistkind = processlevel)
or
(processparamlevel = lastgloballevel - 1);
end_global_use;
namelevel := namelevel - 1;
end;

procedure test_recursive_type;
(* will test that 'cur_typename' is a defined type *)
begin
with names [ cur_typename ] do
if spix (* of typename *) <> anonymous_spix then
(* recursion only possible with named types *)
with types [ typ ] do
if not emitted then
begin
error (recursive_use_of_type);
set_error_type;
end;
end;

(*QQQ*)



function empty_paramlist (paramlist: nameptr): boolean;
(* returns false, if the paramlist contains 'varparam' or 'valueparam' *)

label 99;

begin
while paramlist <> nilname do
with names [ paramlist ] do
if (namekind = cvarp) or (namekind = cvaluep) then
begin
empty_paramlist := false;
goto 99;
end
else
paramlist := nextname;  (* follow chain *)

(* the list did'nt contain var- or valueparam *)
empty_paramlist := true;
99: ;

end; (* procedure empty-paramlist *)

procedure compare_paramlists;
(* compares the previous paramlist of 'cur_routine' *)
(*   with param-list in current namelevel *)

(* the new paramlist may be empty or exactly the same *)

(* the new paramlist is released and replaced by the original list *)

var
newparam, oldparam: nameptr;
errorflag: boolean;

begin
errorflag := false; (* suppose no errors *)
with namestack [ namelevel ] do
with names [ cur_routine ] do
begin

newparam := firstname; (* first of new parameter list *)

if not empty_paramlist (newparam) then
begin
oldparam := params; (* first of old parameter list (of cur_routine) *)

(* compare the two lists *)
(* they both terminate with nilname *)

while oldparam <> newparam do
with names [ oldparam ] do
begin

if
(* they must have identical names *)
(spix     <> names [ newparam ] . spix)
or
(* both must be 'cvarp' or 'cvaluep' *)
(namekind <> names [ newparam ] . namekind)
or
(* they must have same type *)
(typename <> names [ newparam ] . typename)
then
errorflag := true;

oldparam := nextname;
newparam := names [ newparam ] . nextname;

end; (* with/while more params *)

if errorflag then
error (paramlist_changed_since_forwarddecl);

end; (* if new paramlist not empty *)

(* release the new paramlist and replace it by the old one *)

releasenames (firstname (* of namelevel *) );
insert_namelist (params (* of cur-routine *) );

end; (* with cur_routine *)

end; (* procedure compare_paramlists *)

(*QQQ*)

procedure begin_block;
(* called before first local declaration in a routine *)
begin
expecting_block := false; (* indicate that the procedure has been called *)

with names [ cur_routine ] do
begin
if namekind <> cprocess then
cur_blockno := cur_blockno + 1;
forward_decl := false; (* because here comes the body *)
end;

emit (xblock);
emitin (cur_blockno);

end;

(*QQQ*)

(* procedures for emitting identifiers and types *)



procedure emitexpr (expr: opandptr);
(* the expression is emitted, and maybe released (depending on 'expr-release') *)

procedure emitboth;
begin
with opands [ expr ] do
begin
emitexpr (left);
emitexpr (rigth);
end;
end;

procedure emit_arith (outcode: pass3codes);
begin
with opands [ expr ] do
begin
if left <> nilopand then
begin
emitexpr (left);
emit (xgetvalue);
end;
emitexpr (rigth);
emit (outcode);
end;
end;

begin

if expr <> nilopand then
with opands [ expr ] do
begin

(* note: only 'newopand' inserts proper lineno in opands *)
if op_lineno <> 0 then
if op_lineno <> emit_lineno then
begin
emit (xnewline);
emitin (op_lineno);
emit_lineno := op_lineno;
end;


expr_level := expr_level + 1;
if expr_level = 1 then
begin
emit (xexpr);      (* this is the start of a whole expression *)
if testoutput then continue_line;
end;

if opcode = cnocode then
emitboth
else
case opcode (* of opand *) of

cid:
begin
(* identifier: action depends on namekind *)

with names [ op_name ] do  (* namenode of identifier *)

case namekind (* of namenode *) of

cundeclared,
cscalarelem,
cconstant,
cvar,
cvarp,
cvaluep,
cfuncval:
begin
emitid (xvar, op_name);
emitin ( ord(typename) );
end;

cprocess: ; (* nothing *)
(* start of process param sequence *)

cprocedure:
begin
(* start of procedure call-sequence *)
emitid (xproccall, op_name);
end;

cfunction:
begin
(* start of function call sequence *)
emitid (xfunccall, op_name);
(* the temp-return-value and the type are emitted by 'functrailer' *)
end;

ctype:
begin
(* start of structured constant sequence *)
emitid (xstrucconst, op_name (* name of type itself *));
end;

end (* case namekind *)
otherwise
if true then write (output, '*** id: namekind = ', ord(namekind):1)
else
if compilertest then
comp_error (unknown_namekind);

end; (* opcode = 'id' *)

cliteral:
begin
emit (xliteral);
with names [ op_typename ] do    (* namenode of opand-type *)
with types [ typ ] do          (* corresponding typenode *)
if typekind (* of opand-typenode *) = cinteger then
emitin ( ord(lit_integer) )
else
with strings [ op_value ] do
if stringlgt = 1 then
emitin ( ord(lit_char) )
else
emitin ( ord(lit_string_or_empty) );
emitstring (op_value);
end;


cskipparam:
emit (xnull);


cfunctrailer:
begin
emitexpr (rigth);  (* emit funccall etc *)
emitin (ord (op_name) );  (* name of temp-return-value *)
with names [ op_name ] do  (* namenode of functemp var *)
emitin (ord (typename) );  (* typename of function *)
end;


cfunctemp:
begin
(* this is almost an 'id', but the namenode does'nt contain typename *)
(* used for actual argment, to match 'funcval' *)
emitid (xvar, op_name);
with names [ op_name ] do  (* namenode of functemp var *)
emitin ( ord (typename) );
if expr_release then
releasenames (op_name); (* because it was a temporary *)
end;


cfcall:
begin
emitexpr (rigth);  (* note: it is an unary operator *)
emit (xfcall);
emitin (count_processparam); count_processparam := 0;
(* note: the 'endfunccall' is emitted after any indexing,uparrow etc *)
end;


cendproc:
begin
emitexpr (rigth);  (* note: it is an unary operator *)
emit (xendproc);
emitin (count_processparam); count_processparam := 0;
end;


ccallprocess:
emitexpr (rigth);  (* note: it is an unary operator *)


cendprocessparam:
begin
emitexpr (rigth);  (* note: it is an unary operator *)
count_processparam := count_processparam + 1;
end;


(* emission of set_values *)
csetlist:
emit (xset);
cs_element:
begin
emitboth;
emit (xinclude);
end;
cm_element:
begin
emitexpr (left);
emit (xsetexpr);
emitexpr (rigth);
emit (xincluderange);
end;
cendsetlist:
begin
emitexpr (rigth);  (* note: unary operator *)
(* note: pass4 will generate its own type description, using this type-nix *)
emitid (xendset, op_typename);
if expr_release then
if not op_packflag then  (* dont't release, when const-declaration *)
releasenames (op_typename); (* because it was a temporary *)
end;


cfield:
begin
emitexpr (rigth);  (* nb: field is unary operator *)
emit (xfield);
emitin (ord (op_name) );     (* field name *)
emitin (ord (op_typename) ); (* field type name *)
end;


cuparrow:
begin
emitexpr (rigth); (* nb: uparrow is unary operator *)
emitid (xarrow, op_typename);
end;

crange:
begin
emitexpr (rigth);  (* note: unary operator *)
emitid (xrange, op_typename);
end;


cerrorarg, (* midlertidig ************************************** *)
cindex:
begin
emitexpr (left); (* array name etc *)
emit (xindexexpr);
emitexpr (rigth); (* index expression *)
emit (xindex);
emitin (ord (op_name) );     (* array type name *)
emitin (ord (op_typename) ); (* element type name *)
end;


cprocessargument:
begin
(* parameter, describing a process-'call' *)
(* emit the argument-expression at once (i.e. the process-params) *)
(* and then later simulate a normal argument *)
emit (xprocessparam);
emit (xvarpointer);
emitin ( ord (op_name) );  (* son-var of process *)
emitin ( ord (op_typename) );  (* temp var, for addressing the 'processrec' *)
emit (xtempointer);
emitexpr (rigth);  (* emit the process-params *)

emit (xarglistsize);
emitexpr (left);  (* previous routine-ident and arguments *)
end;


cargument:
begin
(* argument-list of routine call *)
emitexpr (left);  (* previous routine-ident and arguments *)
emitid (xactual, op_name);
emitexpr (rigth); (* argument expression *)
emit (xendactual);
end;


cdoubleparam:
begin
(* used for repetition in structured array-values *)
emitexpr (left);  (* emit repeat-value *)
emit (xtimes);
emitexpr (rigth); (* emit the struc-value *)
end;


cendvariable:
begin (* made by 'cendvariable', if after function call *)
emitexpr (rigth);  (* note: unary operator *)
emit (xendfunccall);
end;


cstrucarray,
cstrucrecord:
begin
emitboth;  (* emit previous struc-elements and value component *)
emitid (xstruc, op_typename);
end;


cendstruc:
begin
emitexpr (rigth);  (* note: it is an unary operator *)
emit (xendstruc);
end;

cendassign:
begin
emit (xassignstat);
emitexpr (left);   (* variable *)
emit (xbecomes);
emitexpr (rigth);  (* expression *)
emit (xassign);
end;

cendexchange:
begin
emit (xexchangestat);
emitexpr (left);   (* lefthand variable *)
emit (xbecomes);
emitexpr (rigth);  (* rigthhand variable *)
emit (xexchange);
end;

crangefirst:
begin
emitexpr (left);  (* first range *)
emit (xgetexpr);
emitexpr (rigth); (* last range *)
end;

cplus:   emit_arith (xadd);
cminus:  emit_arith (xsub);
cstar:   emit_arith (xmul);
cslash,                    (* until further same as div... *)
cdiv:    emit_arith (xdiv);
cmod:    emit_arith (xmod);
ceq:     emit_arith (xeq);
cne:     emit_arith (xne);
clt:     emit_arith (xlt);
cle:     emit_arith (xle);
cgt:     emit_arith (xgt);
cge:     emit_arith (xge);
cin:     emit_arith (xin);
cor:     emit_arith (xor);
cand:    emit_arith (xand);
cnot:    emit_arith (xnot);
cuminus: emit_arith (xneg);
cuplus:  emitexpr (rigth);  (* blind operator *)


end (* case opcode of opand *)
otherwise
if compilertest then
comp_error (unknown_opcode);

if testoutput then continue_line;

if expr_release then
begin
if op_value <> nilstring then
release_string (op_value);
if expr = stacktop then
stacktop := next;
next := freeopands;
freeopands := expr;
end;

expr_level := expr_level - 1;

end; (* with expr *)

end; (* procedure emitexpr *)



procedure emit_and_release (expr: opandptr);
(* emits - and releases - the expression *)
begin
expr_release := true;
emitexpr (expr);
expr_release := false;

(* in case stacktop has been updated, now update nexttop *)
nexttop := opands [ stacktop ] . next;

end;



procedure prepare_statement;
(* the procedure will emit all pending expressions  *)
(* .... but maybe it should rather test for pending expressions ? *)
(**)
(* furthermore it will set a flag, used to determine how *)
(*   a function-identifier should be interpreted         *)

begin
while stacktop <> nilopand do
emit_and_release (stacktop);
before_assign := true;
end;



procedure prepare_expression;
(* works in coorporation with prepare-statement *)

begin
before_assign := false;
end;



procedure emittype (xtypename: nameptr);
label 10; (* loop in cscalar *)
var name: nameptr;
begin

with names [ xtypename ] do
with types [ typ ] do
begin 

if emitted then
emitid (xtype, xtypename)
else
begin
(* this is the first time the typename is emitted *)
(*   emit the whole definition *)
emitted := true;

case typekind of

calias:
begin
(* output:  <type>  redeftype(nix) *)
emittype (element);
emitid (xredeftype, xtypename);
end;



cscalar:
begin
(* output:  ( scalarid(nix) )*  scalardef(nix)   *)
name := element; (* first scalar name of scalartype *)

10: (* loop *)
with names [ name ] do
if namekind = cscalarelem then
(* the scalar names are in the common namelist *)
if typename = xtypename then
begin
emitid (xscalarid, name);
name := nextname;  (* follow chain *)
if testoutput then continue_line;
goto 10;  (* goto loop *)
end;

emitid (xscalardef, xtypename);
end;



csubrange:
begin
(* output:  <expr> <expr> subdef(typenix, elementnix) *)
emit_and_release (subexpr);  (* emit both expressions *)
subexpr := nilopand;
emitid (xsubdef, xtypename);
emitin (ord (index) );  (* nix of element type *)
end;



cpointer:
begin
(* output:  <type>  pointerdef(nix)  *)
emittype (element);
emitid (xpointerdef, xtypename);
end;



creadonly:
begin
(* output:  <type>  frozendef(nix)  *)
emittype (element);
emitid (xfrozendef, xtypename);
end;



carray:
begin
(* output:  <indextype> <elementtype> (packed) arraydef(nix)  *)
emittype (index);
emittype (element);
if packflag (* of array type *) then
emitid (xpackedarraydef, xtypename)
else
emitid (xarraydef, xtypename);
end;



crecord:
begin
(* output:                                   *)
(*   packedrecord/record                     *)
(*     ( fieldid(nix)  <type>  fielddef )*   *)
(*   recdef(nix)                             *)
if packflag (* of record type *) then
emit (xpackedrecord)
else
emit (xrecord);

name := element;  (* first name in field list *)
while name <> nilname do
with names [ name ] do
begin
if namekind (* of fieldname/local typedef *) = crecfield then
begin
if testoutput then continue_line;
emitid (xfieldid, name);
emittype (typename);
emit (xfielddef);
end;
name := nextname;  (* follow chain *)
end;

emitid (xrecdef, xtypename);

end;



cset:
begin
(* output:  <type>  setdef(nix)  *)
emittype (element);
emitid (xsetdef, xtypename);
end;



cpool:
begin
(* output:  <expr> <type> pooldef(nix)  *)
emit_and_release (subexpr);
subexpr := nilopand;
emittype (element);
emitid (xpooldef, xtypename);
end;



cinteger:
emitid (xinteger, xtypename);



creal:
emitid (xreal, xtypename);



cniltype:
emitid (xniltype,xtypename);



cerrorkind:
emitid (xerrortype, xtypename);



ctext:
emitid (xstringtype, xtypename);



end (* case typekind *)
otherwise
if true then write(' unknown typekind = ', ord (typekind)) else
comp_error(unknown_typekind);

end; (* if not emitted yet *)

end; (* with typ/typename *)

end; (* procedure emittype *)

(*QQQ*)

procedure emitformal (plist: nameptr);
(* output:  ( paramid(nix) <type> cparam/vparam )*  *)
procedure emit_one_formal (xparamkind: pass3codes);
begin
if testoutput then continue_line;
emitid (xparamid, plist);
emittype ( names [ plist ] . typename );
emit (xparamkind);
end;
begin

while plist <> nilname do
with names [ plist ] do (* namenode of current parameter *)
begin
case namekind of
cfuncval: emit_one_formal (xvarparam);     (* function value *)
cvaluep:  emit_one_formal (xvalueparam);      (* value parameter *)
cvarp:    emit_one_formal (xvarparam);        (* var parameter *)
ctype,        (* implicit type decls *)
cundeclared,  (* undeclared typenames *)
cscalarelem:  (* scalar-elems of implicit typedecls *)
; (* no action *)
end
otherwise
comp_error(unknown_paramkind);

plist := nextname;  (* follow chain *)
end;  (* while/with plist *)

end;



procedure emitroutinehead (xname: nameptr);
(* 'xname' is the namenode of the routine *)

(* if this is second emit of routinehead, i.e. earlier was 'forward' *)
(*    then emit short description,
(*    otherwise emit the complete routine head *)

begin

with names [ xname ] do (* namenode of routine *)
if forward_decl then
begin
case namekind of
cprocess,
cprocedure: emitid (xsecprocid, xname);
cfunction:  emitid (xsecfuncid, xname);
end
otherwise
if compilertest then comp_error (unknown_namekind);
end
else
begin

case namekind of
cprocess:   emitid (xprocessid, xname);
cprocedure: emitid (xprocid, xname);
cfunction:  emitid (xfuncid, xname);
end
otherwise
comp_error(unknown_routinekind);

if namekind = cprocess then
begin
(* emit the son var nix *)
emitin (ord (nextname) ); (* 'sonvar' is next to 'processname' *)
emitin ( ord (son_typename) );  (* type-nix of 'sonvariable' *)
end;

(* emit external name of the routine *)
emit_extname (opand_procname);

(* emit formallist *)
emitformal (params);

end; (* if first emission of this routine head *)

(* set flag to look for first local declaration *)
expecting_block := true;

end; (* procedure emitroutinehead *)



function testprocessparam (xtypename: nameptr; dangerous: boolean) : boolean;
(* returns true, if the type contains (or may reach via pointers) *)
(*   shadow, reference or pool                                    *)
(* or                                                             *)
(*   a pointer, which it not protected                            *)

var
no_of_pointers : typeptr;  (* counts number of tested pointer-types *)
checked_pointers : packed array [ typeptr ] of nameptr;  (* contains typenames *)
param_error : boolean;

procedure test (xtypename: nameptr; dangerous: boolean);
var
field: nameptr;
ptr_index: typeptr;

begin
if not param_error then
with names [ xtypename ] do  (* namenode of the type to be tested *)
with types [ typ ] do      (* corresponding typenode *)
if [ t_shadow, t_reference, t_pool ] * contents (* of typenode *) <> [] then
param_error := true
else
if t_pointer in contents (* of typenode *) then
case typekind (* of typenode *) of
carray:
test (element, dangerous);
crecord:
begin
field := element;
while field <> nilname do
with names [ field ] do  (* namenode of field *)
begin
test (typename, dangerous);
field := nextname;
end;
end;
creadonly:
test (element, false);
cpointer:
if dangerous then
param_error := true
else
(* test that the outpointed type has'nt been tested already *)
(* i.e. 'recursive' pointer *)
for ptr_index := niltype to no_of_pointers do
if ptr_index = no_of_pointers then
begin
checked_pointers [ no_of_pointers ] := element;
no_of_pointers := no_of_pointers + 1;
test (element, true);  (* from now on: really dangerous ... *)
end
else
if checked_pointers [ ptr_index ] = element then
ptr_index := no_of_pointers;  (* force fast exit of loop *)

end (* case *)
otherwise
if compilertest then comp_error (unknown_typekind);

end; (* procedure test *)

begin (* body of testprocessparam *)
no_of_pointers := niltype;
param_error := false;
test (xtypename, dangerous);
testprocessparam := param_error;
end; (* procedure testprocessparam *)

(*QQQ*)

(* procedures for handling of label declarations/definitions/use *)

procedure pseudodefine (xscopeno: labelrange; xspix: spixrange);
(* the label-definition is inserted in the local label-list *)

var
curlabel: labelptr;
multdef : boolean;

begin

(* test for multiple definition *)

curlabel := lastlabel;
multdef  := false; (* suppose ok *)

while curlabel <> nillabel do
with labels [ curlabel ] do
begin
if labelspix = xspix then
begin
multdef  := true;
multflag := true; (* mark the labelnode as inconsistent *)
end;
curlabel := prevlabel;  (* follow chain backwards *)
end;

(* allocate and initialize a new labelnode *)

curlabel := alloc_label;
with labels [ curlabel ] do
begin
labelspix  := xspix;
labelscope := xscopeno;
labelstate := outside_scope;
multflag   := multdef; (* mark it as (in)consistent *)
used_from_inner_routines := false;

prevlabel  := lastlabel;  (* insert in front of other label defs *)
lastlabel  := curlabel;

(* test for declaration on current namelevel *)
searchspix (xspix, namelevel, namelevel);
labelname := retrieved_name;  (* = nilname, if undeclared *)
with names [ labelname ] do
if namekind <> clabel then
labelname := nilname;

(* test for use from inner routines *)
(*   if so, it better be defined at outermost labelscope *)
if labelname <> nilname then
with names [ labelname ] do
if usedlevel >= lowestlevel then
(* it has been used *)
used_from_inner_routines := true;

end; (* with curlabel *)

end; (* procedure pseudodefine *)



procedure initlabels;
(* called at enddeclaration, at 'begin' *)
(* initializes the labelnodes from 'pass3labels' *)

var lab: labelptr;

begin

(* set all labelnodes in free-list *)
freelabels := nillabel;
for lab := nillabel to max_labels do
with labels [ lab ] do
begin
prevlabel := freelabels;
freelabels := lab;
end;
lastlabel := nillabel; (* initialize list of defined labels *)

while convtable [ labelin (* = rectype in labelfile *) ] = clabeldef do
pseudodefine (labelin (* = scopeno *), labelin (* = spix *) );

end; (* procedure initlabels *)



procedure definelabel (xscopeno: labelrange; xspix: spixrange);
(* searches the local labels to retrieve the wanted label *)

var
curlabel: labelptr;

begin

(* check the list of defined labels to produce errors *)

curlabel := lastlabel;
while curlabel <> nillabel do
with labels [ curlabel ] do
if labelspix = xspix then
begin
if multflag then
error (multiple_defined_label);
if labelname = nilname then
error (label_not_declared);
if used_from_inner_routines then
error (label_used_from_inner);
(* nbnbnb hvem checker erkl paa yderste scope ? *)

(* output:  label(labelnix) *)
emitid (xlabel, labelname);

curlabel := nillabel;
end
else
curlabel := prevlabel;

end;



procedure set_label_state (setscope: boolean);
(* used by: begin/end-label-scope *)
(* the labelstates, belonging to current labelscope are set *)
(*   to inside/outside label scope *)
var
curlabel: labelptr;

begin

curlabel := lastlabel;
while curlabel <> nillabel do
with labels [ curlabel ] do
begin

(* first: reopen any labels, hidden by this labelscope *)
if labelstate = hidden_by_lock_or_channel then
if hiddenscope = cur_labelscope then
labelstate := inside_scope;  (* it must be: clear-scope *)

(* second: hide all open labels, if start of lock or channel statements *)
if start_of_protected then
(* first setscope in lock-channel *)
if labelstate = inside_scope then
begin
labelstate  := hidden_by_lock_or_channel;
hiddenscope := cur_labelscope;
end;

(* third: open or close label, when belonging to this labelscope *)
if labelscope = cur_labelscope then
if setscope then
labelstate := inside_scope
else
labelstate := outside_scope;
curlabel := prevlabel;
end; (* while/with curlabel *)

start_of_protected := false;

end; (* procedure set_label_state *)



function check_label (labname: nameptr) : pass3errors;
(* used when referring to a labelname *)

var
curlabel: labelptr;

begin
check_label := noerror; (* suppose found and ok *)

with names [ labname ] do
begin
if namekind <> clabel then
check_label := not_label_name
else
begin
(* check locally declared label *)

curlabel := lastlabel;
while curlabel <> nillabel do
with labels [ curlabel ] do
begin
if labelspix = spix (* of labelname *) then
begin
(* it was locally declared, now check the labelscope *)
case labelstate of
outside_scope:
check_label := label_used_outside_scope;
(* i.e. goto leading into control structure *)
hidden_by_lock_or_channel:
check_label := label_defined_outside_lock_or_channel;
(* i.e. goto out of lock or channel statement *)
end otherwise;
if multflag then
check_label := erroneous_label;
if labelname = nilname then
check_label := label_not_locally_declared;
end;

curlabel := prevlabel;
end; (* while/with curlabel *)

(* note: *)
(*   if label is global to current block, it will be *)
(*   checked later, that the label is defined in the *)
(*   outermost labelscope of that block              *)

end; (* if namekind = label *)

end; (* with labname *)

end; (* procedure checklabel *)



procedure testvalue (opand: opandptr);
(* tests that the opand posseses a value *)

label 98;

begin

with opands [ opand ] do
case opcode of
cid:
with names [ op_name ] do (* namenode of identifier *)

(* certain of the namekinds are illegal in expressions *)
case namekind of
clabel,
cprocess,
cprocedure,
ctype,
cprefix:
goto 98; (* error *)

cundeclared,  (* don't cause error-cascades *)
cvar,
cvarp,
cvaluep,
cfuncval,
cscalarelem,
cconstant: ; (* ok *)

cfunction:
make_call (opand); (* assume that the paramlist was empty *)

end otherwise; (* case *)

cindex,
cfield,
cendstruc,
cuparrow,
cliteral,
cfcall,      (* when fielding or indexing on function value *)
cendvariable,   (* after function call and any fielding or indexing *)
cfunctemp,  (* used when describing 'processcall' as actual param *)
cendsetlist,
cdoubleparam,
cerrorarg,
cplus, cminus, cstar, cslash, cdiv, cmod,
ceq, cne, clt, cle, cgt, cge, cin, cor, cand, cnot,
cuminus, cuplus: ; (* ok *)

end (* case opcode *)
otherwise
98:  (* error *)
begin
error (illegal_in_expr);
op_typename := error_typename;   (* try to prevent error-cascades *)
end;

end; (* procedure testvalue *)



procedure testvariable (opand: opandptr);
(* tests that the opand may be used as <variable> *)

label 99; (* opand ok *)

begin

with opands [ opand ] do

case opcode of

cindex,
cfield,
cuparrow:
goto 99; (* ok *)

cid:
with names [ op_name ] do  (* namenode of variable *)
case namekind (* of namenode *) of
cfunction:
make_call (opand); (* terminate an erroneous parameter-less function *)
cundeclared,  (* don't cause error-cascades *)
cvar,
cvarp, cvaluep, cfuncval:
goto 99; (* ok *)
end otherwise (* continue *); (* case namekind *)

end otherwise; (* case opcode *)

error (not_variable);
99: ; (* ok *)

end; (* procedure testvariable *)



function testfrozen (opand: opandptr): boolean;
var all_tested : boolean;

begin
testfrozen := false;
all_tested := false;

repeat
with opands [ opand ] do
with names [ op_typename ] do  (* typename of operand *)
with types [ typ ] do        (* corresponding typenode *)
if typekind = creadonly then
begin
testfrozen := true;
all_tested := true;
end
else
(* follow typenodes backwards for records and arrays *)
(* to search for 'readonly' types *)
case opcode (* of opand *) of
cindex : opand := left;  (* follow the array-operand *)
cfield : opand := rigth; (* follow the record-operand *)
end (* case *)
otherwise
all_tested := true;

until all_tested;

end; (* procedure testfrozen *)



procedure testassignable (opand: opandptr);
(* generates an error, if operand cannot be assigned *)
begin
testvariable (opand);  (* it has to be a variable *)
with opands [ opand ] do
with names [ op_typename ] do  (* namenode of operand-type *)
with types [ typ ] do        (* corresponding typenode *)
if (contents (* of typenode *)
* [ t_semaphore, t_pool, t_reference, t_shadow, t_readonly ] <> [])
or testfrozen (opand) then
error (not_assignable);
end; (* procedure testassignable *)



procedure testexchangable (opand: opandptr);
(* generates en error, if operand cannot be exchanged *)
begin
testvariable (opand);  (* it has to be a variable *)
with opands [ opand ] do
with names [ op_typename ] do  (* namenode of operand-type *)
with types [ typ ] do        (* corresponding typenode *)
if contents (* of typenode *)
* [ t_semaphore, t_pool, t_readonly ] <> [] then
error (not_exchangeable);
end; (* procedure testexchangable *)



procedure testunpacked (opand: opandptr);
(* generates an error, if the operand is packed *)
begin
with opands [ opand ] do
if op_packflag then
error (variable_may_not_be_packed);
end; (* procedure testunpacked *)



procedure resolve_named_type (
xxtypename: nameptr;
var xtypename: nameptr;
var xelement: nameptr;
var xtypekind: codes);  (* ************** *)  forward;  (* ********* *)



procedure resolvetype (
opand: opandptr;
var xtypename: nameptr;
var xelement: nameptr;
var xtypekind: codes);
label 10;

var local_typename: nameptr;
local_element: nameptr;
local_kind: codes;

begin

testvalue (opand);  (* the operand must posses a value *)

local_typename := opands [ opand ] . op_typename;

10: (* after stripping of superflous type inf *)

with names [ local_typename ] do
with types [ typ ] do

begin

if typekind = csubrange then
begin
local_typename := index;
goto 10;
end;
if typekind = creadonly then
begin
local_typename := element;
goto 10;
end;

xtypename := local_typename;
xtypekind := typekind;
xelement  := element;

if xtypekind = cset then
(* resolve element-type *)
resolve_named_type (element, xelement, local_element, local_kind);
if xtypekind = calias then
resolve_named_type (element, local_typename, xelement, xtypekind);

end; (* with names,types *)

end; (* procedure resolvetype *)



procedure resolve_named_type (
xxtypename: nameptr; (* typename to be resolved *)
var xtypename: nameptr;
var xelement: nameptr;
var xtypekind: codes);
begin
(* seperates the type into its components, stripping subrange etc. *)
opands [ nilopand ] . op_typename := xxtypename; (* use as working cell *)
resolvetype (nilopand, xtypename, xelement, xtypekind);
end;



function unstripfrozen (xtypename: nameptr): nameptr;
label 10;

begin

10: with names [ xtypename ] do   (* namenode of type *)
with types [ typ ] do       (* corresponding typenode *)
if typekind = creadonly then
begin
xtypename := element;  (* follow typename-chain *)
goto 10;  (* repeat search for several 'frozen' in row *)
end;

unstripfrozen := xtypename;   (* deliver unstrip'ed typename *)

end;



procedure equaltypes (leftop, rigthop: opandptr; wanted_typename: nameptr; errorcode: pass3errors);

begin
resolvetype (leftop, lefttypename, leftelement, leftbasekind);
resolvetype (rigthop, rigthtypename, rigthelement, rigthbasekind);

if (lefttypename <> rigthtypename) or
(lefttypename <> wanted_typename) then
error (errorcode);

end;



procedure assure (opand: opandptr; wanted_typename: nameptr; errorcode: pass3errors);

(* modifies 'optypename' if any error is produced *)

begin
resolvetype (opand, exprtypename, exprelement, exprbasekind);
if exprtypename <> wanted_typename then
if exprbasekind <> cerrorkind then  (* suppress error-cascades *)
begin
error (errorcode);
with opands [ opand ] do
op_typename := error_typename;
end;
end;



procedure testindex (var xtypename: nameptr);
(* tests that the typekind is enumeration kind *)

begin
resolve_named_type (xtypename, exprtypename, exprelement, exprbasekind);
case exprbasekind of

cerrorkind,  (* don't cause error-cascades *)
cinteger,
cscalar: ; (* ok *)

end

otherwise
begin
error (not_index_type);
xtypename := error_typename;
end;

end; (* procedure testindex *)



function testenumeration (opand: opandptr): nameptr;
(* works as 'testindex', but works on an opand *)
var local_typename: nameptr;

begin
testvalue (opand);
with opands [ opand ] do
begin
local_typename := op_typename;
testindex (local_typename);
op_typename := local_typename;
testenumeration := op_typename;
end;

end; (* procedure testenumeration *)



procedure set_procedure;
(* handles set-values *)

begin

case rectype of

csetlist:
(* prepare s-element or m-element to be binary operators *)
newopand (csetlist, nil_typename);

cs_element,
cm_element:
begin
rigthtypename := testenumeration (stacktop);
if rectype = cm_element then
begin
lefttypename := testenumeration (nexttop);
if lefttypename <> rigthtypename then
error (mixed_types_in_setlist);
oper (binary, rectype, rigthtypename);
rectype := cnocode;  (* let rectype describe simple binding *)
end;

(* compare element-type with previous type in setlist *)
with opands [ nexttop ] do  (* previous setlist-element or dummy-element *)
if op_typename (* of nexttop *) <> rigthtypename then
if op_typename <> nil_typename then  (* suppress error for very first element *)
error (mixed_types_in_setlist);

oper (binary, rectype, rigthtypename);

end;


cendsetlist:
begin
(* construct a typenode: set of <typename> *)
exprtypename := alloc_namenode;
with names [ exprtypename ] do
begin
namekind := ctype;
typename := nil_typename;
typ      := alloc_typenode;
with types [ typ ] do
begin

typekind := cset;
element  := opands [ stacktop ] . op_typename;
contents := [ t_simple ];
end;
end; (* with exprtypename *)

oper (unary, cendsetlist, exprtypename);

end;

end (* case rectype *)
otherwise
if compilertest then
comp_error (unknown_rectype);

end; (* procedure set-procedure *)



procedure export_procedure;

var
errortxt: pass3errors;
opand:    opandptr;
expkind:  (undefkind, constkind, varkind);

begin

case rectype of

cexport:
begin
(* save the external name, to be emitted later *)
opand_procname := take_stacktop;
end;

cexportvalue,
cexportsize,
cexportdisp,
cexportoffset,
cexportaddr:
begin
(* opand_procname holds external name *)
(* stacktop holds variable to be exported *

(* exportvalue: only const *)
(* exportsize : const or var *)
(* exportdisp : field (of const or var) *)
(* exportoffset: only var *)
(* exportaddr : const or var *)

resolvetype (stacktop, exprtypename, exprelement, exprbasekind);

if exprbasekind <> cerrorkind then
begin
(* find the identifier, in front of any possible fields *)
opand := stacktop;
while opands [ opand ] . opcode = cfield do
opand := opands [ opand ] . rigth;

errortxt := noerror; (* suppose no errors... *)

(* decide kind of identifier *)
with opands [ opand ] do  (* opcode = 'cid' ... *)
with names [ op_name ] do (* namenode of identifier *)
case namekind (* of identifier *) of
cvar,
cvarp,
cvaluep,
cfuncval: expkind := varkind;
cconstant: expkind := constkind;
end otherwise expkind := undefkind;

case rectype of
cexportvalue:
if expkind <> constkind then
errortxt := const_export_only;
cexportsize,
cexportdisp,
cexportaddr:
if (expkind <> constkind) and (expkind <> varkind) then
errortxt := const_or_var_export_only
else
if rectype = cexportdisp then
if opand = stacktop (* i.e. no field-operators *) then
errortxt := disp_export_must_have_fields;
cexportoffset:
if expkind <> varkind then
errortxt := var_export_only;
end; (* case *)

if errortxt <> noerror then
error (errortxt);

end; (* if no error-operand *)

case rectype of
cexportvalue : emit (xexportvalue);
cexportsize  : emit (xexportsize);
cexportdisp  : emit (xexportdispl);
cexportoffset: emit (xexportoffset);
cexportaddr  : emit (xexportaddr);
end;

emit_extname (opand_procname);
emit_and_release (stacktop);
emit (xendexport);

end;
end (* case rectype... *)
otherwise if compilertest then comp_error(unknown_rectype);

end; (* procedure export-procedure *)



function allow_text_literals: boolean;
(* implicit parameters: left... and rigth... *)
(* returns true, if one is textliteral and the other is ( text or array of char *)
begin

allow_text_literals := (
((leftbasekind  = ctext) and (rigthbasekind = ctext)) or
((leftbasekind  = ctext) and (rigthbasekind = carray) and (rigthelement = char_typename)) or
((rigthbasekind = ctext) and (leftbasekind  = carray) and (leftelement  = char_typename))
);

end;



procedure relation (rel: codes);
(* creates a binary operation node, working on top and nexttop *)
(* in case of errors, the resulting type etc will be set to error-values *)

var rel_error: pass3errors;
begin

resolvetype (nexttop, lefttypename, leftelement, leftbasekind);
resolvetype (stacktop, rigthtypename, rigthelement, rigthbasekind);

rel_error := noerror;

if rigthbasekind = cerrorkind then
leftbasekind := rigthbasekind;  (* suppress error-cascades *)

case leftbasekind of

cscalar:
(* both must be scalars, belonging to the same scalar-type *)
if (leftbasekind <> rigthbasekind) or
(leftelement <> rigthelement) then
rel_error := relation_error;

carray,
ctext,
crecord:
(* both must belong to the same type, and only '=' or '<>' *)
if ((lefttypename <> rigthtypename) and (not allow_text_literals)) or 
((rel <> ceq) and (rel <> cne)) then
rel_error := relation_error
else
(* test that the record does'nt contains system types *)
with names [ lefttypename ] do
with types [ typ ] do  (* typenode of one of the operands *)
if contents * [ t_semaphore, t_pool, t_reference, t_shadow ] <> [] then
rel_error := relation_error;

cpointer:
(* both must be pointers to same type, and only '=' or '<>' *)
(* note: especially used by the monitor-process... *)
if (leftbasekind <> rigthbasekind) or
(leftelement <> rigthelement) or
((rel <> ceq) and (rel <> cne)) then
rel_error := relation_error;

cset:
(* both must be sets, with same elementtypes (or empty) *)
if (leftbasekind <> rigthbasekind) (* both 'set' *) or
((leftelement <> rigthelement) (* with same element-type *) and
(leftelement <> nil_typename) (* allow empty sets *) and
(rigthelement <> nil_typename)) or
(rel = clt) or (rel = cgt) then
rel_error := relation_error;

cerrorkind: ; (* anything allowed *)

cinteger,
creal:
(* simple version: demand same type *)
if leftbasekind <> rigthbasekind then
rel_error := relation_error;

end
otherwise
rel_error := relation_error;

(* perform the binary operation *)
if rel_error <> noerror then
begin
oper (binary, rel, error_typename);
error (rel_error);
end
else
oper (binary, rel, boolean_typename);

end; (* procedure relation *)



procedure arithop (operator: codes);
(* creates a binary operation node, working on stacktop and nexttop *)
(* in case of errors, the resulting type etc will be set to error-values *)

var arith_error: pass3errors;

begin

resolvetype (nexttop, lefttypename, leftelement, leftbasekind);
resolvetype (stacktop, rigthtypename, rigthelement, rigthbasekind);

arith_error := noerror;

if rigthbasekind = cerrorkind then
begin
lefttypename := error_typename;
leftbasekind := rigthbasekind;
end;

if leftbasekind <> rigthbasekind then
arith_error := arithmetic_error
else
case leftbasekind of
cinteger:
if operator = cslash then
arith_error := real_division_not_implemented;
creal:
arith_error := real_not_implemented;
cset:
if ((leftelement <> rigthelement) (* sets with same elementtypes *) and
(leftelement <> nil_typename) (* allow empty sets *) and
(rigthelement <> nil_typename)) or
(operator = cslash) then
arith_error := arithmetic_error;

cerrorkind: ; (* allow anything *)

end
otherwise
arith_error := arithmetic_error;

if arith_error <> noerror then
begin
oper (binary, operator, error_typename);
error (arith_error);
end
else
oper (binary, operator, lefttypename);

end; (* procedure arithop *)



procedure test_value_compatible (errorcode: pass3errors);
(* implicit params: left... and rigth... *)

begin

if rigthbasekind = cerrorkind then
leftbasekind := rigthbasekind;

case leftbasekind of

carray:
(* allow rigth to be text literal, when left is array of char *)
if not allow_text_literals then
error (errorcode);

cpointer:
(* both must be pointers to same type ( or to 'niltype' ) *)
if (leftbasekind <> rigthbasekind) or
((leftelement <> rigthelement) (* to same type *) and
(leftelement <> nil_typename) (* allow pointers to niltype *) and
(rigthelement <> nil_typename)) then
error (errorcode);

cset:
(* both must be sets, with same componenttypes (or empty) *)
if (leftbasekind <> rigthbasekind)  (* both sets *) or
((leftelement <> rigthelement) (* with same element-type *) and
(rigthelement <> nil_typename)) (* allow rigth to be empty set *) then
error (errorcode);

cerrorkind: ; (* anything allowed *)

end
otherwise
error (errorcode);

end; (* procedure test_value_compatible *)



procedure test_var_compatible (errorcode: pass3errors);
(* implicit params: left... and rigth... *)

begin

if rigthbasekind = cerrorkind then
leftbasekind := rigthbasekind;

case leftbasekind of

cpointer:
(* both must be pointers, to same type (or to 'niltype') *)
if (leftbasekind <> rigthbasekind) or
((leftelement <> rigthelement) (* pointer to same type *) and
(leftelement <> nil_typename) (* allow pointers to niltype *) and
(rigthelement <> nil_typename)) then
(* suppress error message for the 'nil'-function, with actual shadow ... *)
if (leftelement <> nil_typename) or (rigthtypename <> shadow_typename) then
error (errorcode);

cpool:
(* both must be pool, but don't care about 'of-type' *)
if leftbasekind <> rigthbasekind then
error (errorcode);

cerrorkind: ; (* anything allowed *)

end
otherwise
error (errorcode);

end; (* procedure test_var_compatible *)



procedure testinitialize (xtypename: nameptr; errorcode: pass3errors);
(* tests that stacktop may be 'assigned' to a *)
(*  variable of the given type *)

begin

(* special test for 'skipparam' *)
with opands [ stacktop ] do
if opcode <> cskipparam then
begin
(*the type-comparison is omitted in case of 'skipparam' *)

resolve_named_type (xtypename, lefttypename, leftelement, leftbasekind);
resolvetype (stacktop, rigthtypename, rigthelement, rigthbasekind);

if lefttypename <> rigthtypename then
test_value_compatible (errorcode);

end;

end;



procedure testrange (xtypename: nameptr);
(* inserts a 'range-test', in case the type is a subrange *)

var local_typename: nameptr;

begin

local_typename := unstripfrozen (xtypename);
with names [ local_typename ] do  (* namenode of simplified type *)
with types [ typ ] do           (* corresponding typenode *)
if typekind = csubrange then
oper (unary, crange, xtypename);

end;



procedure beginactual;
(* called on the left paranthesis in a parameter-list *)

label 1, 2;

begin

1: (* repeat after parameter-less function-call *)
pushcall; (* because of nested calls *)

(* decide the kind of argument-list: index, parameter, strucconst *)
(* stacktop describes the 'owner' *)

with opands [ stacktop ] do
case opcode of
cid:
with names [ op_name ] do  (* namenode of 'owner' *)
case namekind (* of owner *) of
cprocess,
cprocedure,
cfunction:
begin
prepare_call (stacktop);
if namekind = cfunction then
if empty_paramlist (params) then
begin
(* the function did'nt have any formal parameters *)
(* therefor the arglist must be an index-list     *)
terminate_call (stacktop);  (* make the function-call *)
goto 1;                    (* start all over again *)
(* note: this time the arglist will be taken as an index-list *)
end;
end;
ctype:
begin
(* the list is a struc-constant *)
arglist_owner := op_name;  (* remember the namenode of the type *)
with types [ typ ] do        (* typenode of the type *)
case typekind of
carray:
begin
argkind    := cstrucarray;
curformal  := element;     (* typename of array elements *)
end;
crecord:
begin
argkind    := cstrucrecord;
curformal  := element;     (* first of field-name list *)
end;
end
otherwise
begin
(* only array-types and record-types may be struc-consts *)
argkind := cerrorarg;
error (type_must_be_record_or_array);
end; (* case typekind *)
end; (* case namekind = ctype *)

end (* case namekind *)

otherwise

begin
2: ;   (* the argumentlist must be an index-list *)
argkind    := cindex;
curformal  := op_typename;  (* typename ougth to be name of array-type *)
end;

end (* case opcode *)
otherwise goto 2; (* assume index in all other cases *)

end; (* procedure beginactual *)



procedure act_param;
(* called on: cdoubleparam-cactualparam *)

label 5, 10;

var sonvar_name: nameptr;
loc_tempvar: nameptr;

begin

(* first bind any possible doubleparam to a single one *)
if rectype = cdoubleparam then
begin
(* nexttop must be integer expression *)
assure (nexttop, integer_typename, repetition_type);
testvalue (stacktop);
with opands [ stacktop ] do
oper (binary, cdoubleparam, op_typename (* propagate typename... *) );
end;


(* argkind now describes how to interprete the actualarg *)

case argkind of
cerrorarg,
cindex:
begin
(* curformal is typename of (supposed) array *)
(* test that its typekind is 'carray'        *)

(* doubleparam is not allowed *)
if rectype <> cactualparam then
error (double_param_only_in_struc_const);

curformal := unstripfrozen (curformal);  (* in case the array itself was frozen *)

with names [ curformal ] do     (* namenode of type *)
with types [ typ ] do         (* corresponding typenode *)
begin
if argkind <> cerrorarg then   (* suppress error-cascade *)
case typekind (* of typenode *) of

cerrorkind: ; (* nothing, but suppress error-cascade *)

carray:
begin
with opands [ stacktop ] do
if opcode = cskipparam then
error (skipparam_only_in_struc_const)
else
begin
(* get basekind of indextype of the array *)
resolve_named_type (index, lefttypename, leftelement, leftbasekind);
(* get basekind of actual index expression *)
resolvetype (stacktop, rigthtypename, rigthelement, rigthbasekind);

if lefttypename <> rigthtypename then
error (incompatible_index);
end;
end;
end
otherwise
begin
error (subscript_after_nonarray);
argkind := cerrorarg;
end;

(* bind the index-expression to the owner *)
oper (binary, argkind, element (* typename of array-element *));
with opands [ stacktop ] do
begin
op_name := curformal;  (* type-name of array *)
op_packflag := packflag (* from typenode of the array *);
end;

(* let curformal be typename of array-element *)
curformal := element;

end; (* with curformal *)

end; (* argkind = index *)

cargument:
begin
(* curformal is name in formal param list *)
while curformal <> nilname do
(* skip implicit types and function-return-value *)
with names [ curformal ] do
begin
case namekind (* of formal name *) of
cscalarelem,
ctype,
cundeclared,  (* undeclared typename *)
cfuncval: ; (* skip *)

cvarp:
begin
(* check var parameter *)

(* first test if the actual is a process-name *)
with opands [ stacktop ] do
if opcode = cskipparam then
begin
error (skipparam_only_in_struc_const);
goto 5;
end
else
if opcode = cid then
with names [ op_name ] do  (* namenode of identifier *)
if namekind = cprocess then
begin
(* it was really a process-name *)
(* exchange the identifier with the corresponding son-variable *)
op_name := nextname (* of processname *);
with names [ op_name ] do  (* namenode of son-var *)
op_typename := typename (* of sonvar *)
end;

(* actual must be unpacked variable *)
testvariable (stacktop);
testunpacked (stacktop);

(* the formaltype and the actualtype must match exactly, except for 'frozen' *)
with opands [ stacktop ] do
(* now: typename    = formal typename *)
(*      op-typename = actual typename *)
if typename <> op_typename then
begin
(* try to remove readonly-marks from formal and actual types *)
if unstripfrozen (typename) <> unstripfrozen (op_typename) then
begin
resolve_named_type (typename (* of curformal *), lefttypename, leftelement, leftbasekind);
resolvetype (stacktop, rigthtypename, rigthelement, rigthbasekind);
test_var_compatible (illegal_var_param_substitution);
end
else
(* it helped... but in this case formal must be readonly *)
if typename = unstripfrozen (typename) then
(* formal was'nt frozen, but actual was *)
error ( actual_may_not_be_frozen);
end; (* if not direct match *)
goto 5;
end;

cvaluep:
begin
(* check value parameter *)

(* first test if the actual is a process-call *)
make_call (stacktop);  (* if parameter-less *)
with opands [ stacktop ] do
if opcode = cskipparam then
begin
error (skipparam_only_in_struc_const);
goto 5;
end
else
if opcode = ccallprocess then
begin

count_processparam := count_processparam + 1;

(* insert extra opands to describe the process-'call' as normal argument *)
sonvar_name := op_name;  (* get the name from the 'callprocess'-node *)

(* get a temporary namenode for describing the 'processrec' *)
loc_tempvar := functempvar;  (* save the global variable *)
functempvar := alloc_namenode;
insert_functype (processrec_typename);

(* bind the processcall to the normal paramlist *)
oper (binary, cprocessargument, functempvar (* = temp variable *) );
with opands [ stacktop ] do
op_name := sonvar_name;

(* create an operand, with 'processrec' type *)
newopand (cfunctemp, nilname (* irrell typename *));
with opands [ stacktop ] do
op_name := functempvar;

(* now: stacktop is a functemp-var, of processrec type *)
functempvar := loc_tempvar;  (* restore the global variable *)
end;

with names [ curformal ] do
begin

if typename (* of curformal *) = nil_typename then
begin
(* test certain special std-functions *)

if (arglist_owner = succ_procname)
or (arglist_owner = pred_procname) then
begin
(* actual expression has to be enumeration *)
rigthtypename := testenumeration (stacktop);
insert_functype (rigthtypename);
goto 5;
end;

if arglist_owner = ord_procname then
begin
(* actual expression has to be enumeration *)
rigthtypename := testenumeration (stacktop);
goto 5;
end;

if arglist_owner = abs_procname then
begin
(* actual expression must be integer (or subrange hereof) *)
(* note: in future also real... *)
assure (stacktop, integer_typename, illegal_value_param_substitution);
insert_functype (integer_typename);
goto 5;
end;

end; (* special functions *)

resolve_named_type (typename, lefttypename, leftelement, leftbasekind);
resolvetype (stacktop, rigthtypename, rigthelement, rigthbasekind);

if lefttypename <> rigthtypename then
test_value_compatible (illegal_value_param_substitution);
(* note: implicit params: left... and rigth... *)

testrange (typename (* of curformal *) );
end; (* with curformal *)

goto 5;
end;

end

otherwise

if compilertest then comp_error (unknown_namekind);

curformal := nextname;  (* follow chain *)

end; (* with curformal *)

(* the formal paramlist was exhausted *)
error (too_many_actual_params);

5: ;

(* note: see also 'prepare_call' *)

(* bind the actual parameter to the owner *)
oper (binary, argkind, nilname (* irrell typename *) );
with opands [ stacktop ] do
op_name := curformal;   (* let opname point at current formal name *)

(* let curformal be the next in formal-list *)
with names [ curformal ] do
curformal := nextname;

end;  (* argkind = cargument *)


cstrucarray:
begin
(* curformal is element typename *)
(* check transfer to array-element *)
testinitialize (curformal, struc_arr_incompatible);
oper (binary, argkind, curformal (* = element typename *) );
end;

cstrucrecord:
begin
(* curformal is name in field list *)

while curformal <> nilname do
(* skip implicit types in field list *)
with names [ curformal ] do
begin
if namekind = crecfield then
begin
(* check transfer to field *)
testinitialize (typename, struc_rec_incompatible);
goto 10;
end;
curformal := nextname;
end; (* with curformal *)

error (too_many_values_in_record_struc);

10: ;

(* bind the value to the owner *)
with names [ curformal ] do   (* namenode of field name *)
begin
oper (binary, argkind, curformal (* i.e. fieldname itself *) );
curformal := nextname;
end;

end;


end (* case argkind *)
otherwise
if compilertest then
comp_error (unknown_argkind);

end; (* procedure actparam *)



(*QQQ*)

procedure initialize;

var strptr: stringptr;
err: pass3errors;

begin

(* initialize files *)
reset (pass1file);
reset (pass1labels);
rewrite (pass3file);

(* initialize conversion table *)
for rectype := cnocode to clastcode do
convtable [ ord(rectype) ] := rectype;

(* clear error-bitmap *)
for err := noerror to lastpass3error do
error_bitmap [ err ] := false;

(* initialize stdspix table *)
(* all entries are set to: 'max-spix'... this will ensure *)
(*   that pass1 actually sends out initialization for these *)
for rectype := canonymous to cord do
stdspix (max_spix, rectype);

(* initialize test facilities *)
testinput     := false;
testoutput    := false;
testing       := testinput or testoutput;
testlinecnt   := 0;

call_pass4    := true;   (* default = continue with pass4 *)
lambda_version := true;  (* default = rc3502 *)

date (cur_date);
time (cur_time);
if testing then changeline;

cur_lineno    := 0;
no_of_errors := 0;
cur_opandno := 0;
emit_lineno   := 0;
cur_blockno := process_block;

(* initialize list structures *)

(* initialize 'names' *)
insert_in_front := false;  (* default is: insert all names in rear *)
freenames := nilname;
for curname := nilname to max_names do
with names [ curname ] do
begin
namekind := cundeclared;
nextname := freenames;
freenames := curname;
end;

(* initialize 'types' *)
freetypename := nilname;
dummy_typenode := max_types;  (* notice: must have the correct value from the very beginning *)
for cur_typenode := niltype to max_types do
begin
with types [ cur_typenode ] do
begin
typekind := cnocode;
subexpr := nilopand;
end;
release_typenode (cur_typenode);
end;

(* initialize 'dummy_typenode' as the very first one *)
cur_typenode := alloc_typenode;
if compilertest then
if dummy_typenode <> cur_typenode then
comp_error (inconsist_alloc);

(* initialize 'strings' *)
freestrings := nilstring;
for strptr := nilstring to max_strings do
with strings [ strptr ] do
begin
nextstr := freestrings;
freestrings := strptr;
end;

(* initialize 'opands' *)
freeopands := nilopand;
for stacktop := nilopand to max_opands do
with opands [ stacktop ] do
begin
next := freeopands;
opcode := cerrorarg;  (* nbnbnbnbnbnb: skal laves bedre ved lejlighed *)
(* initialized because it is used as 'working location' by 'testindex' *)
freeopands := stacktop;
end;

(* initialize variables concerning opands *)
stacktop := nilopand;
nexttop  := nilopand;

(* initialize namestack etc *)
namelevel := lowestlevel - 1;
levelkind := processlevel;
lastgloballevel := namelevel;
newnamelevel;
expecting_block := false;
after_funccall := false;
expr_release := false;
retain_top := false;
expr_level := 0;  (* i.e. first 'emitexpr' is beginning of expression *)
pushnameindex := 0;
start_of_protected := false;

(* initialize stack for holding arguments *)
callindex    := 0;
argkind      := cnocode;
curformal    := nilname;
arglist_owner:= nilname;
functempvar  := nilname;
count_processparam := 0;


(* initialize important spix'es *)

(* the following construction matches the main-loop *)
endpass1 := false;

repeat

if testing then changeline;

rectype := password;

case rectype of

cnewline:
cur_lineno := passin;

coption:
readoption;

cstandardname:
standardname;

end
otherwise endpass1 := true;

until endpass1;
envir_spix := anonymous_spix; (* used as flag to omit 'typedef' for integer etc *)
reset (pass1file);  (* start all over again, later *)

(* initialze important name/type nodes *)

error_typename := alloc_namenode;
error_typenode := alloc_typenode;

with names [ error_typename ] do
begin
spix          := anonymous_spix;
namekind      := cerrorkind;
typename      := error_typename;
typ           := error_typenode;
end;

with types [ error_typenode ] do
typekind    := cerrorkind;

with types [ dummy_typenode ] do
typekind    := cnocode;

text_typename := alloc_namenode;
with names [ text_typename ] do
begin
spix     := anonymous_spix;
namekind := ctype;
typ      := alloc_typenode;
with types [ typ ] do
typekind := ctext;
end;

names [ nilname ] := names [ error_typename ];
types [ niltype ] := types [ dummy_typenode ];

set_error_type;
emittype (error_typename);
emittype (text_typename);
prepare_expression;

end; (* procedure initialize *)

\f



«eof»
DataMuseum.dk

RC3500

⟦c9d3c3743⟧ TextFileVerbose

Derivation

TextFileVerbose
