DataMuseum.dk

top - download

    Length: 61009 (0xee51)
    Types: TextFile
    Names: »P4PROC.PAS«

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

TextFile

procedure routine_def(m: block_mode);\r
begin\r
push_name(nix);\r
with nametable(nix)^ do begin\r
context:=routine_type;\r
niv:=current_niv;\r
lix:=current_lix;\r
current_lix:=current_lix+1;\r
end;\r
push_level(m);\r
idcount:=0;  param_number:=0;\r
head_line:=source_line;\r
end;\r
\r
procedure process_def;\r
var ty: integer;\r
begin\r
passin(nix);    (*skip nix*)\r
push_name(nix);   passin(ty);\r
with nametable(nix)^ do\r
begin\r
context:=variable;\r
offset:=alloc_var(nametable(ty)^.size);\r
niv:=current_niv;\r
end;\r
push_level(process_mode);\r
idcount:=0;   param_number:=0;\r
head_line:=source_line;\r
end;\r
\r
procedure extprocess_def;\r
var \r
temp_var,\r
type_p, param_size, step: integer;\r
help_ptr: stack_ptr;\r
begin (* pick up parametert list for external process type *)\r
passin(nix); (* of external process type *)\r
with nametable( nix )^ do\r
begin\r
context:= process_type;\r
size:= nametable( comp_type )^.size;\r
dynamic:= false;\r
packed_comp:= false;\r
max:= param_number;\r
end;\r
\r
pop_to_free_stack(param_number+1);\r
help_ptr:= free_stack;\r
for step:= param_number downto 1 do\r
begin\r
temp_var:= help_ptr^.stacked_val;\r
help_ptr:= help_ptr^.former_elem;\r
nametable( temp_var )^.next_comp:= help_ptr^.stacked_val; (*chain of formal parameters *)\r
with nametable( help_ptr^.stacked_val )^ do\r
begin\r
with nametable( comp_type )^ do\r
begin\r
param_size:= size; (* of param type *)\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,\r
sys_record_type: type_p:= 6;\r
allign_arr_type,\r
sys_array_type:  type_p:= 7;\r
else      type_p:= 8;\r
end;\r
end; (* with comp type *)\r
\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
end; (* var param *)\r
size:= param_size;\r
min:= type_p; (* save param type for later dump in sysinit *)\r
end; (* with param *)\r
end; (* for ... *)\r
param_number:= 0;\r
end; (* extprocess def *)\r
\r
\r
procedure exception_def;\r
begin\r
push_name(nix);   pop_to_free_stack(1);\r
if (* **lambda or rc3502c** *) not versionz80 then\r
with nametable(nix)^ do\r
if niv<0 then begin  \r
put1(zextexception, offset);  (* offset is name key *)\r
end else\r
put2(zexception,niv,lix);\r
end;\r
\r
function alloc_process_param : integer;  (* return = param length *)\r
var type_nix, no, param_size, byte_displ, parameter_length : integer;\r
help_ptr: stack_ptr;\r
begin\r
pop_to_free_stack(param_number);\r
help_ptr:=free_stack; (* temporary reverse of parameter list *)\r
for no:=param_number - 1 downto 0 do\r
with nametable( help_ptr^.stacked_val )^ do begin\r
help_ptr:= help_ptr^.former_elem;\r
type_nix:=comp_type;\r
if context = value_param then\r
param_size:=nametable(type_nix)^.size\r
else\r
param_size:=pointer_length;\r
if nametable(type_nix)^.dynamic then begin\r
error(error_dyn);\r
param_size:=0;\r
end;\r
byte_displ:=0;\r
if (* **z80** *) versionz80 then begin\r
if param_size = byte_length then param_size:=word_length;\r
end\r
else\r
if lambdaversion then\r
begin\r
if nametable(type_nix)^.context in index_types then\r
if param_size = byte_length then byte_displ:=1;\r
if odd(param_size) then param_size:=param_size+1;\r
end\r
else\r
begin (* **rc3502c** *)\r
if (nametable(type_nix)^.context in adjust_types) or (context=var_param) then\r
if odd(param_size) then byte_displ := 1;\r
if odd(param_size) then param_size := param_size + 1;\r
end;\r
niv:=current_niv;\r
offset:=alloc_var(param_size);\r
offset:=offset+byte_displ;\r
end; (* for .. with .. *)\r
\r
(* put the elements back onto the stack *)\r
for no:= param_number downto 1 do\r
begin\r
help_ptr:= free_stack;\r
free_stack:= free_stack^.former_elem;\r
help_ptr^.former_elem:= stack_top;\r
stack_top:= help_ptr;\r
end;\r
\r
if (* **z80** *) versionz80 then\r
parameter_length:=-current_offset\r
else\r
if lambdaversion then\r
(* **lambda** *)\r
parameter_length:=current_offset + 1\r
else (* **rc3502c** *)\r
parameter_length := current_offset;\r
this_level^.parameter_length:=parameter_length;\r
alloc_process_param:=parameter_length;\r
end;  (* alloc process param *)\r
\r
function alloc_routine_param : integer;  (* return = param length *)\r
var q, no, parameter_offset, return_size, param_size,\r
parameter_length, byte_displ : integer;\r
help_ptr: stack_ptr;\r
\r
function alloc_param(size : integer) : integer;\r
begin\r
(*$R-*)\r
if (* **z80** *) versionz80 then begin\r
(* parameter_offset >= 0 *)\r
alloc_param:=parameter_offset;\r
if top_address - parameter_offset >= size then\r
parameter_offset:=parameter_offset + size\r
else\r
error(address_overflow);\r
end\r
else\r
begin\r
(* **lambda or rc3502c** *)\r
(* parameter_offset <= 0 *)\r
if top_address + parameter_offset >= size then\r
parameter_offset:=parameter_offset - size\r
else\r
error(address_overflow);\r
alloc_param:=parameter_offset;\r
end;\r
(*R+*)\r
end; (* alloc_param *)\r
\r
begin (* alloc routine param *)\r
return_size:=0;\r
q:=param_number - 1;\r
if mode = func_mode then\r
begin\r
help_ptr:= stack_top; (* find function designator element in stack *)\r
for no:= 1 to q do help_ptr:= help_ptr^.former_elem; (* skip the parameters *)\r
\r
with nametable( help_ptr^.stacked_val )^ do begin\r
if nametable(comp_type)^.context in direct_return then begin\r
context:=return_param;\r
return_size:=nametable(comp_type)^.size;\r
if (* **lambda or z80** *) lambdaversion or versionz80 then\r
begin\r
if return_size=byte_length then return_size:=word_length\r
end\r
else (* **rc3502c** *)\r
if odd(return_size) then return_size := return_size + 1;\r
end;\r
if nametable(comp_type)^.dynamic then error(error_dyn);\r
end;\r
end; (* if func_mode *)\r
if (* **z80 or rc3502c** *) versionz80 or (not lambdaversion) then\r
parameter_offset:=0\r
else\r
(* **lambda** *)\r
parameter_offset:=-1;\r
parameter_length:=0;\r
\r
help_ptr:= stack_top; (* traverse the parameter list *)\r
for no:=0 to q do\r
with nametable( help_ptr^.stacked_val )^ do begin\r
help_ptr:= help_ptr^.former_elem;\r
if context = var_param then\r
param_size:=pointer_length\r
else\r
(* value param and return param *)\r
with nametable( comp_type)^ do begin\r
param_size:=size;\r
if dynamic then begin\r
error(error_dyn);\r
param_size:=0;\r
end;\r
end;\r
byte_displ:=0;\r
if (* **z80** *) versionz80 then begin\r
if param_size = byte_length then param_size:=word_length;\r
end\r
else\r
if  (* **lambda** *) lambdaversion then\r
begin\r
if nametable(comp_type)^.context in index_types then\r
if param_size = byte_length then byte_displ:=1;\r
if odd(param_size) then param_size:=param_size + 1;\r
end\r
else\r
begin (* **rc3502c** *)\r
if (nametable(comp_type)^.context in adjust_types) or (context = var_param) then\r
if odd(param_size) then byte_displ := 1;\r
if odd(param_size) then param_size := param_size + 1;\r
end;\r
parameter_length:=parameter_length + param_size;\r
niv:=current_niv;\r
offset:=alloc_param(param_size);\r
offset:=offset + byte_displ;\r
end; (* for ... with .. *)\r
parameter_length:=parameter_length - return_size;\r
alloc_routine_param:=parameter_length;\r
end; (* alloc routine param *)\r
\r
procedure formal_param(c: context_kind);\r
var type_nix, parm_size, byte_displ, i: integer;\r
help_ptr: stack_ptr;\r
begin\r
type_nix:=stack_top^.stacked_val;\r
help_ptr:= stack_top^.former_elem; (* bypass top element *)\r
for i:=idcount downto 1 do\r
with nametable(help_ptr^.stacked_val   )^ do begin\r
help_ptr:= help_ptr^.former_elem;\r
context:=c;\r
comp_type:=type_nix;\r
end;\r
param_number:=param_number+idcount;\r
idcount:=0;   pop_to_free_stack(1);\r
end;\r
\r
procedure name;\r
var p,q,ch,i: integer;  na: alfa;\r
begin\r
passin(p);   q:=0;   na:='            ';\r
if p>alfalength then begin\r
q:=p;  p:=alfalength;\r
end;\r
for i:=1 to p do begin\r
passin(ch);\r
na[i]:=chr(ch);\r
end;\r
if q>0 then\r
for i:=p+1 to q do passin(ch);\r
if prefixed_name then begin\r
prefix_name:=na;\r
prefixed_name:=false;\r
end\r
else\r
ext_name:=na;\r
end;\r
\r
procedure new_block;\r
var op: out_code;   parameter_length: integer;\r
step: integer;\r
help_ptr: stack_ptr; \r
begin\r
passin(i);   (*skip*)\r
(* find proc/func entry in stack *)\r
help_ptr:= stack_top;\r
for step:= 1 to param_number do help_ptr:= help_ptr^.former_elem;\r
case mode of\r
proc_mode, func_mode: begin\r
with nametable(help_ptr^.stacked_val)^ do begin\r
if param_list then\r
parameter_length:=alloc_routine_param\r
else\r
parameter_length:=size;   (* routine previous defined *)\r
param_list:=true;\r
if prefixed then begin\r
put0(zmodule);   out_name(prefix_name);\r
put_arg1(param_number);\r
out_formal_list; (* pop parameter list *)\r
prefixed:=false;\r
end  \r
else\r
pop_to_free_stack(param_number);\r
this_level^.parameter_length:=parameter_length;\r
size:=parameter_length;\r
if mode=proc_mode then op:=zproc else op:=zfunc;\r
put1(op,lix);\r
out_name(ext_name);\r
put1(zblock,current_niv);\r
end;\r
end;\r
process_mode: begin\r
parameter_length:=alloc_process_param;\r
with nametable(help_ptr^.stacked_val)^ do begin\r
put1(zprocess,offset);   out_name(ext_name);\r
put_arg2(parameter_length,param_number);\r
end;\r
out_formal_list; (* pop parameter list *)\r
put1(zblock, 0);\r
end;\r
end;\r
this_level^.saved_lix:=current_lix;\r
pop_to_free_stack(1); (* pop proc/func name *)   param_number:=0;\r
var_length:=0;\r
end;\r
\r
procedure external_;\r
var op: out_code;  not_std: boolean;\r
step: integer;\r
help_ptr: stack_ptr;\r
begin\r
not_std:=true;\r
(* find proc/func entry in stack *)\r
help_ptr:= stack_top; \r
for step:= 1 to param_number do help_ptr:= help_ptr^.former_elem;\r
case mode of\r
proc_mode, func_mode:\r
with nametable(help_ptr^.stacked_val)^ do begin\r
not_std:=niv>=0;\r
size:=alloc_routine_param;\r
if not_std then begin\r
niv:=-1;\r
if mode=proc_mode then op:=zextproc else op:=zextfunc;\r
put1(op, name_key);   out_name(ext_name);\r
offset:=name_key;\r
name_key:=name_key+1;\r
end;\r
end;\r
process_mode:  \r
if prelude then error(prelude_error)\r
else\r
with nametable(help_ptr^.stacked_val)^ do\r
if versionz80 or lambdaversion (* for z80 or RC3502 model 1 *) then\r
begin put1(zextprocess,offset);  out_name(ext_name); end\r
else\r
begin\r
put1(zsysinit, offset);\r
put0(zextprocess);\r
end;\r
end;\r
if not_std then begin\r
put_arg1(param_number);   out_formal_list; (* pop parameter list *)\r
end \r
else\r
pop_to_free_stack(param_number);\r
this_level^.saved_lix:=current_lix;\r
pop_level;\r
pop_to_free_stack(1); (* pop proc / func name *)\r
param_number:=0;\r
end;\r
\r
procedure forward_;\r
var step: integer;\r
help_ptr: stack_ptr;\r
begin\r
(* find proc/func entry in stack *)\r
help_ptr:= stack_top; \r
for step:= 1 to param_number do help_ptr:= help_ptr^.former_elem;\r
with nametable(help_ptr^.stacked_val)^ do\r
size:=alloc_routine_param;\r
this_level^.saved_lix:=current_lix;\r
pop_level;   \r
pop_to_free_stack(param_number+1);    param_number:=0;\r
idcount:=0;\r
end;\r
\r
procedure previous_forward(m: block_mode);\r
begin\r
push_level(m);\r
param_number:=0;\r
push_name(nix);\r
param_list:=false;\r
head_line:=source_line;\r
end;\r
\r
procedure end_block;\r
var l,i: integer;\r
begin\r
if lambdaversion then\r
var_length:=var_length+1;\r
if mode = process_mode then\r
var_length:=var_length - this_level^.parameter_length\r
else\r
var_length:=var_length - activation_record_length;\r
if odd(var_length) then var_length:=var_length+1;\r
put2(zlength,var_length, this_level^.parameter_length);\r
out_constant_area;\r
l:=current_lix - 1;\r
if l > top_lix then top_lix:=l;\r
pop_level;\r
if this_level=bottom_level then begin\r
out_constant_area;\r
if (ot<>empty_stack) or (stack_top<>nil) or (ss<>struc_bottom) then\r
begin\r
if ot <> empty_stack then writeln(' not empty stack');\r
if stack_top <> nil then writeln(' not nil stack');\r
if ss <> struc_bottom then writeln(' not structure bottom');\r
abort(stack_error);\r
end;\r
for i:=0 to max_name_index do\r
with nametable(i)^ do\r
if lix > 0 then\r
lix:=-lix; (*mark the name as unused *)\r
end;\r
put2(zendblock, current_lix, l);\r
end;\r
\r
procedure begin_code;\r
begin\r
if ot^.context <> sconst then error(var_error);\r
put1(zbegincode,ot^.offset);\r
pop;\r
end;\r
\r
procedure code_line;\r
var i,no,ch: integer;\r
begin\r
passin(no);\r
put1(zcodeline,no);\r
for i:=1 to no do begin\r
passin(ch);\r
put_arg1(ch);\r
end;\r
end;\r
\r
procedure init_values(nix,vniv,voffset: integer);\r
var varvalue,typ: integer;\r
begin\r
if prelude then error(prelude_error);\r
with ot^ do if context=struc_c then context:=lconst;\r
with nametable(nix)^ do\r
if context in simple_types then begin\r
if ot^.context<>sconst then\r
error(var_error) else\r
begin\r
varvalue:=ot^.offset;\r
if (varvalue<min) or (varvalue>max) then\r
error(type_error) else\r
begin\r
put0(zinitialize);  put2(zaddr,vniv,voffset);\r
if context=bool_type then typ:=bool_typ\r
else if size=word_length then typ:=int_typ\r
else typ:=scalar_typ;\r
put2(zsimpleinit,typ,varvalue);\r
end\r
end;\r
end else \r
if ot^.context=lconst then begin\r
(*if ot^.niv<0 then *) constant_used(ot);\r
if ot^.kind = array_type then begin\r
push;\r
ot^.size:=size;\r
adjust_string(os, ot);\r
pop;\r
end;\r
put0(zinitialize);   put2(zaddr,vniv,voffset);\r
put2(zstrucinit,size,ot^.niv);\r
end else\r
if ot^.context=set_const then begin\r
(*if ot^.niv<0 then *) constant_used(ot);\r
put0(zinitialize);  put2(zaddr,vniv,voffset);\r
put3(zsetinit,size,ot^.niv,ot^.size);\r
end\r
else error(var_error);\r
end;\r
\r
procedure component_init(type_nix: integer);\r
var field_nix, w_offset, s, step, param_chain: integer;\r
begin\r
with nametable(type_nix)^ do\r
if (context = sys_record_type) or (context = allign_rec_type)\r
then begin\r
field_nix:=next_comp;\r
while field_nix <> 0 do\r
with nametable(field_nix)^ do begin\r
if context = field then\r
put1(zfieldinit, offset)\r
else\r
put2(zdynfieldinit, niv, offset);\r
component_init(comp_type);\r
field_nix:=next_comp;\r
end; (*with*)\r
put0(zendinitfields);\r
end  (*record*)\r
else\r
if (context = sys_array_type) or (context = allign_arr_type)\r
then begin\r
w_offset:=alloc_temp(word_length);\r
s:=nametable(next_comp)^.size;\r
if (* **lambda or rc3502c** *) not versionz80 then\r
if (context = allign_arr_type) and odd(s) then s:= s+ 1;\r
if dynamic then\r
put3(zarraydyninit, w_offset, niv, offset)\r
else\r
put4(zarrayinit, w_offset, min, max, s);\r
component_init(next_comp);\r
release_temp(word_length);\r
end (*array*)\r
else\r
if context = pool_type then\r
put2(zpoolinit, min, max)\r
else\r
if context=process_type then\r
begin\r
put1(zextprocess, max (* param number *));\r
param_chain:= next_comp;\r
for step:= 1 to max (* param number *) do\r
with nametable( param_chain )^ do\r
begin\r
put2(zparamtype, min (* type_p of param *), size);\r
param_chain:= next_comp;\r
end; (* for .. with *)\r
end (* process type *)\r
else\r
if (* **z80** *) versionz80 then\r
compiler_error(addr_error)\r
else\r
(* **lambda or rc3502c** *)\r
put1(zvarinit, type_o(context));\r
end; (*component init*)\r
\r
procedure system_init(type_nix, voffset: integer);\r
begin\r
if new_call then\r
put0(zsysnewinit)\r
else\r
with nametable(type_nix)^ do begin\r
if dynamic then\r
put1(zsysdyninit, voffset)\r
else\r
put1(zsysinit, voffset);\r
end;\r
component_init(type_nix);\r
end; (*system init*)\r
\r
procedure var_list;\r
var type_nix, var_size, type_niv, type_offset, i: integer;\r
  init, allign, dyn: boolean;\r
