$CONTROL MAP,CODE,USLINIT                                               00010000
<<slpatch>>                                                             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 main=slpatch,privileged                                       00028000
$ title "            SL PATCH UTILITY"                                  00030000
begin                                                                   00032000
                                                                        00034000
<<----------------------------------------------------------------------00036000
*                                                                      *00038000
*                           sl file patcher                            *00040000
*                                                                      *00042000
*                                cu.06                                 *00044000
*                                                                      *00046000
---------------------------------------------------------------------->>00048000
                                                                        00050000
define                                                         <<01.01>>00052000
ptitle=("SLPATCH C.00.00 (C) HEWLETT-PACKARD CO., 1976")#;              00054000
                                                                        00056000
integer xreg = x;                                                       00058000
integer s0 = s-0;                                                       00060000
byte pointer bps0 = s-0;                                                00062000
                                                                        00064000
array prompt (0:0) _ "? ";                                              00066000
array msg2 (0:4) _ "SL FILE?  ";                                        00068000
array msg3 (0:6) _ "SEGMENT NAME? ";                                    00070000
array msg4 (0:7) := "ILLEGAL COMMAND ";                                 00072000
array msg5 (0:10) := "SEGMENT NOT SPECIFIED ";                          00074000
array msg6 (0:9) _ "ILLEGAL SEGMENT NAME";                              00076000
array msg7 (0:7) := "INVALID SL FILE ";                                 00078000
array msg8 (0:6) _ "ILLEGAL RANGE ";                                    00080000
array msg9 (0:6) _ "ILLEGAL NUMBER";                                    00082000
array msg10 (0:9) := "*** END-OF-FILE *** ";                            00084000
array msg11 (0:8) := "*** I/O ERROR *** ";                              00086000
array msg12 (0:7) := "FILE ERROR =    ";                                00088000
                                                                        00090000
array tty (0:35);                                                       00092000
byte array btty (*) = tty;                                              00094000
byte array delims (0:1) _ ",",%15;  <<command delimiters>>              00096000
integer nrparms;                                                        00098000
double array descrip (0:3)=db;                                          00100000
double descrip1 = descrip+0;                                            00102000
byte pointer ident1 = descrip1;                                         00104000
integer info1 = ident1+1;                                               00106000
byte len1 = info1;                                                      00108000
double descrip2 = descrip+2;                                            00110000
byte pointer ident2 = descrip2;                                         00112000
integer info2 = ident2+1;                                               00114000
byte len2 = info2;                                                      00116000
double descrip3 = descrip+4;                                            00118000
byte pointer ident3 = descrip3;                                         00120000
integer info3 = ident3+1;                                               00122000
byte len3 = info3;                                                      00124000
double descrip4 = descrip+6;                                            00126000
byte pointer ident4 = descrip4;                                         00128000
integer info4 = ident4+1;                                               00130000
byte len4 = info4;                                                      00132000
                                                                        00134000
equate slfilecode = 1031,  <<file code>>                                00136000
       slversion = 3;  <<latest version nr.>>                           00138000
integer slfnum;  <<sl file nr.>>                                        00140000
integer array slrec0 (0:127);  <<sl file record 0>>                     00142000
integer array slrec1 (0:127);  <<sl file record 1>>                     00144000
integer slnrt;  <<nr. reference table entries>>                         00146000
integer array rtbuf (0:127);  <<reference table buffer>>                00148000
integer pointer rtp;  <<reference table entry pointer>>                 00150000
double drtrecd := 0d;  <<reference table rec. nr.>>                     00152000
integer rtrecd = drtrecd+1;                                             00154000
byte array segname (0:15);  <<segment name>>                            00156000
integer segnr := -1;  <<segment nr.>>                                   00158000
integer seglen;  <<segment length>>                                     00160000
integer segrecd;  <<starting record nr.>>                               00162000
                                                                        00164000
integer i;                                                              00166000
logical modify;                                                         00168000
integer array buf (*) = slrec0;  <<record buffer>>                      00170000
integer adr;  <<segment address>>                                       00172000
integer count;  <<nr. words requested>>                                 00174000
double drecd _ 0d;                                                      00176000
integer recd = drecd+1;                                                 00178000
integer disp;                                                           00180000
   equate vuf'col=4;  << vuf column number >>                  <<04542>>00182000
