<< LINES .001/.009 ARE RESERVED FOR SYSTEMS INTEGRATION>>               00000001
$control map,code,uslinit                                               00010000
<<diskedt2>>                                                            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=disked2                                        00028000
begin                                                                   00030000
equate vufpos = 8;                                             <<04692>>00032000
$include inclvuf                                               <<04692>>00034000
    define                                                              00036000
ptitle = ("DISKED2         (C) HEWLETT-PACKARD CO., 1976")#,   <<04692>>00038000
        turnofftraps = push (status);                                   00040000
                       tos.(2:1):=0;                                    00042000
                       set (status) #;                                  00044000
                                                                        00046000
<< format control >>                                                    00048000
equate                                                                  00050000
   stay = %320,                                                         00052000
   doubles = %60; <<causes double space (ascii "0").>>         <<01154>>00054000
<< eject = %61 >> << unused >>                                 <<01154>>00056000
<< misc >>                                                              00058000
   double capd;                                                         00060000
   logical cap=capd,mode;                                               00062000
   integer len;                                                         00064000
   integer s0 = s-0;                                                    00066000
   integer s2 = s-2;                                           <<04692>>00068000
   integer q0 = q-0;                                           <<04692>>00070000
   integer xreg = x;                                                    00072000
   logical delp = q-2;                                                  00074000
<< define sysup=cap.(5:1)#; >> << unused >>                    <<01154>>00076000
   define sysmgr=cap.(0:1)#;                                            00078000
   define cr=%15,%12#;                                                  00080000
   define modei = mode #;                                               00082000
   define moded = mode & lsr(1) #;                                      00084000
   logical saves, errorl;                                               00086000
   integer array dummy (*) = db+0;                             <<01.01>>00088000
<< mycommand stuff >>                                                   00090000
byte array dict (0:160) :=                                     <<04692>>00092000
   9, 4, "DISC", 1, 1, 0,                                               00094000
   11, 6, "MODIFY", 2, 3, 1,                                            00096000
9, 4, "DUMP", 1, 3, 2,                                         <<b0.01>>00098000
   9, 4, "LIST", 0, 1, 3,                                               00100000
   9, 4, "EXIT", 0, 0, 4,                                               00102000
   10, 5, "INSTR", 0, 0, 5,                                             00104000
   9,4,"BASE",0,1,6,                                                    00106000
   10,5,"DEBUG",0,0,7,                                                  00108000
   10,5,"WIDTH",0,0,8,                                                  00110000
   9,4,"HELP",0,0,9,                                                    00112000
   6,1,"M",2,3,10,                                             <<03514>>00114000
   6,1,"D",1,3,11,                                             <<03514>>00116000
   6,1,"L",0,1,12,                                             <<03514>>00118000
   6,1,"E",0,0,13,                                             <<03514>>00120000
   6,1,"B",0,1,14,                                             <<03514>>00122000
   6,1,"W",0,0,15,                                             <<03514>>00124000
   6,1,"H",0,0,16,                                             <<03514>>00126000
   9,4,"FILE",1,1,17,                                          <<04692>>00128000
   6,1,"F",1,1,18,                                             <<04692>>00130000
   0;                                                                   00132000
   equate maxp = 3;                                                     00134000
   double array parms (0:maxp);                                         00136000
double secta,basea;                                                     00138000
   array lparms (*) = parms;                                            00140000
   byte pointer defn;                                                   00142000
   integer secsize := 128,func,type,ldev,i;                    <<03514>>00144000
   integer np;                                                          00146000
<< "EXECUTOR"s >>                                                       00148000
   switch comswitch :=                                                  00150000
      disc,modify,dump,list,exit,loop,base,dbug,width,help,    <<03514>>00152000
      modify,dump,list,exit,base,width,help,file,file;         <<04692>>00154000
   integer                                                              00156000
        nums, numwds, wdpos, linep, coln, mxlen;               <<04692>>00158000
   logical ddu := 1,    fnl := 0,  short := false;                      00160000
logical nonum :=false;                                         <<b0.01>>00162000
<< disc buffer >>                                                       00164000
   array dbuf (0:512); byte array dbbuf(*) = dbuf;             <<03514>>00166000
<< other buffers >>                                                     00168000
   array buf(0:65) ;                                                    00170000
   byte array bbuf (*) = buf;                                           00172000
   array pbuf (*) = buf(5);                                             00174000
   byte array pbbuf (*) = pbuf;                                         00176000
   array numbuf(0:36) :=                                       <<03514>>00178000
"        .1234567.1234567.1234567.1234567",                    <<03514>>00180000
         ".1234567.1234567.1234567.1234567";                   <<03514>>00182000
   byte array msg(0:375);                                      <<04692>>00184000
   array msg'(*)=msg;                                                   00186000
   array prompt (0:0) := "> ";                                          00188000
   equate promptl = -1;                                                 00190000
   array err (0:4) := " **ERROR";                                       00192000
   equate errl = -8;                                                    00194000
   array smes (0:29) := "SECTOR %                  LDEV = %      ";     00196000
   byte array bsmesn(*) = smes(4);                                      00198000
   byte array sbmesn1(*) = smes(17);                                    00200000
   equate smesl = 20;                                                   00202000
   array wr (0:3) := "WRITTEN";                                         00204000
   equate wrl = -7;                                                     00206000
   byte array fdl(0:8):="DEDILIST ";                                    00208000
   byte array fdl1(0:8) := "DEDITTY ";                                  00210000
                                                               <<04692>>00212000
logical mask,modf;                                             <<04692>>00214000
integer lfn,pos;                                               <<04692>>00216000
<< file label information >>                                   <<04692>>00218000
double lastsector,llastsector,sectl;                           <<04692>>00220000
array   flab(0:127);                                           <<04692>>00222000
double array flabd(*)=flab;                                    <<05018>>00223000
double array extmap(*) = flabd(22);                            <<05018>>00224000
equate                                                         <<04692>>00226000
   flskip1      = 28,                                          <<04692>>00230000
   flskip2      = 34,                                          <<04692>>00232000
   flskip3      = 35;                                          <<04692>>00234000