help_ptr: stack_ptr;\r
begin\r
type_nix:=stack_top^.stacked_val;\r
with nametable(type_nix)^ do begin\r
var_size:=size;\r
allign := context in allign_types;\r
init := (context in init_types) and (not prelude);\r
type_niv:=niv;   type_offset:=offset;\r
dyn:=dynamic;\r
if context = dyn_subrange then dyn:=false;\r
end;\r
pop_to_free_stack(idcount+1);\r
help_ptr:= free_stack;\r
for i:=idcount downto 1 do\r
with nametable(help_ptr^.stacked_val)^ do begin\r
help_ptr:= help_ptr^.former_elem;\r
if dyn then begin\r
context:=dyn_variable;\r
niv:=current_niv;\r
offset:=alloc_var(pointer_length);\r
put3(zallocdynvar, offset, type_niv, type_offset);\r
end\r
else\r
begin\r
if allign then word_allign;\r
context:=variable;\r
niv:=current_niv;\r
offset:=alloc_var(var_size);\r
end;\r
if variable_init then begin\r
if dyn then error(error_dyn_init)\r
else\r
init_values(type_nix, niv, offset);\r
end;\r
if init then system_init(type_nix, offset);\r
end;\r
idcount:=0;\r
if variable_init then pop; (*init value*)\r
variable_init:=false;\r
end;\r
\r
procedure end_export;\r
var typ, val: integer;\r
begin\r
with ot^ do begin\r
if field_packed then error(field_export_error);\r
case export_kind of\r
exportvalue: begin\r
if context<>sconst then error(exportvalue_error);\r
typ:=value_type;\r
val:=offset;\r
end;\r
exportsize: begin\r
typ:=value_type;\r
val:=size;\r
end;\r
exportdispl: begin\r
typ:=value_type;\r
val:=field_offset;\r
end;\r
exportaddr, \r
exportoffset: begin\r
if not ( context in var_types ) then error(exportaddr_error);\r
if export_kind=exportaddr then \r
typ:=offset_type else typ:=value_type;\r
val:=offset+field_offset;\r
end;\r
end;(*case*)\r
end;(*with*)\r
put0(zexport);     out_name(ext_name);\r
put_arg2(typ, val);\r
pop;\r
export:=false;\r
field_offset:=0;\r
end;(*end export*)\r
\r
\r
procedure new_label;\r
begin\r
push_name(nix);\r
with nametable(nix)^ do begin\r
context:=label_type;\r
lix:=current_lix;\r
current_lix:=current_lix+1;\r
end;\r
pop_to_free_stack(1);\r
end;\r
\r
procedure const_def;\r
begin\r
push_name(nix);\r
with ot^ do begin\r
if context=struc_c then context:=lconst;\r
if (context<>sconst) and (context<>lconst) and (context<>set_const) then begin\r
error(var_error);\r
context:=sconst;  size:=0;  niv:=0;\r
offset:=0;\r
end;\r
end;\r
with nametable(nix)^ do begin\r
context:=ot^.context;\r
size:=ot^.size;\r
niv:=ot^.niv;\r
offset:=ot^.offset;\r
end;\r
pop;\r
pop_to_free_stack(1);\r
end;\r
\r
procedure load_var(op: out_code);\r
var load_type: integer;\r
begin\r
with ot^ do begin\r
if kind in simple_types then begin\r
if field_packed then\r
put3(op, field_typ,first, comp_size)\r
else\r
begin\r
if size=0 then error(empty_element_change);\r
if size=byte_length then load_type:=byte_typ else\r
load_type:=word_typ;\r
put1(op,load_type);\r
end\r
end\r
else\r
if kind=pointer_type then put1(op,type_pointer)\r
else\r
if kind=set_type then begin\r
put2(op,set_typ,size);\r
end\r
else\r
begin\r
if dynamic then\r
with nametable(type_nix)^ do\r
put3(op, dyn_typ, niv, offset)\r
else\r
put2(op, addr_typ, size);\r
end;\r
end;\r
end;\r
\r
procedure get_pushed_consts;\r
var p: operand_ptr; stop: boolean;\r
begin\r
p:=ot;\r
if p<>first_of_expr then\r
repeat\r
p:=p^.former_operand;\r
if p<>first_of_expr then\r
begin\r
with p^ do if context=struc_c then context:=lconst;\r
stop:= (p^.context <> sconst) and (p^.context <> lconst)\r
end\r
else stop:=true;\r
until stop;\r
if p^.next_operand<>ot then\r
repeat\r
p:= p^.next_operand;\r
with p^ do begin\r
if context=sconst then begin\r
put1(zconst,offset);\r
if size=byte_length then size:=word_length;\r
end\r
else begin\r
(*if niv<0 then *) constant_used(p);\r
put2(zlconst,niv,size);\r
end;\r
state:=expression;  context:=expr;\r
end; (* with *)\r
until p^.next_operand=ot;\r
end;\r
\r
procedure address;\r
begin\r
get_pushed_consts;\r
with ot^ do if context=struc_c then context:=lconst;\r
with ot^ do begin\r
case state of\r
direct:  if context=lconst then\r
begin\r
(*if niv<0 then *) constant_used(ot);\r
put1(zcaddr,niv);\r
end\r
else\r
if (context=sconst) or (context=set_const) then begin\r
compiler_error(addr_error);\r
put2(zaddr,0,0);\r
end else\r
put2(zaddr,niv,offset);\r
indirect: begin\r
put2(zaddr,niv,offset); put0(zindaddr);\r
end;\r
addr, p_comp: ;\r
expression:  compiler_error(addr_error);\r
end;\r
state:=addr;   context:=expr;\r
end;\r
end;\r
\r
procedure load_operand;\r
begin\r
if ( ot^.context<>sconst ) and\r
( ot^.context<>struc_c) and\r
   (ot^.context<>lconst ) then begin\r
