⟦295a8a662⟧

TextFileVerbose

program platonpass3 (
input,  (* used when reading pass3errors *)
output, (* used for testoutput *)
pass1file = 'pass1code', (* contains pass1-output *)
pass1labels = 'pass1labels' , (* contains labeldefs from pass1 *)
pass3file = 'pass3code' (* contains output from pass3 *)
);

label 999; (* exit from pass3 main program *)

const

version = '81.04.03';
versionpass3 = 205;  (* 2.05 *)
versionpass1 = 300;  (* pass1 version must be 3.xx *)
own_passno = 3;
(*$T+*)
{
nilname = 0; max_names = 600;
niltype = 601; max_types = 800;
nillabel = 950; max_labels = 999;
nilopand = 1000; max_opands = 1500;
nilstring = 2000; max_strings = 2010;
max_levels = 20;
}

nilname = 0;           (* dummy index in 'names' *)
niltype = 0;           (* dummy index in 'types' *)
nillabel = 0;          (* dummy index in 'labels' *)
nilopand = 0;          (* dummy index in 'opands' *)
nilstring = 0;         (* dummy index in 'strings' *)

max_names = 2000;      (* max index in 'names' *)
max_types = 450;       (* max index in 'types' *)
max_labels = 20;       (* max index in 'labels' *)
max_opands = 1500;     (* max index in 'opands' *)
max_levels = 20;       (* max index in 'namestack' *)
max_strings = 1000;     (* max index in 'strings' *)
max_pushnames = 100;   (* max index in 'pushnamestack' *)
max_nested_calls = 20; (* max index in 'calls' *)

lines_pr_page = 45;    (* used for nice testoutput *)

max_spix = 4095;       (* max value of 'spix' *)
max_labelscopenumber = 100000; (* max value of 'labelscope' *)

lowestlevel = 1;       (* first used namelevel *)
process_block = 0;     (* blocknumber for process variables *)
maxstring = 12;        (* number of chars per string portion *)

compilertest = true;   (* determines amount of 'superflous' testing *)

type

nameptr = nilname .. max_names;
typeptr = niltype .. max_types;
labelptr = nillabel .. max_labels;
opandptr = nilopand .. max_opands;
stringptr = nilstring .. max_strings;
str_index = 1 .. maxstring;

spixrange = 0 .. max_spix;
labelrange = 0 .. max_labelscopenumber;
levelrange = 0 .. max_levels;
pushrange = 0 .. max_pushnames;
callrange = 0 .. max_nested_calls;

(* define codes in pass1file/pass1labels *)
codes =
(
cnocode,
cerror, cerrortext, cerrorno,
coption,
cnewline,
ceom,

cendstandards,
cstandardname,
(* parameters to 'standardname' *)
canonymous, (* first std name *)
cboolean,
cchar,
cshadow,
creference,
csemaphore,
cson,
cprocessrec,
cexception,
cabs,
csucc,
cpred,
cchr,
cord,       (* last std name *)

cinclude, cendinclude,
ccontext, cerrcontext, cendcontext,

cendprefix,

cbeginlevel, cendlevel,
cdeclaration, cdeclare, cdeclarelist,

cexternal, cforward,

cendformallist, cendformal,
cendprocdecl, cendfuncdecl, cendtypedecl,
cendconstantdecl,

cnoinit, cinit, cendvardecl,

cexport,
cexportvalue, cexportsize, cexportdisp, cexportoffset, cexportaddr,

cenddeclarations,

cstartlabelscope, cendlabelscope,

cbegincode, ccodeline, cendcode,

cendblock,

ctypeid,
cendtype,
cwithout_data,

cnewtype,
cendscalar, cendsubrange, cendarray, cendfield, cendrecord, cendset,
cendpool, cendpointer, cendreadonly,
cendexttype,
cpacked,

cbegin, cend,

clabeldef,

ccasestat, ccaseexpr, ccaselabel, ccaselabelrange, ccaselist,
ccaseelement, cotherwise, cendcase,

cforstat, cforvar, cup, cdown, cendfor,

cifstat, cifexpr, celse, cendif,

crepeatstat, cuntil, cendrepeat,

cwhilestat, cwhileexpr, cendwhile,

clockstat, cwithstat, cwithvar,
cnolocaldecl, cendlocaldeclare,
cnolocaltype,
cwithcomma, cdo, cendwith,

cgotostat, cendgoto,

cchannelstat, cchanvar, cendchannel,

cendassign, cendexchange,

ccallprocedure,

(* expression codes *)
cendexpression,
ceq, cne, clt, cle, cgt, cge, cin,
cuplus, cuminus, cplus, cminus, cor, cxor,
cstar, cslash, cdiv, cmod, cand,
cnot,
cendvariable,
cindex, (* <<< used internally by pass3 *)

(* operand codes *)
csetlist, cs_element, cm_element, cendsetlist,
cliteral,
cid,
cskipparam,
cfield,
cuparrow,
crangefirst, (* <<< used internally by pass3 *)
crange,      (* <<< used internally by pass3 *)

cbeginactual, cactualparam, cdoubleparam, cendactual,
(* the following few lines are all for internal pass3-use *)
cfunctrailer, cfunctemp, cerrorarg, cargument,
cfcall, cendproc,
ccallprocess, cprocessargument,
cendprocessparam,
cstrucrecord, cstrucarray, cendstruc,


(* namekinds i.e. parameters for 'declaration' *)
cprocess, cprocedure, cfunction, ctype,
cscalarelem, crecfield, cconstant, cvar,
cvarp, cvaluep, cfuncval (* <<< used internally by pass3 *),
clabel,
cprefix,
cundeclared (* <<< used internally by pass3 *),


(* typekinds *)
calias (* <<< used internally by pass3 *),
(* typekinds i.e. parameters for 'newtype' *)
cerrorkind (* <<< used internally by pass3 *),
cscalar, csubrange, carray, crecord, cset, cpool,
cpointer, creadonly,
cexttype,
(* standard types *)
cinteger, creal, cniltype,
ctext, (* used for string-literals *)

clastcode (* used internally by pass1/pass3 *)

);

