⟦c58362154⟧

TextFile

job hlv 3 1000 time 11 0 size 50000 perm mini 1000 10
(mode list.yes
punchprom1=set 1 mini
scope project punchprom1
punchprom1=algol list.yes xref.no bossline.yes 
finis)
\f


begin 
  comment <area=>punchprom <func> <areas>   
          <func>::= mode.<modetype>, prom.<promparams>, check.<checkparams>
          <modetype>::=8:8,4:<auto>,0:<boot>
          <promparams>::= <firstadr>.<size>.<part>
          <checkparams>::= <size>.<no-of-proms>.<mask>
          <firstadr>, <size>, <no-of-proms>, <mask>::= integer
          <part>::= l : r

  version: 800825 hlv;
  integer check,esc,mode,i,i0,j,p1,p2,sourceno,word, count;
  long l;
  real r;
  integer field inf1;
  integer array filename(0:11);
  integer firstadr, promsize, promside,promno, errcnt, toterrcnt;
  integer array table(0:255);
  zone zi(128*2,2,stderror),zo(128,1,stderror), ptr(12,2,stderror);

  procedure punch_word(mode);
  value mode; integer mode;
  begin
    integer i,n,p;
    word:=word extract 16;
    for i:=word shift(-8), word extract 8 do
    begin
      check:=check+i;
      if mode=8 then write(zo, false add i, 1) else
      begin
        for p:=i shift(-4) + 16, i extract 4 do
        begin
          p:=if p=0 then 96 else p+64;
          p:=p extract 8;
          write(zo, false add p, 1);
        end;
      end;
    end;
  end punch;

boolean procedure opennextsource(z, sourceno);
  integer sourceno;
  zone z;