get_pushed_consts;\r
with ot^ do begin\r
case state of\r
direct: if context=set_const then\r
begin\r
(*if niv<0 then *) constant_used(ot);\r
put2(zsetconst,niv,size);\r
end\r
else\r
begin put2(zaddr, niv, offset); load_var(zindvar); end;\r
indirect:  begin\r
put2(zaddr,niv,offset);  put0(zindaddr);\r
load_var(zindvar);\r
end;\r
addr: load_var(zindvar);\r
expression, p_comp: ;\r
end; (*case*)\r
\r
(*if the operand is a byte or a pointer(3 bytes), then the size of space\r
  occupied on the stack is a word for a byte and a double for a pointer.\r
  i.e. the size has to be even*)\r
if kind in adjust_types then\r
if odd(size) then size := size + 1;\r
state:=expression;   context:=expr;\r
end; (*with*)\r
end; (*if*)\r
end;\r
\r
procedure load_expr;\r
begin\r
with ot^ do begin\r
if context=struc_c then context:=lconst;\r
if (context=lconst) or (context=set_const) then\r
(*if niv<0 then *) constant_used(ot);\r
if context=sconst then begin\r
put1(zconst,offset);\r
end\r
else\r
if context=lconst then put2(zlconst,niv,size)\r
else\r
if context=set_const then put2(zsetconst,niv,size)\r
else\r
load_operand;\r
if size=byte_length then size:=word_length;\r
state:=expression;   context:=expr;\r
end;\r
end;\r
\r
procedure pass_expr(op: out_code);\r
begin\r
load_expr;   pop;\r
put0(op);\r
end;\r
\r
procedure pass_addr(op: out_code);\r
begin\r
address;   pop;\r
put0(op);\r
end;\r
\r
procedure arithmetic(op: out_code);\r
var step, maskval, f, typ: integer;\r
rotate_first: boolean;\r
begin\r
if ( ot^.context=sconst ) and\r
( os^.context=sconst ) then begin\r
f:=ot^.offset;  pop;\r
with ot^ do begin\r
case op of\r
zand, zor_, zxor: offset := int_logical( op, offset, f );\r
zadd: offset:=int_add(offset,f);\r
zsub: offset:=int_add(offset,-f);\r
zmul: offset:=int_mul(offset,f);\r
zdiv: offset:=int_div(offset,f);\r
zmod: offset:=int_mod(offset,f);\r
zshift: offset:= int_shift(offset, f);\r
end;\r
end;\r
end\r
else\r
if (op=zshift) and (ot^.context=sconst) then\r
with ot^ do\r
begin (* convert to mask and rotate *)\r
if offset<>0 then\r
begin\r
rotate_first:= offset<0;\r
offset:= abs(offset);\r
if offset>16 then offset:= 16;\r
(*$R-*)\r
maskval:= (1 shl (16 - offset)) - 1;\r
(*$R+*)\r
if rotate_first then\r
begin\r
if offset<16 then\r
begin\r
put1(zconst, -offset);\r
put0(zrotate);\r
end;\r
put1(zconst, maskval);\r
put0(zand);\r
end\r
else\r
begin\r
put1(zconst, maskval);\r
put0(zand);\r
if offset<16 then\r
begin\r
put1(zconst, offset);\r
put0(zrotate);\r
end;\r
end;\r
end; (* offset <> 0 *)\r
pop;\r
with ot^ do\r
begin\r
size:= word_length;\r
context:= expr;\r
state:= expression;\r
end; (* with ot^ *)\r
end\r
else\r
begin\r
load_expr;\r
pop;\r
with ot^ do begin\r
case kind of\r
bool_type:  typ:=bool_typ;\r
set_type:   typ:=setof_typ;\r
else typ:=int_typ;\r
end;\r
put0(op);\r
if (op=zmul) or (op=zadd) or (op=zsub) then \r
put_arg1(typ);\r
if size=byte_length then size:=word_length;\r
context:=expr;  state:=expression;\r
end;\r
end;\r
end;\r
\r
procedure neg_not(op: out_code);\r
var typ : integer;\r
begin\r
with ot^ do\r
if context=sconst then begin\r
case op of\r
zneg: offset:=-offset;\r
znot: if kind<>bool_type then\r
(*$R-*)\r
offset:= -offset-1\r
(*$R+*)\r
else\r
if offset=0 then offset:=1 else offset:=0;\r
end;\r
end\r
else begin\r
load_operand;\r
with ot^ do begin\r
put0(op);\r
if op = znot then begin\r
if kind = bool_type then typ := bool_typ else typ:=int_typ;\r
put_arg1(typ);\r
end;\r
if size=byte_length then size:=word_length;\r
context:=expr;   state:=expression;\r
end;\r
end;\r
end;\r
\r
procedure equality(op: integer);\r
var f,q,n,op1,p,op1_size,op2_size,last,n1,i: integer;\r
bo, remove1, remove2: boolean;\r
begin\r
if (ot^.context=sconst) and\r
(os^.context=sconst) then begin\r
f:=ot^.offset;   pop;\r
with ot^ do begin\r
case op of\r
zne:  bo:=offset<>f;\r
zeq:  bo:=offset=f;\r
zle:  bo:=offset<=f;\r
zge:  bo:=offset>=f;\r
zlt:  bo:=offset<f;\r
zgt:  bo:=offset>f;\r
end; (*case*)\r
if bo then offset:=1 else offset:=0;\r
kind:=bool_type;   size:=word_length;\r
end; (*with*)\r
end\r
else\r
begin\r
remove1:=ot^.context=struc_c;\r
if remove1 then ot^.context:=lconst;\r
remove2:=os^.context=struc_c;\r
if remove2 then os^.context:=lconst;\r
if ((op=zne) or (op=zeq)) and\r
(ot^.context=lconst) and\r
(os^.context=lconst) then begin\r
op1_size:=os^.size;\r
op2_size:=ot^.size;\r
n:=op1_size;\r
if n>op2_size then n:=op2_size;\r
n1:=n;\r
p:=ot^.offset;   pop;\r
with ot^ do begin\r
n:=(n+1) div 2 -1;   q:=offset;\r
bo:=true;\r
for i:=0 to n do\r
bo:=bo and (retrieve_const(i+p)=retrieve_const(i+q));\r
if op1_size>op2_size then begin\r
for i:=n to (op1_size+1)div 2 - 1 do bo:=bo and (retrieve_const(i+q)=spsp);\r
end\r
else\r
if op2_size>op1_size then begin\r
for i:=n to (op2_size+1)div 2 - 1 do bo:=bo and (retrieve_const(i+p)=spsp);\r
end;\r
case op of\r
zeq:  if bo then offset:=1 else offset:=0;\r
zne:  if bo then offset:=0 else offset:=1;\r
end;\r
kind:=bool_type;   size:=word_length;\r
context:=sconst;\r
end;  (*with*)\r
if remove1 then remove_constant(p);\r
if remove2 then remove_constant(q);\r
end\r
else begin\r
with ot^ do\r
if (kind=array_type) and (context=lconst) then adjust_string(ot,os);\r
with os^ do\r
if (kind=array_type) and (context=lconst) then adjust_string(os,ot);\r
load_expr;   pop;\r
with ot^ do\r
case kind of\r
int_type,char_type,bool_type,scalar_type,dyn_subrange:\r
put1(zcompare,op);\r
array_type, record_type, sys_array_type, sys_record_type,\r
allign_arr_type,allign_rec_type:\r
begin\r
if op=zeq then op1:=zeq_struc\r
else op1:=zne_struc;\r
if dynamic then\r
with nametable(type_nix)^ do\r
put3(zcompdynstruc, op1, niv, offset)\r
else\r
put2(zcompstruc,op1,size);\r
end;\r
pointer_type: if versionz80 then\r
put1(zcompare, op)\r
else\r
begin\r
if op=zeq then op1:= zeq_struc\r
else op1:= zne_struc;\r
if dynamic then\r
with nametable(type_nix)^ do\r
put3(zcompdynstruc, op1, niv, offset)\r
else\r
put2(zcompstruc, op1, size);\r
end; (* pointer type *)\r
set_type: begin\r
case op of\r
zeq:  op1:=zeq_set;\r
zne:  op1:=zne_set;\r
zle:  op1:=zle_set;\r
zge:  op1:=zge_set;\r
end;\r
put1(zcompare,op1);\r
end;\r
else compiler_error (var_error);\r
end;\r
with ot^ do begin\r
kind:=bool_type;   size:=word_length;\r
context:=expr;     state:=expression;\r
end;\r
end;\r
end\r
end;\r
\r
procedure inclusion;\r
begin\r
if stat_part then begin\r
get_pushed_consts;\r
load_expr;   pop;\r
with ot^ do begin\r
put1(zcompare,zin);\r
kind:=bool_type;  size:=word_length;\r
context:=expr;      state:=expression;\r
end;\r
end else begin\r
error(var_error);\r
pop;\r
end;\r
end;\r
\r
procedure range;\r
var a,b: integer;   dyn : boolean;\r
begin\r
passin(nix);\r
with nametable(nix)^ do begin\r
a:=min;   b:=max;    dyn:=dynamic;\r
end;\r
if dyn then begin\r
if ot^.context = sconst then begin\r
push; get_pushed_consts; pop;\r
end;\r
load_operand;\r
if index_check then\r
with nametable(nix)^ do\r
put2(zdynrangetest, niv, offset+2);\r
end\r
else\r
with ot^ do\r
if context=sconst then begin\r
if (offset<a) or (offset>b) then begin\r
error(type_error);   offset:=a;\r
end;\r
end else begin\r
load_operand;\r
if index_check then\r
with nametable(nix)^ do\r
if not (lambdaversion or versionz80) and (min=0)\r
then\r
begin\r
(*rc3502 model 2 and static array starting in 0*)\r
if lix < 0 then lix := -lix;\r
put1(zrangemax,max)\r
end\r
else begin\r
if lix<0 then begin\r
lix:=-lix;\r
alloc_range_descr(lix,min,max);\r
end;\r
put1(zrangetest,lix);\r
end;\r
end;\r
end;\r
\r
procedure func_call;\r
var p,q,result_size,std,alloc_size: integer;   via_stack : boolean;\r
begin\r
push;\r
get_pushed_consts;\r
passin(nix);   std:=0;\r
with nametable(nix)^ do\r
if niv<0 then begin  (*external or std function *)\r
std:=-niv-1;\r
if niv=-1 then begin\r
put2(zextfunccall, offset, size);  (* offset = name key *)\r
end else put1(zstdfunccall, std );\r
end \r
else put3(zfunccall,niv,lix, size);\r
push_name(nix);   pop_to_free_stack(1);\r
passin(p);\r
if std>0 then\r
begin\r
case std of\r
zsucc: put_arg1(nametable(p)^.max);\r
zpred: put_arg1(nametable(p)^.min);\r
znil, znilref: ; (* no action *)\r
else           ; (* no action *)\r
end;\r
end;\r
with nametable(nix)^ do begin\r
with nametable(p)^ do begin\r
result_size:=size;\r
via_stack:=context in direct_return;\r
if dynamic and (context<>dyn_subrange) then error(error_dyn);\r
end;\r
context:=func_result;\r
if not via_stack then begin\r
niv:=current_niv;\r
if (* **z80** *) versionz80 then begin\r
if result_size=byte_length then\r
alloc_size:=result_size+1 else alloc_size:=result_size;\r
end\r
else\r
(* **lambda or rc3502c** *)\r
if odd(result_size) then \r
alloc_size:=result_size+1 else alloc_size:=result_size;\r
q:=alloc_temp(alloc_size);\r
offset:=q;\r
end (* not via stack *)\r
else\r
alloc_size:=0;\r
end;\r
via_stack:=via_stack or (std>0);\r
with ot^ do begin\r
type_nix:=p;\r
var_nix:=nix;\r
kind:=nametable(p)^.context;\r
niv:=current_niv;   context:=func_result;\r
offset:=q;          size:=result_size;\r
lix:=nametable(p)^.lix;\r
array_packed:=nametable(p)^.packed_comp;\r
field_packed:=false;\r
func_value:=via_stack;\r
state:=direct;\r
temp_size:=alloc_size;\r
dynamic:=false;\r
end;\r
end;\r
\r
procedure end_func_call;\r
begin\r
if not ot^.func_value then begin\r
load_operand;\r
end\r
else\r
with ot^ do begin\r
\r
(*size of bytes and pointers(3 bytes) occupied on stack is a word for\r
  a byte and a double for a pointer. i.e. the size has to be even *)\r
