|
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: 54131 (0xd373)
Types: TextFile
Names: »P4INIT.PAS«
└─⟦b6837b237⟧ Bits:30010500 SW2103 REL 1.11 Sourcer DVBS1.SW2103.rel.1.11-1 MASTER 31-1-192
└─⟦this⟧ »P4INIT.PAS«
const\r
filrec_max = 256;\r
\r
versionpass4= 600;\r
version= 'REAL-TIME PASCAL, pass4, version 90.03.01';\r
versionpass3 = 6; (* pass 3 version must be 6.xx *)\r
versionz80 = false; (* not z80 *)\r
lambdaversion = false; (* not lambda *)\r
(* must be: rc3502.2 *)\r
(* both false : rc3502c version *)\r
\r
(*std variable length, and max values *)\r
\r
word_length=2; byte_length=1;\r
char_length=1;\r
set_const_length = 64; (* words *)\r
(*\r
pointer_length,\r
activation_record_length are variables\r
*)\r
\r
array_template_size = 8;\r
sub_template_size = 6;\r
field_template_size = 2;\r
record_template_size = 2;\r
lockmes_templ_size= 6; (* 3 words for: first, last+1, computed top *)\r
\r
bits_pr_byte=8;\r
bits_pr_word=16;\r
min_fields_pr_word = 3;\r
\r
max_byte_value = 255;\r
module_size = 65536; (* 2**16 *)\r
top_address = 65535; (* module size -1 *)\r
max_int = 32767;\r
min_int = -32768;\r
\r
(* miscellaneous *)\r
\r
shift8 = 256;\r
shift16 = 65536;\r
bit_0_8 = - shift16; (* bit 0 - 8 in rc8000 word *)\r
spsp = 8224; (* string with 2 spaces *)\r
print_limit = 15;\r
\r
max_const_area = 1000; (* size in words of one constant buffer *)\r
pack = true;\r
non_pack = false;\r
this_pass = 4;\r
(* constants in pass 4 code *)\r
\r
(* value of type_v in pass 4 code *)\r
\r
byte_typ = 1; field_typ = 5;\r
word_typ = 2; addr_typ = 6;\r
point_typ= 3; set_typ = 7;\r
double_typ = 4; dyn_typ = 8;\r
\r
(* values of type_o in pass 4 code *)\r
\r
bool_typ = 1; int_typ = 2; real_typ = 3; setof_typ = 4;\r
pointer_typ = 5; sem_typ = 6; ref_typ = 7; shadow_typ = 8;\r
scalar_typ = 9;\r
\r
(* compare function number in pass 4 code *)\r
\r
zeq = 2; zne = 3; zlt = 4; \r
zgt = 5; zle = 6; zge = 7;\r
zeq_set = 8; zne_set = 9; zle_set = 10;\r
zge_set = 11; zin = 12; zeq_struc = 13;\r
zne_struc = 14;\r
\r
(* std function number in pass 4 code *)\r
\r
zord= 1; zsucc= 2; zpred= 3; zchr= 4; znil= 5; znilref (* only used in rev c *)= 6;\r
znew = 7;\r
\r
(* mode for for statement *)\r
\r
zup = 1; zdown = 2;\r
\r
(* export name type *)\r
\r
offset_type = 1; value_type = 2;\r
\r
(* end pass 4 code constants *)\r
\r
\r
\r
\r
\r
(* literal type *)\r
\r
num_const = 1; string_const = 2; char_const = 3;\r
\r
\r
\r
type\r
filrec = array[1..filrec_max] of integer;\r
\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
\r
\r
out_code = \r
(* pass4codes= *)\r
( zfirstcode,\r
\r
zmodule, zeom,\r
zoption, znewline,\r
\r
zprocess, zextprocess,\r
zblock, zlength, zendblock,\r
\r
zbegincode, zcodeline, zendcode,\r
\r
zsubdef,\r
zarray1template, zarray2template, zarray3template,\r
zrecordtemplate, zfieldsize, zdynfieldsize, zincfield,\r
zendtemplate,\r
zenddecl,\r
\r
zallocdynvar,\r
\r
zinitialize, zstrucinit, zsimpleinit, zsetinit,\r
zexception, zextexception,\r
zsysinit, zsysdyninit,\r
zsysnewinit,\r
zfieldinit, zdynfieldinit,\r
zendinitfields,\r
zarrayinit, zarraydyninit,\r
zpoolinit,\r
zvarinit,\r
zexport,\r
\r
zproc, zextproc,\r
zfunc, zextfunc,\r
zparamtype,\r
\r
zdeflix,\r
\r
zproccall, zendpcall,\r
zextproccall, zstdproccall,\r
zprocessparam, zendprocessparam,\r
zstdfunccall, zfcall, zendfunccall,\r
zfunccall, zextfunccall,\r
zendnewcall,\r
\r
zvarpointer, ztempointer, zarglistsize,\r
\r
zvarparam, zvalueparam, zreturnparam,\r
\r
zassignstat, zleft, zassign,\r
\r
zcasestat, zcase, zendcaselist, zendcasestat, zendcase,\r
zcaserange, zcaselabel, zotherwise,\r
\r
zforstat, zleftfor, zforstore, zdo, zendfor,\r
\r
zgoto,\r
\r
zifstat, zifexpr, zelse, zif,\r
\r
zrepeat, zuntil, zendrepeat,\r
\r
zloopstat, zendloopstat, zcontloopstat, zexitloopstat,\r
zexitstat,\r
\r
zwhile, zwhileexpr, zendwhile,\r
\r
zwithstat, zwithvar, zwithdynvar, zendwith, znoretype, zretype, zdynretype,\r
\r
zlockstat, zlockvar, zlockdynvar, zendlock,\r
\r
zlockmesstat, zexitlock,\r
\r
zchannel, zchanvar, zendchannel,\r
\r
zexchstat, zexchange,\r
\r
znot, zneg, zcompare, zcompstruc, zcompdynstruc, zdiv,\r
zmul, zshift, zrotate, zmod, zor_, zxor,\r
zadd, zsub, zand, zrangetest,\r
zdynrangetest,\r
\r
zconst, zlconst, zsetconst,\r
zset, zinclude, zsetexpr, zincludeint, zendset,\r
\r
zinitconst,\r
\r
zindvar,\r
\r
zaddr, zcaddr, zindaddr, \r
zpackedarr,\r
\r
zfield, zdynfield,\r
\r
zindexexpr, zcindex, zindex,\r
\r
zerror, zerrorno, zerrortext,\r
zrangemax, zhindex,\r
zlastcode\r
\r
);\r
\r
pass4codeindex = 0..160; (* number of pass4codes *)\r
\r
\f
\r
\r
(* end pass 4 codes *)\r
\r
\r
\r
\r
\r
\r
context_kind = ( not_used,\r
int_type, char_type, bool_type, sem_type,\r
shadow_type, ref_type, scalar_type, set_type,\r
pool_type, array_type, sys_array_type, pointer_type,\r
record_type, sys_record_type,label_type, routine_type,\r
process_type, dyn_subrange, undef_type,\r
field, dyn_field, variable, dyn_variable,\r
var_param, value_param, return_param,\r
sconst, lconst, set_const,\r
with_var, lock_var, func_result,\r
expr, struc_c ,\r
allign_rec_type, allign_arr_type);\r
\r
error_types = (overflow, range_def_error, set_def_error,\r
pool_def_error, type_error,\r
addr_error, var_error, range_error,\r
literal_error, set_error, const_error,\r
for_error, input_error, scalar_error,\r
name_overflow, const_area_overflow,\r
bit_count_error, prelude_error, address_overflow,\r
with_size_error, record_size_error, array_size_error,\r
field_export_error, exportvalue_error, exportaddr_error,\r
stack_error, version_error, not_implemented,\r
not_impl_loop, not_impl_lockmes, not_impl_cont_exit_loop,\r
not_impl_exit, empty_element_change,\r
error_dyn, error_dyn_init, error_dyn_var, error_channel);\r
\r
location_index = integer;\r
\r
addr_state = (direct, indirect, addr, expression, p_comp );\r
\r
block_mode = (process_mode, proc_mode, func_mode, record_mode);\r
export_kind_type = (exportvalue, exportsize, exportdispl,\r
exportoffset, exportaddr );\r
\r
\r
name_rec = record\r
context: context_kind;\r
size: integer;\r
min: integer;\r
max: integer;\r
niv: integer;\r
offset: integer;\r
lix: location_index;\r
next_comp: integer;\r
comp_type: integer;\r
packed_comp:boolean;\r
dynamic : boolean;\r
end;\r
\r
operand_ptr= ^ operand_rec;\r
operand_rec = record\r
next_operand,\r
former_operand: operand_ptr;\r
type_nix: integer;\r
var_nix: integer;\r
kind: context_kind;\r
niv: integer;\r
offset: integer;\r
size: integer;\r
context: context_kind;\r
lix: integer;\r
first: integer;\r
comp_size:integer;\r
field_packed : boolean;\r
array_packed : boolean;\r
dynamic: boolean;\r
state: addr_state;\r
temp_size: integer;\r
func_value: boolean;\r
end;\r
\r
init_modes = (record_init, array_init, packed_array, error_init );\r
\r
struc_ptr= ^ struc_level;\r
struc_level = record\r
next_struc,\r
former_struc: struc_ptr;\r
times: integer;\r
current_index: integer;\r
top_index: integer;\r
first: integer;\r
displ: integer;\r
bits_pr_field: integer;\r
elem_pr_word: integer;\r
dope_lix: integer;\r
saved_nix: integer;\r
saved_lix: integer;\r
saved_size: integer;\r
saved_stat_part: boolean;\r
init_mode: init_modes;\r
end;\r
\r
display_ptr= ^ display_rec;\r
display_rec = record\r
former_level,\r
next_level: display_ptr;\r
saved_mode: block_mode;\r
saved_offset: integer;\r
saved_niv: integer;\r
saved_part: boolean;\r
saved_pack: boolean;\r
saved_bit: integer;\r
saved_chain: integer;\r
saved_v_length: integer;\r
saved_idcount: integer;\r
saved_lix: integer;\r
saved_allign: boolean;\r
saved_init: boolean;\r
saved_dyn: boolean;\r
saved_c_index: integer;\r
saved_name_key : integer;\r
saved_prefix : boolean;\r
parameter_length: integer;\r
end;\r
\r
const_area_ptr= ^ const_area;\r
const_area= record\r
next_const: const_area_ptr;\r
first_index: integer;\r
const_buffer: array [ 0..max_const_area ] of integer;\r
end;\r
\r
stack_ptr= ^stack_elem;\r
stack_elem=record\r
former_elem: stack_ptr;\r
stacked_val: integer;\r
end;\r
\r
universal_ptr= ^ integer; (* used for allocation of dynamic heap portions *)\r
\r
var\r
source_line: integer;\r
incode_filptr : ^filrec;\r
incode_fileix : integer;\r
outcode_filptr: ^filrec;\r
outcode_fileix: integer;\r
pass3file, pass4file: file of filrec;\r
i,\r
max_name_key, (* output in the entry tail of pass4code *)\r
max_name_index: integer; (* read from the entry tail of pass3code *)\r
code_file_name: alfa;\r
program_ok, test: boolean;\r
\r
const\r
max_names = 65521 div sizeof(name_rec);\r
max_memories = 4;\r
\r
type\r
nametab_type= array [0..max_names-1] of name_rec;\r
name_rec_ptr = ^name_rec;\r
var\r
needed_namesize : longint;\r
nametab_ptr: array[0..max_memories-1] of ^ nametab_type;\r
\r
\r
function nametable(ix: integer): name_rec_ptr;\r
var tab_ix : integer;\r
begin\r
tab_ix := ix div max_names;\r
nametable := @ nametab_ptr[tab_ix]^[ix - max_names*tab_ix];\r
end;\r
\r
procedure alloc_nametab_and_call_pass4;\r
procedure pass4;\r
\r
var\r
\r
convert_in_code: array [pass3codeindex] of pass3codes;\r
\r
\r
nix: integer;\r
\r
\r
first_of_expr,\r
os, ot, empty_stack: operand_ptr;\r
\r
struc_bottom,\r
ss: struc_ptr;\r
\r
stack_top, (* top element of stacked elements *)\r
free_stack: stack_ptr; (* stack of poped elements, i.e. poped elements are\r
accessible in reverse order through the former-chain of free_stack *)\r
\r
(* the const area is a chain of constant buffers elements are retrieved and\r
updated by routines 'retrieve_c' and 'update_c' *)\r
start_const_area, (* first constant buffer *)\r
current_const_area: const_area_ptr; (* last accessed const buffer *)\r
first_c_index, top_c_index: integer; (* const area indices *)\r
\r
bottom_level, (* bottom of display stack *)\r
this_level: display_ptr; (* current level *)\r
\r
direct_return, array_types, index_types, indirects, init_types,\r
allign_types,adjust_types,var_types, simple_types: set of context_kind;\r
\r
new_call, (* true between proccall(new) and endproc, flag extra parameter and special endcall action *)\r
done, allign_fields,init_fields, dyn_fields, pack_record, prelude,\r
index_check, prefixed_name, temp_withvar_not_used, line_number,\r
lock_mes_stat,\r
preserve_option,\r
prefixed, stat_part, variable_init, export, test_survey, param_list : boolean;\r
\r
mode: block_mode;\r
\r
ext_name,\r
prefix_name: alfa;\r
\r
export_kind: export_kind_type;\r
type_pointer, (* target machine dependent constant !!! *)\r
pointer_length, (* target machine dependent constant !!! *)\r
activation_record_length,\r
field_unite,\r
top_nix,\r
top_stack,\r
top_ops,\r
top_ss,\r
top_lix,\r
process_offset,\r
current_bit,\r
current_lix,\r
current_niv,\r
current_offset,\r
record_offset,\r
process_niv, (*used to note outermost process level or prefix. It takes\r
the following values: -1:environment, 0:outermost process\r
or prefix, >0: inner process*)\r
name_key,\r
field_offset,\r
var_length,\r
idcount,\r
scalar_count,\r
param_number,\r
head_line,\r
process_param_length,\r
printed,\r
i,no,\r
nil_nix, (* name table index of external routine nil, only used by z80 version *)\r
niltype_nix,\r
undef_nix,\r
max_set_const_value,\r
semaphor_length,\r
chain : integer;\r
top_c : integer;\r
\r
\r
\r
procedure error(ty: error_types); forward;\r
\r
procedure load_expr; forward;\r
\r
\r
procedure print(op: out_code);\r
begin\r
if printed>=print_limit then begin\r
writeln; printed:=0;\r
end;\r
write(' *',ord(op):3);\r
printed:=printed+1;\r
end;\r
\r
procedure print_arg(arg: integer);\r
begin\r
if printed>=print_limit then begin\r
writeln; printed:=0;\r
end;\r
write(arg:7);\r
printed:=printed+1;\r
end;\r
\r
procedure passin(var number: integer);\r
begin\r
incode_fileix := incode_fileix + 1;\r
if incode_fileix > filrec_max then\r
begin\r
read(pass3file, incode_filptr^);\r
incode_fileix := 1;\r
end;\r
number := incode_filptr^[incode_fileix];\r
end;\r
\r
procedure outcode(c:integer);\r
begin\r
outcode_fileix := outcode_fileix + 1;\r
if outcode_fileix > filrec_max then\r
begin\r
write(pass4file, outcode_filptr^);\r
outcode_fileix := 1;\r
end;\r
outcode_filptr^[outcode_fileix] := c;\r
end;\r
\r
procedure test_linenumber;\r
var newl: integer;\r
begin\r
if line_number then begin\r
newl := ord(znewline);\r
outcode(newl);\r
outcode(source_line);\r
line_number:=false;\r
end;\r
end;\r
\r
procedure put0(op: out_code);\r
var arg: integer;\r
begin\r
test_linenumber;\r
arg := ord(op);\r
outcode(arg);\r
if test then print(op);\r
end;\r
\r
procedure put1(op: out_code; arg1: integer);\r
var arg: integer;\r
begin\r
test_linenumber;\r
arg := ord(op);\r
outcode(arg);\r
outcode(arg1);\r
if test then begin\r
print(op); print_arg(arg1);\r
end;\r
end;\r
\r
procedure put2(op: out_code; arg1,arg2: integer);\r
var arg: integer;\r
begin\r
test_linenumber;\r
arg := ord(op);\r
outcode(arg);\r
outcode(arg1);\r
outcode(arg2);\r
if test then begin\r
print(op); print_arg(arg1); print_arg(arg2);\r
end;\r
end;\r
\r
procedure put3(op: out_code; arg1,arg2,arg3: integer);\r
var arg: integer;\r
begin\r
test_linenumber;\r
arg := ord(op);\r
outcode(arg);\r
outcode(arg1);\r
outcode(arg2);\r
outcode(arg3);\r
if test then begin\r
print(op); print_arg(arg1); print_arg(arg2);\r
print_arg(arg3);\r
end;\r
end;\r
\r
procedure put4(op: out_code; arg1,arg2,arg3,arg4: integer);\r
var arg: integer;\r
begin\r
test_linenumber;\r
arg := ord(op);\r
outcode(arg);\r
outcode(arg1);\r
outcode(arg2);\r
outcode(arg3);\r
outcode(arg4);\r
if test then begin\r
print(op); print_arg(arg1); print_arg(arg2);\r
print_arg(arg3); print_arg(arg4);\r
end;\r
end;\r
\r
procedure put_arg1(arg1: integer);\r
begin\r
outcode(arg1);\r
if test then print_arg(arg1);\r
end;\r
\r
procedure put_arg2(arg1,arg2: integer);\r
begin\r
outcode(arg1);\r
outcode(arg2);\r
if test then begin\r
print_arg(arg1); print_arg(arg2);\r
end;\r
end;\r
\r
procedure put_arg3(arg1,arg2,arg3: integer);\r
begin\r
outcode(arg1);\r
outcode(arg2);\r
outcode(arg3);\r
if test then begin\r
print_arg(arg1); print_arg(arg2); print_arg(arg3);\r
end;\r
end;\r
\r
procedure copy(op: out_code; no: integer);\r
var arg, i: integer;\r
begin\r
put0(op);\r
for i:=1 to no do begin\r
passin(arg); put_arg1(arg);\r
end;\r
end;\r
\r
procedure new_line;\r
begin\r
passin(source_line);\r
line_number:=true;\r
end;\r
\r
procedure out_name(name: alfa);\r
var i: integer;\r
begin\r
for i:=1 to alfalength do put_arg1( ord(name[i] ) );\r
end;\r
\r
\r
procedure find_const_ptr(index: integer);\r
var\r
cur_ptr: const_area_ptr;\r
begin\r
(* find const buffer containing 'index' and let 'current_const_area' be that\r
buffer *)\r
cur_ptr:= current_const_area;\r
if (index<cur_ptr^.first_index) or\r
(index>=cur_ptr^.first_index+max_const_area) then\r
(* outside current const area *)\r
begin\r
if index<cur_ptr^.first_index then\r
cur_ptr:= start_const_area; (* traverse from start of chain *)\r
(* else proceed in the chain from current const area *)\r
while index>=cur_ptr^.first_index+max_const_area do\r
begin\r
if cur_ptr^.next_const=nil then (* end of chain, extend *)\r
begin\r
new(cur_ptr^.next_const);\r
with cur_ptr^.next_const^ do\r
begin\r
next_const:= nil;\r
first_index:= cur_ptr^.first_index+max_const_area;\r
end; (* with *)\r
end; (* allocate new element *)\r
cur_ptr:= cur_ptr^.next_const;\r
end; (* while index> .... *)\r
current_const_area:= cur_ptr;\r
end; (* find actual requested const buffer *)\r
end; (* procedure find_const_ptr *)\r
\r
\r
function retrieve_const(index: integer): integer;\r
begin\r
find_const_ptr(index);\r
with current_const_area ^ do\r
retrieve_const:= const_buffer[index-first_index];\r
end;\r
\r
procedure update_const(index: integer; const_value: integer);\r
begin\r
find_const_ptr(index);\r
with current_const_area ^ do\r
const_buffer[index-first_index]:= const_value;\r
end;\r
\r
procedure write_const_area(first: integer);\r
var i: integer;\r
val, och : integer;\r
ch1,ch2: char;\r
begin\r
if first < top_c_index then\r
begin\r
writeln; write('const area ', first, ' ', top_c_index);\r
for i:=first to top_c_index-1 do begin\r
if (i-first) mod 6 = 0 then begin\r
writeln;\r
write(i:5,'. ');\r
end;\r
val := retrieve_const(i);\r
och := val shr 8;\r
ch1 := ' ';\r
if (och >= 32) and (och < 128) then ch1 := chr(och);\r
och := val and 255;\r
ch2 := ' ';\r
if (och >= 32) and (och < 128) then ch2 := chr(och);\r
write(val:8,'(',ch1,ch2,')');\r
end;\r
writeln;\r
end;\r
end;\r
\r
procedure out_constant_area;\r
var first,il : integer;\r
p, i: integer;\r
begin\r
if top_c_index > top_c then top_c:=top_c_index;\r
first:=first_c_index;\r
while first<top_c_index do begin\r
if retrieve_const(first+1)>0 then begin\r
put1(zdeflix,retrieve_const(first+1));\r
p:=retrieve_const(first);\r
if retrieve_const(first+2)>p then p:=retrieve_const(first+2);\r
put1(zinitconst,p-3);\r
for il:=first+3 to first + retrieve_const(first) -1 do\r
put_arg1(retrieve_const(il));\r
if retrieve_const(first+2) > retrieve_const(first) then\r
for i:=1 to retrieve_const(first+2) - retrieve_const(first) do put_arg1(spsp);\r
update_const(first+1, -retrieve_const(first+1));\r
end;\r
first:=first+retrieve_const(first);\r
end;\r
end;\r
\r
\r
procedure pop_to_free_stack(count: integer); forward;\r
\r
\r
procedure out_formal_list;\r
var type_p,no,param_size: integer;\r
help_ptr: stack_ptr;\r
begin\r
(* reverse the stacked parameter list on free_stack *)\r
pop_to_free_stack(param_number);\r
help_ptr:= free_stack;\r
for no:=param_number downto 1 do\r
with nametable(help_ptr^.stacked_val)^ do begin\r
with nametable(comp_type)^ do begin\r
param_size:=size;\r
case context of\r
pointer_type: type_p:=1;\r
sem_type: type_p:=2;\r
ref_type: type_p:=3;\r
shadow_type: type_p:=4;\r
pool_type: type_p:=5;\r
allign_rec_type,sys_record_type: type_p:=6;\r
allign_arr_type,sys_array_type: type_p:=7;\r
else type_p:=8;\r
end;\r
end;\r
if context=value_param then\r
type_p := type_p * 4 + 2\r
else\r
begin\r
if nametable(comp_type)^.dynamic then error(error_dyn);\r
type_p := type_p * 4 + 1;\r
if context = return_param then\r
type_p := type_p + 2;\r
end;\r
put2(zparamtype,type_p,param_size);\r
help_ptr:= help_ptr^.former_elem;\r
end;\r
end;\r
\r
procedure printhead;\r
begin\r
if test then writeln;\r
write('*** pass 4 line ',source_line:4,', ');\r
end;\r
\r
procedure eom; forward;\r
\r
procedure compiler_error(e: error_types);\r
begin\r
printhead;\r
write('compiler error : ');\r
case e of\r
addr_error: writeln('addressing');\r
bit_count_error: writeln('bit count');\r
for_error: writeln('for error');\r
scalar_error: writeln('scalar error');\r
input_error: writeln('wrong input');\r
else writeln(', error code = ',ord(e):1);\r
end;\r
eom; rtphalt(true (* terminate program with trace and ok.no *));;\r
end;\r
\r
procedure pass4error(e: error_types);\r
begin\r
printhead;\r
case e of\r
overflow: writeln('overflow');\r
error_dyn: writeln('dynamic type not allowed');\r
error_dyn_init: writeln('initialize dynamic type not allowed');\r
error_dyn_var: writeln('dynamic variable not allowed');\r
empty_element_change: writeln('access to zero sized object');\r
not_implemented: writeln('dynamic types not implemented');\r
not_impl_loop: writeln('loop statement not implemented');\r
not_impl_lockmes: writeln('lockmes statement not implemented');\r
not_impl_cont_exit_loop:writeln('continueloop/exitloop not implemented');\r
not_impl_exit: writeln('exit statement not implemented');\r
error_channel: writeln('channel statement not implemented in z80');\r
range_def_error: writeln('subrange def.');\r
set_def_error: writeln('set def.');\r
pool_def_error: writeln('pool def.');\r
type_error: writeln('constant value');\r
var_error: writeln('not constant');\r
range_error: writeln('case label range');\r
prelude_error: writeln('no init. or process in enviroment');\r
literal_error: writeln('constant');\r
set_error: writeln('set constant');\r
const_error: writeln('times');\r
address_overflow: writeln('stack');\r
with_size_error: writeln('WITH-AS: size of new type exceeds that of old');\r
record_size_error: writeln('record size');\r
array_size_error: writeln('array size');\r
exportvalue_error: writeln('export value error');\r
field_export_error: writeln('packed field export');\r
exportaddr_error: writeln('export offset error');\r
else compiler_error(e);\r
end;\r
end;\r
\r
procedure eom;\r
begin\r
put0(zeom);\r
write(pass4file, outcode_filptr^);\r
close(pass4file);\r
close(pass3file);\r
if not preserve_option then\r
begin\r
erase(pass3file);\r
assign(pass3file, concat(path2_name, o_pass3_nixname));\r
erase(pass3file);\r
end;\r
\r
done:= true;\r
\r
(* tell max name key to pass5 as part of the entry tail of pass4code *)\r
if name_key>max_name_key then\r
max_name_key:= name_key;\r
assign(pass4file, concat(path1_name, o_pass4_nixname));\r
rewrite(pass4file);\r
outcode_fileix := 0;\r
outcode(max_name_key);\r
write(pass4file, outcode_filptr^);\r
close(pass4file);\r
\r
end;\r
\r
procedure error(ty: error_types);\r
begin\r
put2(zerror,this_pass,ord(ty));\r
program_ok:=false;\r
pass4error(ty);\r
end;\r
\r
procedure abort(ty: error_types);\r
begin\r
printhead;\r
write('compilation terminated by ');\r
case ty of\r
name_overflow: writeln('name table overflow');\r
stack_error: writeln('stack error');\r
version_error: writeln('wrong pass 4');\r
else compiler_error(ty);\r
end;\r
eom; rtphalt(true (* terminate program with trace and ok.no *));;\r
end;\r
\r
procedure write_nametable(top: integer);\r
var ch1,ch2: char;\r
var i: integer;\r
begin\r
if top>max_name_index then\r
top:= max_name_index;\r
writeln;\r
writeln(' nix c s min max niv',\r
' offset lix n-c c-t pack dyn');\r
for i:= top to max_name_index do\r
with nametable(i)^ do\r
if context<>not_used then begin\r
writeln('name',i:6,ord(context):4,size:5,\r
min,max,niv,offset,lix,next_comp:7,comp_type:7,\r
packed_comp:8, dynamic:8);\r
end;\r
end;\r
\r
procedure write_operand_stack;\r
var\r
oper: operand_ptr;\r
begin\r
writeln;\r
writeln('expr = ',seg(first_of_expr), ofs(first_of_expr));\r
writeln('ot = ',seg(ot), ofs(ot));\r
writeln('os = ',seg(os), ofs(os));\r
if ot=empty_stack then writeln('operand stack empty')\r
else begin\r
writeln(' k niv offset size con',\r
' lix first f_sizepack_f pack_a state temp');\r
oper:= ot;\r
while oper<>empty_stack do\r
with oper^ do\r
begin\r
writeln('operand stack ',ord(kind):4,niv,offset,size,\r
ord(context),lix,first:7,comp_size:7,\r
field_packed:7,array_packed:7,ord(state):8,temp_size);\r
oper:= former_operand;\r
end; (* with oper^ *)\r
end;\r
end;\r
\r
procedure write_name_stack;\r
var ch1,ch2: char; p: integer;\r
help_ptr: stack_ptr;\r
begin\r
writeln;\r
if stack_top=nil then writeln('name stack empty') else\r
begin\r
writeln('name stack');\r
help_ptr:= stack_top;\r
while help_ptr<>nil do begin\r
writeln(help_ptr^.stacked_val: 4);\r
help_ptr:= help_ptr^.former_elem;\r
end;\r
end;\r
end;\r
\r
\r
procedure set_option;\r
var p,a,b: integer;\r
begin\r
passin(p); passin(a); passin(b);\r
if p=this_pass then\r
case a of\r
1: write_nametable(b);\r
2: write_operand_stack;\r
3: write_name_stack;\r
4: test:=b=1;\r
5: program_ok:=program_ok and (b=1);\r
6: write_const_area(1);\r
7: preserve_option:= b=1;\r
9: begin (* index check on,off *)\r
index_check:=b=1;\r
put3(zoption,5,a,b);\r
end;\r
10: test_survey:=b=1;\r
end\r
else\r
begin\r
if (p=0) and (a=3) then\r
if b div 100 <> versionpass3 then abort(version_error);\r
put3(zoption,p,a,b);\r
end;\r
end;\r
\r
procedure initialize;\r
var code: pass3codes; p: word; empty_name: name_rec;\r
empty_ops: operand_rec;\r
i: integer;\r
begin\r
for code:=xfirstcode to xlastcode do\r
convert_in_code[ord(code)]:=code;\r
\r
(* all nametable entries empty *)\r
with empty_name do begin\r
context:=not_used;\r
size:=0; min:=0; max:=0;\r
niv:=0; offset:=0;lix:=0;\r
next_comp:=0;\r
comp_type:=0;\r
packed_comp:=false;\r
dynamic:=false;\r
end;\r
for i:=0 to max_name_index do nametable(i)^:=empty_name;\r
\r
(* init operand stack bottom to empty *)\r
new(empty_stack);\r
with empty_stack^ do begin\r
next_operand:= nil; (* last element in stack *)\r
former_operand:= empty_stack;\r
kind:=not_used; niv:=0; offset:=0; size:=0;\r
context:=not_used;lix:=0; first:=0;\r
field_packed:=false;\r
array_packed:=false;\r
comp_size:=0;\r
state:=direct; temp_size:=0;\r
func_value:=false;\r
end;\r
\r
(*$I-*)\r
reset(pass3file);\r
if ioresult <> 0 then\r
begin\r
nofile(concat(path2_name, o_pass3_codename));\r
end;\r
(*$I+*)\r
rewrite(pass4file);\r
source_line:=0;\r
line_number:=false;\r
top_nix:=0; top_stack:=0; top_ops:=0; top_ss:=0;\r
top_c:=0; top_lix:=0;\r
preserve_option:= false; (* preserve.no, i.e. remove pass3code after use *)\r
test_survey:=false;\r
index_check:=true; (* default index.yes *)\r
new_call:= false;\r
\r
stack_top:= nil; (* empty stack *)\r
free_stack:= nil; (* empty free list *)\r
\r
new(struc_bottom);\r
with struc_bottom^ do\r
begin\r
next_struc:= nil;\r
former_struc:= struc_bottom;\r
end;\r
ss:= struc_bottom;\r
\r
os:=empty_stack;\r
ot:=empty_stack;\r
\r
(* allocate start of constant area *)\r
new(start_const_area);\r
with start_const_area^ do\r
begin\r
next_const:= nil; (* end of const buffer chain *)\r
first_index:= 1;\r
end;\r
current_const_area:= start_const_area;\r
top_c_index:=1;\r
first_c_index:=1;\r
\r
done:=false;\r
program_ok:=true;\r
prefixed:=false;\r
prefixed_name:=false;\r
prelude:=true;\r
variable_init:=false;\r
temp_withvar_not_used:=false;\r
stat_part:=false;\r
export:=false;\r
param_list:=true;\r
mode:=process_mode;\r
\r
new(bottom_level); (* bottom element of display stack *)\r
with bottom_level^ do\r
begin\r
next_level:= nil; (* last allocated element of display stack *)\r
former_level:= bottom_level;\r
end;\r
this_level:= bottom_level;\r
\r
printed:=0; idcount:=0; param_number:=0;\r
scalar_count:=0;\r
if (* **z80** *) versionz80 then begin\r
type_pointer:=word_typ;\r
activation_record_length:=12;\r
process_offset:=6;\r
current_offset:=0;\r
pointer_length:=word_length;\r
field_unite:=word_length;\r
end\r
else\r
if lambdaversion then\r
begin (* **lambda** *)\r
type_pointer:=double_typ;\r
activation_record_length:=16;\r
process_offset:=0;\r
current_offset:=-1;\r
pointer_length:=2*word_length;\r
field_unite:=byte_length;\r
end\r
else\r
begin (* **rc3502c** *)\r
type_pointer := point_typ;\r
activation_record_length := 8;\r
process_offset := 0;\r
current_offset := 0;\r
pointer_length := 3 * byte_length;\r
field_unite := byte_length;\r
end;\r
process_param_length:=2*pointer_length + word_length;\r
pack_record:=non_pack;\r
allign_fields:=false;\r
dyn_fields:=false;\r
init_fields:=false;\r
current_bit:=0;\r
current_lix:=1;\r
current_niv:=0;\r
process_niv:=-1; (*environment*)\r
name_key:=1;\r
field_offset:=0;\r
first_of_expr:=ot;\r
max_set_const_value:=set_const_length*bits_pr_word - 1;\r
var_types:=[variable, var_param, value_param ];\r
direct_return:=[int_type, char_type, bool_type, scalar_type,\r
dyn_subrange, pointer_type];\r
array_types:=[array_type,sys_array_type,allign_arr_type];\r
index_types:=[int_type,char_type,bool_type,scalar_type];\r
simple_types:=[ int_type, char_type, bool_type, scalar_type, dyn_subrange ];\r
if (* **z80** *) versionz80 then\r
begin\r
init_types := [pool_type,allign_arr_type,allign_rec_type];\r
allign_types := init_types;\r
end\r
else\r
if (* **rc3502** *) lambdaversion then\r
begin\r
init_types := [shadow_type,ref_type,pool_type,sem_type,pointer_type,\r
allign_arr_type,allign_rec_type];\r
allign_types := init_types;\r
end\r
else\r
begin (* **rc3502/2** *)\r
init_types := [shadow_type,ref_type,pool_type,process_type, sem_type,pointer_type,\r
allign_arr_type,allign_rec_type,sys_array_type,sys_record_type];\r
allign_types :=[ref_type,pool_type,sem_type,allign_arr_type,\r
allign_rec_type];\r
end;\r
adjust_types:= [int_type,char_type,bool_type,scalar_type,pointer_type,\r
var_param];\r
indirects:=[var_param,with_var,lock_var,dyn_variable];\r
put3(zoption, 0, this_pass, versionpass4);\r
end;\r
\r
procedure push;\r
begin\r
os:=ot;\r
if ot^.next_operand=nil then\r
begin (* allocate new element *)\r
new(ot^.next_operand);\r
top_ops:= top_ops+1;\r
with ot^.next_operand^ do\r
begin\r
next_operand:= nil;\r
former_operand:= ot;\r
end; (* with *)\r
end; (* allocate *)\r
ot:= ot^.next_operand;\r
ot^.temp_size:=source_line; (* test *)\r
end;\r
\r
procedure pop;\r
begin\r
ot:=os;\r
os:=os^.former_operand;\r
end;\r
\r
procedure push_name(var nix: integer);\r
var \r
top: stack_ptr;\r
begin\r
passin(nix);\r
if nix>max_name_index then abort(name_overflow);\r
if free_stack=nil then\r
begin\r
new(free_stack);\r
top_stack:= top_stack+1;\r
free_stack^.former_elem:= nil;\r
end;\r
top:= free_stack;\r
free_stack:= free_stack^.former_elem;\r
with top^ do\r
begin\r
former_elem:= stack_top;\r
stacked_val:= nix;\r
end; (* with *)\r
stack_top:= top;\r
end;\r
\r
procedure push_old(nix: integer);\r
var\r
top: stack_ptr;\r
begin\r
if free_stack=nil then\r
begin\r
new(free_stack);\r
top_stack:= top_stack+1;\r
free_stack^.former_elem:= nil;\r
end;\r
top:= free_stack;\r
free_stack:= free_stack^.former_elem;\r
with top^ do\r
begin\r
former_elem:= stack_top;\r
stacked_val:= nix;\r
end; (* with *)\r
stack_top:= top;\r
end;\r
\r
procedure pop_to_free_stack(count: integer);\r
(* pop count elements from stack the top of which is stack_top and\r
push the elements onto the stack denoted by free_stack *)\r
var\r
help_ptr: stack_ptr;\r
begin\r
for count:= count downto 1 do\r
begin\r
help_ptr:= stack_top;\r
stack_top:= stack_top^.former_elem;\r
help_ptr^.former_elem:= free_stack;\r
free_stack:= help_ptr;\r
end;\r
end; (* pop to free stack *)\r
\r
procedure new_name;\r
begin\r
push_name(nix);\r
idcount:=idcount+1;\r
end;\r
\r
procedure new_scalar;\r
begin\r
push_name(nix);\r
scalar_count:=scalar_count+1;\r
end;\r
\r
procedure word_allign; forward;\r
\r
procedure push_level(m: block_mode);\r
begin\r
if this_level^.next_level=nil then\r
begin\r
new(this_level^.next_level);\r
with this_level^.next_level^ do\r
begin\r
next_level:= nil; (* top of level stack *)\r
former_level:= this_level;\r
end;\r
end; (* allocate new display level *)\r
this_level:= this_level^.next_level;\r
with this_level^ do begin\r
saved_mode:=mode; mode:=m;\r
saved_niv:=current_niv;\r
saved_part:=stat_part; stat_part:=false;\r
if mode=record_mode then begin\r
saved_offset:=record_offset; record_offset:=0;\r
saved_pack:=pack_record; pack_record:=false;\r
saved_bit:=current_bit; current_bit:=0;\r
saved_chain:=chain; chain:=0;\r
saved_idcount:=idcount; idcount:=0;\r
saved_allign := allign_fields; allign_fields := false;\r
saved_init:=init_fields; init_fields:=false;\r
saved_dyn:=dyn_fields; dyn_fields:=false;\r
end\r
else\r
begin\r
saved_offset:=current_offset;\r
saved_prefix := prefixed;\r
if (mode = process_mode) or saved_prefix then\r
begin\r
process_niv := process_niv + 1;\r
(* if outermost process or prefix then save the namekey*)\r
if process_niv = 0 then saved_name_key := name_key;\r
end;\r
if mode=process_mode then begin\r
current_niv:=0;\r
if (* **z80** *) versionz80 then\r
current_offset:= -process_offset\r
else\r
(* **lambda or rc3502c** *)\r
current_offset:=process_offset;\r
end else begin\r
current_niv:=current_niv+1;\r
if (* **z80** *) versionz80 then\r
current_offset:= -activation_record_length\r
else\r
if lambdaversion then\r
current_offset:=activation_record_length-1\r
else (*rc3502c*)\r
current_offset := activation_record_length;\r
end;\r
saved_v_length:=var_length; var_length:=0;\r
saved_c_index:=first_c_index;\r
first_c_index:=top_c_index;\r
saved_lix:=current_lix;\r
end;\r
end;\r
end;\r
\r
procedure pop_level;\r
begin\r
with this_level^ do begin\r
if mode=record_mode then begin\r
pack_record:=saved_pack;\r
current_bit:=saved_bit;\r
chain:=saved_chain;\r
idcount:=saved_idcount;\r
allign_fields := saved_allign;\r
init_fields:=saved_init;\r
record_offset:=saved_offset;\r
dyn_fields:=saved_dyn;\r
end\r
else\r
begin\r
current_offset:=saved_offset;\r
top_c_index:=first_c_index;\r
first_c_index:=saved_c_index;\r
var_length:=saved_v_length;\r
if (* **z80** *) versionz80 then\r
current_lix:=saved_lix;\r
if (mode = process_mode) or saved_prefix then\r
begin\r
process_niv := process_niv -1;\r
(*if outermost process or prefix is popped then restore namekey*)\r
if process_niv=-1 then\r
begin\r
if name_key>max_name_key then\r
max_name_key:= name_key;\r
name_key:= saved_name_key;\r
end;\r
end;\r
end;\r
mode:=saved_mode;\r
current_niv:=saved_niv;\r
stat_part:=saved_part;\r
end;\r
this_level:=this_level^.former_level;\r
end;\r
\r
function int_add(a,b: integer): integer;\r
begin\r
(*$R-*)\r
int_add:=a+b;\r
(*$R+*)\r
end;\r
\r
function int_mul(a,b: integer): integer;\r
begin\r
(*$R-*)\r
int_mul := a*b;\r
(*$R+*)\r
end;\r
\r
function int_div(a,b: integer): integer;\r
begin\r
if b = 0 then\r
begin\r
int_div := a;\r
error(type_error);\r
end else\r
int_div := a div b;\r
end;\r
\r
function int_mod(a,b: integer): integer;\r
begin\r
if b = 0 then\r
begin\r
int_mod := a;\r
error(type_error);\r
end else\r
int_mod := a mod b;\r
end;\r
\r
function int_logical( kind : out_code; a,b : integer) : integer;\r
begin\r
case kind of\r
zand: int_logical := a and b;\r
zor_: int_logical := a or b;\r
zxor: int_logical := a xor b;\r
end;\r
end;\r
\r
\r
function int_shift(a, b: integer): integer;\r
begin\r
if b >= 0 then\r
begin\r
int_shift:= a shl b;\r
end else int_shift := a shr (-b);\r
end; (* int shift *)\r
\r
\r
function alloc_var(size: integer): integer;\r
begin\r
(*$R-*)\r
if (* **z80** *) versionz80 then begin\r
(* current_offset <= 0 *)\r
if top_address + current_offset >= size then\r
current_offset := current_offset - size\r
else error(address_overflow);\r
alloc_var:=current_offset;\r
end\r
else\r
begin\r
(* **lambda or rc3502c** *)\r
alloc_var:=current_offset;\r
(* current_offset >= -1 *)\r
if top_address - current_offset >= size then\r
current_offset := current_offset + size\r
else error(address_overflow);\r
end;\r
(*$R+*)\r
end; (*alloc var*)\r
\r
function address_add(a,b: integer): integer;\r
begin\r
(*$R-*)\r
if top_address - a >= b then address_add:=a+b\r
else\r
begin\r
error(address_overflow);\r
address_add:=a;\r
end;\r
(*$R+*)\r
end;\r
\r
function field_add(a,b: integer): integer;\r
begin\r
(*$R-*)\r
if module_size - a >= b then field_add:=a+b\r
else\r
begin\r
error(record_size_error);\r
field_add:=a;\r
end;\r
(*$R+*)\r
end;\r
\r
function take_expr: integer;\r
begin\r
with ot^ do begin\r
if context<>sconst then begin\r
error(var_error); take_expr:=0;\r
end\r
else\r
begin\r
take_expr:=offset;\r
end;\r
end;\r
pop;\r
end;\r
\r
function bits(v: integer): integer;\r
var no,power: word;\r
begin\r
if v<0 then no:=bits_pr_word else\r
if v<2 then no:=1 else\r
begin\r
power:=4; no:=2;\r
while v>power-1 do begin\r
power:=power shl 1;\r
no:=no+1;\r
end;\r
end;\r
if no>bits_pr_word then compiler_error(bit_count_error);\r
bits:=no;\r
end;\r
\r
function var_size(min,max: integer): integer;\r
begin\r
(*$R-*)\r
if min>max then (* empty subrange *)\r
var_size:= 0\r
else\r
if (min<0) or (bits(max) > bits_pr_byte) then\r
var_size:=word_length else\r
var_size:=byte_length;\r
(*$R+*)\r
end;\r
\r
function check_type(ty: integer; a,b: integer): boolean;\r
var bo: boolean;\r
begin\r
bo:=a<=b;\r
with nametable(ty)^ do\r
if (a<min) or (b>max) then bo:=false;\r
check_type:=bo;\r
end;\r
\r
procedure word_allign;\r
begin\r
if (not lambdaversion) and (not versionz80) then\r
begin (* **rc3502c** *)\r
if odd(current_offset) then\r
current_offset := address_add(current_offset,1);\r
end\r
else\r
begin\r
if not versionz80 then\r
(* **lambda** *)\r
if not odd(current_offset) then\r
current_offset:=address_add(current_offset,1);\r
end;\r
end;\r
\r
procedure field_allign;\r
begin\r
if not versionz80 then\r
(* **lambda or rc3502c** *)\r
if odd(record_offset) then\r
record_offset:=field_add(record_offset,1);\r
end;\r
\r
function type_o(c: context_kind): integer;\r
begin\r
case c of\r
pointer_type: type_o:=pointer_typ;\r
sem_type: type_o:=sem_typ;\r
ref_type: type_o:=ref_typ;\r
shadow_type: type_o:=shadow_typ;\r
end;\r
end;\r
\r
procedure alloc_constant(var lix: location_index;\r
var index: integer; bytes: integer);\r
var words: integer; i: integer;\r
begin\r
words:=bytes shr 1;\r
(*$R-*)\r
if odd(bytes) then words := words + 1;\r
index:=top_c_index + 3;\r
if index < 0 then abort(const_area_overflow);\r
top_c_index:=index+words;\r
if top_c_index < 0 then abort(const_area_overflow);\r
(*$R+*)\r
if top_c < top_c_index then top_c:=top_c_index;\r
lix:=-current_lix;\r
current_lix:=current_lix+1;\r
update_const(index-3, words + 3);\r
update_const(index-2, lix);\r
update_const(index-1, words+3);\r
for i:=index to top_c_index-1 do update_const(i, 0);\r
end;\r
\r
procedure cut_constant(c_index: integer; new_words: integer);\r
var first: integer;\r
begin\r
first:=c_index - 3;\r
update_const(first, new_words+3);\r
top_c_index:=first+new_words+3;\r
update_const(first+2, retrieve_const(first));\r
end;\r
\r
procedure adjust_string(p,q: operand_ptr);\r
var words:integer; i: integer;\r
begin\r
if q^.dynamic then error(error_dyn_var)\r
else\r
begin\r
p^.size:=q^.size;\r
words:=(q^.size + 1) div 2+3;\r
i:=p^.offset;\r
if words > retrieve_const(i-1) then update_const(i-1, words);\r
end;\r
end;\r
\r
procedure remove_constant(c_index: integer);\r
var first, q: integer;\r
begin\r
first:=c_index-3; q:=first;\r
if q+retrieve_const(first) = top_c_index then\r
top_c_index:=first;\r
end;\r
\r
procedure release_temp(s: integer);\r
begin\r
if (* **z80** *) versionz80 then\r
current_offset:=current_offset + s\r
else\r
(* **lambda or rc3502c** *)\r
current_offset:=current_offset - s;\r
end;\r
\r
procedure constant_used(q: operand_ptr);\r
begin\r
with q^ do begin\r
niv:= abs(niv);\r
update_const(offset-2, niv);\r
if var_nix >= 0 then\r
nametable(var_nix)^.niv:=niv;\r
end;\r
end;\r
\r
\r
\r
function alloc_temp(size: integer): integer;\r
begin\r
alloc_temp:=alloc_var(size);\r
if (* **z80** *) versionz80 then begin\r
if -current_offset > var_length then\r
var_length:= -current_offset;\r
end\r
else\r
(* **lambda or rc3502c** *)\r
if current_offset>var_length then\r
var_length:=current_offset;\r
end;\r
\r
procedure alloc_dope(lix, lower, upper, elem: integer);\r
var index: integer;\r
begin\r
index:=top_c_index;\r
(*$R-*)\r
top_c_index:=top_c_index + 6;\r
if top_c_index < 0 then abort(const_area_overflow);\r
(*$R+*)\r
update_const(index, 6);\r
update_const(index+1, lix);\r
update_const(index+2, 6);\r
update_const(index+3, lower);\r
update_const(index+4, upper);\r
update_const(index+5, elem);\r
end;\r
\r
procedure alloc_range_descr(lix, lower, upper: integer);\r
var index: integer;\r
begin\r
index:=top_c_index;\r
(*$R-*)\r
top_c_index:=top_c_index+5;\r
if top_c_index < 0 then abort(const_area_overflow);\r
(*$R+*)\r
update_const(index, 5);\r
update_const(index+1, lix);\r
update_const(index+2, 5);\r
update_const(index+3, lower);\r
update_const(index+4, upper);\r
end;\r
\r
procedure std_name(ty: pass3codes);\r
begin\r
push_name(nix);\r
with nametable(nix)^ do begin\r
dynamic:=false;\r
case ty of\r
xinteger: begin\r
context:=int_type;\r
size:=word_length;\r
max:=max_int; min:=min_int;\r
lix:=-current_lix;\r
current_lix:=current_lix+1;\r
end;\r
xchar: begin pop_to_free_stack(1); context:=char_type; end;\r
xreal: ;(* not inplemented *)\r
xboolean: begin pop_to_free_stack(1); context:=bool_type; end;\r
xstringtype: begin\r
pop_to_free_stack(1);\r
context:=array_type;\r
lix:=0; size:=0;\r
packed_comp:=false;\r
end;\r
xsemaphore: begin\r
pop_to_free_stack(1);\r
context:=sem_type;\r
semaphor_length:=size;\r
end;\r
xshadow: begin pop_to_free_stack(1); context:=shadow_type; end;\r
xreference: begin\r
pop_to_free_stack(1);\r
context:=ref_type;\r
if (* **rc3502c** *) (not lambdaversion) and (not versionz80) then\r
size := byte_length + 2 * pointer_length\r
else\r
if (* **lambda** *) not versionz80 then size:=2*pointer_length;\r
end;\r
xniltype: begin\r
context:=int_type;\r
niltype_nix:=nix;\r
size:=2;\r
end;\r
xerrortype: begin\r
pop_to_free_stack(1);\r
undef_nix:=nix;\r
context:=undef_type;\r
size:=word_length;\r
end;\r
xundeclid: begin\r
pop_to_free_stack(1);\r
nametable(nix)^:=nametable(undef_nix)^;\r
end;\r
xchr: begin pop_to_free_stack(1); niv:=-zchr-1; end;\r
xord: begin pop_to_free_stack(1); niv:=-zord-1; end;\r
xpred: begin pop_to_free_stack(1); niv:=-zpred-1; end;\r
xsucc: begin pop_to_free_stack(1); niv:=-zsucc-1; end;\r
xnil: begin pop_to_free_stack(1); niv:=-znil-1; end;\r
xnilref: begin pop_to_free_stack(1); niv:=-znilref-1; end;\r
xnew: begin pop_to_free_stack(1); niv:=-znew-1; end;\r
end;\r
end;\r
end;\r
\r
procedure scalar_def;\r
var saved_size, i: integer;\r
help_ptr: stack_ptr;\r
begin\r
push_name(nix);\r
with nametable(nix)^ do begin\r
context:=scalar_type;\r
dynamic:=false;\r
min:=0; max:=scalar_count-1;\r
if max<0 then begin\r
compiler_error(scalar_error);\r
max:=0;\r
end;\r
size:=var_size(min,max);\r
saved_size:=size;\r
end;\r
(* reverse the scalar list and update the names in declaration order *)\r
pop_to_free_stack(scalar_count+1);\r
help_ptr:= free_stack;\r
for i:=scalar_count downto 1 do\r
with nametable(help_ptr^.stacked_val)^ do begin\r
context:=sconst;\r
size:=saved_size;\r
offset:=scalar_count-i;\r
help_ptr:= help_ptr^.former_elem;\r
end;\r
scalar_count:=0;\r
push_old(nix);\r
end;\r
\r
procedure sub_def;\r
var ty: integer;\r
begin\r
push_name(nix); passin(ty);\r
if (ot^.context = sconst) and (os^.context = sconst) then\r
with nametable(nix)^ do begin\r
context:=nametable(ty)^.context;\r
max:=take_expr; min:=take_expr;\r
if not check_type(ty,min,max) then\r
if var_size(min, max)<>0 then\r
begin\r
error(range_def_error);\r
min:=0; max:=1;\r
end;\r
dynamic:=false;\r
size:=var_size(min,max);\r
lix:=-current_lix; (* no range descr allocated *)\r
current_lix:=current_lix+1;\r
end\r
else\r
begin (* dynamic *)\r
load_expr; pop; pop;\r
with nametable(nix)^ do begin\r
context:=dyn_subrange;\r
size:=word_length;\r
min:=min_int; max:=max_int;\r
niv:=current_niv;\r
word_allign;\r
offset:=alloc_var(sub_template_size);\r
dynamic:=true;\r
put1(zsubdef, offset);\r
if (* **z80** *) versionz80 then begin\r
error(not_implemented);\r
min:=0; max:=1;\r
dynamic:=false;\r
end;\r
end; (*with*)\r
end; (*dynamic*)\r
end;\r
\r
procedure pointer_def;\r
var component_type: integer;\r
begin\r
component_type:= stack_top^.stacked_val;\r
pop_to_free_stack(1); (*pop component type*)\r
push_name(nix);\r
with nametable(nix)^ do begin\r
context:=pointer_type;\r
size:=pointer_length;\r
comp_type:= component_type;\r
dynamic:=false;\r
end;\r
end;\r
\r
procedure forward_pointer_def;\r
begin\r
push_name(nix);\r
with nametable(nix)^ do begin\r
context:=pointer_type;\r
size:=pointer_length;\r
comp_type:= niltype_nix;\r
dynamic:=false;\r
end;\r
end;\r
\r
procedure redef_type;\r
begin\r
i:=stack_top^.stacked_val; pop_to_free_stack(1);\r
push_name(nix);\r
nametable(nix)^:=nametable(i)^;\r
with nametable(nix)^ do\r
if context in index_types then begin\r
lix:=-current_lix;\r
current_lix:=current_lix+1\r
end;\r
end;\r
\r
procedure static_array_def(pack_array: boolean);\r
var span : longint;\r
lower,upper,array_size,bit_span,\r
comp_nix,fields_pr_word,elem_size: integer;\r
pack, init_type,allign_type: boolean;\r
begin\r
pack:=pack_array;\r
with nametable(stack_top^.former_elem^.stacked_val)^ do begin\r
lower:=min; upper:=max;\r
(*$R-*)\r
span:=upper;\r
span := span-lower+1;\r
(*$R+*)\r
end;\r
comp_nix:=stack_top^.stacked_val;\r
with nametable(comp_nix)^ do begin\r
allign_type := context in allign_types;\r
init_type:=context in init_types;\r
if (* **z80** *) versionz80 then\r
elem_size:=size\r
else\r
(* **lambda or rc3502c** *)\r
if odd(size) and allign_type then\r
elem_size:=size+1 else elem_size:=size;\r
if pack then pack:=context in index_types;\r
if pack then begin\r
bit_span:=bits(max);\r
fields_pr_word:=bits_pr_word div bit_span;\r
if fields_pr_word>=min_fields_pr_word then begin\r
array_size:=(span div fields_pr_word)*2 +\r
((span mod fields_pr_word)*bit_span+7) div bits_pr_byte;\r
if (* **z80** *) versionz80 then\r
if odd(array_size) then array_size:=array_size + 1;\r
elem_size:=fields_pr_word*shift8+bit_span;\r
end\r
else pack:=false;\r
end;\r
if not pack then\r
begin\r
(*$R-*)\r
if span = 0 then array_size := 0 else\r
if elem_size<=module_size div span then array_size:=elem_size*span\r
(*$R+*)\r
else\r
begin\r
error(array_size_error);\r
array_size:=size;\r
end;\r
end;\r
end;\r
pop_to_free_stack(2);\r
push_name(nix);\r
with nametable(nix)^ do begin\r
if allign_type then\r
(* z80: component contains a variable of pool_type for alligment and init*)\r
(* rc3502: component contains a systemvariable for allignment and init*)\r
(* rc3502/2: component contains a systemvariable for allignment and init -\r
not a pointervariable*)\r
context := allign_arr_type\r
else\r
if init_type then\r
(* rc3502/2: component contains a pointervariable for initialization*)\r
(* note that z80 and rc3502 never gets to this point, since allign_type\r
and init_type always are true at the same time for these machines *)\r
context := sys_array_type\r
else\r
(*component contains no system variables*)\r
context := array_type;\r
size:=array_size;\r
min:=lower; max:=upper; niv:=elem_size;\r
lix:=-current_lix; (* no dope vector allocated *)\r
current_lix:=current_lix+1;\r
next_comp:=comp_nix;\r
packed_comp:=pack;\r
dynamic:=false;\r
end;\r
end;\r
\r
procedure array_def(pack_array: boolean);\r
var index_nix, comp_nix, dyn_case, bit_span, fields_pr_word,\r
comp_niv, comp_offset,\r
lower, upper, index_niv, index_offset,\r
allign, elem_size : integer;\r
pack, init_type,allign_type: boolean;\r
begin\r
index_nix:=stack_top^.former_elem^.stacked_val;\r
comp_nix:=stack_top^.stacked_val;\r
if nametable(index_nix)^.dynamic then\r
dyn_case:=2 else dyn_case:=1;\r
if nametable(comp_nix)^.dynamic then\r
dyn_case:=dyn_case+2;\r
if nametable(comp_nix)^.context = dyn_subrange then\r
dyn_case:=dyn_case-2;\r
(*\r
index type comp type : dyn_case\r
static static 1\r
dynamic static 2\r
static dynamic 3\r
dynamic dynamic 4\r
*)\r
if dyn_case = 1 then\r
static_array_def(pack_array)\r
else\r
begin\r
pack:=false; fields_pr_word:=1; bit_span:=0;\r
with nametable(index_nix)^ do begin\r
lower:=min; upper:=max;\r
index_niv:=niv; index_offset:=offset;\r
end;\r
with nametable(comp_nix)^ do begin\r
allign_type := context in allign_types;\r
init_type:=context in init_types;\r
if allign_type then allign:=1 else allign:=0;\r
if dyn_case = 2 then begin\r
if (* **z80** *) versionz80 then\r
elem_size:=size\r
else\r
(* **lambda or rc3502c** *)\r
if odd(size) and allign_type then\r
elem_size:=size+1 else elem_size:=size;\r
if pack_array then pack:=context in index_types;\r
if pack then begin\r
bit_span:=bits(max);\r
fields_pr_word:=bits_pr_word div bit_span;\r
if fields_pr_word < min_fields_pr_word then begin\r
fields_pr_word:=1;\r
pack:=false;\r
end;\r
end; (*if pack*)\r
end; (*dyn_case=2*)\r
comp_niv:=niv; comp_offset:=offset;\r
end; (*with*)\r
pop_to_free_stack(2); (*pop pop namestack*)\r
push_name(nix);\r
with nametable(nix)^ do begin\r
if allign_type then\r
(*z80:component contains poolvariable for alligment and initialization*)\r
(*rc3502:component contains systemvariable for allignment and init*)\r
(*rc3502/2:component contains systemvariable(not a pointer) for allignment\r
and initialization*)\r
context := allign_arr_type\r
else\r
if init_type then\r
(*rc3502/2: component contains a pointervariable for initialization*)\r
(*note that z80 and rc3502 does not get to this point since allign_type\r
and init_type are true at the same time*)\r
context := sys_array_type\r
else\r
(*component does not contain any systemvariable*)\r
context := array_type;\r
niv:=current_niv;\r
word_allign;\r
offset:=alloc_var(array_template_size);\r
next_comp:=comp_nix;\r
packed_comp:=pack;\r
dynamic:=true;\r
size:=0; min:=0; max:=0; lix:=0;\r
case dyn_case of\r
2: begin\r
put4(zarray1template, offset,\r
index_niv, index_offset, elem_size);\r
put_arg2(fields_pr_word, bit_span);\r
end;\r
3: begin\r
put3(zarray2template, offset,\r
comp_niv, comp_offset);\r
put_arg3(lower, upper, allign);\r
end;\r
4: begin\r
put3(zarray3template, offset,\r
comp_niv, comp_offset);\r
put_arg3(index_niv, index_offset, allign);\r
end;\r
end; (*case*)\r
end; (*with*)\r
end; (*if*)\r
end; (*array def*)\r
\r
procedure field_list;\r
var field_type_nix, field_size, field_nix, max_bits,\r
comp_niv, comp_offset, allign, i: integer;\r
allign_type, pack_field, init,dyn: boolean;\r
help_ptr: stack_ptr;\r
begin\r
pack_field:=false;\r
field_type_nix:=stack_top^.stacked_val;\r
with nametable(field_type_nix)^ do begin\r
field_size:=size;\r
if pack_record and (context in index_types) then begin\r
if min>=0 then begin\r
max_bits:=bits(max);\r
if max_bits<bits_pr_word then\r
pack_field:=true;\r
end;\r
end;\r
init:=context in init_types;\r
allign_type := context in allign_types;\r
comp_niv:=niv; comp_offset:=offset;\r
dyn:=dynamic;\r
if context = dyn_subrange then dyn:=false;\r
if allign_type then allign:=1 else allign:=0;\r
end;\r
if pack_record and not pack_field then begin\r
if current_bit>0 then begin\r
record_offset:=field_add(record_offset,field_unite);\r
if dyn_fields then put0(zincfield);\r
end;\r
current_bit:=0;\r
end;\r
allign_fields := allign_fields or allign_type;\r
init_fields:=init_fields or init;\r
pop_to_free_stack(idcount+1);\r
help_ptr:= free_stack;\r
for i:=idcount downto 1 do begin\r
field_nix:=help_ptr^.stacked_val;\r
help_ptr:= help_ptr^.former_elem;\r
with nametable(field_nix)^ do begin\r
if pack_field then begin\r
if current_bit+max_bits>bits_pr_word then begin\r
record_offset:=field_add(record_offset,field_unite);\r
if dyn_fields then put0(zincfield);\r
current_bit:=0;\r
end;\r
size:=max_bits;\r
max:=max_bits;\r
min:=current_bit;\r
current_bit:=current_bit+max_bits;\r
if dyn_fields then begin\r
niv:=current_niv;\r
offset:=alloc_var(field_template_size);\r
put3(zfieldsize, 0, offset, 0);\r
end\r
else\r
offset:=record_offset;\r
if (* **lambda or rc3502c** *) not versionz80 then\r
if current_bit >= bits_pr_byte then begin\r
current_bit:=current_bit - bits_pr_byte;\r
record_offset:=field_add(record_offset,byte_length);\r
if dyn_fields then put0(zincfield);\r
end;\r
end else begin\r
if allign_type then field_allign;\r
if dyn_fields then begin\r
niv:=current_niv;\r
offset:=alloc_var(field_template_size);\r
if dyn then\r
put4(zdynfieldsize, allign, offset,\r
comp_niv, comp_offset)\r
else\r
put3(zfieldsize, allign, offset, field_size);\r
end\r
else\r
begin\r
size:=field_size; offset:=record_offset;\r
record_offset:=field_add(record_offset, field_size);\r
if dyn then\r
put3(zrecordtemplate, offset, comp_niv, comp_offset);\r
end;\r
end;\r
if dyn_fields then\r
context:=dyn_field else context:=field;\r
dyn_fields:=dyn_fields or dyn;\r
packed_comp:=pack_field;\r
if pack_field then\r
if size=bits_pr_byte then\r
if (min=0) or (min=8) then begin\r
packed_comp:=false;\r
size:=byte_length;\r
if (* **z80** *) versionz80 then begin\r
if min=0 then offset:=offset+1\r
end\r
else\r
(* **lambda or rc3502c** *)\r
if min=8 then offset:=offset+1\r
end;\r
if init then begin\r
next_comp:=chain; chain:=field_nix;\r
comp_type:=field_type_nix;\r
end;\r
end;\r
end;\r
idcount:=0;\r
end;\r
\r
procedure record_def;\r
begin\r
push_name(nix);\r
with nametable(nix)^ do begin\r
if pack_record then begin\r
if current_bit>0 then begin\r
record_offset:=field_add(record_offset,field_unite);\r
if dyn_fields then put0(zincfield);\r
end;\r
end;\r
dynamic:=dyn_fields;\r
if dyn_fields then begin\r
niv:=current_niv;\r
offset:=alloc_var(record_template_size);\r
put1(zendtemplate, offset);\r
size:=0;\r
end\r
else\r
size:=record_offset;\r
if allign_fields then\r
begin\r
(*z80 and rc3502: some field contains a systemvariable for allignment\r
and initialization*)\r
(*rc3502/2: some field contains a systemvariable (not pointer) for\r
allignment and initilization*)\r
context := allign_rec_type;\r
next_comp := chain;\r
end\r
else\r
(*rc3502/2: some field is a pointervariable for initialization*)\r
(*note that z80 and rc3502 never gets to this point since allign_fields\r
and init_fields are true at the same time for these machines*)\r
if init_fields then begin\r
context:=sys_record_type;\r
next_comp:=chain;\r
end else\r
context:=record_type;\r
end;\r
pop_level;\r
end;\r
\r
procedure set_def;\r
var lower,upper,words: integer;\r
begin\r
with nametable(stack_top^.stacked_val)^ do begin\r
lower:=min; upper:=max;\r
if dynamic then begin\r
error(error_dyn);\r
lower:=0; upper:=1;\r
end;\r
words:=upper div bits_pr_word;\r
if upper mod bits_pr_word <> 0 then words := words + 1;\r
end;\r
pop_to_free_stack(1);\r
if lower<0 then begin\r
error(set_def_error); lower:=0;\r
end;\r
if words=0 then words:=1;\r
push_name(nix);\r
with nametable(nix)^ do begin\r
context:=set_type;\r
min:=lower; max:=upper;\r
size:=words*2;\r
dynamic:=false;\r
end;\r
end;\r
\r
procedure pool_def;\r
var data_size: integer;\r
begin\r
with nametable(stack_top^.stacked_val)^ do begin\r
if stack_top^.stacked_val = niltype_nix then\r
data_size:=0\r
else\r
data_size:=size;\r
if dynamic then begin\r
error(error_dyn);\r
data_size:=0;\r
end;\r
end;\r
pop_to_free_stack(1);\r
push_name(nix);\r
with nametable(nix)^ do begin\r
context:=pool_type;\r
size:=semaphor_length;\r
min:=take_expr;\r
if min<0 then begin\r
error(pool_def_error); min:=1;\r
end;\r
max:=data_size;\r
dynamic:=false;\r
end;\r
end;\r
«eof»