codeindex = 0 .. 200; (* number of codes *)

\f





stdname_range = canonymous .. cord;

(* define codes in pass3file *)
pass3codes =
(
xfirstcode,
xerror, xerrortext, xerrorno,
xoption,
xnewline,
xeom,

xendprelude,

xexternal, xforward, xsecprocid, xsecfuncid,

xprocessid, xprocid, xfuncid,
xconstid,

xvarid, xinitconst, xvarlist,

xlabelid,

xundeclid,

xblock, xexception, xinitblock, xendblock,

xbegincode, xcodeline, xendcode,

(* std types *)
xinteger, xreal, xniltype, xerrortype, xstringtype,
xboolean, xshadow, xreference, xsemaphore,
xchar,

(* std functions *)
xsucc, xpred, xord, xchr,

xtype,
xredeftype,
xscalarid, xscalardef,
xgetexpr, xsubdef,
xarraydef, xpackedarraydef,
xpackedrecord, xrecord, xfieldid, xfielddef, xrecdef,
xsetdef, xpooldef, xpointerdef, xfrozendef,
xtypedef,

xexportvalue, xexportsize, xexportdispl, xexportoffset, xexportaddr,
xendexport,

xparamid, xvalueparam, xvarparam,

xname,

xprefix,

xlabel,

xcasestat, xcase, xcaselabel, xcaserange, xotherwise, xendcase,
xendcaselist, xendcasestat,

xforstat, xfor, xup, xdown, xdo, xendfor,

xifstat, xifexpr, xelse, xif,

xrepeat, xuntil, xendrepeat,

xwhile, xwhileexpr, xendwhile,

xwith, xwithvar, xendwith,
xlockstat, xlockvar, xlock, xendlock,

xgoto,

xchannel, xchanvar, xendchannel,

xassignstat, xbecomes, xassign,
xexchangestat, xexchange,

xproccall, xendproc,
xfunccall, xfcall, xendfunccall,
xactual, xendactual,

xprocessparam,
xvarpointer, xtempointer, xarglistsize,

(* expressions *)
xexpr,
xgetvalue,
xne, xeq, xle, xge, xlt, xgt, xin,
xneg, xadd, xsub, xor,
xxor,
xdiv, xmul, xmod, xand,
xnot,

(* conversion operators *)
xrange,

xset, xinclude, xsetexpr, xincluderange, xendset,

xliteral,
xvar,
xstrucconst, xtimes, xnull, xstruc, xendstruc,
xindexexpr, xindex,
xarrow, xfield,

xlastcode

);

pass3codeindex = 0 .. 200; (* number of pass3codes *)


literalkinds = (lit_dummy, lit_integer, lit_string_or_empty, lit_char);

\f



(* end pass 3 codes *)