if odd(size) then size := size + 1;\r
state:=expression;   context:=expr;\r
end;\r
put1(zendfunccall,ot^.size);\r
release_temp(ot^.temp_size);\r
end;\r
\r
procedure proc_call;\r
var\r
std: integer;\r
begin\r
passin(nix);\r
with nametable(nix)^ do\r
if niv<0 then begin  (* external or standard *)\r
std:= -niv-1;\r
if (niv=-1) or versionz80 then (* external *)\r
put2(zextproccall, offset, size)  (* offset = name_key *)\r
else\r
begin (* standard procedure call, must be NEW-call *)\r
put1(zstdproccall, std);\r
new_call:= true; (* flag special call, used at endactual and endproccall *)\r
end; (* new call *)\r
end (* niv<0 *)\r
else put3(zproccall,niv,lix,size);\r
end;\r
\r
procedure actual;\r
var s : integer;\r
begin\r
passin(nix);   push;\r
with nametable(nix)^ do begin\r
ot^.dynamic := false;\r
ot^.type_nix:=comp_type;\r
ot^.var_nix:=nix;\r
ot^.kind:=nametable(comp_type)^.context;\r
ot^.size:=nametable(comp_type)^.size;\r
s:=ot^.size;\r
if s < word_length then s:=word_length;\r
ot^.context:=context;  (*save parameter type*)\r
case context of\r
var_param:  put0(zvarparam);\r
value_param: begin\r
put0(zvalueparam);\r
with nametable(comp_type)^ do\r
case context of\r
int_type, char_type, bool_type, scalar_type: put_arg1(word_typ);\r
pointer_type: put_arg1(type_pointer);\r
set_type: put_arg2(set_typ,size);\r
else put_arg2(addr_typ,size);\r
end;\r
end;\r
return_param: if versionz80 or lambdaversion then put1(zreturnparam,s)\r
else begin (*rc3502c*)\r
if odd(s) then s := s+1;\r
put1(zreturnparam,s);\r
end;\r
end;\r
end;\r
end;\r
\r
procedure end_actual;\r
var\r
pointed_type_nix: integer; (* used for call of NEW, the type of the new object *)\r
begin\r
with ot^ do begin\r
if context=struc_c then context:=lconst;\r
if (context=lconst) and (kind=array_type) then\r
if os^.size<>size then adjust_string(ot,os);\r
end;\r
with os^ do\r
case context of\r
value_param:   load_expr;\r
var_param: begin\r
if ot^.context=sconst then (* simple constant as readonly-var-param, simulate structured const *)\r
with ot^ do\r
begin\r
first:= offset; (* save value of constant *)\r
alloc_constant(niv (* of ot *), offset (* of ot *), os^.size);\r
if os^.size=byte_length then\r
begin\r
if (first>max_byte_value) or (first<0) then\r
begin\r
first:= 0;\r
error(type_error);\r
end;\r
if (* **z80** *) versionz80 then\r
update_const(offset, first)\r
else\r
update_const(offset, first shl 8); (* RC35022 *)\r
end\r
else\r
begin (* word length constant *)\r
if (* **z80** *) versionz80 then\r
first:= swap(first);\r
update_const(offset, first);\r
end;\r
context:= struc_c; (* change context *)\r
var_nix:= -1;\r
end; (* sconst, simulate struc *)\r
address;\r
end; (* varparam *)\r
return_param:  ;  (* no action *)\r
end;\r
if new_call then\r
(* convert to special call, i.e. add returnparam, size parameter, and allign parameter *)\r
begin\r
put1(zreturnparam, 4 (* size of result, (pointer) *));\r
put1(zvalueparam, word_typ);\r
pointed_type_nix:= nametable( ot^.type_nix (* the pointer *) )^.comp_type;\r
with nametable( pointed_type_nix )^ do\r
begin\r
if dynamic then\r
begin\r
put2(zaddr, niv, offset); (* size information from the dope vector *)\r
put1(zindvar, word_typ);\r
end\r
else\r
put1(zconst, size);\r
(* add allign parameter *)\r
put1(zvalueparam, word_typ);\r
put1(zconst, ord(context in allign_types));\r
put0(zendnewcall);\r
if context in init_types then\r
system_init(pointed_type_nix, 0 (* not used *));\r
end; (* with nametable[ pointed type nix ] *)\r
end; (* new call *)\r
pop; (* expr or addr *)\r
pop; (* saved parameter type *)\r
end;\r
\r
procedure label_goto(op: out_code);\r
begin\r
passin(nix);\r
with nametable(nix)^ do put1(op,lix);\r
end;\r
\r
procedure becomes;\r
begin\r
address;\r
with ot^ do \r
if kind= ref_type then (* exchange of refences *)\r
put1(zleft, ref_typ)\r
else\r
if kind=shadow_type then\r
put1(zleft, shadow_typ)\r
else\r
if field_packed then\r
put3(zleft,field_typ,first,comp_size)\r
else\r
load_var(zleft);\r
end;\r
\r
procedure assign;\r
begin\r
with ot^ do begin\r
if context=struc_c then context:=lconst;\r
if (kind=array_type) and (context=lconst) then adjust_string(ot,os);\r
end;\r
load_expr;  (* right hand side *)\r
pop;  (*right hand side*)\r
pop;  (*left hand side*)\r
put0(zassign);\r
end;\r
\r
procedure case_label;\r
begin\r
with ot^ do\r
if context=sconst then begin\r
put1(zcaselabel,offset);\r
end\r
else begin\r
error(var_error);  put1(zcaselabel,0);\r
end;\r
pop;\r
end;\r
\r
procedure caserange;\r
var last,first: integer;\r
begin\r
if (ot^.context<>sconst) or (os^.context<>sconst) then\r
begin\r
error(var_error); last:=0; first:=0;\r
end else begin\r
first:=os^.offset;\r
last:=ot^.offset;\r
end;\r
pop;  pop;\r
if last<first then \r
begin first:=last; error(range_error);  end;\r
put2(zcaserange,first,last);\r
end;\r
\r
procedure for_;\r
var load_type,temp: integer;\r
begin\r
address;                      (*control var addr*)\r
with ot^ do begin         (*push temp control var*)\r
if kind in simple_types then begin\r
if size=byte_length then load_type:=byte_typ\r
else load_type:=word_typ;\r
end\r
else compiler_error(for_error);\r
kind:=pointer_type;\r
context:=variable;\r
niv:=current_niv;\r
size:=pointer_length;\r
offset:=alloc_temp(size);\r
temp:=alloc_temp(word_length);\r
state:=indirect;\r
put3(zleftfor,offset,temp,load_type);\r
end;\r
end;\r
\r
procedure up_down(mode: integer);\r
begin\r
load_expr; pop;      (*load from expr value*)\r
ot^.lix:=mode;   (*set mode in temp control var addr*)\r
put0(zforstore);\r
end;\r
\r
procedure for_do;\r
var m:integer;\r
begin\r
load_expr;  pop;  (*load to expression value*)\r
with ot^ do begin\r
if lix=1 then m:=zup else m:=zdown;\r
end;\r
put1(zdo,m);   pop;\r
end;\r
\r
procedure end_for;\r
var m: integer;\r
begin\r
put0(zendfor);\r
release_temp(pointer_length+word_length);\r
end;\r
\r
\r
procedure withvar;\r
var\r
withvar_offset: integer;\r
begin\r
stat_part:= false;\r
push_name(nix);\r
ot^.temp_size:= current_offset; (* unstack limit after with statement *)\r
if not ot^.dynamic and temp_withvar_not_used then\r
with ot^ do begin\r
nametable(nix)^.context:=context;\r
nametable(nix)^.niv:=niv;\r
nametable(nix)^.offset:=offset;\r
withvar_offset:= 0; (* value not used *)\r
temp_withvar_not_used:=false;\r
put2(zaddr, niv, offset); (* dummy "variable", not used by pass5 *)\r
end\r
else\r
with nametable(nix)^ do begin\r
address;\r
context:=with_var;\r
niv:=current_niv;\r
offset:=alloc_temp(pointer_length);\r
withvar_offset:= offset;\r
end;\r
if ot^.dynamic then\r
put3(zwithdynvar, nametable( ot^.type_nix )^.niv, nametable( ot^.type_nix )^.offset, withvar_offset)\r
else\r
put2(zwithvar, ot^.size, withvar_offset);\r
end; (* with var *)\r
\r
procedure retype;\r
var\r
type_size, type_niv, type_offset: integer;\r
dyn: boolean;\r
begin\r
with (* new type *) nametable( stack_top^.stacked_val )^ do\r
begin\r
type_size:= size; (* size if static *)\r
dyn:= dynamic;\r
type_niv:= niv; (* dope vector address if dynamic *)\r
type_offset:= offset;\r
end;\r
pop_to_free_stack(1); (* pop new type info *)\r
\r
if dyn (* new type *) then\r
put2(zdynretype, type_niv, type_offset)\r
else\r
if not ot^.dynamic then (* both types are static, compile time size check *)\r
begin\r
if type_size (* of new type *) > ot^.size (* of with variable *) then\r
error(with_size_error);\r
put0(znoretype); (* no size test at run time *)\r
end\r
else\r
put1(zretype, type_size);\r
\r
if versionz80 then begin\r
if -current_offset>var_length then\r
var_length:= -current_offset\r
end\r
else\r
(* ** lambda or 3502c ** *)\r
if current_offset > var_length then\r
var_length := current_offset;\r
with ot^ do\r
temp_size := current_offset - temp_size;   (* size allocated for types *)\r
\r
pop_to_free_stack(1); (* pop with variable *)\r
stat_part:= true;\r
end; (* retype *)\r
\r
\r
procedure no_retype;\r
begin\r
put0(znoretype);\r
with ot^ do\r
temp_size:= current_offset-temp_size; (* size allocated for with address *)\r
pop_to_free_stack(1); (* pop with variable *)\r
stat_part:= true;\r
end; (* no retype *)\r
\r
\r
procedure end_with;\r
begin\r
put0(zendwith);\r
with ot^ do\r
release_temp(ot^.temp_size);\r
pop;\r
end;\r
\r
procedure lock_var_;\r
begin\r
stat_part:=false;\r
push_name(nix);\r
address;   \r
ot^.temp_size := current_offset;\r
end;\r
\r
procedure lock_type;\r
var type_size, type_niv, type_offset : integer;\r
dyn : boolean;\r
begin\r
with nametable( stack_top^.stacked_val )^ do begin\r
type_size:=size;\r
dyn:=dynamic;\r
type_niv:=niv;\r
type_offset:=offset;\r
end;\r
pop_to_free_stack(1);\r
with nametable(stack_top^.stacked_val)^ do begin\r
context:=lock_var;\r
niv:=current_niv;\r
if lock_mes_stat then\r
offset:= alloc_var(pointer_length+lockmes_templ_size)\r
else\r
offset:=alloc_var(pointer_length);\r
if dyn then\r
put3(zlockdynvar, type_niv, type_offset, offset)\r
else\r
put2(zlockvar, type_size, offset);\r
end;\r
if versionz80 then begin\r
if -current_offset>var_length then\r
var_length:= -current_offset\r
end\r
else\r
(* ** lambda or 3502c ** *)\r
if current_offset > var_length then\r
var_length := current_offset;\r
with ot^ do\r
temp_size := current_offset - temp_size;   (* size allocated for types *)\r
pop_to_free_stack(1);\r
stat_part := true;\r
end;\r
\r
procedure end_lock;\r
begin\r
put0(zendlock);\r
release_temp(ot^.temp_size);\r
pop;\r
end;\r
\r
procedure loop_goto(code_kind: out_code);\r
var\r
param: integer; (* pass3 code *)\r
begin (* exitloop/continueloop/exitlock (statement to loop in or exit from) *)\r
if versionz80 then error(not_impl_cont_exit_loop)\r
else\r
begin\r
put0(code_kind);\r
passin(param);\r
case convert_in_code[ param ] of\r
xchannel:    code_kind:= zchannel;\r
xforstat:    code_kind:= zforstat;\r
xlockstat:   code_kind:= zlockstat;\r
xloopstat:   code_kind:= zloopstat;\r
xrepeat:     code_kind:= zrepeat;\r
xwhile:      code_kind:= zwhile;\r
else compiler_error(input_error);\r
end; (* case *)\r
put0(code_kind);\r
end; (* not version z80 *)\r
end; (* loop goto *)\r
\r
\r
procedure chan_var;\r
var temp: integer;\r
begin\r
address;  pop;\r
put0(zchanvar);\r
end;\r
\r
procedure end_channel;\r
begin\r
put0(zendchannel);\r
end;\r
\r
procedure var_pointer;\r
begin\r
push_name(nix);\r
with nametable(nix)^ do begin\r
context:=variable;\r
niv:=current_niv;\r
offset:=alloc_temp(pointer_length);\r
put1(zvarpointer, offset);\r
end;\r
end;\r
\r
procedure tempointer;\r
var p: integer;\r
begin\r
address;\r
pop;\r
p:=alloc_temp(pointer_length);\r
put1(ztempointer,p);\r
end;\r
\r
procedure arglist_size;\r
var p: integer;\r
begin\r
p:=alloc_temp(word_length);\r
put1(zarglistsize,p);\r
if (* ***z80** *) versionz80 then\r
nametable( stack_top^.stacked_val )^.offset:=p;\r
pop_to_free_stack(1); (* pop name stack *)\r
end;\r
\r
procedure end_proc;\r
var i,n: integer;\r
begin\r
put0(zendpcall);\r
passin(n);                (* number of process param lists*)\r
for i:=1 to n do begin\r
release_temp(process_param_length);\r
put0(zendprocessparam);\r
end;\r
end;\r
\r
procedure end_func;\r
var i,n: integer;\r
begin\r
put0(zfcall);\r
passin(n);          (* number of process param lists *)\r
for i:=1 to n do \r
with ot^ do begin\r
temp_size:=temp_size + process_param_length;\r
put0(zendprocessparam);\r
end;\r
end;\r
\r
procedure var_ref;\r
begin\r
passin(nix);\r
with nametable(nix)^ do begin\r
ot^.var_nix:=nix;\r
ot^.context:=context;\r
if context=lconst then ot^.size:=size;\r
ot^.niv:=niv;\r
ot^.offset:=offset;\r
ot^.first:=min;\r
ot^.comp_size:=max;\r
if (context <> field) and (context <> dyn_field) then\r
ot^.field_packed:=false\r
else\r
ot^.field_packed:=packed_comp;\r
end;\r
end;\r
\r
procedure type_ref;\r
begin\r
passin(nix);\r
with nametable(nix)^ do begin\r
ot^.type_nix:=nix;\r
ot^.kind:=context;\r
ot^.lix:=lix;\r
if ot^.context<>lconst then \r
ot^.size:=size;\r
if context <> array_type then\r
ot^.array_packed:=false\r
else\r
ot^.array_packed:=packed_comp;\r
ot^.dynamic:=dynamic;\r
end;\r
end;\r
\r
procedure var_;\r
begin\r
push;\r
var_ref;   type_ref;\r
ot^.func_value:=false;\r
with ot^ do begin\r
if context in indirects then\r
state:=indirect else state:=direct;\r
end;\r
end;\r
\r
procedure field_;\r
var c: context_kind;  p: integer;\r
begin\r
if export then\r
with ot^ do begin\r
c:=context;  p:=offset;\r
var_ref;  type_ref;\r
if context <> field then error(error_dyn);\r
context:=c;\r
field_offset:=field_offset+offset;\r
offset:=p;\r
end\r
else\r
begin\r
temp_withvar_not_used:= false;\r
address;\r
var_ref;   type_ref;\r
with ot^ do begin\r
if context = field then\r
put1(zfield, offset)\r
else\r
put2(zdynfield, niv, offset);\r
state:=addr;\r
end;\r
end;\r
end;\r
\r
procedure arrow;\r
begin\r
if ot^.func_value then begin\r
type_ref;\r
with ot^ do begin\r
state:=addr;   context:=expr;\r
func_value:=false;\r
end;\r
end\r
else\r
begin\r
temp_withvar_not_used:= false;\r
address;\r
if (* **rc3502c** *) (not versionz80) and (not lambdaversion) then\r
if ot^.kind = ref_type then\r
put1(zfield,byte_length);\r
put0(zindaddr);\r
ot^.state:=addr;\r
type_ref;\r
end;\r
end;\r
\r
procedure index_expr;\r
begin\r
temp_withvar_not_used:= false;\r
address;\r
with ot^ do\r
if array_packed then put0(zpackedarr)\r
else put0(zindexexpr);\r
end;\r
\r
procedure index;\r
var nix, e: integer;   pa : boolean;\r
begin\r
load_expr;   (*load index value*)\r
pop;         (*index value*)\r
passin(nix);   (* array type nix *)\r
with nametable(nix)^ do begin\r
if dynamic then\r
put2(zindex, niv, offset+2)\r
else\r
if not(lambdaversion or versionz80)     (*rc3502 mod.2*)\r
   and not packed_comp\r
   and ( (min = 0) or (min = 1) )\r
   (* static array with index starting in 0 or 1 and static element type *)\r
