DataMuseum.dk

top - metrics - download

    Length: 31488 (0x7b00)
    Types: TextFile
    Names: »mainpass3«

└─⟦2c55ea56f⟧ Bits:30001844 SW-save af projekt 1000, Alarm-system
    └─⟦6b41451d2⟧ 
        └─⟦this⟧ »mainpass3« 

TextFile

(* start of main program *)

begin

initialize;

endpass1 := false;

(* the mainloop reads the next record-keyword *)

repeat (* until endpass1, i.e. eom-record from pass1 *)

if testing then changeline;

rectype := password;

(* switch out, depending on rectype *)

case rectype of

cnewline:
begin
lineno := passin;
if lineno <> cur_lineno then
begin
cur_lineno := lineno;
cur_opandno := 0;  (* let opands be counted from zero *)
emit (xnewline);
emitin (cur_lineno);
emit_lineno := cur_lineno;
end;
end;

coption:
readoption;

(*QQQ*)

cstandardname:
standardname; (* merely to skip the parameters... *)

cendprefix: ; (* blind *)

cinclude,
ccontext:
begin
cur_opandno := cur_opandno + 1;
envir_spix := passin;  (* skip the spix *)
end;

cerrcontext: ; (* blind *)

cendcontext: ; (* blind *)

cendinclude:
begin
lastgloballevel := namelevel;
emit (xendprelude);
end;

cbeginlevel:
begin
(* increase the namelevel, and initialize a new namelist *)
newnamelevel;
end;

cendlevel:
begin
(* if any global names have been used at this level, *)
(*   then pretend that they were used at the next, outer, level *)
endnamelevel;
end;

(*QQQ*)

cdeclaration:
begin
if expecting_block then
begin_block;
cur_namekind := password;

(* test that 'process' only occurs at process-level *)
(* ... else bhange it to: 'procedure'               *)

if cur_namekind = cprocess then
if cur_blockno <> process_block then
begin
error (process_only_allowed_at_processlevel);
cur_namekind := cprocedure;
end;

if compilertest then
(* test legality of namekind *)
case cur_namekind of
cprocess, cprocedure, cfunction, ctype,
cscalarelem, crecfield, cconstant, cvar,
cvarp, cvaluep,
clabel,
cprefix: ; (* ok *)
end
otherwise
comp_error (unknown_namekind);

