⟦23a3b8db7⟧

TextFile

;ali time 2 0 
;copyright Anders Lindgård, march 1979;
mode list.yes
lookup netalglist
if ok.yes
mode 15.yes
lookup tnetcollect
netcollect=set 100
permanent netcollect.22
netcollect=hcalg
Call:
  <ls>=netcollect micro.<name> <parameters>
  <ls> outputarea. If it does not exist an area of 150 segments
       is created. If it does exist it must be a backing store file
  <parameters>::=program.<name>/block.<no>/
     header.<option>/key.<no>/<parameters>
  micro.<name> name of a microcomputer in the network.
  program.<name> name of a program for a local microcomputer. If this
       parameter is specified the microcomputer is loaded from scratch.
  block.<no>  If specified this block number is used instead of the block
       number from the tail of <ls>.
  header.<option> if specified the header information is not used when
       <option> is no.
  key.<no> if specified <ls> is permanented with this key.
  maxbuf.<no> if specified <no> of buffers will
           be used in the datacollection else double buffering
           is used. Legal values of <no> are 1,2,3.
begin
integer i,j,res,pda,block,segm,lastsegm,key,first,attbuf,buf,
       status,remaining,bufi,no,nextblock,maxbuf;
boolean endblock,statuserror,repeat,header,test,testout,listblock;
integer array tail(1:10),M,Mbs,A(1:8),
   m,a(1:256);
array outn,name,program,bs(1:3),command(1:10);
integer array field ia;

testout:=readsfp(<:out:>,outn);
test:=lookupentry(<:netcoltest:>)=0 or true or testout;
if -,readbfp(<:listblock:>,listblock) then listblock:=test;
cleanbuf(0);

if -,readlsfp(bs) then alarm(nl,1,star,3,<:left side missing:>);
res:=lookuptail(bs,tail);
if res<>0 then
begin
  cleararray(tail);
  tail(1):=150;
  res:=createentry(bs,tail);
  if res<>0 then alarm(nl,1,star,3,string inc(bs),<: create entry :>,res);
  end else
  if tail(1)<1 or tail(7)>tail(1) then
    alarm(nl,1,star,3,<:tail error segm  :>,tail(1),<: block :>,tail(7));
if readifp(<:key:>,key) then permentry(bs,key);
if -,readsfp(<:micro:>,name) then alarm(nl,1,star,3,<:micro not specified in call:>);
res:=reserveproc(name,0);
if res<>0 then alarm(nl,1,string inc(name),<: reservation error:>,res);
pda:=description(name);
i:=wordload(pda);
if i<>114 then alarm(nl,1,star,3,string inc(name),<: is not a local microcomputer:>);
if readsfp(<:program:>,program) then
begin
  res:=netprogload(string inc(name),string inc(program));
end else
begin
  res:=netoperat(string inc(name),opautoload,0);
end;
if res<>1 then alarm(nl,1,star,3,<:initialisation error:>);
res:=netoperat(string inc(name),opstart,0);
if res<>1 then alarm(nl,1,star,3,string inc(name),<: start error:>,res);
if -,readbfp(<:header:>,header) then header:=true;
if -,readifp(<:block:>,block) then block:=if header then tail(7) else 0;
res:=careaproc(bs);
if res<>0 then alarm(nl,1,star,3,string inc(bs),<: create area process:>,res);
res:=reserveproc(bs,0);
if res<>0 then alarm(nl,1,star,3,string inc(bs),<: reserve area process :>,res);
if -,readifp(<:maxbuf:>,maxbuf) then maxbuf:=2 else
  if maxbuf>3 then maxbuf:=3 else
  if maxbuf<1 then maxbuf:=1;

begin
integer array ba,sb(1:maxbuf),data(1:maxbuf*256);

for i:=1 step 1 until maxbuf do sb(i):=ba(i):=0;
endblock:=statuserror:=false;
Mbs(1):=opoutput;
M(1):=opinput+2;
first:=M(2):=firstaddr(data);
M(3):=M(2)+510;
sb(1):=M(4):=block shift 1;
lastsegm:=tail(1);
ba(1):=sendmessage(pda,M);
if maxbuf>=2 then
begin
  M(2):=first+512;
  M(3):=M(2)+510;
  sb(2):=M(4):=(block+1) shift 1;
  ba(2):=sendmessage(pda,M);
  nextblock:=block+1;
