|
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 - download
Length: 9216 (0x2400)
Types: Rc489k_TapeFile, TextFile
└─⟦aa55fa693⟧ Bits:30007479 SW8110/1 TAS/SOS/PRIMO Rel 2.3
└─⟦this⟧
external integer procedure transfer(action, ipar, ileng, opar, oleng);
integer action, ileng, oleng;
integer array ipar, opar;
begin
integer treply, tno, tname, tuser, tsend, treceiv, tktype, tkgroup,
tkname, treser, tserr, trerr,
tsubno, tsubst, tsubpos, tsubtime, tcause, terrst,
tleng, level, nlevel, rectype, form, size, stackix,
bytes,start, ecode, i;
integer field zix;
integer array descr(1:42), stack(1:10), ia(1:20);
zone z(50,1,stderror);
boolean test;
procedure putheader(type, level, form, size);
integer type, level, form, size;
<* the four parameters is packed into one integer to give
* a header. this is placed in primo parameter record pointed
* out by zix. *>
begin zix := zix + 2;
z.zix := type shift 12 +level shift 8
+ form shift 4 + size;
end;
procedure putfield(ix, size);
integer ix, size;
<* moves the field pointed at by ix,size to primo parameter
* record pointed out by zix. *>
begin integer i;
for i:=0 step 1 until size-1 do
begin zix := zix + 2;
z.zix := ipar(ix+i);
end;
end;
integer procedure gethdr(rectype, level, form, size);
integer rectype, level, form, size;
<* unpack a header pointed out in primo answer record and
* delivers the components in the procedure parameters.
* at entry zix points to the last delivered header in
* primo record. *>
begin own integer oform,osize;
integer field i;
i := zix + 2;
zix := if zix = 0 then 2 else zix + 2 + (case oform+1 of
(osize, osize, 0, 0, z.i+1, z.i+1, 1, 0)) * 2;
if zix > bytes then gethdr := 0 else
begin
gethdr := 1;
rectype := z.zix shift (-12);
level := z.zix shift (-8) extract 4;
form := oform := z.zix shift (-4) extract 4;
size := osize := z.zix extract 4;
end;
end;
procedure getfield (ix, osize);
integer ix, osize;
<* moves the field described in primo header pointed out by
* zix,form,size to the user parameter area pointed out by
* ix,osize. *>
begin integer field jf;
integer i,n;
if form = 2 then opar(ix) := size else
begin
jf := zix + 2;
if form = 0 or form = 1 then n := max(size,osize) else
if form = 4 or form = 5 then
begin n := max(z.jf,osize);
jf := zix + 2;
end else n := 1;
for i := 0 step 1 until n-1 do
begin opar(ix + i) := z.jf;
jf := jf + 2;
end;
end;
end;
integer procedure max(a, b);
integer a, b;
begin
max := if a > b then a else b;
end;
procedure testout(start, length);
integer start, length;
begin integer array mov(1:length);
integer i, j;
system(5,start,mov);
for i := 0 step 1 until 4 do
write(out,<:<10>mess:>,<<d>,i,<<dddddddd>,ia(i+4));
write(out,<:<10><10>record:<10>decimal grouped:>);
for i := 1 step 1 until length do
begin write(out,<:<10>:>,<<dddddddd>,mov(i),<: :>);
for j := -20 step 4 until 0 do
write(out,<<dddd>,mov(i) shift j extract 4);
end;
end;
<* build record format for the user delivered parameter
* area ipar and opar. *>
<* generel header, common to all records. *>
treply := 1; tno := 2; tname := 3; tuser:= 9;
<* define transport.*>
tsend := 21; treceiv := 26;
tktype := 30; tkgroup := 31; tkname := 35;
<* answer define transport. *>
treser := 7; tserr := 8; trerr := 10;
<* answer get transport state. *>
tsubno := 20; tsubst := 21; tsubpos := 22;
tsubtime := 24; tcause := 25; terrst := 26;
<* the data handled to primo is build in the
* zone z. the fields are moved one by one, and
* the field variable zix points to the last used
* integer in the zone record. *>
zix := 0;
<* the array descr gives the definition of which of
* the records in the primo output data is of interest.
* it is represented as a tree structure, each node
* occupies 2 words giving the value of an accepted
* record type in the first word . in the second word
* is either an action number or a pointer of the
* description of the nodes on the next level. *>
for i:= 1 step 1 until 42 do descr(i) := case i of
(3, 11, 5, 23, 7, 23, 9, 41, -11, 41,
1, -1, 3, -2, -4, 17,
1, -3, 3, -4, -4, -5,
4, 17, 1, -1, 3, -2, -1000, 31,
-3, 33,
4, -6, 5, -7, 6, -7, -7, -8,
-4, 17);
<* make the zone ready for communication with primo. *>
test := false;
open(z, 0, <:primo:>, 0);
outrec(z,50);
if action = 2 then
<* define transport *>
begin ecode := 8;
if ileng <30 or oleng < 11 then goto ereturn;
putheader(2,0,0,0); <*define transport*>
putheader(1,1,0,4); <*transport name*>
putfield(tname,4);
putheader(2,1,0,4); <*user ident*>
putfield(tuser,4);
putheader(1000,1,0,0); <*record subtransport*>
putheader(1,2,0,0); <*sender device*>
putheader(2,3,0,4); <*name*>
putfield(tsend,4);
putheader(2,2,0,0); <*receiver device*>
putheader(2,3,0,4); <*name*>
putfield(treceiv,4);
tleng := ileng - 20;
while ipar(tktype) <> -1 do
begin ecode := 8;
if tleng < 9 or zix > 200-26 then goto ereturn;
ecode := 9;
if ipar(tktype) <> 0 then goto ereturn;
putheader(3,3,0,0); <*queues*>
putheader(1,4,0,4); <*group id*>
putfield(tkgroup,4);
putheader(3,4,0,4); <*name*>
putfield(tkname,4);
tktype := tktype + 9;
tkgroup := tkgroup + 9;
tkname := tkname + 9;
tleng := tleng - 9;
end;
end else
if action = 4 or action = 6 or action = 8 or action=10 then
<* get state of transport, wait and get state of transport,
* release transport and kill transport. *>
begin
tleng := if action = 8 or action = 10 then 7 else 9;
ecode := 8; if ileng < tleng then goto ereturn;
tleng := if action = 8 or action = 10 then 6 else 26;
if oleng < tleng then goto ereturn;
putheader(action,0,0,0); <*record type*>
putheader(3,1,0,1); <*transport no*>
putfield(tno,1);
end else
<* unknown action. *>
begin ecode := 7; goto ereturn; end;
<* build primo message in share. *>
repeat <* until status <> stopped *>
getzone(z,ia); i:=ia(19);
getshare(z, ia, 1);
i := i + ia(2);
ia(4):= 7 shift 12; <*operation:=output-input*>
ia(5) := i; <*first output*>
ia(6) := i + zix - 2; <*last output *>
ia(7) := i; <*first input = first output*>
ia(8) := i + 200-2; <*last input = max*>
setshare(z,ia,1);
if test then testout(i, zix//2);
ecode := 6; <*send message*>
if monitor(16, z, 1, ia) = 0 then goto ereturn;
ecode := monitor(18, z, 1, ia);
if ecode <> 1 then goto ereturn;
until ia(1) = 0;
bytes := ia(2);
if test then testout(i,bytes//2);
<* clear user buffer*>
for i:= 1 step 1 until oleng do opar(i) := -1;
<* translate primo dataformat to user output format.
* array descr gives the structure for the fields
* which has to be copied to the user area .*>
ecode := level := zix := 0;
stackix := 1;
stack(stackix) := 1;
rep1:
<* look in primo data for a header with level <=
* current level (nlevel).*>
repeat
if gethdr(rectype, nlevel, form, size) = 0 then goto ereturn;
until nlevel <= level;
<* unstack description until level becomes nlevel in current
* primo header. *>
stackix := stackix - (level - nlevel);
level := nlevel;
start := stack(stackix);
<* search in description(level) for record typr.*>
for i := start, i+2 while descr(i-2) > 0 do
if rectype = abs(descr(i)) then goto found;
goto rep1;
found:
<* check if the description tree is deeper, i.e.
* there is one more level needed. *>;
if descr(i+1) > 0 then
begin stackix := stackix + 1;
level := level + 1;
stack(stackix):= descr(i+1);
goto rep1;
end else
begin
<* a parameter field has to be moved acording to
* action number. *>
case -descr(i+1) of
begin
getfield(tname,4);
getfield(tno,1);
getfield(treply,1);
getfield(tserr,2);
getfield(trerr,2);
begin opar(tsubno) := 1;
getfield(tsubst,1);
end;
getfield(tcause,1);
getfield(tsubpos,2);
end;
end;
goto rep1;
ereturn:
getzone(z, ia);
ia(13):= 0; <*zone state*>
setzone(z, ia);
close(z,true);
transfer := ecode;
if test then
begin write(out,<:<10>transfer = :>, <<ddd>,ecode);
for i := 1 step 1 until oleng do
write(out,<:<10>:>, <<ddddddddd>, opar(i));
end;
end; end;
▶EOF◀