define                                                         <<04692>>00236000
   flflim       = flabd(15)#,                                  <<04692>>00238000
   fleof        = flabd(21)#,                                  <<05018>>00238100
   flstart      = flabd(56)#,                                  <<06081>>00238110
   flend        = flabd(57)#,                                  <<05018>>00238200
   flfcbv       = flab(27)#,                                   <<05018>>00239000
   fllbleof     = flab(29).(0:8)#,                             <<05018>>00239010
   fllbl        = flab(29).(8:8)#,                             <<05018>>00239020
   flfoptions   = flab(36)#,                                   <<05018>>00239100
   flformat     = flfoptions.(8:2)#,                           <<05018>>00239200
   flnormvar    = (flformat = 1)#,                             <<05018>>00239300
   flrecsize    = integer(flab(37))#,                          <<05018>>00240000
   flblksize    = integer(flab(38))#,                          <<05018>>00242000
   flsectoff    = flab(39).(0:8)#,                             <<04692>>00244000
   flnumexts    = integer(flab(39).(11:5))#,                   <<05018>>00245000
   fllastextsize= flab(40)#,                                   <<04692>>00246000
   flextsize    = flab(41)#;                                   <<05018>>00248000
                                                               <<05018>>00250000
                                                               <<04692>>00252000
                                                               <<04692>>00264000
equate                                                         <<04692>>00266000
   fcbextmap    = %44,                                         <<04692>>00268000
   sizebfcb     = 36,                                          <<04692>>00270000
   sizexacb     = 56,                                          <<04692>>00272000
   fsoverhead   = 5;                                           <<04692>>00274000
                                                               <<04692>>00276000
<< control y >>                                                <<04692>>00278000
integer cyaddr,cylabel,cyold;                                  <<04692>>00280000
integer sval,qval,statval;                                     <<04692>>00282000
integer deltap=q-2,qmstat=q-1,deltaq=q-0;                      <<04692>>00284000
                                                               <<04692>>00286000
intrinsic getprivmode,ferrmsg,ffileinfo,xcontrap,resetcontrol; <<04692>>00288000
intrinsic fopen,fwrite,fgetinfo,fclose,fcheck,read,print;      <<04692>>00290000
intrinsic dbinary,dascii,who,binary,ascii,debug,quit;          <<04692>>00292000
                                                                        00294000
integer procedure mycommand (buf, ds, mp, np, p, di, de);               00296000
   value mp;                                                            00298000
   byte array buf, ds, di;                                              00300000
   integer mp, np;                                                      00302000
   double array p;                                                      00304000
   byte pointer de;                                                     00306000
   option external, variable;                                           00308000
                                                                        00310000
double procedure attachio (du,qmisc, dst,buf, func, cnt, p1, p2,flags); 00312000
   value du,qmisc, dst, buf, func, cnt, p1, p2,flags;                   00314000
   integer du,qmisc, dst, buf, func, cnt, p1, p2,flags;                 00316000
   option external;                                                     00318000
                                                                        00320000
integer procedure ldevtotype(ldev);                            <<03514>>00322000
   value ldev;                                                 <<03514>>00324000
   integer ldev;                                               <<03514>>00326000
   option external;                                            <<03514>>00328000
                                                               <<03514>>00330000
integer procedure ldevtosubtype(ldev);                         <<03514>>00332000
   value ldev;                                                 <<03514>>00334000
   integer ldev;                                               <<03514>>00336000
   option external;                                            <<03514>>00338000
                                                               <<03514>>00340000
double procedure getfcb'info(fcbv,item);                       <<05018>>00344000
value fcbv,item;                                               <<05018>>00346000
integer fcbv,item;                                             <<05018>>00348000
option external;                                               <<05018>>00350000
integer procedure num (n);                                              00386000
   value n;                                                             00388000
   integer n;                                                           00390000
begin                                                                   00392000
   tos := 0;                                                            00394000
   tos := lparms (n & asl(1));                                          00396000
   tos := lparms (xreg+1).(0:8);                                        00398000
   num := binary (*, *);                                                00400000
   if <> then delp := errorl;                                           00402000
   end    <<num>>;                                                      00404000
                                                                        00406000
                                                                        00408000
procedure lio (buf, len, cntrl);                                        00410000
   value len, cntrl;                                                    00412000
   array buf;                                                           00414000
   integer len, cntrl;                                                  00416000
begin                                                                   00418000
   array lerr (0:40);                                                   00420000
   byte array blerr (*) = lerr;                                         00422000
   if fnl = 0 then go fwerr;                                            00424000
   if (len > mxlen) then len := mxlen;                                  00426000
   if (-len > (mxlen & asl(1))) then len := mxlen;                      00428000
   fwrite(fnl,buf,len,cntrl);                                           00430000
   if <> then                                                           00432000
    begin <<fwrite error or eof>>                                       00434000
fwerr:                                                                  00436000
      move blerr_(" **FWRITE ERR ON LIST #"),2;                         00438000
      len_tos-@blerr;                                                   00440000
      fcheck(fnl,cntrl);                                                00442000
      print(lerr,-len-ascii(cntrl,10,blerr(len)),0);                    00444000
      delp := errorl;                                                   00446000
      end;                                                              00448000
   end    <<lio>>;                                                      00450000
                                                                        00452000
                                                                        00454000
procedure dio (func, sectn);                                            00456000
   value func, sectn;                                                   00458000
   integer func;double sectn;                                           00460000
