$CONTROL USLINIT,CODE,MAP                                               00010000
<<spook>>                                                      <<00897>>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                                                     00028000
$control main=spook                                                     00030000
<<*************************************>>                               00032000
<<  spook    version c.00.02           >>                      <<02724>>00034000
<<*************************************>>                               00036000
                                                                        00038000
 << note : change version # in message >>                               00040000
                                                               <<04145>>00042000
<<**********************************************************>> <<04145>>00044000
<<                                                          >> <<04145>>00046000
<<                fix  information                          >> <<04145>>00048000
<<                                                          >> <<04145>>00050000
<< for each fix submitted, please describe                  >> <<04145>>00052000
<< the fix and date below.                                  >> <<04145>>00054000
<<**********************************************************>> <<04145>>00056000
                                                               <<04145>>00058000
<<**********************************************************>> <<04145>>00060000
<<  fixed a variety of sr's against spook.  also added a few>> <<04145>>00062000
<< minor enhancements in find and in the way spook handles  >> <<04145>>00064000
<< file error conditions.  also added a lot of comments,    >> <<04145>>00066000
<< please do the same!!                                     >> <<04145>>00068000
<<**********************************************************>> <<04145>>00070000
                                                               <<04145>>00072000
                                                                        00074000
begin                                                                   00076000
   define                                                      <<01.02>>00078000
bad'rename                                                     <<04145>>00080000
=("UNABLE TO RENAME COPY FILE")#,                              <<04145>>00082000
printfile                                                      <<04145>>00084000
= ("FILE                             ALREADY EXISTS")#,        <<04145>>00086000
replacefile                                                    <<04145>>00088000
= ("DO YOU WANT TO REPLACE IT?(Y/N)")#,                        <<04145>>00090000
renamefile                                                     <<b0.01>>00092000
= ("ENTER NEW NAME OR CARRIAGE RETURN (PURGE)")#,              <<b0.01>>00094000
renamed'message                                                <<b0.01>>00096000
= ("COPY FILE HAS BEEN RENAMED")#,                             <<b0.01>>00098000
ptitle = ("SPOOK5 V.UU.FF  (C) HEWLETT-PACKARD CO., 1983")#;   <<x7786>>00100000
equate vuuff'col = 7;  << index into ptitle for v.uu.ff     >> <<x7786>>00102000
$include inclvuf                                               <<04151>>00104000
                                                                        00106000
$set x8=on                                                              00108000
$include inclldt5                                              <<06426>>00110000
$include incllpdt                                              <<06426>>00112000
$include incldct                                               <<06536>>00114000
$include inclxdd5                                              <<x7786>>00116000
$page "SPOOK GLOBAL VARIABLES AND DEFINES"                     <<x7786>>00118000
                                                               <<x7786>>00120000
<<---------------------------------------------------------->> <<x7786>>00122000
<<                                                          >> <<x7786>>00124000
<<           xdd declarations for this module only          >> <<x7786>>00126000
<<                                                          >> <<x7786>>00128000
<<---------------------------------------------------------->> <<x7786>>00130000
define                                                         <<x7786>>00132000
   << refers to both xdds'dfid'in'or'out bit and xdds'dfid' >> <<x7786>>00134000
   << number at the same time                               >> <<x7786>>00136000
   xd'dfid      = 18#,                                         <<x7786>>00138000
   xdds'dfid'all            = xdd'subentry(xd'dfid)#,          <<x7786>>00140000
                                                               <<x7786>>00142000
   << ldev number, or dct index >>                             <<a8449>>00144000
   xd'device = 20#,                                            <<a8449>>00146000
                                                               <<a8449>>00148000
   << refers to purge'extents, restart, forms'on'device,    >> <<x7786>>00150000
   << spaced'out, aborted'job, and number'copies fields at  >> <<x7786>>00152000
   << the same time.                                        >> <<x7786>>00154000
   xd'copy'info = 26#,                                         <<x7786>>00156000
   xdds'copy'info           = xdd'subentry(xd'copy'info)#,     <<x7786>>00158000
                                                               <<x7786>>00160000
   << spook uses the xdds'next'subentry field to store err- >> <<x7786>>00162000
   << ors encountered while processing commands.  it can    >> <<x7786>>00164000
   << get away with this as it's only playing with its own  >> <<x7786>>00166000
   << local copies of the significant xdd subentries in the >> <<x7786>>00168000
   << db- area.  of course, this define must be changed if  >> <<x7786>>00170000
   << xdds'next'subentry moves in the table.                >> <<x7786>>00172000
                                                               <<x7786>>00174000
   xd'errs      = 27#,                                         <<x7786>>00176000
   xdds'show'errs           = xdd'subentry(xd'errs)#,          <<x7786>>00178000
   xdds'spook'err           = xdd'subentry(xd'errs).(0:8)#,    <<x7786>>00180000
   xdds'filesys'err         = xdd'subentry(xd'errs).(8:8)#;    <<x7786>>00182000
                                                               <<x7786>>00184000
<<global declarations>>                                                 00186000
equate                                                                  00188000
   no'file'error = -1,                                         <<04145>>00190000
   cr            = %15,                                        <<04145>>00192000
   exitinstr = %031400;                                        <<x7786>>00194000
define intrins = intrword.(0:10)#,                             <<b0.00>>00196000
      numparms = intrword.(10:6)#;                             <<b0.00>>00198000
define                                                         <<x7786>>00200000
   << for device file id's >>                                  <<x7786>>00202000
   is'odd = (0:1)#,                                            <<x7786>>00204000
   idnum  = (1:15)#,                                           <<x7786>>00206000
                                                               <<x7786>>00208000
   << for showio >>                                            <<x7786>>00210000
   idds = (14:1)#,                                             <<x7786>>00212000
   odds = (15:1)#;                                             <<x7786>>00214000
                                                               <<x7786>>00216000
integer x=x;                                                            00218000
integer s0=s-0;                                                         00220000
logical ls0=s-0;                                                        00222000
integer pointer ps0=s-0;                                                00224000
byte pointer bps0=s-0;                                                  00226000
                                                                        00228000
<<general>>                                                             00230000
integer i,count,cnt;                                           <<x7786>>00232000
logical carryf;                                                         00234000
<< pointer to pcb table >>                                     <<x7786>>00236000
                                                                        00238000
logical pointer pcb = 3;                                       <<x7786>>00240000
                                                               <<x7786>>00242000
<<control y>>                                                           00244000
integer cylabel,cyold,cyaddr;                                           00246000
integer sval,qval,statval;                                              00248000
integer deltap=q-2,qmstat=q-1,deltaq=q-0;                               00250000
logical critflag,controlyflag,                                 <<04145>>00252000
   file'match,   << at least one dfid found on input tape >>   <<i7784>>00254000
   file'found;     << at least one dev file found in command>> <<04145>>00256000
                                                               <<b0.00>>00258000
<< subtasking interface >>                                     <<b0.00>>00260000
integer pin:=0,lastpin:=0,pinoffather:=0;                      <<b0.00>>00262000
double fatherinfo;                                             <<b0.00>>00264000
byte array progname(0:26);                                     <<b0.00>>00266000
byte array lastcreate(0:26);                                   <<b0.00>>00268000
logical subtask:=false;                                        <<b0.00>>00270000
integer subtask'level := 0,sublevel = q-4;                     <<b0.00>>00272000
integer intrword;                                              <<b0.00>>00274000
integer fatherinfo0=fatherinfo;                                <<b0.01>>00276000
integer fatherinfo1=fatherinfo0+1;                             <<b0.01>>00278000
<<                      >>                                     <<b0.00>>00280000
                                                                        00282000
<<user attributes>>                                                     00284000
integer mode,ldev;                                                      00286000
double  cap,lat;                                                        00288000
logical cap1=cap,cap2=cap+1;                                            00290000
array names(0:15);                                                      00292000
byte array bnames(*)=names;                                             00294000
byte array usern(*)=names(0),                                           00296000
           acctn(*)=names(4),                                           00298000
           groupn(*)=names(8),                                          00300000
           homen(*)=names(12);                                          00302000
                                                                        00304000
<<modes>>                                                               00306000
logical fall;                                                           00308000
integer fwidth;                                                         00310000
                                                                        00312000
<<alter>>                                                               00314000
integer pri,copies,class,device;                               <<x7786>>00316000
                                                                        00318000
<<commands and xdd mgmt>>                                               00320000
integer crit,errn,warn,errf;                                   <<x7786>>00322000
integer initxddp;                                                       00324000
integer xddx,xddc,devf,devfc,filef;                                     00326000
logical userf,acctf;                                                    00328000
logical showio,showf,showp;                                             00330000
array snames(0:7);                                                      00332000
byte array susern(*)=snames(0),                                         00334000
           sacctn(*)=snames(4);                                         00336000
                                                                        00338000
<<spool file mgmt>>                                                     00340000
integer filen,xddn,devfn;                                               00342000
integer flinecnt;                                                       00344000
integer oddn;      <<01.02>>                                   <<01.02>>00346000
double sbline;                                                          00348000
double fline,eofline;                                                   00350000
logical purgeflag;  <<used for output>>                       <<00204>> 00352000
double start'recnum; <<beginning record number of file>>     <<<<01549>>00354000
                  <<may be non-zero in extent purged case>>  <<<<01549>>00356000
                                                                        00358000
<<spool file scan/list>>                                                00360000
double frline,toline,linecnt;                                           00362000
double dnum;                                                            00364000
integer dnum0=dnum+0,dnum1=dnum+1;                                      00366000
integer fstring;                                                        00368000
logical fstrall;                                                        00370000
logical eofflag;                                               <<b0.01>>00372000
array fstr(0:40);                                                       00374000
byte array bfstr(*)=fstr;                                               00376000
byte pointer                                                   <<00897>>00378000
     firstparm,                                                <<00897>>00380000
     secondparm,                                               <<00897>>00382000
     thirdparm;                                                <<00897>>00384000
                                                               <<x7786>>00386000
