$CONTROL USLINIT,CODE,MAP                                      <<01549>>00005000
<<allocate - module 54>>                                       <<01549>>00010000
<< hp32002c mpe source c.00.00 >>                                       00015000
$copyright     "(C) COPYRIGHT HEWLETT-PACKARD CO. 1980. ",            & 00020000
$     "THIS PROGRAM MAY BE USED WITH ONE COMPUTER SYSTEM AT A ",      & 00025000
$     "TIME AND SHALL NOT OTHERWISE BE RECORDED, TRANSMITTED OR ",    & 00030000
$     "STORED IN A RETRIEVAL SYSTEM.  COPYING OR OTHER REPRODUCTION ",& 00035000
$     "OF THIS PROGRAM EXCEPT FOR ARCHIVAL PURPOSES IS PROHIBITED ",  & 00040000
$     "WITHOUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY."   00045000
                                                               <<04620>>00050000
                                                               <<04620>>00055000
$thirty                                                                 00060000
$control privileged                                            <<00652>>00065000
$control main=alocate                                          <<00652>>00070000
begin                                                                   00075000
                                                               <<03698>>00080000
<<  changes made to allocate module since 1/19/82          >>  <<03698>>00085000
                                                               <<03698>>00090000
<<  fix the check made for tapes and serial discs for      >>  <<03698>>00095000
<<  unlabeled "tapes".                                     >>  <<03698>>00100000
                                                               <<03698>>00105000
<< make sure a request for disc (fdisc/sdisc) fails if pv  >>  <<03788>>00110000
<<  is on the ldev.                                        >>  <<03788>>00115000
<< new option in deallocate for morgue.                    >>  <<04201>>00120000
<< release ldtsir before attachio calls in deallocate.       >><<04843>>00125000
<< take out halt 0                                         >>  <<04622>>00130000
                                                               <<06730>>00135000
<< change to incorporate $include files for ldt, lpdt.      >> <<06730>>00140000
<< change to incorporate $include file for xdd.             >> <<06730>>00145000
                                                               <<04622>>00150000
<< call to ckforlabel (in labseg) split into two procedure >>  <<06027>>00155000
<< calls, ckforldev and ckforexdate.                       >>  <<06027>>00160000
                                                               <<06027>>00165000
<< incorporate sysglob $include file.                       >> <<07050>>00170000
                                                               <<07050>>00175000
<< return primedevice fopen flags parm to %17 (from 7) to   >> <<s8098>>00180000
<<   avoid sf661.                                           >> <<s8098>>00185000
<< in deallocate, convert xdd vtab to ldev before deallo-   >> <<s8651>>00190000
<<   cating first spoolfile extent.                         >> <<s8651>>00195000
<< in askop, delete type requirement for auto allocation.   >> <<a8986>>00200000
<<   (sysdump/initial manages lpdt'auto'alloc).  makes it   >> <<a8986>>00205000
<<   possible to auto-allocate unlabelled sdisc.  assume    >> <<a8986>>00210000
<<   write ring is o.k. for such requests.                  >> <<a8986>>00215000
$page "***  GENERAL/GLOBAL EQUIVALENCES   ***"                          00220000
define                                                                  00225000
           penable           = assemble(pseb)    #,            <<06730>>00230000
           pdisable          = assemble(psdb)    #,            <<06730>>00235000
           disable           = assemble(sed 0)   #,                     00240000
           enable            = assemble(sed 1)   #,            <<06730>>00245000
           stack             = 0                 #;            <<06730>>00250000
define                                                         <<03546>>00255000
           lock             = 16                 #,            <<03546>>00260000
           unlock           = 17                 #;            <<03546>>00265000
integer                                                                 00270000
           s0                = s-0   ,                                  00275000
           x                 = x     ;                         <<07050>>00280000
                                                               <<06730>>00285000
byte pointer                                                   <<06730>>00290000
           bps0              = s-0   ;                         <<06730>>00295000
                                                               <<06730>>00300000
$page "***   TABLE CONSTANTS   ***"                            <<06730>>00305000
equate                                                                  00310000
           mvtabsir          = 27    ,                         <<rh.pv>>00315000
           mvtabdst          = 53    ,                         <<rh.pv>>00320000
           mvtabsize         = 21    ;                         <<06730>>00325000
$set x8 = on                                                   <<06730>>00330000
$include inclsysg                                              <<07050>>00335000
$include inclldt5                                              <<06730>>00340000
$include incllpdt                                              <<06730>>00345000
$include incldct                                               <<06730>>00350000
$page "MPE TABLE ACCESS:  PXGLOBAL"                            <<06730>>00355000
$include inclpxg                                               <<06730>>00360000
$title "MPE TABLE ACCESS:  USER CAPABILITIES"                  <<06730>>00365000
$include inclcap                                               <<06730>>00370000
$page "MPE TABLE ACCESS:  PCB"                                 <<06730>>00375000
$include inclpcb5                                              <<06730>>00380000
$include inclxdd5                                              <<06730>>00385000
$page "***   FURTHER EQUIVALENCES   ***"                                00390000
   equate                                                               00395000
         words'per'sector = 128,                               <<06730>>00400000
                                                               <<06730>>00405000
         olddata          =   0,  << for askop and allocate >> <<06730>>00410000
         realloc          =   1,                               <<06730>>00415000
         opassigned       =   2;                               <<06730>>00420000
                                                               <<06730>>00425000
   define                                                      <<06730>>00430000
         cc           = status.(6:2)#,                         <<06730>>00435000
         cce          = 2 #,                                            00440000
         ccg          = 0 #,                                            00445000
         ccl          = 1 #;                                   <<06730>>00450000
   define                                                      <<rh.pv>>00455000
         pvclassf     = (0:1)#,                                <<rh.pv>>00460000
         mvtabxf      = (4:4)#,                                <<rh.pv>>00465000
         vmaskf       = (8:8)#,                                <<rh.pv>>00470000
         cycpf        = (1:4)#;                                <<rh.pv>>00475000
   equate                                                      <<sd.00>>00480000
      memsize = %77700,    << max size for sdisc xds >>        <<03563>>00485000
         vdsize  = 0;                                          <<sd.00>>00490000
                                                               <<07050>>00495000
   equate            << suddendeath equates for easy xref.  >> <<07050>>00500000
      sd350 = 350,                                             <<07050>>00505000
      sd351 = 351,                                             <<07050>>00510000
      sd352 = 352,                                             <<07050>>00515000
      sd353 = 353,                                             <<07050>>00520000
      sd354 = 354,                                             <<07050>>00525000
      sd360 = 360,                                             <<07050>>00530000
      sd361 = 361,                                             <<07050>>00535000
      sd362 = 362,                                             <<07050>>00540000
      sd363 = 363,                                             <<07050>>00545000
      sd364 = 364,                                             <<07050>>00550000
      sd365 = 365,                                             <<07050>>00555000
      sd366 = 366,                                             <<07050>>00560000
      sd367 = 367;                                             <<07050>>00565000
$page "ASSOCIATION TABLE DEFINITIONS AND DECLARATIONS"         <<01647>>00570000
                                                               <<01647>>00575000
equate                                                         <<01647>>00580000
   ass'dst       = 34,          << assoc. table dst.     >>    <<01647>>00585000
   ass'entrysize = 7,           << in words.             >>    <<01647>>00590000
   ass'class     = 3,           << classname index       >>    <<01647>>00595000
   ass'sir       = 24;          << assoc. table sir.     >>    <<01647>>00600000
                                                               <<01647>>00605000
define                                                         <<01647>>00610000
   ass'jmat      = 0).(8:8 #,   << jmat index in entry.  >>    <<01647>>00615000
   ass'jit       = 1).(6:10 #;  << jit index in entry.   >>    <<01647>>00620000
                                                               <<01647>>00625000
define                                                         <<01647>>00630000
   lock'ass'table  = assoc'sir := getsir( ass'sir ) #,         <<01647>>00635000
   free'ass'table  = relsir( ass'sir, assoc'sir )   #;         <<01647>>00640000
                                                               <<01647>>00645000
<< subroutine "declarations" for movefromdseg,  movetodseg. >> <<06730>>00650000
<< to use, declare "SUBROUTINE DEF'MOVExxDSEG" in each pro- >> <<06730>>00655000
<< cedure requiring it. note that dbsource and dbtarget are >> <<06730>>00660000
<< logical, not logical pointer.  this makes it  easier  to >> <<06730>>00665000
<< move one or two word quantities from/to single or double >> <<06730>>00670000
<< word cells which are not arrays or pointers. remember to >> <<06730>>00675000
<< include the "@" sign, no matter what its attribute is.   >> <<06730>>00680000
                                                               <<06730>>00685000
define                                                         <<06730>>00690000
                                                               <<06730>>00695000
   def'movefromdseg =                                          <<06730>>00700000
      movefromdseg (dbtarget, dstn, dstoffset, word'count);    <<06730>>00705000
         value   dbtarget, dstn, dstoffset, word'count;        <<06730>>00710000
         logical dbtarget, dstn, dstoffset, word'count;        <<06730>>00715000
      begin                                                    <<06730>>00720000
      x := tos;            << save    return address.       >> <<06730>>00725000
      assemble (mfds 0);                                       <<06730>>00730000
      tos := x;            << restore return address.       >> <<06730>>00735000
      end #,                                                   <<06730>>00740000
                                                               <<06730>>00745000
   def'movetodseg =                                            <<06730>>00750000
      movetodseg (dstn, dstoffset, dbsource, word'count);      <<06730>>00755000
         value   dstn, dstoffset, dbsource, word'count;        <<06730>>00760000
         logical dstn, dstoffset, dbsource, word'count;        <<06730>>00765000
      begin                                                    <<06730>>00770000
      x := tos;                                                <<06730>>00775000
      assemble (mtds 0);                                       <<06730>>00780000
      tos := x;                                                <<06730>>00785000
      end #;                                                   <<06730>>00790000
$page "***   EXTERNAL PROCEDURES   ***"                                 00795000
                                                                        00800000
procedure abortio (ldev);                                               00805000
   value   ldev;                                                        00810000
   integer ldev;                                                        00815000
   option external;                                                     00820000
                                                                        00825000
logical procedure altdsegsize(dstx,size);                               00830000
   value dstx,size;                                                     00835000
   integer dstx,size;                                                   00840000
   option external;                                                     00845000
                                                                        00850000
double procedure attachio (ldev,qm,d,b,f,c,p1,p2,fl);                   00855000
   value   ldev,qm,d,b,f,c,p1,p2,fl;                                    00860000
   integer ldev,qm,d,b,f,c,p1,p2,fl;                                    00865000
   option external;                                                     00870000
                                                               <<06730>>00875000
double procedure p'attachio (ldnum, qmisc, dstx, offset,       <<06730>>00880000
                 function, count, p1, p2, flags,               <<06730>>00885000
                 extent'base, extent'length);                  <<06730>>00890000
   value   ldnum, qmisc, dstx, offset, function, count, p1,    <<06730>>00895000
           p2, flags, extent'base, extent'length;              <<06730>>00900000
   integer ldnum, qmisc, dstx, offset, function, count, p1,    <<06730>>00905000
           p2, flags, extent'length;                           <<06730>>00910000
   double extent'base;                                         <<06730>>00915000
   option privileged, uncallable, external, variable;          <<06730>>00920000
                                                                        00925000
double procedure reqstatus(ldev);                              <<03698>>00930000
  value ldev;                                                  <<03698>>00935000
  integer ldev;                                                <<03698>>00940000
  option external;                                             <<03698>>00945000
                                                               <<03698>>00950000
procedure awake(pcbpt,n,waitf);                                         00955000
   value pcbpt,n,waitf;                                                 00960000
   integer pcbpt,n,waitf;                                               00965000
   option external;                                                     00970000
                                                                        00975000
logical procedure calendar;                                             00980000
   option external;                                                     00985000
                                                                        00990000
                                                                        00995000
procedure clean'message(msg,len);                                       01000000
   value len;                                                           01005000
   integer len;                                                         01010000
   byte array msg;                                                      01015000
   option privileged,uncallable,external;                               01020000
                                                                        01025000
double procedure clock;                                                 01030000
   option external;                                                     01035000
                                                                        01040000
logical procedure exchangedb(dstx);                                     01045000
   value dstx;                                                          01050000
   logical dstx;                                                        01055000
   option external;                                                     01060000
                                                               <<0u.eb>>01065000
integer procedure genmsg(setno,msgno,mask,b,c,d,e,f,           <<0u.eb>>01070000
      dest,reply,buff,dst,iotype);                             <<0u.eb>>01075000
   value setno,msgno,mask,b,c,d,e,f,dest,reply,buff,           <<0u.eb>>01080000
      dst,iotype;                                              <<0u.eb>>01085000
   logical setno,msgno,mask,b,c,d,e,f,dest,reply,buff,         <<0u.eb>>01090000
      dst,iotype;                                              <<0u.eb>>01095000
   option variable,external;                                   <<0u.eb>>01100000
                                                               <<01549>>01105000
integer procedure get'dsdevice(ldev);                          <<01549>>01110000
   value ldev;                                                 <<01549>>01115000
   integer ldev;                                               <<01549>>01120000
   option privileged,uncallable,external;                      <<01549>>01125000
                                                               <<01549>>01130000
logical procedure getsir(sirnum);                                       01135000
   value sirnum;                                                        01140000
   integer sirnum;                                                      01145000
   option external;                                                     01150000
                                                                        01155000
logical procedure header (oddsubp, ldev, devtype, devrsize);            01160000
   value oddsubp, ldev, devtype, devrsize;                              01165000
   integer pointer oddsubp;                                             01170000
   integer ldev, devtype, devrsize;                                     01175000
   option external;                                                     01180000
                                                               <<06730>>01185000
integer procedure ldevtotype(ldev);                            <<01357>>01190000
value ldev;                                                    <<01357>>01195000
integer ldev;                                                  <<01357>>01200000
option external;                                               <<01357>>01205000
                                                               <<01357>>01210000
integer procedure linklabel(ldevn,acc);                        <<tl.02>>01215000
  value acc;                                                   <<tl.02>>01220000
  integer ldevn,acc;                                           <<tl.02>>01225000
  option external;                                             <<tl.02>>01230000
                                                               <<tl.02>>01235000
logical procedure ckforexdate(ldev,rdwr,lbled);                <<06027>>01240000
 value ldev,rdwr,lbled;                                        <<06027>>01245000
 integer ldev,rdwr,lbled;                                      <<06027>>01250000
 option external;                                              <<06027>>01255000
                                                               <<06027>>01260000
logical procedure ckforldev(ldev);                             <<06027>>01265000
   value ldev;                                                 <<06027>>01270000
   integer ldev;                                               <<06027>>01275000
   option external;                                            <<06027>>01280000
                                                               <<06027>>01285000
procedure set'lpdt'bot(ldev,val);                              <<02566>>01290000
   value ldev,val;                                             <<02566>>01295000
   integer ldev,val;                                           <<02566>>01300000
   option external;                                            <<02566>>01305000
                                                               <<02566>>01310000
procedure store'density(ldev,buffer,mode);                     <<02566>>01315000
   value ldev,mode;                                            <<02566>>01320000
   integer ldev,mode;                                          <<02566>>01325000
   array buffer;                                               <<02566>>01330000
   option external;                                            <<02566>>01335000
                                                                        01340000
procedure relsir(sirnum,already);                                       01345000
   value sirnum,already;                                                01350000
   integer sirnum;                                                      01355000
   logical already;                                                     01360000
   option external;                                                     01365000
                                                                        01370000
logical procedure sysproc (lpin);                                       01375000
   value   lpin;                                                        01380000
   logical lpin;                                                        01385000
   option external;                                                     01390000
                                                                        01395000
procedure suddendeath(errnum);                                          01400000
   value errnum;                                                        01405000
   integer errnum;                                                      01410000
   option external;                                                     01415000
                                                                        01420000
logical procedure trailer (oddsubp, ldev, devtype, devrsize);           01425000
   value oddsubp, ldev, devtype, devrsize;                              01430000
   integer pointer oddsubp;                                             01435000
   integer ldev, devtype, devrsize;                                     01440000
   option external;                                                     01445000
                                                                        01450000
integer procedure assoc'class(classname);                      <<00552>>01455000
integer array classname;                                       <<00552>>01460000
option external,privileged;                                    <<00552>>01465000
                                                               <<00552>>01470000
procedure writedseg'serial(d); << special entry point for  >>  <<w7889>>01475000
   value d;                    << writedseg, goes thru the >>  <<w7889>>01480000
   integer d;                  << serial write queue       >>  <<w7889>>01485000
   option external;                                            <<w7889>>01490000
                                                               <<00453>>01495000
integer procedure getdataseg(memsize,vdsize);                  <<sd.00>>01500000
value memsize,vdsize;                                          <<sd.00>>01505000
integer memsize,vdsize;                                        <<sd.00>>01510000
option external;                                               <<sd.00>>01515000
                                                               <<sd.00>>01520000
procedure reldataseg(dstn);                                    <<sd.00>>01525000
value dstn;                                                    <<sd.00>>01530000
integer dstn;                                                  <<sd.00>>01535000
option external;                                               <<sd.00>>01540000
                                                               <<sd.00>>01545000
logical procedure putdev(ldev,table,buf);                      <<sp.01>>01550000
   value ldev,table;                                           <<sp.01>>01555000
   integer ldev,table;                                         <<sp.01>>01560000
   integer array buf;                                          <<sp.01>>01565000
   option forward;                                             <<sp.01>>01570000
                                                               <<sp.01>>01575000
logical procedure getdev(ldev,table,buf);                      <<sp.01>>01580000
   value ldev,table;                                           <<sp.01>>01585000
   integer ldev,table;                                         <<sp.01>>01590000
   integer array buf;                                          <<sp.01>>01595000
   option forward;                                             <<sp.01>>01600000
                                                               <<sp.01>>01605000
integer procedure get'disc'space (ldev, number'of'sectors,     <<03507>>01610000
                                  disc'address);               <<03507>>01615000
   value ldev, number'of'sectors;                              <<03507>>01620000
   integer ldev;                                               <<03507>>01625000
   double number'of'sectors, disc'address;                     <<03507>>01630000
   option external;                                            <<03507>>01635000
                                                               <<03507>>01640000
procedure return'disc'space (ldev, disc'address,               <<03507>>01645000
                             number'of'sectors);               <<03507>>01650000
   value ldev, disc'address, number'of'sectors;                <<03507>>01655000
   integer ldev;                                               <<03507>>01660000
   double disc'address, number'of'sectors;                     <<03507>>01665000
   option external;                                            <<03507>>01670000
                                                               <<03507>>01675000
logical procedure deallocate'dfs'data'seg (ldev);              <<03507>>01680000
   value ldev;                                                 <<03507>>01685000
   integer ldev;                                               <<03507>>01690000
   option external;                                            <<03507>>01695000
                                                               <<03507>>01700000
procedure delete'dfs'data'seg (ldev);                          <<03507>>01705000
   value ldev;                                                 <<03507>>01710000
   integer ldev;                                               <<03507>>01715000
   option external;                                            <<03507>>01720000
                                                               <<03507>>01725000
procedure process'dfs'error (ldev,error'status,type'of'error); <<04811>>01730000
   value ldev,error'status,type'of'error;                      <<04811>>01735000
   integer ldev;                                               <<04811>>01740000
   logical error'status;                                       <<04811>>01745000
   integer type'of'error;                                      <<04811>>01750000
   option external;                                            <<04811>>01755000
                                                               <<04811>>01760000
procedure soft'death (num);                                    <<04811>>01765000
   value num;                                                  <<04811>>01770000
   integer num;                                                <<04811>>01775000
   option external;                                            <<04811>>01780000
                                                               <<04811>>01785000
integer procedure lun (vtab'index, mvtab'index);               <<07050>>01790000
   value   vtab'index, mvtab'index;                            <<07050>>01795000
   integer vtab'index, mvtab'index;                            <<07050>>01800000
   option  privileged, uncallable, external;                   <<07050>>01805000
  comment -- accepts a (system) volume table index and returns <<07050>>01810000
the corresponding ldev in the result.  if mvtab'index <> 0 the <<07050>>01815000
(private) mounted volume table is searched instead.            <<07050>>01820000
;                                                              <<07050>>01825000
                                                               <<07050>>01830000
integer procedure vtabinx (ldev, local);                       <<07050>>01835000
   value   ldev, local;                                        <<07050>>01840000
   integer ldev;                                               <<07050>>01845000
   logical local;                                              <<07050>>01850000
   option  privileged, uncallable, external;                   <<07050>>01855000
  comment -- accepts a logical device number.  returns the xdd <<07050>>01860000
head index in (0:8) of the result and the system volume  table <<07050>>01865000
index  in (8:8).  if local is false, the volume table index is <<07050>>01870000
fetched from the ldt.  if true, it is fetched from the  system <<07050>>01875000
volume table.                                                  <<07050>>01880000
;                                                              <<07050>>01885000
                                                               <<00652>>01890000
procedure help;                                                <<00868>>01895000
  option external;                                             <<00868>>01900000
                                                               <<00868>>01905000
intrinsic ascii;                                               <<06730>>01910000
$page "***   Forward procedures   ***"                         <<06730>>01915000
logical procedure getclass (return'buf, everything, cladr,     <<06730>>01920000
                            clindex, clname);                  <<06730>>01925000
   value   cladr, clindex, everything;                         <<06730>>01930000
   integer cladr, clindex;                                     <<06730>>01935000
   logical everything;                                         <<06730>>01940000
   integer array clname, return'buf;                           <<06730>>01945000
   option  privileged, uncallable, variable, forward;          <<06730>>01950000
$page "   ***   GET'DEVICE'CLASS   ***"                        <<06730>>01955000
$control segment = allocutil                                   <<06730>>01960000
                                                               <<06730>>01965000
integer procedure get'device'class (class'index,               <<06730>>01970000
                      entry'address);                          <<06730>>01975000
   value   class'index;                                        <<06730>>01980000
   integer class'index, entry'address;                         <<06730>>01985000
   option privileged, uncallable;                              <<06730>>01990000
begin comment --                                               <<06730>>01995000
  get'device'class accepts a device class table index and  re- <<06730>>02000000
turns the length of its entry in the dct and its segment-rela- <<06730>>02005000
tive offset in the dct.  callers can use this  information  to <<06730>>02010000
create a local copy of the entry.  new code should prefer this <<06730>>02015000
procedure over getclass because it relies only on the $include <<06730>>02020000
files for its information.  we still use  getclass  here,  but <<06730>>02025000
only to obtain entry'address (the first word it returns).      <<06730>>02030000
                                                               <<06730>>02035000
    *-*-*  this is not a replacement for getclass.   *-*-*     <<06730>>02040000
                                                               <<06730>>02045000
inputs:   class'index.  the nth entry (1 is first) in the  de- <<06730>>02050000
          vice class table.  must be > 0.                      <<06730>>02055000
                                                               <<06730>>02060000
returns:  result.  the length of the entry, or -1 if the entry <<06730>>02065000
          doesn't exist.                                       <<06730>>02070000
                                                               <<06730>>02075000
          entry'address.  the dct segment-relative address  of <<06730>>02080000
          the entry, or 0 if the entry doesn't exist.          <<06730>>02085000
                                                               <<06730>>02090000
special considerations:  db must be at  the  stack  on  entry, <<06730>>02095000
                         same at exit.  this is because of the <<06730>>02100000
                         stack db-relative reference parameter <<06730>>02105000
                         entry'address.                        <<06730>>02110000
;                                                              <<06730>>02115000
logical array                                                  <<06730>>02120000
   dct(0:size'of'dct'head-1);   << req'd by dct $incl file. >> <<06730>>02125000
                                                               <<06730>>02130000
                                                               <<06730>>02135000
subroutine def'movefromdseg;                                   <<06730>>02140000
                                                               <<06730>>02145000
                                                               <<06730>>02150000
if getclass (dct <<temp>>, false, <<cladr>>, class'index) then <<06730>>02155000
   begin   << entry exists.                                 >> <<06730>>02160000
   entry'address := dct;   << first word retnd by getclass. >> <<06730>>02165000
   movefromdseg (@dct, dct'dst, entry'address,                 <<06730>>02170000
                 size'of'dct'head);                            <<06730>>02175000
   get'device'class := dct'words'in'entry;                     <<06730>>02180000
   end                                                         <<06730>>02185000
else                                                           <<06730>>02190000
   begin   << entry doesn't exist.                          >> <<06730>>02195000
   get'device'class := -1;                                     <<06730>>02200000
   entry'address := 0;                                         <<06730>>02205000
   end;                                                        <<06730>>02210000
end;   << of get'device'class.                              >> <<06730>>02215000
$page "   ***   SROOSTER   ***"                                <<06730>>02220000
$control segment= allocutil                                             02225000
                                                                        02230000
                                                                        02235000
procedure srooster (dev'or'class);                             <<06730>>02240000
   value   dev'or'class;                                       <<06730>>02245000
   integer dev'or'class;                                       <<06730>>02250000
   option  privileged, uncallable;                             <<06730>>02255000
begin comment --                                               <<06730>>02260000
  srooster wakes up output spooler processes by  satisfying  a <<06730>>02265000
son wait.  processes which are already awake are unaffected by <<06730>>02270000
being awakened again.  srooster is called whenever a spoolfile <<06730>>02275000
is fclosed (made ready), whenever the system outfence or a de- <<06730>>02280000
vice outfence changes or whenever  :altspoolfile  changes  the <<06730>>02285000
device, class or priority of an output spoolfile.              <<06730>>02290000
                                                               <<06730>>02295000
input:   dev'or'class.  if > 0, an ldev number.  wake  up  its <<06730>>02300000
                        spooler if it exists.                  <<06730>>02305000
                        if < 0, a device  class  table  index. <<06730>>02310000
                        wake  up  all  spoolers for devices in <<06730>>02315000
                        the class.                             <<06730>>02320000
                        if 0, wake up all output spoolers.     <<06730>>02325000
                                                               <<06730>>02330000
return:  none.  condition code is not affected.                <<06730>>02335000
                                                               <<06730>>02340000
special considerations:  db may be anywhere at entry, same  at <<06730>>02345000
                         return. srooster is most efficient if <<06730>>02350000
                         called with db at the stack.          <<06730>>02355000
                                                               <<06730>>02360000
ways and means:  starting with mpe v, the logical device table <<06730>>02365000
                 (ldt) and device class  table  (dct)  are  in <<06730>>02370000
                 different  data segments.  to avoid excessive <<06730>>02375000
                 exchangedb's, srooster and  other  procedures <<06730>>02380000
                 which access both tables make local copies of <<06730>>02385000
                 the entries they work with. since dct entries <<06730>>02390000
                 are of variable length, any local  copy  must <<06730>>02395000
                 be built on the stack. references to this ar- <<06730>>02400000
                 ray must be indirect, therefore db  must  re- <<06730>>02405000
                 main at the stack.                            <<06730>>02410000
;                                                              <<06730>>02415000
<< note:  the following equate is a parameter to the  awake >> <<07050>>02420000
<< procedure,  and  represents  a  pcb  event mask position >> <<07050>>02425000
<< shifted right four bits.  it is currently unavailable in >> <<07050>>02430000
<< any $include file, which is why it is here!  if the  un- >> <<07050>>02435000
<< derlying  event  mask  (or the awake interface) changes, >> <<07050>>02440000
<< this equate will also have to change.                    >> <<07050>>02445000
                                                               <<07050>>02450000
equate                                                         <<07050>>02455000
   sonwait       = 2;                                          <<07050>>02460000
                                                               <<07050>>02465000
integer                                                        <<06730>>02470000
   dst'at'entry := -1,                                         <<06730>>02475000
   entry'address,        << dct-rel. offset to dct entry.   >> <<06730>>02480000
   entry'length,         << length of entry at entry'address>> <<06730>>02485000
   pcbpt,                << required by pcb $include file.  >> <<06730>>02490000
   save'dct'sir,                                               <<06730>>02495000
   save'ldt'sir;                                               <<06730>>02500000
                                                               <<06730>>02505000
logical                                                        <<06730>>02510000
   loop'counter,                                               <<06730>>02515000
   num'ldt'entries;      << local copy of ldt'num'entries.  >> <<06730>>02520000
                                                               <<06730>>02525000
logical array                                                  <<06730>>02530000
   ldt(0:size'of'ldt'entry-1) = q;                             <<07050>>02535000
                                                               <<06730>>02540000
logical pointer                                                <<06730>>02545000
   dct,                                                        <<06730>>02550000
   pcb = syspcbindex;                                          <<06730>>02555000
                                                               <<06730>>02560000
define                                                         <<06730>>02565000
   ldt'index  = 0                      #,                      <<06730>>02570000
   lpdt'index = ldev * lpdt'entry'size #;                      <<06730>>02575000
                                                               <<06730>>02580000
                                                               <<06730>>02585000
subroutine def'movefromdseg;                                   <<06730>>02590000
                                                               <<06730>>02595000
subroutine sroost (ldev);                                      <<06730>>02600000
   value   ldev;                                               <<06730>>02605000
   logical ldev;                                               <<06730>>02610000
begin                                                          <<06730>>02615000
if not lpdt'virtual'device then                                <<06730>>02620000
   begin   << real device, wake it if it's spooled.         >> <<06730>>02625000
   movefromdseg (@ldt, ldt'dst, ldev * size'of'ldt'entry,      <<06730>>02630000
                 size'of'ldt'entry);                           <<06730>>02635000
   if ldt'spool'state = ldt'output'spooled and                 <<06730>>02640000
      ldt'main'pin <> 0 then                                   <<06730>>02645000
      awake (ldt'main'pin * pcbsize, sonwait, 0);              <<06730>>02650000
   end;    << real device.                                  >> <<06730>>02655000
end;       << of sroost.                                    >> <<06730>>02660000
                                                               <<06730>>02665000
                                                               <<06730>>02670000
<< *-*-*   procedure body starts here.                *-*-* >> <<06730>>02675000
                                                               <<06730>>02680000
pcbpt := curprc;                                               <<06730>>02685000
if spcbxdsdst <> stack then dst'at'entry := exchangedb (stack);<<06730>>02690000
save'ldt'sir := getsir (ldt'sir);                              <<06730>>02695000
if dev'or'class > 0 then                                       <<06730>>02700000
   sroost (dev'or'class)   << wake up one spooler.          >> <<06730>>02705000
else if dev'or'class < 0 then                                  <<06730>>02710000
   begin   << device class request, get local copy of entry >> <<06730>>02715000
   save'dct'sir := getsir (dct'sir);                           <<06730>>02720000
   entry'length := get'device'class (-dev'or'class,            <<06730>>02725000
                   entry'address);                             <<06730>>02730000
   if entry'length <> -1 then                                  <<06730>>02735000
      begin   << valid class index.                         >> <<06730>>02740000
      push (s);                                                <<06730>>02745000
      @dct := tos + 1;   << build dct entry on stack.       >> <<06730>>02750000
      tos := entry'length;                                     <<06730>>02755000
      assemble (adds 0);                                       <<06730>>02760000
      movefromdseg (@dct, dct'dst, entry'address,              <<06730>>02765000
                    entry'length);                             <<06730>>02770000
      loop'counter := 0;   << wake all spoolers in class.   >> <<06730>>02775000
      do sroost (dct(dct'first'ldev + loop'counter)) until     <<06730>>02780000
         (loop'counter := loop'counter + 1) >= dct'num'devices;<<06730>>02785000
      end;    << valid class index.                         >> <<06730>>02790000
   relsir (dct'sir, save'dct'sir);                             <<06730>>02795000
   end        << device class request...                    >> <<06730>>02800000
else                                                           <<06730>>02805000
   begin   << dev'or'class = 0, wake all output spoolers.   >> <<06730>>02810000
                                                               <<06730>>02815000
<< ***caution*** sroost is called  for  all  ldevs  (except >> <<06730>>02820000
<< ldev  1)  on  the  system.  proper  operation depends on >> <<06730>>02825000
<< sroost continuing to wake only real devices  which  have >> <<06730>>02830000
<< been  spooled out.  even so, it can take a while on sys- >> <<06730>>02835000
<< tems with a large number of real devices.                >> <<06730>>02840000
                                                               <<06730>>02845000
   loop'counter := 2;                                          <<06730>>02850000
   movefromdseg (@ldt, ldt'dst, 0 << base of segment >>,       <<06730>>02855000
                 size'of'ldt'entry);   << master entry.     >> <<06730>>02860000
   num'ldt'entries := ldt'num'entries;                         <<06730>>02865000
   do sroost (loop'counter) until                              <<06730>>02870000
      (loop'counter := loop'counter + 1) > num'ldt'entries;    <<06730>>02875000
   end;    << wake all output spoolers.                     >> <<06730>>02880000
relsir (ldt'sir, save'ldt'sir);                                <<06730>>02885000
                                                               <<06730>>02890000
<< the following call to help forces an stt  entry.  it  is >> <<06730>>02895000
<< never executed.                                          >> <<06730>>02900000
                                                               <<06730>>02905000
if false then help;                                            <<06730>>02910000
end;   << of srooster.                                      >> <<06730>>02915000
$page "   ***   ALLOCENTRY   ***"                              <<06730>>02920000
$control segment = allocutil                                   <<06730>>02925000
                                                                        02930000
logical procedure allocentry;                                           02935000
   option privileged, uncallable;                                       02940000
                                                               <<06730>>02945000
begin                                                          <<06730>>02950000
  comment -- allocentry searches the idd or odd (db must be at <<06730>>02955000
the proper xds on entry, same at exit) for an available suben- <<06730>>02960000
try.  the first word of an available subentry is 0. if no sub- <<06730>>02965000
entry is available in the currently allocated xds, the segment <<06730>>02970000
is expanded by one sector, the new area is initialized  to  0, <<06730>>02975000
and  the new subentry is taken from it.  if the segment is al- <<06730>>02980000
ready at its maximum size  (unlikely,  since  this  represents <<06730>>02985000
roughly 500 in-use input or output dfid's), allocentry returns <<06730>>02990000
ccl.  note that allocentry merely finds space.  other routines <<06730>>02995000
are responsible for filling the entry and linking it properly. <<06730>>03000000
                                                               <<06730>>03005000
inputs:   none.  db must be at the proper xds (idd or odd) and <<06730>>03010000
          the corresponding sir must be locked.                <<06730>>03015000
                                                               <<06730>>03020000
returns:  segment-relative address of available subentry, or 0 <<06730>>03025000
          (no subentry available, also returns ccl).           <<06730>>03030000
                                                               <<06730>>03035000
condition code:  cce -- no errors.                             <<06730>>03040000
                 ccl -- no subentry available.                 <<06730>>03045000
                                                               <<06730>>03050000
system failures:   350 -- error while expanding xds.           <<06730>>03055000
                                                               <<06730>>03060000
special considerations:  db must be at the idd or odd  on  en- <<06730>>03065000
                         try and the corresponding sir must be <<06730>>03070000
                         locked, same at exit.                 <<06730>>03075000
;                                                              <<06730>>03080000
integer                                                        <<06730>>03085000
   max'word'address,   << last segment-relative address  in >> <<06730>>03090000
                       << currently-allocated  segment that >> <<06730>>03095000
                       << a subentry can start in.          >> <<06730>>03100000
   status = q - 1,                                             <<06730>>03105000
   temp,                                                       <<06730>>03110000
   xdd'dst;                                                    <<06730>>03115000
                                                               <<06730>>03120000
logical pointer                                                <<06730>>03125000
   test'address;       << segment-relative offset of candi- >> <<06730>>03130000
                       << date subentry.                    >> <<06730>>03135000
logical array                                                  <<06730>>03140000
   xdd(*) = db + 0;    << required by xdd $include file.    >> <<06730>>03145000
                                                               <<06730>>03150000
                                                               <<06730>>03155000
cc := cce;                                                     <<06730>>03160000
if xdd0'idd'or'odd = xdd0'odd                                  <<06730>>03165000
   then xdd'dst := odd'dst                                     <<06730>>03170000
   else xdd'dst := idd'dst;                                    <<06730>>03175000
@test'address := xdd0'subentry'area;                           <<06730>>03180000
max'word'address := xdd0'current'sectors * words'per'sector    <<06730>>03185000
                    - xdd0'subentry'length;                    <<06730>>03190000
while true do                                                  <<06730>>03195000
      if @test'address <= max'word'address then                <<06730>>03200000
         if test'address = 0 then                              <<06730>>03205000
            begin   << available subentry in current alloc. >> <<06730>>03210000
            allocentry := @test'address;                       <<06730>>03215000
            return;                                            <<06730>>03220000
            end                                                <<06730>>03225000
         else @test'address := @test'address +                 <<06730>>03230000
              integer (xdd0'subentry'length)                   <<06730>>03235000
      else                                                     <<06730>>03240000
         begin   << all subentries in use, expand table.    >> <<06730>>03245000
         if xdd0'current'sectors >= xdd0'max'sectors then      <<06730>>03250000
            begin   << no room left to expand.              >> <<06730>>03255000
            allocentry := 0;                                   <<06730>>03260000
            cc := ccl;                                         <<06730>>03265000
            return;                                            <<06730>>03270000
            end;                                               <<06730>>03275000
         altdsegsize (xdd'dst, words'per'sector);              <<06730>>03280000
         if <> then suddendeath (sd350);                       <<07050>>03285000
         xdd (temp := xdd0'current'sectors * words'per'sector) <<06730>>03290000
             := 0;                                             <<06730>>03295000
         move xdd(temp+1) := xdd(temp), (words'per'sector-1);  <<06730>>03300000
         xdd0'current'sectors := xdd0'current'sectors + 1;     <<06730>>03305000
         max'word'address := max'word'address +                <<06730>>03310000
             words'per'sector;                                 <<06730>>03315000
         end;    << all subentries in use, also while loop. >> <<06730>>03320000
end;             << of allocentry.                          >> <<06730>>03325000
                                                                        03330000
$page "   ***   DEALLOCENTRY   ***"                            <<06730>>03335000
$control segment = allocutil                                   <<06730>>03340000
                                                               <<06730>>03345000
procedure deallocentry (xdd'subentry);                         <<06730>>03350000
   value xdd'subentry;                                         <<06730>>03355000
   logical pointer xdd'subentry;                               <<06730>>03360000
option privileged, uncallable;                                 <<06730>>03365000
                                                               <<06730>>03370000
begin                                                          <<06730>>03375000
  comment -- deallocentry makes an idd or  odd  subentry  area <<06730>>03380000
available  once  more  by setting its first word to 0.  (other <<06730>>03385000
routines must previously have delinked the subentry).  if  re- <<06730>>03390000
leasing  this  subentry makes it possible to decrease the data <<06730>>03395000
segment by one or more sectors, this is also done.             <<06730>>03400000
                                                               <<06730>>03405000
input:   segment-relative subentry address.  db must be at the <<06730>>03410000
         proper xds (idd or odd)  and  the  corresponding  sir <<06730>>03415000
         must be locked.                                       <<06730>>03420000
                                                               <<06730>>03425000
returns: none.  condition code is not affected.                <<06730>>03430000
                                                               <<06730>>03435000
system failures:  351 -- error while contracting xds.          <<06730>>03440000
                                                               <<06730>>03445000
special considerations:  db must be at the idd or odd  on  en- <<06730>>03450000
                         try and the corresponding sir must be <<06730>>03455000
                         locked, same at exit.                 <<06730>>03460000
;                                                              <<06730>>03465000
integer                                                        <<06730>>03470000
   max'word'address,   << last segment-relative address  in >> <<06730>>03475000
                       << currently-allocated  segment that >> <<06730>>03480000
                       << a subentry can start in.          >> <<06730>>03485000
   temp,                                                       <<06730>>03490000
   xdd'dst;                                                    <<06730>>03495000
                                                               <<06730>>03500000
logical pointer                                                <<06730>>03505000
   test'address;       << segment-relative offset of candi- >> <<06730>>03510000
                       << date subentry.                    >> <<06730>>03515000
logical array                                                  <<06730>>03520000
   xdd(*) = db + 0;    << required by xdd $include file.    >> <<06730>>03525000
                                                               <<06730>>03530000
if xdd0'idd'or'odd = xdd0'odd                                  <<06730>>03535000
   then xdd'dst := odd'dst                                     <<06730>>03540000
   else xdd'dst := idd'dst;                                    <<06730>>03545000
xdd'subentry := xdds'unused'subentry;   << make entry avail >> <<06730>>03550000
max'word'address := xdd0'current'sectors * words'per'sector    <<06730>>03555000
                    - xdd0'subentry'length;                    <<06730>>03560000
@test'address := @xdd'subentry;                                <<06730>>03565000
while @test'address <= max'word'address and                    <<06730>>03570000
   test'address = xdds'unused'subentry do                      <<06730>>03575000
      @test'address := @test'address +                         <<06730>>03580000
         integer (xdd0'subentry'length);                       <<06730>>03585000
if @test'address > max'word'address then                       <<06730>>03590000
   begin                                                       <<06730>>03595000
                                                               <<06730>>03600000
<< input entry parameter was last one currently in use. see >> <<06730>>03605000
<< if any others are available in front of it.              >> <<06730>>03610000
                                                               <<06730>>03615000
   @test'address := @xdd'subentry;                             <<06730>>03620000
   while test'address = xdds'unused'subentry and               <<06730>>03625000
         @test'address > integer (xdd0'subentry'area) do       <<06730>>03630000
      @test'address := @test'address -                         <<06730>>03635000
      integer (xdd0'subentry'length);                          <<06730>>03640000
   if test'address <> xdds'unused'subentry then                <<06730>>03645000
      @test'address := @test'address +                         <<06730>>03650000
                       integer (xdd0'subentry'length);         <<06730>>03655000
                                                               <<06730>>03660000
<< @test'address is now at the start of the next  available >> <<06730>>03665000
<< subentry. see if we recovered enough space to shrink the >> <<06730>>03670000
<< xds by one or more sectors.                              >> <<06730>>03675000
                                                               <<06730>>03680000
   temp := (integer (xdd0'current'sectors) * words'per'sector  <<06730>>03685000
           - @test'address) / words'per'sector;                <<06730>>03690000
   if temp > 0 then                                            <<06730>>03695000
      begin   << can shrink at least one sector.            >> <<06730>>03700000
      xdd0'current'sectors := xdd0'current'sectors -           <<06730>>03705000
           logical (temp);                                     <<06730>>03710000
      altdsegsize (xdd'dst, -(temp * words'per'sector));       <<06730>>03715000
      if <> then suddendeath (sd351);                          <<07050>>03720000
      end;    << can shrink at least one sector.            >> <<06730>>03725000
   end;   << input entry parameter was last one in use.     >> <<06730>>03730000
writedseg'serial (xdd'dst);                                    <<w7889>>03735000
end;      << of deallocentry.                               >> <<06730>>03740000
$page "   ***   SLINKXDD   ***"                                <<06730>>03745000
$control segment = allocutil                                   <<06730>>03750000
                                                                        03755000
procedure slinkxdd (head'index, new'entry);                    <<06730>>03760000
  value head'index, new'entry;                                 <<06730>>03765000
  integer head'index;                                          <<06730>>03770000
  logical pointer new'entry;                                   <<06730>>03775000
  option privileged, uncallable;                               <<06730>>03780000
begin comment --                                               <<06730>>03785000
  slinkxdd links the xdd subentry image pointed to by  new'en- <<06730>>03790000
try to the subentry chain associated with the head entry indi- <<06730>>03795000
cated by head'index.  if the subentry is an odd subentry,  its <<06730>>03800000
position in the chain is determined by its output priority (it <<06730>>03805000
goes just before the first subentry of lower priority). if the <<06730>>03810000
subentry is an idd subentry, it goes at the end of the chain.  <<06730>>03815000
  once the subentry has been linked, the updated data  segment <<06730>>03820000
is written to the disc.                                        <<06730>>03825000
  there are several possible inconsistencies with this  method <<06730>>03830000
which the previous version of slinkxdd did not check, no doubt <<06730>>03835000
for performance (speed) reasons since  the  checks  take  more <<06730>>03840000
time  per  link than the search and the problems only arise if <<06730>>03845000
the xdd has been corrupted.  however, i feel that this is time <<06730>>03850000
well spent if it will help insure the integrity of the xdd. we <<06730>>03855000
only come here when opening, closing or altering a devicefile, <<06730>>03860000
so we won't lose much time overall.                            <<06730>>03865000
  the inconsistencies (any of which result in sf 354) are:     <<06730>>03870000
1.  the first word of new'entry is 0, signifying that the sub- <<06730>>03875000
    entry is currently not in use.                             <<06730>>03880000
2.  new'entry is not a part of the chain defined  by  head'in- <<06730>>03885000
    dex.  this is checked by examining the head index field of <<06730>>03890000
    new'entry and comparing it to head'index.                  <<06730>>03895000
3.  while searching the links, we link to an area outside  the <<07050>>03900000
    currently-defined  xdd  subentry  area or exceed the total <<07050>>03905000
    number of subentries in the table  (signifies  an  endless <<07050>>03910000
    loop).                                                     <<07050>>03915000
                                                               <<06730>>03920000
inputs:   head'index.  defines the chain (ldev  or  class)  to <<06730>>03925000
          which new'entry is linked.                           <<06730>>03930000
                                                               <<06730>>03935000
          new'entry.  the subentry image to be linked  to  the <<06730>>03940000
          head'index chain.                                    <<06730>>03945000
                                                               <<06730>>03950000
returns:  none.  the condition code is not affected.           <<06730>>03955000
                                                               <<06730>>03960000
system failures:  354 -- see comments.                         <<06730>>03965000
                                                               <<06730>>03970000
special considerations:  db must be at the idd or odd  on  en- <<06730>>03975000
                         try and the corresponding sir must be <<06730>>03980000
                         locked, same at exit.                 <<06730>>03985000
;                                                              <<06730>>03990000
logical array                                                  <<06730>>03995000
   xdd(*) = db + 0;    << required by xdd $include file.    >> <<06730>>04000000
                                                               <<06730>>04005000
logical pointer                                                <<06730>>04010000
   xdd'head,           << required by xdd $include file.    >> <<06730>>04015000
   xdd'subentry;       << required by xdd $include file.    >> <<06730>>04020000
                                                               <<06730>>04025000
logical                                                        <<06730>>04030000
   found'it := false;                                          <<06730>>04035000
                                                               <<06730>>04040000
integer                                                        <<06730>>04045000
   entry'count := 0, << count of checked subentry links.    >> <<07050>>04050000
   entry'limit     , << max # links (to prevent looping).   >> <<07330>>04055000
   max'word'address, << last  segment-relative  address  in >> <<07050>>04060000
                     << currently-allocated  segment that a >> <<07050>>04065000
                     << subentry can start in.              >> <<07050>>04070000
   new'outpri,                                                 <<06730>>04075000
   next'entry,       << used during link search.            >> <<06730>>04080000
   previous'entry := -1,   << this too.                     >> <<06730>>04085000
   xdd'dst;                                                    <<06730>>04090000
                                                               <<06730>>04095000
@xdd'head := head'index * integer (xdd0'head'length);          <<06730>>04100000
@xdd'subentry := @new'entry;                                   <<06730>>04105000
if xdd0'idd'or'odd = xdd0'odd then                             <<06730>>04110000
   begin   << odd, scan links looking for lower priority.   >> <<06730>>04115000
   xdd'dst := odd'dst;                                         <<06730>>04120000
   next'entry := xddh'first'subentry;                          <<07050>>04125000
   if integer (xdds'head'index) <> head'index or               <<06730>>04130000
      xdd'subentry = xdds'unused'subentry then                 <<06730>>04135000
      suddendeath (sd354);                                     <<07050>>04140000
   new'outpri := xdds'output'priority;                         <<06730>>04145000
   max'word'address := xdd0'current'sectors * words'per'sector <<07050>>04150000
                       - xdd0'subentry'length;                 <<07050>>04155000
   entry'limit := (logical (max'word'address) -                <<07330>>04160000
                   xdd0'subentry'area) / xdd0'subentry'length  <<07330>>04165000
                   + 1;                                        <<07330>>04170000
   while next'entry <> xdds'end'of'chain and not found'it do   <<06730>>04175000
      begin   << compare priorities at this link.           >> <<06730>>04180000
      if next'entry > max'word'address or                      <<07330>>04185000
         next'entry < integer (xdd0'subentry'area) then        <<06730>>04190000
         suddendeath (sd354);   << outside subentry area.   >> <<07050>>04195000
      @xdd'subentry := next'entry;                             <<06730>>04200000
      if integer (xdds'output'priority) >= new'outpri then     <<06730>>04205000
         begin   << link not found yet, advance to next one >> <<06730>>04210000
         previous'entry := next'entry;                         <<06730>>04215000
         next'entry := xdds'next'subentry;                     <<06730>>04220000
         if (entry'count := entry'count + 1) > entry'limit     <<07050>>04225000
            then suddendeath (sd354);  << stop endless loop >> <<07050>>04230000
         end                                                   <<06730>>04235000
      else found'it := true;                                   <<06730>>04240000
      end;   << of while loop.                              >> <<06730>>04245000
   end       << of odd case.                                >> <<06730>>04250000
else                                                           <<06730>>04255000
   begin     << idd, put new subentry at tail.              >> <<06730>>04260000
   xdd'dst := idd'dst;                                         <<06730>>04265000
   if xdd'subentry = xdds'unused'subentry then                 <<06730>>04270000
      suddendeath (sd354);                                     <<07050>>04275000
   if integer (xddh'last'subentry) <> @xddh'first'subentry     <<06730>>04280000
      then previous'entry := xddh'last'subentry;               <<06730>>04285000
   next'entry := xdds'end'of'chain;                            <<06730>>04290000
   end;      << of idd case.                                >> <<06730>>04295000
if previous'entry = -1 then                                    <<06730>>04300000
   xddh'first'subentry := @new'entry; << linking at head.   >> <<06730>>04305000
if next'entry = xdds'end'of'chain then                         <<06730>>04310000
   xddh'last'subentry := @new'entry;  << linking at tail.   >> <<06730>>04315000
@xdd'subentry := @new'entry;                                   <<06730>>04320000
xdds'next'subentry := next'entry;     << new "next" link.   >> <<06730>>04325000
if integer (xddh'first'subentry) <> @new'entry then            <<06730>>04330000
   begin   << new "prior" link if not at head of queue.     >> <<06730>>04335000
   @xdd'subentry := previous'entry;                            <<06730>>04340000
   xdds'next'subentry := @new'entry;                           <<06730>>04345000
   end;    << new "prior" link.                             >> <<06730>>04350000
writedseg'serial (xdd'dst);                                    <<w7889>>04355000
end;       << of slinkxdd                                   >> <<06730>>04360000
$page "   ***   DELINKENTRY   ***"                             <<06730>>04365000
$control segment = allocutil                                   <<06730>>04370000
                                                                        04375000
procedure delinkentry (head'pointer, old'subentry);            <<06730>>04380000
   value old'subentry;                                         <<06730>>04385000
   logical pointer head'pointer, old'subentry;                 <<06730>>04390000
   option privileged, uncallable;                              <<06730>>04395000
begin comment --                                               <<06730>>04400000
  delinkentry delinks old'subentry from the  chain  of  suben- <<06730>>04405000
tries starting at the address in head'pointer. the subentry is <<06730>>04410000
not modified (the caller may want  to  relink  it  to  another <<06730>>04415000
chain).  the  chain is then relinked around the deleted suben- <<06730>>04420000
try.  if the subentry being delinked is either the head or the <<06730>>04425000
tail subentry (or both if it is the only one), the appropriate <<06730>>04430000
pointers in the head entry are also updated.                   <<06730>>04435000
  the subentry chain is searched, starting with the address in <<06730>>04440000
head'pointer and continuing through the links, until  old'sub- <<06730>>04445000
entry  is  found.  there  are several possible inconsistencies <<06730>>04450000
with this method which the previous version of delinkentry did <<06730>>04455000
not check, no doubt for performance (speed) reasons since  the <<06730>>04460000
checks  take  more time per link than the search and the prob- <<06730>>04465000
lems only arise if the xdd has been corrupted. however, i feel <<06730>>04470000
that this is time well spent if it will help assure the integ- <<06730>>04475000
rity of the xdd.  we only come here when opening,  closing  or <<06730>>04480000
altering a devicefile, so we won't lose much time overall.     <<06730>>04485000
  the inconsistencies (any of which result in sf 354 are):     <<06730>>04490000
1.  old'subentry is not a part of the chain defined  by  head' <<06730>>04495000
    pointer. this is checked by examining the head index field <<06730>>04500000
    of old'subentry and comparing it to  head'pointer.  it  is <<06730>>04505000
    also  established  if  we  search  the entire head'pointer <<06730>>04510000
    chain without matching old'subentry.                       <<06730>>04515000
2.  while searching the links, we link to an area outside  the <<07050>>04520000
    currently-defined  xdd  subentry  area, discover an unused <<07050>>04525000
    (but linked) subentry, or exceed the total number of  sub- <<07050>>04530000
    entries in the table (signifies an endless loop).          <<07050>>04535000
                                                               <<06730>>04540000
inputs:   head'pointer. the head entry word containing the ad- <<06730>>04545000
          dress of the first subentry in the chain.  note: not <<06730>>04550000
          the head index or the address of  the  corresponding <<06730>>04555000
          head entry, but the address of the head pointer word <<06730>>04560000
          in the head entry.                                   <<06730>>04565000
                                                               <<06730>>04570000
          old'subentry.  the segment-relative address  of  the <<06730>>04575000
          subentry to be delinked.                             <<06730>>04580000
                                                               <<06730>>04585000
returns:  updated head and tail  pointer,  if  any,  in  head' <<06730>>04590000
          pointer.  condition code is not affected.            <<06730>>04595000
                                                               <<06730>>04600000
system failures:  354 -- see comments.                         <<06730>>04605000
                                                               <<06730>>04610000
special considerations:  db must be at the idd or odd  on  en- <<06730>>04615000
                         try and the corresponding sir must be <<06730>>04620000
                         locked, same at exit.                 <<06730>>04625000
                                                               <<06730>>04630000
ways and means:  we need the local variable i'head'pointer  to <<06730>>04635000
                 get the address of head'pointer. i don't like <<06730>>04640000
                 this method, but it impossible to get the ad- <<06730>>04645000
                 dress of a reference  parameter  pointer  any <<06730>>04650000
                 other way.                                    <<06730>>04655000
;                                                              <<06730>>04660000
integer                                                        <<06730>>04665000
   entry'count := 0, << count of checked subentry links.    >> <<07050>>04670000
   entry'limit     , << max # links (to prevent looping).   >> <<07330>>04675000
   i'head'pointer = head'pointer,                              <<06730>>04680000
   max'word'address, << last  segment-relative  address  in >> <<07050>>04685000
                     << currently-allocated  segment that a >> <<07050>>04690000
                     << subentry can start in.              >> <<07050>>04695000
   next'entry,       << used during link search.            >> <<06730>>04700000
   old'next'link,    << link word from old'subentry.        >> <<06730>>04705000
   previous'entry := -1;   << used during link search.      >> <<06730>>04710000
                                                               <<06730>>04715000
logical array                                                  <<06730>>04720000
   xdd(*) = db + 0;    << required by xdd $include file.    >> <<06730>>04725000
                                                               <<06730>>04730000
logical pointer                                                <<06730>>04735000
   xdd'head,           << required by xdd $include file.    >> <<06730>>04740000
   xdd'subentry;       << this one too.                     >> <<06730>>04745000
                                                               <<06730>>04750000
                                                               <<06730>>04755000
@xdd'subentry := @old'subentry;                                <<06730>>04760000
@xdd'head := xdds'head'index * xdd0'head'length;               <<06730>>04765000
if i'head'pointer <> @xddh'first'subentry then                 <<06730>>04770000
   suddendeath (sd354);                                        <<07050>>04775000
old'next'link := xdds'next'subentry;                           <<06730>>04780000
next'entry := xddh'first'subentry;                             <<07050>>04785000
max'word'address := xdd0'current'sectors * words'per'sector    <<07050>>04790000
                    - xdd0'subentry'length;                    <<07050>>04795000
entry'limit := (logical (max'word'address) -                   <<07330>>04800000
                xdd0'subentry'area) / xdd0'subentry'length     <<07330>>04805000
                + 1;                                           <<07330>>04810000
                                                               <<06730>>04815000
while next'entry <> @old'subentry do                           <<06730>>04820000
   begin   << search links looking for match.               >> <<06730>>04825000
   if next'entry > max'word'address or                         <<07330>>04830000
      next'entry < integer (xdd0'subentry'area) or             <<06730>>04835000
      next'entry = xdds'end'of'chain then suddendeath (sd354); <<07050>>04840000
   @xdd'subentry := previous'entry := next'entry;              <<06730>>04845000
   if xdd'subentry = xdds'unused'subentry then                 <<06730>>04850000
      suddendeath (sd354);                                     <<07050>>04855000
   next'entry := xdds'next'subentry;                           <<06730>>04860000
   if (entry'count := entry'count + 1) > entry'limit then      <<07050>>04865000
      suddendeath (sd354);   << stop endless loop.          >> <<07050>>04870000
   end;                                                        <<06730>>04875000
                                                               <<06730>>04880000
<< found our subentry, now adjust links and pointers.       >> <<06730>>04885000
                                                               <<06730>>04890000
if previous'entry = -1 then                                    <<06730>>04895000
   begin   << delinking first or only subentry.             >> <<06730>>04900000
   xddh'first'subentry := old'next'link;                       <<06730>>04905000
   if old'next'link = xdds'end'of'chain then                   <<06730>>04910000
      xddh'last'subentry := @xddh'first'subentry;  << only  >> <<06730>>04915000
   end                                                         <<06730>>04920000
else                                                           <<06730>>04925000
   begin   << not first subentry, may be last.              >> <<06730>>04930000
   @xdd'subentry := previous'entry;                            <<06730>>04935000
   xdds'next'subentry := old'next'link;                        <<06730>>04940000
   if old'next'link = xdds'end'of'chain then                   <<06730>>04945000
      xddh'last'subentry := previous'entry;  << last subntry>> <<06730>>04950000
   end;                                                        <<06730>>04955000
end;   << of delinkentry.                                   >> <<06730>>04960000
$page "   ***   SRELINKODD   ***"                              <<06730>>04965000
$control segment = allocutil                                   <<06730>>04970000
                                                               <<06730>>04975000
procedure srelinkodd (xdd'subentry, newdev);                   <<06730>>04980000
   value   xdd'subentry, newdev;                               <<06730>>04985000
   integer newdev;                                             <<06730>>04990000
   logical pointer xdd'subentry;                               <<06730>>04995000
   option privileged, uncallable;                              <<06730>>05000000
begin comment --                                               <<06730>>05005000
  srelinkodd relinks the odd subentry beginning at odd segment <<06730>>05010000
relative address xdd'subentry to the chain specified  by  new- <<06730>>05015000
dev.  if  newdev < 0 it is taken as a device class table index <<06730>>05020000
and xdd'subentry is relinked to the odd class chain.           <<06730>>05025000
                                                               <<06730>>05030000
inputs:   xdd'subentry.  odd segment-relative address  of  the <<06730>>05035000
          first  word  of  the subentry to be relinked.  note: <<06730>>05040000
          the xdd $include file requires this symbol.          <<06730>>05045000
                                                               <<06730>>05050000
          newdev.  the new chain to which xdd'subentry  is  to <<06730>>05055000
          be  linked, if > 0 the associated ldev chain, if < 0 <<06730>>05060000
          the odd class chain.                                 <<06730>>05065000
                                                               <<06730>>05070000
returns:  none.  the condition code is not affected.           <<06730>>05075000
                                                               <<06730>>05080000
system failures:  352 -- the odd is inconsistent with the ldt. <<06730>>05085000
                                                               <<06730>>05090000
special consideration:  db may be anywhere at entry,  same  at <<06730>>05095000
                        exit.                                  <<06730>>05100000
;                                                              <<06730>>05105000
integer                                                        <<06730>>05110000
   dst'at'entry := -1,                                         <<06730>>05115000
   head'index,                                                 <<06730>>05120000
   ldt'index,                                                  <<06730>>05125000
   pcbpt,             << required by pcb $include file.     >> <<06730>>05130000
   save'ldt'sir,                                               <<06730>>05135000
   save'odd'sir,                                               <<06730>>05140000
   spool'state,                                                <<06730>>05145000
   virtual'device;                                             <<06730>>05150000
                                                               <<06730>>05155000
logical array                                                  <<06730>>05160000
   xdd(*) = db + 0;   << required by xdd $include file.     >> <<06730>>05165000
                                                               <<06730>>05170000
logical pointer                                                <<06730>>05175000
   ldt,               << required by ldt $include file.     >> <<06730>>05180000
   pcb = syspcbindex, << required by pcb $include file.     >> <<06730>>05185000
   xdd'head;          << required by xdd $include file.     >> <<06730>>05190000
                                                               <<06730>>05195000
subroutine def'movefromdseg;                                   <<06730>>05200000
                                                               <<06730>>05205000
if newdev = 0 then return;                                     <<06730>>05210000
pcbpt := curprc;      << required by pcb $include file.     >> <<06730>>05215000
save'ldt'sir := getsir (ldt'sir);                              <<06730>>05220000
save'odd'sir := getsir (odd'sir);                              <<06730>>05225000
if spcbxdsdst <> odd'dst then                                  <<06730>>05230000
   dst'at'entry := exchangedb (odd'dst);                       <<06730>>05235000
@xdd'head := xdds'head'index * xdd0'head'length;               <<06730>>05240000
tos := @xddh'first'subentry;   << can't fool spl...         >> <<06730>>05245000
delinkentry (*, xdd'subentry); <<   any other way.          >> <<06730>>05250000
virtual'device := xdds'virtual'ldev;                           <<06730>>05255000
spool'state := xdds'spool'state;                               <<06730>>05260000
exchangedb (ldt'dst);                                          <<06730>>05265000
@ldt := 0;                                                     <<06730>>05270000
ldt'index := newdev * integer (ldt'entry'size);                <<06730>>05275000
if newdev > 0                                                  <<06730>>05280000
   then head'index := ldt'xdd'head'index                       <<06730>>05285000
   else head'index := xdd'class'index;                         <<06730>>05290000
if spool'state = xdds'open and virtual'device <> 0 then        <<06730>>05295000
   begin   << update xdd index in ldt virtual device entry. >> <<06730>>05300000
   ldt'index := virtual'device * integer (ldt'entry'size);     <<06730>>05305000
   ldt'xdd'head'index := head'index;                           <<06730>>05310000
   end;                                                        <<06730>>05315000
exchangedb (odd'dst);                                          <<06730>>05320000
if newdev > 0 then                                             <<06730>>05325000
   begin   << consistency check between ldt and odd.        >> <<06730>>05330000
   @xdd'head := head'index * integer (xdd0'head'length);       <<06730>>05335000
   if integer (xddh'ldev) <> newdev then suddendeath (sd352);  <<07050>>05340000
   end;                                                        <<06730>>05345000
xdds'class := (newdev < 0);                                    <<06730>>05350000
xdds'device := \newdev\;                                       <<06730>>05355000
xdds'head'index := head'index;                                 <<06730>>05360000
slinkxdd (head'index, xdd'subentry);                           <<06730>>05365000
if dst'at'entry <> -1 then exchangedb (dst'at'entry);          <<06730>>05370000
relsir (odd'sir, save'odd'sir);                                <<06730>>05375000
relsir (ldt'sir, save'ldt'sir);                                <<06730>>05380000
end;   << of srelinkodd.                                    >> <<06730>>05385000
$page "   ***   SPUTXDD   ***"                                 <<06730>>05390000
$control segment = allocutil                                   <<06730>>05395000
                                                                        05400000
integer procedure sputxdd (odd, device, new'subentry,          <<06730>>05405000
                           xdd'address);                       <<06730>>05410000
   value   odd, device;                                        <<06730>>05415000
   logical odd;                                                <<06730>>05420000
   integer device;                                             <<06730>>05425000
   logical array new'subentry;                                 <<06730>>05430000
   logical pointer xdd'address;                                <<06730>>05435000
   option  privileged, uncallable;                             <<06730>>05440000
                                                               <<06730>>05445000
begin comment --                                               <<06730>>05450000
  sputxdd takes an xdd subentry image (new'subentry) built and <<06730>>05455000
partially filled by the caller. it fills some more fields, ac- <<06730>>05460000
quires space for it in the appropriate table (idd or odd), and <<06730>>05465000
links the subentry into the appropriate device or class chain. <<06730>>05470000
                                                               <<06730>>05475000
inputs:   odd. true if the subentry is to go in the odd, false <<06730>>05480000
          if it goes in the idd.                               <<06730>>05485000
                                                               <<06730>>05490000
          device.  if > 0, a logical device number.  if < 0, a <<06730>>05495000
          device class table index.  0 is not allowed  (causes <<06730>>05500000
          a system failure).                                   <<06730>>05505000
                                                               <<06730>>05510000
          new'subentry.  the image of the  subentry  which  we <<06730>>05515000
          will insert into the xdd.                            <<06730>>05520000
                                                               <<06730>>05525000
returns:  xdd'address.(1:15): the xdd segment-relative address <<06730>>05530000
          where the subentry was placed, or 0 if there was  no <<06730>>05535000
          room in the segment.                                 <<06730>>05540000
                                                               <<06730>>05545000
          xdd'address.(0:1):  1 if this is an odd subentry,  0 <<06730>>05550000
          if  this  is an idd subentry or if sputxdd indicates <<06730>>05555000
          no room in the xdd.                                  <<06730>>05560000
                                                               <<06730>>05565000
          sputxdd.  0 -- no error, 1 -- no room in xdd.        <<06730>>05570000
                                                               <<06730>>05575000
          the condition code is not affected.                  <<06730>>05580000
                                                               <<06730>>05585000
system failure:  353 -- the xdd is inconsistent with the  ldt, <<06730>>05590000
                        -or- the device parameter = 0.         <<06730>>05595000
                                                               <<06730>>05600000
special considerations:  db must be at  the  stack  at  entry, <<06730>>05605000
                         same at exit.                         <<06730>>05610000
                                                               <<06730>>05615000
ways and means:  after we get space for the subentry, we  must <<06730>>05620000
                 move  the  new'subentry image into the space. <<06730>>05625000
                 but new'subentry is stack db-relative,  while <<06730>>05630000
                 db is then at the xdd. using a rather bizarre <<06730>>05635000
                 application of movefromdseg, we move from the <<06730>>05640000
                 stack data segment to the xdd-relative suben- <<06730>>05645000
                 try area.  since db is not at the base of the <<06730>>05650000
                 stack data segment, we must obtain the offset <<06730>>05655000
                 before setting db to the xdd.                 <<06730>>05660000
                   the xdd revision for mpe v gives us a  real <<07050>>05665000
                 headache  --  we have to more the ldev/device <<07050>>05670000
                 class index field out of word 0 to expand  it <<07050>>05675000
                 to 16 bits.  the remaining eight bits can all <<07050>>05680000
                 be 0 (an active input file to an ldev (as op- <<07050>>05685000
                 posed to a class) at priority 0).  but we use <<07050>>05690000
                 a 0 in this word to test for an unused suben- <<07050>>05695000
                 try.  while the ldev/device class  index  was <<07050>>05700000
                 there we were safe (never use ldev or dci 0). <<07050>>05705000
                 to avoid this problem without changing sever- <<07050>>05710000
                 al modules, sputxdd will stuff a non-0  value <<07050>>05715000
                 in this unused field.                         <<07050>>05720000
;                                                              <<06730>>05725000
$page                                                          <<06730>>05730000
equate                                                         <<06730>>05735000
   no'error = 0,   << sputxdd                               >> <<06730>>05740000
   no'room  = 1;   <<   result values.                      >> <<06730>>05745000
                                                               <<06730>>05750000
logical array                                                  <<06730>>05755000
   qarray(*) = q + 0, << required by pxglobal $include file >> <<06730>>05760000
   ldt(0:size'of'ldt'entry-1),                                 <<06730>>05765000
   xdd(*) = db + 0;   << required by xdd $include file.     >> <<06730>>05770000
                                                               <<06730>>05775000
logical pointer                                                <<06730>>05780000
   pcb = syspcbindex, << required by pcb $include file.     >> <<06730>>05785000
   xdd'head,          << required by xdd $include file.     >> <<06730>>05790000
   xdd'subentry;      << this one too.                      >> <<06730>>05795000
                                                               <<06730>>05800000
integer                                                        <<06730>>05805000
   db'offset,         << from stack segment base to db.     >> <<06730>>05810000
   head'index,                                                 <<06730>>05815000
   ldt'index := 0,    << required by ldt $include file.     >> <<06730>>05820000
   pcbpt,             << required by pcb $include file.     >> <<06730>>05825000
   pcbglobloc,        << required by pxglobal $include file >> <<06730>>05830000
   q'new'subentry,    << for use later with db at xdd.      >> <<06730>>05835000
   save'xdd'sir,                                               <<06730>>05840000
   xdd'dst,                                                    <<06730>>05845000
   xdd'sir;                                                    <<06730>>05850000
                                                               <<06730>>05855000
                                                               <<06730>>05860000
subroutine def'movefromdseg;                                   <<06730>>05865000
                                                               <<06730>>05870000
                                                               <<06730>>05875000
pxglobal;             << required by pxglobal $include file >> <<06730>>05880000
db'offset := pxg'relative'db;                                  <<06730>>05885000
pcbpt := curprc;      << required by pcb $include file.     >> <<06730>>05890000
q'new'subentry := @new'subentry;                               <<06730>>05895000
if device = 0 then suddendeath (sd353);   << don't do that! >> <<07050>>05900000
if odd then                                                    <<06730>>05905000
   begin                                                       <<06730>>05910000
   xdd'dst := odd'dst;                                         <<06730>>05915000
   xdd'sir := odd'sir;                                         <<06730>>05920000
   end                                                         <<06730>>05925000
else                                                           <<06730>>05930000
   begin                                                       <<06730>>05935000
   xdd'dst := idd'dst;                                         <<06730>>05940000
   xdd'sir := idd'sir;                                         <<06730>>05945000
   end;                                                        <<06730>>05950000
                                                               <<06730>>05955000
if device  < 0 then   << device class table index.          >> <<06730>>05960000
   head'index := xdd'class'index                               <<06730>>05965000
else                                                           <<06730>>05970000
   begin              << logical device number.             >> <<06730>>05975000
   movefromdseg (@ldt, ldt'dst, device * size'of'ldt'entry,    <<06730>>05980000
                 size'of'ldt'entry);                           <<06730>>05985000
   head'index := ldt'xdd'head'index;                           <<06730>>05990000
   end;                                                        <<06730>>05995000
exchangedb (xdd'dst);                                          <<06730>>06000000
if device > 0 then                                             <<06730>>06005000
   begin   << consistency check between xdd and ldt.        >> <<06730>>06010000
   @xdd'head := head'index * integer (xdd0'head'length);       <<06730>>06015000
   if integer (xddh'ldev) <> device then suddendeath (sd353);  <<07050>>06020000
   end;                                                        <<06730>>06025000
save'xdd'sir := getsir (xdd'sir);                              <<06730>>06030000
@xdd'subentry := allocentry;   << try to get xdd space      >> <<06730>>06035000
if = then                      <<   for new subentry.       >> <<06730>>06040000
   begin                                                       <<06730>>06045000
                                                               <<06730>>06050000
<< got the space, now move subentry into it.  subentry  was >> <<06730>>06055000
<< partially initialized at entry.  we fill some more of it >> <<06730>>06060000
<< (but not all the rest) here.  this is where we  set  the >> <<07050>>06065000
<< unused  field  of word 0 to non-0 so that other routines >> <<07050>>06070000
<< will always know the subentry is in use.                 >> <<07050>>06075000
<<         *-*-*   c-a-u-t-i-o-n:    *-*-*                  >> <<07050>>06080000
<< this fix is over and above the xdd $include file defini- >> <<07050>>06085000
<< tion. if the xdd is ever revised to use this field, this >> <<07050>>06090000
<< code must also be changed.                               >> <<07050>>06095000
                                                               <<06730>>06100000
   movefromdseg (@xdd'subentry, spcbstkdst,                    <<06730>>06105000
       db'offset + q'new'subentry, xdd0'subentry'length);      <<06730>>06110000
   xdd'subentry.(8:8) := 1;   << any non-0 value will do.   >> <<07050>>06115000
   xdds'class := (device < 0);                                 <<06730>>06120000
   xdds'device := \device\;                                    <<06730>>06125000
   xdds'dfid'number := xdd0'next'dfid;                         <<06730>>06130000
   xdds'dfid'in'or'out := odd;                                 <<06730>>06135000
   xdd0'next'dfid := xdd0'next'dfid + 1;                       <<06730>>06140000
   if xdd0'next'dfid = 0 then xdd0'next'dfid := 1;             <<06730>>06145000
   xdds'head'index := head'index;                              <<06730>>06150000
                                                               <<06730>>06155000
<< link the subentry into the proper (device/class) chain.  >> <<06730>>06160000
                                                               <<06730>>06165000
   slinkxdd (head'index, xdd'subentry);                        <<06730>>06170000
                                                               <<06730>>06175000
<< we need the tos's below to avoid the split-stack trap -- >> <<06730>>06180000
<< stuffing a stack db-relative reference parameter  (@xdd' >> <<06730>>06185000
<< address with db not at the stack (still at the xdd here. >> <<06730>>06190000
                                                               <<06730>>06195000
   tos := logical (@xdd'subentry) lor (odd & lsl(15));         <<06730>>06200000
   sputxdd := no'error;                                        <<06730>>06205000
   end                                                         <<06730>>06210000
else                                                           <<06730>>06215000
   begin   << allocentry failed, no room left in xdd.       >> <<06730>>06220000
   tos := 0;                                                   <<06730>>06225000
   sputxdd := no'room;                                         <<06730>>06230000
   end;                                                        <<06730>>06235000
relsir (xdd'sir, save'xdd'sir);                                <<06730>>06240000
exchangedb (stack);                                            <<06730>>06245000
@xdd'address := tos;   << safe to return this now.          >> <<06730>>06250000
end;       << of sputxdd.                                   >> <<06730>>06255000
$page "   ***   SREMOVEXDD   ***"                              <<06730>>06260000
$control segment = allocutil                                   <<06730>>06265000
                                                                        06270000
procedure sremovexdd (xdd'subentry);                           <<06730>>06275000
   value xdd'subentry;                                         <<06730>>06280000
   logical pointer xdd'subentry;                               <<06730>>06285000
   option  privileged, uncallable;                             <<06730>>06290000
                                                               <<06730>>06295000
begin comment --                                               <<06730>>06300000
  sremovexdd delinks xdd'subentry from its  head  entry  chain <<06730>>06305000
and deallocates its subentry space.                            <<06730>>06310000
                                                               <<06730>>06315000
inputs:   xdd'subentry.(1:15) -- the xdd segment-relative  ad- <<06730>>06320000
          dress of the subentry to be deleted.                 <<06730>>06325000
                                                               <<06730>>06330000
          xdd'subentry.(0:1) -- 1 if this is an odd  subentry, <<06730>>06335000
          0 if this is an idd subentry.                        <<06730>>06340000
                                                               <<06730>>06345000
          note:  the xdd $include file requires this symbol.   <<06730>>06350000
                                                               <<06730>>06355000
returns:  none.  the condition code is not affected.           <<06730>>06360000
                                                               <<06730>>06365000
special considerations:  db may be anywhere at entry, same  at <<06730>>06370000
                         exit.                                 <<06730>>06375000
;                                                              <<06730>>06380000
integer                                                        <<06730>>06385000
   dst'at'entry := -1,                                         <<06730>>06390000
   pcbpt,             << required by pcb $include file.     >> <<06730>>06395000
   save'xdd'sir,                                               <<06730>>06400000
   xdd'dst,                                                    <<06730>>06405000
   xdd'sir;                                                    <<06730>>06410000
                                                               <<06730>>06415000
logical array                                                  <<06730>>06420000
   xdd(*) = db + 0;   << required by xdd $include file.     >> <<06730>>06425000
                                                               <<06730>>06430000
logical pointer                                                <<06730>>06435000
   pcb = syspcbindex, << required by pcb $include file.     >> <<06730>>06440000
   xdd'head;          << required by xdd $include file.     >> <<06730>>06445000
                                                               <<06730>>06450000
pcbpt := curprc;      << required by pcb $include file.     >> <<06730>>06455000
if logical (@xdd'subentry).(0:1) then                          <<06730>>06460000
   begin                                                       <<06730>>06465000
   xdd'dst := odd'dst;                                         <<06730>>06470000
   xdd'sir := odd'sir;                                         <<06730>>06475000
   end                                                         <<06730>>06480000
else                                                           <<06730>>06485000
   begin                                                       <<06730>>06490000
   xdd'dst := idd'dst;                                         <<06730>>06495000
   xdd'sir := idd'sir;                                         <<06730>>06500000
   end;                                                        <<06730>>06505000
                                                               <<06730>>06510000
<< don't need, and can't stand, bit 0 anymore, remove it.   >> <<06730>>06515000
                                                               <<06730>>06520000
@xdd'subentry := @xdd'subentry & lsl(1) & lsr(1);              <<06730>>06525000
if integer (spcbxdsdst) <> xdd'dst then                        <<06730>>06530000
   dst'at'entry := exchangedb (xdd'dst);                       <<06730>>06535000
save'xdd'sir := getsir (xdd'sir);                              <<06730>>06540000
@xdd'head := xdds'head'index * xdd0'head'length;               <<06730>>06545000
tos := @xddh'first'subentry;   << can't fool spl...         >> <<06730>>06550000
delinkentry (*, xdd'subentry); <<   any other way.          >> <<06730>>06555000
deallocentry (xdd'subentry);                                   <<06730>>06560000
relsir (xdd'sir, save'xdd'sir);                                <<06730>>06565000
if dst'at'entry <> -1 then exchangedb (dst'at'entry);          <<06730>>06570000
end;   << of sremovexdd.                                    >> <<06730>>06575000
$page "   ***   SFINDODD/SFINDIDD   ***"                       <<06730>>06580000
$control segment = allocutil                                   <<06730>>06585000
                                                               <<06730>>06590000
logical procedure sfindodd (dfid, xdd'address);                <<06730>>06595000
   value   dfid;                                               <<06730>>06600000
   integer dfid, xdd'address;                                  <<06730>>06605000
   option  privileged, uncallable;                             <<06730>>06610000
                                                               <<06730>>06615000
begin                                                          <<06730>>06620000
                                                               <<06730>>06625000
entry sfindidd;                                                <<06730>>06630000
                                                               <<06730>>06635000
comment --                                                     <<06730>>06640000
  sfindxdd searches the xdd linearly for  the  subentry  which <<06730>>06645000
corresponds  to dfid.  it returns the xdd segment-relative ad- <<06730>>06650000
dress in xdd'address.(1:15) and "x" (o = 1, i = 0) in (0:1).   <<06730>>06655000
                                                               <<06730>>06660000
inputs:   dfid.(1:15).  the input of output devicefile id num- <<06730>>06665000
          ber whose corresponding subentry is to be found.     <<06730>>06670000
                                                               <<06730>>06675000
          dfid.(0:1).  1 if this is an odd dfid, 0 if  an  idd <<06730>>06680000
          dfid.  as clear a case of belt and suspenders as can <<06730>>06685000
          be.  we'll use the entry point rather than this bit. <<06730>>06690000
                                                               <<06730>>06695000
returns:  xdd'address.(1:15). the xdd segment-relative address <<06730>>06700000
          of the target subentry, or 0 if  a  subentry  corre- <<06730>>06705000
          sponding to dfid could not be found.                 <<06730>>06710000
                                                               <<06730>>06715000
          xdd'address.(0:1).  1 if xdd = odd and the  subentry <<06730>>06720000
          was  located,  0  if xdd = idd or the subentry could <<06730>>06725000
          not be found.                                        <<06730>>06730000
                                                               <<06730>>06735000
          result:  true if the subentry was found, else false. <<06730>>06740000
                                                               <<06730>>06745000
          the condition code is not affected.                  <<06730>>06750000
                                                               <<06730>>06755000
special considerations: db must be at the stack on entry, same <<06730>>06760000
                        at exit.  this is because of the stack <<06730>>06765000
                        db-relative reference  parameter  xdd' <<06730>>06770000
                        address.                               <<06730>>06775000
;                                                              <<06730>>06780000
integer                                                        <<06730>>06785000
   max'word'address,   << last segment-relative address  in >> <<06730>>06790000
                       << currently-allocated  segment that >> <<06730>>06795000
                       << a subentry can start in.          >> <<06730>>06800000
   save'xdd'sir,                                               <<06730>>06805000
   xdd'dst,                                                    <<06730>>06810000
   xdd'sir;                                                    <<06730>>06815000
                                                               <<06730>>06820000
logical                                                        <<06730>>06825000
   found'it,                                                   <<06730>>06830000
   odd;                                                        <<06730>>06835000
                                                               <<06730>>06840000
logical array                                                  <<06730>>06845000
   xdd(*) = db + 0;    << required by xdd $include file.    >> <<06730>>06850000
                                                               <<06730>>06855000
logical pointer                                                <<06730>>06860000
   xdd'subentry;       << required by xdd $include file.    >> <<06730>>06865000
                                                               <<06730>>06870000
                                                               <<06730>>06875000
odd := true;                                                   <<06730>>06880000
                                                               <<06730>>06885000
while false do                                                 <<06730>>06890000
                                                               <<06730>>06895000
sfindidd:                                                      <<06730>>06900000
                                                               <<06730>>06905000
      odd := false;                                            <<06730>>06910000
                                                               <<06730>>06915000
sfindodd := found'it := false;                                 <<06730>>06920000
if odd then                                                    <<06730>>06925000
   begin                                                       <<06730>>06930000
   xdd'dst := odd'dst;                                         <<06730>>06935000
   xdd'sir := odd'sir;                                         <<06730>>06940000
   end                                                         <<06730>>06945000
else                                                           <<06730>>06950000
   begin                                                       <<06730>>06955000
   xdd'dst := idd'dst;                                         <<06730>>06960000
   xdd'sir := idd'sir;                                         <<06730>>06965000
   end;                                                        <<06730>>06970000
                                                               <<06730>>06975000
<< don't need dfid.(0:1), remove it.                        >> <<06730>>06980000
                                                               <<06730>>06985000
dfid := dfid & lsl(1) & lsr(1);                                <<06730>>06990000
exchangedb (xdd'dst);                                          <<06730>>06995000
save'xdd'sir := getsir (xdd'sir);                              <<06730>>07000000
max'word'address := xdd0'current'sectors * words'per'sector    <<06730>>07005000
                    - xdd0'subentry'length;                    <<06730>>07010000
@xdd'subentry := xdd0'subentry'area;                           <<06730>>07015000
while not found'it and @xdd'subentry <= max'word'address do    <<06730>>07020000
      if xdd'subentry <> xdds'unused'subentry                  <<06730>>07025000
         and integer (xdds'dfid'number) = dfid then            <<06730>>07030000
         found'it := true                                      <<06730>>07035000
      else @xdd'subentry := @xdd'subentry +                    <<06730>>07040000
         integer (xdd0'subentry'length);   << try next.     >> <<06730>>07045000
if found'it then                                               <<06730>>07050000
   begin   << must use tos to avoid split-stack problems.   >> <<06730>>07055000
   tos := logical (@xdd'subentry) lor (odd & lsl(15));         <<06730>>07060000
   sfindodd := true;                                           <<06730>>07065000
   end                                                         <<06730>>07070000
else tos := 0;                                                 <<06730>>07075000
exchangedb (stack);                                            <<06730>>07080000
relsir (xdd'sir, save'xdd'sir);                                <<06730>>07085000
xdd'address := tos;   << safe to return this now.           >> <<06730>>07090000
end;   << of sfindxdd.                                      >> <<06730>>07095000
$page "   ***   SFINDACTIVE   ***"                             <<06730>>07100000
$control segment = allocutil                                   <<06730>>07105000
                                                               <<06730>>07110000
logical procedure sfindactive (ldev, dfid);                    <<06730>>07115000
   value   ldev;                                               <<06730>>07120000
   integer ldev, dfid;                                         <<06730>>07125000
   option  privileged, uncallable;                             <<06730>>07130000
                                                               <<06730>>07135000
begin comment --                                               <<06730>>07140000
  sfindactive searches the odd chain defined by  ldev  for  an <<06730>>07145000
active devicefile id.  its number is returned in dfid.         <<06730>>07150000
                                                               <<06730>>07155000
inputs:   ldev.  the logical device number of a spooled output <<06730>>07160000
          device.  (if the device is unspooled it is never ac- <<06730>>07165000
          tive, and input spooled devices are not considered). <<06730>>07170000
                                                               <<06730>>07175000
returns:  dfid.(1:15).  the devicefile id number of  the  cur- <<07330>>07180000
          rently  active  file  on  ldev,  or 0 if ldev is not <<07330>>07185000
          spooled for output or if no file is currently active <<07330>>07190000
          on it.                                               <<07330>>07195000
                                                               <<07330>>07200000
          dfid.(0:1).  1 if dfid.(1:15) <> 0, else 0.          <<07330>>07205000
                                                               <<06730>>07210000
          sfindactive.  true if dfid is non-zero, else false.  <<06730>>07215000
                                                               <<06730>>07220000
special considerations: db must be at the stack on entry, same <<06730>>07225000
                        at exit.  this is because of the stack <<06730>>07230000
                        db-relative reference parameter dfid.  <<06730>>07235000
                                                               <<06730>>07240000
                        the ldt and odd sir's must be acquired <<06730>>07245000
                        (in that order) before sfindactive  is <<06730>>07250000
                        called.                                <<06730>>07255000
;                                                              <<06730>>07260000
integer                                                        <<06730>>07265000
   ldt'index := 0;                                             <<06730>>07270000
                                                               <<06730>>07275000
logical                                                        <<06730>>07280000
   found'it := false;                                          <<06730>>07285000
                                                               <<06730>>07290000
logical array                                                  <<06730>>07295000
   ldt(0:size'of'ldt'entry-1) = q,  << to access w/db @ odd >> <<07050>>07300000
   xdd(*) = db + 0;    << required by xdd $include file.    >> <<06730>>07305000
                                                               <<06730>>07310000
logical pointer                                                <<06730>>07315000
   xdd'head,           << required by xdd $include file.    >> <<06730>>07320000
   xdd'subentry;       << this one too.                     >> <<06730>>07325000
                                                               <<06730>>07330000
define                 << required by lpdt $include file.   >> <<06730>>07335000
   lpdt'index = ldev * integer (lpdt'entry'size)#;             <<06730>>07340000
                                                               <<06730>>07345000
subroutine def'movefromdseg;                                   <<06730>>07350000
                                                               <<06730>>07355000
                                                               <<06730>>07360000
sfindactive := false;                                          <<06730>>07365000
dfid := 0;                                                     <<06730>>07370000
if ldev <= 0 then return;                                      <<06730>>07375000
movefromdseg (@ldt, ldt'dst, 0, size'of'ldt'entry);            <<06730>>07380000
if ldev > integer (ldt'num'entries) then return;               <<06730>>07385000
if lpdt'virtual'device then return;                            <<06730>>07390000
movefromdseg (@ldt, ldt'dst, ldev * size'of'ldt'entry,         <<06730>>07395000
              size'of'ldt'entry);                              <<06730>>07400000
if ldt'spool'state <> ldt'output'spooled then return;          <<06730>>07405000
exchangedb (odd'dst);                                          <<06730>>07410000
@xdd'head := ldt'xdd'head'index * xdd0'head'length;            <<06730>>07415000
@xdd'subentry := xddh'first'subentry;                          <<06730>>07420000
while @xdd'subentry <> xdds'end'of'chain and not found'it do   <<06730>>07425000
      if xdd'subentry <> xdds'unused'subentry                  <<06730>>07430000
         and xdds'spool'state = xdds'active                    <<06730>>07435000
         then found'it := true                                 <<06730>>07440000
      else @xdd'subentry := xdds'next'subentry;                <<06730>>07445000
if found'it then                                               <<06730>>07450000
   begin   << must use tos to avoid split-stack problems.   >> <<06730>>07455000
   sfindactive := true;                                        <<06730>>07460000
   tos := xdds'dfid'number lor (xdds'dfid'in'or'out & lsl(15));<<06730>>07465000
   end                                                         <<06730>>07470000
else tos := 0;                                                 <<06730>>07475000
exchangedb (stack);                                            <<06730>>07480000
dfid := tos;   << safe to return this now.                  >> <<06730>>07485000
end;           << of sfindactive.                           >> <<06730>>07490000
$page "   ***   XDDSPOOLINFO   ***"                            <<06730>>07495000
$control segment = allocutil                                   <<06730>>07500000
                                                               <<06730>>07505000
double procedure xddspoolinfo (dvalue, bitmap, xdd'subentry);  <<06730>>07510000
   value   dvalue, bitmap, xdd'subentry;                       <<06730>>07515000
   double  dvalue;                                             <<06730>>07520000
   logical bitmap;                                             <<06730>>07525000
   logical pointer xdd'subentry;                               <<06730>>07530000
   option  privileged, uncallable;                             <<06730>>07535000
                                                               <<06730>>07540000
begin comment --                                               <<06730>>07545000
   xddspoolinfo is a hodgepodge of an xdd access  routine.  it <<06730>>07550000
allows  the  caller to get/put/test/modify/increment/decrement <<06730>>07555000
one field in the xdd subentry whose  segment-relative  address <<06730>>07560000
is  passed  in.  (xdd'subentry bit 0:  true ==> odd, false ==> <<06730>>07565000
idd).  the field to be accessed, as well as what is to be done <<06730>>07570000
with it, is determined by the bitmap parameter (see below  for <<06730>>07575000
details).  new  values  for fields are passed in dvalue, while <<06730>>07580000
any existing or modified values are returned in the result.    <<06730>>07585000
  since only one operation per call is allowed, the least sig- <<06730>>07590000
nificant bit in bitmap (except bit 15, which  is  a  direction <<06730>>07595000
bit) determines which operation is performed.                  <<06730>>07600000
                                                               <<06730>>07605000
bitmap    bitmap               function                        <<06730>>07610000
 bit      bit 15                                               <<06730>>07615000
-------------------------------------------------------------- <<06730>>07620000
                                                               <<06730>>07625000
  0          x      not defined.                               <<06730>>07630000
                                                               <<06730>>07635000
  1          x      not defined.                               <<06730>>07640000
                                                               <<06730>>07645000
  2          x      not defined.                               <<06730>>07650000
                                                               <<06730>>07655000
  3          1      set job aborted bit.                       <<06730>>07660000
             0      return state of job aborted bit.           <<06730>>07665000
                                                               <<06730>>07670000
  4          x      return dfid number.                        <<06730>>07675000
                                                               <<06730>>07680000
  5          1      decrement number of extents by 1.          <<06730>>07685000
             0      increment number of extents by 1 -and-     <<06730>>07690000
                      increment number of records by dvalue.   <<06730>>07695000
                                                               <<06730>>07700000
  6          1      set purge extents (sqeeze) bit.            <<06730>>07705000
             0      return state of purge extents bit.         <<06730>>07710000
                                                               <<06730>>07715000
  7          x      return state of spaced out bit.            <<06730>>07720000
                                                               <<06730>>07725000
  8          x      set spaced out bit.                        <<06730>>07730000
                                                               <<06730>>07735000
  9          x      increment number of extents by 1.          <<06730>>07740000
                                                               <<06730>>07745000
 10          1      set number of extents to dvalue msw and    <<06730>>07750000
                      last extent size (sectrs) to dvalue lsw. <<06730>>07755000
             0      return the same information in             <<06730>>07760000
                      xddspoolinfo msw and lsw.                <<06730>>07765000
                                                               <<06730>>07770000
 11          1      set number of records to dvalue.           <<06730>>07775000
             0      return number of records.                  <<06730>>07780000
                                                               <<06730>>07785000
 12          x      set the spoolfile to the ready state.      <<06730>>07790000
                                                               <<06730>>07795000
 13          x      decrement the number of copies (restrict   <<06730>>07800000
                      to >= 0) and return the new number.      <<06730>>07805000
                                                               <<06730>>07810000
 14          1      set spoolfile label address and ldev.      <<06730>>07815000
             0      return spoolfile label address and ldev.   <<06730>>07820000
                                                               <<06730>>07825000
return:  see above.  the condition code is not affected.       <<06730>>07830000
                                                               <<06730>>07835000
special considerations:  db may be anywhere at entry, same  at <<06730>>07840000
                         exit.                                 <<06730>>07845000
;                                                              <<06730>>07850000
integer                                                        <<06730>>07855000
   count,              << for case, corresponds to bitmap   >> <<06730>>07860000
                       <<   function bit.                   >> <<06730>>07865000
   dvalue0 = dvalue,                                           <<06730>>07870000
   dvalue1 = dvalue + 1,                                       <<06730>>07875000
   dst'at'entry := -1,                                         <<06730>>07880000
   pcbpt,              << required by pcb $include file.    >> <<06730>>07885000
   save'xdd'sir,                                               <<06730>>07890000
   xdd'dst,                                                    <<06730>>07895000
   xdd'sir;                                                    <<06730>>07900000
                                                               <<06730>>07905000
logical array                                                  <<06730>>07910000
   xdd(*) = db + 0;    << required by xdd $include file.    >> <<06730>>07915000
                                                               <<07104>>07920000
byte                                                           <<07104>>07925000
   xddspoolinfo'b = xddspoolinfo;                              <<07104>>07930000
                                                               <<06730>>07935000
logical pointer                                                <<06730>>07940000
   pcb = syspcbindex,  << required by pcb $include file.    >> <<06730>>07945000
   xdd'head;           << required by xdd $include file.    >> <<06730>>07950000
                                                               <<06730>>07955000
double pointer                                                 <<06730>>07960000
   xdd'dsubentry = xdd'subentry;   << for xdd $include file >> <<06730>>07965000
                                                               <<06730>>07970000
define                                                         <<06730>>07975000
   decrement = bitmap#,   << different interpretations of   >> <<06730>>07980000
   sets      = bitmap#;   <<   bitmap.(15:1).               >> <<06730>>07985000
                                                               <<06730>>07990000
                                                               <<06730>>07995000
xddspoolinfo := 0d;                                            <<06730>>08000000
pcbpt := curprc;       << required by pcb $include file.    >> <<06730>>08005000
if logical (@xdd'subentry).(0:1) then                          <<06730>>08010000
   begin                                                       <<06730>>08015000
   xdd'dst := odd'dst;                                         <<06730>>08020000
   xdd'sir := odd'sir;                                         <<06730>>08025000
   end                                                         <<06730>>08030000
else                                                           <<06730>>08035000
   begin                                                       <<06730>>08040000
   xdd'dst := idd'dst;                                         <<06730>>08045000
   xdd'sir := idd'sir;                                         <<06730>>08050000
   end;                                                        <<06730>>08055000
                                                               <<06730>>08060000
<< don't need, and can't stand, bit 0 anymore, remove it.   >> <<06730>>08065000
                                                               <<06730>>08070000
@xdd'subentry := @xdd'subentry & lsl(1) & lsr(1);              <<06730>>08075000
if integer (spcbxdsdst) <> xdd'dst then                        <<06730>>08080000
   dst'at'entry := exchangedb (xdd'dst);                       <<06730>>08085000
save'xdd'sir := getsir (xdd'sir);                              <<06730>>08090000
if xdd'subentry <> xdds'unused'subentry                        <<06730>>08095000
   and bitmap > 1 then            << something to do        >> <<06730>>08100000
   begin   << scan bitmap, bit 14 to msb to find our task.  >> <<06730>>08105000
   count := 14;                                                <<06730>>08110000
   tos := bitmap;                                              <<06730>>08115000
   while not (tos := tos & lsr(1)) do count := count - 1;      <<06730>>08120000
   del;                                                        <<06730>>08125000
   case * count of                                             <<06730>>08130000
   begin                                                       <<06730>>08135000
      ;      << bit 0 -- unused.                            >> <<06730>>08140000
      ;      << bit 1 -- unused.                            >> <<06730>>08145000
      ;      << bit 2 -- unused.                            >> <<06730>>08150000
                                                               <<06730>>08155000
<< *-*-* bit 3 -- set or return job abort bit.        *-*-* >> <<06730>>08160000
                                                               <<06730>>08165000
      if sets                                                  <<06730>>08170000
         then odds'aborted'job := true                         <<06730>>08175000
         else xddspoolinfo := double (odds'aborted'job);       <<06730>>08180000
                                                               <<06730>>08185000
<< *-*-* bit 4 -- return dfid.                        *-*-* >> <<06730>>08190000
                                                               <<06730>>08195000
      xddspoolinfo := double (xdds'dfid'number lor             <<06730>>08200000
                      (xdds'dfid'in'or'out & lsl(15)));        <<06730>>08205000
                                                               <<06730>>08210000
<< *-*-* bit 5 -- decrement number of extents by 1 -or-     >> <<06730>>08215000
<<                increment by 1 and bump number of records >> <<06730>>08220000
<<                by dvalue.                          *-*-* >> <<06730>>08225000
                                                               <<06730>>08230000
      begin                                                    <<06730>>08235000
      if decrement then                                        <<06730>>08240000
         xdds'number'extents := xdds'number'extents - 1        <<06730>>08245000
      else                                                     <<06730>>08250000
         begin                                                 <<06730>>08255000
         xdds'number'extents := xdds'number'extents + 1;       <<06730>>08260000
         xddsd'record'count := xddsd'record'count + dvalue;    <<06730>>08265000
         end;                                                  <<06730>>08270000
      writedseg'serial (xdd'dst);  << post updated segment. >> <<w7889>>08275000
      end;                                                     <<06730>>08280000
                                                               <<06730>>08285000
<< *-*-* bit 6 -- set or return purge extents bit.    *-*-* >> <<06730>>08290000
                                                               <<06730>>08295000
      if sets then                                             <<06730>>08300000
         begin                                                 <<06730>>08305000
         odds'purge'extents := true;                           <<06730>>08310000
         writedseg'serial (xdd'dst); <<post updated segment.>> <<w7889>>08315000
         end                                                   <<06730>>08320000
      else xddspoolinfo := double (odds'purge'extents);        <<06730>>08325000
                                                               <<06730>>08330000
<< *-*-* bit 7 -- return spaced out bit.              *-*-* >> <<06730>>08335000
                                                               <<06730>>08340000
      xddspoolinfo := double (xdds'spaced'out);                <<06730>>08345000
                                                               <<06730>>08350000
<< *-*-* bit 8 -- set spaced out bit.                 *-*-* >> <<06730>>08355000
                                                               <<06730>>08360000
      begin                                                    <<06730>>08365000
      xdds'spaced'out := true;                                 <<06730>>08370000
      writedseg'serial (xdd'dst);  << post updated segment. >> <<w7889>>08375000
      end;                                                     <<06730>>08380000
                                                               <<06730>>08385000
<< *-*-* bit 9 -- increment number of extents by 1.   *-*-* >> <<06730>>08390000
                                                               <<06730>>08395000
      begin                                                    <<06730>>08400000
      xdds'number'extents := xdds'number'extents + 1;          <<06730>>08405000
      writedseg'serial (xdd'dst);  << post updated segment. >> <<w7889>>08410000
      end;                                                     <<06730>>08415000
                                                               <<06730>>08420000
<< *-*-* bit 10 -- set or return number of extents and      >> <<06730>>08425000
<<                 size of last extent.               *-*-* >> <<06730>>08430000
                                                               <<06730>>08435000
      if sets then                                             <<06730>>08440000
         begin                                                 <<06730>>08445000
         xdds'number'extents := dvalue0;                       <<06730>>08450000
         xdds'last'extent'size := dvalue1;                     <<06730>>08455000
         writedseg'serial (xdd'dst); <<post updated segment.>> <<w7889>>08460000
         end                                                   <<06730>>08465000
      else                                                     <<06730>>08470000
         begin   << gather values on tos, not nice but...   >> <<06730>>08475000
         tos := xdds'number'extents;                           <<06730>>08480000
         tos := xdds'last'extent'size;                         <<06730>>08485000
         xddspoolinfo := tos;                                  <<06730>>08490000
         end;                                                  <<06730>>08495000
                                                               <<06730>>08500000
<< *-*-* bit 11 -- set or return number of records.   *-*-* >> <<06730>>08505000
                                                               <<06730>>08510000
      if sets then                                             <<06730>>08515000
         begin                                                 <<06730>>08520000
         xddsd'record'count := dvalue;                         <<06730>>08525000
         writedseg'serial (xdd'dst); <<post updated segment.>> <<w7889>>08530000
         end                                                   <<06730>>08535000
      else xddspoolinfo := xddsd'record'count;                 <<06730>>08540000
                                                               <<06730>>08545000
<< *-*-* bit 12 -- set spoolfile state to ready.      *-*-* >> <<06730>>08550000
                                                               <<06730>>08555000
      begin                                                    <<06730>>08560000
      xdds'spool'state := xdds'ready;                          <<06730>>08565000
      writedseg'serial (xdd'dst);  << post updated segment. >> <<w7889>>08570000
      end;                                                     <<06730>>08575000
                                                               <<06730>>08580000
<< *-*-* bit 13 -- decrement # copies, limit to 0.          >> <<06730>>08585000
<<                 return the result.                 *-*-* >> <<06730>>08590000
                                                               <<06730>>08595000
      begin                                                    <<06730>>08600000
      if odds'number'copies > 0 then                           <<06730>>08605000
         odds'number'copies := odds'number'copies - 1;         <<06730>>08610000
      writedseg'serial (xdd'dst);  << post updated segment. >> <<w7889>>08615000
      xddspoolinfo := double (odds'number'copies);             <<06730>>08620000
      end;                                                     <<06730>>08625000
                                                               <<06730>>08630000
<< *-*-* bit 14 -- set or return spoolfile label address    >> <<06730>>08635000
<<                 and ldev.                          *-*-* >> <<06730>>08640000
                                                               <<06730>>08645000
      if sets then                                             <<06730>>08650000
         begin                                                 <<06730>>08655000
         xddsd'disc'label := dvalue;                           <<06730>>08660000
                                                               <<07050>>08665000
<< convert ldev in xdd disc label field to vtab index.      >> <<07050>>08670000
                                                               <<07050>>08675000
         xdds'spoofle'vt'index :=                              <<07050>>08680000
              vtabinx (xdds'spoofle'vt'index, false);          <<07050>>08685000
         writedseg'serial (xdd'dst); <<post updated segment.>> <<w7889>>08690000
         end                                                   <<06730>>08695000
      else                                                     <<06730>>08700000
                                                               <<07050>>08705000
<< convert vtab index in xdd disc label field to ldev.      >> <<07050>>08710000
                                                               <<07050>>08715000
         begin                                                 <<07050>>08720000
         xddspoolinfo := xddsd'disc'label;                     <<07104>>08725000
         xddspoolinfo'b := lun (xdds'spoofle'vt'index, 0);     <<07104>>08730000
         end;                                                  <<07050>>08735000
                                                               <<06730>>08740000
   end;   << of case statement.                             >> <<06730>>08745000
                                                               <<06730>>08750000
   end;   << something to do.                               >> <<06730>>08755000
relsir (xdd'sir, save'xdd'sir);                                <<06730>>08760000
if dst'at'entry <> -1 then exchangedb (dst'at'entry);          <<06730>>08765000
end;      << of xddspoolinfo.                               >> <<06730>>08770000
$page "   ***   SPOOLEDDEV   ***"                              <<06730>>08775000
$control segment = allocutil                                   <<06730>>08780000
                                                               <<06730>>08785000
logical procedure spooleddev (device);                         <<06730>>08790000
   value device;                                               <<06730>>08795000
   integer device;                                             <<06730>>08800000
   option privileged, uncallable;                              <<06730>>08805000
begin comment --                                               <<06730>>08810000
  spooleddev examines the ldt and returns spooling information <<06730>>08815000
about device as follows:                                       <<06730>>08820000
1.  if device > 0, we assume it's an ldev.  if the  device  is <<06730>>08825000
    available  to  users as a spooled device (spool queues are <<06730>>08830000
    open), bit 15 of the result is set. if the device is owned <<06730>>08835000
    by a spooler process, bit 14 (output spooler) or 13 (input <<06730>>08840000
    spooler) is set.                                           <<06730>>08845000
2.  if device < 0, we assume it's a device class table  index. <<06730>>08850000
    if  spool queues are open for the class, bit 15 of the re- <<06730>>08855000
    sult is set.  if not, then every device in  the  class  is <<06730>>08860000
    checked  according  to 1. above.  the resulting bits 13-15 <<06730>>08865000
    are logically ored for all devices checked. callers beware <<06730>>08870000
    the situation where one ldev has its queues  open  but  is <<06730>>08875000
    not spooled, while for another the reverse is true.        <<06730>>08880000
                                                               <<06730>>08885000
special considerations:  db may be anywhere at entry, same  at <<06730>>08890000
                         return.  spooleddev is most efficient <<06730>>08895000
                         if called with db at the stack.       <<06730>>08900000
                                                               <<06730>>08905000
ways and means:  starting with mpe v, the logical device table <<06730>>08910000
                 (ldt) and device class  table  (dct)  are  in <<06730>>08915000
                 different  data segments.  to avoid excessive <<06730>>08920000
                 exchangedb's, spooleddev and other procedures <<06730>>08925000
                 which access both tables make local copies of <<06730>>08930000
                 the entries they work with. since dct entries <<06730>>08935000
                 are of variable length, any local  copy  must <<06730>>08940000
                 be built on the stack. references to this ar- <<06730>>08945000
                 ray must be indirect, therefore db  must  re- <<06730>>08950000
                 main at the stack.                            <<06730>>08955000
;                                                              <<06730>>08960000
integer                                                        <<06730>>08965000
   devices'in'class,                                           <<06730>>08970000
   dst'at'entry := -1,                                         <<06730>>08975000
   entry'address,                                              <<06730>>08980000
   entry'length,                                               <<06730>>08985000
   pcbpt,             << required by pcb $include file.     >> <<06730>>08990000
   save'dct'sir,                                               <<06730>>08995000
   save'ldt'sir;                                               <<06730>>09000000
                                                               <<06730>>09005000
logical array                                                  <<06730>>09010000
   ldt(0:size'of'ldt'entry-1) = q;                             <<07050>>09015000
                                                               <<06730>>09020000
logical pointer                                                <<06730>>09025000
   dct,                                                        <<06730>>09030000
   pcb = syspcbindex; << required by pcb $include file.     >> <<06730>>09035000
                                                               <<06730>>09040000
define                                                         <<06730>>09045000
   ldt'index = 0 #;                                            <<06730>>09050000
                                                               <<06730>>09055000
                                                               <<06730>>09060000
subroutine def'movefromdseg;                                   <<06730>>09065000
                                                               <<06730>>09070000
                                                               <<06730>>09075000
subroutine check'1'dev (ldev);                                 <<06730>>09080000
   value ldev;  integer ldev;                                  <<06730>>09085000
begin                                                          <<06730>>09090000
movefromdseg (@ldt, ldt'dst, ldev * size'of'ldt'entry,         <<06730>>09095000
              size'of'ldt'entry);                              <<06730>>09100000
if ldt'spool'state <> ldt'not'spooled then                     <<06730>>09105000
   if ldt'spool'state = ldt'output'spooled                     <<06730>>09110000
      then spooleddev.(14:1) := true                           <<06730>>09115000
      else spooleddev.(13:1) := true;                          <<06730>>09120000
if ldt'spool'queues = ldt'qopen then spooleddev.(15:1) := true;<<06730>>09125000
end;   << of check'1'dev.                                   >> <<06730>>09130000
                                                               <<06730>>09135000
<<             procedure body starts here.                  >> <<06730>>09140000
                                                               <<06730>>09145000
pcbpt := curprc;      << required by pcb $include file.     >> <<06730>>09150000
spooleddev := 0;                                               <<06730>>09155000
if device = 0 then return;   << that's a no-no.             >> <<06730>>09160000
if spcbxdsdst <> stack then                                    <<06730>>09165000
   dst'at'entry := exchangedb (stack);                         <<06730>>09170000
save'ldt'sir := getsir (ldt'sir);                              <<06730>>09175000
if device > 0 then                                             <<06730>>09180000
   check'1'dev (device)                                        <<06730>>09185000
else                                                           <<06730>>09190000
   begin   << device class request, get local copy of entry >> <<06730>>09195000
   save'dct'sir := getsir (dct'sir);                           <<06730>>09200000
   entry'length := get'device'class (-device, entry'address);  <<06730>>09205000
   if entry'length <> -1 then                                  <<06730>>09210000
      begin   << valid class index.                         >> <<06730>>09215000
      push (s);                                                <<06730>>09220000
      @dct := tos + 1;   << build dct entry on stack.       >> <<06730>>09225000
      tos := entry'length;                                     <<06730>>09230000
      assemble (adds 0);                                       <<06730>>09235000
      movefromdseg (@dct, dct'dst, entry'address,              <<06730>>09240000
                    entry'length);                             <<06730>>09245000
      if dct'spool'queues = dct'open                           <<06730>>09250000
         then spooleddev.(15:1) := true                        <<06730>>09255000
         else                                                  <<06730>>09260000
            begin   << class queues shut, test ldevs in cls >> <<06730>>09265000
            devices'in'class := dct'num'devices;               <<06730>>09270000
            while (devices'in'class := devices'in'class - 1)   <<06730>>09275000
                  >= 0 do                                      <<06730>>09280000
                  check'1'dev (dct(dct'first'ldev +            <<06730>>09285000
                        devices'in'class));                    <<06730>>09290000
            end;    << class queues shut.                      <<06730>>09295000
      end;          << valid class index.                   >> <<06730>>09300000
   relsir (dct'sir, save'dct'sir);                             <<06730>>09305000
   end;    << device class request.                         >> <<06730>>09310000
relsir (ldt'sir, save'ldt'sir);                                <<06730>>09315000
if dst'at'entry <> -1 then exchangedb (dst'at'entry);          <<06730>>09320000
end;   << of spooleddev.                                    >> <<06730>>09325000
$page "   ***   ATOB   ***"                                    <<06730>>09330000
$control segment = allocutil                                   <<06730>>09335000
                                                               <<06730>>09340000
integer procedure atob (number'string, number'of'digits);      <<04377>>09345000
   value number'of'digits;                                     <<04377>>09350000
   integer number'of'digits;                                   <<04377>>09355000
   byte array number'string;                                   <<04377>>09360000
   option internal, uncallable;                                <<04377>>09365000
                                                               <<04377>>09370000
begin comment --                                               <<04377>>09375000
  converts the first number'of'digits or  less  ascii  decimal <<04377>>09380000
digits  in number'string to binary.  number'string may be ter- <<04377>>09385000
minated by any non-numeric character.                          <<04377>>09390000
;                                                              <<04377>>09395000
integer                                                        <<04377>>09400000
   loop'counter,                                               <<04377>>09405000
   result,                                                     <<04377>>09410000
   this'digit;                                                 <<04377>>09415000
                                                               <<04377>>09420000
result := 0;                                                   <<04377>>09425000
for loop'counter := 0 step 1 until number'of'digits - 1 do     <<04377>>09430000
   begin                                                       <<04377>>09435000
   this'digit := number'string (loop'counter) - "0";           <<04377>>09440000
   if (0 <= this'digit <= 9)                                   <<04377>>09445000
      then result := result*10 + this'digit                    <<04377>>09450000
      else loop'counter := number'of'digits;   << stop loop >> <<04377>>09455000
   end;                                                        <<04377>>09460000
atob := result;                                                <<04377>>09465000
end;              << of atob.                               >> <<04377>>09470000
$page "   ***   GETCLASS   ***"                                <<06730>>09475000
$control segment = allocutil                                   <<06730>>09480000
                                                               <<06730>>09485000
logical procedure getclass (return'buf, everything, cladr,     <<06730>>09490000
                            clindex, clname);                  <<06730>>09495000
   value   cladr, clindex, everything;                         <<06730>>09500000
   integer cladr, clindex;                                     <<06730>>09505000
   logical everything;                                         <<06730>>09510000
   integer array clname, return'buf;                           <<06730>>09515000
   option privileged, uncallable, variable;                    <<06730>>09520000
                                                               <<06730>>09525000
begin comment --                                               <<06730>>09530000
  getclass returns information from a device class table (dct) <<06730>>09535000
entry.  callers can specify the desired entry by one (and only <<06730>>09540000
one) of three methods:                                         <<06730>>09545000
1.  if clname is used, it contains the ascii name of  the  de- <<06730>>09550000
    sired  class.  getclass then tries to match this name with <<06730>>09555000
    a class name in the dct.                                   <<06730>>09560000
2.  if clindex is used, it represents the nth entry  (starting <<06730>>09565000
    with 1) in the dct, whatever its name.                     <<06730>>09570000
3.  if cladr is used, it is the  segment-relative  address  of <<06730>>09575000
    the  desired  entry.  this option is normally used for the <<06730>>09580000
    second call to getclass.                                   <<06730>>09585000
  two calls are needed because dct entries have  variable  and <<06730>>09590000
unlimited  lengths,  although the length of a particular entry <<06730>>09595000
can be calculated from information stored in the entry.  call- <<06730>>09600000
ing routines retrieve this length information (along with  the <<06730>>09605000
segment-relative address of the entry) on the first call using <<06730>>09610000
clname or clindex.  they can then configure  enough  space  to <<06730>>09615000
hold  the rest of the entry and call us again, using the cladr <<06730>>09620000
returned in return'buf from the first call (thus allowing  di- <<06730>>09625000
rect access of the entry the second time).                     <<06730>>09630000
  if everything is false, getclass returns  only  five  words, <<06730>>09635000
including the entry length information. this is the usual sit- <<06730>>09640000
uation for the first call.  for the second call, everything is <<06730>>09645000
true.  the same five words are returned, along with the entire <<06730>>09650000
list of logical devices in the class.                          <<06730>>09655000
  with all that said, callers are warned that getclass returns <<06730>>09660000
information in substantially the same form that it  exists  in <<06730>>09665000
the dct. changes to that table will be reflected in the length <<06730>>09670000
requirements and contents of return'buf. this is a severe flaw <<06730>>09675000
in the design, which should justify a change in the  function- <<06730>>09680000
ality  of  the  routine.  unfortunately,  the routine has many <<06730>>09685000
callers, some of which are the responsibility not only of oth- <<06730>>09690000
er labs but of other divisions as well.  so we in mpe must  be <<06730>>09695000
content with the above warning.                                <<06730>>09700000
                                                               <<06730>>09705000
  inputs:   everything - false, return five words  in  return' <<06730>>09710000
                         buf as shown below.                   <<06730>>09715000
                       - true, return same five words plus the <<06730>>09720000
                         rest of the ldev list for the  class. <<06730>>09725000
$page                                                          <<06730>>09730000
        +-->clname     - the ascii name of a device  class,  8 <<06730>>09735000
        |                bytes,  left-justified  with trailing <<06730>>09740000
        |                blanks.                               <<06730>>09745000
        |                                                      <<06730>>09750000
one and<    clindex    - the nth entry (1 is first),  whatever <<06730>>09755000
only one|                its name, in the device class table.  <<06730>>09760000
        |                                                      <<06730>>09765000
        +-->cladr      - the segment-relative address  of  the <<06730>>09770000
                         desired  dct  entry.  note:  cladr is <<06730>>09775000
                         only checked to be  within  the  dct. <<06730>>09780000
                         the caller is responsible for setting <<06730>>09785000
                         it to the first word of a dct entry.  <<06730>>09790000
                                                               <<06730>>09795000
  returns:  result     - true, found specified entry, info  in <<06730>>09800000
                         return'buf is valid.                  <<06730>>09805000
                         false,  could  not  match  clname  or <<06730>>09810000
                         clindex.                              <<06730>>09815000
                                                               <<06730>>09820000
            return'buf - 0:  segment-relative address of entry <<06730>>09825000
                             (for cladr next time).            <<06730>>09830000
                         1:  dct index of entry (0 if getclass <<06730>>09835000
                             called with cladr).               <<06730>>09840000
                         2:  word 4 (5th word) of  dct  entry. <<06730>>09845000
                             contains  cyclical pointer, class <<06730>>09850000
                             access type, sq bit.              <<06730>>09855000
                         3:  number of ldev's in class.        <<06730>>09860000
                         4:  first ldev in class.              <<06730>>09865000
                         >4  returned only if everything true. <<06730>>09870000
                             remaining ldev's in class.        <<06730>>09875000
                                                               <<06730>>09880000
  system failures:       360:  cladr not within dct limits.    <<06730>>09885000
                         365:  more than one of clname,  cladr <<06730>>09890000
                               or clindex was specified.       <<06730>>09895000
                         367:  return'buf  or  everything  was <<06730>>09900000
                               not specified.                  <<06730>>09905000
                                                               <<06730>>09910000
  special considerations:  dct sir must be acquired externally.<<07330>>09915000
                             db must be at the stack, same  at <<06730>>09920000
                           exit.                               <<06730>>09925000
;                                                              <<06730>>09930000
equate                                                         <<06730>>09935000
   class'name  = 1,  << access method (from parm'mask bits) >> <<06730>>09940000
   dct'address = 4,                                            <<06730>>09945000
   dct'index   = 2;                                            <<06730>>09950000
                                                               <<06730>>09955000
integer                                                        <<06730>>09960000
   extra'words'to'move,   << if everything true, number  of >> <<06730>>09965000
                          << words  to  return  in addition >> <<06730>>09970000
                          << to first four.                 >> <<06730>>09975000
   method,                                                     <<06730>>09980000
   parm'mask = q - 4,                                          <<06730>>09985000
   this'entry;                                                 <<06730>>09990000
                                                               <<06730>>09995000
logical pointer                                                <<06730>>10000000
   dct,                                                        <<06730>>10005000
   dct'head := 0;   << required by dct $include file.       >> <<06730>>10010000
                                                               <<06730>>10015000
logical array                                                  <<06730>>10020000
   qclname(0:3) = q;   << must be direct to accs in spl-stk >> <<06730>>10025000
                                                               <<06730>>10030000
subroutine def'movefromdseg;                                   <<06730>>10035000
                                                               <<06730>>10040000
getclass := false;                                             <<06730>>10045000
if parm'mask < 25 then                                         <<06730>>10050000
   suddendeath (sd367); << return'buf or everything missing >> <<07050>>10055000
method := parm'mask.(13:3);                                    <<06730>>10060000
if method = class'name then move qclname := clname, (4);       <<06730>>10065000
exchangedb (dct'dst);                                          <<06730>>10070000
if method = dct'address then                                   <<06730>>10075000
   begin   << probably 2nd call w/ everything true.         >> <<06730>>10080000
   if cladr < integer (dcth'dct'base) or                       <<06730>>10085000
      cladr >= integer (dcth'tdt'base)                         <<06730>>10090000
      then suddendeath (sd360);   << cladr not within dct.  >> <<07050>>10095000
   @dct := cladr;                                              <<06730>>10100000
   end                                                         <<06730>>10105000
else                                                           <<06730>>10110000
   begin   << access by class name or dct index.            >> <<06730>>10115000
   @dct := dcth'dct'base;                                      <<06730>>10120000
   this'entry := 0;                                            <<06730>>10125000
   while (this'entry := this'entry + 1) <=                     <<06730>>10130000
         integer (dcth'num'dct'entries) do                     <<06730>>10135000
      begin   << search until name or index matches.        >> <<06730>>10140000
      if method = class'name then                              <<06730>>10145000
                                                               <<06730>>10150000
<< caution -- the following comparison, though  cumbersome, >> <<06730>>10155000
<< is the only way to avoid illegal address references while>> <<06730>>10160000
<< in split-stack mode.                                     >> <<06730>>10165000
                                                               <<06730>>10170000
         if qclname = dct and qclname(1) = dct(1) and          <<06730>>10175000
            qclname(2) = dct(2) and qclname(3) = dct(3) then   <<06730>>10180000
            go to found'it                                     <<06730>>10185000
         else   << no match, try next entry.                >> <<06730>>10190000
      else if method = dct'index then                          <<06730>>10195000
         if this'entry = clindex then                          <<06730>>10200000
            go to found'it                                     <<06730>>10205000
         else   << no match, try next entry.                >> <<06730>>10210000
      else suddendeath (sd365);   << >1 access specified.   >> <<07050>>10215000
      @dct := @dct + integer (dct'next'entry);                 <<06730>>10220000
      end;      << of while loop.                           >> <<06730>>10225000
   exchangedb (stack);   << no name or index match.         >> <<06730>>10230000
   return;                                                     <<06730>>10235000
   end;    << access by class name or dct index.            >> <<06730>>10240000
                                                               <<06730>>10245000
found'it:  << dct now at desired entry.                     >> <<06730>>10250000
                                                               <<06730>>10255000
extra'words'to'move := dct'words'in'entry - dct'first'ldev - 1;<<06730>>10260000
exchangedb (stack);                                            <<06730>>10265000
return'buf := @dct;   << note:  dct segment relative.       >> <<06730>>10270000
if method = dct'address                                        <<06730>>10275000
   then return'buf(1) := 0                                     <<06730>>10280000
   else return'buf(1) := this'entry;   << dct index.        >> <<06730>>10285000
movefromdseg (@return'buf(2), dct'dst, @dct(4), 3);            <<06730>>10290000
if everything and extra'words'to'move > 0 then                 <<g7907>>10295000
   movefromdseg (@return'buf(5), dct'dst, @dct +               <<06730>>10300000
      dct'first'ldev + 1, extra'words'to'move);                <<06730>>10305000
getclass := true;                                              <<06730>>10310000
end;           << of getclass                               >> <<06730>>10315000
$page "   ***   PUTDEV and GETDEV   ***"                       <<06730>>10320000
$control segment = allocutil                                   <<06730>>10325000
                                                               <<06730>>10330000
logical procedure putdev  << & getdev >>  (ldev, table, buf);           10335000
   value ldev, table;                                                   10340000
   integer ldev;      << log. device no. >>                             10345000
   integer table;     << dst # of lpdt (13) or ldt (14) >>              10350000
   integer array buf; << table entry destination or source >>           10355000
   option privileged, uncallable;                                       10360000
                                                                        10365000
begin comment --                                               <<06730>>10370000
  putdev moves entry image in buf into entry ldev of table ta- <<06730>>10375000
ble, where table is either the ldt or lpdt.  the image is  not <<06730>>10380000
checked for correctness, only that an entry for ldev exists in <<06730>>10385000
table (that is, ldev does not exceed the maximum for  the  ta- <<06730>>10390000
ble).                                                          <<06730>>10395000
  getdev returns entry ldev of table table (ldt  or  lpdt)  in <<06730>>10400000
buf.                                                           <<06730>>10405000
                                                               <<06730>>10410000
  the procedure result is returned as follows:                 <<06730>>10415000
      true  - all o.k., buf returned if getdev.                <<06730>>10420000
      false - ldev < 0 or > max configured -or- (getdev  only) <<06730>>10425000
              ldev  is unassigned (i.e., table entry is not in <<06730>>10430000
              use, should never occur).                        <<06730>>10435000
                                                               <<06730>>10440000
  special considerations:                                      <<06730>>10445000
    db must be at the stack at entry, unchanged at exit.       <<06730>>10450000
    the caller must have acquired the appropriate sir.         <<06730>>10455000
;                                                              <<06730>>10460000
entry                                                          <<06730>>10465000
   getdev;                                                     <<06730>>10470000
                                                               <<06730>>10475000
logical                                                        <<06730>>10480000
   get := false;         << getdev/putdev flag.             >> <<06730>>10485000
                                                               <<06730>>10490000
integer                                                        <<06730>>10495000
   max'entry,                                                  <<06730>>10500000
   table'size;                                                 <<06730>>10505000
                                                               <<06730>>10510000
logical array                                                  <<06730>>10515000
   ldt (0:size'of'ldt'entry - 1);   << for header entry.    >> <<06730>>10520000
                                                               <<06730>>10525000
subroutine def'movefromdseg;                                   <<06730>>10530000
                                                               <<06730>>10535000
subroutine def'movetodseg;                                     <<06730>>10540000
                                                               <<06730>>10545000
<< ****************** procedure starts here. ************** >> <<06730>>10550000
                                                               <<06730>>10555000
if false then                                                  <<06730>>10560000
                                                               <<06730>>10565000
getdev:                                                        <<06730>>10570000
                                                               <<06730>>10575000
   get := true;                                                <<06730>>10580000
                                                               <<06730>>10585000
putdev := false;                                               <<06730>>10590000
if ldev > 0 then                                               <<06730>>10595000
   begin   << passed the first test.                        >> <<06730>>10600000
   if table = lpdt'dst                                         <<06730>>10605000
      then                                                     <<06730>>10610000
         begin                                                 <<06730>>10615000
         table'size := lpdt'entry'size;                        <<06730>>10620000
         max'entry  := lpdt'max'entries;                       <<06730>>10625000
         end                                                   <<06730>>10630000
      else                                                     <<06730>>10635000
         begin   << not lpdt, must be ldt.                  >> <<06730>>10640000
         movefromdseg (@ldt, ldt'dst, 0 << base of segment >>, <<06730>>10645000
                       size'of'ldt'entry);                     <<06730>>10650000
         table'size := ldt'entry'size;                         <<06730>>10655000
         max'entry  := ldt'num'entries;                        <<06730>>10660000
         end;                                                  <<06730>>10665000
   if max'entry >= ldev then   << another test passed.      >> <<06730>>10670000
      if get then                                              <<06730>>10675000
         begin   << getdev, return an entry.                >> <<06730>>10680000
                                                               <<06730>>10685000
  comment -- the strange test below, which determines  whether <<06730>>10690000
getdev  returns  true  or false, has been preserved unchanged. <<06730>>10695000
its origins have been lost.  anyone knowing what these  checks <<06730>>10700000
are for and why they are made is welcome to clear the air.     <<06730>>10705000
;                                                              <<06730>>10710000
         movefromdseg (@buf, table, ldev * table'size,         <<06730>>10715000
                       table'size);                            <<06730>>10720000
         if table = lpdt'dst then                              <<06730>>10725000
            putdev := (buf <> 0) lor (buf(2) <> 0)             <<06730>>10730000
         else putdev := (buf(2) <> 0);                         <<06730>>10735000
         end     << getdev, return an entry.                >> <<06730>>10740000
      else                                                     <<06730>>10745000
         begin   << putdev, move entry to table w/o check.  >> <<06730>>10750000
         if table = lpdt'dst then disable;                     <<s7474>>10755000
         movetodseg (table, ldev * table'size, @buf,           <<06730>>10760000
                     table'size);                              <<06730>>10765000
         if table = lpdt'dst then enable;                      <<s7474>>10770000
         putdev := true;                                       <<06730>>10775000
         end;    << putdev, move entry to table w/o check.  >> <<06730>>10780000
   end;    << passed the first test.                        >> <<06730>>10785000
end;       << of putdev/getdev                              >> <<06730>>10790000
$page "   ***   GETDEVINFO   ***"                              <<06730>>10795000
$control segment = allocutil                                   <<06730>>10800000
                                                               <<06730>>10805000
integer procedure getdevinfo (device, devinfo);                <<06730>>10810000
   byte array device;                                          <<06730>>10815000
   integer array devinfo;                                      <<06730>>10820000
   option privileged, uncallable;                              <<06730>>10825000
                                                               <<06730>>10830000
begin comment --                                               <<06730>>10835000
  getdevinfo returns information about device in devinfo.  the <<06730>>10840000
information returned depends on  whether  device  specifies  a <<06730>>10845000
class,  a  ds node or a specific ldev, and is described in de- <<06730>>10850000
tail below.  it includes an ldt entry when a class or ldev  is <<06730>>10855000
specified, and an lpdt image as well for the latter.           <<06730>>10860000
  because table entries are  returned  directly,  callers  are <<06730>>10865000
warned  that changes to a table structure will be reflected in <<06730>>10870000
the length requirements and contents of devinfo. this is a se- <<06730>>10875000
vere flaw in the design, which should justify a change in  the <<06730>>10880000
functionality  of the routine.  unfortunately, the routine has <<06730>>10885000
many callers, some of which are the responsibility not only of <<06730>>10890000
other labs but of other divisions as well.  so we in mpe  must <<06730>>10895000
be content with the above warning.                             <<06730>>10900000
                                                               <<06730>>10905000
  input:                                                       <<06730>>10910000
    device - an ascii string representing a device class, a ds <<06730>>10915000
             node, or a logical device. note that ldev 6 (say) <<06730>>10920000
             must be specified as "6" (ascii), not 6  (numeri- <<06730>>10925000
             cal  value).  if  a device class is specified, it <<06730>>10930000
             must be eight  bytes,  left-justified  and  blank <<06730>>10935000
             filled.  a  ds  node may be shorter, but must end <<06730>>10940000
             with "#" to be handled properly.                  <<06730>>10945000
                                                               <<06730>>10950000
  returns:                                                     <<06730>>10955000
    getdevinfo - -1 - specified ldev is a virtual device.      <<06730>>10960000
                  0 - no errors.                               <<06730>>10965000
                  1 - invalid device class  specification (> 8 <<06730>>10970000
                      characters).                             <<07330>>10975000
                  2 - unknown device class (couldn't be  found <<06730>>10980000
                      in the device class table (dct).         <<06730>>10985000
                  3 - unknown or unconfigured ldev.            <<06730>>10990000
    devinfo:                                                   <<06730>>10995000
      if device is a class name:                               <<06730>>11000000
         devinfo(0)          - dct index of class (< 0).       <<06730>>11005000
                (1)          - device type as  it  appears  in <<06730>>11010000
                               the dct.                        <<06730>>11015000
                (2)          - word 4 of the dct  entry  (con- <<06730>>11020000
                               tains  cyclical  ptr, class ac- <<06730>>11025000
                               cess type, sq bit).             <<06730>>11030000
                (3)          - not used (contents random).     <<06730>>11035000
                (4) - (10)   - ldt entry of 1st ldev in class. <<06730>>11040000
                (11) - (12)  - not used (contents random).     <<06730>>11045000
                                                               <<06730>>11050000
      if device is a ds node:                                  <<06730>>11055000
         devinfo(0), (2)-(12)- 0                               <<06730>>11060000
                (1)          - 41 (ds device type).            <<06730>>11065000
$page                                                          <<06730>>11070000
      if device is a specific ldev:                            <<06730>>11075000
         devinfo(0)          - numerical value of ldev (> 0).  <<06730>>11080000
                (1)          - device type from logical device <<06730>>11085000
                               table (ldt), except that serial <<06730>>11090000
                               disc always returns 31, foreign <<06730>>11095000
                               disc always returns 7.          <<06730>>11100000
                (2)-(5)      - lpdt entry of ldev.             <<06730>>11105000
                (6)-(12)     - ldt entry of ldev.              <<06730>>11110000
                                                               <<06730>>11115000
  special considerations:  db must be at the stack  at  entry, <<06730>>11120000
                           same at return.                     <<06730>>11125000
;                                                              <<06730>>11130000
equate                                                         <<06730>>11135000
   blank             = %40,                                    <<06730>>11140000
   cr                = %15,                                    <<06730>>11145000
   ds'device'type    =  41,                                    <<06730>>11150000
   invalid'dev'class =   1,                                    <<06730>>11155000
   no'error          =   0,                                    <<06730>>11160000
   unknown'dev'class =   2,                                    <<06730>>11165000
   unknown'ldev      =   3,                                    <<06730>>11170000
   virtual'device    =  -1;                                    <<06730>>11175000
                                                               <<06730>>11180000
integer                                                        <<06730>>11185000
   ldt'index     := 0,   << needed by ldt defines.          >> <<06730>>11190000
   ldev              ,                                         <<06730>>11195000
   lpdt'index,           << needed by lpdt defines.         >> <<06730>>11200000
   name'length,                                                <<06730>>11205000
   save'ldt'sir;                                               <<06730>>11210000
                                                               <<06730>>11215000
logical array                                                  <<06730>>11220000
   dev'class'i(0:4),       << allow extra word for cr.      >> <<06730>>11225000
   getclass'retn(0:4),     << getclass returns info here.   >> <<06730>>11230000
   ldt(0:size'of'ldt'entry-1);   << local ldt entry.        >> <<06730>>11235000
                                                               <<06730>>11240000
byte array                                                     <<06730>>11245000
   dev'class(*)     = dev'class'i;                             <<06730>>11250000
$page                                                          <<06730>>11255000
getdevinfo := no'error;                                        <<06730>>11260000
dev'class := blank;                                            <<06730>>11265000
move dev'class(1) := dev'class, (9);                           <<06730>>11270000
if (ldev := atob (device, 3)) = 0 then                         <<06730>>11275000
   begin   << device class, part 1.                         >> <<06730>>11280000
   move dev'class := device while ans, 1;                      <<06730>>11285000
   if (name'length := tos - @dev'class) > 8 then               <<06730>>11290000
      begin                                                    <<06730>>11295000
      getdevinfo := invalid'dev'class;                         <<06730>>11300000
      return;                                                  <<06730>>11305000
      end;                                                     <<06730>>11310000
   end;    << device class, part 1.                         >> <<06730>>11315000
save'ldt'sir := getsir (ldt'sir);                              <<06730>>11320000
if ldev = 0 then                                               <<06730>>11325000
   begin   << device class, part 2.                         >> <<06730>>11330000
   if getclass (getclass'retn, false, , , dev'class'i) then    <<06730>>11335000
      begin   << name matched in dct, get first ldev.       >> <<06730>>11340000
      ldev := getclass'retn(4);                                <<06730>>11345000
      getdev (ldev, ldt'dst, ldt);   << get its ldt entry.  >> <<06730>>11350000
      relsir (ldt'sir, save'ldt'sir);                          <<06730>>11355000
      devinfo    := -getclass'retn(1); << dct index.        >> <<06730>>11360000
      devinfo(2) := getclass'retn(2);  << word 4, dct entry >> <<06730>>11365000
      devinfo(1) := devinfo(2).(10:6); << class access type >> <<06730>>11370000
      move devinfo(4) := ldt, (size'of'ldt'entry);             <<06730>>11375000
      end     << name matched in dct...                     >> <<06730>>11380000
   else                                                        <<06730>>11385000
      begin   << name not found in dct, check for ds node.  >> <<06730>>11390000
      relsir (ldt'sir, save'ldt'sir);                          <<06730>>11395000
      if device(name'length) <> "#" then                       <<06731>>11400000
         getdevinfo := unknown'dev'class                       <<06730>>11405000
      else                                                     <<06730>>11410000
         begin   << found "#", assume ds node.              >> <<06730>>11415000
         devinfo := 0;                                         <<06730>>11420000
         move devinfo(2) := devinfo, (11);                     <<06730>>11425000
         devinfo(1) := ds'device'type;                         <<06730>>11430000
         end;    << found "#"...                            >> <<06730>>11435000
      end        << name not found in dct...                >> <<06730>>11440000
   end           << device class, part 2.                   >> <<06730>>11445000
else                                                           <<06730>>11450000
   begin         << specific ldev.                          >> <<06730>>11455000
   if not getdev (ldev, ldt'dst, ldt) then                     <<06730>>11460000
      begin                                                    <<06730>>11465000
      relsir (ldt'sir, save'ldt'sir);                          <<06730>>11470000
      getdevinfo := unknown'ldev;                              <<06730>>11475000
      return;                                                  <<06730>>11480000
      end;                                                     <<06730>>11485000
   relsir (ldt'sir, save'ldt'sir);                             <<06730>>11490000
   lpdt'index := (devinfo := ldev) * integer (lpdt'entry'size);<<06730>>11495000
   devinfo(1) := ldt'device'type;   << may change in a bit. >> <<06730>>11500000
   move devinfo(2+lpdt'entry'size) := ldt, (size'of'ldt'entry);<<06730>>11505000
   disable;                                                    <<06730>>11510000
   getdev (ldev, lpdt'dst, devinfo(2));                        <<06730>>11515000
                                                               <<06730>>11520000
<< note:  a pv disc cannot be  opened  without  a  pv  pack >> <<06730>>11525000
<< mounted on the spindle. non-system volumes without discs >> <<06730>>11530000
<< spinning are assumed to be serial discs.                 >> <<06730>>11535000
                                                               <<06730>>11540000
   if ldt'access'type = ldt'direct'access  <<from local copy>> <<06730>>11545000
      and lpdt'not'pv'or'sys then                              <<06730>>11550000
          if lpdt'serial'or'foreign = lpdt'serial              <<06730>>11555000
             then devinfo(1) := ldt'serial'disc                <<06730>>11560000
             else devinfo(1) := ldt'foreign'disc;              <<06730>>11565000
   if lpdt'virtual'device then getdevinfo := virtual'device;   <<06730>>11570000
   enable;                                                     <<06730>>11575000
   end;   << specific ldev.                                 >> <<06730>>11580000
end;      << of getdevinfo.                                 >> <<06730>>11585000
$page "   ***   DISKDEALLOC   ***"                             <<06730>>11590000
$control segment = allocutil                                   <<06730>>11595000
                                                               <<06730>>11600000
integer procedure diskdealloc(extsize,lastextsize,numexts,map);  <<mv>> 11605000
    value numexts,extsize,lastextsize;                           <<mv>> 11610000
   integer numexts;                                                     11615000
   logical extsize, lastextsize;                                        11620000
   double array map;                                             <<mv>> 11625000
   option privileged,uncallable;                                 <<mv>> 11630000
   begin                                                         <<mv>> 11635000
   <<deallocates disk device and space                >>         <<mv>> 11640000
   <<if numexts>0 then the disk space will be returned>>         <<mv>> 11645000
   <<otherwise the devices will just be deallocated   >>         <<mv>> 11650000
   <<   note that the usecount is now bumped for each >>         <<mv>> 11655000
   <<   extent.                                                  <<mv>> 11660000
   <<db must be set to stack                          >>         <<mv>> 11665000
   <<input............................................>>         <<mv>> 11670000
   <<extsize          size of each extent.                 >>           11675000
   <<lastextsize      size of last extent. (all others same)>>          11680000
   <<numexts         the number of extents in the map.   >>      <<mv>> 11685000
   <<   negative => simply deallocate disc devices.    >>               11690000
   <<   \numexts\.(8:1) => spooling call               >>               11695000
   <<map     an array of disk addresses.              >>         <<mv>> 11700000
   <<        format is : one bye of ldev              >>         <<mv>> 11705000
   <<                    three bytes of diskaddr.     >>         <<mv>> 11710000
   <<returns..........................................>>         <<mv>> 11715000
   <<       0               ok                        >>         <<mv>> 11720000
                                                               <<03507>>11725000
   <<space of all extents possible is returned.       >>        <<mv>>  11730000
   byte array bmap(*)=map;                                      <<mv>>  11735000
   logical ldev,count;                                           <<mv>> 11740000
   integer index, ldt'index := 0;                              <<06730>>11745000
   logical array ldt(0:size'of'ldt'entry-1);                   <<06730>>11750000
   logical save'ldt'sir, retspace;                             <<06730>>11755000
   double diskaddr;                                              <<mv>> 11760000
   byte bdiskaddr=diskaddr;                                      <<mv>> 11765000
   logical down:=false;  <<did i put the dev down?>>                    11770000
   logical forspooling := false;    <<spooling call?>>                  11775000
   define type'of'error = [8/7,8/4]#; <<id=7,4-unexpected er>> <<04811>>11780000
   define msg'unexpected'error = %44#;                         <<04811>>11785000
   define                                                      <<07050>>11790000
      pushnumss = tos := syscurspksec1;                        <<07050>>11795000
                  tos := syscurspksec2#,                       <<07050>>11800000
                                                               <<07050>>11805000
      popnumss  = syscurspksec2 := tos;                        <<07050>>11810000
                  syscurspksec1 := tos#;                       <<07050>>11815000
                                                               <<04811>>11820000
subroutine def'movefromdseg;                                   <<06730>>11825000
                                                               <<06730>>11830000
subroutine def'movetodseg;                                     <<06730>>11835000
                                                               <<06730>>11840000
   subroutine decrusecount;                                      <<mv>> 11845000
      begin  <<decrement usecount and call deallocate>>          <<mv>> 11850000
             <<if it goes to zero.                   >>          <<mv>> 11855000
      save'ldt'sir := getsir (ldt'sir);                        <<06730>>11860000
      movefromdseg (@ldt, ldt'dst, ldev * size'of'ldt'entry,   <<06730>>11865000
                    size'of'ldt'entry);                        <<06730>>11870000
      if ldt'file'use'cnt < count then                         <<06730>>11875000
         begin                                                 <<04811>>11880000
         <<it is something wrong with ldt usage count which>>  <<04811>>11885000
         <<represents number of allocated extents of open  >>  <<04811>>11890000
         <<files. we are going to disable allocation and   >>  <<04811>>11895000
         <<deallocation disc space on such device. in case >>  <<04811>>11900000
         <<of private volume switching the drive (off-line/>>  <<04811>>11905000
         <<on-line) will enable disc space allocation.     >>  <<04811>>11910000
         process'dfs'error(ldev,msg'unexpected'error,          <<04811>>11915000
                           type'of'error);                     <<04811>>11920000
         soft'death (420);                                     <<04811>>11925000
         end                                                   <<04811>>11930000
      else                                                     <<04811>>11935000
      begin  <<o.k.>>                                          <<04811>>11940000
      ldt'file'use'cnt := ldt'file'use'cnt - count;            <<06730>>11945000
      if ldt'file'use'cnt = 0 and ldt'down'pending then        <<06730>>11950000
         begin<<down pending so down it>>                               11955000
         ldt'down'pending := false;   << no longer pending. >> <<06730>>11960000
         ldt'avail'to'sys := false;   << it's down.         >> <<06730>>11965000
         down:=true;                                                    11970000
                                                               <<03507>>11975000
         << deallocate and delete disc free space data >>      <<03507>>11980000
         << segment, ignore errors.                    >>      <<03507>>11985000
                                                               <<03507>>11990000
         deallocate'dfs'data'seg (ldev);                       <<03507>>11995000
                                                               <<03507>>12000000
         delete'dfs'data'seg (ldev);                           <<03507>>12005000
                                                               <<03507>>12010000
         end;   << down pending, so down it.                >> <<06730>>12015000
      movetodseg (ldt'dst, ldev * size'of'ldt'entry, @ldt,     <<06730>>12020000
                  size'of'ldt'entry);                          <<06730>>12025000
      end;                                                     <<04811>>12030000
      relsir (ldt'sir, save'ldt'sir);                          <<06730>>12035000
      if down then begin                                                12040000
                   genmsg(1,250,%10000,ldev,,,,,0);            <<0u.eb>>12045000
                   down:=false;                                         12050000
                   end;                                                 12055000
      end; <<decrusecount>>                                      <<mv>> 12060000
                                                                        12065000
                                                                        12070000
   retspace:=numexts>0;                                          <<mv>> 12075000
   numexts:=\numexts\;                                           <<mv>> 12080000
   if logical (numexts.(8:1)) then                                      12085000
      begin    <<spooling call: set true extsize and flag>>             12090000
      extsize := sysspextntsec;                                <<07050>>12095000
      forspooling := true;                                              12100000
      numexts.(8:1) := 0;                                               12105000
      end;                                                              12110000
   if lastextsize = 0 then lastextsize := extsize;                      12115000
   count:=0;                                                     <<mv>> 12120000
   ldev:=bmap(0);                                                <<mv>> 12125000
   index:=0;                                                     <<mv>> 12130000
   while index<numexts do                                        <<mv>> 12135000
   begin                                                         <<mv>> 12140000
   if bmap(index*4)<>0 then                                      <<mv>> 12145000
      begin  <<a non zero ldev in map>>                          <<mv>> 12150000
      if ldev=logical(bmap(x)) then                              <<mv>> 12155000
         count:=count+1 <<number of times this ldev>>            <<mv>> 12160000
      else                                                       <<mv>> 12165000
         begin <<new ldev; so bump usecounter by count>>         <<mv>> 12170000
         decrusecount;                                           <<mv>> 12175000
         ldev:=bmap(index*4);                                    <<mv>> 12180000
         count:=1;<<new ldev>>                                   <<mv>> 12185000
         end;                                                    <<mv>> 12190000
      if retspace then                                           <<mv>> 12195000
         begin                                                   <<mv>> 12200000
         diskaddr:=map(index);                                   <<mv>> 12205000
         bdiskaddr:=0;                                           <<mv>> 12210000
         return'disc'space (ldev, diskaddr,                    <<03507>>12215000
                            (if index < numexts-1 then         <<03507>>12220000
                            double (extsize) else              <<03507>>12225000
                            double (lastextsize)));            <<03507>>12230000
                                                               <<03507>>12235000
         << the return of disc space can no longer fail >>     <<03507>>12240000
                                                               <<03507>>12245000
            begin    << all okay >>                                     12250000
            if forspooling then                                         12255000
               begin    <<spooling call: reduce count>>                 12260000
               pdisable;                                       <<06730>>12265000
               pushnumss;    <<subtract from system count>>             12270000
               tos := tos - (if index >= numexts-1 then                 12275000
                  double(lastextsize) else double(extsize));            12280000
               popnumss;                                                12285000
               penable;                                        <<06730>>12290000
               end;                                                     12295000
            end;                                                        12300000
         end;                                                    <<mv>> 12305000
      end;                                                       <<mv>> 12310000
      index:=index+1;                                            <<mv>> 12315000
      end;                                                       <<mv>> 12320000
    if count <> 0 then decrusecount;                             <<mv>> 12325000
    end;<<diskdealloc>>                                          <<mv>> 12330000
$page "   ***   DISKALLOC   ***"                               <<06730>>12335000
$control segment = allocutil                                   <<06730>>12340000
                                                               <<06730>>12345000
integer procedure diskalloc(indx,numext,spacedata,pvinfo);     <<rh.pv>>12350000
    value indx,numext,pvinfo;                                  <<rh.pv>>12355000
                                                            <<mv>>      12360000
    double array spacedata;                                             12365000
    integer indx,numext;                                                12370000
    logical pvinfo;                                            <<rh.pv>>12375000
    option privileged,uncallable;                                       12380000
         <<allocates disk device and disk-space. no device allocation >>12385000
         <<will be made if sufficient disk-space cannot be found.     >>12390000
         <<input:.....................................................>>12395000
         <<indx < 0      - index into device class table.             >>12400000
         <<     > 0      - logical device number.                     >>12405000
         <<     = 0       - spooling call.        >>                    12410000
         <<numext        - # extents required                         >>12415000
         <<   (see note below)   >>                                     12420000
         <<spacedata     - size of each extent (in sectors)           >>12425000
         <<                (a size may be zero in which case no space >>12430000
         <<                is allocated for that extent - zero sizes  >>12435000
         <<                do count as far as numext is concerned.)   >>12440000
         <<pvinfo.(0:1)  - use mvtab entry as dev class      >><<rh.pv>>12445000
         <<      .(4:4)  - mounted volume table index        >><<rh.pv>>12450000
         <<      .(8:8)  - volume mask of allowable volumes  >><<rh.pv>>12455000
         <<note..if numext < 0 then spacedata should  >>         <<mv>> 12460000
         <<contain the ldev-address map (ldev in first>>         <<mv>> 12465000
         <<byte of the double word) and the devices will>>       <<mv>> 12470000
         <<be allocated but no space will be assigned  >>        <<mv>> 12475000
         <<        db must be at stack.                 >>       <<mv>> 12480000
         <<output:....................................................>>12485000
                                                                        12490000
                                                                        12495000
                                                                        12500000
         <<spacedata     - disk address of each requested extent      >>12505000
         <<              note. upper byte contains ldev>>        <<mv>> 12510000
         <<diskalloc = 0 - ok, device and space allocated.            >>12515000
         <<           = 1 - space not available.      >>       <<03507>>12520000
         <<           = 2 - i/o or other error.       >>       <<03507>>12525000
         <<           = 3 - free space deallocation   >>       <<03507>>12530000
         <<                 disabled on ldev.         >>       <<03507>>12535000
         <<           = 4 - device unavailable.       >>       <<06730>>12540000
         <<          = 5 - invalid indx                               >>12545000
         <<in case of error no space or devices allocated.            >>12550000
   begin                                                                12555000
    double array                                               <<06730>>12560000
         addr(0:31)=q                                            <<mv>> 12565000
   ;array laddr(*)=addr                                          <<mv>> 12570000
   ;byte array baddr(*)=addr                                     <<mv>> 12575000
   ;byte array bspacedata(*)=spacedata                           <<mv>> 12580000
   ;array mvtabent(0:mvtabsize-1)=q                            <<rh.pv>>12585000
   ;integer                                                             12590000
         ldev   <<logical device number>>                               12595000
         ,i,j:=-1 <<current extent pointer>>,k,v:=-1           <<rh.pv>>12600000
         ,counter <<for usecount>>                               <<mv>> 12605000
        ,nldev   <<# of logical devices in device class>>               12610000
        ,dstx                                                           12615000
        ,cycp   <<cyclical pointer>>                                    12620000
        ,count   <<for stepping through dct>>                           12625000
        ,ldt'index := 0                                        <<06730>>12630000
        ,temp'dct   << holds local @dct while at dct'dst.   >> <<06730>>12635000
        ,temp'ldt   << holds local @ldt while at ldt'dst.   >> <<06730>>12640000
        ,entry'address    << of device class table entry.   >> <<06730>>12645000
        ,entry'length     << of device class table entry.   >> <<06730>>12650000
        ,hvol                                                  <<rh.pv>>12655000
        ,mvtabx                                                <<rh.pv>>12660000
   ;logical                                                             12665000
         save'dct'sir                                          <<06730>>12670000
        ,save'ldt'sir                                          <<06730>>12675000
        ,save'mvtab'sir                                        <<06730>>12680000
        ,mask    <<volume test mask>>                          <<rh.pv>>12685000
        ,vmask   <<allowable-volume mask>>                     <<rh.pv>>12690000
        ,error := false                                        <<06730>>12695000
        ,forspooling := false;                                 <<06730>>12700000
    logical array                                              <<06730>>12705000
       ldt(0:size'of'ldt'entry-1);                             <<06730>>12710000
                                                               <<06730>>12715000
    logical pointer                                            <<06730>>12720000
       dct,          << space for array is built on stack.  >> <<06730>>12725000
       dct'head := 0;   << required by dct $include file.   >> <<06730>>12730000
                                                               <<06730>>12735000
    define                                                     <<06730>>12740000
       lpdt'index = ldev * integer (lpdt'entry'size)#;         <<06730>>12745000
                                                               <<03507>>12750000
   << the following var remembers if we have tried to get >>   <<03507>>12755000
   << space on any device in the class and no space was   >>   <<03507>>12760000
   << available.  this is needed so that we return the    >>   <<03507>>12765000
   << disallocation disabled error only when all discs in >>   <<03507>>12770000
   << the class have had free space disabled.             >>   <<03507>>12775000
                                                               <<03507>>12780000
   logical out'of'space'on'any'dev := false;                   <<06730>>12785000
                                                               <<03507>>12790000
   integer return'value = diskalloc                            <<03507>>12795000
   ;define pvalloc = pvinfo <> 0#                              <<rh.pv>>12800000
   ;define pvclass = pvinfo.pvclassf#                          <<rh.pv>>12805000
   ;                                                                    12810000
   define                                                      <<07050>>12815000
      pushmaxss = tos := sysmxspsec1;                          <<07050>>12820000
                  tos := sysmxspsec2#,                         <<07050>>12825000
                                                               <<07050>>12830000
      pushnumss = tos := syscurspksec1;                        <<07050>>12835000
                  tos := syscurspksec2#,                       <<07050>>12840000
                                                               <<07050>>12845000
      popnumss  = syscurspksec2 := tos;                        <<07050>>12850000
                  syscurspksec1 := tos#;                       <<07050>>12855000
                                                               <<03507>>12860000
subroutine def'movefromdseg;                                   <<06730>>12865000
                                                               <<06730>>12870000
subroutine def'movetodseg;                                     <<06730>>12875000
                                                               <<03507>>12880000
subroutine getdspace;                                                   12885000
         <<try to get all requested extents on ldev                   >>12890000
         <<ldev must be correctly set                                 >>12895000
         <<i will be most significant result from "DISKSPACE"         >>12900000
         <<addresses will be put in addr(*)                           >>12905000
         <<also bumps usecount for each extent>>                 <<mv>> 12910000
         <<on exit j points to last allocated extent>>           <<mv>> 12915000
   begin                                                                12920000
   i := 0;   <<for case where numext=0>>                       <<06730>>12925000
   counter := 0;                                                 <<mv>> 12930000
   if numext >0 then                                             <<mv>> 12935000
      begin <<get space>>                                        <<mv>> 12940000
   while (j := j+1) < numext do if spacedata(j) > 0d then      <<06730>>12945000
      begin                                                             12950000
      i := get'disc'space (ldev, spacedata(j), addr(j));       <<03507>>12955000
      if i<>0 then                                               <<mv>> 12960000
         begin <<error or no room>>                              <<mv>> 12965000
                                                               <<03507>>12970000
          << remember if it was a no space error >>            <<03507>>12975000
                                                               <<03507>>12980000
          if i = 1 then                                        <<03507>>12985000
             out'of'space'on'any'dev := true;                  <<03507>>12990000
                                                               <<03507>>12995000
         goto upusecount;                                        <<mv>> 13000000
         end;                                                    <<mv>> 13005000
      baddr(4*j):=ldev;                                          <<mv>> 13010000
      counter := counter +1;                                            13015000
      end;                                                              13020000
 upusecount:         j:=j-1;                                     <<mv>> 13025000
      ldt'file'use'cnt := ldt'file'use'cnt + logical(counter); <<06730>>13030000
      putdev (ldev, ldt'dst, ldt);                             <<06730>>13035000
      end                                                        <<mv>> 13040000
   else                                                          <<mv>> 13045000
      begin<<allocate the devices>>                              <<mv>> 13050000
      ldev:=bspacedata(0);                                       <<mv>> 13055000
      counter:=0;                                                <<mv>> 13060000
      k:=0;<<points to the last ext allocated>>                  <<mv>> 13065000
      while (j:=j+1)<-numext do                                  <<mv>> 13070000
      if bspacedata(j*4)<>0 then                                 <<mv>> 13075000
         begin                                                   <<mv>> 13080000
         if ldev=integer(bspacedata(j*4)) then                   <<mv>> 13085000
            counter:=counter+1                                   <<mv>> 13090000
         else                                                    <<mv>> 13095000
            begin<<new ldev - bump usecount>>                    <<mv>> 13100000
lastdev:    if not getdev (ldev, ldt'dst, ldt)                 <<06730>>13105000
               then begin                                        <<mv>> 13110000
                j:=k-1;                                          <<mv>> 13115000
                goto badindx;                                    <<mv>> 13120000
                end;                                             <<mv>> 13125000
            if ldt'down'pending or not ldt'avail'to'sys then   <<06730>>13130000
               begin<<device not available>>                     <<mv>> 13135000
               diskalloc := 4;                                 <<03507>>13140000
               diskalloc.(0:8):=ldev;                            <<mv>> 13145000
               j:=k-1;<<fix it for diskdealloc>>            <<mv>>      13150000
               goto out1;                                        <<mv>> 13155000
               end;                                              <<mv>> 13160000
            ldt'file'use'cnt := ldt'file'use'cnt +             <<06730>>13165000
                logical (counter);                             <<06730>>13170000
            k:=k+counter;                                        <<mv>> 13175000
            counter:=1;                                          <<mv>> 13180000
            putdev (ldev, ldt'dst, ldt);                       <<06730>>13185000
            ldev:=bspacedata(j*4);                               <<mv>> 13190000
            end;                                                 <<mv>> 13195000
         end;                                                    <<mv>> 13200000
      if j =-numext then                                   <<mv>>       13205000
          goto lastdev <<this will bump the usecount>>     <<mv>>       13210000
                       <<and then bump j            >>     <<mv>>       13215000
      else j:=-numext-1; <<just in case>>                  <<mv>>       13220000
      end;                                                       <<mv>> 13225000
   end;<<getdspace>>                                             <<mv>> 13230000
                                                                        13235000
subroutine spacemsg (type);                                             13240000
   value   type;                                                        13245000
   integer type;                                                        13250000
   begin   << shut all device and class spool queues.       >> <<06730>>13255000
   temp'ldt := @ldt;   << i don't like this either, but ... >> <<06730>>13260000
   temp'dct := @dct;                                           <<06730>>13265000
   exchangedb (ldt'dst);                                       <<06730>>13270000
   @ldt := 0;                                                  <<06730>>13275000
   ldt'index := ldt'entry'size;                                <<06730>>13280000
   do begin   << device queues first (not that it matters). >> <<06730>>13285000
      ldt'spool'queues := ldt'qshut;                           <<06730>>13290000
      ldt'index := ldt'index + integer (ldt'entry'size);       <<06730>>13295000
      end                                                      <<06730>>13300000
     until logical(ldt'index)/ldt'entry'size > ldt'num'entries;<<06730>>13305000
   exchangedb (dct'dst);                                       <<06730>>13310000
   @dct := dcth'dct'base;   << now shut class queues.       >> <<06730>>13315000
   do dct'spool'queues := dct'shut                             <<06730>>13320000
      until (@dct := @dct + integer (dct'next'entry)) >=       <<06730>>13325000
      integer (dcth'tdt'base);                                 <<06730>>13330000
   exchangedb (stack);                                         <<06730>>13335000
   @ldt := temp'ldt;   << restore local array.              >> <<06730>>13340000
   ldt'index := 0;                                             <<06730>>13345000
   @dct := temp'dct;                                           <<06730>>13350000
   genmsg(1,type,,,,,,,0);                                     <<0u.eb>>13355000
   end;                                                                 13360000
                                                                        13365000
   return'value := 1;  << init to no space >>                  <<03507>>13370000
                                                               <<03507>>13375000
   if pvalloc then                                             <<rh.pv>>13380000
      begin                                                    <<rh.pv>>13385000
      save'mvtab'sir := getsir (mvtabsir);                     <<06730>>13390000
      tos:=pvinfo;                                             <<rh.pv>>13395000
      vmask:=s0.vmaskf;                                        <<rh.pv>>13400000
      mvtabx:=tos.mvtabxf;                                     <<rh.pv>>13405000
      movefromdseg (@mvtabent, mvtabdst, mvtabx * mvtabsize,   <<06730>>13410000
                    mvtabsize);                                <<06730>>13415000
      hvol:=mvtabent(1).(0:4);  <<highest volume index>>       <<rh.pv>>13420000
      end;                                                     <<06730>>13425000
   save'ldt'sir := getsir (ldt'sir);                           <<06730>>13430000
   save'dct'sir := getsir (dct'sir);                           <<06730>>13435000
   if indx = 0 then                                                     13440000
      begin    << spooling call: use sysglob values & check sect cnt >> 13445000
      if numext > 0 then                                                13450000
         begin    << actual sector allocation >>                        13455000
         pdisable;                                             <<06730>>13460000
         pushnumss;    << check & adjust sect count >>                  13465000
         tos := tos + (sysspextntsec ** logical (numext));     <<07050>>13470000
         assemble (ddup);                                               13475000
         pushmaxss;                                                     13480000
         assemble (dcmp);                                               13485000
         if > then                                                      13490000
            begin                                                       13495000
            penable;                                           <<06730>>13500000
            spacemsg(232);                                              13505000
            goto out1;                                         <<03507>>13510000
            end;                                                        13515000
         popnumss;                                                      13520000
         penable;                                              <<06730>>13525000
         spacedata := double (sysspextntsec);                  <<07050>>13530000
         move spacedata (1) := spacedata, ((numext-1) &asl(1));         13535000
         << spl wants word count, above >>                              13540000
         end;                                                           13545000
      indx := sysspooldctindx;                                 <<07050>>13550000
      forspooling := true;                                              13555000
      end;                                                              13560000
   laddr:=0;                                                     <<mv>> 13565000
   if numext>0 then                                              <<mv>> 13570000
      move laddr(1):=laddr,(numext*2-1)                          <<mv>> 13575000
      else                                                       <<mv>> 13580000
         goto notspace;   <<just alloc devices>>             <<mv>>     13585000
   if pvclass then  <<use mvtab entry as pseudo dev. class>>   <<rh.pv>>13590000
      begin                                                    <<rh.pv>>13595000
      mask:=0;                                                 <<rh.pv>>13600000
      cycp:=mvtabent.cycpf;                                    <<rh.pv>>13605000
nextv:                                                         <<rh.pv>>13610000
      while (mask land vmask) = 0 do                           <<rh.pv>>13615000
         begin                                                 <<rh.pv>>13620000
         if vmask = 0 then go out1;                            <<03507>>13625000
         cycp:=if cycp < hvol then (cycp+1) else 0;            <<rh.pv>>13630000
         mask:=1 & lsl(cycp);                                  <<rh.pv>>13635000
         end;                                                  <<rh.pv>>13640000
      vmask:=vmask land not mask;  <<reset bit just tested>>   <<rh.pv>>13645000
      ldev:=mvtabent((cycp&lsl(1))+5).(0:8);                   <<rh.pv>>13650000
      go cont2;                                                <<rh.pv>>13655000
      end;                                                     <<rh.pv>>13660000
   if indx >= 0 then go specdev;                               <<06730>>13665000
                                                               <<06730>>13670000
<< device class request.                                    >> <<06730>>13675000
                                                               <<06730>>13680000
   indx := -indx;                                              <<06730>>13685000
   entry'length := get'device'class (indx, entry'address);     <<06730>>13690000
   if entry'length = -1 then                                   <<06730>>13695000
      begin   <<invalid indx>>                                          13700000
badindx:                                                                13705000
      diskalloc := 5;                                          <<06730>>13710000
out1:                                                                   13715000
      relsir (dct'sir, save'dct'sir);                          <<06730>>13720000
      relsir (ldt'sir, save'ldt'sir);                          <<06730>>13725000
                                                               <<03507>>13730000
      if return'value = 3 and out'of'space'on'any'dev          <<03507>>13735000
         then return'value := 1;  << force "out-of-space" >>   <<03507>>13740000
                                                               <<03507>>13745000
      if pvalloc then relsir (mvtabsir, save'mvtab'sir);       <<06730>>13750000
      if numext>0 then <<return space>>                          <<mv>> 13755000
         begin                                                          13760000
         diskdealloc (logical (spacedata), logical (spacedata (j)),     13765000
            j+1, addr);                                                 13770000
         if forspooling then                                            13775000
            begin    << err when spooling call: set cnt back >>         13780000
            pdisable;                                          <<06730>>13785000
            pushnumss;                                                  13790000
            tos := tos -(logical (spacedata) ** logical (j+1));         13795000
            popnumss;                                                   13800000
            penable;                                           <<06730>>13805000
            end;                                                        13810000
         end                                                            13815000
      else  <<keep space>>                                       <<mv>> 13820000
         diskdealloc(0,0<<ignored>>,-j-1,spacedata);             <<mv>> 13825000
      return;                                                           13830000
      end;                                                              13835000
                                                               <<06730>>13840000
  comment -- we need to scan the list of ldev's in our dct en- <<06730>>13845000
try.  unfortunately, the length of the list is  arbitrary  and <<06730>>13850000
varies  from entry to entry.  thus to make a local copy of the <<06730>>13855000
entry, we must build space for it on the stack.  (we can't de- <<06730>>13860000
clare an array for it because the length is unknown at entry). <<06730>>13865000
;                                                              <<06730>>13870000
   push (s);                                                   <<06730>>13875000
   @dct := tos + 1;                                            <<06730>>13880000
   tos := entry'length;                                        <<06730>>13885000
   assemble (adds 0);   << hope stack has enough room.      >> <<06730>>13890000
   movefromdseg (@dct, dct'dst, entry'address, entry'length);  <<06730>>13895000
   cycp := dct'cyclical'ptr;                                   <<06730>>13900000
   nldev := dct'num'devices;                                   <<06730>>13905000
   count := 0;                                                 <<06730>>13910000
next:                                                                   13915000
   if (count := count+1) > nldev then                          <<06730>>13920000
      begin                                                             13925000
      if forspooling then spacemsg(233);                                13930000
      go out1;                                                          13935000
      end;                                                              13940000
   if (cycp := cycp+1) > nldev then cycp := 1;                 <<06730>>13945000
   ldev := dct(dct'first'ldev + cycp - 1);                     <<06730>>13950000
   if pvalloc then                                             <<rh.pv>>13955000
      begin                                                    <<rh.pv>>13960000
      v:=-1;                                                   <<rh.pv>>13965000
      while (v:=v+1) <= hvol do                                <<rh.pv>>13970000
      if (mvtabent((v&lsl(1))+5).(0:8) = logical(ldev) land    <<06730>>13975000
         (((1 & lsl(v)) land vmask) <> 0)) then go cont2;      <<rh.pv>>13980000
      go next;                                                 <<rh.pv>>13985000
      end                                                      <<rh.pv>>13990000
   else                                                        <<rh.pv>>13995000
      if lpdt'non'sys'domain then go next;                     <<06730>>14000000
cont2:                                                         <<rh.pv>>14005000
   getdev (ldev, ldt'dst, ldt);   << ldt entry for ldev.    >> <<06730>>14010000
   if ldt'down'pending or not ldt'avail'to'sys then            <<06730>>14015000
      begin   <<device not available>>                                  14020000
      if pvclass then go nextv else go next;                   <<rh.pv>>14025000
      end;                                                              14030000
   getdspace;                                                           14035000
   return'value := i;                                          <<03507>>14040000
   if i=0 then go cont;                                                 14045000
   if i <> 2 then << not an i/o error >>                       <<03507>>14050000
      if pvclass then go nextv else go next;  <<no room>>      <<rh.pv>>14055000
   error := true;                                              <<06730>>14060000
cont:   <<update cyclical pointer>>                                     14065000
   if pvclass then  <<update pv cycp>>                         <<rh.pv>>14070000
      if hvol > 0 then                                         <<06730>>14075000
         begin   << more than one possible value for cycp.  >> <<06730>>14080000
         mvtabent.cycpf := cycp;                               <<06730>>14085000
         movetodseg (mvtabdst, mvtabx*mvtabsize, @mvtabent, 1);<<06730>>14090000
         end                                                   <<06730>>14095000
      else                                                     <<06730>>14100000
   else                                                        <<06730>>14105000
      begin   << system disc class, update its cyclical ptr >> <<06730>>14110000
      dct'cyclical'ptr := cycp;                                <<06730>>14115000
      movetodseg (dct'dst, entry'address, @dct, entry'length); <<06730>>14120000
      end;                                                     <<rh.pv>>14125000
   if error then go out1;                                               14130000
                                                               <<06730>>14135000
latchon:                                                         <<mv>> 14140000
   relsir (dct'sir, save'dct'sir);                             <<06730>>14145000
   relsir (ldt'sir, save'ldt'sir);                             <<06730>>14150000
   if pvalloc then relsir (mvtabsir, save'mvtab'sir);          <<06730>>14155000
   i := -1;                                                    <<06730>>14160000
   while (i := i+1) < numext do spacedata(i) := addr(i);       <<06730>>14165000
   diskalloc := 0;    <<okay return>>                                   14170000
   return;                                                              14175000
                                                               <<06730>>14180000
specdev:   <<specific device>>                                          14185000
                                                               <<06730>>14190000
   ldev := indx;                                               <<06730>>14195000
   if pvalloc then                                             <<rh.pv>>14200000
      begin                                                    <<rh.pv>>14205000
      v:=-1;                                                   <<rh.pv>>14210000
      while (v:=v+1) <= hvol do                                <<rh.pv>>14215000
      if (mvtabent((v&lsl(1))+5).(0:8) = logical(ldev) land    <<06730>>14220000
         (((1 & lsl(v)) land vmask) <> 0)) then  go cont3;     <<rh.pv>>14225000
      go notavail;                                             <<00565>>14230000
      end                                                      <<rh.pv>>14235000
   else                                                        <<rh.pv>>14240000
      if lpdt'non'sys'domain then go notavail;                 <<06730>>14245000
cont3:                                                         <<rh.pv>>14250000
   if not getdev (ldev, ldt'dst, ldt) then                     <<06730>>14255000
      begin   <<invalid ldev (indx)>>                                   14260000
      go badindx;                                                       14265000
      end;                                                              14270000
   if ldt'down'pending or not ldt'avail'to'sys then            <<06730>>14275000
notavail:                                                      <<00565>>14280000
      begin   <<device not available>>                                  14285000
      diskalloc := 4;                                          <<03507>>14290000
      go out1;                                                          14295000
      end;                                                              14300000
notspace:                                              <<mv>>           14305000
   getdspace;                                                           14310000
   if i=0 then go latchon;                                              14315000
   diskalloc := i;                                             <<06730>>14320000
   go out1;                                                             14325000
   end;   <<diskalloc>>                                                 14330000
$page "    ***   REMOVE'FROM'XDD   ***"                        <<07104>>14335000
$control segment=allocutil                                     <<07104>>14340000
procedure remove'from'xdd(xdd'index,ci'session);               <<07104>>14345000
value xdd'index,ci'session;                                    <<07104>>14350000
logical xdd'index,ci'session;                                  <<07104>>14355000
option privileged,uncallable;                                  <<07104>>14360000
                                                               <<07104>>14365000
!------------------------------------------------------------- <<07104>>14370000
! this  procedure  is  called by term'reallocate to remove xdd <<07104>>14375000
! entries  that  contain  the given ci'session number from the <<07104>>14380000
! given  xdd  chain.  it scans the subentry links of the given <<07104>>14385000
! head  chain  and  removes all entries with the given session <<07104>>14390000
! number.  it  is  used  when  a  terminal  is  reallocated to <<07104>>14395000
! another ci's process tree and then reallocated back (see the <<07104>>14400000
! comment in term'reallocate).                                 <<07104>>14405000
!------------------------------------------------------------- <<07104>>14410000
                                                               <<07104>>14415000
begin                                                          <<07104>>14420000
logical array                                                  <<07104>>14425000
   xdd'head(0:size'of'xdd'head-1),                             <<07104>>14430000
   xdd'subentry(0:size'of'xdd'subentry);                       <<07104>>14435000
integer pointer                                                <<07104>>14440000
   link;          ! used in call to sremovexdd.                <<07104>>14445000
integer i;        ! simply used for index variable.            <<07104>>14450000
logical                                                        <<07104>>14455000
   link'pntr,     ! points to xdd subentry.                    <<07104>>14460000
   odd=i,         ! used to determine if we are using odd/idd. <<07104>>14465000
   xdd'head'pntr, ! points to the xdd head entry.              <<07104>>14470000
   save'xdd'sir,  ! return parm from getsir.                   <<07104>>14475000
   xdd'dst,       ! either odd or idd dst.                     <<07104>>14480000
   xdd'sir;       !   "     "   "   " sir.                     <<07104>>14485000
define                                                         <<07104>>14490000
   session'type  = ci'session.(0:2)#,                          <<07104>>14495000
   session'num   = ci'session.(2:14)#;                         <<07104>>14500000
                                                               <<07104>>14505000
subroutine def'movefromdseg;                                   <<07104>>14510000
$page                                                          <<07104>>14515000
xdd'head'pntr := xdd'index*size'of'xdd'head;                   <<07104>>14520000
for i:=1 until 2 do                                            <<07104>>14525000
   begin          ! once for the odd and once for the idd.     <<07104>>14530000
   if odd then                                                 <<07104>>14535000
      begin                                                    <<07104>>14540000
      xdd'dst := odd'dst;                                      <<07104>>14545000
      xdd'sir := odd'sir;                                      <<07104>>14550000
      end                                                      <<07104>>14555000
   else                                                        <<07104>>14560000
      begin                                                    <<07104>>14565000
      xdd'dst := idd'dst;                                      <<07104>>14570000
      xdd'sir := idd'sir;                                      <<07104>>14575000
      end;                                                     <<07104>>14580000
   save'xdd'sir := getsir(xdd'sir);                            <<07104>>14585000
   movefromdseg(@xdd'head,xdd'dst,xdd'head'pntr,               <<07104>>14590000
                size'of'xdd'head);                             <<07104>>14595000
   link'pntr := xddh'first'subentry;                           <<07104>>14600000
                                                               <<07104>>14605000
   while link'pntr <> xdds'end'of'chain do                     <<07104>>14610000
      begin       ! delete all entries with given session.     <<07104>>14615000
      movefromdseg(@xdd'subentry,xdd'dst,link'pntr,            <<07104>>14620000
                   size'of'xdd'subentry);                      <<07104>>14625000
      if xdds'job'number = session'num and                     <<07104>>14630000
         xdds'job'type   = session'type then                   <<07104>>14635000
         begin    ! session matches, delete it.                <<07104>>14640000
         @link := link'pntr;                                   <<07104>>14645000
         if odd then                                           <<07104>>14650000
            @link.(0:1) := 1;    ! signify odd access.         <<07104>>14655000
         sremovexdd(link);                                     <<07104>>14660000
         end;                                                  <<07104>>14665000
      link'pntr := xdds'next'subentry;                         <<07104>>14670000
      end;                                                     <<07104>>14675000
   relsir(xdd'sir,save'xdd'sir);                               <<07104>>14680000
   end;                                                        <<07104>>14685000
end;              ! procedure remove'from'xdd.                 <<07104>>14690000
$page          "***   TERM'REALLOCATE   ***"                   <<07104>>14695000
$control segment=allocate                                      <<07104>>14700000
procedure term'reallocate(term'ldev,new'ci'pin);               <<07104>>14705000
value term'ldev,new'ci'pin;                                    <<07104>>14710000
integer term'ldev,new'ci'pin;                                  <<07104>>14715000
option privileged,uncallable;                                  <<07104>>14720000
                                                               <<07104>>14725000
!------------------------------------------------------------- <<07104>>14730000
!  this  procedure  is used by mm/pm 3000 to reallocate a par- <<07104>>14735000
! ticular  terminal  to  another  ci.  this  is done so that a <<07104>>14740000
! process that is in another ci's process tree (the mm monitor <<07104>>14745000
! process tree) can fopen and  access the terminal.  this pro- <<07104>>14750000
! cedure is a bit of a kludge, but it works!  all that is bas- <<07104>>14755000
! ically done is that the ci main pin of the ldt entry for the <<07104>>14760000
! terminal  is modified to reflect the new'ci'pin, sent by the <<07104>>14765000
! mm process.                                                  <<07104>>14770000
!                                                              <<07104>>14775000
!  when the process in the other process tree fopen's the ter- <<07104>>14780000
! minal, fopen  will  allow  the terminal to be opened because <<07104>>14785000
! the  ci  main  pin in the ldt matches the ci main pin of the <<07104>>14790000
! process.  however,  since  the  session  number found in the <<07104>>14795000
! corresponding xdd entries do not match the session number of <<07104>>14800000
! the  process opening the terminal, another idd and odd entry <<07104>>14805000
! is  created  for the ldev containing the new session number. <<07104>>14810000
! thus,  when  the  original  process reallocates the terminal <<07104>>14815000
! back, we  must remove the xdd entries that were created when <<07104>>14820000
! the  terminal was reopened.  thus, if the ci main pin of the <<07104>>14825000
! process  reallocating  the  terminal is equal to the ci main <<07104>>14830000
! pin  passed  to  us, then  this is the case and we must call <<07104>>14835000
! remove'from'xdd  to remove all xdd entries from the terminal <<07104>>14840000
! with  the  session  number  of the ci process that currently <<07104>>14845000
! owns the ldt.                                                <<07104>>14850000
!------------------------------------------------------------- <<07104>>14855000
                                                               <<07104>>14860000
begin                                                          <<07104>>14865000
logical array                                                  <<07104>>14870000
   ldt(0:size'of'ldt'entry-1),                                 <<07104>>14875000
   qarray(*) = q-0;                                            <<07104>>14880000
logical pointer                                                <<07104>>14885000
   pcb = syspcbindex;      ! pcb sysglobal pointer.            <<07104>>14890000
integer                                                        <<07104>>14895000
   ldt'index := 0,         ! used for ldt defines.             <<07104>>14900000
   ci'jitdst,              ! jit dst of the "other" ci.        <<07104>>14905000
   my'ci'pin,              ! my ci pin number, from the jit.   <<07104>>14910000
   ci'session,             ! the session num of "other CI".    <<07104>>14915000
   old'ci'pin,             ! current owner in ldt of terminal. <<07104>>14920000
   save'ldt'sir,           ! return parm from getsir.          <<07104>>14925000
   pcbglobloc,             ! used for pxglobal defines.        <<07104>>14930000
   pcbpt;                  ! used for pcb defines.             <<07104>>14935000
equate                                                         <<07104>>14940000
   jit'ci'main'pin   = 11, ! offset in jit of ci main pin.     <<07104>>14945000
   jit'session'num   = 7,  ! offset in jit of session number.  <<07104>>14950000
   stk'jitdst'offset  =11; ! offset in other stack of jitdst.  <<07104>>14955000
$page     "***   TERM'REALLOCATE - SUBROUTINES   ***"          <<07104>>14960000
subroutine def'movefromdseg;                                   <<07104>>14965000
                                                               <<07104>>14970000
subroutine get'my'ci'pin;                                      <<07104>>14975000
                                                               <<07104>>14980000
!------------------------------------------------------------- <<07104>>14985000
! retrieves the ci pin from the jit of the current process.    <<07104>>14990000
!------------------------------------------------------------- <<07104>>14995000
                                                               <<07104>>15000000
begin                                                          <<07104>>15005000
pxglobal;                  ! set pcbglobloc for defines.       <<07104>>15010000
movefromdseg(@my'ci'pin,pxg'jitdst,jit'ci'main'pin,1);         <<07104>>15015000
end;                                                           <<07104>>15020000
                                                               <<07104>>15025000
                                                               <<07104>>15030000
subroutine get'ci'session;                                     <<07104>>15035000
                                                               <<07104>>15040000
!------------------------------------------------------------- <<07104>>15045000
! finds  the  session  number  from the jit of the ci based on <<07104>>15050000
! the pin # found in the ldt.  gets the stack dst from the pcb <<07104>>15055000
! and gets the jit dst from the ci's stack pxglobal area.      <<07104>>15060000
!------------------------------------------------------------- <<07104>>15065000
                                                               <<07104>>15070000
begin                                                          <<07104>>15075000
pcbpt := old'ci'pin*pcbsize;   ! set pcb pointer for defines.  <<07104>>15080000
movefromdseg(@ci'jitdst,spcbstkdst,stk'jitdst'offset,1);       <<07104>>15085000
movefromdseg(@ci'session,ci'jitdst,jit'session'num,1);         <<07104>>15090000
end;                                                           <<07104>>15095000
                                                               <<07104>>15100000
$page       "***   TERM'REALLOCATE - OUTER BLOCK   ***"        <<07104>>15105000
save'ldt'sir := getsir(ldt'sir);  ! obtain proper sir.         <<07104>>15110000
getdev(term'ldev,ldt'dst,ldt);    ! copy ldt entry to stack.   <<07104>>15115000
old'ci'pin := ldt'main'pin;       ! save current owners pin.   <<07104>>15120000
ldt'main'pin := new'ci'pin;       ! insert new ci pin in ldt.  <<07104>>15125000
putdev(term'ldev,ldt'dst,ldt);    ! copy changed ldt back.     <<07104>>15130000
relsir(ldt'sir,save'ldt'sir);                                  <<07104>>15135000
                                                               <<07104>>15140000
get'my'ci'pin;                    ! retrieve my ci main pin.   <<07104>>15145000
if new'ci'pin = my'ci'pin then                                 <<07104>>15150000
   begin                          ! clear xdd entries.         <<07104>>15155000
   get'ci'session;                ! "Other" ci session number. <<07104>>15160000
   remove'from'xdd(ldt'xdd'head'index,ci'session);             <<07104>>15165000
   end;                                                        <<07104>>15170000
end;                                                           <<07104>>15175000
$page          "***   FORMSALIGN   ***"                        <<07104>>15180000
$control segment= allocate                                              15185000
                                                                        15190000
procedure formsalign(ldev);                                             15195000
    value ldev;                                                         15200000
    integer ldev;                                                       15205000
    option privileged,uncallable;                                       15210000
   begin                                                                15215000
                                                               <<06064>>15220000
   equate                                                      <<06064>>15225000
      feature'access   =  9,   << 2608s subtypes.           >> <<06064>>15230000
      transparent'mode = 13;                                   <<06064>>15235000
                                                               <<06064>>15240000
   integer array                                                        15245000
         ibuf(0:65),                                           <<04620>>15250000
         ldt(0:size'of'ldt'entry - 1);                         <<06730>>15255000
   byte pointer bbuf;                                                   15260000
   logical ok;                                                 <<04620>>15265000
   integer                                                     <<04620>>15270000
      rsize,          << record size of the device.         >> <<04620>>15275000
      ldt'index := 0, << for ldt $include file.             >> <<06730>>15280000
          i;          << general purpose index.             >> <<04620>>15285000
                                                               <<06730>>15290000
   define                                                      <<06730>>15295000
      lpdt'index = ldev * integer(lpdt'entry'size)#;           <<06730>>15300000
                                                               <<04620>>15305000
   getdev (ldev, ldt'dst, ldt);  << local copy of ldt entry >> <<06730>>15310000
                                                               <<04620>>15315000
   <<*******************************************************>> <<04620>>15320000
   << do forms alignment only on printers and remote spooled>> <<06064>>15325000
   << terminals (also of type printer).  omit the forms     >> <<06064>>15330000
   << alignment rack (but keep forms aligned ok question)   >> <<06064>>15335000
   << for 2608s, because it has a button for the rack.      >> <<06064>>15340000
   <<*******************************************************>> <<04620>>15345000
                                                               <<04620>>15350000
   if ldt'device'type = ldt'printer then                       <<06730>>15355000
        begin                                                  <<04620>>15360000
        rsize := ldt'record'width;                             <<06730>>15365000
        @bbuf := (@ibuf &lsl(1)) -1;                           <<04620>>15370000
        move ibuf := "....:....#";                             <<04620>>15375000
        move ibuf (5) := ibuf, (61);                           <<04620>>15380000
        i := 10;                                               <<04620>>15385000
        do bbuf (i) := (i/10) mod 10 + "0"                     <<04620>>15390000
        until (i := i + 10) > 130;                             <<04620>>15395000
        do                                                     <<04620>>15400000
           begin                                               <<04620>>15405000
           if lpdt'subtype <> feature'access                   <<06730>>15410000
              and lpdt'subtype <> transparent'mode then        <<06730>>15415000
              attachio (ldev, 0, 0, @ibuf, 1, rsize, 0, 0, 1); <<06730>>15420000
           genmsg(1,216,%10000,ldev,,,,,0,1,@ok);              <<04620>>15425000
           end                                                 <<04620>>15430000
        until ok;                                              <<04620>>15435000
                                                               <<04620>>15440000
        << call to help for stt entry, never executed       >> <<04620>>15445000
                                                               <<04620>>15450000
        if false then help;                                    <<04620>>15455000
        end;                                                   <<04620>>15460000
                                                               <<04620>>15465000
   end;   <<forms align>>                                               15470000
$page "***   ASKOP   ***"                                      <<06730>>15475000
$control segment = allocate                                    <<06730>>15480000
                                                               <<06730>>15485000
logical procedure askop(reqdev,fname,oldflag,allocdev,type,jmpin,       15490000
    spoolernum,jobnum,flags,ptype,strin,response);             <<sd.00>>15495000
    value reqdev,oldflag,spoolernum,jobnum,jmpin,flags,ptype;  <<sd.00>>15500000
    integer reqdev,allocdev,type,spoolernum,jobnum,jmpin,flags,<<sd.00>>15505000
            ptype;                                             <<sd.00>>15510000
    logical oldflag;                                                    15515000
    integer array fname;                                                15520000
    byte array strin,response;                                 <<sd.00>>15525000
    option privileged,uncallable,variable;                              15530000
         <<requests device or device in class. if class, insures that >>15535000
         <<device is in class.if realee, then checks ownership and    >>15540000
         <<whether old-data accepting. operator is harassed until     >>15545000
         <<he/she/it gives a valid response.                          >>15550000
         <<input:                                                     >>15555000
         <<      reqdev             - +ldev or -class index           >>15560000
         <<      fname              - file name (8bytes,1st blank     >>15565000
         <<                                               terminates) >>15570000
         <<      oldflag            - true if old request             >>15575000
         <<      jmpin              - job main process#               >>15580000
         <<      ptype=0#             no parameter sought             >>15585000
         <<           =1            - numeric parm sought             >>15590000
         <<           =2            - yes/no parm sought              >>15595000
         <<           =3            - string parm sought              >>15600000
         <<      strin !            - formatted parameter defining    >>15605000
         <<                           operator response desired.      >>15610000
         <<                         i.e. ",WRITE RING? (Y/N)",0       >>15615000
         <<                           byte array delimited by a zero  >>15620000
         <<      spoolernum*        - spoolee ldev                    >>15625000
         <<      jobnum*            - spoofle's job#                  >>15630000
         <<  * spooler callers only                                   >>15635000
         <<  # only needed if a parm after ldev is wanted             >>15640000
         <<  ! only needed if ptype=3                                 >>15645000
         <<output:                                                    >>15650000
         <<      askop = true       - not rejected (see type)         >>15655000
         <<            = FALSE      - OP.REJECTED (REPLIED "0"OR"NO)  >>15660000
         <<      allocdev           - +ldev# (the one op.gave you)    >>15665000
         <<      type = 0           - old & data accepting            >>15670000
         <<           = 1           - re-allocation                   >>15675000
         <<           = 2           - initial allocation (reserved)   >>15680000
         <<                                     (i.e. ss = 3)  <<06730>>15685000
         <<      response           - minus one (-1) for "YES"        >>15690000
         <<                           zero (0) for "NO"               >>15695000
         <<                           the number input by op (integer)>>15700000
         <<                           or                              >>15705000
         <<                           string with length in first word>>15710000
         <<                           and characters beginning in     >>15715000
         <<                           second.  maxlen=20char          >>15720000
         <<     note: db at stack coming in & going out.              >>15725000
   begin                                                                15730000
   equate                                                               15735000
         okay = opassigned,                                             15740000
         rejected = 3,                                                  15745000
         invalid = 4;                                                   15750000
    define access  = flags.(14:2)#;                            <<tl.02>>15755000
    define labeled = flags.(7:1)#;                             <<tl.02>>15760000
   define      <<optional parameter bitmap>>                   <<sd.00>>15765000
         spoolerbits=(10:2)#,                                  <<sd.00>>15770000
         responsebit=(15:1)#,                                  <<sd.00>>15775000
         strinbit=(14:1)#,                                     <<sd.00>>15780000
         ptypebit=(13:1)#;                                     <<sd.00>>15785000
   logical                                                              15790000
         classreq,   <<class request>>                                  15795000
         spooldev,   <<call from spooler>>                              15800000
      autoalloc,  <<automatically allocated mag tape>>         <<tl.03>>15805000
      check'for'avr,  <<check for avr on tape and sdisc>>      <<03681>>15810000
         save'ldt'sir,                                         <<06730>>15815000
         save'lpdt'sir;                                        <<06730>>15820000
   double dstat'ret;                                           <<03698>>15825000
   integer stat'ret0=dstat'ret;                                <<03698>>15830000
   integer stat'ret1=stat'ret0+1;                              <<03698>>15835000
   define on'line=(stat'ret1.(14:1)=0)#;                       <<03698>>15840000
   integer                                                              15845000
         i,                                                    <<06730>>15850000
         q4 = q-4,   <<bit map>>                                        15855000
         answer,   <<op.response>>                                      15860000
      classlen,                                                <<00552>>15865000
         resp,   <<temp.storage of type>>                               15870000
         devtoconsider,   <<device currently being considered>>         15875000
      ldevn,                                                   <<tl.02>>15880000
         ldt'index := 0,  << these two cells keep the ldt & >> <<06730>>15885000
         lpdt'index,      << lpdt $include files happy.     >> <<06730>>15890000
         entry'address,   << dct-rel addr of desired entry. >> <<06730>>15895000
         entry'length;    << length of local dct entry.     >> <<06730>>15900000
   logical                                                     <<01647>>15905000
      assoc'sir;                   << save sir for assoc.   >> <<01647>>15910000
                                                               <<01647>>15915000
   integer array                                                        15920000
         lfname(0:4),   <<local version of fname(*)>>                   15925000
         lclassname(0:4),                                               15930000
         jobnumber (0:3),                                               15935000
         assoc(0:ass'entrysize);   << extra word is for     >> <<06730>>15940000
                                   <<   genmsg terminator.  >> <<06730>>15945000
   byte array                                                           15950000
      assoc'(*)=assoc,                                         <<00552>>15955000
         blfname(*) = lfname,                                           15960000
         blclassname(*) = lclassname,                                   15965000
         bjobnumber (*) = jobnumber;                                    15970000
   logical array                                               <<06730>>15975000
         ldt(0:size'of'ldt'entry - 1);                         <<06730>>15980000
   logical pointer                                             <<06730>>15985000
         dct;             << for device class table entry.  >> <<06730>>15990000
   integer pointer                                             <<sd.00>>15995000
         tbuf, <<will point to operator reply>>                <<sd.00>>16000000
         ioutbuf; <<will point to response buffer>>            <<sd.00>>16005000
   byte array                                                  <<sd.00>>16010000
         btbuf(0:26), <<max op reply length is 27 char>>       <<sd.00>>16015000
         blankbuf(0:1); <<default input string>>               <<sd.00>>16020000
   byte pointer                                                <<sd.00>>16025000
         inbuf:=@blankbuf,  <<input string holder>>            <<sd.00>>16030000
         outbuf:=@btbuf; <<output string holder>>              <<sd.00>>16035000
                                                               <<06730>>16040000
subroutine def'movefromdseg;                                   <<06730>>16045000
$page                                                          <<00552>>16050000
subroutine parseparm;                                          <<sd.00>>16055000
comment: parse operator response.  must be in the form         <<sd.00>>16060000
         ldev# (or) yes/no   ,   parameter                     <<sd.00>>16065000
         parameter may be 1)a number<=32759                    <<sd.00>>16070000
                          2)"YES" or "NO"                      <<sd.00>>16075000
                          3)a string of up to 20 characters    <<sd.00>>16080000
         parameter is optional with defaults being             <<sd.00>>16085000
                          1)zero                               <<sd.00>>16090000
                          2)"NO"                               <<sd.00>>16095000
                          3)zero length string                 <<sd.00>>16100000
         any deviation will result in the operator being       <<sd.00>>16105000
         reasked.  ((resp:=invalid))                           <<sd.00>>16110000
end of comment;                                                <<sd.00>>16115000
begin <<parseparm>>                                            <<sd.00>>16120000
i:=tbuf; <<length of response>>                                <<sd.00>>16125000
resp:=okay;                                                    <<sd.00>>16130000
btbuf(i+2):=%54; <<append comma to insure end of scan>>        <<sd.00>>16135000
if classreq then                                               <<sd.00>>16140000
   begin <<numeric response requested>>                        <<sd.00>>16145000
   i:=1; <<response begins in second word>>                    <<sd.00>>16150000
   while btbuf(i:=i+1)<>%54 <<comma>> do                       <<sd.00>>16155000
     if %60<=integer(btbuf(i))<=%71 then else resp:=invalid;   <<sd.00>>16160000
   end   <<numeric response requested>>                        <<sd.00>>16165000
else                                                           <<sd.00>>16170000
   begin <<yes/no response requested>>                         <<sd.00>>16175000
   resp:=invalid;                                              <<sd.00>>16180000
   if btbuf(2)="Y," or btbuf(2)="YES," then resp:=okay;        <<sd.00>>16185000
   if btbuf(2)="N," or btbuf(2)="NO,"  or                      <<04538>>16190000
      btbuf(2)="0," then resp := okay;                         <<04538>>16195000
   end;  <<yes/no response requested>>                         <<sd.00>>16200000
if resp=okay then                                              <<sd.00>>16205000
   begin <<operator response has valid syntax>>                <<sd.00>>16210000
   if classreq then                                            <<sd.00>>16215000
      begin <<convert # to binary>>                            <<sd.00>>16220000
      i:=1; <<# begins in second word>>                        <<sd.00>>16225000
      answer:=0; <<accumulator>>                               <<sd.00>>16230000
      while btbuf(i:=i+1)<>%54 and answer<3276 do              <<sd.00>>16235000
         answer:=answer*10+integer(btbuf(i))-%60;              <<sd.00>>16240000
      end   <<convert # to binary>>                            <<sd.00>>16245000
   else                                                        <<sd.00>>16250000
      begin <<set yes/no>>                                     <<sd.00>>16255000
      answer:=if btbuf(2)="Y" then -1<<true>> else 0<<false>>; <<sd.00>>16260000
      i:=2; <<for scan to find comma>>                         <<sd.00>>16265000
      end;  <<set yes/no>>                                     <<sd.00>>16270000
   while btbuf(i)<>%54 do i:=i+1; <<find first comma>>         <<sd.00>>16275000
   if i-1<tbuf then                                            <<sd.00>>16280000
      begin <<parameter entered by operator>>                  <<sd.00>>16285000
      case ptype of                                            <<sd.00>>16290000
         begin <<case statement>>                              <<sd.00>>16295000
            ioutbuf:=0; <<no parameter sought>>                <<sd.00>>16300000
            begin <<numeric parm sought>>                      <<sd.00>>16305000
            ioutbuf:=0; <<accumulator>>                        <<sd.00>>16310000
            while btbuf(i:=i+1)<>%54 do                        <<sd.00>>16315000
               begin <<convert # to binary>>                   <<sd.00>>16320000
               if btbuf(i)<%60 or btbuf(i)>%71 then resp:=invalid;      16325000
               if ioutbuf<3276 then                            <<sd.00>>16330000
                  ioutbuf:=ioutbuf*10+integer(btbuf(i))-%60    <<sd.00>>16335000
               else                                            <<sd.00>>16340000
                  resp:=invalid;                               <<sd.00>>16345000
               end;  <<convert # to binary>>                   <<sd.00>>16350000
            end;  <<numeric parm sought>>                      <<sd.00>>16355000
            begin <<yes/no>>                                   <<sd.00>>16360000
            if resp=okay then                                  <<sd.00>>16365000
               begin <<set return value for yes/no>>           <<sd.00>>16370000
               resp:=invalid;                                  <<sd.00>>16375000
               if btbuf(i+1)="Y," or btbuf(i+1)="YES," then    <<sd.00>>16380000
                  begin <<valid yes parm>>                     <<sd.00>>16385000
                  resp:=okay;                                  <<sd.00>>16390000
                  ioutbuf:=-1; <<true>>                        <<sd.00>>16395000
                  end;  <<valid yes parm>>                     <<sd.00>>16400000
               if btbuf(i+1)="N," or btbuf(i+1)="NO," then     <<sd.00>>16405000
                  begin <<valid no parm>>                      <<sd.00>>16410000
                  resp:=okay;                                  <<sd.00>>16415000
                  ioutbuf:=0; <<false>>                        <<sd.00>>16420000
                  end;  <<valid no parm>>                      <<sd.00>>16425000
               end;  <<set return value for yes/no>>           <<sd.00>>16430000
            end;  <<yes/no>>                                   <<sd.00>>16435000
            begin <<string response sought>>                   <<sd.00>>16440000
            ioutbuf:=tbuf-i+1; <<length of string>>            <<sd.00>>16445000
            move outbuf(2):=btbuf(i+1),(tbuf-i+1);             <<sd.00>>16450000
            end;  <<string parm sought>>                       <<sd.00>>16455000
         end;  <<case statement>>                              <<sd.00>>16460000
      end   <<parameter entered by operator>>                  <<sd.00>>16465000
   else                                                        <<sd.00>>16470000
      begin <<no parm entered by op>>                          <<sd.00>>16475000
      if ptype>0 then ioutbuf:=0; <<defaults are:>>            <<sd.00>>16480000
                                  <<numeric- 0   >>            <<sd.00>>16485000
                                  <<yes/no-  no  >>            <<sd.00>>16490000
                                  <<string-  none>>            <<sd.00>>16495000
      end;  <<no parm entered by op>>                          <<sd.00>>16500000
   end;  <<operator response has valid syntax>>                <<sd.00>>16505000
end;  <<parseparm>>                                            <<sd.00>>16510000
$page                                                          <<00552>>16515000
logical subroutine chkass(ldev);                               <<00552>>16520000
value ldev;                                                    <<00552>>16525000
integer ldev;                                                  <<00552>>16530000
begin                                                          <<00552>>16535000
   lock'ass'table;                                             <<01647>>16540000
   movefromdseg (@assoc, ass'dst, ldev * ass'entrysize,        <<06730>>16545000
                 ass'entrysize);                               <<06730>>16550000
   free'ass'table;                                             <<01647>>16555000
   move blclassname:=blclassname while an,1;                   <<00552>>16560000
   classlen:=tos-@blclassname;                                 <<00552>>16565000
   if assoc(ass'jit)<>0 and                                    <<00552>>16570000
      assoc'(ass'class*2)<>blclassname,(classlen) then         <<00552>>16575000
      chkass:=true                                             <<00552>>16580000
   else chkass:=false;                                         <<00552>>16585000
end;                                                           <<00552>>16590000
$page                                                          <<00552>>16595000
   <<********* set optional parm values ***************>>      <<sd.00>>16600000
   move blankbuf:=%40,%0; <<default input buffer>>             <<sd.00>>16605000
   if q4.ptypebit=0 then ptype:=0;                             <<sd.00>>16610000
   if ptype>0 then                                             <<sd.00>>16615000
      if q4.strinbit=1 then @inbuf:=@strin;                    <<sd.00>>16620000
   if q4.responsebit=1 then @outbuf:=@response;                <<sd.00>>16625000
   @ioutbuf:=@outbuf&lsr(1);                                   <<sd.00>>16630000
   push (z);   << check for bank wraparound.                >> <<a8986>>16635000
   if tos < @ioutbuf then @ioutbuf.(0:1) := 1;                 <<a8986>>16640000
   @tbuf:=@btbuf&lsr(1);                                       <<sd.00>>16645000
   push (z);   << check for bank wraparound.                >> <<a8986>>16650000
   if tos < @tbuf then @tbuf.(0:1) := 1;                       <<a8986>>16655000
   if (classreq := reqdev<0) then                              <<06730>>16660000
      begin   <<get class entry>>                                       16665000
      entry'length := get'device'class (-reqdev,               <<06730>>16670000
                      entry'address);                          <<06730>>16675000
                                                               <<06730>>16680000
  comment -- we need to work with the list of  ldev's  in  our <<06730>>16685000
dct entry.  unfortunately, the length of the list is arbitrary <<06730>>16690000
and varies from entry to entry.  thus to make a local copy  of <<06730>>16695000
the entry, we must build space for it on the stack.  (we can't <<06730>>16700000
declare an array because the length is unknown at entry).      <<06730>>16705000
;                                                              <<06730>>16710000
      push (s);                                                <<06730>>16715000
      @dct := tos + 1;                                         <<06730>>16720000
      tos := entry'length;                                     <<06730>>16725000
      assemble (adds 0);                                       <<06730>>16730000
      movefromdseg (@dct, dct'dst, entry'address,              <<06730>>16735000
                    entry'length);                             <<06730>>16740000
      move lclassname := dct, (4);                             <<06730>>16745000
      blclassname(8) := " ";                                   <<06730>>16750000
      scan blclassname until "  ", 1;                          <<06730>>16755000
      bps0 := 0;   << genmsg termination character.         >> <<06730>>16760000
      end;   <<classreq>>                                               16765000
   spooldev:=q4.spoolerbits > 0;   <<spooler parms passed>>    <<sd.00>>16770000
   move lfname := fname, (4);                                           16775000
   blfname (8) := " ";                                                  16780000
   scan blfname until "  ", 1;                                 <<06730>>16785000
   bps0 := 0;      << genmsg termination character.         >> <<06730>>16790000
   if spooldev then                                                     16795000
      begin    << format job number >>                                  16800000
      bjobnumber :=                                                     16805000
            if jobnum.(0:2) = 1 then "S" else "J";                      16810000
      bjobnumber (ascii (jobnum.(2:14), 10, bjobnumber (1)) +1)         16815000
            := 0;                                                       16820000
      end;                                                              16825000
                                                               <<02566>>16830000
<< when a magtape has been configured for automatic >>         <<02566>>16835000
<< allocation, it means that operator intervention is not >>   <<02566>>16840000
<< required for fopens which specifically request that >>      <<02566>>16845000
<< device.  the caller will automatically be given that >>     <<02566>>16850000
<< device providing the following conditions are met:  >>      <<02566>>16855000
                                                               <<02566>>16860000
<< 1)  the ldev is configured as a magtape (type 24) and >>    <<02566>>16865000
<<     the subtype is greater than or equal to %10.      >>    <<02566>>16870000
<< 2)  the ldev is neither job nor data accepting.       >>    <<02566>>16875000
<< 3)  the fopen is for an unlabelled tape.              >>    <<02566>>16880000
<< 4)  the tape drive is not already allocated to        >>    <<02566>>16885000
<<     another user.                                     >>    <<02566>>16890000
<< 5)  for class requests, there can only be one ldev    >>    <<02566>>16895000
<<     in the class, and if the device is associated, it >>    <<02566>>16900000
<<     must be associated under the same class name.     >>    <<02566>>16905000
                                                               <<02566>>16910000
autoalloc := false;  << initialize flag >>                     <<02566>>16915000
                                                               <<02566>>16920000
if classreq and dct'num'devices = 1                            <<06730>>16925000
   and not chkass (dct(dct'first'ldev)) then                   <<06730>>16930000
  begin  <<only one device in this class>>                     <<tl.03>>16935000
  devtoconsider := dct(dct'first'ldev);                        <<06730>>16940000
  go to auto;                                                  <<tl.03>>16945000
  end;                                                         <<tl.03>>16950000
if not classreq then                                           <<tl.03>>16955000
  begin                                                        <<tl.03>>16960000
  devtoconsider:=reqdev;                                       <<tl.03>>16965000
auto:  <<possible automatically allocated device>>             <<tl.03>>16970000
    lpdt'index := devtoconsider * integer (lpdt'entry'size);   <<06730>>16975000
    if labeled = 1 and systapeavr = 1 then                     <<07050>>16980000
       go normal;       << labelled tape request >>            <<02566>>16985000
    if not getdev (devtoconsider, ldt'dst, ldt)                <<06730>>16990000
       then go normal;  << can't get ldt entry >>              <<02566>>16995000
    if not lpdt'auto'alloc then go normal;                     <<06730>>17000000
    if lpdt'job'accept or lpdt'data'accept then go normal;     <<06730>>17005000
    autoalloc := true;   << unique unlabelled device req.   >> <<a8986>>17010000
    resp:=okay;                                                <<tl.03>>17015000
normal: <<continue with normal processing>>                    <<tl.03>>17020000
    end;                                                       <<tl.03>>17025000
   do                                                                   17030000
      begin                                                             17035000
      resp:=okay;                                              <<01115>>17040000
      ioutbuf := 0;   << in case it was -1 last time.       >> <<a8986>>17045000
      if autoalloc then                                        <<a8986>>17050000
         begin  << see if ptype is consistent w/ auto alloc >> <<a8986>>17055000
         case ptype of                                         <<a8986>>17060000
            begin                                              <<a8986>>17065000
                                                               <<a8986>>17070000
            ;                     << 0 -- no parm request.  >> <<a8986>>17075000
            autoalloc := false;   << 1 -- retn is numeric,  >> <<a8986>>17080000
                                  <<      op must provide.  >> <<a8986>>17085000
            ioutbuf := true;      << 2 -- retn is y/n ==> y >> <<a8986>>17090000
            autoalloc := false;   << 3 -- retn is string,   >> <<a8986>>17095000
                                  <<      op must provide.  >> <<a8986>>17100000
            end;    << case statement.                      >> <<a8986>>17105000
         if <<still>> autoalloc then go checkdev;              <<a8986>>17110000
         end;   << see if ptype is consistent w/ auto alloc >> <<a8986>>17115000
      if classreq then                                                  17120000
         begin                                                          17125000
         if spooldev then                                               17130000
            genmsg(1,211,%10000,spoolernum,@bjobnumber,        <<0u.eb>>17135000
                @blfname,@blclassname,,assoc'class(lclassname),<<00552>>17140000
                0,@answer)                                     <<00552>>17145000
         else                                                           17150000
begin                                                          <<tl.02>>17155000
  if labeled =1 and systapeavr = 1 then go labtape;            <<07050>>17160000
            if ptype=0 then                                    <<sd.00>>17165000
               genmsg(1,6,%0,@blfname,@blclassname,,,,         <<sd.00>>17170000
                assoc'class(lclassname),0,@answer) <<no parm re<<00552>>17175000
            else                                               <<sd.00>>17180000
               begin <<parm type request>>                     <<sd.00>>17185000
               genmsg(1,276,0,@blfname,@blclassname,@inbuf,,,  <<sd.00>>17190000
                assoc'class(lclassname),%15402,@tbuf);<<parm re<<00552>>17195000
               parseparm;                                      <<sd.00>>17200000
               end;  <<parm type request>>                     <<sd.00>>17205000
end;                                                           <<tl.02>>17210000
     if resp=okay then                                         <<01115>>17215000
       begin                                                   <<01115>>17220000
         if answer = 0 then                                             17225000
            resp := rejected                                   <<06730>>17230000
         else                                                           17235000
            begin   <<see if answer is in class>>                       17240000
            i := dct'first'ldev - 1;                           <<06730>>17245000
            while (i := i+1) - dct'first'ldev <                <<06730>>17250000
                  integer (dct'num'devices) do                 <<06730>>17255000
               if answer = integer (dct(i)) then               <<06730>>17260000
               if chkass (integer (dct(i))) then               <<06730>>17265000
               begin                                           <<00552>>17270000
                  assoc(ass'class+4):=0; <<for genmsg>>        <<00552>>17275000
                  genmsg(1,301,[1/0,3/1,3/0,9/0],answer,       <<00552>>17280000
                         @assoc'(ass'class*2),,,,              <<00552>>17285000
                  assoc'class(lclassname),,,,1);               <<00552>>17290000
               end                                             <<00552>>17295000
               else                                            <<00552>>17300000
                  i := %77770;   <<stop loop>>                 <<06730>>17305000
            if i - dct'first'ldev = integer (dct'num'devices)  <<06730>>17310000
               then resp := invalid                            <<06730>>17315000
            else resp := okay;                                 <<06730>>17320000
            end;                                                        17325000
       end;                                                    <<01115>>17330000
         devtoconsider := answer;                              <<06730>>17335000
         end   <<classreq>>                                             17340000
      else                                                              17345000
         begin   <<particular device request>>                          17350000
         if spooldev then                                               17355000
            genmsg(1,212,%10010,spoolernum,@bjobnumber,        <<0u.eb>>17360000
               @blfname,reqdev,,0,1,@answer)                   <<0u.eb>>17365000
         else                                                           17370000
 begin                                                         <<tl.02>>17375000
  if labeled =1 and systapeavr = 1 then  <<labelled tape>>     <<07050>>17380000
  begin                                                        <<tl.02>>17385000
labtape:                                                       <<tl.02>>17390000
    << if user made a specific ldev request, tell linklabel >> <<02566>>17395000
    if classreq then  ldevn := 0                               <<02566>>17400000
                else  ldevn := devtoconsider;                  <<02566>>17405000
    resp:=linklabel(ldevn,access);                             <<tl.02>>17410000
    devtoconsider:=ldevn;                                      <<tl.02>>17415000
    go gotdev;                                                 <<tl.02>>17420000
  end                                                          <<tl.02>>17425000
  else                                                         <<tl.02>>17430000
  begin  <<no label>>                                          <<tl.02>>17435000
            if ptype=0 then                                    <<sd.00>>17440000
            genmsg(1,5,%01000,@blfname,reqdev,,,,0,1,          <<0u.eb>>17445000
               @answer) <<no parm requested>>                  <<sd.00>>17450000
            else                                               <<sd.00>>17455000
              begin <<parm type request>>                      <<sd.00>>17460000
              genmsg(1,275,%1000,@blfname,reqdev,              <<sd.00>>17465000
              @inbuf,,,0,%14002,@tbuf);                        <<sd.00>>17470000
              parseparm;                                       <<sd.00>>17475000
              end;  <<parm type request>>                      <<sd.00>>17480000
  end;                                                         <<tl.02>>17485000
 end;                                                          <<tl.02>>17490000
         if resp=okay then                                     <<01115>>17495000
            resp := if logical(answer) then okay else rejected;<<01115>>17500000
         devtoconsider := reqdev;                              <<06730>>17505000
         end;   <<device req>>                                          17510000
checkdev: <<check for valid dev>>                              <<tl.03>>17515000
gotdev:                                                        <<tl.02>>17520000
      save'ldt'sir := getsir (ldt'sir);                        <<06730>>17525000
      save'lpdt'sir := getsir (lpdt'sir);                      <<06730>>17530000
      lpdt'index := devtoconsider * integer (lpdt'entry'size); <<06730>>17535000
      if resp = okay then                                               17540000
         if not getdev (devtoconsider, ldt'dst, ldt) then      <<06730>>17545000
            resp := invalid;                                   <<06730>>17550000
      if resp = okay then                                               17555000
         begin                                                          17560000
         if ldt'down'pending or not ldt'avail'to'sys then      <<06730>>17565000
            resp := invalid;   <<down or down pending>>        <<06730>>17570000
         if lpdt'virtual'device then                           <<06730>>17575000
            resp := invalid;   <<vdev or non-existent>>        <<06730>>17580000
                                                               <<06730>>17585000
<< if device is in a foreign disc class, check that a  for- >> <<06730>>17590000
<< eign disc is actually mounted on it.                     >> <<06730>>17595000
                                                               <<03770>>17600000
         if resp=okay and classreq and                         <<01115>>17605000
            dct'class'acc'type = ldt'foreign'disc then         <<06730>>17610000
                if not lpdt'rdy'ser'frn'disc or                <<06730>>17615000
                   lpdt'serial'or'foreign <> lpdt'foreign      <<06730>>17620000
            then  <<not foreign>>                              <<01115>>17625000
              begin                                            <<01115>>17630000
              genmsg(1,272,%10000,devtoconsider,,,,,0);        <<01115>>17635000
              resp:=invalid;                                   <<01115>>17640000
              end;                                             <<01115>>17645000
<< we will check for a "labeled" serial disc or tape here   >> <<03788>>17650000
<< since the indentation is screwed up already, we will     >> <<03788>>17655000
<< persist with the tradition (after all we need tradition!)>> <<03788>>17660000
<< additionally, we will not accept a reply in which the ldev>><<03788>>17665000
<< has a pv at this time (for both class and ldev requests). >><<03788>>17670000
                                                               <<03788>>17675000
check'for'avr := false;      << default no check >>            <<03788>>17680000
                                                               <<03788>>17685000
if resp=okay then                                              <<03788>>17690000
begin   << set check'for'avr if tape or serial disc.        >> <<06730>>17695000
    if ldt'device'type = ldt'mag'tape                          <<06730>>17700000
      then check'for'avr := true                               <<03788>>17705000
                                                               <<03788>>17710000
      else        << not a tape >>                             <<03788>>17715000
      begin                                                    <<03788>>17720000
        dstat'ret := reqstatus(devtoconsider);                 <<03788>>17725000
        if =  then   << = means disc device >>                 <<03788>>17730000
          if not on'line then                                  <<03788>>17735000
           begin                                               <<03788>>17740000
              resp := invalid;                                 <<03788>>17745000
              genmsg(1,292,%10000,devtoconsider,,,,,0);        <<03788>>17750000
              << ldev# \ must be on-line before replying>>     <<03788>>17755000
           end                                                 <<03788>>17760000
          else   << an on-line disc.                        >> <<06730>>17765000
            if lpdt'rdy'ser'frn'disc then                      <<07229>>17770000
               begin  << foreign or serial disc.            >> <<07229>>17775000
               if lpdt'serial'or'foreign = lpdt'serial         <<07229>>17780000
                  then check'for'avr := true                   <<07229>>17785000
               end                                             <<07229>>17790000
            else      << neither foreign or serial, invalid!>> <<07229>>17795000
               resp := invalid;                                <<07229>>17800000
     end; << not a tape >>                                     <<03788>>17805000
 end;  << check for tape/serial disc >>                        <<03788>>17810000
           if resp=okay and check'for'avr                      <<03788>>17815000
            and labeled <> 1 and systapeavr = 1 then           <<07050>>17820000
            begin                                              <<tl.03>>17825000
             relsir (lpdt'sir, save'lpdt'sir);                 <<06730>>17830000
             relsir (ldt'sir, save'ldt'sir);                   <<06730>>17835000
             if ckforldev(devtoconsider) or                    <<06027>>17840000
                ckforexdate(devtoconsider,access,0)            <<06027>>17845000
             then resp:=invalid;                               <<tl.03>>17850000
             save'ldt'sir := getsir (ldt'sir);                 <<06730>>17855000
             save'lpdt'sir := getsir (lpdt'sir);               <<06730>>17860000
            end;                                               <<tl.03>>17865000
         end;                                                           17870000
                                                               <<03698>>17875000
      if resp = okay and (not spooldev) then                            17880000
         begin                                                          17885000
         if oldflag and lpdt'data'accept then                  <<06730>>17890000
            resp := olddata                                    <<06730>>17895000
         else                                                           17900000
            begin                                                       17905000
            disable;                                                    17910000
          if labeled =1 and systapeavr = 1 then go labok;      <<07050>>17915000
            if lpdt'dev'own'state <> lpdt'not'owned then       <<06730>>17920000
               begin   <<owned>>                                        17925000
               enable;                                                  17930000
               if classreq then                                         17935000
                  resp := invalid                              <<06730>>17940000
               else                                                     17945000
                  begin                                                 17950000
                  if jmpin = integer (ldt'main'pin) then       <<06730>>17955000
                     resp := realloc   <<owned by caller>>     <<06730>>17960000
                  else                                                  17965000
                     resp := invalid;                          <<06730>>17970000
                  end;                                                  17975000
               end                                                      17980000
            else                                                        17985000
               begin   <<unowned>>                                      17990000
labok:                                                         <<tl.02>>17995000
               lpdt'dev'own'state := lpdt'reserved;            <<06730>>18000000
               enable;                                                  18005000
               end;                                                     18010000
            end;                                                        18015000
         end;                                                           18020000
      relsir (lpdt'sir, save'lpdt'sir);                        <<06730>>18025000
      relsir (ldt'sir, save'ldt'sir);                          <<06730>>18030000
     autoalloc:=false; <<if failed autoalloc ask op>>          <<tl.03>>18035000
      end until resp<>invalid;                                          18040000
   if resp <> rejected then                                             18045000
      begin                                                             18050000
      askop := true;                                           <<06730>>18055000
      allocdev := devtoconsider;                               <<06730>>18060000
      type := resp;                                            <<06730>>18065000
      end;                                                              18070000
   end;   <<askop>>                                                     18075000
$page "   ***   ALLOCATE -- Local variable definition   ***"   <<06730>>18080000
$control segment = allocate                                    <<06730>>18085000
                                                               <<06730>>18090000
integer procedure allocate (indx, old, outpri, id, jmpin,      <<06730>>18095000
                  formsg, jnum, copies, devinfo,               <<06730>>18100000
                  return'xdd'address, flags);                  <<06730>>18105000
    value indx, old, outpri, jmpin, jnum, copies;              <<06730>>18110000
    integer indx, outpri, jmpin, flags, jnum, copies;          <<06730>>18115000
    logical old;                                                        18120000
    integer array id, devinfo;                                 <<06730>>18125000
    integer pointer return'xdd'address;                        <<06730>>18130000
    byte array formsg;                                                  18135000
    option privileged, uncallable;                             <<06730>>18140000
         <<real and virtual device allocation for all non-disk devices>>18145000
         <<input:                                                     >>18150000
         <<      indx > 0           - logical device #                >>18155000
         <<           < 0           - device class index              >>18160000
         <<      old = true         - old device                      >>18165000
         <<          = false        - new device                      >>18170000
         <<      outpri             - output spool priority           >>18175000
         <<      id                 - user name,acct.name,job name,   >>18180000
         <<                            file name (4 words apiece) >>    18185000
         <<      jmpin              - job main process #              >>18190000
         <<      flags            - (0:8)= flags            >> <<tl.02>>18195000
         <<      labeled          - flags.(7:1)             >> <<tl.02>>18200000
         <<      stdin'list       - flags.(13:1)            >> <<06084>>18205000
         <<      access           - flags.(14:2)            >> <<tl.02>>18210000
         <<      jnum               - job #                           >>18215000
         <<      formsg             - forms msg. string terminated by >>18220000
         <<                            a period. (supplied by user)   >>18225000
         <<      access = 0         - input only                      >>18230000
         <<             = 1         - output only                     >>18235000
         <<             = 2         - input/output                    >>18240000
         <<                                                           >>18245000
         <<output:                                                    >>18250000
         <<      allocate = 0       - ok, it's yours                  >>18255000
         <<               = -1      - ok, but there're forms on dev   >>18260000
         <<                           (only for initial $stdlist)     >>18265000
         <<               = -2      - new or realloc :data            >>18270000
         <<               = -3      - ok, spooled class request<<00635>>18275000
         <<               = 1       - dev.(or vdev) not available     >>18280000
         <<               = 3       - nd capability required          >>18285000
         <<               = 4       - vdev requested not owned        >>18290000
         <<               = 5       - couldn't get spoofle  >> <<06730>>18295000
         <<                             extent.             >> <<06730>>18300000
         <<               = 6       - access violation                >>18305000
         <<               = 7       - no room in xdd                  >>18310000
         <<               = 8       - couldn't get sdisc xds>> <<s7474>>18315000
         <<      accessparm         - may be changed from 2 to 0 or 1 >>18320000
         <<      devinfo(0)         - ldev or vdev allocated          >>18325000
         <<             (1)-(2)     - lpdt entry                      >>18330000
         <<             (3)-(7)     - ldt entry                       >>18335000
         <<      return'xdd'address - adr. of xdd entry     >> <<06730>>18340000
         <<     note: db must be at stack - same on exit.             >>18345000
   begin                                                                18350000
   equate yes'no=2; <<for yes/no parm from operator>>          <<sd.00>>18355000
   equate                                                      <<06730>>18360000
      ok'spooled'class       = -3,   << allocate returns.   >> <<06730>>18365000
      new'or'realloc'data    = -2,                             <<06730>>18370000
      ok'special'forms       = -1,                             <<06730>>18375000
      device'allocated       =  0,   << normal return.      >> <<06730>>18380000
      device'unavailable     =  1,   << boo, hiss.          >> <<06730>>18385000
           << 2 not used.                                   >> <<06730>>18390000
      no'nd'capability       =  3,                             <<06730>>18395000
      virtual'devc'not'yours =  4,                             <<06730>>18400000
      no'spoofle'extent      =  5,                             <<06730>>18405000
      in'out'spec'error      =  6,                             <<06730>>18410000
      no'room'in'xdd         =  7,                             <<06730>>18415000
      no'sdisc'xds           =  8,                             <<s7474>>18420000
                                                               <<06730>>18425000
      inputonly   = 0,     << part of flags,                >> <<06730>>18430000
      outputonly  = 1,     <<   from fopen aoptions.        >> <<06730>>18435000
                                                               <<06730>>18440000
      no'match    = 0,     << for subroutine scanxdd.       >> <<06730>>18445000
      close'match = 1,                                         <<06730>>18450000
      exact'match = 2,                                         <<06730>>18455000
                                                               <<06730>>18460000
      open        =  true, << also for scanxdd.             >> <<06730>>18465000
      ready       = false,                                     <<06730>>18470000
                                                               <<06730>>18475000
      gotready    = 0,     << for old file processing.      >> <<06730>>18480000
      gotopened   = 1,                                         <<06730>>18485000
      tryopened   = 2,                                         <<06730>>18490000
      tryready    = 3;                                         <<06730>>18495000
                                                               <<06730>>18500000
   equate page'printer = 8;                                    <<06730>>18505000
                                                               <<06730>>18510000
<< the following two declarations are required by the pxglo->> <<06730>>18515000
<< bal $include file.  see comments there for details.      >> <<06730>>18520000
                                                               <<06730>>18525000
    logical array                                              <<06730>>18530000
       qarray(*) = q + 0;                                      <<06730>>18535000
                                                               <<06730>>18540000
    integer                                                    <<06730>>18545000
       pcbglobloc;    << required by pxglobal $include file >> <<06730>>18550000
                                                               <<02540>>18555000
   integer                                                              18560000
         i,j,k,                                                         18565000
         ldt'index := 0,                                       <<06730>>18570000
         ldtx'index := 0,                                      <<06730>>18575000
         lpdt'index,                                           <<06730>>18580000
         lpdt'entry,                                           <<06730>>18585000
         xdd'dst,                                              <<06730>>18590000
         xdd'sir,                                              <<06730>>18595000
         best'so'far,   << near match flag for scanxdd.     >> <<06730>>18600000
         allocdev,   <<ldev or vdev allocated>>                         18605000
         devtype,   <<device type (or class type)>>                     18610000
         nextdev,   <<used as ldev when humping through devs.in class>> 18615000
         entry'address,  << dct-rel. addr of dct entry.     >> <<06730>>18620000
         entry'length,   << of device class table entry.    >> <<06730>>18625000
         this'ldev,      << current ldev in dct list.       >> <<06730>>18630000
         tryflag,   <<beats me>>                                        18635000
         replytype,   <<type returned by askop>>                        18640000
         fmsglgth  := 0,                                                18645000
         trydev,                                                        18650000
         numcopies  := 0;    <<#copies caller will get>>       <<06730>>18655000
                                                               <<06730>>18660000
    logical array                                              <<06730>>18665000
       ldt(0:size'of'ldt'entry-1),                             <<06730>>18670000
       ldtx(0:size'of'ldtx'entry-1),                           <<06730>>18675000
       xdd(*) = db + 0;   << required by xdd $include file. >> <<06730>>18680000
    logical pointer                                            <<06730>>18685000
       ucapptr, << required by the inclcap $include file.   >> <<06730>>18690000
       dct;     << device class tbl entry is built on stack.>> <<06730>>18695000
                                                               <<06730>>18700000
   define access     = flags.(14:2)#,                          <<06084>>18705000
          stdin'list = logical(flags.(13:1))#;                 <<06084>>18710000
   define labeled=logical(flags.(7:1))#;                       <<00677>>18715000
   logical sorfdisc:=false; <<allocating ser/forn disc>>       <<01115>>18720000
   equate initarraysize=5;                                     <<03512>>18725000
          <<**warning** changing initarraysize will require>>  <<sd.00>>18730000
          <<same change in sdiscio>>                           <<sd.00>>18735000
   equate justallocated'adr=7; <<changng this>>                <<00076>>18740000
          <<will require same change in sdisc>>                <<00076>>18745000
   equate justalloccell=0, <<cells in the init>>               <<00239>>18750000
          writeringcell=1, <<array for sdisc>>                 <<00239>>18755000
          fatalerrcell =2, <<extra data seg>>                  <<03512>>18760000
          errorlogcell =3,                                     <<03512>>18765000
          memsizecell  =4;                                     <<03512>>18770000
   integer array tempdesc(0:initarraysize-1); <<sdisc descrip>><<sd.00>>18775000
   integer segnum := 0,                                        <<s7474>>18780000
           savetype;                                           <<f7676>>18785000
   byte array mess(0:18); <<message for serial disc>>          <<sd.00>>18790000
   logical spoolflag;                                          <<00635>>18795000
   logical                                                     <<06730>>18800000
         qlogical:=%140000; <<bitmap of logical variables>>    <<00.dl>>18805000
         <<initial:=true>>                                     <<00.dl>>18810000
         <<reald:=true>>                                       <<00.dl>>18815000
         <<all else:=false>>                                   <<00.dl>>18820000
   define                                                      <<00.dl>>18825000
         initial=qlogical.(0:1)#, <<initial allocation>>       <<00.dl>>18830000
         reald=qlogical.(1:1)#, <<real device>>                <<00.dl>>18835000
         ndcap=qlogical.(2:1)#, <<user has nd capability>>     <<00.dl>>18840000
         <<** unused **>>                                      <<00.dl>>18845000
         <<** unused **>>                                      <<00.dl>>18850000
         <<** unused **>>                                      <<00.dl>>18855000
         classreq=qlogical.(6:1)#, <<request is by class>>     <<00.dl>>18860000
         oldreq=qlogical.(7:1)#, <<old device request>>        <<00.dl>>18865000
         restart=qlogical.(8:1)#,                              <<00.dl>>18870000
         formsflag=qlogical.(9:1)#,                            <<00.dl>>18875000
         opflag=qlogical.(10:1)#, <<operator intervention>>    <<00.dl>>18880000
         askforms=qlogical.(11:1)#,                            <<00.dl>>18885000
         opreqd=qlogical.(12:1)#, <<op intervention req'd>>    <<00.dl>>18890000
         updatexdd=qlogical.(13:1)#, <<xdd must be or has>>    <<00.dl>>18895000
                                     <<been updated>>          <<00.dl>>18900000
         gotsext=qlogical.(14:1)#, <<got spool extent>>        <<00.dl>>18905000
         freserved=qlogical.(15:1)#; <<ss has been set to 3>>  <<00.dl>>18910000
                                                               <<06730>>18915000
   define                                                      <<06730>>18920000
         ownedbycaller = jmpin = integer (ldt'main'pin) and    <<06730>>18925000
                         (lpdt'dev'own'state = lpdt'owned      <<06730>>18930000
                            or ldtx'serial'or'foreign)#;       <<06730>>18935000
                                                               <<06730>>18940000
   logical                                                     <<06730>>18945000
      found'it,       << flag for match in scanxdd.         >> <<06730>>18950000
      job'type,       << funct. compat. for jnum parm.      >> <<06730>>18955000
      save'ldt'sir,                                            <<06730>>18960000
      save'ldtx'base,                                          <<06730>>18965000
      save'dct'sir,                                            <<06730>>18970000
      save'lpdt'sir,                                           <<06730>>18975000
      save'xdd'sir;                                            <<06730>>18980000
   logical locked := false;  << lock drive flag >>             <<03546>>18985000
   logical pointer                                             <<06730>>18990000
      close'idd'subentry,      << see comments in old req.  >> <<06730>>18995000
      save'subentry'address,   << see comments in scanxdd.  >> <<06730>>19000000
      xdd'address := 0,        << segment-relative offset   >> <<06730>>19005000
                               <<   of chosen subentry.     >> <<06730>>19010000
      xdd'compare'id,          << see comments in scanxdd.  >> <<06730>>19015000
      xdd'head;                << req'd by xdd $include file>> <<06730>>19020000
   logical array                                               <<06730>>19025000
         usern(*) = id(0),                                     <<04973>>19030000
         accnt(*) = id(4),                                     <<04973>>19035000
         jobn(*)  = id(8),                                     <<04973>>19040000
         fname(*) = id(12),                                    <<04973>>19045000
         qid(0:15) = q,   <<local version of id>>                       19050000
                                                               <<06730>>19055000
<< the following two arrays hold local copies of an xdd sub->> <<06730>>19060000
<< entry.  xdd'subentry must be an indirect array (see com- >> <<06730>>19065000
<< ments in scanxdd).  save'xdd'subentry holds a near match >> <<06730>>19070000
<< subentry (see comments in the old request processor)  in >> <<06730>>19075000
<< case an exact match can't be found.                      >> <<06730>>19080000
                                                               <<06730>>19085000
         xdd'subentry(0:size'of'xdd'subentry-1),               <<06730>>19090000
         save'xdd'subentry(0:size'of'xdd'subentry-1);          <<06730>>19095000
                                                               <<06730>>19100000
   double array                                                <<06730>>19105000
         xdd'dsubentry(*) = xdd'subentry;  << req'd symbol. >> <<06730>>19110000
                                                               <<06730>>19115000
subroutine def'movefromdseg;                                   <<06730>>19120000
                                                               <<06730>>19125000
subroutine def'movetodseg;                                     <<06730>>19130000
                                                                        19135000
$page "   ***   ALLOCATE -- Subroutine CREATESUBENTRY   ***"   <<06730>>19140000
subroutine createsubentry;                                     <<06730>>19145000
                                                               <<06730>>19150000
begin comment --                                               <<06730>>19155000
  createsubentry is the first of three steps required to get a <<06730>>19160000
new subentry entered into the xdd.  this step assumes the  ex- <<06730>>19165000
istence and availability of a local subentry image, xdd'suben- <<06730>>19170000
try.  it zeros out the image (thereby satisfying the  require- <<06730>>19175000
ments  of a non-spoolfile subentry), then fills in some of the <<06730>>19180000
fields. the second step, performed by allocate, fills in other <<06730>>19185000
areas of the image. finally, allocate calls sputxdd (the third <<06730>>19190000
step), which fills in even more, allocates space in  the  xdd, <<06730>>19195000
and moves the image in.                                        <<06730>>19200000
                                                               <<06730>>19205000
special considerations:  db must be at the stack.              <<06730>>19210000
;                                                              <<06730>>19215000
                                                               <<06730>>19220000
updatexdd := true;                                             <<06730>>19225000
                                                               <<06730>>19230000
<< zero out the image first.                                >> <<06730>>19235000
                                                               <<06730>>19240000
xdd'subentry := 0;                                             <<06730>>19245000
move xdd'subentry(1) := xdd'subentry, (size'of'xdd'subentry-1);<<06730>>19250000
                                                               <<06730>>19255000
if oldreq then                                                 <<06730>>19260000
   begin                                                       <<06730>>19265000
   xdds'spool'state := xdds'ready;                             <<06730>>19270000
   xdds'output'priority := 0;                                  <<06730>>19275000
   end                                                         <<06730>>19280000
else                                                           <<06730>>19285000
   begin   << new file.                                     >> <<06730>>19290000
   xdds'spool'state := xdds'open;                              <<06730>>19295000
   xdds'output'priority := outpri;                             <<06730>>19300000
   end;                                                        <<06730>>19305000
if reald then                                                  <<06730>>19310000
   begin   << real device.                                  >> <<06730>>19315000
   xdds'class := false;                                        <<06730>>19320000
   xdds'device := allocdev;                                    <<06730>>19325000
   end                                                         <<06730>>19330000
else                                                           <<06730>>19335000
   begin   << virtual device (spoolfile).                   >> <<06730>>19340000
   xdds'class := (indx < 0);                                   <<06730>>19345000
   xdds'device := \indx\;                                      <<06730>>19350000
   xdds'virtual'ldev := allocdev;                              <<06730>>19355000
   if not oldreq then odds'number'copies := numcopies;         <<06730>>19360000
   end;                                                        <<06730>>19365000
xdds'job'number := jnum;                                       <<06730>>19370000
xdds'job'type := job'type;                                     <<06730>>19375000
                                                               <<06730>>19380000
<< note:  the following statement depends  heavily  on  the >> <<06730>>19385000
<< internal  structure  of  the table and the format of the >> <<06730>>19390000
<< data passed in allocate's id parameter, namely that  the >> <<06730>>19395000
<< user,  account,  job and file name fields are four words >> <<06730>>19400000
<< each and are contiguous in the order named.              >> <<06730>>19405000
                                                               <<06730>>19410000
move xdds'user'name := id, (16);                               <<06730>>19415000
odds'forms'in'file := (fmsglgth <> 0);                         <<06730>>19420000
end;   << of createsubentry.                                >> <<06730>>19425000
$page "   ***   ALLOCATE -- Subroutine GETVDEV   ***"          <<06730>>19430000
integer subroutine getvdev;                                             19435000
   begin                                                                19440000
   getvdev := 0;                                                        19445000
   lpdt'entry := 0;                                            <<06730>>19450000
   while (lpdt'entry := lpdt'entry + 1) <=                     <<06730>>19455000
         integer (lpdt'max'entries) do                         <<06730>>19460000
      begin   << step through looking for avail. virt. dev. >> <<06730>>19465000
      lpdt'index := lpdt'entry * integer (lpdt'entry'size);    <<06730>>19470000
      if lpdt'virtual'device then                              <<06730>>19475000
         begin  <<vdev>>                                                19480000
         disable;                                                       19485000
         if lpdt'dev'own'state = lpdt'not'owned then           <<06730>>19490000
            begin                                                       19495000
            lpdt'dev'own'state := lpdt'reserved;               <<06730>>19500000
            enable;                                                     19505000
            getvdev := lpdt'entry;                             <<06730>>19510000
            freserved := true;                                 <<06730>>19515000
            lpdt'entry := lpdt'max'entries + 1;                <<06730>>19520000
            end;                                                        19525000
         enable;                                                        19530000
         end;                                                           19535000
      end;    << step through table...                      >> <<06730>>19540000
   end;  <<getvdev>>                                                    19545000
                                                                        19550000
$page "   ***   ALLOCATE -- Subroutine GETLDT'LPDT   ***"      <<06730>>19555000
logical subroutine getldt'lpdt (ldev);                         <<06730>>19560000
   value   ldev;                                               <<06730>>19565000
   integer ldev;                                               <<06730>>19570000
                                                               <<06730>>19575000
begin comment --                                               <<06730>>19580000
  returns ldt and ldtx entries  to  local  arrays.  tests  for <<06730>>19585000
valid lpdt entry.  device type field in local ldt entry is re- <<06730>>19590000
placed by serial disc or foreign disc access type if  applica- <<06730>>19595000
ble.                                                           <<06730>>19600000
;                                                              <<06730>>19605000
getldt'lpdt := false;                                          <<06730>>19610000
movefromdseg (@ldt, ldt'dst, 0, size'of'ldt'entry);            <<06730>>19615000
lpdt'index := (lpdt'entry := ldev) * integer (lpdt'entry'size);<<06730>>19620000
save'ldtx'base := ldtx'base;                                   <<06730>>19625000
movefromdseg (@ldtx, ldt'dst, integer (save'ldtx'base) +       <<06730>>19630000
   lpdt'entry * size'of'ldtx'entry, size'of'ldtx'entry);       <<06730>>19635000
                                                               <<06730>>19640000
<< the getdev calls return table entries and make some mys- >> <<06730>>19645000
<< terious validity check.  because we now use system table >> <<06730>>19650000
<< pointers, we don't need the local lpdt entry (it goes in >> <<06730>>19655000
<< the ldt entry because getdev needs someplace to put it). >> <<06730>>19660000
<< we retain its getdev call just in case someone somewhere >> <<06730>>19665000
<< needs it.                                                >> <<06730>>19670000
                                                               <<06730>>19675000
if getdev (ldev, lpdt'dst, ldt) then                           <<06730>>19680000
   if getdev (ldev, ldt'dst, ldt) then                         <<06730>>19685000
      begin                                                    <<06730>>19690000
      getldt'lpdt := true;                                     <<06730>>19695000
      savetype := ldt'device'type;   << may change, next.   >> <<f7676>>19700000
      if classreq then ldt'device'type := dct'class'acc'type   <<f7676>>19705000
      else if ldt'access'type = ldt'direct'access              <<f7676>>19710000
         and lpdt'not'pv'or'sys then                           <<06730>>19715000
         begin   << replace hdwe disc type w/ sdisc/fdisc.  >> <<06730>>19720000
         if lpdt'serial'or'foreign = lpdt'serial then          <<06730>>19725000
            ldt'device'type := ldt'serial'disc                 <<06730>>19730000
         else ldt'device'type := ldt'foreign'disc;             <<06730>>19735000
         end;                                                  <<06730>>19740000
      end;   << valid ldt, lpdt entries.                    >> <<06730>>19745000
end;         << of getldt'lpdt.                             >> <<06730>>19750000
                                                                        19755000
$page "   ***   ALLOCATE -- Subroutine ASK   ***"              <<06730>>19760000
subroutine ask;                                                         19765000
   begin                                                                19770000
   relsir (xdd'sir, save'xdd'sir);                             <<06730>>19775000
   relsir (lpdt'sir, save'lpdt'sir);                           <<06730>>19780000
   relsir (dct'sir, save'dct'sir);                             <<06730>>19785000
   relsir (ldt'sir, save'ldt'sir);                             <<06730>>19790000
   if ldt'device'type = ldt'serial'disc or                     <<06730>>19795000
      ldt'device'type = ldt'foreign'disc then                  <<06730>>19800000
      begin <<askop for sdisc and writering>>                  <<sd.00>>19805000
      move mess:=",WRITE RING? (Y/N)";                         <<sd.00>>19810000
      mess(18) := 0;                                           <<06730>>19815000
      if not askop (indx, fname, oldreq, allocdev,             <<06730>>19820000
      replytype,jmpin,,,flags,yes'no,mess,                     <<sd.00>>19825000
      tempdesc(writeringcell)) then                            <<00239>>19830000
         begin <<rejected sdisc>>                              <<sd.00>>19835000
         allocate := device'unavailable;                       <<06730>>19840000
         go bad3;                                              <<sd.00>>19845000
         end;                                                  <<sd.00>>19850000
         if tempdesc(writeringcell)=0 and                      <<01737>>19855000
            ldt'device'type = ldt'foreign'disc then            <<06730>>19860000
            access := inputonly;                               <<06730>>19865000
      end   <<askop for sdisc and writering>>                  <<sd.00>>19870000
   else                                                        <<sd.00>>19875000
   if not askop (indx, fname, oldreq, allocdev,                <<06730>>19880000
   replytype,jmpin,,,flags)  then                              <<00531>>19885000
      begin                                                             19890000
      allocate := device'unavailable;                          <<06730>>19895000
      go bad3;   <<rejected>>                                           19900000
      end;                                                              19905000
   if replytype = opassigned then                                       19910000
      freserved := true;   <<for failure unwind>>              <<06730>>19915000
   if replytype = realloc then                                          19920000
      initial := false;                                        <<06730>>19925000
   save'ldt'sir := getsir (ldt'sir);                           <<06730>>19930000
   save'dct'sir := getsir (dct'sir);                           <<06730>>19935000
   save'lpdt'sir := getsir (lpdt'sir);                         <<06730>>19940000
   getldt'lpdt (allocdev);                                              19945000
   save'xdd'sir := getsir (xdd'sir);                           <<06730>>19950000
   end;   <<ask>>                                                       19955000
$page "   ***   ALLOCATE -- Subroutine REJECTLDEV   ***"       <<06730>>19960000
logical subroutine rejectldev(trydev);                         <<02540>>19965000
   value trydev;                                               <<02540>>19970000
   integer trydev;                                             <<02540>>19975000
                                                               <<02540>>19980000
<< reject special cases of devices>>                           <<02540>>19985000
<< eg:  an unspooled 2680a (epoc) >>                           <<02540>>19990000
<<      page printer cannot be allocated>>                     <<02540>>19995000
<<      as a hot printer         >>                            <<02540>>20000000
begin                                                          <<02540>>20005000
                                                               <<02540>>20010000
<<>>                                                           <<02540>>20015000
   rejectldev := false;                                        <<02540>>20020000
   if ldt'device'type = ldt'printer and                        <<06730>>20025000
      lpdt'subtype = page'printer and                          <<06730>>20030000
      ldt'spool'state = ldt'not'spooled then                   <<06730>>20035000
      rejectldev := true;                                      <<02540>>20040000
end; <<rejectldev>>                                            <<02540>>20045000
                                                               <<02540>>20050000
$page "   ***   ALLOCATE -- Subroutine TRYNEWREALDEV   ***"    <<06730>>20055000
integer subroutine trynewrealdev(trydev);                               20060000
    value trydev;                                                       20065000
    integer trydev;                                                     20070000
         <<check specific device for up & unowned.                    >>20075000
         <<input:                                                     >>20080000
         <<      trydev             - log.dev.#                       >>20085000
         <<output:                                                    >>20090000
         <<      trynewrealdev = 0  - unavailable                     >>20095000
         <<                    = 1  - forms reqd.or forms mounted     >>20100000
         <<                    = 2  - mag.tape                        >>20105000
         <<                    = 3  - ok,ss set to 3,(reserved)       >>20110000
   begin                                                                20115000
   trynewrealdev := 0;                                         <<06730>>20120000
   lpdt'index := trydev * integer (lpdt'entry'size);           <<06730>>20125000
   if ldt'avail'to'sys then                                    <<06730>>20130000
      begin   <<up>>                                                    20135000
      if rejectldev(trydev) then return; <<unavail>>           <<02540>>20140000
   if ldt'special'forms or fmsglgth > 0 then                   <<06730>>20145000
      formsflag := true   << forms req'd or forms mounted.  >> <<06730>>20150000
   else formsflag := false;                                    <<06730>>20155000
      if fname <> "$S" then                                    <<06730>>20160000
         << never ask op for $stdlist, from allocate >>                 20165000
         if formsflag                                          <<06730>>20170000
            or ldt'device'type = ldt'mag'tape                  <<06730>>20175000
            or ldt'device'type = ldt'serial'disc               <<06730>>20180000
            or ldt'device'type = ldt'foreign'disc              <<06730>>20185000
            or classreq and                                    <<08840>>20190000
                   (dct'class'acc'type = ldt'serial'disc lor   <<06730>>20195000
                   dct'class'acc'type = ldt'foreign'disc)      <<08840>>20200000
            then opflag := true                                <<06730>>20205000
            else opflag := false;                              <<06730>>20210000
      disable;                                                          20215000
      if lpdt'dev'own'state = lpdt'not'owned then              <<06730>>20220000
         begin   <<up&unowned>>                                         20225000
         if not opflag then                                    <<06730>>20230000
            begin                                                       20235000
            lpdt'dev'own'state := lpdt'reserved;               <<06730>>20240000
            enable;                                                     20245000
            trynewrealdev := 3;   <<reserved>>                 <<06730>>20250000
            freserved := true;   <<for error unwinding>>       <<06730>>20255000
            if formsflag then   << devc needs or has forms. >> <<06730>>20260000
               allocate := ok'special'forms;                   <<06730>>20265000
            end                                                         20270000
         else                                                           20275000
            begin   <<can't reserve it>>                                20280000
            enable;                                                     20285000
            trynewrealdev := if formsflag then 1 else 2;       <<06730>>20290000
            end;                                                        20295000
         end                                                   <<04289>>20300000
         else                                                  <<04289>>20305000
         if ldt'device'type = ldt'mag'tape and                 <<06730>>20310000
            lpdt'dev'own'state = lpdt'owned then               <<06730>>20315000
            trynewrealdev := 2;                                <<06730>>20320000
      enable;                                                           20325000
      end;                                                              20330000
   end;   <<trynewrealdev>>                                             20335000
$page "   ***   ALLOCATE -- Subroutine SCANXDD   ***"          <<06730>>20340000
integer subroutine scanxdd (head'index, open'or'ready);        <<06730>>20345000
   value   head'index, open'or'ready;                          <<06730>>20350000
   integer head'index;                                         <<06730>>20355000
   logical open'or'ready;                                      <<06730>>20360000
                                                               <<06730>>20365000
begin comment --                                               <<06730>>20370000
  scanxdd scans subentries on the xdd chain defined  by  head' <<06730>>20375000
index,  looking  for  one  which matches the properties of the <<06730>>20380000
devicefile allocate is currently trying to open.  if  open'or' <<06730>>20385000
ready  is  true,  any subentry must be in the open state to be <<06730>>20390000
considered further.  if it is false, the subentry must  be  in <<06730>>20395000
the  ready  state.  in  either case, this is only the first of <<06730>>20400000
many tests a candidate subentry must pass. these are described <<06730>>20405000
more fully below.                                              <<06730>>20410000
  scanxdd returns one of three  values,  summarized  here  and <<06730>>20415000
listed below:                                                  <<06730>>20420000
  0 -- no matching subentry was found.                         <<06730>>20425000
  1 -- a "near match" (see below) was found.                   <<06730>>20430000
  2 -- an exact match was found.                               <<06730>>20435000
                                                               <<06730>>20440000
  now the details:                                             <<06730>>20445000
  no matter whether the caller wants a ready file or  an  open <<06730>>20450000
file,  any  candidate  subentry  must  pass a series of tests. <<06730>>20455000
failure of almost any test causes that subentry to be discard- <<06730>>20460000
ed and the next one tried.  ready files can have  an  "almost" <<06730>>20465000
or  "near  match"  condition.  if a candidate survives all but <<06730>>20470000
the final test, scanxdd remembers it.  if no  exact  match  is <<06730>>20475000
found  among  the  remaining  subentries in the chain, scanxdd <<06730>>20480000
returns the "near match" subentry instead.  this situation  is <<06730>>20485000
described more fully in the next paragraph.                    <<06730>>20490000
  the old request processor calls scanxdd to try to find ready <<06730>>20495000
devicefiles (subentries) in the idd.  these must  be  spooled, <<06730>>20500000
by  definition,  since  there  is no such thing as a ready un- <<06730>>20505000
spooled devicefile.  the old  request  processor  is  probably <<06730>>20510000
looking for :data files or :streamed jobs.  [on rare occasions <<06730>>20515000
(described in allocate), it may look  for  open  files  if  it <<06730>>20520000
can't find an appropriate ready one].  :data files do not have <<06730>>20525000
job numbers, but do have optional filenames.  a  "near  match" <<06730>>20530000
is  a  :data  subentry whose job, user and account names match <<06730>>20535000
those passed in the id parameter, but whose filename  was  not <<06730>>20540000
specified  (and  is therefore blank) in either the subentry or <<06730>>20545000
the id parameter, but not both.  (if both  fields  were  blank <<06730>>20550000
they would match, and we would have an exact match rather than <<06730>>20555000
a near match).  scanxdd remembers only the first near match it <<06730>>20560000
finds.                                                         <<06730>>20565000
  the new request processor calls scanxdd to try to find  open <<06730>>20570000
devicefiles.  the  only  way such files can be new is if users <<06730>>20575000
are re-opening existing new files (such as printers) by  logi- <<06730>>20580000
cal  device number.  open files can be spooled or non-spooled, <<06730>>20585000
so some consistency tests between the open files and  the  de- <<06730>>20590000
vice (allocdev) currently being considered by allocate must be <<06730>>20595000
performed.  the "near match" condition doesn't exist for  open <<06730>>20600000
files,  since  they  always  have a job number associated with <<06730>>20605000
them.                                                          <<06730>>20610000
                                                               <<06730>>20615000
inputs:   head'index.  the index (head entry/4) of the  device <<06730>>20620000
          whose subentry chain is to be searched.              <<06730>>20625000
                                                               <<06730>>20630000
          open'or'ready.  if true, subentry must be  open,  if <<06730>>20635000
          false, subentry must be ready.                       <<06730>>20640000
                                                               <<06730>>20645000
returns:  scanxdd = 0, no matching subentry found,             <<06730>>20650000
                  = 1, a close match (see above) was found,    <<06730>>20655000
                  = 2, an exact match (see above) was found.   <<06730>>20660000
                                                               <<06730>>20665000
          xdd'subentry.  for close or  exact  match,  contains <<06730>>20670000
          the  matching  subentry.  if  no match, array is not <<06730>>20675000
          changed.                                             <<06730>>20680000
                                                               <<06730>>20685000
          xdd'address. initialized to 0 at start of allocate,  <<06730>>20690000
          set to xdd segment-relative address of close or  ex- <<06730>>20695000
          act matching subentry if either is found.            <<06730>>20700000
                                                               <<06730>>20705000
ways and means:  the symbol "XDD'SUBENTRY" is required by  the <<06730>>20710000
                 xdd $include file. we have to use it two dif- <<06730>>20715000
                 ferent ways within allocate.  everywhere  but <<06730>>20720000
                 in scanxdd, db is at the stack and xdd'suben- <<06730>>20725000
                 try is a q-relative indirect array,  a  local <<06730>>20730000
                 copy of a subentry image which will eventual- <<06730>>20735000
                 ly be entered or rewritten back to  the  xdd. <<06730>>20740000
                 in scanxdd, db is at the xdd data segment and <<06730>>20745000
                 xdd'subentry is a pointer to  an  actual  xdd <<06730>>20750000
                 subentry.  changing  back  and forth requires <<06730>>20755000
                 some fancy footwork, in particular the use of <<06730>>20760000
                 a temporary cell to hold the  q-relative  ad- <<06730>>20765000
                 dress  of  xdd'subentry so we can put it back <<06730>>20770000
                 again later.  note that the q-relative  array <<06730>>20775000
                 must  be  an  indirect array for this scam to <<06730>>20780000
                 work.  all this magic is handled within scan- <<06730>>20785000
                 xdd.                                          <<06730>>20790000
                                                               <<06730>>20795000
special considerations:  db must be at  the  stack  at  entry, <<06730>>20800000
                         same at exit.                         <<06730>>20805000
;                                                              <<06730>>20810000
@save'subentry'address := @xdd'subentry;                       <<06730>>20815000
exchangedb (xdd'dst);                                          <<06730>>20820000
scanxdd := best'so'far := no'match;   << prepare for worst. >> <<06730>>20825000
found'it := false;                                             <<06730>>20830000
@xdd'head := head'index * integer (xdd0'head'length);          <<06730>>20835000
@xdd'subentry := xddh'first'subentry;                          <<06730>>20840000
                                                               <<06730>>20845000
while @xdd'subentry <> xdds'end'of'chain and not found'it do   <<06730>>20850000
   begin   << search subentry links on this chain.          >> <<06730>>20855000
   if open'or'ready = open then                                <<06730>>20860000
      begin   << caller wants an opened file.               >> <<06730>>20865000
      if xdds'spool'state <> xdds'open then go to next'link;   <<06730>>20870000
      if integer(xdds'job'number) <> jnum or                   <<06730>>20875000
         xdds'job'type <> job'type then go to next'link;       <<06730>>20880000
      if lpdt'virtual'device then                              <<06730>>20885000
         if integer (xdds'virtual'ldev) <> allocdev or         <<06730>>20890000
            xddsd'disc'label = 0d then go to next'link         <<06730>>20895000
         else                                                  <<06730>>20900000
      else if xddsd'disc'label <> 0d then go to next'link;     <<06730>>20905000
                                                               <<06730>>20910000
<< all tests passed for open file, this is an exact match.  >> <<06730>>20915000
                                                               <<06730>>20920000
      found'it := true;                                        <<06730>>20925000
      end     << caller wants an opened file.               >> <<06730>>20930000
   else                                                        <<06730>>20935000
      begin   << caller wants a ready file.                 >> <<06730>>20940000
      if xdds'spool'state <> xdds'ready then go to next'link;  <<06730>>20945000
                                                               <<06730>>20950000
<< xdd'compare'id is an artifice, used  for  comparing  the >> <<06730>>20955000
<< job,  user,  account (and later file) name fields of the >> <<06730>>20960000
<< candidate subentry with their counterparts passed in via >> <<06730>>20965000
<< allocate's id parameter. the method depends a lot on the >> <<06730>>20970000
<< internal structure of the xdd, since the fields are  as- >> <<06730>>20975000
<< sumed to follow each other.  *-*-* caution:  *-*-* don't >> <<06730>>20980000
<< rewrite the comparisons  below  to use the compare bytes >> <<06730>>20985000
<< (cmpb) machine instruction. it won't work in split-stack >> <<06730>>20990000
<< for q-relative variables (read "QID").                   >> <<06730>>20995000
                                                               <<06730>>21000000
      @xdd'compare'id := @xdds'user'name;                      <<06730>>21005000
      if xdds'job'number = 0 and xdds'job'type = 0 then        <<j7846>>21010000
         begin   << no job number, must be a :data file.    >> <<06730>>21015000
         i := -1;                                              <<06730>>21020000
         while (i := i + 1) < 12 do                            <<06730>>21025000
               if xdd'compare'id(i) <> qid(i) then             <<06730>>21030000
                  go to next'link;                             <<06730>>21035000
         end                                                   <<06730>>21040000
      else if integer (xdds'job'number) <> jnum or             <<06730>>21045000
              xdds'job'type <> job'type then go to next'link;  <<06730>>21050000
                                                               <<06730>>21055000
<< almost a near match if here.  if we haven't had  a  pre- >> <<06730>>21060000
<< vious  near  match,  a  blank  subentry or qid file name >> <<06730>>21065000
<< field will establish one now.                            >> <<06730>>21070000
                                                               <<06730>>21075000
      if best'so'far = no'match then                           <<06730>>21080000
         if xdds'file'name = "  " or qid(12) = "  " then       <<06730>>21085000
            best'so'far := @xdd'subentry;                      <<06730>>21090000
                                                               <<06730>>21095000
<< exact match if file names match (blank or not).          >> <<06730>>21100000
                                                               <<06730>>21105000
      i := 11;   << position before file name fields.       >> <<06730>>21110000
      while (i := i + 1) < 16 do                               <<06730>>21115000
            if xdd'compare'id(i) <> qid(i) then                <<06730>>21120000
               go to next'link;                                <<06730>>21125000
      found'it := true;                                        <<06730>>21130000
      end;    << caller wants a ready file.                 >> <<06730>>21135000
                                                               <<06730>>21140000
next'link:                                                     <<06730>>21145000
                                                               <<06730>>21150000
   if not found'it then @xdd'subentry := xdds'next'subentry;   <<06730>>21155000
   end;    << while (search subentry links on this chain).  >> <<06730>>21160000
                                                               <<06730>>21165000
exchangedb (stack);                                            <<06730>>21170000
if found'it or best'so'far <> no'match then                    <<06730>>21175000
   begin   << some kind of match.                           >> <<06730>>21180000
   if found'it then                                            <<06730>>21185000
      begin                                                    <<06730>>21190000
      scanxdd := exact'match;                                  <<06730>>21195000
      @xdd'address := @xdd'subentry;                           <<06730>>21200000
      end                                                      <<06730>>21205000
   else                                                        <<06730>>21210000
      begin                                                    <<06730>>21215000
      scanxdd := close'match;                                  <<06730>>21220000
      @xdd'address := best'so'far;                             <<06730>>21225000
      end;                                                     <<06730>>21230000
   @xdd'subentry := @save'subentry'address;                    <<06730>>21235000
   movefromdseg (@xdd'subentry, xdd'dst, @xdd'address,         <<06730>>21240000
                 size'of'xdd'subentry);                        <<06730>>21245000
   end     << some kind of match.                           >> <<06730>>21250000
else @xdd'subentry := @save'subentry'address;   << no match >> <<06730>>21255000
                                                               <<06730>>21260000
end;   << of scanxdd.                                       >> <<06730>>21265000
$page "   ***   ALLOCATE -- Subroutine FINDNEWREALEE   ***"    <<06730>>21270000
logical subroutine findnewrealee;                              <<00.dl>>21275000
         <<scan class(indx) for up,unowned,realee.                    >>21280000
         <<output:                                                    >>21285000
         <<      findnewrealee = false - no device available         >> 21290000
         <<                  = true  - device available               >>21295000
         <<    * if dev.avail then:                                   >>21300000
         <<      opreqd = false      - no op.intervention reqd.       >>21305000
         <<                            allocdev set. lpdt entry       >>21310000
         <<                            reserved. (i.e. ss_3)   <<06730>>21315000
         <<             = true       - op.intervention reqd.          >>21320000
         <<    * if dev.avail.and op.intervention reqd.then:          >>21325000
         <<      askforms = true     - forms request reqd.            >>21330000
         <<               = false    - mag.tape                       >>21335000
   begin                                                                21340000
   findnewrealee := false;                                     <<06730>>21345000
   askforms := true;                                           <<06730>>21350000
   this'ldev := dct'first'ldev - 1;                            <<06730>>21355000
   while (this'ldev := this'ldev + 1) - dct'first'ldev <       <<06730>>21360000
         integer (dct'num'devices) do                          <<06730>>21365000
      begin                                                             21370000
      trydev := dct(this'ldev);                                <<06730>>21375000
      getldt'lpdt (trydev);                                             21380000
      if ldt'spool'queues = ldt'qshut                          <<06730>>21385000
         and ((k := trynewrealdev (trydev)) <> 0) then         <<06730>>21390000
         begin   <<trydev is some kind of available>>                   21395000
         findnewrealee := true;   <<available>>                <<06730>>21400000
         if k=3 then                                                    21405000
            begin   <<got it. no forms or magtape problems>>            21410000
            allocdev := trydev;                                <<06730>>21415000
            opreqd := false;                                   <<06730>>21420000
            return;                                                     21425000
            end;                                                        21430000
         opreqd := true;                                       <<06730>>21435000
         if k=2 then                                                    21440000
            askforms := false;                                 <<06730>>21445000
          <<try again>>                                                 21450000
         end;                                                           21455000
      end;                                                              21460000
   end;   <<findnewrealee>>                                             21465000
$page "   ***   ALLOCATE -- Procedure body   ***"              <<06730>>21470000
   pxglobal;   << required by pxglobal $include file.       >> <<06730>>21475000
   allocate := device'allocated;   << assume the best.      >> <<06730>>21480000
   move qid := id, (16);                                                21485000
   @ucapptr := @pxg'userattributes;                            <<06730>>21490000
   ndcap := ucapnd;                                            <<06730>>21495000
   restart := pxg'restart;                                     <<06730>>21500000
   job'type := jnum.(0:2);   << funct. compat. w/ xdd $in-  >> <<06730>>21505000
   jnum := jnum.(2:14);      << clude file for jnum parm.   >> <<06730>>21510000
   save'ldt'sir := getsir (ldt'sir);                           <<06730>>21515000
   save'dct'sir := getsir (dct'sir);                           <<06730>>21520000
   save'lpdt'sir := getsir (lpdt'sir);                         <<06730>>21525000
   classreq:=indx.(0:1);                                       <<00.dl>>21530000
   if indx = 0 then suddendeath (sd363);  << not ldev or cls >><<07050>>21535000
   if classreq then                                            <<06730>>21540000
      begin   <<class request setup>>                                   21545000
      if not ndcap then                                        <<06730>>21550000
         begin   <<no nd capability>>                                   21555000
         allocate := no'nd'capability;                         <<06730>>21560000
         go bad2;                                                       21565000
         end;                                                           21570000
      entry'length := get'device'class (-indx, entry'address); <<06730>>21575000
      if entry'length = -1 then suddendeath (sd361);           <<07050>>21580000
      push (s);   << build space for dct entry on stack.    >> <<06730>>21585000
      @dct := tos + 1;                                         <<06730>>21590000
      tos := entry'length;                                     <<06730>>21595000
      assemble (adds 0);   << room for entire entry.        >> <<06730>>21600000
      movefromdseg (@dct, dct'dst, entry'address,              <<06730>>21605000
                    entry'length);                             <<06730>>21610000
      allocdev := dct(dct'first'ldev);                         <<06730>>21615000
      devtype := dct'class'acc'type;                           <<06730>>21620000
      if not getldt'lpdt(allocdev) then                                 21625000
         suddendeath (sd362);   <<bad device# in class table>> <<07050>>21630000
      end                                                               21635000
   else                                                                 21640000
      begin   <<device request setup>>                                  21645000
      << check for nd cap.  but ok for $stdin/list by ci.   >> <<04973>>21650000
      if not ndcap and not stdin'list then                     <<06730>>21655000
         begin   <<no nd capability>>                          <<04537>>21660000
         allocate := no'nd'capability;                         <<06730>>21665000
         go bad2;                                              <<04537>>21670000
         end;                                                  <<04537>>21675000
      allocdev := indx;                                        <<06730>>21680000
      if not getldt'lpdt(allocdev) then                                 21685000
         begin   <<invalid indx>>                                       21690000
         suddendeath (sd363);                                  <<07050>>21695000
         end;                                                           21700000
      devtype := ldt'access'type;                              <<06730>>21705000
      end;                                                              21710000
    <<check access compatability with devtype>>                         21715000
   if devtype = ldt'serial'in then                             <<06730>>21720000
      begin                                                             21725000
      if access = outputonly then                                       21730000
         begin   <<bad access>>                                         21735000
badacc:                                                                 21740000
         allocate := in'out'spec'error;                        <<06730>>21745000
         go bad2;                                                       21750000
         end;                                                           21755000
      access := inputonly;                                     <<06730>>21760000
      oldreq := true;                                          <<06730>>21765000
      end                                                               21770000
   else                                                                 21775000
      if devtype = ldt'serial'out then                         <<06730>>21780000
         begin                                                          21785000
         if access = inputonly then                                     21790000
            go badacc;                                                  21795000
         access := outputonly;                                          21800000
         oldreq := false;                                      <<06730>>21805000
         end                                                            21810000
      else                                                              21815000
         begin   <<i/o device>>                                         21820000
         if lpdt'virtual'device then                           <<06730>>21825000
            if access = inputonly and lpdt'vdev'direction =    <<06730>>21830000
               lpdt'vdev'output                                <<06730>>21835000
            or access = outputonly and lpdt'vdev'direction =   <<06730>>21840000
               lpdt'vdev'input then go to badacc;              <<06730>>21845000
         if access = inputonly then oldreq := true             <<06730>>21850000
         else                                                           21855000
            if access = outputonly then oldreq := false        <<06730>>21860000
            else                                                        21865000
            if lpdt'virtual'device then  <<virtual device>>    <<06730>>21870000
               if lpdt'vdev'direction = lpdt'vdev'output then  <<06730>>21875000
                  begin                                        <<sp.01>>21880000
                  access := outputonly;                        <<sp.01>>21885000
                  oldreq := false;                             <<06730>>21890000
                  end                                          <<sp.01>>21895000
               else                 <<virtual input device>>   <<sp.01>>21900000
                  begin                                        <<sp.01>>21905000
                  access := inputonly;                         <<sp.01>>21910000
                  oldreq := true;                              <<06730>>21915000
                  end                                          <<sp.01>>21920000
            else                                               <<sp.01>>21925000
               oldreq:=old.(15:1);                             <<00.dl>>21930000
         end;                                                           21935000
$page "   ***   ALLOCATE- OLD   ***"                                    21940000
   if oldreq then                                              <<06730>>21945000
      begin   <<* * * * * * * * *   o l d   r e q u e s t   * * * * * >>21950000
      xdd'sir := idd'sir;                                      <<06730>>21955000
      save'xdd'sir := getsir (xdd'sir);                        <<06730>>21960000
      xdd'dst := idd'dst;                                      <<06730>>21965000
      if classreq then                                         <<06730>>21970000
         begin                                                 <<06730>>21975000
                                                               <<06730>>21980000
<< trying to open an old (existing?) devicefile via a class >> <<06730>>21985000
<< name.  scan through subentries for  all  ldev's  in  the >> <<06730>>21990000
<< class  until  we  find  an  exact match (see comments in >> <<06730>>21995000
<< scanxdd) or run out of subentries.  remember  the  first >> <<06730>>22000000
<< close  match  we  may find.  if we run out of subentries >> <<06730>>22005000
<< without finding an exact match we'll use any close match >> <<06730>>22010000
<< we found. if there were none of those either, we have to >> <<06730>>22015000
<< ask the operator to assign us a device.                  >> <<06730>>22020000
                                                               <<06730>>22025000
         @close'idd'subentry := no'match;                      <<06730>>22030000
         k := no'match;   << to prime the loop below.       >> <<06730>>22035000
         this'ldev := dct'first'ldev - 1;                      <<06730>>22040000
         while (this'ldev := this'ldev + 1) - dct'first'ldev < <<06730>>22045000
            integer (dct'num'devices) and k <> exact'match do  <<06730>>22050000
            begin   <<loop through class>>                              22055000
            nextdev := dct(this'ldev);                         <<06730>>22060000
            getldt'lpdt (nextdev);                             <<f7676>>22065000
            k := scanxdd (ldt'xdd'head'index, ready);          <<06730>>22070000
            if k = exact'match then                            <<06730>>22075000
               allocdev := nextdev   <<got it>>                <<06730>>22080000
            else                                                        22085000
               if k = close'match and                          <<06730>>22090000
                  @close'idd'subentry = no'match then          <<06730>>22095000
                  begin   <<first close match - save it>>               22100000
                  @close'idd'subentry := @xdd'address;         <<06730>>22105000
                  move save'xdd'subentry := xdd'subentry,      <<06730>>22110000
                       (size'of'xdd'subentry);                 <<06730>>22115000
                  end;                                                  22120000
            end;                                               <<06730>>22125000
         if k <> exact'match then                              <<f7676>>22130000
            if @close'idd'subentry <> no'match then            <<06730>>22135000
               begin   << close match was found, use it.    >> <<06730>>22140000
               move xdd'subentry := save'xdd'subentry,         <<06730>>22145000
                    (size'of'xdd'subentry);                    <<06730>>22150000
               allocdev := xdds'device;                        <<06730>>22155000
               @xdd'address := @close'idd'subentry;            <<06730>>22160000
               getldt'lpdt (allocdev);                                  22165000
               end                                                      22170000
            else    << no match, operator must find device. >> <<06730>>22175000
               do begin                                        <<06730>>22180000
                  ask;                                         <<06730>>22185000
                  end                                          <<06730>>22190000
                 until replytype = opassigned                  <<06730>>22195000
                       or scanxdd (ldt'xdd'head'index, ready)  <<06730>>22200000
                          <> no'match;                         <<06730>>22205000
         end     << old devicefile, class request.          >> <<06730>>22210000
      else                                                              22215000
         begin   <<old req.by ldev>>                                    22220000
         if ownedbycaller then                                          22225000
            begin   <<must succeed>>                                    22230000
            scanxdd (ldt'xdd'head'index, open);                <<06730>>22235000
            end                                                         22240000
         else                                                           22245000
            begin   <<not a simple reallocation>>                       22250000
            if lpdt'virtual'device then                        <<06730>>22255000
               begin   << can't directly alloc. virt. dev.  >> <<06730>>22260000
               allocate := virtual'devc'not'yours;             <<06730>>22265000
               go badexit;                                              22270000
               end;                                                     22275000
             <<at this point, must be initial alloc,spoofle realloc by>>22280000
             <<ldev or a sudden realloc during askop.                 >>22285000
            do                                                          22290000
               begin   <<try to find ready file>>                       22295000
               tryflag := gotready;   <<init.for loop>>        <<06730>>22300000
               if scanxdd (ldt'xdd'head'index, ready) =        <<06730>>22305000
                  no'match then do                             <<06730>>22310000
                     begin   <<try to find opened file>>                22315000
                     tryflag := gotopened;                     <<06730>>22320000
                     if scanxdd (ldt'xdd'head'index, open)     <<06730>>22325000
                        = no'match then                        <<06730>>22330000
                        begin   <<ask operator>>                        22335000
                        if not ndcap then                      <<06730>>22340000
                           begin   <<no nd capability>>                 22345000
                           allocate := no'nd'capability;       <<06730>>22350000
                           go badexit;                                  22355000
                           end;                                         22360000
                        ask;                                            22365000
                        if replytype = realloc then                     22370000
                           tryflag := tryopened                <<06730>>22375000
                        else                                            22380000
                           if replytype = olddata then                  22385000
                              tryflag := tryready;             <<06730>>22390000
                        << else opassigned:                             22395000
                              leave tryflag = gotopened,                22400000
                              to drop out of loop >>                    22405000
                        end;   <<operator>>                             22410000
                     end                                                22415000
                  until tryflag<>tryopened                              22420000
               else                                                     22425000
                  if not ndcap then                            <<06730>>22430000
                     begin   <<no nd capability-ready,initial alloc>>   22435000
                     allocate := no'nd'capability;             <<06730>>22440000
                     go badexit;                                        22445000
                     end;                                               22450000
               end                                                      22455000
            until tryflag<>tryready;                                    22460000
            end;                                                        22465000
         end;   <<old ldev req.>>                                       22470000
      if @xdd'address = 0 then                                 <<06730>>22475000
         createsubentry                                                 22480000
      else                                                              22485000
         begin                                                          22490000
         if xddsd'disc'label <> 0d then                        <<06730>>22495000
            reald := false;                                    <<06730>>22500000
         if xdds'spool'state = xdds'open then                  <<06730>>22505000
            initial := false;                                  <<06730>>22510000
         end;                                                           22515000
      if not reald then                                        <<06730>>22520000
         begin   <<spoofle>>                                            22525000
         if initial then                                       <<06730>>22530000
            begin                                                       22535000
            if ( allocdev := getvdev ) = 0 then                         22540000
               begin                                                    22545000
               allocate := device'unavailable;                 <<06730>>22550000
               go badexit;                                              22555000
               end;                                                     22560000
            xdds'virtual'ldev := allocdev;                     <<06730>>22565000
            if restart then idds'restart := true;              <<06730>>22570000
            updatexdd := true;                                 <<06730>>22575000
            end                                                         22580000
         else   << virtual device re-allocation.            >> <<06730>>22585000
            allocdev := xdds'virtual'ldev;                     <<06730>>22590000
         end;                                                           22595000
      if initial then                                          <<06730>>22600000
         begin                                                          22605000
         updatexdd := true;                                    <<06730>>22610000
         xdds'spool'state := xdds'open;                        <<06730>>22615000
         xdds'job'number := jnum;                              <<06730>>22620000
         xdds'job'type := job'type;                            <<06730>>22625000
         end;                                                           22630000
      if idds'data then                                        <<06730>>22635000
         allocate := new'or'realloc'data;                      <<06730>>22640000
      end    <<old request>>                                            22645000
$page "   ***   ALLOCATE- NEW   ***"                                    22650000
   else                                                                 22655000
      begin   <<* * * * * * * * *   n e w   r e q u e s t   * * * * * >>22660000
      tos := formsg(49);   << get fmsg length, limit it.    >> <<06730>>22665000
      formsg(49) := ".";                                       <<06730>>22670000
      scan formsg until "..", 1;                               <<06730>>22675000
      fmsglgth := tos - @formsg;                               <<06730>>22680000
      formsg(49) := tos;   << restore final byte.           >> <<06730>>22685000
      numcopies := if copies = 0 then 1 else copies;    <<copies>>      22690000
      if outpri = 0 then outpri := 8;   << default outpri.  >> <<06008>>22695000
      xdd'dst := odd'dst;                                      <<06730>>22700000
      xdd'sir := odd'sir;                                      <<06730>>22705000
      save'xdd'sir := getsir (xdd'sir);                        <<06730>>22710000
      if classreq then                                         <<06730>>22715000
         begin   <<class request>>                                      22720000
         spoolflag := spooleddev(indx);                                 22725000
         if spoolflag = 1 then                                          22730000
            begin <<spooled class>>                            <<06730>>22735000
               allocate := ok'spooled'class;                   <<06730>>22740000
               reald := false;                                 <<06730>>22745000
            end    <<spooled class>>                           <<06730>>22750000
         else                                                           22755000
            begin     <<not spooled class>>                    <<06730>>22760000
            if numcopies <= 1 then                             <<06730>>22765000
               begin   <<normal initial allocation>>           <<06730>>22770000
               if not findnewrealee then                       <<06730>>22775000
                  begin                                        <<06730>>22780000
                     if spoolflag then                         <<06730>>22785000
                     reald := false                            <<06730>>22790000
                  else                                         <<06730>>22795000
                     begin   <<device unavailable>>            <<06730>>22800000
                     allocate := device'unavailable;           <<06730>>22805000
                     go badexit;                               <<06730>>22810000
                     end;                                      <<06730>>22815000
                  end                                          <<06730>>22820000
               else   <<op.intervention reqd.or reserved>>     <<06730>>22825000
               end                                             <<06730>>22830000
            else                                               <<06730>>22835000
               begin   <<#copies>1, try for spoolee>>          <<06730>>22840000
               if spoolflag then                               <<06730>>22845000
                  reald := false                               <<06730>>22850000
               else       << try for real device and        >> <<06730>>22855000
                  begin   << override number of copies.     >> <<06730>>22860000
                  if not findnewrealee then                    <<06730>>22865000
                     begin                                     <<06730>>22870000
                     allocate := device'unavailable;           <<06730>>22875000
                     go badexit;                               <<06730>>22880000
                     end;                                      <<06730>>22885000
                  numcopies := 1;                              <<06730>>22890000
                  end;                                         <<06730>>22895000
               end;   <<spool try>>                            <<06730>>22900000
            end;      <<not spooled class>>                    <<06730>>22905000
         end   <<new,class stuff>>                                      22910000
$page                                                          <<06730>>22915000
      else                                                              22920000
         begin   <<new,ldev request>>                                   22925000
         if ownedbycaller then                                          22930000
            begin   <<owned by caller. ldev or vdev realloc>>           22935000
            initial := false;                                  <<06730>>22940000
            if lpdt'virtual'device then                        <<06730>>22945000
               reald := false   <<vdev realloc>>               <<06730>>22950000
            else                                                        22955000
               begin   <<ldev realloc>>                                 22960000
               numcopies := 1;                                 <<06730>>22965000
               if fmsglgth > 0 or ldt'special'forms then       <<06730>>22970000
                  begin <<forms req'd or forms up>>            <<00.dl>>22975000
                  opreqd := true;                              <<06730>>22980000
                  askforms := true;                            <<06730>>22985000
                  end;  <<forms req'd or forms up>>            <<00.dl>>22990000
               end;                                                     22995000
            end   <<realloc>>                                           23000000
         else                                                           23005000
            begin                                                       23010000
            if lpdt'virtual'device then                        <<06730>>23015000
               begin                                           <<06730>>23020000
                                                               <<06730>>23025000
<< allocate's caller has specified, by ldev, a virtual  de- >> <<06730>>23030000
<< vice (that is, one which is not configured as a real de- >> <<06730>>23035000
<< vice and is therefore available as a virtual device  for >> <<06730>>23040000
<< open spoolfiles).  this is allowed only when re-allocat- >> <<06730>>23045000
<< ing the device (re-opening it after a previous  call  to >> <<06730>>23050000
<< allocate  by the same process tree).  callers cannot di- >> <<06730>>23055000
<< rectly allocate a virtual device, as one has tried to do >> <<06730>>23060000
<< here.                                                    >> <<06730>>23065000
                                                               <<06730>>23070000
               allocate := virtual'devc'not'yours;             <<06730>>23075000
               go badexit;                                              23080000
               end;                                                     23085000
             <<must be initial alloc or spoofle realloc by ldev>>       23090000
            i := scanxdd (ldt'xdd'head'index, open);           <<06730>>23095000
            if i <> no'match then                              <<06730>>23100000
               begin   <<got opened, must be realloc spoofle>>          23105000
               initial := false;                               <<06730>>23110000
               reald := false;                                 <<06730>>23115000
               allocdev := xdds'virtual'ldev;                  <<06730>>23120000
               end                                                      23125000
            else                                                        23130000
               begin   <<initial alloc>>                                23135000
               if ldt'spool'queues = ldt'qopen then            <<06730>>23140000
                  reald := false  <<spoolee>>                  <<06730>>23145000
               else                                                     23150000
                  begin   <<realee>>                                    23155000
                  if (k := trynewrealdev(allocdev)) = 0 then   <<06730>>23160000
                     begin   <<dev.not available>>                      23165000
                     allocate := device'unavailable;           <<06730>>23170000
                     go badexit;                                        23175000
                     end;                                               23180000
                  if k <> 3 then                                        23185000
                     begin   <<magtape or forms>>                       23190000
                     opreqd := true;                           <<06730>>23195000
                     if k=1 then                                        23200000
                        askforms := true;   <<forms>>          <<06730>>23205000
                     end;                                               23210000
                  end;   <<realee>>                                     23215000
               end;   <<initial alloc>>                                 23220000
            end;                                                        23225000
         end;   <<new,ldev req.>>                                       23230000
$page                                                          <<06730>>23235000
       <<stuff common to all new>>                                      23240000
       <<real initial                                                   23245000
       << t      t     if opreqd then ask for forms,mag.tape          >>23250000
       <<               else allocdev set & reserved.                 >>23255000
       << t      f     if opreqd then ask for forms else simple       >>23260000
       <<               realloc of allocdev                           >>23265000
       << f      t     get a new vdev.                                >>23270000
       << f      f     spoofle realloc. allocdev set to vdev.         >>23275000
       <<                                                             >>23280000
       << xdd'address=0, except for spoofle realloc by ldev >> <<06730>>23285000
       <<for real alloc, opreqd set if op.intervention required.      >>23290000
      if opreqd then                                           <<06730>>23295000
         begin   <<op.intervention required>>                           23300000
         if askforms then                                      <<06730>>23305000
            if fmsglgth > 0 then                                        23310000
               begin   <<send forms message>>                           23315000
               i := formsg(fmsglgth);   <<save>>               <<06730>>23320000
               formsg(x) := 0;   <<term. char. for putmsg>>    <<06730>>23325000
               clean'message(formsg,fmsglgth);                          23330000
               genmsg(1,213,%10000,allocdev,@formsg,,,,0);     <<00741>>23335000
               formsg (fmsglgth) := i;                                  23340000
               end                                                      23345000
            else                                                        23350000
               genmsg(1,214,%10000,allocdev);                  <<00552>>23355000
         ask;                                                           23360000
         end;   <<op.intervention. got initial or realloc realee>>      23365000
      if initial then                                          <<06730>>23370000
         begin   <<create local odd subentry>>                          23375000
         if not reald then                                     <<06730>>23380000
            if ( allocdev := getvdev ) = 0 then                         23385000
               begin                                                    23390000
               allocate := device'unavailable;                 <<06730>>23395000
               go badexit;                                              23400000
               end;                                                     23405000
         createsubentry;                                                23410000
         if not reald then                                     <<06730>>23415000
            begin    << initial, new, spoolfile: get 1st ext >>         23420000
            if diskalloc (0, 1, xddsd'disc'label, 0) <> 0 then <<06730>>23425000
               begin    << err getting 1st ext for spoolfile >>         23430000
               allocate := no'spoofle'extent;                  <<06730>>23435000
               goto badexit;                                            23440000
               end;                                                     23445000
                                                               <<07050>>23450000
<< convert ldev in xdd disc label field to vtab index.      >> <<07050>>23455000
                                                               <<07050>>23460000
            xdds'spoofle'vt'index :=                           <<07050>>23465000
                 vtabinx (xdds'spoofle'vt'index, false);       <<07050>>23470000
            gotsext := true;                                   <<06730>>23475000
            end;                                                        23480000
         end                                                            23485000
      else                                                              23490000
         begin   <<realloc>>                                            23495000
         if @xdd'address = 0 then                              <<06730>>23500000
            if scanxdd (ldt'xdd'head'index, open) = no'match   <<06730>>23505000
               then createsubentry;                            <<06730>>23510000
         end;                                                           23515000
      if reald then                                            <<06730>>23520000
         begin                                                 <<06730>>23525000
         getldt'lpdt (allocdev);                                        23530000
         if not ldt'special'forms and fmsglgth > 0 or          <<06730>>23535000
            ldt'special'forms and fmsglgth = 0 then            <<06730>>23540000
            ldt'special'forms := not ldt'special'forms;        <<06730>>23545000
         end                                                            23550000
      else                                                              23555000
         begin   << virtual device.                         >> <<06730>>23560000
         if not initial then                                   <<06730>>23565000
            begin                                                       23570000
            getldt'lpdt (allocdev);                                     23575000
            if integer (odds'number'copies) < numcopies then   <<06730>>23580000
               begin   << raised numcopies during realloc.  >> <<06730>>23585000
               updatexdd := true;                              <<06730>>23590000
               odds'number'copies := numcopies;                <<06730>>23595000
               end;                                                     23600000
            end;                                                        23605000
         end;                                                           23610000
      if fmsglgth > 0 and not odds'forms'in'file then          <<06730>>23615000
         begin   << subentry doesn't know about forms yet.  >> <<06730>>23620000
         odds'forms'in'file := true;   << it does now.      >> <<06730>>23625000
         updatexdd := true;                                    <<06730>>23630000
         end;                                                           23635000
      end;   <<new request>>                                            23640000
$page "   ***   COMPLETE ALLOCATE (OLD AND NEW)   ***"                  23645000
   getldt'lpdt (allocdev);  << in case oprat gave us another>> <<06730>>23650000
   if initial and reald and                                    <<06730>>23655000
      (ldt'device'type = ldt'serial'disc or                    <<06730>>23660000
           ldt'device'type = ldt'foreign'disc) then            <<06730>>23665000
      begin   << get and initialize dataseg if serial disc. >> <<03607>>23670000
      if ldt'device'type = ldt'serial'disc then                <<06730>>23675000
         begin                                                 <<01115>>23680000
         <<************* get **************************>>      <<sd.00>>23685000
         segnum := getdataseg (memsize, vdsize);               <<sd.00>>23690000
         if <> then                                            <<sd.00>>23695000
            begin <<can't get dataseg>>                        <<sd.00>>23700000
            segnum := 0;   << don't give back resources.    >> <<s7474>>23705000
            allocate := no'sdisc'xds;                          <<s7474>>23710000
            go to badexit;                                     <<s7474>>23715000
            end;  <<can't get dataseg>>                        <<sd.00>>23720000
         <<************* save in ldtx *****************>>      <<sd.00>>23725000
         end                                                   <<01115>>23730000
      else                                                     <<01115>>23735000
         segnum := 1;   << foreign disc.                    >> <<01115>>23740000
      if not ldtx'serial'or'foreign then                       <<06730>>23745000
         begin <<first allocation>>                            <<sd.01>>23750000
                                                               <<03607>>23755000
<< lock any cs80 device to prevent the  operator  from  un- >> <<03607>>23760000
<< loading it while it is allocated.  this must be a physi- >> <<06730>>23765000
<< cal i/o request (that is, not to the serial disc  code). >> <<06730>>23770000
<< the same holds for the p'attachio call at badexit.       >> <<06730>>23775000
                                                               <<03607>>23780000
         if ldevtotype(allocdev) = ldt'cs80'device then        <<06730>>23785000
            begin                                              <<03607>>23790000
            locked := true;    <<set in case of an error>>     <<03607>>23795000
            p'attachio (allocdev, 0, 0, 0, lock, 0, 0, 0, 1);  <<06730>>23800000
            end;                                               <<03607>>23805000
         ldtx'serial'or'foreign := true;                       <<06730>>23810000
         ldtx'sdisc'gpt'xds := segnum;                         <<06730>>23815000
         if ldt'device'type = ldt'serial'disc then             <<s7474>>23820000
            begin   << set a bit attachio can read.         >> <<s7474>>23825000
            disable;                                           <<s7474>>23830000
            lpdt'serial'disc := true;                          <<s7474>>23835000
            enable;                                            <<s7474>>23840000
            end;    << set a bit attachio can read.         >> <<s7474>>23845000
         movetodseg (ldt'dst, save'ldtx'base +                 <<06730>>23850000
            logical (allocdev) * size'of'ldtx'entry, @ldtx,    <<06730>>23855000
            size'of'ldtx'entry);                               <<06730>>23860000
         <<************* initialize for this subtype **>>      <<sd.00>>23865000
         if segnum > 0 and ldt'device'type = ldt'serial'disc   <<06730>>23870000
           then                                                <<06730>>23875000
            begin <<valid dataseg number>>                     <<sd.00>>23880000
            tempdesc(justalloccell) := -1;                     <<00239>>23885000
            tempdesc(fatalerrcell) := 0;                       <<00239>>23890000
            tempdesc(errorlogcell) := 0;                       <<03512>>23895000
            tempdesc(memsizecell) := memsize;                  <<03512>>23900000
            movetodseg (segnum, justallocated'adr, @tempdesc,  <<06730>>23905000
               initarraysize);                                 <<06730>>23910000
            end;  <<valid dataseg number>>                     <<sd.00>>23915000
         end   <<first allocation>>                            <<sd.01>>23920000
      else                                                     <<sd.01>>23925000
         if segnum > 0 then                                    <<s7474>>23930000
            begin   << serial/foreign disc, not 1st alloc.  >> <<s7474>>23935000
            if segnum > 1 then                                 <<s7474>>23940000
               reldataseg (segnum);   << serial disc.       >> <<s7474>>23945000
            segnum := 0;                                       <<s7474>>23950000
            end;    << serial/foreign disc, not 1st alloc.  >> <<s7474>>23955000
      end;  <<get and initialize dataseg>>                     <<sd.00>>23960000
   if updatexdd then                                           <<06730>>23965000
      begin   <<new or altered entry>>                                  23970000
      if @xdd'address = 0 then                                 <<06730>>23975000
         begin   << add new subentry.                       >> <<06730>>23980000
                                                               <<06730>>23985000
<< sputxdd allocates space for our new subentry in the xdd, >> <<06730>>23990000
<< then links it in.  it needs to know:  idd or odd (oldreq >> <<06730>>23995000
<< means idd) (1st parm), and whether to link it to an ldev >> <<06730>>24000000
<< chain or to the class chain (2nd parm, > 0 ==> ldev, < 0 >> <<06730>>24005000
<< ==> class).  it also needs the new subentry image  (xdd' >> <<06730>>24010000
<< subentry).  it  returns the xdd segment-relative address >> <<06730>>24015000
<< where the subentry was linked  in  xdd'address.  sputxdd >> <<06730>>24020000
<< also assigns the devicefile id (dfid) number.            >> <<06730>>24025000
                                                               <<06730>>24030000
         if sputxdd ((not oldreq), if xdds'class then          <<06730>>24035000
                    -xdds'device else xdds'device,             <<06730>>24040000
                    xdd'subentry, xdd'address) <> 0 then       <<06730>>24045000
            begin                                              <<06730>>24050000
            allocate := no'room'in'xdd;                        <<06730>>24055000
            go badexit;                                                 24060000
            end;                                                        24065000
                                                               <<06730>>24070000
<< sputxdd returns odd/idd as 1/0 in @xdd'address.(0:1). we >> <<06730>>24075000
<< can't use it, so we must remove it.                      >> <<06730>>24080000
                                                               <<06730>>24085000
         @xdd'address := @xdd'address & lsl(1) & lsr(1);       <<06730>>24090000
         end                                                            24095000
      else                                                              24100000
         begin   << sputxdd linked new, we move modified.   >> <<06730>>24105000
         movetodseg (xdd'dst, @xdd'address, @xdd'subentry,     <<06730>>24110000
                     size'of'xdd'subentry);                    <<06730>>24115000
         end;                                                           24120000
      end;   <<new or altered entry>>                                   24125000
   if initial then                                             <<06730>>24130000
      if not reald then                                        <<06730>>24135000
         begin   << new virtual device entry.               >> <<06730>>24140000
                                                               <<06730>>24145000
  comment -- the following code builds new virtual device  en- <<06730>>24150000
tries in the ldt and lpdt.  we start with the ldt and lpdt en- <<06730>>24155000
tries for the real ldev or an ldev from the class (trydev) de- <<06730>>24160000
pending on how allocate was called.  these are placed  in  the <<06730>>24165000
corresponding  virtual device entries.  the latter entries are <<06730>>24170000
then modified to make them true virtual device entries (mostly <<06730>>24175000
by setting virtual device and xdd fields in the lpdt). this is <<06730>>24180000
so that anyone who looks at the entries while  the  devicefile <<06730>>24185000
is  open will see as much of a simulation of the corresponding <<06730>>24190000
real device as possible (such as  the  type,  subtype,  record <<06730>>24195000
width, jaid bits, etc.).                                       <<06730>>24200000
  note -- the lpdt is a memory-resident system table. as a re- <<06730>>24205000
sult, the move from one entry to another must use intermediate <<06730>>24210000
storage.  we choose devinfo(1), the same area in which the fi- <<06730>>24215000
nal lpdt entry is eventually returned.                         <<06730>>24220000
;                                                              <<06730>>24225000
         trydev := xdds'device;                                <<06730>>24230000
         if xdds'class then                                    <<06730>>24235000
            begin   << linked to class chain.               >> <<06730>>24240000
            if get'device'class (xdds'device, entry'address) = <<07050>>24245000
               -1 then suddendeath (sd364);                    <<07050>>24250000
            movefromdseg (@dct, dct'dst, entry'address,        <<07050>>24255000
               dct'first'ldev + 1);   << minimum entry.     >> <<07050>>24260000
            trydev := dct(dct'first'ldev);                     <<06730>>24265000
            end;                                               <<06730>>24270000
         getdev (trydev, ldt'dst, ldt);   << refills ldt.   >> <<07050>>24275000
         lpdt'index := trydev * integer (lpdt'entry'size);     <<s8651>>24280000
         disable;                                              <<06730>>24285000
         movefromdseg (@devinfo(1), lpdt'dst, lpdt'index,      <<06730>>24290000
                       lpdt'entry'size);                       <<06730>>24295000
         lpdt'index := allocdev * integer (lpdt'entry'size);   <<06730>>24300000
         movetodseg (lpdt'dst, lpdt'index, @devinfo(1),        <<06730>>24305000
                     lpdt'entry'size);                         <<06730>>24310000
         enable;                                               <<06730>>24315000
                                                               <<06730>>24320000
<< update appropriate ldt fields for a virtual device entry >> <<06730>>24325000
                                                               <<06730>>24330000
         ldt'file'use'cnt := 0;                                <<06730>>24335000
         ldt'special'forms := false;                           <<06730>>24340000
                                                               <<06730>>24345000
<< this is a virtual device entry, so the symbols below per->> <<06730>>24350000
<< tain to the spooled file rather than a  spooled  device. >> <<06730>>24355000
<< i don't know if anyone uses this information.            >> <<06730>>24360000
                                                               <<06730>>24365000
         if oldreq                                             <<06730>>24370000
            then ldt'spool'state := ldt'input'spooled          <<06730>>24375000
            else ldt'spool'state := ldt'output'spooled;        <<06730>>24380000
         ldt'spool'queues := ldt'qshut;                        <<06730>>24385000
         if xdds'class then                                    <<06730>>24390000
            ldt'xdd'head'index := xdd'class'index;             <<06730>>24395000
                                                               <<06730>>24400000
<< now do lpdt virtual device entry fields.  since this  is >> <<06730>>24405000
<< a  virtual  device  entry, disable/enable are not needed >> <<06730>>24410000
<< around these statements.  we still  hold  the  lpdt  sir >> <<06730>>24415000
<< which we acquired at entry to allocate.                  >> <<06730>>24420000
                                                               <<06730>>24425000
         lpdt'dit'ptr := 0;   << no dit for virtual device. >> <<s8651>>24430000
         lpdt'xdd'subentry'ptr  := @xdd'address;               <<06730>>24435000
         lpdt'virtual'device    := true;                       <<06730>>24440000
         lpdt'vdev'direction    := not oldreq;                 <<06730>>24445000
         lpdt'non'sys'domain    := false;                      <<06730>>24450000
         lpdt'eof'type          := lpdt'no'eof;                <<06730>>24455000
         lpdt'rdy'ser'frn'disc  := false;                      <<06730>>24460000
         lpdt'serial'or'foreign := false;                      <<06730>>24465000
         end;    << new virtual device entry.               >> <<06730>>24470000
   ldt'main'pin := jmpin;                                      <<06730>>24475000
   disable;   << this can be for a real device, so...       >> <<06730>>24480000
   lpdt'dev'own'state := lpdt'owned;                           <<06730>>24485000
                                                               <<06730>>24490000
<< because the lpdt is a system table, it is impossible  to >> <<06730>>24495000
<< load its "address" for a move into devinfo. thus we must >> <<06730>>24500000
<< resort to movefromdseg instead.                          >> <<06730>>24505000
                                                               <<06730>>24510000
   movefromdseg (@devinfo(1), lpdt'dst, lpdt'index,            <<06730>>24515000
                 lpdt'entry'size);                             <<06730>>24520000
   enable;                                                     <<06730>>24525000
   ldt'file'use'cnt := ldt'file'use'cnt + 1;                   <<06730>>24530000
   sorfdisc := ldt'device'type;                                <<06730>>24535000
   if sorfdisc = ldt'serial'disc or sorfdisc = ldt'foreign'disc<<06730>>24540000
      then ldt'device'type := savetype; << restore hdwe type>> <<f7676>>24545000
   putdev (allocdev, ldt'dst, ldt);                            <<06730>>24550000
   writedseg'serial (xdd'dst); <<post our manglings to disc.>> <<w7889>>24555000
   relsir (xdd'sir, save'xdd'sir);                             <<06730>>24560000
   relsir (lpdt'sir, save'lpdt'sir);                           <<06730>>24565000
   relsir (dct'sir, save'dct'sir);                             <<06730>>24570000
   relsir (ldt'sir, save'ldt'sir);                             <<06730>>24575000
   ldt'device'type := sorfdisc;   << for devinfo returns.   >> <<06730>>24580000
    <<set up returns>>                                                  24585000
   devinfo := allocdev;                                        <<06730>>24590000
   move devinfo(1+lpdt'entry'size) := ldt, (size'of'ldt'entry);<<06730>>24595000
   @return'xdd'address := @xdd'address;                        <<06730>>24600000
   @return'xdd'address.(0:1) := not oldreq;   << odd/idd    >> <<06730>>24605000
   return;                                                              24610000
badexit:                                                                24615000
   if locked then p'attachio(allocdev,0,0,0,unlock,0,0,0,1);   <<06730>>24620000
   if freserved then                                           <<06730>>24625000
      begin                                                             24630000
      lpdt'index := allocdev * integer (lpdt'entry'size);      <<06730>>24635000
      disable;                                                 <<06730>>24640000
      lpdt'dev'own'state := lpdt'not'owned;                    <<06730>>24645000
      enable;                                                  <<06730>>24650000
      end;                                                              24655000
   if segnum <> 0 then                                         <<s7474>>24660000
      begin   << unwind serial or foreign disc.             >> <<s7474>>24665000
      if segnum > 1 then                                       <<s7474>>24670000
         begin   << serial disc.                            >> <<s7474>>24675000
         reldataseg (segnum);                                  <<s7474>>24680000
         disable;                                              <<s7474>>24685000
         lpdt'serial'disc := false;                            <<s7474>>24690000
         enable;                                               <<s7474>>24695000
         end;    << serial disc.                            >> <<s7474>>24700000
      ldtx'serial'or'foreign := false;                         <<s7474>>24705000
      ldtx'sdisc'gpt'xds := 0;                                 <<s7474>>24710000
      movetodseg (ldt'dst, save'ldtx'base + logical (allocdev) <<s7474>>24715000
         * size'of'ldtx'entry, @ldtx, size'of'ldtx'entry);     <<s7474>>24720000
      end;    << unwind serial or foreign disc.             >> <<s7474>>24725000
   if gotsext then                                             <<06730>>24730000
      << got 1st spoolfile extent: release it >>                        24735000
      begin                                                    <<07050>>24740000
                                                               <<07050>>24745000
<< convert vtab index in xdd disc label field to ldev.      >> <<07050>>24750000
                                                               <<07050>>24755000
      xdds'spoofle'vt'index :=                                 <<07050>>24760000
           lun (xdds'spoofle'vt'index, 0);                     <<07050>>24765000
      diskdealloc (0, 0, %201, xddsd'disc'label);              <<06730>>24770000
      end;                                                     <<07050>>24775000
   relsir (xdd'sir, save'xdd'sir);                             <<06730>>24780000
bad2:                                                                   24785000
   relsir (lpdt'sir, save'lpdt'sir);                           <<06730>>24790000
   relsir (dct'sir, save'dct'sir);                             <<06730>>24795000
   relsir (ldt'sir, save'ldt'sir);                             <<06730>>24800000
bad3:                                                                   24805000
   end;   <<allocate>>                                                  24810000
$page "   ***   PRIMEDEVICE   ***"                                      24815000
$control segment = allocate                                    <<06730>>24820000
                                                               <<06730>>24825000
logical procedure primedevice (ldev, xddep, forms);            <<01027>>24830000
   value ldev, xddep, forms;                                            24835000
   integer ldev;          <<log. dev no.>>                              24840000
   integer pointer xddep; <<xdd entry pntr (w/sign flag)>>              24845000
   logical forms;         <<special forms were mounted>>                24850000
   option privileged, uncallable;                                       24855000
                                                                        24860000
<< does necessary attachio setup for allocate'd device <ldev>:          24865000
   always issues attachio (openfile);                                   24870000
   prints header if 1st alloc (of l.p., cd. pun., or p/r/p);            24875000
   performs forms alignment, if <forms>.                                24880000
   >>                                                                   24885000
                                                                        24890000
begin                                                                   24895000
                                                               <<06730>>24900000
logical array                                                  <<06730>>24905000
   ldt (0:size'of'ldt'entry-1),                                <<06730>>24910000
   ldtx(0:size'of'ldtx'entry-1);                               <<06730>>24915000
                                                               <<06730>>24920000
integer                                                        <<06730>>24925000
   ldt'index  := 0,                                            <<06730>>24930000
   ldtx'index := 0,                                            <<06730>>24935000
   save'ldt'sir;                                               <<06730>>24940000
                                                               <<06730>>24945000
subroutine def'movefromdseg;                                   <<06730>>24950000
                                                               <<06730>>24955000
primedevice := false;                                          <<06730>>24960000
tos := attachio (ldev, 0, 0, 0, 2, 0, 0, 0, %17);              <<s8098>>24965000
del;                                                           <<07104>>24970000
if tos.(13:3) <> 1 then return;   << check for error.       >> <<07104>>24975000
save'ldt'sir := getsir (ldt'sir);                              <<06730>>24980000
movefromdseg (@ldt, ldt'dst, 0, size'of'ldt'entry);            <<06730>>24985000
movefromdseg (@ldtx, ldt'dst, ldtx'base +                      <<06730>>24990000
   ldev*size'of'ldtx'entry, size'of'ldtx'entry);               <<06730>>24995000
movefromdseg (@ldt, ldt'dst, ldev * size'of'ldt'entry,         <<06730>>25000000
   size'of'ldt'entry);                                         <<06730>>25005000
relsir (ldt'sir, save'ldt'sir);                                <<06730>>25010000
                                                               <<06730>>25015000
<< send job start to newly-allocated ciper device.          >> <<06730>>25020000
                                                               <<06730>>25025000
if ldtx'ciper'protocol and ldt'file'use'cnt = 1 then           <<06730>>25030000
   begin                                                       <<06730>>25035000
                                                               <<06730>>25040000
<< 142 = job start, p1=1 ==> reset programmable features.   >> <<06730>>25045000
                                                               <<06730>>25050000
   tos := attachio (ldev, 0, 0, 0, 142, 0, 1, 0, 1);           <<06730>>25055000
   del;                                                        <<06730>>25060000
   if tos.(13:3) <> 1 << normal completion >> then return;     <<06730>>25065000
   end;                                                        <<06730>>25070000
if @xddep < 0 then                                             <<06730>>25075000
   begin    << output device: [,header] [,formsalign] >>       <<06730>>25080000
   if ldt'file'use'cnt = 1 then                                <<06730>>25085000
      begin   << first allocation, try to print header.     >> <<06730>>25090000
      tos := 0;    <<stack parms for header call>>             <<06730>>25095000
      tos := @xddep.(1:15);    <<mask off odd bit>>            <<06730>>25100000
      if not header (*, ldev, ldt'device'type,                 <<06730>>25105000
         ldt'record'width) then return;                        <<06730>>25110000
      end;                                                     <<06730>>25115000
   if forms then formsalign (ldev);    <<align if <forms>.>>   <<06730>>25120000
   end;    << output dev >>                                    <<06730>>25125000
primedevice := true;                                           <<06730>>25130000
end;    << primedevice >>                                      <<06730>>25135000
$page "   ***   FREEDEVICE   ***"                              <<06730>>25140000
$control segment= allocutil                                             25145000
                                                                        25150000
procedure freedevice(ldev,wait,norew);                         <<tl.02>>25155000
   value wait,ldev,norew;                                      <<tl.02>>25160000
   integer ldev;    <<non-sharable, real device 2 b freed>>             25165000
   logical wait;    <<wait on closedevice?>>                            25170000
   logical norew;                                              <<07050>>25175000
   option variable;                                            <<07050>>25180000
   option privileged, uncallable;                                       25185000
begin                                                                   25190000
                                                               <<07050>>25195000
<< note:  the following equate is a parameter to the  awake >> <<07050>>25200000
<< procedure,  and  represents  a  pcb  event mask position >> <<07050>>25205000
<< shifted right four bits.  it is currently unavailable in >> <<07050>>25210000
<< any $include file, which is why it is here!  if the  un- >> <<07050>>25215000
<< derlying  event  mask  (or the awake interface) changes, >> <<07050>>25220000
<< this equate will also have to change.                    >> <<07050>>25225000
                                                               <<07050>>25230000
   equate                                                      <<07050>>25235000
                     junkwait   = %20;                         <<07050>>25240000
                                                               <<07050>>25245000
   integer           save'ldt'sir,     <<getsir returns>>      <<06730>>25250000
                     ldt'index := 0,                           <<06730>>25255000
                     dummy,            << for procedure call >><<02566>>25260000
                     q4=q-4,                                   <<tl.02>>25265000
                     lpdt'index;                               <<06730>>25270000
                                                               <<06730>>25275000
   logical array     ldt(0:size'of'ldt'entry-1);               <<06730>>25280000
                                                               <<06730>>25285000
   logical           nowoffline  := false,  <<if down pending>><<06730>>25290000
                     flush  := false;  <<com pend or non-i and accept>> 25295000
                                                                        25300000
   logical lflag:=false; <<tape label flag>>                   <<tl.02>>25305000
                                                               <<06730>>25310000
                                                               <<06730>>25315000
   subroutine def'movefromdseg;                                <<06730>>25320000
                                                               <<06730>>25325000
   subroutine def'movetodseg;                                  <<06730>>25330000
                                                               <<06730>>25335000
                                                               <<06730>>25340000
                                                               <<06730>>25345000
   lpdt'index := ldev * integer (lpdt'entry'size);             <<06730>>25350000
   if q4.(15:1)=1 then lflag:=norew;                           <<tl.02>>25355000
   save'ldt'sir := getsir (ldt'sir);                           <<06730>>25360000
   movefromdseg (@ldt, ldt'dst, ldev * size'of'ldt'entry,      <<06730>>25365000
                 size'of'ldt'entry);                           <<06730>>25370000
   ldt'file'use'cnt := 0;                                      <<06730>>25375000
   ldt'main'pin := 0;                                          <<06730>>25380000
   if ldt'down'pending then                                    <<06730>>25385000
      begin   << device is done now, take it down.          >> <<06730>>25390000
      nowoffline := true;                                               25395000
      ldt'avail'to'sys := false;                               <<06730>>25400000
      ldt'down'pending := false;                               <<06730>>25405000
      end                                                               25410000
   else                                                                 25415000
      begin                                                             25420000
      disable;                                                 <<06730>>25425000
                                                               <<06730>>25430000
  comment -- the strange code which  follows  is  designed  to <<06730>>25435000
wake devrec (a few lines from now) under certain conditions:   <<06730>>25440000
1.  a :data, :hello or :job has been detected (the  eof  field <<06730>>25445000
    is even -- very table-dependent), -or-                     <<06730>>25450000
2.  the device is not interactive but is job or data accepting <<06730>>25455000
    (say, a job stream device).                                <<06730>>25460000
;                                                              <<06730>>25465000
      if lpdt'eof'type <> 0 and not lpdt'eof'type              <<06730>>25470000
         or not lpdt'interactive and                           <<06730>>25475000
            (lpdt'job'accept or lpdt'data'accept) then         <<06730>>25480000
         flush := true;                                        <<06730>>25485000
      enable;                                                  <<06730>>25490000
      end;                                                              25495000
   movetodseg (ldt'dst, ldev*size'of'ldt'entry, @ldt,          <<06730>>25500000
               size'of'ldt'entry);                             <<06730>>25505000
   relsir (ldt'sir, save'ldt'sir);                             <<06730>>25510000
                                                                        25515000
   if nowoffline then                                                   25520000
      genmsg(1,250,%10000,ldev,,,,,0);                         <<0u.eb>>25525000
   if flush then                                                        25530000
      begin                                                             25535000
      disable;                                                          25540000
      lpdt'dev'own'state := lpdt'service'req;                  <<06730>>25545000
      lpdt'serv'req'count := lpdt'serv'req'count + 1;          <<06730>>25550000
      enable;                                                           25555000
      awake (sysdevrecpcb, junkwait, 0);                       <<07050>>25560000
      end                                                               25565000
   else                                                                 25570000
      begin                                                             25575000
      if not ldt'cs'device then                                <<06730>>25580000
         if not lflag then                                     <<02566>>25585000
            begin                                              <<02566>>25590000
            << clean up density data structure for tapes. >>   <<02566>>25595000
            if ldt'device'type = ldt'mag'tape then             <<06730>>25600000
               begin                                           <<02566>>25605000
               store'density(ldev,dummy,2);  << clear fields >><<02566>>25610000
               set'lpdt'bot(ldev,1);   << set bot >>           <<02566>>25615000
               end;                                            <<02566>>25620000
                                                               <<02566>>25625000
            << close device >>                                 <<02566>>25630000
            attachio(ldev,0,0,0,4,0,0,0,if wait then 1         <<02566>>25635000
                                                else %17);     <<07229>>25640000
            end;                                               <<02566>>25645000
      disable;                                                 <<06730>>25650000
      lpdt'dev'own'state := lpdt'not'owned;                    <<06730>>25655000
      enable;                                                  <<06730>>25660000
      if not (nowoffline) then                                          25665000
         begin                                                          25670000
                                                               <<07050>>25675000
  comment -- we communicate with ucop  through  some  bits  in <<07050>>25680000
sysglob.  we set a bit saying we are freeing up a device. then <<07050>>25685000
we see if ucop is waiting for a device to become free (another <<07050>>25690000
bit).  if so we awaken ucop, because we have just freed one it <<07050>>25695000
may be able to use.  we also clear the ucop wait bit.          <<07050>>25700000
;                                                              <<07050>>25705000
         disable;                                              <<07050>>25710000
         sysdevavail := true;                                  <<07050>>25715000
         tos := syswaitfordev;                                 <<07050>>25720000
         syswaitfordev := false;                               <<07050>>25725000
         enable;                                               <<07050>>25730000
         if tos then awake (sysucoppcb, junkwait, 0);          <<07050>>25735000
         end;                                                           25740000
      end;                                                              25745000
   end;    <<freedevice>>                                               25750000
$page "   ***   DOUBLETIME   ***"                              <<06730>>25755000
$control segment = allocutil                                   <<06730>>25760000
                                                               <<06730>>25765000
double procedure doubletime;                                            25770000
   option privileged, uncallable;                                       25775000
                                                                        25780000
<< returns current time in following (positive) double-word format:     25785000
   [1/0, 7/year, 9/day, 5/hour, 6/min, 4/quadsecond] d.  >>             25790000
                                                                        25795000
begin                                                                   25800000
   tos := calendar;                                                     25805000
   tos := clock;                                                        25810000
   << "TASK" now is to "ELIMINATE" (1).(0:3), (1).(8:2), (2).(0:2),     25815000
      (2).(6:10); compressing remaining fields, rt-justified. >>        25820000
   tos := tos &lsl(2);    <<make min & sec adjacent>>                   25825000
   tos := tos &dlsr(8);    <<setup to make hr & min adjacent>>          25830000
   tos := tos &lsl(2);    <<make hr & min adjacent>>                    25835000
   tos := tos &dlsr(5);    <<make yr & hr adjacent>>                    25840000
   delb;                  <<all info shifted out of s-1>>               25845000
   tos := tos &dlsr(1);    <<rt. justify>>                              25850000
                                                                        25855000
   doubletime := tos;                                                   25860000
   end;    <<doubletime>>                                               25865000
$page "   ***   FORS'XDS'DEALLOC   ***"                        <<06730>>25870000
$control segment = allocutil                                   <<06730>>25875000
                                                               <<06730>>25880000
procedure fors'xds'dealloc(ldev);                              <<03633>>25885000
  value ldev;                                                  <<03633>>25890000
  integer ldev;                                                <<03633>>25895000
  option privileged,uncallable;                                <<03633>>25900000
comment                                                        <<03633>>25905000
                                                               <<03633>>25910000
   this procedure is used to deallocate the extra data         <<03633>>25915000
segment used in sdisc.  it is called from deallocate and       <<03633>>25920000
cleantape (in labseg).  to be called the device (ldev)         <<03633>>25925000
must be a non system and non private volume disc.              <<03633>>25930000
db at stack on entry/exit.                                     <<03633>>25935000
                                                               <<03633>>25940000
;                                                              <<03633>>25945000
begin  << unlock cs80 dev, deallocate sd xds >>                <<03633>>25950000
  integer ldtx'index := 0,                                     <<06730>>25955000
          lpdt'index;                                          <<06730>>25960000
  integer segnum;                                              <<03633>>25965000
  integer save'ldt'sir;                                        <<06730>>25970000
                                                               <<06730>>25975000
  logical array                                                <<06730>>25980000
     ldt (0:size'of'ldt'entry-1),   << just to get to ldtx. >> <<06730>>25985000
     ldtx(0:size'of'ldtx'entry-1);                             <<06730>>25990000
                                                               <<06730>>25995000
                                                               <<06730>>26000000
  subroutine def'movefromdseg;                                 <<06730>>26005000
                                                               <<06730>>26010000
  subroutine def'movetodseg;                                   <<06730>>26015000
                                                               <<06730>>26020000
                                                               <<06730>>26025000
                                                               <<03633>>26030000
lpdt'index := ldev * integer (lpdt'entry'size);                <<06730>>26035000
                                                               <<03633>>26040000
<< unlock any cs80 serial or foreign disc.                  >> <<06730>>26045000
                                                               <<03633>>26050000
if ldevtotype(ldev) = ldt'cs80'device                          <<06730>>26055000
  then p'attachio (ldev, 0, 0, 0, unlock, 0, 0, 0, 1);         <<06730>>26060000
                                                               <<03633>>26065000
<< get serial disc xds number from ldt extension.           >> <<03633>>26070000
                                                               <<03633>>26075000
save'ldt'sir := getsir (ldt'sir);                              <<06730>>26080000
movefromdseg (@ldt, ldt'dst, 0, size'of'ldt'entry);            <<06730>>26085000
movefromdseg (@ldtx, ldt'dst, ldtx'base +                      <<06730>>26090000
              ldev * size'of'ldtx'entry, size'of'ldtx'entry);  <<06730>>26095000
segnum := ldtx'sdisc'gpt'xds;                                  <<06730>>26100000
                                                               <<03633>>26105000
<< segment exists only if the device is a serial disc,  but >> <<03633>>26110000
<< the  foreign  disc facility uses the ldtx entry as well. >> <<03633>>26115000
<< thus the ldtx entry must be cleared in any case.         >> <<03633>>26120000
                                                               <<03633>>26125000
ldtx'serial'or'foreign := false;                               <<06730>>26130000
ldtx'sdisc'gpt'xds := 0;                                       <<06730>>26135000
movetodseg (ldt'dst, ldtx'base + ldev *                        <<06730>>26140000
            size'of'ldtx'entry, @ldtx, size'of'ldtx'entry);    <<06730>>26145000
if segnum > 1 then                                             <<s7474>>26150000
   begin   << serial disc, release xds, clear lpdt bit.     >> <<s7474>>26155000
   reldataseg (segnum);                                        <<03633>>26160000
   disable;                                                    <<s7474>>26165000
   lpdt'serial'disc := false;                                  <<s7474>>26170000
   enable;                                                     <<s7474>>26175000
   end;    << serial disc, release xds, clear lpdt bit.     >> <<s7474>>26180000
relsir (ldt'sir, save'ldt'sir);                                <<06730>>26185000
end;   << unlock cs80 dev, deallocate sd xds >>                <<03633>>26190000
$page "   ***   DEALLOCATE   ***"                              <<06730>>26195000
$control segment = allocutil                                   <<06730>>26200000
                                                                        26205000
                                                                        26210000
procedure deallocate (devparm);                                         26215000
   value devparm;                                                       26220000
   double devparm;                                             <<06730>>26225000
   option privileged, uncallable;                                       26230000
begin                                                                   26235000
                                                               <<04201>>26240000
   << the stdlistfail bit will be set by morgue when the     >><<04201>>26245000
   << fjopen of $stdlist (from :job, i.e. virtual) fails. in >><<04201>>26250000
   << this case, we want make sure the file usecount (ldt(0))>><<04201>>26255000
   << gets set to zero, the lpdt shows as unowned, and that  >><<04201>>26260000
   << the odd entry gets removed. however we do not want to  >><<04201>>26265000
   << perform any disc deallocation. before ucop launches a  >><<04201>>26270000
   << job/session it will pre-allocate the devices for $stdx.>><<04201>>26275000
   << ucop will never allocate the disc space for the spooled>><<04201>>26280000
   << devices. fjopen will not perform any deallocation - it >><<04201>>26285000
   << knows that $stdlist is a new file so upon a failure has>><<04201>>26290000
   << nothing to deallocate. so it now becomes morgue's      >><<04201>>26295000
   << responsibility to clean up after the fjopen failures.  >><<06730>>26300000
   << therefore we will do everything except deallocate disc >><<04201>>26305000
   << space.                                                 >><<04201>>26310000
                                                               <<07050>>26315000
<< note:  the following equate is a parameter to the  awake >> <<07050>>26320000
<< procedure,  and  represents  a  pcb  event mask position >> <<07050>>26325000
<< shifted right four bits.  it is currently unavailable in >> <<07050>>26330000
<< any $include file, which is why it is here!  if the  un- >> <<07050>>26335000
<< derlying  event  mask  (or the awake interface) changes, >> <<07050>>26340000
<< this equate will also have to change.                    >> <<07050>>26345000
                                                               <<07050>>26350000
   equate                                                      <<07050>>26355000
                     junkwait   = %20;                         <<07050>>26360000
                                                               <<04201>>26365000
   define            << input parameter breakdown: >>                   26370000
                     alloced     = not devparm0.(5:1) #,       <<06730>>26375000
                     ioabort     =     devparm0.(4:1) #,       <<06730>>26380000
                     labelled    =     devparm0.(3:1) #,       <<06730>>26385000
                     ldev        =     devparm1       #,       <<06730>>26390000
                     primed      = not devparm0.(7:1) #,       <<06730>>26395000
                     stdlistfail =     devparm0.(2:1) #,       <<06730>>26400000
                     wait        = not devparm0.(6:1) #;       <<06730>>26405000
                                                               <<06730>>26410000
   equate            ds'pseudo'term = 3;                       <<06730>>26415000
                                                               <<06730>>26420000
   integer           save'ldt'sir,                             <<06730>>26425000
                     save'xdd'sir;                             <<06730>>26430000
   logical pointer   xdd'head,       << req'd by xdd $incl  >> <<06730>>26435000
                     xdd'subentry;   << this one too.       >> <<06730>>26440000
   double pointer    xdd'dsubentry = xdd'subentry;             <<06730>>26445000
   double array      diskaddr(0:1) = q;                                 26450000
   byte   array      diskaddr'b(*) = diskaddr;                 <<s8651>>26455000
   integer           ldt'index := 0,                           <<06730>>26460000
                     ldtx'index := 0,                          <<06730>>26465000
                     lpdt'index,                               <<06730>>26470000
                     rooster'parm;                             <<06730>>26475000
   logical           devparm0 = devparm,                       <<06730>>26480000
                     devparm1 = devparm0 + 1,                  <<06730>>26485000
                     found'it,                                 <<06730>>26490000
                     trailerprinted  := false;                 <<06730>>26495000
   logical array                                               <<06730>>26500000
      ldt (0:size'of'ldt'entry-1),                             <<06730>>26505000
      ldtx(0:size'of'ldtx'entry-1),                            <<06730>>26510000
      xdd(*) = db + 0;   << required by xdd $include file.  >> <<06730>>26515000
                                                               <<06730>>26520000
                                                               <<06730>>26525000
   subroutine def'movefromdseg;                                <<06730>>26530000
                                                               <<06730>>26535000
   subroutine def'movetodseg;                                  <<06730>>26540000
                                                                        26545000
                                                                        26550000
logical subroutine find'entry (xdd'dst, xdd'sir, remove);      <<06730>>26555000
   value   xdd'dst, xdd'sir, remove;                           <<06730>>26560000
   integer xdd'dst, xdd'sir;                                   <<06730>>26565000
   logical remove;                                             <<06730>>26570000
                                                               <<06730>>26575000
begin comment --                                               <<06730>>26580000
  find'entry searches the chain defined externally by xdd'head <<06730>>26585000
for an appropriate subentry and returns its xdd  segment-rela- <<06730>>26590000
tive address.  if remove is true the subentry is also delinked <<06730>>26595000
from the chain and its space deallocated from the XDD. "Appro- <<06730>>26600000
priate" here means a non-spooled devicefile in the OPEN  state <<06730>>26605000
(alloced = true) or the ready state (alloced = false). spooled <<06730>>26610000
devicefiles are ignored in here.                               <<06730>>26615000
;                                                              <<06730>>26620000
exchangedb (xdd'dst);                                          <<06730>>26625000
save'xdd'sir := getsir (xdd'sir);                              <<06730>>26630000
@xdd'subentry := xddh'first'subentry;                          <<06730>>26635000
found'it := false;                                             <<06730>>26640000
                                                               <<06730>>26645000
while @xdd'subentry <> xdds'end'of'chain and not found'it do   <<06730>>26650000
      begin                                                    <<06730>>26655000
      if xddsd'disc'label = 0d then   << not spooled        >> <<06730>>26660000
         if alloced and xdds'spool'state = xdds'open           <<06730>>26665000
            or xdds'spool'state = xdds'ready                   <<06730>>26670000
            then found'it := true;                             <<06730>>26675000
      if not found'it then @xdd'subentry := xdds'next'subentry;<<06730>>26680000
      end;   << while loop.                                 >> <<06730>>26685000
                                                               <<06730>>26690000
if (find'entry := @xdd'subentry) <> xdds'end'of'chain          <<06730>>26695000
   and remove then                                             <<06730>>26700000
   begin                                                       <<06730>>26705000
   tos := @xddh'first'subentry;     << can't fool spl...    >> <<06730>>26710000
   delinkentry (*, xdd'subentry);   <<   any other way.     >> <<06730>>26715000
   deallocentry (xdd'subentry);                                <<06730>>26720000
   end;                                                        <<06730>>26725000
relsir (xdd'sir, save'xdd'sir);                                <<06730>>26730000
exchangedb (stack);                                            <<06730>>26735000
end;             << of find'entry.                          >> <<06730>>26740000
                                                                        26745000
                                                                        26750000
   lpdt'index := ldev * lpdt'entry'size;                       <<06730>>26755000
   save'ldt'sir := getsir (ldt'sir);                           <<06730>>26760000
   movefromdseg (@ldt, ldt'dst, 0, size'of'ldt'entry);         <<06730>>26765000
   movefromdseg (@ldtx, ldt'dst, logical (ldtx'base) +         <<06730>>26770000
                 ldev*size'of'ldtx'entry, size'of'ldtx'entry); <<06730>>26775000
   movefromdseg (@ldt, ldt'dst, ldev * size'of'ldt'entry,      <<06730>>26780000
                 size'of'ldt'entry);                           <<06730>>26785000
   if ldt'access'type = ldt'direct'access and                  <<06730>>26790000
      not lpdt'not'pv'or'sys then                              <<06730>>26795000
      begin   << system disc or private volume.             >> <<06730>>26800000
      ldt'file'use'cnt := ldt'file'use'cnt - 1;                <<06730>>26805000
      if ldt'file'use'cnt = 0 and ldt'down'pending then        <<06730>>26810000
         begin    <<down was pending: take down>>                       26815000
         ldt'down'pending := false;   << no longer pending. >> <<06730>>26820000
         ldt'avail'to'sys := false;                            <<06730>>26825000
         movetodseg (ldt'dst, ldev * size'of'ldt'entry, @ldt,  <<06730>>26830000
                     size'of'ldt'entry);                       <<06730>>26835000
         relsir (ldt'sir, save'ldt'sir);                       <<06730>>26840000
                                                               <<03507>>26845000
         << deallocate and delete disc free space data >>      <<03507>>26850000
         << segment, ignore errors.                    >>      <<03507>>26855000
                                                               <<03507>>26860000
         deallocate'dfs'data'seg (ldev);                       <<03507>>26865000
                                                               <<03507>>26870000
         delete'dfs'data'seg (ldev);                           <<03507>>26875000
                                                               <<03507>>26880000
         genmsg(1,250,%10000,ldev,,,,,0);                      <<0u.eb>>26885000
         end;                                                           26890000
      end    <<disc dealloc>>                                           26895000
   else                                                                 26900000
      begin    <<non-sharable device>>                                  26905000
      if not alloced then goto elim;                                    26910000
                                                                        26915000
      if not ldt'cs'device and not lpdt'virtual'device then    <<06730>>26920000
        if primed or ldt'device'type = ldt'terminal then       <<06730>>26925000
          if ldt'file'use'cnt > 1 then                         <<06730>>26930000
             begin   << not the last fclose to this device. >> <<06730>>26935000
             relsir (ldt'sir, save'ldt'sir);                   <<06730>>26940000
             attachio (ldev, 0, 0, 0, 3, 0, 0, 0, 7);          <<06730>>26945000
             save'ldt'sir := getsir (ldt'sir);                 <<06730>>26950000
             end                                               <<06730>>26955000
          else << file'use'cnt = 1 >>                                   26960000
            if get'dsdevice(ldev) = ds'pseudo'term then        <<06730>>26965000
              begin                                            <<06730>>26970000
              relsir (ldt'sir, save'ldt'sir);                  <<06730>>26975000
              attachio (ldev, 0, 0, 0, 3, 0, 1, 0, 1);         <<06730>>26980000
              save'ldt'sir := getsir (ldt'sir);                <<06730>>26985000
              end                                              <<06730>>26990000
            else << file'use'cnt = 1, not pseudo-terminal >>            26995000
              if not ldtx'ciper'protocol then                  <<06730>>27000000
                begin                                          <<04843>>27005000
                relsir (ldt'sir, save'ldt'sir);                <<06730>>27010000
                attachio (ldev, 0, 0, 0, 3, 0, 0, 0, %17);     <<07229>>27015000
                save'ldt'sir := getsir (ldt'sir);              <<06730>>27020000
                end;                                           <<04843>>27025000
                                                               <<04843>>27030000
<< if we took one of the three paths above  which  releases >> <<b8395>>27035000
<< the  ldt  sir, another process may have modified the use >> <<b8395>>27040000
<< count.  refresh the local copy now that we have the  sir >> <<b8395>>27045000
<< again.                                                   >> <<b8395>>27050000
                                                               <<b8395>>27055000
      movefromdseg (@ldt, ldt'dst, ldev * size'of'ldt'entry,   <<b8395>>27060000
                    size'of'ldt'entry);                        <<b8395>>27065000
      ldt'file'use'cnt := ldt'file'use'cnt - 1;                <<06730>>27070000
      if integer (ldt'file'use'cnt) < 0 then                   <<07050>>27075000
         suddendeath (sd366);                                  <<07050>>27080000
      if ldt'file'use'cnt = 0 then                             <<06730>>27085000
         begin    <<final dealloc>>                                     27090000
  elim:                                                                 27095000
         ldt'main'pin := 0;                                    <<06730>>27100000
         if not lpdt'virtual'device then                       <<06730>>27105000
            begin  <<real device>>                                      27110000
                                                               <<04274>>27115000
            << if forms on a terminal, turn forms off.      >> <<04274>>27120000
                                                               <<04274>>27125000
            if ldt'device'type = ldt'terminal then             <<06730>>27130000
               ldt'special'forms := 0;                         <<06730>>27135000
                                                               <<04274>>27140000
            @xdd'head := ldt'xdd'head'index * size'of'xdd'head;<<06730>>27145000
            movetodseg (ldt'dst, ldev * size'of'ldt'entry,     <<06730>>27150000
                        @ldt, size'of'ldt'entry);              <<06730>>27155000
            relsir (ldt'sir, save'ldt'sir);                    <<06730>>27160000
                                                               <<06730>>27165000
<< even though we've updated the ldt, we  can  continue  to >> <<06730>>27170000
<< read from our local copy.                                >> <<06730>>27175000
                                                               <<06730>>27180000
            if ioabort and ldt'access'type <> ldt'io'concurrent<<06730>>27185000
               and ldt'access'type <> ldt'direct'access        <<06730>>27190000
               then abortio(-ldev);                                     27195000
            if ldt'access'type <> ldt'serial'in                <<06730>>27200000
               and (@xdd'subentry := find'entry (odd'dst,      <<06730>>27205000
                    odd'sir, false)) <> xdds'end'of'chain then <<06730>>27210000
               begin    <<odd entry exists: [trailer &] remove>>        27215000
               if primed then                                           27220000
                  begin                                        <<06730>>27225000
                  if ldtx'ciper'protocol then                  <<06730>>27230000
                                                               <<06730>>27235000
  comment -- this is the second time the ciper protocol forces <<06730>>27240000
us to stand on our heads.  the first time was a few lines  ago <<06730>>27245000
where the final (use count -> 0) attachio fclose was postponed <<06730>>27250000
for ciper devices.  here we do a special case (that is, ciper) <<06730>>27255000
buffer flush (function 186, return job report  with  p1  =  0, <<06730>>27260000
flush  all  buffers to the device), then come out to print any <<06730>>27265000
required trailer (any eligible device, not just  ciper),  then <<06730>>27270000
back  into ciper to send it the end of job (function 145), and <<06730>>27275000
finally the long-neglected final attachio fclose.  this  whole <<06730>>27280000
area of deallocate could stand some rethinking.                <<06730>>27285000
;                                                              <<06730>>27290000
                     attachio (ldev,0,0,0,186,0,0,0,1);        <<06730>>27295000
                  trailerprinted := trailer (xdd'subentry,     <<06730>>27300000
                     ldev, ldt'device'type, ldt'record'width); <<06730>>27305000
                  if ldtx'ciper'protocol then                  <<06730>>27310000
                     begin   << end of job, final fclose.   >> <<06730>>27315000
                     attachio (ldev,0,0,0,145,0,0,0,1);        <<06730>>27320000
                     attachio (ldev,0,0,0,  3,0,0,0,1);        <<06730>>27325000
                     end;                                      <<06730>>27330000
                  end;   << if primed...                    >> <<06730>>27335000
               tos := @xdd'subentry;                           <<06730>>27340000
               tos.(0:1) := 1;                                          27345000
               sremovexdd (*);                                          27350000
               end;                                                     27355000
            if ldt'access'type <> ldt'serial'out then          <<06730>>27360000
               << find entry and remove, if there is 1 >>               27365000
               find'entry (idd'dst, idd'sir, true);            <<06730>>27370000
                                                               <<03607>>27375000
<< the call to freedevice must precede the release  of  any >> <<03607>>27380000
<< serial disc extra data segment.  freedevice makes an at- >> <<03607>>27385000
<< tachio device close call which is ignored by the  serial >> <<03607>>27390000
<< disc code if the data segment has been released. but the >> <<03607>>27395000
<< device close call is sometimes needed to insure that the >> <<03607>>27400000
<< serial disc is logically (and for linus physically) dis- >> <<03607>>27405000
<< mounted.                                                 >> <<03607>>27410000
                                                               <<03607>>27415000
            freedevice (ldev, wait land trailerprinted,        <<tl.02>>27420000
                        labelled);                             <<tl.02>>27425000
            if ldt'access'type = ldt'direct'access and         <<06730>>27430000
               lpdt'not'pv'or'sys and not labelled then        <<06730>>27435000
               fors'xds'dealloc (ldev);                        <<06730>>27440000
            end    << real device.                          >>          27445000
         else                                                           27450000
            begin  <<virtual device>>                                   27455000
            @xdd'subentry := lpdt'xdd'subentry'ptr;            <<06730>>27460000
            if lpdt'vdev'direction = lpdt'vdev'input then      <<06730>>27465000
               begin                                           <<06730>>27470000
               sremovexdd (xdd'subentry);                      <<06730>>27475000
               movetodseg (ldt'dst, ldev * size'of'ldt'entry,  <<06730>>27480000
                           @ldt, size'of'ldt'entry);           <<06730>>27485000
               relsir (ldt'sir, save'ldt'sir);                 <<06730>>27490000
               end                                             <<06730>>27495000
            else                                                        27500000
               begin    << new spoolfile >>                             27505000
               exchangedb (odd'dst);                           <<06730>>27510000
               save'xdd'sir := getsir (odd'sir);               <<06730>>27515000
               @xdd'head := xdds'head'index * xdd0'head'length;<<06730>>27520000
               tos := @xddh'first'subentry;  << to fool...  >> <<06730>>27525000
               delinkentry (*, xdd'subentry);  << spl.      >> <<06730>>27530000
               if primed then                                           27535000
                  begin                                                 27540000
                  slinkxdd (xdds'head'index, xdd'subentry);    <<06730>>27545000
                  xdds'spool'state := xdds'ready;              <<06730>>27550000
                  xddsd'ready'time := doubletime;              <<06730>>27555000
                  if xdds'class then                           <<06730>>27560000
                     rooster'parm := -xdds'device              <<06730>>27565000
                  else rooster'parm := xdds'device;            <<06730>>27570000
                  end                                                   27575000
               else                                                     27580000
                  begin                                                 27585000
                  tos := lun (xdds'spoofle'vt'index, 0);       <<s8651>>27590000
                  diskaddr := xddsd'disc'label;                <<s8651>>27595000
                  diskaddr'b := tos;                           <<s8651>>27600000
                  deallocentry (xdd'subentry);                 <<06730>>27605000
                  end;                                                  27610000
               relsir (odd'sir, save'xdd'sir);                 <<06730>>27615000
               exchangedb (stack);                             <<06730>>27620000
               movetodseg (ldt'dst, ldev * size'of'ldt'entry,  <<06730>>27625000
                           @ldt, size'of'ldt'entry);           <<06730>>27630000
               relsir (ldt'sir, save'ldt'sir);                 <<06730>>27635000
               if primed then                                           27640000
                  srooster (rooster'parm)                      <<06730>>27645000
               else                                                     27650000
                  begin                                                 27655000
                  if not stdlistfail  then                     <<04201>>27660000
                      diskdealloc(0,0,%201,diskaddr);          <<04201>>27665000
                  end;                                                  27670000
               end;   << new spoolfile.                     >> <<07050>>27675000
            disable;                                           <<06730>>27680000
            lpdt'dev'own'state := lpdt'not'owned;              <<06730>>27685000
                                                               <<07050>>27690000
  comment -- we communicate with ucop  through  some  bits  in <<07050>>27695000
sysglob.  we set a bit saying we are freeing up a device. then <<07050>>27700000
we see if ucop is waiting for a device to become free (another <<07050>>27705000
bit).  if so we awaken ucop, because we have just freed one it <<07050>>27710000
may be able to use.  we also clear the ucop wait bit.          <<07050>>27715000
;                                                              <<07050>>27720000
            sysdevavail := true;                               <<07050>>27725000
            tos := syswaitfordev;                              <<07050>>27730000
            syswaitfordev := false;                            <<07050>>27735000
            enable;                                            <<07050>>27740000
            if tos then awake (sysucoppcb, junkwait, 0);       <<07050>>27745000
            end;   << virtual device.                       >> <<07050>>27750000
         end     << final devicefile deallocation.          >> <<06730>>27755000
      else                                                     <<06730>>27760000
         begin   << not final dealloc., release resources.  >> <<06730>>27765000
         movetodseg (ldt'dst, ldev * size'of'ldt'entry, @ldt,  <<06730>>27770000
                     size'of'ldt'entry);                       <<06730>>27775000
         relsir (ldt'sir, save'ldt'sir);                       <<06730>>27780000
         end;                                                  <<06730>>27785000
      end;    <<non-sharable device treatment>>                         27790000
   end;    <<deallocate>>                                               27795000
$page "   ***   Global symbol table   ***"                     <<06730>>27800000
$page                                                          <<06730>>27805000
$control segment=main                                                   27810000
end.   << of module allocate.                               >> <<06730>>27815000
