$CONTROL USLINIT,SOURCE,MAP,CODE                                        00010000
<< patch >>                                                             00012000
<< hp32002c mpe source c.00.00 >>                                       00014000
$copyright     "(C) COPYRIGHT HEWLETT-PACKARD CO. 1980. ",            & 00016000
$     "THIS PROGRAM MAY BE USED WITH ONE COMPUTER SYSTEM AT A ",      & 00018000
$     "TIME AND SHALL NOT OTHERWISE BE RECORDED, TRANSMITTED OR ",    & 00020000
$     "STORED IN A RETRIEVAL SYSTEM.  COPYING OR OTHER REPRODUCTION ",& 00022000
$     "OF THIS PROGRAM EXCEPT FOR ARCHIVAL PURPOSES IS PROHIBITED ",  & 00024000
$     "WITHOUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY."   00026000
$control privileged,main=patch                                          00028000
  * *  program file patcher  cu.06  * *                                 00030000
begin                                                                   00032000
    define                                                              00034000
ptitle=("PROGRAM PATCH C.00.00 (C) HEWLETT-PACKARD CO., 1976")#,        00036000
        turnofftraps = push (status);                                   00038000
                       tos.(2:1):=0;                                    00040000
                       set (status) #;                                  00042000
   integer nval;                                                        00044000
   integer i1;                                                          00046000
   array obuf(0:39)_"  FILE=?";                                         00048000
   array ibuf(0:39);                                                    00050000
   byte array obufb(*)=obuf;                                            00052000
   byte array dpb(0:15);                                                00054000
   byte pointer sp_@obufb,spib_@sp;                                     00056000
   byte pointer dp_@dpb;                                                00058000
   array buf(0:127),zseg(0:127);                                        00060000
   integer l,seg,ll,rc,cnt,pfnum;                              <<01.01>>00062000
   array fn(0:16)=db;                                                   00064000
   byte array fnb(*)=fn;                                                00066000
   logical dataflag_0;                                                  00068000
   logical dflag,                                                       00070000
       qmcr_%37415;                                                     00072000
   integer x=x;                                                         00074000
   equate progmess = 0;  <<error message equates>>             <<00241>>00076000
   equate in'out = 4;  <<input out access to file--aopt>>      <<00241>>00078000
   logical aoptions;                                           <<00241>>00080000
   equate vuf'col=7;  << vuf column number >>                  <<04502>>00082000
$include inclvuf                                               <<04502>>00084000
   intrinsic quit;                                                      00086000
  procedure terminate; option external;                                 00088000
   intrinsic fopen,fread,freaddir,fwritedir,read,print,fclose;          00090000
intrinsic fgetinfo;                                            <<00241>>00092000
procedure blankbuf(n); value n; integer n;                              00094000
begin                                                                   00096000
   obuf(0)_"  ";                                                        00098000
move obuf(1)_obuf(0),(n);                                               00100000
end;                                                                    00102000
procedure octout1(buf,t,n); value t,n;                                  00104000
   byte array buf; integer t,n;                                         00106000
begin                                                                   00108000
   integer k=x;                                                         00110000
   k_n;                                                                 00112000
   tos_t;                                                               00114000
while (k_k-1)>=0 do                                                     00116000
   begin                                                                00118000
     assemble(dup,nop);                                                 00120000
     buf(k)_integer((logical(tos) land 7)+%60);                         00122000
     tos_tos&lsr(3);                                                    00124000
   end;                                                                 00126000
end;                                                                    00128000
procedure asci(sp,c,n,m); value n,m;                                    00130000
   byte array sp;                                                       00132000
   integer c,n,m;                                                       00134000
   begin                                                                00136000
     integer k_0,d1_0,d2_0,d3_0,x=x;                                    00138000
     label overflo;                                                     00140000
         while k < n do                                                 00142000
          begin                                                         00144000
           x _ m;                                                       00146000
           assemble(ldxa,lmpy);                                         00148000
           i1 _ tos;                                                    00150000
           assemble(xch,nop);                                           00152000
           assemble(ldxa,lmpy; dadd,xch);                               00154000
           if <> then goto overflo;                                     00156000
           assemble(xch,nop);                                           00158000
           tos _ i1;                                                    00160000
           tos _ 0;                                                     00162000
           tos _ sp(k);                                                 00164000
           assemble(dup,nop);                                           00166000
           if tos > "9" then tos _ tos-7;                               00168000
           tos _ tos-"0";                                               00170000
           assemble(dadd);                                              00172000
           if carry then goto overflo;                                  00174000
           k _ k+1;                                                     00176000
          end;                                                          00178000
         assemble(std c,i);                                             00180000
         return;                                                        00182000