equate bentries = 10, bentry'size=5;                           <<b0.01>>00388000
array blocktable(0:bentries * bentry'size);                    <<b0.01>>00390000
integer pointer blockcp,blockfp;  <<current,first pointer>>    <<b0.01>>00392000
double pointer dblockfp = blockfp;                             <<b0.01>>00394000
double pointer dblockcp=blockcp;                               <<b0.01>>00396000
logical read'dir'flag;                                         <<b0.01>>00398000
double blockno;                                                <<b0.01>>00400000
<<note each blocktable entry is >>                             <<b0.01>>00402000
<<      blockcount      (doubleword)>>                         <<b0.01>>00404000
<<      recordcount     (doubleword)>>                         <<b0.01>>00406000
<<      pagecount       (doubleword)>>                         <<b0.01>>00408000
                                                                        00410000
<<copy spoolfile variables>>                                   <<b0.01>>00412000
integer                                                        <<b0.01>>00414000
        new'filen,                                             <<b0.01>>00416000
        old'pri,                                               <<x7786>>00418000
        new'xddn;                                              <<x7786>>00420000
logical                                                        <<x7786>>00422000
   copy'files'flag,                                            <<x7786>>00424000
   inhibit'fopen,                                              <<x7786>>00426000
   new'spoolfile,                                              <<x7786>>00428000
   file'formsmsg,                                              <<x7786>>00430000
   append;                                                     <<x7786>>00432000
                                                               <<x7786>>00434000
integer array new'bufw(0:128);                                 <<x7786>>00436000
                                                               <<x7786>>00438000
byte array new'buf(*) = new'bufw;                              <<x7786>>00440000
                                                               <<x7786>>00442000
byte array                                                     <<x7786>>00444000
   new'filename(0:28),                                         <<x7786>>00446000
   old'filename(0:28);                                         <<x7786>>00448000
                                                               <<x7786>>00450000
integer pointer new'xddnp = new'xddn;                          <<x7786>>00452000
                                                               <<x7786>>00454000
equate                                                         <<x7786>>00456000
   copy = 2;                                                   <<x7786>>00458000
                      <<end of copy variables>>                <<b0.01>>00460000
<<tape file management>>                                                00462000
integer filet,tcount,reel;                                              00464000
logical lastreel,eotmark,fileend;                                       00466000
double time;                                                            00468000
logical date,time1=time+0,time2=time+1;                                 00470000
                                                                        00472000
                                                                        00474000
<<command buffer>>                                                      00476000
equate command'length = 40;                                    <<b0.00>>00478000
array cbuf(0:command'length);                                  <<b0.00>>00480000
byte array bcbuf(*)=cbuf;                                               00482000
byte pointer bp;                                                        00484000
                                                                        00486000
<<xdd buffer>>                                                          00488000
array devfs(0:63);                                                      00490000
array xddbuf(0:size'of'xdd'subentry-1);                        <<x7786>>00492000
byte array bxddbuf(*)=xddbuf;                                  <<x7786>>00494000
                                                                        00496000
<<list output buffer>>                                                  00498000
array obuf(0:127);                                                      00500000
byte array bobuf(*)=obuf;                                               00502000
                                                                        00504000
<<spoolfile buffers>>                                                   00506000
array sbuf(0:1024);                                                     00508000
byte array bsbuf(*)=sbuf;                                               00510000
pointer sp;                                                             00512000
                                                                        00514000
<<tape label buffer>>                                                   00516000
array tbuf(0:40);                                                       00518000
byte array btbuf(*)=tbuf;                                               00520000
define  << label record >>                                     <<x7786>>00522000
   l0spookid = tbuf(0)#,                                       <<x7786>>00524000
   l0eof     = tbuf(21)#,                                      <<x7786>>00526000
   l0lastreel= tbuf(22)#,                                      <<x7786>>00528000
   l0reel    = tbuf(23)#,                                      <<x7786>>00530000
   l0date    = tbuf(24)#,                                      <<x7786>>00532000
   l0time1   = tbuf(25)#,                                      <<x7786>>00534000
   l0time2   = tbuf(26)#,                                      <<x7786>>00536000
   l0mpe5    = tbuf(30)#;                                      <<x7786>>00538000
logical                                                        <<x7786>>00540000
   mpe5tape;                                                   <<x7786>>00542000
                                                                        00544000
<<tape reply buffer>>                                                   00546000
array rbuf(0:1);                                                        00548000
byte array brbuf(*)=rbuf;                                               00550000
                                                                        00552000
<< spook tape directory >>                                     <<06426>>00554000
equate                                                         <<06426>>00556000
   fdir'entrysize = 12,                                        <<x7786>>00558000
   fdir'recsize   = 1020,                                      <<x7786>>00560000
   ldev'entrysize = 3;                                         <<06426>>00562000
   array newldevs(0:700);                                      <<x7786>>00564000
                                                                        00566000
<<commands>>                                                            00568000
equate cnum = 18;                                              <<b0.01>>00570000
equate csize=6;                                                         00572000
byte array command'list(0:cnum*csize-1):=                      <<b0.00>>00574000
      "DEBUG EXIT  XPLAINSHOW  ",                                       00576000
      "TEXT  LIST  FIND  MODE  ",                                       00578000
      "ALTER PURGE INPUT OUTPUT",                              <<b0.00>>00580000
      "HELP  RUN   KILL  QUIT  ",                              <<b0.01>>00582000
      "COPY  APPEND";                                          <<b0.01>>00584000
                                                                        00586000
<<modes>>                                                               00588000
equate mnum=2;                                                          00590000
equate msize=8;                                                         00592000
byte array mmode(0:15):=                                                00594000
      "WIDTH   CONTROLS";                                               00596000
                                                                        00598000
<<alter>>                                                               00600000
equate anum=3;                                                          00602000
equate asize=6;                                                         00604000
byte array aalter(0:anum * asize - 1):=                        <<b0.00>>00606000
      "PRI   COPIESDEV   ";                                             00608000
                                                                        00610000
<<states>>                                                              00612000
byte array states(0:23):=                                               00614000
      "ACTIVEREADY OPEN  LOCKED";                                       00616000
                                                                        00618000
<<headings>>                                                            00620000
                                                               <<01.02>>00622000
                                                               <<01.02>>00624000
array tapeid(0:13):=                                                    00626000
      "SPOOLFILETAPE LABEL-HP/3000.";                                   00628000
array tapempev(0:1):=                                          <<x7786>>00630000
      "MPEV";                                                  <<x7786>>00632000
array mreel(0:16):=                                                     00634000
      " CHANGE REELS ON LDEV     ? (Y/N) ";                             00636000
array ereel(0:17):=                                                     00638000
      " INCORRECT REEL - TRY AGAIN ? (Y/N) ";                           00640000
array abortp(0:12):=                                           <<x7786>>00642000
      "PROGRAM ABORTED BY SYSTEM.";                            <<x7786>>00644000
array mshow(0:28):=                                                     00646000
      "#FILE   #JOB    FNAME    STATE  DEV/CL   PR COP RFN OWNER ";     00648000
array mshows(0:18):=                                                    00650000
      "#FILE   #JOB    FNAME    STATE  OWNER ";                         00652000
array min(0:22):=                                                       00654000
      "#FILE   ===>  #FILE   #JOB    DEV/CL    OWNER ";                 00656000
array mout(0:21):=                                                      00658000
      "#FILE   #JOB    DEV/CL   SECTORS      OWNER ";                   00660000
array mshwx(0:28):=                                                     00662000
      "#FILE   LDEV    LABEL      SECTORS       LINES      TIME  ";     00664000
                                                                        00666000
switch swcom:=                                                          00668000
      dbugl,                                                            00670000
      exitl,                                                            00672000
      xplal,                                                            00674000
      showl,                                                            00676000
      textl,                                                            00678000
      listl,                                                            00680000
      findl,                                                            00682000
      model,                                                            00684000
      altel,                                                            00686000
      purgl,                                                            00688000
      inl  ,                                                            00690000
      outl ,                                                   <<b0.00>>00692000
      helpl,                                                   <<b0.00>>00694000
      runl ,                                                   <<b0.00>>00696000
      killl,                                                   <<b0.00>>00698000
      quitl,                                                   <<b0.01>>00700000
      copyl,                                                   <<b0.01>>00702000
      appendl;                                                 <<b0.01>>00704000
                                                                        00706000
define def'movefromdseg=                                       <<01726>>00708000
movefromdseg(target,dstn,offset,count);                        <<01726>>00710000
value target,dstn,offset,count;                                <<01726>>00712000
logical target,dstn,offset,count;                              <<01726>>00714000
begin                                                          <<01726>>00716000
   x:=tos;     <<save return addr>>                            <<01726>>00718000
   assemble(mfds 0);                                           <<01726>>00720000
   tos:=x;     <<restore return addr>>                         <<01726>>00722000
end#,                                                          <<01726>>00724000
                                                               <<01726>>00726000
       def'movetodseg=                                         <<01726>>00728000
movetodseg(dstn,offset,source,count);                          <<01726>>00730000
value dstn,offset,source,count;                                <<01726>>00732000
logical dstn,offset,source,count;                              <<01726>>00734000
begin                                                          <<01726>>00736000
   x:=tos;                                                     <<01726>>00738000
   assemble(mtds 0);                                           <<01726>>00740000
   tos:=x;     <<restore return addr>>                         <<01726>>00742000
end#;                                                          <<01726>>00744000
                                                               <<01726>>00746000
$page                                                          <<04145>>00748000
                                                               <<04145>>00750000
<<**********************************************************>> <<04145>>00752000
<<    explanation of important global variables             >> <<04145>>00754000
<<                                                          >> <<04145>>00756000
<<  devf - device file id, if the 1st. bit is on, then it is>> <<04145>>00758000
<<         an output file, off and input file.  id number   >> <<04145>>00760000
<<         is the integer portion.                          >> <<04145>>00762000
<<  devfn- device file id of currently texted spoolfile.    >> <<06426>>00764000
<<  filef- the file number (aft entry number) of an open    >> <<06426>>00766000
<<         spool file.                                      >> <<06426>>00768000
<<  filen- currently texted file number.                    >> <<06426>>00770000
<<  devfs- logical array containing all the device file id's>> <<04145>>00772000
<<         to be used for the current command.              >> <<04145>>00774000
<<  devfc- number of device file id's in the array devfs for>> <<04145>>00776000
<<         the current command.                             >> <<04145>>00778000
<< showio- a logical to show which types of device id's we  >> <<06426>>00780000
<<         have encountered .  if bit 15=on output and/or   >> <<04145>>00782000
<<                                    14=on input           >> <<04145>>00784000
<<  showf- flag signifying to show all the file information,>> <<04145>>00786000
<<         eg. show pri, cop, ldev, etc.                    >> <<04145>>00788000
<<  xddc - number of xdd subentries currently in our stack  >> <<06426>>00790000
<<         (db- area).                                      >> <<06426>>00792000
<<**********************************************************>> <<04145>>00794000
                                                               <<04145>>00796000
<<**********************************************************>> <<04145>>00798000
                                                               <<04145>>00800000
$page "EXTERNAL PROCEDURES"                                    <<x7786>>00802000
                                                                        00804000
procedure controlyproc;                                        <<b0.00>>00806000
   option forward;                                             <<b0.00>>00808000
procedure debug;                                                        00810000
   option external;                                                     00812000
integer procedure setcritical;                                          00814000
   option external;                                                     00816000
procedure resetcritical(c);                                             00818000
   value   c;                                                           00820000
   integer c;                                                           00822000
   option external;                                                     00824000
integer procedure getsir(s);                                            00826000
   value   s;                                                           00828000
   integer s;                                                           00830000
   option external;                                                     00832000
procedure relsir(s,r);                                                  00834000
   value   s,r;                                                         00836000
   integer s,r;                                                         00838000
   option external;                                                     00840000
integer procedure exchangedb(d);                                        00842000
   value   d;                                                           00844000
   integer d;                                                           00846000
   option external;                                                     00848000
logical procedure calendar;                                             00850000
   option external;                                                     00852000
double procedure clock;                                                 00854000
   option external;                                                     00856000
integer procedure getdevinfo(d,i);                                      00858000
   integer array i;                                                     00860000
   byte array d;                                                        00862000
   option external;                                                     00864000
logical procedure spooleddev(d);                                        00866000
   value   d;                                                           00868000
   integer d;                                                           00870000
   option external;                                                     00872000
procedure srooster(d);                                                  00874000
   value   d;                                                           00876000
   integer d;                                                           00878000
   option external;                                                     00880000
procedure srelinkodd(o,d);                                              00882000
   value   o,d;                                                         00884000
   integer d;                                                           00886000
   integer pointer o;                                                   00888000
   option external;                                                     00890000
integer procedure sputxdd(odd,dev,sube,xddsubp);                        00892000
   value   odd,dev;                                                     00894000
   logical odd;                                                         00896000
   integer dev;                                                         00898000
   integer array sube;                                                  00900000
   integer pointer xddsubp;                                             00902000
   option external;                                                     00904000
procedure sremovexdd(xddsubp);                                          00906000
   value   xddsubp;                                                     00908000
   integer pointer xddsubp;                                             00910000
   option external;                                                     00912000
integer procedure fsopen(fd,fo,ao,xd,dv,fm,ul,bf,nb,                    00914000
                           fs,ne,ia,fc);                                00916000
   value   fo,ao,xd,ul,bf,nb,fs,ne,ia,fc;                               00918000
   integer xd,ul,bf,nb,ne,ia,fc;                                        00920000
   logical fo,ao;                                                       00922000
   double  fs;                                                          00924000
   byte array fd,dv,fm;                                                 00926000
   option external,variable;                                            00928000
procedure fsclose(fn,d,s);                                              00930000
   value   fn,d,s;                                                      00932000
   integer fn,d,s;                                                      00934000
   option external;                                                     00936000
procedure erroron;                                             <<b0.00>>00938000
   option external;                                            <<b0.00>>00940000
procedure errorexit(intrinexit,errword,param);                 <<b0.00>>00942000
   value intrinexit,errword,param;                             <<b0.00>>00944000
   logical intrinexit,errword,param;                           <<b0.00>>00946000
   option external;                                            <<b0.00>>00948000
integer procedure genmsg(setno,msgno,m,p1,p2,p3,p4,p5,         <<b0.00>>00950000
         d,r,o,dst,c);                                         <<b0.00>>00952000
   value setno,msgno,m,p1,p2,p3,p4,p5,d,r,o,dst,c;             <<b0.00>>00954000
   integer setno,msgno,d,dst;                                  <<b0.00>>00956000
   logical m,p1,p2,p3,p4,p5,r,o,c;                             <<b0.00>>00958000
   option external,variable;                                   <<b0.00>>00960000
logical procedure new'file'close(old);                         <<b0.01>>00962000
   value old;                                                  <<b0.01>>00964000
   logical old;                                                <<b0.01>>00966000
   option forward;                                             <<b0.01>>00968000
                                                               <<b0.01>>00970000
logical procedure sfindodd(dfid,xddep);                        <<b0.01>>00972000
   value dfid;                                                 <<b0.01>>00974000
   integer xddep;                                              <<b0.01>>00976000
   integer dfid;                                               <<b0.01>>00978000
   option external;                                            <<b0.01>>00980000
                                                               <<b0.01>>00982000
integer procedure lun (vtab'index, mvtab'index);               <<x7786>>00984000
   value vtab'index, mvtab'index;                              <<x7786>>00986000
   integer vtab'index, mvtab'index;                            <<x7786>>00988000
   option privileged, uncallable, external;                    <<x7786>>00990000
                                                               <<b0.00>>00992000
logical procedure verify'block'structure(buffer,index,numrecs);<<01726>>00994000
                                                              <<sp.mp4>>00996000
   logical array buffer;                                      <<sp.mp4>>00998000
   integer index,numrecs;                                     <<sp.mp4>>01000000
                                                              <<sp.mp4>>01002000
   option forward;                                             <<01726>>01004000
                                                               <<01726>>01006000
   procedure read'record(filenum, recordnum, buffer, recp,     <<01726>>01008000
        xddp,blocknum, errnum);                                <<01726>>01010000
                                                               <<01726>>01012000
      value recordnum, filenum, xddp;                          <<01726>>01014000
      double recordnum, blocknum;                              <<01726>>01016000
      integer pointer recp;                                    <<01726>>01018000
      logical xddp;                                            <<01726>>01020000
      integer errnum, filenum;                                 <<01726>>01022000
      logical array buffer;                                    <<01726>>01024000
                                                               <<01726>>01026000
      option forward;                                          <<01726>>01028000
                                                                        01030000
intrinsic fopen,fclose,fread,fwrite,fcontrol,fgetinfo,fcheck;           01032000
intrinsic who,dlsize,read,print,ascii,binary,printopreply;              01034000
intrinsic dascii,dbinary;                                               01036000
intrinsic xcontrap,resetcontrol,ferrmsg,ffileinfo,terminate;   <<04145>>01038000
intrinsic aritrap;                                             <<01.02>>01040000
                                                                        01042000
intrinsic create,father,kill,activate,suspend; <<subtasking>>  <<b0.00>>01044000
intrinsic getprocid,getprocinfo; <<subtasking>>                <<b0.01>>01046000
intrinsic command;                                             <<b0.00>>01048000
intrinsic freaddir;                                            <<b0.01>>01050000
intrinsic fwritedir;                                           <<b0.01>>01052000
intrinsic frename;                                             <<b0.01>>01054000
intrinsic freadlabel, fwritelabel;                             <<01886>>01056000
$page "ERROR MESSAGES"                                         <<x7786>>01058000
$control segment=spook1                                                 01060000
                                                                        01062000
procedure errform(err,ferr,ix);                                         01064000
   value   err,ferr;                                                    01066000
   integer err,ferr,ix;                                                 01068000
   begin                                                                01070000
   integer ct,iz,beg'msg;                                      <<04145>>01072000
   logical f;                                                           01074000
   integer array messag(*) = pb :=                             <<04151>>01076000
       1,12,"NOT INTERACTIVE SESSION ",                                 01078000
       2, 6,"END OF FILE",                                              01080000
       3, 7,"TOO MANY FILES",                                           01082000
       4,12,"INSUFFICIENT CAPABILITY ",                                 01084000
       5,22,"NO FILES FOUND UNDER USER.ACCOUNT SPECIFIED ",    <<04145>>01086000
      19,13,"IMPOSSIBLE INTERNAL ERROR ",                               01088000
      20,10,"INVALID COMMAND NAME",                                     01090000
      21,10,"COMMAND NAME TOO BIG",                                     01092000
      22, 8,"PROMPT I/O ERROR",                                         01094000
      23, 8,"INPUT I/O ERROR ",                                         01096000
      24,10,"UNABLE TO CLOSE FILE",                                     01098000
      25,10,"UNABLE TO PURGE FILE",                                     01100000
      26, 8,"FILE READ ERROR ",                                         01102000
      27, 8,"FILE WRITE ERROR",                                         01104000
      28, 8,"FILE NOT 'READY'",                                         01106000
      29,10,"UNABLE TO OPEN FILE ",                                     01108000
      30,11,"INPUT FILE NOT ALLOWED",                                   01110000
      31, 7,"FILE NOT FOUND",                                           01112000
      32, 8,"INVALID FILE ID ",                                         01114000
      33,10,"UNEXPECTED CHARACTER",                                     01116000
      34, 9,"USER NAME TOO BIG ",                                       01118000
      35,10,"USER NOT ACCESSIBLE ",                                     01120000
      36,10,"ACCOUNT NAME TOO BIG",                                     01122000
      37,11,"ACCOUNT NOT ACCESSIBLE",                                   01124000
      38,11,"INVALID LINE MNEMONIC ",                                   01126000
      39,10,"INVALID LINE NUMBER ",                                     01128000
      40, 9,"INVALID LINE COUNT",                                       01130000
      41, 9,"INVALID LINE RANGE",                                       01132000
      42,16,"NON TERMINATED CHARACTER STRING ",                         01134000
      43,10,"INVALID OPTION NAME ",                                     01136000
      44,12,"INVALID OPTION SEPARATOR",                                 01138000
      45,12,"INVALID OPTION PARAMETER",                                 01140000
      46, 6,"NO TEXT FILE",                                             01142000
      47,11,"FILE NOT 'READY/OPEN' ",                                   01144000
      48,11,"TEXT FILE NOT ALLOWED ",                                   01146000
      49, 9,"MISSING SEMI-COLON",                                       01148000
      50,12,"UNABLE TO OPEN TAPE FILE",                                 01150000
      51,13,"UNABLE TO CLOSE TAPE FILE ",                               01152000
      52, 9,"INVALID TAPE FILE ",                                       01154000
      53,10,"INVALID TAPE FORMAT ",                                     01156000
      54,10,"TAPE FILE READ ERROR",                                     01158000
      55,11,"TAPE FILE WRITE ERROR ",                                   01160000
      56,12,"USER.ACCOUNT NOT ALLOWED",                                 01162000
      57,10,"NO EQUIVALENT DEVICE",                                     01164000
      58,10,"NO EQUIVALENT CLASS ",                                     01166000
      59,12,"NO ROOM IN DEVICE TABLE ",                                 01168000
      60, 8,"MULTI REEL ABORT",                                         01170000
      61,19,"INVALID LENGTH OF RECORD IN TEXT FILE",           <<b0.00>>01172000
      70,12,"FILE IS NOT PROGRAM FILE",                        <<b0.00>>01174000
      71,14,"NO SON PROCESS TO BE DELETED",                    <<b0.00>>01176000
      72,13,"MISSING PROGRAM FILE NAME ",                      <<b0.00>>01178000
      73,13,"UNABLE TO CLOSE COPY FILE",                       <<b0.01>>01180000
      74,13,"UNABLE TO OPEN COPY FILE ",                       <<b0.01>>01182000
      75,11,"SPOOLFILE CREATE ERROR",                          <<b0.01>>01184000
      76,13,"UNABLE TO RENAME COPY FILE",                      <<b0.01>>01186000
   77,13,"DS COPY NOT YET AVAILABLE",                                   01188000
      78,16,"LINE NUMBER IS IN PURGED EXTENT",               <<<<01549>>01190000
      79,9,"INVALID COPY FILE",                                <<04145>>01192000
      80,14,"MISSING DFID OR USER.ACCOUNT",                    <<04145>>01194000
       0, 0;                                                            01196000
   << >>                                                                01198000
   if (f := (err < 0)) then err := -err;                                01200000
   if err < 16 then                                                     01202000
      begin move bobuf(ix) := "*WARNING="; ix:=ix+9; end                01204000
   else                                                                 01206000
      begin move bobuf(ix) := "*ERROR="; ix:=ix+7; end;                 01208000
   ct := ascii(err,10,bobuf(ix));                                       01210000
   ix := ix+ct;                                                         01212000
   if f and err >= 16 then                                              01214000
      begin                                                             01216000
      move bobuf(ix) := " BYTE=";                                       01218000
      ix := ix+6;                                                       01220000
      ct := ascii(@bp-@bcbuf(2),10,bobuf(ix));                          01222000
      ix := ix+ct;                                                      01224000
      end;                                                              01226000
   bobuf(ix) := "*";                                                    01228000
   ix := (ix+3)&asr(1);                                                 01230000
   iz := 0;                                                             01232000
   while messag(iz)<>0 and messag(iz)<>err do                           01234000
      iz := iz+2+messag(iz+1);                                          01236000
   move obuf(ix) := messag(iz+2),(messag(iz+1));                        01238000
   beg'msg:=ix;                                                <<04145>>01240000
   ix := ix+messag(iz+1);                                               01242000
   ix := ix&asl(1);                                                     01244000
   print(obuf,-ix,0);                                          <<04145>>01246000
   if ferr <> no'file'error then                               <<04145>>01248000
      begin                                                             01250000
        move bobuf(0):=" ";                                    <<04145>>01252000
        move bobuf(1):=bobuf(0),(254);                         <<04145>>01254000
        ferrmsg(ferr,obuf(0),ct);                              <<04329>>01256000
        ix:=ct ;                                               <<04329>>01258000
        print(obuf,-ix,0);                                     <<04145>>01260000
      end;                                                              01262000
   end;                                                                 01264000
                                                                        01266000
$control segment=spook1                                                 01268000
                                                                        01270000
procedure errmsg(err,ferr);                                             01272000
   value   err,ferr;                                                    01274000
   integer err,ferr;                                                    01276000
   begin                                                                01278000
   integer ix;                                                          01280000
   << >>                                                                01282000
   critflag := false; if controlyflag then controlyproc;       <<b0.00>>01284000
   obuf := "  ";                                                        01286000
   move obuf(1) := obuf,(127);                                          01288000
   ix := 0;                                                             01290000
   errform(-err,ferr,ix);                                               01292000
   critflag := true;                                           <<b0.00>>01294000
   end;                                                                 01296000
$page "EXPLAIN TEXT"                                           <<x7786>>01298000
$control segment=spook1                                                 01300000
                                                                        01302000
procedure explain;                                                      01304000
   begin                                                                01306000
   integer ix,iz;                                                       01308000
   logical f;                                                           01310000
   integer array xmessag(*)=pb:=                               <<04151>>01312000
    %400, 3,"DEBUG ",                                                   01314000
       1,21,"EXIT  <<TERMINATE IF NOT A SON PROCESS>> ",       <<b0.00>>01316000
       2, 3,"XPLAIN",                                                   01318000
       3,23,"SHOW   [ USER [ .ACCOUNT ] ] [ ; [@] [I] [O] ]",           01320000
       3,21,"SHOW   DEVICEFILEID [ , DEVICEFILEID ]....",               01322000
       4,10,"TEXT   DEVICEFILEID ",                                     01324000
       5, 8,"LIST   [ RANGE ]",                                         01326000
       6,20,"FIND   [ @ ] [ ""STRING"" ] [ , FRANGE ] ",       <<04145>>01328000
       7,16,"MODE   [ OPTION [ , OPTION ]...]",                         01330000
       7,16,"       OPTION = WIDTH / CONTROLS",                         01332000
     %10,28,"ALTER {DFID [,DFID[,...]]} [ ; OPTION [ , OPTION ]....]",  01334000
     %10,28,"ALTER {USER [.ACCOUNT]   } [ ; OPTION [ , OPTION ]....]",  01336000
     %10,17,"       OPTION = PRI / COPIES / DEV",                       01338000
     %11,21,"PURGE  DEVICEFILEID [ , DEVICEFILEID ]....",               01340000
   %1012,20,"INPUT  [ USER [ .ACCOUNT ] ] ; TAPEFILE ",                 01342000
   %1012,26,"INPUT  DEVICEFILEID [ , DEVICEFILEID ].. ; TAPEFILE ",     01344000
%1013,25,"OUTPUT [ USER [ .ACCOUNT ] ] ; TAPEFILE [; PURGE] ",<<00204>> 01346000
%1013,28,"OUTPUT DEVFILEID [, DEVFILEID ] .. ; TAPEFILE [; PURGE] ",    01348000
     %14, 2,"HELP",                                            <<b0.00>>01350000
     %15,23,"RUN    PROGRAMFILENAME [ .GROUP [ .ACCOUNT] ]",   <<b0.00>>01352000
     %16,12,"KILL  << SON PROCESS >>",                         <<b0.00>>01354000
     %17,11,"QUIT  << TERMINATE >> ",                          <<b0.00>>01356000
     %20,13,"COPY   [RANGE] [,FILENAME]",                      <<b0.01>>01358000
     %20,28,"COPY   [DFID [,DFID [,...]] ;] [RANGE [,FILENAME]]     ",  01360000
     %20,24,"COPY   [USER [.ACCOUNT] ;]  [RANGE [,FILENAME]]",          01362000
     %21,13,"APPEND [RANGE [,FILENAME]]",                               01364000
     %20,28,"APPEND [DFID [,DFID [,...]] ;] [RANGE [,FILENAME]]     ",  01366000
     %20,24,"APPEND [USER [.ACCOUNT] ;]  [RANGE [,FILENAME]]",          01368000
     %21, 8,"       [END  ]  ",                               <<00204>> 01370000
     %22,0;                                                    <<b0.01>>01372000
   << >>                                                                01374000
   critflag := false; if controlyflag then controlyproc;       <<b0.00>>01376000
   obuf := "  ";                                                        01378000
   move obuf(1) := obuf,(127);                                          01380000
   iz := 0;                                                             01382000
   while (ix := xmessag(iz+1)) <> 0 do                                  01384000
      begin                                                             01386000
      f := true;                                                        01388000
      tos := xmessag(iz).(0:8);                                         01390000
      assemble(tbc 15);                                                 01392000
      if <> then if not cap2.(9:1) then f := false;                     01394000
      assemble(tbc 14);                                                 01396000
      if <> then if not cap1.(0:1) then f := false;                     01398000
      if f then                                                         01400000
         begin                                                          01402000
         move obuf := xmessag(iz+2),(ix);                               01404000
         print(obuf,ix,0);                                              01406000
         end;                                                           01408000
      iz := iz+2+ix;                                                    01410000
      end;                                                              01412000
   critflag := true;                                           <<b0.00>>01414000
   end;                                                                 01416000
$page "* * * LOCKXDD * * *"                                    <<x7786>>01418000
$control segment=spook2                                                 01420000
                                                                        01422000
procedure lockxdd(xddi);                                                01424000
   value   xddi;                                                        01426000
   integer xddi;                                                        01428000
   begin                                                                01430000
   logical pointer xdd'subentry;                               <<x7786>>01432000
   << >>                                                                01434000
   @xdd'subentry := xddi.idnum;                                <<x7786>>01436000
   exchangedb(if xddi<0 then odd'dst else idd'dst);            <<x7786>>01438000
   xdds'spool'state := xdds'locked;                            <<x7786>>01440000
   exchangedb(0);                                                       01442000
   end;                                                                 01444000
$page "* * * COPYXDD * * *"                                    <<x7801>>01446000
                                                               <<x7801>>01448000
<<**********************************************************>> <<04145>>01450000
<< copyxdd is sent a file id by movefromxdd,alterxdd and    >> <<04145>>01452000
<< spoolopen to copy a xdd subentry from either the odd or  >> <<x7801>>01454000
<< idd into xddbuf.  if the sign bit of fid is on, we search>> <<x7801>>01456000
<< the odd; if it is off, the idd.  if xddx is non-zero     >> <<x7801>>01458000
<< (pointing to the last subentry accessed), the search     >> <<x7801>>01460000
<< starts at the subentry after xddx in the class or device >> <<x7801>>01462000
<< chain.  if xddx is 0 we search from the beginning, start->> <<x7801>>01464000
<< ing with the class chain pointed to by the first head    >> <<x7801>>01466000
<< entry, and so on with the device chains through the rest >> <<x7801>>01468000
<< of the head entries.                                     >> <<x7801>>01470000
<<**********************************************************>> <<04145>>01472000
                                                               <<04145>>01474000
$control segment=spook2                                                 01476000
                                                                        01478000
logical procedure copyxdd(fid);                                         01480000
   value   fid;                                                         01482000
   integer fid;                                                         01484000
   begin                                                                01486000
   logical pointer                                             <<x7786>>01488000
      xdd,                                                     <<x7786>>01490000
      xdd'head,                                                <<x7786>>01492000
      last'head,                                               <<x7786>>01494000
      xdd'subentry,                                            <<x7786>>01496000
      user'acct;                                               <<x7786>>01498000
   integer                                                     <<x7786>>01500000
      n, m,                                                    <<x7786>>01502000
      index;                                                   <<x7786>>01504000
   logical                                                     <<x7786>>01506000
      uf, af,                                                  <<x7786>>01508000
      match;                                                   <<x7786>>01510000
   array name(0:7)=q;                                                   01512000
   << >>                                                                01514000
subroutine def'movefromdseg;                                   <<x7786>>01516000
<< move global variables to q-relative before exchanging db >> <<x7786>>01518000
   uf := userf;                                                         01520000
   af := acctf;                                                         01522000
   move name := snames,(8);                                             01524000
   index := xddx;                                                       01526000
   @xdd := 0;                                                  <<x7786>>01528000
   exchangedb(if fid.is'odd=1 then odd'dst else idd'dst);      <<x7786>>01530000
   if index = 0 then    << start at beginning >>               <<x7786>>01532000
   begin                                                       <<x7786>>01534000
      @xdd'head := size'of'xdd0; << addr of first head entry >><<x7786>>01536000
      @xdd'subentry := xddh'first'subentry;                    <<x7786>>01538000
   end                                                         <<x7786>>01540000
   else       << take up where we left off >>                  <<x7786>>01542000
   begin                                                       <<x7786>>01544000
      @xdd'subentry := index;  << last subentry accessed >>    <<x7786>>01546000
      @xdd'head := xdds'head'index * 4;                        <<x7786>>01548000
      @xdd'subentry := xdds'next'subentry;                     <<x7786>>01550000
   end;                                                        <<x7786>>01552000
                                                               <<04145>>01554000
   <<*******************************************************>> <<04145>>01556000
   << main loop to search through the xdd until a qualified >> <<x7801>>01558000
   << subentry is found, or we run out.  if a user.account  >> <<x7801>>01560000
   << was entered (userf & acctf are true), compare words 2 >> <<x7801>>01562000
   << to 9 with that of name. otherwise, check if the file  >> <<x7801>>01564000
   << id (if non-null) sent matches that in word 18 of the  >> <<x7801>>01566000
   << xdd subentry.                                         >> <<x7801>>01568000
   <<*******************************************************>> <<04145>>01570000
                                                               <<04145>>01572000
   @last'head := xdd0'subentry'area - size'of'xdd'head;        <<x7786>>01574000
   while @xdd'head <= @last'head do                            <<x7786>>01576000
   begin                                                       <<x7786>>01578000
      while @xdd'subentry <> xdds'end'of'chain do              <<x7786>>01580000
      begin                                                    <<x7786>>01582000
        if (xdds'device<>0) and (xdds'spoofle'vt'index<>0) then<<x7786>>01584000
         begin                                                 <<x7786>>01586000
            n := if uf then -1 else 3;                         <<x7786>>01588000
            m := if af then 8 else 4;                          <<x7786>>01590000
            @user'acct := @xdds'user'name;                     <<x7786>>01592000
            match := true;                                     <<x7786>>01594000
            while ((n := n+1) < m) and match do                <<x7786>>01596000
               if name(n) <> user'acct(n) then match := false; <<x7786>>01598000
            if match then                                      <<x7786>>01600000
               if fid.idnum = 0 then goto found                <<x7786>>01602000
               else                                            <<x7786>>01604000
                  if logical(fid) = xdds'dfid'all then         <<x7786>>01606000
                     goto found;                               <<x7786>>01608000
         end;                                                  <<x7786>>01610000
         @xdd'subentry := xdds'next'subentry;                  <<x7786>>01612000
      end;                                                     <<x7786>>01614000
      @xdd'head := @xdd'head + size'of'xdd'head;               <<x7786>>01616000
      @xdd'subentry := xddh'first'subentry;                    <<x7786>>01618000
   end;                                                        <<x7786>>01620000
                                                               <<x7786>>01622000
   << xdd subentry not found >>                                <<x7786>>01624000
   exchangedb(0);                                              <<x7786>>01626000
   xddx := 0;                                                  <<x7786>>01628000
   goto quickout;                                              <<x7786>>01630000
                                                               <<04145>>01632000
<<**********************************************************>> <<04145>>01634000
<< move the entry from the data segment (odd or idd segment)>> <<04145>>01636000
<< to the users stack via mfds.                             >> <<04145>>01638000
<<**********************************************************>> <<04145>>01640000
                                                               <<04145>>01642000
found:                                                         <<x7786>>01644000
   exchangedb(0);                                              <<x7786>>01646000
   << offset from beginning of xdd >>                          <<x7786>>01648000
   xddx := @xdd'subentry;                                      <<x7786>>01650000
   movefromdseg(@xddbuf,                                       <<x7786>>01652000
                 if fid.is'odd=1 then odd'dst else idd'dst,    <<x7786>>01654000
                 xddx, size'of'xdd'subentry);                  <<x7786>>01656000
   copyxdd := true;                                            <<x7786>>01658000
                                                               <<x7786>>01660000
                                                               <<x7786>>01662000
quickout:                                                      <<x7786>>01664000
   end;                                                                 01666000
$page "* * * SHOWERRORS * * *"                                 <<x7786>>01668000
<<**********************************************************>> <<04145>>01670000
<<  showerrors outputs any errors encountered while access- >> <<04145>>01672000
<< ing or attempting to access an xdd entry.                >> <<04145>>01674000
<<**********************************************************>> <<04145>>01676000
                                                               <<04145>>01678000
                                                                        01680000
$control segment=spook2                                                 01682000
                                                                        01684000
procedure showerrors(show);                                    <<04145>>01686000
  value show;logical show;                                     <<04145>>01688000
   begin                                                                01690000
   integer c,ix,df,errn,errf;                                  <<04145>>01692000
   logical pointer xdd'subentry;                               <<x7786>>01694000
                                                               <<04145>>01696000
   <<*******************************************************>> <<04145>>01698000
   <<  output devfid and error number via errform.          >> <<04145>>01700000
   <<*******************************************************>> <<04145>>01702000
                                                               <<04145>>01704000
   subroutine showit;                                                   01706000
      begin                                                             01708000
      ix := 0;                                                          01710000
      obuf := "  ";                                                     01712000
      move obuf(1) := obuf,(127);                                       01714000
      bobuf(ix) := "#";                                                 01716000
      bobuf(ix+1) := if df<0 then "O" else "I";                         01718000
      ascii(df.idnum,10,bobuf(ix+2));                          <<x7786>>01720000
      ix := ix+8;                                                       01722000
      if errf = 0 or errf = 255 then errf := no'file'error;    <<04151>>01724000
      errform(errn,errf,ix);                                   <<04145>>01726000
      end;                                                              01728000
   << >>                                                                01730000
   critflag := false; if controlyflag then controlyproc;       <<b0.00>>01732000
   errn := errf := 0;                                          <<04145>>01734000
   c := -1;                                                             01736000
   move obuf := " "; move obuf(1):=obuf,(127);                 <<04145>>01738000
                                                               <<04145>>01740000
   if not file'found and not show then                         <<04145>>01742000
      begin                                                    <<04145>>01744000
         << no files found under user.acct specified >>        <<06426>>01746000
        errn :=  5; errf := no'file'error; ix:=0;              <<04145>>01748000
        errform(errn,errf,ix);                                 <<04145>>01750000
      end;                                                     <<04145>>01752000
                                                               <<04145>>01754000
   <<*******************************************************>> <<04145>>01756000
   <<  for each devfid not used in our array devfs (not     >> <<04145>>01758000
   << zeroed out) output an error for that devfid.          >> <<04145>>01760000
   <<*******************************************************>> <<04145>>01762000
                                                               <<04145>>01764000
   while (c:=c+1) < devfc do                                            01766000
      if devfs(c) <> 0 then                                             01768000
         begin                                                          01770000
         df := devfs(c);                                                01772000
         errn := 32;    << invalid file id >>                  <<06426>>01774000
         if showio.odds and df > 0 then                        <<x7786>>01776000
            errn := 30;       << input file not allowed >>     <<06426>>01778000
         showit;                                                        01780000
         end;                                                           01782000
$page                                                          <<04145>>01784000
                                                               <<04145>>01786000
   <<*******************************************************>> <<04145>>01788000
   <<  for each xdd entried copied into our stack for this  >> <<04145>>01790000
   << command, check xdd(25), which, if non zero, conatins  >> <<04145>>01792000
   << error numbers for errn and errf, put there as the     >> <<04145>>01794000
   << errors were encountered dealing with the xdd entry.   >> <<04145>>01796000
   <<*******************************************************>> <<04145>>01798000
                                                               <<04145>>01800000
   c := 0;                                                              01802000
   @xdd'subentry := initxddp;                                  <<x7786>>01804000
   while (c:=c+1) <= xddc do                                            01806000
      begin                                                             01808000
      @xdd'subentry := @xdd'subentry - size'of'xdd'subentry;   <<x7786>>01810000
      if (xdds'device <> 0) and (xdds'show'errs <> 0) then     <<x7786>>01812000
         begin                                                          01814000
         << copy device file id and idd'or'odd bit >>          <<x7786>>01816000
         df := xdds'dfid'all;                                  <<x7786>>01818000
         errn := xdds'spook'err;                               <<x7786>>01820000
         errf := xdds'filesys'err;                             <<x7786>>01822000
         showit;                                                        01824000
         end;                                                           01826000
      end;                                                              01828000
   critflag := true;                                           <<b0.00>>01830000
   end;                                                                 01832000
$page "* * * SHOWXDD * * *"                                    <<x7786>>01834000
                                                                        01836000
$control segment=spook2                                                 01838000
                                                                        01840000
procedure showxdd(flag,dfid);                                           01842000
   value   flag,dfid;                                                   01844000
   logical flag;                                                        01846000
   integer dfid;                                                        01848000
   begin                                                                01850000
   integer ix,iy,dev,ct,jprime;                                         01852000
   integer spoofle'ldev;                                       <<x7786>>01854000
   logical out;                                                         01856000
   logical pointer                                             <<06426>>01858000
      dct'head,                                                <<06536>>01860000
      dct,                                                     <<x7786>>01862000
      xdd'subentry;                                            <<x7786>>01864000
   byte pointer xdd'bsubentry;                                 <<x7786>>01866000
   double pointer dctd=dct;                                    <<06426>>01868000
   array cl(0:9)=q;                                                     01870000
   double dcl0=cl+0,dcl1=cl+2;                                          01872000
   byte pointer bcl;                                                    01874000
   array days(0:11)=pb:=                                                01876000
      0,31,60,91,121,152,182,                                           01878000
      213,244,274,305,335;                                              01880000
   << >>                                                                01882000
   subroutine showsect;                                                 01884000
      begin                                                             01886000
      tos := 0;                                                         01888000
      tos := xdds'number'extents;                              <<x7786>>01890000
      if = then tos := tos+1;                                           01892000
      << number of sectors / spoofle extent >>                 <<x7786>>01894000
      tos := logical(tos-1)**absolute(%1104);                           01896000
      tos := tos+double(xdds'last'extent'size);                <<x7786>>01898000
      ct := dascii(*,10,bcl(4));                                        01900000
      move bobuf(ix+10-ct-((12-ct)/4)*2) := bcl(4),(ct);                01902000
      ix := ix+11;                                                      01904000
      end;                                                              01906000
   << >>                                                                01908000
   obuf := "  ";                                                        01910000
   move obuf(1) := obuf,(127);                                          01912000
   @xdd'subentry := @xddbuf;                                   <<x7786>>01914000
   @xdd'bsubentry := @bxddbuf;                                 <<x7786>>01916000
   out := xdds'dfid'in'or'out;                                 <<x7786>>01918000
   ix := 0;                                                             01920000
   @bcl := @cl&lsl(1);                                                  01922000
   if flag.(12:1) then                                                  01924000
      begin                                                             01926000
      bobuf(ix) := "#";                                                 01928000
      bobuf(ix+1) := if dfid < 0 then "O" else "I";                     01930000
      ascii(dfid.idnum,10,bobuf(ix+2));                        <<x7786>>01932000
      move bobuf(ix+8) := "===>";                                       01934000
      ix := ix+14;                                                      01936000
      end;                                                              01938000
   bobuf(ix) := "#";                                                    01940000
   bobuf(ix+1) := if out then "O" else"I";                              01942000
   ascii(xdds'dfid'number,10,bobuf(ix+2));                     <<x7786>>01944000
   ix := ix+8;                                                          01946000
   if not flag then                                                     01948000
      begin                                                             01950000
      if xdds'job'number <> 0 then                             <<x7786>>01952000
         begin                                                          01954000
         bobuf(ix) := "#";                                              01956000
         bobuf(ix+1) := if xdds'job'type<=1 then "S" else"J";  <<x7786>>01958000
         jprime := 0;                                                   01960000
         if not (1<=integer(xdds'job'type)<=2) then            <<x7786>>01962000
            begin                                                       01964000
            jprime := 1;                                                01966000
            bobuf(ix+2) := "'";                                         01968000
            end;                                                        01970000
         ascii(xdds'job'number,10,bobuf(ix+2+jprime));         <<x7786>>01972000
         end;                                                           01974000
      ix := ix+8;                                                       01976000
      if flag.(12:2) = 0 then                                           01978000
         begin                                                          01980000
         move bobuf(ix) := xddsb'file'name,(8);                <<x7786>>01982000
         ix := ix+9;                                                    01984000
         move bobuf(ix) := states(xdds'spool'state*6),(6);     <<x7786>>01986000
         ix := ix+7;                                                    01988000
         end;                                                           01990000
      if flag.(12:3) <> 0 then                                          01992000
         begin                                                          01994000
         if xdds'class then                                    <<x7786>>01996000
            begin                                                       01998000
            dev := -xdds'device;                               <<x7786>>02000000
            @dct'head := 0;                                    <<06536>>02002000
            exchangedb(dct'dst);                               <<06536>>02004000
            @dct := dcth'dct'base;                             <<06536>>02006000
            while (dev:=dev+1) < 0 do                                   02008000
               @dct := @dct+integer(dct'next'entry);           <<06426>>02010000
            dcl0 := dctd;                                      <<06426>>02012000
            dcl1 := dctd(1);                                   <<06426>>02014000
            exchangedb(0);                                              02016000
            move bobuf(ix) := bcl,(8);                                  02018000
            end                                                         02020000
         else                                                           02022000
            ascii(xdds'device,10,bobuf(ix));                   <<x7786>>02024000
         ix := ix+10;                                                   02026000
         end;                                                           02028000
      if flag.(14:1) then                                               02030000
         begin                                                          02032000
         if out then                                                    02034000
            begin                                                       02036000
            ascii(xdds'output'priority,-10,bobuf(ix));         <<x7786>>02038000
            ascii(odds'number'copies,-10,bobuf(ix+4));         <<x7786>>02040000
            end;                                                        02042000
         ix := ix+6;                                                    02044000
         if idds'restart then bobuf(ix) := "R";                <<x7786>>02046000
         if odds'forms'on'device or odds'forms'in'file         <<x7786>>02048000
            then bobuf(ix+1) := "F";                           <<04145>>02050000
         if xdds'spaced'out then bobuf(ix+2) := "N";           <<x7786>>02052000
         ix := ix+4;                                                    02054000
         end;                                                           02056000
      if flag.(13:1) then                                               02058000
         begin                                                          02060000
         showsect;                                                      02062000
         ix := ix+1;                                                    02064000
         end;                                                           02066000
      move bobuf(ix) := xddsb'user'name,(8);                   <<x7786>>02068000
      scan bobuf(ix) until "  ",1;                                      02070000
      ix := tos-@bobuf;                                                 02072000
      bobuf(ix) := ".";                                                 02074000
      move bobuf(ix+1) := xddsb'account'name,(8);              <<x7786>>02076000
      ix := ix+9;                                                       02078000
      end                                                               02080000
   else                                                                 02082000
      begin                                                             02084000
         spoofle'ldev := lun(xdds'spoofle'vt'index,0);         <<x7786>>02086000
         ct := ascii(spoofle'ldev,8,bcl(4));                   <<x7786>>02088000
      if ct = 0 then ct := 1;                                           02090000
      bobuf(ix) := "%";                                                 02092000
      move bobuf(ix+1) := bcl(10-ct),(ct);                              02094000
      cl := xdds'msw'label;                                    <<x7786>>02096000
      cl(1) := xdds'lsw'label;                                 <<x7786>>02098000
      ct := dascii(dcl0,8,bcl(5));                                      02100000
      if ct = 0 then ct := 1;                                           02102000
      ct := ct+1;                                                       02104000
      bcl(16-ct) := "%";                                                02106000
      move bobuf(ix+4+(12-ct)/2) := bcl(16-ct),(ct);                    02108000
      ix := ix+17;                                                      02110000
      showsect;                                                         02112000
      tos := 0;                                                         02114000
      tos := xdds'msw'record'count;                            <<x7786>>02116000
      tos := xdds'lsw'record'count;                            <<x7786>>02118000
      ct := dascii(*,10,bcl(4));                                        02120000
      move bobuf(ix+12-ct-((12-ct)/4)*2) := bcl(4),(ct);                02122000
      ix := ix+16;                                                      02124000
         cl(0) := xdd'subentry(30);    << date >>              <<x7786>>02126000
         cl(1) := xdd'subentry(31);    << time >>              <<x7786>>02128000
      if dcl0 <> 0d then                                                02130000
         begin                                                          02132000
         bcl(8) := " ";                                                 02134000
         move bcl(9) := bcl(8),(4);                                     02136000
         ascii(xdds'minute,-10,bcl(12));                       <<x7786>>02138000
         bcl(10) := ":";                                                02140000
         ascii(xdds'hour,-10,bcl(9));                          <<x7786>>02142000
                                                               <<*7784>>02144000
         << shift in last bit of day of year >>                <<*7784>>02146000
         dcl0 := dcl0&dlsr(8);                                          02148000
         cl(1) := cl(1)&lsr(7);                                         02150000
         if cl(0).(14:2) <> 0 and cl(1) >= 60 then                      02152000
            cl(1) := cl(1)+1;    << leap year >>               <<*7784>>02154000
                                                               <<*7784>>02156000
         << day of year must be at least 0 >>                  <<*7784>>02158000
         if cl(1) > 0 then                                     <<*7784>>02160000
            begin                                              <<*7784>>02162000
            << now ok to move time in >>                       <<*7784>>02164000
            move bobuf(ix) := bcl(8),(5);                      <<*7784>>02166000
            ix := ix+6;                                        <<*7784>>02168000
            iy := 12;                                          <<*7784>>02170000
            do iy := iy-1 until cl(1) > days(iy);              <<*7784>>02172000
            cl(1) := cl(1)-days(iy);                           <<*7784>>02174000
            iy := iy+1;                                        <<*7784>>02176000
            bcl(8) := " ";                                     <<*7784>>02178000
            move bcl(9) := bcl(8),(7);                         <<*7784>>02180000
            ascii(cl(0),-10,bcl(15));                          <<*7784>>02182000
            bcl(13) := "/";                                    <<*7784>>02184000
            ascii(cl(1),-10,bcl(12));                          <<*7784>>02186000
            bcl(10) := "/";                                    <<*7784>>02188000
            ascii(iy,-10,bcl(9));                              <<*7784>>02190000
            move bobuf(ix) := bcl(8),(8);                      <<*7784>>02192000
            ix := ix+10;                                       <<*7784>>02194000
            end;                                               <<*7784>>02196000
         end;                                                  <<*7784>>02198000
      end;                                                              02200000
   if flag.(12:2) = 0 then  begin   critflag := false;         <<b0.00>>02202000
      if controlyflag then controlyproc; end;                  <<b0.00>>02204000
   print(obuf,-ix,0);                                                   02206000
   if flag.(12:2) = 0 then critflag := true;                   <<b0.00>>02208000
   end;                                                                 02210000
$page "COMMAND STRING PARSING ROUTINES"                        <<x7786>>02212000
                                                                        02214000
$control segment=spook1                                                 02216000
                                                                        02218000
logical procedure getusac;                                              02220000
   begin                                                                02222000
   << >>                                                                02224000
   devf := 0;                                                           02226000
   userf := true;                                                       02228000
   acctf := true;                                                       02230000
   snames := "  ";                                                      02232000
   move snames(1) := snames,(7);                                        02234000
   if bp = cr  or bp = ";" then                                <<04145>>02236000
      move susern := usern,(16)                                         02238000
   else                                                                 02240000
      begin                                                             02242000
      if bp = "@" then                                                  02244000
         begin                                                          02246000
         userf := false;                                                02248000
         if cap1.(0:2)=0 then                                           02250000
            begin                                                       02252000
            warn := 4;                                                  02254000
            move susern := usern,(8);                                   02256000
            userf := 1;                                                 02258000
            end;                                                        02260000
         cnt := 1;                                                      02262000
         end                                                            02264000
      else                                                              02266000
         begin                                                          02268000
         move bp := bp while as,0;                                      02270000
         if s0 <> @bp then move * := * while ans,0;                     02272000
         cnt := tos-@bp;                                                02274000
         del;                                                           02276000
         if not (1<=cnt<=8) then                                        02278000
            << user name too big >>                            <<06426>>02280000
            begin errn := 34; goto lx; end;                             02282000
         move susern := bp,(cnt);                                       02284000
         if (cap1.(0:2)=0) and (susern<>usern,(8)) then                 02286000
            << user not accessible >>                          <<06426>>02288000
            begin errn := 35; goto lx; end;                             02290000
         end;                                                           02292000
      @bp := @bp+cnt;                                                   02294000
      if bp = cr  or bp = ";" then                             <<04145>>02296000
         move sacctn := acctn,(8)                                       02298000
      else                                                              02300000
         begin                                                          02302000
         if bp <> "." then                                              02304000
            << unexpected character >>                         <<06426>>02306000
            begin errn := 33; goto lx; end;                             02308000
         @bp := @bp+1;                                                  02310000
         if bp = "@" then                                               02312000
            begin                                                       02314000
            acctf := false;                                             02316000
            if cap1.(0:1)=0 then                                        02318000
               begin                                                    02320000
               warn := 4;                                               02322000
               move sacctn := acctn,(8);                                02324000
               acctf := 1;                                              02326000
               end;                                                     02328000
            cnt := 1;                                                   02330000
            end                                                         02332000
         else                                                           02334000
            begin                                                       02336000
            move bp := bp while as,0;                                   02338000
            if s0 <> @bp then move * := * while ans,0;                  02340000
            cnt := tos-@bp;                                             02342000
            del;                                                        02344000
            if not (1<=cnt<=8) then                                     02346000
               << account name too big >>                      <<06426>>02348000
               begin errn := 36; goto lx; end;                          02350000
            move sacctn := bp,(cnt);                                    02352000
            if (cap1.(0:1)=0) and (sacctn<>acctn,(8)) then              02354000
               << account not accessible >>                    <<06426>>02356000
               begin errn := 37; goto lx; end;                          02358000
            end;                                                        02360000
         @bp := @bp+cnt;                                                02362000
         end;                                                           02364000
      end;                                                              02366000
   getusac := true;                                                     02368000
lx:                                                                     02370000
   end;                                                                 02372000
$page                                                          <<x7786>>02374000
                                                               <<x7786>>02376000
$control segment=spook1                                                 02378000
                                                                        02380000
<<**********************************************************>> <<04145>>02382000
<< getdevf obtains a device file id from the command string >> <<04145>>02384000
<< and places it in the device file array devfs and updates >> <<04145>>02386000
<< the count devfc, assuming no errors.                     >> <<04145>>02388000
<<**********************************************************>> <<04145>>02390000
                                                               <<04145>>02392000
logical procedure getdevf;                                              02394000
   begin                                                                02396000
   integer dev'cnt;                                            <<04145>>02398000
   logical output,found;                                       <<04145>>02400000
   << >>                                                                02402000
   errn := 32;      << assume invalid file id >>               <<06426>>02404000
   devf := 0;                                                           02406000
   userf := true;                                                       02408000
   acctf := true;                                                       02410000
   snames := "  ";                                                      02412000
   move snames(1) := snames,(7);                                        02414000
                                                               <<04145>>02416000
   <<*******************************************************>> <<04145>>02418000
   << check for proper string.  if we have a *, then check  >> <<04145>>02420000
   << if a file has been texted in, (device file number<>0),>> <<04145>>02422000
   << if not, error condition.                              >> <<04145>>02424000
   <<*******************************************************>> <<04145>>02426000
                                                               <<04145>>02428000
   if bp = "#" or bp = "*" or bp = numeric then                         02430000
      begin                                                             02432000
      if bp = "*" then                                                  02434000
         begin                                                          02436000
         if filen = 0 then      << no text file >>             <<06426>>02438000
            begin errn := 46; goto lx; end;                             02440000
         @bp := @bp+1;                                                  02442000
         devf := devfn;                                                 02444000
         end                                                            02446000
                                                               <<04145>>02448000
      <<****************************************************>> <<04145>>02450000
      << otherwise we have a device file id.  if it begins  >> <<04145>>02452000
      << with "#", check id for "I" or "O" and set flag     >> <<04145>>02454000
      << accordingly, true for o, false for i.              >> <<04145>>02456000
      <<****************************************************>> <<04145>>02458000
                                                               <<04145>>02460000
      else                                                              02462000
         begin                                                          02464000
         if bp = "#" then                                               02466000
            begin                                                       02468000
            @bp := @bp+1;                                               02470000
            move bp:=bp while as; <<upshift alpha         >>   <<01.02>>02472000
            if bp = "I" then output := false                   <<04145>>02474000
            else if bp = "O" then output := true               <<04145>>02476000
                 else goto lx;                                          02478000
                 @bp := @bp+1;                                          02480000
            end                                                         02482000
         else      << must be numeric >>                       <<06426>>02484000
            output := true;                                    <<04145>>02486000
$page                                                          <<04145>>02488000
        <<**************************************************>> <<04145>>02490000
        << get id number and set top bit of devf on for     >> <<04145>>02492000
        << output and off for input                         >> <<04145>>02494000
        <<**************************************************>> <<04145>>02496000
                                                               <<04145>>02498000
         move bp := bp while n,1;                                       02500000
         cnt := tos-@bp;                                                02502000
         devf := binary(bp,cnt);                                        02504000
         if <> then goto lx;                                            02506000
         if devf.is'odd <> 0 then goto lx;                     <<x7786>>02508000
         @bp := @bp+cnt;                                                02510000
         devf.is'odd := output;                                <<x7786>>02512000
         end;                                                           02514000
                                                               <<04145>>02516000
      <<****************************************************>> <<04145>>02518000
      <<  check to see if the dev id exists already in the  >> <<04145>>02520000
      << array devfs (in case of duplicate device file      >> <<04145>>02522000
      << id's.) if not, place it in the array at devfc and  >> <<04145>>02524000
      << update the count devfc by one.                     >> <<04145>>02526000
      <<****************************************************>> <<04145>>02528000
                                                               <<04145>>02530000
      found := false;                                          <<04145>>02532000
      dev'cnt := -1;                                           <<04145>>02534000
      while (dev'cnt:=dev'cnt+1) < devfc do                    <<04145>>02536000
         if devf = integer(devfs(dev'cnt)) then found := true; <<04145>>02538000
      if not found then                                        <<04145>>02540000
         begin                                                          02542000
         devfs(devfc) := devf;                                          02544000
         devfc := devfc+1;                                              02546000
         end;                                                           02548000
      move susern := usern,(16);                                        02550000
      if cap1.(0:2) <> 0 then userf := false;                           02552000
      if cap1.(0:1) <> 0 then acctf := false;                           02554000
      getdevf := true;                                                  02556000
      errn := 0;                                                        02558000
      end;                                                              02560000
lx:                                                                     02562000
   end;                                                                 02564000
                                                                        02566000
$control segment=spook1                                                 02568000
                                                                        02570000
<<---------------------------------------------------------->> <<x7801>>02572000
<< getdnum scans the command string for an ascii number     >> <<x7801>>02574000
<< which it returns as a binary value in dnum.              >> <<x7801>>02576000
<<---------------------------------------------------------->> <<x7801>>02578000
                                                               <<x7801>>02580000
logical procedure getdnum;                                              02582000
   begin                                                                02584000
   integer y,z;                                                         02586000
   << >>                                                                02588000
   z := 0;                                                              02590000
   if bp = "+" or bp = "-" then z := 1;                                 02592000
   move bp(z) := bp(z) while n,1;                                       02594000
   y := tos-@bp(z);                                                     02596000
   if y = 0 then                                                        02598000
      begin                                                             02600000
      if z = 0 then getdnum := 2;                                       02602000
      goto lx;                                                          02604000
      end;                                                              02606000
   dnum := dbinary(bp,z+y);                                             02608000
   if <> then goto lx;                                                  02610000
   @bp := @bp+z+y;                                                      02612000
   getdnum := true;                                                     02614000
lx:                                                                     02616000
   end;                                                                 02618000
$page                                                          <<i7784>>02620000
$control segment=spook1                                                 02622000
                                                                        02624000
<<---------------------------------------------------------->> <<x7801>>02626000
<< getline is called by linerange to scan the command string>> <<x7801>>02628000
<< for a line number.                                       >> <<x7801>>02630000
<<---------------------------------------------------------->> <<x7801>>02632000
                                                               <<x7801>>02634000
logical procedure getline(last);                                        02636000
   value   last;                                                        02638000
   logical last;                                                        02640000
   begin                                                                02642000
   double dline;                                                        02644000
   logical result;                                             <<x7786>>02646000
   << >>                                                                02648000
   errn := 39;    << invalid line number >>                    <<06426>>02650000
   dline := if fline = -1d then start'recnum  else fline;     <<<01549>>02652000
   if bp <> cr  then                                           <<04145>>02654000
      begin                                                             02656000
      if bp = "*" then                                                  02658000
         @bp := @bp+1                                                   02660000
      else                                                              02662000
         if bp = alpha then                                             02664000
            begin                                                       02666000
            if bp = "FIRST" then                                        02668000
               begin                                                    02670000
               dline := start'recnum;                        <<<<01549>>02672000
               @bp := @bp+5;                                            02674000
               end                                                      02676000
            else                                                        02678000
               if bp = "LAST" then                                      02680000
                  begin                                                 02682000
                  dline := eofline;                                     02684000
                  @bp := @bp+4;                                         02686000
                  end                                                   02688000
            else                                               <<b0.01>>02690000
               if bp = "EOF" and last then                     <<b0.01>>02692000
                  begin                                        <<b0.01>>02694000
                  dline := eofline;                            <<b0.01>>02696000
                  eofflag := true;                             <<b0.01>>02698000
                  @bp := @bp + 3;                              <<b0.01>>02700000
                  end                                          <<b0.01>>02702000
               else       << invalid line mnemonic >>          <<06426>>02704000
                  begin errn := 38; goto lx; end;                       02706000
            end                                                         02708000
         else                                                           02710000
            begin                                                       02712000
            if (result := getdnum) = 0 then goto lx;           <<x7786>>02714000
            if result then dline := dnum;                      <<x7786>>02716000
            end;                                                        02718000
      while bp = "+" or bp = "-" do                                     02720000
         begin                                                          02722000
         if not getdnum then goto lx;                                   02724000
         dline := dline+dnum;                                           02726000
         end;                                                           02728000
      if dline < 0d then goto lx;                                       02730000
      if dline < start'recnum then                           <<<<01549>>02732000
      begin                                                  <<<<01549>>02734000
         errn := 78; <<linenum in a purged extent>>          <<<<01549>>02736000
         go to lx;                                           <<<<01549>>02738000
      end;                                                   <<<<01549>>02740000
      if dline > eofline then goto lx;                                  02742000
      end;                                                              02744000
   if last                                                              02746000
      then toline := dline                                              02748000
      else frline := dline;                                             02750000
   getline := true;                                                     02752000
   errn := 0;                                                           02754000
lx:                                                                     02756000
   end;                                                                 02758000
$page                                                          <<04145>>02760000
<<**********************************************************>> <<04145>>02762000
<< get'new'file, called by linerange, parses the file to be >> <<04145>>02764000
<< copied to and places it in new'filename.  the file must  >> <<04145>>02766000
<< begin with a "*", "$", or a alphabetic character.        >> <<04145>>02768000
<<**********************************************************>> <<04145>>02770000
                                                               <<04145>>02772000
$control segment = spook1                                      <<b0.01>>02774000
                                                               <<b0.01>>02776000
logical procedure get'new'file;                                <<b0.01>>02778000
<<>>                                                           <<b0.01>>02780000
begin                                                          <<b0.01>>02782000
integer tcount,t;                                              <<b0.01>>02784000
<<>>                                                           <<b0.01>>02786000
move old'filename := new'filename,(29);                        <<b0.01>>02788000
if bp <> cr  then                                              <<04145>>02790000
   begin                                                       <<b0.01>>02792000
   if bp = "," then                                            <<b0.01>>02794000
      begin                                                    <<b0.01>>02796000
      @bp := @bp + 1;                                          <<b0.01>>02798000
     if bp <> "*" and bp <> "$" and bp <> alpha then           <<04145>>02800000
        begin                                                  <<04145>>02802000
          errn := 79;   << invalid copy file >>                <<06426>>02804000
          go to lx;                                            <<04145>>02806000
        end;                                                   <<04145>>02808000
      scan bp until %6473,1; <<cr ;>>                          <<b0.01>>02810000
      tcount := tos;                                           <<b0.01>>02812000
      move new'filename := bp,(t:=tcount-@bp+1);               <<b0.01>>02814000
      @bp := @bp+t-1;                                          <<b0.01>>02816000
      if carry then go to lx1;                                 <<b0.01>>02818000
      end                                                      <<b0.01>>02820000
   else move new'filename := "  " ;                            <<b0.01>>02822000
   end                                                         <<b0.01>>02824000
else                                                           <<b0.01>>02826000
   move new'filename := "  ";                                  <<b0.01>>02828000
lx1:                                                           <<b0.01>>02830000
   get'new'file := true;                                       <<b0.01>>02832000
lx:                                                            <<b0.01>>02834000
   end;                                                        <<b0.01>>02836000
$page                                                          <<04145>>02838000
                                                               <<b0.01>>02840000
<<---------------------------------------------------------->> <<x7801>>02842000
<< linerange parses the command string for the range of     >> <<x7801>>02844000
<< lines to be used in the command.  frline is the line     >> <<x7801>>02846000
<< number of the first line, and toline is the last line of >> <<x7801>>02848000
<< of the range.                                            >> <<x7801>>02850000
<<---------------------------------------------------------->> <<x7801>>02852000
                                                                        02854000
$control segment=spook1                                                 02856000
                                                                        02858000
logical procedure linerange(skan);                                      02860000
   value   skan;                                                        02862000
   logical skan;                                                        02864000
   begin                                                                02866000
   << >>                                                                02868000
   if bp = "ALL" then                                                   02870000
      begin                                                             02872000
      @bp := @bp+3;                                                     02874000
      frline := start'recnum;                                <<<<01549>>02876000
      toline := eofline;                                                02878000
      linecnt := eofline+1d;                                            02880000
      end                                                               02882000
   else                                                                 02884000
      begin                                                             02886000
      if not getline(false) then goto lx;                               02888000
      toline := if skan then eofline else frline;                       02890000
      linecnt := toline-frline+1d;                                      02892000
      if bp <> cr  then                                        <<04145>>02894000
         if bp = "," then                                               02896000
            begin                                                       02898000
            errn := 40;    << invalid line count >>            <<06426>>02900000
            @bp := @bp+1;                                               02902000
            if not getdnum then goto lx;                                02904000
            if (linecnt := dnum) <= 0d then goto lx;                    02906000
            toline := frline+linecnt-1d;                                02908000
            if toline > eofline then goto lx;                           02910000
            errn := 0;                                                  02912000
            end                                                         02914000
         else                                                           02916000
            begin                                                       02918000
            if bp <> "/" then   << unexpected character >>     <<06426>>02920000
               begin errn := 33; goto lx; end;                          02922000
            @bp := @bp+1;                                               02924000
            if not getline(true) then goto lx;                          02926000
            linecnt := toline-frline+1d;                                02928000
            if linecnt <= 0d then                                       02930000
               << invalid line range >>                        <<06426>>02932000
               begin errn := 41; goto lx; end;                          02934000
            end;                                                        02936000
      end;                                                              02938000
   if skan = copy then <<copy called procedure>>               <<b0.01>>02940000
      if not get'new'file then go to lx;                       <<b0.01>>02942000
   if bp <> cr  then   << unexpected character >>              <<06426>>02944000
      begin errn := 33; goto lx; end;                                   02946000
   linerange := true;                                                   02948000
lx:                                                                     02950000
   end;                                                                 02952000
$page                                                          <<04145>>02954000
$control segment=spook1                                                 02956000
                                                                        02958000
logical procedure findrange;                                            02960000
   begin                                                                02962000
   << >>                                                                02964000
   fstrall := false;                                                    02966000
   fstring := 0;                                                        02968000
   if bp = "@" then                                                     02970000
      begin                                                             02972000
      fstrall := true;                                                  02974000
      @bp := @bp+1;                                                     02976000
      end;                                                              02978000
   if bp = %42 then                                                     02980000
      begin                                                             02982000
      @bp := @bp+1;                                                     02984000
      scan bp while %6440,1;                                            02986000
      @bp := tos;                                                       02988000
      scan bp(1) until %6442,1;                                         02990000
      if carry then   << non-terminated character string >>    <<06426>>02992000
         begin errn := 42; goto lx; end;                                02994000
      fstring := tos-@bp;                                               02996000
      @bfstr := @fstr&asl(1);                                           02998000
      move bfstr := bp,(fstring);                                       03000000
      @bp := @bp+fstring+1;                                             03002000
      end;                                                              03004000
   if bp = "," then                                                     03006000
      @bp := @bp+1                                                      03008000
   else                                                                 03010000
      if bp <> cr  then   << unexpected character >>           <<06426>>03012000
         begin errn := 33; goto lx; end;                                03014000
   if not linerange(true) then goto lx;                                 03016000
   findrange := true;                                                   03018000
lx:                                                                     03020000
   end;                                                                 03022000
$page                                                          <<x7801>>03024000
procedure scanblocktab(endline,blockno,recno);                 <<b0.01>>03026000
double endline,blockno,recno;                                  <<b0.01>>03028000
<<>>                                                           <<b0.01>>03030000
begin                                                          <<b0.01>>03032000
integer pointer blocktp;                                       <<b0.01>>03034000
double pointer dblocktp = blocktp;                             <<b0.01>>03036000
integer bcount;                                                <<b0.01>>03038000
<<>>                                                           <<b0.01>>03040000
bcount := 0;                                                   <<b0.01>>03042000
critflag := false;if controlyflag then controlyproc;           <<b0.01>>03044000
@blocktp := @blockfp;                                          <<b0.01>>03046000
  while (bcount:= bcount + 1) < bentries                       <<b0.01>>03048000
      and endline >= dblocktp(1)                     <<b0.01>> <<b0.01>>03050000
      do begin                                                 <<b0.01>>03052000
      @blocktp := @blocktp + bentry'size;                      <<b0.01>>03054000
      if @blocktp >=  @blocktable+bentries * bentry'size       <<b0.01>>03056000
         then @blocktp := @blocktable;                         <<b0.01>>03058000
      end;                                                     <<b0.01>>03060000
if @blocktp = @blocktable then                                 <<b0.01>>03062000
   @blocktp := @blocktable + (bentries-1)*bentry'size          <<b0.01>>03064000
else                                                           <<b0.01>>03066000
   @blocktp := @blocktp - bentry'size;                         <<b0.01>>03068000
critflag := true;                                              <<b0.01>>03070000
blockno := dblocktp(0);                                        <<b0.01>>03072000
recno := dblocktp(1);                                          <<b0.01>>03074000
end;                                                           <<b0.01>>03076000
$page                                                          <<04145>>03078000
$control segment=spook2                                        <<b0.01>>03080000
                                                               <<b0.01>>03082000
procedure copy'last'open;                                      <<b0.01>>03084000
<<>>                                                           <<b0.01>>03086000
begin                                                          <<b0.01>>03088000
integer i;                                                     <<b0.01>>03090000
<<>>                                                           <<b0.01>>03092000
move sbuf(512) := new'bufw,((new'bufw+3)/2);                   <<b0.01>>03094000
sbuf(i:= 512 + (new'bufw+3)/2    ) := -1 ;                     <<b0.01>>03096000
move sbuf(i+1) := sbuf(i),(1024 - i -1);                       <<b0.01>>03098000
fwrite(new'filen,sbuf(512),512,0);                             <<b0.01>>03100000
                                                               <<b0.01>>03102000
end;                                                           <<b0.01>>03104000
$control segment=spook2                                        <<b0.01>>03106000
                                                               <<b0.01>>03108000
procedure compress(buffer,beginning,buflength);                <<b0.01>>03110000
                                                               <<b0.01>>03112000
value beginning,buflength;                                     <<b0.01>>03114000
array buffer;                                                  <<b0.01>>03116000
integer beginning,buflength;                                   <<b0.01>>03118000
<<>>                                                           <<b0.01>>03120000
begin                                                          <<b0.01>>03122000
pointer cp;                                                    <<b0.01>>03124000
integer len;                                                   <<b0.01>>03126000
@cp := beginning;                                              <<b0.01>>03128000
move buffer := cp,(len:=buflength-(@cp-@buffer));              <<b0.01>>03130000
buffer(len) :=-1;                                              <<b0.01>>03132000
move buffer(len+1) := buffer(len),(buflength-len-1);           <<b0.01>>03134000
end;                                                           <<b0.01>>03136000
$page                                                          <<04145>>03138000
                                                                        03140000
$control segment=spook2                                                 03142000
                                                                        03144000
logical procedure skantoline(skan);                                     03146000
   value   skan;                                                        03148000
   logical skan;                                                        03150000
   begin                                                                03152000
   integer temp;                                                        03154000
   double endline;                                                      03156000
double recno;                                                  <<b0.01>>03158000
   pointer p;                                                           03160000
   integer r,q;                                                <<b0.01>>03162000
   << >>                                                                03164000
subroutine add'block'entry;                                    <<b0.01>>03166000
begin                                                          <<b0.01>>03168000
<<>>                                                           <<b0.01>>03170000
     @blockcp := @blockcp + bentry'size;                       <<b0.01>>03172000
     if @blockcp - @blocktable >=  r:= bentries * bentry'size  <<b0.01>>03174000
      then begin                                               <<b0.01>>03176000
           @blockcp := @blocktable;                            <<b0.01>>03178000
           @blockfp := @blocktable + bentry'size;              <<b0.01>>03180000
           end                                                 <<b0.01>>03182000
      else                                                     <<b0.01>>03184000
         if @blockfp <> @blocktable then                       <<b0.01>>03186000
           @blockfp := if (q:=@blockfp+bentry'size) >          <<b0.01>>03188000
                @blocktable + r then @blocktable               <<b0.01>>03190000
                else q;                                        <<b0.01>>03192000
     dblockcp(0) := blockno;                                   <<b0.01>>03194000
     dblockcp(1) := sbline;                                    <<b0.01>>03196000
end;                                                           <<b0.01>>03198000
<<>>  <<end of add'block'entry>>                               <<b0.01>>03200000
                                                               <<b0.01>>03202000
   endline := if skan then frline else toline;                          03204000
   if skan then                                                <<01726>>03206000
   begin  << incredibly fast freaddir to record>>              <<01726>>03208000
      read'record(filen,endline,sbuf,sp,xddn,blockno,errf);    <<01726>>03210000
      if <> then                                               <<01726>>03212000
      begin <<error, if ccl then before first extent>>         <<01726>>03214000
         if < then                                             <<01726>>03216000
         begin                                                 <<01726>>03218000
            errn := 78; <<before purged extent>>               <<01726>>03220000
            go to lx;                                          <<01726>>03222000
         end                                                   <<01726>>03224000
         else                                                  <<01726>>03226000
         if  > then                                            <<01726>>03228000
         begin  << error , if ccg then beyond eof>>            <<01726>>03230000
            errn := 41;                                        <<01726>>03232000
            go to lx;                                          <<01726>>03234000
         end;                                                  <<01726>>03236000
      end;                                                     <<01726>>03238000
      fline := endline;                                        <<01726>>03240000
      tos := sbuf(510);                                        <<01726>>03242000
      tos := sbuf(511);                                        <<01726>>03244000
      sbline := tos;                                           <<01726>>03246000
      go to li;                                                <<01726>>03248000
   end;                                                        <<01726>>03250000
   while fline <> endline do                                   <<01726>>03252000
      begin                                                             03254000
      if > then                                                         03256000
         begin                                                          03258000
         if not skan then    << impossible internal error >>   <<06426>>03260000
            begin errn := 19; goto lx; end;                             03262000
         if sbline > endline then                                       03264000
            begin                                                       03266000
<< note: the following code is turned off until      >>        <<01549>>03268000
<<      freaddir works correctly with special        >>        <<01549>>03270000
<<      variable spoolfiles.                         >>        <<01549>>03272000
         if endline > dblockfp(1) then                         <<01549>>03274000
            begin                                              <<01549>>03276000
            scanblocktab(endline,blockno,recno);               <<01549>>03278000
            read'dir'flag := true;                             <<01549>>03280000
            end                                                <<01549>>03282000
          else begin                                           <<01549>>03284000
               @blockfp := @blockcp := @blocktable  ;          <<01549>>03286000
               dblockfp(0) := 0d;                              <<01549>>03288000
               dblockfp(1) := 0d;                              <<01549>>03290000
               blockno := 0d;                                  <<01549>>03292000
            fcontrol(filen,5,temp);                                     03294000
            if <> then      << file read error >>              <<06426>>03296000
               begin errn := 26; fcheck(filen,errf); goto lx; end;      03298000
            fline := -1d;                                               03300000
            end;                 <<see comment above>>         <<01549>>03302000
            end                                                         03304000
         else                                                           03306000
            begin                                                       03308000
            @sp := @sbuf;                                               03310000
            fline := sbline;                                            03312000
            goto li;                                                    03314000
            end;                                                        03316000
         end;                                                           03318000
      if fline >= 0d then                                               03320000
         begin                                                 <<b0.01>>03322000
         @p := @sp+integer((sp+3)&asr(1))                               03324000
                                             ;                 <<b0.01>>03326000
         if @p > @sbuf + 512 then                              <<b0.01>>03328000
            << invalid length of record in text file >>        <<06426>>03330000
            begin errn := 61; go to lx; end;                   <<b0.01>>03332000
         end                                                   <<b0.01>>03334000
      else                                                              03336000
         begin                                                          03338000
         @p := @sbuf;                                                   03340000
         fread(filen,sbuf,512); <<get first block>>            <<01549>>03342000
         tos := sbuf(510);                                     <<01549>>03344000
         tos := sbuf(511);                                     <<01549>>03346000
         fline := tos - 1d;  <<record num of first record>>    <<01549>>03348000
         fcontrol(filen,5,temp); <<rewind file>>               <<01549>>03350000
<<>>                                                           <<01549>>03352000
         p := -1;                                                       03354000
         end;                                                           03356000
      while p = -1 do                                                   03358000
         begin                                                          03360000
         if not read'dir'flag then                             <<b0.01>>03362000
         begin                                                 <<b0.01>>03364000
         fread(filen,sbuf,512);                                         03366000
         if <> then    << file read error >>                   <<06426>>03368000
            begin errn := 26; fcheck(filen,errf); goto lx; end;         03370000
         sbline := fline+1d;                                            03372000
         add'block'entry;                                      <<b0.01>>03374000
         blockno := blockno + 1d;                              <<b0.01>>03376000
         end                                                   <<b0.01>>03378000
         else begin                                            <<b0.01>>03380000
              read'dir'flag := false;                          <<b0.01>>03382000
              freaddir(filen,sbuf,512,blockno);                <<b0.01>>03384000
              if <> then     << file read error >>             <<06426>>03386000
            begin errn:=26; fcheck(filen,errf); go to lx;end;  <<b0.01>>03388000
              sbline := fline := recno;                        <<b0.01>>03390000
                fline := fline - 1d;                           <<01549>>03392000
              end;                                             <<b0.01>>03394000
         @p := @sbuf;                                                   03396000
         end;                                                           03398000
      @sp := @p;                                                        03400000
      if not file'formsmsg then                                <<b0.01>>03402000
         if sp(2) = 3 <<fopen>> then                           <<b0.01>>03404000
            move new'bufw := sp,((sp+3)/2);                    <<b0.01>>03406000
         if sp(3) = 4 <<fclose>> and eofflag then              <<b0.01>>03408000
            begin                                              <<b0.01>>03410000
            eofflag := false;                                  <<b0.01>>03412000
            endline := toline := fline + 1d;                   <<b0.01>>03414000
            end;                                               <<b0.01>>03416000
      fline := fline+1d;                                                03418000
li:                                                                     03420000
      flinecnt := sp-8;                                                 03422000
      if not skan then endline := fline;                                03424000
      critflag := false; if controlyflag then controlyproc;    <<b0.00>>03426000
      critflag := true;                                        <<b0.00>>03428000
      end;                                                              03430000
   skantoline := true;                                                  03432000
lx:                                                                     03434000
   end;                                                                 03436000
$page                                                          <<04145>>03438000
$control segment=spook2                                                 03440000
                                                                        03442000
logical procedure listrange(skan);                                      03444000
   value   skan;                                                        03446000
   logical skan;                                                        03448000
   begin                                                                03450000
   integer ix,iy,ct,ctl,lsp,nx;                                         03452000
   logical uni,found;                                                   03454000
   array cl(0:7);                                                       03456000
   byte pointer bsp;                                                    03458000
   byte pointer bcl;                                                    03460000
   logical fdevctl;                                            <<01726>>03462000
    integer length;                                            <<01726>>03464000
   define func = sp(2)#,                                       <<01726>>03466000
          p1   = sp(3)#,                                       <<01726>>03468000
          p2   = sp(4)#,                                       <<01726>>03470000
          len  = sp(0)#;                                       <<01726>>03472000
                                                               <<04145>>03474000
   define                                                      <<04145>>03476000
      list'command = not skan#,                                <<04145>>03478000
      find'command =     skan#;                                <<04145>>03480000
                                                               <<01726>>03482000
   << >>                                                                03484000
   uni := true;                                                         03486000
   fdevctl := false;                                           <<01726>>03488000
   @bcl := @cl&asl(1);                                                  03490000
   nx := dascii(eofline,10,bcl);                                        03492000
   do                                                                   03494000
      begin                                                             03496000
       found := false;                                         <<04145>>03498000
      if uni then                                                       03500000
         uni := false                                                   03502000
      else                                                              03504000
         if not skantoline(false) then goto lx;                         03506000
      @bcl := @cl&asl(1);                                               03508000
      @bsp := @sp(5)&asl(1);                                            03510000
      lsp := flinecnt;                                                  03512000
      obuf := "  ";                                                     03514000
      move obuf(1) := obuf,(127);                                       03516000
      ix := 0;                                                          03518000
      ct := dascii(fline,10,bcl);                                       03520000
      move bobuf(ix+nx-ct) := bcl,(ct);                                 03522000
      ix := ix+nx+1;                                                    03524000
      ctl := sp(3);                                                     03526000
      if ctl = 1 and func = 1 then                             <<01886>>03528000
         begin                                                          03530000
         ctl := sp(5).(0:8);                                            03532000
         lsp := lsp-1;                                                  03534000
         @bsp := @bsp+1;                                                03536000
         end;                                                           03538000
      if fall then                                                      03540000
         begin                                                          03542000
          if func >= %200 then                                 <<01726>>03544000
          begin  <<fdevicecontrol>>                            <<01726>>03546000
             fdevctl := true;                                  <<01726>>03548000
             move bobuf(ix) := "FDEVICECONTROL FUNC=";         <<01726>>03550000
             ix := ix + 21;                                    <<01726>>03552000
             ascii(func,10,bcl);                               <<01726>>03554000
             move bobuf(ix) := bcl   , (3);                    <<01726>>03556000
             ix := ix + 4;                                     <<01726>>03558000
             move bobuf(ix) := "P1=% ";                        <<01726>>03560000
             ix := ix + 5;                                     <<01726>>03562000
             ascii(p1,8,bcl);                                  <<01726>>03564000
             move bobuf(ix) := bcl , (6);                      <<01726>>03566000
             ix := ix + 7;                                     <<01726>>03568000
             move bobuf(ix) := "P2=% ";                        <<01726>>03570000
             ix := ix + 5;                                     <<01726>>03572000
             ascii(p2,8,bcl);                                  <<01726>>03574000
             move bobuf(ix) := bcl , (6);                      <<01726>>03576000
             ix := ix + 7;                                     <<01726>>03578000
             move bobuf(ix) := "LEN= ";                        <<01726>>03580000
             ix := ix + 5;                                     <<01726>>03582000
             length := ascii(len,10,bcl);                      <<01726>>03584000
             move bobuf(ix) := bcl   , (length);               <<01726>>03586000
             ix := ix + 7;                                     <<01726>>03588000
                                                               <<01726>>03590000
             case func - 128 of                                <<01726>>03592000
             begin                                             <<01726>>03594000
                   <<128>>                                     <<01726>>03596000
                move bobuf(ix) :=                              <<01726>>03598000
                    "Select Primary/Secondary Character Set";  <<01726>>03600000
                   <<129>>                                     <<01726>>03602000
                move bobuf(ix) :=                              <<01726>>03604000
                    "Select Logical Pages/Forms            ";  <<01726>>03606000
                   <<130>>                                     <<01726>>03608000
                move bobuf(ix) :=                              <<01726>>03610000
                    "Move Pen Relative                     ";  <<01726>>03612000
                   <<131>>                                     <<01726>>03614000
                move bobuf(ix) :=                              <<01726>>03616000
                    "Move Pen Absolute                     ";  <<01726>>03618000
                   <<132>>                                     <<01726>>03620000
                move bobuf(ix) :=                              <<01726>>03622000
                    "Define Job Characteristics            ";  <<01726>>03624000
                   <<133>>                                     <<01726>>03626000
                move bobuf(ix) :=                              <<01726>>03628000
                    "Download Physical Page Definition     ";  <<01726>>03630000
                   <<134>>                                     <<01726>>03632000
                move bobuf(ix) :=                              <<01726>>03634000
                    "Download/Delete Character Set         ";  <<01726>>03636000
                   <<135>>                                     <<01726>>03638000
                move bobuf(ix) :=                              <<01726>>03640000
                    "Download/Delete Forms                 ";  <<01726>>03642000
                   <<136>>                                     <<01726>>03644000
                move bobuf(ix) :=                              <<01726>>03646000
                    "Download Logical Page Table           ";  <<01726>>03648000
                   <<137>>                                     <<01726>>03650000
                move bobuf(ix) :=                              <<01726>>03652000
                    "Download Multi-Copy Form Overlay Table";  <<01726>>03654000
                   <<138>>                                     <<01726>>03656000
                move bobuf(ix) :=                              <<01726>>03658000
                    "Download/Delete VFC                   ";  <<01726>>03660000
            end;  <<case>>                                     <<01726>>03662000
            ix := ix + 39;                                     <<01726>>03664000
        end                                                    <<01726>>03666000
        else                                                   <<01726>>03668000
        begin                                                  <<01726>>03670000
         ascii(ctl,8,bcl);                                              03672000
         case sp(2) of                                                  03674000
            begin                                                       03676000
            <<0>>                                                       03678000
            move bobuf(ix) := "W";                                      03680000
            <<1>>                                                       03682000
               begin                                                    03684000
               move bobuf(ix) := "W";                                   03686000
               if ctl <> 0 then                                         03688000
                  begin                                                 03690000
                  bobuf(ix+1) := "%";                                   03692000
                  move bobuf(ix+2) := bcl(3),(3);                       03694000
                  end;                                                  03696000
               end;                                                     03698000
            <<2>>                                                       03700000
               begin                                                    03702000
               move bobuf(ix) := "C";                                   03704000
               if ctl <> 0 then                                         03706000
                  begin                                                 03708000
                  bobuf(ix+1) := "%";                                   03710000
                  move bobuf(ix+2) := bcl(3),(3);                       03712000
                  end;                                                  03714000
               end;                                                     03716000
            <<3>>                                                       03718000
            move bobuf(ix) := "FOPEN";                                  03720000
            <<4>>                                                       03722000
            move bobuf(ix) := "FCLOSE";                                 03724000
            end;                                                        03726000
         ix := ix+7;                                                    03728000
                           end;                                <<01726>>03730000
         end;                                                           03732000
         if lsp > 256 or lsp < 0 then                          <<01326>>03734000
         begin  <<invalid length>>                             <<01326>>03736000
            errn := 61;                                        <<01326>>03738000
            go to lx;                                          <<01326>>03740000
         end;                                                  <<01326>>03742000
      if fdevctl then lsp := 0                                 <<01726>>03744000
      else                                                     <<01726>>03746000
      move bobuf(ix) := bsp,(lsp);                                      03748000
      fdevctl := false;                                        <<01726>>03750000
      ct := lsp+ix;                                                     03752000
      if find'command then                                     <<04145>>03754000
         begin                                                          03756000
         bobuf(ct+1) := cr ;                                   <<04145>>03758000
         scan bobuf(ix) while %6440,1;                                  03760000
         ix := tos-@bobuf;                                              03762000
         bobuf(ct+1) := " ";                                            03764000
         iy := ix;                                                      03766000
         while iy <= (ct+1-fstring) do                                  03768000
            begin                                                       03770000
            if bfstr = bobuf(iy),(fstring) then                         03772000
               begin                                                    03774000
               found := true;                                           03776000
               toline := fline;                                <<04459>>03778000
               iy := ct+1;                                              03780000
               end;                                                     03782000
            if not fstrall then iy := ct+1;                    <<04459>>03784000
            iy := iy+1;                                                 03786000
            end;                                                        03788000
         end;                                                           03790000
      critflag := false; if controlyflag then controlyproc;    <<b0.00>>03792000
      if list'command or found then                            <<04145>>03794000
         begin                                                          03796000
         if fwidth <> 0 then                                            03798000
            if ct > fwidth then ct := fwidth;                           03800000
         if ct > 256 or ct < 0 then                            <<b0.01>>03802000
            << invalid record length in text file >>           <<06426>>03804000
            begin errn := 61; go to lx; end;                   <<b0.01>>03806000
         iy := -1;                                                      03808000
         while (iy:=iy+1) < ct do                                       03810000
            if not (%40<=integer(bobuf(iy))<=%176) then        <<b0.01>>03812000
               bobuf(iy) := ".";                                        03814000
         print(obuf,-ct,0);                                             03816000
         if find'command and not fstrall                       <<04145>>03818000
            then toline := fline;                              <<04145>>03820000
         end;                                                           03822000
      critflag := true;                                        <<b0.00>>03824000
      end                                                               03826000
   until fline >= toline;                                               03828000
   if toline < eofline then                                    <<04145>>03830000
      begin                                                             03832000
      toline := toline+1d;                                              03834000
      if not skantoline(false) then goto lx;                            03836000
      end;                                                              03838000
   listrange := true;                                                   03840000
lx:                                                                     03842000
   end;                                                                 03844000
$page                                                          <<04145>>03846000
$control segment=spook2                                        <<b0.00>>03848000
                                                               <<b0.00>>03850000
logical procedure shiftupper(string,count);                    <<b0.00>>03852000
                                                               <<04145>>03854000
<<*************************************************>>          <<04145>>03856000
<< this procedure upshifts alphanumeric string     >>          <<04145>>03858000
<< except for quantities enclosed in quotes.       >>          <<04145>>03860000
<< if a quote occurs within the string it must     >>          <<04145>>03862000
<< be a double quote:                              >>          <<04145>>03864000
<< for example "STRING IS QUOTE = "" IS ALLOWED "  >>          <<b0.00>>03866000
<<*************************************************>>          <<04145>>03868000
                                                               <<04145>>03870000
<<>>                                                           <<b0.00>>03872000
                                                               <<b0.00>>03874000
byte array string;                                             <<b0.00>>03876000
integer count;                                                 <<b0.00>>03878000
                                                               <<b0.00>>03880000
begin                                                          <<b0.00>>03882000
integer i, firstquote,secondquote,diff;                        <<b0.00>>03884000
equate quote = %42;                                            <<b0.00>>03886000
equate crquote = %6442;                                        <<b0.00>>03888000
<<>>                                                           <<b0.00>>03890000
shiftupper := true;                <<initialize>>              <<b0.00>>03892000
i := 0;                                                        <<b0.00>>03894000
do                                                             <<b0.00>>03896000
  begin  <<upshift alphanumerics >>                            <<b0.00>>03898000
    move string(i) := string(i) while ans,1;                   <<b0.00>>03900000
    assemble(dup);                                             <<b0.00>>03902000
    if string(i := tos - @string) = quote then                 <<b0.00>>03904000
         <<look for quote if >>                                <<b0.00>>03906000
      begin               << not alphanumeric>>                <<b0.00>>03908000
        firstquote := tos;             <<we found first quote>><<b0.00>>03910000
scan1:  scan string(i := i+1) until crquote,1;                 <<b0.00>>03912000
        secondquote := tos;           <<we found second quote>><<b0.00>>03914000
        if carry then                  <<if end of string>>    <<b0.00>>03916000
          begin                <<undelimited string>>          <<b0.00>>03918000
            errn := 42; shiftupper := false;                   <<b0.00>>03920000
          end                                                  <<b0.00>>03922000
        else                                                   <<b0.00>>03924000
          begin                                                <<b0.00>>03926000
            diff := secondquote - firstquote;                  <<b0.00>>03928000
            i := i + diff;                                     <<b0.00>>03930000
            if  string(i) = quote then                         <<b0.00>>03932000
               begin    << if another quote >>                 <<b0.00>>03934000
           << immediately follows then keep scanning>>         <<b0.00>>03936000
                 i := i+1;  <<for terminal quote>>             <<b0.00>>03938000
                 if string(i) = cr then  <<unless last quote>> << 7784>>03940000
                   begin  << last quote in string, not paired>><< 7784>>03942000
                     errn := 42;  <<undelimited string>>       << 7784>>03944000
                     shiftupper := false;                      << 7784>>03946000
                   end                                         << 7784>>03948000
                 else                                          << 7784>>03950000
                   go to scan1;                                << 7784>>03952000
               end;                                            <<b0.00>>03954000
          end;                                                 <<b0.00>>03956000
      end;                                                     <<b0.00>>03958000
  end                                                          <<b0.00>>03960000
until (i := i + 1) >= count;   <<stop at carriage return>>     <<b0.00>>03962000
                                                               <<b0.00>>03964000
                                                               <<b0.00>>03966000
end;                                                           <<b0.00>>03968000
$page "* * * SPOOLOPEN * * *"                                 <<<x7801>>03970000
$control segment=spook2                                                 03972000
                                                                        03974000
<<---------------------------------------------------------->> <<x7801>>03976000
<< logical procedure spoolopen returns true if it success-  >> <<x7801>>03978000
<< fully opens the old spoolfile described in devf.  it re- >> <<x7801>>03980000
<< turns (in filef) the aft entry number of the opened      >> <<x7801>>03982000
<< spoofle.  the relevant xdd subentry is placed in xddbuf. >> <<x7801>>03984000
<< the spoofle is checked to see if it is present and ready.>> <<x7801>>03986000
<< if so, the spool state is set to locked and the spoofle  >> <<x7801>>03988000
<< is opened.  the record number of the first non-purged    >> <<x7801>>03990000
<< extent is saved in fline.  the file is rewound.          >> <<x7801>>03992000
<<---------------------------------------------------------->> <<x7801>>03994000
                                                               <<x7801>>03996000
logical procedure spoolopen(devf,filef);                       <<b0.01>>03998000
   value devf;                                                 <<b0.01>>04000000
   integer devf,filef;                                         <<b0.01>>04002000
                                                               <<b0.01>>04004000
   begin                                                                04006000
   logical pointer                                             <<x7786>>04008000
      xdd'subentry;                                            <<x7786>>04010000
   integer                                                     <<x7786>>04012000
      temp,                                                    <<x7786>>04014000
      save'xdd'sir;                                            <<x7786>>04016000
   << >>                                                                04018000
   save'xdd'sir := getsir(if devf<0 then odd'sir else idd'sir);<<x7786>>04020000
   @xdd'subentry := @xddbuf;                                   <<x7786>>04022000
   xddx := 0;                                                           04024000
   if copyxdd(devf) then                                                04026000
      begin                                                             04028000
      xddx.is'odd := devf.is'odd;                              <<x7786>>04030000
      if xdds'spool'state = xdds'ready then                    <<x7786>>04032000
         lockxdd(xddx);                                        <<x7786>>04034000
      end;                                                              04036000
   relsir(if devf<0 then odd'sir else idd'sir,save'xdd'sir);   <<x7786>>04038000
   if xddx = 0 then                                                     04040000
      << file not found >>                                     <<06426>>04042000
      begin errn := 31; goto lx; end;                                   04044000
   if not (xdds'spool'state) then                              <<x7786>>04046000
      << file not ready >>                                     <<06426>>04048000
      begin errn := 28; goto lx; end;                                   04050000
                                                               <<x7786>>04052000
<< open the spoolfile with the following:                   >> <<x7786>>04054000
<<    foptions - ascii, old permanent                       >> <<x7786>>04056000
<<    aoptions - nobuf, read only                           >> <<x7786>>04058000
                                                               <<x7786>>04060000
   filef := fsopen(,%305,%400,xddx);                                    04062000
   if <> then                                                           04064000
      << unable to open file >>                                <<06426>>04066000
      begin errn := 29; fcheck(filef,errf); goto lx; end;               04068000
   fread(filef,sbuf,512); <<read first block>>                 <<01549>>04070000
   <<store recnum of first non-purged extent in>>              <<01549>>04072000
   <<fline for future use and then rewind file>>               <<01549>>04074000
   tos := sbuf(510);                                           <<01549>>04076000
   tos  := sbuf(511);                                          <<01549>>04078000
   fline := tos - 1d;  <<recnum of beginning of file>>         <<01549>>04080000
   fcontrol(filef,5,temp);  <<rewind file>>                    <<01549>>04082000
   spoolopen := true;                                                   04084000
lx:                                                                     04086000
   end;                                                                 04088000
$page "* * * GETMODE * * *"                                    <<x7786>>04090000
$control segment=spook1                                                 04092000
                                                                        04094000
logical procedure getmode;                                              04096000
   begin                                                                04098000
   integer tw,tc;                                                       04100000
   integer ct,z,num;                                                    04102000
   logical flag;                                                        04104000
   << >>                                                                04106000
   tw := fwidth;                                                        04108000
   tc := fall;                                                          04110000
   while bp <> cr  do                                          <<04145>>04112000
      begin                                                             04114000
      errn := 43;   << invalid option name >>                  <<06426>>04116000
      move bp := bp while as,1;                                         04118000
      ct := tos-@bp;                                                    04120000
      if not (1<=ct<=msize) then goto lx;                               04122000
      z := 0;                                                           04124000
      while (z<mnum) and (bp<>mmode(z*msize),(ct)) do                   04126000
         z := z+1;                                                      04128000
      if z = mnum then goto lx;                                         04130000
      if bp(ct) <> "=" then                                             04132000
         << invalid option separator >>                        <<06426>>04134000
         begin errn := 44; goto lx; end;                                04136000
      @bp := @bp+ct+1;                                                  04138000
      errn := 45;    << invalid option parameter >>            <<06426>>04140000
      flag := false;                                                    04142000
      num := -1;                                                        04144000
      if bp = alpha then                                                04146000
         begin                                                          04148000
         if bp = "ON" then                                              04150000
            begin                                                       04152000
            flag := true;                                               04154000
            @bp := @bp+2;                                               04156000
            end                                                         04158000
         else                                                           04160000
            if bp = "OFF" then                                          04162000
               begin                                                    04164000
               flag := false;                                           04166000
               @bp := @bp+3;                                            04168000
               end                                                      04170000
            else                                                        04172000
               goto lx;                                                 04174000
         end                                                            04176000
      else                                                              04178000
         begin                                                          04180000
         if not getdnum then goto lx;                                   04182000
         if dnum < 0d then                                              04184000
            dnum := -dnum                                               04186000
         else                                                           04188000
            dnum := dnum&dasl(1);                                       04190000
         if dnum0 <> 0 then goto lx;                                    04192000
         num := dnum1;                                                  04194000
         end;                                                           04196000
      case z of                                                         04198000
         begin                                                          04200000
         <<0>>                                                          04202000
         if num >= 0 then                                               04204000
            tw := num                                                   04206000
         else                                                           04208000
            if not flag then                                            04210000
               tw := 0                                                  04212000
            else goto lx;                                               04214000
         <<1>>                                                          04216000
         if num < 0 then                                                04218000
            tc := flag                                                  04220000
         else                                                           04222000
            goto lx;                                                    04224000
         end;                                                           04226000
      errn := 0;                                                        04228000
      if bp = "," then @bp := @bp+1;                                    04230000
      end;                                                              04232000
   fwidth := tw;                                                        04234000
   fall := tc;                                                          04236000
   getmode := true;                                                     04238000
lx:                                                                     04240000
   end;                                                                 04242000
$page "* * * GETALTER * * *"                                   <<x7801>>04244000
$control segment=spook1                                                 04246000
<<---------------------------------------------------------->> <<06426>>04248000
<< getalter is called by the main command loop to parse the >> <<06426>>04250000
<< parameters specified in the command string of an alter   >> <<06426>>04252000
<< command.  options are: pri, copies, and dev.             >> <<06426>>04254000
<< note that getdevinfo is called to return information     >> <<x7801>>04256000
<< about a device (bp) in array info.  info(0) contains the >> <<x7801>>04258000
<< numerical value of ldev or the dct index of a class, and >> <<x7801>>04260000
<< is the parameter that spooleddev is called with to re-   >> <<x7801>>04262000
<< trieve spooling information.                             >> <<x7801>>04264000
<<---------------------------------------------------------->> <<x7801>>04266000
                                                                        04268000
logical procedure getalter;                                             04270000
   begin                                                                04272000
   integer ct,z;                                                        04274000
   integer array info(0:12);                                   <<x7786>>04276000
   << >>                                                                04278000
   pri := 0;                                                            04280000
   copies := 0;                                                         04282000
   class := 0;                                                 <<x7786>>04284000
   device := 0;                                                <<x7786>>04286000
   while bp <> cr  do                                          <<04145>>04288000
      begin                                                             04290000
      errn := 43;     << invalid option name >>                <<06426>>04292000
      move bp := bp while as,1;                                         04294000
      ct := tos-@bp;                                                    04296000
      if not (1<=ct<=asize) then goto lx;                               04298000
      z := 0;                                                           04300000
      while (z<anum) and (bp<>aalter(z*asize),(ct)) do                  04302000
         z := z+1;                                                      04304000
      if z = anum then goto lx;                                         04306000
      if bp(ct) <> "=" then                                             04308000
         << invalid option separator >>                        <<06426>>04310000
         begin errn := 44; goto lx; end;                                04312000
      @bp := @bp+ct+1;                                                  04314000
      errn := 45;   << invalid option parameter >>             <<06426>>04316000
      case z of                                                         04318000
         begin                                                          04320000
         <<0>>       << priority >>                            <<06426>>04322000
            begin                                                       04324000
            if not getdnum then goto lx;                                04326000
            if dnum < 0d then goto lx;                                  04328000
            if dnum0 <> 0 then goto lx;                                 04330000
            if not (1<=dnum1<=13) then goto lx;                         04332000
            pri := dnum1;                                               04334000
            end;                                                        04336000
         <<1>>       << number of copies >>                    <<06426>>04338000
            begin                                                       04340000
            if not getdnum then goto lx;                                04342000
            if dnum < 0d then goto lx;                                  04344000
            if dnum0 <> 0 then goto lx;                                 04346000
            if not (1<=dnum1<=127) then goto lx;                        04348000
            copies := dnum1;                                            04350000
            end;                                                        04352000
         <<2>>       << device >>                              <<06426>>04354000
            begin                                                       04356000
            if (getdevinfo(bp,info) <> 0) then                 <<x7786>>04358000
               goto lx;   << unknown or virtual ldev >>        <<x7786>>04360000
            if spooleddev(info).(14:2) = 0 then                <<x7786>>04362000
               goto lx;   <<spoolq's shut, not output spooler>><<x7786>>04364000
            if bp = "+" or bp = "-" then @bp := @bp+1;                  04366000
            move bp := bp while ans,1;                                  04368000
            @bp := tos;                                                 04370000
            if info < 0 then <<device is class index into dct>><<x7786>>04372000
               begin                                           <<x7786>>04374000
               device := -info;                                <<x7786>>04376000
               class := 1;                                     <<x7786>>04378000
               end                                             <<x7786>>04380000
            else                                               <<x7786>>04382000
               device := info;                                 <<x7786>>04384000
            end;                                                        04386000
         end;                                                           04388000
      errn := 0;                                                        04390000
      if bp = "," then @bp := @bp+1;                                    04392000
      end;                                                              04394000
   getalter := true;                                                    04396000
lx:                                                                     04398000
   end;                                                                 04400000
$page "* * * ALTERXDD * * *"                                   <<x7786>>04402000
$control segment=spook2                                                 04404000
                                                                        04406000
<<******************a l t e r x d d ************************>> <<04145>>04408000
<< alterxdd is sent a device file id.  it calls copyxdd to  >> <<04145>>04410000
<< copy an xdd entry into stack.  if then changes one to all>> <<04145>>04412000
<< of the following before copying the entry back into the  >> <<04145>>04414000
<< xdd: number of copies, priority, and device.             >> <<04145>>04416000
<<**********************************************************>> <<04145>>04418000
                                                               <<04145>>04420000
logical procedure alterxdd(devf);                              <<b0.01>>04422000
   value devf;                                                 <<b0.01>>04424000
   integer devf;                                               <<b0.01>>04426000
                                                               <<b0.01>>04428000
   begin                                                                04430000
   logical pointer xdd'subentry;                               <<x7786>>04432000
   logical rlink;                                                       04434000
   integer                                                     <<06426>>04436000
      save'ldt'sir,                                            <<x7786>>04438000
      save'xdd'sir,                                            <<x7786>>04440000
      class'dev;                                               <<x7786>>04442000
   << >>                                                                04444000
subroutine def'movetodseg;                                     <<x7786>>04446000
   rlink := false;                                                      04448000
   @xdd'subentry := @xddbuf;                                   <<x7786>>04450000
   xddx := 0;                                                           04452000
   save'ldt'sir := getsir(ldt'sir);                            <<06426>>04454000
   save'xdd'sir := getsir(if devf<0 then odd'sir else idd'sir);<<x7786>>04456000
                                                               <<04145>>04458000
   <<*******************************************************>> <<04145>>04460000
   << copy the xdd entry onto stack and change the local    >> <<04145>>04462000
   << values to copies, pri or cldev if specified.          >> <<04145>>04464000
   <<*******************************************************>> <<04145>>04466000
                                                               <<04145>>04468000
   if not copyxdd(devf) then                                            04470000
      << file not found >>                                     <<06426>>04472000
      begin errn := 31; goto lx; end;                                   04474000
   if xdds'spool'state = xdds'active then                      <<x7786>>04476000
      << file not ready/open >>                                <<06426>>04478000
      begin errn := 47; goto lx; end;                                   04480000
   if copies <> 0 then                                                  04482000
      odds'number'copies := copies;                            <<x7786>>04484000
   if pri <> 0 then                                                     04486000
      begin                                                             04488000
      old'pri := xdds'output'priority; << save old priority >> <<x7786>>04490000
      xdds'output'priority := pri;                             <<x7786>>04492000
      rlink := true;                                                    04494000
      end;                                                              04496000
   if device <> 0 then                                         <<x7786>>04498000
      begin                                                             04500000
      xdds'class := class;                                     <<x7786>>04502000
      xdds'device := device;                                   <<x7786>>04504000
      rlink := true;                                                    04506000
      end;                                                              04508000
                                                               <<04145>>04510000
   <<*******************************************************>> <<04145>>04512000
   << if we have changed the device of an odd entry, then   >> <<04145>>04514000
   << we must relink the odd via srelinkodd because the odd >> <<04145>>04516000
   << is ordered by ldev and class name.                    >> <<04145>>04518000
   <<*******************************************************>> <<04145>>04520000
                                                               <<04145>>04522000
                                                               <<04145>>04524000
   <<*******************************************************>> <<04145>>04526000
   << now copy the changed xdd entry back to the odd or idd.>> <<04145>>04528000
   << the offset of the entry in the xdd is pointed to by   >> <<04145>>04530000
   << xddx, set by copyxdd, and the stack array is pointed  >> <<04145>>04532000
   << to by xdd, set in the calling procedure.              >> <<04145>>04534000
   <<*******************************************************>> <<04145>>04536000
                                                               <<04145>>04538000
   movetodseg (if devf < 0 then odd'dst else idd'dst,          <<x7786>>04540000
               xddx, @xddbuf, size'of'xdd'subentry);           <<x7786>>04542000
                                                               <<x7786>>04544000
   if rlink and devf < 0 then                                  <<x7786>>04546000
      begin                                                    <<x7786>>04548000
      @xdd'subentry := xddx;                                   <<x7786>>04550000
      exchangedb(odd'dst);                                     <<x7786>>04552000
      class'dev := xdds'device;                                <<x7786>>04554000
      if xdds'class then                                       <<x7786>>04556000
         class'dev := -class'dev;                              <<x7786>>04558000
      srelinkodd(xdd'subentry, class'dev);                     <<x7786>>04560000
      exchangedb(0);                                           <<x7786>>04562000
      relsir(odd'sir,save'xdd'sir);   << release sir >>        <<x7786>>04564000
      srooster(class'dev);                                     <<x7786>>04566000
   alterxdd := true;                                           <<01.02>>04568000
   go to lx1;     <<bypass repeat of relsir>>                  <<01.02>>04570000
<<  >>                                                         <<01.02>>04572000
      end;                                                              04574000
   alterxdd := true;                                                    04576000
lx:                                                                     04578000
   relsir(if devf<0 then odd'sir else idd'sir,save'xdd'sir);   <<x7786>>04580000
lx1:                                                           <<01.02>>04582000
   relsir(ldt'sir,save'ldt'sir);                               <<06426>>04584000
   end;                                                                 04586000
$page "* * * FINDODD * * *"                                    <<x7786>>04588000
$control segment=spook2                                        <<01.02>>04590000
integer procedure findodd(xddnum);                             <<01.02>>04592000
value xddnum;                                                  <<01.02>>04594000
integer xddnum;                                                <<01.02>>04596000
begin                                                          <<01.02>>04598000
<<  >>                                                         <<01.02>>04600000
      << procedure added 6/20/77         >>                    <<01.02>>04602000
   logical pointer                                             <<x7786>>04604000
      xdd'subentry;                                            <<x7786>>04606000
                                                               <<x7786>>04608000
   @xdd'subentry := xddnum.idnum;                              <<x7786>>04610000
   exchangedb(odd'dst);                                        <<x7786>>04612000
   tos:=xdds'device;                                           <<x7786>>04614000
      if xdds'class then tos:=-tos;                            <<x7786>>04616000
      exchangedb(0);                                           <<01.02>>04618000
      findodd:=tos;                                            <<01.02>>04620000
      end;                                                     <<01.02>>04622000
$page "* * * GETFILES * * *"                                   <<x7786>>04624000
                                                               <<x7786>>04626000
<<**********************************************************>> <<04145>>04628000
<<  getfiles obtains the device files from the command      >> <<04145>>04630000
<< string and sets up the array devfs via getdevf.  the     >> <<04145>>04632000
<< value of shw depends on what is allowed and what type of >> <<04145>>04634000
<< file id we are dealing with, input or output.  showio is >> <<04145>>04636000
<< set in this procedure and it signifies what types of     >> <<04145>>04638000
<< files we are dealing with.  if bit 15 of showio is on,   >> <<04145>>04640000
<< we have at least one output dev. id, if 14 is on we have >> <<04145>>04642000
<< at least one input dev. id.                              >> <<04145>>04644000
<<                                                          >> <<04145>>04646000
<<    command        shw            allowed        type     >> <<04145>>04648000
<<   show             1     dfid,user.account,*    i & o    >> <<04145>>04650000
<<   output & copy    2     dfid,user.account,*    o only   >> <<04145>>04652000
<<   purge            3     dfid,*                 o only   >> <<04145>>04654000
<<   alter            4     dfid,user.account,*    o only   >> <<04145>>04656000
<<   input            0     dfid,user.account      o only   >> <<04145>>04658000
<<**********************************************************>> <<04145>>04660000
                                                               <<04145>>04662000
$control segment=spook1                                                 04664000
                                                                        04666000
logical procedure getfiles(shw);                                        04668000
   value   shw;                                                         04670000
   logical shw;                                                         04672000
   begin                                                                04674000
     logical nofiles;                                          <<04145>>04676000
   << >>                                                                04678000
   devfc := 0;                                                          04680000
                                                               <<04145>>04682000
   <<*******************************************************>> <<04145>>04684000
   << if the command sting gives a list of device id's or a >> <<04145>>04686000
   << "*", then obtain all the device id's in the list.     >> <<04145>>04688000
   <<*******************************************************>> <<04145>>04690000
                                                               <<04145>>04692000
   if bp = "#" or bp = "*" or bp = numeric then                         04694000
      begin                                                             04696000
      << set both odds and idds bits to 0 >>                   <<x7786>>04698000
      showio := 0;                                                      04700000
      do                                                                04702000
         begin                                                          04704000
         if integer(shw)=0 and bp="*" then                              04706000
            << text file not allowed >>                        <<06426>>04708000
            begin errn:=48; goto lx; end;                               04710000
         if not getdevf then goto lx;                                   04712000
         tos := if devf < 0 then 1 else 2;                              04714000
         showio := showio lor tos;                                      04716000
         nofiles:=true;                                        <<04145>>04718000
         if bp = "," then                                               04720000
            begin                                                       04722000
            nofiles:=false;                                    <<04145>>04724000
            @bp := @bp+1;                                               04726000
            end;                                                        04728000
         end                                                            04730000
      until nofiles;                                           <<04145>>04732000
      showf := true;                                                    04734000
      end                                                               04736000
$page                                                          <<04145>>04738000
                                                               <<04145>>04740000
   <<*******************************************************>> <<04145>>04742000
   <<  if the string gives a user.account obtains it via    >> <<04145>>04744000
   << getusad. (3 is sent by purge, user.account is illegal >> <<04145>>04746000
   << for purge.)  then, if we have the show command (shw   >> <<04145>>04748000
   << has value 1) and a ";" follows, look for "@","O" and/ >> <<04145>>04750000
   << or "I".  "@" signifies show all information and the   >> <<04145>>04752000
   << flag showf is set to true.  if no user.account is     >> <<04145>>04754000
   << specified and we have alter command, return error.    >> <<04145>>04756000
   <<*******************************************************>> <<04145>>04758000
                                                               <<04145>>04760000
   else                                                                 04762000
      begin                                                             04764000
      if shw = 3 then                                                   04766000
         << user.account not allowed for purge >>              <<06426>>04768000
         begin errn := 56; goto lx; end;                                04770000
      if (bp = ";" or bp = cr) and shw = 4 then                <<04145>>04772000
         << missing dfid or user.account >>                    <<06426>>04774000
         begin errn := 80; goto lx; end;                       <<04145>>04776000
      if not getusac then goto lx;                                      04778000
      showio := if shw then 3 else 1;                                   04780000
      showf := false;                                                   04782000
      if shw and bp = ";" then                                          04784000
         begin                                                          04786000
         do                                                             04788000
            begin                                                       04790000
            @bp := @bp+1;                                               04792000
            if bp = "@" then showf := true                              04794000
            else if bp = "I" then showio := showio land 2               04796000
                 else if bp = "O" then showio := showio land 1          04798000
                      else if bp <> cr  then                   <<04145>>04800000
                              << unexpected character >>       <<06426>>04802000
                              begin errn:=33; goto lx; end;             04804000
            end                                                         04806000
         until bp = cr ;                                       <<04145>>04808000
         if showio = 0 then showio := 3;                                04810000
         end;                                                           04812000
      end;                                                              04814000
                                                               <<04145>>04816000
   <<*******************************************************>> <<04145>>04818000
   << set showio to output only  unless we are using the    >> <<04145>>04820000
   << "SHOW" command, the only one that uses input dev. id's>> <<04145>>04822000
   <<*******************************************************>> <<04145>>04824000
                                                               <<04145>>04826000
   if integer(shw) <> 1 then showio := 1;                               04828000
   getfiles := true;                                                    04830000
lx:                                                                     04832000
   end;                                                                 04834000
                                                                        04836000
$page "* * * MOVEFROMXDD * * *"                                <<x7801>>04838000
<<**********************************************************>> <<04145>>04840000
<< movefromxdd moves all the significant entries for the    >> <<04145>>04842000
<< output and/or input device directories into the area be- >> <<04145>>04844000
<< tween db-2048 and dl(expanding it via dlsize as needed), >> <<04145>>04846000
<< or db-0 and dl, depending on the command being executed. >> <<04145>>04848000
<< it finds the entries that have device id's in the array  >> <<04145>>04850000
<< devfs or qualify via our user.account in snames.  based  >> <<04145>>04852000
<< on showio, it will search the idd and/or odd.  the xdd   >> <<04145>>04854000
<< entries are stored as follows:                           >> <<04145>>04856000
<<           dl----->----------                             >> <<04145>>04858000
<<                   |        |                             >> <<04145>>04860000
<<                   ~        ~                             >> <<04145>>04862000
<<                   |--------|<-----db-initxddp-96         >> <<x7786>>04864000
<<                   |  xdd3  |                             >> <<04145>>04866000
<<                   |--------|<-----db-initxddp-64         >> <<x7786>>04868000
<<                   |  xdd2  |                             >> <<04145>>04870000
<<                   |--------|<-----db-initxddp-32         >> <<x7786>>04872000
<<                   |  xdd1  |                             >> <<04145>>04874000
<<     initxddp----->|--------|                             >> <<04145>>04876000
<< (db-2048 or db-0) ~        ~                             >> <<04145>>04878000
<<                   |        |                             >> <<04145>>04880000
<<           db----->|--------|                             >> <<04145>>04882000
<<                                                          >> <<04145>>04884000
<<  we search the array devfs for odd's in the first pass,  >> <<x7801>>04886000
<<  and idd's in the second pass.  1 or 2 passes will be    >> <<x7801>>04888000
<<  executed, depending on the value of showio.             >> <<x7801>>04890000
<<                                                          >> <<04145>>04892000
<<   showio        passes executed                          >> <<x7801>>04894000
<<  %2(11) i&o       passes 1 & 2                           >> <<x7801>>04896000
<<     01  o only    pass 1 only                            >> <<x7801>>04898000
<<     10  i only    pass 2 only                            >> <<x7801>>04900000
<<                                                          >> <<04145>>04902000
<<  first obtain proper sir. turn to bit of devf on for o   >> <<04145>>04904000
<<  and off for i.                                          >> <<04145>>04906000
<<**********************************************************>> <<04145>>04908000
                                                               <<04145>>04910000
$control segment=spook2                                                 04912000
                                                                        04914000
logical procedure movefromxdd;                                 <<04145>>04916000
   begin                                                                04918000
   integer count;                                              <<04145>>04920000
   integer                                                     <<x7786>>04922000
      save'xdd'sir,                                            <<x7786>>04924000
      pass;                                                    <<x7786>>04926000
   logical                                                     <<x7786>>04928000
      error,                                                   <<x7786>>04930000
      more'xdds,                                               <<x7786>>04932000
      copy'it,                                                 <<x7786>>04934000
      found=movefromxdd;  <<signify at least one found >>      <<x7786>>04936000
   logical pointer xdd'subentry;                               <<x7786>>04938000
   << >>                                                                04940000
   movefromxdd := false;                                       <<04145>>04942000
   file'found := true;                                         <<04145>>04944000
   pass := 1;                                                  <<x7786>>04946000
   xddc := 0;                                                           04948000
   @xdd'subentry := initxddp;                                  <<x7786>>04950000
   error := false;                                             <<04145>>04952000
   while (pass <= 2) and (not error) do                        <<x7786>>04954000
      begin                                                             04956000
     << search for odd's in first pass, idd's in second pass >><<x7786>>04958000
      if (pass=1 land showio.odds) lor                         <<x7786>>04960000
         (pass=2 land showio.idds) then                        <<x7786>>04962000
         begin                                                 <<x7786>>04964000
         save'xdd'sir := getsir(if pass=1 then odd'sir         <<x7786>>04966000
                                          else idd'sir);       <<x7786>>04968000
         devf.is'odd := if pass=1 then 1 else 0;               <<x7786>>04970000
         count := -1;                                          <<x7786>>04972000
                                                               <<x7786>>04974000
      <<****************************************************>> <<04145>>04976000
      << do until and error or until there are still device >> <<04145>>04978000
      << id's in the array devfs for which to copy thier xdd>> <<04145>>04980000
      << entry (done via copyxdd).                          >> <<04145>>04982000
      <<****************************************************>> <<04145>>04984000
                                                               <<04145>>04986000
      do                                                                04988000
         begin                                                          04990000
         more'xdds := (devfc <> 0);                            <<x7786>>04992000
         copy'it := true;                                      <<x7786>>04994000
         if more'xdds then                                     <<x7786>>04996000
            begin                                                       04998000
            copy'it := false;                                  <<x7786>>05000000
            while (not copy'it) and (count+1 < devfc) do       <<x7786>>05002000
               begin                                                    05004000
               count := count + 1;                             <<x7786>>05006000
               devf := devfs(count);                           <<x7786>>05008000
               if (devf<0 land pass=1) lor   << want odd's >>  <<x7786>>05010000
                  (devf>0 land pass=2) then  << want idd's >>  <<x7786>>05012000
                  copy'it := true;                             <<x7786>>05014000
               end;                                            <<x7786>>05016000
            more'xdds := copy'it;                              <<x7786>>05018000
            end;   << if more'xdds >>                          <<x7786>>05020000
         xddx := 0;                                                     05022000
         while copy'it do                                      <<x7786>>05024000
            begin                                                       05026000
            tos := copyxdd(devf);                                       05028000
            if not tos then                                             05030000
               copy'it := false                                <<x7786>>05032000
            else    << successfully copied xdd >>              <<x7786>>05034000
               begin                                                    05036000
               xddc := xddc+1;                                          05038000
               @xdd'subentry := @xdd'subentry -                <<x7786>>05040000
                                 size'of'xdd'subentry;         <<x7786>>05042000
                                                               <<04145>>05044000
         <<*************************************************>> <<04145>>05046000
         <<  if, after updating the address of the xdd en-  >> <<04145>>05048000
         << tries (xddpoint), it is set before dl (dl>@xddp)>> <<04145>>05050000
         << then expand dl via dlsize and check for errors. >> <<04145>>05052000
         <<*************************************************>> <<04145>>05054000
                                                               <<04145>>05056000
         ll:                                                            05058000
               push(dl);                                                05060000
               if s0 > @xdd'subentry then                      <<x7786>>05062000
                  begin                                                 05064000
                  dlsize(s0-512);                                       05066000
                  if = then                                             05068000
                     begin                                              05070000
                     del;                                               05072000
                     goto ll;                                           05074000
                     end                                                05076000
                  else    << error in expanding dl area >>     <<x7786>>05078000
                     begin                                              05080000
                     warn := 3;                                         05082000
                     error := true;                            <<04145>>05084000
                     copy'it := false;                         <<x7786>>05086000
                     xddc := xddc-1;                                    05088000
                     @xdd'subentry := @xdd'subentry +          <<x7786>>05090000
                                      size'of'xdd'subentry;    <<x7786>>05092000
                     end;                                               05094000
                  end;   << if s0 > @xdd'subentry >>           <<x7786>>05096000
               del;                                                     05098000
               end;                                                     05100000
                                                               <<04145>>05102000
             <<*********************************************>> <<04145>>05104000
             << if we copied an xdd entry, blank out the    >> <<04145>>05106000
             << link pointer, then zero out the entry in    >> <<x7786>>05108000
             << our devfs array.                            >> <<x7786>>05110000
             <<*********************************************>> <<04145>>05112000
                                                               <<04145>>05114000
            if copy'it then                                    <<x7786>>05116000
              begin                                            <<x7786>>05118000
              xddbuf(xd'errs) := 0;                            <<x7786>>05120000
              move xdd'subentry:=xddbuf,(size'of'xdd'subentry);<<x7786>>05122000
              devfs(count) := 0;                               <<x7786>>05124000
              movefromxdd := true;                             <<x7786>>05126000
              end;                                             <<x7786>>05128000
            if more'xdds then copy'it := false;                <<x7786>>05130000
            end;    << while copy'it do >>                     <<x7786>>05132000
         end     << do >>                                      <<x7786>>05134000
      until not more'xdds or error;                            <<x7786>>05136000
      relsir(if pass=1 then odd'sir else idd'sir,save'xdd'sir);<<x7786>>05138000
      end;      << if pass=1 and odds, or pass=2 and idds >>   <<x7786>>05140000
      pass := pass + 1;                                        <<x7786>>05142000
   end;     << while pass <= 2 and not error >>                <<x7786>>05144000
                                                               <<04145>>05146000
   if found                                                    <<04145>>05148000
      then userf := acctf := false                             <<04145>>05150000
      else if userf or acctf                                   <<04145>>05152000
           then file'found := false;                           <<04145>>05154000
                                                               <<04145>>05156000
   end;                                                                 05158000
$page "* * * SHOWFILES * * *"                                  <<x7786>>05160000
                                                                        05162000
$control segment=spook2                                                 05164000
                                                                        05166000
procedure showfiles;                                                    05168000
   begin                                                                05170000
   integer c;                                                           05172000
   logical pointer xdd'subentry;                               <<x7786>>05174000
   << >>                                                                05176000
   if xddc > 0 then                                                     05178000
      begin                                                             05180000
      showp := false;                                                   05182000
      do                                                                05184000
         begin                                                          05186000
         if showp then print(mshwx,29,0)                                05188000
         else if showf then print(mshow,29,0)                           05190000
                       else print(mshows,19,0);                         05192000
         c := 0;                                                        05194000
         @xdd'subentry := initxddp;                            <<x7786>>05196000
         while (c:=c+1) <= xddc do                                      05198000
            begin                                                       05200000
            @xdd'subentry :=@xdd'subentry-size'of'xdd'subentry;<<x7786>>05202000
            move xddbuf := xdd'subentry,(size'of'xdd'subentry);<<x7786>>05204000
            tos := 0;                                                   05206000
            if showp then tos.(15:1) := 1;                              05208000
            if showf then tos.(14:1) := 1;                              05210000
            showxdd(*,0);                                               05212000
            end;                                                        05214000
         showp := showp+1;                                              05216000
         end                                                            05218000
      until not showp or not showf;                                     05220000
      end;                                                              05222000
   end;                                                                 05224000
$page "* * * OPENTAPE * * *"                                   <<x7801>>05226000
                                                               <<x7801>>05228000
<<**********************************************************>> <<04145>>05230000
<< opentape is called by the input and output commands to   >> <<04145>>05232000
<< open the tape file to read from or write to.  out=1 for  >> <<04145>>05234000
<< the output command and 0 for the input command.  note    >> <<x7801>>05236000
<< that "FILET" is the file number (aft entry number) of    >> <<x7801>>05238000
<< the opened tape file.                                    >> <<x7801>>05240000
<<**********************************************************>> <<04145>>05242000
                                                               <<04145>>05244000
$control segment=spook3                                                 05246000
                                                                        05248000
logical procedure opentape(out);                                        05250000
   value   out;                                                         05252000
   logical out;                                                         05254000
   begin                                                                05256000
   integer c,p;                                                         05258000
   integer f,a,r,d,b;                                                   05260000
   integer fx,ax,rx,dx,bx,ld;                                           05262000
   integer sdisc;                                              <<b0.00>>05264000
   << >>                                                                05266000
   subroutine eofin;                                                    05268000
      begin                                                             05270000
      fread(filet,sbuf,1);                                              05272000
      if < then goto closet;                                   <<x7786>>05274000
      if = then goto badfmt;                                   <<x7786>>05276000
      end;                                                              05278000
   << >>                                                                05280000
   subroutine eofout;                                                   05282000
      begin                                                             05284000
      fcontrol(filet,6,p);   << write eof >>                   <<x7786>>05286000
      if <> then goto closet;                                  <<x7786>>05288000
      end;                                                              05290000
   << >>                                                                05292000
                                                               <<04145>>05294000
   <<*******************************************************>> <<04145>>05296000
   << fopen the tape file with the following parms:         >> <<04145>>05298000
   << foption - undef. recs,ascii, no labled tapes, domain= >> <<04145>>05300000
   <<           new file for out, old perm. for input.      >> <<04145>>05302000
   << aoption - nobuf, exclusive, read for in, write for out>> <<04145>>05304000
   << record size - 1024 words.                             >> <<04145>>05306000
   <<*******************************************************>> <<04145>>05308000
                                                               <<04145>>05310000
   errn := 0;                                                  <<x7786>>05312000
   f:= if out then %204 else %205;                            <<b0.00>> 05314000
   a := out lor %500;                                                   05316000
   r := 1024;                                                           05318000
   d := 24;                                                             05320000
   sdisc := 31;    <<serial disc>>                             <<b0.00>>05322000
   b := 1024;                                                           05324000
   if bp = cr  then                                            <<04145>>05326000
      << invalid tape file >>                                  <<06426>>05328000
      begin errn := 52; goto quickout; end;                    <<x7786>>05330000
   filet := fopen(bp,f,a,r);                                            05332000
   if <> then                                                           05334000
      << unable to open tape file >>                           <<06426>>05336000
      begin errn := 50; fcheck(filet,errf); goto quickout; end;<<x7786>>05338000
$page                                                          <<04145>>05340000
                                                               <<04145>>05342000
   <<*******************************************************>> <<04145>>05344000
   << since a file command can over-ride the above parms,   >> <<04145>>05346000
   << check for compatibility.                              >> <<04145>>05348000
   <<  rec. and block size - convert to words.              >> <<04145>>05350000
   <<*******************************************************>> <<04145>>05352000
                                                               <<04145>>05354000
   fgetinfo(filet,,fx,ax,rx,dx,ld,,,,,,,,bx);                           05356000
   if rx < 0 then rx := (-rx)&asr(1);                                   05358000
   if bx < 0 then bx := (-bx)&asr(1);                                   05360000
                                                               <<04145>>05362000
   <<*******************************************************>> <<04145>>05364000
   << now check for foption,aoption,rec. and block size     >> <<04145>>05366000
   << compatibiltiy.  also, check for proper type, 24 for   >> <<04145>>05368000
   << mag tape or 31 for serial disc.                       >> <<04145>>05370000
   <<*******************************************************>> <<04145>>05372000
                                                               <<04145>>05374000
   if f<>fx or a<>ax or r<>rx or b<>bx                         <<b0.00>>05376000
      or not((d=dx.(8:8)) lor (sdisc = dx.(8:8))) then         <<00897>>05378000
      << invalid tape file >>                                  <<06426>>05380000
      begin errn := 52; goto closet; end;                      <<x7786>>05382000
   mreel(11) := "  ";                                                   05384000
   mreel(12) := "  ";                                                   05386000
   ascii(ld,10,mreel(11));                                              05388000
   reel := 1;                                                           05390000
   eotmark := false;                                                    05392000
   lastreel := false;                                                   05394000
   fileend := true;                                                     05396000
                                                               <<04145>>05398000
   <<*******************************************************>> <<04145>>05400000
   << for input, first skip over 2 eof's via eofin.  next,  >> <<04145>>05402000
   << read 40 word label record.  compare reel number on    >> <<04145>>05404000
   << tape with reel and check words 0-13 for tapeid. lastly>> <<04145>>05406000
   << obtain date and time and skip over next eof.          >> <<04145>>05408000
   <<*******************************************************>> <<04145>>05410000
                                                               <<04145>>05412000
   if not out then                                                      05414000
      begin                                                             05416000
      eofin;                                                            05418000
      eofin;                                                            05420000
      tcount := fread(filet,tbuf,41);                                   05422000
      if <> then goto badread;                                 <<x7786>>05424000
      if tcount <> 40 then goto badfmt;                        <<x7786>>05426000
      if integer(l0reel) <> reel then goto badfmt;             <<x7786>>05428000
      c := -1;                                                          05430000
      while (c:=c+1)<14 do                                     <<x7786>>05432000
         if tbuf(c) <> tapeid(c) then goto badfmt;             <<x7786>>05434000
      date := l0date;                                          <<x7786>>05436000
      time1 := l0time1;                                        <<x7786>>05438000
      time2 := l0time2;                                        <<x7786>>05440000
      mpe5tape := true;                                        <<x7786>>05442000
      c := -1;                                                 <<x7786>>05444000
      while (c:=c+1) < 2 do                                    <<x7786>>05446000
         if tbuf(c+30) <> tapempev(c) then mpe5tape := false;  <<x7786>>05448000
      eofin;                                                            05450000
      end                                                               05452000
$page                                                          <<04145>>05454000
                                                               <<04145>>05456000
   <<*******************************************************>> <<04145>>05458000
   << for output, we set up the beginnig of the tape:       >> <<04145>>05460000
   <<      eof,eof,                                         >> <<04145>>05462000
   <<      label record contains:                           >> <<04145>>05464000
   <<          words 0-13: "SPOOLFILETAPE LABEL-HP3000."    >> <<04145>>05466000
   <<          word   23 : reel number (1 to last)          >> <<04145>>05468000
   <<          word   24 : date                             >> <<04145>>05470000
   <<          words 25-26: time                            >> <<04145>>05472000
   <<          words 30-31: "MPEV" if it's a mpe5 spook tape>> <<x7786>>05474000
   <<      all other words zero.                            >> <<04145>>05476000
   <<*******************************************************>> <<04145>>05478000
                                                               <<04145>>05480000
   else                                                                 05482000
      begin                                                             05484000
      tbuf := 0;                                                        05486000
      move tbuf(1) := tbuf,(39);                                        05488000
      move l0spookid := tapeid,(14);                           <<x7786>>05490000
      l0reel := reel;                                          <<x7786>>05492000
      date := calendar;                                                 05494000
      time := clock;                                                    05496000
      l0date := date;                                          <<x7786>>05498000
      l0time1:= time1;                                         <<x7786>>05500000
      l0time2:= time2;                                         <<x7786>>05502000
      if ldt'mpe'version = 5 then                              <<x7786>>05504000
         move l0mpe5 := tapempev, (2);                         <<x7786>>05506000
      eofout;                                                           05508000
      eofout;                                                           05510000
      fwrite(filet,tbuf,40,0);                                          05512000
      if <> then goto badwrite;                                <<x7786>>05514000
      eofout;                                                           05516000
      end;                                                              05518000
                                                               <<x7786>>05520000
   opentape := true;                                                    05522000
   goto quickout;                                              <<x7786>>05524000
badfmt:                                                        <<x7786>>05526000
   << invalid tape format >>                                   <<06426>>05528000
   errn := 53;                                                          05530000
   goto closet;                                                <<x7786>>05532000
badread:   << tape file read error >>                          <<x7786>>05534000
   errn := 54;                                                 <<x7786>>05536000
   goto closet;                                                <<x7786>>05538000
badwrite:  << tape file write error >>                         <<x7786>>05540000
   errn := 55;                                                 <<x7786>>05542000
closet:                                                        <<x7786>>05544000
   fclose(filet,1,0);                                          <<02724>>05546000
   filet := 0;                                                          05548000
quickout:                                                      <<x7786>>05550000
   end;                                                                 05552000
$page "* * * INDIRECTORY * * *"                                <<x7786>>05554000
$control segment=spook3                                                 05556000
                                                                        05558000
<<----------------------------------------------------------->><<06426>>05560000
<< indirectory is called by the main loop when an input com- >><<06426>>05562000
<< mand is encountered in the command string.  it reads in   >><<06426>>05564000
<< the file directory entries from the spook tape for the    >><<06426>>05566000
<< files to be input.  i don't know what else it's doing...  >><<06426>>05568000
<<----------------------------------------------------------->><<06426>>05570000
                                                               <<06426>>05572000
logical procedure indirectory;                                          05574000
   begin                                                                05576000
   integer                                                     <<06426>>05578000
      lpdt'index,                                              <<06426>>05580000
      ldt'index,                                               <<06426>>05582000
      ldev,                                                    <<06426>>05584000
      hits,                                                    <<x7786>>05586000
      new'ldev,                                                <<x7786>>05588000
      max'hits,                                                <<x7786>>05590000
      num'devs,                                                <<06426>>05592000
      dev'type,                                                <<06426>>05594000
      dev'count,                                               <<06426>>05596000
      entry'size,                                              <<x7786>>05598000
      n, m,                                                    <<i7784>>05600000
      i, ix;                                                   <<06426>>05602000
   logical no'more;                                            <<x7786>>05604000
      logical match;                                           <<i7784>>05606000
   logical pointer xdd'subentry;                               <<x7786>>05608000
   integer pointer dcp;                                                 05610000
   integer pointer dptr;                                       <<02686>>05612000
   logical pointer                                             <<06426>>05614000
      ldt,                                                     <<06426>>05616000
      dct,                                                     <<06536>>05618000
      dct'head;                                                <<06536>>05620000
   integer array advc(*)=q;  <<last decl>>                              05622000
   << >>                                                                05624000
$page                                                          <<x7786>>05626000
<<----------------------------------------------------------->><<06426>>05628000
<< test'ldev checks to see how the current logical device    >><<06426>>05630000
<< entry in the system ldt compares with the logical device  >><<06426>>05632000
<< entry in the spook tape directory.  the return value of   >><<06426>>05634000
<< test'ldev depends on how many of the following fields     >><<06426>>05636000
<< match:  device type, subtype, and record width.           >><<06426>>05638000
<< (assuming this is a real device).                         >><<06426>>05640000
<< note:  db is at ldt'dst when this subroutine is called.   >><<06426>>05642000
<<----------------------------------------------------------->><<06426>>05644000
                                                               <<06426>>05646000
   integer subroutine test'ldev;                               <<06426>>05648000
      begin                                                             05650000
      ldt'index := ldev * size'of'ldt'entry;                   <<06426>>05652000
      lpdt'index := ldev * size'of'lpdt'entry;                 <<06426>>05654000
      if advc(2).(10:6)=integer(ldt'device'type) then          <<06426>>05656000
         begin                                                 <<06426>>05658000
         test'ldev := 1;                                       <<06426>>05660000
         if advc(1).(0:8)=integer(lpdt'subtype) then           <<06426>>05662000
            begin                                                       05664000
            test'ldev := 2;                                    <<06426>>05666000
            if advc(2).(0:8)=integer(ldt'record'width) then    <<06426>>05668000
               test'ldev := 3;                                 <<06426>>05670000
            end;                                                        05672000
         end;                                                           05674000
      if lpdt'virtual'device or (lpdt'dit'ptr = 0)  then       <<06426>>05676000
            test'ldev := 0;  <<illegal or virtual>>            <<06426>>05678000
      end;                                                              05680000
   << >>                                                                05682000
$page                                                          <<x7786>>05684000
<<----------------------------------------------------------->><<06426>>05686000
<< test'class is given an dct entry.  for each ldev in the   >><<06426>>05688000
<< dct entry, it looks up its device type in the system ldt, >><<06426>>05690000
<< and searches for a matching device type in the array advc.>><<06426>>05692000
<< the return value of test'class depends on how many of the >><<06426>>05694000
<< device characteristics matched:                           >><<06426>>05696000
<<        0:  nothing matched                                >><<06426>>05698000
<<        1:  only type matched                              >><<06426>>05700000
<<        2:  type and class name matched                    >><<06426>>05702000
<< note:  db is at dct'dst when the subroutine is called.    >><<06536>>05704000
<< db must be switched to ldt'dst temporarily to get the     >><<06536>>05706000
<< device type.                                              >><<06536>>05708000
<<----------------------------------------------------------->><<06426>>05710000
                                                               <<06426>>05712000
   integer subroutine test'class;                              <<06426>>05714000
      begin                                                             05716000
      @ldt := 0;                                               <<06536>>05718000
      hits := 0;                                               <<x7786>>05720000
      dev'count := 0;                                          <<06536>>05722000
      while dev'count < integer(dct'num'devices) do            <<06536>>05724000
         begin                                                          05726000
         ldev := integer( dct(dev'count + dct'first'ldev) );   <<06536>>05728000
         ldt'index := ldev * size'of'ldt'entry;                <<06426>>05730000
         exchangedb(ldt'dst);                                  <<06536>>05732000
         dev'type := ldt'device'type;                          <<06426>>05734000
         exchangedb(dct'dst);                                  <<06536>>05736000
         num'devs := advc(7);                                  <<06426>>05738000
         while (num'devs := num'devs-1) >= 0 do                <<06426>>05740000
            if advc(8+num'devs) = dev'type then                <<06426>>05742000
               hits := hits + 1;                               <<x7786>>05744000
         dev'count := dev'count+1;                             <<06426>>05746000
         end;                                                           05748000
      if hits <> 0 then                                        <<x7786>>05750000
         begin   << try to match class name >>                 <<06426>>05752000
         hits := 0;                                            <<x7786>>05754000
         dev'count := 4;                                       <<06426>>05756000
         while (dev'count:=dev'count-1) >= 0 do                <<06426>>05758000
           if integer(dct(dev'count)) <> advc(2+dev'count) then<<06426>>05760000
               hits := hits + 1;                               <<x7786>>05762000
      test'class := if hits = 0 then 2 else 1;                 <<x7786>>05764000
         end;                                                           05766000
      end;                                                              05768000
   << >>                                                       <<02686>>05770000
$page                                                          <<x7786>>05772000
<<----------------------------------------------------------->><<06426>>05774000
<< gettype is given an ldev number (ldev) which is an entry  >><<06426>>05776000
<< within the device class entry of the spook tape directory.>><<06426>>05778000
<< it then searches the logical device entries in the same   >><<06426>>05780000
<< directory to find the matching ldev, and returns its      >><<06426>>05782000
<< device type.                                              >><<06426>>05784000
<<----------------------------------------------------------->><<06426>>05786000
                                                               <<06426>>05788000
   integer subroutine gettype;                                 <<02686>>05790000
      begin                                                    <<02686>>05792000
      gettype:=0;                                              <<02686>>05794000
      @dptr:=initxddp;                                         <<02686>>05796000
      while dptr<>0 do                                         <<02686>>05798000
         begin                                                 <<02686>>05800000
         if dptr=ldev then                                     <<06426>>05802000
            begin                                              <<02686>>05804000
            gettype:=dptr(2).(10:6);                           <<02686>>05806000
            return;                                            <<02686>>05808000
            end;                                               <<02686>>05810000
         if dptr > 0 then   << ldev entry >>                   <<x7786>>05812000
            @dptr := @dptr + ldev'entrysize                    <<x7786>>05814000
         else               << class entry >>                  <<x7786>>05816000
            @dptr := @dptr + dptr(1);                          <<x7786>>05818000
         end;                                                  <<02686>>05820000
      end;                                                     <<02686>>05822000
                                                               <<06426>>05824000
$page                                                          <<x7786>>05826000
   << begin procedure indirectory >>                           <<06426>>05828000
   xddc := 0;                                                           05830000
   @xdd'subentry := initxddp;                                  <<x7786>>05832000
   file'match := false;                                        <<i7784>>05834000
   file'found := true;                                         <<04329>>05836000
   no'more := false;                                           <<x7786>>05838000
                                                               <<06426>>05840000
<<---------------------------------------------------------->> <<x7801>>05842000
<< file directory entries are 12 words long, and are padded >> <<x7801>>05844000
<< into as many 1020-word records as necessary.  they will  >> <<x7801>>05846000
<< be read into the db- area.  each 12 word entry will be   >> <<x7801>>05848000
<< placed into a xdd subentry size slot (30 or 32 words).   >> <<x7801>>05850000
<< this is to reserve space for the xdd subentries which    >> <<x7801>>05852000
<< will overlay them later in procedure infiles.            >> <<x7801>>05854000
<<---------------------------------------------------------->> <<x7801>>05856000
   do                                                                   05858000
      begin                                                             05860000
      tcount := fread(filet,sbuf,1024);                                 05862000
      if < then goto badread;                                  <<06426>>05864000
      if > then goto badfmt;                                   <<06426>>05866000
      if tcount <> fdir'recsize then                           <<x7786>>05868000
         no'more := true                                       <<x7786>>05870000
      else                                                              05872000
         begin                                                          05874000
         ix := 0;                                                       05876000
         do                                                             05878000
            begin                                                       05880000
            if sbuf(ix) = 0 then                                        05882000
               no'more := true                                 <<x7786>>05884000
            else                                                        05886000
               begin                                                    05888000
               xddc := xddc+1;                                          05890000
               @xdd'subentry := @xdd'subentry -                <<x7786>>05892000
                                 size'of'xdd'subentry;         <<x7786>>05894000
         ll:                                                            05896000
               push(dl);                                                05898000
               if s0 > @xdd'subentry then                      <<x7786>>05900000
                  begin                                                 05902000
                  dlsize(s0-512);                                       05904000
                  if = then                                             05906000
                     begin                                              05908000
                     del;                                               05910000
                     goto ll;                                           05912000
                     end                                                05914000
                  else                                                  05916000
                     begin                                              05918000
                     warn := 3;                                         05920000
                     no'more := true;                          <<x7786>>05922000
                     xddc := xddc-1;                                    05924000
                     @xdd'subentry := @xdd'subentry +          <<x7786>>05926000
                                       size'of'xdd'subentry;   <<x7786>>05928000
                     end;                                               05930000
                  end;                                                  05932000
               del;                                                     05934000
$page                                                          <<i7784>>05936000
<<---------------------------------------------------------->> <<i7784>>05938000
<< as the file directory entries are being read in, we com- >> <<i7784>>05940000
<< pare it to the dfid's in the array devfs or a matching   >> <<i7784>>05942000
<< user.acct.  file'match is set to true if we find at      >> <<i7784>>05944000
<< least one spoolfile that we're looking for on this tape. >> <<i7784>>05946000
<< if not, we don't scan through the tape later in procedure>> <<i7784>>05948000
<< infiles.                                                 >> <<i7784>>05950000
<<---------------------------------------------------------->> <<i7784>>05952000
                                                               <<i7784>>05954000
               if not no'more then                             <<x7786>>05956000
                  begin                                        <<i7784>>05958000
                  move xdd'subentry:=sbuf(ix),(fdir'entrysize);<<x7786>>05960000
                  if not file'match then                       <<i7784>>05962000
                     if devfc <> 0 then                        <<i7784>>05964000
                        begin                                  <<i7784>>05966000
                        i := -1;                               <<i7784>>05968000
                        while (i:=i+1) < devfc do              <<i7784>>05970000
                           if xdd'subentry = devfs(i) then     <<i7784>>05972000
                              file'match := true;              <<i7784>>05974000
                        end                                    <<i7784>>05976000
                     else                                      <<i7784>>05978000
                        begin                                  <<i7784>>05980000
                        match := true;                         <<i7784>>05982000
                        n := if userf then -1 else 3;          <<i7784>>05984000
                        m := if acctf then 8 else 4;           <<i7784>>05986000
                        while (n:=n+1) < m do                  <<i7784>>05988000
                         if xdd'subentry(4+n) <> snames(n) then<<i7784>>05990000
                           match := false;                     <<i7784>>05992000
                        if match then file'match := true;      <<i7784>>05994000
                        end;                                   <<i7784>>05996000
                  end;                                         <<i7784>>05998000
               end;                                                     06000000
            end                                                         06002000
         until no'more or                                      <<x7786>>06004000
           (ix := ix+fdir'entrysize) >= fdir'recsize;          <<x7786>>06006000
         end;                                                           06008000
      end                                                               06010000
   until no'more;                                              <<x7786>>06012000
                                                               <<06426>>06014000
   << the last 1020 word record may be padded with 0's at   >> <<x7786>>06016000
   << the end.  this loop skips over the 0's portion.       >> <<x7786>>06018000
                                                               <<x7786>>06020000
   while tcount = fdir'recsize do                              <<x7786>>06022000
      begin                                                             06024000
      tcount := fread(filet,sbuf,1024);                                 06026000
      if < then goto badread;                                  <<06426>>06028000
      if > then goto badfmt;                                   <<06426>>06030000
      end;                                                              06032000
                                                               <<06426>>06034000
   << we should now be at the start of the device and class >> <<x7786>>06036000
   << directory, which is contained in one 1024-word record.>> <<x7786>>06038000
                                                               <<x7786>>06040000
   if tcount <> 1024 then goto badfmt;                         <<06426>>06042000
   @dcp := initxddp;                                                    06044000
   move dcp := sbuf,(1024);                                             06046000
                                                               <<x7786>>06048000
   << read in first 2 spoofle blocks >>                        <<x7786>>06050000
   tcount := fread(filet,sbuf,1024);                                    06052000
   if < then goto badread;                                     <<06426>>06054000
   if = then                                                            06056000
      begin                                                             06058000
      if tcount <> 1024 then goto badfmt;                      <<06426>>06060000
      move dcp(1024) := sbuf,(1024);                                    06062000
      tcount := fread(filet,sbuf,1024);                                 06064000
      if < then goto badread;                                  <<06426>>06066000
      if = then goto badfmt;                                   <<06426>>06068000
      end;                                                              06070000
                                                               <<06426>>06072000
   @dcp := initxddp;                                                    06074000
   ix := 0;                                                    <<x7786>>06076000
   while dcp <> 0 do                                                    06078000
      begin                                                             06080000
      if dcp > 0 then                                          <<x7786>>06082000
         entry'size := ldev'entrysize                          <<x7786>>06084000
      else                                                     <<x7786>>06086000
         entry'size := dcp(1);                                 <<x7786>>06088000
      tos := entry'size;                                       <<x7786>>06090000
      assemble(adds 0);                                                 06092000
                                                               <<06426>>06094000
      << move in an entry into advc from the device and class>><<06426>>06096000
      << directory.  it can be a logical device entry or a   >><<06426>>06098000
      << device class entry.                                 >><<06426>>06100000
                                                               <<06426>>06102000
      move advc := dcp, (entry'size);                          <<x7786>>06104000
      new'ldev := 0;                                           <<x7786>>06106000
      max'hits := 0;                                           <<x7786>>06108000
      if advc > 0 then     << it's a ldev entry >>             <<06426>>06110000
         begin                                                          06112000
         @ldt := 0;                                            <<06426>>06114000
         exchangedb(ldt'dst);                                  <<06426>>06116000
         ldev := 1;                                            <<06426>>06118000
                                                               <<06426>>06120000
         << try to find an ldev in the system ldt that      >> <<x7786>>06122000
         << matches as closely as possible the original     >> <<x7786>>06124000
         << ldev the spool file was created for.            >> <<x7786>>06126000
                                                               <<x7786>>06128000
         do                                                             06130000
            begin                                                       06132000
            hits := test'ldev;                                 <<x7786>>06134000
            if hits > max'hits or                              <<x7786>>06136000
              (hits = max'hits land ldev=advc) then            <<x7786>>06138000
            begin                                              <<x7786>>06140000
               max'hits := hits;                               <<x7786>>06142000
               new'ldev := ldev;                               <<x7786>>06144000
            end;                                               <<x7786>>06146000
            end                                                         06148000
         until (ldev := ldev+1) > integer(ldt'num'entries);    <<06426>>06150000
         end                                                   <<x7786>>06152000
      else    << it's a device class entry >>                  <<06426>>06154000
         begin                                                          06156000
         if mpe5tape then dev'count := advc(7)                 <<x7786>>06158000
                     else dev'count := advc(7).(0:8);          <<x7786>>06160000
         tos := dev'count + 8 - entry'size;                    <<x7786>>06162000
         assemble(adds 0);                                              06164000
         advc(1) := dev'count + 8;   << size of advc entry  >> <<x7786>>06166000
         num'devs := dev'count;                                <<06426>>06168000
                                                               <<06426>>06170000
         << find a matching ldev entry in the device and    >> <<x7786>>06172000
         << class directory.                                >> <<x7786>>06174000
                                                               <<06426>>06176000
         while num'devs > 0 do                                 <<06426>>06178000
            begin                                              <<x7786>>06180000
            if mpe5tape then                                   <<x7786>>06182000
               ldev := advc(7+num'devs)                        <<x7786>>06184000
            else   << mpe4 spook tape >>                       <<x7786>>06186000
               ldev := if logical(num'devs) then               <<x7786>>06188000
                          advc(7+(num'devs/2)).(8:8)           <<x7786>>06190000
                       else advc(7+(num'devs/2)).(0:8);        <<x7786>>06192000
                                                               <<i7784>>06194000
            << replace ldev#'s in the device class entry with>><<i7784>>06196000
            << the corresponding device type found in the    >><<i7784>>06198000
            << logical device entry.                         >><<i7784>>06200000
                                                               <<i7784>>06202000
            advc(7+num'devs) := gettype;                       <<06426>>06204000
            num'devs := num'devs-1;                            <<06426>>06206000
            end;                                                        06208000
         advc(7) := dev'count;                                 <<x7786>>06210000
         @dct'head := 0;                                       <<06536>>06212000
         exchangedb(dct'dst);                                  <<06536>>06214000
         @dct := dcth'dct'base;                                <<06536>>06216000
         i := 0;                                               <<06426>>06218000
         while (i:=i+1) <= integer(dcth'num'dct'entries) do    <<06536>>06220000
            begin                                                       06222000
            hits := test'class;                                <<x7786>>06224000
            if hits > max'hits then                            <<x7786>>06226000
               begin max'hits := hits; new'ldev := i; end;     <<x7786>>06228000
            @dct := @dct + integer(dct'next'entry);            <<06426>>06230000
            end;                                                        06232000
         end;                                                           06234000
      exchangedb(0);                                                    06236000
      tos := entry'size;                                       <<x7786>>06238000
      assemble(subs 0);                                                 06240000
      newldevs(ix) := if max'hits=0 then 0 else new'ldev;      <<x7786>>06242000
      @dcp := @dcp + entry'size;                               <<x7786>>06244000
      ix := ix + 1;                                            <<x7786>>06246000
      end;   << while dcp <> 0 >>                              <<x7786>>06248000
   indirectory := true;                                                 06250000
                                                               <<04329>>06252000
   << if user.account was specified, and no files found,    >> <<04329>>06254000
   << then file'found  signifies this.  used in showerrors. >> <<04329>>06256000
                                                               <<04329>>06258000
   if (not file'match) and (userf or acctf)                    <<i7784>>06260000
      then file'found := false;   << no files found u.a     >> <<04329>>06262000
                                                               <<04329>>06264000
   goto quickout;                                              <<06426>>06266000
badfmt:      << invalid tape format >>                         <<06426>>06268000
   errn := 53;                                                          06270000
   goto closeout;                                              <<06426>>06272000
badread:      << unable to open tape file >>                   <<06426>>06274000
   errn := 54;                                                          06276000
closeout:                                                      <<06426>>06278000
   fclose(filet,1,0);                                          <<02724>>06280000
   filet := 0;                                                          06282000
quickout:                                                      <<06426>>06284000
   end;                                                                 06286000
$page "* * * OUTDIRECTORY * * *"                               <<x7786>>06288000
$control segment=spook3                                                 06290000
                                                                        06292000
<<----------------------------------------------------------->><<06426>>06294000
<< outdirectory is called by the main loop when an output    >><<06426>>06296000
<< command is encountered in the commmand string.  it creates>><<06426>>06298000
<< entries in the spook tape directory for the spoofles to   >><<06426>>06300000
<< be output to tape.                                        >><<06426>>06302000
<<----------------------------------------------------------->><<06426>>06304000
                                                               <<06426>>06306000
logical procedure outdirectory;                                         06308000
   begin                                                                06310000
   integer                                                     <<06426>>06312000
      lpdt'index,                                              <<06426>>06314000
      ldt'index,                                               <<06426>>06316000
      ldev,                                                    <<06426>>06318000
      limit,                                                   <<06426>>06320000
      dev'count,                                               <<06426>>06322000
      p,                                                       <<06426>>06324000
      c, ix;                                                   <<06426>>06326000
   logical pointer xdd'subentry;                               <<x7786>>06328000
   logical pointer                                             <<06426>>06330000
      ldt,                                                     <<06426>>06332000
      dct,                                                     <<06536>>06334000
      dct'head;                                                <<06536>>06336000
   integer pointer << pointers to device and class directory >><<06536>>06338000
      dcp,                                                     <<06536>>06340000
      dp,                                                      <<06536>>06342000
      dcptr;                                                   <<06536>>06344000
   << >>                                                                06346000
$page                                                          <<x7786>>06348000
   <<------------------------------------------------------->> <<06426>>06350000
   << got'ldcl searches through the device and class direc- >> <<06426>>06352000
   << tory, and returns true if it finds a matching ldev or >> <<06426>>06354000
   << device class.  it is called to avoid placing duplicate>> <<x7786>>06356000
   << entries in the directory.                             >> <<x7786>>06358000
   <<------------------------------------------------------->> <<x7786>>06360000
                                                               <<x7786>>06362000
   logical subroutine got'ldcl;                                <<06426>>06364000
      begin                                                             06366000
      ix := 0;                                                 <<06426>>06368000
      @dp := initxddp;                                                  06370000
      while (ix:=ix+1) <= dev'count do                         <<06426>>06372000
        begin                                                           06374000
        if dp = ldev then got'ldcl := true;                    <<06426>>06376000
      if dp > 0 then                                           <<x7786>>06378000
         @dp := @dp + ldev'entrysize                           <<x7786>>06380000
      else                                                     <<x7786>>06382000
         @dp := @dp + dp(1);                                   <<x7786>>06384000
        end;                                                            06386000
      end;                                                              06388000
   << >>                                                                06390000
$page                                                          <<x7786>>06392000
   <<------------------------------------------------------->> <<06426>>06394000
   << put'ldev creates a new logical device entry in the    >> <<06426>>06396000
   << spook tape directory.  it extracts the device subtype >> <<06426>>06398000
   << from the lpdt, and the record width and device type   >> <<06426>>06400000
   << from the ldt.  the format of the logical device entry >> <<06426>>06402000
   << is:                                                   >> <<06426>>06404000
   <<                                                       >> <<06426>>06406000
   <<    word 0:  logical device number                     >> <<06426>>06408000
   <<                                                       >> <<06426>>06410000
   <<    word 1:  bits 0:8, device subtype                  >> <<06426>>06412000
   <<             bits 8:8, 3=length of this entry in words >> <<06426>>06414000
   <<                                                       >> <<06426>>06416000
   <<    word 2:  device type                               >> <<06426>>06418000
   <<------------------------------------------------------->> <<06426>>06420000
                                                               <<06426>>06422000
   subroutine put'ldev;                                        <<06426>>06424000
      begin                                                             06426000
      dcp := ldev;                                             <<06426>>06428000
      lpdt'index := ldev * size'of'lpdt'entry;                 <<06426>>06430000
      dcp(1).(0:8) := lpdt'subtype;                            <<06426>>06432000
      dcp(1).(8:8) := ldev'entrysize;                          <<06426>>06434000
      @ldt := 0;                                               <<06426>>06436000
      ldt'index := ldev * size'of'ldt'entry;                   <<06426>>06438000
      exchangedb(ldt'dst);                                     <<06426>>06440000
      tos := ldt(ldt'index+2);                                 <<06426>>06442000
      exchangedb(0);                                                    06444000
                                                               <<06426>>06446000
      << set bits off for cs device, special forms >>          <<06426>>06448000
      tos.(8:2) := 0;                                                   06450000
      dcp(2) := tos;                                                    06452000
      @dcp := @dcp+ldev'entrysize;                             <<06426>>06454000
      dev'count := dev'count+1;                                <<06426>>06456000
      end;                                                              06458000
   << >>                                                                06460000
$page                                                          <<x7786>>06462000
   <<------------------------------------------------------->> <<06426>>06464000
   << put'class creates a new device class entry in the     >> <<06426>>06466000
   << spook tape directory.  it copies the entire entry for >> <<06426>>06468000
   << that class from the device class table.  the format   >> <<06426>>06470000
   << of the device class entry is:                         >> <<06426>>06472000
   <<                                                       >> <<06426>>06474000
   <<    word     0:  device class number (negated).  this  >> <<06426>>06476000
   <<                 is the number of the entry of this    >> <<06426>>06478000
   <<                 device class in the system's dct.     >> <<06426>>06480000
   <<                                                       >> <<06426>>06482000
   <<    word     1:  total number of words in this entry.  >> <<06426>>06484000
   <<                                                       >> <<06426>>06486000
   <<    words 2 on:  the entire contents of the dct entry  >> <<06426>>06488000
   <<                 for this device class.                >> <<06426>>06490000
   <<------------------------------------------------------->> <<06426>>06492000
                                                               <<06426>>06494000
    subroutine put'class;                                      <<06426>>06496000
      begin                                                             06498000
      dcp := ldev;                                             <<06426>>06500000
      @dct'head := 0;                                          <<06536>>06502000
      exchangedb(dct'dst);                                     <<06536>>06504000
      @dct := dcth'dct'base;                                   <<06536>>06506000
      while (ldev:=ldev+1) < 0 do                              <<06426>>06508000
         @dct := @dct + integer(dct'next'entry);               <<06426>>06510000
                                                               <<06426>>06512000
      << copy the entire dct entry onto tos, starting >>       <<06426>>06514000
      << from the back                                >>       <<06426>>06516000
                                                               <<06426>>06518000
      limit := dct'next'entry - 1;                             <<06426>>06520000
      ix := limit;                                             <<06426>>06522000
      do tos := dct(ix) until (ix:=ix-1) < 0;                  <<06426>>06524000
                                                               <<06426>>06526000
      << now copy dct entry from stack into dcp, starting   >> <<06426>>06528000
      << at dcp(2).  comes out in original sequence, as it  >> <<06426>>06530000
      << was put in backwards.  the wonders of stack        >> <<06426>>06532000
      << architecture....                                   >> <<06426>>06534000
                                                               <<06426>>06536000
      exchangedb(0);                                                    06538000
      ix := 0;                                                          06540000
      do dcp(ix+2) := tos until (ix:=ix+1) > limit;            <<06426>>06542000
      dcp(1) := limit+3;   << total no. of words in entry >>   <<06426>>06544000
                                                               <<06426>>06546000
      << for each ldev in the dct entry, see if a logical    >><<06426>>06548000
      << device entry already exists in the spook directory  >><<06426>>06550000
      << (by calling got'ldcl).  if not, create one by       >><<06426>>06552000
      << calling put'ldev.                                   >><<06426>>06554000
                                                               <<06426>>06556000
      << points to "#devices in class" field in dct entry >>   <<06426>>06558000
      @dcptr := @dcp+dct'first'ldev+1;                         <<06536>>06560000
      @dcp := @dcp+limit+3;                                    <<06426>>06562000
      dev'count := dev'count+1;                                <<06426>>06564000
      limit := dcptr;          <<no. of devices in dct entry>> <<06536>>06566000
      ix := 1;                                                          06568000
      do                                                                06570000
         begin                                                          06572000
         ldev := dcptr(ix);                                    <<06536>>06574000
         if not got'ldcl then put'ldev;                        <<06426>>06576000
         end                                                            06578000
      until (ix:=ix+1) > limit;                                <<06426>>06580000
      end;                                                              06582000
   << >>                                                                06584000
$page                                                          <<x7786>>06586000
   << start of procedure outdirectory >>                       <<06426>>06588000
                                                               <<06426>>06590000
<<----------------------------------------------------------->><<06426>>06592000
<< the file directory portion of the spook directory is set  >><<06426>>06594000
<< up here.  it contains one entry for each spoolfile on the >><<06426>>06596000
<< tape.  each entry is 12 words, and entries are packed into>><<06426>>06598000
<< as many 1020-word records as needed.  the last record will>><<06426>>06600000
<< be padded with zeros if necessary.  the entry format is:  >><<06426>>06602000
<<                                                           >><<06426>>06604000
<<   word     0: device file id number (if bit 0 on, output  >><<06426>>06606000
<<                                      spoolfile)           >><<06426>>06608000
<<   words  1-3: zero                                        >><<06426>>06610000
<<   words  4-7: user name                                   >><<06426>>06612000
<<   words 8-11: account name                                >><<06426>>06614000
<<----------------------------------------------------------->><<06426>>06616000
                                                               <<06426>>06618000
   ix := 0;                                                             06620000
   c := 0;                                                              06622000
   @xdd'subentry := initxddp;                                  <<x7786>>06624000
   while (c:=c+1) <= xddc do                                            06626000
      begin                                                             06628000
      @xdd'subentry := @xdd'subentry-size'of'xdd'subentry;     <<x7786>>06630000
      if ix = 0 then                                                    06632000
         begin                                                          06634000
         sbuf := 0;                                                     06636000
         move sbuf(1) := sbuf,(1023);                                   06638000
         end;                                                           06640000
      if xdd'subentry > 0 then                                 <<x7786>>06642000
         begin                                                          06644000
                                                               <<x7786>>06646000
         << set up file directory entry:                    >> <<x7786>>06648000
         <<   copy idd'or'odd bit, and device file id number>> <<x7786>>06650000
         <<   move user name and account name               >> <<x7786>>06652000
                                                               <<x7786>>06654000
         sbuf(ix) := xdds'dfid'all;                            <<x7786>>06656000
         move sbuf(ix+4) := xdds'user'name,(8);                <<x7786>>06658000
         ix := ix+fdir'entrysize;                              <<x7786>>06660000
         end;                                                           06662000
      if ix >= fdir'recsize then                               <<x7786>>06664000
         begin                                                          06666000
         fwrite(filet,sbuf,fdir'recsize,0);                    <<x7786>>06668000
         if <> then goto badwrite;                             <<06426>>06670000
         ix := 0;                                                       06672000
         end;                                                           06674000
      end;                                                              06676000
   if ix > 0 then                                                       06678000
      begin                                                             06680000
      fwrite(filet,sbuf,fdir'recsize,0);                       <<x7786>>06682000
      if <> then goto badwrite;                                <<06426>>06684000
      end;                                                              06686000
$page                                                          <<x7786>>06688000
<<----------------------------------------------------------->><<06426>>06690000
<< the device and class directory is generated here.  it is  >><<06426>>06692000
<< contained in one 1024-word record.  no eof separates this >><<06426>>06694000
<< record from the file directory.  it contains one entry for>><<06426>>06696000
<< each logical device or device class linked to the spool-  >><<06426>>06698000
<< files on the tape.  also, there is an entry for each      >><<06426>>06700000
<< logical device in each class in the directory, whether or >><<06426>>06702000
<< not that ldev was directly referenced by a spoolfile.     >><<06426>>06704000
<< entries are packed into the tape record one after another >><<06426>>06706000
<< in no particular order.                                   >><<06426>>06708000
<<----------------------------------------------------------->><<06426>>06710000
                                                               <<06426>>06712000
   c := 0;                                                              06714000
   dev'count := 0;                                             <<06426>>06716000
   @xdd'subentry := initxddp;                                  <<x7786>>06718000
   @dcp := initxddp;                                                    06720000
   while (c:=c+1) <= xddc do                                            06722000
      begin                                                             06724000
      @xdd'subentry := @xdd'subentry-size'of'xdd'subentry;     <<x7786>>06726000
      if xdd'subentry > 0 then                                 <<x7786>>06728000
         begin                                                          06730000
         ldev := xdds'device;                                  <<x7786>>06732000
         if xdds'class=1 then ldev := -ldev;                   <<x7786>>06734000
         if not got'ldcl then  << entry not already there >>   <<x7786>>06736000
            if ldev > 0 then put'ldev                          <<06426>>06738000
                        else put'class;                        <<06426>>06740000
         end;                                                           06742000
      end;                                                              06744000
   dcp := 0;                                                            06746000
   limit := @dcp-initxddp+1;                                   <<06426>>06748000
   @dcp := initxddp;                                                    06750000
   fwrite(filet,dcp,1024,0);                                            06752000
   if <> then goto badwrite;                                   <<06426>>06754000
   if limit > 1024 then                                        <<06426>>06756000
      begin                                                             06758000
      fwrite(filet,dcp(1024),1024,0);                                   06760000
      if <> then goto badwrite;                                <<06426>>06762000
      end;                                                              06764000
   fcontrol(filet,6,p);     << write eof >>                    <<x7786>>06766000
   if <> then goto badwrite;                                   <<06426>>06768000
   outdirectory := true;                                                06770000
   goto quickout;                                              <<06426>>06772000
badwrite:                                                      <<06426>>06774000
   errn := 55;    << tape file write error >>                  <<06426>>06776000
   fclose(filet,1,0);                                          <<02724>>06778000
   filet := 0;                                                          06780000
quickout:                                                      <<06426>>06782000
   end;                                                                 06784000
$page "* * * VERIFY'BLOCK'STRUCTURE * * *"                     <<x7801>>06786000
$control segment=spook3                                       <<<01549>>06788000
                                                              <<<01549>>06790000
<<---------------------------------------------------------->> <<x7801>>06792000
<< verify'block'structure check to see that the variable-   >> <<x7801>>06794000
<< length records in a spool file block are laid out pro-   >> <<x7801>>06796000
<< perly.  it counts the number of words in each record, and>> <<x7801>>06798000
<< verifies that the end of the data in the block does not  >> <<x7801>>06800000
<< extend into the count information (words 510-511).       >> <<x7801>>06802000
<<---------------------------------------------------------->> <<x7801>>06804000
                                                               <<x7801>>06806000
logical procedure verify'block'structure(buffer,index,numrecs);<<01726>>06808000
                                                              <<sp.mp4>>06810000
   logical array buffer;                                      <<sp.mp4>>06812000
   integer index,numrecs;                                     <<sp.mp4>>06814000
                                                              <<sp.mp4>>06816000
   begin                                                      <<<01549>>06818000
                                                              <<<01549>>06820000
      integer scount := 0;                                    <<<01549>>06822000
      integer rec'len;                                         <<x7786>>06824000
      equate end'of'data = 509;                               <<<01549>>06826000
                                                              <<<01549>>06828000
      verify'block'structure := true;                         <<<01549>>06830000
      numrecs := 0; <<number of records in block>>             <<01726>>06832000
      do                                                      <<<01549>>06834000
      begin                                                   <<<01549>>06836000
         rec'len := buffer(scount);                           <<<01549>>06838000
         index := scount;                                     <<<01549>>06840000
         scount := scount + (rec'len + 3)&asr(1);             <<<01549>>06842000
         numrecs := numrecs + 1;                               <<01726>>06844000
      end                                                     <<<01549>>06846000
      until (scount > end'of'data) or                         <<<01549>>06848000
         (integer(buffer(scount)) = -1);                      <<<01549>>06850000
      if scount > end'of'data then                            <<<01549>>06852000
         verify'block'structure := false;                     <<<01549>>06854000
   end; <<verify'block'structure>>                            <<<01549>>06856000
$page "* * * REWRITE'BLOCK * * *"                              <<x7786>>06858000
                                                              <<<01549>>06860000
$control segment=spook3                                       <<<01549>>06862000
                                                              <<<01549>>06864000
logical procedure rewrite'block(filenum,buffer,index);        <<<01549>>06866000
                                                              <<<01549>>06868000
   value filenum;                                             <<<01549>>06870000
   logical array buffer;                                      <<<01549>>06872000
   integer index,filenum;                                     <<<01549>>06874000
                                                              <<<01549>>06876000
   begin                                                      <<<01549>>06878000
                                                              <<<01549>>06880000
      logical i,j,k;                                          <<<01549>>06882000
                                                              <<<01549>>06884000
      rewrite'block := true;                                  <<<01549>>06886000
      i := buffer(index);                                     <<<01549>>06888000
      buffer(index) := -1;  <<end of block>>                  <<<01549>>06890000
      j := buffer(510); <<store last 2 words before>>         <<<01549>>06892000
      k := buffer(511); <<file sys overlays with >>           <<<01549>>06894000
                        <<record count>>                      <<<01549>>06896000
                                                              <<<01549>>06898000
      fwrite(filenum,buffer,512,0); <<write buffer up to>>    <<<01549>>06900000
       if <> then rewrite'block := false;                     <<<01549>>06902000
                                    <<last record that fits>> <<<01549>>06904000
      buffer(index) := i;                                     <<<01549>>06906000
      buffer(510) := j;                                       <<<01549>>06908000
      buffer(511) := k;                                       <<<01549>>06910000
                                                              <<<01549>>06912000
      move buffer := buffer(index), (512-index);              <<<01549>>06914000
   end;  <<rewrite'block>>                                    <<<01549>>06916000
$page "* * * INFILES * * *"                                    <<x7786>>06918000
$control segment=spook3                                                 06920000
                                                                        06922000
<<---------------------------------------------------------->> <<x7786>>06924000
<< procedure infiles reads in the specified files from the  >> <<x7786>>06926000
<< input spook tape.  for each file, a new spoolfile is     >> <<x7786>>06928000
<< created and an odd entry is linked into the table.       >> <<x7786>>06930000
<<---------------------------------------------------------->> <<x7786>>06932000
                                                               <<x7786>>06934000
logical procedure infiles;                                              06936000
   begin                                                                06938000
   integer c,i,p,d,n,m,dfid;                                   <<x7786>>06940000
   integer ldev,ner,fer,cntx;                                  <<x7786>>06942000
   logical delete,file'end,match,got,gotx;                     <<x7786>>06944000
   logical pointer xdd'subentry;                               <<x7786>>06946000
   integer pointer xddsubp;                                             06948000
   double pointer xdd'dsubentry = xdd'subentry;                <<x7786>>06950000
   integer pointer dcp;                                                 06952000
   integer index,numrecs;                                      <<x7786>>06954000
   logical done;                                               <<x7786>>06956000
   integer numspulabs,j;                                       <<01886>>06958000
   logical past'ulabs;                                         <<01886>>06960000
   << >>                                                                06962000
$page                                                          <<i7784>>06964000
   subroutine def'movefromdseg;                                <<x7786>>06966000
   subroutine nextreel;                                                 06968000
      begin                                                             06970000
      reel := reel+1;                                                   06972000
      l0reel := reel;                                          <<x7786>>06974000
      i := printopreply(mreel,17,0,rbuf,-1);                            06976000
      if brbuf = "N" then goto mrabort;                        <<x7786>>06978000
   rl:                                                                  06980000
      tcount := fread(filet,sbuf,1024);                                 06982000
      if < then goto badread;                                  <<x7786>>06984000
      if > or tcount<>40 or btbuf<>bsbuf,(80) then                      06986000
         begin                                                          06988000
         fcontrol(filet,9,p);                                           06990000
         if <> then goto badread;                              <<x7786>>06992000
         i := printopreply(ereel,18,0,rbuf,-1);                         06994000
         if brbuf = "N" then goto mrabort;                     <<x7786>>06996000
         goto rl;                                                       06998000
         end;                                                           07000000
      fread(filet,sbuf,1024);                                           07002000
      if <= then goto badfmt;                                  <<x7786>>07004000
      end;                                                              07006000
$page                                                          <<x7801>>07008000
   << >>                                                                07010000
<<---------------------------------------------------------->> <<x7801>>07012000
<< subroutine readtape does the actual reading of the tape  >> <<x7801>>07014000
<< into buffer sbuf.  if read1st is true, a 1024-word record>> <<x7801>>07016000
<< is read.  if it's false, we skip to the end of the cur-  >> <<x7801>>07018000
<< rent file before reading.  if a trailer label is encoun- >> <<x7801>>07020000
<< tered, nextreel is called to do a reelswitch.            >> <<x7801>>07022000
<<---------------------------------------------------------->> <<x7801>>07024000
                                                               <<x7801>>07026000
   subroutine readtape(read1st);                               <<x7786>>07028000
      value read1st;                                           <<x7786>>07030000
      logical read1st;                                         <<x7786>>07032000
                                                               <<x7786>>07034000
      begin                                                             07036000
      if lastreel then goto badfmt;                            <<x7786>>07038000
   do                                                          <<x7786>>07040000
   begin                                                       <<x7786>>07042000
      done := true;                                            <<x7786>>07044000
      if read1st then                                          <<x7786>>07046000
         begin                                                          07048000
         if gotx then                                                   07050000
            << we did a previous read to fill up the buffer >> <<x7786>>07052000
            << just retrieve saved byte/word count          >> <<x7786>>07054000
            begin                                                       07056000
            gotx := false;                                              07058000
            tcount := cntx;                                             07060000
            goto out;                                          <<x7786>>07062000
            end;                                                        07064000
         tcount := fread(filet,sbuf,1024);                              07066000
         if < then goto badread;                               <<x7786>>07068000
         if = then goto out;  << still reading in mid-file >>  <<x7786>>07070000
         end                                                            07072000
      else   << skip to end of this file >>                    <<x7786>>07074000
         begin                                                          07076000
         gotx := false;                                                 07078000
         fcontrol(filet,7,p);   << forward to tape mark >>     <<x7786>>07080000
         if <> then goto badread;                              <<x7786>>07082000
         end;                                                           07084000
                                                               <<x7786>>07086000
      tcount := fread(filet,sbuf,1024);                                 07088000
      if <> then goto badread;                                 <<x7786>>07090000
      if tcount <> 40 then  << reading next file >>            <<x7786>>07092000
         begin                                                          07094000
         fileend := true;                                               07096000
         gotx := true;                                                  07098000
         cntx := tcount;                                                07100000
         end                                                            07102000
      else    << at trailer label >>                           <<x7786>>07104000
         begin                                                          07106000
         fileend := (sbuf(21) = 1);                                     07108000
         lastreel := (sbuf(22) = 1);                                    07110000
         fcontrol(filet,9,p);   << rewind/offline >>           <<x7786>>07112000
         if <> then goto badread;                              <<x7786>>07114000
         if not lastreel then                                           07116000
            begin                                                       07118000
            nextreel;                                                   07120000
            if not fileend then done := false;                 <<x7786>>07122000
            end;                                                        07124000
         end;                                                           07126000
   end                                                         <<x7786>>07128000
   until done;                                                 <<x7786>>07130000
      tcount := 0;                                                      07132000
out:                                                           <<x7786>>07134000
      end;                                                              07136000
   << >>                                                                07138000
   subroutine errorset;                                                 07140000
      begin                                                             07142000
      delete := true;                                          <<x7786>>07144000
      xdds'spook'err := ner;                                   <<x7786>>07146000
      xdds'filesys'err := fer;                                 <<x7786>>07148000
      readtape(false);                                                  07150000
      file'end := true;                                        <<x7786>>07152000
      end;                                                              07154000
   << >>                                                                07156000
   subroutine errorfile(a);                                             07158000
      value   a;                                                        07160000
      integer a;                                                        07162000
      begin                                                             07164000
      ner := a;                                                         07166000
      fcheck(filef,fer);                                                07168000
            errf := fer;                                       <<01326>>07170000
      errorset;                                                         07172000
      end;                                                              07174000
   << >>                                                                07176000
   subroutine errorin;                                                  07178000
      begin                                                             07180000
      ner := sbuf;                                                      07182000
      fer := sbuf(1);                                                   07184000
      errorset;                                                         07186000
      end;                                                              07188000
   << >>                                                                07190000
$page                                                          <<x7786>>07192000
<<---------------------------------------------------------->> <<x7786>>07194000
<< subroutine open'newsp first takes the xdd subentry image >> <<x7786>>07196000
<< from the spoolfile being input from tape and modifies    >> <<x7786>>07198000
<< several fields.  it then checks to make sure that a ldev >> <<x7786>>07200000
<< approximately similar to the one the spoolfile was       >> <<x7786>>07202000
<< created on was found on the host system.  sputxdd is then>> <<x7786>>07204000
<< called to link the new xdd subentry into the appropriate >> <<x7786>>07206000
<< device or class chain.  the new spoolfile is then opened.>> <<x7786>>07208000
<<---------------------------------------------------------->> <<x7786>>07210000
                                                               <<x7786>>07212000
   subroutine open'newsp;                                      <<x7786>>07214000
      begin                                                             07216000
      << if the system the spook tape was created on and the>> <<x7786>>07218000
      << one it is being input to are running on different  >> <<x7786>>07220000
      << versions of mpe, the xdd image must be converted.  >> <<x7786>>07222000
                                                               <<x7786>>07224000
      if not mpe5tape then                                     <<x7786>>07226000
         begin                                                 <<x7786>>07228000
         move xdd'subentry := sbuf, (19);                      <<x7786>>07230000
         xdds'copy'info := sbuf(24);                           <<x7786>>07232000
         xdds'show'errs := sbuf(25);                           <<x7786>>07234000
         tos := sbuf(28);                                      <<x7786>>07236000
         tos := sbuf(29);                                      <<x7786>>07238000
         xddsd'ready'time := tos;                              <<x7786>>07240000
         ldev := sbuf(0).(8:8);                                <<x7786>>07242000
         end                                                   <<x7786>>07244000
      else    << system versions match >>                      <<x7786>>07246000
         begin                                                 <<x7786>>07248000
         move xdd'subentry := sbuf, (size'of'xdd'subentry);    <<x7786>>07250000
         ldev := xdds'device;                                  <<x7786>>07252000
         end;                                                  <<x7786>>07254000
                                                               <<x7786>>07256000
      dfid := xdds'dfid'all;                                   <<x7786>>07258000
      if xdds'job'type > 1 then                                <<x7786>>07260000
         xdds'job'type := xdds'job'                            <<x7786>>07262000
      else                                                     <<x7786>>07264000
         xdds'job'type := xdds'session';                       <<x7786>>07266000
      xddsd'disc'label := 0d;                                  <<x7786>>07268000
      xdds'number'extents := 0;                                <<x7786>>07270000
      xdds'virtual'ldev := 0;                                  <<x7786>>07272000
      xdds'last'extent'size := 0;                              <<x7786>>07274000
      xddsd'record'count := 0d;                                <<x7786>>07276000
      if xdds'class then ldev := -ldev;                        <<x7786>>07278000
      @dcp := initxddp;                                                 07280000
      i := 0;                                                  <<x7786>>07282000
      while dcp <> 0 and dcp <> ldev do                        <<x7786>>07284000
         begin                                                 <<x7786>>07286000
         if dcp > 0 then                                       <<x7786>>07288000
            @dcp := @dcp + ldev'entrysize                      <<x7786>>07290000
         else                                                  <<x7786>>07292000
            @dcp := @dcp + dcp(1);                             <<x7786>>07294000
         i := i+1;                                             <<x7786>>07296000
         end;                                                  <<x7786>>07298000
      ldev := newldevs(i);                                     <<x7786>>07300000
      if dcp = 0 or ldev = 0 then                              <<x7786>>07302000
         begin                                                          07304000
         ner := if dcp >= 0 then 57  << no equiv device >>     <<x7786>>07306000
                            else 58; << no equiv class >>      <<x7786>>07308000
         errorset;                                                      07310000
         end                                                            07312000
      else                                                              07314000
         begin                                                          07316000
         xdd'subentry.(2:1) := 0; << 2nd bit of spool state >> <<x7786>>07318000
         xdds'device := ldev;                                  <<x7786>>07320000
         xdds'class := if dcp < 0 then 1 else 0;               <<x7786>>07322000
         if dcp < 0 then ldev := -ldev;                        <<x7786>>07324000
         if sputxdd(1,ldev,xdd'subentry,xddsubp) <> 0 then     <<x7786>>07326000
            begin                                              <<x7786>>07328000
            ner := 59;    << no room in device table >>        <<x7786>>07330000
            errorset;                                          <<x7786>>07332000
            end                                                <<x7786>>07334000
         else                                                  <<x7786>>07336000
            begin                                              <<x7786>>07338000
            filef := fsopen(,%304,%501,@xddsubp);              <<x7786>>07340000
            if < then                                          <<x7786>>07342000
               begin                                           <<x7786>>07344000
               errorfile(29);                                  <<x7786>>07346000
               sremovexdd(xddsubp);                            <<x7786>>07348000
               filef := 0;                                     <<x7786>>07350000
               end                                             <<x7786>>07352000
            else    << spoofle opened ok >>                    <<x7786>>07354000
               begin                                           <<x7786>>07356000
               movefromdseg(@xdd'subentry, odd'dst,            <<x7786>>07358000
                            @xddsubp.idnum,                    <<x7786>>07360000
                            size'of'xdd'subentry);             <<x7786>>07362000
               xdds'show'errs := 0;                            <<x7786>>07364000
               end;                                            <<x7786>>07366000
            end;                                               <<x7786>>07368000
         end;                                                  <<x7786>>07370000
      end;                                                     <<x7786>>07372000
                                                               <<x7786>>07374000
$page                                                          <<i7784>>07376000
   << >>                                                                07378000
                                                               <<01886>>07380000
   subroutine readuserlabels;                                  <<01886>>07382000
      begin                                                    <<01886>>07384000
         past'ulabs := false;                                  <<01886>>07386000
         readtape(true);                                       <<01886>>07388000
         if sbuf(2) = 3 <<fopen>> and sbuf(4) <> 0 <<numulabs>><<01930>>07390000
            and sbuf((sbuf+3)&asr(1)) = -1 <<end of block>>    <<01930>>07392000
            then                                               <<01930>>07394000
         begin <<there are userlabels>>                        <<01886>>07396000
            numspulabs := sbuf(4);                             <<01930>>07398000
           j := 1;                                             <<01930>>07400000
            do                                                 <<01886>>07402000
            begin                                              <<01886>>07404000
               tcount := fread(filet,sbuf,1024);               <<01930>>07406000
               if < then goto badread;                         <<x7786>>07408000
               fwritelabel(filef,sbuf(128),,j-1);              <<01930>>07410000
               if j < numspulabs - 1 then                      <<01930>>07412000
               fwritelabel(filef,sbuf(128*2),,j);              <<01930>>07414000
               if j+1 < numspulabs - 1 then                    <<01930>>07416000
               fwritelabel(filef,sbuf(128*3),,j+1);            <<01930>>07418000
               if j+2 < numspulabs - 1 then                    <<01930>>07420000
               fwritelabel(filef,sbuf(512+128),,j+2);          <<01930>>07422000
               if j+3 < numspulabs - 1 then                    <<01930>>07424000
               fwritelabel(filef,sbuf(512+(128*2)),,j+3);      <<01930>>07426000
               if j+4 < numspulabs - 1 then                    <<01930>>07428000
               fwritelabel(filef,sbuf(512+(128*3)),,j+4);      <<01930>>07430000
            end                                                <<01930>>07432000
            until (j := j + 6) > numspulabs;                   <<01930>>07434000
         end                                                   <<01886>>07436000
         else                                                  <<01886>>07438000
             past'ulabs := true;                               <<01886>>07440000
       end; <<subroutine readuserlabels>>                      <<01886>>07442000
$page                                                          <<x7786>>07444000
<<>>                                                           <<01886>>07446000
<< procedure infiles starts here >>                            <<x7786>>07448000
                                                               <<01886>>07450000
   c := 0;                                                              07452000
   gotx := false;                                                       07454000
   got := false;                                                        07456000
   filef := 0;                                                          07458000
   @xdd'subentry := initxddp;                                  <<x7786>>07460000
   print(min,23,0);                                                     07462000
                                                               <<i7784>>07464000
   << if file'match is true, then there is at least one     >> <<i7784>>07466000
   << spoolfile on this tape that we want.  otherwise, we   >> <<i7784>>07468000
   << skip scanning through this entire tape.               >> <<i7784>>07470000
                                                               <<i7784>>07472000
   if file'match then                                          <<i7784>>07474000
   while (c:=c+1) <= xddc do                                            07476000
      begin                                                             07478000
      critflag := false; if controlyflag then controlyproc;    <<b0.00>>07480000
      critflag := true;                                        <<b0.00>>07482000
                                                               <<x7786>>07484000
      <<---------------------------------------------------->> <<x7786>>07486000
      << we're not actually accessing a xdd subentry here,  >> <<x7786>>07488000
      << but the file directory entry placed in the db-     >> <<x7786>>07490000
      << area by procedure infiles.  it serves as a place-  >> <<x7786>>07492000
      << holder for the real thing which is generated in    >> <<x7786>>07494000
      << open'newsp.  forgive me for calling it xdd'subentry>> <<x7786>>07496000
      << but it does refer to the same location in memory...>> <<x7786>>07498000
      <<---------------------------------------------------->> <<x7786>>07500000
                                                               <<x7786>>07502000
      @xdd'subentry := @xdd'subentry-size'of'xdd'subentry;     <<x7786>>07504000
      file'end := false;                                       <<x7786>>07506000
      delete := false;                                         <<x7786>>07508000
      ner := 0;                                                         07510000
      fer := 0;                                                         07512000
      fileend := false;                                                 07514000
      if devfc <> 0 then                                                07516000
         begin                                                          07518000
         match := false;                                       <<x7786>>07520000
         if not got then                                                07522000
            begin                                                       07524000
            d := -1;                                                    07526000
            got := true;                                                07528000
                                                               <<x7786>>07530000
            << look at the device file id in the file direc->> <<x7786>>07532000
            << tory entry to see if it matches any of the   >> <<x7786>>07534000
            << dfid's we asked to be input.                 >> <<x7786>>07536000
                                                               <<x7786>>07538000
            while (d:=d+1) < devfc do                                   07540000
               if devfs(d) <> 0 then                                    07542000
                  begin                                                 07544000
                  got := false;                                         07546000
                  if xdd'subentry = devfs(d) then              <<x7786>>07548000
                     begin                                              07550000
                     match := true;                            <<x7786>>07552000
                     devfs(d) := 0;                                     07554000
                     end;                                               07556000
                  end;                                                  07558000
            end;                                                        07560000
         end                                                            07562000
      else                                                              07564000
         begin                                                          07566000
         match := true;                                        <<x7786>>07568000
         n := if userf then -1 else 3;                                  07570000
         m := if acctf then 8 else 4;                          <<x7786>>07572000
         while (n:=n+1) < m do                                 <<x7786>>07574000
            if xdd'subentry(4+n) <> snames(n) then             <<x7786>>07576000
               match := false;                                 <<x7786>>07578000
         end;                                                           07580000
                                                               <<x7786>>07582000
      if not match then                                        <<x7786>>07584000
         begin                                                          07586000
         xdd'subentry := 0;                                    <<x7786>>07588000
         if not got then readtape(false);                               07590000
         end                                                            07592000
      else                                                              07594000
         << read odd entry which precedes spoolfile blocks >>  <<x7786>>07596000
         << 30 words if mpe4 tape, 32 words if mpe5 tape   >>  <<x7786>>07598000
         begin                                                 <<x7786>>07600000
         readtape(true);                                       <<x7786>>07602000
         if tcount = 0 then goto badfmt                        <<x7786>>07604000
         else                                                  <<x7786>>07606000
            if tcount = 20 then errorin                        <<x7786>>07608000
            else                                               <<x7786>>07610000
               if (mpe5tape land tcount=32) or                 <<x7786>>07612000
                  (not mpe5tape land tcount=30) then           <<x7786>>07614000
                     begin                                     <<x7786>>07616000
                     open'newsp;                               <<x7786>>07618000
                     if not file'end then << no error found >> <<x7786>>07620000
                        readuserlabels;                        <<x7786>>07622000
                     end                                       <<x7786>>07624000
                     else goto badfmt;                         <<x7786>>07626000
                                                               <<x7786>>07628000
         << read spoolfile blocks at this point >>             <<x7786>>07630000
         while not file'end do                                 <<x7786>>07632000
            begin                                              <<01886>>07634000
            if not past'ulabs then                             <<01886>>07636000
            readtape(true);                                             07638000
            past'ulabs := false;                               <<01886>>07640000
            if tcount = 0 then                                          07642000
               file'end := true                                <<x7786>>07644000
            else                                                        07646000
                    begin                                               07648000
                    if tcount = 20 then errorin                <<x7786>>07650000
                    else                                       <<x7786>>07652000
                    if tcount = 512 or tcount = 1024 then               07654000
                       begin                                            07656000
                       if not verify'block'structure(sbuf,    <<<01549>>07658000
                            index,numrecs) then                <<01726>>07660000
                         if not rewrite'block(filef,sbuf,     <<<01549>>07662000
                            index) then                       <<<01549>>07664000
                            errorfile(27);                    <<<01549>>07666000
                       fwrite(filef,sbuf,512,0);              <<<01549>>07668000
                       if <> then                                       07670000
                          errorfile(27)                                 07672000
                       else                                             07674000
                          if tcount = 1024 then                         07676000
                             begin                                      07678000
                    if not verify'block'structure(sbuf(512),  <<<01549>>07680000
                            index,numrecs) then                <<01726>>07682000
                         if not rewrite'block(filef,sbuf(512),<<<01549>>07684000
                            index) then                       <<<01549>>07686000
                            errorfile(27);                    <<<01549>>07688000
                             fwrite(filef,sbuf(512),512,0);   <<<01549>>07690000
                             if <> then errorfile(27);                  07692000
                             end;                                       07694000
                       end                                     <<x7786>>07696000
                    else goto badfmt;                          <<x7786>>07698000
                    end;                                                07700000
            end;     << while not file'end >>                  <<x7786>>07702000
         if filef <> 0 then                                             07704000
            begin                                                       07706000
            fsclose(filef,if delete then 4 else 0,0);          <<x7786>>07708000
            if < then errorfile(25);                                    07710000
            filef := 0;                                                 07712000
            end;                                                        07714000
         if not delete then                                    <<x7786>>07716000
            begin                                                       07718000
            move xddbuf := xdd'subentry,(size'of'xdd'subentry);<<x7786>>07720000
            showxdd(%10,dfid);                                 <<x7786>>07722000
            end;                                                        07724000
         end;                                                           07726000
      end;   << while c <= xddc >>                             <<x7786>>07728000
   infiles := true;                                                     07730000
   goto lx;                                                             07732000
mrabort:                                                       <<x7786>>07734000
   errn := 60;     << multi-reel abort >>                      <<06426>>07736000
   goto lyz;                                                            07738000
badfmt:                                                        <<x7786>>07740000
   errn := 53;     << invalid tape format >>                   <<06426>>07742000
   goto lyz;                                                            07744000
badread:                                                       <<x7786>>07746000
   errn := 54;     << tape file read error >>                  <<06426>>07748000
lyz:                                                                    07750000
   if filef <> 0 then fsclose(filef,4,0);                               07752000
   fclose(filet,1,0);                                          <<02724>>07754000
   filet := 0;                                                          07756000
lx:                                                                     07758000
   end;                                                                 07760000
$page "* * * OUTFILES * * *"                                   <<x7786>>07762000
$control segment=spook3                                                 07764000
                                                                        07766000
logical procedure outfiles;                                             07768000
   begin                                                                07770000
   integer c,p,i;                                                       07772000
   integer ner,fer;                                                     07774000
   integer numspulabs,j;                                       <<01886>>07776000
   integer save'xdds'addr;                                     <<x7786>>07778000
   logical stop'write;                                         <<x7786>>07780000
   logical pointer xdd'subentry;                               <<x7786>>07782000
   << >>                                                                07784000
   <<------------------------------------------------------->> <<x7786>>07786000
   << writetape performs the actual fwrite's to the output  >> <<x7786>>07788000
   << spook tape.                                           >> <<x7786>>07790000
   <<    if count=0, an eof mark is written.                >> <<x7786>>07792000
   <<    if count<> 0, that many words/bytes is written out >> <<x7786>>07794000
   <<                  to tape.                             >> <<x7786>>07796000
   <<------------------------------------------------------->> <<x7786>>07798000
                                                               <<x7786>>07800000
   logical subroutine writetape(addr,count);                            07802000
      value   count;                                                    07804000
      integer count;                                                    07806000
      array   addr;                                                     07808000
      begin                                                             07810000
      writetape := true;                                                07812000
      if count <> 0 then fwrite(filet,addr,count,0)                     07814000
                    else fcontrol(filet,6,p);                           07816000
      if <> then                                                        07818000
         << check if at end of tape >>                         <<x7786>>07820000
         begin                                                          07822000
         fcheck(filet,p);                                               07824000
         if p = 23 then eotmark := true                                 07826000
                   else writetape := false;                             07828000
         end;                                                           07830000
      end;                                                              07832000
   << >>                                                                07834000
   subroutine nextreel;                                                 07836000
      begin                                                             07838000
      if eotmark or lastreel then                                       07840000
         begin                                                          07842000
         if not fileend then                                            07844000
            if not writetape(sbuf,0) then goto badwrite;       <<x7786>>07846000
         l0eof := if fileend then 1 else 0;                    <<x7786>>07848000
         l0lastreel := if lastreel then 1 else 0;              <<x7786>>07850000
         if not writetape(tbuf,40) then goto badwrite;         <<x7786>>07852000
         i := -1;                                                       07854000
         while (i:=i+1) <= 3 do                                         07856000
            if not writetape(sbuf,0) then goto badwrite;       <<x7786>>07858000
         if not lastreel then   << switch reels >>             <<x7786>>07860000
            begin                                                       07862000
            fcontrol(filet,9,p);  << rewind/offline >>         <<x7786>>07864000
            if <> then goto badwrite;                          <<x7786>>07866000
            reel := reel+1;                                             07868000
            i := printopreply(mreel,17,0,rbuf,-1);                      07870000
            if brbuf = "N" then goto mrabort;                  <<x7786>>07872000
            eotmark := false;                                           07874000
            l0eof := 0;                                        <<x7786>>07876000
            l0lastreel := 0;                                   <<x7786>>07878000
            l0reel := reel;                                    <<x7786>>07880000
            if not writetape(tbuf,40) then goto badwrite;      <<x7786>>07882000
            if not writetape(sbuf,0) then goto badwrite;       <<x7786>>07884000
            end;                                                        07886000
         end;                                                           07888000
      end;                                                              07890000
   << >>                                                                07892000
   <<------------------------------------------------------->> <<x7786>>07894000
   << errorout saves errors in sbuf(0) and (1) for procedure>> <<x7786>>07896000
   << infiles to recover when inputting these files.        >> <<x7786>>07898000
   <<------------------------------------------------------->> <<x7786>>07900000
                                                               <<x7786>>07902000
   subroutine errorout;                                                 07904000
      begin                                                             07906000
      xdds'spook'err := ner;                                   <<x7786>>07908000
      xdds'filesys'err := fer;                                 <<x7786>>07910000
      sbuf := ner;                                                      07912000
      sbuf(1) := fer;                                                   07914000
      ner := 0;                                                         07916000
      fer := 0;                                                         07918000
      if not writetape(sbuf,20) then goto badwrite;            <<x7786>>07920000
      end;                                                              07922000
   << >>                                                                07924000
   subroutine errorfile;                                                07926000
      begin                                                             07928000
      ner := 26;    << file read error >>                      <<x7786>>07930000
      fcheck(filef,fer);                                                07932000
            errf := fer;                                       <<01326>>07934000
      errorout;                                                         07936000
      end;                                                              07938000
   << >>                                                                07940000
                                                               <<01886>>07942000
   subroutine writeuserlabels;                                 <<01886>>07944000
      begin                                                    <<01886>>07946000
         ffileinfo(filef, 17, numspulabs);                     <<01886>>07948000
         if numspulabs > 0 then                                <<01886>>07950000
         begin                                                 <<01886>>07952000
            sbuf := 8;  <<length>>                             <<01930>>07954000
            sbuf(1) := 0;                                      <<01930>>07956000
            sbuf(2) := 3; <<fopen>>                            <<01930>>07958000
            sbuf(3) := 0; <<p1>>                               <<01930>>07960000
            sbuf(4) := numspulabs; <<p2>>                      <<01930>>07962000
            sbuf(5) := -1; <<end of block>>                    <<01930>>07964000
            move sbuf(512) := sbuf, (6);                       <<01930>>07966000
            if not writetape(sbuf,1024) then go to badwrite;   <<x7786>>07968000
            j := 1 ;                                           <<01930>>07970000
            do                                                 <<01886>>07972000
            begin                                              <<01886>>07974000
               freadlabel(filef,sbuf(128),, j-1);              <<01930>>07976000
               freadlabel(filef, sbuf(128*2),,j);              <<01930>>07978000
               freadlabel(filef, sbuf(128*3),,j+1);            <<01930>>07980000
               freadlabel(filef,sbuf(512+128),, j+2);          <<01930>>07982000
               freadlabel(filef, sbuf(512+(128*2)),,j+3);      <<01930>>07984000
               freadlabel(filef, sbuf(512+(128*3)),,j+4);      <<01930>>07986000
               if not writetape(sbuf,1024) then go to badwrite;<<x7786>>07988000
            end                                                <<01930>>07990000
            until (j := j+6) > numspulabs;                     <<01930>>07992000
         end;                                                  <<01886>>07994000
      end; <<subroutine writeuserlabels>>                      <<01886>>07996000
$page                                                          <<x7786>>07998000
<<>>                                                           <<01886>>08000000
<< start of procedure outfiles >>                              <<x7786>>08002000
                                                               <<01886>>08004000
   filef := 0;                                                          08006000
   c := 0;                                                              08008000
   @xdd'subentry := initxddp;                                  <<x7786>>08010000
   print(mout,22,0);                                                    08012000
   while (c:=c+1) <= xddc do                                            08014000
      begin                                                             08016000
      critflag := false; if controlyflag then controlyproc;    <<b0.00>>08018000
      critflag := true;                                        <<b0.00>>08020000
      @xdd'subentry := @xdd'subentry-size'of'xdd'subentry;     <<x7786>>08022000
      if xdd'subentry > 0 then                                 <<x7786>>08024000
         begin                                                          08026000
         << copy device file id number and idd'or'odd bit >>   <<x7786>>08028000
         devf := xdds'dfid'all;                                <<x7786>>08030000
         stop'write := true;                                   <<x7786>>08032000
         fileend := false;                                              08034000
                                                               <<x7786>>08036000
      << open the spoolfile to be output >>                    <<x7786>>08038000
      tos := spoolopen(devf,filef);                            <<b0.01>>08040000
         save'xdds'addr := @xdd'subentry;                      <<x7786>>08042000
         @xdd'subentry := @xddbuf;                             <<x7786>>08044000
         xdds'spool'state := xdds'locked;                      <<x7786>>08046000
         xdds'output'priority := 1;                            <<x7786>>08048000
         xdds'show'errs := 0;                                  <<x7786>>08050000
         @xdd'subentry := save'xdds'addr;                      <<x7786>>08052000
         move xdd'subentry := xddbuf,(size'of'xdd'subentry);   <<x7786>>08054000
         if not tos then   << spoolfile not opened ok >>       <<x7786>>08056000
            begin                                                       08058000
            ner := errn;                                                08060000
            fer := errf;                                                08062000
            errn := 0;                                                  08064000
            errf := no'file'error;                             <<04145>>08066000
            errorout                                                    08068000
            end                                                         08070000
         else                                                           08072000
            <<spoolfile opened ok, write xdd subentry to tape>><<x7786>>08074000
            begin                                                       08076000
            if not writetape(xddbuf,size'of'xdd'subentry) then <<x7786>>08078000
               goto badwrite;                                  <<x7786>>08080000
            writeuserlabels;                                   <<01886>>08082000
                                                               <<x7786>>08084000
            << write 2 spoolfile blocks (1024-word record)  >> <<x7786>>08086000
            << at a time, until we are at the end of file.  >> <<x7786>>08088000
            do                                                          08090000
               begin                                                    08092000
               stop'write := true;                             <<x7786>>08094000
               fread(filef,sbuf,512);                                   08096000
               if < then                                                08098000
                  errorfile                                             08100000
               else                                                     08102000
                  if = then                                             08104000
                     begin                                              08106000
                     nextreel;                                          08108000
                     fread(filef,sbuf(512),512);                        08110000
                     if < then                                          08112000
                        errorfile                                       08114000
                     else                                               08116000
                        if > then                                       08118000
                           begin                                        08120000
                           if not writetape(sbuf,512) then              08122000
                              goto badwrite;                   <<x7786>>08124000
                           end                                          08126000
                        else  << cce from fread >>             <<x7786>>08128000
                           begin                                        08130000
                           if not writetape(sbuf,1024) then             08132000
                              goto badwrite;                   <<x7786>>08134000
                           stop'write := false;                <<x7786>>08136000
                           end;                                         08138000
                     end;                                               08140000
               end                                                      08142000
            until stop'write;                                  <<x7786>>08144000
            end;                                                        08146000
         if not writetape(sbuf,0) then goto badwrite;          <<x7786>>08148000
         fileend := true;                                               08150000
         nextreel;                                                      08152000
         if filef <> 0 then                                             08154000
            begin                                                       08156000
            pri := 1;                                                   08158000
            copies := 0;                                                08160000
            class := 0;                                        <<x7786>>08162000
            device := 0;                                       <<x7786>>08164000
            alterxdd(devf);                                    <<b0.01>>08166000
            fsclose(filef,if purgeflag then 4 else 0,0);      <<00204>> 08168000
            filef := 0;                                                 08170000
            end;                                                        08172000
         move xddbuf := xdd'subentry,(size'of'xdd'subentry);   <<x7786>>08174000
         if xdds'show'errs = 0 then showxdd(%4,0);             <<x7786>>08176000
         end;    << if spoofle opened successfully >>          <<x7786>>08178000
      end;   << while c < xddc >>                              <<x7786>>08180000
   lastreel := true;                                                    08182000
   nextreel;                                                            08184000
   outfiles := true;                                                    08186000
   goto lx;                                                             08188000
mrabort:                                                       <<x7786>>08190000
   errn := 60;    << multi-reel abort >>                       <<x7786>>08192000
   goto ly;                                                             08194000
badwrite:                                                      <<x7786>>08196000
   errn := 55;    << tape file write error >>                  <<x7786>>08198000
ly:                                                                     08200000
   if filef <> 0 then fsclose(filef,0,0);                               08202000
   fclose(filet,1,0);                                          <<02724>>08204000
   filet := 0;                                                          08206000
   purgeflag := false;                                        <<00204>> 08208000
lx:                                                                     08210000
   end;                                                                 08212000
$page "* * * PURGEFILES * * *"                                 <<x7801>>08214000
$control segment=spook2                                                 08216000
                                                               <<x7801>>08218000
<<---------------------------------------------------------->> <<x7801>>08220000
<< purgefiles purges the spoolfiles previously obtained by  >> <<x7801>>08222000
<< procedure getfiles.  a spoolfile to be purged is des-    >> <<x7801>>08224000
<< cribed in devf, and filef is its entry into the aft.     >> <<x7801>>08226000
<<---------------------------------------------------------->> <<x7801>>08228000
                                                                        08230000
procedure purgefiles;                                                   08232000
   begin                                                                08234000
   integer c;                                                           08236000
   logical pointer xdd'subentry;                               <<x7786>>08238000
   << >>                                                                08240000
   subroutine errorpurg;                                                08242000
      begin                                                             08244000
      xdds'spook'err := errn;                                  <<x7786>>08246000
      xdds'filesys'err := errf;                                <<x7786>>08248000
      errn := 0;                                                        08250000
      errf := no'file'error;                                   <<04145>>08252000
      filef := 0;                                                       08254000
      end;                                                              08256000
   << >>                                                                08258000
   c := 0;                                                              08260000
   @xdd'subentry := initxddp;                                  <<x7786>>08262000
   print(mout,22,0);                                                    08264000
   while (c:=c+1) <= xddc do                                            08266000
      begin                                                             08268000
      critflag := false; if controlyflag then controlyproc;    <<b0.00>>08270000
      critflag := true;                                        <<b0.00>>08272000
      @xdd'subentry := @xdd'subentry-size'of'xdd'subentry;     <<x7786>>08274000
      if xdd'subentry > 0 then                                 <<x7786>>08276000
         begin                                                          08278000
         devf := xdds'dfid'all;                                <<x7786>>08280000
         if filen <> 0 and devf = devfn then                            08282000
            begin                                                       08284000
            filef := filen;                                             08286000
            filen := 0;                                                 08288000
            end                                                         08290000
         else                                                           08292000
         if not spoolopen(devf,filef) then errorpurg;          <<b0.01>>08294000
         if filef <> 0 then                                             08296000
            begin    << close file and delete it >>            <<x7786>>08298000
            fsclose(filef,4,0);                                         08300000
            if < then                                                   08302000
               begin                                                    08304000
               errn := 25;    << unable to purge file >>       <<x7786>>08306000
               fcheck(filef,errf);                                      08308000
               errorpurg;                                               08310000
               end                                                      08312000
            else                                                        08314000
               begin                                                    08316000
              move xddbuf:=xdd'subentry,(size'of'xdd'subentry);<<x7786>>08318000
               showxdd(%4,0);                                           08320000
               end;                                                     08322000
            end;                                                        08324000
         end;                                                           08326000
      end;                                                              08328000
   end;                                                                 08330000
                                                                        08332000
$page "SPOOK CONTROLY ROUTINES"                                <<b0.00>>08334000
$control segment=spook1                                                 08336000
                                                                        08338000
procedure controly;                                                     08340000
   begin                                                                08342000
   << >>                                                                08344000
      tos:=exchangedb(0);                                      <<b0.00>>08346000
      if critflag then                                         <<b0.00>>08348000
        begin                                                  <<b0.00>>08350000
        controlyflag := true;                                  <<b0.00>>08352000
        assemble(zero,xch);                                    <<b0.01>>08354000
        exchangedb(*);                                         <<b0.00>>08356000
        tos := tos.(8:8) + exitinstr;                          <<b0.01>>08358000
        assemble(xeq 0);                                       <<b0.01>>08360000
        end                                                    <<b0.00>>08362000
      else                                                     <<b0.00>>08364000
         ddel;                                                 <<b0.01>>08366000
        controlyproc;                                          <<b0.00>>08368000
        end;                                                   <<b0.00>>08370000
                                                               <<b0.00>>08372000
                                                               <<b0.00>>08374000
$control segment=spook1                                        <<b0.00>>08376000
                                                               <<b0.00>>08378000
procedure controlyproc;                                        <<b0.00>>08380000
                                                               <<b0.00>>08382000
   begin                                                       <<b0.00>>08384000
<<>>                                                           <<b0.00>>08386000
                                                               <<b0.00>>08388000
   exchangedb(0) ;                                             <<b0.01>>08390000
   deltap.(2:14) := cyaddr;                                             08392000
   qmstat := statval;                                                   08394000
   push(q);                                                             08396000
   deltaq := tos-qval;                                                  08398000
   if deltaq < 4 then debug;                                   <<b0.01>>08400000
   controlyflag := false;                                      <<b0.00>>08402000
   resetcontrol;                                                        08404000
   end;                                                                 08406000
$page "SPOOK SUBTASKING INTERFACE ROUTINE"                     <<b0.00>>08408000
$control segment=spook1                                        <<b0.00>>08410000
<<  procedure attach will attempt >>                           <<b0.00>>08412000
<<  to attach (create and/or activate >>                       <<b0.00>>08414000
<<  a task            >>                                       <<b0.00>>08416000
                                                               <<b0.00>>08418000
logical procedure attach(progname,pinnum);                     <<b0.00>>08420000
byte array progname;                                           <<b0.00>>08422000
integer pinnum;                                                <<b0.00>>08424000
                                                               <<b0.00>>08426000
begin                                                          <<b0.00>>08428000
   integer count;                                              <<b0.00>>08430000
                                                               <<x7786>>08432000
<<  >>                                                         <<b0.00>>08434000
   scan progname until %6440,1;                                <<b0.00>>08436000
   count := tos - @progname;                                   <<b0.00>>08438000
   attach:=false;                                              <<b0.00>>08440000
   if lastcreate = progname ,(count)  then                     <<b0.00>>08442000
      begin                                                    <<b0.00>>08444000
      critflag := false; if controlyflag then controlyproc;    <<b0.00>>08446000
      if (lastpin := getprocid(1)) = 0                         <<b0.00>>08448000
      then go to create'task;                                  <<b0.00>>08450000
      activate(pinnum,3);                                      <<b0.00>>08452000
      if < then go to create'task;                             <<b0.00>>08454000
      if (lastpin := getprocid(1)) = 0                         <<b0.00>>08456000
      then lastcreate := 0;    <<son has terminated>>          <<b0.00>>08458000
      xcontrap(cylabel,cyold); <<rearm controly>>              <<b0.00>>08460000
      attach:=true;                                            <<b0.00>>08462000
      critflag := true;;                                       <<b0.00>>08464000
      return;                                                  <<b0.00>>08466000
      end;                                                     <<b0.00>>08468000
create'task:                                                   <<b0.00>>08470000
          if lastpin <> 0 then                                 <<b0.00>>08472000
             kill(lastpin);                                    <<b0.00>>08474000
   erroron; intrins := 100;numparms :=2;                       <<b0.00>>08476000
   create (progname,,pinnum,subtask'level,1);                  <<b0.00>>08478000
      if < or carry  then                                      <<b0.00>>08480000
            begin                                              <<b0.00>>08482000
            attach:=false;                                     <<b0.00>>08484000
            errorexit(intrword,0,0);                           <<b0.00>>08486000
            return;                                            <<b0.00>>08488000
            end                                                <<b0.00>>08490000
     else begin                                                <<b0.00>>08492000
     critflag := false; if controlyflag then controlyproc;     <<b0.00>>08494000
          activate(pinnum,3);                                  <<b0.00>>08496000
         xcontrap(cylabel,cyold); <<rearm controly>>           <<b0.00>>08498000
          if (lastpin := getprocid(1)) = 0                     <<b0.00>>08500000
      then lastcreate := 0     <<son has terminated>>          <<b0.00>>08502000
      else                                                     <<b0.00>>08504000
          move lastcreate:=progname,(27);                      <<b0.00>>08506000
      critflag := true;                                        <<b0.00>>08508000
            attach:=true;                                      <<b0.00>>08510000
      errorexit(intrword,0,0);                                 <<b0.00>>08512000
          end;                                                 <<b0.00>>08514000
end;                                                           <<b0.00>>08516000
$page "SPOOK MPE COMMAND PROCESSING ROUTINE"                   <<00897>>08518000
$control segment=spook1                                        <<b0.00>>08520000
<< procedure mpecommand will attempt>>                         <<b0.00>>08522000
<< to execute programmatically a    >>                         <<b0.00>>08524000
<< command string that is not       >>                         <<b0.00>>08526000
<< a spook command                  >>                         <<b0.00>>08528000
                                                               <<b0.00>>08530000
logical procedure mpecommand(command'string);                  <<b0.00>>08532000
byte array   command'string;                                   <<b0.00>>08534000
                                                               <<b0.00>>08536000
begin                                                          <<b0.00>>08538000
   integer error, parm, j;                                     <<x7786>>08540000
                                                               <<x7786>>08542000
<<>>                                                           <<b0.00>>08544000
mpecommand := false;                                           <<b0.00>>08546000
command(command'string,error, parm);                           <<b0.00>>08548000
   if = then                                                   <<c7784>>08550000
   begin                                                       <<c7784>>08552000
      mpecommand := true;                                      <<c7784>>08554000
      if error <> 0 then                                       <<c7784>>08556000
      begin                                                    <<c7784>>08558000
         if error < 0 then error := -error;                    <<c7784>>08560000
         j := genmsg(2,error);                                 <<c7784>>08562000
      end;                                                     <<c7784>>08564000
   end                                                         <<c7784>>08566000
   else                                                        <<c7784>>08568000
      if > then                                                <<b0.00>>08570000
         begin                                                 <<b0.00>>08572000
            if error < 0 then error := -error;                          08574000
            j := genmsg(2,error);                              <<b0.00>>08576000
            mpecommand := true;                                <<b0.00>>08578000
        end;                                                   <<b0.00>>08580000
end;                                                           <<b0.00>>08582000
$page "SPOOK COPY/APPEND ROUTINES"                             <<00897>>08584000
$control segment=spook3                                        <<b0.01>>08586000
                                                               <<b0.01>>08588000
logical procedure new'file'close(old);                         <<b0.01>>08590000
<<>>                                                           <<b0.01>>08592000
   value old;                                                  <<b0.01>>08594000
   logical old;                                                <<b0.01>>08596000
                                                               <<04145>>08598000
<<****************************************************>>       <<04145>>08600000
<< this procedure closes the newly created copied file>>       <<b0.01>>08602000
<< that was opened as a result of copy/append         >>       <<b0.01>>08604000
<< if the file is a spoolfile, then a call to fsclose >>       <<b0.01>>08606000
<< is made and the appropriate spooler is awakened.   >>       <<b0.01>>08608000
<< if the file is a permanent file, then if a file    >>       <<b0.01>>08610000
<< with the same name already exists, the user is     >>       <<b0.01>>08612000
<< prompted for its replacement.                      >>       <<b0.01>>08614000
<<****************************************************>>       <<04145>>08616000
                                                               <<04145>>08618000
begin                                                          <<b0.01>>08620000
integer disp;  <<close disposition>>                           <<b0.01>>08622000
array filename(0:13);                                          <<04145>>08624000
byte array filename'b(*)=filename;                             <<04145>>08626000
logical try'again;                                             <<b0.01>>08628000
<<>>                                                           <<b0.01>>08630000
                                                               <<b0.01>>08632000
new'file'close := false;                                       <<b0.01>>08634000
disp := %11;                                                   <<b0.01>>08636000
try'again := false;                                            <<b0.01>>08638000
                                                               <<04145>>08640000
<<**********************************************************>> <<04145>>08642000
<<  if we have a new spoolfile, close it out.               >> <<04145>>08644000
<<**********************************************************>> <<04145>>08646000
                                                               <<04145>>08648000
if new'spoolfile then                                          <<b0.01>>08650000
   if new'filen <> 0 then                                      <<b0.01>>08652000
   begin                                                       <<b0.01>>08654000
   oddn := findodd(new'xddn);                                  <<x7786>>08656000
   fsclose(new'filen,0,0);                                     <<b0.01>>08658000
   if < then                                                   <<b0.01>>08660000
      begin                                                    <<b0.01>>08662000
      << unable to close copy file >>                          <<06426>>08664000
      errn := 73; fcheck(new'filen,errf); go to lx;            <<b0.01>>08666000
      end;                                                     <<b0.01>>08668000
   srooster(oddn);                                             <<x7786>>08670000
   new'spoolfile := false;                                     <<b0.01>>08672000
   end                                                         <<b0.01>>08674000
   else go to lx                                               <<b0.01>>08676000
$page                                                          <<04145>>08678000
<<**********************************************************>> <<04145>>08680000
<< permanent file, try closing it permanent, freeing space  >> <<04145>>08682000
<< after eof.                                               >> <<04145>>08684000
<<**********************************************************>> <<04145>>08686000
                                                               <<04145>>08688000
else                                                           <<b0.01>>08690000
perm'close:                                                    <<b0.01>>08692000
   begin                                                       <<b0.01>>08694000
   fclose(new'filen,disp,0);                                   <<b0.01>>08696000
   if < then                                                   <<b0.01>>08698000
      begin                                                    <<b0.01>>08700000
      if try'again then                                        <<b0.01>>08702000
        begin                                                  <<b0.01>>08704000
        disp := -1;                                            <<b0.01>>08706000
        go to perm'close;                                      <<b0.01>>08708000
        end;                                                   <<b0.01>>08710000
      try'again := true;                                       <<b0.01>>08712000
      << unable to close copy file >>                          <<06426>>08714000
      errn := 73; fcheck(new'filen,errf);                      <<b0.01>>08716000
                                                               <<04145>>08718000
      <<****************************************************>> <<04145>>08720000
      << if the file already exists (perm or temp), ask the >> <<04145>>08722000
      << user if he wants the file purged.                  >> <<04145>>08724000
      <<****************************************************>> <<04145>>08726000
                                                               <<04145>>08728000
      if errf = 100 or errf = 101 then                         <<b0.01>>08730000
         begin                                                 <<b0.01>>08732000
replace'file:                                                  <<b0.01>>08734000
         fgetinfo(new'filen,filename'b);                       <<04145>>08736000
         move cbuf := printfile,2;                             <<04145>>08738000
         i := tos - @cbuf;                                     <<04145>>08740000
         move cbuf(3) := filename,(13);                        <<04145>>08742000
         print(cbuf,i,0);                                      <<04145>>08744000
         move cbuf := replacefile,2;                           <<b0.01>>08746000
         i := tos - @cbuf;                                     <<b0.01>>08748000
         print(cbuf,i,%320);                                   <<b0.01>>08750000
         critflag := false; if controlyflag then               <<b0.01>>08752000
            controlyproc;                                      <<b0.01>>08754000
         count := read(cbuf,-72);                              <<b0.01>>08756000
         critflag := true;                                     <<b0.01>>08758000
             errf := no'file'error;                            <<04145>>08760000
         @bp := @bcbuf;                                        <<b0.01>>08762000
         bp(count) := cr ;                                     <<04145>>08764000
         if not shiftupper(bp,count) then go replace'file;     <<b0.01>>08766000
         scan bp while %6440 ,1; <<cr,blank>>                  <<b0.01>>08768000
         @bp := tos;                                           <<b0.01>>08770000
                                                               <<04145>>08772000
         <<*************************************************>> <<04145>>08774000
         <<  if so, purge the file via mpecommand and re-   >> <<04145>>08776000
         << close the file via perm'close.                  >> <<04145>>08778000
         <<*************************************************>> <<04145>>08780000
                                                               <<04145>>08782000
         if nocarry and bp = "Y" then                          <<b0.01>>08784000
            begin                                              <<b0.01>>08786000
            if old then move bcbuf(6) := old'filename,(29)     <<b0.01>>08788000
                   else move bcbuf(6) := new'filename,(29);    <<b0.01>>08790000
            move bcbuf(6+28) := cr ;                           <<04145>>08792000
            move bcbuf := "PURGE ";                            <<b0.01>>08794000
            mpecommand(bcbuf);                                 <<b0.01>>08796000
            disp := %11;                                       <<b0.01>>08798000
            go to perm'close;                                  <<b0.01>>08800000
            end                                                <<b0.01>>08802000
                                                               <<04145>>08804000
       <<***************************************************>> <<04145>>08806000
       <<  otherwise, prompt the user for a new file name,  >> <<04145>>08808000
       << a cr signifies user wants the new file purged.    >> <<04145>>08810000
       <<***************************************************>> <<04145>>08812000
                                                               <<04145>>08814000
       else                                                    <<b0.01>>08816000
rename'file:                                                   <<b0.01>>08818000
          begin                                                <<b0.01>>08820000
          critflag := false;                                   <<b0.01>>08822000
          if controlyflag then controlyproc;                   <<b0.01>>08824000
          move cbuf := renamefile,2;                           <<b0.01>>08826000
          i := tos - @cbuf;                                    <<b0.01>>08828000
          print(cbuf,i,%320);                                  <<b0.01>>08830000
          count := read(cbuf,-72);                             <<b0.01>>08832000
          critflag := true;                                    <<b0.01>>08834000
          @bp := @bcbuf;                                       <<b0.01>>08836000
          bp(count) := cr ;                                    <<04145>>08838000
          if not shiftupper(bp,count) then                     <<b0.01>>08840000
             go rename'file;                                   <<b0.01>>08842000
          scan bp while %6440 ,1; <<cr , blank>>               <<b0.01>>08844000
          @bp := tos;                                          <<b0.01>>08846000
          if carry then                                        <<b0.01>>08848000
            begin                                              <<b0.01>>08850000
            disp := %4;  <<delete file>>                       <<b0.01>>08852000
            go to perm'close;                                  <<b0.01>>08854000
            end;                                               <<b0.01>>08856000
                                                               <<04145>>08858000
          <<************************************************>> <<04145>>08860000
          << otherwise rename the file and reclose it.  if  >> <<04145>>08862000
          << rename failed, return to rename'file to        >> <<04145>>08864000
          << prompt the user again.                         >> <<04145>>08866000
          <<************************************************>> <<04145>>08868000
                                                               <<04145>>08870000
          frename(new'filen,bp);                               <<b0.01>>08872000
          if <> then                                           <<b0.01>>08874000
             begin                                             <<b0.01>>08876000
             move cbuf := bad'rename,2;                        <<04145>>08878000
             i := tos - @cbuf;                                 <<04145>>08880000
             print(cbuf,i,0);                                  <<04145>>08882000
             go to rename'file;                                <<04145>>08884000
             end                                               <<b0.01>>08886000
          else                                                 <<b0.01>>08888000
             move cbuf := renamed'message,2;                   <<b0.01>>08890000
             i:= tos - @cbuf;                                  <<b0.01>>08892000
             print(cbuf,i,0);                                  <<b0.01>>08894000
             errn := 0;                                        <<b0.01>>08896000
             errf := no'file'error;                            <<04145>>08898000
             disp := %11;                                      <<04145>>08900000
             try'again:=false;                                 <<04145>>08902000
             go to perm'close;                                 <<04145>>08904000
          end;  << rename file >>                              <<04145>>08906000
                                                               <<04145>>08908000
          end; <<if error = 100 or 101 >>                      <<04145>>08910000
                                                               <<04145>>08912000
      fclose(new'filen,0,0); <<give back file space>>          <<04145>>08914000
      new'filen:=0;                                            <<04145>>08916000
      go to lx; <<if other than error 100 or 101>>             <<04145>>08918000
                                                               <<04145>>08920000
      end; <<if < on the fclose>>                              <<04145>>08922000
                                                               <<04145>>08924000
   end;  <<if permenent file>>                                 <<04145>>08926000
                                                               <<04145>>08928000
<<good fclose>>                                                <<04145>>08930000
                                                               <<04145>>08932000
                                                               <<x7786>>08934000
new'file'close := true;                                        <<b0.01>>08936000
new'filen := 0;                                                <<b0.01>>08938000
                                                               <<04145>>08940000
<<bad fclose>>                                                 <<04145>>08942000
                                                               <<04145>>08944000
lx:                                                            <<b0.01>>08946000
end;                                                           <<b0.01>>08948000
                                                               <<b0.01>>08950000
$control segment=spook3                                        <<b0.01>>08952000
                                                               <<b0.01>>08954000
logical procedure new'file'open;                               <<b0.01>>08956000
<<>>                                                           <<b0.01>>08958000
<< this procedure is invoked to create a new file>>            <<b0.01>>08960000
<< for copy/append or in the case of append to   >>            <<b0.01>>08962000
<< use file already opened for output.           >>            <<b0.01>>08964000
<<>>                                                           <<b0.01>>08966000
begin                                                          <<b0.01>>08968000
integer dev;                                                   <<b0.01>>08970000
integer temp;                                                           08972000
integer filex, orig'filen ;                                    <<01886>>08974000
logical pointer                                                <<06426>>08976000
   dct'head,                                                   <<06536>>08978000
   dct,                                                        <<x7786>>08980000
   xdd'subentry;                                               <<x7786>>08982000
double pointer                                                 <<06426>>08984000
   dctd = dct;                                                 <<06426>>08986000
byte pointer xdd'bsubentry;                                    <<x7786>>08988000
array cl(0:9) = q;                                             <<b0.01>>08990000
double dcl0 = cl + 0,dcl1 = cl+2;                              <<b0.01>>08992000
byte array bcl(*) = cl + 0;                                    <<b0.01>>08994000
logical stdlist;                                               <<x7786>>08996000
integer                                                        <<x7786>>08998000
        new'numbufs,                                           <<x7786>>09000000
        new'outpri,                                            <<x7786>>09002000
        new'copies,                                            <<x7786>>09004000
        new'aoptions,                                          <<x7786>>09006000
        new'dfid,                                              <<x7786>>09008000
        new'devtype,                                           <<x7786>>09010000
        new'ldev,                                              <<x7786>>09012000
        new'hdaddr;                                            <<x7786>>09014000
logical                                                        <<x7786>>09016000
        remote'file;                                           <<x7786>>09018000
byte array                                                     <<x7786>>09020000
        new'env(0:36),                                         <<x7786>>09022000
        new'device(0:8);                                       <<x7786>>09024000
<<>>                                                           <<b0.01>>09026000
@xdd'subentry := @xddbuf;                                      <<x7786>>09028000
@xdd'bsubentry := @bxddbuf;                                    <<x7786>>09030000
new'file'open := false;                                        <<b0.01>>09032000
stdlist := false;   <<initialize>>                             <<00123>>09034000
if new'filen <> 0 then  <<previously opened file>>             <<b0.01>>09036000
   if append then      <<append command>>                      <<b0.01>>09038000
      begin                                                    <<b0.01>>09040000
      new'file'open := true;                                   <<b0.01>>09042000
      goto quickout;                                           <<x7786>>09044000
      end                                                      <<b0.01>>09046000
   else                                                        <<b0.01>>09048000
      begin          <<new file, must close old file>>         <<b0.01>>09050000
      if not new'file'close(true) then goto quickout;          <<x7786>>09052000
      end;                                                     <<b0.01>>09054000
move new'device := "DISC"; <<default>>                         <<b0.01>>09056000
new'device(4):=0;                                              <<b0.01>>09058000
new'numbufs := 0;                                              <<b0.01>>09060000
if new'filename = "  " then                                    <<b0.01>>09062000
      begin                                                    <<b0.01>>09064000
      <<ensure that xdd array reflects text file>>             <<b0.01>>09066000
                                                               <<b0.01>>09068000
      spoolopen(devfn,filex);                                  <<b0.01>>09070000
      fsclose(filex,0,0);                                      <<b0.01>>09072000
     <<>>                                                      <<b0.01>>09074000
      move new'filename := xddsb'file'name,(8);                <<x7786>>09076000
      if new'filename = "$STDLIST" then                        <<00123>>09078000
         begin                                                 <<00123>>09080000
         stdlist := true;                                      <<00123>>09082000
         new'filename := "S";      <<change "$" to "S" >>      <<00123>>09084000
         end;                                                  <<00123>>09086000
      new'numbufs.(4:7):=new'copies:=odds'number'copies;       <<x7786>>09088000
      new'numbufs.(0:4):=new'outpri:=xdds'output'priority;     <<x7786>>09090000
      if xdds'class then   <<class bits>>                      <<x7786>>09092000
         begin                                                 <<b0.01>>09094000
         dev := -xdds'device;                                  <<x7786>>09096000
         @dct'head := 0;                                       <<06536>>09098000
         exchangedb(dct'dst);                                  <<06536>>09100000
         @dct := dcth'dct'base;                                <<06536>>09102000
         while (dev := dev +1) < 0 do                          <<b0.01>>09104000
            @dct := @dct+integer(dct'next'entry);              <<06426>>09106000
         dcl0 := dctd;                                         <<06426>>09108000
         dcl1 := dctd(1);                                      <<06426>>09110000
         exchangedb(0);                                        <<b0.01>>09112000
         move new'device := bcl,(8);                           <<b0.01>>09114000
         end                                                   <<b0.01>>09116000
      else                                                     <<b0.01>>09118000
         ascii(xdds'device,10,new'device);   << ldev >>        <<x7786>>09120000
      end;                                                     <<b0.01>>09122000
                                                               <<b0.01>>09124000
<<---------------------------------------------------------->> <<x7801>>09126000
<< fopen the new copy file with the following options:      >> <<x7801>>09128000
<<   foptions - variable recs, ascii, new file              >> <<x7801>>09130000
<<   aoptions - buf, excl. access, r/w access               >> <<x7801>>09132000
<<   records  - 132 bytes                                   >> <<x7801>>09134000
<<---------------------------------------------------------->> <<x7801>>09136000
                                                               <<b0.01>>09138000
new'filen := fopen(new'filename,%504,%1004,-132,                        09140000
                  new'device,,,,new'numbufs);                  <<b0.01>>09142000
if <> then                                                     <<b0.01>>09144000
   << unable to open copy file >>                              <<06426>>09146000
   begin errn:=74; fcheck(new'filen,errf); goto quickout;      <<x7786>>09148000
   end;                                                        <<b0.01>>09150000
                                                               <<x7786>>09152000
fgetinfo(new'filen,new'filename,,new'aoptions,,new'devtype,    <<x7786>>09154000
         new'ldev,new'hdaddr,new'dfid);                        <<b0.01>>09156000
   new'env := 0; <<initialize>>                                <<01886>>09158000
ffileinfo(new'filen,38,new'dfid,43, new'env);                  <<01886>>09160000
                                                               <<x7786>>09162000
<< find out if this is a remote file by looking at the aft  >> <<x7786>>09164000
<< entry type.  if it is, purge the new copy file.          >> <<x7786>>09166000
push(dl);                                                      <<00131>>09168000
tos := tos - 4 - new'filen * 4; <<aftentry>>                   <<00131>>09170000
remote'file := ps0.(0:4) = 1 <<entry type 1>>;                 <<00131>>09172000
del;                                                           <<00131>>09174000
if remote'file then                                                     09176000
   begin                                                                09178000
   errn := 77;  <<ds copy not available>>                               09180000
   fclose(new'filen,4,0); <<purge new file>>                            09182000
   new'filen := 0;                                                      09184000
   goto quickout;                                              <<x7786>>09186000
   end;                                                                 09188000
                                                               <<x7786>>09190000
if new'hdaddr.(0:8) = 0 then                                   <<b0.01>>09192000
   <<new spoolfile>>                                           <<b0.01>>09194000
   begin                                                       <<b0.01>>09196000
   if not sfindodd(new'dfid,new'xddn) then                     <<b0.01>>09198000
   << spool file create error >>                               <<06426>>09200000
      begin errn := 75; goto quickout; end;                    <<x7786>>09202000
   pri := 1;                                                   <<b0.01>>09204000
   copies := 0;                                                <<b0.01>>09206000
   class := 0;                                                 <<x7786>>09208000
   device := 0;                                                <<x7786>>09210000
   alterxdd(new'dfid);     <<temporary defer>>                 <<b0.01>>09212000
   fclose(new'filen,0,0);                                      <<b0.01>>09214000
   if not spoolopen(new'dfid,new'filen) then                   <<b0.01>>09216000
      goto quickout;                                           <<x7786>>09218000
   move sbuf(512) := sbuf, (512); <<store current block>>      <<b0.01>>09220000
   fread(new'filen,sbuf,512);  <<get fopen record>>            <<b0.01>>09222000
   move new'bufw := sbuf,((sbuf+3)/2);<<fopen record>>         <<b0.01>>09224000
   file'formsmsg := if sbuf > 8 then true                      <<b0.01>>09226000
        else false;      <<if formsmsg then true>>             <<b0.01>>09228000
   inhibit'fopen := false;                                     <<01726>>09230000
   orig'filen := new'filen;                                    <<01886>>09232000
   xdds'output'priority := old'pri;                            <<x7786>>09234000
   dev := xdds'device;                                         <<x7786>>09236000
   if xdds'class then dev := -dev;                             <<x7786>>09238000
   xdds'spool'state := xdds'open;                              <<x7786>>09240000
   if stdlist then begin <<change "S" back to "$">>            <<00123>>09242000
                   stdlist := false; xdds'file'name := "$S";   <<x7786>>09244000
                   end;                                        <<00123>>09246000
   if sputxdd(1,dev,xdd'subentry,new'xddnp) <> 0 then          <<x7786>>09248000
      << no room in device table >>                            <<06426>>09250000
      begin errn := 59; goto quickout; end;                    <<x7786>>09252000
   new'filen := fsopen(,%304,%501,new'xddn);                   <<b0.01>>09254000
   if < then                                                   <<b0.01>>09256000
      << unable to open copy file >>                           <<06426>>09258000
      begin errn := 74; sremovexdd(new'xddnp);                 <<b0.01>>09260000
       new'filen := 0;                                         <<b0.01>>09262000
      end;                                                     <<b0.01>>09264000
   fcontrol(orig'filen,5,temp); <<rewind spoolfile>>                    09266000
                                                               <<x7786>>09268000
   do                                                          <<01886>>09270000
   begin  <<read original file and write fopen, env recs>>     <<01886>>09272000
      fread(orig'filen, sbuf, 512);                            <<01886>>09274000
      if <> then goto close;                                   <<x7786>>09276000
      fwrite(new'filen, sbuf, 512, 0);                         <<01886>>09278000
      if <> then                                               <<01886>>09280000
      << file write error >>                                   <<06426>>09282000
      begin errn := 27; goto quickout; end;                    <<x7786>>09284000
   end                                                         <<01886>>09286000
   until false;                                                <<x7786>>09288000
close:                                                         <<x7786>>09290000
   fsclose(orig'filen,4,0);  <<purge file>>                    <<01886>>09292000
   new'spoolfile := true;                                      <<b0.01>>09294000
   end;                                                        <<b0.01>>09296000
new'file'open := true;                                         <<b0.01>>09298000
quickout:                                                      <<x7786>>09300000
end;                                                           <<b0.01>>09302000
                                                               <<b0.01>>09304000
                                                               <<b0.01>>09306000
$page                                                          <<04145>>09308000
$control segment=spook2                                        <<b0.01>>09310000
                                                               <<b0.01>>09312000
logical procedure copyrange;                                   <<x7786>>09314000
   begin                                                       <<x7786>>09316000
   integer lsp;                                                <<x7786>>09318000
   integer                                                     <<x7786>>09320000
      new'foptions,                                            <<x7786>>09322000
      new'recsize,                                             <<x7786>>09324000
      old'rec'size;   << # of bytes to xfer from old spoofle>> <<04626>>09326000
   logical uni;                                                <<b0.01>>09328000
   byte pointer bsp,new'buf'pntr;                              <<04626>>09330000
   logical pointer sp'next;                                    <<b0.01>>09332000
   define new'var'file = new'foptions.(8:2)=1#;                <<04626>>09334000
define cctloption = logical(new'foptions.(7:1))#;              <<x7786>>09336000
define nocctl'input = logical(sp(3) = 0 land sp(2) = 1)#;      <<x7786>>09338000
   << >>                                                       <<b0.01>>09340000
   uni := true;                                                <<b0.01>>09342000
   do                                                          <<b0.01>>09344000
      begin                                                    <<b0.01>>09346000
      if uni then                                              <<b0.01>>09348000
      begin                                                    <<b0.01>>09350000
         uni := false ;                                        <<b0.01>>09352000
      if new'spoolfile then                                    <<b0.01>>09354000
         begin                                                 <<b0.01>>09356000
         if not file'formsmsg and not inhibit'fopen then       <<01726>>09358000
         copy'last'open;                                       <<b0.01>>09360000
                                                               <<b0.01>>09362000
         inhibit'fopen := true; <<just copy first fopen>>      <<01726>>09364000
         file'formsmsg := false; <<reset for subseqent fopens>><<b0.01>>09366000
         compress(sbuf,@sp,512);                               <<b0.01>>09368000
         @sp := @sbuf;                                         <<b0.01>>09370000
         end;                                                  <<b0.01>>09372000
      end                                                      <<b0.01>>09374000
      else                                                     <<b0.01>>09376000
         if not skantoline(false) then goto lx;                <<b0.01>>09378000
                                                               <<04145>>09380000
      <<****************************************************>> <<04145>>09382000
      << now, sp(word pointer) points to the beginning of   >> <<04145>>09384000
      << the next spoolfile record to copy and bsp(byte ptr)>> <<04145>>09386000
      << points to the beginning of the data of the record. >> <<04145>>09388000
      << the spoolfile record looks like the following:     >> <<04145>>09390000
      <<                                                    >> <<04145>>09392000
      <<   sp----->------------------------------------     >> <<04145>>09394000
      <<    word 0 | byte count of entire record - 2  |     >> <<04145>>09396000
      <<           |----------------------------------|     >> <<04145>>09398000
      <<    word 1 | byte cnt data portion, w/blanks  |     >> <<04145>>09400000
      <<           |----------------------------------|     >> <<04145>>09402000
      <<    word 2 | function code of attachio        |     >> <<04145>>09404000
      <<           |----------------------------------|     >> <<04145>>09406000
      <<    word 3 | p1 attachio parameter            |     >> <<04145>>09408000
      <<           |----------------------------------|     >> <<04145>>09410000
      <<    word 4 | p2 attachio parameter            |     >> <<04145>>09412000
      <<   bsp---->|----------------------------------|     >> <<04145>>09414000
      <<    word 5+| data portion of record           |     >> <<04145>>09416000
      <<           ~                                  ~     >> <<04145>>09418000
      <<           |----------------------------------|     >> <<04145>>09420000
      <<****************************************************>> <<04145>>09422000
                                                               <<04145>>09424000
      @bsp := @sp(5)&asl(1);                                   <<b0.01>>09426000
      lsp := flinecnt;                                         <<b0.01>>09428000
                                                               <<x7786>>09430000
      <<****************************************************>> <<04145>>09432000
      << if we are copying to a new spoolfile, then check if>> <<04145>>09434000
      << we are at the end of a block (-1 after record).    >> <<04145>>09436000
      <<****************************************************>> <<04145>>09438000
                                                               <<04145>>09440000
      if new'spoolfile then                                    <<b0.01>>09442000
      begin                                                    <<b0.01>>09444000
      @sp'next := logical(@sp) + logical((sp +3)/2);           <<b0.01>>09446000
      if  sp'next = -1 then                                    <<b0.01>>09448000
         begin                                                 <<b0.01>>09450000
         fwrite(new'filen,sbuf,512,0);                         <<b0.01>>09452000
         if <> then                                            <<b0.01>>09454000
            begin                                              <<b0.01>>09456000
            << file write error >>                             <<06426>>09458000
            errn := 27; fcheck(new'filen,errf); go to lx;      <<b0.01>>09460000
            end;                                               <<b0.01>>09462000
                                                               <<b0.01>>09464000
         end;                                                  <<b0.01>>09466000
      end                                                      <<b0.01>>09468000
                                                               <<04145>>09470000
      <<****************************************************>> <<04145>>09472000
      << otherwise, we have a regular disc file.  the start->> <<04626>>09474000
      << ing byte location of the new file buffer and the   >> <<04626>>09476000
      << old file buffer bsp, will be different when copying>> <<04626>>09478000
      << from nocctl to cctl or vise-versa.  when copying   >> <<04626>>09480000
      << to a file with cctl, transform the fcontrol func-  >> <<04626>>09482000
      << tions to a record with only a cctl byte in it,     >> <<04626>>09484000
      << equal to the fcontrol function.                    >> <<04626>>09486000
      <<****************************************************>> <<04145>>09488000
                                                               <<04145>>09490000
      else                                                     <<b0.01>>09492000
         begin                                                 <<b0.01>>09494000
   fgetinfo(new'filen,new'filename,new'foptions,,              <<x7786>>09496000
            new'recsize,,,,);                                  <<x7786>>09498000
         new'buf(0) := " ";  << blank out the new buffer.   >> <<04626>>09500000
         move new'buf(1) := new'buf(0),(255);                  <<04626>>09502000
         old'rec'size := sp(0) - 8; << size of actual data. >> <<04626>>09504000
         @new'buf'pntr := @new'buf; << assume no change.    >> <<04626>>09506000
                                                               <<04626>>09508000
         << for variable files, record size in neg. bytes.  >> <<04626>>09510000
                                                               <<04626>>09512000
         if new'var'file                                       <<04626>>09514000
            then new'recsize := -old'rec'size;                 <<04626>>09516000
         if cctloption then                                    <<04626>>09518000
            begin << new file has carriage control          >> <<04626>>09520000
            if sp(2) = 2 and old'rec'size = 0 then             <<04626>>09522000
               begin   << fcontrol function! place in cctl  >> <<04626>>09524000
               old'rec'size := 1;   << transfer one byte    >> <<04626>>09526000
               if new'var'file                                 <<04626>>09528000
                  then new'recsize := -1;                      <<04626>>09530000
               @bsp := @bsp - 3;    << point p1 control byte>> <<04626>>09532000
               end                                             <<04626>>09534000
                                                               <<04626>>09536000
            <<**********************************************>> <<04626>>09538000
            << new file has cctl, old file does not, skip   >> <<04626>>09540000
            << past cctl byte of new file.                  >> <<04626>>09542000
            <<**********************************************>> <<04626>>09544000
                                                               <<04626>>09546000
            else if nocctl'input then                          <<04626>>09548000
               @new'buf'pntr := @new'buf'pntr + 1;             <<04626>>09550000
            end                                                <<04626>>09552000
         else if not nocctl'input then                         <<04626>>09554000
            begin << new does not have cctl, old file does! >> <<04626>>09556000
            @bsp := @bsp + 1;  << skip over cctl byte.      >> <<04626>>09558000
            if old'rec'size > 1                                <<04626>>09560000
               then old'rec'size := old'rec'size - 1;          <<04626>>09562000
            if new'var'file << decrement variable count.  >>   <<04626>>09564000
               then new'recsize := new'recsize + 1;            <<04626>>09566000
            end;                                               <<04626>>09568000
                                                               <<04626>>09570000
         <<*************************************************>> <<04626>>09572000
         << now do the move and write the record.  the de-  >> <<04626>>09574000
         << fault cctl for new files is single space (" "). >> <<04626>>09576000
         <<*************************************************>> <<04626>>09578000
                                                               <<04626>>09580000
          if new'recsize <> 0 and old'rec'size <> 0 then       <<04626>>09582000
             begin                                             <<04626>>09584000
             move new'buf'pntr := bsp,(old'rec'size);          <<04626>>09586000
             if new'buf(0) = 0 and cctloption                  <<04626>>09588000
                then new'buf(0) := " ";                        <<04626>>09590000
             fwrite(new'filen,new'bufw,new'recsize,1);         <<04626>>09592000
             if <> then                                        <<04626>>09594000
                begin                                          <<04626>>09596000
               << file write error >>                          <<06426>>09598000
                errn := 27;                                    <<04626>>09600000
                fcheck(new'filen,errf);                        <<04626>>09602000
                go to lx;                                      <<04626>>09604000
                end;                                           <<04626>>09606000
             end;                                              <<04626>>09608000
         critflag := false; if controlyflag then controlyproc; <<04145>>09610000
         critflag := true;                                     <<04145>>09612000
         end; <<else of if new'spoolfile>>                     <<04145>>09614000
      end   <<of do until fline >= toline >>                   <<04145>>09616000
   until fline >= toline;                                      <<b0.01>>09618000
$page                                                          <<04145>>09620000
   <<*******************************************************>> <<04145>>09622000
   << if you can explain the below code, be my guest!!!     >> <<04145>>09624000
   <<*******************************************************>> <<04145>>09626000
                                                               <<04145>>09628000
   if new'spoolfile then                                       <<b0.01>>09630000
      if toline < eofline and sp'next <> -1 then               <<b0.01>>09632000
      begin                                                    <<b0.01>>09634000
      move sbuf(512) := sbuf,(512);                            <<b0.01>>09636000
       sp'next := -1;                                          <<b0.01>>09638000
      move  sp'next(1) :=  sp'next,(  512-( @sp'next-@sbuf)-1);<<b0.01>>09640000
      fwrite(new'filen,sbuf,512,0);                            <<b0.01>>09642000
      if <> then                                               <<b0.01>>09644000
         begin   << file write error >>                        <<06426>>09646000
        errn := 27; fcheck(new'filen,errf);                    <<b0.01>>09648000
        go to lx;                                              <<b0.01>>09650000
        end;                                                   <<b0.01>>09652000
      move sbuf := sbuf(512),(512); <<restore last block>>     <<b0.01>>09654000
<<    freaddir(filen,sbuf,512,blockno);   restore last block>> <<b0.01>>09656000
<<    if <> then  >>                                           <<b0.01>>09658000
<<    begin      >>                                            <<b0.01>>09660000
<<       errn:= 26; fcheck(filen,errf); go to lx;   >>         <<b0.01>>09662000
<<       end;  >>                                              <<b0.01>>09664000
      end;                                                     <<b0.01>>09666000
                                                               <<b0.01>>09668000
   copyrange := true;                                          <<b0.01>>09670000
lx:                                                            <<b0.01>>09672000
   end;                                                        <<b0.01>>09674000
$control segment=spook2                                        <<00897>>09676000
                                                               <<00897>>09678000
logical procedure text'next'file(xdd'subentry);                <<x7786>>09680000
  logical pointer xdd'subentry;                                <<x7786>>09682000
                                                               <<00897>>09684000
begin                                                          <<00897>>09686000
                                                               <<00897>>09688000
   text'next'file := false;                                    <<00897>>09690000
   @xdd'subentry := @xdd'subentry-size'of'xdd'subentry;        <<x7786>>09692000
   if filen <> 0 then                                          <<00897>>09694000
      begin   <<release the currently texted file>>            <<00897>>09696000
         oddn := findodd(xddn);                                <<x7786>>09698000
         fsclose(filen,0,0);                                   <<00897>>09700000
         if < then                                             <<00897>>09702000
         begin     << unable to close file >>                  <<06426>>09704000
            errn := 24;                                        <<00897>>09706000
            fcheck(filen,errf);                                <<00897>>09708000
            go to lx;                                          <<00897>>09710000
         end;                                                  <<00897>>09712000
         srooster(oddn);                                       <<x7786>>09714000
         filen := 0;                                           <<00897>>09716000
         xddn := 0;                                            <<00897>>09718000
         devfn := 0;                                           <<00897>>09720000
      end;                                                     <<00897>>09722000
   if not spoolopen(devf := xdds'dfid'all,filef) then          <<x7786>>09724000
      go to lx ;                                               <<00897>>09726000
   start'recnum := fline + 1d; <<initialize start'recnum>>   <<<<01549>>09728000
   @blockfp := @blockcp := @blocktable;                        <<00897>>09730000
   blockno := 0d;                                              <<00897>>09732000
   blockfp := 0;                                               <<00897>>09734000
   move blockfp(1) := blockfp, (bentries*bentry'size-1);       <<00897>>09736000
   filen := filef;                                             <<00897>>09738000
   xddn := xddx;                                               <<00897>>09740000
   devfn := devf;                                              <<00897>>09742000
   fline := -1d;                                               <<00897>>09744000
   fgetinfo(filen,,,,,,,,,,eofline);                           <<00897>>09746000
   eofline := eofline - 1d;                                    <<00897>>09748000
   text'next'file := true;                                     <<00897>>09750000
lx:                                                            <<00897>>09752000
end;   <<text'next'file>>                                      <<00897>>09754000
                                                               <<00897>>09756000
$control segment = spook2                                      <<00897>>09758000
<<---------------------------------------------------------->> <<x7801>>09760000
<< alter'files is called by the main loop to process the    >> <<x7801>>09762000
<< alter command.  it in turn calls alterxdd, which changes >> <<x7801>>09764000
<< the actual xdd subentry in the odd or idd.  errors re-   >> <<x7801>>09766000
<< turned from alterxdd are saved.                          >> <<x7801>>09768000
<<---------------------------------------------------------->> <<x7801>>09770000
                                                               <<x7801>>09772000
                                                               <<00897>>09774000
logical procedure alter'files;                                 <<00897>>09776000
                                                               <<00897>>09778000
begin                                                          <<00897>>09780000
                                                               <<00897>>09782000
logical pointer xdd'subentry;                                  <<x7786>>09784000
                                                               <<00897>>09786000
   alter'files := false;                                       <<00897>>09788000
   count := 0;                                                 <<00897>>09790000
   @xdd'subentry := initxddp;                                  <<x7786>>09792000
   while (count := count+1)<= xddc                             <<00897>>09794000
   do                                                          <<00897>>09796000
      begin                                                    <<00897>>09798000
         @xdd'subentry := @xdd'subentry-size'of'xdd'subentry;; <<x7786>>09800000
         move xddbuf := xdd'subentry,(size'of'xdd'subentry);   <<x7786>>09802000
         if not alterxdd(xddbuf(xd'dfid)) then                 <<x7786>>09804000
         begin <<store errors in xdd copy in stack>>           <<01326>>09806000
            xdds'spook'err := errn;                            <<x7786>>09808000
            xdds'filesys'err := errf;                          <<x7786>>09810000
            errn := 0;                                         <<04145>>09812000
            errf := no'file'error;                             <<04145>>09814000
         end                                                   <<01726>>09816000
         else                                                  <<01726>>09818000
            begin     << copy altered fields from xddbuf >>    <<a8449>>09820000
             xdd'subentry := xddbuf;                           <<x7786>>09822000
               xdds'device := xddbuf (xd'device);              <<a8449>>09824000
             xdds'copy'info := xddbuf(xd'copy'info);           <<x7786>>09826000
         end;                                                  <<01726>>09828000
      end;                                                     <<00897>>09830000
   alter'files := true;                                        <<00897>>09832000
                                                               <<x7786>>09834000
end;    <<alter'files>>                                        <<00897>>09836000
                                                               <<00897>>09838000
$control segment = spook2                                      <<00897>>09840000
                                                               <<00897>>09842000
logical procedure copy'files;                                  <<00897>>09844000
                                                               <<00897>>09846000
begin                                                          <<00897>>09848000
                                                               <<00897>>09850000
logical pointer xdd'subentry;                                  <<x7786>>09852000
                                                               <<00897>>09854000
copy'files := false;                                           <<00897>>09856000
   count := 0;                                                 <<00897>>09858000
   @xdd'subentry := initxddp;                                  <<x7786>>09860000
   while (count := count + 1) <=xddc                           <<00897>>09862000
   do  begin                                                   <<00897>>09864000
      @bp := @secondparm;                                      <<00897>>09866000
      if copy'files'flag then                                  <<00897>>09868000
      if not text'next'file(xdd'subentry) then go to exit1;    <<x7786>>09870000
      if not linerange(copy) then  go to exit1;                <<00897>>09872000
      if not new'file'open then go to exit1;                   <<00897>>09874000
      if not skantoline(true) then go to exit1;                <<00897>>09876000
      if not copyrange then go to exit1;                       <<x7786>>09878000
      if not append then                                       <<00897>>09880000
         if not new'file'close(false) then go to exit1;        <<00897>>09882000
   end;                                                        <<00897>>09884000
   copy'files := true;                                         <<00897>>09886000
                                                               <<00897>>09888000
exit1:                                                         <<00897>>09890000
end;  <<copy'files>>                                           <<00897>>09892000
                                                               <<01726>>09894000
$page "READ'RECORD WITH FREADDIR PROCEDURE"                    <<01726>>09896000
                                                               <<01726>>09898000
$control segment = spook2                                      <<01726>>09900000
                                                               <<01726>>09902000
   procedure read'record(filenum, recordnum, buffer, recp,     <<01726>>09904000
        xddp,blocknum, errnum);                                <<01726>>09906000
                                                               <<01726>>09908000
      value recordnum, filenum, xddp;                          <<01726>>09910000
      double recordnum, blocknum;                              <<01726>>09912000
      integer pointer recp;                                    <<01726>>09914000
      integer errnum, filenum;                                 <<01726>>09916000
      logical xddp;                                            <<01726>>09918000
      logical array buffer;                                    <<01726>>09920000
                                                               <<01726>>09922000
   begin                                                       <<01726>>09924000
      comment                                                  <<01726>>09926000
        this procedure reads a block containing                <<01726>>09928000
        the recordnum into buffer and points to                <<01726>>09930000
        recordnum with recp, places the block                  <<01726>>09932000
        number in blocknum.                                    <<01726>>09934000
        if filesys error then errnum contains the error        <<01726>>09936000
        otherwise errnum = no'file'error.                      <<04145>>09938000
        if recordnum is < first non purged recordnum           <<01726>>09940000
        then we return ccl.                                    <<01726>>09942000
        if recordum is past the end of file we                 <<01726>>09944000
        return ccg. otherwise cce.                             <<01726>>09946000
                                                               <<01726>>09948000
                                        ;                      <<01726>>09950000
                                                               <<01726>>09952000
   double rec'first'block,                                     <<01726>>09954000
          block'eof,                                           <<01726>>09956000
          rec'eof,                                             <<01726>>09958000
          rec'curr'block,                                      <<01726>>09960000
          first'block,                                         <<01726>>09962000
          tot'sectors,                                         <<01726>>09964000
          target'block,                                        <<01726>>09966000
          last'target'block,                                   <<01726>>09968000
          hi'h2o,                                              <<01726>>09970000
          lo'h2o,                                              <<01726>>09972000
          dcount;                                              <<01726>>09974000
                                                               <<01726>>09976000
   integer rec'cnt'in'block,                                   <<01726>>09978000
          numspulabs,                                          <<01726>>09980000
          first'extent,                                        <<01726>>09982000
          length,                                              <<01726>>09984000
          index,                                               <<01726>>09986000
          scount;                                              <<01726>>09988000
                                                               <<01726>>09990000
   logical status = q-1;                                       <<01726>>09992000
   logical continue,                                           <<01726>>09994000
            single'step,                                       <<01730>>09996000
          extent'in'sectors;                                   <<01726>>09998000
                                                               <<01726>>10000000
                                                               <<01726>>10002000
   logical array xdd'subentry(0:size'of'xdd'subentry-1);       <<x7786>>10004000
                                                               <<01726>>10006000
   define condcode = status.(6:2)#;                            <<01726>>10008000
                                                               <<01726>>10010000
   equate  cce = 2,                                            <<01726>>10012000
           ccg = 0,                                            <<01726>>10014000
           ccl = 1,                                            <<01726>>10016000
           ulab = 17,   <<integer>>                            <<01726>>10018000
           eof = 10,    <<double>>                             <<01726>>10020000
           nzextent = 39, <<logical>>                          <<01726>>10022000
           extentsize = 15; <<logical>>                        <<x7786>>10024000
                                                               <<01726>>10026000
subroutine def'movefromdseg;                                   <<01726>>10028000
                                                               <<01726>>10030000
subroutine point'to'record;                                    <<01726>>10032000
   begin                                                       <<01726>>10034000
       comment                                                 <<01726>>10036000
           given a buffer the last two words are               <<01726>>10038000
           the recordnumber of the first record                <<01726>>10040000
           in block.                                           <<01726>>10042000
           point to target recnum with recp                    <<01726>>10044000
                                            ;                  <<01726>>10046000
                                                               <<01726>>10048000
      scount := 0;                                             <<01726>>10050000
      tos := buffer(510);                                      <<01726>>10052000
      tos := buffer(511);                                      <<01726>>10054000
      dcount := tos;                                           <<01726>>10056000
      @recp := @buffer;                                        <<01726>>10058000
      continue := true;                                        <<01726>>10060000
      do                                                       <<01726>>10062000
      begin                                                    <<01726>>10064000
         if dcount >= recordnum then                           <<01726>>10066000
            continue := false                                  <<01726>>10068000
         else                                                  <<01726>>10070000
            begin                                              <<01726>>10072000
               length := buffer(scount);                       <<01726>>10074000
               index := scount;                                <<01726>>10076000
               scount := scount + (length+3)&asr(1);           <<01726>>10078000
               dcount := dcount + 1d;                          <<01726>>10080000
            end;                                               <<01726>>10082000
       end                                                     <<01726>>10084000
       until (not continue) lor (integer(buffer(scount))       <<01726>>10086000
                 = -1);                                        <<01726>>10088000
       @recp := @buffer + scount;                              <<01726>>10090000
   end;  <<subroutine point'to'record>>                        <<01726>>10092000
                                                               <<01726>>10094000
   << find initial parameters defining spoolfile>>             <<01726>>10096000
                                                               <<01726>>10098000
   condcode := cce;                                            <<01726>>10100000
   ffileinfo(filenum, ulab,       numspulabs,                  <<01726>>10102000
                      eof,        rec'eof,                     <<01726>>10104000
                      extentsize, extent'in'sectors,           <<01726>>10106000
                      nzextent,   first'extent);               <<01726>>10108000
                                                               <<01726>>10110000
                                                               <<01726>>10112000
   movefromdseg(@xdd'subentry, odd'dst, xddp.idnum,            <<x7786>>10114000
       size'of'xdd'subentry);                                  <<x7786>>10116000
                                                               <<01726>>10118000
   tos := 0;                                                   <<01726>>10120000
   tos := xdds'number'extents;                                 <<x7786>>10122000
   if = then tos := tos + 1;                                   <<01726>>10124000
   tos := logical( tos - 1)**extent'in'sectors;                <<01726>>10126000
   tos := tos + double(xdds'last'extent'size);                 <<x7786>>10128000
   tot'sectors := tos;   <<total sectors in file>>             <<01726>>10130000
   block'eof := (double(((first'extent                         <<01726>>10132000
          -(if first'extent = 0 then 0 else 1))                <<01726>>10134000
          * integer(extent'in'sectors))                        <<01726>>10136000
                - (numspulabs + 1))                                     10138000
                + tot'sectors)&dasr(2);                                 10140000
   first'block := double((first'extent *                       <<01726>>10142000
          integer(extent'in'sectors)                           <<01726>>10144000
          - (if first'extent = 0 then 0 else                   <<01726>>10146000
            (numspulabs + 1)))&asr(2));                        <<01726>>10148000
   rec'curr'block := target'block := 0d;                       <<01726>>10150000
   if recordnum > rec'eof then                                 <<01726>>10152000
   begin                                                       <<01726>>10154000
      condcode := ccg;                                         <<01726>>10156000
      return;                                                  <<01726>>10158000
   end                                                         <<01726>>10160000
   else                                                        <<01726>>10162000
   begin                                                       <<01726>>10164000
      freaddir(filenum,buffer, 512, first'block);              <<01726>>10166000
      if <> then                                               <<01726>>10168000
      begin                                                    <<01726>>10170000
         fcheck(filenum, errnum);  <<error in first block>>    <<01726>>10172000
         condcode := ccl;                                      <<01726>>10174000
         continue := false;                                    <<01726>>10176000
      end                                                      <<01726>>10178000
      else                                                     <<01726>>10180000
      begin  <<read went ok, get recordnum of first block>>    <<01726>>10182000
         tos := buffer(510);                                   <<01726>>10184000
         tos := buffer(511);                                   <<01726>>10186000
         rec'first'block := tos;                               <<01726>>10188000
         if recordnum < rec'first'block then                   <<01726>>10190000
         begin  <<target record before beginning of file>>     <<01726>>10192000
            condcode := ccl;                                   <<01726>>10194000
            return;                                            <<01726>>10196000
         end;                                                  <<01726>>10198000
      end;                                                     <<01726>>10200000
  end;                                                         <<01726>>10202000
                                                               <<01726>>10204000
   continue := true;   <<initialize>>                          <<01726>>10206000
    lo'h2o := first'block;                                     <<01726>>10208000
    hi'h2o := block'eof - 1d;                                  <<01730>>10210000
    single'step := false;                                      <<01730>>10212000
   do                                                          <<01726>>10214000
   begin << iteratively find block of targetrec>>              <<01726>>10216000
      last'target'block := target'block;                       <<01726>>10218000
      target'block := target'block +                           <<01726>>10220000
              (block'eof * (recordnum - rec'curr'block))       <<01726>>10222000
              / rec'eof;                                       <<01726>>10224000
                                                               <<01726>>10226000
      if first'block > target'block then                       <<01726>>10228000
         target'block := first'block                           <<01726>>10230000
               + (last'target'block - first'block)&dasr(1)     <<01726>>10232000
      else                                                     <<01726>>10234000
      if target'block > block'eof then                         <<01726>>10236000
         target'block := last'target'block +                   <<01726>>10238000
               (block'eof - last'target'block)&dasr(1) ;       <<01726>>10240000
                                                               <<01726>>10242000
                                                               <<01726>>10244000
             << read target block, see if in ballpark>>        <<01726>>10246000
            if last'target'block <  target'block then          <<01730>>10248000
            lo'h2o := last'target'block + 1d                   <<01726>>10250000
            else                                               <<01726>>10252000
            if last'target'block >  target'block then          <<01730>>10254000
            hi'h2o := last'target'block - 1d;                  <<01726>>10256000
            if last'target'block = target'block then           <<01730>>10258000
            begin                                              <<01730>>10260000
               single'step := true;                            <<01730>>10262000
            end;                                               <<01730>>10264000
            if target'block < lo'h2o then                      <<01726>>10266000
               target'block := lo'h2o;                         <<01726>>10268000
            if target'block > hi'h2o then                      <<01726>>10270000
               target'block := hi'h2o;                         <<01726>>10272000
try'read:                                                      <<01730>>10274000
         critflag := false;                                    <<01726>>10276000
         if controlyflag then controlyproc;                    <<01726>>10278000
         critflag := true;                                     <<01726>>10280000
         freaddir(filenum, buffer, 512, target'block);         <<01726>>10282000
         if <> then                                            <<01726>>10284000
         begin                                                 <<01726>>10286000
            fcheck(filenum, errnum);                           <<01726>>10288000
            condcode := ccl;                                   <<01726>>10290000
            continue := false;                                 <<01726>>10292000
         end                                                   <<01726>>10294000
         else                                                  <<01726>>10296000
         begin  <<see if we are in right block>>               <<01726>>10298000
            tos := buffer(510);                                <<01726>>10300000
            tos := buffer(511);                                <<01726>>10302000
            rec'curr'block := tos;                             <<01726>>10304000
            verify'block'structure(buffer, index,              <<01726>>10306000
                 rec'cnt'in'block);                            <<01726>>10308000
            if rec'curr'block <= recordnum and                 <<01726>>10310000
               recordnum <  rec'curr'block +                   <<01726>>10312000
                double(rec'cnt'in'block   ) then               <<01726>>10314000
            begin << a hit !!!>>                               <<01726>>10316000
               errnum := no'file'error;                        <<04145>>10318000
               condcode := cce;                                <<01726>>10320000
               blocknum := target'block;                       <<01726>>10322000
               point'to'record;                                <<01726>>10324000
               continue := false;                              <<01726>>10326000
            end                                                <<01730>>10328000
            else                                               <<01730>>10330000
            if single'step then                                <<01730>>10332000
            begin                                              <<01730>>10334000
               if recordnum < rec'curr'block then              <<01730>>10336000
                  target'block := target'block -1d             <<01730>>10338000
               else                                            <<01730>>10340000
                  target'block := target'block + 1d;           <<01730>>10342000
               go to try'read;                                 <<01730>>10344000
            end;                                               <<01730>>10346000
         end;                                                  <<01726>>10348000
                                                               <<01726>>10350000
  end                                                          <<01726>>10352000
                                                               <<01726>>10354000
  until not continue;                                          <<01726>>10356000
end; <<read'record>>                                           <<01726>>10358000
                                                               <<01726>>10360000
$page  "SPOOK OUTER BLOCK"                                     <<b0.00>>10362000
<< - - -   main program   - - - >>                             <<01.02>>10364000
                                                                        10366000
spook:                                                         <<b0.00>>10368000
   pinoffather:=father;                                        <<b0.00>>10370000
   if = then subtask:=true;                                    <<b0.00>>10372000
   subtask'level := if sublevel = 0 then "1"                   <<b0.00>>10374000
        else sublevel+1;                                       <<b0.00>>10376000
   critflag := true;                                           <<b0.00>>10378000
   cylabel := @controly;                                                10380000
   push(q);                                                             10382000
   qval := tos;                                                         10384000
   push(s);                                                             10386000
   sval := tos;                                                         10388000
   aritrap(false);                                             <<01.02>>10390000
   push(status);                                                        10392000
   statval := tos;                                                      10394000
   xcontrap(cylabel,cyold);                                             10396000
   if cylabel = 0 then                                                  10398000
      begin                                                             10400000
         <<*************************************************>> <<04145>>10402000
         << entrance from control y procedure.              >> <<04145>>10404000
         <<*************************************************>> <<04145>>10406000
                                                               <<04145>>10408000
cynext:                                                                 10410000
      push(s);                                                          10412000
      tos := tos-sval;                                                  10414000
      assemble(subs 0);                                                 10416000
      if filet <> 0 then                                                10418000
         begin                                                          10420000
         fclose(filet,1,0);                                    <<02724>>10422000
         filet := 0;                                                    10424000
         end;                                                           10426000
       move cbuf := "  ** Control Y ** ";                      <<04145>>10428000
      print(cbuf,-17,0);                                       <<04145>>10430000
      goto next;                                                        10432000
      end                                                               10434000
   else                                                                 10436000
      cyaddr := @cynext;                                                10438000
                                                               <<04145>>10440000
   <<*******************************************************>> <<04145>>10442000
   << obtain a variety of information from the "WHO", inclu->> <<04145>>10444000
   << ding capabilities, names, ldev etc.  initialize global>> <<04145>>10446000
   << variables and print title.                            >> <<04145>>10448000
   <<*******************************************************>> <<04145>>10450000
                                                               <<04145>>10452000
   who(mode,cap,lat,names(0),names(8),names(4),                         10454000
                    names(12),ldev);                                    10456000
   if cap1.(5:1) then cap1.(0:1) := 1;                                  10458000
   errn := 0;                                                           10460000
   errf := no'file'error;                                      <<04145>>10462000
   warn := 0;                                                           10464000
   filen := 0;                                                          10466000
   filet := 0;                                                          10468000
   xddn := 0;                                                           10470000
   devfn := 0;                                                          10472000
   fall := false;                                                       10474000
   fwidth := 0;                                                         10476000
spook'title:                                                            10478000
   move cbuf := ptitle,2;                                      <<01.02>>10480000
   i := tos-@cbuf;                                             <<01.02>>10482000
   move bcbuf(vuuff'col) := official'vuuff;                    <<04151>>10484000
   print(cbuf,i,0);                                            <<01.02>>10486000
                                                               <<*7979>>10488000
   <<------------------------------------------------------->> <<*7979>>10490000
   << see if this is the correct version of spook running on>> <<*7979>>10492000
   << the appropriate system by looking at the pcb entry    >> <<*7979>>10494000
   << size (16 for mpe4, 21 for mpe5).  if not, print mes-  >> <<*7979>>10496000
   << sage and exit.                                        >> <<*7979>>10498000
   <<------------------------------------------------------->> <<*7979>>10500000
                                                               <<*7979>>10502000
   if ldt'mpe'version=5 and pcb(1)<>21 then                    <<*7979>>10504000
   begin                                                       <<*7979>>10506000
      genmsg (2,1259);                                         <<*7979>>10508000
      goto exitl;                                              <<*7979>>10510000
   end;                                                        <<*7979>>10512000
$page                                                          <<04145>>10514000
<<**********************************************************>> <<04145>>10516000
<<                                                          >> <<04145>>10518000
<<    ############ c o m m a n d     l o o p ##########     >> <<04145>>10520000
<<                                                          >> <<04145>>10522000
<<**********************************************************>> <<04145>>10524000
                                                               <<04145>>10526000
next:                                                                   10528000
   if warn <> 0 then                                                    10530000
      begin                                                             10532000
      errmsg(warn,no'file'error);                              <<04145>>10534000
      warn := 0;                                                        10536000
      end;                                                              10538000
   dlsize(0);                                                           10540000
   initxddp := 0;                                                       10542000
   critflag := false; if controlyflag then controlyproc;       <<b0.00>>10544000
   cbuf := "> ";                                                        10546000
   i := 1;                                                     <<b0.00>>10548000
                                                               <<04145>>10550000
   <<*******************************************************>> <<04145>>10552000
   << output prompt ">" and (sublevel).  read command and   >> <<04145>>10554000
   << check for errors on the way!!                         >> <<04145>>10556000
   <<*******************************************************>> <<04145>>10558000
                                                               <<04145>>10560000
   if sublevel <> 0 then begin                                 <<b0.00>>10562000
      cbuf.(8:8) := "(";                                       <<b0.00>>10564000
      cbuf(1).(0:8) := sublevel;                               <<b0.00>>10566000
      cbuf(1).(8:8) := ")";                                    <<b0.00>>10568000
      i := 2;                                                  <<b0.00>>10570000
      end;                                                     <<b0.00>>10572000
   print(cbuf,i,%320);                                         <<b0.00>>10574000
   if > then                                                   <<04145>>10576000
      terminate                                                <<04145>>10578000
   else if < then                                              <<04145>>10580000
      begin    << prompt i/o error >>                          <<06426>>10582000
         errn := 22;                                           <<04145>>10584000
         go to error;                                          <<04145>>10586000
      end;                                                     <<04145>>10588000
   count := read(cbuf(1),-72);                                          10590000
   if < then    << input i/o error >>                          <<06426>>10592000
      begin errn := 23; goto error; end;                                10594000
   if > then                                                            10596000
      begin errmsg(2,no'file'error); go to quitl; end;         <<04145>>10598000
   if not logical(mode.(14:1)) then  <<not duplicative>>       <<00897>>10600000
      print(cbuf(1),-count,0);                                 <<00897>>10602000
   critflag := true;                                           <<b0.00>>10604000
                                                               <<04145>>10606000
   @bp := @bcbuf(2);                                                    10608000
   bp(count) := cr ;                                           <<04145>>10610000
   cnt := 0;                                                            10612000
   scan bp(cnt) while %6440,1; <<skip past blanks, if empty >> <<04145>>10614000
   @bp := tos;                  << go to command loop      >>  <<04145>>10616000
   if carry then goto next;                                             10618000
   move bp := bp while as,1; << scan for alpha charactera an>> <<04145>>10620000
   cnt := tos-@bp;           <<upshift.                     >> <<04145>>10622000
   if cnt = 0 then                                             <<b0.01>>10624000
      begin     << invalid command name >>                     <<06426>>10626000
      errn := 20; go to error;                                 <<b0.01>>10628000
      end;                                                     <<b0.01>>10630000
   i := 0;                                                              10632000
                                                               <<04145>>10634000
   <<*******************************************************>> <<04145>>10636000
   << check for proper command name.  if not command, try   >> <<04145>>10638000
   << mpe command.                                          >> <<04145>>10640000
   <<*******************************************************>> <<04145>>10642000
                                                               <<04145>>10644000
   while (i<cnum) and (bp<>command'list(i*csize),(cnt)) do     <<b0.00>>10646000
      i := i+1;                                                         10648000
   if i = cnum then                                                     10650000
      if not mpecommand(bp) then                               <<04145>>10652000
         begin      << invalid command name >>                 <<06426>>10654000
           errn := 20; go to error;                            <<04145>>10656000
         end                                                   <<04145>>10658000
      else go to next;                                         <<04145>>10660000
   if not shiftupper(bp,count) then go to error;               <<04145>>10662000
   scan bp(cnt) while %6440,1;                                          10664000
   @bp := tos;                                                          10666000
   carryf := 0;                                                         10668000
   tos := @bp;                                                          10670000
   tos := @bp;                                                          10672000
   while not carryf do                                                  10674000
      begin                                                             10676000
      scan * while %6440,1;                                             10678000
      assemble(dup,dup);                                                10680000
      if bps0 = %42 then                                                10682000
         begin                                                          10684000
         tos := tos+1;                                                  10686000
         scan * until %6442,1;                                          10688000
         end;                                                           10690000
      if carry                                                          10692000
         then carryf := true                                            10694000
         else tos := tos+1;                                             10696000
      assemble(xch,sub);                                                10698000
      cnt := tos;                                                       10700000
      move * := *,(cnt),1;                                              10702000
      end;                                                              10704000
   move * := *,(1);                                                     10706000
   goto swcom(i);                                                       10708000
                                                                        10710000
$page                                                          <<04145>>10712000
<<*********************** e r r o r ! **********************>> <<04145>>10714000
                                                               <<04145>>10716000
error:                                                                  10718000
   errmsg(errn,errf);                                                   10720000
   errn := 0;                                                           10722000
   errf := no'file'error;                                      <<04145>>10724000
   goto next;                                                           10726000
                                                                        10728000
<<*********************** d e b u g ************************>> <<04145>>10730000
                                                               <<04145>>10732000
dbugl:                                                                  10734000
   if not cap2.(9:1) then                                               10736000
      begin                                                             10738000
      errn := 20;     << invalid command name >>               <<06426>>10740000
      warn := 4;                                                        10742000
      goto error;                                                       10744000
      end;                                                              10746000
   critflag := false; if controlyflag then controlyproc;       <<b0.00>>10748000
   debug;                                                               10750000
   critflag := true;                                           <<b0.00>>10752000
   goto next;                                                           10754000
                                                                        10756000
<<*********************** e x i t **************************>> <<04145>>10758000
<< first check if we are a subtask.  of so, check for errors>> <<04145>>10760000
<<**********************************************************>> <<04145>>10762000
                                                               <<04145>>10764000
exitl:                                                                  10766000
      if subtask then                                          <<b0.00>>10768000
         begin                                                 <<b0.00>>10770000
      critflag := false; if controlyflag then controlyproc;    <<b0.00>>10772000
         fatherinfo := getprocinfo(0);                         <<b0.01>>10774000
         if <> then go to quitl; <<father terminated>>         <<b0.01>>10776000
         if logical(fatherinfo1) then go to quitl;             <<b0.01>>10778000
                                      <<father active>>        <<b0.01>>10780000
           activate(0,3);         <<father>>                   <<b0.00>>10782000
         xcontrap(cylabel,cyold); <<rearm controly>>           <<b0.00>>10784000
      critflag := true;                                        <<b0.00>>10786000
           go to next;                                         <<b0.00>>10788000
         end;                                                  <<b0.00>>10790000
                                                               <<04145>>10792000
$page                                                          <<04145>>10794000
   <<*******************************************************>> <<04145>>10796000
   << close any texted spool files open and place back on   >> <<04145>>10798000
   << ready queue via srooster.                             >> <<04145>>10800000
   <<*******************************************************>> <<04145>>10802000
                                                               <<04145>>10804000
   if filen <> 0 then                                                   10806000
      begin                                                             10808000
      oddn:=findodd(xddn);                                     <<x7786>>10810000
      fsclose(filen,0,0);                                               10812000
      if < then                                                         10814000
         begin                                                 <<04145>>10816000
           errn := 24;                                         <<04145>>10818000
           fcheck(filen,errf);                                 <<04145>>10820000
           filen := 0;                                         <<04145>>10822000
           goto error;                                         <<04145>>10824000
         end;                                                  <<04145>>10826000
      srooster(oddn);   << place odd back on ready queue >>    <<x7786>>10828000
      end;                                                              10830000
                                                               <<04145>>10832000
   <<*******************************************************>> <<04145>>10834000
   << close any disk files that have been left open.        >> <<04145>>10836000
   <<*******************************************************>> <<04145>>10838000
                                                               <<04145>>10840000
   if new'filen <> 0  then                                     <<b0.01>>10842000
      if not new'file'close(false) then                        <<b0.01>>10844000
         go to error;                                          <<b0.01>>10846000
   goto fin;                                                            10848000
                                                                        10850000
<<*****************e x p l a i n  i t ! ********************>> <<04145>>10852000
                                                               <<04145>>10854000
xplal:                                                                  10856000
   if bp <> cr  then   << unexpected character >>              <<06426>>10858000
      begin errn := 33; goto error; end;                                10860000
   explain;                                                             10862000
   goto next;                                                           10864000
                                                                        10866000
<<********************* s h o w ****************************>> <<04145>>10868000
<< obtain file id's, get xdd's and show them and any errors!>> <<04145>>10870000
<<**********************************************************>> <<04145>>10872000
                                                               <<04145>>10874000
showl:                                                                  10876000
   if not getfiles(1) then goto error;                                  10878000
   if bp <> cr  then    << unexpected character >>             <<06426>>10880000
      begin errn := 33; goto error; end;                                10882000
   if movefromxdd                                              <<04145>>10884000
     then showfiles;                                           <<04145>>10886000
   showerrors(true);                                           <<04145>>10888000
   goto next;                                                           10890000
$page                                                          <<04145>>10892000
<<************************ t e x t *************************>> <<04145>>10894000
<< first close any previously texted files.                 >> <<04145>>10896000
<<**********************************************************>> <<04145>>10898000
                                                               <<04145>>10900000
textl:                                                                  10902000
   if filen <> 0 then                                                   10904000
      begin                                                             10906000
      oddn:=findodd(xddn);                                     <<x7786>>10908000
      fsclose(filen,0,0);                                               10910000
      if < then      << unable to close file >>                <<06426>>10912000
         begin errn := 24; fcheck(filen,errf); goto error; end;         10914000
      srooster(oddn);                                          <<x7786>>10916000
      filen := 0;                                                       10918000
      xddn := 0;                                                        10920000
      devfn := 0;                                                       10922000
      if bp = "*" and bp(1) = cr  then go to next;             <<04145>>10924000
      end;                                                              10926000
   devfc := 0;                                                          10928000
   if not getdevf then goto error;                                      10930000
   if devf >= 0 then    << input file not allowed >>           <<06426>>10932000
      begin errn := 30; goto error; end;                                10934000
   if bp <> cr  then     << unexpected character >>            <<06426>>10936000
      begin errn := 33; goto error; end;                                10938000
   if not spoolopen(devf,filef) then go to error;              <<b0.01>>10940000
  start'recnum := fline + 1d; <<initialize start'recnum>>   <<s<<01549>>10942000
   @blockfp := @blockcp := @blocktable;                        <<b0.01>>10944000
   blockno := 0d;                                              <<b0.01>>10946000
   blockfp := 0;                                               <<b0.01>>10948000
   move blockfp(1) := blockfp, (bentries*bentry'size-1);       <<b0.01>>10950000
   filen := filef;                                                      10952000
   xddn := xddx;                                                        10954000
   devfn := devf;                                                       10956000
   fline := -1d;                                                        10958000
   fgetinfo(filen,,,,,,,,,,eofline);                                    10960000
   eofline := eofline-1d;                                               10962000
   goto next;                                                           10964000
$page                                                          <<04145>>10966000
<<*********************** l i s t **************************>> <<04145>>10968000
<< check for texted file, obtain list range, skan to the    >> <<04145>>10970000
<< range and list the file.                                 >> <<04145>>10972000
<<**********************************************************>> <<04145>>10974000
                                                               <<04145>>10976000
listl:                                                                  10978000
   if filen = 0 then   << no text file >>                      <<06426>>10980000
      begin errn := 46; goto error; end;                                10982000
   if not linerange(false) then goto error;                             10984000
   if not skantoline(true) then goto error;                             10986000
   if not listrange(false) then goto error;                             10988000
   goto next;                                                           10990000
                                                                        10992000
<<******************** f i n d  i t ! **********************>> <<04145>>10994000
                                                               <<04145>>10996000
findl:                                                                  10998000
   if filen = 0 then   << no text file >>                      <<06426>>11000000
      begin errn := 46; goto error; end;                                11002000
   if not findrange then goto error;                                    11004000
   if not skantoline(true) then goto error;                             11006000
   if not listrange(true) then goto error;                              11008000
   goto next;                                                           11010000
                                                                        11012000
model:                                                                  11014000
   if not getmode then goto error;                                      11016000
   goto next;                                                           11018000
                                                                        11020000
<<******************* a l t e r ****************************>> <<04145>>11022000
                                                               <<04145>>11024000
altel:                                                                  11026000
   devfc := 0;                                                          11028000
   initxddp := -2048;                                          <<00897>>11030000
   if not getfiles(4) then goto error;                         <<04145>>11032000
   if bp <> ";" then    << missing semi-colon >>               <<06426>>11034000
      begin errn := 49; goto error; end;                       <<00897>>11036000
   @bp := @bp+1;                                               <<00897>>11038000
   if movefromxdd then                                         <<04145>>11040000
      begin                                                    <<04145>>11042000
        if not getalter then goto error;                       <<04145>>11044000
        if not alter'files then go to error;                   <<04145>>11046000
        showfiles;                                             <<04145>>11048000
      end;                                                     <<04145>>11050000
   showerrors(false);                                          <<04145>>11052000
   goto next;                                                           11054000
                                                                        11056000
$page                                                          <<04145>>11058000
<<******************* p u r g e ****************************>> <<04145>>11060000
                                                               <<04145>>11062000
purgl:                                                                  11064000
   if not getfiles(3) then                                     <<b0.00>>11066000
      if not mpecommand(bcbuf(2)) then                         <<b0.00>>11068000
         go to error                                           <<b0.00>>11070000
      else go to next;                                         <<b0.00>>11072000
   if bp <> cr  then    << unexpected character >>             <<06426>>11074000
      begin errn := 33; goto error; end;                                11076000
   if movefromxdd                                              <<04145>>11078000
   then purgefiles;                                            <<04145>>11080000
   showerrors(false);                                          <<04145>>11082000
   goto next;                                                           11084000
                                                                        11086000
<<******************* i n p u t ****************************>> <<04145>>11088000
<<  first check for sm capabilities.  get the input files   >> <<04145>>11090000
<<  list.  open the input tape file.  build the tape direc- >> <<04145>>11092000
<<  tory and input the files.  lastly, close the tape file  >> <<04145>>11094000
<<  and check for errors.                                   >> <<04145>>11096000
<<**********************************************************>> <<04145>>11098000
                                                               <<04145>>11100000
inl:                                                                    11102000
   if not cap1.(0:1) then    << invalid command name >>        <<06426>>11104000
      begin errn := 20;warn := 4;goto error; end;                       11106000
   initxddp := -2048;                                                   11108000
   if not getfiles(0) then goto error;                                  11110000
   if bp <> ";" then    << missing semi-colon >>               <<06426>>11112000
      begin errn := 49; goto error; end;                                11114000
   @bp := @bp+1;                                                        11116000
   if not opentape(0) then goto error;                                  11118000
   if not indirectory then goto error;                                  11120000
   if not infiles then goto error;                                      11122000
   showerrors(false);                                          <<04145>>11124000
   fclose(filet,1,0);                                          <<02724>>11126000
   if < then         << unable to close tape file >>           <<06426>>11128000
      begin errn := 51; fcheck(filet,errf); goto error; end;            11130000
   filet := 0;                                                          11132000
   goto next;                                                           11134000
                                                                        11136000
$page                                                          <<04145>>11138000
<<********************* o u t p u t ************************>> <<04145>>11140000
<< check for sm capabilities.  get the files for output.    >> <<04145>>11142000
<<**********************************************************>> <<04145>>11144000
                                                               <<04145>>11146000
outl:                                                                   11148000
   if not cap1.(0:1) then   << invalid command name >>         <<06426>>11150000
      begin errn := 20;warn := 4;goto error; end;                       11152000
   initxddp := -2048;                                                   11154000
   if not getfiles(2) then goto error;                                  11156000
   if bp <> ";" then        << missing semi-colon >>           <<06426>>11158000
      begin errn := 49; goto error; end;                                11160000
                                                               <<04145>>11162000
   <<*******************************************************>> <<04145>>11164000
   << if there are any files to output found by getfiles,   >> <<04145>>11166000
   << then open the tape file, check for the purge option   >> <<04145>>11168000
   << and output the files.  last, show any error encountred>> <<04145>>11170000
   <<*******************************************************>> <<04145>>11172000
                                                               <<04145>>11174000
   if movefromxdd then                                         <<04145>>11176000
      begin                                                    <<04145>>11178000
        @bp := @bp+1;                                          <<04145>>11180000
        if not opentape(1) then goto error;                    <<04145>>11182000
        purgeflag := false;                                    <<04145>>11184000
        scan bp until %6473,1;  <<cr, ; >>                     <<04145>>11186000
        @bp := tos  ;                                          <<04145>>11188000
        if nocarry then                                        <<04145>>11190000
           if bp(1) = "PURGE" then                             <<04145>>11192000
              purgeflag := true                                <<04145>>11194000
           else                                                <<04145>>11196000
              begin                                            <<04145>>11198000
              fclose(filet,1,0);                               <<04145>>11200000
              filet := 0;                                      <<04145>>11202000
              << unexpected character >>                       <<06426>>11204000
              errn := 33; go to error; end;                    <<04145>>11206000
                                                               <<04145>>11208000
        if not outdirectory then goto error;                   <<04145>>11210000
        if not outfiles then goto error;                       <<04145>>11212000
      end;                                                     <<04145>>11214000
   purgeflag := false;                                        <<00204>> 11216000
   showerrors(false);                                          <<04145>>11218000
                                                               <<04145>>11220000
   <<close the tape file                                    >> <<04145>>11222000
                                                               <<04145>>11224000
   if filet <> 0 then                                          <<04145>>11226000
      begin                                                    <<04145>>11228000
        fclose(filet,1,0);                                     <<04145>>11230000
        if < then                                              <<04145>>11232000
           begin    << unable to close tape file >>            <<06426>>11234000
             errn := 51;                                       <<04145>>11236000
             fcheck(filet,errf);                               <<04145>>11238000
             goto error;                                       <<04145>>11240000
           end;                                                <<04145>>11242000
        filet := 0;                                            <<04145>>11244000
      end;                                                     <<04145>>11246000
   goto next;                                                           11248000
                                                               <<01.02>>11250000
$page                                                          <<04145>>11252000
<<************************ h e l p ! ***********************>> <<04145>>11254000
<< check if mpe help facility has been requested and call   >> <<04145>>11256000
<< via mpecommand.                                          >> <<04145>>11258000
<<**********************************************************>> <<04145>>11260000
                                                               <<04145>>11262000
helpl:                                                         <<b0.00>>11264000
   if bp = cr  then                                            <<04145>>11266000
   go to xplal;                                                <<b0.00>>11268000
   if bp = "MPE" then                                          <<b0.00>>11270000
      begin                                                    <<b0.00>>11272000
      scan bp(3) while %6440;                                  <<b0.00>>11274000
      if carry then                                            <<b0.00>>11276000
         bp := cr ;                                            <<04145>>11278000
      end;                                                     <<b0.00>>11280000
   mpecommand(bcbuf(2));                                       <<b0.00>>11282000
   if bp=cr  and bp(1) ="PE" then                              <<04145>>11284000
      go to spook'title                                                 11286000
   else                                                                 11288000
     go to next;                                                        11290000
                                                                        11292000
<<************************** r u n *************************>> <<04145>>11294000
<< run a user program via attach.  if failed, than either   >> <<04145>>11296000
<< capabilty is illegal or program is invalid.              >> <<04145>>11298000
<<**********************************************************>> <<04145>>11300000
                                                               <<04145>>11302000
runl:                                                          <<b0.00>>11304000
         progname(26):=" ";                                    <<b0.00>>11306000
         move progname:=bp,(26);                               <<b0.00>>11308000
         scan progname until %6440,1;                          <<b0.00>>11310000
         move * := " ";                                        <<b0.00>>11312000
         if progname = " " then                                <<b0.00>>11314000
            begin                                              <<b0.00>>11316000
            errn := 72; go to error; <<missing operand>>       <<b0.00>>11318000
            end;                                               <<b0.00>>11320000
         if progname = "*" then                                <<b0.00>>11322000
            move progname := lastcreate,(27);                  <<b0.00>>11324000
         if not attach(progname,pin) then                      <<b0.00>>11326000
           begin                                               <<04145>>11328000
            if not cap2.(15:1) then                            <<04145>>11330000
               begin    << invalid command name >>             <<06426>>11332000
                 errn := 20;                                   <<04145>>11334000
                 warn := 4;                                    <<04145>>11336000
                 go to error;                                  <<04145>>11338000
               end                                             <<04145>>11340000
            else                                               <<04145>>11342000
               begin    << file is not program file >>         <<06426>>11344000
                 errn := 70;                                   <<04145>>11346000
                 go to error;                                  <<04145>>11348000
               end;                                            <<04145>>11350000
           end                                                 <<04145>>11352000
         else begin                                            <<04145>>11354000
              move cbuf := ptitle,2;                           <<04145>>11356000
              i := tos - @cbuf;                                <<04145>>11358000
        move bcbuf(vuuff'col) := official'vuuff;               <<04151>>11360000
              print(cbuf,i,0);                                 <<04145>>11362000
            end;                                               <<04145>>11364000
      go to next;                                              <<b0.00>>11366000
                                                               <<b0.00>>11368000
<<************************* k i l l ! **********************>> <<04145>>11370000
<< check if any programs being run and kill the last pin    >> <<04145>>11372000
<< number via kill.                                         >> <<04145>>11374000
<<**********************************************************>> <<04145>>11376000
                                                               <<04145>>11378000
killl:                                                         <<b0.00>>11380000
   if lastpin = 0 then                                         <<b0.00>>11382000
      begin     << no son process to be deleted >>             <<06426>>11384000
         errn :=71; go to error;                               <<b0.00>>11386000
      end                                                      <<b0.00>>11388000
   else                                                        <<b0.00>>11390000
      begin                                                    <<b0.00>>11392000
      kill(lastpin);                                           <<b0.00>>11394000
      lastpin := 0; lastcreate := 0;                           <<b0.00>>11396000
      end;                                                     <<b0.00>>11398000
   go to next;                                                 <<b0.00>>11400000
                                                               <<b0.00>>11402000
<<********************** i  q u i t ! **********************>> <<04145>>11404000
                                                               <<04145>>11406000
quitl:                                                         <<b0.00>>11408000
   <<  terminate subtask>>                                     <<b0.00>>11410000
                                                               <<b0.00>>11412000
   subtask := false;                                           <<b0.00>>11414000
   go to exitl;                                                <<b0.00>>11416000
                                                               <<b0.00>>11418000
$page                                                          <<04145>>11420000
<<********************** c o p y ***************************>> <<04145>>11422000
<< if a file was specified, then obtain the list of files   >> <<04145>>11424000
<< via getfiles.  move the odd entries in.  if no files were>> <<04145>>11426000
<< specified, copy the texted file if one is texted.  if no >> <<04145>>11428000
<< copy file was specified, create another spoolfile exactly>> <<04145>>11430000
<< like the original and copy the contents of the spoolfiles>> <<04145>>11432000
<< specified into it.                                       >> <<04145>>11434000
<<**********************************************************>> <<04145>>11436000
                                                               <<04145>>11438000
copyl:                                                         <<b0.01>>11440000
   if bp = "END" then                                          <<b0.01>>11442000
     begin                                                     <<b0.01>>11444000
     append := false;                                          <<b0.01>>11446000
      if new'filen = 0 then go to next                         <<b0.01>>11448000
      else                                                     <<b0.01>>11450000
         begin                                                 <<b0.01>>11452000
         if not new'file'close(false) then go to error;        <<b0.01>>11454000
         go to next;                                           <<b0.01>>11456000
         end;                                                  <<00897>>11458000
      end;                                                     <<00897>>11460000
   copy'files'flag := false; @firstparm := @bp;                <<00897>>11462000
   initxddp := -2048;                                          <<00897>>11464000
   scan bp until %6473;                                        <<04329>>11466000
   if nocarry then   << cr ";">>                               <<04329>>11468000
      begin                                                    <<04329>>11470000
      if not getfiles(2) then go to error;                     <<00897>>11472000
      if bp <> ";" then     << missing semi-colon >>           <<06426>>11474000
      begin errn := 49; go to error ; end;                     <<00897>>11476000
      @bp := @bp + 1;                                          <<00897>>11478000
      movefromxdd;                                             <<00897>>11480000
      copy'files'flag := true; @secondparm := @bp;             <<00897>>11482000
      end                                                      <<04329>>11484000
   else                                                        <<00897>>11486000
      if filen = 0 then                                        <<04329>>11488000
         begin                                                 <<04329>>11490000
         errn := 46;               << no text file          >> <<04329>>11492000
         go to error;              << aren't go to's ugly?  >> <<04329>>11494000
         end                                                   <<04329>>11496000
      else                                                     <<04329>>11498000
        file'found := true;        << file exists.          >> <<04329>>11500000
                                                               <<04329>>11502000
   if not copy'files'flag then                                 <<00897>>11504000
   begin                                                       <<00897>>11506000
      xddc := 1;                                               <<00897>>11508000
      @bp := @firstparm;                                       <<00897>>11510000
      @secondparm := @firstparm;                               <<00897>>11512000
   end;                                                        <<00897>>11514000
                                                               <<04145>>11516000
   <<*******************************************************>> <<04145>>11518000
   << copy the files via copy'files and show any error that >> <<04145>>11520000
   << occured via showerrors.                               >> <<04145>>11522000
   <<*******************************************************>> <<04145>>11524000
                                                               <<04145>>11526000
   if file'found then                                          <<04145>>11528000
      if not copy'files then go to error;                      <<04145>>11530000
   append:= false;                                             <<b0.01>>11532000
   if copy'files'flag                                          <<04329>>11534000
      then showerrors(false);                                  <<04329>>11536000
   copy'files'flag := false;                                   <<04329>>11538000
   go to next;                                                 <<b0.01>>11540000
                                                               <<b0.01>>11542000
                                                               <<b0.01>>11544000
appendl:                                                       <<b0.01>>11546000
   append := true;                                             <<b0.01>>11548000
   go to copyl;                                                <<b0.01>>11550000
                                                                        11552000
                                                                        11554000
fin:                                                                    11556000
   xcontrap(cyold,cylabel);                                             11558000
   critflag := false; if controlyflag then controlyproc;       <<b0.00>>11560000
                                                                        11562000
                                                                        11564000
end.                                                                    11566000
