|
DataMuseum.dkPresents historical artifacts from the history of: DANOSI |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about DANOSI Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 35843 (0x8c03)
Types: TextFile
Names: »P3INIT.PAS«
└─⟦b6837b237⟧ Bits:30010500 SW2103 REL 1.11 Sourcer DVBS1.SW2103.rel.1.11-1 MASTER 31-1-192
└─⟦this⟧ »P3INIT.PAS«
\r
const\r
filrec_max = 256;\r
\r
version = '90.03.01';\r
versionpass3 = 602; (* 6.02 *)\r
versionpass1 = 700; (* pass1 version must be 7.xx *)\r
own_passno = 3;\r
targetz80 = 0; (* z80 as target machine *)\r
target35021 = 1; (* default target machine, RC3502 model 1 *)\r
target35022 = 2; (* RC3502 model 2 *)\r
\r
\r
max_nested_calls = 20; (* max index in 'calls' *)\r
\r
max_spix = 32767; (* max value of 'spix' *)\r
max_labelscopenumber = 32767; (* max value of 'labelscope' *)\r
\r
process_block = 0; (* blocknumber for process variables *)\r
maxstring = 12; (* number of chars per string portion *)\r
\r
compilertest = true; (* determines amount of 'superflous' testing *)\r
\r
type\r
filrec = array[1..filrec_max] of integer;\r
\r
nameptr = ^ namenode;\r
typeptr = ^ typenode;\r
labelptr = ^ labelnode;\r
opandptr = ^ opandnode;\r
stringptr = ^ stringnode;\r
str_index = 1 .. maxstring;\r
namestackptr = ^ namestacknode;\r
pushname_ptr= ^ pushname_node;\r
\r
spixrange = 0 .. max_spix;\r
labelrange = 0 .. max_labelscopenumber;\r
callrange = 0 .. max_nested_calls;\r
\r
(* define codes in pass1file/pass1labels *)\r
codes =\r
(\r
cnocode,\r
cerror, cerrortext, cerrorno,\r
coption,\r
cnewline,\r
ceom,\r
\r
cendstandards,\r
cstandardname,\r
(* parameters to 'standardname' *)\r
canonymous, (* first std name *)\r
cboolean,\r
cchar,\r
cshadow,\r
creference,\r
csemaphore,\r
cson,\r
cprocessrec,\r
cexception,\r
cabs,\r
csucc,\r
cpred,\r
cnew,\r
cnil,\r
cnilref,\r
cchr,\r
cord, (* last std name *)\r
\r
cinclude, cendinclude,\r
ccontext, cerrcontext, cendcontext,\r
\r
cendprefix,\r
\r
cbeginlevel, cendlevel,\r
cdeclaration, cdeclare, cdeclarelist,\r
\r
cexternal, cforward,\r
\r
cendformallist, cendformal,\r
cendprocdecl, cendfuncdecl, cendtypedecl,\r
cendconstantdecl,\r
\r
cnoinit, cinit, cendvardecl,\r
\r
cexport,\r
cexportvalue, cexportsize, cexportdisp, cexportoffset, cexportaddr,\r
\r
cenddeclarations,\r
\r
cstartlabelscope, cendlabelscope,\r
\r
cbegincode, ccodeline, cendcode,\r
\r
cendblock,\r
\r
ctypeid,\r
cendtype,\r
cwithout_data,\r
\r
cnewtype,\r
cendscalar, cendsubrange, cendarray, cendfield, cendrecord, cendset,\r
cendpool, cendpointer, cendreadonly,\r
cendextprocess,\r
cpacked,\r
\r
cbegin, cend,\r
\r
clabeldef,\r
\r
ccasestat, ccaseexpr, ccaselabel, ccaselabelrange, ccaselist,\r
ccaseelement, cotherwise, cendcase,\r
\r
cforstat, cforvar, cup, cdown, cendfor,\r
\r
cifstat, cifexpr, celse, cendif,\r
\r
crepeatstat, cuntil, cendrepeat,\r
cloopstat, ccontloopstat, cexitloopstat, cendloopstat, cexitlock,\r
\r
cwhilestat, cwhileexpr, cendwhile,\r
\r
clockstat, cwithstat, cwithvar,\r
clockmesstat,\r
cnolocaldecl, cendlocaldeclare,\r
cnolocaltype,\r
cwithcomma, cdo, cendwith, cendlock,\r
\r
cgotostat, cendgoto,\r
cexitstat,\r
\r
cchannelstat, cchanvar, cendchannel,\r
\r
cendassign, cendexchange,\r
\r
ccallprocedure,\r
\r
(* expression codes *)\r
cendexpression,\r
ceq, cne, clt, cle, cgt, cge, cin,\r
cuplus, cuminus, cplus, cminus, cor, cxor,\r
cstar, cslash, cdiv, cmod, cand,\r
cshift, cnot,\r
cendvariable,\r
ctypesizecall, cvarsizecall,\r
cindex, (* <<< used internally by pass3 *)\r
\r
(* operand codes *)\r
csetlist, cs_element, cm_element, cendsetlist,\r
cliteral,\r
cid,\r
cskipparam,\r
cfield,\r
cuparrow,\r
crangefirst, (* <<< used internally by pass3 *)\r
crange, (* <<< used internally by pass3 *)\r
\r
cbeginactual, cactualparam, cdoubleparam, cendactual,\r
cbeginstruc, cendstruc,\r
\r
(* the following few lines are all for internal pass3-use *)\r
cfunctrailer, cfunctemp, cerrorarg, cargument,\r
cfcall, cendproc,\r
ccallprocess, cprocessargument,\r
cendprocessparam,\r
cstrucrecord, cstrucarray,\r
\r
(* namekinds i.e. parameters for 'declaration' *)\r
cprocess, cprocedure, cfunction, ctype,\r
cscalarelem, crecfield, cconstant, cvar,\r
cvarp, cvaluep, cfuncval (* <<< used internally by pass3 *),\r
clabel,\r
cprefix,\r
cundeclared (* <<< used internally by pass3 *),\r
\r
\r
(* typekinds *)\r
calias (* <<< used internally by pass3 *),\r
(* typekinds i.e. parameters for 'newtype' *)\r
cerrorkind (* <<< used internally by pass3 *),\r
cscalar, csubrange, carray, crecord, cset, cpool,\r
cpointer, cforwardpointer, creadonly,\r
cextprocess,\r
(* standard types *)\r
cinteger, creal, cniltype,\r
ctext, (* used for string-literals *)\r
\r
clastcode (* used internally by pass1/pass3 *)\r
\r
);\r
\r
codeindex = 0 .. 220; (* greater than number of codes *)\r
(* end pass 1 codes *) \r
\f
\r
\r
\f
\r
\r
\r
\r
stdname_range = canonymous .. cord;\r
\r
(* define codes in pass3file *)\r
pass3codes =\r
(\r
xfirstcode,\r
xerror, xerrortext, xerrorno,\r
xoption,\r
xnewline,\r
xeom,\r
\r
xendprelude,\r
\r
xexternal, xforward, xsecprocid, xsecfuncid,\r
\r
xprocessid, xprocid, xfuncid,\r
xconstid,\r
\r
xvarid, xinitconst, xvarlist,\r
\r
xlabelid,\r
\r
xundeclid,\r
\r
xblock, xexception, xinitblock, xendblock,\r
\r
xbegincode, xcodeline, xendcode,\r
\r
(* std types *)\r
xinteger, xreal, xniltype, xerrortype, xstringtype,\r
xboolean, xshadow, xreference, xsemaphore,\r
xchar,\r
\r
(* std functions *)\r
xsucc, xpred, xnew, xnil, xnilref, xord, xchr,\r
\r
xtype,\r
xredeftype,\r
xscalarid, xscalardef,\r
xgetexpr, xsubdef,\r
xarraydef, xpackedarraydef,\r
xpackedrecord, xrecord, xfieldid, xfielddef, xrecdef,\r
xsetdef, xpooldef, xpointerdef, xforwardpointer, xfrozendef,\r
xextprocess, xextprocdef,\r
xtypedef,\r
\r
xexportvalue, xexportsize, xexportdispl, xexportoffset, xexportaddr,\r
xendexport,\r
\r
xparamid, xvalueparam, xvarparam,\r
\r
xname,\r
\r
xprefix,\r
\r
xlabel,\r
\r
xcasestat, xcase, xcaselabel, xcaserange, xotherwise, xendcase,\r
xendcaselist, xendcasestat,\r
\r
xforstat, xfor, xup, xdown, xdo, xendfor,\r
\r
xifstat, xifexpr, xelse, xif,\r
\r
xrepeat, xuntil, xendrepeat,\r
\r
xloopstat, xendloopstat, xexitloopstat, xcontloopstat,\r
xexitlock, \r
\r
xexitstat,\r
\r
xwhile, xwhileexpr, xendwhile,\r
\r
xwith, xwithvar, xendwith, xretype, xnoretype,\r
xlockstat, xlockmesstat, xlockvar, xlock, xendlock,\r
\r
xgoto,\r
\r
xchannel, xchanvar, xendchannel,\r
\r
xassignstat, xbecomes, xassign,\r
xexchangestat, xexchange,\r
\r
xproccall, xendproc,\r
xfunccall, xfcall, xendfunccall,\r
xactual, xendactual,\r
\r
xprocessparam,\r
xvarpointer, xtempointer, xarglistsize,\r
\r
(* expressions *)\r
xexpr,\r
xgetvalue,\r
xne, xeq, xle, xge, xlt, xgt, xin,\r
xneg, xadd, xsub, xor_,\r
xxor,\r
xdiv, xmul, xshift, xmod, xand,\r
xnot,\r
\r
(* conversion operators *)\r
xrange,\r
\r
xset, xinclude, xsetexpr, xincluderange, xendset,\r
\r
xliteral,\r
xtypesizecall,\r
xvar,\r
xstrucconst, xtimes, xnull, xstruc, xendstruc,\r
xindexexpr, xindex,\r
xarrow, xfield,\r
\r
xlastcode\r
\r
);\r
\r
pass3codeindex = 0 .. 200; (* number of pass3codes *)\r
\r
\r
literalkinds = (lit_dummy, lit_integer, lit_string_or_empty, lit_char);\r
\r
\f
\r
\r
(* end pass 3 codes *)\r
\r
(* include pass3errors from stdfile *)\r
pass3errors =\r
(\r
noerror,\r
undeclared, (* identifier not declared *)\r
inconsistent_use, (* identifier used before declaration *)\r
double_declaration, (* identifier already declared at this level *)\r
label_not_declared, (* label-identifier not declared at all *)\r
not_label_name, (* other identifier used as label-name *)\r
multiple_defined_label, (* label defined several times at this level *)\r
label_not_locally_declared, (* label-identifier declared at surrounding level *)\r
erroneous_label, (* use of a multiple defined label *)\r
label_used_from_inner, (* a label-ident has been used in inner routine *)\r
label_used_outside_scope, (* goto leading into control-structure *)\r
label_defined_outside_lock_or_channel, (* goto out of lock- or channel statements *)\r
label_undefined, (* label is not defined *)\r
not_typename, (* identifier is not a type-identifier *)\r
assign_missing, (* := assumed between type and (: *)\r
type_name_missing, (* type of structured constant not specified *)\r
recursive_use_of_type, (* error in record or array etc. *)\r
recursive_constant_use,(* constant is used in its own definition-expression *)\r
illegal_pool_type, (* pool ... of <illegal type>, shielded components not allowed *)\r
pool_cardinality_must_be_integer, (* illegal size'ing of pool type *)\r
subrange_elems_must_be_enumeration, (* illegal limit-types in subrange def *)\r
redefinition_of_context_name, (* redefinition of object *)\r
type_may_only_be_used_at_process_level, (* semaphore, external process and pool may only be declared at process level *)\r
process_only_allowed_at_processlevel, (* processes inside functions/procedures forbidden *)\r
illegal_formal_type, (* formal type may not be used in this context *)\r
illegal_function_type, (* functiontype may not contain shielded components *)\r
illegal_scope_of_type_component, (* only variables of surrounding scope allowed *)\r
paramlist_changed_since_forwarddecl, (* 'new' paramlist may be empty or exact the same *)\r
forward_not_solved, (* forward-declared type/routine not followed by the real body *)\r
funcval_not_used, (* function-value has not been defined at all *)\r
type_has_pointers, (* locktype contains pointer-types *)\r
type_has_systemtypes, (* lock-/with-type contains shielded component(s) *)\r
opands_incompatible, (* operands not of same typename *)\r
for_incompatible, (* for-variable/startvalue/endvalue not of compatible types *)\r
case_incompatible, (* case-expression/caselabels not of compatible types *)\r
if_type, (* if-expression must be boolean type *)\r
repeat_type, (* until-expression must be boolean type *)\r
while_type, (* while-expression must be boolean type *)\r
short_form_of_multiple_locks_not_allowed, (* short form of multiple locks not allowed *)\r
lock_name_missing, (* buffer name missing in lock statement *)\r
buffer_type_missing, (* buffer type specification is missing *)\r
lock_type, (* lock-variable must be reference type *)\r
channel_type, (* channel-variable must be reference type *)\r
not_index_type, (* type of operand must be enumeration-type *)\r
not_varname, (* varsizecall: identifier is not name of a variable *)\r
not_variable, (* operand cannot be used as variable *)\r
field_must_follow_recordtype, (* <variable> in front of <.> is not a record *)\r
name_not_fieldname, (* <name> after <.> is not a fieldname of <variable> *)\r
must_be_pointertype_before_uparrow, (* <variable> in front of <uparrow> is not a pointer *)\r
mixed_types_in_setlist, (* elements in set-value may not be of mixed types *)\r
relation_error, (* illegal mixture of types in relation *)\r
arithmetic_error, (* illegal mixture of types in term or factor *)\r
monadic_error, (* illegal type for monadic operator *)\r
real_not_implemented, (* real occuring in expression *)\r
real_division_not_implemented, (* real-division of integers not impl *)\r
illegal_in_expr, (* illegal operand kind in expression *)\r
too_few_parameters, (* too few actual parameters to routinecall (or strucrecord *)\r
too_many_actual_params, (* error in routinecall *)\r
too_many_values_in_record_structure, (* error in structured-record constant *)\r
type_must_be_record_or_array, (* typename in front of structured constant must be record or array *)\r
double_param_only_in_struc_const, (* the '***' operator must only occur in structured-array constant *)\r
subscript_after_nonarray, (* name in front of arglist is not of array-type *)\r
incompatible_index, (* index-expression doesn't match array-declaration *)\r
assign_incompatible, (* incompatible types in assignment *)\r
exchange_incompatible, (* incompatible types in exchange *)\r
not_procedure_call, (* the statement is not a procedure-call *)\r
variable_may_not_be_packed, (* for-variable, with-variable or actual var-param is packed *)\r
not_assignable, (* operand may not be assigned to, type is shielded or frozen *)\r
not_exchangeable, (* operand may not be exchanged, type is semaphore, external process, pool or frozen *)\r
exchange_type, (* type must be: reference or shadow *)\r
illegal_var_param_substitution, (* formal and actual type must match exactly *)\r
illegal_value_param_substitution, (* actual and formal types are not compatible *)\r
actual_may_not_be_frozen, (* formal is not frozen, therefore actual may not be frozen *)\r
skipparam_only_in_struc_const, (* the '?' may only occur in structured constants *)\r
struc_arr_incompatible, (* incomp. types in structured array-constant *)\r
struc_rec_incompatible, (* incomp. types in structured record-constant *)\r
var_init_incompatible, (* incomp. types in var-initialization *)\r
repetition_type, (* repetition must be integer *)\r
const_export_only, (* value-export demands constant *)\r
var_export_only, (* offset-export demands variable *)\r
const_or_var_export_only,(* size-,disp-,addr-export demands constant or variable *)\r
disp_export_must_have_field, (* disp-export demands 'fielding' *)\r
not_implemented_on_z80, (* xor, integer-and, and integer-or not implemented on z80 *)\r
forward_process_not_allowed, (* a process may not be FORWARD declared *)\r
forward_must_be_pointer, (* FORWARD specified type must be pointer *)\r
lastpass3error);\r
\r
(* define parameters to procedure 'stop' *)\r
stopcodes = (\r
dummy_stop_code, (* not used *)\r
too_many_nested_calls);\r
\r
levelkinds = (\r
processlevel,\r
firstwith, nextwith,\r
firstlock, nextlock,\r
irrell_level);\r
\r
(* define pass3 programming error-codes *)\r
comp_errorcodes =\r
(unknown_namekind,\r
unknown_argkind,\r
unknown_opcode,\r
unknown_paramkind,\r
unknown_routinekind,\r
unknown_spix,\r
unknown_stdtype_name,\r
unknown_typekind,\r
unknown_rectype,\r
inconsist_alloc,\r
wrong_version,\r
unstack_nontype,\r
too_many_types);\r
\r
\r
(* operator modes *)\r
opmodes = (unary, binary);\r
\r
(* components of a type *)\r
components = (t_simple, t_semaphore, t_pool, t_reference, t_shadow,\r
t_extprocess, t_pointer, t_readonly);\r
\r
content_set = set of components;\r
\r
label_states = (outside_scope, inside_scope, hidden_by_lock_or_channel);\r
\r
\f
\r
namenode = packed record\r
nextname: nameptr ; (* used to chain names of same level *)\r
namekind: codes ; (* kind of identifier: var, const, function etc *)\r
spix : spixrange ; (* spelling index of identifier *)\r
typename: nameptr ; (* points to the namenode of the type (unless namekind = 'ctype' *)\r
typ : typeptr ; (* only relevant if namekind = 'ctype' *)\r
params : nameptr ; (* routine etc: first formal parameter name *)\r
forward_decl: boolean ; (* true, when after 'forward' *)\r
external_decl: boolean ; (* true, when after 'external' *)\r
func_assigned: boolean; (* true, when funcval is used *)\r
usedlevel: namestackptr ; (* nillevel, if never used, otherwise some namelevel *)\r
nix: integer; (* name index, i.e. identification of the node as pass4 will know *)\r
end;\r
\r
\r
\r
typenode = packed record\r
typekind: codes ; (* kind of type: subrange, array etc *)\r
emitted: boolean ; (* true, when type has been emitted *)\r
packflag: boolean ; (* true, if type is packed *)\r
contents: content_set ; (* describes the components of the type *)\r
element: nameptr ; (* depends on 'typekind':\r
- scalar: first scalarname\r
- record: first field name\r
- array : typename of elements\r
- set : typename of elements\r
- pool : typename of elements\r
- pointer: typename of element\r
- readonly: typename of element\r
- alias : typename of alias type\r
*)\r
index: nameptr ; (* depends on 'typekind':\r
- subrange: typename of limits\r
- array : typename of index\r
- alias : ( corresponding to the alias type )\r
*)\r
subexpr: opandptr ; (* depends on 'typekind':\r
- subrange: pointer to 'both' expressions\r
- pool: pointer to cardinality-expr\r
*)\r
end;\r
\r
\f
\r
labelnode = packed record\r
prevlabel : labelptr ; (* used to chain to other label def's *)\r
labelname : nameptr ; (* points to the label-declaration namenode *)\r
labelscope: labelrange ; (* scope number of label *)\r
hiddenscope: labelrange; (* scopenumber of lock-or-channel which hides this label *)\r
labelstate: label_states; (* used to determine 'visability' *)\r
multflag : boolean ; (* true, if multiple defined *)\r
used_from_inner_routines: boolean; (* true, if used from inner routines *)\r
labelspix : spixrange ; (* spelling index of label *)\r
end;\r
\r
\r
\r
opandnode = packed record\r
op_packflag: boolean ; (* true, if the opand is packed *)\r
opcode : codes ; (* kind of operand/operator *)\r
op_lineno : integer ; (* line number *)\r
left : opandptr ; (* left subtree *)\r
rigth : opandptr ; (* rigth subtree *)\r
next : opandptr ; (* opand to the left of reduced tree *)\r
op_name : nameptr ; (* name of operand, if 'id' *)\r
op_value : stringptr ; (* relevant, if 'literal' *)\r
op_typename: nameptr ; (* typename of reduced tree *)\r
end;\r
\r
\r
\r
\r
namestacknode = record\r
former_level, (* pushdown stack of level heads is implemented as a double *)\r
next_level: namestackptr; (* chained list of namestacknodes *)\r
level_number: integer;\r
firstname : nameptr ; (* points to first name of a level *)\r
lastname : nameptr ; (* points to last name of a level *)\r
namelistkind: levelkinds; (* defines kind of list *)\r
withname : nameptr ; (* holds the name of the pseudo var *)\r
end;\r
\r
pushname_node= record\r
push_chain, \r
pop_chain: pushname_ptr;\r
pushed_name: nameptr;\r
end;\r
\r
\r
stringnode = packed record\r
nextstr : stringptr ; (* pointer to next string portion *)\r
stringlgt: integer ; (* length of remaining part *)\r
str: packed array [ str_index ] of char; (* contains the portion *)\r
end;\r
\r
\r
\r
callnode = packed record\r
(* the record holds stacked values of global variables *)\r
callkind : codes; (* holds: 'actkind' *)\r
callformal : nameptr; (* holds: 'curformal' *)\r
callowner : nameptr; (* holds: 'arglist_owner' *)\r
call_afterfunc: boolean; (* holds: 'after_funccall' *)\r
call_functemp : nameptr; (* holds: 'functempvar' *)\r
call_countprocess: integer; (* holds: 'count_processparam' *)\r
end;\r
\r
var\r
incode_filptr : ^ filrec;\r
incode_fileix : integer;\r
insymb_filptr : ^ filrec;\r
insymb_fileix : integer;\r
outcode_filptr: ^ filrec;\r
outcode_fileix: integer;\r
\r
cur_lineno: integer; (* current line number from pass1file *)\r
lineno : integer; (* last read lineno from pass1 *)\r
cur_opandno: integer; (* number of operands on current line *)\r
emit_lineno:integer; (* current emitted lineno in pass3file *)\r
cur_printname, (* position in the file of names, *)\r
(* used in conjunction with error reports *)\r
errorspix, (* if <>-1 then spix of name *)\r
(* involved in error report *)\r
maxlabels, (* label complexity counter *)\r
maxstrings, (* string node complexity counter *)\r
maxopands, (* expression complexity counter *)\r
maxtypes, (* type node complexity counter *)\r
maxnamestacklevels, (* name level complexity counter *)\r
maxpushnames, (* pushname stack depth *)\r
maxnix: integer; (* highest nix is told pass4 for *)\r
(* dimensioning of namestructure *)\r
nilname, (* dummy stop mark *)\r
curname: nameptr; (* current name node *)\r
cur_routine:nameptr; (* current routine *)\r
cur_typename: nameptr; (* namenode of current type *)\r
niltype, (* dummy index in 'types' *)\r
cur_typenode: typeptr; (* corresponding typenode *)\r
cur_blockno: integer; (* lexicographical level *)\r
cur_context_no : integer; (* -1 in process, otherwise the context number,*)\r
(* used in error reporting *)\r
cur_labelscope: labelrange; (* updated by: begin/end label scope *)\r
withvar_spix: integer; (* spix of withvar *)\r
with_namekind, (* updated by find with namekind ( on withvar ) *)\r
cur_namekind: codes; (* updated by 'declaration' and 'newtype' *)\r
rectype: codes; (* record type of current input-record *)\r
levelkind: levelkinds; (* kind of (future) namelevel *)\r
cur_dyn_var_level, (* highest level allowed for use of variables *)\r
lowestlevel, (* outermost level at all *)\r
lastgloballevel: namestackptr; (* identifies last environment level *)\r
processparamlevel: namestackptr; (* used when searching identifiers *)\r
curpushname: pushname_ptr; (* current top element of pushname stack *)\r
callindex : callrange; (* index in calls *)\r
\r
(* the following variables are results from 'searchspix' etc *)\r
retrieved_level: namestackptr; (* undef, if name was'nt found *)\r
retrieved_name : nameptr; (* nilname, if name was'nt found *)\r
\r
(* variables used when processing actual parameter lists *)\r
curformal : nameptr; (* points into formal parameter list *)\r
argkind : codes; (* separates into: argument, index, struc etc *)\r
arglist_owner: nameptr; (* points to the routinename or arraytypename or typename *)\r
functempvar : nameptr; (* points to temporary namenode *)\r
count_processparam: integer; (* number of process-'calls' in arglist *)\r
preserve_option, (* determines if temporary pass1files are preserved or not *)\r
survey_info, (* determines printing of statistics about dynamic structures *)\r
\r
testinput: boolean; (* determines printing of input-records *)\r
testoutput: boolean; (* determines printing of output-records *)\r
testing: boolean; (* = (testinput or testoutput) *)\r
\r
freenames: nameptr; (* list of free name node *)\r
freetypename: nameptr; (* list of free type nodes, linked via namenodes *)\r
nilstring, (* dummy index in 'strings' *)\r
freestrings: stringptr; (* list of free string nodes *)\r
nillabel, (* dummy index in 'labels' *)\r
freelabels: labelptr; (* list of free label nodes *)\r
freeopands: opandptr; (* list of free opand nodes *)\r
\r
listfirst: nameptr; (* first name in current declaration list *)\r
listlast: nameptr; (* last name in current declaration list *)\r
listtop: nameptr; (* used when scanning the current decl list *)\r
lastlabel: labelptr; (* last name in list of defined labels *)\r
\r
endpass1: boolean; (* false, until 'eom'-record has been read *)\r
call_pass4: boolean; (* true, until first error in pass3 *)\r
target_machine : targetz80 .. target35022;\r
after_funccall: boolean; (* flag to determine 'endfunccall' *)\r
insert_in_front: boolean; (* true: names are inserted in front else in rear *)\r
before_assign: boolean; (* true: identifier cannot be function or process *)\r
afterdecl: boolean; (* flag to determine <end-decl> in a routine *)\r
expecting_block: boolean; (* flag to determine <first decl> in a routine *)\r
var_initialization: boolean; (* true, if initialization in var-decl *)\r
expr_release: boolean; (* true, if expression must be released after emit *)\r
const_decl: boolean; (* true, when emitting expr in const declaration *)\r
retain_top: boolean; (* true, if stacktop must be reused *)\r
start_of_protected: boolean; (* true when starting channel or lock statements *)\r
expr_level: integer; (* controls beginning of whole expression *)\r
\r
dummy_typenode: typeptr; (* std type entry *)\r
error_typename: nameptr; (* std name entry *)\r
error_typenode: typeptr; (* std type entry *)\r
\r
envir_spix: spixrange; (* working location ? *)\r
newspix : spixrange; (* holds spix of fieldname *)\r
\r
maxstdspix: integer; (* holds max spix with special interrest *)\r
anonymous_spix: spixrange; (* initialized during startup *)\r
exception_spix: spixrange; (* initialized durring startup *)\r
\r
boolean_typename: nameptr;\r
integer_typename: nameptr;\r
char_typename : nameptr;\r
shadow_typename : nameptr;\r
reference_typename: nameptr;\r
text_typename : nameptr; (* internally used for text-literals *)\r
processrec_typename: nameptr;\r
son_typename : nameptr;\r
nil_typename : nameptr;\r
\r
exception_procname: nameptr;\r
abs_procname : nameptr;\r
succ_procname : nameptr;\r
pred_procname : nameptr;\r
nil_procname : nameptr;\r
nilref_procname : nameptr; (* nil(reference) is handled as a special nil *)\r
ord_procname : nameptr;\r
\r
for_typename: nameptr; (* holds typename of current for-variable *)\r
for_basetypename: nameptr; (* holds simplified typename of for-variable *)\r
case_typename: nameptr; (* holds typename of current case-expression *)\r
with_typename: nameptr; (* work-location: holds typename of with-variable *)\r
\r
indexname: nameptr; (* working location *)\r
elemname: nameptr; (* working location *)\r
\r
paramkind: codes; (* used when checking formal parameters *)\r
not_allowed: content_set; (* holds the illegal parameter contents *)\r
\r
opand_procname: opandptr; (* holds 'literal'-operand, with routine name *)\r
\r
for_expr: opandptr; (* holds the end-value expression of a for-statement *)\r
\r
nilopand, (* stop mark of opands *)\r
stacktop: opandptr; (* points to current top of opands *)\r
nexttop: opandptr; (* points to 'next' of current top-opand *)\r
\r
(* the following variables are used when resolving opand-types *)\r
lefttypename: nameptr;\r
leftbasekind: codes;\r
leftelement: nameptr;\r
rigthtypename: nameptr;\r
rigthbasekind: codes;\r
rigthelement: nameptr;\r
exprtypename: nameptr;\r
exprbasekind: codes;\r
exprelement: nameptr;\r
\r
errorcode: pass3errors; (* working location *)\r
\r
no_of_warnings,\r
no_of_errors: integer;\r
\r
nil_namestack_ptr, (* bottom element of name level stack *)\r
namelevel: namestackptr; (* current name level *)\r
\r
calls: array [ callrange ] of callnode;\r
\r
convtable: array [ codeindex ] of codes;\r
\r
stdspix_table: array [ stdname_range ] of integer;\r
\r
error_bitmap: packed array [ noerror .. lastpass3error ] of boolean;\r
\r
pass1file: file of filrec;\r
pass1labels: file of filrec;\r
pass3file: file of filrec;\r
\r
\f
\r
procedure myexit; forward;\r
(* procedures used for testoutput purposes *)\r
\r
procedure continue_line;\r
begin\r
(* used for alligning testoutput on consequtive lines *)\r
writeln(output);\r
write (output, ' ');\r
end;\r
\r
\f
\r
(* procedures for reading pass1-code file *)\r
\r
function passin : integer;\r
(* delivers the next pass1-code as integer value *)\r
begin\r
incode_fileix := incode_fileix + 1;\r
if incode_fileix > filrec_max then\r
begin\r
read(pass1file, incode_filptr^);\r
incode_fileix := 1;\r
end;\r
passin:= incode_filptr^[incode_fileix];\r
if testinput then\r
write (output, ' ', incode_filptr^[incode_fileix]:1, '*');\r
end;\r
\r
\r
\r
function password : codes;\r
(* delivers the next pass1-code as code value *)\r
begin\r
password:= convtable [ passin ];\r
end;\r
\r
\f
\r
(* procedures for reading the pass1-label file *)\r
\r
function labelin : integer;\r
(* delivers the next pass1-label-value as integer value *)\r
begin\r
insymb_fileix := insymb_fileix + 1;\r
if insymb_fileix > filrec_max then\r
begin\r
read(pass1labels, insymb_filptr^);\r
insymb_fileix := 1;\r
end;\r
labelin:= insymb_filptr^[insymb_fileix];\r
if testinput then\r
write (output, ' ', insymb_filptr^[insymb_fileix]:1, '+');\r
end;\r
\r
\f
\r
(* procedures for writing the pass3file *)\r
\r
procedure emitin(c:integer);\r
begin\r
outcode_fileix := outcode_fileix + 1;\r
if outcode_fileix > filrec_max then\r
begin\r
write(pass3file, outcode_filptr^);\r
outcode_fileix := 1;\r
end;\r
outcode_filptr^[outcode_fileix] := c;\r
if testoutput then\r
write (output, ' ', c:1, '<');\r
end;\r
\r
procedure emit (code: pass3codes);\r
(* outputs the codeword as integer value *)\r
var i: integer;\r
begin\r
i:= ord (code);\r
emitin(i);\r
end;\r
\r
\r
\r
procedure emitid (xcode: pass3codes; xnix: nameptr);\r
begin\r
emit (xcode);\r
emitin (xnix^.nix);\r
end;\r
\r
\r
\r
procedure terminate;\r
var\r
err: pass3errors;\r
finish : boolean;\r
number : integer;\r
ch,ch1 : char;\r
heapfree: longint;\r
begin\r
(* terminate use of files *)\r
\r
emit (xeom);\r
write(pass3file, outcode_filptr^);\r
close (pass3file);\r
assign(pass3file, concat(path2_name, o_pass3_nixname));\r
rewrite(pass3file);\r
outcode_fileix := 0;\r
emitin(maxnix);\r
write(pass3file, outcode_filptr^);\r
close(pass3file);\r
\r
close (pass1file);\r
close (pass1labels);\r
if cur_printname<>-1 then (* input used for printing of names *)\r
close(input);\r
\r
if not preserve_option then\r
begin\r
assign(pass1file, concat(path1_name,o_pass1_codename));\r
erase(pass1file);\r
assign(pass1file, concat(path1_name,o_pass1_symbname));\r
erase(pass1file);\r
assign(pass1file, concat(path1_name,o_pass1_spixname));\r
erase(pass1file);\r
end;\r
\r
if survey_info then\r
begin\r
(* survey information about dynamic structures, i.e. about the complexity of\r
the compiled program *)\r
writeln(output);\r
writeln(output, 'Information survey from REAL-TIME PASCAL, pass3, version ', version);\r
\r
writeln(output, 'Max number of active names: ', maxnix);\r
writeln(output, 'Deepest nesting: ', maxnamestacklevels);\r
writeln(output, 'Deepest stack of names: ', maxpushnames);\r
writeln(output, 'Max number of active types: ', maxtypes);\r
writeln(output, 'Max number of active strings: ', maxstrings);\r
writeln(output, 'Max number of active operands: ', maxopands);\r
heapfree := memavail;\r
release(heaporg);\r
writeln(output, 'Heep space used in bytes: ',\r
memavail - heapfree);\r
writeln(output);\r
end; (* survey information *)\r
\r
\r
(* if any errormessages then print the descriptions *)\r
if (no_of_errors > 0) or (no_of_warnings > 0) then\r
begin\r
(* at least one error, therefore prepare the errorlist *)\r
writeln (output, 'REAL-TIME PASCAL, pass3, version ', version);\r
writeln (output, 'error description');\r
writeln(output);\r
case target_machine of\r
targetz80,target35021: assign(input,concat(rtp35_pathname, i_passx_err1name));\r
target35022: assign(input,concat(rtp35_pathname, i_passx_err2name));\r
end;\r
(*$I-*)\r
reset(input);\r
if ioresult <> 0 then\r
begin\r
if target_machine = target35022 then\r
begin\r
nofile(concat(rtp35_pathname, i_passx_err2name));\r
end else\r
nofile(concat(rtp35_pathname, i_passx_err1name));\r
end;\r
(*$I+*)\r
(* find the start of error-table *)\r
repeat\r
readln(input, number);\r
until number = 3333;\r
repeat\r
readln (input, ch);\r
until ch = '(';\r
\r
for err:= noerror to lastpass3error do\r
begin\r
if error_bitmap [ err ] then\r
begin\r
write (ord (err) : 4, ' = ');\r
while not eoln (input) do\r
begin\r
repeat\r
read(input,ch);\r
until ch = '*';\r
read(input,ch);\r
finish:= false;\r
while not finish do\r
begin\r
read(input,ch1);\r
finish:= (ch = '*') and (ch1 = ')');\r
if not finish then write(output,ch);\r
ch:= ch1;\r
end;\r
end;\r
writeln(output);\r
end;\r
readln (input);\r
end; (* scan when errors *)\r
end; (* if any errors *)\r
\r
end;\r
\r
\f
\r
(* procedures for error-handling etc *)\r
\r
procedure printname(xspix: integer);\r
(* find the name which conrresponds to xspix and print it\r
in conjunction with the error message *)\r
var\r
ch: char;\r
begin\r
if cur_printname=-1 then (* first call or spixtoname missing *)\r
begin\r
assign(input, concat(path1_name, o_pass1_spixname));\r
end;\r
if (cur_printname>=xspix) or (cur_printname=-1) then\r
begin\r
(*$I-*)\r
reset(input);\r
if ioresult <> 0 then\r
begin\r
nofile(concat(path1_name, o_pass1_spixname));\r
end;\r
(*$I+*)\r
read(input, cur_printname);\r
end;\r
while not eof(input) and (cur_printname<xspix) do\r
begin\r
readln(input);\r
read(input, cur_printname);\r
end;\r
if cur_printname=xspix then (* name found *)\r
begin\r
write(output, ': ''');\r
while not eoln(input) do\r
begin\r
read(input, ch);\r
if (ch>='A') and (ch<=']') then\r
ch:= chr(ord(ch)-ord('A')+ord('a'));\r
if ch<>' ' then\r
write(output, ch);\r
end;\r
write(output, '''');\r
end; (* name found *)\r
end; (* printname *)\r
\r
procedure warn (error: pass3errors; err: boolean);\r
(* mark errors and warnings *)\r
begin\r
if (no_of_errors = 0) or testing then writeln(output);\r
write (output, '*** pass ', own_passno:1,\r
' line ', cur_lineno:4, '.', cur_opandno:1);\r
if err then\r
write(output, ', error ', ord (error):2)\r
else\r
write(output, ', warning ', ord (error):2);\r
\r
if cur_context_no <> -1 then\r
write(', in environment: ', cur_context_no : 2);\r
if (errorspix<>-1) and (errorspix<>anonymous_spix) then\r
printname(errorspix);\r
errorspix:= -1; (* reset error spix *)\r
writeln(output);\r
error_bitmap [ error ]:= true;\r
end; (* warn *)\r
\r
procedure warning(error : pass3errors);\r
begin\r
no_of_warnings := no_of_warnings + 1;\r
warn(error, false); (* only a warning *)\r
end;\r
\r
\r
procedure error (err: pass3errors);\r
begin\r
call_pass4:= false; (* avoid calling pass4 automaticly *)\r
emit (xerror);\r
emitin (own_passno);\r
emitin (ord (err));\r
emit (xerrorno);\r
emitin (cur_opandno);\r
warn (err, true);\r
no_of_errors := no_of_errors + 1;\r
end;\r
\r
\r
\r
procedure suppress_error (kind: codes; err: pass3errors);\r
(* the error-message will be suppressed, if already after error *)\r
(* the typename of stacktop will be set to error-type *)\r
begin\r
if kind <> cerrorkind then error (err);\r
errorspix := -1; (* reset error spix *)\r
with stacktop ^ do\r
op_typename:= error_typename;\r
end;\r
\r
\r
\r
procedure break;\r
(* used when a call-trace is wanted *)\r
begin\r
terminate; (* terminate the files etc *)\r
writeln;\r
writeln ('***** intentionally error...');\r
rtphalt(true (* terminate program with trace of active routines and ok.no *));\r
(* the program is terminated *)\r
end;\r
\r
\r
\r
procedure stop (cause: stopcodes);\r
begin\r
writeln (output);\r
writeln ('*** error found in pass3, at sourceline: ', cur_lineno:1);\r
\r
case cause of\r
too_many_nested_calls:\r
writeln ('max_nested_calls exceeded', max_nested_calls);\r
else writeln ('??? stop-cause = ', ord (cause):1);\r
end;\r
\r
call_pass4:= false; (* suppress automatic call of next pass *)\r
\r
myexit;\r
\r
end;\r
\r
\r
\r
procedure comp_error (cause: comp_errorcodes);\r
begin\r
writeln;\r
writeln ('*** program inconsistency in pass3, at sourceline ', cur_lineno:1);\r
write (' cause is: ');\r
case cause of\r
unknown_namekind: write ('unknown-namekind');\r
unknown_argkind: write ('unknown-argkind');\r
unknown_opcode: write ('unknown-opcode');\r
unknown_paramkind: write ('unknown-paramkind');\r
unknown_routinekind: write ('unknown-routinekind');\r
unknown_spix: write ('unknown-spix');\r
unknown_stdtype_name: write ('unknown-stdtype-name');\r
unknown_typekind: write ('unknown-typekind');\r
unknown_rectype: write ('unknown-rectype');\r
inconsist_alloc: write ('inconsistent-alloc');\r
wrong_version: write ('wrong pass1/pass3 combination');\r
unstack_nontype: write ('unstack-nontype');\r
too_many_types: write('inconsistent allocation of type node');\r
else write ('??? = ', ord(cause):1 );\r
end;\r
\r
break; (* terminate program, with call-trace *)\r
\r
end; (* procedure comp_error *)\r
\r
\r
\r
procedure readoption;\r
(* reads: passno, option number, option value *)\r
(* if passno is not current pass then emit the option *)\r
\r
var passno, optno, optvalue: integer;\r
\r
begin\r
\r
passno := passin;\r
optno := passin;\r
optvalue:= passin;\r
\r
if passno <> own_passno then\r
begin\r
if passno = 0 then (* version-identification *)\r
if optno = 1 (* pass 1 *) then\r
if (optvalue div 100 <> versionpass1 div 100) or\r
(optvalue mod 100 < versionpass1 mod 100) then\r
comp_error (wrong_version);\r
emit (xoption);\r
emitin (passno);\r
emitin (optno);\r
emitin (optvalue);\r
end\r
else\r
begin\r
case optno of\r
1: testinput := optvalue = 1;\r
2: testoutput := optvalue = 1;\r
3: call_pass4 := optvalue = 1;\r
4: target_machine:= optvalue;\r
5: survey_info:= optvalue=1;\r
6: preserve_option:= optvalue=1;\r
else;\r
end;\r
end;\r
testing:= testinput or testoutput;\r
\r
end; (* procedure readoption *)\r
\r
\f
\r
«eof»