|
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: 20736 (0x5100)
Types: TextFile
Names: »rc850jobs«
└─⟦2c55ea56f⟧ Bits:30001844 SW-save af projekt 1000, Alarm-system
└─⟦6b41451d2⟧
└─⟦this⟧ »rc850jobs«
; rc850jobs
%
\f
(***********************
* ep test 1 *
* test 1 rc850 sys *
***********************)
process progenitor(var s1,s2,s3 : semaphore);
var i,j : integer;
begin
printtext('start rc850#');
for i:=1 to 20 do
begin
writenl;
for j:=1 to i do writechar('*');
end;
end.
%
\f
(**********************
* ep test 2 *
* test statements *
**********************)
process progenitor(var s1,s2,s3:semaphore);
type re = record
a : integer;
b : alfa;
end;
ar = array (1..6) of re;
var a : ar := ar ( re(1, 'no 1 '), re(2, 'no 2 '),
re(3, 'no 3 '), re(4, 'no 4 '),
re(5, 'no 5 '), re(6, 'no 6 '));
p,q,i : integer;
label lab;
procedure casetest(l,u,v : integer);
begin
if (v<l) or (v>u) then begin
writenl;
printtext('case error');
printnumber(l,4);
printnumber(u,4);
printnumber(v,4);
end
else writechar('c')
end;
begin
q:=1;
lab:
printtext('next #'); printnumber(q,4);
printtext('for up #');
for p:=q to 3 do writechar('+');
printtext(' : fordown #');
for p:=3 downto q do writechar('-');
writenl;
printtext('repeat #');
p:=3;
repeat writechar('r'); p:=p+1; until p>q;
printtext(' : while #');
p:=3;
while p>=q do begin writechar('w'); p:=p-1 end;
writenl;
with a(q) do begin
printnumber(a,2); printtext(' #');
printtext(b)
end;
writenl;
q:=q+1;
if q<=6 then goto lab;
printtext('neg up/down');
for p:=-10 to -8 do writechar('-');
for p:=-2 to 1 do writechar('>');
for p:=1 downto -2 do writechar('<');
for p:=-8 downto -10 do writechar('+');
writenl; printtext('case #');
for p:=1 to 10 do begin
printnumber(p, 3); printtext(' #');
case p of
5: i:=5;
4: i:=4;
3: i:=3;
2: i:=2;
1: i:=1;
otherwise begin casetest(6,10,p); i:=p end;
end;
if 6>p then casetest(i,i,p);
case p of
1..3: casetest(1,3,p);
6..8: casetest(6,8,p);
4..5: casetest(4,5,p);
9,10: casetest(9,10,p);
end;
case p of
1..3: casetest(1,3,p);
6..8: casetest(6,8,p);
9: casetest(9,9,p);
10: casetest(10,10,p);
4..5: casetest(4,5,p);
end;
case p of
2: i:=2;
7: i:=7;
4: i:=4;
3: i:=3;
5: i:=5;
1: i:=1;
otherwise
if p=6 then casetest(6,6,p)
else
casetest(8,10,p);
end;
if not ( (p=6) or (p>7) ) then casetest(i,i,p);
end;
writenl; printtext('case end.#');
end.
%
\f
(*************************
* ep test 3 *
* test rev, stv, stc *
*************************)
process progenitor(var s1,s2,s3:semaphore);
type pr = packed record
a,b,c,d : 0..63;
e : integer;
f : 0..255;
end;
const ca = 41; cb = 42; cc = 43; cd = 44; ce = 45;
cf = 46;
var gr, gr1 : pr;
sum : integer;
i : integer;
a1 : array (1..4) of integer; (* 1,2,3,4*)
a2 : array (1..4) of 0..255; (* 5,6,7,8*)
a3 : array (1..4) of pr; (* a = 9,10,11,12 *)
(* d = 13,14,15,16 *)
(* e = 17,18,19,20 *)
(* f = 21,22,23,24 *)
procedure error(i : integer);
begin
writenl; printtext('error no #');
printnumber(i,1);
end;
procedure testout(s : alfa);
begin
writenl; printtext(s);
end;
procedure pa;
var pa1 : pr;
pa2 : pr;
procedure pb;
var pb1 : pr := pr(21,22,23,24,25,26);
pb2 : pr;
procedure pc;
var pc1 : pr;
pc2 : pr;
pc3 : pr;
procedure pd;
begin
testout('pd called #');
pc1.a:=pc1.a + gr.a;
pc1.b:=pc1.b + gr.b;
pc1.c:=pc1.c + gr.c;
pc1.d:=pc1.d + gr.d;
pc1.e:=pc1.e + gr.e;
pc1.f:=pc1.f + gr.f;
pa1.a:=ca;
pa1.b:=cb;
pa1.c:=cc;
pa1.d:=cd;
pa1.e:=ce;
pa1.f:=cf;
pc3:=pc1;
end;
(*c*)
begin
testout('pc called #');
pc1.a:=31; pc1.b:=32; pc1.c:=33; pc1.d:=34;
pc1.e:=35; pc1.f:=36;
pc2:=pc1;
pd;
if pc2.a <> (pc1.a - gr.a) then error(1);
if pc2.b <> (pc1.b - gr.b) then error(2);
if pc2.c <> (pc1.c - gr.c) then error(3);
if pc2.d <> (pc1.d - gr.d) then error(4);
if pc2.e <> (pc1.e - gr.e) then error(5);
if pc2.f <> (pc1.f - gr.f) then error(6);
if pc3 <> pc1 then error(25);
with pc2 do
sum := a+b+c+d+e+f;
writenl; printtext('proc c sum');
printnumber(sum,7);
end; (*c*)
(*b*)
begin
testout('pb called #');
pb2:=pb1;
pc;
if pb2.a <> pb1.a then error(7);
if pb2.b <> pb1.b then error(8);
if pb2.c <> pb1.c then error(9);
if pb2.d <> pb1.d then error(10);
if pb2.e <> pb1.e then error(11);
if pb2.f <> pb1.f then error(12);
with pb2 do
sum := a+b+c+d+e+f;
writenl; printtext('proc b sum');
printnumber(sum,1);
end; (*b*)
(*a*)
begin
testout('pa called #');
i:=11; pa1.a:=i; i:=12; pa1.b:=i; i:=13; pa1.c:=i;
i:=14; pa1.d:=i; i:=15; pa1.e:=i; i:=16; pa1.f:=i;
i:=41; gr1.a:=i; i:=42; gr1.b:=i; i:=43; gr1.c:=i;
i:=44; gr1.d:=i; i:=45; gr1.e:=i; i:=46; gr1.f:=i;
pa2:=pa1;
pb;
if (pa1.a - pa2.a) <> (ca-11) then error(13);
if (pa1.b - pa2.b) <> (cb-12) then error(14);
if (pa1.c - pa2.c) <> (cc-13) then error(15);
if (pa1.d - pa2.d) <> (cd-14) then error(16);
if (pa1.e - pa2.e) <> (ce-15) then error(17);
if (pa1.f - pa2.f) <> (cf-16) then error(18);
with pa2 do
sum:=a+b+c+d+e+f;
writenl; printtext('proc a sum');
printnumber(sum,4);
end; (*a*)
begin (*main*)
printtext('test rev o.l');
error(0);
testout('main #');
gr.a:=1; gr.b:=2; gr.c:=3; gr.d:=4;
gr.e:=5; gr.f:=6;
for i:=1 to 3 do begin
a1(i):=i;
a2(i):=4+i;
with a3(i) do begin a:=8+i; d:=12+i; e:=16+i; f:=20+i end;
end;
a1(4):=4; a2(4):=8;
with a3(4) do
begin a:=12; d:=16; e:=20; f:=24 end;
pa;
if gr1.a <> 41 then error(19);
if gr1.b <> 42 then error(20);
if gr1.c <> 43 then error(21);
if gr1.d <> 44 then error(22);
if gr1.e <> 45 then error(23);
if gr1.f <> 46 then error(24);
sum:=0;
with gr1 do sum:=a+b+c+d+e+f;
writenl; printtext('gr1 sum'); printnumber(sum,1);
sum:=0;
for i:=1 to 4 do
sum:=sum + a1(i) + a2(i) + a3(i).a + a3(i).d + a3(i).e + a3(i).f;
writenl;
printtext('main sum #'); printnumber(sum,10);
writenl;
printtext('test end.#');
end.
%
\f
(******************************
* ep test 4 *
* test int/bool operators *
******************************)
process progenitor(var s1,s2,s3 : semaphore);
type rec = record a,b,c:integer end;
var a,b,c,d,b_no: integer;
t,f : boolean;
g,h : rec;
procedure ta(x,y:integer);
begin
b_no:=b_no+1;
if x<>y then begin
writenl; printtext('error a #'); printnumber(b_no,1);
printnumber(x,7); printnumber(y,7);
end;
end;
procedure teststart(a:alfa);
begin
writenl; printtext(a);
end;
procedure tb(x,y:boolean);
var er : boolean;
begin
b_no:=b_no+1;
if x then begin
if y then er:=false else er:=true;
end else
if y then er:=true else er:=false;
if er then begin
writenl; printtext('error b #');
printnumber(b_no,2);
if x then printtext('true #') else printtext('false #');
if y then printtext('true #') else printtext('false #');
end;
end;
begin
printtext('test int/boo');
printtext('l operators');
b_no:=0;
teststart('proc ta'); ta(1,2); ta(1,1);
teststart('proc tb');
tb(true,true); tb(true,false);
tb(false,true); tb(false,false);
b_no:=0;
teststart('test =');
a:=5; b:=6; c:=-5; d:=-6;
tb( a=b, false);
tb( a=a, true);
teststart('test <>');
tb( a<>b, true);
tb( a<>a, false);
teststart('test >');
tb( d>a, false);
tb( a>d, true);
tb( b>a, true);
tb( d>c, false);
teststart('test <');
tb( d<a, true);
tb( a<d, false);
tb( b<a, false);
tb( d<c, true);
teststart('test <>');
tb( d<=a, true);
tb( a<=d, false);
tb( b<=a, false);
tb( d<=c, true);
tb( a<=5, true);
tb( d<=-6, true);
teststart('test >=');
tb( d>=a, false);
tb( a>=d, true);
tb( b>=a, true);
tb( d>=c, false);
tb( a>=5, true);
tb( d>=-6, true);
teststart('test s =');
g:=rec(1,2,3); h:=rec(3,4,5);
tb( g=g, true);
tb( g=h, false);
teststart('test not');
t:=true; f:=false;
tb( not t, false);
tb( not f, true);
teststart('test or');
tb( t or t, true);
tb( t or f, true);
tb( f or t, true);
tb( f or f, false);
teststart('test and');
tb( t and t, true);
tb( t and f, false);
tb( f and t, false);
tb( f and f, false);
b_no:=0;
writenl; printtext('test succ/pr'); printtext('ed/abs');
a:=10; b:=-10;
ta( succ(a), 11);
ta( pred(a), 9);
ta( abs(a), 10);
ta( abs(b), 10);
waitd(255);
teststart('test +');
a:=-5; b:=5; c:=8; d:=-8;
ta( a+b, 0);
ta( a+c, 3);
ta( b+d, -3);
ta( a+d, -13);
teststart('test -');
a:=5;
ta( a-b, 0);
ta( c-a, 3);
ta( b-c, -3);
ta( b-d, 13);
teststart('test div');
a:=0; b:=28;
ta( a div b, 0);
ta( b div c, 3);
ta( b div d, -3);
a:=28;
ta( a div c, 3);
ta( a div d, -3);
teststart('test mod');
a:=0;
ta( a mod b, 0);
a:=24; b:=8;
ta( a mod b, 0);
a:=-24;
ta( a mod b, 0);
a:=28; b:=-28;
ta( a mod c, 4);
ta( b mod c, 4);
ta( a mod d, 4);
ta( b mod d, 4);
teststart('test *');
a:=0; b:=3; c:=4; d:=-4;
ta( a*b, 0);
ta( b*a, 0);
ta( b*0, 0);
a:=-3;
ta( a*c, -12);
ta( b*d, -12);
ta( a*d, 12);
teststart('test neg');
a:=-5; b:=5;
ta( -a, 5);
ta( -b, -5);
writenl; printtext('test end.');
end.
%
\f
(********************
* ep test 5 *
* test push/pop *
********************)
process progenitor(var s1,s2,s3 : semaphore);
const n = 5;
var i : integer;
b : boolean;
r, stack, stc : reference;
ans, sem : semaphore;
p_one : pool n of integer;
p_two : pool n;
procedure error(e : integer);
var a : array (1..1) of integer;
begin
writenl; printtext('error no #');
printnumber(e,1);
i:=a(3); (* exception *)
end;
begin
writenl; printtext('test push#'); printtext('/pop #');
for i:=1 to n do begin
if not openpool(p_one) then error(1);
alloc(r, p_one, ans);
lock r as w:integer do w:=i;
push(r, stc);
if not openpool(p_two) then error(2);
alloc(r, p_two, ans);
push(r, stc);
end;
if openpool(p_one) or openpool(p_two) then error(3);
stc :=: stack;
lock stack as w:integer do
if w<>n then error(4);
i:=n;
while not nil(stack) do begin
b:=empty(stack);
pop(r, stack);
if ownertest(p_one, r) then begin
lock r as w:integer do
if w <> i then error(5);
if (i=1) and not b then error(6);
i:=i-1;
end;
release(r);
end;
for i:=1 to n do begin
if not openpool(p_one) then error(7);
alloc(r, p_one, sem);
return(r);
if passive(sem) then error(8);
end;
if not open(sem) then error(9);
while open(sem) do begin
wait(r,sem);
release(r);
end;
if not passive(sem) then error(10);
writenl; printtext('test end.');
end.
%
\f
(**********************
* ep test 6 *
* test create ... *
**********************)
process progenitor(var s1,s2,s3 : semaphore);
var sender,ty,n : integer;
r : reference;
fin1,fin2 : boolean;
sem1, sem2, test : semaphore;
sh1, sh2, sh3 : shadow;
process tick; external;
process one(var sem1, sem2, test_sem : semaphore);
const n = 6;
var i,p: integer;
r, test : reference;
a_sem, test_answer : semaphore;
po : pool n;
t_p : pool 1 of alfa;
procedure test_out(a:alfa);
begin
lock test as t:alfa do t:=a;
signal(test, test_sem);
wait(test, test_answer);
end;
begin
alloc(test, t_p, test_answer);
test^.u1:=1; (*sender*)
test^.u2:=1; (*test*)
test_out('started');
for i:=1 to n do begin
alloc(r, po, a_sem);
signal(r,sem1);
test_out('send');
waitd(49);
end;
alloc(r, po, a_sem);
release(r);
test_out('ready to rec');
waits(r,sem2);
release(r);
test_out('sensesem');
p:=n-2;
while p>0 do begin
repeat
sensesem(r, a_sem);
if nil(r) then waitd(5);
until not nil(r);
test_out('received');
p:=p-1;
release(r);
end;
test_out('finis');
test^.u2:=2; (*finis*)
signal(test, test_sem);
wait(test, test_answer);
end; (* process one *)
process two(var sem1, sem2, test_sem : semaphore);
var c: activation;
rest : byte;
r, test : reference;
w_sem, test_answer : semaphore;
p : pool 1 of alfa;
procedure test_out(a:alfa);
begin
lock test as t:alfa do t:=a;
signal(test, test_sem);
wait(test, test_answer);
end;
begin
alloc(test, p, test_answer);
test^.u1:=2; (*sender*)
test^.u2:=1; (*text*)
test_out('started');
repeat
c:=waitsd(r, sem1, 200);
if c=a_semaphore then begin
rest:=remdelay;
test_out('received#'); printnumber(200-rest,4);
signal(r, w_sem);
end;
until c=a_delay;
test_out('time out');
wait(r, w_sem);
release(r);
waitd(50);
if locked(sem2) then test_out('sem 2 locked')
else test_out('sem2 error');
wait(r,w_sem);
signal(r,sem2);
while open(w_sem) do begin
waits(r, w_sem);
return(r);
test_out('send');
waitd(10);
end;
test_out('finis');
test^.u2:=2; (*finis*)
signal(test, test_sem);
wait(test, test_answer);
end; (* process two*)
begin
writenl; printtext('test routines'); writenl;
n:=create( one(sem1, sem2, test), sh1, 500);
start(sh1, 100);
n:=create( two(sem1, sem2, test), sh2, 500);
start(sh2, 100);
link('tickproc', tick);
n:=create(tick, sh3, 300);
start(sh3,250);
fin1:=false; fin2:=false;
n:=-1;
repeat
wait(r,test);
sender:=r^.u1; ty:=r^.u2;
if ty = 1 then begin
n:=n+1;
if (n mod 4) = 0 then writenl;
if sender=1 then printtext(' $a #')
else printtext(' $b #');
lock r as t:alfa do printtext(t);
end
else
begin
if sender = 1 then begin
fin1:=true;
end
else
begin
fin2:=true;
end;
end;
return(r);
until fin1 and fin2;
waitd(255); waitd(255); waitd(255);
writenl; printtext('test end.');
end.
%
\f
(*****************
* ep test 7 *
* test set *
*****************)
process progenitor(var s1,s2,s3 : semaphore);
const
c1 = (. 0..5, 12..17, 24..29, 36..41, 48..53, 60..63 .);
c2 = (. 3..8, 15..20, 27..32, 39..44, 51..56, 63 .);
c3 = (. 0..5, 12..17, 24..29, 36..41 .);
c4 = (. 3..8, 15..20, 27..32, 39..44 .);
c5 = (. 15,16 .);
c6 = (. 16 .);
c7 = (. 31,32 .);
c8 = (. 31 .);
var a : set of 0..63;
b : set of 0..47;
c : set of 0..127;
b_no , i, j :integer;
procedure os(a : integer; s: set of 0..63; b,n : integer);
begin
writenl; printnumber(n,2);
printtext('. #');
for i:=0 to 63 do
if i in s then writechar('1') else writechar('0');
if (a<>1) or (b<>2) then printtext(' error#');
end;
procedure tb(x,y : boolean);
begin
b_no:=b_no+1;
if x<>y then begin
writenl; printtext('error #');
printnumber(b_no,2);
if x then printtext(' true #') else printtext(' false #');
if y then printtext(' true #') else printtext(' false #');
end;
end;
begin
printtext('test set'); writenl;
b_no:=0;
tb(true, true); tb(true,false); tb(false,true); tb(false,false);
os(0, c1, 2, 91); os(1, c2, 3, 92);
os(1, c3, 2, 93);
b_no:=0;
writenl; printtext('test +');
os(1, c1+c2, 2,1);
os(1, c3+c2, 2,2);
os(1, c1+c4, 2,3);
writenl; printtext('test *');
os(1, c1*c2, 2,4);
os(1, c3*c2, 2,5);
os(1, c1*c4, 2,6);
writenl; printtext('test -');
os(1, c1-c2, 2, 7);
os(1, c3-c2, 2, 8);
os(1, c1-c4, 2, 9);
writenl; printtext('test <=');
tb( c6<=c5, true);
tb( c5<=c6, false);
tb( c5<=c5, true);
tb( c7<=c8, false);
tb( c8<=c7, true);
writenl; printtext('test >=');
tb( c6>=c5, false);
tb( c5>=c6, true);
tb( c5>=c5, true);
tb( c7>=c8, true);
tb( c8>=c7, false);
writenl; printtext('test =');
tb( c7=c7, true);
tb( c7=c8, false);
tb( c8=c7, false);
writenl; printtext('test <>');
tb( c7<>c7, false);
tb( c7<>c8, true);
tb( c8<>c7, true);
writenl; printtext('test in');
tb( 0 in c1, true);
tb( 100 in c1, false);
writenl; printtext('test setst');
a:=c7;
os(1, a, 2, 10);
b:=c8;
os(1, b, 2, 11);
a:=c1;
os(1, a, 2, 12);
c:=c1;
os(1, c, 2, 13);
writenl; printtext('test setcr');
i:=3; j:=7;
a:=(. i, j, i+j..j*j, 60.);
os(1, a, 2, 14);
writenl; printtext('test end.');
end.
%
\f
(******************
* ep test 8 *
* test array *
******************)
process progenitor(var s1,s2,s3:semaphore);
type tx = packed array (1..4) of 0..31;
ty = array (1..4) of tx;
var
b : ty := ty( tx(1,0,1,0), tx(0,1,1,0), tx(0,0,0,1), tx(1,1,0,1));
a : ty := ty( tx(1,2,3,4), tx(5,6,7,8),
tx(9,10,11,12), tx(13,14,15,16));
c : ty := ty( 4 *** tx(0,0,0,0));
i,p,q,s : integer;
procedure out;
begin
writenl;
for p:=1 to 4 do begin
for q:=1 to 4 do printnumber( a(p,q),3);
printtext(' #');
for q:=1 to 4 do printnumber( b(p,q),3);
printtext(' #');
for q:=1 to 4 do printnumber( c(p,q),3);
writenl;
end;
end;
begin
writenl; printtext('test array'); writenl;
out;
for p:=1 to 4 do
for q:=1 to 4 do begin
s:=0;
for i:=1 to 4 do s:=s+a(p,i)*b(i,q);
c(p,q):=s;
end;
out;
printtext('test end.');
end.
%
\f
(***********************
* ep test 9 *
* test init pool *
***********************)
process progenitor(var s1,s2,s3 : semaphore);
type
r1 = record a,b:integer; c:char end;
r2 = array (1..10) of integer;
t1 = pool 1 of alfa;
t2 = array (0..2) of pool 3 of r1;
t3 = array (1..3,1..4) of pool 4 of byte;
ty = record
a : pool 5;
b : array (3..5) of pool 6 of integer;
end;
t4 = array (-1..2) of ty;
t5 = record
a : pool 7 of r2;
b : t2;
c : ty;
end;
var p1 : t1;
p2 : t2;
p3 : t3;
p4 : t4;
p5 : t5;
no : integer :=0;
i,j : integer;
r : reference;
sem, st : semaphore;
procedure ck(n,s:integer; var pul : pool 1);
var i : integer; ok : boolean := true;
p : integer := 1;
begin
writenl; printtext('pool #');
no:=no+1; printnumber(no,3);
printtext(' #'); printnumber(n,3); printnumber(s,5);
if (no mod 20) = 0 then waitd(200);
alloc(r,pul,sem);
if r^.size <> s then ok:=false;
signal(r,st);
while openpool(pul) do begin
alloc(r, pul, sem); p:=p+1;
signal(r,st);
end;
if p<>n then ok:=false;
for i:=1 to p do begin
wait(r,st);
release(r);
end;
if ok then printtext(' ok ') else printtext(' not ok ');
end;
begin
printtext('test pool');
ck(2,12,p1);
ck(1,10,p1);
ck(1,12,p1);
for i:=0 to 2 do ck(3,5,p2(i));
for i:=1 to 3 do
for j:=1 to 4 do ck(4,1,p3(i,j));
for i:=-1 to 2 do begin
ck(5,0,p4(i).a);
for j:=3 to 5 do ck(6,2,p4(i).b(j));
end;
ck(7,20,p5.a);
for i:=0 to 2 do ck(3,5,p5.b(i));
ck(5,0,p5.c.a);
for i:=3 to 5 do ck(6,2,p5.c.b(i));
end.
%
\f
(*****************************
* ep test 10 *
* test exception/trace *
*****************************)
process progenitor(var s1,s2,s3 : semaphore);
procedure pip(n : integer);
begin
trace(51);
waitd(255);
if n=0 then exception(68)
else
pip(n-1);
end;
begin
trace(50);
pip(10);
end.
%
▶EOF◀