|
DataMuseum.dkPresents historical artifacts from the history of: RC4000/8000/9000 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about RC4000/8000/9000 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 22272 (0x5700)
Types: TextFile
Names: »testdbcodes «
└─⟦01e83a425⟧ Bits:30008166 Bånd med SW8010 og SW8500 source code
└─⟦75ff9bef3⟧
└─⟦this⟧ »testdbcodes «
job jw 2 294102 size 35000 time 3 0 temp disc 500 20
mode list.yes
data=edit
m e
i/
512 0 0 0
16 0 0
registre(regno,nul,felttype,byteto)
5 0 -1 0 byte38
7 0 0 4 byte138
9, 0 0, 0, by186
8388607, -1
(byte to) SUBTABEL FOR FØRSTE REGISTER
5,0,0,0,10,byte58,0,3,0
indivtyper(indivtype,bytefire,længde,class)
1,0,20,1
3,byte78,20,8192
5,0,20,5
6,byte84,32,16384
12,byte90,28,24576
8388607 -1
(byte tre)fieldgroup(fieldgroupno,længde,nul)
19 6 0
21 8 0
23 10 0
8388607
(byte fire) relative addr
0,10,0
8204 8210 8218 (tolv atten seksovtyve)
8206 8212 0 (fjorten tolv nul)
(byte to) SUBTABEL FOR ANDET REGISTER
7,0,0,0,10,byte26,0,2,1
indivtyper
4,byte40,18,4
8388607 -1
(byte tre) fieldgroup
26 2 0
27 4 0
8388607
(byte fire b) relative addr
10 14
(byte to c) SUBTABEL FOR TREDIE REGISTER
9,0,0,0,10,byte0,0,0,3
indivtyper
2,byte0,22,0
8388607 -1
/,f
\f
at=edit
m e
i/
begin zone z0(10,1,stderror);
begin integer i,j,c1,c2,c3,i19,test,res;
integer array ia(1:20); array ra,a(1:20),b(1:2);
integer field inf,type;
real r;
zone table,z1,z2,z3,db(128,1,stderror);
integer array field iaf,iaf1,iaf2,iaf3,iaf4,iaf5,iaf6;
procedure ud;
begin
reclength(db,512); zonestate(db,0);
for i:=1 step 1 until 111 do
write(out,<:<10>:>,<<ddd>,i*2,<< ddd>,db.iaf(i));
reclength(db,0); zonestate(db,25);
end;
procedure ud1(i); integer i;
begin
write(out,<:<10>result=:>,res,
<: class :>,c1,
<: fieldvar:>,iaf1,iaf2,iaf3);
if i<>0 then
for inf:=2 step 2 until 30 do
write(out,<:<10>:>,<<-dddddddd>,z1.inf,a.inf);
end ud1;
procedure reclength(z,l); zone z; integer l;
begin getzone6(z,ia); ia(14):= ia(19); ia(16):=l; setzone6(z,ia) end;
procedure zonestate(z,s); zone z; integer s;
begin getzone6(z,ia); ia(13):=s; setzone6(z,ia) end;
procedure startdb;
begin open(table,4,<:data:>,0);
reclength(db, 512);
iaf:=0;
for i:=1 step 1 until 113 do
begin read(table,j); db.iaf(i):=j end;
zonestate(db,25); reclength(db,0);
end startdb;
procedure udskrift(text); string text;
write(out,false add 10,1,text);
i19:=19;type:=6;iaf:=0;
reclength(z1,32);
z1.iaf(1):=32; z1.type:=6;
for i:=4 step 1 until 16 do z1.iaf(i):=i;
zonestate(z0,26); reclength(z0,0);
read(in ,test); write(out,<:<10>test:>,test);
startdb;
if test>30 and test < 59 or test=64 then initdbtable(db,5,z1,c1,19,iaf1,21,iaf2,23,iaf3);
comment if testbit(1) then ud;
\f
case test of
begin
comment 1, blockjam 0;
begin udskrift(<:blockjam 0:>);
initdbtable(db,5,z0,c1);
end;
comment 2, blockjam1;
begin integer f;
udskrift(<:blockjam 1:>);
initdbtable(db,5,z1,c1,19,f);
end;
comment 3, all fieldparam missing;
begin udskrift(<:-dbfield 19:>);
initdbtable(db,5,z1,c1);
end;
comment 4, fiedlparam not as expected;
begin udskrift(<:-dbfield 19:>);
initdbtable(db,5,z1,c1,20,iaf1);
end;
comment 5, fieldparam missing;
begin udskrift(<:-dbfield 23:>);
initdbtable(db,5,z1,c1,19,iaf1,21,iaf2);
end;
comment 6, double init;
begin udskrift(<:+initdb 5:>);
initdbtable(db,5,z1,c1,19,iaf1,21,iaf2,23,iaf3);
initdbtable(z0,5,z1,c1);
end;
comment 7, fieldgr is real;
begin udskrift(<:param 7:>);
initdbtable(db,5,z1,c1,19,iaf1,r,iaf2);
end;
comment 8, fieldvar is real;
begin udskrift(<:param 8:>);
initdbtable(db,5,z1,c1,19,iaf1,21,r);
end;
comment 9, fieldvar is constant;
begin udskrift(<:param 6:>);
initdbtable(db,5,z1,c1,19,21);
end;
comment 10, class is constant;
begin udskrift(<:param 4:>);
initdbtable(db,5,z1,10);
end;
\f
comment 11, class is real;
begin udskrift(<:param 4:>);
initdbtable(db,5,z1,r);
end;
comment 12, too many param;
begin udskrift(<:param 11:>);
initdbtable(db,5,z1,c1,19,iaf1,21,iaf2,23,iaf3,24,iaf4);
end;
comment 13, no fieldvar in dbtable;
begin udskrift(<:param 5:>);
initdbtable(db,9,z3,c3,19,iaf1);
end;
comment 14, not started;
begin udskrift(<:-startdb 5:>);
zonestate(db,0); reclength(db,512);
initdbtable(db,5,z1,c1);
end;
comment 15, gal zonestate;
begin udskrift(<:-startdb 5:>);
zonestate(db,0);
initdbtable(db,5,z1,c1)
end;
comment 16, gal reclength;
begin udskrift(<:-startdb 5:>);
reclength(db,512); initdbtable(db,5,z1,c1);
end;
comment 17, ukendt register;
begin udskrift(<:-regno 12:>);
initdbtable(db,12,z1,c1);
end;
comment 18, double init of reg;
begin udskrift(<:+regno 9:>);
initdbtable(db,9,z3,c3); initdbtable(db,9,z3,c3)
end;
comment 19, samme zone i 2 reg;
begin udskrift(<:+zone 9:>);
initdbtable(db,9,z1,c1);
initdbtable(db,5,z1,c1);
end;
comment 20, uaabnet cf-zone;
begin udskrift(<:z.state 4:>);
initdbtable(db,7,z2,c2);
end;
\f
comment 21, initdbtable not initialized;
begin udskrift(<:dbinitst 0:>);
connectdb(true,ra,z1);
end;
comment 22, array not in dbtable;
begin udskrift(<:dbinitst 1:>);
initdbtable(db,9,ra,c3);
connectdb(true,a,z1);
end;
comment 23, zone not in dbtable;
begin udskrift(<:dbinitst 1:>);
initdbtable(db,9,ra,c3);
connectdb(false,ra,z1);
end;
comment 24, zone not connected to array;
begin udskrift(<:-regno 5:>);
initdbtable(db,9,ra,c3);
initdbtable(db,5,z1,c1,19,iaf1,21,iaf2,23,iaf3);
connectdb(false,ra,z1);
end;
comment 25, not this array connected to the zone;
begin udskrift(<:-regno 9:>);
initdbtable(db,9,ra,c3);
connectdb(true,ra,z1);
connectdb(false,a,z1);
end;
comment 26, array is already connected to a zone;
begin udskrift(<:dbinitst 1:>);
initdbtable(db,9,ra,c3);
connectdb(true,ra,z1);
connectdb(true,ra,z1);
end;
comment 27, array must not be connected;
begin udskrift(<:-regno 5:>);
initdbtable(db,5,ra,c1,19,iaf1,21,iaf2,23,iaf3);
connectdb(true,ra,z1);
end;
comment 28, zone already connected to another register;
begin udskrift(<:+zone 5:>);
initdbtable(db,5,z1,c1,19,iaf1,21,iaf2,23,iaf3);
initdbtable(db,9,ra,c3);
connectdb(true,ra,z1);
end;
comment 29, uaabnet cf-zone;
begin udskrift(<:z.state 4:>);
initdbtable(db,7,ra,c2,26,iaf1,27,iaf2);
connectdb(true,ra,z2);
end;
\f
comment 30, not init;
begin udskrift(<:dbinitst 0:>);
dbrecdecode(z1);
end;
comment 31, zone not in table;
begin udskrift(<:dbinitst 1:>);
dbrecdecode(z0);
end;
comment 32, to gange startdbrec ;
begin udskrift(<:gentag startdbrec initdbtable:>);
close(table, false);
startdb;
reclength(table, 512);
reclength(db, 512);
tofrom(table, db, 512);
zonestate(table, 25);
reclength(table, 0);
initdbtable(table, 5, z1, c1, 19, iaf1, 21, iaf2, 23, iaf3);
end 32;
comment 33, same param dbrectransf;
begin udskrift(<:param:>);
dbrectransf(z1,6,z1);
end;
comment 34, array too short dbreccreate;
begin udskrift(<:recsize 28:>);
dbreccreate(z1,12,b);
end;
comment 35, array too short dbrectransf;
begin udskrift(<:recsize 32:>);
dbrectransf(z1,6,b);
end;
comment 36, dbreccreate prohibited;
begin udskrift(<:-create:>);
initdbtable(db,9,z3,c3);
dbreccreate(z3,4,a);
end;
comment 37, dbrectransf prohibited;
begin udskrift(<:-transf:>);
initdbtable(db,9,z3,c3);
dbrectransf(z3,4,a);
end;
comment 38, dbreccreate prohibited (after connectdb);
begin udskrift(<:-create:>);
initdbtable(db,9,ra,c3); connectdb(true,ra,z3);
dbreccreate(z3,4,a);
end;
comment 39; ;
comment 40, dbrecdecode -13;
begin udskrift(<:decode class 0:>);
z1.type:=-13; res:=dbrecdecode(z1); ud1(0);
end;
comment 41, dbrecdecode length error;
begin udskrift(<:decode class -1:>);
reclength(z1,40); z1.iaf(1):=40; res:=dbrecdecode(z1); ud1(0);
end;
comment 42, dbrecdecode illegal;
begin udskrift(<:create class -2:>);
z1.type:=14; res:=dbrecdecode(z1); ud1(0);
end;
\f
comment 43, dbreccreate -13;
begin udskrift(<:create class 0:>);
res:=dbreccreate(z1,-13,a); ud1(0);
end;
comment 44, dbreccreate illegal;
begin udskrift(<:create class -2:>);
res:=dbreccreate(z1,14,a); ud1(0) end;
comment 45, dbrectransf -13;
begin udskrift(<:transf class 0:>);
z1.type:=-13; res:=dbrectransf(z1,6,a); ud1(0);
end;
comment 46, dbrectransf length error;
begin udskrift(<:transf class -1:>);
reclength(z1,40); z1.iaf(1):=40; res:=dbrectransf(z1,12,a); ud1(0);
end;
comment 47, dbrectransf illegal;
begin udskrift(<:transf class -2:>);
z1.type:=14; res:=dbrectransf(z1,6,a); ud1(0);
end;
comment 48, dbrectransf to -13;
begin udskrift(<:transf class 0:>);
res:=dbrectransf(z1,-13,a); ud1(0);
end;
comment 49, dbrectransf to illegal;
begin udskrift(<:transf class -2:>);
res:=dbrectransf(z1,14,a); ud1(0);
end;
\f
comment 50, dbrecdecode ok;
begin udskrift(<:decode ok:>);
res:=dbrecdecode(z1); ud1(0); end;
comment 51, dbrecdecode as last decoded, ok;
begin udskrift(<:decode ok:>);
res:=dbrecdecode(z1); dbrecdecode(z1); ud1(0); end;
comment 52, dbreccreate ok;
begin udskrift(<:create ok:>);
res:=dbreccreate(z1,6,a); ud1(1); end;
comment 53, dbreccreate as last decoded, ok;
begin udskrift(<:create ok:>);
res:=dbrecdecode(z1); dbreccreate(z1,6,a); ud1(1); end;
comment 54, dbrectransf ok;
begin udskrift(<:transf ok:>);
res:=dbrectransf(z1,12,a); ud1(1);
end;
comment 55, dbrectransf as last decoded ok;
begin udskrift(<:transf ok:>);
dbrecdecode(z1); res:=dbrectransf(z1,12,a); ud1(1); end;
comment 56, dbrectransf as last decoded to same, ok;
begin udskrift(<:transf ok:>);
dbrecdecode(z1); res:=dbrectransf(z1,6,a); ud1(1); end;
comment 57 decode after length error in same type;
begin udskrift(<:decode ok:>);
reclength(z1,40); dbrecdecode(z1);
reclength(z1,32); res:=dbrecdecode(z1); ud1(0);
end;
comment 58 transf after length error in same type;
begin udskrift(<:transf ok:>);
reclength(z1,40); dbrecdecode(z1);
reclength(z1,32); res:=dbrectransf(z1,6,a); ud1(1);
end;
comment test 59 array;
begin array ra(1:10);
udskrift(<:create ok:>);
initdbtable(db,5,ra,c1,19,iaf1,21,iaf2,23,iaf3);
res:=dbreccreate(ra,6,a); ud1(1);
end;
\f
comment 60, dbrectransf ok, after connectdb;
begin udskrift(<:transf ok:>);
initdbtable(db,5,ra,c1,19,iaf1,21,iaf2,23,iaf3);
connectdb(true,ra,z1);
res:=dbrectransf(z1,12,a); ud1(1);
end;
comment 61, dbrectransf ok med array;
begin udskrift(<:transf ok:>);
initdbtable(db,5,ra,c1,19,iaf1,21,iaf2,23,iaf3);
for i:=1 step 1 until 8 do ra(i):=z1(i);
res:=dbrectransf(ra,12,a); ud1(1);
end;
begin comment 62, result connectdb;
udskrift(<:connectdb 5 0 5 0 5 5 5 0 5:>);
initdbtable(db,5,ra,c1,19,iaf1,21,iaf2,23,iaf3);
write(out,<:<10>connectdb:>,<< d>,
connectdb(false add 1,ra,z1),
connectdb(false add 2,ra,z1),
connectdb(true,ra,z1),
connectdb(false add 1,ra,z1),
connectdb(false add 2,ra,z1),
connectdb(false,ra,z1),
connectdb(false add 1,ra,z1),
connectdb(false add 2,ra,z1),
connectdb(true,ra,z1));
end;
begin comment 63, dbrecdescr, alarm;
udskrift(<:dbinitst 0, fra dbreccreate:>);
dbrecdescr(z1, i, j);
end 63;
begin comment 64, dbrecdescr;
integer rno, iklas;
udskrift(<:dbrecdescr 3 -999999 -999999 : :>);
i:= dbrecdescr(a, rno, iklas);
write(out, i, rno, iklas);
udskrift(<:dbrecdescr 1 5 0 : :>);
i:= dbrecdescr(z1, rno, iklas);
write(out, i, rno, iklas);
udskrift(<:dbrecdescr 28 2 5 24576 : :>);
write(out, dbreccreate(z1, 12, a));
i:= dbrecdescr(z1, rno, iklas);
write(out, i, rno, iklas);
end 64;
comment 65 - 69; ; ; ; ; ;
\f
comment test 70: test cf-system ændringer;
begin comment 25.11.74 testprog til test af cf-systemet efter ændringer;
udskrift(<:test cf-code:>);
begin comment block til oprettelse af filhoveder;
integer array size, chains(1:8), recdescr(1:2, 1:2);
integer i;
for i:= 1 step 1 until 8 do
chains(i):= case i of (1, 2, 1, 0,
1, 2, 1, 0);
recdescr(1, 1):= 2;
recdescr(1, 2):= 10;
recdescr(2, 1):=
recdescr(2, 2):= 2;
size(1):=
size(2):= 100;
size(3):= 36;
size(4):= 1;
head_m(<:master1:>, 1, chains, recdescr, 1, size);
size(1):= 0;
size(2):= 10;
size(3):= 1;
size(4):= 2000;
head_l(<:list2:>, 2, chains, size);
end block til oprettelse af filhoveder;
begin comment block til initialisering af masterfilen;
zone zm(buflength_cf(<:master1:>, 2), 3, stderror);
array rec(1:100);
integer i;
for i:= 1 step 1 until 100 do
rec(i):= real<::>;
rec(1):= 0.0 shift 24 add 100 shift 24;
rec(2):= rec(2) add (-13) shift 24;
comment length = 100, type = hemmelig;
init_file_m(zm, <:master1:>, 0, 1, 1);
init_rec_m (zm, rec);
close_cf(zm, true);
end block til initialisering;
\f
begin comment block til selve testen;
zone zm(buflength_cf(<:master1:>, 2), 3, stderror),
zl(buflength_cf(<:list2:> , 2) +10, 3, stderror);
real chain, chain_2;
integer array field g19, g21, g23, g26, g27;
integer field længde, nøgle, type;
integer class_m, class_l, i, itype;
real array rec(1:30), key(1:6);
boolean ff, nl, sp;
procedure luk_åben;
if false then
begin comment tester rettelser i tilbageskrivning af bloktabellen;
integer paramno, værdi;
write(out, nl, 2, <:luk-åben: :>,
<: dead-bytes used-bytes fill-limit:>,
nl, 1, sp, 12);
for paramno:= 1, 2, 3 do
begin
getparam_cf(zl, paramno, værdi);
write(out, sp, 4, <<-ddddddd>, værdi);
end;
close_cf(zl, true);
open_cf(zl, <:list2:>, 0);
write(out, nl, 1, sp, 12);
for paramno:= 1, 2, 3 do
begin
getparam_cf(zl, paramno, værdi);
write(out, sp, 4, <<-ddddddd>, værdi);
end;
init_chain(zm, zl, 1, chain);
init_chain(zm, zl, 2, chain_2);
update_all_cf(zl);
set_jumps_cf(zl, jump, 0, 123456);
end luk_åben;
\f
procedure jump(z, procno, alarmno);
zone z;
integer procno, alarmno;
begin comment bliver kaldt internt for hvert procedurehop. udskriver
tilstanden af zonen, samt feltgrupperne og individklasserne;
integer array ia(1:20);
integer field ifelt;
if procno < 0 then
begin comment alarm;
procno:= -procno;
write(out, nl, 2, <:jump alarm: :>, alarmno, sp, 3,
case alarmno - 7 of
(<:z.state :>, <:ch.ass. :>, <:cf-error:>, <:mode-p :>,
<:a-12 :>, <:array p :>, <:no.curr.:>, <:chain p :>,
<:ch.state:>, <:ch.state:>, <:ch.head :>, <:rec.no. :>,
<:ch.type :>, <:fixed l :>, <:rec.no. :>, <:a-23 :>,
<:prep-cf :>, <:prep-cf :>, <:prep-cf :>, <:a-27 :>,
<:m.state :>, <:d.state :>, <:rec.type:>, <:zrecsize:>,
<:prep-cf :>, <:prep-cf :>, <:a-34 :>, <:a-35 :>,
<:express.:>, <:cf-error:>, <:par.pair:>)
);
end;
getzone6(z, ia);
write(out, nl, 2, <:jump: :>, << -dd>, procno, sp, 2, case procno of
(<:1 :>, <:2 :>, <:3 :>, <:4 :>,
<:init_chain :>, <:close_cf :>, <:7 :>, <:get_m :>,
<:get_l :>, <:get_head :>, <:insert_m :>, <:insert_l :>,
<:connect :>, <:delete_m :>, <:delete_l :>, <:delete_chain :>,
<:next_m :>, <:put_cf :>, <:read_only_cf :>, <:read_upd_cf :>,
<:update_all_cf:>, <:22 :>, <:get_numb_l :>, <:24 :>,
<:25 :>, <:26 :>, <:27 :>, <:init_rec_m :>,
<:29 :>, <:30 :>, <:31 :>, <:32 :>,
<:33 :>, <:34 :>, <:35 :>, <:36 :>,
<:37 :>),
sp, 2, result_cf
);
print_g;
write(out, sp, 2, if ia(13) >= 22 then <: list2:> else <:master1:>,
<< -dd>, ia(16) );
if ia(16) > 0 then
begin
for ifelt:= 2 step 2 until 10 do
write(out, nl, 1, sp, 72, <<-ddddddd>, z.ifelt);
end if;
end jump;
procedure print_g;
begin comment udskriver feltgrupperne og individklasserne, stiller
alle adresser og klasserne til 1111;
write(out, << -dddd>, sp, 2, class_m, class_l,
<< dddd>, sp, 1, g19, g21, g23, g26, g27);
class_m:= class_l:= 1111;
g19:= g21:= g23:= g26:= g27:= 1111;
comment for at prøve om feltgruppeadresserne og individklasserne
bliver sat, næste gang et individ bruges;
end print_g;
\f
ff:= false add 12;
nl:= false add 10;
sp:= false add 32;
comment udskriv hovedlinie til testoutput;
write(out, ff, 1, nl, 2, <: procno procnavn res-cf :>,
<: cl-m cl-l g19 g21 g23 g26 g27 :>,
<:zone reclength:>);
open_cf(zm, <:master1:>, 0);
open_cf(zl, <:list2:> , 0);
set_jumps_cf(zm, jump, 0, 0);
comment set_jumps_cf(zl, jump, 0, 123456);
init_db_table(db)reg:( 5)m_zone:( zm)klasse:( class_m)feltgrupper:(
19, g19,
21, g21,
23, g23);
init_db_table(db)reg:( 7)l_zone:( zl)klasse:( class_l)feltgrupper:(
26, g26,
27, g27);
ud;
read_upd_cf(zm);
read_upd_cf(zl);
comment nu er dbtable initialiseret og filerne existerer,
sæt individer i filer og kæder;
initchain(zm, zl, 1, chain);
comment konfigurationen er:
nøgle ! itype ! ityper paa kædeelementer ! indsætningsrækkefølge
------+-------+---------------------------+----------------------
0 ! -13 !
10 ! 1 !
20 ! 3 ! i4 i4 ! 1 2
30 ! 5 !
40 ! 6 ! i4 ! 1
50 ! 12 !
60 ! 12 ! i4 i4 i4 i4 ! 2 1 4 3,
! ! ! 2 3 4 indsættes først efter at
! ! ! individet med nøgle 80 er indsat
70 ! 12 !
80 ! -13 !
90 ! -13 !
100 ! 97 ! i4 i4 i4 ! 3 1 2
110 ! 3 !
;
\f
længde:= 2;
type := 6;
nøgle:= 10;
for i:=1 step 1 until 11 do
begin
itype:= case i of ( 1, 3, 5, 6,
12, 12, 12,-13,
-13, 97, 3);
dbreccreate(zm, itype, rec);
if class_m < 1 then
begin comment snyd de syge typer igennem;
rec.længde:= 50;
rec.type:= -13;
end;
jump(zm, 7, 0);
rec.nøgle:= i*10;
insert_m(zm, rec);
zm.type:= itype;
comment indsæt evt individer i kæden;
case i of
begin
; comment ingen kæde;
begin
dbreccreate(zl, 4, rec);
insert_l(zl, chain, 1, rec);
insert_l(zl, chain, 2, rec);
end;
; comment ingen kæde;
begin
dbreccreate(zl, 4, rec);
insert_l(zl, chain, 1, rec);
end;
; comment ingen kæde;
begin
dbreccreate(zl, 4, rec);
insert_l(zl, chain, 1, rec);
end;
; comment ingen kæde;
begin comment ingen kæde her, men indsæt flere elementer i kæden
til individet med nøgle 60;
dbreccreate(zl, 4, rec);
insert_l(zl, chain, 3, rec);
get_l(zl, chain, 2);
insert_l(zl, chain, 2, rec);
insert_l(zl, chain, 3, rec);
end;
; comment ingen kæde;
begin
dbreccreate(zl, 4, rec);
insert_l(zl, chain, 1, rec);
insert_l(zl, chain, 2, rec);
insert_l(zl, chain, 1, rec);
end;
; comment ingen kæde;
end case i;
end for i;
comment alle individer er oprettet;
\f
comment gennemløb masterfilen og alle kæderne 2 gange,
1. gang slettes individet med nøgle 60 og dens kæde;
for i:= 1, 2 do
begin comment 2 gennemløb;
key.nøgle:= 0;
get_m(zm, key);
for i:= 1 while result_cf = 1 do
begin comment gennemløb alle individer i masterfilen;
get_l(zl, chain, 1);
for i:= i while result_cf = 1 do
get_l(zl, chain, 2);
comment hele kæden til individet gennemløbes;
if zm.nøgle = 60 then
delete_m(zm)
else next_m(zm);
end alle individer i filen;
read_only_cf(zm);
read_only_cf(zl);
end 2 gennemløb;
comment test tilbageskrivning af bloktabellen;
luk_åben;
update_all_cf(zm);
dbreccreate(zl, 4, rec);
insert_l(zl, chain, 1, rec);
connect(zl, chain, chain_2, 1);
comment nu er et element i zl dobbelthægtet.
saa kan set_free testes;
luk_åben;
get_l(zl, chain_2, 1);
get_l(zl, chain , 1);
delete_l(zl, chain);
luk_åben;
get_l(zl, chain_2, 1);
luk_åben;
set_param_cf(zl, 3, 10); comment fill limit = 10 pct;
luk_åben;
extend_cf(zl, 1);
luk_åben;
close_cf(zm, true);
close_cf(zl, true);
\f
comment test et tilfælde hvor bloktabellen ikke skal skrives
tilbage;
begin
zone z(3*128, 3, blproc);
integer array ia(1:20);
procedure blproc(z, s, b);
zone z;
integer s, b;
begin
real array field raf;
raf:= 0;
getzone6(z, ia);
writeall(out, ia.raf, 40, 2);
getshare6(z, ia, ia(17));
writeall(out, ia.raf, 24, 2);
end;
open_cf(z, <:list2:>, 2);
update_all_cf(z);
read_only_cf(z);
write(out, nl, 2, <:efter read_only: :>);
read_upd_cf(z);
extend_cf(z, 1);
close_cf(z, true);
end;
end block til selve testen;
end testprog;
end test case;
end
end
/,f
p=algol at spill.yes survey.yes
\f
p
1
p
2
p
3
p
4
p
5
p
6
p
7
p
8
p
9
p
10
p
11
p
12
p
13
p
14
p
15
p
16
p
17
p
18
p
19
p
20
p
21
p
22
p
23
p
24
p
25
p
26
p
27
p
28
p
29
\f
p
30
p
31
p
32
p
33
p
34
p
35
p
36
p
37
p
38
p
40
p
41
p
42
p
43
p
44
p
45
p
46
p
47
p
48
p
49
p
50
p
51
p
52
p
53
p
54
p
55
p
56
p
57
p testbit.1
58
p
59
p
63
p
64
data=edit data
l./byte38/,r/-1/0/,f
p
60
p
61
p
62
\f
data=edit data
l./byte38/,r/0 0 0/0 0 3/,f
master1=set 36
list2=set 36
p
70
lookup master1 list2
end
▶18◀finis
▶EOF◀