then\r
put3(zhindex, min, max, niv)\r
else begin\r
if lix < 0 then begin  (* alloc dope vector *)\r
lix:=-lix;\r
alloc_dope(lix, min, max, niv);\r
end;\r
put1(zcindex, lix);\r
end;\r
pa:=packed_comp;\r
end;\r
type_ref;\r
if pa then\r
with ot^ do begin\r
state:=p_comp;  size:=word_length;\r
end;\r
end;\r
\r
procedure literal;\r
var i, c_index : integer;\r
    ty,l,clix,ch1,ch2,ch,val,base: integer;\r
begin\r
passin(ty);   passin(l);\r
case ty of\r
string_const: begin\r
alloc_constant(clix,c_index,l);\r
for i:=c_index to c_index+l div 2-1 do begin\r
passin(ch1); passin(ch2);\r
if (* **z80** *) versionz80 then\r
update_const(i, ch2 shl 8 + ch1)\r
else\r
(* **lambda or rc3502c** *)\r
update_const(i, ch1 shl 8+ch2);\r
end;\r
if l mod 2 <> 0 then begin\r
passin(ch);\r
i:=c_index + l div 2;\r
if (* **z80** *) versionz80 then\r
update_const(i, ord(' ') shl 8 + ch)\r
else\r
(* **lambda or rc3502c** *)\r
update_const(i, ch shl 8+ord(' '));\r
end;\r
push;\r
with ot^ do begin\r
var_nix:=-1;\r
type_nix:=-1;\r
kind:=array_type; niv:=clix;\r
offset:=c_index;    size:=l;\r
context:=struc_c;  state:=direct;\r
dynamic:=false;\r
end;\r
end;\r
char_const: begin\r
passin(ch);\r
push;\r
with ot^ do begin\r
type_nix:=-1;\r
var_nix:=-1;\r
kind:=char_type;\r
offset:=ch;    size:=char_length;\r
context:=sconst;  state:=direct;\r
dynamic:=false;\r
end;\r
end;\r
num_const: begin\r
passin(ch);   val:=0;   base:=10;\r
if ch=ord('#') then begin\r
passin(ch);   l:=l-2;\r
if ch=ord('b') then base:=2\r
else if ch=ord('o') then base:=8\r
else if ch=ord('h') then base:=16\r
else if ch=ord('d') then base:=10\r
else error(literal_error);\r
passin(ch);\r
end;\r
for i:=1 to l do begin\r
if ch<=ord('9') then ch:=ch-ord('0')\r
else if ch>=ord('a') then ch:=ch-ord('a')+10;\r
if (ch<0) or (ch>=base) then begin\r
error(literal_error);\r
ch:=0;\r
end;\r
if base=10 then\r
val:=int_add(int_mul(val,base),ch)\r
else\r
begin\r
(*$R-*)\r
case base of\r
2: if val<0 then\r
begin\r
error(literal_error);\r
val := 0;\r
end;\r
8:if (-1) shr 3 < val then\r
begin\r
error(literal_error);\r
val := 0;\r
end;\r
16:if (-1) shr 4 < val then\r
begin\r
error(literal_error);\r
val := 0;\r
end;\r
end;\r
val:=val*base+ch;\r
(*$R+*)\r
end;\r
if i<l then passin(ch);\r
end;\r
push;\r
with ot^ do begin\r
type_nix:=-1;\r
var_nix:=-1;\r
kind:=int_type;     offset:=val;\r
context:=sconst;    state:=direct;\r
size:=word_length;\r
dynamic:=false;\r
end;\r
end;\r
end;\r
end; (* literal *)\r
\r
Procedure typesize_call;\r
begin\r
passin(nix);\r
push;\r
with ot^ do\r
begin (* initialize common fields *)\r
type_nix:= -1;\r
var_nix:= -1;\r
state:= direct;\r
kind:= int_type;\r
dynamic:= false;\r
size:= word_length;\r
end; (* with ot^ *)\r
with nametable( nix )^ (* type nix *) do\r
if dynamic then\r
begin\r
ot^.context:= variable;\r
ot^.niv:= niv; (* of dope vector *)\r
ot^.offset:= offset; (* of dope vector *)\r
(* niv, offset denotes the size field of the dope vector *)\r
end\r
else (* static *)\r
begin\r
ot^.context:= sconst;\r
ot^.offset:= size (* of object *);\r
end;\r
end; (* type size call *)\r
\r
\r
procedure new_set;\r
begin\r
push;\r
get_pushed_consts;\r
if stat_part then begin\r
put0(zset);\r
with ot^ do begin\r
kind:=set_type;  context:=expr;\r
size:=0;\r
state:=expression;\r
end\r
end\r
else\r
begin\r
with ot^ do begin\r
kind:=set_type;\r
size:=set_const_length*2;\r
alloc_constant(niv,offset,size);\r
context:=set_const;   first:=0;\r
state:=direct;\r
var_nix:= -1; type_nix:= -1;\r
dynamic:=false;\r
end;\r
end;\r
end;\r
\r
procedure set_bit(no: integer); forward;\r
\r
procedure set_expr;\r
begin\r
if stat_part then begin\r
load_expr;   pop;\r
put0(zsetexpr);\r
end;\r
end;\r
\r
procedure include_int;\r
var min,max,i: integer;\r
begin\r
if stat_part then begin\r
load_expr;   pop;\r
put0(zincludeint);\r
end else begin\r
max:=take_expr;   min:=take_expr;\r
if (min<0) or (min>max_set_const_value) then begin\r
error(set_error);\r
min:=0;\r
end;\r
if (max>max_set_const_value) then begin\r
error(set_error);\r
max:=min;\r
end;\r
for i:=min to max do set_bit(i);\r
end;\r
end;\r
\r
procedure include;\r
var v: integer;\r
begin\r
if stat_part then begin\r
load_expr;   pop;\r
put0(zinclude);\r
end else begin\r
v:=take_expr;\r
if (v<0) or (v>max_set_const_value) then begin\r
error(set_error);\r
v:=0;\r
end;\r
set_bit(v);\r
end;\r
end;\r
\r
procedure set_bit(no: integer);\r
var bit,word, old: integer;\r
begin\r
bit :=no mod bits_pr_word;\r
word:=ot^.offset + no div bits_pr_word;\r
old :=retrieve_const(word);\r
if old and (1 shl ((bits_pr_word-1)-bit)) = 0 then\r
update_const(word, old or (1 shl ((bits_pr_word-1)-bit)));\r
with ot^ do\r
if first<no then first:=no;\r
end;\r
\r
procedure end_set;\r
var words: integer;\r
begin\r
passin(nix);\r
if stat_part then\r
put0(zendset)\r
else\r
with ot^ do begin\r
(* offset is index in c  --  first is max value of expr *)\r
words:=(first + 1 + bits_pr_word - 1) div bits_pr_word;\r
if words=0 then words:=1;\r
size:=words*2;\r
cut_constant(offset,words);\r
with nametable(nix)^ do begin\r
context:=set_type;\r
size:=words*2;\r
min:=0;   max:=ot^.first;\r
end;\r
end;\r
end;\r
\r
procedure null;\r
begin\r
push;\r
with ot^ do begin\r
kind:=int_type;    offset:=0;\r
size:=0;           context:=sconst;\r
state:=direct;\r
end;\r
end;\r
\r
procedure struc_const;\r
begin\r
(* push const level *)\r
if ss^.next_struc= nil then\r
begin\r
new(ss^.next_struc);\r
with ss^.next_struc^ do\r
begin\r
next_struc:= nil; (* top element *)\r
former_struc:= ss;\r
end;\r
top_ss:= top_ss+1;\r
end; (* allocate one more element *)\r
ss:= ss^.next_struc;\r
passin(nix);\r
with nametable(nix)^, ss^ do begin\r
saved_nix:=nix;\r
alloc_constant(saved_lix,first,size);\r
(*$R-*)\r
first:=first*2;\r
displ:=first;\r
saved_size:=size;\r
saved_stat_part:=stat_part;\r
stat_part:=false;\r
dope_lix:=lix;\r
times:=1;\r
if context in array_types then begin\r
if packed_comp then begin\r
init_mode:=packed_array;\r
elem_pr_word:=niv shr 8;\r
bits_pr_field:=niv and 255;\r
end else\r
init_mode:=array_init;\r
current_index:=0;   top_index:=max-min+1;\r
(*$R+*)\r
end else\r
init_mode:=record_init;\r
if dynamic then begin\r
error(error_dyn);\r
init_mode:=error_init;\r
end;\r
end;\r
end;\r
\r
procedure end_struc;\r
begin\r
push;\r
with ot^, ss^ do begin\r
if init_mode=record_init then\r
kind:=record_type else kind:=array_type;\r
array_packed:=init_mode = packed_array;\r
field_packed:=false;\r
lix:=dope_lix;\r
size:=saved_size;\r
state:=direct;\r
offset:=first shr 1;\r
niv:=saved_lix;\r
context:=struc_c;\r
var_nix:=-1;\r
type_nix:=saved_nix;\r
func_value:=false;\r
dynamic:=false;\r
if init_mode <> error_init then\r
if init_mode<>record_init then\r
begin\r
if current_index<>top_index then error(const_error);\r
end;\r
stat_part:=saved_stat_part;\r
end;\r
ss:=ss^.former_struc; (* pop const level*)\r
end;\r
\r
procedure times_;\r
begin\r
with ss^ do begin\r
times:=take_expr;\r
if init_mode <> error_init then\r
if (times<0) or (current_index+times>top_index) then begin\r
error(const_error);\r
times:=top_index-current_index;\r
end;\r
end;\r
end;\r
\r
\r
procedure put_byte(val:integer; addr: integer);\r
var sh:integer;\r
    w: integer;\r
