|
DataMuseum.dkPresents historical artifacts from the history of: RC3500 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about RC3500 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 31488 (0x7b00)
Types: TextFileVerbose
Names: »mainpass3«
└─⟦2c55ea56f⟧ Bits:30001844 SW-save af projekt 1000, Alarm-system
└─⟦6b41451d2⟧
└─⟦this⟧ »mainpass3«
(* 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»