|
DataMuseum.dkPresents historical artifacts from the history of: DANOSI |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about DANOSI Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 4119 (0x1017)
Types: TextFile
Names: »FIRST.RTP«
└─⟦289818552⟧ Bits:30010516 DVBS1.SW2114.src.2.7-3 SW2114 3/4 Real Time Pascal 2.7
└─⟦this⟧ »RTP\FIRST.RTP«
└─⟦783187a02⟧ Bits:30010525 DVBS1.SW2114.src.2.6-3 RTP compiler source SW2104+SW2114 Disk#3 30/1-92 HHA
└─⟦this⟧ »RTP\FIRST.RTP«
└─⟦ca921ce75⟧ Bits:30010528 DVBS1.SW2114.src.2.6-6 RTP Compiler Source SW2104+SW2114 Disk 3 92.02.03 HEJ HHA
└─⟦this⟧ »RTP\FIRST.RTP«
└─⟦d5707feda⟧ Bits:30010512 DVBS1.SW2114.src.2.14-3 SW2114 REAL #3/4 TIME PASCAL SOURCE REL 2.14 92.09.01
└─⟦this⟧ »RTP\FIRST.RTP«
\r
program first(shared firstend, firstok : boolean);\r
const test_antal=6;\r
var ref: reference;\r
r: array(0..test_antal-1) of reference;\r
p: array(0..1) of pool;\r
ref_no: array(0..test_antal-1) of integer;\r
is_fault: boolean := false;\r
max_i: integer;\r
mbx: mailbox;\r
test3: boolean;\r
for_i,for_j:integer;\r
z : inoutzone;\r
\r
procedure tracex(i:integer);\r
begin\r
trace(i);\r
is_fault:= true;\r
end;\r
\r
procedure allocrefs(i:integer);\r
begin\r
for j:=0 to i-1 do alloc(r(j),p(0),mbx);\r
for j:=i to test_antal-1 do begin\r
alloc(r(j),p(1),mbx);\r
setoffset(r(j),5+j);\r
setbytecount(r(j),11+j);\r
settop(r(j),117+j);\r
end;\r
end;\r
\r
procedure releaserefs;\r
begin\r
for j:=0 to test_antal-1 do release(r(j));\r
end;\r
\r
procedure build_stack(i:integer);\r
var j:integer;\r
begin \r
for antal:=test_antal downto 1 do\r
begin\r
j:=i mod antal;\r
for x:=0 to test_antal-1 do \r
begin\r
if nil(r(x)) then else\r
begin\r
if j=0 then begin\r
push(r(x),ref);\r
ref_no(test_antal-antal):=x;\r
end;\r
j:=j-1;\r
end;\r
end;\r
i:=i div antal;\r
end; \r
end;\r
\r
function test_unchanged(var r: reference;x:integer): boolean;\r
begin\r
if bufsize(r)>0 then begin\r
if offset(r)<>5+x then tracex(200);\r
if bytecount(r)<>11+x then tracex(201);\r
if top(r)<>117+x then tracex(202);\r
if first(r)<>5+x then tracex(203);\r
if next(r)<>16+x+x then tracex(204);\r
if last(r)<>116+x then tracex(205);\r
if is_fault then\r
begin\r
trace(for_j); trace(for_i); trace(x);\r
for i:=0 to test_antal-1 do trace(ref_no(i));\r
end;\r
end;\r
test_unchanged:= is_fault; \r
end;\r
\r
function test_changed(var r: reference): boolean;\r
var tempoffset : integer;\r
begin\r
if test3 then\r
begin\r
tempoffset := offset(r);\r
if bytecount(r)<> ( 20 - tempoffset) then tracex(301);\r
if top(r)<>101 then tracex(302);\r
if first(r) <> tempoffset then tracex(303);\r
if next(r)<>20 then tracex(304);\r
if last(r)<>100 then tracex(305); \r
end\r
else\r
begin\r
if offset(r)<>7 then tracex(300);\r
if bytecount(r)<>13 then tracex(301);\r
if top(r)<>101 then tracex(302);\r
if first(r)<>7 then tracex(303);\r
if next(r)<>20 then tracex(304);\r
if last(r)<>100 then tracex(305); \r
end;\r
test_changed:= is_fault; \r
end;\r
\r
function test:boolean;\r
var i:integer;\r
c:boolean;\r
begin\r
c:=true;\r
test:=true;\r
for x:=test_antal-1 downto 0 do\r
begin\r
if c then\r
begin\r
if test_changed(ref) then exit;\r
pop(r(ref_no(x)),ref);\r
if bufsize(r(ref_no(x)))<>0 then c:=false;\r
end else\r
begin\r
pop(r(ref_no(x)),ref);\r
if test_unchanged(r(ref_no(x)),ref_no(x)) then exit;\r
end;\r
end; \r
\r
test:=false; \r
end;\r
procedure exiterror;\r
begin\r
region firstok do firstok := false;\r
region firstend do firstend := true;\r
end; \r
begin\r
if allocmempool(p(0),test_antal,0,mem_private)<>test_antal then tracex(100);\r
if allocpool(p(1),test_antal,200)<>test_antal then tracex(101);\r
\r
max_i:=1;\r
for i:=2 to test_antal do max_i:=max_i*i;\r
for j:=1 to test_antal-1 do\r
for i:=0 to max_i-1 do\r
begin\r
if (i mod 10) = 0 then printinteger(z,i);\r
for_j:=j;\r
for_i:=i;\r
test3:=false;\r
allocrefs(j);\r
build_stack(i);\r
setfirst(ref,7);\r
setnext(ref,20);\r
setlast(ref,100);\r
if test then begin exiterror; exit; end;\r
releaserefs;\r
allocrefs(j);\r
build_stack(i);\r
setnext(ref,20);\r
setfirst(ref,7);\r
setlast(ref,100);\r
if test then begin tracex(600); exiterror; exit; end;\r
releaserefs;\r
test3:=true;\r
allocrefs(j);\r
build_stack(i);\r
setoffset(ref,7);\r
setnext(ref,20);\r
setlast(ref,100);\r
if test then begin tracex(601); exiterror; exit; end;\r
releaserefs;\r
end;\r
(*\r
allocrefs(0);\r
build_stack(0);\r
setnext(ref,30);\r
for i:=0 to test_antal-1 do\r
begin\r
pop(r(i),ref);\r
if bytecount(r(i))<>30 then tracex(700+i);\r
end;\r
*)\r
region firstok do firstok := not is_fault;\r
region firstend do firstend := true;\r
end.\r
\r