|
DataMuseum.dkPresents historical artifacts from the history of: RC3500 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about RC3500 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 79104 (0x13500)
Types: TextFileVerbose
Names: »pass4text«
└─⟦2c55ea56f⟧ Bits:30001844 SW-save af projekt 1000, Alarm-system
└─⟦6b41451d2⟧
└─⟦this⟧ »pass4text«
program pass4(output, pass3file='pass3code',
pass4file='pass4code');
(*$T+*)
const
versionpass4 = 301; (* 3.01 date : 81.xx.xx *)
versionpass3 = 2; (* pass 3 version must be 2.xx *)
versionz80 = false; (* true z80 version *)
(* false lambda version *)
(*std variable length, and max values *)
word_length=2; byte_length=1;
char_length=1;
set_const_length = 64; (* words *)
(*
pointer_length,
activation_record_length is variables
*)
array_template_size = 8;
sub_template_size = 6;
field_template_size = 2;
record_template_size = 2;
bits_pr_byte=8;
bits_pr_word=16;
min_fields_pr_word = 3;
max_byte_value = 255;
module_size = 65536; (* 2**16 *)
top_address = 65535; (* module size -1 *)
max_int = 32768;
min_int = -max_int;
(*div*)
shift8 = 256;
shift16 = 65536;
bit_0_8 = - shift16; (* bit 0 - 8 in rc8000 word *)
spsp = 8224; (* string with 2 spaces *)
print_limit = 15;
max_block_level = 20; (* >= max_levels in pass 3 *)
max_operand = 100;
max_name_index = 2000;
max_init_level = 10;
max_const_area = 3000;
max_stack =200;
pack = true;
non_pack = false;
this_pass = 4;
(* constants in pass 4 code *)
(* value of type_v in pass 4 code *)
byte_typ = 1; addr_typ = 5;
word_typ = 2; set_typ = 6;
field_typ= 3; dyn_typ = 7;
double_typ = 4;
(* values of type_o in pass 4 code *)
bool_typ = 1; int_typ = 2; real_typ = 3; setof_typ = 4;
pointer_typ = 5; sem_typ = 6; ref_typ = 7; shadow_typ = 8;
scalar_typ = 9;
(* compare function number in pass 4 code *)
zeq = 2; zne = 3; zlt = 4;
zgt = 5; zle = 6; zge = 7;
zeq_set = 8; zne_set = 9; zle_set = 10;
zge_set = 11; zin = 12; zeq_struc = 13;
zne_struc = 14;
(* std function number in pass 4 code *)
zord = 1; zsucc = 2; zpred = 3; zchr = 4;
(* mode for for statement *)
zup = 1; zdown = 2;
(* export name type *)
offset_type = 1; value_type = 2;
(* end pass 4 code constants *)
(* literal type *)
num_const = 1; string_const = 2; char_const = 3;
type
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 *)
out_code =
(* pass4codes= *)
( zfirstcode,
zmodule, zeom,
zoption, znewline,
zprocess, zextprocess,
zblock, zlength, zendblock,
zbegincode, zcodeline, zendcode,
zsubdef,
zarray1template, zarray2template, zarray3template,
zrecordtemplate, zfieldsize, zdynfieldsize, zincfield,
zendtemplate,
zenddecl,
zallocdynvar,
zinitialize, zstrucinit, zsimpleinit, zsetinit,
zexception, zextexception,
zsysinit, zsysdyninit,
zfieldinit, zdynfieldinit,
zendinitfields,
zarrayinit, zarraydyninit,
zpoolinit,
zvarinit,
zexport,
zproc, zextproc,
zfunc, zextfunc,
zparamtype,
zdeflix,
zproccall, zendpcall,
zextproccall,
zprocessparam, zendprocessparam,
zvarpointer, ztempointer, zarglistsize,
zvarparam, zvalueparam,
zassignstat, zleft, zassign,
zcasestat, zcase, zendcaselist, zendcasestat, zendcase,
zcaserange, zcaselabel, zotherwise,
zforstat, zleftfor, zforstore, zdo, zendfor,
zgoto,
zifstat, zifexpr, zelse, zif,
zrepeat, zuntil, zendrepeat,
zwhile, zwhileexpr, zendwhile,
zwithstat, zwithvar, zendwith,
zlockstat, zlockvar, zlockdynvar, zendlock,
zchannel, zchanvar, zendchannel,
zexchstat, zexchange,
znot, zneg, zcompare, zcompstruc, zcompdynstruc, zdiv,
zmul, zmod, zor, zxor, zadd, zsub, zand, zrangetest,
zdynrangetest,
zconst, zlconst, zsetconst,
zset, zinclude, zsetexpr, zincludeint, zendset,
zinitconst,
zindvar,
zaddr, zcaddr, zindaddr,
zpackedarr,
zfield, zdynfield,
zindexexpr, zcindex, zindex,
zstdfunccall, zfcall, zendfunccall,
zfunccall, zextfunccall,
zerror, zerrorno, zerrortext,
zlastcode
);
pass4codeindex = 0..150; (* number of pass4codes *)
\f
(* end pass 4 codes *)
context_kind = ( not_used,
int_type, char_type, bool_type, sem_type,
shadow_type, ref_type, scalar_type, set_type,
pool_type, array_type, sys_array_type, pointer_type,
record_type, sys_record_type,label_type, routine_type,
dyn_subrange, undef_type,
field, dyn_field, variable, dyn_variable,
var_param, value_param,
sconst, lconst, set_const,
with_var, lock_var, func_result,
expr, struc_c );
error_types = (overflow, range_def_error, set_def_error,
pool_def_error, type_error,
addr_error, var_error, range_error,
literal_error, set_error, const_error,
for_error, input_error, scalar_error,
operand_overflow, name_overflow, block_overflow,
bit_count_error, const_overflow,prelude_error, address_overflow,
record_size_error, array_size_error,
field_export_error, exportvalue_error, exportaddr_error,
stack_error, version_error, not_implemented,
error_dyn, error_dyn_init, error_dyn_var);
name_index = 0..max_name_index;
location_index = integer;
display_index = 1..max_block_level;
addr_state = (direct, indirect, addr, expression, p_comp );
block_mode = (process_mode, proc_mode, func_mode, record_mode);
export_kind_type = (exportvalue, exportsize, exportdispl,
exportoffset, exportaddr );
name_rec = record
context: context_kind;
size: integer;
min: integer;
max: integer;
niv: integer;
offset: integer;
lix: location_index;
next_comp: name_index;
comp_type: name_index;
packed_comp:boolean;
dynamic : boolean;
end;
operand_rec = record
type_nix: integer;
var_nix: integer;
kind: context_kind;
niv: integer;
offset: integer;
size: integer;
context: context_kind;
lix: integer;
first: integer;
comp_size:integer;
field_packed : boolean;
array_packed : boolean;
dynamic: boolean;
state: addr_state;
temp_size: integer;
func_value: boolean;
end;
init_modes = (record_init, array_init, packed_array, error_init );
struc_level = record
times: integer;
current_index: integer;
top_index: integer;
first: integer;
displ: integer;
bits_pr_field: integer;
elem_pr_word: integer;
dope_lix: integer;
saved_nix: name_index;
saved_lix: integer;
saved_size: integer;
saved_stat_part: boolean;
init_mode: init_modes;
end;
display_rec = record
saved_mode: block_mode;
saved_offset: integer;
saved_niv: integer;
saved_part: boolean;
saved_pack: boolean;
saved_bit: integer;
saved_chain: integer;
saved_v_length: integer;
saved_idcount: integer;
saved_lix: integer;
saved_init: boolean;
saved_dyn: boolean;
saved_c_index: integer;
parameter_length: integer;
end;
var
source_line: integer;
convert_in_code: array [pass3codeindex] of pass3codes;
shift_to: array [0..15] of integer;
nametable: array [name_index] of name_rec;
nix: integer;
stack: array [0..max_stack] of integer;
t: integer;
ops: array [1..max_operand] of operand_rec;
os, ot, empty_stack: integer;
struc_init: array [1..max_init_level] of struc_level;
ss: integer;
c: array [1..max_const_area] of integer;
first_c_index, top_c_index: integer;
display: array [display_index] of display_rec;
this_level: integer;
array_types, index_types, indirects, init_types,
system_types,var_types, simple_types : set of context_kind;
program_ok, done, test, init_fields, dyn_fields, pack_record, prelude,
index_check, prefixed_name, waiting_with, line_number,
prefixed, stat_part, variable_init, export, test_survey : boolean;
mode: block_mode;
ext_name,
prefix_name: alfa;
export_kind: export_kind_type;
type_pointer,
pointer_length,
activation_record_length,
field_unite,
top_nix,
top_t,
top_ops,
top_ss,
top_c,
top_level,
top_lix,
process_offset,
current_bit,
current_lix,
current_niv,
current_offset,
record_offset,
name_key,
field_offset,
first_of_expr,
var_length,
idcount,
scalar_count,
param_number,
head_line,
process_param_length,
printed,
i,no,
undef_nix,
max_set_const_value,
semaphor_length,
chain : integer;
pass3file, pass4file: file of integer;
procedure error(ty: error_types); forward;
procedure load_expr; forward;
procedure get(var number: integer);
begin
read(pass3file,number);
end;
procedure print(op: out_code);
begin
if printed>=print_limit then begin
writeln; printed:=0;
end;
write(' *',ord(op):3);
printed:=printed+1;
end;
procedure print_arg(arg: integer);
begin
if printed>=print_limit then begin
writeln; printed:=0;
end;
write(arg:7);
printed:=printed+1;
end;
procedure put0(op: out_code);
begin
if line_number then begin
write(pass4file, ord(znewline), source_line);
line_number:=false;
end;
write(pass4file,ord(op));
if test then print(op);
end;
procedure put1(op: out_code; arg1: integer);
begin
if line_number then begin
write(pass4file, ord(znewline), source_line);
line_number:=false;
end;
write(pass4file,ord(op),arg1);
if test then begin
print(op); print_arg(arg1);
end;
end;
procedure put2(op: out_code; arg1,arg2: integer);
begin
if line_number then begin
write(pass4file, ord(znewline), source_line);
line_number:=false;
end;
write(pass4file,ord(op),arg1,arg2);
if test then begin
print(op); print_arg(arg1); print_arg(arg2);
end;
end;
procedure put3(op: out_code; arg1,arg2,arg3: integer);
begin
if line_number then begin
write(pass4file, ord(znewline), source_line);
line_number:=false;
end;
write(pass4file,ord(op),arg1,arg2,arg3);
if test then begin
print(op); print_arg(arg1); print_arg(arg2);
print_arg(arg3);
end;
end;
procedure put4(op: out_code; arg1,arg2,arg3,arg4: integer);
begin
if line_number then begin
write(pass4file, ord(znewline), source_line);
line_number:=false;
end;
write(pass4file,ord(op),arg1,arg2,arg3,arg4);
if test then begin
print(op); print_arg(arg1); print_arg(arg2);
print_arg(arg3); print_arg(arg4);
end;
end;
procedure put_arg1(arg1: integer);
begin
write(pass4file,arg1);
if test then print_arg(arg1);
end;
procedure put_arg2(arg1,arg2: integer);
begin
write(pass4file,arg1,arg2);
if test then begin
print_arg(arg1); print_arg(arg2);
end;
end;
procedure put_arg3(arg1,arg2,arg3: integer);
begin
write(pass4file,arg1,arg2,arg3);
if test then begin
print_arg(arg1); print_arg(arg2); print_arg(arg3);
end;
end;
procedure copy(op: out_code; no: integer);
var arg: integer;
begin
put0(op);
for i:=1 to no do begin
get(arg); put_arg1(arg);
end;
end;
procedure new_line;
begin
get(source_line);
line_number:=true;
end;
procedure out_name(name: alfa);
begin
for i:=1 to alfalength do put_arg1( ord(name[i] ) );
end;
procedure out_constant_area;
var first,p: integer;
begin
if top_c_index > top_c then top_c:=top_c_index;
first:=first_c_index;
while first<top_c_index do begin
if c[first+1]>0 then begin
put1(zdeflix,c[first+1]);
p:=c[first];
if c[first+2]>p then p:=c[first+2];
put1(zinitconst,p-3);
for i:=first+3 to first + c[first] -1 do put_arg1(c[i]);
if c[first+2] > c[first] then
for i:=1 to c[first+2] - c[first] do put_arg1(spsp);
end;
first:=first+c[first];
end;
end;
procedure out_formal_list;
var type_p,no,param_size: integer;
begin
for no:=param_number-1 downto 0 do
with nametable[stack[t-no]] do begin
with nametable[comp_type] do begin
param_size:=size;
case context of
pointer_type: type_p:=1;
sem_type: type_p:=2;
ref_type: type_p:=3;
shadow_type: type_p:=4;
pool_type: type_p:=5;
sys_record_type: type_p:=6;
sys_array_type: type_p:=7;
end
otherwise type_p:=8;
end;
if context=value_param then
type_p := type_p * 4 + 2
else
begin
if nametable[comp_type].dynamic then error(error_dyn);
type_p := type_p * 4 + 1;
end;
put2(zparamtype,type_p,param_size)
end;
end;
procedure printhead;
begin
if test then writeln;
write('*** pass 4 line ',source_line:4,', ');
end;
procedure eom; forward;
procedure compiler_error(e: error_types);
begin
printhead;
write('compiler error : ');
case e of
addr_error: writeln('addressing');
bit_count_error: writeln('bit count');
for_error: writeln('for error');
scalar_error: writeln('scalar error');
input_error: writeln('wrong input');
end
otherwise writeln(', error code = ',ord(e):1);
eom; eom;
end;
procedure pass4error(e: error_types);
begin
printhead;
case e of
overflow: writeln('overflow');
error_dyn: writeln('dynamic type not allowed');
error_dyn_init: writeln('initialize dynamic type not allowed');
error_dyn_var: writeln('dynamic variable not allowed');
not_implemented: writeln('dynamic types not implemented');
range_def_error: writeln('subrange def.');
set_def_error: writeln('set def.');
pool_def_error: writeln('pool def.');
type_error: writeln('constant value');
var_error: writeln('not constant');
range_error: writeln('case label range');
prelude_error: writeln('no init. or process in enviroment');
literal_error: writeln('constant');
set_error: writeln('set constant');
const_error: writeln('times');
address_overflow: writeln('stack');
record_size_error: writeln('record size');
array_size_error: writeln('array size');
exportvalue_error: writeln('export value error');
field_export_error: writeln('packed field export');
exportaddr_error: writeln('export offset error');
end
otherwise compiler_error(e);
end;
procedure eom;
begin
put0(zeom);
close(pass4file); close(pass3file);
done:=true;
end;
procedure error(ty: error_types);
begin
put2(zerror,this_pass,ord(ty));
program_ok:=false;
pass4error(ty);
end;
procedure abort(ty: error_types);
begin
printhead;
write('compilation terminated by ');
case ty of
operand_overflow: writeln('operand overflow');
name_overflow: writeln('name table overflow');
block_overflow: writeln('block level overflow');
const_overflow: writeln('constant area overflow');
stack_error: writeln('stack error');
version_error: writeln('wrong pass 4');
end
otherwise compiler_error(ty);
eom; eom;
end;
procedure write_nametable(top: integer);
var ch1,ch2: char;
begin
if top=0 then top:=max_name_index;
writeln;
writeln(' nix c s min max niv',
' offset lix n-c c-t pack dyn');
for i:=0 to top do
with nametable[i] do
if context<>not_used then begin
writeln('name',i:6,ord(context):4,size:5,
min,max,niv,offset,lix,next_comp:7,comp_type:7,
packed_comp:8, dynamic:8);
end;
end;
procedure write_operand_stack;
begin
writeln;
writeln('expr = ',first_of_expr:1);
writeln('ot = ',ot:1);
writeln('os = ',os:1);
if ot=empty_stack then writeln('operand stack empty')
else begin
writeln(' k niv offset size con',
' lix first f_sizepack_f pack_a state temp');
for i:=ot downto empty_stack+1 do
with ops[i] do
writeln('operand stack ',ord(kind):4,niv,offset,size,
ord(context),lix,first:7,comp_size:7,
field_packed:7,array_packed:7,ord(state):8,temp_size);
end;
end;
procedure write_name_stack;
var ch1,ch2: char; p: integer;
begin
writeln;
if t=0 then writeln('name stack empty') else
begin
writeln('name stack');
for i:=t downto 1 do begin
p:=stack[i];
writeln(i:4,' - ',p:4);
end;
end;
end;
procedure write_const_area;
var i : integer;
begin
writeln; write('const area', first_c_index, top_c_index);
for i:=1 to top_c_index do begin
if (i-1) mod 10 = 0 then begin
writeln;
write(i:6,'. ');
end;
write(c[i]:8);
end;
writeln;
end;
procedure set_option;
var p,a,b: integer;
begin
get(p); get(a); get(b);
if p=this_pass then
case a of
1: write_nametable(b);
2: write_operand_stack;
3: write_name_stack;
4: test:=b=1;
5: program_ok:=program_ok and (b=1);
6: write_const_area;
9: begin (* index check on,off *)
index_check:=b=1;
put3(zoption,5,a,b);
end;
10: test_survey:=b=1;
end
else
begin
if (p=0) and (a=3) then
if b div 100 <> versionpass3 then abort(version_error);
put3(zoption,p,a,b);
end;
end;
procedure initialize;
var code: pass3codes; p: integer; empty_name: name_rec;
empty_ops: operand_rec;
begin
for code:=xfirstcode to xlastcode do
convert_in_code[ord(code)]:=code;
(*shift_to[bit] is 2**(15-bit) *)
p:=1;
for i:=15 downto 0 do begin
shift_to[i]:=p; p:=p*2;
end;
(* all nametable entries empty *)
with empty_name do begin
context:=not_used;
size:=0; min:=0; max:=0;
niv:=0; offset:=0;lix:=0;
next_comp:=0;
comp_type:=0;
packed_comp:=false;
dynamic:=false;
end;
for i:=0 to max_name_index do nametable[i]:=empty_name;
(* init all operand stack entries to empty *)
with empty_ops do begin
kind:=not_used; niv:=0; offset:=0; size:=0;
context:=not_used;lix:=0; first:=0;
field_packed:=false;
array_packed:=false;
comp_size:=0;
state:=direct; temp_size:=0;
func_value:=false;
end;
for i:=1 to max_operand do ops[i]:=empty_ops;
reset(pass3file);
rewrite(pass4file);
source_line:=0;
line_number:=false;
top_nix:=0; top_t:=0; top_ops:=0; top_ss:=0;
top_c:=0; top_level:=0; top_lix:=0;
test_survey:=false;
index_check:=true; (* default index.yes *)
t:=0;
ss:=0;
empty_stack:=0;
os:=empty_stack;
ot:=empty_stack;
top_c_index:=1;
first_c_index:=1;
done:=false;
program_ok:=true;
test:=false;
prefixed:=false;
prefixed_name:=false;
prelude:=true;
variable_init:=false;
waiting_with:=false;
stat_part:=false;
export:=false;
mode:=process_mode;
this_level:=0;
printed:=0; idcount:=0; param_number:=0;
scalar_count:=0;
if (* **z80** *) versionz80 then begin
type_pointer:=word_typ;
activation_record_length:=12;
process_offset:=6;
current_offset:=0;
pointer_length:=word_length;
field_unite:=word_length;
end
else
begin (* **lambda** *)
type_pointer:=double_typ;
activation_record_length:=16;
process_offset:=0;
current_offset:=-1;
pointer_length:=2*word_length;
field_unite:=byte_length;
end;
process_param_length:=2*pointer_length + word_length;
current_bit:=0;
current_lix:=1;
current_niv:=0;
name_key:=1;
field_offset:=0;
first_of_expr:=ot;
max_set_const_value:=set_const_length*bits_pr_word - 1;
var_types:=[variable, var_param, value_param ];
array_types:=[array_type,sys_array_type];
index_types:=[int_type,char_type,bool_type,scalar_type];
simple_types:=[ int_type, char_type, bool_type, scalar_type, dyn_subrange ];
if (* **z80** *) versionz80 then
init_types:=[pool_type, sys_array_type, sys_record_type]
else
(* **lambda** *)
init_types:=[shadow_type,ref_type,pool_type,sem_type,
sys_array_type,sys_record_type,pointer_type];
system_types:=[shadow_type,ref_type,pool_type,sem_type,pointer_type];
indirects:=[var_param,with_var,lock_var,dyn_variable];
put3(zoption, 0, this_pass, versionpass4);
end;
procedure push;
begin
os:=ot; ot:=ot+1;
if ot > top_ops then top_ops:=ot;
if ot>max_operand then abort(operand_overflow);
ops[ot].temp_size:=source_line; (* test *)
end;
procedure pop;
begin
ot:=os;
if os>empty_stack then os:=os-1;
end;
procedure push_name(var nix: integer);
begin
get(nix);
if nix>max_name_index then abort(name_overflow);
t:=t+1;
if t > top_t then top_t:=t;
if t>max_stack then abort(name_overflow);
stack[t]:=nix;
end;
procedure push_old(nix: name_index);
begin
t:=t+1;
if t>max_stack then abort(name_overflow);
stack[t]:=nix;
end;
procedure new_name;
begin
push_name(nix);
idcount:=idcount+1;
end;
procedure new_scalar;
begin
push_name(nix);
scalar_count:=scalar_count+1;
end;
procedure word_allign; forward;
procedure push_level(m: block_mode);
begin
if this_level>=max_block_level then abort(block_overflow)
else this_level:=this_level+1;
if this_level > top_level then top_level:=this_level;
with display[this_level] do begin
saved_mode:=mode; mode:=m;
saved_niv:=current_niv;
saved_part:=stat_part; stat_part:=false;
if mode=record_mode then begin
saved_offset:=record_offset; record_offset:=0;
saved_pack:=pack_record; pack_record:=false;
saved_bit:=current_bit; current_bit:=0;
saved_chain:=chain; chain:=0;
saved_idcount:=idcount; idcount:=0;
saved_init:=init_fields; init_fields:=false;
saved_dyn:=dyn_fields; dyn_fields:=false;
end
else
begin
saved_offset:=current_offset;
if mode=process_mode then begin
current_niv:=0;
if (* **z80** *) versionz80 then
current_offset:= -process_offset
else
(* **lambda** *)
current_offset:=process_offset;
end else begin
current_niv:=current_niv+1;
if (* **z80** *) versionz80 then
current_offset:= -activation_record_length
else
(* **lambda** *)
current_offset:=activation_record_length-1;
end;
saved_v_length:=var_length; var_length:=0;
saved_c_index:=first_c_index;
first_c_index:=top_c_index;
saved_lix:=current_lix;
end;
end;
end;
procedure pop_level;
begin
with display[this_level] do begin
if mode=record_mode then begin
pack_record:=saved_pack;
current_bit:=saved_bit;
chain:=saved_chain;
idcount:=saved_idcount;
init_fields:=saved_init;
record_offset:=saved_offset;
dyn_fields:=saved_dyn;
end
else
begin
current_offset:=saved_offset;
top_c_index:=first_c_index;
first_c_index:=saved_c_index;
var_length:=saved_v_length;
if (* **z80** *) versionz80 then
current_lix:=saved_lix;
end;
mode:=saved_mode;
current_niv:=saved_niv;
stat_part:=saved_part;
end;
this_level:=this_level-1;
end;
function int_add(a,b: integer): integer;
begin
if a>=0 then begin
if max_int-a>=b then int_add:=a+b
else begin
error(overflow); int_add:=a;
end;
end else begin
if min_int-a<=b then int_add:=a+b
else begin
error(overflow); int_add:=a;
end;
end;
end;
function int_mul(a,b: integer): integer;
var s1,s2: integer;
begin
s1:=1; s2:=1;
if a<0 then begin a:=-a; s1:=-1; end;
if b<0 then begin b:=-b; s2:=-1; end;
if a<=max_int div b then int_mul:=a*b*s1*s2
else begin
error(overflow); int_mul:=a;
end;
end;
function alloc_var(size: integer): integer;
begin
if (* **z80** *) versionz80 then begin
(* current_offset <= 0 *)
if top_address + current_offset >= size then
current_offset := current_offset - size
else error(address_overflow);
alloc_var:=current_offset;
end
else
begin
(* **lambda** *)
alloc_var:=current_offset;
(* current_offset >= -1 *)
if top_address - current_offset >= size then
current_offset := current_offset + size
else error(address_overflow);
end;
end; (*alloc var*)
function address_add(a,b: integer): integer;
begin
if top_address - a >= b then address_add:=a+b
else
begin
error(address_overflow);
address_add:=a;
end;
end;
function field_add(a,b: integer): integer;
begin
if module_size - a >= b then field_add:=a+b
else
begin
error(record_size_error);
field_add:=a;
end;
end;
function take_expr: integer;
begin
with ops[ot] do begin
if context<>sconst then begin
error(var_error); take_expr:=0;
end
else
begin
if offset>max_int-1 then begin
take_expr:=max_int-1;
error(overflow);
end
else
take_expr:=offset;
end;
end;
pop;
end;
function bits(v: integer): integer;
var no,power: integer;
begin
if v<0 then no:=bits_pr_word else
if v<2 then no:=1 else
begin
power:=4; no:=2;
while v>power-1 do begin
power:=power*2;
no:=no+1;
end;
end;
if no>bits_pr_word then compiler_error(bit_count_error);
bits:=no;
end;
function var_size(min,max: integer): integer;
begin
if (min<0) or (bits(max) > bits_pr_byte) then
var_size:=word_length else
var_size:=byte_length;
end;
function check_type(ty: name_index; a,b: integer): boolean;
var bo: boolean;
begin
bo:=a<=b;
with nametable[ty] do
if (a<min) or (b>max) then bo:=false;
check_type:=bo;
end;
procedure word_allign;
begin
if not versionz80 then
(* **lambda** *)
if not odd(current_offset) then
current_offset:=address_add(current_offset,1);
end;
procedure field_allign;
begin
if not versionz80 then
(* **lambda** *)
if odd(record_offset) then
record_offset:=field_add(record_offset,1);
end;
function type_o(c: context_kind): integer;
begin
case c of
pointer_type: type_o:=pointer_typ;
sem_type: type_o:=sem_typ;
ref_type: type_o:=ref_typ;
shadow_type: type_o:=shadow_typ;
end;
end;
procedure alloc_constant(var lix: location_index;
var index: integer; bytes: integer);
var words: integer;
begin
words:=(bytes+1) div 2;
index:=top_c_index + 3;
top_c_index:=top_c_index+words+3;
if top_c < top_c_index then top_c:=top_c_index;
if top_c_index>max_const_area then abort(const_overflow);
lix:=-current_lix;
current_lix:=current_lix+1;
c[index-3]:=words + 3;
c[index-2]:=lix;
c[index-1]:=words+3;
for i:=index to top_c_index-1 do c[i]:=0;
end;
procedure cut_constant(c_index, new_words: integer);
var first: integer;
begin
first:=c_index - 3;
c[first]:=new_words+3;
top_c_index:=first+new_words+3;
c[first+2]:=c[first];
end;
procedure adjust_string(p,q: integer);
var words, i: integer;
begin
if ops[q].dynamic then error(error_dyn_var)
else
begin
ops[p].size:=ops[q].size;
words:=(ops[q].size + 1) div 2+3;
i:=ops[p].offset;
if words > c[i-1] then c[i-1]:=words;
end;
end;
procedure remove_constant(c_index: integer);
var first, q: integer;
begin
first:=c_index-3; q:=first;
if q+c[first] = top_c_index then
top_c_index:=first;
end;
procedure release_temp(s: integer);
begin
if (* **z80** *) versionz80 then
current_offset:=current_offset + s
else
(* **lambda** *)
current_offset:=current_offset - s;
end;
procedure constant_used(q: integer);
begin
with ops[q] do begin
niv:=-niv;
c[offset-2]:=niv;
if var_nix >= 0 then
nametable[var_nix].niv:=niv;
end;
end;
function alloc_temp(size: integer): integer;
begin
alloc_temp:=alloc_var(size);
if (* **z80** *) versionz80 then begin
if -current_offset > var_length then
var_length:= -current_offset;
end
else
(* **lambda** *)
if current_offset>var_length then
var_length:=current_offset;
end;
procedure alloc_dope(lix, lower, upper, elem: integer);
var index: integer;
begin
index:=top_c_index;
top_c_index:=top_c_index + 6;
if top_c_index>max_const_area then abort(const_overflow);
c[index]:=6;
c[index+1]:=lix;
c[index+2]:=6;
c[index+3]:=lower;
c[index+4]:=upper;
c[index+5]:=elem;
end;
procedure alloc_range_descr(lix, lower, upper: integer);
var index: integer;
begin
index:=top_c_index;
top_c_index:=top_c_index+5;
if top_c_index>max_const_area then abort(const_overflow);
c[index]:=5;
c[index+1]:=lix;
c[index+2]:=5;
c[index+3]:=lower;
c[index+4]:=upper;
end;
procedure std_name(ty: pass3codes);
begin
push_name(nix);
with nametable[nix] do begin
dynamic:=false;
case ty of
xinteger: begin
context:=int_type;
size:=word_length;
max:=max_int-1; min:=-max_int;
lix:=-current_lix;
current_lix:=current_lix+1;
end;
xchar: begin t:=t-1; context:=char_type; end;
xreal: ;(* not inplemented *)
xboolean: begin t:=t-1; context:=bool_type; end;
xstringtype: begin
t:=t-1;
context:=array_type;
lix:=0; size:=0;
packed_comp:=false;
end;
xsemaphore: begin
t:=t-1;
context:=sem_type;
semaphor_length:=size;
end;
xshadow: begin t:=t-1; context:=shadow_type; end;
xreference: begin
t:=t-1;
context:=ref_type;
if (* **lambda** *) not versionz80 then size:=2*pointer_length;
end;
xniltype: begin
context:=int_type;
size:=0;
end;
xerrortype: begin
t:=t-1;
undef_nix:=nix;
context:=undef_type;
size:=word_length;
end;
xundeclid: begin
t:=t-1;
nametable[nix]:=nametable[undef_nix];
end;
xchr: begin t:=t-1; niv:=-zchr-1; end;
xord: begin t:=t-1; niv:=-zord-1; end;
xpred: begin t:=t-1; niv:=-zpred-1; end;
xsucc: begin t:=t-1; niv:=-zsucc-1; end;
end;
end;
end;
procedure scalar_def;
var saved_size: integer;
begin
push_name(nix);
with nametable[nix] do begin
context:=scalar_type;
dynamic:=false;
min:=0; max:=scalar_count-1;
if max<0 then begin
compiler_error(scalar_error);
max:=0;
end;
size:=var_size(min,max);
saved_size:=size;
end;
for i:=scalar_count downto 1 do
with nametable[stack[t-i]] do begin
context:=sconst;
size:=saved_size;
offset:=scalar_count-i;
end;
t:=t-scalar_count-1;
scalar_count:=0;
push_old(nix);
end;
procedure sub_def;
var ty: integer;
begin
push_name(nix); get(ty);
if (ops[ot].context = sconst) and (ops[os].context = sconst) then
with nametable[nix] do begin
context:=nametable[ty].context;
max:=take_expr; min:=take_expr;
if not check_type(ty,min,max) then begin
error(range_def_error);
min:=0; max:=1;
end;
size:=var_size(min,max);
lix:=-current_lix; (* no range descr allocated *)
current_lix:=current_lix+1;
end
else
begin (* dynamic *)
load_expr; pop; pop;
with nametable[nix] do begin
context:=dyn_subrange;
size:=word_length;
min:=min_int; max:=max_int-1;
niv:=current_niv;
offset:=alloc_var(sub_template_size);
dynamic:=true;
put1(zsubdef, offset);
if (* **z80** *) versionz80 then begin
error(not_implemented);
dynamic:=false;
end;
end; (*with*)
end; (*dynamic*)
end;
procedure pointer_def;
begin
t:=t-1; (*skip type*)
push_name(nix);
with nametable[nix] do begin
context:=pointer_type;
size:=pointer_length;
dynamic:=false;
end;
end;
procedure redef_type;
begin
i:=stack[t]; t:=t-1;
push_name(nix);
nametable[nix]:=nametable[i];
with nametable[nix] do
if context in index_types then begin
lix:=-current_lix;
current_lix:=current_lix+1
end;
end;
procedure static_array_def(pack_array: boolean);
var lower,upper,span,array_size,bit_span,
comp_nix,fields_pr_word,elem_size: integer;
pack, init_type: boolean;
begin
pack:=pack_array;
with nametable[stack[t-1]] do begin
lower:=min; upper:=max;
span:=upper-lower+1;
end;
comp_nix:=stack[t];
with nametable[comp_nix] do begin
init_type:=context in init_types;
if (* **z80** *) versionz80 then
elem_size:=size
else
(* **lambda** *)
if odd(size) and init_type then
elem_size:=size+1 else elem_size:=size;
if pack then pack:=context in index_types;
if pack then begin
bit_span:=bits(max);
fields_pr_word:=bits_pr_word div bit_span;
if fields_pr_word>=min_fields_pr_word then begin
array_size:=(span div fields_pr_word)*2 +
((span mod fields_pr_word)*bit_span+7) div bits_pr_byte;
if (* **z80** *) versionz80 then
if odd(array_size) then array_size:=array_size + 1;
elem_size:=fields_pr_word*shift8+bit_span;
end
else pack:=false;
end;
if not pack then
begin
if elem_size<=module_size div span then array_size:=elem_size*span
else
begin
error(array_size_error);
array_size:=size;
end;
end;
end;
t:=t-2;
push_name(nix);
with nametable[nix] do begin
if init_type then
context:=sys_array_type else context:=array_type;
size:=array_size;
min:=lower; max:=upper; niv:=elem_size;
lix:=-current_lix; (* no dope vector allocated *)
current_lix:=current_lix+1;
next_comp:=comp_nix;
packed_comp:=pack;
dynamic:=false;
end;
end;
procedure array_def(pack_array: boolean);
var index_nix, comp_nix, dyn_case, bit_span, fields_pr_word,
comp_niv, comp_offset,
lower, upper, index_niv, index_offset,
allign, elem_size : integer;
pack, init_type: boolean;
begin
index_nix:=stack[t-1];
comp_nix:=stack[t];
if nametable[index_nix].dynamic then
dyn_case:=2 else dyn_case:=1;
if nametable[comp_nix].dynamic then
dyn_case:=dyn_case+2;
if nametable[comp_nix].context = dyn_subrange then
dyn_case:=dyn_case-2;
(*
index type comp type : dyn_case
static static 1
dynamic static 2
static dynamic 3
dynamic dynamic 4
*)
if dyn_case = 1 then
static_array_def(pack_array)
else
begin
pack:=false; fields_pr_word:=1; bit_span:=0;
with nametable[index_nix] do begin
lower:=min; upper:=max;
index_niv:=niv; index_offset:=offset;
end;
with nametable[comp_nix] do begin
init_type:=context in init_types;
if init_type then allign:=1 else allign:=0;
if dyn_case = 2 then begin
if (* **z80** *) versionz80 then
elem_size:=size
else
(* **lambda** *)
if odd(size) and init_type then
elem_size:=size+1 else elem_size:=size;
if pack_array then pack:=context in index_types;
if pack then begin
bit_span:=bits(max);
fields_pr_word:=bits_pr_word div bit_span;
if fields_pr_word < min_fields_pr_word then begin
fields_pr_word:=1;
pack:=false;
end;
end; (*if pack*)
end; (*dyn_case=2*)
comp_niv:=niv; comp_offset:=offset;
end; (*with*)
t:=t-2; (*pop pop namestack*)
push_name(nix);
with nametable[nix] do begin
if init_type then
context:=sys_array_type else context:=array_type;
niv:=current_niv;
offset:=alloc_var(array_template_size);
next_comp:=comp_nix;
packed_comp:=pack;
dynamic:=true;
size:=0; min:=0; max:=0; lix:=0;
case dyn_case of
2: begin
put4(zarray1template, offset,
index_niv, index_offset, elem_size);
put_arg2(fields_pr_word, bit_span);
end;
3: begin
put3(zarray2template, offset,
comp_niv, comp_offset);
put_arg3(lower, upper, allign);
end;
4: begin
put3(zarray3template, offset,
comp_niv, comp_offset);
put_arg3(index_niv, index_offset, allign);
end;
end; (*case*)
end; (*with*)
end; (*if*)
end; (*array def*)
procedure field_list;
var field_type_nix, field_size, field_nix, max_bits,
comp_niv, comp_offset, allign: integer;
allign_type, pack_field, init,dyn: boolean;
begin
pack_field:=false;
field_type_nix:=stack[t];
with nametable[field_type_nix] do begin
field_size:=size;
if pack_record and (context in index_types) then begin
if min>=0 then begin
max_bits:=bits(max);
if max_bits<bits_pr_word then
pack_field:=true;
end;
end;
init:=context in init_types;
allign_type:=init;
comp_niv:=niv; comp_offset:=offset;
dyn:=dynamic;
if context = dyn_subrange then dyn:=false;
if allign_type then allign:=1 else allign:=0;
end;
if pack_record and not pack_field then begin
if current_bit>0 then begin
record_offset:=field_add(record_offset,field_unite);
if dyn_fields then put0(zincfield);
end;
current_bit:=0;
end;
init_fields:=init_fields or init;
for i:=idcount downto 1 do begin
field_nix:=stack[t-i];
with nametable[field_nix] do begin
if pack_field then begin
if current_bit+max_bits>bits_pr_word then begin
record_offset:=field_add(record_offset,field_unite);
if dyn_fields then put0(zincfield);
current_bit:=0;
end;
size:=max_bits;
max:=max_bits;
min:=current_bit;
current_bit:=current_bit+max_bits;
if dyn_fields then begin
niv:=current_niv;
offset:=alloc_var(field_template_size);
put3(zfieldsize, 0, offset, 0);
end
else
offset:=record_offset;
if (* **lambda** *) not versionz80 then
if current_bit >= bits_pr_byte then begin
current_bit:=current_bit - bits_pr_byte;
record_offset:=field_add(record_offset,byte_length);
if dyn_fields then put0(zincfield);
end;
end else begin
if allign_type then field_allign;
if dyn_fields then begin
niv:=current_niv;
offset:=alloc_var(field_template_size);
if dyn then
put4(zdynfieldsize, allign, offset,
comp_niv, comp_offset)
else
put3(zfieldsize, allign, offset, field_size);
end
else
begin
size:=field_size; offset:=record_offset;
record_offset:=field_add(record_offset, field_size);
if dyn then
put3(zrecordtemplate, offset, comp_niv, comp_offset);
end;
end;
if dyn_fields then
context:=dyn_field else context:=field;
dyn_fields:=dyn_fields or dyn;
packed_comp:=pack_field;
if pack_field then
if size=bits_pr_byte then
if (min=0) or (min=8) then begin
packed_comp:=false;
size:=byte_length;
if (* **z80** *) versionz80 then begin
if min=0 then offset:=offset+1
end
else
(* **lambda** *)
if min=8 then offset:=offset+1
end;
if init then begin
next_comp:=chain; chain:=field_nix;
comp_type:=field_type_nix;
end;
end;
end;
t:=t-idcount-1; idcount:=0;
end;
procedure record_def;
begin
push_name(nix);
with nametable[nix] do begin
if pack_record then begin
if current_bit>0 then begin
record_offset:=field_add(record_offset,field_unite);
if dyn_fields then put0(zincfield);
end;
end;
dynamic:=dyn_fields;
if dyn_fields then begin
niv:=current_niv;
offset:=alloc_var(record_template_size);
put1(zendtemplate, offset);
size:=0;
end
else
size:=record_offset;
if init_fields then begin
context:=sys_record_type;
next_comp:=chain;
end else
context:=record_type;
end;
pop_level;
end;
procedure set_def;
var lower,upper,words: integer;
begin
with nametable[stack[t]] do begin
lower:=min; upper:=max;
if dynamic then begin
error(error_dyn);
lower:=0; upper:=1;
end;
words:=((upper+1+bits_pr_word-1) div bits_pr_word);
end;
t:=t-1;
if lower<0 then begin
error(set_def_error); lower:=0;
end;
if words=0 then words:=1;
push_name(nix);
with nametable[nix] do begin
context:=set_type;
min:=lower; max:=upper;
size:=words*2;
dynamic:=false;
end;
end;
procedure pool_def;
var data_size: integer;
begin
with nametable[stack[t]] do begin
data_size:=size;
if dynamic then begin
error(error_dyn);
data_size:=0;
end;
end;
t:=t-1;
push_name(nix);
with nametable[nix] do begin
context:=pool_type;
size:=semaphor_length;
min:=take_expr;
if min<=0 then begin
error(pool_def_error); min:=1;
end;
max:=data_size;
dynamic:=false;
end;
end;
procedure routine_def(m: block_mode);
begin
push_name(nix);
with nametable[nix] do begin
context:=routine_type;
niv:=current_niv;
lix:=current_lix;
current_lix:=current_lix+1;
end;
push_level(m);
idcount:=0; param_number:=0;
head_line:=source_line;
end;
procedure process_def;
var ty: integer;
begin
get(nix); (*skip nix*)
push_name(nix); get(ty);
with nametable[nix] do
begin
context:=variable;
offset:=alloc_var(nametable[ty].size);
niv:=current_niv;
end;
push_level(process_mode);
idcount:=0; param_number:=0;
head_line:=source_line;
end;
procedure exception_def;
begin
push_name(nix); t:=t-1;
if (* **lambda** *) not versionz80 then
with nametable[nix] do
if niv<0 then begin
put1(zextexception, offset); (* offset is name key *)
end else
put2(zexception,niv,lix);
end;
procedure formal_param(c: context_kind);
var type_nix, parm_size, byte_displ: integer;
begin
type_nix:=stack[t];
if c = value_param then
with nametable[type_nix]do begin
parm_size:=size;
if dynamic then begin
error(error_dyn);
parm_size:=0;
end;
end
else
parm_size:=pointer_length;
byte_displ:=0;
if (* **z80** *) versionz80 then begin
if parm_size=byte_length then parm_size:=word_length;
end else
begin
(* **lambda** *)
if nametable[type_nix].context in index_types then
if parm_size=byte_length then byte_displ:=1;
if odd(parm_size) then parm_size:=parm_size+1;
end;
for i:=idcount downto 1 do
with nametable[stack[t-i]] do begin
context:=c;
niv:=current_niv;
offset:=alloc_var(parm_size);
offset:=offset+byte_displ;
comp_type:=type_nix;
end;
param_number:=param_number+idcount;
idcount:=0; t:=t-1;
end;
procedure name;
var p,q,ch: integer; na: alfa;
begin
get(p); q:=0; na:=' ';
if p>alfalength then begin
q:=p; p:=alfalength;
end;
for i:=1 to p do begin
get(ch);
na[i]:=chr(ch);
end;
if q>0 then
for i:=p+1 to q do get(ch);
if prefixed_name then begin
prefix_name:=na;
prefixed_name:=false;
end
else
ext_name:=na;
end;
procedure new_block;
var op: out_code; parameter_length: integer;
begin
if (* **z80** *) versionz80 then
parameter_length:= - current_offset
else
(* **lambda** *)
parameter_length:=current_offset+1;
display[this_level].parameter_length:=parameter_length;
get(i); (*skip*)
case mode of
proc_mode, func_mode: begin
with nametable[stack[t-param_number]] do begin
if prefixed then begin
put0(zmodule); out_name(prefix_name);
put_arg1(param_number);
out_formal_list;
prefixed:=false;
end;
size:=parameter_length-activation_record_length;
if mode=proc_mode then op:=zproc else op:=zfunc;
put1(op,lix);
out_name(ext_name);
put_arg1(parameter_length);
put1(zblock,current_niv);
end;
end;
process_mode: begin
with nametable[stack[t-param_number]] do begin
put1(zprocess,offset); out_name(ext_name);
put_arg2(parameter_length,param_number);
end;
out_formal_list;
put1(zblock, 0);
end;
end;
t:=t-param_number-1; param_number:=0;
var_length:=0;
end;
procedure external_;
var op: out_code; not_std: boolean;
begin
not_std:=true;
case mode of
proc_mode, func_mode:
with nametable[stack[t-param_number]] do begin
not_std:=niv>=0;
if (* **z80** *) versionz80 then
size:= - current_offset - activation_record_length
else
(* **lambda** *)
size:=current_offset+1-activation_record_length;
if not_std then begin
niv:=-1;
if mode=proc_mode then op:=zextproc else op:=zextfunc;
put1(op, name_key); out_name(ext_name);
offset:=name_key;
name_key:=name_key+1;
end;
end;
process_mode:
if prelude then error(prelude_error)
else
with nametable[stack[t-param_number]] do
begin put1(zextprocess,offset); out_name(ext_name); end;
end;
if not_std then begin
put_arg1(param_number); out_formal_list;
end;
pop_level;
t:=t-param_number-1; param_number:=0;
end;
procedure forward_;
begin
with nametable[stack[t-param_number]] do
size:=current_offset;
pop_level;
t:=t-param_number-1; param_number:=0;
idcount:=0;
end;
procedure previous_forward(m: block_mode);
begin
push_level(m);
param_number:=0;
push_name(nix);
current_offset:=nametable[nix].size;
head_line:=source_line;
end;
procedure end_block;
var l,i: integer;
begin
if (* **z80** *) versionz80 then
var_length:=var_length - display[this_level].parameter_length
else
begin
(* **lambda** *)
var_length:=var_length+1-display[this_level].parameter_length;
end;
if odd(var_length) then var_length:=var_length+1;
put1(zlength,var_length);
out_constant_area;
l:=current_lix - 1;
if l > top_lix then top_lix:=l;
pop_level;
if this_level=0 then begin
out_constant_area;
if test_survey then begin
top_nix:=0;
for i:=0 to max_name_index do
if nametable[i].context<>not_used then top_nix:=top_nix+1;
writeln(' 4. ', top_nix:5, top_t:5, top_ops:5, top_ss:5,
top_c:5, top_level:5, top_lix:5);
end;
if (ot<>empty_stack) or (t<>0) or (ss<>0) then abort(stack_error);
for i:=0 to max_name_index do
with nametable[i] do
if lix > 0 then
lix:=-lix; (*mark the name as unused *)
end;
put2(zendblock, current_lix, l);
end;
procedure begin_code;
begin
if ops[ot].context <> sconst then error(var_error);
put1(zbegincode,ops[ot].offset);
pop;
end;
procedure code_line;
var i,no,ch: integer;
begin
get(no);
put1(zcodeline,no);
for i:=1 to no do begin
get(ch);
put_arg1(ch);
end;
end;
procedure init_values(nix,vniv,voffset: integer);
var varvalue,typ: integer;
begin
if prelude then error(prelude_error);
with ops[ot] do if context=struc_c then context:=lconst;
with nametable[nix] do
if context in simple_types then begin
if ops[ot].context<>sconst then
error(var_error) else
begin
varvalue:=ops[ot].offset;
if (varvalue<min) or (varvalue>max) then
error(type_error) else
begin
if varvalue>max_int-1 then error(overflow);
put0(zinitialize); put2(zaddr,vniv,voffset);
if context=bool_type then typ:=bool_typ
else if size=word_length then typ:=int_typ
else typ:=scalar_typ;
put2(zsimpleinit,typ,varvalue);
end
end;
end else
if ops[ot].context=lconst then begin
if ops[ot].niv<0 then constant_used(ot);
put0(zinitialize); put2(zaddr,vniv,voffset);
put2(zstrucinit,size,ops[ot].niv);
end else
if ops[ot].context=set_const then begin
if ops[ot].niv<0 then constant_used(ot);
put0(zinitialize); put2(zaddr,vniv,voffset);
put3(zsetinit,size,ops[ot].niv,ops[ot].size);
end
else error(var_error);
end;
procedure component_init(type_nix: integer);
var field_nix, w_offset,s: integer;
begin
with nametable[type_nix] do
if context = sys_record_type then begin
field_nix:=next_comp;
while field_nix <> 0 do
with nametable[field_nix] do begin
if context = field then
put1(zfieldinit, offset)
else
put2(zdynfieldinit, niv, offset);
component_init(comp_type);
field_nix:=next_comp;
end; (*with*)
put0(zendinitfields);
end (*record*)
else
if context = sys_array_type then begin
w_offset:=alloc_temp(word_length);
s:=nametable[next_comp].size;
if (* **lambda** *) not versionz80 then
if odd(s) then s:=s+1;
if dynamic then
put3(zarraydyninit, w_offset, niv, offset)
else
put4(zarrayinit, w_offset, min, max, s);
component_init(next_comp);
release_temp(word_length);
end (*array*)
else
if context = pool_type then
put2(zpoolinit, min, max)
else
if (* **z80** *) versionz80 then
compiler_error(addr_error)
else
(* **lambda** *)
put1(zvarinit, type_o(context));
end; (*component init*)
procedure system_init(type_nix, voffset: integer);
begin
with nametable[type_nix] do begin
if dynamic then
put1(zsysdyninit, voffset)
else
put1(zsysinit, voffset);
end;
component_init(type_nix);
end; (*system init*)
procedure var_list;
var type_nix, var_size, type_niv, type_offset: integer;
init, allign, dyn: boolean;
begin
type_nix:=stack[t];
with nametable[type_nix] do begin
var_size:=size;
allign:=context in init_types;
init:= allign and not prelude;
type_niv:=niv; type_offset:=offset;
dyn:=dynamic;
if context = dyn_subrange then dyn:=false;
end;
for i:=idcount downto 1 do
with nametable[stack[t-i]] do begin
if dyn then begin
context:=dyn_variable;
niv:=current_niv;
offset:=alloc_var(pointer_length);
put3(zallocdynvar, offset, type_niv, type_offset);
end
else
begin
if allign then word_allign;
context:=variable;
niv:=current_niv;
offset:=alloc_var(var_size);
end;
if variable_init then begin
if dyn then error(error_dyn_init)
else
init_values(type_nix, niv, offset);
end;
if init then system_init(type_nix, offset);
end;
t:=t-idcount-1; idcount:=0;
if variable_init then pop; (*init value*)
variable_init:=false;
end;
procedure end_export;
var typ, val: integer;
begin
with ops[ot] do begin
if field_packed then error(field_export_error);
case export_kind of
exportvalue: begin
if context<>sconst then error(exportvalue_error);
typ:=value_type;
val:=offset;
end;
exportsize: begin
typ:=value_type;
val:=size;
end;
exportdispl: begin
typ:=value_type;
val:=field_offset;
end;
exportaddr,
exportoffset: begin
if not ( context in var_types ) then error(exportaddr_error);
if export_kind=exportaddr then
typ:=offset_type else typ:=value_type;
val:=offset+field_offset;
end;
end;(*case*)
end;(*with*)
put0(zexport); out_name(ext_name);
put_arg2(typ, val);
pop;
export:=false;
field_offset:=0;
end;(*end export*)
procedure new_label;
begin
push_name(nix);
with nametable[nix] do begin
context:=label_type;
lix:=current_lix;
current_lix:=current_lix+1;
end;
t:=t-1;
end;
procedure const_def;
begin
push_name(nix);
with ops[ot] do begin
if context=struc_c then context:=lconst;
if (context<>sconst) and (context<>lconst) and (context<>set_const) then begin
error(var_error);
context:=sconst; size:=0; niv:=0;
offset:=0;
end;
end;
with nametable[nix] do begin
context:=ops[ot].context;
size:=ops[ot].size;
niv:=ops[ot].niv;
offset:=ops[ot].offset;
if offset>max_int-1 then begin
offset:=max_int-1;
error(overflow);
end;
end;
pop;
t:=t-1;
end;
procedure load_var(op: out_code);
var load_type: integer;
begin
with ops[ot] do begin
if kind in simple_types then begin
if field_packed then
put3(op, field_typ,first, comp_size)
else
begin
if size=byte_length then load_type:=byte_typ else
load_type:=word_typ;
put1(op,load_type);
end
end
else
if kind=pointer_type then put1(op,type_pointer)
else
if kind=set_type then begin
put2(op,set_typ,size);
end
else
begin
if dynamic then
with nametable[type_nix] do
put3(op, dyn_typ, niv, offset)
else
put2(op, addr_typ, size);
end;
end;
end;
procedure get_pushed_consts;
var p: integer; stop: boolean;
begin
p:=ot;
repeat
p:=p-1;
if p>first_of_expr then
begin
with ops[p] do if context=struc_c then context:=lconst;
stop:= (ops[p].context <> sconst) and (ops[p].context <> lconst)
end
else stop:=true;
until stop;
for i:=p+1 to ot-1 do
with ops[i] do begin
if context=sconst then begin
if offset>max_int-1 then error(overflow);
put1(zconst,offset);
if size=byte_length then size:=word_length;
end
else begin
if niv<0 then constant_used(i);
put2(zlconst,niv,size);
end;
state:=expression; context:=expr;
end;
end;
procedure address;
begin
get_pushed_consts;
with ops[ot] do if context=struc_c then context:=lconst;
with ops[ot] do begin
case state of
direct: if context=lconst then
begin
if niv<0 then constant_used(ot);
put1(zcaddr,niv);
end
else
if (context=sconst) or (context=set_const) then begin
compiler_error(addr_error);
put2(zaddr,0,0);
end else
put2(zaddr,niv,offset);
indirect: begin
put2(zaddr,niv,offset); put0(zindaddr);
end;
addr, p_comp: ;
expression: compiler_error(addr_error);
end;
state:=addr; context:=expr;
end;
end;
procedure load_operand;
begin
if ( ops[ot].context<>sconst ) and
( ops[ot].context<>struc_c) and
(ops[ot].context<>lconst ) then begin
get_pushed_consts;
with ops[ot] do begin
case state of
direct: if context=set_const then
begin
if niv<0 then constant_used(ot);
put2(zsetconst,niv,size);
end
else
begin put2(zaddr, niv, offset); load_var(zindvar); end;
indirect: begin
put2(zaddr,niv,offset); put0(zindaddr);
load_var(zindvar);
end;
addr: load_var(zindvar);
expression, p_comp: ;
end; (*case*)
if kind in index_types then
if size=byte_length then size:=word_length;
state:=expression; context:=expr;
end; (*with*)
end; (*if*)
end;
procedure load_expr;
begin
with ops[ot] do begin
if context=struc_c then context:=lconst;
if (context=lconst) or (context=set_const) then
if niv<0 then constant_used(ot);
if context=sconst then begin
if offset>max_int-1 then error(overflow);
put1(zconst,offset);
end
else
if context=lconst then put2(zlconst,niv,size)
else
if context=set_const then put2(zsetconst,niv,size)
else
load_operand;
if size=byte_length then size:=word_length;
state:=expression; context:=expr;
end;
end;
procedure pass_expr(op: out_code);
begin
load_expr; pop;
put0(op);
end;
procedure pass_addr(op: out_code);
begin
address; pop;
put0(op);
end;
procedure arithmetic(op: out_code);
var f,typ: integer;
begin
if ( ops[ot].context=sconst ) and
( ops[os].context=sconst ) then begin
f:=ops[ot].offset; pop;
with ops[ot] do begin
case op of
zand: if (offset=1) and (f=1) then offset:=1 else offset:=0;
zor: if (offset=0) and (f=0) then offset:=0 else offset:=1;
zxor: if offset = f then offset := 0 else offset := 1;
zadd: offset:=int_add(offset,f);
zsub: offset:=int_add(offset,-f);
zmul: offset:=int_mul(offset,f);
zdiv: offset:=offset div f;
zmod: offset:=offset mod f;
end;
end;
end
else
begin
load_expr;
pop;
with ops[ot] do begin
case kind of
bool_type: typ:=bool_typ;
set_type: typ:=setof_typ;
end
otherwise typ:=int_typ;
put0(op);
if (op=zmul) or (op=zadd) or (op=zsub) then
put_arg1(typ);
if size=byte_length then size:=word_length;
context:=expr; state:=expression;
end;
end;
end;
procedure neg_not(op: out_code);
var typ : integer;
begin
with ops[ot] do
if context=sconst then begin
case op of
zneg: offset:=-offset;
znot: if offset=0 then offset:=1 else offset:=0;
end;
end
else begin
load_operand;
with ops[ot] do begin
put0(op);
if op = znot then begin
if kind = bool_type then typ := bool_typ else typ:=int_typ;
put_arg1(typ);
end;
if size=byte_length then size:=word_length;
context:=expr; state:=expression;
end;
end;
end;
procedure equality(op: integer);
var f,q,n,op1,p,op1_size,op2_size,last,n1: integer;
bo, remove1, remove2: boolean;
begin
if (ops[ot].context=sconst) and
(ops[os].context=sconst) then begin
f:=ops[ot].offset; pop;
with ops[ot] do begin
case op of
zne: bo:=offset<>f;
zeq: bo:=offset=f;
zle: bo:=offset<=f;
zge: bo:=offset>=f;
zlt: bo:=offset<f;
zgt: bo:=offset>f;
end; (*case*)
if bo then offset:=1 else offset:=0;
kind:=bool_type; size:=word_length;
end; (*with*)
end
else
begin
remove1:=ops[ot].context=struc_c;
if remove1 then ops[ot].context:=lconst;
remove2:=ops[os].context=struc_c;
if remove2 then ops[os].context:=lconst;
if ((op=zne) or (op=zeq)) and
(ops[ot].context=lconst) and
(ops[os].context=lconst) then begin
op1_size:=ops[os].size;
op2_size:=ops[ot].size;
n:=op1_size;
if n>op2_size then n:=op2_size;
n1:=n;
p:=ops[ot].offset; pop;
with ops[ot] do begin
n:=(n+1) div 2 -1; q:=offset;
bo:=true;
for i:=0 to n do
bo:=bo and (c[i+p]=c[i+q]);
if op1_size>op2_size then begin
for i:=n to (op1_size+1)div 2 - 1 do bo:=bo and (c[i+q]=spsp);
end
else
if op2_size>op1_size then begin
for i:=n to (op2_size+1)div 2 - 1 do bo:=bo and (c[i+p]=spsp);
end;
case op of
zeq: if bo then offset:=1 else offset:=0;
zne: if bo then offset:=0 else offset:=1;
end;
kind:=bool_type; size:=word_length;
context:=sconst;
end; (*with*)
if remove1 then remove_constant(p);
if remove2 then remove_constant(q);
end
else begin
with ops[ot] do
if (kind=array_type) and (context=lconst) then adjust_string(ot,os);
with ops[os] do
if (kind=array_type) and (context=lconst) then adjust_string(os,ot);
load_expr; pop;
with ops[ot] do
case kind of
int_type,char_type,bool_type,scalar_type:
put1(zcompare,op);
pointer_type, array_type, record_type, sys_array_type, sys_record_type:
begin
if op=zeq then op1:=zeq_struc
else op1:=zne_struc;
if dynamic then
with nametable[type_nix] do
put3(zcompdynstruc, op1, niv, offset)
else
put2(zcompstruc,op1,size);
end;
set_type: begin
case op of
zeq: op1:=zeq_set;
zne: op1:=zne_set;
zle: op1:=zle_set;
zge: op1:=zge_set;
end;
put1(zcompare,op1);
end;
end otherwise compiler_error (var_error);
with ops[ot] do begin
kind:=bool_type; size:=word_length;
context:=expr; state:=expression;
end;
end;
end
end;
procedure inclusion;
begin
if stat_part then begin
load_expr; pop;
with ops[ot] do begin
put1(zcompare,zin);
kind:=bool_type; size:=word_length;
context:=expr; state:=expression;
end;
end else begin
error(var_error);
pop;
end;
end;
procedure range;
var a,b: integer; dyn : boolean;
begin
get(nix);
with nametable[nix] do begin
a:=min; b:=max; dyn:=dynamic;
end;
if dyn then begin
if ops[ot].context = sconst then begin
push; get_pushed_consts; pop;
end;
load_operand;
if index_check then
with nametable[nix] do
put2(zdynrangetest, niv, offset+2);
end
else
with ops[ot] do
if context=sconst then begin
if (offset<a) or (offset>b) then begin
error(type_error); offset:=a;
end;
end else begin
load_operand;
if index_check then
with nametable[nix] do begin
if lix<0 then begin
lix:=-lix;
alloc_range_descr(lix,min,max);
end;
put1(zrangetest,lix);
end;
end;
end;
procedure func_call;
var p,q,result_size,std,alloc_size: integer;
begin
push;
get_pushed_consts;
get(nix); std:=0;
with nametable[nix] do
if niv<0 then begin (*external or std function *)
std:=-niv-1;
if niv=-1 then begin
put1(zextfunccall, offset); (* offset = name key *)
end else put1(zstdfunccall, std );
end
else put2(zfunccall,niv,lix);
push_name(nix); t:=t-1;
get(p);
if std>0 then
begin
case std of
zsucc: put_arg1(nametable[p].max);
zpred: put_arg1(nametable[p].min);
end;
end;
with nametable[nix] do begin
with nametable[p] do begin
result_size:=size;
if dynamic and (context<>dyn_subrange) then error(error_dyn);
end;
context:=func_result;
niv:=current_niv;
if (* **z80** *) versionz80 then begin
if result_size=byte_length then
alloc_size:=result_size+1 else alloc_size:=result_size;
end
else
(* **lambda** *)
if odd(result_size) then
alloc_size:=result_size+1 else alloc_size:=result_size;
q:=alloc_temp(alloc_size);
offset:=q;
end;
with ops[ot] do begin
type_nix:=p;
var_nix:=nix;
kind:=nametable[p].context;
niv:=current_niv; context:=func_result;
offset:=q; size:=result_size;
lix:=nametable[p].lix;
array_packed:=nametable[p].packed_comp;
field_packed:=false;
func_value:=std=0;
state:=direct;
temp_size:=alloc_size;
dynamic:=false;
end;
end;
procedure end_func_call;
begin
if ops[ot].func_value then begin
load_operand;
end
else
with ops[ot] do begin
if size=byte_length then size:=word_length;
state:=expression; context:=expr;
end;
put0(zendfunccall);
release_temp(ops[ot].temp_size);
end;
procedure proc_call;
begin
get(nix);
with nametable[nix] do
if niv<0 then begin (* external *)
put1(zextproccall, offset); (* offset = name_key *)
end
else put2(zproccall,niv,lix);
end;
procedure actual;
begin
get(nix); push;
with nametable[nix] do begin
ops[ot].dynamic := false;
ops[ot].type_nix:=comp_type;
ops[ot].var_nix:=nix;
ops[ot].kind:=nametable[comp_type].context;
ops[ot].size:=nametable[comp_type].size;
ops[ot].context:=context; (*save parameter type*)
case context of
var_param: put0(zvarparam);
value_param: begin
put0(zvalueparam);
with nametable[comp_type] do
case context of
int_type, char_type, bool_type, scalar_type: put_arg1(word_typ);
pointer_type: put_arg1(type_pointer);
set_type: put_arg2(set_typ,size);
end
otherwise put_arg2(addr_typ,size);
end;
end;
end;
end;
procedure end_actual;
begin
with ops[ot] do begin
if context=struc_c then context:=lconst;
if (context=lconst) and (kind=array_type) then
if ops[os].size<>size then adjust_string(ot,os);
end;
with ops[os] do
case context of
value_param: load_expr;
var_param: address;
end;
pop; (* expr or addr *)
pop; (* saved parameter type *)
end;
procedure label_goto(op: out_code);
begin
get(nix);
with nametable[nix] do put1(op,lix);
end;
procedure becomes;
begin
address;
with ops[ot] do
if (kind=ref_type) or (kind=shadow_type) then
put1(zleft,type_pointer)
else
if field_packed then
put3(zleft,field_typ,first,comp_size)
else
load_var(zleft);
end;
procedure assign;
begin
with ops[ot] do begin
if context=struc_c then context:=lconst;
if (kind=array_type) and (context=lconst) then adjust_string(ot,os);
end;
load_expr; (* right hand side *)
pop; (*right hand side*)
pop; (*left hand side*)
put0(zassign);
end;
procedure case_label;
begin
with ops[ot] do
if context=sconst then begin
if offset>max_int-1 then error(overflow);
put1(zcaselabel,offset);
end
else begin
error(var_error); put1(zcaselabel,0);
end;
pop;
end;
procedure caserange;
var last,first: integer;
begin
if (ops[ot].context<>sconst) or (ops[os].context<>sconst) then
begin
error(var_error); last:=0; first:=0;
end else begin
first:=ops[os].offset;
last:=ops[ot].offset;
if last>max_int-1 then error(overflow);
end;
pop; pop;
if last<first then
begin first:=last; error(range_error); end;
put2(zcaserange,first,last);
end;
procedure for_;
var load_type,temp: integer;
begin
address; (*control var addr*)
with ops[ot] do begin (*push temp control var*)
if kind in simple_types then begin
if size=byte_length then load_type:=byte_typ
else load_type:=word_typ;
end
else compiler_error(for_error);
kind:=pointer_type;
context:=variable;
niv:=current_niv;
size:=pointer_length;
offset:=alloc_temp(size);
temp:=alloc_temp(word_length);
state:=indirect;
put3(zleftfor,offset,temp,load_type);
end;
end;
procedure up_down(mode: integer);
begin
load_expr; pop; (*load from expr value*)
ops[ot].lix:=mode; (*set mode in temp control var addr*)
put0(zforstore);
end;
procedure for_do;
var m:integer;
begin
load_expr; pop; (*load to expression value*)
with ops[ot] do begin
if lix=1 then m:=zup else m:=zdown;
end;
put1(zdo,m); pop;
end;
procedure end_for;
var m: integer;
begin
put0(zendfor);
release_temp(pointer_length+word_length);
end;
procedure with_;
begin
put0(zwithstat);
waiting_with:=false;
end;
procedure with_var_;
begin
if waiting_with then
with ops[ot] do begin
get(nix);
nametable[nix].context:=context;
nametable[nix].niv:=niv;
nametable[nix].offset:=offset;
waiting_with:=false;
end
else
begin
push_name(nix); t:=t-1;
with nametable[nix] do begin
context:=with_var;
niv:=current_niv;
offset:=alloc_temp(pointer_length);
put1(zwithvar,offset);
end;
end;
end;
procedure end_with;
begin
with ops[ot] do
if state=addr then begin
put0(zendwith);
release_temp(pointer_length);
end;
pop;
end;
procedure lock_var_;
begin
stat_part:=false;
push_name(nix);
address; pop;
end;
procedure lock_type;
var type_size, type_niv, type_offset : integer;
dyn : boolean;
begin
with nametable[ stack[t] ] do begin
type_size:=size;
dyn:=dynamic;
type_niv:=niv;
type_offset:=offset;
end;
t:=t-1;
with nametable[stack[t]] do begin
context:=lock_var;
niv:=current_niv;
offset:=alloc_temp(pointer_length);
if dyn then
put3(zlockdynvar, type_niv, type_offset, offset)
else
put2(zlockvar, type_size, offset);
end;
t:=t-1;
stat_part := true;
end;
procedure end_lock;
begin
put0(zendlock);
release_temp(pointer_length);
end;
procedure chan_var;
var temp: integer;
begin
address; pop;
put0(zchanvar);
end;
procedure end_channel;
begin
put0(zendchannel);
end;
procedure var_pointer;
begin
get(nix);
with nametable[nix] do
put2(zvarpointer,niv,offset);
push_name(nix);
with nametable[nix] do begin
context:=variable;
niv:=current_niv;
offset:=alloc_temp(pointer_length);
put_arg1(offset);
end;
end;
procedure tempointer;
var p: integer;
begin
p:=alloc_temp(pointer_length);
put1(ztempointer,p);
end;
procedure arglist_size;
var p: integer;
begin
p:=alloc_temp(word_length);
put1(zarglistsize,p);
if (* ***z80** *) versionz80 then
nametable[ stack[ t] ].offset:=p;
t:=t-1; (* pop name stack *)
end;
procedure end_proc;
var i,n: integer;
begin
put0(zendpcall);
get(n); (* number of process param lists*)
for i:=1 to n do begin
release_temp(process_param_length);
put0(zendprocessparam);
end;
end;
procedure end_func;
var i,n: integer;
begin
put0(zfcall);
get(n); (* number of process param lists *)
for i:=1 to n do
with ops[ot] do begin
temp_size:=temp_size + process_param_length;
put0(zendprocessparam);
end;
end;
procedure var_ref;
begin
get(nix);
with nametable[nix] do begin
ops[ot].var_nix:=nix;
ops[ot].context:=context;
if context=lconst then ops[ot].size:=size;
ops[ot].niv:=niv;
ops[ot].offset:=offset;
ops[ot].first:=min;
ops[ot].comp_size:=max;
if (context <> field) and (context <> dyn_field) then
ops[ot].field_packed:=false
else
ops[ot].field_packed:=packed_comp;
end;
end;
procedure type_ref;
begin
get(nix);
with nametable[nix] do begin
ops[ot].type_nix:=nix;
ops[ot].kind:=context;
ops[ot].lix:=lix;
if ops[ot].context<>lconst then
ops[ot].size:=size;
if context <> array_type then
ops[ot].array_packed:=false
else
ops[ot].array_packed:=packed_comp;
ops[ot].dynamic:=dynamic;
end;
end;
procedure var_;
begin
push;
var_ref; type_ref;
with ops[ot] do begin
if context in indirects then
state:=indirect else state:=direct;
end;
end;
procedure field_;
var c: context_kind; p: integer;
begin
if export then
with ops[ot] do begin
c:=context; p:=offset;
var_ref; type_ref;
if context <> field then error(error_dyn);
context:=c;
field_offset:=field_offset+offset;
offset:=p;
end
else
begin
if waiting_with then with_;
address;
var_ref; type_ref;
with ops[ot] do begin
if context = field then
put1(zfield, offset)
else
put2(zdynfield, niv, offset);
state:=addr;
end;
end;
end;
procedure arrow;
begin
if waiting_with then with_;
address;
put0(zindaddr);
ops[ot].state:=addr;
type_ref;
end;
procedure index_expr;
begin
if waiting_with then with_;
address;
with ops[ot] do
if array_packed then put0(zpackedarr)
else put0(zindexexpr);
end;
procedure index;
var nix, e: integer; pa : boolean;
begin
load_expr; (*load index value*)
pop; (*index value*)
get(nix); (* array type nix *)
with nametable[nix] do begin
if dynamic then
put2(zindex, niv, offset+2)
else
begin
if lix < 0 then begin (* alloc dope vector *)
lix:=-lix;
alloc_dope(lix, min, max, niv);
end;
put1(zcindex, lix);
end;
pa:=packed_comp;
end;
type_ref;
if pa then
with ops[ot] do begin
state:=p_comp; size:=word_length;
end;
end;
procedure literal;
var ty,l,clix,c_index,ch1,ch2,ch,val,base: integer;
begin
get(ty); get(l);
case ty of
string_const: begin
alloc_constant(clix,c_index,l);
for i:=c_index to c_index+l div 2-1 do begin
get(ch1); get(ch2);
if (* **z80** *) versionz80 then
c[i]:=ch2*shift8 + ch1
else
(* **lambda** *)
c[i]:=ch1*shift8+ch2;
end;
if l mod 2 <> 0 then begin
get(ch);
i:=c_index + l div 2;
if (* **z80** *) versionz80 then
c[i]:=ord(' ')*shift8 + ch
else
(* **lambda** *)
c[i]:=ch*shift8+ord(' ');
end;
push;
with ops[ot] do begin
var_nix:=-1;
type_nix:=-1;
kind:=array_type; niv:=clix;
offset:=c_index; size:=l;
context:=struc_c; state:=direct;
dynamic:=false;
end;
end;
char_const: begin
get(ch);
push;
with ops[ot] do begin
type_nix:=-1;
var_nix:=-1;
kind:=char_type;
offset:=ch; size:=char_length;
context:=sconst; state:=direct;
dynamic:=false;
end;
end;
num_const: begin
get(ch); val:=0; base:=10;
if ch=ord("#") then begin
get(ch); l:=l-2;
if ch=ord("b") then base:=2
else if ch=ord("o") then base:=8
else if ch=ord("h") then base:=16
else error(literal_error);
get(ch);
end;
for i:=1 to l do begin
if ch<=ord("9") then ch:=ch-ord("0")
else if ch>=ord("a") then ch:=ch-ord("a")+10;
if (ch<0) or (ch>=base) then begin
error(literal_error);
ch:=0;
end;
if base=10 then
val:=int_add(int_mul(val,base),ch)
else
begin
val:=val*base+ch;
if val div shift16 <> 0 then begin
error(literal_error);
val:=0;
end;
end;
if i<l then get(ch);
end;
if base<>10 then
if val>max_int then val:=val + bit_0_8;
push;
with ops[ot] do begin
type_nix:=-1;
var_nix:=-1;
kind:=int_type; offset:=val;
context:=sconst; state:=direct;
size:=word_length;
dynamic:=false;
end;
end;
end;
end;
procedure new_set;
begin
push;
get_pushed_consts;
if stat_part then begin
put0(zset);
with ops[ot] do begin
kind:=set_type; context:=expr;
size:=0;
state:=expression;
end
end
else
begin
with ops[ot] do begin
kind:=set_type;
size:=set_const_length*2;
alloc_constant(niv,offset,size);
context:=set_const; first:=0;
state:=direct;
dynamic:=false;
end;
end;
end;
procedure set_bit(no: integer); forward;
procedure set_expr;
begin
if stat_part then begin
load_expr; pop;
put0(zsetexpr);
end;
end;
procedure include_int;
var min,max: integer;
begin
if stat_part then begin
load_expr; pop;
put0(zincludeint);
end else begin
max:=take_expr; min:=take_expr;
if (min<0) or (min>max_set_const_value) then begin
error(set_error);
min:=0;
end;
if (max>max_set_const_value) then begin
error(set_error);
max:=min;
end;
for i:=min to max do set_bit(i);
end;
end;
procedure include;
var v: integer;
begin
if stat_part then begin
load_expr; pop;
put0(zinclude);
end else begin
v:=take_expr;
if (v<0) or (v>max_set_const_value) then begin
error(set_error);
v:=0;
end;
set_bit(v);
end;
end;
procedure set_bit(no: integer);
var bit,word: integer;
begin
bit:=no mod bits_pr_word;
word:=ops[ot].offset + no div bits_pr_word;
if ( c[word] div shift_to[bit] ) mod 2 = 0 then
c[word]:=c[word] + shift_to[bit];
with ops[ot] do
if first<no then first:=no;
end;
procedure end_set;
var words: integer;
begin
get(nix);
if stat_part then
put0(zendset)
else
with ops[ot] do begin
(* offset is index in c -- first is max value of expr *)
words:=(first + 1 + bits_pr_word - 1) div bits_pr_word;
if words=0 then words:=1;
size:=words*2;
cut_constant(offset,words);
with nametable[nix] do begin
context:=set_type;
size:=words*2;
min:=0; max:=ops[ot].first;
end;
end;
end;
procedure null;
begin
push;
with ops[ot] do begin
kind:=int_type; offset:=0;
size:=0; context:=sconst;
state:=direct;
end;
end;
procedure struc_const;
begin
ss:=ss+1; (* push const level *)
if ss > top_ss then top_ss:=ss;
get(nix);
with nametable[nix], struc_init[ss] do begin
saved_nix:=nix;
alloc_constant(saved_lix,first,size);
first:=first*2; displ:=first;
saved_size:=size;
saved_stat_part:=stat_part;
stat_part:=false;
dope_lix:=lix;
times:=1;
if context in array_types then begin
if packed_comp then begin
init_mode:=packed_array;
elem_pr_word:=niv div shift8;
bits_pr_field:=niv mod shift8;
end else
init_mode:=array_init;
current_index:=0; top_index:=max-min+1;
end else
init_mode:=record_init;
if dynamic then begin
error(error_dyn);
init_mode:=error_init;
end;
end;
end;
procedure end_struc;
begin
push;
with ops[ot], struc_init[ss] do begin
if init_mode=record_init then
kind:=record_type else kind:=array_type;
array_packed:=init_mode = packed_array;
field_packed:=false;
lix:=dope_lix;
size:=saved_size;
state:=direct;
offset:=first div 2;
niv:=saved_lix;
context:=struc_c;
var_nix:=-1;
type_nix:=saved_nix;
dynamic:=false;
if init_mode <> error_init then
if init_mode<>record_init then
begin
if current_index<>top_index then error(const_error);
end;
stat_part:=saved_stat_part;
end;
ss:=ss-1; (*pop const level*)
end;
procedure times_;
begin
with struc_init[ss] do begin
times:=take_expr;
if init_mode <> error_init then
if (times<0) or (current_index+times>top_index) then begin
error(const_error);
times:=top_index-current_index;
end;
end;
end;
procedure put_byte(val, addr: integer);
var sh, w: integer;
begin
if (* **z80** *) versionz80 then begin
if odd(addr) then sh:=shift8 else sh:=1
end
else
begin
(* **lambda** *)
if odd(addr) then sh:=1 else sh:=shift8
end;
w:=addr div 2;
c[w]:=c[w] + val*sh;
end; (*put byte*)
procedure put_word(val, addr: integer);
var w: integer;
begin
w:=addr div 2;
if (* **z80** *) versionz80 then begin
if odd(addr) then begin
c[w]:=c[w] + (val mod shift8) * shift8;
c[w+1]:=c[w+1] + val div shift8;
end
else c[w]:=val + c[w];
end
else
begin
(* **lambda** *)
if odd(addr) then begin
if val < 0 then val:=val + 65536;
c[w]:=c[w] + val div shift8;
c[w+1]:=c[w+1] + (val mod shift8) * shift8;
end
else
c[w]:=val+c[w];
end;
end;(*put word*)
procedure get_byte(var val: integer; addr: integer);
var q, w: integer;
begin
w:=addr div 2;
q:=c[w];
if (* **z80** *) versionz80 then begin
if odd(addr) then
val:=q div shift8
else
val:=q mod shift8;
end
else
begin
(* **lambda** *)
if odd(addr) then
val:=q mod shift8
else
val:=q div shift8
end;
end;(*get byte*)
procedure put_constant(var displ: integer; times,const_size: integer);
var dsize,val,p,c_index,sh,rest,q,v: integer; con: context_kind;
remove, fill: boolean;
begin
with ops[ot] do begin
dsize:=size; val:=offset;
con:=context;
end;
if con=struc_c then begin
c_index:=val;
remove:=true; con:=lconst;
end else remove:=false;
pop;
if (con<>sconst) and (con<>lconst) and (con<>set_const) then begin
error(var_error);
dsize:=0;
end;
for i:=1 to times do begin
if dsize=0 then (*null*) else
if (const_size=byte_length) and (con=sconst) then begin
if (val>max_byte_value) or (val<0) then begin
val:=0;
error(type_error);
end;
put_byte(val, displ);
end else
if (const_size=word_length) and (con=sconst) then
begin
if val>max_int-1 then error(overflow);
put_word(val, displ);
end
else
begin
rest:=const_size; q:=2*val;
if con=set_const then
begin (* adjust set-constants to demanded size *)
if dsize>const_size then error(type_error)
else
if dsize<const_size then
rest:=dsize;
end;
if dsize < rest then begin
rest:=dsize; fill:=true;
end else fill:=false;
p:=displ;
while rest>0 do begin
get_byte(v,q); put_byte(v,p);
p:=p+1; q:=q+1;
rest:=rest-1;
end;
if fill then begin
rest:=const_size - dsize;
while rest > 0 do begin
put_byte(32,p);
p:=p+1; rest:=rest-1;
end;
end;
end;
displ:=displ+const_size;
end; (*for times*)
if remove then remove_const(c_index);
end;
procedure struc;
var first_bit,val,w,q,r,s: integer;
begin
get(nix);
with struc_init[ss], nametable[nix] do begin
case init_mode of
array_init: begin
if current_index+times>top_index then begin
times:=0;
error(const_error);
end;
s:=size;
if (* **lambda** *) not versionz80 then
if size>2 then
if odd(size) and (context in init_types) then
s:=s+1;
put_constant(displ, times, s);
current_index:=current_index+times;
times:=1;
end;
record_init: begin
displ:=first+offset;
if packed_comp then begin
first_bit:=min; bits_pr_field:=max;
with ops[ot] do
if context=sconst then begin
val:=offset;
if bits(val)>bits_pr_field then begin
error(type_error);
val:=0;
end;
end else begin
error(var_error);
val:=0;
end;
pop;
q:=val*shift_to[first_bit+bits_pr_field-1];
put_word(q, displ);
end else
put_constant(displ,1,size);
end;
packed_array: begin
with ops[ot] do
if context=sconst then begin
val:=offset;
if bits(val)>bits_pr_field then begin
error(type_error);
val:=0;
end;
end else begin
error(var_error);
val:=0;
end;
pop;
if current_index+times>top_index then begin
times:=0;
error(const_error);
end;
for i:=1 to times do begin
q:=elem_pr_word;
first_bit:=(current_index mod q)*bits_pr_field;
w:=first + (current_index div q)*2;
r:=val*shift_to[first_bit+bits_pr_field-1];
put_word(r, w);
current_index:=current_index+1;
end; (*for*)
times:=1;
end; (*packed*)
error_init: begin
times:=1;
pop;
end;
end; (*case*)
end; (*with*)
end;
begin
initialize;
repeat
read(pass3file,no);
case convert_in_code[no] of
xactual: actual;
xadd: arithmetic(zadd);
xand: arithmetic(zand);
xarglistsize: arglist_size;
xarraydef: array_def(non_pack);
xarrow: arrow;
xassign: assign;
xassignstat: put0(zassignstat);
xbecomes: becomes;
xbegincode: begin_code;
xblock: new_block;
xboolean: std_name(xboolean);
xcase: begin stat_part:=false; pass_expr(zcase); end;
xcaselabel: case_label;
xcaserange: caserange;
xcasestat: put0(zcasestat);
xchannel: put0(zchannel);
xchanvar: chan_var;
xchar: std_name(xchar);
xchr: std_name(xchr);
xcodeline: code_line;
xconstid: const_def;
xdiv: arithmetic(zdiv);
xdo: for_do;
xdown: up_down(-1);
xelse: put0(zelse);
xendactual: end_actual;
xendblock: end_block;
xendcase: begin stat_part:=true; put0(zendcase); end;
xendcaselist: begin stat_part:=true;
put0(zendcaselist); end;
xendcasestat: begin stat_part:=false; put0(zendcasestat); end;
xendchannel: end_channel;
xendcode: begin put0(zendcode); put2(zendblock,2,1); pop_level; end;
xendexport: end_export;
xendfor: end_for;
xendfunccall: end_func_call;
xendlock: end_lock;
xendprelude: begin word_allign;
source_line:=0;
if (* **lambda** *) not versionz80 then
process_offset:=current_offset; prelude:=false; end;
xendproc: end_proc;
xendrepeat: pass_expr(zendrepeat);
xendset: end_set;
xendstruc: end_struc;
xendwhile: put0(zendwhile);
xendwith: end_with;
xeom: eom;
xeq: equality(zeq);
xerror: begin copy(zerror,2); program_ok:=false; end;
xerrorno: begin copy(zerrorno,1); program_ok:=false; end;
xerrortext: begin copy(zerrortext,1); program_ok:=false; end;
xexception: exception_def;
xexchange: begin pass_addr(zexchange); pop; end;
xexchangestat: put0(zexchstat);
xexportaddr: begin export:=true; export_kind:=exportaddr end;
xexportdispl: begin export:=true; export_kind:=exportdispl end;
xexportoffset:begin export:=true; export_kind:=exportoffset end;
xexportsize: begin export:=true; export_kind:=exportsize end;
xexportvalue: begin export:=true; export_kind:=exportvalue end;
xexpr: first_of_expr:=ot;
xexternal: external_;
xfcall: end_func;
xfield: field_;
xfielddef: field_list;
xfieldid: new_name;
xfor: for_;
xforstat: put0(zforstat);
xforward: forward_;
xfrozendef: redef_type;
xfunccall: func_call;
xfuncid: routine_def(func_mode);
xge: equality(zge);
xgetexpr: load_operand;
xgetvalue: load_operand;
xgoto: label_goto(zgoto);
xgt: equality(zgt);
xif: put0(zif);
xifexpr: pass_expr(zifexpr);
xifstat: put0(zifstat);
xin: inclusion;
xinclude: include;
xincluderange: include_int;
xindex: index;
xindexexpr: index_expr;
xinitblock: begin stat_part:=true; word_allign;
put0(zenddecl);
if (* **z80** *) versionz80 then
i:= - current_offset
else
(* **lambda** *)
i:=current_offset;
if i>var_length then var_length:=i;
end;
xinitconst: variable_init:=true;
xinteger: std_name(xinteger);
xlabel: label_goto(zdeflix);
xle: equality(zle);
xlabelid: new_label;
xliteral: literal;
xlock: lock_type;
xlockstat: put0(zlockstat);
xlockvar: lock_var_;
xlt: equality(zlt);
xmod: arithmetic(zmod);
xmul: arithmetic(zmul);
xname: name;
xne: equality(zne);
xneg: neg_not(zneg);
xnewline: new_line;
xniltype: std_name(xniltype);
xnot: neg_not(znot);
xnull: null;
xoption: set_option;
xor: arithmetic(zor);
xord: std_name(xord);
xotherwise: put0(zotherwise);
xparamid: new_name;
xpackedarraydef: array_def(pack);
xpointerdef: pointer_def;
xpooldef: pool_def;
xpred: std_name(xpred);
xpackedrecord: begin push_level(record_mode); pack_record:=pack end;
xprefix: begin prefixed:=true; prefixed_name:=true; end;
xprocessid: process_def;
xproccall: proc_call;
xprocessparam:begin push; get_pushed_consts; pop; put0(zprocessparam); end;
xprocid: routine_def(proc_mode);
xrange: range;
xreal: std_name(xreal);
xrecdef: record_def;
xrecord: push_level(record_mode);
xredeftype: redef_type;
xreference: std_name(xreference);
xrepeat: put0(zrepeat);
xscalardef: scalar_def;
xscalarid: new_scalar;
xsecfuncid: previous_forward(func_mode);
xsecprocid: previous_forward(proc_mode);
xsemaphore: std_name(xsemaphore);
xset: new_set;
xsetdef: set_def;
xsetexpr: set_expr;
xshadow: std_name(xshadow);
xstringtype: std_name(xstringtype);
xstruc: struc;
xstrucconst: struc_const;
xsub: arithmetic(zsub);
xsubdef: sub_def;
xsucc: std_name(xsucc);
xtempointer: tempointer;
xtimes: times_;
xtype: push_name(nix);
xtypedef: t:=t-1;
xerrortype: std_name(xerrortype);
xundeclid: std_name(xundeclid);
xuntil: put0(zuntil);
xup: up_down(+1);
xvalueparam: formal_param(value_param);
xvar: var_;
xvarparam: formal_param(var_param);
xvarid: new_name;
xvarlist: var_list;
xvarpointer: var_pointer;
xwhile: put0(zwhile);
xwhileexpr: pass_expr(zwhileexpr);
xwith: waiting_with:=true;
xwithvar: with_var_;
xxor: arithmetic(zxor);
end otherwise compiler_error(input_error);
until done;
if test then writeln;
if program_ok then
if (* **z80** *) versionz80 then replace('pass56z80')
else
(* **lambda** *)
replace('platonpass5')
else
writeln('*** compilation terminated after pass4');
end.
«eof»