⟦e2cc2f326⟧

TextFile

 
; dynedit
; (edit nyp4text     ;  d.810226.1658
;finis)






















;page 1

l./versionpass4 =/,  r/202/302/,  r/2.02/3.02/,  r/81.02.26/81.xx.xx/,
l./versionpass3/, g/1/2/,
p-1

l./bits_pr_byte=8;/,   i/

array_template_size = 8;
sub_template_size   = 6;
field_template_size = 2;
record_template_size = 2;
/,





; page 9

l./context_kind = (/,
l./undef_type,/,  r/undef_type,/dyn_subrange,   undef_type,/,
l./field,/,  d,  i/
field,          dyn_field,      variable,       dyn_variable,
var_param,      value_param,
/,


l./error_types = (/,
l./);/,  r/);/,
error_dyn, error_dyn_init, error_dyn_var);/,

l./name_rec = record/,  
l./end;/,  i/
dynamic : boolean;
/,

l./operand_rec = record/,
l1,  i/
type_nix: integer;
var_nix:  integer;
/,
l./state:/,  i/
dynamic:  boolean;
/,

l./init_modes/,  r/ )/, error_init )/,

l./struc_level = record/,
l./saved_lix:/,  i/
saved_nix: name_index;
/,




; page 10

l./display_rec = record/,
l./saved_init:/,  l1,  i/
saved_dyn:      boolean;
/,



; page 11

l./system_types, var_types/,
r/,var_types            /,var_types, simple_types/,


l./test, init_fields,/,  r/fields,/fields, dyn_fields,/,
l1,  r/_with,/_with, line_number,/,

; page 12

l./name_key,/,  i/
record_offset,
/,

