⟦e4d365ece⟧

TextFile

; editpass4
;(edit pass4text
;finis)


; 81.05.11   page 57     procedure inclusion
; 81.05.12   page 60     procedure actual
;            page 31     procedure std_name, niltype size 2
; 81.05.29               pool n; ok
;                        -channel stat i z80
;                        function^.field; ok
; 81.06.09               save current lix; ok
;                        var a:alfa:='abc';  ok
;                        #b10000000000000000; ok






; page 1

l./versionpass4 = /,   d1,   i/

versionpass4 = 400;  (* version this pass 4.00      *)
versionpass3 = 2;    (* pass 3 version must be 2.xx *)
/,  
p-1







; page 9


l./context_kind = /,
l./var_param,/,   r/value_param,/value_param,    return_param,/,


l./error_types = (/,
l./);/,  r/)/, error_channel)/,


; page 11

l./array_types, index_types,/,
r/a/direct_return, a/,

l./: boolean/,  r/ :/, param_list : /,

l./undef_nix,/,   i/
niltype_nix,
/,



; page 17

l./procedure pass4error(e:/,
l./not_implemented:/,  l1,  i/
error_channel:          writeln('channel statement not implemented in z80');
/,

; page 20

l./procedure initialize;/,


; page 21

l./export:=false;/,   l1,  i/
param_list:=true;
/,


; page 22

l./array_types:=/,    i/
direct_return:=Æint_type, char_type, bool_type, scalar_type, 
dyn_subrange, pointer_typeÅ;/,

; page 24





; page 31

l./procedure std_name(ty:/,
l./xniltype:/,
l./size:=/,   r/0/2/,
i/
niltype_nix:=nix;
/,





; page 32

l./procedure sub_def;/,


; page 33

l./size:=var_size(min,max);/,   i/
dynamic:=false;
/,
l./begin (*dynamic*)/,
l./offset:=alloc_var(/,  i/
word_allign;
/,

l./error(not_implemented)/,  l1,  i/
min:=0;  max:=1;
/,


; page 35

l./procedure array_def(pack/,

; page 36

l./offset:=alloc_var(array_template_size);/,
i/
word_allign;
/,


; page 40

l./procedure pool_def;/,
l./data_size:=size/,   i/
if stackÆtÅ = niltype_nix then
data_size:=0
else
/,


; page 41

l./procedure formal_param(c:/,
i/

function alloc_process_param : integer;  (* return = param length *)
var type_nix, no, param_size, byte_displ, parameter_length : integer;
begin
for no:=param_number - 1 downto 0 do
with nametableÆ stackÆt-noÅ Å do begin
type_nix:=comp_type;
if context = value_param then
param_size:=nametableÆtype_nixÅ.size
else
param_size:=pointer_length;
if nametableÆtype_nixÅ.dynamic then begin
error(error_dyn);
param_size:=0;
end;
byte_displ:=0;
if (* **z80** *) versionz80 then begin
if param_size = byte_length then param_size:=word_length;
end
else
begin (* **lambda** *)
if nametableÆtype_nixÅ.context in index_types then
if param_size = byte_length then byte_displ:=1;
if odd(param_size) then param_size:=param_size+1;
end;
niv:=current_niv;
offset:=alloc_var(param_size);
offset:=offset+byte_displ;
end; (* for .. with .. *)
if (* **z80** *) versionz80 then
parameter_length:=-current_offset
else
(* **lambda** *)
parameter_length:=current_offset + 1;
displayÆthis_levelÅ.parameter_length:=parameter_length;
alloc_process_param:=parameter_length;
end;  (* alloc process param *)

function alloc_routine_param : integer;  (* return = param length *)
var q, no, parameter_offset, return_size, param_size,
parameter_length, byte_displ : integer;

function alloc_param(size : integer) : integer;
begin
if (* **z80** *) versionz80 then begin
(* parameter_offset >= 0 *)
alloc_param:=parameter_offset;
if top_address - parameter_offset >= size then
parameter_offset:=parameter_offset + size
else
error(address_overflow);
end
else
begin
(* **lambda** *)
(* parameter_offset <= 0 *)
if top_address + parameter_offset >= size then
parameter_offset:=parameter_offset - size
else
error(address_overflow);
alloc_param:=parameter_offset;
end;
end; (* alloc_param *)

begin (* alloc routine param *)
return_size:=0;
q:=param_number - 1;
if mode = func_mode then
with nametableÆ stackÆt-qÅ Å do begin
if nametableÆcomp_typeÅ.context in direct_return then begin
context:=return_param;
return_size:=nametableÆcomp_typeÅ.size;
if return_size=byte_length then return_size:=word_length;
end;
if nametableÆcomp_typeÅ.dynamic then error(error_dyn);
end;
if (* **z80** *) versionz80 then
parameter_offset:=0
else
(* **lambda** *)
parameter_offset:=-1;
parameter_length:=0;
for no:=0 to q do
with nametableÆ stackÆt-noÅ Å do begin
if context = var_param then
param_size:=pointer_length
else
(* value param and return param *)
with nametableÆ comp_typeÅ do begin
param_size:=size;
if dynamic then begin
error(error_dyn);
param_size:=0;
end;
end;
byte_displ:=0;
if (* **z80** *) versionz80 then begin
if param_size = byte_length then param_size:=word_length;
end
else
begin (* **lambda** *)
if nametableÆcomp_typeÅ.context in index_types then
if param_size = byte_length then byte_displ:=1;
if odd(param_size) then param_size:=param_size + 1;
end;
parameter_length:=parameter_length + param_size;
niv:=current_niv;
offset:=alloc_param(param_size);
offset:=offset + byte_displ;
end; (* for ... with .. *)
parameter_length:=parameter_length - return_size;
alloc_routine_param:=parameter_length;
end; (* alloc routine param *)
/,



l./procedure formal_param(c:/,
l./if c=value_param/,
d./if odd(parm_size) then/,  d,
l./niv:=current_niv;/,  d2,



; page 43

l./procedure new_block;/,
l./if (* **z80**/, 
d./displayÆthis_levelÅ./,
l./proc_mode, func_mode:/,   l2,  i/
if param_list then
parameter_length:=alloc_routine_param
else
parameter_length:=size;   (* routine previous defined *)
param_list:=true;
/,
l./size:=parameter/,  d,  i/
displayÆthis_levelÅ.parameter_length:=parameter_length;
size:=parameter_length;
/,
l./put_arg1(/,  d,
l./process_mode:/,   l1,  i/
parameter_length:=alloc_process_param;
/,

l./t:=t-param_number-1;/,   i/
displayÆthis_levelÅ.saved_lix:=current_lix;
/,


l./procedure external_;/,
l./if (* **z80/,  d4,  i/
size:=alloc_routine_param;
/,
l./pop_level;/,   i/
displayÆthis_levelÅ.saved_lix:=current_lix;
/,


l./procedure forward_;/,
l./size:=/,  r/current_offset/alloc_routine_param/,
l1,   i/
displayÆthis_levelÅ.saved_lix:=current_lix;
/,
l./current_offset:=nametable/,   d,  i/
param_list:=false;
/,







; page 45

l./procedure end_block;/,
l./if (* **z80/,   d6,   i/
if (* **lambda** *) not versionz80 then
var_length:=var_length+1;
if mode = process_mode then
var_length:=var_length - displayÆthis_levelÅ.parameter_length
else
var_length:=var_length - activation_record_length;
/,



l./put1(zlength/,  r/)/, displayÆthis_levelÅ.parameter_length)/,
r/1/2/,

; page 48

l./procedure init_values(nix/,
l./if opsÆotÅ.context=lconst/,
l./put0(zinitialize/,  i/
if opsÆotÅ.kind = array_type then begin
push;
opsÆotÅ.size:=size;
adjust_string(os, ot);
pop;
end;
/,



; page 55

l./procedure equality(op:/,


; page 56
l./int_type,char_type,bool_type,scalar_type:/,
r/:/,dyn_subrange:/,




; page 57

l./procedure inclusion;/,
l./load_expr;/,  i/
get_pushed_consts;
/,







; page 58

l./procedure func_call;/,
l1,  r/;/;   via_stack : boolean;/,
l./put1(zextfunccall/,   r/1/2/,   r/)/, size)/,
l./else put2(zfunccall/,   r/)/, size)/,
r/2/3/,
l./result_size:=size;/,  l1,  i/
via_stack:=context in direct_return;
/,
l./context:=func_result;/,   l1,   i/
if not via_stack then begin
/,
l./offset:=q;/,  l1,  i/
end (* not via stack *)
else
alloc_size:=0;
/,
l./with ops/,   i/
via_stack:=via_stack or (std>0);
/,
l./func_value:=std=0/,  r/std=0/via_stack/,


l./procedure end_func_call;/,
l./if ops/,  r/if/if not/,
l./put0(zendfunccall/,   r/)/,opsÆotÅ.size)/,
r/0/1/,


l./procedure proc_call;/,
l./put1(zextproccall/,   r/1/2/,   r/)/, size)/,
l./put2(zproccall/,  r/2/3/,  r/)/,size)/,



; page 60

l./procedure actual;/,
l1,  i/
var s : integer;
/,
l./opsÆotÅ.size:=/,   l1,   i/
s:=opsÆotÅ.size;
if s < word_length then s:=word_length;
/,
l./otherwise put_arg2(addr_typ/,  l2,  i/
return_param:  put1(zreturnparam, s);
/,



l./procedure end_actual;/,
l./var_param:/,   l1,  i/
return_param:  ;  (* no action *)
/,



; page 69

l./procedure var_;/,
l./with opsÆotÅ/,  i/
opsÆotÅ.func_value:=false;
/,



l./procedure arrow;/,
l./begin/,  l1,  i/
if opsÆotÅ.func_value then begin
type_ref;
with opsÆotÅ do begin
state:=addr;   context:=expr;
func_value:=false;
end;
end
else
begin
/,
l./end;/,  i/
end;
/,

; page 71

l./procedure literal;/,
l./num_const:/,
l./if val>max_int then val:=val + bit_0_8;/,
r/>/>=/,



; page 76

l./procedure end_struc;/,
l./dynamic:=false;/, i/
func_value:=false;
/,



; page 81

l./xchannel:put0(zchannel);/,
d,  i/
xchannel:     begin
if (* **z80** *) versionz80 then error(error_channel);
put0(zchannel);
end;
/,


f


▶EOF◀
DataMuseum.dk

RC4000/8000/9000

⟦e4d365ece⟧ TextFile

Derivation

TextFile