begin
  integer i, j, k, cnt, pno, file, block;
  boolean first;
  real array field ra;
  integer array arr(1:10);
  real array rarr(1:2);
  procedure alarm;
  begin
    write(out, <:<10>connect file:>, <<-d>, sourceno, <:<10>:>);
    goto slut;
  end;

  first:=true;
  if sourceno>1 then close(z, true);
  opennextsource:=true;
  pno:=1;
  if system(4, pno, rarr)=6 shift 12 + 10 then pno:=pno+1;
  cnt:=k:=0;
  for j:=system(4, pno, rarr) while cnt<>sourceno and(j<>0 or k<>0) do
  begin
    if k=4 shift 12 + 10 and (j shift(-12)=4 or j=0) then
      cnt:=cnt+1;
    k:=j;
    pno:=pno+1;
  end;
  if cnt<>sourceno or pno<>2 and sourceno=0 then opennextsource:=false else
  begin
    system(4, pno-2, rarr);
    cnt:=0;
    for i:=0 step 1 until 11 do filename(i):=rarr(1+i//6)
                                          shift(8*(i mod 6)-40)extract 8;
\f


loop:
    i:=1;
    if sourceno<>0 and mode >= 0 then
    begin
      write(out,<:<10>sourcefile: :>);
      j:=12-write(out,string rarr(increase(i)));i:=1;
      write(out,false add 32,j,<: segm: :>,count//750,
                <: bytes: :>,((count mod 768)-3*(count//768)));
    end;
    open(z, 4, string rarr(increase(i)), 0);
    if monitor(42, z, j, arr)<>0 then
    begin
      for j:=1 step 1 until 10 do arr(j):=0; arr(1):=1;
      if monitor(40,z,j,arr)<>0 then alarm;
      goto out1;
    end;
    if first then
    begin
      file:=arr(7);
      block:=arr(8);
      first:=false;
    end;
    if arr(1)<0 then
    begin
      ra:=2;
      rarr(1):=arr.ra(1);
      rarr(2):=arr.ra(2);
    end;
    if arr(1)=1 shift 23 + 4 then
    begin
      cnt:=cnt+1;
      if cnt=100 then alarm;
      close(z, false);
      goto loop;
    end;
    if arr(1)<0 then
    begin
      j:=arr(1) shift(-12) extract 11;
      k:=arr(1) extract 12;
      if k>20 or k extract 1=1 or arr(1)=0 or j extract 1=1 or
        j>(if k=10 or k=12 then 6 else if k=16 then 4 else if
        k=18 then 2 else 0) then alarm;
      j:=arr(1)extract 23;
      if k=20 then j:=j+(14-20);
      close(z, false);
      k:=1;
      open(z, j, string rarr(increase(k)), 0);
    end not bsarea;
    k:=arr(1) extract 12;
    if k<>10 and k<>16 then setposition(z,file,block);
    if sourceno<>0 then sourceno:=sourceno+1;
  end;
out1:
end opennextsource;
\f


procedure examineparams;
begin
  integer names;
  names:=3;
  begin
    boolean first;
    integer pno, j, i,paramfct;
    real array rarr(1:2), name(1:names, 1:2);
    integer array field ia;

    procedure alarm;
    begin
      write(out, <:<10>params<10>:>);
      goto slut;
    end;

    integer procedure type;
    begin
      type:= if i extract 12=4 then 1 else if rarr(1)=real<:yes:>
             then 2 else if rarr(1)=real<:no:> then 3 else 4;
    end;

    for j:=1 step 1 until names do name(j,1):=name(j,2):=real<::>;
    name(1,1):= real<:mode:>;
    name(2,1):= real<:prom:>;
    name(3,1):= real<:check:>;

    mode:=8;
    pno:=1;
    if system(4,pno,rarr)=6 shift 12 + 10 then pno:=pno+1;

    for j:=system(4,pno,rarr) while j<>0 do
    begin
      if j<>4 shift 12 + 10 then alarm;
      for paramfct:=1 step 1 until names do
        if name(paramfct,1)=rarr(1) and
        name(paramfct,2)=rarr(2) then goto ud; ud:

      first:=true;
      for i:=system(4,increase(pno)+1,rarr)while i shift(-12)=8 do
      begin comment .param;
        case paramfct of
        begin
           begin comment mode;
              if type=1 then
              begin
                if rarr(1)<>8 then alarm;
                mode:=rarr(1);
                paramfct:= names+2;
              end else
              if rarr(1)=real<:auto:> then
              begin
                 mode:= 4;
                 paramfct:= names+2;
              end else
              if rarr(1)=real<:boot:> then
              begin
                 mode:=0;
                 paramfct:=names+2;
              end;
           end mode first param;

           begin comment prom;
             if type = 1 then firstadr:= rarr(1) else alarm;
             i:= system(4,increase(pno)+1,rarr);
             if i shift (-12) <> 8 then alarm;
             if type = 1 then promsize:= rarr(1) else alarm;
             i:= system(4,increase(pno)+1,rarr);
             if i shift (-12) <> 8 then alarm;
             if type = 4 then
             begin
               if rarr(1) = real<:l:> then promside:= -8 else
               if rarr(1) = real<:r:> then promside:= 0
               else alarm;
             end else alarm;
             mode:= -1;
           end prom;
           begin comment check;
             if type = 1 then promsize:= rarr(1) else alarm;
             i:= system(4,increase(pno)+1,rarr);
             if i shift (-12) = 8 and type = 1 then firstadr:= rarr(1) else alarm;
             i:= system(4,increase(pno)+1,rarr);
             if i shift (-12) = 8 and type = 1 then promside:= rarr(1) else alarm;
             mode:= -2;
           end check;

           if -, first then alarm;comment not known;
           alarm; comment no more points might follow;
        end case paramfct of;
        first:= false;
     end paramlist;
     end outer loop;
    end inner block;
  end examin params;
\f


;comment programstart;

  examineparams;

  if mode = -2 then
  begin comment check;
    open(ptr,8 shift 12 + 10,<:reader:>,0);
    write(out,<:<10>prom compare, size: :>,promsize,<:, no of proms: :>,
              firstadr,<:, mask: :>,promside,false add 10,2);
    sourceno:= 1; toterrcnt:= 0;
    for i:= 0 step 1 until 255 do table(i):= 7 shift 12 + i;
    intable(table); table_index:= 0;
    if -,opennextsource(zi,sourceno) then goto slut;

    for promno:= 1 step 1 until firstadr do
    begin
      write(out,<:<10>prom no: :>,promno,false add 10,1);
      errcnt:= 0;
      for i:= readchar(ptr,p1) while p1<>255 do ;
      for i:= readchar(zi ,p2) while p2<>255 do ;

      for count:= 0 step 1 until promsize do
      begin
        readchar(ptr,p1); readchar(zi,p2);
        if logand(p1,promside) <> logand(p2,promside) then
        begin
          if errcnt < 20 then write(out,<:adr: :>,count,<:, ptr: :>,
                                        logand(p1,promside),<:, disc: :>,
                                        logand(p2,promside),<:<10>:>);
          errcnt:= errcnt + 1;
        end;
      end;
      write(out,<:<10>:>,errcnt,<: errors in prom no: :>,promno,
                false add 10,2);
    end;
    write(out,<:<10>:>,toterrcnt,<: errors in total compare<10>:>);
    close(zi,true);
    close(ptr,true);
    goto slut;
  end check;

  if -,opennextsource(zo,0) then
  open(zo,4 shift 12 +12,<:punch:>,0);
  if mode>0 then  write(zo,false,100,false add 64,1);
  if mode=0 then goto mode0;
  if mode < 0 then
  begin <* prom *>
    count:= 0;
    sourceno:= 1;
    write(zo,false,100,false add 255,1);
    for i0:= 0 while opennextsource(zi,sourceno) do
    begin
promblock:
      inrec6(zi,512);
      for inf1:= 2 step 2 until 512 do
      begin
        word:= zi.inf1;
        if word < 0 then
        begin
          if count < firstadr then count:= firstadr;
          write(out,<:<10>input too short, prom filled with :>,
                    firstadr+promsize-count,<: zeros<10>:>);
          write(zo,false add 255,firstadr+promsize-count);
          count:= firstadr + promsize;
        end;
        if count >= firstadr then
        begin
          if count < firstadr + promsize then
            write(zo,false add ((word shift promside) extract 8),1)
          else
          begin
            write(zo,false,100);
            write(out,<:<10>prom punched succesfully<10>:>);
            goto slut2;
          end;
        end;
        count:= count + 1;
      end block;
      goto promblock;
promslut:
    end source;
    write(out,<:<10>*** input too short, prom incomplete ***<10>:>);
    goto slut2;
  end prom;

  check:=0;
  if mode=4 then
  begin
    count:=0;
    sourceno:=1;
    for i0:=0 while opennextsource(zi, sourceno) do
    begin
nb:
      inrec6(zi, 512);
      for inf1:=2 step 2 until 512 do
      begin
        if zi.inf1<0 then goto sl1;
        count:=count+2;
      end;
      goto nb;
sl1:
    end;
    word:=(count+258) extract 16;
    punchword(mode);
  end mode=4;
  sourceno:= 1;
  for i0:= 0 while opennextsource(zi,sourceno) do
  begin
nextblock:
    inrec6(zi,512);
  for inf1:=2 step 2 until 512 do
    begin
      word:= zi.inf1;
      if word<0 then goto slut1;
      punch_word(mode);
    end;
    goto next_block;
slut1:
  end;
  word:=check;
  punchword(mode);
  goto slut;
\f


mode0:
  sourceno:=1;count:=0;
  for inf1:=2 while opennextsource(zi,sourceno) do
  for inf1:=inf1 while inf1=2 do
  if count mod 768=0 then
  begin  check:=0;
     count:=count+write(zo,false,1,false add(765 shift(-8)extract 8),1,
                           false add(765 extract 8),1);
  end else
  if count mod 768=753 then
  begin
    <* write(out,<:<10>segmentno: :>,<<ddd>,count//768,<:  checksum: :>);
    for i:=-15,-12,-9,-6,-3,0 do outchar(out,48+((check shift i)extract 3)); *>
    count:=count+15;
    outchar(zo,check shift(-8)extract 8);
    outchar(zo,check extract 8);outchar(zo,0);
    for i:=0 step 1 until 11 do outchar(zo,filename(i));
  end else
  begin  inrec6(zi,2);word:=zi.inf1;
     if word<0 then inf1:=0 else
     for i:=word shift(-8)extract 8,word extract 8 do
     begin  check:=(check-i)extract 16;
        count:=count+write(zo,false add i,1);
     end;
  end;
  i:=count mod 768;
  if i<>0 then
  begin <*fill last datasegment*>
    if i<753 then write(zo,false,753-i);
    write(zo,false add(check shift(-8)extract 8),1,
             false add(check extract 8),1,false,1);
    for i:=0 step 1 until 11 do outchar(zo,filename(i));
  end <*fill last data segment*>;
  write(zo,false,2,false add 15,1,<:rc3500fpaloader:>);
  write(zo,true,2,false add((-3)extract 8),1);
  write(zo,<:end rc3500bootloader :>);
  write(out,<:<10>rc3500-bootloader: :>,(count//750)+1,<:  segments<10>:>);
slut:
  write(zo,false add 3,1,false add 25,3,false,100);
slut2:
  close(zo,true);
  monitor(42,zo,i,filename);
  systime(1,0,r);l:=625*r;
  filename(6):=l shift(-15)extract 24;
  monitor(44,zo,i,filename);
end;

▶EOF◀
DataMuseum.dk

RC4000/8000/9000

⟦c58362154⟧ TextFile

Derivation

TextFile