(* include pass3errors from stdfile *)
pass3errors =
(
noerror,
undeclared,            (* identifier not declared *)
inconsistent_use,      (* identifier used before declaration *)
double_declaration,    (* identifier already declared at this level *)
label_not_declared,    (* label-identifier not declared at all *)
not_label_name,        (* other identifier used as label-name *)
multiple_defined_label, (* label defined several times at this level *)
label_not_locally_declared,  (* label-identifier declared at surrounding level *)
erroneous_label,       (* use of a multiple defined label *)
label_used_from_inner, (* a label-ident has been used in inner routine *)
label_used_outside_scope,    (* goto leading into control-structure *)
label_defined_outside_lock_or_channel, (* goto out of lock- or channel statements *)
label_undefined,       (* label is not defined *) 
not_typename,          (* identifier is not a type-identifier *)
recursive_use_of_type, (* error in record or array etc. *)
recursive_constant_use,(* constant is used its own definition-expression *)
illegal_pool_type,     (* pool ... of <illegal type> *)
pool_cardinality_must_be_integer, (* illegal size'ing of pool type *)
subrange_elems_must_be_enumeraton, (* illegal limit-types in subrange def *)
type_may_only_be_used_at_process_level,  (* nb: semaphore, pool *)
process_only_allowed_at_processlevel, (* processes inside functions/procedures forbidden *)
illegal_formal_type,   (* formal type may not be used in this context *)
illegal_function_type,  (* functiontype may not contain:semaphore etc *)
illegal_scope_of_type_component, (* only variables of surrounding scope allowed *)
paramlist_changed_since_forwarddecl, (* 'new' paramlist may be empty or exact the same *)
forward_not_solved,    (* forward-declared routine not followed with the real body *)
funcval_not_used,      (* function-value has not been defined at all *)
type_has_pointers,     (* locktype contains pointer-types *)
type_has_systemtypes,  (* locktype contains semaphore, reference, shadow, pool *)
opands_incompatible,   (* opands not of same typename *)
for_incompatible,      (* for-variable/startvalue/endvalue not of compatible types *)
case_incompatible,     (* case-expression/caselabels not of compatible types *)
if_type,               (* if-expression must be boolean type *)
repeat_type,           (* until-expression must be boolean type *)
while_type,            (* while-expression must be boolean type *)
with_type,             (* with-variable must be a record *)
lock_type,             (* lock-variable must be reference type *)
channel_type,          (* channel-variable must be reference type *)
not_index_type,        (* type of operand must be enumeration-type *)
not_variable,          (* operand cannot be used as variable *)
field_must_follow_recordtype, (* <variable> in front of <.> is not a record *)
name_not_fieldname,    (* <name> after <.> is not a fieldname of <variable> *)
must_be_pointertype_before_uparrow, (* <variable> in front of <uparrow> is not a pointer *)
mixed_types_in_setlist, (* elements in set-value may not be of mixed types *)
relation_error,        (* illegal mixture of types in relation *)
arithmetic_error,      (* illegal mixture of types in term or factor *)
monadic_error,         (* illegal type for monadic operator *)
real_not_implemented,  (* real occuring in expression *)
real_division_not_implemented,  (* real-division of integers not impl *)
illegal_in_expr,       (* illegal operand kind in expression *)
too_few_parameters,    (* too few actual parameters to routinecall (or strucrecord *)
too_many_actual_params, (* error in routinecall *)
too_many_values_in_record_structure, (* error in structured-record constant *)
type_must_be_record_or_array, (* typename in front of arglist must be... *)
double_param_only_in_struc_const, (* the '***' operator must only occur in structured-array constant *)
subscript_after_nonarray, (* name in front of arglist is not of array-type *)
incompatible_index,     (* index-expression does'nt match array-declaration *)
assign_incompatible,    (* incompatible types in assignment *)
exchange_incompatible,  (* incompatible types in exchange *)
not_procedure_call,     (* the statement is not a procedure-call *)
variable_may_not_be_packed,  (* for-variable or actual var-param is packed *)
not_assignable,          (* operand may not be assigned: sem, pool, ref, shadow, frozen *)
not_exchangeable,        (* operand may not be exchanged: sem, pool, frozen *)
exchange_type,           (* type must be: reference or shadow *)
illegal_var_param_substitution,   (* formal and actual type must match exactly *)
illegal_value_param_substitution, (* actual and formal types are not compatible *)
actual_may_not_be_frozen, (* formal is not frozen, therefor... *)
skipparam_only_in_struc_const,  (* the '?' may only occur in structured constants *)
struc_arr_incompatible,  (* incomp. types in structured array-constant *)
struc_rec_incompatible,  (* incomp. types in structured record-constant *)
var_init_incompatible,   (* incomp. types in var-initialization *)
repetition_type,         (* repeatiton must be integer *)
const_export_only,       (* value-export demands constant *)
var_export_only,         (* offset-export demands variable *)
const_or_var_export_only,(* size-,disp-,addr-export demands constant or variable *)
disp_export_must_have_field, (* disp-export demands 'fielding' *)
not_implemented_on_z80, (* xor, integer-and, and integer-or not implemented *)
lastpass3error);

(* define parameters to procedure 'stop' *)
stopcodes = (
too_many_names,
too_many_types,
too_many_strings,
too_many_labels,
too_many_opands,
too_many_levels,
too_many_pushnames,
too_many_nested_calls);

levelkinds = (
processlevel,
firstwith, nextwith,
firstlock, nextlock,
irrell_level);

(* define pass3 programming error-codes *)
comp_errorcodes =
(unknown_namekind,
unknown_argkind,
unknown_opcode,
unknown_paramkind,
unknown_routinekind,
unknown_spix,
unknown_stdtype_name,
unknown_typekind,
unknown_rectype,
inconsist_alloc,
wrong_version,
unstack_nontype);


(* operator modes *)
opmodes = (unary, binary);

(* components of a type *)
components = (t_simple, t_semaphore, t_pool, t_reference, t_shadow,
t_pointer, t_readonly);

content_set = set of components;

label_states = (outside_scope, inside_scope, hidden_by_lock_or_channel);

(*QQQ*)

namenode = packed record
nextname: nameptr      ; (* used to chain names of same level *)
spix    : spixrange    ; (* spelling index of identifier *)
namekind: codes        ; (* kind of identifier: var, const, function etc *)
typename: nameptr      ; (* points to the namenode of the type (unless namekind = 'ctype' *)
typ     : typeptr      ; (* only relevant if namekind = 'ctype' *)
params  : nameptr      ; (* routine etc: first formal parameter name *)
forward_decl: boolean  ; (* true, when after 'forward' *)
external_decl: boolean ; (* true, when after 'external' *)
func_assigned: boolean; (* true, when funcval is used *)
usedlevel: levelrange  ; (* nillevel, if never used, otherwise some namelevel *)
end;



typenode = packed record
typekind: codes        ; (* kind of type: subrange, array etc *)
emitted:  boolean      ; (* true, when type has been emitted *)
contents: content_set  ; (* describes the components of the type *)
packflag: boolean      ; (* true, if type is packed *)
element: nameptr       ; (* depends on 'typekind':
                         -    scalar: first scalarname
                         -    record: first field name
                         -    array : typename of elements
                         -    set   : typename of elements
                         -    pool  : typename of elements
                         -    pointer: typename of element
                         -    readonly: typename of element
                         -    alias : typename of alias type
                         *)
index:    nameptr      ; (* depends on 'typekind':
                         -    subrange: typename of limits
                         -    array   : typename of index
-    alias   : ( corresponding to the alias type )
                         *)
subexpr:  opandptr     ; (* depends on 'typekind':
                         -    subrange: pointer to 'both' expressions
                         -    pool:     pointer to cardinality-expr
                         *)
end;

(*QQQ*)

labelnode = packed record
prevlabel : labelptr   ; (* used to chain to other label def's *)
labelspix : spixrange  ; (* spelling index of label *)
labelname : nameptr    ; (* points to the label-declaration namenode *)
labelscope: labelrange ; (* scope number of label *)
hiddenscope: labelrange; (* scopenumber of lock-or-channel which hides this label *)
labelstate: label_states; (* used to determine 'visability' *)
multflag  : boolean    ; (* true, if multiple defined *)
used_from_inner_routines: boolean; (* true, if used from inner routines *)
end;



opandnode = packed record
opcode     : codes     ; (* kind of operand/operator *)
op_lineno  : integer   ; (* line number *)
left       : opandptr  ; (* left subtree *)
rigth      : opandptr  ; (* rigth subtree *)
next       : opandptr  ; (* opand to the left of reduced tree *)
op_name    : nameptr   ; (* name of operand, if 'id' *)
op_value   : stringptr ; (* relevant, if 'literal' *)
op_typename: nameptr   ; (* typename of reduced tree *)
op_packflag: boolean   ; (* true, if the opand is packed *)
end;



namestacknode = packed record
firstname : nameptr    ; (* points to first name of a level *)
lastname  : nameptr    ; (* points to last  name of a level *)
namelistkind: levelkinds; (* defines kind of list *)
withname  : nameptr    ; (* holds the name of the pseudo var *)
end;



stringnode = packed record
nextstr  : stringptr   ; (* pointer to next string portion *)
stringlgt: integer     ; (* length of remaining part *)
str: packed array [ str_index ] of char; (* contains the portion *)
end;



callnode = packed record
(* the record holds stacked values of global variables *)
callkind      : codes;      (* holds: 'actkind' *)
callformal    : nameptr;    (* holds: 'curformal' *)
callowner     : nameptr;    (* holds: 'arglist_owner' *)
call_afterfunc: boolean;    (* holds: 'after_funccall' *)
call_functemp : nameptr;     (* holds: 'functempvar' *)
call_countprocess: integer;  (* holds: 'count_processparam' *)
end;

var
cur_lineno: integer;   (* current line number from pass1file *)
lineno    : integer;   (* last read lineno from pass1 *)
cur_opandno: integer;  (* number of operands on current line *)
emit_lineno:integer;   (* current emitted lineno in pass3file *)
curname:    nameptr;   (* current name node *)
cur_routine:nameptr;   (* current routine *)
cur_typename: nameptr; (* namenode of current type *)
cur_typenode: typeptr; (* corresponding typenode *)
cur_blockno: integer;  (* lexicographical level *)
cur_labelscope: labelrange; (* updated by: begin/end label scope *)
cur_namekind: codes;   (* updated by 'declaration' (and 'newtype') *)
rectype: codes;        (* record type of current input-record *)
cur_dyn_var_level:integer; (* highest level allowed for use of variables *)
namelevel: levelrange; (* current name level *)
levelkind: levelkinds; (* kind of (future) namelevel *)
lastgloballevel: levelrange; (* identifies last environment level *)
processparamlevel: levelrange; (* used when searching identifiers *)
pushnameindex: pushrange; (* index in pushnamestack *)
callindex    : callrange; (* index in calls *)

(* the following variables are results from 'searchspix' etc *)
retrieved_level: levelrange; (* undef, if name was'nt found *)
retrieved_name : nameptr;    (* nilname, if name was'nt found *)

(* variables used when processing actual parameter lists *)
curformal     : nameptr; (* points into formal parameter list *)
argkind       : codes;   (* separates into: argument, index, struc etc *)
arglist_owner: nameptr; (* points to the routinename or arraytypename or typename *)
functempvar   : nameptr; (* points to temporary namenode *)
count_processparam: integer;  (* number of process-'calls' in arglist *)

testinput: boolean;    (* determines printing of input-records *)
testoutput: boolean;   (* determines printing of output-records *)
testing:   boolean;    (* = (testinput or testoutput) *)
testlinecnt: integer;  (* used for changing page during testprinting *)

freenames: nameptr;    (* list of free name node *)
freetypename: nameptr; (* list of free type nodes, linked via namenodes *)
freestrings: stringptr; (* list of free string nodes *)
freelabels: labelptr;  (* list of free label nodes *)
freeopands: opandptr;  (* list of free opand nodes *)

listfirst: nameptr;    (* first name in current declaration list *)
listlast:  nameptr;    (* last  name in current declaration list *)
listtop:   nameptr;    (* used when scanning the current decl list *)
lastlabel: labelptr;   (* last name in list of defined labels *)

endpass1:  boolean;    (* false, until 'eom'-record has been read *)
call_pass4: boolean;    (* true, until first error in pass3 *)
lambda_version: boolean; (* true, unless z80-version *)
after_funccall: boolean;  (* flag to determine 'endfunccall' *)
insert_in_front: boolean; (* true: names are inserted in front else in rear *)
before_assign: boolean; (* true: identifier cannot be function or process *)
afterdecl: boolean;    (* flag to determine <end-decl> in a routine *)
expecting_block: boolean; (* flag to determine <first decl> in a routine *)
var_initialization: boolean;  (* true, if initialization in var-decl *)
expr_release: boolean; (* true, if expression must be released after emit *)
const_decl: boolean;   (* true, when emitting expr in const declaration *)
retain_top: boolean;   (* true, if stacktop must be reused *)
start_of_protected: boolean;  (* true when starting channel or lock statements *)
expr_level: integer;   (* controls beginning of whole expression *)

dummy_typenode: typeptr; (* std type entry *)
error_typename: nameptr; (* std name entry *)
error_typenode: typeptr; (* std type entry *)

envir_spix: spixrange; (* working location ? *)
newspix    : spixrange; (* holds spix of fieldname *)

maxstdspix: integer;   (* holds max spix with special interrest *)
anonymous_spix: spixrange; (* initialized during startup *)
exception_spix: spixrange; (* initialized durring startup *)

boolean_typename: nameptr;
integer_typename: nameptr;
char_typename   : nameptr;
shadow_typename   : nameptr;
reference_typename: nameptr;
text_typename     : nameptr; (* internally used for text-literals *)
processrec_typename: nameptr;
son_typename    : nameptr;
nil_typename    : nameptr;

exception_procname: nameptr;
abs_procname    : nameptr;
succ_procname   : nameptr;
pred_procname   : nameptr;
ord_procname    : nameptr;

for_typename: nameptr;  (* holds typename of current for-variable *)
for_basetypename: nameptr; (* holds simplified typename of for-variable *)
case_typename: nameptr; (* holds typename of current case-expression *)
with_typename: nameptr; (* work-location: holds typename of with-variable *)

indexname: nameptr;     (* working location *)
elemname:  nameptr;     (* working location *)

paramkind: codes;       (* used when checking formal parameters *)
not_allowed: content_set; (* holds the illegal parameter contents *)

opand_procname: opandptr; (* holds 'literal'-operand, with routine name *)

for_expr: opandptr;     (* holds the end-value expression of a for-statement *)

stacktop: opandptr;     (* points to current top of opands *)
nexttop:  opandptr;     (* points to 'next' of current top-opand *)

(* the following variables are used when resolving opand-types *)
lefttypename:  nameptr;
leftbasekind:  codes;
leftelement:   nameptr;
rigthtypename: nameptr;
rigthbasekind: codes;
rigthelement:  nameptr;
exprtypename:  nameptr;
exprbasekind:  codes;
exprelement:   nameptr;

errorcode: pass3errors; (* working location *)

no_of_errors: integer;

cur_date: alfa;  (* string holding current date *)
cur_time: alfa;  (* string holding current time *)

names:   array [ nameptr ] of namenode;
types:   array [ typeptr ] of typenode;
labels:  array [ labelptr ] of labelnode;
opands:  array [ opandptr ] of opandnode;
namestack: array [ levelrange ] of namestacknode;
strings: array [ stringptr ] of stringnode;
pushnamestack: array [ pushrange ] of nameptr;
calls: array [ callrange ] of callnode;

convtable: array [ codeindex ] of codes;

stdspix_table: array [ stdname_range ] of integer;

error_bitmap: packed array [ noerror .. lastpass3error ] of boolean;

pass1file: file of integer;
pass1labels: file of integer;
pass3file: file of integer;

(*QQQ*)

(* procedures used for testoutput purposes *)

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



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

(*QQQ*)

(* procedures for reading pass1-code file *)

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



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

(*QQQ*)

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

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

(*QQQ*)

(* procedures for writing the pass3file *)

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



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



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



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

emit (xeom);
close (pass3file);

close (pass1file);
close (pass1labels);

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

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

end;

(*QQQ*)

(* procedures for error-handling etc *)

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



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



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



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



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

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

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

goto 999; (* terminate program *)
end;



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

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

end; (* procedure comp_error *)



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

var passno, optno, optvalue: integer;

begin

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

if passno <> own_passno then
begin
if passno = 0 then (* version-identification *)
if optno = 1 (* pass 1 *) then
if (optvalue div 100 <> versionpass1 div 100) or
(optvalue mod 100 < versionpass1 mod 100) then
comp_error (wrong_version);
emit   (xoption);
emitin (passno);
emitin (optno);
emitin (optvalue);
end
else
begin
case optno of
1: testinput   := optvalue = 1;
2: testoutput  := optvalue = 1;
3: call_pass4  := optvalue = 1;
4: lambda_version := optvalue = 1;
end otherwise; (* case, otherwise blind *)
end;
testing := testinput or testoutput;

end; (* procedure readoption *)

(*QQQ*)

(* procedures for allocating/releasing structures *)



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

var string: stringptr;

begin

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

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

end;



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

var string: stringptr;

begin

string := xstring;

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

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

end;



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

var opand: opandptr;

begin

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

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

end;



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

begin

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

end; (* procedure release-expr *)



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

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

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

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

end;



procedure release_typenode (xtype: typeptr); forward;

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

var name: nameptr;

begin

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

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

xnamelist := name;

end; (* with xnamelist *)

end;



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

var name : nameptr;

begin

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


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

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

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

end; (* with typenode *)

end;



procedure release_typenode (xtype: typeptr);

var name: nameptr;

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

end;



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

var lab: labelptr;

begin

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

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

end;

(*QQQ*)



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

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

begin

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

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

portion := maxstring;

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

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

if length > 0 then
nextstr := alloc_string;

curstr := nextstr;

end; (* with curstr *)

end; (* procedure readstring *)



procedure emitstring (string: stringptr);

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

begin

curstr := string;
portion := maxstring;

with strings [ curstr ] do
length := stringlgt;

emitin (length);

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

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

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

until curstr = nilstring;

end; (* procedure emitstring *)



procedure emit_extname (opand: opandptr);

begin

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

end;



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

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

var i: stdname_range;

begin

stdspix_table [ xstdname ] := xspix;

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

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

end;



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

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

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



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

label 99;
var i: stdname_range;

begin

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

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

case i of

canonymous: ; (* empty *)

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

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

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

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

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

cson:
son_typename     := xname;

cprocessrec:
processrec_typename := xname;

cexception:
exception_procname := xname;

cabs:
abs_procname     := xname;

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

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

cchr:
emitid (xchr, xname);

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

end
otherwise
if compilertest then
comp_error (unknown_stdtype_name);

goto 99; (* goto found *)

end; (* for i in stdspix_range *)

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

99: ; (* found: *)

end; (* procedure specialspix *)



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

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

(* procedures for inserting/retrieving names *)



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

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

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

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

begin

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

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

end; (* procedure searchspix *)



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

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



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

label 99;
var name : nameptr;

begin

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

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

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

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

end; (* if existing name *)

end; (* if explicit spix *)

(* allocate and initialize a new namenode *)

name := alloc_namenode;

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

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

end; (* with name *)

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

end; (* procedure newname *)



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

var name: nameptr;

begin

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

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

new_undecl := name;

end; (* procedure new-undecl *)



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

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

var name: nameptr;

begin

cur_opandno := cur_opandno + 1;

name := findname (xspix);

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

end; (* if undeclared *)

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

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

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

end; (* procedure usename *)



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

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

var
name: nameptr;
level: levelrange;

begin

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

end; (* procedure end_level_use *)



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

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

(*QQQ*)

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

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



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



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

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

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



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

procedure pushtype;
begin
pushname (cur_typename);
end;

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

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



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

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

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

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

count_processparam := 0;

callindex := callindex + 1;

end; (* procedure pushcall *)



procedure popcall;
(* works opposite of pushcall *)

begin

callindex := callindex - 1;

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

end; (* procedure popcall *)


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

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

var
oldtop: opandptr;

begin

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

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

opcode := xopcode;

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

nexttop := next;

end;

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

end; (* with (new) stacktop *)

end; (* procedure oper *)



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

var
oldtop: opandptr;

begin

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

oldtop := stacktop;
stacktop := alloc_opand;

end;

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

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

end;

nexttop := oldtop;

end; (* procedure newopand *)



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



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



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

var
saved_stacktop : opandptr;
saved_nexttop  : opandptr;

begin

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

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

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

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

retain_top := true;

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

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

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

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

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

retain_top := false;

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

end; (* with namenode of routine *)

end; (* procedure prepare-call *)



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

label 10;

var
saved_stacktop : opandptr;
saved_nexttop  : opandptr;

begin

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

case argkind of

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

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

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

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

cindex: ; (* nothing *)

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

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

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

end (* case argkind *)

otherwise
if compilertest then
comp_error (unknown_argkind);

(* unstack nested call *)
popcall;

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

end; (* procedure terminate-call *)



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

var
saved_stacktop : opandptr;
saved_nexttop  : opandptr;

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



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

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

end; (* procedure make-call *)

(*QQQ*)

(* procedures for handling level-change etc *)

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

end;


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


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

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

(*QQQ*)



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

label 99;

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

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

end; (* procedure empty-paramlist *)

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

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

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

var
newparam, oldparam: nameptr;
errorflag: boolean;

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

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

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

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

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

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

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

end; (* with/while more params *)

if errorflag then
error (paramlist_changed_since_forwarddecl);

end; (* if new paramlist not empty *)

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

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

end; (* with cur_routine *)

end; (* procedure compare_paramlists *)

(*QQQ*)

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

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

emit (xblock);
emitin (cur_blockno);

end;

(*QQQ*)

(* procedures for emitting identifiers and types *)



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

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

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

begin

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

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


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

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

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

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

case namekind (* of namenode *) of

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

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

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

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

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

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

end; (* opcode = 'id' *)

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


cskipparam:
emit (xnull);


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


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


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


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


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


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


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


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


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

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


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


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

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


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


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


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


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


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

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

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

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

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


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

if testoutput then continue_line;

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

expr_level := expr_level - 1;

end; (* with expr *)

end; (* procedure emitexpr *)



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

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

end;



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

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



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

begin
before_assign := false;
end;



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

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

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

case typekind of

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



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

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

emitid (xscalardef, xtypename);
end;



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



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



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



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



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

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

emitid (xrecdef, xtypename);

end;



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



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



cinteger:
emitid (xinteger, xtypename);



creal:
emitid (xreal, xtypename);



cniltype:
emitid (xniltype,xtypename);



cerrorkind:
emitid (xerrortype, xtypename);



ctext:
emitid (xstringtype, xtypename);



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

end; (* if not emitted yet *)

end; (* with typ/typename *)

end; (* procedure emittype *)

(*QQQ*)

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

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

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

end;



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

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

begin

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

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

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

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

(* emit formallist *)
emitformal (params);

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

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

end; (* procedure emitroutinehead *)



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

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

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

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

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

end; (* procedure test *)

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

(*QQQ*)

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

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

var
curlabel: labelptr;
multdef : boolean;

begin

(* test for multiple definition *)

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

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

(* allocate and initialize a new labelnode *)

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

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

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

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

end; (* with curlabel *)

end; (* procedure pseudodefine *)



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

var lab: labelptr;

begin

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

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

end; (* procedure initlabels *)



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

var
curlabel: labelptr;

begin

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

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

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

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

end;



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

begin

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

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

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

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

start_of_protected := false;

end; (* procedure set_label_state *)



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

var
curlabel: labelptr;

begin

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

check_label := label_undefined; (* suppose not locally declared *)

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

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

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

end; (* if namekind = label *)

end; (* with labname *)

end; (* procedure checklabel *)



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

label 98;

begin

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

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

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

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

end otherwise; (* case *)

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

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

end; (* procedure testvalue *)



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

label 99; (* opand ok *)

begin

with opands [ opand ] do

case opcode of

cindex,
cfield,
cuparrow:
begin
if opcode = cindex then
testvariable( left )
else testvariable( rigth );
goto 99; (* ok *)
end;

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

end otherwise; (* case opcode *)

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

end; (* procedure testvariable *)



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

begin
testfrozen := false;
all_tested := false;

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

until all_tested;

end; (* procedure testfrozen *)



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



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



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



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



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

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

begin

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

local_typename := opands [ opand ] . op_typename;

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

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

begin

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

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

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

end; (* with names,types *)

end; (* procedure resolvetype *)



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



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

begin

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

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

end;



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

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

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

end;



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

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

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



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

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

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

end

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

end; (* procedure testindex *)



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

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

end; (* procedure testenumeration *)



procedure set_procedure;
(* handles set-values *)

begin

case rectype of

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

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

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

oper (binary, rectype, rigthtypename);

end;


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

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

oper (unary, cendsetlist, exprtypename);

end;

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

end; (* procedure set-procedure *)



procedure export_procedure;

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

begin

case rectype of

cexport:
begin
(* save the external name, to be emitted later *)
opand_procname := take_stacktop;
if expecting_block then
begin_block;
cur_dyn_var_level := maxint;
end;

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

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

resolvetype (stacktop, exprtypename, exprelement, exprbasekind);

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

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

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

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

if errortxt <> noerror then
error (errortxt);

end; (* if no error-operand *)

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

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

cur_dyn_var_level := namelevel;

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

end; (* procedure export-procedure *)



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

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

end;



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

var rel_error: pass3errors;
begin

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

rel_error := noerror;

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

case leftbasekind of

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

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

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

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

cerrorkind: ; (* anything allowed *)

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

end
otherwise
rel_error := relation_error;

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

end; (* procedure relation *)



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

var arith_error: pass3errors;

begin

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

arith_error := noerror;

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

if leftbasekind <> rigthbasekind then
arith_error := arithmetic_error
else
case leftbasekind of
cinteger: begin
if not lambda_version and
((operator = cor) or (operator = cand)) then 
arith_error := not_implemented_on_z80;

if operator = cslash then
arith_error := real_division_not_implemented;
lefttypename := integer_typename;  (* let result be base type *)
end;
creal:
arith_error := real_not_implemented;
cset:
if ((leftelement <> rigthelement) (* sets with same elementtypes *) and
(leftelement <> nil_typename) (* allow empty sets *) and
(rigthelement <> nil_typename)) or
(operator = cand) or (operator = cor) or (operator = cxor) or
(operator = cslash) then
arith_error := arithmetic_error
else
if leftelement = nil_typename then   (* if left-operand is empty set then *)
lefttypename := rigthtypename;     (*   use typename from rigth-operand *)

cerrorkind: ; (* allow anything *)

cscalar: if (lefttypename <> rigthtypename) or (lefttypename <> boolean_typename)
or ( (operator <> cand) and (operator <> cor) and (operator <> cxor) ) then
arith_error := arithmetic_error;


end
otherwise
arith_error := arithmetic_error;

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

end; (* procedure arithop *)



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

begin

if rigthbasekind = cerrorkind then
leftbasekind := rigthbasekind;

case leftbasekind of

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

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

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

cerrorkind: ; (* anything allowed *)

end
otherwise
error (errorcode);

end; (* procedure test_value_compatible *)



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

begin

if rigthbasekind = cerrorkind then
leftbasekind := rigthbasekind;

case leftbasekind of

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

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

cerrorkind: ; (* anything allowed *)

end
otherwise
error (errorcode);

end; (* procedure test_var_compatible *)



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

begin

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

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

if lefttypename <> rigthtypename then
test_value_compatible (errorcode);

end;

end;



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

var local_typename: nameptr;

begin

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

end;



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

label 1, 2;

begin

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

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

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

end (* case namekind *)

otherwise

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

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

end; (* procedure beginactual *)



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

label 5, 10;

var sonvar_name: nameptr;
loc_tempvar: nameptr;

begin

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


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

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

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

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

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

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

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

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

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

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

end; (* with curformal *)

end; (* argkind = index *)

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

cvarp:
begin
(* check var parameter *)

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

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

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

cvaluep:
begin
(* check value parameter *)

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

count_processparam := count_processparam + 1;

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

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

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

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

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

with names [ curformal ] do
begin

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

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

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

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

end; (* special functions *)

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

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

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

goto 5;
end;

end

otherwise

if compilertest then comp_error (unknown_namekind);

curformal := nextname;  (* follow chain *)

end; (* with curformal *)

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

5: ;

(* note: see also 'prepare_call' *)

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

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

end;  (* argkind = cargument *)


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

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

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

error (too_many_values_in_record_struc);

10: ;

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

end;


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

end; (* procedure actparam *)



(*QQQ*)

procedure initialize;

var strptr: stringptr;
err: pass3errors;

begin

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

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

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

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

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

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

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

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

(* announce own version to next pass *)
emit (xoption);
emitin (0);
emitin (own_passno);
emitin (versionpass3);

(* initialize list structures *)

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

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

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

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

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

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

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

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


(* initialize important spix'es *)

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

repeat

if testing then changeline;

rectype := password;

case rectype of

cnewline:
cur_lineno := passin;

coption:
readoption;

cstandardname:
standardname;

cendstandards:
endpass1 := true;

end otherwise comp_error (unknown_rectype);

until endpass1;
envir_spix := anonymous_spix; (* used as flag to omit 'typedef' for integer etc *)

(* initialze important name/type nodes *)

error_typename := alloc_namenode;
error_typenode := alloc_typenode;

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

with types [ error_typenode ] do
typekind    := cerrorkind;

with types [ dummy_typenode ] do
typekind    := cnocode;

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

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

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

end; (* procedure initialize *)

\f



(* 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 *)
cur_dyn_var_level := namelevel;
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;
cur_dyn_var_level := namelevel;
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;
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
typename (* of constant *) := op_typename;  (*i.e. copy from expression type *)
end;

const_decl := true;
emit_and_release (stacktop);
const_decl := false;

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;

cur_dyn_var_level := maxint; (* all varianble levels are legal *)

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;
(* release local declared variables, nb ! only precent if "endblock" *)
if rectype = cendblock then

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;
index    := types [ names [ element ] . typ ] . index;
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 = crecord then
begin
pushlist;
newnamelevel;
end;

if rectype = cscalar then
begin
pushlist;
with names [ cur_typename ] do
if spix <> anonymous_spix then   (* keep scalarelems on the correct namelevel *)
endnamelevel;
end;

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

endnamelevel;

(* 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
contents := types [ names [ element ] . typ ] . contents + [ t_readonly ];
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;

cur_dyn_var_level := namelevel;

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: 
cur_dyn_var_level := maxint;



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;

cur_dyn_var_level := maxint;

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);
if opands [ nexttop ] . op_typename <> opands [ stacktop ] . op_typename then
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
begin
if retrieved_level >= cur_dyn_var_level then
begin
if (namekind <> cconstant) and (namekind <> cscalarelem) 
and (namekind <> ctype) then
error( illegal_scope_of_type_component );
end
else
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 *)
if namekind <> crecfield then
newopand (cid, typename (* of curname *) );

end; (* with names[ 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;

(* if the previous 'variable' is parameterless functioncall, then... *)
with opands [ stacktop ] do
if opcode = cid then
with names [ op_name ] do  (* namenode of (possible) function name *)
if namekind = cfunction then
begin
pushcall;
prepare_call (stacktop);
terminate_call (stacktop);
end;

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);



cand,
cor,
cxor,
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;



cnot:
begin
(* stacktop must be of boolean or integer type *)
resolvetype (stacktop, exprtypename, exprelement, exprbasekind);

if not lambda_version and (exprtypename <> boolean_typename) then
error( monadic_error );

if (exprtypename = integer_typename) or ( exprtypename = boolean_typename ) then
oper( unary, rectype, exprtypename )
else
suppress_error( exprbasekind, monadic_error);
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»
DataMuseum.dk

RC3500

⟦295a8a662⟧ TextFileVerbose

Derivation

TextFileVerbose