end;
if maxbuf>=3 then
begin
  M(2):=first+1024;
  M(3):=M(2)+510;
  sb(3):=M(4):=(block+2) shift 1;
  nextblock:=block+2;
  ba(3):=sendmessage(pda,M);
end;
attbuf:=att;
if ba(1)=0 or ba(maxbuf)=0 or attbuf=0 then
begin
  cleanbuf(0);
  alarm(nl,1,star,3,<:too few buffers:>);
end;
remaining:=0;
if testout then
begin
  stackcuro;
  res:=connectcuro(outn);
  if res<>0 then unstackcuro;
end;
no:=0;
for no:=no+1 while
  (remaining>0 or -,endblock) and -,statuserror do
begin
  if test then write(out,nl,2,<:run :>,no,block);
  buf:=0;
  res:=waitevent(buf);
  if res=0 then
  begin
   getevent(buf);
   sendanswer(buf,2,A);
  end
  else
  if buf=attbuf then
  begin
    comment attbuf;
    cleararray(command);
    if header then
    begin
      readstring(in,command,1);
      if command(1)=real <:end:> then
      begin
      end
    else
    begin write(out,nl,1,star,2,<:unknown command:>); outend(0); end;
    end else endblock:=true;
    getevent(attbuf);
    attbuf:=att;
  end
  else
  begin
  bufi:=if buf=ba(1) then 1 else
        if buf=ba(2) then 2 else 
        if buf=ba(3) then 3 else 0;
if bufi=0 then getevent(buf) else
begin
  ia:=(bufi-1)*512;
  if testout then
  begin
    write(out,nl,1);
    for i:=8 step 2 until 22 do 
    begin
    j:=wordload(ba(bufi)+i);
    if i=8 then writebinary(out,j) else
    if i=10 then write(out,nl,1,<<dddddd>,j) else
    write(out,<<  dddddd>,j,<< dd>,j shift (-16) extract 8, 
        j shift (-8) extract 8, j extract 8, j extract 16,<:;:>);
    end write;
    end testout;
  res:=waitanswer(ba(bufi),A);
  remaining:=remaining-1;
  repeat:=false;
  if res=1 and A(1)=0 and A(2)=0 then repeat:=true else
  if res>1 then alarm(nl,1,string inc(name),<: result transfer :>,res) else
  if A(1)<>0 then
  begin
    write(out,nl,1,star,3,string inc(name),<: status:>);
    writebinary(out,A(1));
    alarm(<::>);
  end;
  if listblock and -,repeat then write(out,nl,1,<:block no (read):>,data.ia(3));
  if header then 
  begin
    block:=data.ia(3);
    status:=data.ia(6);
    if testbit(status,10) then endblock:=true else
    if status<>0 then statuserror:=true;
    if statuserror then
    begin
      write(out,nl,1,star,2,string inc(name),<: status in block:>);
      writebinary(out,status);
      alarm(<::>);
    end;
  end header;
  M(2):=Mbs(2):=first+ia;
  M(3):=Mbs(3):=Mbs(2)+510;
  Mbs(4):=block;
  if repeat then
  begin
    M(4):=sb(bufi);
    if test then write(out,nl,1,<:wait block :>,block,M(4)extract 16);
  end
else
  if block>lastsegm or block<0 then 
    alarm(nl,1,star,3,<:blocknumber range:>,block,<: last segment :>,lastsegm)
 else

  begin
    for res:=waitanswer(sendmessage(bs,Mbs),A) while 
      res=1 and A(1)=0 and A(2)=0 do;
    if res>1 then alarm(nl,1,star,3,string inc(bs),<: transfererror:>,res) else
    if A(1)<>0 then
    begin
      write(out,nl,1,star,3,string inc(bs),<: status:>);
       writebinary(out,A(1));
      alarm(<::>);
    end;
    tail(7):=block;
    res:=changeentry(bs,tail);
    if res<>0 then alarm(nl,1,star,3,string inc(bs),<: changeentry:>,res);
    if  test then 
      begin write(out,nl,1,<:segment :>,block); outend(10); end;
    block:=block+1;
    sb(bufi):=M(4):=(nextblock+1) shift 1;
    nextblock:=nextblock+1;
    end -,repeat;
    ba(bufi):=if endblock then 0 else send_message(pda,M);
    remaining:=remaining+(if endblock then 0 else 1);
end bufi<>0;
    end answer;
end
if testout then closeout;
end array block;
end
▶EOF◀
DataMuseum.dk

RC4000/8000/9000

⟦23a3b8db7⟧ TextFile

Derivation

TextFile
