|
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: 19200 (0x4b00)
Types: TextFileVerbose
Names: »dynedit«
└─⟦2c55ea56f⟧ Bits:30001844 SW-save af projekt 1000, Alarm-system
└─⟦6b41451d2⟧
└─⟦this⟧ »dynedit«
; 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»