DataMuseum.dk

top - download

    Length: 40576 (0x9e80)
    Types: TextFile
    Names: »P3MAIN.PAS«

└─⟦b6837b237⟧ Bits:30010500 SW2103 REL 1.11 Sourcer DVBS1.SW2103.rel.1.11-1 MASTER 31-1-192
    └─⟦this⟧ »P3MAIN.PAS« 

TextFile

start of main program *)\r
\r
begin\r
\r
initialize;\r
\r
endpass1:= false;\r
\r
(* the mainloop reads the next record-keyword *)\r
\r
repeat (* until endpass1, i.e. eom-record from pass1 *)\r
\r
if testing then writeln(output);\r
\r
rectype:= password;\r
\r
(* switch out, depending on rectype *)\r
\r
case rectype of\r
\r
cnewline:\r
begin\r
lineno:= passin;\r
if lineno <> cur_lineno then\r
begin\r
cur_lineno:= lineno;\r
cur_opandno:= 0;  (* let opands be counted from zero *)\r
emit (xnewline);\r
emitin (cur_lineno);\r
emit_lineno:= cur_lineno;\r
end;\r
end;\r
\r
coption:\r
readoption;\r
\r
\f

\r
cstandardname:\r
standardname; (* merely to skip the parameters... *)\r
\r
cendprefix: \r
releasenames(namelevel ^. firstname);\r
\r
\r
cinclude,\r
ccontext:\r
begin\r
cur_opandno:= cur_opandno + 1;\r
envir_spix:= passin;  (* skip the spix *)\r
cur_context_no:= cur_context_no + 1;\r
end;\r
\r
cerrcontext: ; (* blind *)\r
\r
cendcontext: ; (* blind *)\r
\r
cendinclude:\r
begin\r
lastgloballevel:= namelevel;\r
emit (xendprelude);\r
cur_context_no:= -1; (* end of contexts, i.e. change format of error messages *)\r
end;\r
\r
cbeginlevel:\r
begin\r
(* increase the namelevel, and initialize a new namelist *)\r
cur_dyn_var_level:= namelevel;\r
newnamelevel;\r
end;\r
\r
cendlevel:\r
begin\r
(* if any global names have been used at this level, *)\r
(*   then pretend that they were used at the next, outer, level *)\r
endnamelevel;\r
cur_dyn_var_level:= namelevel;\r
end;\r
\r
\f