$include inclvuf                                               <<04542>>00184000
intrinsic quit;                                                         00186000
intrinsic fopen,fclose,freaddir,fwritedir,fcheck,fgetinfo,flock;        00188000
intrinsic read,print,mycommand,ascii,binary;                            00190000
                                                                        00192000
procedure ioerror;                                                      00194000
   begin                                                                00196000
   if <> then  <<error?>>                                               00198000
      begin                                                             00200000
      if > then  <<end of file?>>                                       00202000
         begin                                                          00204000
         tos := @msg10;                                                 00206000
         tos := -19                                                     00208000
         end                                                            00210000
      else  <<i/o error>>                                               00212000
         begin                                                          00214000
         tos := @msg11;                                                 00216000
         tos := -17                                                     00218000
         end;                                                           00220000
      print(*,*,0);                                                     00222000
      quit(0)                                                           00224000
      end                                                               00226000
   end;                                                                 00228000
procedure ferror;                                                       00230000
   begin                                                                00232000
   if <> then  <<error?>>                                               00234000
      begin                                                             00236000
      tos := @msg12;                                                    00238000
      tos := 0;  <<for result of ascii>>                                00240000
      tos := 0; fcheck(slfnum,s0);  <<error nr.>>                       00242000
      tos := 10;  <<conversion base>>                                   00244000
      tos := @msg12&lsl(1)+13;                                          00246000
      tos := ascii(*,*,*);  <<convert error nr.>>                       00248000
      tos := -tos-13;                                                   00250000
      print(*,*,0);                                                     00252000
      ioerror;  <<error?>>                                              00254000
      quit(1);                                                          00256000
      end                                                               00258000
   end;                                                                 00260000
logical procedure getnum (num,string,length);                           00262000
   value length;                                                        00264000
   integer num,length;                                                  00266000
   byte array string;                                                   00268000
   begin                                                                00270000
   integer result = getnum;                                             00272000
   @string _ @string-1;                                                 00274000
   string _ "%";  <<force octal conversion>>                            00276000
   length _ length+1;                                                   00278000
   num _ binary(string,length);                                         00280000
   if <> then  <<error?>>                                               00282000
      begin                                                             00284000
      print(msg9,-14,0);  <<"ILLEGAL NUMBER">>                          00286000
      ioerror;  <<error?>>                                              00288000
      return                                                            00290000
      end;                                                              00292000
   result := result+1  <<return true>>                                  00294000
   end;                                                                 00296000
procedure getreftabentry (segnr);                                       00298000
   value segnr;                                                         00300000
   integer segnr;                                                       00302000
   begin                                                                00304000
   tos := segnr; tos := 4;                                              00306000
   assemble(div,stbx);                                                  00308000
   @rtp := (tos&lsl(5))+@rtbuf;                                         00310000
   tos := slrec1(xreg);  <<rec. nr.>>                                   00312000
   if s0 <> rtrecd then  <<different record?>>                          00314000
      begin                                                             00316000
      rtrecd := tos;                                                    00318000
      freaddir(slfnum,rtbuf,128,drtrecd);                               00320000
      ferror  <<error?>>                                                00322000
      end;                                                              00324000
   seglen _ rtp.(2:14);  <<segment length>>                             00326000
   segrecd _ rtp(1)  <<starting record nr.>>                            00328000
   end;                                                                 00330000
integer procedure searchsegname;                                        00332000
   begin                                                                00334000
   tos := slnrt-1;                                                      00336000
   while >= do                                                          00338000
      begin                                                             00340000
      getreftabentry(s0);                                               00342000
      if not logical(rtp(3).(0:1)) then  <<not deleted?>>               00344000
         begin                                                          00346000
         tos := @rtp(8)&lsl(1);                                         00348000
         if * = segname,(16) then go getout                             00350000
         end;                                                           00352000
      tos := tos-1                                                      00354000
      end;                                                              00356000
   getout:                                                              00358000
   searchsegname := tos  <<seg. nr.>>                                   00360000
   end;                                                                 00362000
procedure loadbuffer;                                                   00364000
   begin                                                                00366000
   freaddir(slfnum,buf,128,drecd);  <<read first record>>               00368000
   ferror  <<error?>>                                                   00370000
   end;                                                                 00372000
procedure storebuffer;                                                  00374000
   begin                                                                00376000
   if modify then  <<buffer modified?>>                                 00378000
      begin                                                             00380000
      fwritedir(slfnum,buf,128,drecd);                                  00382000
      ferror  <<error?>>                                                00384000
      end                                                               00386000
   end;                                                                 00388000
                                                                        00390000