(* certain declarations are followed by a literal with the external name *)
(* adjust the opand-number in advance... *)
case cur_namekind of
cprocess,
cprocedure,
cfunction,
cprefix:
cur_opandno := cur_opandno - 1;
end otherwise (* don't care *);

(* prepare endlist-actions, by initializing list-pointers *)
listfirst := nilname;
listlast  := nilname;

end;

cdeclare,
cdeclarelist:
begin
cur_opandno := cur_opandno + 1;
curname := newname ( passin (* = spix *) );

(* insert the name in the list *)
if listfirst = nilname then
listfirst := curname;
listlast := curname;

case cur_namekind of
cprocess,
cprocedure,
cfunction:
begin
(* the name will be followed by a formal list *)
(* remember the routine name *)
cur_routine := curname;
(* the name of the routine was preceded by a literal name *)
(* remember the  opand holding this name *)
opand_procname := take_stacktop;

(* prepare for 'beginlevel': process-level is special *)
if cur_namekind = cprocess then
begin
cur_namekind := cvar;  (* set up for variable *)
curname := newname (anonymous_spix); (* used for 'son-variable *)
with names Æ curname Å do
typename := son_typename;
levelkind := processlevel;
end
else
levelkind := irrell_level;

end;

cprefix:
begin
emit (xprefix);
emit_extname (take_stacktop);
end;

clabel:
emitid (xlabelid, curname);

end otherwise; (* nothing *)

end;

(*QQQ*)

cexternal,
cforward:
begin


with names Æ cur_routine Å do
begin
if forward_decl then
error (double_declaration) (* i.e. it was already forward declared *)
else

(* set the proper flag and emit the corresponding record *)
case rectype of

cexternal:
begin
external_decl := true;
if cur_blockno <> process_block then
error (external_only_at_process_level)
else
emit (xexternal);
end;

cforward:
begin
forward_decl := true;
emit (xforward);
end;

end otherwise; (* case rectype *)

end; (* with names *)

expecting_block := false; (* flag to omit 'blockno' *)

end;

(*QQQ*)

cendformallist:

begin

(* 'cur_routine'  is the name of the process/procedure/function *)
(* 'cur_typename' is the name of the common type *)
(* 'cur_typenode' is the corresponding typenode *)

(* 'listfirst' and 'listlast' outpoint the list of formal params *)

paramkind := names Æ listfirst Å . namekind;
(* may be value/var param *)

(* check paramkind versus routinekind to test legality of parameter-type *)
with types Æ cur_typenode Å do
with names Æ cur_routine Å do
begin

not_allowed := ÆÅ;

case namekind (* of routine *) of

ctype: ; (* not implemented *)

cfunction,
cprocedure:
(* semaphore, reference, shadow, pool not allowed as value param *)
if paramkind = cvaluep then
not_allowed := Æ t_semaphore, t_reference, t_shadow, t_pool Å;

cprocess:
(* reference, shadow, pool not allowed at all *)
(* semaphore not allowed as value param *)
(* pointers may not be modified by child *)
if testprocessparam (cur_typename, paramkind = cvarp) then
not_allowed := contents (* i.e. provoke error below *)
else
if paramkind = cvaluep then
not_allowed := Æ t_semaphore Å;

end otherwise; (* case namekind *)

if not_allowed * contents (* of param type *) <> ÆÅ then
begin
(* the parameter type was illegal, replace it *)
error (illegal_formal_type);
set_error_type;
end;

end; (* with cur_routine *) (* with cur_typenode *)

(* pass the type to all formals in the list *)

with names Æ listlast Å do listtop := nextname;

while listfirst <> listtop do
with names Æ listfirst Å do
begin
typename := cur_typename;
listfirst := nextname;
end;

poptype;

end;

(*QQQ*)

cendformal: ; (* blind, the action is delayed until end-routine-decl *)


(*QQQ*)

cendprocdecl,
cendfuncdecl:

begin

(* in case of function, add the type *)

(* emit the routinehead *)

with names Æ cur_routine Å do
begin

if rectype = cendfuncdecl then
begin
(* function type may not contain ... *)
with types Æ cur_typenode Å do  (* typenode of function type *)
if contents * Æ t_semaphore, t_reference, t_shadow, t_pool Å <> ÆÅ then
begin
error (illegal_function_type);
set_error_type;
end;

typename (* of function name *) := cur_typename;

(* allocate a namenode for holding the function value *)
cur_namekind := cfuncval;
insert_in_front := true;  (* note: it must be the very first in formal list *)
curname := newname (anonymous_spix);
insert_in_front := false; (* all other names etc are inserted in rear *)
with names Æ curname Å do
typename := cur_typename;

poptype;

end; (* if function declaration *)

(* the whole paramlist (including implicit types) are in the *)
(*   current namelevel in namestack *)

(* transfer the paramlist pointer to this routine *)

(* but first compare the new paramlist against the old paramlist *)
(* (in case of earlier forward declaration) *)
if forward_decl then
compare_paramlists; (* the new list must be empty or match exactly *)

with namestack Æ namelevel Å do
params (* of cur_routine *) := firstname; (* of namelevel *)

emitroutinehead (cur_routine);

(* the routine is of special interrest, if it is: 'ord', 'succ', etc *)
if spix <= maxstdspix then
specialspix (cur_routine);

end; (* with cur_routine *)

end;

(*QQQ*)

cendconstantdecl:

begin

testvalue (stacktop);

with names Æ listfirst Å do (* nb just one name in the list *)
begin
usedlevel := lowestlevel;  (* let the identifier be defined now... *)
with opands Æ stacktop Å do
begin
typename (* of constant *) := op_typename;  (*i.e. copy from expression type *)
op_packflag := true;  (* don't release temporary set-type *)
end;
end;

emit_and_release (stacktop);

emitid (xconstid, listfirst);

end;



cendtypedecl:

begin

emittype (cur_typename);
emit (xtypedef);

(* the type is of special interrest in case of 'reference' etc *)
with names Æ cur_typename Å do
if spix <= maxstdspix then
specialspix (cur_typename);

poptype;

end;



cnoinit,
cinit:
var_initialization := rectype = cinit;



cendvardecl:

begin

(* semaphore and pool may only *)
(*   be declared on process-level *)

if cur_blockno <> process_block then
begin
with types Æ cur_typenode Å do
if Æ t_semaphore, t_pool Å * contents (* of type *) <> ÆÅ then
begin
error (type_may_only_be_used_at_process_level);
set_error_type;
end;
end;

(* transfer the type to all variables in the namelist *)

with names Æ listlast Å do listtop := nextname;

while listfirst <> listtop do
begin
emitid (xvarid, listfirst);
with names Æ listfirst Å do
begin
typename := cur_typename;
listfirst := nextname;
end;
end;

emittype (cur_typename);

if var_initialization then
begin
testinitialize (cur_typename, var_init_incompatible);
emit_and_release (stacktop);
emit (xinitconst);
end;

emit (xvarlist);

poptype;

end;

(*QQQ*)


cexport,
cexportvalue,
cexportsize,
cexportdisp,
cexportoffset,
cexportaddr:
export_procedure;

cenddeclarations:

begin

(* this record comes at end of each context *)
(*   and at the first 'begin' in a routine *)

(* the separation of these two will be done by 'startlabelscope' *)

afterdecl := true;

(* test that all forward-declared routines have been solved *)
with namestack Æ namelevel Å do
curname := firstname;   (* first name in name list *)
while curname <> nilname do
with names Æ curname Å do
begin
if forward_decl then
error (forward_not_solved);
curname := nextname;
end;

end;



cstartlabelscope,
cendlabelscope:

begin

cur_labelscope := passin;

if afterdecl then
begin
(* this is the 'begin' of a routine *)
afterdecl := false;

if expecting_block then
begin_block; (* because there were no declarations at all *)

if cur_blockno = process_block then
begin
(* process level *)
(* find the relevant exception procedure *)

curname := findname (exception_spix);
with names Æ curname Å do (* namenode of exception procedure *)
if namekind <> cprocedure then
curname := exception_procname;
(* nb nb nb nb: test korrekt paramliste *)

emitid (xexception, curname);
end;

emit (xinitblock);

initlabels;

end;

set_label_state (rectype = cstartlabelscope);

end;



cbegincode:
begin
begin_block;
emit_and_release (stacktop);  (* literal == stack appetite *)
emit (xbegincode);
end;



ccodeline:
begin
emit (xcodeline);
lineno := passin;  (* number of chars in line *)
emitin (lineno);
for lineno := lineno downto 1 do emitin (passin);
end;

(*QQQ*)

cendcode,
cendblock:

begin

(* release all local namenodes and their typenodes *)

(* notice: the namenodes of the parameters to a block *)
(*         are released by the surrounding block *)

if rectype = cendcode then
emit (xendcode)
else
emit (xendblock);
if cur_blockno <> process_block then
cur_blockno := cur_blockno - 1;

releasenames (namestack Æ namelevel Å . firstname);

(* test that functions have had a chance for assigning a value *)
if rectype = cendblock then
with namestack Æ namelevel - 1 Å do  (* parameter-level *)
with names Æ firstname Å do        (* first formal name *)
if namekind = cfuncval then      (* it must have been a function *)
if not func_assigned then
error (funcval_not_used);

end;

(*QQQ*)

ctypeid:

begin

(* an existing typenode will be reused *)

pushtype; (* because types may be nested *)

cur_typename := usename (passin (* = spix *) );

with names Æ cur_typename Å do

begin

cur_typenode := typ;

(* test that the namenode really was a typename node *)
(* notice: all namenodes are initialized with 'dummy_typenode' *)
(*         while type/error nodes have specific typenodes *)
if cur_typenode = dummy_typenode then
begin
error (not_typename);
set_error_type;
end;

end; (* with cur_typename *)

if cur_namekind = ctype then
begin
(* this is:   <name> = <typename>;  *)
(* setup an 'alias' node *)

(* it is not nescessary to test for recursive use, because it *)
(* has been tested that rigthhand name was the name of a defined type *)

cur_typenode := alloc_typenode;
with types Æ cur_typenode Å do
begin
typekind := calias;
element := cur_typename;
contents := types Æ names Æ element Å . typ Å . contents;
packflag := types Æ names Æ element Å . typ Å . packflag;
end;

cur_typename := curname;

with names Æ cur_typename Å do
typ := cur_typenode;

end; (* if namekind = ctype *)

end;




cendtype: ; (* blind *)

(*QQQ*)

cwithout_data:

begin

(* this special type is used by 'pool definition' to simulate notype *)

pushtype; (* because this type is nested in 'pool-def' *)

cur_typename := nil_typename;
cur_typenode := names Æ cur_typename Å . typ;

end;

(*QQQ*)

cnewtype:

begin

(* a new type will be constructed *)

pushtype; (* because types may be nested *)

if cur_namekind <> ctype then
begin
(* implicit type, insert pseudo typename *)

cur_typename := newname (anonymous_spix);

with names Æ cur_typename Å do
namekind := ctype;

end

else

begin
(* explicit type, use 'curname' as 'cur_typename' *)

cur_typename := curname;
cur_namekind := cnocode; (* only the outermost newtype is explicit *)

end;

(* prepare the succeding typedefinitions *)
cur_typenode := alloc_typenode;

with names Æ cur_typename Å do
typ := cur_typenode;

end;

(*QQQ*)

cscalar,
csubrange,
carray,
crecord,
cset,
cpool,
cpointer,
creadonly,
cinteger,
creal,
cniltype:

begin

(* insert the rectype in the 'cur_typenode' *)
with types Æ cur_typenode Å do
typekind := rectype;

(* maybe push the current namelist, in case of inner namelists *)
if (rectype = cscalar) or
(rectype = crecord) then
pushlist;

if rectype = cscalar then
with names Æ cur_typename Å do
if spix <> anonymous_spix then   (* keep scalarelems on the correct namelevel *)
endnamelevel;

if rectype = cinteger then
integer_typename := cur_typename;

if rectype = cniltype then
nil_typename := cur_typename;

end;

(*QQQ*)

cendscalar:

begin

(* add the scalar-list to the scalar type node *)

with types Æ cur_typenode Å do (* typenode of scalar type *)
begin
element := listfirst;
contents := Æ t_simple Å;
end;

(* insert typename in the whole scalar-list *)
with names Æ listlast Å do listtop := nextname;

while listfirst <> listtop do
with names Æ listfirst Å do
begin
typename := cur_typename;
listfirst := nextname;
end;

with names Æ cur_typename Å do
if spix <> anonymous_spix then  (* keep scalarelems on correct namelevel *)
newnamelevel;

poplist; (* return to outer namelist *)

end;

(*QQQ*)

cendsubrange:

begin

(* the two expressions are in 'stacktop' and 'nexttop' *)

(* the two expressions must be <same> enumeration type *)
lefttypename (* dummy assignment *) := testenumeration (nexttop); (* nb: exprtypename = simplified typename *)
resolvetype (stacktop, rigthtypename, rigthelement, rigthbasekind);
if exprtypename <> rigthtypename then
begin
error (subrange_elems_must_be_enumeration);
exprtypename := error_typename;
end;

(* bind the two expressions to a single one *)
oper (binary, crangefirst, exprtypename);

with types Æ cur_typenode Å do
begin
subexpr := take_stacktop; (* remember the two expressions *)
index   := exprtypename;
contents:= Æ t_simple Å;
end;

end;

(*QQQ*)

cendarray:

begin

test_recursive_type;

elemname := cur_typename; poptype;
indexname:= cur_typename; poptype;

testindex (indexname);

with types Æ cur_typenode Å do (* typenode of array *)
begin
element := elemname;
index   := indexname;
contents:= types Æ names Æ elemname Å . typ Å . contents;
(* transfer contents from element type *)
end;

end;

(*QQQ*)

cendfield:

begin

(* types may not be recursive *)
test_recursive_type;

with names Æ listlast Å do listtop := nextname;
while listfirst <> listtop do
with names Æ listfirst Å do
begin
typename := cur_typename;
listfirst := nextname;
end;

elemname := cur_typename;
poptype; (* return to record typename/typenode *)

(* transfer field-contents to record-contents *)
with types Æ cur_typenode Å do (* typenode of record *)
contents := contents + types Æ names Æ elemname Å . typ Å . contents;

end;

(*QQQ*)

cendrecord:

begin

(* transfer the whole current namelist, i.e. the list of field-names *)
(*   and their implicit types, to the record-typenode *)

with types Æ cur_typenode Å do (* typenode of record *)
with namestack Æ namelevel + 1 Å do (* just terminated field list *)
element := firstname;

poplist; (* return to outer namelist *)

end;

(*QQQ*)

cendset:

begin

(* indexname must be enumeration type *)

indexname := cur_typename;
poptype; (* return to set-type *)

testindex (indexname);

with types Æ cur_typenode Å do (* typenode of set *)
begin
element := indexname;
contents:= Æ t_simple Å;
end;

end;

(*QQQ*)

cendpool:

begin

(* test that <cardinality> is <integer> *)

resolvetype (stacktop, exprtypename, exprelement, exprbasekind);
if exprbasekind <> cinteger then
begin
error (pool_cardinality_must_be_integer);
end;

(* test legality of type *)

with types Æ cur_typenode Å do (* typenode of pool-sizetype *)
(* it may not contain: semaphore, shadow, reference, pool, pointer *)
if contents * Æ t_semaphore, t_reference, t_shadow, t_pool, t_pointer Å <> ÆÅ then
begin
error (illegal_pool_type);
set_error_type;
end;

elemname := cur_typename;
poptype; (* return to pool *)

with types Æ cur_typenode Å do (* typenode of pool *)
begin
subexpr := take_stacktop;
element := elemname;
contents:= Æ t_pool Å;
end;

end;

(*QQQ*)

cendreadonly,
cendpointer:

begin

if rectype = cendreadonly then
test_recursive_type;
(* notice: pointer-to-type is not considered recursion *)

elemname := cur_typename;
poptype; (* return to readonly/pointer type *)

with types Æ cur_typenode Å do
begin
element := elemname;
if rectype = cendpointer then
contents := Æ t_pointer Å
else
begin
(* note: special handling of t_pointer versus t_froz_ptr *)
(*       because t_pointer would be dangerous as process-varparam *)
(*       whereas t_froz_ptr is safe... *)
contents := types Æ names Æ element Å . typ Å . contents;
contents := contents + Æ t_readonly Å;
end;
end;

end;

(*QQQ*)

cpacked:

begin
(* 'cur_typename/node' are nodes of record/array (or set) *)

with types Æ cur_typenode Å do
packflag := true;

end;

(*QQQ*)

cbegin:
prepare_statement;

cend: ; (* blind *)

clabeldef:

begin

(* label def statement *)
definelabel ( passin (* = scopeno *) , passin (* = spix *) );

end;

(*QQQ*)

ccasestat:
prepare_expression;

ccaseexpr:
begin
pushname (case_typename); (* because case may be nested *)
case_typename := testenumeration (stacktop);
case_typename := exprtypename;  (* nbnbnbnb: get simplified typename *)

emit (xcasestat);

emit_and_release (stacktop);

emit (xcase);
end;


ccaselabel:
begin
(* the caselabel must have same type as the case-expression *)
resolvetype (stacktop, exprtypename, exprelement, exprbasekind);
if case_typename <> exprtypename then
  error (case_incompatible);

emit_and_release (stacktop);

emit (xcaselabel);

end;



ccaselabelrange:
begin
(* both caselabels must match the case-expression *)
equaltypes (nexttop, stacktop, case_typename, case_incompatible);

(* bind the two expressions together *)
oper (binary, crangefirst, nilname (* irrell typename *) );
emit_and_release (stacktop);

emit (xcaserange);

end;



cotherwise:
emit (xotherwise);



ccaselist:
begin
prepare_statement;
emit (xendcaselist);
end;



ccaseelement:
begin
prepare_expression;
emit (xendcasestat);
end;



cendcase:
begin

emit (xendcase);

(* unstack case type name *)
case_typename := popname;

prepare_statement;

end;

(*QQQ*)

cforstat:
prepare_expression;

cforvar:
begin
(* the controlling variable must be: assignable, unpacked variable *)
testassignable (stacktop);
testunpacked (stacktop);
for_typename := testenumeration (stacktop);
for_basetypename := exprtypename;  (* nbnbnbnb: get simplified typename *)

emit (xforstat);
emit_and_release (stacktop);
emit (xfor);

end;



cup,
cdown:
begin
equaltypes (nexttop, stacktop, for_basetypename, for_incompatible);

(* insert a possible range-test after each of the two expressions *)
testrange (for_typename);
for_expr := take_stacktop;
testrange (for_typename);

emit_and_release (stacktop); (* start-value *)
if rectype = cup then
emit (xup)
else
emit (xdown);
emit_and_release (for_expr); (* end-value *)

emit (xdo);

prepare_statement;

end;



cendfor:
emit (xendfor);

(*QQQ*)

cifstat:
prepare_expression;



cifexpr:
begin

assure (stacktop, boolean_typename, if_type);

emit (xifstat);

emit_and_release (stacktop);

emit (xifexpr);

prepare_statement;

end;



celse:
emit (xelse);



cendif:
emit (xif);

(*QQQ*)

crepeatstat:
emit (xrepeat);



cuntil:
prepare_expression;



cendrepeat:
begin

assure (stacktop, boolean_typename, repeat_type);

emit (xuntil);

emit_and_release (stacktop);

emit (xendrepeat);

prepare_statement;

end;

(*QQQ*)

cwhilestat:
begin
emit (xwhile);
prepare_expression;
end;



cwhileexpr:
begin

assure (stacktop, boolean_typename, while_type);

emit_and_release (stacktop);

emit (xwhileexpr);

prepare_statement;

end;



cendwhile:
emit (xendwhile);

(*QQQ*)

clockstat,
cwithcomma,
cwithstat:

begin

case rectype of
clockstat:
begin
start_of_protected := true;  (* prepare: goto not out of lock-statement *)
emit (xlockstat);
levelkind := firstlock;
end;
cwithcomma,
cwithstat:
begin
emit (xwith);
if rectype = cwithstat then
levelkind := firstwith;
end;
end otherwise; (* case *)

prepare_expression;

end;



cwithvar:

begin
(* most of this action is common for lock- and with-statements *)

resolvetype (stacktop, exprtypename, exprelement, exprbasekind);
with opands Æ stacktop Å do
with_typename := op_typename;

(* it must be a variable *)
testvariable (stacktop);

newnamelevel;

with namestack Æ namelevel Å do

begin

(* test the lockvar/withvar *)

case namelistkind of

firstlock,
nextlock:
begin
levelkind := nextlock;
(* variable must be of type reference *)
if exprtypename <> reference_typename then
if exprbasekind <> cerrorkind then  (* suppress if already in error *)
error (lock_type);
end;

firstwith,
nextwith:
begin
levelkind := nextwith;
(* variable must be a record *)
if exprbasekind = crecord then
insert_namelist (exprelement (* = field name list of record *) )
else
if exprbasekind <> cerrorkind then  (* suppress if already in error *)
error(with_type);
end;

end otherwise; (* case namelistkind *)

emit_and_release (stacktop); (* variable *)

if levelkind = nextwith then
begin

(* initialize namelevel *)
withname := alloc_namenode;
with names Æ withname Å do
begin
namekind := cvar;  (* pretend variable-kind *)
typename := with_typename;  (* insert typename *)
end;
emitid (xwithvar, withname);

end; (* if with-statement *)

end; (* with namelevel *)

end;



cnolocaldecl: ; (* blind *)



cendlocaldeclare:
begin

with names Æ listfirst Å do (* namenode of local var *)
begin

(* test legality of local type *)
with types Æ cur_typenode Å do
begin
if contents * Æ t_semaphore, t_reference, t_shadow, t_pool Å <> ÆÅ then
begin
set_error_type;
error (type_has_systemtypes);
end;

if t_pointer in contents then
warning (type_has_pointers);
end;

typename := cur_typename;

end;

with namestack Æ namelevel Å do
begin
withname := listfirst;  (* save the list-start, for later releasenames *)
emitid (xlockvar, withname);  (* notice: first name in namelevel *)
end;

emittype (cur_typename);
emit (xlock);

poptype;

end;



cdo:
prepare_statement;



cendwith:

begin

repeat

with namestack Æ namelevel Å do
begin

case namelistkind of

firstlock,
nextlock:
emit (xendlock);
firstwith,
nextwith:
emit (xendwith);

end otherwise; (* case *)

levelkind := namelistkind;

releasenames (withname);

end; (* with namelevel *)

endnamelevel;

until (levelkind = firstlock) or (levelkind = firstwith);

end;

(*QQQ*)

cgotostat:
prepare_expression;



cendgoto:

begin
with opands Æ stacktop Å do
begin

errorcode := check_label (op_name);

if errorcode <> noerror then
  error (errorcode)
else
emitid (xgoto, op_name);

end; (* with stacktop *)
release_expr (take_stacktop);
prepare_statement;
end;

(*QQQ*)

cchannelstat:
begin
start_of_protected := true;  (* prepare: goto not out of channel-statement *)
prepare_expression;
end;



cchanvar:

begin

testvariable (stacktop);
assure (stacktop, reference_typename, channel_type);

emit (xchannel);
emit_and_release (stacktop);
emit (xchanvar);

prepare_statement;

end;



cendchannel:
emit (xendchannel);



cendassign:
begin
(* lefthandside must be assignable variable *)
testassignable (nexttop);
(* the rigthhandside must be a value *)
(* implicitly tested by resolvetype *)
resolvetype (nexttop, lefttypename, leftelement, leftbasekind);
resolvetype (stacktop, rigthtypename, rigthelement, rigthbasekind);
if lefttypename <> rigthtypename then
test_value_compatible (assign_incompatible);
with opands Æ nexttop Å do
testrange (op_typename);  (* make rangetest, when assigning to subrange *)
oper (binary, rectype, nilname);
emit_and_release (stacktop);
prepare_statement;
end;



cendexchange:
begin
(* both left- and rigthhandside must be assignable variables *)
(* of exactly the same type *)
testexchangable (nexttop);
testexchangable (stacktop);
with opands Æ nexttop Å do
(* type must be reference or shadow *)
if (op_typename <> reference_typename) and
(op_typename <> shadow_typename) then
error (exchange_type)
else
if op_typename <> opands Æ stacktop Å . op_typename then
error (exchange_incompatible);
oper (binary, rectype, nilname);
emit_and_release (stacktop);
prepare_statement;
end;



cid:
begin

curname := usename (passin (* = spix *) );

if before_assign then
begin
(* be prepared for doing special when assigning to function-name *)

prepare_expression;

with names Æ curname Å do   (* namenode of identifier *)
if namekind = cfunction then
(* a function name was used in front of an assignment *)
if retrieved_level < namelevel-1 then
(* test if we are inside the body of the function *)
with namestack Æ retrieved_level + 1 Å do  (* level of possible paramlist *)
if firstname (* of namestack *) = params (* of function *) then
(* exchange the function name by the returnvalue name *)
begin
curname := params;  (* first of paramlist *)
with names Æ curname Å do
func_assigned := true;
end;

end; (* before assign *)

with names Æ curname Å do
if namekind = crecfield then
begin
(* there has been a previous 'with' *)
(* simulate: <withname>.<fieldname> *)
with namestack Æ retrieved_level Å do  (* ... defined by: 'usename' *)
begin
with names Æ withname Å do
newopand (cid, typename (* of withname *) );
with opands Æ stacktop Å do
op_name := withname;
oper (unary, cfield, typename (* of curname ( = fieldname ) *) );

(* insert the packflag from the record-type of the withvar *)
with names Æ withname Å do
with names Æ typename Å do   (* namenode of record-type for withvar *)
with types Æ typ Å do      (* corresponding typenode *)
with opands Æ stacktop Å do
op_packflag := packflag; (* from typenode of withvar *)

end;

end (* if recfield *)
else
newopand (cid, typename (* of curname *) );

with opands Æ stacktop Å do
op_name := curname;

end; (* cid *)



cliteral:
begin

cur_opandno := cur_opandno + 1;

rectype := password;  (* get type of literal *)

newopand (cliteral, nilname (* typename not defined yet *) );

with opands Æ stacktop Å do
begin
if rectype = cinteger then op_typename := integer_typename
else
if rectype = creal    then op_typename := nil_typename
else
if rectype = ctext    then op_typename := text_typename
else
if compilertest then
comp_error (unknown_rectype);

op_value := readstring;
(* midlertidig simplifikation, for at kunne opfatte literal-chars *)
if rectype = ctext then
with strings Æ op_value Å do
if stringlgt = 1 then
op_typename := char_typename;
end;

end; (* literal *)



cskipparam:
begin
cur_opandno := cur_opandno + 1;
newopand (cskipparam, nilname (* irrell typename *) );
end;



(* pickup of sets *)
csetlist,
cs_element,
cm_element,
cendsetlist:
set_procedure;



cfield:
begin
(* stacktop contains previous 'variable' *)

cur_opandno := cur_opandno + 1;

newspix := passin;

resolvetype (stacktop, exprtypename, exprelement, exprbasekind);

with names Æ exprtypename Å do   (* namenode of <variable> type *)
with types Æ typ Å do          (* corresponding typenode *)
(* note: in case of alias-type, exprelement and exprbasekind are the best ones *)
if exprbasekind <> crecord then
suppress_error (exprbasekind, field_must_follow_recordtype)
else
begin
(* find the spix among the fieldnames of the record *)
curname := exprelement;  (* first of field name list *)
while (newspix <> anonymous_spix (* i.e. not found yet *) )
and (curname <> nilname (* i.e. more names to compare to *) ) do
with names Æ curname Å do
if newspix = spix (* of curname *) then
begin
oper (unary, cfield, typename (* of fieldname *) );
with opands Æ stacktop Å do
begin
op_name := curname;
op_packflag := packflag; (* from record typenode *)
end;
newspix := anonymous_spix; (* indicate succes *)
end 
else
curname := nextname; (* follow chain, and test next name in list *)

if curname = nilname then
error (name_not_fieldname);

end; (* with names, types etc of stacktop *)

end; (* cfield *)



cuparrow:
begin
(* stacktop is <variable>, which must be pointertype *)

resolvetype (stacktop, exprtypename, exprelement, exprbasekind);
if exprbasekind <> cpointer then
suppress_error (exprbasekind, must_be_pointertype_before_uparrow)
else
oper (unary, cuparrow, exprelement (* follow pointer-type *) );

end; (* cpointer *)



ceq,
cne,
clt,
cle,
cgt,
cge:
relation (rectype);



cplus,
cminus,
cstar,
cslash:
arithop (rectype);



cendexpression: ; (* blind *)



cbeginactual:
beginactual;



cactualparam,
cdoubleparam:
act_param;



cendactual:
terminate_call (stacktop);



cendvariable:
terminate_funccall (stacktop);



ccallprocedure:
begin
terminate_funccall (stacktop);  (* terminate any erroneous function-call *)
make_call (stacktop); (* make sure even a parameter-less procedure is called *)
(* test that the stacktop identifies a procedure call *)
with opands Æ stacktop Å do
if opcode <> cendproc then
error (not_procedure_call);
emit_and_release (stacktop);
prepare_statement;
end;



cuplus,
cuminus:
begin
resolvetype (stacktop, exprtypename, exprelement, exprbasekind);
(* expression must be of integer or real types *)
if (exprbasekind = cinteger) or (exprbasekind = creal) then
oper (unary, rectype, exprtypename)
else
suppress_error (exprbasekind, monadic_error);
end;



cdiv,
cmod:
begin
(* both operands must be integers *)
equaltypes (nexttop, stacktop, integer_typename, arithmetic_error);
oper (binary, rectype, integer_typename);
end;



cand,
cor:
begin
(* both operands must be booleans *)
equaltypes (nexttop, stacktop, boolean_typename, relation_error);
oper (binary, rectype, boolean_typename);
end;



cnot:
begin
(* stacktop must be of boolean type *)
assure (stacktop, boolean_typename, monadic_error);
oper (unary, rectype, boolean_typename);
end;



cin:
begin
(* rigth opand must be of set-type *)
lefttypename (* dummy assignment *) := testenumeration (nexttop);
(* note: exprtypename is simplified typename of nexttop *)
resolvetype (stacktop, rigthtypename, rigthelement, rigthbasekind);
if (exprbasekind <> cerrorkind) and (rigthbasekind <> cerrorkind) then
if rigthbasekind <> cset then
error (relation_error)
else
if rigthelement <> nil_typename then   (* omit error, if empty set *)
if exprtypename <> rigthelement then
error (relation_error);
oper (binary, cin, boolean_typename);
end;




ceom:
endpass1 := true;



end (* case rectype *)

otherwise
comp_error (unknown_rectype);

until endpass1;






(* end of program *)
999:
terminate;

if call_pass4 then
if lambda_version then
replace ('platonpass4')
else
replace ('pass4z80')
else
writeln ('*** compilation terminated after pass', own_passno:1);
end.
▶EOF◀