begin                                                                   00462000
   integer len,sectn1=sectn,sectn2=sectn+1;                             00464000
    array msg'(0:39);                                                   00466000
    byte array msg(*)=msg';                                             00468000
                                                                        00470000
   tos:=attachio(ddu,0,0,@dbuf,func,secsize,sectn1,sectn2,1);  <<03514>>00472000
   assemble (del,dup);                                         <<00817>>00474000
   if (tos land %377) <> 1 then <<error>>                      <<00817>>00476000
   begin                                                                00478000
      assemble (dup);                                          <<00817>>00480000
      if (tos land %377) = %64 then                            <<00817>>00482000
      begin  <<invalid disc address>>                          <<00817>>00484000
         move msg := (" **INVALID DISC ADDRESS**"),2;          <<00817>>00486000
         len := tos-@msg;                                      <<00817>>00488000
         print (msg',-len,0);                                  <<00817>>00490000
         delp := errorl;  <<return to error>>                  <<00817>>00492000
      end  <<end invalid disc address>>                        <<00817>>00494000
      else                                                     <<00817>>00496000
      begin  <<other error>>                                   <<00817>>00498000
      tos _ tos land %377; <<mask off pcb>>                             00500000
      move msg _ (" **IRRECOVERABLE DISC ERROR =%"),2;                  00502000
      len_tos-@msg;                                                     00504000
      ascii(*,8,msg(len));                                              00506000
      print(msg',-(len+6),0);                                           00508000
      delp_errorl;                                                      00510000
      end;  <<end other error>>                                <<00817>>00512000
   end; <<error>>                                              <<00817>>00514000
end; <<dio>>                                                            00516000
procedure controly;                                            <<04692>>00518000
   begin                                                       <<04692>>00520000
   msg := " ";                                                 <<04692>>00522000
   print(msg',-1,0);                                           <<04692>>00524000
   deltap.(2:14) := cyaddr;                                    <<04692>>00526000
   qmstat := statval;                                          <<04692>>00528000
   push(q);                                                    <<04692>>00530000
   deltaq := tos - qval;                                       <<04692>>00532000
   resetcontrol;                                               <<04692>>00534000
   end;                                                        <<04692>>00536000
                                                               <<04692>>00538000
integer procedure lastextsize(flab);                           <<04692>>00540000
   integer array flab;                                         <<04692>>00542000
   begin                                                       <<04692>>00544000
   integer rsize;                                              <<04692>>00546000
   tos := flrecsize;                                           <<04692>>00550000
   if < then tos := -tos else tos := tos&lsl(1);               <<04692>>00552000
   rsize := tos;  <<pos. bytes>>                               <<04692>>00554000
   if fllastextsize = 0 then <<compute last ext size>>         <<04692>>00556000
      begin                                                    <<04692>>00558000
      tos := flflim;                                           <<04692>>00560000
      xreg := flblksize/(rsize&lsr(1));                        <<04692>>00562000
      assemble(zero,cab;ldxa,ldiv;cab,ldxa;ldiv);              <<04692>>00564000
      if tos <> 0 then tos := tos+1d;                          <<04692>>00566000
      xreg := (flblksize+127)&lsr(7);                          <<04692>>00568000
      assemble(ldxa,lmpy;cab,ldxa;mpy,zero;dadd);              <<04692>>00570000
      tos := tos+double(logical(flsectoff));                   <<04692>>00572000
      tos := flextsize;                                        <<04692>>00574000
      assemble(ldiv,delb;test);                                <<04692>>00576000
      if = then tos := tos+flextsize;                          <<04692>>00578000
      end else                                                 <<04692>>00580000
      tos := fllastextsize;                                    <<04692>>00582000
      lastextsize := tos;                                      <<04692>>00584000
   end;   <<lastextsize>>                                      <<04692>>00586000
$page                                                          <<06081>>00588000
logical procedure fileopen(filename);                          <<04692>>00590000
   byte array filename;                                        <<04692>>00592000
                                                               <<05018>>00592010
   <<*******************************************************>> <<05018>>00592020
   << this procedure opens the file for the "FILE" command. >> <<05018>>00592030
   << it also sets the variable for the eof sector and the  >> <<05018>>00592040
   << file limit sector.  it lastly extracts the fcb extent >> <<05018>>00592050
   << map and copies it to the flab extent map since the    >> <<05018>>00592060
   << fcb extent map has ldev's instead of vtab's.          >> <<05018>>00592070
   <<   input varialbe:                                     >> <<05018>>00592080
   <<      filename - byte array containing the file name.  >> <<05018>>00592090
   <<   output variable:                                    >> <<05018>>00592100
   <<      fileopen - true if successful open.              >> <<05018>>00592110
   <<                 false if fopen failed.                >> <<05018>>00592120
   <<*******************************************************>> <<05018>>00592130
                                                               <<05018>>00592140
   begin                                                       <<04692>>00594000
   integer len,pos:=0,error,recsize;                           <<04692>>00596000
   double flabaddr,                                            <<05018>>00598000
      full'blks;     << number of full blocks in the file.  >> <<05018>>00599000
   integer flabaddr1 = flabaddr;                               <<04692>>00600000
   integer                                                     <<05018>>00602000
      sects'blk,     << sectors per block of file.          >> <<05018>>00604000
      blk'fact,      << number of records per block.        >> <<05018>>00604200
      recs'last'blk, << num. of recs in partial block.      >> <<05018>>00604400
      sects'last'blk,<< num. of sectors in partial block.   >> <<05018>>00604500
      fcbv,          << fcb vector for getfcb'info.         >> <<05018>>00605000
      ext'offset;    << offset into extent map to obtain.   >> <<05018>>00606000
                                                               <<05018>>00607000
   if lfn <> 0 then fclose(lfn,0,0);  <<close old file>>       <<04692>>00608000
   while filename(pos) = " " do pos := pos +1;                 <<04692>>00610000
                                                               <<06081>>00614000
   <<*******************************************************>> <<06081>>00616000
   << first, fopen the file.  try exclusive with r/w first. >> <<06081>>00618000
   << if that fails, then try shared, read only.  if that   >> <<06081>>00620000
   << fails, then error exit. open the file perm/temp, with >> <<06081>>00622000
   << the copy bit on for ksam and message files.           >> <<06081>>00624000
   <<*******************************************************>> <<06081>>00626000
                                                               <<06081>>00630000
   lfn := fopen(filename(pos),%2003,%10504);                   <<06081>>00632000
   if <> then                                                  <<04692>>00634000
      begin                                                    <<04692>>00636000
      lfn := fopen(filename(pos),%2003,%10400);                <<06081>>00638000
      if <> then                                               <<04692>>00640000
         begin                                                 <<04692>>00642000
         fcheck(,error);                                       <<04692>>00644000
         ferrmsg(error,msg',len);                              <<04692>>00646000
         print(msg',-len,0);                                   <<04692>>00648000
         goto erxit;                                           <<04692>>00650000
         end                                                   <<04692>>00652000
         else modf := false;                                   <<04692>>00654000
      end                                                      <<04692>>00656000
      else modf := true;                                       <<04692>>00658000
$page                                                          <<06081>>00658100
   <<*******************************************************>> <<06081>>00658200
   << obtain remote ldev via fgetinfo (ffileinfo does not   >> <<06081>>00658300
   << work for this). this must be changed in mpe v with the>> <<06081>>00658310
   << coming of the 16 bit ldev.  now, obtain flabaddr from >> <<06081>>00658400
   << ffileinfo. if non-disc file, it will return 0d.       >> <<06081>>00658500
   <<*******************************************************>> <<06081>>00658600
                                                               <<06081>>00658700
   fgetinfo(lfn,, ,, ,,ddu);  << obtain remote ldev, if one.>> <<06081>>00658800
   ffileinfo(lfn,19,flabaddr);<< obtain file label address. >> <<06081>>00658900
                                                               <<06081>>00660000
   << only local disc files are allowed, anything else, die!>> <<06081>>00660200
                                                               <<06081>>00660300
   if flabaddr = 0d or ddu.(0:8) <> 0 then                     <<06081>>00660400
      begin                                                    <<06081>>00660500
      move msg := "  **LOCAL DISC FILES ONLY",2;               <<06081>>00660510
      len := tos - @msg;                                       <<06081>>00660600
      print(msg',-len,0);                                      <<06081>>00660700
erxit:                                                         <<06081>>00660900
      fclose(lfn,0,0);                                         <<06081>>00661000
      fileopen := false;                                       <<06081>>00661100
      lfn := 0;                                                <<06081>>00661110
      return;             << get out!                       >> <<06081>>00661120
      end;                                                     <<06081>>00661200
                                                               <<06081>>00661300
   << it is indeed a local disc file, read the flab.        >> <<06081>>00661400
                                                               <<06081>>00661500
   ddu := flabaddr1.(0:8);                                     <<04692>>00662000
   flabaddr1.(0:8) := 0;                                       <<04692>>00664000
   dio(0,flabaddr);                                            <<04692>>00666000
   move flab := dbuf,(secsize);                                <<05018>>00668000
                                                               <<06081>>00668100
                                                               <<06081>>00668200
   <<*******************************************************>> <<06081>>00668300
   << now, calculate the physcial file limit and logical    >> <<06081>>00668400
   << eof.  for variable files, the logical eof is easy, for>> <<06081>>00668500
   << fixed and undefined, it takes a some calculations.    >> <<06081>>00668600
   <<*******************************************************>> <<06081>>00668700
                                                               <<06081>>00668800
   lastsector := double(flnumexts)*double(flextsize)+          <<05018>>00670000
                 double(lastextsize(flab)-1);                  <<04692>>00672000
   recsize:= flrecsize;                                        <<05018>>00674000
   if recsize < 0                                              <<05018>>00676000
      then recsize := (\recsize\+1)/2;  << positive words.  >> <<05018>>00677000
   sects'blk := (flblksize +secsize-1)/secsize;                <<05018>>00678000
   blk'fact := flblksize/recsize;                              <<05018>>00680000
   if flnormvar then                                           <<05018>>00682000
      begin                                                    <<06127>>00682100
      if fleof = 0d                                            <<06127>>00682200
         then llastsector := 0d                                <<06127>>00682300
         else llastsector := (flstart+flend+1d)*               <<06081>>00684000
                             double(sects'blk);                <<06081>>00684500
      end                                                      <<06127>>00685000
   else                                                        <<05018>>00686000
      begin                                                    <<05018>>00688000
      full'blks := fleof/double(blk'fact);                     <<05018>>00690000
      recs'last'blk := fleof modd logical(blk'fact);           <<05018>>00692000
      sects'last'blk :=                                        <<05018>>00693000
           (recs'last'blk*recsize+secsize-1)/secsize;          <<05018>>00693100
      llastsector :=                                           <<05018>>00693200
          (full'blks*double(sects'blk))+double(sects'last'blk);<<05018>>00693210
      end;                                                     <<05018>>00693300
   llastsector := llastsector+double(flsectoff-1);             <<04692>>00694000
   fileopen := true;                                           <<04692>>00696000
                                                               <<05018>>00697000
   << extract extent map from fcb >>                           <<04692>>00698000
                                                               <<04692>>00700000
   fcbv := flfcbv;                                             <<05018>>00704000
   for ext'offset:=0 until flnumexts do                        <<05018>>00706000
      extmap(ext'offset) := getfcb'info(flfcbv,fcbextmap+      <<05018>>00708000
                                               ext'offset*2);  <<05018>>00710000
                                                               <<04692>>00722000
   end;   <<fileopen>>                                         <<04692>>00724000
$page                                                          <<06081>>00725000
                                                               <<04692>>00726000
logical procedure readsector(m);                               <<04692>>00728000
   value m;                                                    <<04692>>00730000
   logical m;                                                  <<04692>>00732000
   begin                                                       <<04692>>00734000
   integer ctrl:=doubles,                                      <<04692>>00736000
           len,ext,                                            <<04692>>00738000
           secta1 = secta;                                     <<04692>>00740000
   if not sysmgr and lfn = 0 then <<open file>>                <<04692>>00746000
      begin                                                    <<04692>>00748000
tryagain:                                                      <<04692>>00750000
      move msg := "FILE ? ",2;                                 <<04692>>00752000
      len := tos-@msg;                                         <<04692>>00754000
      print(msg',-len,stay);                                   <<04692>>00756000
      len := read(msg',-30);                                   <<04692>>00758000
      if len = 0 then  <<terminate>>                           <<04692>>00760000
         begin                                                 <<04692>>00762000
         readsector := false;                                  <<04692>>00764000
         return;                                               <<04692>>00766000
         end;                                                  <<04692>>00768000
      msg(len) := " ";                                         <<04692>>00770000
      if not fileopen(msg) then goto tryagain;                 <<04692>>00772000
      end;                                                     <<04692>>00774000
   if lfn <> 0 then  <<compute abs. address>>                  <<04692>>00776000
      begin                                                    <<04692>>00778000
      if m and not modf then <<modify cmd>>                    <<04692>>00780000
         begin                                                 <<04692>>00782000
         move msg := "  **WRITE ACCESS IS REQUIRED",2;         <<04692>>00784000
         len := tos-@msg;                                      <<04692>>00786000
         print(msg',-len,0);                                   <<04692>>00788000
         readsector := false;                                  <<04692>>00790000
         return;                                               <<04692>>00792000
         end;                                                  <<04692>>00794000
      if sectl = 0d and m and not sysmgr then                  <<04692>>00796000
         begin                                                 <<04692>>00798000
         move msg := "  **SYS. MGR CAPABILITY IS REQUIRED",2;  <<04692>>00800000
         move * := " TO MODIFY FILE LABEL",2;                  <<04692>>00802000
         len := tos-@msg;                                      <<04692>>00804000
         print(msg',-len,0);                                   <<04692>>00806000
         readsector := false;                                  <<04692>>00808000
         return;                                               <<04692>>00810000
         end;                                                  <<04692>>00812000
      <<print logical sector number>>                          <<04692>>00814000
      msg := " ";move msg(1) := msg,(72);                      <<04692>>00816000
      move msg := "LOGICAL SECTOR ",2;                         <<04692>>00818000
      len := dascii(sectl,10,msg(72));                         <<04692>>00820000
      move * := msg(72),(len);                                 <<04692>>00822000
      if sectl = 0d then                                       <<04692>>00824000
         move msg(24) := "*** FILE LABEL ***"                  <<04692>>00826000
         else if sectl <= double(fllbleof) then                <<05018>>00828000
         move msg(20):="*** USER-DEFINED LABEL - WRITTEN ***"  <<04692>>00830000
         else                                                  <<04692>>00832000
         if sectl <= double(fllbl) then                        <<05018>>00834000
         move msg(19):="*** USER-DEFINED LABEL - AVAILABLE ***"<<04692>>00838000
         else if sectl < double(flsectoff) then                <<04692>>00840000
         move msg(26):="*** UNUSED ***"                        <<04692>>00842000
         else if sectl = double(flsectoff) then                <<04692>>00844000
         move msg(20):="*** BEGINNING OF DATA ***"             <<04692>>00846000
         else if sectl = llastsector then                      <<04692>>00848000
         move msg(28) := "*** EOF ***";                        <<06127>>00850000
      if sectl > llastsector then                              <<06127>>00852000
         begin                                                 <<06127>>00853000
         move msg(20) := "*** BEYOND EOF ***           ";      <<06127>>00854000
         lio(msg',-72,ctrl);                                   <<06127>>00856000
         readsector := false;                                  <<06127>>00870000
         return;                                               <<06127>>00872000
         end;                                                  <<06127>>00874000
      lio(msg',-72,ctrl);                                      <<06127>>00874100
      ctrl := 0;                                               <<06127>>00875000
checkext:                                                      <<04692>>00876000
      ext := integer(sectl/double(flextsize));                 <<04692>>00878000
      if extmap(ext) = 0d then    <<extend not allocated>>     <<05018>>00880000
         begin                                                 <<04692>>00882000
         msg := " ";move msg(1) := msg,(30);                   <<04692>>00884000
         move msg := "EXTENT ",2;                              <<05018>>00886000
         len := ascii(ext,10,msg(30));                         <<04692>>00888000
         move * := msg(30),(len),2;                            <<04692>>00890000
         move * := " NOT ALLOCATED";                           <<04692>>00892000
         lio(msg',-30,0);                                      <<04692>>00894000
         sectl := sectl+double(flextsize);                     <<04692>>00896000
         nums := nums-integer(flextsize);                      <<04692>>00898000
         numwds := numwds - integer(flextsize) * secsize;      <<04692>>00900000
         if nums > 0 and sectl <= lastsector then go checkext  <<04692>>00902000
         else                                                  <<04692>>00904000
            begin                                              <<04692>>00906000
            readsector := false;                               <<04692>>00908000
            return;                                            <<04692>>00910000
            end;                                               <<04692>>00912000
         end;                                                  <<04692>>00914000
                                                               <<05018>>00916000
      secta:=extmap(ext)+double(sectl modd flextsize);         <<05018>>00918000
      ddu := secta1.(0:8);   <<get ldev>>                      <<04692>>00920000
      secta1.(0:8) := 0;                                       <<04692>>00922000
      ascii(ddu,8,sbmesn1);                                    <<04692>>00924000
      end;                                                     <<04692>>00926000
   dascii(secta,8,bsmesn);                                     <<04692>>00928000
   lio(smes,smesl,ctrl);                                       <<04692>>00930000
   dio(0,secta);                                               <<04692>>00932000
   readsector := true;                                         <<04692>>00934000
   end;                                                        <<04692>>00936000
                                                               <<04692>>00938000
logical subroutine setchecksum;                                <<04692>>00940000
   begin                                                       <<04692>>00942000
   mask := -1;                                                 <<04692>>00944000
   xreg := 127;                                                <<04692>>00946000
   do begin                                                    <<04692>>00948000
      if xreg <> flskip1 and xreg <> flskip2 and               <<04692>>00950000
         xreg <> flskip3 then                                  <<04692>>00952000
         mask := mask xor dbuf(xreg);                          <<04692>>00954000
      xreg := xreg-1;                                          <<04692>>00956000
      end until <;                                             <<04692>>00958000
   dbuf(flskip2) := mask;                                      <<04692>>00960000
   move msg := "CHECKSUM MODIFIED",2;                          <<04692>>00962000
   len := tos-@msg;                                            <<04692>>00964000
   print(msg',-len,0);                                         <<04692>>00966000
   end;  <<setchecksum>>                                       <<04692>>00968000
                                                               <<04692>>00970000
                                                               <<01.01>>00972000
                                                               <<04692>>00974000
   move msg := ptitle,2;                                       <<01.01>>00976000
   move msg(vufpos) := official'vuuff;                         <<04692>>00978000
   len := tos-@msg;                                                     00980000
   print(msg',-len,0);                                                  00982000
   who(mode,capd);                                                      00984000
   getprivmode;                                                <<04692>>00986000
   turnofftraps;                                                        00990000
<<initialize values for control y>>                            <<04692>>00992000
   cylabel := @controly;   <<trap handler procedure>>          <<04692>>00994000
   cyaddr := @start;   <<continuation entry point>>            <<04692>>00996000
   push(q);                                                    <<04692>>00998000
   qval := tos;   <<save initial value of q>>                  <<04692>>01000000
   push(s);                                                    <<04692>>01002000
   sval := tos;   <<save initial value of s>>                  <<04692>>01004000
   push(status);                                               <<04692>>01006000
   statval := tos;   <<save initial value of status>>          <<04692>>01008000
   xcontrap(cylabel,cyold);   <<activate trap handler>>        <<04692>>01010000
   errorl := @error'; <<set error address>>                    <<00817>>01012000
   move msg_("TYPE 'HELP' FOR INFO"),2;                                 01014000
   len_tos-@msg;                                                        01016000
   print(msg',-len,0);                                                  01018000
   push (s);                                                            01020000
   saves := tos;                                                        01022000
ascii (ddu,8,sbmesn1);                                         <<b0.01>>01024000
   if ldevtotype(ddu) = 3 and ldevtosubtype(ddu) = 0           <<03514>>01026000
   then secsize := 512;   << linus >>                          <<03514>>01028000
   go setlist;                                                          01030000
start:   <<resume after control y>>                            <<04692>>01032000
   push(s);                                                    <<04692>>01034000
   tos := tos - sval;                                          <<04692>>01036000
   assemble(subs 0);   <<reset value of s>>                    <<04692>>01038000
loop:                                                                   01040000
   tos := saves;                                                        01042000
   set (s);                                                             01044000
   if modei then print (prompt, promptl, stay);                         01046000
   len := read (buf, -72);                                              01048000
   << check if read is ok >>                                   <<01013>>01050000
   if > then go exit;                                          <<01013>>01052000
   if < then                                                   <<01013>>01054000
readerr:                                                       <<01013>>01056000
        begin                                                  <<01013>>01058000
            move msg:=("**HARDWARE END OF FILE ENCOUNTERED"),2;<<01013>>01060000
            len := tos - @msg;                                 <<01013>>01062000
            print(msg',-len,0);                                <<01013>>01064000
            quit(0);                                           <<01013>>01066000
        end;                                                   <<01013>>01068000
   if len=0 then goto loop;                                    <<05018>>01069000
   if not(moded) then print (buf, -len, 0);                             01070000
   bbuf (len) := %15;                                                   01072000
   mycommand (buf, , maxp, np, parms, dict, defn);                      01074000
   if <> then                                                           01076000
error:                                                                  01078000
      begin                                                             01080000
      print (err, errl, 0);                                             01082000
error':                                                        <<00817>>01084000
      if modei then goto loop;                                          01086000
      quit (0);                                                         01088000
      end;                                                              01090000
                                                               <<01154>>01092000
<< make sure the correct number of parameters are present.>>   <<01154>>01094000
   if not( integer(defn) <= np <= integer( defn(1) ) )         <<01154>>01096000
           then begin                                          <<01154>>01098000
      move msg :=                                              <<01154>>01100000
           "  WRONG NUMBER OF PARAMETERS.";                    <<01154>>01102000
      print ( err, errl, %320 );                               <<01154>>01104000
      print ( msg', -29, 0 );                                  <<01154>>01106000
      go to error';                                            <<01154>>01108000
   end;                                                        <<01154>>01110000
                                                               <<01154>>01112000
   goto comswitch (integer(defn(2)));                                   01114000
   goto error;                                                          01116000
                                                                        01118000
base:                                                                   01120000
   if np=0 then                                                         01122000
    begin  <<reset base address to 0d>>                                 01124000
     basea := 0d;                                                       01126000
     go loop;                                                           01128000
    end;                                                                01130000
   tos:=0d; << to prevent stack underflow in toothpick >>      <<b0.01>>01132000
   tos := lparms;                                                       01134000
   tos := lparms(1).(0:8);                                              01136000
   basea := dbinary(*,*);                                               01138000
   if <> then                                                           01140000
    begin                                                               01142000
     basea := 0d;                                                       01144000
adrinv:                                                                 01146000
     move buf := "INVALID DISC ADDRESS";                                01148000
     print(buf,-20,0);                                                  01150000
     go error;                                                          01152000
    end;                                                                01154000
   dio (0,secta); <<check if address is valid>>                <<00817>>01156000
                  <<for this disc>>                            <<00817>>01158000
   go loop;                                                             01160000
                                                                        01162000
dbug:                                                                   01164000
   debug;                                                               01166000
   go loop;                                                             01168000
                                                                        01170000
help:                                                                   01172000
   move msg := (cr,"DISKED2 allows to dump and/or ",           <<04692>>01174000
   "modify : file contents or",cr,"any disc sector",           <<04692>>01176000
   " (sys. mgr capability is required)."),2;                   <<04692>>01178000
   len := tos-@msg;                                            <<04692>>01180000
   print(msg',-len,0);                                         <<04692>>01182000
   move msg := (cr," B[ASE] [<ABS SEC #>]",cr,                 <<03514>>01184000
   " DEBUG",cr," DISC <LOG DEV #>",cr,                         <<03514>>01186000
   " D[UMP] [ [<REL SEC #>] [, <# OF SEC>] ] OR [<'ALL'>]",    <<04692>>01188000
   " [, A=ASCII ]",cr,                                         <<04692>>01190000
   "     (AT LEAST ONE PARAMETER MUST BE PRESENT.)",cr,        <<03514>>01192000
   " F[ILE] <FILENAME>",cr,                                    <<04692>>01194000
   " L[IST] [<DEVICE CLASS>] OR [<LOG DEV #>]",cr,             <<03514>>01196000
   " M[ODIFY] <SEC NUM, REL WORD ADDR [,NUM OF WORDS]>",cr,    <<03514>>01198000
   "     (NEW VALUE STARTS WITH : # - DECIMAL, ' - ASCII)"     <<04692>>01200000
    ,cr,                                                       <<04692>>01202000
   " W[IDTH]",cr," E[XIT]",cr),2;                              <<03514>>01204000
   len := tos-@msg-2;                                          <<03514>>01206000
   print(msg',-len,0);                                                  01208000
   go loop;                                                             01210000
width:                                                                  01212000
   move buf := "NARROW FORMAT?";                                        01214000
   print(buf,-14,0);                                                    01216000
   read(buf,-71);                                                       01218000
  << check for the read cc's >>                                <<01013>>01220000
  if > then go exit;                                           <<01013>>01222000
  if < then go readerr;                                        <<01013>>01224000
   short := if bbuf = "Y" then true else false;                         01226000
   go loop;                                                             01228000
                                                                        01230000
disc:                                                                   01232000
   if not sysmgr then                                          <<04692>>01234000
      begin                                                    <<04692>>01236000
      move msg := "  **SYS. MGR CAPABILITY IS REQUIRED",2;     <<04692>>01238000
      len := tos-@msg;                                         <<04692>>01240000
      print(msg',-len,0);                                      <<04692>>01242000
      goto loop;                                               <<04692>>01244000
      end;                                                     <<04692>>01246000
   @defn_lparms;                                                        01248000
   secsize := 128;   <<sector size in words>>                  <<03514>>01250000
   ldev := num(0);                                             <<03514>>01252000
   type := ldevtotype(ldev);   <<get device type>>             <<03514>>01254000
   if <> or type > 7 then                                      <<03514>>01256000
   begin                                                                01258000
      move msg_("DEVICE NOT DISC"),2;                                   01260000
      len_tos-@msg;                                                     01262000
      print(msg',-len,0);                                               01264000
      go error;                                                         01266000
   end                                                                  01268000
   else                                                                 01270000
   begin                                                                01272000
      if type = 3 and ldevtosubtype(ldev) = 0                  <<03514>>01274000
      then secsize := 512;  <<sector size for linus>>          <<03514>>01276000
      ddu := ldev;                                             <<03514>>01278000
      ascii(ddu,8,sbmesn1);                                             01280000
      if lfn <> 0 then                                         <<04692>>01282000
         begin                                                 <<04692>>01284000
         fclose(lfn,0,0);                                      <<04692>>01286000
         lfn := 0;                                             <<04692>>01288000
         end;                                                  <<04692>>01290000
    end;                                                                01292000
   goto loop;                                                           01294000
                                                                        01296000
list:                                                                   01298000
   fclose(fnl,1,0);                                                     01300000
   if np=0 then                                                         01302000
    begin                                                               01304000
setlist:                                                                01306000
     fnl := fopen(fdl1,%10);                                            01308000
     if <> then go listerr;                                             01310000
     go getlen;                                                         01312000
    end;                                                                01314000
   xreg := if bbuf = "LIST" then 4 else 1;                     <<04692>>01316000
   while bbuf(xreg) = " " do xreg := xreg+1;<<strip blanks>>            01318000
   if bbuf(xreg) = "0" then go setlist;<<ldev 0>>              <<00817>>01320000
   fnl := fopen(fdl,,%101,,bbuf(xreg));                                 01322000
   if <> then go listerr;                                               01324000
getlen:                                                                 01326000
   fgetinfo(fnl,,,,mxlen);                                              01328000
   if <> then debug;                                                    01330000
   if mxlen < 0 then mxlen := -mxlen & asr(1);                          01332000
   mxlen := mxlen-1;  <<avoid full line on crt>>                        01334000
   go loop;                                                             01336000
listerr:                                                                01338000
   move buf := "UNABLE TO OPEN LIST DEVICE";                            01340000
   print(buf,-26,0);                                                    01342000
   go error;                                                            01344000
                                                                        01346000
file:                                                          <<04692>>01348000
   pos := if bbuf = "FILE" then 4 else 1;                      <<04692>>01350000
   while bbuf(pos) = " " do pos := pos+1;                      <<04692>>01352000
   fileopen(bbuf(pos));                                        <<04692>>01354000
   goto loop;                                                  <<04692>>01356000
                                                               <<04692>>01358000
dump:                                                                   01360000
   pos := if bbuf = "DUMP" then 4 else 1;                      <<04692>>01362000
   while bbuf(pos) = " " do pos := pos+1;                      <<04692>>01364000
                                                               <<04692>>01366000
<<special processing for 'all' parameter>>                     <<04692>>01368000
   if bbuf(pos) = "ALL" then                                   <<04692>>01370000
      begin                                                    <<04692>>01372000
      secta := 0d;                                             <<04692>>01374000
      nums := %77777;                                          <<04692>>01376000
      nonum := false;                                          <<04692>>01378000
      if np >= 2 then                                          <<04692>>01380000
         begin                                                 <<04692>>01382000
         xreg := lparms(2);                                    <<04692>>01384000
         assemble(ldb db+0,x);                                 <<04692>>01386000
         if tos.(8:8) = "A" and np = 2 then                    <<04692>>01388000
         nonum := true                                         <<04692>>01390000
         else goto er2;                                        <<04692>>01392000
         end;                                                  <<04692>>01394000
      bbuf(7) := ":";                                          <<04692>>01396000
      goto pdump;                                              <<04692>>01398000
      end;                                                     <<04692>>01400000
                                                               <<04692>>01402000
assemble(dzro);                                                         01404000
                                                               <<01154>>01406000
<< disallow no specified parameters.                >>         <<01154>>01408000
   if (  lparms(1).(0:8)                                       <<01154>>01410000
         + ( if np >= 2 then lparms(3).(0:8) else 0 )          <<01154>>01412000
         + ( if np >= 3 then lparms(5).(0:8) else 0 ) )        <<01154>>01414000
           < 1  then begin                                     <<01154>>01416000
      move msg :=                                              <<01154>>01418000
           "ONE NON-NULL PARAMETER MUST BE SPECIFIED",2;       <<01154>>01420000
      len := tos - @msg;                                       <<01154>>01422000
      print ( msg', -len, 0 );                                 <<01154>>01424000
      go error;                                                <<01154>>01426000
   end;                                                        <<01154>>01428000
tos:=lparms;                                                            01430000
tos:=lparms(1).(0:8);                                                   01432000
secta:=dbinary(*,*);                                                    01434000
   if <> then                                                  <<01376>>01436000
   begin                                                       <<01376>>01438000
      move msg := "FIRST PARAMETER INVALID.";                  <<01376>>01440000
      print( msg', -24, 0 );                                   <<01376>>01442000
      go error;                                                <<01376>>01444000
   end;                                                        <<01376>>01446000
                                                               <<01376>>01448000
   secta := secta + basea;                                              01450000
   if secta < 0d then go adrinv;                                        01452000
                                                               <<01154>>01454000
<< check for invalid characters in 2nd parameter.  >>          <<01154>>01456000
   if np > 1 and (lparms(3).(8:1) = 1 <<alphabetics>> lor      <<04946>>01458000
      lparms(3).(10:1) = 1) <<specials>> then begin            <<04946>>01460000
er2:                                                           <<04692>>01462000
      move msg := "SECOND PARAMETER INVALID.";                 <<01154>>01464000
      print ( msg', -25, 0 );                                  <<01154>>01466000
      go error;                                                <<01154>>01468000
   end;                                                        <<01154>>01470000
                                                               <<01154>>01472000
<< determine number of sectors (default = 1). >>               <<01154>>01474000
   nums := if np > 1 then num(1) else 1;                       <<01154>>01476000
   nums := if nums <= 0 then 1 else nums; << default >>        <<01154>>01478000
<< check the third parameter before formatting output. >>      <<01154>>01480000
<< note:  "BUF" is used both for the output string and >>      <<01154>>01482000
<<        the inputted command.                        >>      <<01154>>01484000
xreg:=lparms(4);                                               <<b0.01>>01488000
assemble(ldb db+0,x);                                          <<b0.01>>01490000
if tos.(8:8) = "A" and np = 3 then                             <<b0.01>>01492000
   begin                                                       <<01154>>01494000
      nonum := true;                                           <<01154>>01496000
      bbuf(7) := ":";                                          <<01154>>01498000
   end                                                         <<01154>>01500000
else                                                           <<b0.01>>01502000
  begin                                                        <<b0.01>>01504000
  nonum :=false;                                               <<b0.01>>01506000
  bbuf(7) := ":";                                              <<01154>>01508000
  if np = 3 then                                               <<b0.01>>01510000
   begin                                                       <<b0.01>>01512000
    move msg :="THIRD PARM INVALID";                           <<b0.01>>01514000
    print (msg',-18,0);                                        <<b0.01>>01516000
    go error;                                                  <<b0.01>>01518000
    end;                                                       <<b0.01>>01520000
   end;                                                        <<b0.01>>01522000
pdump:                                                         <<04692>>01524000
   lio(dummy,0,doubles);                                       <<04692>>01526000
   sectl := secta;                                             <<04692>>01528000
   do begin                                                             01530000
      if not readsector(0) then goto loop;                     <<04692>>01534000
      linep := 0;                                                       01538000
    if nonum then go asciionly;                                <<b0.01>>01540000
      do begin                                                          01542000
         ascii (linep, 8, bbuf(1));                                     01544000
         coln := 0;                                                     01546000
         do begin                                                       01548000
            ascii (dbuf(linep+coln), 8, pbbuf(coln & asl(3)));          01550000
            pbuf (xreg & asr(1) -1) := %20040;                          01552000
            end                                                         01554000
         until (coln := coln+1) >= 8;                                   01556000
         buf(36) := "  ";                                               01558000
         move buf(37) := dbuf(linep),(8);                               01560000
         xreg := 73;                                                    01562000
         while (xreg := xreg+1) < 90 do                                 01564000
          begin                                                         01566000
           tos := bbuf(xreg);                                           01568000
           if s0 < %40 then bbuf(xreg) := %56;                          01570000
            if tos > %176 then bbuf(xreg) := %56;              <<01138>>01572000
          end;                                                          01574000
         len := if short then 35 else 43;                               01576000
         lio (buf(2), len, 0);                                          01578000
         end                                                            01580000
      until (linep := linep+8) >= secsize;                     <<03514>>01582000
      lio (dummy, 0, doubles);                                 <<01.01>>01584000
      if short then                                                     01586000
       begin  <<print ascii chars. below octals>>                       01588000
asciionly:                                                     <<b0.01>>01590000
        xreg := -1;                                                     01592000
        while (xreg := xreg +1) < secsize*2 do                 <<03514>>01594000
         begin  <<replace non-printing chars with ".">>                 01596000
          if dbbuf(xreg) <  %40 then dbbuf(xreg) := ".";                01598000
           if dbbuf(xreg) > %176 then dbbuf(xreg) := ".";      <<01138>>01600000
         end;                                                           01602000
        i := if secsize = 128 then 1 else 0;                   <<03514>>01604000
        if not nonum then lio(numbuf(i),36-i,0);               <<03514>>01606000
        pbuf := "  ";  move pbuf(1) := pbuf,(32);                       01608000
        linep := -32;                                                   01610000
        while (linep := linep + 32) < secsize do               <<03514>>01612000
         begin  <<move chars and print 4 lines>>                        01614000
         ascii(linep & asl(1),8,bbuf(i)); <<byte number>>      <<03514>>01616000
          move pbuf := dbuf(linep),(32);                                01618000
         if i = 0 then buf(3) := ": ";                         <<03514>>01620000
    buf (4) :="  ";                                            <<b0.01>>01622000
         lio(buf(i+1),36-i,0);  <<print it>>                   <<03514>>01624000
         end;                                                           01626000
       lio (dummy, 0, doubles);                                <<01.01>>01628000
       end;                                                             01630000
      secta := secta+1d;                                                01632000
      sectl := sectl+1d;                                       <<04692>>01634000
      nums := nums-1;                                                   01636000
      end                                                               01638000
   until <=;                                                   <<04692>>01640000
   goto loop;                                                           01642000
                                                                        01644000
modify:                                                                 01646000
   tos := 0;                                                            01648000
   tos := num(1)/secsize;  <<sector number>>                   <<03514>>01650000
   assemble(zero,xch,dzro);                                             01652000
   tos:=lparms;                                                         01654000
   tos:=lparms(1).(0:8);                                                01656000
   secta:=dbinary(*,*);                                                 01658000
   secta := secta + basea;                                              01660000
   secta:=secta+tos;                                                    01662000
   sectl := secta;                                             <<04692>>01664000
   if secta < 0d then go adrinv;                                        01666000
   wdpos := num(1) mod secsize;  <<offset>>                    <<03514>>01668000
   tos := if np > 2 then num(2) else 1;                                 01670000
   assemble (test);                                                     01672000
   if = then goto loop;                                                 01674000
   func := 1;   <<write function>>                             <<03514>>01676000
   if secta = 0d and lfn = 0 and sysmgr then                   <<04692>>01678000
   begin                                                       <<03514>>01680000
   move msg := "DO YOU WANT TO MODIFY SECTOR 0 (Y/N) ? ";      <<03514>>01682000
   print (msg',-39,%320);                                      <<03514>>01684000
   len := read(msg',-30);                                      <<04692>>01686000
   if len = 0 or not (msg = "Y" lor msg = "y") then goto loop; <<04946>>01688000
   func := 11;                                                 <<03514>>01690000
   end;                                                        <<03514>>01692000
   numwds := tos;                                                       01694000
   pbbuf(-3) := ":";                                                    01696000
   pbuf(-1) := %20040;                                                  01698000
   pbbuf := "%";                                               <<04692>>01700000
rdsect:                                                                 01702000
   if not readsector(1) then goto loop;                        <<04692>>01704000
reqwd:                                                                  01708000
   ascii (wdpos, 8, bbuf(1));                                           01710000
   ascii (dbuf(wdpos),8,pbbuf(1));                             <<04692>>01712000
   bbuf(17) := ",";                                            <<04692>>01714000
   pos := 17;                                                  <<04692>>01716000
   print (buf(2), 7, stay);                                             01718000
   bbuf(17) := "%";                                            <<04692>>01720000
   len := read (buf (9), -72);                                          01722000
    if > then go exit;                                         <<01013>>01724000
    if < then go readerr;                                      <<01013>>01726000
   if len = 0 then goto skipstore;                             <<01376>>01728000
   if not (moded) then print (buf(9), -len, 0);                         01730000
   if bbuf(18) = "*" then goto skipstore;                               01732000
   if bbuf (xreg) = "/" then goto loop;                                 01734000
   if bbuf(18) = "#" then pos := 19;                           <<04692>>01736000
   if bbuf(18) = "%" then pos := 18;                           <<04692>>01738000
   if bbuf(18) = "'" then                                      <<04692>>01740000
      begin  <<ascii>>                                         <<04692>>01742000
      if len = 4 and bbuf(17+len) <> "'" then goto reqwd;      <<04692>>01744000
      len := if len = 2 or len = 3 and bbuf(17+len) = "'"      <<04692>>01746000
      then 1 else 2;                                           <<04692>>01748000
      move dbbuf(wdpos&lsl(1)) := bbuf(19),(len);              <<04692>>01750000
      end                                                      <<04692>>01752000
      else  <<numeric>>                                        <<04692>>01754000
      begin                                                    <<04692>>01756000
      len := len + 18 - pos;                                   <<04692>>01758000
      tos := binary (bbuf(pos),len);                           <<04692>>01760000
      if <> then goto reqwd;                                   <<04692>>01762000
      dbuf(wdpos) := tos;                                      <<04692>>01764000
      end;                                                     <<04692>>01766000
skipstore:                                                              01770000
   wdpos := wdpos+1;                                                    01772000
   numwds := numwds-1;                                                  01774000
   if (numwds > 0) and (wdpos < secsize) then goto reqwd;      <<03514>>01776000
   if lfn <> 0 and sectl = 0d then setchecksum;                <<04692>>01778000
   dio (func,secta);                                           <<03514>>01780000
   print (wr, wrl, 0);                                                  01782000
   if numwds <= 0 then goto loop;                              <<04692>>01784000
   sectl := sectl+1d;                                          <<04692>>01786000
   secta := secta+1d;                                                   01788000
   wdpos := 0;                                                          01790000
   goto rdsect;                                                         01792000
                                                                        01794000
exit:                                                                   01796000
end.                                                           <<03514>>01798000