<<* * * primary entry point * * *>>                                     00392000
                                                                        00394000
go ob1;                                                                 00396000
                                                                        00398000
<<* * * secondary entry point * * *>>                                   00400000
                                                                        00402000
                                                                        00404000
ob1: move tty := ptitle,2;                                     <<01.01>>00406000
   move tty(vuf'col):=official'vuuff;                          <<04542>>00408000
   print(tty,(s0 := s0-@tty),0);                               <<01.01>>00410000
ioerror;  <<error?>>                                                    00412000
                                                                        00414000
<<* * * get sl file name * * *>>                                        00416000
                                                                        00418000
ob2:                                                                    00420000
print(msg2,-9,%320);  <<"SL FILE?">>                                    00422000
ioerror;  <<error?>>                                                    00424000
tos _ read(tty,-72);  <<read sl file name>>                             00426000
ioerror;  <<error?>>                                                    00428000
xreg := tos; if = then go ob2;  <<zero char. count?>>                   00430000
btty(xreg) := %15;  <<insert cr stopper>>                               00432000
mycommand(btty,delims(1),1,nrparms,descrip);                            00434000
if > then  <<error?>>                                                   00436000
   begin                                                                00438000
   print(msg4,-16,0);  <<"ILLEGAL COMMAND">>                            00440000
   go ob2                                                               00442000
   end;                                                                 00444000
                                                                        00446000
<<* * * open sl file * * *>>                                            00448000
                                                                        00450000
slfnum := fopen(ident1,%(2)00000000011,%(2)111110110);                  00452000
ferror;  <<error?>>                                                     00454000
flock(slfnum,true);  <<get file exclusively>>                           00456000
freaddir(slfnum,slrec0,256,0d);  <<read records 0,1>>                   00458000
ferror;  <<error?>>                                                     00460000
tos := 0;                                                               00462000
fgetinfo(slfnum,,,,,,,,s0);                                             00464000
if tos <> slfilecode or slrec0 <> slversion then                        00466000
   begin                                                                00468000
   print(msg7,-15,0);  <<"INVALID SL FILE">>                            00470000
   ioerror;  <<error?>>                                                 00472000
   go ob2                                                               00474000
   end;                                                                 00476000
slnrt _ slrec0(9);  <<nr. reference table entries>>                     00478000
                                                                        00480000
<<* * * process command * * *>>                                         00482000
                                                                        00484000
ob3:                                                                    00486000
print(prompt,-1,%320);  <<prompt = "?">>                                00488000
ioerror;  <<error?>>                                                    00490000
tos := read(tty,-72);  <<read command>>                                 00492000
ioerror;  <<error?>>                                                    00494000
xreg := tos; if = then go ob3;  <<zero char. count?>>                   00496000
btty(xreg) := %15;  <<insert cr stopper>>                               00498000
mycommand(btty,delims,4,nrparms,descrip);                               00500000
if > then  <<error?>>                                                   00502000
   begin                                                                00504000
   error4:                                                              00506000
   print(msg4,-16,0);  <<"ILLEGAL COMMAND">>                            00508000
   go ob3                                                               00510000
   end;                                                                 00512000
                                                                        00514000
if ident1 = "EXIT" and integer(len1) = 4 and nrparms = 1 then           00516000
   go finished;                                                         00518000
if not (2 <= nrparms <= 4) then go error4;                              00520000
                                                                        00522000
<< * * * get segment name * * *>>                                       00524000
                                                                        00526000
if ident2 = alpha and nrparms >= 3 then  <<new segment?>>               00528000
   begin                                                                00530000
   if len1 > 15 then go error1;  <<too long?>>                          00532000
   move segname := ident1,(integer(len1)),2;  <<segment name>>          00534000
   bps0 := " "; assemble(dup,incb);                                     00536000
   move * := *,(15-integer(len1));  <<trailing blanks>>                 00538000
   tos := searchsegname;                                                00540000
   assemble(test);                                                      00542000
   if < then  <<can't find segment?>>                                   00544000
      begin                                                             00546000
      del;                                                              00548000
      error1:                                                           00550000
      print(msg6,-20,0);  <<"ILLEGAL SEGMENT NAME">>                    00552000
      ioerror;  <<error?>>                                              00554000
      if segnr <> -1 then getreftabentry(segnr);  <<restore old seg.>>  00556000
      go ob3                                                            00558000
      end;                                                              00560000
   segnr := tos;  <<segment nr.>>                                       00562000
   tos := @descrip1; tos := @descrip2; tos := 6;                        00564000
   assemble(move 3);                                                    00566000
   nrparms := nrparms-1                                                 00568000
   end;                                                                 00570000
if segnr = -1 then  <<segment not specified?>>                          00572000
   begin                                                                00574000
   print(msg5,-21,0);  <<"SEGMENT NOT SPECIFIED">>                      00576000
   ioerror;  <<error?>>                                                 00578000
   go ob3                                                               00580000
   end;                                                                 00582000
                                                                        00584000
if integer(len1) <> 1 then go error4;                                   00586000
if ident1 = "D" then  <<dump cells?>>                                   00588000
   begin                                                                00590000
   tos := false;  <<clear modify flag>>                                 00592000
   loop:                                                                00594000
   modify := tos;  <<modify flag>>                                      00596000
   if not getnum(adr,ident2,integer(len2)) then go ob3;                 00598000
   if nrparms = 3 then  <<optional count?>>                             00600000
      if not getnum(count,ident3,integer(len3)) then go ob3             00602000
      else                                                              00604000
   else count _ 1;  <<default count = 1>>                               00606000
   if adr >= seglen or adr+count-1 >= seglen then                       00608000
      begin                                                             00610000
      error8:                                                           00612000
      print(msg8,-13,0);  <<"ILLEGAL RANGE">>                           00614000
      ioerror;  <<error?>>                                              00616000
      go ob3                                                            00618000
      end;                                                              00620000
   recd _ segrecd+adr.(0:9);  <<starting record nr.>>                   00622000
   disp _ adr.(9:7);  <<starting record displacement>>                  00624000
   loadbuffer;  <<read first record>>                                   00626000
   tos _ count;  <<word counter>>                                       00628000
   while <> do                                                          00630000
      begin                                                             00632000
      tryagain:                                                         00634000
      ascii(buf(disp),8,btty);  <<current contents>>                    00636000
      if modify then  <<modify contents?>>                              00638000
         begin                                                          00640000
         move btty(6) _ " _ ";                                          00642000
         print(tty,-9,%320);                                            00644000
         ioerror;  <<error?>>                                           00646000
         tos := read(tty,-72);                                          00648000
         ioerror;  <<error?>>                                           00650000
         xreg := tos; if = then go tryagain;  <<zero char. count?>>     00652000
         btty(xreg) := %15;  <<insert cr stopper>>                      00654000
         mycommand(btty,delims(1),1,nrparms,descrip);                   00656000
         if > then  <<error?>>                                          00658000
            begin                                                       00660000
            print(msg9,-14,0);  <<"ILLEGAL NUMBER">>                    00662000
            ioerror;  <<error?>>                                        00664000
            go tryagain                                                 00666000
            end;                                                        00668000
         if ident1 <> "*" or integer(len1) <> 1 then                    00670000
            begin                                                       00672000
            if not getnum(i,ident1,integer(len1)) then go tryagain;     00674000
            buf(disp) _ i  <<modify contents>>                          00676000
            end                                                         00678000
         end                                                            00680000
      else  <<print contents>>                                          00682000
         begin                                                          00684000
         print(tty,-6,0);  <<print number>>                             00686000
         ioerror  <<error?>>                                            00688000
         end;                                                           00690000
      disp _ (disp+1).(9:7);                                            00692000
      if = then  <<refil buffer?>>                                      00694000
         begin                                                          00696000
         storebuffer;  <<save record>>                                  00698000
         recd _ recd+1;                                                 00700000
         loadbuffer  <<read next record>>                               00702000
         end;                                                           00704000
      tos := tos-1                                                      00706000
      end;                                                              00708000
   del;                                                                 00710000
   storebuffer;  <<save last record>>                                   00712000
   go ob3                                                               00714000
   end;                                                                 00716000
                                                                        00718000
if ident1 = "M" then  <<modify cells?>>                                 00720000
   begin                                                                00722000
   tos := true;  <<set modify flag>>                                    00724000
   go loop                                                              00726000
   end;                                                                 00728000
                                                                        00730000
go error4;  <<illegal command?>>                                        00732000
                                                                        00734000
finished:                                                               00736000
end;                                                                    00738000
