DataMuseum.dk

top - download

    Length: 46890 (0xb72a)
    Types: TextFile
    Names: »P3PROC.PAS«

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

TextFile

procedure emitformal (plist: nameptr);\r
(* output:  ( paramid(nix) <type> cparam/vparam )*  *)\r
procedure emit_one_formal (xparamkind: pass3codes);\r
begin\r
if testoutput then continue_line;\r
emitid (xparamid, plist);\r
emittype (  plist ^ . typename );\r
emit (xparamkind);\r
end;\r
begin\r
\r
while plist <> nilname do\r
with  plist ^ do (* namenode of current parameter *)\r
begin\r
case namekind of\r
cfuncval: emit_one_formal (xvarparam);     (* function value *)\r
cvaluep:  emit_one_formal (xvalueparam);      (* value parameter *)\r
cvarp:    emit_one_formal (xvarparam);        (* var parameter *)\r
ctype,        (* implicit type decls *)\r
cundeclared,  (* undeclared typenames *)\r
cscalarelem:  (* scalar-elems of implicit typedecls *)\r
; (* no action *)\r
else\r
comp_error(unknown_paramkind);\r
end;\r
\r
plist:= nextname;  (* follow chain *)\r
end;  (* while/with plist *)\r
\r
end;\r
\r
\r
\r
procedure emitroutinehead (xname: nameptr);\r
(* 'xname' is the namenode of the routine *)\r
\r
(* if this is second emit of routinehead, i.e. earlier was 'forward' *)\r
(*    then emit short description,\r
(*    otherwise emit the complete routine head *)\r
\r
begin\r
\r
with  xname ^ do (* namenode of routine *)\r
if forward_decl then\r
begin\r
case namekind of\r
cprocess,\r
cprocedure: emitid (xsecprocid, xname);\r
cfunction:  emitid (xsecfuncid, xname);\r
else\r
if compilertest then comp_error (unknown_namekind);\r
end;\r
emit_extname (opand_procname);  (* emit the name once again... *)\r
end\r
else\r
begin\r
\r
case namekind of\r
cprocess:   emitid (xprocessid, xname);\r
cprocedure: emitid (xprocid, xname);\r
cfunction:  emitid (xfuncid, xname);\r
else\r
comp_error(unknown_routinekind);\r
end;\r
\r
if namekind = cprocess then\r
begin\r
(* emit the son var nix *)\r
emitin (nextname^.nix); (* 'sonvar' is next to 'processname' *)\r
emitin (son_typename^.nix);  (* type-nix of 'sonvariable' *)\r
end;\r
\r
(* emit external name of the routine *)\r
emit_extname (opand_procname);\r
\r
(* emit formallist *)\r
emitformal (params);\r
\r
end; (* if first emission of this routine head *)\r
\r
(* set flag to look for first local declaration *)\r
expecting_block:= true;\r
\r
end; (* procedure emitroutinehead *)\r
\r
\r
\r
function testprocessparam (xtypename: nameptr; dangerous: boolean) : boolean;\r
(* returns true, if the type contains (or may reach via pointers) *)\r
(*   shadow, reference or pool                                    *)\r
(* or                                                             *)\r
(*   a pointer, which it not protected                            *)\r
const\r
start_type_range= 0;\r
top_type_range  = 50;\r
\r
type\r
type_range= start_type_range..top_type_range;\r
var\r
no_of_pointers : type_range;  (* counts number of tested pointer-types *)\r
checked_pointers : array [ type_range ] of nameptr;  (* contains typenames *)\r
param_error : boolean;\r
\r
procedure test (xtypename: nameptr; dangerous: boolean);\r
var\r
field: nameptr;\r
ptr_index: type_range;\r
\r
begin\r
if not param_error then\r
with  xtypename ^ do  (* namenode of the type to be tested *)\r
with  typ ^ do      (* corresponding typenode *)\r
if [ t_shadow, t_reference, t_pool, t_extprocess ] * contents (* of typenode *) <> [] then\r
param_error:= true\r
else\r
if t_pointer in contents (* of typenode *) then\r
case typekind (* of typenode *) of\r
calias,\r
carray:\r
test (element, dangerous);\r
crecord:\r
begin\r
field:= element;\r
while field <> nilname do\r
with  field ^ do  (* namenode of field *)\r
begin\r
test (typename, dangerous);\r
field:= nextname;\r
end;\r
end;\r
creadonly:\r
test (element, false);\r
cpointer:\r
if dangerous then\r
param_error:= true\r
else\r
(* test that the outpointed type has'nt been tested already *)\r
(* i.e. 'recursive' pointer *)\r
for ptr_index:= start_type_range to no_of_pointers do\r
if ptr_index = no_of_pointers then\r
begin\r
checked_pointers [ no_of_pointers ]:= element;\r
no_of_pointers:= no_of_pointers + 1;\r
test (element, true);  (* from now on: really dangerous ... *)\r
end\r
else\r
if checked_pointers [ ptr_index ] = element then\r
ptr_index:= no_of_pointers;  (* force fast exit of loop *)\r
\r
else\r
if compilertest then comp_error (unknown_typekind);\r
end; (* case *)\r
\r
end; (* procedure test *)\r
\r
begin (* body of testprocessparam *)\r
no_of_pointers:= start_type_range;\r
param_error:= false;\r
test (xtypename, dangerous);\r
testprocessparam:= param_error;\r
end; (* procedure testprocessparam *)\r
\r
\f

\r
(* procedures for handling of label declarations/definitions/use *)\r
\r
procedure pseudodefine (xscopeno: labelrange; xspix: spixrange);\r
(* the label-definition is inserted in the local label-list *)\r
\r
var\r
curlabel: labelptr;\r
multdef : boolean;\r
\r
begin\r
\r
(* test for multiple definition *)\r
\r
curlabel:= lastlabel;\r
multdef := false; (* suppose ok *)\r
\r
while curlabel <> nillabel do\r
with  curlabel ^ do\r
begin\r
if labelspix = xspix then\r
begin\r
multdef := true;\r
multflag:= true; (* mark the labelnode as inconsistent *)\r
end;\r
curlabel:= prevlabel;  (* follow chain backwards *)\r
end;\r
\r
(* allocate and initialize a new labelnode *)\r
\r
curlabel:= alloc_label;\r
with  curlabel ^ do\r
begin\r
labelspix := xspix;\r
labelscope:= xscopeno;\r
labelstate:= outside_scope;\r
multflag  := multdef; (* mark it as (in)consistent *)\r
used_from_inner_routines:= false;\r
\r
prevlabel := lastlabel;  (* insert in front of other label defs *)\r
lastlabel := curlabel;\r
\r
(* test for declaration on current namelevel *)\r
searchspix (xspix, namelevel, namelevel);\r
labelname:= retrieved_name;  (* = nilname, if undeclared *)\r
with  labelname ^ do\r
if namekind <> clabel then\r
labelname:= nilname;\r
\r
(* test for use from inner routines *)\r
(*   if so, it better be defined at outermost labelscope *)\r
if labelname <> nilname then\r
with  labelname ^ do\r
if usedlevel <> nil_namestack_ptr then\r
(* it has been used *)\r
used_from_inner_routines:= true;\r
\r
end; (* with curlabel *)\r
\r
end; (* procedure pseudodefine *)\r
\r
\r
\r
procedure initlabels;\r
(* called at enddeclaration, at 'begin' *)\r
(* initializes the labelnodes from 'pass3labels' *)\r
\r
var lab: labelptr;\r
\r
begin\r
\r
(* set all labelnodes in free-list *)\r
lab:= freelabels;\r
while lab<>nillabel do\r
with  lab ^ do\r
begin\r
prevlabel:= freelabels;\r
freelabels:= lab;\r
end;\r
lastlabel:= nillabel; (* initialize list of defined labels *)\r
\r
while convtable [ labelin (* = rectype in labelfile *) ] = clabeldef do\r
pseudodefine (labelin (* = scopeno *), labelin (* = spix *) );\r
\r
end; (* procedure initlabels *)\r
\r
\r
\r
procedure definelabel (xscopeno: labelrange; xspix: spixrange);\r
(* searches the local labels to retrieve the wanted label *)\r
\r
var\r
curlabel: labelptr;\r
\r
begin\r
\r
(* check the list of defined labels to produce errors *)\r
\r
curlabel:= lastlabel;\r
while curlabel <> nillabel do\r
with  curlabel ^ do\r
if labelspix = xspix then\r
begin\r
errorspix:= labelspix; (* prepare error message *)\r
if multflag then\r
error (multiple_defined_label);\r
if labelname = nilname then\r
error (label_not_declared);\r
if used_from_inner_routines then\r
error (label_used_from_inner);\r
(* nbnbnb hvem checker erkl paa yderste scope ? *)\r
errorspix:= -1; (* reset errorspix *)\r
\r
(* output:  label(labelnix) *)\r
emitid (xlabel, labelname);\r
\r
curlabel:= nillabel;\r
end\r
else\r
curlabel:= prevlabel;\r
\r
end;\r
\r
\r
\r
procedure set_label_state (setscope: boolean);\r
(* used by: begin/end-label-scope *)\r
(* the labelstates, belonging to current labelscope are set *)\r
(*   to inside/outside label scope *)\r
var\r
curlabel: labelptr;\r
\r
begin\r
\r
curlabel:= lastlabel;\r
while curlabel <> nillabel do\r
with  curlabel ^ do\r
begin\r
\r
(* first: reopen any labels, hidden by this labelscope *)\r
if labelstate = hidden_by_lock_or_channel then\r
if hiddenscope = cur_labelscope then\r
labelstate:= inside_scope;  (* it must be: clear-scope *)\r
\r
(* second: hide all open labels, if start of lock or channel statements *)\r
if start_of_protected then\r
(* first setscope in lock-channel *)\r
if labelstate = inside_scope then\r
begin\r
labelstate := hidden_by_lock_or_channel;\r
hiddenscope:= cur_labelscope;\r
end;\r
\r
(* third: open or close label, when belonging to this labelscope *)\r
if labelscope = cur_labelscope then\r
if setscope then\r
labelstate:= inside_scope\r
else\r
labelstate:= outside_scope;\r
curlabel:= prevlabel;\r
end; (* while/with curlabel *)\r
\r
start_of_protected:= false;\r
\r
end; (* procedure set_label_state *)\r
\r
\r
\r
function check_label (labname: nameptr) : pass3errors;\r
(* used when referring to a labelname *)\r
\r
var\r
curlabel: labelptr;\r
\r
begin\r
\r
with  labname ^ do\r
begin\r
if namekind <> clabel then\r
check_label:= not_label_name\r
else\r
begin\r
(* check locally declared label *)\r
\r
check_label:= label_undefined; (* suppose not locally declared *)\r
\r
curlabel:= lastlabel;\r
while curlabel <> nillabel do\r
with  curlabel ^ do\r
begin\r
if labelspix = spix (* of labelname *) then\r
begin\r
(* it was locally declared, now check the labelscope *)\r
case labelstate of\r
inside_scope: check_label:= noerror;\r
outside_scope:\r
check_label:= label_used_outside_scope;\r
(* i.e. goto leading into control structure *)\r
hidden_by_lock_or_channel:\r
check_label:= label_defined_outside_lock_or_channel;\r
(* i.e. goto out of lock or channel statement *)\r
else;\r
end;\r
if multflag then\r
check_label:= erroneous_label;\r
if labelname = nilname then\r
check_label:= label_not_locally_declared;\r
end;\r
\r
curlabel:= prevlabel;\r
end; (* while/with curlabel *)\r
\r
(* note: *)\r
(*   if label is global to current block, it will be *)\r
(*   checked later, that the label is defined in the *)\r
(*   outermost labelscope of that block              *)\r
\r
end; (* if namekind = label *)\r
\r
end; (* with labname *)\r
\r
end; (* procedure checklabel *)\r
\r
\r
\r
procedure testvalue (opand: opandptr);\r
(* tests that the opand posseses a value *)\r
\r
label 98;\r
\r
begin\r
\r
with  opand ^ do\r
case opcode of\r
cid:\r
with  op_name ^ do (* namenode of identifier *)\r
\r
(* certain of the namekinds are illegal in expressions *)\r
case namekind of\r
clabel,\r
cprocess,\r
cprocedure,\r
ctype,\r
cprefix:\r
goto 98; (* error *)\r
\r
cundeclared,  (* don't cause error-cascades *)\r
cvar,\r
cvarp,\r
cvaluep,\r
cfuncval,\r
cscalarelem,\r
cconstant: ; (* ok *)\r
\r
cfunction:\r
make_call (opand); (* assume that the paramlist was empty *)\r
\r
else;\r
end; (* case *)\r
\r
cindex,\r
cfield,\r
cendstruc,\r
cuparrow,\r
cliteral,\r
ctypesizecall, \r
cfcall,      (* when fielding or indexing on function value *)\r
cendvariable,   (* after function call and any fielding or indexing *)\r
cfunctemp,  (* used when describing 'processcall' as actual param *)\r
cendsetlist,\r
cdoubleparam,\r
cerrorarg,\r
cplus, cminus, cstar, cshift, cslash, cdiv, cmod,\r
ceq, cne, clt, cle, cgt, cge, cin, cor, cxor, cand, cnot,\r
cuminus, cuplus: ; (* ok *)\r
\r
else\r
98:  (* error *)\r
begin\r
error (illegal_in_expr);\r
op_typename:= error_typename;   (* try to prevent error-cascades *)\r
end;\r
end; (* case opcode *)\r
\r
end; (* procedure testvalue *)\r
\r
\r
\r
procedure testvariable (opand: opandptr);\r
(* tests that the opand may be used as <variable> *)\r
\r
label 99; (* opand ok *)\r
\r
begin\r
\r
with  opand ^ do\r
\r
case opcode of\r
\r
cindex,\r
cfield,\r
cuparrow:\r
begin\r
if opcode = cindex then\r
testvariable( left )\r
else testvariable( rigth );\r
goto 99; (* ok *)\r
end;\r
\r
cid:\r
with  op_name ^ do  (* namenode of variable *)\r
case namekind (* of namenode *) of\r
cfunction:\r
make_call (opand); (* terminate an erroneous parameter-less function *)\r
cundeclared,  (* don't cause error-cascades *)\r
cvar,\r
cvarp, cvaluep, cfuncval:\r
goto 99; (* ok *)\r
else errorspix:= spix (* of name *)(* continue *);\r
end; (* case namekind *)\r
\r
else;\r
end; (* case opcode *)\r
\r
error (not_variable);\r
99: ; (* ok *)\r
\r
end; (* procedure testvariable *)\r
\r
\r
\r
procedure testreadonlyvarparam(opand: opandptr);\r
(* tests that the opand may be used as <variable>, possibly constant *)\r
label 98;\r
begin\r
with  opand ^ do\r
case opcode of\r
cid:\r
with  op_name ^ do (* namenode of identifier *)\r
(* certain of the namekinds are illegal in expressions *)\r
case namekind of\r
clabel,\r
cprocess,\r
cprocedure,\r
cfunction,\r
cfuncval,\r
ctype,\r
cprefix:\r
begin\r
errorspix:= spix; (* of op_name *)\r
goto 98; (* error *)\r
end;\r
\r
cundeclared,  (* don't cause error-cascades *)\r
cvar,\r
cvarp,\r
cvaluep,\r
cscalarelem,\r
cconstant: ; (* ok *)\r
\r
\r
else;\r
end; (* case *)\r
\r
cindex,\r
cfield,\r
cuparrow:\r
if opcode=cindex then\r
testreadonlyvarparam(left) \r
else\r
testreadonlyvarparam(rigth);\r
\r
cendstruc,\r
cliteral,\r
ctypesizecall, \r
cfunctemp,  (* used when describing 'processcall' as actual param *)\r
cendsetlist,\r
cerrorarg: ; (* ok *)\r
\r
else\r
98:  (* error *)\r
begin\r
error (not_variable);\r
op_typename:= error_typename;   (* try to prevent error-cascades *)\r
end;\r
end; (* case opcode *)\r
\r
end; (* procedure testreadonlyvarparam *)\r
\r
\r
function testfrozen (opand: opandptr): boolean;\r
var all_tested : boolean;\r
\r
begin\r
testfrozen:= false;\r
all_tested:= false;\r
\r
repeat\r
with  opand ^ do\r
with  op_typename ^ do  (* typename of operand *)\r
with  typ ^ do        (* corresponding typenode *)\r
if typekind = creadonly then\r
begin\r
testfrozen:= true;\r
all_tested:= true;\r
end\r
else\r
(* follow typenodes backwards for records and arrays *)\r
(* to search for 'readonly' types *)\r
case opcode (* of opand *) of\r
cindex : opand:= left;  (* follow the array-operand *)\r
cfield : opand:= rigth; (* follow the record-operand *)\r
else\r
all_tested:= true;\r
end; (* case *)\r
\r
until all_tested;\r
\r
end; (* function testfrozen *)\r
\r
\r
\r
procedure testassignable (opand: opandptr);\r
(* generates an error, if operand cannot be assigned *)\r
begin\r
testvariable (opand);  (* it has to be a variable *)\r
with  opand ^ do\r
with  op_typename ^ do  (* namenode of operand-type *)\r
with  typ ^ do        (* corresponding typenode *)\r
if (contents (* of typenode *)\r
* [ t_semaphore, t_pool, t_reference, t_shadow, t_extprocess, t_readonly ] <> [])\r
or testfrozen (opand) then\r
begin\r
if opcode<>cindex then (* if index then op_name holds array type *)\r
errorspix:= op_name^.spix;\r
error (not_assignable);\r
end;\r
end; (* procedure testassignable *)\r
\r
\r
\r
procedure testexchangable (opand: opandptr);\r
(* generates an error, if operand cannot be exchanged *)\r
begin\r
testvariable (opand);  (* it has to be a variable *)\r
with  opand ^ do\r
with  op_typename ^ do  (* namenode of operand-type *)\r
with  typ ^ do        (* corresponding typenode *)\r
if contents (* of typenode *)\r
* [ t_semaphore, t_pool, t_extprocess, t_readonly ] <> [] then\r
error (not_exchangeable);\r
end; (* procedure testexchangable *)\r
\r
\r
\r
procedure testunpacked (opand: opandptr);\r
(* generates an error, if the operand is packed *)\r
begin\r
with  opand ^ do\r
if op_packflag then\r
with op_typename^.typ^ do\r
if (typekind<>carray) and (typekind<>crecord) then\r
begin (* irregular element *)\r
if opcode<>cindex then (* if index then op_name holds array type name *)\r
errorspix:= op_name^.spix;\r
error (variable_may_not_be_packed);\r
end;\r
end; (* procedure testunpacked *)\r
                 \r
\r
procedure find_with_namekind(opand: opandptr);\r
(* find 'id' of opand and let with_namekind be 'constant' or 'var' depending\r
on the namkind of 'id', and withvar_spix is assigned the spix of id,\r
used in conjunction with WITH statements *)\r
label 1234; (* exit point of procedure *)\r
begin\r
while opand^.opcode<>cid do\r
with opand^ do\r
case opcode of\r
cindex: opand:= left;\r
cfield, cuparrow: opand:= rigth;\r
else  (* exit while, set kind to var *)\r
begin (* after error *)\r
with_namekind:= cvar;\r
withvar_spix:= anonymous_spix;\r
goto 1234; (* exit *)\r
end;\r
end;\r
\r
if opand^.op_name^.namekind=cconstant then\r
with_namekind:= cconstant\r
else\r
with_namekind:= cvar;\r
withvar_spix:= opand^.op_name^.spix;\r
1234: (* exit point *)\r
end; (* get with-namekind *)\r
\r
\r
procedure resolve_named_type (\r
xxtypename: nameptr;\r
var xtypename: nameptr;\r
var xelement: nameptr;\r
var xtypekind: codes);  (* ************** *)  forward;  (* ********* *)\r
\r
\r
\r
procedure resolvetype (\r
opand: opandptr;\r
var xtypename: nameptr;\r
var xelement: nameptr;\r
var xtypekind: codes);\r
label 10;\r
\r
var local_typename: nameptr;\r
local_element: nameptr;\r
local_kind: codes;\r
\r
begin\r
\r
testvalue (opand);  (* the operand must posses a value *)\r
\r
local_typename:=  opand ^ . op_typename;\r
\r
10: (* after stripping of superflous type inf *)\r
\r
with  local_typename ^ do\r
with  typ ^ do\r
\r
begin\r
\r
if typekind = csubrange then\r
begin\r
local_typename:= index;\r
goto 10;\r
end;\r
if typekind = creadonly then\r
begin\r
local_typename:= element;\r
goto 10;\r
end;\r
\r
xtypename:= local_typename;\r
xtypekind:= typekind;\r
xelement := element;\r
\r
if xtypekind = cset then\r
(* resolve element-type *)\r
resolve_named_type (element, xelement, local_element, local_kind);\r
if xtypekind = calias then\r
resolve_named_type (element, local_typename, xelement, xtypekind);\r
\r
end; (* with names,types *)\r
\r
end; (* procedure resolvetype *)\r
\r
\r
\r
procedure resolve_named_type (\r
xxtypename: nameptr; (* typename to be resolved *)\r
var xtypename: nameptr;\r
var xelement: nameptr;\r
var xtypekind: codes);\r
begin\r
(* seperates the type into its components, stripping subrange etc. *)\r
 nilopand ^ . op_typename:= xxtypename; (* use as working cell *)\r
resolvetype (nilopand, xtypename, xelement, xtypekind);\r
end;\r
\r
\r
\r
function unstripfrozen (xtypename: nameptr): nameptr;\r
label 10;\r
\r
begin\r
\r
10: with  xtypename ^ do   (* namenode of type *)\r
with  typ ^ do       (* corresponding typenode *)\r
if typekind = creadonly then\r
begin\r
xtypename:= element;  (* follow typename-chain *)\r
goto 10;  (* repeat search for several 'frozen' in row *)\r
end;\r
\r
unstripfrozen:= xtypename;   (* deliver unstrip'ed typename *)\r
\r
end;\r
\r
\r
\r
procedure equaltypes (leftop, rigthop: opandptr; wanted_typename: nameptr; errorcode: pass3errors);\r
\r
begin\r
resolvetype (leftop, lefttypename, leftelement, leftbasekind);\r
resolvetype (rigthop, rigthtypename, rigthelement, rigthbasekind);\r
\r
if (lefttypename <> rigthtypename) or\r
(lefttypename <> wanted_typename) then\r
error (errorcode);\r
\r
end;\r
\r
\r
\r
procedure assure (opand: opandptr; wanted_typename: nameptr; errorcode: pass3errors);\r
\r
(* modifies 'optypename' if any error is produced *)\r
\r
begin\r
resolvetype (opand, exprtypename, exprelement, exprbasekind);\r
if exprtypename <> wanted_typename then\r
if exprbasekind <> cerrorkind then  (* suppress error-cascades *)\r
begin\r
error (errorcode);\r
with  opand ^ do\r
op_typename:= error_typename;\r
end;\r
end;\r
\r
\r
\r
procedure testindex (var xtypename: nameptr);\r
(* tests that the typekind is enumeration kind *)\r
\r
begin\r
resolve_named_type (xtypename, exprtypename, exprelement, exprbasekind);\r
case exprbasekind of\r
\r
cerrorkind,  (* don't cause error-cascades *)\r
cinteger,\r
cscalar: ; (* ok *)\r
\r
else\r
begin\r
error (not_index_type);\r
xtypename:= error_typename;\r
end;\r
end;\r
\r
end; (* procedure testindex *)\r
\r
\r
\r
function testenumeration (opand: opandptr): nameptr;\r
(* works as 'testindex', but works on an opand *)\r
var local_typename: nameptr;\r
\r
begin\r
testvalue (opand);\r
with  opand ^ do\r
begin\r
local_typename:= op_typename;\r
testindex (local_typename);\r
op_typename:= local_typename;\r
testenumeration:= op_typename;\r
end;\r
\r
end; (* procedure testenumeration *)\r
\r
\r
\r
procedure set_procedure;\r
(* handles set-values *)\r
\r
begin\r
\r
case rectype of\r
\r
csetlist:\r
(* prepare s-element or m-element to be binary operators *)\r
newopand (csetlist, nil_typename);\r
\r
cs_element,\r
cm_element:\r
begin\r
rigthtypename:= testenumeration (stacktop);\r
if rectype = cm_element then\r
begin\r
lefttypename:= testenumeration (nexttop);\r
if lefttypename <> rigthtypename then\r
error (mixed_types_in_setlist);\r
oper (binary, rectype, rigthtypename);\r
rectype:= cnocode;  (* let rectype describe simple binding *)\r
end;\r
\r
(* compare element-type with previous type in setlist *)\r
with  nexttop ^ do  (* previous setlist-element or dummy-element *)\r
if op_typename (* of nexttop *) <> rigthtypename then\r
if op_typename <> nil_typename then  (* suppress error for very first element *)\r
error (mixed_types_in_setlist);\r
\r
oper (binary, rectype, rigthtypename);\r
\r
end;\r
\r
\r
cendsetlist:\r
begin\r
(* construct a typenode: set of <typename> *)\r
exprtypename:= alloc_namenode;\r
with  exprtypename ^ do\r
begin\r
namekind:= ctype;\r
typename:= nil_typename;\r
typ     := alloc_typenode;\r
with  typ ^ do\r
begin\r
\r
typekind:= cset;\r
element :=  stacktop ^ . op_typename;\r
(* contents:= [ t_simple ];  *)\r
end;\r
end; (* with exprtypename *)\r
\r
oper (unary, cendsetlist, exprtypename);\r
\r
end;\r
\r
else\r
if compilertest then\r
comp_error (unknown_rectype);\r
end; (* case rectype *)\r
\r
end; (* procedure set-procedure *)\r
\r
\r
\r
procedure export_procedure;\r
\r
var\r
errortxt: pass3errors;\r
opand:    opandptr;\r
expkind:  (undefkind, constkind, varkind);\r
\r
begin\r
\r
case rectype of\r
\r
cexport:\r
begin\r
(* save the external name, to be emitted later *)\r
opand_procname:= take_stacktop;\r
if expecting_block then\r
begin_block;\r
cur_dyn_var_level:=nil_namestack_ptr;(*avoid test for dynamic restrictions*)\r
end;\r
\r
cexportvalue,\r
cexportsize,\r
cexportdisp,\r
cexportoffset,\r
cexportaddr:\r
begin\r
(* opand_procname holds external name *)\r
(* stacktop holds variable to be exported *\r
\r
(* exportvalue: only const *)\r
(* exportsize : const or var *)\r
(* exportdisp : field (of const or var) *)\r
(* exportoffset: only var *)\r
(* exportaddr : const or var *)\r
\r
resolvetype (stacktop, exprtypename, exprelement, exprbasekind);\r
\r
if exprbasekind <> cerrorkind then\r
begin\r
(* find the identifier, in front of any possible fields *)\r
opand:= stacktop;\r
while  opand ^ . opcode = cfield do\r
opand:=  opand ^ . rigth;\r
\r
errortxt:= noerror; (* suppose no errors... *)\r
\r
(* decide kind of identifier *)\r
with  opand ^ do  (* opcode = 'cid' ... *)\r
with  op_name ^ do (* namenode of identifier *)\r
case namekind (* of identifier *) of\r
cvar,\r
cvarp,\r
cvaluep,\r
cfuncval: expkind:= varkind;\r
cconstant: expkind:= constkind;\r
else expkind:= undefkind;\r
end;\r
\r
case rectype of\r
cexportvalue:\r
if expkind <> constkind then\r
errortxt:= const_export_only;\r
cexportsize,\r
cexportdisp,\r
cexportaddr:\r
if (expkind <> constkind) and (expkind <> varkind) then\r
errortxt:= const_or_var_export_only\r
else\r
if rectype = cexportdisp then\r
if opand = stacktop (* i.e. no field-operators *) then\r
errortxt:= disp_export_must_have_field;\r
cexportoffset:\r
if expkind <> varkind then\r
errortxt:= var_export_only;\r
end; (* case *)\r
\r
if errortxt <> noerror then\r
error (errortxt);\r
\r
end; (* if no error-operand *)\r
\r
case rectype of\r
cexportvalue : emit (xexportvalue);\r
cexportsize  : emit (xexportsize);\r
cexportdisp  : emit (xexportdispl);\r
cexportoffset: emit (xexportoffset);\r
cexportaddr  : emit (xexportaddr);\r
end;\r
\r
emit_extname (opand_procname);\r
emit_and_release (stacktop);\r
emit (xendexport);\r
\r
cur_dyn_var_level:= namelevel;\r
\r
end;\r
else if compilertest then comp_error(unknown_rectype);\r
end; (* case rectype... *)\r
\r
end; (* procedure export-procedure *)\r
\r
\r
\r
function allow_text_literals: boolean;\r
(* implicit parameters: left... and rigth... *)\r
(* returns true, if one is textliteral and the other is ( text or array of char *)\r
begin\r
\r
allow_text_literals:= (\r
((leftbasekind  = ctext) and (rigthbasekind = ctext)) or\r
((leftbasekind  = ctext) and (rigthbasekind = carray) and (rigthelement = char_typename)) or\r
((rigthbasekind = ctext) and (leftbasekind  = carray) and (leftelement  = char_typename))\r
);\r
\r
end;\r
\r
\r
\r
procedure relation (rel: codes);\r
(* creates a binary operation node, working on top and nexttop *)\r
(* in case of errors, the resulting type etc will be set to error-values *)\r
\r
var rel_error: pass3errors;\r
begin\r
\r
resolvetype (nexttop, lefttypename, leftelement, leftbasekind);\r
resolvetype (stacktop, rigthtypename, rigthelement, rigthbasekind);\r
\r
rel_error:= noerror;\r
\r
if rigthbasekind = cerrorkind then\r
leftbasekind:= rigthbasekind;  (* suppress error-cascades *)\r
\r
case leftbasekind of\r
\r
cscalar:\r
(* both must be scalars, belonging to the same scalar-type *)\r
if (leftbasekind <> rigthbasekind) or\r
(leftelement <> rigthelement) then\r
rel_error:= relation_error;\r
\r
carray,\r
ctext,\r
crecord:\r
(* both must belong to the same type, and only '=' or '<>' *)\r
if ((lefttypename <> rigthtypename) and (not allow_text_literals)) or \r
((rel <> ceq) and (rel <> cne)) then\r
rel_error:= relation_error\r
else\r
(* test that the record doesn't contain system types *)\r
with  lefttypename ^ do\r
with  typ ^ do  (* typenode of one of the operands *)\r
if contents * [ t_semaphore, t_pool, t_extprocess, t_reference, t_shadow ] <> [] then\r
rel_error:= relation_error;\r
\r
cpointer:\r
(* both must be pointers to same type, and only '=' or '<>' *)\r
(* note: especially used by the monitor-process... *)\r
if (leftbasekind <> rigthbasekind) or\r
(leftelement <> rigthelement) or\r
((rel <> ceq) and (rel <> cne)) then\r
rel_error:= relation_error;\r
\r
cset:\r
(* both must be sets, with same elementtypes (or empty) *)\r
if (leftbasekind <> rigthbasekind) (* both 'set' *) or\r
((leftelement <> rigthelement) (* with same element-type *) and\r
(leftelement <> nil_typename) (* allow empty sets *) and\r
(rigthelement <> nil_typename)) or\r
(rel = clt) or (rel = cgt) then\r
rel_error:= relation_error;\r
\r
cerrorkind: ; (* anything allowed *)\r
\r
cinteger,\r
creal:\r
(* simple version: demand same type *)\r
if leftbasekind <> rigthbasekind then\r
rel_error:= relation_error;\r
\r
else\r
rel_error:= relation_error;\r
end;\r
\r
(* perform the binary operation *)\r
if rel_error <> noerror then\r
begin\r
oper (binary, rel, error_typename);\r
error (rel_error);\r
end\r
else\r
oper (binary, rel, boolean_typename);\r
\r
end; (* procedure relation *)\r
\r
\r
\r
procedure arithop (operator: codes);\r
(* creates a binary operation node, working on stacktop and nexttop *)\r
(* in case of errors, the resulting type etc will be set to error-values *)\r
\r
var arith_error: pass3errors;\r
\r
begin\r
\r
resolvetype (nexttop, lefttypename, leftelement, leftbasekind);\r
resolvetype (stacktop, rigthtypename, rigthelement, rigthbasekind);\r
\r
arith_error:= noerror;\r
\r
if rigthbasekind = cerrorkind then\r
begin\r
lefttypename:= error_typename;\r
leftbasekind:= rigthbasekind;\r
end;\r
\r
if leftbasekind <> rigthbasekind then\r
arith_error:= arithmetic_error\r
else\r
case leftbasekind of\r
cinteger: begin\r
if (target_machine = targetz80) and\r
((operator = cor) or (operator = cand)) then \r
arith_error:= not_implemented_on_z80;\r
\r
if operator = cslash then\r
arith_error:= real_division_not_implemented;\r
lefttypename:= integer_typename;  (* let result be base type *)\r
end;\r
creal:\r
arith_error:= real_not_implemented;\r
cset:\r
if ((leftelement <> rigthelement) (* sets with same elementtypes *) and\r
(leftelement <> nil_typename) (* allow empty sets *) and\r
(rigthelement <> nil_typename)) or\r
(operator = cand) or (operator = cor) or (operator = cxor) or\r
(operator = cslash) then\r
arith_error:= arithmetic_error\r
else\r
if leftelement = nil_typename then   (* if left-operand is empty set then *)\r
lefttypename:= rigthtypename;     (*   use typename from rigth-operand *)\r
\r
cerrorkind: ; (* allow anything *)\r
\r
cscalar: if (lefttypename <> rigthtypename) or (lefttypename <> boolean_typename)\r
or ( (operator <> cand) and (operator <> cor) and (operator <> cxor) ) then\r
arith_error:= arithmetic_error;\r
\r
else\r
arith_error:= arithmetic_error;\r
end;\r
\r
if arith_error <> noerror then\r
begin\r
oper (binary, operator, error_typename);\r
error (arith_error);\r
end\r
else\r
oper (binary, operator, lefttypename);\r
\r
end; (* procedure arithop *)\r
\r
\r
\r
procedure test_value_compatible (errorcode: pass3errors);\r
(* implicit params: left... and rigth... *)\r
\r
begin\r
\r
if rigthbasekind = cerrorkind then\r
leftbasekind:= rigthbasekind;\r
\r
case leftbasekind of\r
\r
carray:\r
(* allow rigth to be text literal, when left is array of char *)\r
if not allow_text_literals then\r
error (errorcode);\r
\r
cpointer:\r
(* both must be pointers to same type ( or to 'niltype' ) *)\r
if (leftbasekind <> rigthbasekind) or\r
((leftelement <> rigthelement) (* to same type *) and\r
(leftelement <> nil_typename) (* allow pointers to niltype *) and\r
(rigthelement <> nil_typename)) then\r
error (errorcode);\r
\r
cset:\r
(* both must be sets, with same componenttypes (or empty) *)\r
if (leftbasekind <> rigthbasekind)  (* both sets *) or\r
((leftelement <> rigthelement) (* with same element-type *) and\r
(rigthelement <> nil_typename)) (* allow rigth to be empty set *) then\r
error (errorcode);\r
\r
cerrorkind: ; (* anything allowed *)\r
\r
else\r
error (errorcode);\r
end;\r
\r
end; (* procedure test_value_compatible *)\r
\r
\r
\r
procedure test_var_compatible (errorcode: pass3errors);\r
(* implicit params: left... and rigth... *)\r
\r
begin\r
\r
if rigthbasekind = cerrorkind then\r
leftbasekind:= rigthbasekind;\r
\r
case leftbasekind of\r
\r
cpointer:\r
(* both must be pointers, to same type (or to 'niltype') *)\r
if (leftbasekind <> rigthbasekind) or\r
((leftelement <> rigthelement) (* pointer to same type *) and\r
(leftelement <> nil_typename) (* allow pointers to niltype *) and\r
(rigthelement <> nil_typename)) then\r
(* suppress error message for the 'nil'-function, with actual shadow ... *)\r
if (leftelement <> nil_typename) or (rigthtypename <> shadow_typename) then\r
error (errorcode);\r
\r
cpool:\r
(* both must be pool, but don't care about 'of-type' *)\r
if leftbasekind <> rigthbasekind then\r
error (errorcode);\r
\r
cerrorkind: ; (* anything allowed *)\r
\r
else\r
error (errorcode);\r
end;\r
\r
end; (* procedure test_var_compatible *)\r
\r
\r
\r
procedure testinitialize (xtypename: nameptr; errorcode: pass3errors);\r
(* tests that stacktop may be 'assigned' to a *)\r
(*  variable of the given type *)\r
\r
begin\r
\r
(* special test for 'skipparam' *)\r
with  stacktop ^ do\r
if opcode <> cskipparam then\r
begin\r
(*the type-comparison is omitted in case of 'skipparam' *)\r
\r
resolve_named_type (xtypename, lefttypename, leftelement, leftbasekind);\r
resolvetype (stacktop, rigthtypename, rigthelement, rigthbasekind);\r
\r
if lefttypename <> rigthtypename then\r
test_value_compatible (errorcode);\r
\r
end;\r
\r
end;\r
\r
\r
\r
procedure testrange (xtypename: nameptr);\r
(* inserts a 'range-test', in case the type is a subrange *)\r
\r
var local_typename: nameptr;\r
\r
begin\r
\r
local_typename:= unstripfrozen (xtypename);\r
with  local_typename ^ do  (* namenode of simplified type *)\r
with  typ ^ do           (* corresponding typenode *)\r
if typekind = csubrange then\r
oper (unary, crange, xtypename);\r
\r
end;\r
\r
\r
\r
procedure beginactual;\r
(* called on the left paranthesis in a parameter-list *)\r
\r
label 1, 2;\r
\r
begin\r
\r
1: (* repeat after parameter-less function-call *)\r
pushcall; (* because of nested calls *)\r
\r
(* decide the kind of argument-list: index, parameter, strucconst *)\r
(* stacktop describes the 'owner' *)\r
\r
with  stacktop ^ do\r
case opcode of\r
ctypeid, (* implicit type name in front of structured constant *)\r
cid:\r
with  op_name ^ do  (* namenode of 'owner' *)\r
case namekind (* of owner *) of\r
cprocess,\r
cprocedure,\r
cfunction:\r
begin\r
prepare_call (stacktop);\r
if namekind = cfunction then\r
if empty_paramlist (params) then\r
begin\r
(* the function did'nt have any formal parameters *)\r
(* therefor the arglist must be an index-list     *)\r
terminate_call (stacktop);  (* make the function-call *)\r
goto 1;                    (* start all over again *)\r
(* note: this time the arglist will be taken as an index-list *)\r
end;\r
end;\r
ctype:\r
begin\r
(* the list is a struc-constant *)\r
opcode:= ctypeid; (* mark after outermost struc const begin *)\r
arglist_owner:= op_name;  (* remember the namenode of the type *)\r
with  typ ^ do        (* typenode of the type *)\r
case typekind of\r
carray:\r
begin\r
argkind   := cstrucarray;\r
curformal := element;     (* typename of array elements *)\r
end;\r
crecord:\r
begin\r
argkind   := cstrucrecord;\r
curformal := element;     (* first of field-name list *)\r
end;\r
else\r
begin\r
(* only array-types and record-types may be struc-consts *)\r
argkind:= cerrorarg;\r
error (type_must_be_record_or_array);\r
end;\r
end; (* case typekind *)\r
end; (* case namekind = ctype *)\r
\r
\r
else\r
\r
begin\r
2:\r
(* see if external process *)\r
if op_typename^.namekind=cextprocess then\r
begin (* prepare actual parameter list *)\r
argkind:= cargument;\r
curformal:= op_typename^.params;\r
arglist_owner:= op_typename;\r
end\r
else\r
begin\r
   (* the argumentlist must be an index-list *)\r
argkind   := cindex;\r
curformal := op_typename;  (* typename ougth to be name of array-type *)\r
end;\r
end;\r
end; (* case namekind *)\r
\r
else goto 2; (* assume index in all other cases *)\r
end; (* case opcode *)\r
\r
end; (* procedure beginactual *)\r
\r
\r
\r
procedure act_param;\r
(* called on: cdoubleparam-cactualparam *)\r
\r
label 5, 10;\r
\r
var sonvar_name: nameptr;\r
loc_tempvar: nameptr;\r
\r
begin\r
\r
(* first bind any possible doubleparam to a single one *)\r
if rectype = cdoubleparam then\r
begin\r
(* nexttop must be integer expression *)\r
assure (nexttop, integer_typename, repetition_type);\r
testvalue (stacktop);\r
with  stacktop ^ do\r
oper (binary, cdoubleparam, op_typename (* propagate typename... *) );\r
end;\r
\r
\r
(* argkind now describes how to interprete the actualarg *)\r
\r
case argkind of\r
cerrorarg,\r
cindex:\r
begin\r
(* curformal is typename of (supposed) array *)\r
(* test that its typekind is 'carray'        *)\r
\r
(* doubleparam is not allowed *)\r
if rectype <> cactualparam then\r
error (double_param_only_in_struc_const);\r
\r
curformal:= unstripfrozen (curformal);  (* in case the array itself was frozen *)\r
\r
with  curformal ^ do     (* namenode of type *)\r
with  typ ^ do         (* corresponding typenode *)\r
begin\r
if argkind <> cerrorarg then   (* suppress error-cascade *)\r
case typekind (* of typenode *) of\r
\r
cerrorkind: ; (* nothing, but suppress error-cascade *)\r
\r
carray:\r
begin\r
with  stacktop ^ do\r
if opcode = cskipparam then\r
error (skipparam_only_in_struc_const)\r
else\r
begin\r
(* get basekind of indextype of the array *)\r
resolve_named_type (index, lefttypename, leftelement, leftbasekind);\r
(* get basekind of actual index expression *)\r
resolvetype (stacktop, rigthtypename, rigthelement, rigthbasekind);\r
\r
if lefttypename <> rigthtypename then\r
error (incompatible_index);\r
end;\r
end;\r
else\r
begin\r
error (subscript_after_nonarray);\r
argkind:= cerrorarg;\r
end;\r
end;\r
\r
(* bind the index-expression to the owner *)\r
oper (binary, argkind, element (* typename of array-element *));\r
with  stacktop ^ do\r
begin\r
op_name:= curformal;  (* type-name of array *)\r
op_packflag:= packflag (* from typenode of the array *);\r
end;\r
\r
(* let curformal be typename of array-element *)\r
curformal:= element;\r
\r
end; (* with curformal *)\r
\r
end; (* argkind = index *)\r
\r
cargument:\r
begin\r
(* curformal is name in formal param list *)\r
while curformal <> nilname do\r
(* skip implicit types and function-return-value *)\r
with  curformal ^ do\r
begin\r
case namekind (* of formal name *) of\r
cscalarelem,\r
ctype,\r
cundeclared,  (* undeclared typename *)\r
cfuncval: ; (* skip *)\r
\r
cvarp:\r
begin\r
(* check var parameter *)\r
\r
(* first test if the actual is a process-name *)\r
with  stacktop ^ do\r
begin\r
if opcode = cskipparam then\r
begin\r
error (skipparam_only_in_struc_const);\r
goto 5;\r
end\r
else\r
if opcode = cid then\r
with  op_name ^ do  (* namenode of identifier *)\r
if namekind = cprocess then\r
begin\r
(* it was really a process-name *)\r
(* exchange the identifier with the corresponding son-variable *)\r
op_name:= nextname (* of processname *);\r
with  op_name ^ do  (* namenode of son-var *)\r
op_typename:= typename (* of sonvar *)\r
end;\r
\r
if op_typename^.namekind=cextprocess then\r
op_typename:= son_typename;\r
end; (* with stacktop *)\r
\r
if typename^.typ^.typekind=creadonly then (* frozen VAR parameter, allow const *)\r
testreadonlyvarparam(stacktop)\r
else\r
(* actual must be unpacked variable *)\r
testvariable (stacktop);\r
testunpacked (stacktop);\r
\r
(* the formaltype and the actualtype must match exactly, except for 'frozen' *)\r
with  stacktop ^ do\r
(* now: typename    = formal typename *)\r
(*      op-typename = actual typename *)\r
if typename <> op_typename then\r
begin\r
(* try to remove readonly-marks from formal and actual types *)\r
if unstripfrozen (typename) <> unstripfrozen (op_typename) then\r
begin\r
resolve_named_type (typename (* of curformal *), lefttypename, leftelement, leftbasekind);\r
resolvetype (stacktop, rigthtypename, rigthelement, rigthbasekind);\r
if allow_text_literals then\r
test_value_compatible(illegal_var_param_substitution)\r
else\r
test_var_compatible (illegal_var_param_substitution);\r
end\r
else\r
(* it helped... but in this case formal must be readonly *)\r
if typename = unstripfrozen (typename) then\r
(* formal was'nt frozen, but actual was *)\r
error ( actual_may_not_be_frozen);\r
end; (* if not direct match *)\r
\r
if arglist_owner = nil_procname then\r
with  stacktop ^ do\r
if  op_typename (* of actual parameter *) = reference_typename then\r
begin (* change the function to the special nil(reference) *)\r
with  nexttop ^ do  (* argkind node *)\r
with  left (* of argkind *) ^ do (* functrailer node *)\r
with  rigth (* of functrailer *) ^ do (* function name node *)\r
 op_name:= nilref_procname ; (* nil(reference) may be handled in a special way in a later pass *)\r
end;\r
\r
goto 5;\r
end;\r
\r
cvaluep:\r
begin\r
(* check value parameter *)\r
\r
(* first test if the actual is a process-call *)\r
make_call (stacktop);  (* if parameter-less normal process *)\r
if stacktop^.op_typename^.namekind=cextprocess then (* parameter less external process typed object *)\r
oper(unary, ccallprocess, nilname (* no type *));\r
\r
with  stacktop ^ do\r
if opcode = cskipparam then\r
begin\r
error (skipparam_only_in_struc_const);\r
goto 5;\r
end\r
else\r
if opcode = ccallprocess then\r
begin\r
\r
count_processparam:= count_processparam + 1;\r
\r
(* insert extra opands to describe the process-'call' as normal argument *)\r
sonvar_name:= op_name;  (* get the name from the 'callprocess'-node *)\r
\r
(* get a temporary namenode for describing the 'processrec' *)\r
loc_tempvar:= functempvar;  (* save the global variable *)\r
functempvar:= alloc_namenode;\r
functempvar^.namekind:= cvar; (* not used, but must not be extprocess *)\r
insert_functype (processrec_typename);\r
\r
(* bind the processcall to the normal paramlist *)\r
oper (binary, cprocessargument, functempvar (* = temp variable *) );\r
with  stacktop ^ do\r
op_name:= sonvar_name;\r
\r
(* create an operand, with 'processrec' type *)\r
newopand (cfunctemp, nilname (* irrell typename *));\r
with  stacktop ^ do\r
op_name:= functempvar;\r
\r
(* now: stacktop is a functemp-var, of processrec type *)\r
functempvar:= loc_tempvar;  (* restore the global variable *)\r
end;\r
\r
with  curformal ^ do\r
begin\r
\r
if typename (* of curformal *) = nil_typename then\r
begin\r
(* test certain special std-functions *)\r
\r
if (arglist_owner = succ_procname)\r
or (arglist_owner = pred_procname) then\r
begin\r
(* actual expression has to be enumeration *)\r
rigthtypename:= testenumeration (stacktop);\r
insert_functype (rigthtypename);\r
goto 5;\r
end;\r
\r
if arglist_owner = ord_procname then\r
begin\r
(* actual expression has to be enumeration *)\r
rigthtypename:= testenumeration (stacktop);\r
goto 5;\r
end;\r
\r
if arglist_owner = abs_procname then\r
begin\r
(* actual expression must be integer (or subrange hereof) *)\r
(* note: in future also real... *)\r
assure (stacktop, integer_typename, illegal_value_param_substitution);\r
insert_functype (integer_typename);\r
goto 5;\r
end;\r
\r
end; (* special functions *)\r
\r
resolve_named_type (typename, lefttypename, leftelement, leftbasekind);\r
resolvetype (stacktop, rigthtypename, rigthelement, rigthbasekind);\r
\r
if lefttypename <> rigthtypename then\r
test_value_compatible (illegal_value_param_substitution);\r
(* note: implicit params: left... and rigth... *)\r
\r
if typename (* of curformal *) <> stacktop^.op_typename then\r
if typename (* of curformal *) <> stacktop^.op_typename then\r
testrange (typename (* of curformal *) );\r
end; (* with curformal *)\r
\r
goto 5;\r
end;\r
\r
else\r
\r
if compilertest then comp_error (unknown_namekind);\r
end;\r
\r
\r
curformal:= nextname;  (* follow chain *)\r
\r
end; (* with curformal *)\r
\r
(* the formal paramlist was exhausted *)\r
errorspix:= arglist_owner^.spix;\r
error (too_many_actual_params);\r
\r
5: ;\r
\r
(* note: see also 'prepare_call' *)\r
\r
(* bind the actual parameter to the owner *)\r
oper (binary, argkind, nilname (* irrell typename *) );\r
with  stacktop ^ do\r
op_name:= curformal;   (* let opname point at current formal name *)\r
\r
(* let curformal be the next in formal-list *)\r
with  curformal ^ do\r
curformal:= nextname;\r
\r
end;  (* argkind = cargument *)\r
\r
\r
cstrucarray:\r
begin\r
(* curformal is element typename *)\r
(* check transfer to array-element *)\r
testinitialize (curformal, struc_arr_incompatible);\r
oper (binary, argkind, curformal (* = element typename *) );\r
end;\r
\r
cstrucrecord:\r
begin\r
(* curformal is name in field list *)\r
\r
(* doubleparam is not allowed *)\r
if rectype <> cactualparam then\r
error (double_param_only_in_struc_const);\r
\r
while curformal <> nilname do\r
(* skip implicit types in field list *)\r
with  curformal ^ do\r
begin\r
if namekind = crecfield then\r
begin\r
(* check transfer to field *)\r
testinitialize (typename, struc_rec_incompatible);\r
goto 10;\r
end;\r
curformal:= nextname;\r
end; (* with curformal *)\r
\r
errorspix:= arglist_owner^.spix;\r
error (too_many_values_in_record_structure);\r
\r
10: ;\r
\r
(* bind the value to the owner *)\r
with  curformal ^ do   (* namenode of field name *)\r
begin\r
oper (binary, argkind, curformal (* i.e. fieldname itself *) );\r
curformal:= nextname;\r
end;\r
\r
end;\r
\r
\r
else\r
if compilertest then\r
comp_error (unknown_argkind);\r
end; (* case argkind *)\r
\r
end; (* procedure actparam *)\r
\r
\r
\r
\f

\r
procedure initialize;\r
\r
var strptr: stringptr;\r
err: pass3errors;\r
\r
begin\r
\r
(* initialize files *)\r
new(incode_filptr);\r
incode_fileix := filrec_max;\r
assign(pass1file, concat(path1_name, o_pass1_codename));\r
(*$I-*)\r
reset(pass1file);\r
if ioresult <> 0 then\r
begin\r
nofile(concat(path1_name, o_pass1_codename));\r
end;\r
(*$I+*)\r
new(insymb_filptr);\r
insymb_fileix := filrec_max;\r
assign(pass1labels, concat(path1_name,o_pass1_symbname));\r
(*$I-*)\r
reset(pass1labels);\r
if ioresult <> 0 then\r
begin\r
nofile(concat(path1_name, o_pass1_symbname));\r
end;\r
(*$I+*)\r
new(outcode_filptr);\r
outcode_fileix := 0;\r
assign(pass3file,concat(path2_name, o_pass3_codename));\r
rewrite (pass3file);\r
\r
(* initialize conversion table *)\r
for rectype:= cnocode to clastcode do\r
convtable [ ord(rectype) ]:= rectype;\r
\r
(* clear error-bitmap *)\r
for err:= noerror to lastpass3error do\r
error_bitmap [ err ]:= false;\r
errorspix:= -1; (* no spix associated with a possible error *)\r
cur_printname:= -1; (* no names printed yet *)\r
\r
\r
(* initialize stdspix table *)\r
(* all entries are set to: 'max-spix'... this will ensure *)\r
(*   that pass1 actually sends out initialization for these *)\r
for rectype:= canonymous to cord do\r
stdspix (max_spix, rectype);\r
\r
(* initialize test facilities *)\r
survey_info:= false;\r
preserve_option:= false; (* default: preserve.no, i.e. remove temporary entries *)\r
testinput    := false;\r
testoutput   := false;\r
testing      := testinput or testoutput;\r
\r
call_pass4   := true;   (* default = continue with pass4 *)\r
target_machine:= target35021; (* default = RC3502 revision 5 *)\r
\r
if testing then \r
begin\r
writeln (output);\r
write (output, 'REAL-TIME PASCAL, pass3, version ', version);\r
end;\r
\r
cur_lineno   := 0;\r
no_of_warnings:= 0;\r
no_of_errors:= 0;\r
cur_opandno:= 0;\r
emit_lineno  := 0;\r
cur_blockno:= process_block;\r
cur_context_no:= -1;\r
\r
(* announce own version to next pass *)\r
emit (xoption);\r
emitin (0);\r
emitin (own_passno);\r
emitin (versionpass3);\r
\r
(* initialize list structures *)\r
\r
(* initialize freelist of 'names' *)\r
insert_in_front:= false;  (* default is: insert all names in rear *)\r
maxnix:= 0;\r
new(nilname);\r
with nilname^ do\r
begin\r
nextname:= nil;\r
nix:= maxnix;\r
end;\r
freenames:= nilname;\r
\r
(* initialize freelist of opands *)\r
maxopands:= 0;\r
new(nilopand);\r
with nilopand^ do\r
begin\r
next:= nil;\r
opcode:= cerrorarg;\r
(* initialized because it is used as 'working location' by 'testindex' *)\r
end;\r
freeopands:= nilopand;\r
\r
(* initialize 'types' *)\r
freetypename:= nilname;\r
maxtypes:= 0;\r
new(dummy_typenode);\r
with dummy_typenode ^ do \r
begin\r
element:= nilname;\r
index:= nilname;\r
subexpr:= nilopand;\r
typekind:= cnocode;\r
contents:= [t_simple];\r
packflag:= false;\r
emitted:= false;\r
end;\r
new(niltype);\r
niltype^:= dummy_typenode^;\r
\r
\r
(* initialize 'strings' *)\r
maxstrings:= 0;\r
new(nilstring);\r
with nilstring^ do\r
nextstr:= nil;\r
freestrings:= nilstring;\r
\r
(* initialize freelist of label nodes *)\r
maxlabels:= 0;\r
new(nillabel);\r
with nillabel^ do\r
prevlabel:= nil;\r
freelabels:= nillabel;\r
\r
(* initialize variables concerning opands *)\r
stacktop:= nilopand;\r
nexttop := nilopand;\r
\r
(* initialize pushname stack *)\r
maxpushnames:= 0;\r
new(curpushname);\r
with curpushname^ do\r
begin\r
push_chain:= nil;\r
pop_chain:= nil;\r
end; (* empty pushname stack *)\r
\r
\r
(* initialize namestack etc *)\r
maxnamestacklevels:= 0;\r
new(nil_namestack_ptr);\r
with nil_namestack_ptr^ do\r
begin\r
former_level:= nil_namestack_ptr;\r
next_level:= nil;\r
level_number:= maxnamestacklevels;\r
end;\r
namelevel:= nil_namestack_ptr; (* current level *)\r
levelkind:= processlevel;\r
lastgloballevel:= namelevel;\r
newnamelevel;\r
lowestlevel:= namelevel; (* very first level *)\r
expecting_block:= false;\r
after_funccall:= false;\r
expr_release:= false;\r
const_decl:= false;\r
retain_top:= false;\r
expr_level:= 0;  (* i.e. first 'emitexpr' is beginning of expression *)\r
start_of_protected:= false;\r
\r
(* initialize stack for holding arguments *)\r
callindex   := 0;\r
argkind     := cnocode;\r
curformal   := nilname;\r
arglist_owner:= nilname;\r
functempvar := nilname;\r
count_processparam:= 0;\r
\r
\r
(* initialize important spix'es *)\r
\r
(* the following construction matches the main-loop *)\r
endpass1:= false;\r
\r
repeat\r
\r
if testing then writeln(output);\r
\r
rectype:= password;\r
\r
case rectype of\r
\r
cnewline:\r
cur_lineno:= passin;\r
\r
coption:\r
readoption;\r
\r
cstandardname:\r
standardname;\r
\r
cendstandards:\r
endpass1:= true;\r
\r
else comp_error (unknown_rectype);\r
end;\r
\r
until endpass1;\r
envir_spix:= anonymous_spix; (* used as flag to omit 'typedef' for integer etc *)\r
\r
(* initialze important name/type nodes *)\r
\r
error_typename:= alloc_namenode;\r
error_typenode:= alloc_typenode;\r
\r
with  error_typename ^ do\r
begin\r
spix         := anonymous_spix;\r
namekind     := cerrorkind;\r
typename     := error_typename;\r
typ          := error_typenode;\r
end;\r
\r
with  error_typenode ^ do\r
typekind   := cerrorkind;\r
\r
with  dummy_typenode ^ do\r
typekind   := cnocode;\r
\r
text_typename:= alloc_namenode;\r
with  text_typename ^ do\r
begin\r
spix    := anonymous_spix;\r
namekind:= ctype;\r
typ     := alloc_typenode;\r
with  typ ^ do\r
typekind:= ctext;\r
end;\r
\r
 nilname ^:=  error_typename ^;\r
\r
set_error_type;\r
emittype (error_typename);\r
emittype (text_typename);\r
prepare_expression;\r
\r
end; (* procedure initialize *)\r
\r
\f

\r
\r
«eof»