overflo :                                                               00184000
   end <<asci>>;                                                        00186000
procedure scanw(a); value a; integer a;                                 00188000
begin                                                                   00190000
   scan sp while a,1;                                                   00192000
    @sp_tos;                                                            00194000
end;                                                                    00196000
integer procedure getnum;                                               00198000
begin                                                                   00200000
   integer k,k1,n;                                                      00202000
   scanw(%6440);                                                        00204000
   move dp_sp while n,0;                                                00206000
   @sp_tos+1;                                                           00208000
   n_tos-@dp;                                                           00210000
   asci(dpb,k,n,8);                                                     00212000
   getnum_k1;                                                           00214000
end;                                                                    00216000
procedure getrec(seg,l); value seg,l; integer seg,l;                    00218000
begin                                                                   00220000
       integer i,k;                                                     00222000
          tos := zseg(4);                                               00224000
          k := 28+(zseg(1)+1)&lsr(1);                                   00226000
          i := -1;                                                      00228000
          while(i:=i+1)<seg do tos:=tos+(zseg(k+i).(2:14)+127)&lsr(7);  00230000
    if dataflag then begin dataflag_0; rc_zseg(3) end else              00232000
   rc_tos;                                                              00234000
   assemble(load l; ldi 128; div);                                      00236000
   ll_tos;                                                              00238000
   rc_rc+tos;                                                           00240000
end;                                                                    00242000
procedure display(n);                                                   00244000
value n; integer n;                                                     00246000
   while n>0 do                                                         00248000
   begin                                                                00250000
   if ll>127 then                                                       00252000
   begin                                                                00254000
       rc_rc+1;                                                         00256000
       freaddir(pfnum,buf,128,double(rc));                              00258000
   if <> then quit(4);                                                  00260000
       ll_0;                                                            00262000
   end;                                                                 00264000
   blankbuf(1);                                                         00266000
   octout1(obufb(2),integer (buf(ll)),6);                               00268000
   print(obuf,4,0);                                                     00270000
   ll_ll+1;                                                             00272000
   n_n-1;                                                               00274000
   end;                                                                 00276000
procedure modify(a); value a; integer a;                                00278000
begin                                                                   00280000
   while a>0 do                                                         00282000
   begin                                                                00284000
     if ll>127 then                                                     00286000
     begin                                                              00288000
       fwritedir(pfnum,buf,128,double(rc));                             00290000
   if <> then quit(5);                                                  00292000
       freaddir(pfnum,buf,128,double(rc:=rc+1));                        00294000
   if <> then quit(5);                                                  00296000
       ll_0;                                                            00298000
     end;                                                               00300000
   blankbuf(1);                                                         00302000
   octout1(obufb(2),integer (buf(ll)),6);                               00304000
   obufb(8) := ",";                                                     00306000
   print(obuf,-9,%320);                                                 00308000
   x := read(obuf,-72);                                                 00310000
   obufb(x) := %15;                                                     00312000
     @sp_@spib;                                                         00314000
     scanw(%6440);                                                      00316000
     nval_getnum;                                                       00318000
     buf(ll)_nval;                                                      00320000
     ll_ll+1;                                                           00322000
     a_a-1;                                                             00324000
   end;                                                                 00326000
   fwritedir(pfnum,buf,128,double(rc));                                 00328000
   if <> then quit(6);                                                  00330000
end;                                                                    00332000
procedure fatalerr(messnum);                                   <<00241>>00334000
   value messnum;                                              <<00241>>00336000
   integer messnum;                                            <<00241>>00338000
begin                                                          <<00241>>00340000
   comment:                                                    <<00241>>00342000
      a fatal error has occured.  print error                  <<00241>>00344000
      message and terminate.                                   <<00241>>00346000
      ;                                                        <<00241>>00348000
                                                               <<00241>>00350000
   integer len;                                                <<00241>>00352000
   logical array wbuf(0:39);                                   <<00241>>00354000
   byte array buf(*)=wbuf;                                     <<00241>>00356000
                                                               <<00241>>00358000
   case messnum of                                             <<00241>>00360000
      begin                                                    <<00241>>00362000
      <<0>> move buf:="*** ERROR *** UNABLE TO OPEN FILE",2;   <<00241>>00364000
      end;                                                     <<00241>>00366000
   len:=tos-logical(@buf);                                     <<00241>>00368000
   print(wbuf,-len,0);                                         <<00241>>00370000
   terminate;                                                  <<00241>>00372000
                                                               <<00241>>00374000