begin\r
if (* **z80** *) versionz80 then begin\r
if odd(addr) then sh:=8 else sh:=0\r
end\r
else\r
begin\r
(* **lambda or rc3502c** *)\r
if odd(addr) then sh:=0 else sh:=8\r
end;\r
w:=addr shr 1;\r
(*$R-*)\r
update_const(w, retrieve_const(w) + val shl sh);\r
(*$R+*)\r
end; (*put byte*)\r
\r
procedure put_word(val:integer; addr: integer);\r
var w: integer;\r
begin\r
w:=addr shr 1;\r
if (* **z80** *) versionz80 then begin\r
if odd(addr) then begin\r
update_const(w, retrieve_const(w) + (val and 255) shl 8);\r
update_const(w+1, retrieve_const(w+1) + val shr 8);\r
end\r
else update_const(w, val + retrieve_const(w));\r
end\r
else\r
begin\r
(* **lambda or rc3502c** *)\r
if odd(addr) then begin\r
update_const(w, retrieve_const(w) + val shr 8);\r
update_const(w+1, retrieve_const(w+1) + (val and 255) shl 8);\r
end\r
else\r
update_const(w, val+retrieve_const(w));\r
end;\r
end;(*put word*)\r
\r
procedure get_byte(var val: integer; addr: integer);\r
var q: integer;\r
    w: integer;\r