l./procedure get(var/,  i/

procedure error(ty: error_types);  forward;

procedure load_expr;  forward;
/,

; page 13

l./procedure put0(op/,
l2,  i/
if line_number then begin
write(pass4file, ord(znewline), source_line);
line_number:=false;
end;
/,

l./procedure put1(op/,
l2,  i/
if line_number then begin
write(pass4file, ord(znewline), source_line);
line_number:=false;
end;
/,

l./procedure put2(op/,
l2,  i/
if line_number then begin
write(pass4file, ord(znewline), source_line);
line_number:=false;
end;
/,

; page 14

l./procedure put3(op/,
l2,  i/
if line_number then begin
write(pass4file, ord(znewline), source_line);
line_number:=false;
end;
/,


l./procedure put4(op/,
l2,  i/
if line_number then begin
write(pass4file, ord(znewline), source_line);
line_number:=false;
end;
/,





; page 15

l./procedure new_line;/,
l./if stat_part then/,  d1,  i/
line_number:=true;
/,


l./procedure out_formal_list;/,
l./type_p := type_p * 4 + 1;/,  i/
begin
if nametableÆcomp_typeÅ.dynamic then error(error_dyn);
/,
l./put2(/,  i/
end;
/,




; page 16

l./procedure pass4error(e:/,  
l./overflow:/,  r/:/:              /,
l1,  i/
error_dyn:              writeln('dynamic type not allowed');
error_dyn_init:         writeln('initialize dynamic type not allowed');
error_dyn_var:          writeln('dynamic variable not allowed');
/,

l./prelude_error:/,  r/init./init. or process/,


; page 17

l./procedure write_nametable(top:/,
l./writeln(/,  l1,  r/')/     dyn')/,



; page 18

l./packed_comp:8/,  r/packed_comp:8/
packed_comp:8, dynamic:8/,


l./procedure write_operand_stack;/,
l./field_packed:7/,  r/field_packed:7/
field_packed:7/,



; page 19

l./procedure initialize;/,
l./with empty_name do begin/,
l./end;/,  i/
dynamic:=false;
/,

l./source_line:=0;/,  l1,  i/
line_number:=false;
/,


l./index_types:=/,  l1,  i/
simple_types:=Æ int_type, char_type, bool_type, scalar_type, dyn_subrange Å;
/,

l./indirects:=/,   r/Å/,dyn_variableÅ/,




; page 22

l./procedure push_level(m:/,
l./saved_offset:=current_offset;/,  d,
l./current_offset:=0;/,  d,  i/
saved_offset:=record_offset;       record_offset:=0;
/,
l./saved_init:=init_fields;/,  l1,  i/
saved_dyn:=dyn_fields;        dyn_fields:=false;
/,
l./if mode=process_mode/,  i/
saved_offset:=current_offset;
/,





; page 23

l./procedure pop_level;/,
l./init_fields:=saved_init;/,  l1,  i/
record_offset:=saved_offset;
dyn_fields:=saved_dyn;
/,
l./begin/,  l1,  i/
current_offset:=saved_offset;
/,
l./mode:=/,  l./current_offset:=/,  d,


; page 26

l./procedure field_allign;/,
l./if odd(/,  r/current/record/,
l1,  r/current/record/,   r/current/record/,




; page 27

l./procedure adjust_string(/,
l./begin/,  l1,  i/
if opsÆqÅ.dynamic then error(error_dyn_var)
else
begin
/,
l./end;/,  i/
end;
/,


l./procedure constant_used(/,
l./end;/,  i/
if var_nix >= 0 then
nametableÆvar_nixÅ.niv:=niv;
/,






; page 29

l./procedure std_name(ty:/,
l./with nametable/,  r/do/do begin/,
l1,  i/
dynamic:=false;
/,





; page 30
l./xsucc:/,  l1,  i/
end;
/,


l./procedure scalar_def;/,
l./context:=scalar_type;/,  l1,  i/
dynamic:=false;
/,



; page 31

l./procedure sub_def;/,
l./push_name(nix);/,    d./end;/,  d./end;/,   i/
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;
dynamic := false;
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);
end; (*with*)
end; (*dynamic*)
/,


l./procedure pointer_def;/,
l./size:=pointer_length;/,  l1,  i/
dynamic:=false;
/,


; page 32


l./procedure array_def(/,  r/array_def/static_array_def/,


; page 33

l./with nametableÆnixÅ do begin/,
l./packed_comp:=pack;/,  l1,  i/
dynamic:=false;
/,

l./procedure field_list;/,   i/

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 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*)
/,

l./procedure field_list;/,
l1,  r/:/,
comp_niv, comp_offset, allign:/,
l./: boolean/, r/:/,dyn:/,
l./allign_type:=init;/,  l1,  i/
comp_niv:=niv;   comp_offset:=offset;
dyn:=dynamic;
if context = dyn_subrange then dyn:=false;
if allign_type then allign:=1 else allign:=0;
/,
l./if current_bit>0/,  r/then/then begin/,
l1,   r/current_offset/record_offset/,  r/current_offset/record_offset/,
l1,
 i/
if dyn_fields then put0(zincfield);
end;
/,
l./current_offset:=field_add/,  
r/current/record/,  r/current/record/,  l1,  i/
if dyn_fields then put0(zincfield);
/,
l./current_bit:=current_bit+/,  l1,  d, i/
if dyn_fields then begin
niv:=current_niv;
offset:=alloc_var(field_template_size);
put3(zfieldsize, 0, offset, 0);
end
else
offset:=record_offset;
/,
l./current_offset:=/,  r/current/record/,  r/current/record/,
l1,  i/
if dyn_fields then put0(zincfield);
/,
l./size:=field_size;/,  d1,   i/
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;
/,
l./context:=field/,
r/context:=field;/if dyn_fields then
context:=dyn_field else context:=field;
dyn_fields:=dyn_fields or dyn;
/,




; page  34

l./procedure record_def;/,
l./if current_bit>0/,  r/then/then begin/,
l1,  r/current/record/,  r/current/record/,
l1,  i/
if dyn_fields then put0(zincfield);
end;
/,
l./size:=current_offset;/,    r/current/record/,   i/
dynamic:=dyn_fields;
if dyn_fields then begin
niv:=current_niv;
offset:=alloc_var(record_template_size);
put1(zendtemplate, offset);
size:=0;
end
else
/,



; page 35

l./procedure set_def;/,
l./lower:=min;/,  l1,  i/
if dynamic then begin
error(error_dyn);
lower:=0;   upper:=1;
end;
/,
l./size:=words*2;/,  l1,  i/
dynamic:=false;
/,

l./procedure pool_def;/,  
l./data_size:=nametable/,  d,  i/
with nametableÆstackÆtÅÅ do begin
data_size:=size;
if dynamic then begin
error(error_dyn);
data_size:=0;
end;
end;
/,
l./max:=data_size;/,  l1,  i/
dynamic:=false;
/,





; page 36

l./procedure formal_param(c:/,
l./if c=value_param then/,
d2,  i/
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;
/,

; page 37

l./procedure new_block;/,
l./put1(znewline/,  d,


; page 38

l./procedure external_;/,
l./process_mode:/,
l1,  i/
if prelude then error(prelude_error)
else
/,





; page 40

l./procedure begin_code;/,
l2,  i/
if opsÆotÅ.context <> sconst then error(var_error);
/,



; page 41

l./procedure init_values(/,
l./put1(znewline/,   d,
l./if context in index_types/,  r/index_types/simple_types/,


l./procedure component_init(nix: integer); forward;/,
d./procedure var_list;/,  i/

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 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
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;
/,



; page 44

l./var type_nix,/,
r/:/, type_niv, type_offset:/,
r/;/;
/,
r/ :/, dyn:/,
l./init:= allign/,  l1,  i/
type_niv:=niv;   type_offset:=offset;
dyn:=dynamic;
if context = dyn_subrange then dyn:=false;
/,

l./if allign then word_allign;/,
d5,   i/
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);
/,



l./procedure end_export;/,
l./put1(znewline/,  d,



; page 45

l./procedure const_def;/,
l./with opsÆotÅ do/,  d,  i/
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;
/,


 



; page 46

l./procedure load_var(op:/,
l./if kind in index_types/,  
r/index/simple/,
l./put2(op,addr_typ,size)/,   d,   i/
begin
if dynamic then
with nametableÆtype_nixÅ do
put3(op, dyn_typ, niv, offset)
else
put2(op, addr_typ, size);
end;
/,








; page 49

l./procedure arithmetic(op:/,
l./zadd:/, i/
zxor: if offset = f then offset := 0 else offset := 1;
/,
l./if stat_part then begin/,   d,
l./end else begin/,  d3,






; page 50

l./procedure neg_not(/,
l1, i/
var typ : integer;
/,
l./if stat_part then begin/,  d,
l./put0(op);/, l1, i/
if op = znot then begin
if kind = bool_type then typ := bool_typ else typ:=int_typ;
put_arg1(typ);
end;
/,
l./end else begin/,  d2,


l./procedure equality(/,


; page 51

l./if stat_part then begin/,  d,
l./int_type,char_type,bool_type,/, r/:/, dyn_subrange :/,

l./pointer_type, array_type/,
l./put2(zcompstruc/,  i/
if dynamic then
with nametableÆtype_nixÅ do
put3(zcompdynstruc, op1, niv, offset)
else
/,

l./else begin/,  l-1,  d4,




; page 52

l./procedure range;/,
l1,  r/;/;   dyn : boolean;/,
l./b:=max;/,  r/max;/max;    dyn:=dynamic;/,
l./with ops/,  i/
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
/,







; page 53

l./procedure func_call;/,
l./result_size:=nametableÆpÅ.size/,  d,  i/
get(p);
/,
l./with nametable/,  l1,   i/
with nametableÆpÅ do begin
result_size:=size;
if dynamic and (context<>dyn_subrange) then error(error_dyn);
end;
/,

l./with opsÆotÅ do/,  l1,  i/
type_nix:=p;
var_nix:=nix;
/,
l./end;/,  i/
dynamic:=false;
/,






; page 55

l./procedure actual;/,
l./with nametable/,  l1,  i/
opsÆotÅ.dynamic := false;
opsÆotÅ.type_nix:=comp_type;
opsÆotÅ.var_nix:=nix;
/,










; page 57

l./procedure for_;/,
l./if kind in index_types/,  r/index/simple/,






; page 59

l./procedure lock_type;/,   i/

procedure lock_var_;
begin
stat_part:=false;
push_name(nix);
address;   pop;
end;
/,

l./procedure lock_type;/,
l1,  d,  i/
var type_size, type_niv, type_offset : integer;
dyn : boolean;
/,
l./address;/,  d1,  i/
with nametableÆ stackÆtÅ Å do begin
type_size:=size;
dyn:=dynamic;
type_niv:=niv;
type_offset:=offset;
end;
/,

l./put2(zlockvar/,  d,  i/
if dyn then
put3(zlockdynvar, type_niv, type_offset, offset)
else
put2(zlockvar, type_size, offset);
/,






; page 61

l./procedure var_ref;/,
l./with nametable/,  l1,  i/
opsÆotÅ.var_nix:=nix;
/,
l./if context <> field/,  d,  i/
if (context <> field) and (context <> dyn_field) then
/,


l./procedure type_ref;/,
l./with nametable/,  l1,  i/
opsÆotÅ.type_nix:=nix;
/,
l./end;/,  i/
opsÆotÅ.dynamic:=dynamic;
/,


l./procedure field_;/,

; page 62

l./context:=c;/,  i/
if context <> field then error(error_dyn);
/,
l./put1(zfield/,   d,  i/
if context = field then
put1(zfield, offset)
else
put2(zdynfield, niv, offset);
/,


l./procedure index;/,
l1,  r/;/;   pa : boolean;/,
l./get(nix);/,
d./put1(zcindex/,  d3,   i/
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;
/,



l./procedure literal;/,
l./with opsÆot/,  l1,  i/
var_nix:=-1;
type_nix:=-1;
/,
l./end;/,  i/
dynamic:=false;
/,


; page 64

l./with opsÆot/,   l1,  i/
type_nix:=-1;
var_nix:=-1;
/,
l./end;/,
i/
dynamic:=false;
/,

l./with opsÆotÅ/,  l1,  i/
type_nix:=-1;
var_nix:=-1;
/,
l./end;/,  i/
dynamic:=false;
/,




; page 65

l./procedure new_set;/,
l./state:=direct;/,  l1,  i/
dynamic:=false;
/,










; page 67

l./procedure struc_const;/,
l./with nametable/,  l1,  i/
saved_nix:=nix;
/,

l./init_mode:=record_init/,  l1,  i/
if dynamic then begin
error(error_dyn);
init_mode:=error_init;
end;
/,




; page 68

l./procedure end_struc;/,
l./context:=struc_c;/,   l1,   i/
var_nix:=-1;
type_nix:=saved_nix;
dynamic:=false;
if init_mode <> error_init then
/,


l./procedure times_;/,
l./if (times<0/,  i/
if init_mode <> error_init then
/,







; page 71


l./procedure struc;/,



; page 72


l./end; (*packed*)/,  l1,  i/
error_init: begin
times:=1;
pop;
end;
/,





; page 74

l./xendcaselist:/,
l1,  r/put1(znewline,source_line);//,



l./xgetexpr:/,   d,   i/
xgetexpr:     load_operand;
/,











; page 80

l./xinitblock:/,
l1,  d,


l./xlockvar:/,  d,  i/
xlockvar:     lock_var_;
/,


l./xwithvar:/, l1, i/
xxor:        arithmetic(zxor);
/,





f


▶EOF◀
DataMuseum.dk

RC4000/8000/9000

⟦e2cc2f326⟧ TextFile

Derivation

TextFile