\r
cdeclaration:\r
begin\r
if expecting_block then\r
begin_block;\r
cur_namekind:= password;\r
\r
(* test that 'process' only occurs at process-level *)\r
(* ... else bhange it to: 'procedure'               *)\r
\r
if cur_namekind = cprocess then\r
if cur_blockno <> process_block then\r
begin\r
error (process_only_allowed_at_processlevel);\r
cur_namekind:= cprocedure;\r
end;\r
\r
if compilertest then\r
(* test legality of namekind *)\r
case cur_namekind of\r
cprocess, cprocedure, cfunction, ctype,\r
cscalarelem, crecfield, cconstant, cvar,\r
cvarp, cvaluep,\r
clabel,\r
cprefix: ; (* ok *)\r
end\r
otherwise\r
comp_error (unknown_namekind);\r
\r
(* certain declarations are followed by a literal with the external name *)\r
(* adjust the opand-number in advance... *)\r
case cur_namekind of\r
cprocess,\r
cprocedure,\r
cfunction,\r
cprefix:\r
cur_opandno:= cur_opandno - 1;\r
end otherwise (* don't care *);\r
\r
(* prepare endlist-actions, by initializing list-pointers *)\r
listfirst:= nilname;\r
listlast := nilname;\r
\r
end;\r
\r
cdeclare,\r
cdeclarelist:\r
begin\r
cur_opandno:= cur_opandno + 1;\r
curname:= newname ( passin (* = spix *) );\r
\r
(* insert the name in the list *)\r
if listfirst = nilname then\r
listfirst:= curname;\r
listlast:= curname;\r
\r
case cur_namekind of\r
cprocess,\r
cprocedure,\r
cfunction:\r
begin\r
(* the name will be followed by a formal list *)\r
(* remember the routine name *)\r
cur_routine:= curname;\r
(* the name of the routine was preceded by a literal name *)\r
(* remember the  opand holding this name *)\r
opand_procname:= take_stacktop;\r
\r
(* prepare for 'beginlevel': process-level is special *)\r
if cur_namekind = cprocess then\r
begin\r
cur_namekind:= cvar;  (* set up for variable *)\r
curname:= newname (anonymous_spix); (* used for 'son-variable *)\r
with  curname ^ do\r
typename:= son_typename;\r
levelkind:= processlevel;\r
end\r
else\r
levelkind:= irrell_level;\r
\r
end;\r
\r
cprefix:\r
begin\r
emit (xprefix);\r
emit_extname (take_stacktop);\r
end;\r
\r
cconstant: set_error_type; (* in case of missing typename in front of structured const *)\r
\r
clabel:\r
emitid (xlabelid, curname);\r
\r
end otherwise; (* nothing *)\r
\r
end;\r
\r
cendextprocess:\r
begin\r
with cur_routine^ do\r
begin\r
with namelevel^ do\r
params (* of external process *):= firstname; (* of namelevel *)\r
\r
emitid(xextprocess, cur_routine (* may be anonymous *));\r
emitin(son_typename^.nix (* the type *));\r
\r
emitformal(params);\r
end; (* with cur routine *)\r
\r
emitid(xextprocdef, cur_routine);\r
\r
expecting_block:= false;\r
end; (* endextprocess *)\r
\r
\f

\r
cexternal,\r
cforward:\r
begin\r
\r
\r
with  cur_routine ^ do\r
begin\r
if forward_decl then\r
begin\r
errorspix:= spix; (* of cur routine *)\r
error (double_declaration) (* i.e. it was already forward declared *)\r
end\r
else\r
\r
(* set the proper flag and emit the corresponding record *)\r
case rectype of\r
\r
cexternal:\r
begin\r
external_decl:= true;\r
emit (xexternal);\r
end;\r
\r
cforward:\r
begin\r
if namekind = cprocess then\r
error(forward_process_not_allowed);\r
forward_decl:= true;\r
emit (xforward);\r
end;\r
\r
end otherwise; (* case rectype *)\r
\r
end; (* with names *)\r
\r
expecting_block:= false; (* flag to omit 'blockno' *)\r
\r
end;\r
\r
\f

\r
cendformallist:\r
\r
begin\r
\r
(* 'cur_routine'  is the name of the process/procedure/function *)\r
(* 'cur_typename' is the name of the common type *)\r
(* 'cur_typenode' is the corresponding typenode *)\r
\r
(* 'listfirst' and 'listlast' outpoint the list of formal params *)\r
\r
paramkind:=  listfirst ^ . namekind;\r
(* may be value/var param *)\r
\r
(* check paramkind versus routinekind to test legality of parameter-type *)\r
with  cur_typenode ^ do\r
with  cur_routine ^ do\r
begin\r
\r
not_allowed:= [];\r
\r
case namekind (* of routine *) of\r
\r
ctype: ; (* not implemented *)\r
\r
cfunction,\r
cprocedure:\r
(* semaphore, reference, ext process, shadow, pool not allowed as value param *)\r
if paramkind = cvaluep then\r
not_allowed:= [ t_semaphore, t_reference, t_extprocess, t_shadow, t_pool ];\r
\r
cextprocess,\r
cprocess:\r
(* reference, shadow, ext process, pool not allowed at all *)\r
(* semaphore not allowed as value param *)\r
(* pointers may not be modified by child *)\r
if testprocessparam (cur_typename, paramkind = cvarp) then\r
not_allowed:= contents (* i.e. provoke error below *)\r
else\r
if paramkind = cvaluep then\r
not_allowed:= [ t_semaphore ];\r
\r
end otherwise; (* case namekind *)\r
\r
if not_allowed * contents (* of param type *) <> [] then\r
begin\r
(* the parameter type was illegal, replace it *)\r
error (illegal_formal_type);\r
set_error_type;\r
end;\r
\r
end; (* with cur_routine *) (* with cur_typenode *)\r
\r
(* pass the type to all formals in the list *)\r
\r
with  listlast ^ do listtop:= nextname;\r
\r
while listfirst <> listtop do\r
with  listfirst ^ do\r
begin\r
typename:= cur_typename;\r
listfirst:= nextname;\r
end;\r
\r
poptype;\r
\r
end;\r
\r
\f

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

\r
cendprocdecl,\r
cendfuncdecl:\r
\r
begin\r
\r
(* in case of function, add the type *)\r
\r
(* emit the routinehead *)\r
\r
with  cur_routine ^ do\r
begin\r
\r
if rectype = cendfuncdecl then\r
begin\r
(* function type may not contain ... *)\r
with  cur_typenode ^ do  (* typenode of function type *)\r
if contents * [ t_semaphore, t_reference, t_extprocess, t_shadow, t_pool ] <> [] then\r
begin\r
error (illegal_function_type);\r
set_error_type;\r
end;\r
\r
typename (* of function name *):= cur_typename;\r
\r
(* allocate a namenode for holding the function value *)\r
cur_namekind:= cfuncval;\r
insert_in_front:= true;  (* note: it must be the very first in formal list *)\r
curname:= newname (anonymous_spix);\r
insert_in_front:= false; (* all other names etc are inserted in rear *)\r
with  curname ^ do\r
typename:= cur_typename;\r
\r
poptype;\r
\r
end; (* if function declaration *)\r
\r
(* the whole paramlist (including implicit types) are in the *)\r
(*   current namelevel in namestack *)\r
\r
(* transfer the paramlist pointer to this routine *)\r
\r
(* but first compare the new paramlist against the old paramlist *)\r
(* (in case of earlier forward declaration) *)\r
if forward_decl then\r
compare_paramlists; (* the new list must be empty or match exactly *)\r
\r
with  namelevel^ do\r
params (* of cur_routine *):= firstname; (* of namelevel *)\r
\r
emitroutinehead (cur_routine);\r
\r
(* the routine is of special interrest, if it is: 'ord', 'succ', etc *)\r
if spix <= maxstdspix then\r
specialspix (cur_routine);\r
\r
end; (* with cur_routine *)\r
\r
end;\r
\r
\f

\r
cendconstantdecl:\r
\r
begin\r
\r
testvalue (stacktop);\r
\r
with  listfirst ^ do (* nb just one name in the list *)\r
begin\r
usedlevel:= lowestlevel;  (* let the identifier be defined now... *)\r
with  stacktop ^ do\r
typename (* of constant *):= op_typename;  (*i.e. copy from expression type *)\r
end;\r
\r
const_decl:= true;\r
emit_and_release (stacktop);\r
const_decl:= false;\r
\r
emitid (xconstid, listfirst);\r
\r
end;\r
\r
\r
\r
cendtypedecl:\r
\r
begin\r
emittype (cur_typename);\r
emit (xtypedef);\r
\r
(* the type is of special interrest in case of 'reference' etc *)\r
with  cur_typename ^ do\r
if spix <= maxstdspix then\r
specialspix (cur_typename);\r
\r
poptype;\r
\r
end;\r
\r
\r
\r
cnoinit,\r
cinit:\r
var_initialization:= rectype = cinit;\r
\r
\r
\r
cendvardecl:\r
\r
begin\r
\r
(* semaphore and pool may only *)\r
(*   be declared on process-level *)\r
\r
if cur_blockno <> process_block then\r
begin\r
with  cur_typenode ^ do\r
if [ t_semaphore, t_pool, t_extprocess ] * contents (* of type *) <> [] then\r
begin\r
error (type_may_only_be_used_at_process_level);\r
set_error_type;\r
end;\r
end;\r
\r
(* transfer the type to all variables in the namelist *)\r
\r
with  listlast ^ do listtop:= nextname;\r
\r
while listfirst <> listtop do\r
begin\r
emitid (xvarid, listfirst);\r
with  listfirst ^ do\r
begin\r
typename:= cur_typename;\r
listfirst:= nextname;\r
end;\r
end;\r
\r
emittype (cur_typename);\r
\r
if var_initialization then\r
begin\r
testinitialize (cur_typename, var_init_incompatible);\r
emit_and_release (stacktop);\r
emit (xinitconst);\r
end;\r
\r
emit (xvarlist);\r
\r
poptype;\r
\r
end;\r
\r
\f

\r
\r
cexport,\r
cexportvalue,\r
cexportsize,\r
cexportdisp,\r
cexportoffset,\r
cexportaddr:\r
export_procedure;\r
\r
cenddeclarations:\r
\r
begin\r
\r
(* this record comes at end of each context *)\r
(*   and at the first 'begin' in a routine *)\r
\r
(* the separation of these two will be done by 'startlabelscope' *)\r
\r
afterdecl:= true;\r
\r
(* test that all forward-declared routines have been solved *)\r
with  namelevel^ do\r
curname:= firstname;   (* first name in name list *)\r
while curname <> nilname do\r
with  curname ^ do\r
begin\r
if forward_decl then\r
begin\r
errorspix:= spix; (* of curname *)\r
error (forward_not_solved);\r
end;\r
curname:= nextname;\r
end;\r
\r
cur_dyn_var_level:= nil; (* all varianble levels are legal *)\r
\r
end;\r
\r
\r
\r
cstartlabelscope,\r
cendlabelscope:\r
\r
begin\r
\r
cur_labelscope:= passin;\r
\r
if afterdecl then\r
begin\r
(* this is the 'begin' of a routine *)\r
afterdecl:= false;\r
\r
if expecting_block then\r
begin_block; (* because there were no declarations at all *)\r
\r
if cur_blockno = process_block then\r
begin\r
(* process level *)\r
(* find the relevant exception procedure *)\r
\r
curname:= findname (exception_spix);\r
with  curname ^ do (* namenode of exception procedure *)\r
if namekind <> cprocedure then\r
curname:= exception_procname;\r
(* nb nb nb nb: test korrekt paramliste *)\r
\r
emitid (xexception, curname);\r
end;\r
\r
emit (xinitblock);\r
\r
initlabels;\r
\r
end;\r
\r
set_label_state (rectype = cstartlabelscope);\r
\r
end;\r
\r
\r
\r
cbegincode:\r
begin\r
begin_block;\r
emit_and_release (stacktop);  (* literal == stack appetite *)\r
emit (xbegincode);\r
end;\r
\r
\r
\r
ccodeline:\r
begin\r
emit (xcodeline);\r
lineno:= passin;  (* number of chars in line *)\r
emitin (lineno);\r
for lineno:= lineno downto 1 do emitin (passin);\r
end;\r
\r
\f

\r
cendcode,\r
cendblock:\r
\r
begin\r
\r
(* release all local namenodes and their typenodes *)\r
\r
(* notice: the namenodes of the parameters to a block *)\r
(*         are released by the surrounding block *)\r
\r
if rectype = cendcode then\r
emit (xendcode)\r
else\r
emit (xendblock);\r
if cur_blockno <> process_block then\r
cur_blockno:= cur_blockno - 1;\r
(* release local declared variables, nb ! only precent if "endblock" *)\r
if rectype = cendblock then\r
\r
releasenames ( namelevel^ . firstname);\r
\r
(* test that functions have had a chance for assigning a value *)\r
if rectype = cendblock then\r
with  namelevel^.former_level^ do  (* parameter-level *)\r
with  firstname ^ do        (* first formal name *)\r
if namekind = cfuncval then      (* it must have been a function *)\r
if not func_assigned then\r
error (funcval_not_used);\r
\r
end;\r
\r
\f

\r
ctypeid:\r
\r
begin\r
\r
(* an existing typenode will be reused *)\r
\r
pushtype; (* because types may be nested *)\r
\r
cur_typename:= usename (passin (* = spix *) );\r
\r
with  cur_typename ^ do\r
\r
begin\r
\r
cur_typenode:= typ;\r
\r
(* test that the namenode really was a typename node *)\r
if (namekind<>ctype) and (namekind<>cextprocess) then\r
begin\r
errorspix:= spix;\r
error (not_typename);\r
set_error_type;\r
end;\r
\r
end; (* with cur_typename *)\r
\r
if cur_namekind = ctype then\r
begin\r
(* this is:   <name> = <typename>;  *)\r
(* setup an 'alias' node *)\r
\r
(* it is not nescessary to test for recursive use, because it *)\r
(* has been tested that rigthhand name was the name of a defined type *)\r
\r
cur_typenode:= alloc_typenode;\r
with  cur_typenode ^ do\r
begin\r
typekind:= calias;\r
element:= cur_typename;\r
index   :=   element ^ . typ ^ . index;\r
contents:=   element ^ . typ ^ . contents;\r
packflag:=   element ^ . typ ^ . packflag;\r
end;\r
\r
cur_typename:= curname;\r
\r
with  cur_typename ^ do\r
begin\r
typ:= cur_typenode;\r
if forward_decl and (typ^.element^.typ^.typekind<>cpointer) then\r
begin\r
errorspix:= spix;\r
error(forward_must_be_pointer);\r
set_error_type;\r
end;\r
forward_decl:= false;\r
end;\r
\r
\r
end; (* if namekind = ctype *)\r
\r
end;\r
\r
\r
\r
\r
cendtype: ; (* blind *)\r
\r
\f

\r
cwithout_data:\r
\r
begin\r
\r
(* this special type is used by 'pool definition' to simulate notype *)\r
\r
pushtype; (* because this type is nested in 'pool-def' *)\r
\r
cur_typename:= nil_typename;\r
cur_typenode:=  cur_typename ^ . typ;\r
\r
end;\r
\r
\f

\r
cnewtype:\r
\r
begin\r
\r
(* a new type will be constructed *)\r
\r
pushtype; (* because types may be nested *)\r
\r
if cur_namekind <> ctype then\r
begin\r
(* implicit type, insert pseudo typename *)\r
\r
cur_typename:= newname (anonymous_spix);\r
\r
with  cur_typename ^ do\r
namekind:= ctype;\r
\r
end\r
\r
else\r
\r
begin\r
(* explicit type, use 'curname' as 'cur_typename' *)\r
\r
cur_typename:= curname;\r
cur_namekind:= cnocode; (* only the outermost newtype is explicit *)\r
\r
end;\r
\r
(* prepare the succeding typedefinitions *)\r
cur_typenode:= alloc_typenode;\r
\r
with  cur_typename ^ do\r
typ:= cur_typenode;\r
\r
end;\r
\r
cextprocess:\r
begin\r
with cur_typename^ do\r
begin\r
namekind:= cextprocess; (* change from ctype to cextprocess *)\r
typename:= son_typename;\r
release_typenode(typ);\r
typ:= son_typename^.typ;\r
cur_typenode:= typ;\r
end;\r
cur_routine:= cur_typename; (* prepare formal parameters *)\r
end;\r
\r
\f

\r
cscalar,\r
csubrange,\r
carray,\r
crecord,\r
cset,\r
cpool,\r
cpointer,\r
creadonly,\r
cinteger,\r
creal,\r
cniltype:\r
begin\r
(* insert the rectype in the 'cur_typenode' *)\r
with  cur_typenode ^ do\r
typekind:= rectype;\r
\r
(* maybe push the current namelist, in case of inner namelists *)\r
if rectype = crecord then\r
begin\r
pushlist;\r
newnamelevel;\r
end;\r
\r
if rectype = cscalar then\r
begin\r
pushlist;\r
with  cur_typename ^ do\r
if spix <> anonymous_spix then   (* keep scalarelems on the correct namelevel *)\r
endnamelevel;\r
end;\r
\r
\r
with  cur_typename ^ do\r
if (rectype<>cpointer) and forward_decl then\r
begin\r
errorspix:= spix;\r
error(forward_must_be_pointer);\r
set_error_type;\r
forward_decl:= false;\r
end;\r
\r
if rectype=cpointer then\r
cur_typename^.forward_decl:= false\r
else\r
if rectype = cinteger then\r
integer_typename:= cur_typename\r
else\r
if rectype = cniltype then\r
nil_typename:= cur_typename;\r
end;\r
\r
cforwardpointer:\r
with cur_typename^ do\r
begin\r
release_typenode(typ); (* not used, a new node will be allocated when the real declaration is met *)\r
typ:= dummy_typenode;\r
forward_decl:= true;\r
end; (* forward pointer *)\r
\f

\r
cendscalar:\r
\r
begin\r
\r
(* add the scalar-list to the scalar type node *)\r
\r
with  cur_typenode ^ do (* typenode of scalar type *)\r
begin\r
element:= listfirst;\r
(* contents:= [ t_simple ];  *)\r
end;\r
\r
(* insert typename in the whole scalar-list *)\r
with  listlast ^ do listtop:= nextname;\r
\r
while listfirst <> listtop do\r
with  listfirst ^ do\r
begin\r
typename:= cur_typename;\r
listfirst:= nextname;\r
end;\r
\r
with  cur_typename ^ do\r
if spix <> anonymous_spix then  (* keep scalarelems on correct namelevel *)\r
newnamelevel;\r
\r
poplist; (* return to outer namelist *)\r
\r
end;\r
\r
\f

\r
cendsubrange:\r
\r
begin\r
\r
(* the two expressions are in 'stacktop' and 'nexttop' *)\r
\r
(* the two expressions must be <same> enumeration type *)\r
lefttypename (* dummy assignment *):= testenumeration (nexttop); (* nb: exprtypename = simplified typename *)\r
resolvetype (stacktop, rigthtypename, rigthelement, rigthbasekind);\r
if exprtypename <> rigthtypename then\r
begin\r
error (subrange_elems_must_be_enumeration);\r
exprtypename:= error_typename;\r
end;\r
\r
(* bind the two expressions to a single one *)\r
oper (binary, crangefirst, exprtypename);\r
\r
with  cur_typenode ^ do\r
begin\r
subexpr:= take_stacktop; (* remember the two expressions *)\r
index  := exprtypename;\r
(* contents:= [ t_simple ];  *)\r
end;\r
\r
end;\r
\r
\f

\r
cendarray:\r
\r
begin\r
\r
test_recursive_type;\r
\r
elemname:= cur_typename; poptype;\r
indexname:= cur_typename; poptype;\r
\r
testindex (indexname);\r
\r
with  cur_typenode ^ do (* typenode of array *)\r
begin\r
element:= elemname;\r
index  := indexname;\r
contents:=   elemname ^ . typ ^ . contents;\r
(* transfer contents from element type *)\r
end;\r
\r
end;\r
\r
\f

\r
cendfield:\r
\r
begin\r
\r
(* types may not be recursive *)\r
test_recursive_type;\r
\r
with  listlast ^ do listtop:= nextname;\r
while listfirst <> listtop do\r
with  listfirst ^ do\r
begin\r
typename:= cur_typename;\r
listfirst:= nextname;\r
end;\r
\r
elemname:= cur_typename;\r
poptype; (* return to record typename/typenode *)\r
\r
(* transfer field-contents to record-contents *)\r
with  cur_typenode ^ do (* typenode of record *)\r
contents:= contents +   elemname ^ . typ ^ . contents;\r
\r
end;\r
\r
\f

\r
cendrecord:\r
\r
begin\r
\r
endnamelevel;\r
\r
(* transfer the whole current namelist, i.e. the list of field-names *)\r
(*   and their implicit types, to the record-typenode *)\r
\r
with  cur_typenode ^ do (* typenode of record *)\r
with  namelevel^.next_level^ do (* just terminated field list *)\r
element:= firstname;\r
\r
poplist; (* return to outer namelist *)\r
\r
end;\r
\f

cendset:\r
\r
begin\r
\r
(* indexname must be enumeration type *)\r
\r
indexname:= cur_typename;\r
poptype; (* return to set-type *)\r
\r
testindex (indexname);\r
\r
with  cur_typenode ^ do (* typenode of set *)\r
begin\r
element:= indexname;\r
(* contents:= [ t_simple ];  *)\r
end;\r
\r
end;\r
\r
\f

\r
cendpool:\r
\r
begin\r
\r
(* test that <cardinality> is <integer> *)\r
\r
resolvetype (stacktop, exprtypename, exprelement, exprbasekind);\r
if exprbasekind <> cinteger then\r
begin\r
error (pool_cardinality_must_be_integer);\r
end;\r
\r
(* test legality of type *)\r
\r
with  cur_typenode ^ do (* typenode of pool-sizetype *)\r
(* it may not contain: semaphore, shadow, reference, pool, pointer *)\r
if contents * [ t_semaphore, t_reference, t_extprocess, t_shadow, t_pool, t_pointer ] <> [] then\r
begin\r
error (illegal_pool_type);\r
set_error_type;\r
end;\r
\r
elemname:= cur_typename;\r
poptype; (* return to pool *)\r
\r
with  cur_typenode ^ do (* typenode of pool *)\r
begin\r
subexpr:= take_stacktop;\r
element:= elemname;\r
contents:= [ t_pool ];\r
end;\r
\r
end;\r
\r
\f

\r
cendreadonly,\r
cendpointer:\r
\r
begin\r
\r
if rectype = cendreadonly then\r
test_recursive_type;\r
(* notice: pointer-to-type is not considered recursion *)\r
\r
elemname:= cur_typename;\r
poptype; (* return to readonly/pointer type *)\r
\r
with  cur_typenode ^ do\r
begin\r
element:= elemname;\r
if rectype = cendpointer then\r
contents:= [ t_pointer ]\r
else\r
contents:=   element ^ . typ ^ . contents + [ t_readonly ];\r
end;\r
\r
end;\r
\r
\f

\r
cpacked:\r
\r
begin\r
(* 'cur_typename/node' are nodes of record/array (or set) *)\r
\r
with  cur_typenode ^ do\r
packflag:= true;\r
\r
end;\r
\r
\f

\r
cbegin:\r
prepare_statement;\r
\r
cend: ; (* blind *)\r
\r
clabeldef:\r
\r
begin\r
\r
(* label def statement *)\r
definelabel ( passin (* = scopeno *) , passin (* = spix *) );\r
\r
end;\r
\r
\f

\r
ccasestat:\r
prepare_expression;\r
\r
ccaseexpr:\r
begin\r
pushname (case_typename); (* because case may be nested *)\r
case_typename:= testenumeration (stacktop);\r
case_typename:= exprtypename;  (* nbnbnbnb: get simplified typename *)\r
\r
emit (xcasestat);\r
\r
emit_and_release (stacktop);\r
\r
emit (xcase);\r
end;\r
\r
\r
ccaselabel:\r
begin\r
(* the caselabel must have same type as the case-expression *)\r
resolvetype (stacktop, exprtypename, exprelement, exprbasekind);\r
if case_typename <> exprtypename then\r
  error (case_incompatible);\r
\r
emit_and_release (stacktop);\r
\r
emit (xcaselabel);\r
\r
end;\r
\r
\r
\r
ccaselabelrange:\r
begin\r
(* both caselabels must match the case-expression *)\r
equaltypes (nexttop, stacktop, case_typename, case_incompatible);\r
\r
(* bind the two expressions together *)\r
oper (binary, crangefirst, nilname (* irrell typename *) );\r
emit_and_release (stacktop);\r
\r
emit (xcaserange);\r
\r
end;\r
\r
\r
\r
cotherwise:\r
emit (xotherwise);\r
\r
\r
\r
ccaselist:\r
begin\r
prepare_statement;\r
emit (xendcaselist);\r
end;\r
\r
\r
\r
ccaseelement:\r
begin\r
prepare_expression;\r
emit (xendcasestat);\r
end;\r
\r
\r
\r
cendcase:\r
begin\r
\r
emit (xendcase);\r
\r
(* unstack case type name *)\r
case_typename:= popname;\r
\r
prepare_statement;\r
\r
end;\r
\r
\f

\r
cforstat:\r
prepare_expression;\r
\r
cforvar:\r
begin\r
(* the controlling variable must be: assignable, unpacked variable *)\r
testassignable (stacktop);\r
testunpacked (stacktop);\r
for_typename:= testenumeration (stacktop);\r
for_basetypename:= exprtypename;  (* nbnbnbnb: get simplified typename *)\r
\r
emit (xforstat);\r
emit_and_release (stacktop);\r
emit (xfor);\r
\r
end;\r
\r
\r
\r
cup,\r
cdown:\r
begin\r
equaltypes (nexttop, stacktop, for_basetypename, for_incompatible);\r
\r
(* insert a possible range-test after each of the two expressions *)\r
testrange (for_typename);\r
for_expr:= take_stacktop;\r
testrange (for_typename);\r
\r
emit_and_release (stacktop); (* start-value *)\r
if rectype = cup then\r
emit (xup)\r
else\r
emit (xdown);\r
emit_and_release (for_expr); (* end-value *)\r
\r
emit (xdo);\r
\r
prepare_statement;\r
\r
end;\r
\r
cendfor:\r
emit (xendfor);\r
\f

cifstat:\r
prepare_expression;\r
\r
\r
\r
cifexpr:\r
begin\r
\r
assure (stacktop, boolean_typename, if_type);\r
\r
emit (xifstat);\r
\r
emit_and_release (stacktop);\r
\r
emit (xifexpr);\r
\r
prepare_statement;\r
\r
end;\r
\r
\r
\r
celse:\r
emit (xelse);\r
\r
\r
\r
cendif:\r
emit (xif);\r
\r
\f

crepeatstat:\r
emit (xrepeat);\r
\r
\r
\r
cuntil:\r
prepare_expression;\r
\r
\r
\r
cendrepeat:\r
begin\r
\r
assure (stacktop, boolean_typename, repeat_type);\r
\r
emit (xuntil);\r
\r
emit_and_release (stacktop);\r
\r
emit (xendrepeat);\r
\r
prepare_statement;\r
\r
end;\r
\f

cloopstat:\r
emit(xloopstat);\r
\r
cendloopstat:\r
emit(xendloopstat);\r
\r
ccontloopstat,\r
cexitloopstat:\r
begin\r
if rectype=ccontloopstat then\r
emit(xcontloopstat)\r
else\r
emit(xexitloopstat);\r
case password (* kind of repetitive statement *) of\r
cloopstat: emit(xloopstat);\r
crepeatstat: emit(xrepeat);\r
cforstat: emit(xforstat);\r
cwhilestat: emit(xwhile);\r
end\r
otherwise\r
comp_error(unknown_rectype);\r
end; (* contloopstat/exitloopstat *)\r
\r
cexitlock:\r
begin\r
emit(xexitlock);\r
case password (* kind:lock or channel *) of\r
clockstat: (* both kinds of lock *) emit(xlockstat);\r
cchannelstat: emit(xchannel);\r
end\r
otherwise\r
comp_error(unknown_rectype);\r
end; (* exitlock *)\r
\r
cexitstat:\r
begin\r
emit(xexitstat);\r
end;\r
\f

\r
cwhilestat:\r
begin\r
emit (xwhile);\r
prepare_expression;\r
end;\r
\r
\r
\r
cwhileexpr:\r
begin\r
\r
assure (stacktop, boolean_typename, while_type);\r
\r
emit_and_release (stacktop);\r
\r
emit (xwhileexpr);\r
\r
prepare_statement;\r
\r
end;\r
\r
\r
\r
cendwhile:\r
emit (xendwhile);\r
\r
\f

\r
clockstat,\r
clockmesstat,\r
cwithcomma,\r
cwithstat:\r
\r
begin\r
\r
case rectype of\r
clockstat:\r
begin\r
start_of_protected:= true;  (* prepare: goto not out of lock-statement *)\r
emit (xlockstat);\r
levelkind:= firstlock;\r
end;\r
clockmesstat:\r
begin\r
start_of_protected:= true;  (* prepare: goto not out of lock-statement *)\r
emit (xlockmesstat);\r
levelkind:= firstlock;\r
end;\r
cwithcomma,\r
cwithstat:\r
begin\r
emit (xwith);\r
if rectype = cwithstat then\r
levelkind:= firstwith\r
else\r
if levelkind=nextlock then (* withcomma only allowed in WITH statements *)\r
error(short_form_of_multiple_locks_not_allowed);\r
end;\r
end otherwise; (* case *)\r
\r
prepare_expression;\r
\r
end;\r
\r
\r
\r
cwithvar:\r
\r
begin\r
(* most of this action is common for lock- and with-statements *)\r
\r
resolvetype (stacktop, exprtypename, exprelement, exprbasekind);\r
with  stacktop ^ do\r
with_typename:= op_typename;\r
\r
find_with_namekind(stacktop); (* with_namekind:= constant or var,\r
withvar_spix:= spix of with variable ( for errorreporting ) *)\r
testunpacked(stacktop); (* with variable must be regular *)\r
\r
newnamelevel;\r
\r
cur_dyn_var_level:= namelevel;\r
\r
with namelevel^ do\r
\r
begin\r
\r
(* test the lockvar/withvar *)\r
\r
case namelistkind of\r
\r
firstlock,\r
nextlock:\r
begin\r
levelkind:= nextlock;\r
(* variable must be of type reference *)\r
if exprtypename <> reference_typename then\r
if exprbasekind <> cerrorkind then  (* suppress if already in error *)\r
error (lock_type);\r
end;\r
\r
firstwith,\r
nextwith:\r
begin\r
levelkind:= nextwith;\r
(* if the variable is of a record type then open for the field names *)\r
if exprbasekind = crecord then\r
insert_namelist (exprelement (* = field name list of record *) );\r
end;\r
\r
end otherwise; (* case namelistkind *)\r
\r
emit_and_release (stacktop); (* variable *)\r
\r
if levelkind = nextwith then\r
begin\r
(* initialize namelevel *)\r
withname:= alloc_namenode;\r
with  withname ^ do\r
begin\r
spix:= withvar_spix;\r
namekind:= with_namekind; (* constant or var, depending on namekind of withvar *)\r
typename:= with_typename;  (* insert typename *)\r
end;\r
end; (* if with statement *)\r
end; (* with namelevel *)\r
\r
newnamelevel; (* with/lock statements has a name level for the with-object and\r
one for the new name, even if there is no renaming involved *)\r
levelkind:= namelevel^.namelistkind; (* reset levelkind *)\r
end; (* withvar *)\r
\r
\r
cnolocaldecl: \r
begin\r
with namelevel ^ .former_level ^ (* with/lock-object level *) do\r
if (namelistkind=firstlock) or (namelistkind=nextlock) then\r
error(lock_name_missing)\r
else\r
begin\r
emitid (xwithvar, withname);\r
emit(xnoretype);\r
end; (* if with-statement *)\r
cur_dyn_var_level:= nil; (* all levels are legal *)\r
end; (* nolocaldecl *)\r
\r
\r
cnolocaltype: begin\r
with listfirst^ do (* namenode of local var *)\r
begin\r
if levelkind=nextwith then\r
begin\r
namekind:= with_namekind; (* constant or var, depending on namekind of withvar *)\r
usedlevel:= lowestlevel; (* in case of constant *)\r
typename:= with_typename; (* same type as the with-object *)\r
emitid (xwithvar, listfirst);\r
emit(xnoretype);\r
namelevel^.former_level^.firstname:= nilname;\r
end\r
else\r
error(buffer_type_missing);\r
cur_dyn_var_level:= nil; (* all levels are legal *)\r
end; (* with listfirst *)\r
end; (* nolocaltype, i.e. renaming *)\r
\r
\r
cendlocaldeclare:\r
begin\r
\r
with  listfirst ^ do (* namenode of local var *)\r
begin\r
\r
(* test legality of local type *)\r
with  cur_typenode ^ do\r
if contents * [ t_semaphore, t_pointer, t_reference, t_extprocess, t_shadow, t_pool ] <> [] then\r
begin\r
set_error_type;\r
errorspix:= cur_typename^.spix;\r
error (type_has_systemtypes);\r
end;\r
\r
if namelevel^.namelistkind=nextwith then\r
begin\r
namekind:= with_namekind; (* constant or var, depending on namekind of withvar *)\r
usedlevel:= lowestlevel; (* in case of constant *)\r
with with_typename^.typ^ do\r
(* test legality of original type *)\r
if contents * [ t_semaphore, t_pointer, t_reference, t_extprocess, \r
t_shadow, t_pool, t_readonly ] <> [] then\r
begin\r
set_error_type;\r
errorspix:= with_typename^.spix;\r
error (type_has_systemtypes);\r
end;\r
end;\r
\r
typename:= cur_typename;\r
\r
end;\r
\r
case namelevel^.namelistkind of\r
firstlock,\r
nextlock: begin\r
emitid (xlockvar, listfirst);  (* notice: first name in namelevel *)\r
emittype (cur_typename);\r
emit (xlock);\r
end;\r
firstwith,\r
nextwith: begin\r
emitid (xwithvar, listfirst);  (* notice: first name in namelevel *)\r
emittype (cur_typename);\r
emit (xretype);\r
namelevel^.former_level^.firstname:= nilname;\r
end;\r
end; (* case *)\r
\r
poptype;\r
\r
cur_dyn_var_level:= nil; (* all levels are legal *)\r
\r
end;\r
\r
\r
\r
cdo:\r
prepare_statement;\r
\r
\r
cendlock,\r
cendwith:\r
begin\r
\r
repeat\r
\r
(* unstack two name levels per lock/with *)\r
releasenames(namelevel^.firstname); (* local object name *)\r
endnamelevel;\r
\r
with  namelevel^ do (* of with-object *)\r
begin\r
\r
case namelistkind of\r
\r
firstlock,\r
nextlock:\r
emit (xendlock);\r
firstwith,\r
nextwith:\r
emit (xendwith);\r
\r
end otherwise; (* case *)\r
\r
levelkind:= namelistkind;\r
\r
releasenames (withname);\r
\r
end; (* with namelevel *)\r
\r
endnamelevel;\r
\r
until (levelkind = firstlock) or (levelkind = firstwith);\r
\r
end;\r
\r
\f

\r
cgotostat:\r
prepare_expression;\r
\r
\r
\r
cendgoto:\r
\r
begin\r
with  stacktop ^ do\r
begin\r
\r
errorcode:= check_label (op_name);\r
\r
if errorcode <> noerror then\r
  error (errorcode)\r
else\r
emitid (xgoto, op_name);\r
\r
end; (* with stacktop *)\r
release_expr (take_stacktop);\r
prepare_statement;\r
end;\r
\r
\f

\r
cchannelstat:\r
begin\r
start_of_protected:= true;  (* prepare: goto not out of channel-statement *)\r
prepare_expression;\r
end;\r
\r
\r
\r
cchanvar:\r
\r
begin\r
\r
testvariable (stacktop);\r
assure (stacktop, reference_typename, channel_type);\r
\r
emit (xchannel);\r
emit_and_release (stacktop);\r
emit (xchanvar);\r
\r
prepare_statement;\r
\r
end;\r
\r
\r
\r
cendchannel:\r
emit (xendchannel);\r
\r
\r
\r
cendassign:\r
begin\r
(* lefthandside must be assignable variable *)\r
testassignable (nexttop);\r
(* the rigthhandside must be a value *)\r
(* implicitly tested by resolvetype *)\r
resolvetype (nexttop, lefttypename, leftelement, leftbasekind);\r
resolvetype (stacktop, rigthtypename, rigthelement, rigthbasekind);\r
if lefttypename <> rigthtypename then\r
test_value_compatible (assign_incompatible);\r
if  nexttop ^ . op_typename <>  stacktop ^ . op_typename then\r
with  nexttop ^ do\r
testrange (op_typename);  (* make rangetest, when assigning to subrange *)\r
oper (binary, rectype, nilname);\r
emit_and_release (stacktop);\r
prepare_statement;\r
end;\r
\r
\r
\r
cendexchange:\r
begin\r
(* both left- and rigthhandside must be assignable variables *)\r
(* of exactly the same type *)\r
testexchangable (nexttop);\r
testexchangable (stacktop);\r
with  nexttop ^ do\r
(* type must be reference or shadow *)\r
if (op_typename <> reference_typename) and\r
(op_typename <> shadow_typename) then\r
error (exchange_type)\r
else\r
if op_typename <>  stacktop ^ . op_typename then\r
error (exchange_incompatible);\r
oper (binary, rectype, nilname);\r
emit_and_release (stacktop);\r
prepare_statement;\r
end;\r
\r
\r
\r
cid:\r
begin\r
\r
curname:= usename (passin (* = spix *) );\r
\r
if before_assign then\r
begin\r
(* be prepared for doing special when assigning to function-name *)\r
\r
prepare_expression;\r
\r
with  curname ^ do   (* namenode of identifier *)\r
if namekind = cfunction then\r
(* a function name was used in front of an assignment *)\r
\r
(****************************************************************************)\r
(* OBS OBS !!!!! level heads are allocated from the PASCAL heap as they are\r
needed, this means that the core addresses are decreasing, without this\r
knowledge a traversal along the former-chain is necessary in order to\r
detect whether we are inside the body of the function or not !!! *)\r
(****************************************************************************)\r
\r
if ord(retrieved_level) >= ord(namelevel^.former_level) then\r
(* test if retrieved level is lower than former of current level *)\r
(* i.e. test if we are inside the body of the function *)\r
with  retrieved_level^.next_level^ do  (* level of possible paramlist *)\r
if firstname (* of namestack *) = params (* of function *) then\r
(* exchange the function name by the returnvalue name *)\r
begin\r
curname:= params;  (* first of paramlist *)\r
with  curname ^ do\r
func_assigned:= true;\r
end;\r
\r
end; (* before assign *)\r
\r
with  curname ^ do\r
begin\r
if (cur_dyn_var_level<>nil (* restrictions on legal levels for dynamic objects *)) and\r
(ord(retrieved_level)<=ord(cur_dyn_var_level)) then\r
\r
(****************************************************************************)\r
(* OBS OBS !!!!! level heads are allocated from the PASCAL heap as they are\r
needed, this means that the core addresses are decreasing, without this\r
knowledge a traversal along the former-chain is necessary in order to\r
detect whether retrieved level is greater than or equal to cur dyn var level *)\r
(****************************************************************************)\r
\r
begin\r
if (namekind <> cconstant) and (namekind <> cscalarelem) \r
and (namekind <> ctype) then\r
begin\r
errorspix:= spix; (* of curname *)\r
error( illegal_scope_of_type_component );\r
namekind:= cconstant; (* assure call of newopand, even if namekind is recfield *)\r
end; (* error *)\r
end\r
else\r
if namekind = crecfield then\r
begin\r
(* there has been a previous 'with' *)\r
(* simulate: <withname>.<fieldname> *)\r
with retrieved_level^ do  (* ... defined by: 'usename' *)\r
begin\r
with  withname ^ do\r
newopand (cid, typename (* of withname *) );\r
with  stacktop ^ do\r
op_name:= withname;\r
oper (unary, cfield, typename (* of curname ( = fieldname ) *) );\r
\r
(* insert the packflag from the record-type of the withvar *)\r
with  withname ^ do\r
with  typename ^ do   (* namenode of record-type for withvar *)\r
with  typ ^ do      (* corresponding typenode *)\r
with  stacktop ^ do\r
op_packflag:= packflag; (* from typenode of withvar *)\r
\r
end;\r
\r
end; (* if recfield *)\r
if namekind <> crecfield then\r
newopand (cid, typename (* of curname *) );\r
\r
end; (* with  curname ^ *)\r
\r
with  stacktop ^ do\r
op_name:= curname;\r
\r
end; (* cid *)\r
\r
\r
\r
cliteral:\r
begin\r
\r
cur_opandno:= cur_opandno + 1;\r
\r
rectype:= password;  (* get type of literal *)\r
\r
newopand (cliteral, nilname (* typename not defined yet *) );\r
\r
with  stacktop ^ do\r
begin\r
if rectype = cinteger then op_typename:= integer_typename\r
else\r
if rectype = creal    then op_typename:= nil_typename\r
else\r
if rectype = ctext    then op_typename:= text_typename\r
else\r
if compilertest then\r
comp_error (unknown_rectype);\r
\r
op_value:= readstring;\r
(* midlertidig simplifikation, for at kunne opfatte literal-chars *)\r
if rectype = ctext then\r
with  op_value ^ do\r
if stringlgt = 1 then\r
op_typename:= char_typename;\r
end;\r
\r
end; (* literal *)\r
\r
\r
\r
cvarsizecall,\r
ctypesizecall:\r
begin\r
cur_opandno:= cur_opandno+1;\r
curname:= usename(passin (* spix *));\r
with curname^ do\r
if rectype=cvarsizecall then\r
if (namekind<>cvar) and (namekind<>crecfield) then\r
error(not_varname)\r
else\r
(* change call to typesizecall *)\r
curname:= typename\r
else (* typesizecall *)\r
if namekind<>ctype then\r
error(not_typename);\r
\r
newopand(ctypesizecall, integer_typename (* result type *));\r
stacktop^.op_name:= curname;\r
end; (* varsizecall/typesizecall *)\r
\r
cskipparam:\r
begin\r
cur_opandno:= cur_opandno + 1;\r
newopand (cskipparam, nilname (* irrell typename *) );\r
end;\r
\r
\r
\r
(* pickup of sets *)\r
csetlist,\r
cs_element,\r
cm_element,\r
cendsetlist:\r
set_procedure;\r
\r
\r
\r
cfield:\r
begin\r
(* stacktop contains previous 'variable' *)\r
\r
cur_opandno:= cur_opandno + 1;\r
\r
newspix:= passin;\r
\r
(* if the previous 'variable' is parameterless functioncall, then... *)\r
with  stacktop ^ do\r
if opcode = cid then\r
with  op_name ^ do  (* namenode of (possible) function name *)\r
if namekind = cfunction then\r
begin\r
pushcall;\r
prepare_call (stacktop);\r
terminate_call (stacktop);\r
end;\r
\r
resolvetype (stacktop, exprtypename, exprelement, exprbasekind);\r
\r
with  exprtypename ^ do   (* namenode of <variable> type *)\r
with  typ ^ do          (* corresponding typenode *)\r
(* note: in case of alias-type, exprelement and exprbasekind are the best ones *)\r
if exprbasekind <> crecord then\r
suppress_error (exprbasekind, field_must_follow_recordtype)\r
else\r
begin\r
(* find the spix among the fieldnames of the record *)\r
curname:= exprelement;  (* first of field name list *)\r
while (newspix <> anonymous_spix (* i.e. not found yet *) )\r
and (curname <> nilname (* i.e. more names to compare to *) ) do\r
with  curname ^ do\r
if newspix = spix (* of curname *) then\r
begin\r
oper (unary, cfield, typename (* of fieldname *) );\r
with  stacktop ^ do\r
begin\r
op_name:= curname;\r
op_packflag:= packflag; (* from record typenode *)\r
end;\r
newspix:= anonymous_spix; (* indicate succes *)\r
end \r
else\r
curname:= nextname; (* follow chain, and test next name in list *)\r
\r
if curname = nilname then\r
error (name_not_fieldname);\r
\r
end; (* with names, types etc of stacktop *)\r
\r
end; (* cfield *)\r
\r
\r
\r
cuparrow:\r
begin\r
(* stacktop is <variable>, which must be pointertype *)\r
(* if the previos 'variable' is parameterless functioncall, then ... *)\r
with stacktop^ do\r
if opcode=cid then\r
with op_name ^ do (* namenode of (possible function name *)\r
if namekind=cfunction then\r
begin\r
pushcall;\r
prepare_call(stacktop);\r
terminate_call(stacktop);\r
end;\r
\r
\r
resolvetype (stacktop, exprtypename, exprelement, exprbasekind);\r
if exprbasekind <> cpointer then\r
suppress_error (exprbasekind, must_be_pointertype_before_uparrow)\r
else\r
oper (unary, cuparrow, exprelement (* follow pointer-type *) );\r
 stacktop ^ . op_packflag:= false; (* pointed variable not packed *)\r
\r
end; (* cpointer *)\r
\r
\r
\r
ceq,\r
cne,\r
clt,\r
cle,\r
cgt,\r
cge:\r
relation (rectype);\r
\r
\r
\r
cand,\r
cor,\r
cxor,\r
cplus,\r
cminus,\r
cstar,\r
cshift,\r
cslash:\r
arithop (rectype);\r
\r
\r
\r
cendexpression: ; (* blind *)\r
\r
\r
\r
cbeginactual:\r
beginactual;\r
\r
\r
\r
cactualparam,\r
cdoubleparam:\r
act_param;\r
\r
\r
\r
cendstruc,\r
cendactual:\r
terminate_call (stacktop);\r
\r
\r
\r
cbeginstruc:\r
begin (* add a type name unless explicit stated in front of (:, and\r
proceed as beginactual *)\r
with stacktop^ do\r
if (opcode<>cid) or (op_name^.namekind<>ctype) then\r
(* (: without leading type specification, assume cur_typename if outermost\r
beginstruc otherwise use the "formal" type (the structure is handled as if \r
it were a parameter list) *)\r
begin\r
if argkind=cnocode (* outermost beginstruc *) then\r
curname:= cur_typename\r
else\r
if argkind=cstrucrecord then\r
begin\r
while (curformal^.namekind<>crecfield) and (curformal<>nilname) do\r
(* bypass anonymous types in the field list *)\r
curformal:= curformal^.nextname;\r
curname:= curformal^ (* field name *) . typename;\r
end\r
else\r
curname:= curformal; (* array element type *)\r
\r
newopand(ctypeid, curname^.typename);\r
stacktop^.op_name:= curname;\r
end; (* simulate id(spix) in front of (:  *)\r
\r
beginactual;\r
\r
end; (* beginstruc *)\r
\r
\r
cendvariable:\r
terminate_funccall (stacktop);\r
\r
\r
\r
ccallprocedure:\r
begin\r
terminate_funccall (stacktop);  (* terminate any erroneous function-call *)\r
make_call (stacktop); (* make sure even a parameter-less procedure is called *)\r
(* test that the stacktop identifies a procedure call *)\r
with  stacktop ^ do\r
if opcode <> cendproc then\r
error (not_procedure_call);\r
emit_and_release (stacktop);\r
prepare_statement;\r
end;\r
\r
\r
\r
cuplus,\r
cuminus:\r
begin\r
resolvetype (stacktop, exprtypename, exprelement, exprbasekind);\r
(* expression must be of integer or real types *)\r
if (exprbasekind = cinteger) or (exprbasekind = creal) then\r
oper (unary, rectype, exprtypename)\r
else\r
suppress_error (exprbasekind, monadic_error);\r
end;\r
\r
\r
\r
cdiv,\r
cmod:\r
begin\r
(* both operands must be integers *)\r
equaltypes (nexttop, stacktop, integer_typename, arithmetic_error);\r
oper (binary, rectype, integer_typename);\r
end;\r
\r
\r
\r
cnot:\r
begin\r
(* stacktop must be of boolean or integer type *)\r
resolvetype (stacktop, exprtypename, exprelement, exprbasekind);\r
\r
if (target_machine = targetz80) and (exprtypename <> boolean_typename) then\r
error( monadic_error );\r
\r
if (exprtypename = integer_typename) or ( exprtypename = boolean_typename ) then\r
oper( unary, rectype, exprtypename )\r
else\r
suppress_error( exprbasekind, monadic_error);\r
end;\r
\r
\r
\r
cin:\r
begin\r
(* rigth opand must be of set-type *)\r
lefttypename (* dummy assignment *):= testenumeration (nexttop);\r
(* note: exprtypename is simplified typename of nexttop *)\r
resolvetype (stacktop, rigthtypename, rigthelement, rigthbasekind);\r
if (exprbasekind <> cerrorkind) and (rigthbasekind <> cerrorkind) then\r
if rigthbasekind <> cset then\r
error (relation_error)\r
else\r
if rigthelement <> nil_typename then   (* omit error, if empty set *)\r
if exprtypename <> rigthelement then\r
error (relation_error);\r
oper (binary, cin, boolean_typename);\r
end;\r
\r
\r
\r
\r
ceom:\r
endpass1:= true;\r
\r
\r
\r
end (* case rectype *)\r
\r
otherwise\r
comp_error (unknown_rectype);\r
\r
until endpass1;\r
\r
\r
    \r
(* end of program *)\r
999:\r
terminate;\r
\r
if call_pass4 then\r
case target_machine of\r
targetz80: replace('pass4z80');\r
target35021: replace('rtp35021p4');\r
target35022: replace('rtp35022p4');\r
end\r
otherwise ;\r
writeln ('*** compilation terminated after pass', own_passno:1);\r
halt(false (* terminate program with ok.no *));\r
end.\r
«eof»