begin\r
w:=addr shr 1;\r
q:=retrieve_const(w);\r
if (* **z80** *) versionz80 then begin\r
if odd(addr) then\r
val:=q shr 8\r
else\r
val:=q and 255;\r
end\r
else\r
begin\r
(* **lambda or rc3502c** *)\r
if odd(addr) then\r
val:=q and 255\r
else\r
val:=q shr 8\r
end;\r
end;(*get byte*)\r
\r
procedure put_constant(var displ: integer; times,const_size: integer);\r
var c_index, p, q, val : integer;\r
    dsize,sh,rest,v,i: integer;  con: context_kind;\r
remove, fill: boolean;\r
begin\r
with ot^ do begin\r
dsize:=size;   val:=offset;\r
con:=context;\r
end;\r
if con=struc_c then begin\r
c_index:=val;\r
remove:=true;  con:=lconst;\r
end else remove:=false;\r
pop;\r
if (con<>sconst) and (con<>lconst) and (con<>set_const) then begin\r
error(var_error);\r
dsize:=0;\r
end;\r
for i:=1 to times do begin\r
if dsize=0 then (*null*) else\r
if (const_size=byte_length) and (con=sconst) then begin\r
if (val>max_byte_value) or (val<0) then begin\r
val:=0;\r
error(type_error);\r
end;\r
put_byte(val, displ);\r
end else\r
if (const_size=word_length) and (con=sconst) then\r
begin\r
put_word(val, displ);\r
end\r
else\r
begin\r
rest:=const_size; q:=val shl 1;\r
if con=set_const then\r
begin (* adjust set-constants to demanded size *)\r
if dsize>const_size then error(type_error)\r
else\r
if dsize<const_size then\r
rest:=dsize;\r
end;\r
if dsize < rest then begin\r
rest:=dsize;  fill:=true;\r
end else fill:=false;\r
p:=displ;\r
(*$R-*)\r
while rest<>0 do begin\r
get_byte(v,q);   put_byte(v,p);\r
p:=p+1;  q:=q+1;\r
rest:=rest-1;\r
end;\r
(*$R+*)\r
if fill then begin\r
rest:=const_size - dsize;\r
while rest > 0 do begin\r
put_byte(32,p);\r
p:=p+1;   rest:=rest-1;\r
end;\r
end;\r
end;\r
(*$R-*)\r
displ:=displ+const_size;\r
(*$R+*)\r
end;  (*for times*)\r
if remove then remove_constant(c_index);\r
end;\r
\r
procedure struc;\r
var first_bit,val,q,r,s,i: integer;\r
    w : integer;\r
begin\r
passin(nix);\r
with ss^, nametable(nix)^ do begin\r
case init_mode of\r
array_init: begin\r
if current_index+times>top_index then begin\r
times:=0;\r
error(const_error);\r
end;\r
s:=size;\r
if (* **lambda or rc3502c** *) not versionz80 then\r
if size>2 then\r
if odd(size) and (context in allign_types) then\r
s:=s+1;\r
put_constant(displ, times, s);\r
current_index:=current_index+times;\r
times:=1;\r
end;\r
record_init: begin\r
displ:=first+offset;\r
if packed_comp then begin\r
first_bit:=min;   bits_pr_field:=max;\r
with ot^ do\r
if context=sconst then begin\r
val:=offset;\r
if bits(val)>bits_pr_field then begin\r
error(type_error);\r
val:=0;\r
end;\r
end else begin\r
error(var_error);\r
val:=0;\r
end;\r
pop;\r
(*$R-*)\r
q:=val*(1 shl ((bits_pr_word-1)-(first_bit+bits_pr_field-1)));\r
(*$R+*)\r
put_word(q, displ);\r
end else\r
put_constant(displ,1,size);\r
end;\r
packed_array:  begin\r
with ot^ do\r
if context=sconst then begin\r
val:=offset;\r
if bits(val)>bits_pr_field then begin\r
error(type_error);\r
val:=0;\r
end;\r
end else begin\r
error(var_error);\r
val:=0;\r
end;\r
pop;\r
if current_index+times>top_index then begin\r
times:=0;\r
error(const_error);\r
end;\r
for i:=1 to times do begin\r
q:=elem_pr_word;\r
first_bit:=(current_index mod q)*bits_pr_field;\r
w:=first + (current_index div q)*2;\r
(*$R-*)\r
r:=val*(1 shl ((bits_pr_word-1)-(first_bit+bits_pr_field-1)));\r
(*$R+*)\r
put_word(r, w);\r
current_index:=current_index+1;\r
end; (*for*)\r
times:=1;\r
end; (*packed*)\r
error_init: begin\r
times:=1;\r
pop;\r
end;\r
end; (*case*)\r
end; (*with*)\r
end;\r
\r
begin\r
initialize;\r
\r
repeat\r
passin(no);\r
\r
case convert_in_code[no] of\r
\r
xactual:      actual;\r
xadd:         arithmetic(zadd);\r
xand:         arithmetic(zand);\r
xarglistsize: arglist_size;\r
xarraydef:    array_def(non_pack);\r
xarrow:       arrow;\r
xassign:      assign;\r
xassignstat:  put0(zassignstat);\r
xbecomes:     becomes;\r
xbegincode:   begin_code;\r
xblock:       new_block;\r
xboolean:    std_name(xboolean);\r
xcase:        begin stat_part:=false; pass_expr(zcase); end;\r
xcaselabel:   case_label;\r
xcaserange:   caserange;\r
xcasestat:    put0(zcasestat);\r
xchannel:     begin\r
if (* **z80** *) versionz80 then error(error_channel);\r
put0(zchannel);\r
end;\r
xchanvar:     chan_var;\r
xchar:       std_name(xchar);\r
xchr:         std_name(xchr);\r
xcodeline:    code_line;\r
xconstid:     const_def;\r
xcontloopstat:loop_goto(zcontloopstat);\r
xdiv:         arithmetic(zdiv);\r
xdo:          for_do;\r
xdown:        up_down(-1);\r
xelse:        put0(zelse);\r
xendactual:   end_actual;\r
xendblock:    end_block;\r
xendcase:     begin stat_part:=true; put0(zendcase); end;\r
xendcaselist: begin stat_part:=true;\r
    put0(zendcaselist); end;\r