end <<fatalerror>>;                                            <<00241>>00376000
<<**************************m a i n   p r o g  **********************>> 00378000
turnofftraps;                                                           00380000
   move ibuf := ptitle,2;                                   <<01.01>>   00382000
   l := tos-@ibuf;                                          <<01.01>>   00384000
   move ibuf(vuf'col):=official'vuuff;                         <<04502>>00386000
   print(ibuf,l,0);                                         <<01.01>>   00388000
print(obuf,4,%320);                                                     00390000
   x := read(fn,-32);                                                   00392000
   if x=0 then terminate;                                      <<00241>>00394000
   fnb(x) := %15;                                                       00396000
pfnum := fopen(fnb,%2001,4);<<old,nofile'eq,in/out access>>    <<00241>>00398000
   if <> then fatalerr(progmess);                              <<00241>>00400000
fgetinfo(pfnum,<<filename>>,<<fopt>>,aoptions);                <<00241>>00402000
if aoptions.(12:4) <> in'out then fatalerr(progmess);          <<00241>>00404000
fread(pfnum,zseg,128);                                                  00406000
   if <> then quit(2);                                                  00408000
while true do                                                           00410000
begin                                                                   00412000
   print(qmcr,-1,%320);                                                 00414000
   x := read(obuf,-72);                                                 00416000
   obufb(x) := %15;                                                     00418000
   scanw(%6440);                                                        00420000
move sp := sp while as;                                        <<04551>>00422000
    if sp="DG," then                                           <<b0.00>>00424000
     begin                                                     <<b0.00>>00426000
      dflag:=1;                                                <<b0.00>>00428000
      dataflag:=1;                                             <<b0.00>>00430000
      @sp:=@sp+3;                                              <<b0.00>>00432000
     end                                                       <<b0.00>>00434000
  else                                                         <<b0.00>>00436000
    if sp="MG," then                                           <<b0.00>>00438000
     begin                                                     <<b0.00>>00440000
      dflag:=0;                                                <<b0.00>>00442000
      dataflag:=1;                                             <<b0.00>>00444000
      @sp:=@sp+3;                                              <<b0.00>>00446000
     end                                                       <<b0.00>>00448000
   else                                                        <<b0.00>>00450000
  if sp="D," then                                              <<b0.00>>00452000
   begin                                                       <<b0.00>>00454000
    dflag:=1;                                                  <<b0.00>>00456000
    dataflag:=0;                                               <<b0.00>>00458000
    @sp:=@sp+2;                                                <<b0.00>>00460000
    seg:=getnum;                                               <<b0.00>>00462000
   end                                                         <<b0.00>>00464000
   else                                                        <<b0.00>>00466000
   if sp ="M," then                                            <<b0.00>>00468000
    begin                                                      <<b0.00>>00470000
     dflag:=0;                                                 <<b0.00>>00472000
     dataflag:=0;                                              <<b0.00>>00474000
     @sp:=@sp+2;                                               <<b0.00>>00476000
     seg:=getnum;                                              <<b0.00>>00478000
    end                                                        <<b0.00>>00480000
   else                                                        <<b0.00>>00482000
    begin                                                      <<b0.00>>00484000
     fclose(pfnum,0,0);                                        <<b0.00>>00486000
     if <> then quit(3);                                       <<b0.00>>00488000
     terminate;                                                <<b0.00>>00490000
    end;                                                       <<b0.00>>00492000
                                                               <<b0.00>>00494000
   l_getnum;                                                            00496000
   @sp_@sp-1;                                                           00498000
   if sp=%15 then cnt_1                                                 00500000
     else                                                               00502000
     begin                                                              00504000
       @sp_@sp+1;                                                       00506000
       cnt_getnum;                                                      00508000
     end;                                                               00510000
   getrec(seg,l);                                                       00512000
   freaddir(pfnum,buf,128,double(rc));                                  00514000
   if <> then quit(4);                                                  00516000
   if dflag then                                                        00518000
     display(cnt)                                                       00520000
   else                                                                 00522000
     modify(cnt);                                                       00524000
     @sp_@spib;                                                         00526000
   end;                                                                 00528000
end;                                                                    00530000