xendcasestat: begin stat_part:=false; put0(zendcasestat); end;\r
xendchannel:  end_channel;\r
xendcode:     begin put0(zendcode); put2(zendblock,2,1);  pop_level; end;\r
xendexport:   end_export;\r
xendfor:      end_for;\r
xendfunccall: end_func_call;\r
xendlock:     end_lock;\r
xendloopstat: put0(zendloopstat);\r
xendprelude:  begin word_allign;\r
source_line:=0;\r
if (* **lambda or rc3502c** *) not versionz80 then \r
process_offset:=current_offset; prelude:=false; end;\r
xendproc:     if new_call then begin passin(i); new_call:= false; end else end_proc;\r
xendrepeat:   pass_expr(zendrepeat);\r
xendset:      end_set;\r
xendstruc:    end_struc;\r
xendwhile:    put0(zendwhile);\r
xendwith:     end_with;\r
xeom:         eom;\r
xeq:          equality(zeq);\r
xerror:       begin copy(zerror,2); program_ok:=false; end;\r
xerrorno:     begin copy(zerrorno,1); program_ok:=false; end;\r
xerrortext:   begin copy(zerrortext,1); program_ok:=false; end;\r
xexception:   exception_def;\r
xexchange:    begin pass_addr(zexchange);  pop;  end;\r
xexchangestat:    put0(zexchstat);\r
xexitlock:    loop_goto(zexitlock);\r
xexitstat:    if versionz80 then error(not_impl_exit)\r
else put0(zexitstat);\r
xexitloopstat:loop_goto(zexitloopstat);\r
xexportaddr:  begin export:=true; export_kind:=exportaddr end;\r
xexportdispl: begin export:=true; export_kind:=exportdispl end;\r
xexportoffset:begin export:=true; export_kind:=exportoffset end;\r
xexportsize:  begin export:=true; export_kind:=exportsize end;\r
xexportvalue: begin export:=true; export_kind:=exportvalue end;\r
xexpr:        first_of_expr:=ot;\r
xexternal:    external_;\r
xextprocdef:  extprocess_def;\r
xextprocess:  begin\r
push_name(nix);\r
passin(i);\r
nametable( nix )^.comp_type:= i;\r
end;\r
xfcall:       end_func;\r
xfield:       field_;\r
xfielddef:    field_list;\r
xfieldid:     new_name;\r
xfor:         for_;\r
xforstat:     put0(zforstat);\r
xforward:     forward_;\r
xforwardpointer: forward_pointer_def;\r
xfrozendef:   redef_type;\r
xfunccall:    func_call;\r
xfuncid:      routine_def(func_mode);\r
xge:          equality(zge);\r
xgetexpr:     load_operand;\r
xgetvalue:    load_operand;\r
xgoto:        label_goto(zgoto);\r
xgt:          equality(zgt);\r
xif:          put0(zif);\r
xifexpr:      pass_expr(zifexpr);\r
xifstat:      put0(zifstat);\r
xin:          inclusion;\r
xinclude:     include;\r
xincluderange:  include_int;\r
xindex:       index;\r
xindexexpr:   index_expr;\r
xinitblock:   begin stat_part:=true; word_allign;\r
put0(zenddecl);\r
if (* **z80** *) versionz80 then\r
i:= - current_offset\r
else\r
(* **lambda or rc3502c** *)\r
i:=current_offset;\r
if i>var_length then var_length:=i;\r
end;\r
xinitconst:   variable_init:=true;\r
xinteger:    std_name(xinteger);\r
xlabel:       label_goto(zdeflix);\r
xle:          equality(zle);\r
xlabelid:     new_label;\r
xliteral:     literal;\r
xlock:        lock_type;\r
xlockmesstat: if versionz80 then error(not_impl_lockmes) else\r
              begin lock_mes_stat:= true; put0(zlockmesstat); end;\r
xlockstat:    begin lock_mes_stat:= false; put0(zlockstat); end;\r
xlockvar:     lock_var_;\r
xloopstat:    if versionz80 then error(not_impl_loop) else\r
              put0(zloopstat);\r
xlt:          equality(zlt);\r
xmod:         arithmetic(zmod);\r
xmul:         arithmetic(zmul);\r
xname:        name;\r
xne:          equality(zne);\r
xneg:         neg_not(zneg);\r
xnew:         std_name(xnew);\r
xnewline:     new_line;\r
xnil:         if versionz80 then passin(nil_nix) (* remember nix *)\r
else std_name(xnil);\r
xnilref:      if versionz80 then\r
begin\r
passin(nix);\r
(* let entry: nilref be equal to entry: nil *)\r
nametable(nix)^:= nametable(nil_nix)^; (* NIL MUST BE DECLARED BEFORE NILREF !!!!!!!!!!!!  *)\r
end\r
else std_name(xnilref);\r
xniltype:     std_name(xniltype);\r
xnoretype:    no_retype;\r
xnot:         neg_not(znot);\r
xnull:        null;\r
xoption:      set_option;\r
xor_:         arithmetic(zor_);\r
xord:         std_name(xord);\r
xotherwise:   put0(zotherwise);\r
xparamid:     new_name;\r
xpackedarraydef:   array_def(pack);\r
xpointerdef:  pointer_def;\r
xpooldef:     pool_def;\r
xpred:        std_name(xpred);\r
xpackedrecord:     begin push_level(record_mode); pack_record:=pack end;\r
xprefix:      begin prefixed:=true; prefixed_name:=true; end;\r
xprocessid:   process_def;\r
xproccall:    proc_call;\r
xprocessparam:begin push; get_pushed_consts; pop; put0(zprocessparam); end;\r
xprocid:      routine_def(proc_mode);\r
xrange:       range;\r
xreal:        std_name(xreal);\r
xrecdef:      record_def;\r
xrecord:      push_level(record_mode);\r
xredeftype:   redef_type;\r
xreference:   std_name(xreference);\r
xrepeat:      put0(zrepeat);\r
xretype:      retype;\r
xscalardef:   scalar_def;\r
xscalarid:    new_scalar;\r
xsecfuncid:   previous_forward(func_mode);\r
xsecprocid:   previous_forward(proc_mode);\r
xsemaphore:   std_name(xsemaphore);\r
xset:         new_set;\r
xsetdef:      set_def;\r
xsetexpr:     set_expr;\r
xshadow:      std_name(xshadow);\r
xshift:       arithmetic(zshift);\r
xstringtype:  std_name(xstringtype);\r
xstruc:       struc;\r
xstrucconst:  struc_const;\r
xsub:         arithmetic(zsub);\r
xsubdef:      sub_def;\r
xsucc:        std_name(xsucc);\r
xtempointer:  tempointer;\r
xtimes:       times_;\r
xtype:        push_name(nix);\r
xtypedef:     pop_to_free_stack(1);\r
xtypesizecall: typesize_call;\r
xerrortype:   std_name(xerrortype);\r
xundeclid:    std_name(xundeclid);\r
xuntil:       put0(zuntil);\r
xup:          up_down(+1);\r
xvalueparam:  formal_param(value_param);\r
xvar:         var_;\r
xvarparam:    formal_param(var_param);\r
xvarid:       new_name;\r
xvarlist:     var_list;\r
xvarpointer:  var_pointer;\r
xwhile:       put0(zwhile);\r
xwhileexpr:   pass_expr(zwhileexpr);\r
xwith:        begin put0(zwithstat); temp_withvar_not_used:=true; end;\r
xwithvar:     withvar;\r
xxor:         arithmetic(zxor);\r
else compiler_error(input_error);\r
end;\r
until done;\r
if test_survey then\r
begin\r
writeln(output, 'Information survey from ', version);\r
writeln(output, 'Deepest name stack:                          ', top_stack);\r
writeln(output, 'Deepest operand stack:                       ', top_ops);\r
writeln(output, 'Constant area size:                          ', top_c);\r
writeln(output, 'Deepest structure nesting:                   ', top_ss);\r
needed_namesize := memavail;\r
release(heaporg);\r
writeln(output, 'Heep space used in bytes:                    ',\r
                memavail - needed_namesize);\r
writeln(output);\r
end; (* test survey *)\r
\r
end; (* pass4 *)\r
\r
begin\r
if max_name_index < max_memories * max_names then\r
begin\r
needed_namesize := 0;\r
i               := 0;\r
max_name_key    := max_name_index;\r
\r
while max_name_index > max_names do\r
begin\r
needed_namesize := needed_namesize + max_names;\r
max_name_index  := max_name_index - max_names;\r
i := i + 1;\r
end;\r
\r
needed_namesize := needed_namesize + max_name_index;\r
needed_namesize := needed_namesize * sizeof(name_rec);\r
\r
if maxavail >= needed_namesize then\r
begin\r
needed_namesize := max_name_index+1;\r
needed_namesize := needed_namesize * sizeof(name_rec);\r
getmem(nametab_ptr[i], needed_namesize);\r
needed_namesize := max_names;\r
needed_namesize := needed_namesize * sizeof(name_rec);\r
for max_name_index := 0 to i-1 do\r
getmem(nametab_ptr[max_name_index], needed_namesize);\r
max_name_index := max_name_key;\r
max_name_key   := 0;\r
\r
pass4;\r
\r
end else\r
begin\r
  needed_namesize := 0;\r
end;\r
end else\r
begin\r
  needed_namesize := 0;\r
end;\r
\r
if needed_namesize = 0 then\r
begin\r
writeln(output, 'too many names ', max_name_index);\r
writeln(output, '     available ', maxavail div sizeof(name_rec) - 1);\r
end;\r
end;\r
«eof»