<< LINES .001/.009 ARE RESERVED FOR SYSTEMS INTEGRATION>>               00005000
$control map,code,uslinit                                               00010000
<< morgue -- module 64 >>                                      <<01071>>00015000
<< hp32002c mpe source c.00.00 >>                                       00020000
$copyright     "(C) COPYRIGHT HEWLETT-PACKARD CO. 1980. ",            & 00025000
$     "THIS PROGRAM MAY BE USED WITH ONE COMPUTER SYSTEM AT A ",      & 00030000
$     "TIME AND SHALL NOT OTHERWISE BE RECORDED, TRANSMITTED OR ",    & 00035000
$     "STORED IN A RETRIEVAL SYSTEM.  COPYING OR OTHER REPRODUCTION ",& 00040000
$     "OF THIS PROGRAM EXCEPT FOR ARCHIVAL PURPOSES IS PROHIBITED ",  & 00045000
$     "WITHOUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY."   00050000
$thirty                                                                 00055000
$control segment=morgue,main=morgue                            <<02.eb>>00060000
$control privileged                                                     00065000
<<                                                           >><<06672>>00070000
<< * fix information                                         >><<06672>>00075000
<<     the procedure cleanupjob now has the new algorithm    >><<06672>>00080000
<<     for freeing up an entry in the jpcnt table.           >><<06672>>00085000
<<                                                           >><<06672>>00090000
begin                                                                   00095000
$include inclpcb5                                              <<06646>>00100000
$include inclreg                                               <<06659>>00105000
$include inclobj                                               <<06659>>00110000
equate   << genmsg messages >>                                 <<05.eb>>00115000
   syset       = 1,                                            <<05.eb>>00120000
   sesslogoff  = 37,                                           <<05.eb>>00125000
   joblogoff   = 45,                                           <<05.eb>>00130000
   conslogoff  = 41,                                           <<05.eb>>00135000
   negcontime = 73,                                            <<04155>>00140000
   negcputime = 74,                                            <<04155>>00145000
   loginfo     = %1167;                                        <<05.eb>>00150000
define                                                                  00155000
         abs      = absolute#,                                 <<01549>>00160000
         asmb     = assemble#,                                 <<01549>>00165000
         trapsoff = push(status);                              <<01549>>00170000
                    tos.(2:1) := 0;                            <<01549>>00175000
                    set(status)#,                              <<01549>>00180000
         a'         = absolute           #,                             00185000
         enable     = assemble(sed 1)    #,                             00190000
         disable    = assemble(sed 0)    #,                             00195000
         enaproc    = assemble(pseb)     #,                             00200000
         disaproc   = assemble(psdb)     #,                    <<05.eb>>00205000
         loglogoff  = absolute(loginfo).(12:1) #;              <<05.eb>>00210000
define logicalmapping = absolute(%1220)#;                      <<06402>>00215000
                                                               <<01614>>00220000
equate                                                         <<06890>>00225000
         ci'proc    = 2,                                       <<06890>>00230000
         session    = 1;                                       <<06890>>00235000
                                                               <<06890>>00240000
integer                                                                 00245000
         x          = x       ,                                         00250000
         status     = q-1     ,                                         00255000
         s0         = s-0     ,                                         00260000
         s1         = s-1     ,                                         00265000
         xreg       = x       ;                                         00270000
integer pointer                                                         00275000
         ps0        = s-0     ;                                         00280000
byte pointer                                                            00285000
         bps0       = s-0     ;                                         00290000
double                                                                  00295000
         ds1        = s-1     ;                                         00300000
                                                               <<06659>>00305000
logical                                                        <<06659>>00310000
         ls0        = s-0     ,                                <<06659>>00315000
         ls1        = s-1     ;                                <<06659>>00320000
                                                               <<06659>>00325000
$page "***   SYSTEM TABLES/CONSTANTS/POINTERS   ***"                    00330000
equate                                                                  00335000
         ccg        = 0       ,                                         00340000
         ccl        = 1       ,                                         00345000
         cce        = 2       ,                                         00350000
   <<fixed cells>>                                                      00355000
         cstb       = 0       ,                                         00360000
         xcst       = 1       ,                                         00365000
         dstb       = 2       ,                                         00370000
         qi         = 5       ,                                         00375000
         zi         = 6       ;                                <<06890>>00380000
   <<tables>>                                                           00385000
$include incllpdt                                              <<06890>>00390000
$include inclldt5                                              <<06890>>00395000
logical pointer                                                <<06646>>00400000
         sys'pcb    = 3;                                       <<06646>>00405000
integer pointer                                                <<06887>>00410000
         jcutarr = %13;                                        <<06887>>00415000
$include inclcis                                               <<04602>>00420000
integer udcdstno = cis'udc0;                                   <<04602>>00425000
$page "***   SYSTEM TABLES/CONSTANTS/POINTERS   ***"           <<04602>>00430000
define initlocflag=(1:1)#,                                     <<01549>>00435000
       flushlocflag=(2:1)#;                                    <<01549>>00440000
equate pcbix=3;                                                <<01549>>00445000
integer pcbsysbaseinx=db+pcbix;                                <<01549>>00450000
                                                               <<01549>>00455000
define                                                         <<04799>>00460000
   def'movefromdseg =                                          <<04799>>00465000
      movefromdseg(target,dstn,offset,count);                  <<04799>>00470000
      value target,dstn,offset,count;                          <<04799>>00475000
      logical target,dstn,offset,count;                        <<04799>>00480000
      begin                                                    <<04799>>00485000
        x := tos;    <<  save return address  >>               <<04799>>00490000
        assemble(mfds 0);                                      <<04799>>00495000
        tos := x;    <<  restore return address  >>            <<04799>>00500000
      end#;                                                    <<04799>>00505000
                                                               <<06673>>00510000
define                                                         <<06673>>00515000
   def'movetodseg =                                            <<06673>>00520000
      movetodseg(dstn, offset, source, count);                 <<06673>>00525000
        value dstn, offset, source, count;                     <<06673>>00530000
        logical dstn, offset, source, count;                   <<06673>>00535000
        begin                                                  <<06673>>00540000
          x := tos;  << save return address >>                 <<06673>>00545000
          assemble(mtds 0);                                    <<06673>>00550000
          tos := x;   << and restore the return address >>     <<06673>>00555000
        end#;                                                  <<06673>>00560000
                                                               <<06673>>00565000
$include inclmeas                                              <<01739>>00570000
                                                                        00575000
$include inclmift                                              <<04108>>00580000
$include inclmmst                                              <<06893>>00585000
$include inclrins                                              <<*7770>>00590000
$set x8=off                                                    <<06673>>00595000
$include incljmat                                              <<06673>>00600000
                                                               <<06673>>00605000
<< auxiliary jmat declarations >>                              <<06673>>00610000
equate                                                         <<06673>>00615000
    sessiontype = 1;  << type of a session >>                  <<06673>>00620000
define   meas'flag  = measinfotabptr(56)#;                     <<06893>>00625000
                                                               <<06632>>00630000
array qarray(*) = q+0;                                         <<*7770>>00635000
$include inclpxdl                                              <<*7770>>00640000
$include inclpxgt                                              <<*7770>>00645000
$include inclpxft                                              <<*7770>>00650000
$page "***   EXTERNAL PROCEDURES   ***"                                 00655000
$include incljcut                                              <<06887>>00660000
$include incljit                                               <<06888>>00665000
                                                                        00670000
$include incljpct                                              <<06672>>00675000
                                                                        00680000
double procedure subqueue(n,criteria);                                  00685000
   value n,criteria;                                                    00690000
   integer n,criteria;                                                  00695000
   option external;                                                     00700000
                                                                        00705000
integer procedure get'dsdevice(ldev);                          <<02077>>00710000
   value ldev;                                                 <<02077>>00715000
   integer ldev;                                               <<02077>>00720000
   option external;                                            <<02077>>00725000
                                                               <<02077>>00730000
procedure adjustlocality(procinx,objident,reqsize,flags);      <<06659>>00735000
value procinx,objident,reqsize,flags;                          <<06659>>00740000
logical procinx,reqsize,flags;                                 <<06659>>00745000
double objident;                                               <<06659>>00750000
option external;                                               <<01549>>00755000
                                                               <<01549>>00760000
procedure queueproc(procsysdbinx,queuename,location);          <<01549>>00765000
value procsysdbinx,queuename,location;                         <<01549>>00770000
integer procsysdbinx,queuename,location;                       <<01549>>00775000
option external;                                               <<01549>>00780000
                                                                        00785000
logical procedure checkalive (pin); value pin; integer pin;    <<01874>>00790000
option external;                                               <<01874>>00795000
                                                               <<01874>>00800000
logical procedure getsir (n);                                           00805000
   value   n;                                                           00810000
   logical n;                                                           00815000
   option external;                                                     00820000
                                                                        00825000
procedure relsir (n,f);                                                 00830000
   value   n,f;                                                         00835000
   logical n,f;                                                         00840000
   option external;                                                     00845000
                                                                        00850000
procedure freelocrin;                                                   00855000
   option external;                                                     00860000
                                                                        00865000
procedure suddendeath (n);                                              00870000
   value   n;                                                           00875000
   integer n;                                                           00880000
   option external;                                                     00885000
                                                                        00890000
procedure errorexit (i,e,p);                                            00895000
   value   i,e,p;                                                       00900000
   logical i,e,p;                                                       00905000
   option external;                                                     00910000
                                                                        00915000
procedure erroron;                                                      00920000
   option external;                                                     00925000
                                                                        00930000
procedure abortprocio (a);                                              00935000
   value   a;                                                           00940000
   integer a;                                                           00945000
   option external;                                                     00950000
                                                                        00955000
procedure runlock (r);                                                  00960000
   value   r;                                                           00965000
   integer r;                                                           00970000
   option external;                                                     00975000
                                                                        00980000
procedure print (mes,l,ctl);                                            00985000
   value   l,ctl;                                                       00990000
   integer l,ctl;                                                       00995000
   array   mes;                                                         01000000
   option external;                                                     01005000
                                                                        01010000
procedure remritentry'(pin,flag);                              <<01400>>01015000
   value pin, flag;                                            <<01400>>01020000
   integer pin, flag;                                          <<01400>>01025000
   option external;                                            <<01400>>01030000
                                                                        01035000
procedure wait (wf,jpc);                                                01040000
   value   wf,jpc;                                                      01045000
   integer wf,jpc;                                                      01050000
   option external;                                                     01055000
                                                                        01060000
logical procedure setsysdb;                                             01065000
   option external;                                                     01070000
                                                                        01075000
procedure resetdb (a);                                                  01080000
   value   a;                                                           01085000
   logical a;                                                           01090000
   option external;                                                     01095000
                                                                        01100000
procedure returnentry (li,ix);                                          01105000
   value   li,ix;                                                       01110000
   integer li,ix;                                                       01115000
   option external;                                                     01120000
                                                                        01125000
procedure reldataseg (ix);                                              01130000
   value   ix;                                                          01135000
   integer ix;                                                          01140000
   option external;                                                     01145000
                                                                        01150000
logical procedure exchangedb (a);                                       01155000
   value   a;                                                           01160000
   logical a;                                                           01165000
   option external;                                                     01170000
                                                                        01175000
procedure fprocterm;                                                    01180000
   option external;                                                     01185000
                                                               <<04809>>01190000
procedure fproctermjob;  << special entry fprocterm >>         <<04809>>01195000
   option external;                                            <<04809>>01200000
                                                                        01205000
procedure requcop (a,b,c);                                              01210000
   value   a,b,c;                                                       01215000
   logical a,b,c;                                                       01220000
   option external;                                                     01225000
                                                                        01230000
procedure unload (pin);                                                 01235000
   value   pin;                                                         01240000
   integer pin;                                                         01245000
   option external;                                                     01250000
                                                                        01255000
procedure abortmail;                                                    01260000
   option external;                                                     01265000
                                                                        01270000
procedure abortdseg (f);                                                01275000
   value   f;                                                           01280000
   logical f;                                                           01285000
   option external;                                                     01290000
                                                                        01295000
procedure awake (p, w, s);                                              01300000
   value p, w, s;                                                       01305000
   integer p, w, s;                                                     01310000
   option external;                                                     01315000
                                                                        01320000
integer procedure fdelete (i,j,mvtabx);                        <<rv.pv>>01325000
   value   i,j,mvtabx;                                         <<rv.pv>>01330000
   integer i,mvtabx;                                           <<rv.pv>>01335000
   double  j;                                                           01340000
   option external,variable;                                   <<rv.pv>>01345000
                                                                        01350000
integer procedure genmsg(setno,msgno,mask,a,b,c,d,e,           <<0u.eb>>01355000
      dest,reply,buff,dst,iotype);                             <<0u.eb>>01360000
   value setno,msgno,mask,a,b,c,d,e,dest,reply,buff,           <<0u.eb>>01365000
      dst,iotype;                                              <<0u.eb>>01370000
   logical setno,msgno,mask,a,b,c,d,e,dest,reply,buff,         <<0u.eb>>01375000
      dst,iotype;                                              <<0u.eb>>01380000
   option variable,external;                                   <<0u.eb>>01385000
                                                                        01390000
logical procedure resetbreakbits (ldev,code);                  <<r8819>>01395000
   value   ldev,code;                                                   01400000
   integer ldev,code;                                                   01405000
   option external;                                                     01410000
                                                                        01415000
integer procedure direclogoff(mask,jmatentry,t1,t2,aentry,     <<02.eb>>01420000
      uentry,gentry);                                          <<02.eb>>01425000
   value mask, t1, t2;                                                  01430000
   integer mask;                                                        01435000
   array jmatentry,aentry,uentry,gentry;                       <<02.eb>>01440000
   double t1, t2;                                                       01445000
   option external;                                                     01450000
                                                                        01455000
procedure usertable(funct,pininfo,mvtabx,retinfo,retsize);     <<rh.pv>>01460000
   value funct,pininfo,mvtabx,retsize;                         <<rh.pv>>01465000
   integer funct,pininfo,mvtabx,retsize;                       <<rh.pv>>01470000
   array retinfo;                                              <<rh.pv>>01475000
   option variable,external;                                   <<rh.pv>>01480000
                                                               <<rh.pv>>01485000
procedure dismount (vsname,vsgroup,vsaccnt,reqtype,            <<00244>>01490000
                    pvinfo,some'other'pin);                    <<00244>>01495000
   value pvinfo,some'other'pin;                                <<00244>>01500000
   integer reqtype,pvinfo,some'other'pin;                      <<00244>>01505000
   byte array vsname,vsgroup,vsaccnt;                          <<rh.pv>>01510000
   option variable,external;                                   <<rh.pv>>01515000
                                                               <<rh.pv>>01520000
procedure fmtdate(calendar',clock',string);                    <<05.eb>>01525000
   value calendar',clock';                                     <<05.eb>>01530000
   logical calendar';                                          <<05.eb>>01535000
   double clock';                                              <<05.eb>>01540000
   byte array string;                                          <<05.eb>>01545000
   option external;                                            <<05.eb>>01550000
                                                               <<05.eb>>01555000
procedure date'line (bbuf);                                             01560000
   byte array bbuf;                                                     01565000
   option external;                                                     01570000
                                                                        01575000
logical procedure calendar;                                             01580000
   option external;                                                     01585000
                                                                        01590000
double procedure clock;                                                 01595000
   option external;                                                     01600000
                                                                        01605000
double procedure timer;                                        <<01739>>01610000
  option external;                                             <<01739>>01615000
                                                               <<01739>>01620000
procedure cleantape(pinno);                                    <<tl.02>>01625000
  value pinno;                                                 <<tl.02>>01630000
  integer pinno;                                               <<tl.02>>01635000
  option external;                                             <<tl.02>>01640000
                                                               <<tl.02>>01645000
procedure log3 (maxpri, creates, cput, elapsedt, logtype);              01650000
   value maxpri, creates, cput, elapsedt, logtype;                      01655000
   integer maxpri, creates, logtype;                                    01660000
   double cput, elapsedt;                                               01665000
   option external;                                                     01670000
                                                                        01675000
logical procedure iocontrol(dev,func);                                  01680000
   value dev,func;                                                      01685000
   integer dev,func;                                                    01690000
   option external;                                                     01695000
                                                                        01700000
logical procedure mrcapok (sb, rin);                           <<00560>>01705000
   value sb, rin;                                              <<00560>>01710000
   logical sb;   integer rin;                                  <<00560>>01715000
   option external, variable;                                  <<00560>>01720000
                                                                        01725000
integer procedure setcritical;                                          01730000
   option external;                                                     01735000
                                                                        01740000
procedure resetcritical (a);                                            01745000
   value   a;                                                           01750000
   integer a;                                                           01755000
   option external;                                                     01760000
                                                                        01765000
procedure set'psif (pcbpt,f);                                           01770000
   value   pcbpt,f;                                                     01775000
   integer pcbpt,f;                                                     01780000
   option external;                                                     01785000
                                                                        01790000
procedure clear'psif (pcbpt,f);                                         01795000
   value   pcbpt,f;                                                     01800000
   integer pcbpt,f;                                                     01805000
   option external;                                                     01810000
                                                                        01815000
logical procedure  sysproc(p);                                          01820000
   value   p;                                                           01825000
   integer p;                                                           01830000
   option external;                                                     01835000
                                                                        01840000
procedure  mmstat'(e,p1,p2,p3,p4,p5,p6);                       <<06893>>01845000
   value e,p1,p2,p3,p4,p5,p6;                                  <<06893>>01850000
   integer e,p1,p2,p3,p4,p5,p6;                                <<06893>>01855000
   option external;                                                     01860000
                                                                        01865000
double procedure  attachio(p1,p2,p3,p4,p5,p6,p7,p8,p9);                 01870000
   value p1,p2,p3,p4,p5,p6,p7,p8,p9;                                    01875000
   integer p1,p2,p3,p4,p5,p6,p7,p8,p9;                                  01880000
   option external;                                                     01885000
                                                               <<06100>>01890000
logical procedure label'is'sl'seg(plabel,pcbpt);               <<06100>>01895000
   value plabel,pcbpt;                                         <<06100>>01900000
   integer plabel,pcbpt;                                       <<06100>>01905000
   option external;                                            <<06100>>01910000
                                                                        01915000
integer procedure cstconv(plabel,pcbpt);                       <<06100>>01920000
   value plabel,pcbpt;                                         <<06100>>01925000
   integer plabel,pcbpt;                                       <<06100>>01930000
   option external;                                            <<06100>>01935000
                                                               <<06402>>01940000
procedure rel'phy'cst(cstn);                                   <<06402>>01945000
   value cstn;                                                 <<06402>>01950000
   integer cstn;                                               <<06402>>01955000
   option external;                                            <<06402>>01960000
                                                                        01965000
integer procedure removestop(proc,pin,dbugid,ploc,info,plabl,  <<06677>>01970000
                             mode);                            <<06677>>01975000
  value proc,pin,dbugid,ploc;                                  <<06677>>01980000
  integer proc,pin,plabl,mode,ploc;                            <<06677>>01985000
  double dbugid;                                               <<06677>>01990000
  integer array info;                                          <<06677>>01995000
  option external,variable;                                    <<06677>>02000000
                                                               <<03047>>02005000
procedure loosesoftinterrupts;                                 <<03047>>02010000
option external;                                               <<03047>>02015000
                                                               <<03047>>02020000
procedure loosetrlx;                                           <<03047>>02025000
option external;                                               <<03047>>02030000
                                                                        02035000
procedure help;                                                         02040000
   option external;                                                     02045000
                                                                        02050000
double procedure startdevice (com,parr,dev,jm,id,jb);                   02055000
   value   com,dev;                                                     02060000
   integer com,dev,jb;                                                  02065000
   byte array parr;                                                     02070000
   integer pointer jm,id;                                               02075000
   option variable,external;                                            02080000
                                                                        02085000
integer procedure formerror (err,parm,buf);                             02090000
   value   err,parm;                                                    02095000
   integer err,parm;                                                    02100000
   array   buf;                                                         02105000
   option external;                                                     02110000
                                                                        02115000
procedure deallocate (xdev);                                            02120000
   value   xdev;                                                        02125000
   double xdev;                                                <<06673>>02130000
   option external;                                                     02135000
                                                                        02140000
procedure formuserid(idbuff);                                  <<04155>>02145000
   byte array idbuff;                                          <<04155>>02150000
   option external;                                            <<04155>>02155000
procedure freedevice (ldev,f);                                          02160000
   value   ldev,f;                                                      02165000
   integer ldev;                                                        02170000
   logical f;                                                           02175000
   option external;                                                     02180000
                                                                        02185000
procedure deallocate'jmat (ep);                                <<06673>>02190000
   value ep;                                                            02195000
   integer pointer ep;                                                  02200000
   option external;                                                     02205000
                                                                        02210000
procedure funbreak(f);                                                  02215000
   value   f;                                                           02220000
   logical f;                                                           02225000
   option external;                                                     02230000
                                                                        02235000
procedure fjclose (fnum, dummy1, dummy2);                               02240000
   value fnum, dummy1, dummy2;                                          02245000
   integer fnum, dummy1, dummy2;                                        02250000
   option external;                                                     02255000
                                                                        02260000
intrinsic dascii;                                                       02265000
                                                                        02270000
procedure cleanuplog;                                          <<00506>>02275000
option external;                                               <<00506>>02280000
logical procedure cilogtable(code,jmatx,cntword,command);      <<02.eb>>02285000
   value   code,jmatx;                                         <<02.eb>>02290000
   integer code,jmatx,cntword;                                 <<02.eb>>02295000
   integer array command;                                      <<02.eb>>02300000
    option external;                                           <<02.eb>>02305000
                                                               <<02.eb>>02310000
    <<fopen entry point>>                                      <<rv.pv>>02315000
integer procedure mustopen (fd,fo,ao,r,d,fm,u,b,n,fs,          <<rv.pv>>02320000
                          ne,i,fc);                            <<rv.pv>>02325000
    value   fo,ao,r,u,b,n,fs,ne,i,fc;                          <<rv.pv>>02330000
    byte array fd,d,fm;                                        <<rv.pv>>02335000
    logical fo,ao;                                             <<rv.pv>>02340000
    integer r,u,b,n,ne,i,fc;                                   <<rv.pv>>02345000
    double  fs;                                                <<rv.pv>>02350000
    option  external,variable;                                 <<rv.pv>>02355000
                                                               <<rv.pv>>02360000
                                                               <<rv.pv>>02365000
intrinsic                                                      <<rv.pv>>02370000
      fclose,ffileinfo,getjcw;                                 <<01549>>02375000
                                                               <<rv.pv>>02380000
logical procedure sfindodd(dfid,xddep);                        <<sp.sz>>02385000
   value dfid;                                                 <<sp.sz>>02390000
   integer dfid;                                               <<sp.sz>>02395000
   integer xddep;                                              <<sp.sz>>02400000
   option external;                                            <<sp.sz>>02405000
                                                               <<sp.sz>>02410000
double procedure xddspoolinfo(dvalue,item,xddsubp);            <<sp.sz>>02415000
   value dvalue,item,xddsubp;                                  <<sp.sz>>02420000
   logical item;                                               <<sp.sz>>02425000
   double dvalue;                                              <<sp.sz>>02430000
   integer pointer xddsubp;                                    <<sp.sz>>02435000
   option external;                                            <<sp.sz>>02440000
                                                               <<sp.sz>>02445000
integer procedure delass(assinx,jitinx);                       <<00552>>02450000
value assinx,jitinx; logical assinx,jitinx;                    <<00552>>02455000
option external;                                               <<00552>>02460000
double procedure findprocessport(pin);                         << 8150>>02465000
value pin;                                                     << 8150>>02470000
integer pin;                                                   << 8150>>02475000
option external;                                               << 8150>>02480000
                                                               << 8150>>02485000
procedure send'db(portid,subqueue,message);                    << 8150>>02490000
value portid,subqueue,message;                                 << 8150>>02495000
integer subqueue;                                              << 8150>>02500000
integer pointer message;                                       << 8150>>02505000
double portid;                                                 << 8150>>02510000
option external;                                               << 8150>>02515000
                                                               << 8150>>02520000
integer procedure get'dcs'failno(where,num);                   << 8150>>02525000
value where,num;                                               << 8150>>02530000
integer where,num;                                             << 8150>>02535000
option external;                                               << 8150>>02540000
                                                               << 8150>>02545000
                                                               <<01549>>02550000
procedure stopstatistics(classmask);                           <<01549>>02555000
value classmask;                                               <<01549>>02560000
logical classmask;                                             <<01549>>02565000
option privileged,uncallable,forward;                          <<01614>>02570000
$page "***   INTERNAL PROCEDURES   ***"                                 02575000
                                                                        02580000
                                                               <<01549>>02585000
 procedure unfreeze(en,test,pinx);                             <<01549>>02590000
 value en,test,pinx;                                           <<01549>>02595000
 integer en,pinx;                                              <<01549>>02600000
 logical test;                                                 <<01549>>02605000
 option external;                                              <<01549>>02610000
                                                               <<01549>>02615000
 procedure unlockseg(en,test,pinx);                            <<01549>>02620000
 value en,test,pinx;                                           <<01549>>02625000
 integer en,pinx;                                              <<01549>>02630000
 logical test;                                                 <<01549>>02635000
 option external;                                              <<01549>>02640000
                                                               <<01549>>02645000
 procedure delay(t);                                           <<01549>>02650000
 value t;                                                      <<01549>>02655000
 double t;                                                     <<01549>>02660000
 option external;                                              <<01549>>02665000
                                                               <<01766>>02670000
procedure procfile(pin,prog'file);                             <<01766>>02675000
value pin;                                                     <<01766>>02680000
integer pin;                                                   <<01766>>02685000
byte array prog'file;                                          <<01766>>02690000
option external;                                               <<01766>>02695000
                                                               <<01766>>02700000
procedure log16;                                               <<01766>>02705000
option external;                                               <<01766>>02710000
                                                               <<01766>>02715000
procedure log'stun'simulation(pin);                            <<01766>>02720000
value pin;                                                     <<01766>>02725000
integer pin;                                                   <<01766>>02730000
option privileged,uncallable,forward;                          <<01766>>02735000
                                                               <<01766>>02740000
procedure cleanupfiles;                                                 02745000
option privileged, uncallable;                                          02750000
                                                                        02755000
comment: sequentially picks out entries from tanle #2 of the job table  02760000
         ,finds an associated logical device number(ldev) and file      02765000
         address(faddr) and passes them to fdelete which deletes the fil02770000
         and releases the disc space. entries in the table #2 are not   02775000
         deleted.                                                       02780000
         ;                                                              02785000
                                                                        02790000
begin                                                                   02795000
    double                                                              02800000
         faddr   <<disk adr.>>                                          02805000
   ;integer                                                             02810000
         pxgjdt   <<job table dst #>>                                   02815000
        ,i,j,k,l,fnum,olddtab3                                 <<00265>>02820000
        ,vtabx  << vtabx value from jit >>                     <<*7770>>02825000
        ,faddr1 = faddr                                                 02830000
        ,faddr2 = faddr+1                                               02835000
        ,jitdstn                                                        02840000
        ,pcbglobloc                                            <<06632>>02845000
   ;double array                                                        02850000
         dmess(0:1)=q                                                   02855000
   ;integer array                                                       02860000
         dtab(*) = db+0   <<job table>>                                 02865000
         ,jitarr(*) = db+0   <<job information table>>         <<06888>>02870000
   ;                                                                    02875000
   array                                                       <<rv.pv>>02880000
       tempa (0:11) = q;                                       <<rv.pv>>02885000
   array                                                       <<06632>>02890000
       qarray(*) = q+0;                                        <<06632>>02895000
   byte array                                                  <<rv.pv>>02900000
       btempa (*) = tempa,                                     <<rv.pv>>02905000
       fdesign (0:26) = q;                                     <<rv.pv>>02910000
                                                                        02915000
   pxglobal;                                                   <<06632>>02920000
   pxgjdt _ pxg'jdtdst;                                        <<06632>>02925000
   jitdstn _ pxg'jitdst;                                       <<06632>>02930000
   exchangedb(pxgjdt);   <<job table>>                                  02935000
   i _ dtab(2);   <<beginning of job temp.file table>>                  02940000
   while i<dtab(3) do                                                   02945000
      begin   <<cycle on entry>>                                        02950000
      olddtab3 := dtab (3);                                    <<00265>>02955000
      k := dtab (i).(8:8);                                              02960000
      exchangedb (0);                                          <<rv.pv>>02965000
      tos := @tempa;                                           <<rv.pv>>02970000
      tos := pxgjdt;                                           <<rv.pv>>02975000
      tos := @dtab (i+1);                                      <<rv.pv>>02980000
      tos := k;                                                <<rv.pv>>02985000
      assemble (mfds);                                         <<rv.pv>>02990000
      j := k & lsl (1); <<# of bytes in name>>                 <<rv.pv>>02995000
      k := l := -1;                                            <<rv.pv>>03000000
      do begin                                                 <<rv.pv>>03005000
             if (logical (btempa (k:=k+1)) land %200) <> 0 then<<rv.pv>>03010000
              if k <> 0 then                                   <<rv.pv>>03015000
               fdesign (l:=l+1) := ".";                        <<rv.pv>>03020000
             fdesign (l:=l+1):= logical (btempa (k)) land %177;<<rv.pv>>03025000
         end until (j:=j-1) <= 0;                              <<rv.pv>>03030000
      fdesign (l:=l+1) := " ";                                 <<rv.pv>>03035000
      if (fnum := mustopen (fdesign,%2002,%500)) <> 0 then     <<rv.pv>>03040000
      begin                                                    <<rv.pv>>03045000
          fclose (fnum,4,0);                                   <<rv.pv>>03050000
          if <> then fclose (fnum,-1,0);                       <<rv.pv>>03055000
      end;                                                     <<rv.pv>>03060000
      exchangedb(pxgjdt);                                               03065000
      if dtab (3) = olddtab3 then i := i + dtab (i).(0:8);     <<00265>>03070000
      end;                                                              03075000
   exchangedb(jitdstn);                                                 03080000
   vtabx := jitpassfilevtabx;                                  <<*7770>>03085000
   faddr1 := jitpassfileptr1;                                  <<06888>>03090000
   faddr2 := jitpassfileptr2;                                  <<06888>>03095000
   exchangedb(0);                                                       03100000
   if vtabx <> 0 and faddr <> 0d then                          <<*7770>>03105000
   begin                                                       <<rv.pv>>03110000
       if (fnum := mustopen (,%2032,%500)) <> 0 then           <<rv.pv>>03115000
       begin                                                   <<rv.pv>>03120000
           fclose (fnum,4,0);                                  <<rv.pv>>03125000
           if <> then fclose (fnum,-1,0);                      <<rv.pv>>03130000
       end;                                                    <<rv.pv>>03135000
   end;                                                        <<rv.pv>>03140000
end;   <<procedure cleanupfiles>>                                       03145000
                                                                        03150000
procedure cleanupvolumes;                                      <<rh.pv>>03155000
option privileged,uncallable;                                  <<rh.pv>>03160000
                                                               <<rh.pv>>03165000
comment: this procedure dissociates the process from           <<rh.pv>>03170000
         any mounted volume sets.                              <<rh.pv>>03175000
       ;                                                       <<rh.pv>>03180000
                                                               <<rh.pv>>03185000
begin                                                          <<rh.pv>>03190000
      integer i:=0,reqtype;                                    <<07314>>03195000
      equate userinfosize = 40,  <<size of return array>>      <<rv.pv>>03200000
             byereq = 5;                                       <<rv.pv>>03205000
      integer array userinfo(0:userinfosize-1);                <<rh.pv>>03210000
                                                               <<rh.pv>>03215000
      usertable(2,curprc,,userinfo,userinfosize);              <<07314>>03220000
      while (i:=i+1) <= userinfo do                            <<rh.pv>>03225000
      begin                                                    <<rh.pv>>03230000
          reqtype := byereq;                                   <<rv.pv>>03235000
          dismount (<<vsname>>,<<vsgroup>>,<<vsaccnt>>,reqtype,<<rv.pv>>03240000
                    userinfo(i));                              <<rv.pv>>03245000
      end;                                                     <<rh.pv>>03250000
end;   <<procedure cleanupvolumes>>                            <<rh.pv>>03255000
                                                               <<rh.pv>>03260000
procedure abortrin(pin);                                                03265000
value pin;                                                              03270000
integer pin;                                                            03275000
option privileged,uncallable;                                           03280000
                                                                        03285000
comment: unlocks all the rins that a process might have left            03290000
         locked when terminating.                                       03295000
         returns                                                        03300000
            ccg if no rin was locked                                    03305000
            ccl if only local rins were still locked                    03310000
            cce if only global rins were still locked                   03315000
            ccx if both local & global rins wre locked                  03320000
         has to be called after fprocterm.                              03325000
      ;                                                                 03330000
                                                                        03335000
begin                                                                   03340000
      equate ccx=3;                                                     03345000
      integer db,cc,rinptr;                                    <<01602>>03350000
                                                                        03355000
      cc:=ccg;                                                          03360000
      db:=exchangedb(rin'dst);                                 <<06270>>03365000
      rinptr := rin'length;                                    <<06270>>03370000
      while rinptr < rin'totalnum do                           <<01602>>03375000
      begin                                                    <<01602>>03380000
        if rin'e'holder = pin then                             <<01602>>03385000
         begin                                                 <<01602>>03390000
          cc := logical(rin'e'type) lor logical(cc);           <<01602>>03395000
          runlock(%100000+(rinptr/rin'length));                <<01602>>03400000
        end;                                                   <<01602>>03405000
        rinptr := rinptr+rin'length;                           <<01602>>03410000
      end;                                                     <<01602>>03415000
      exchangedb(db);                                                   03420000
end;  << a b o r t r i n  >>                                            03425000
                                                                        03430000
                                                                        03435000
integer procedure getprocid(y);                                         03440000
value y;                                                                03445000
integer y;                                                              03450000
option privileged;                                                      03455000
                                                                        03460000
comment:                                                                03465000
         returns the pin of the y th son of the caller, or              03470000
         0 when y exceeds the number of sons that the caller has;       03475000
                                                                        03480000
begin                                                                   03485000
integer pcbpt;                                                 <<06646>>03490000
      disaproc;                                                         03495000
      pcbpt := curprc;                                         <<06646>>03500000
      pcbpt := soninfo;                                        <<06646>>03505000
      while (y:=y-1) > 0 do                                    <<01.01>>03510000
         begin                                                          03515000
         pcbpt := brotherinfo;                                 <<06646>>03520000
         if pcbpt = 0 then                                     <<06646>>03525000
            begin                                              <<06646>>03530000
            getprocid := pcbpt;                                <<06646>>03535000
            enaproc;                                           <<06646>>03540000
            return;                                            <<06646>>03545000
            end;                                               <<06646>>03550000
         end;                                                           03555000
         getprocid := pcbpt/pcbsize;                           <<06646>>03560000
      enaproc;                                                          03565000
end;  << g e t p r o c i d  >>                                          03570000
                                                                        03575000
procedure burryproc(pcbpt);                                             03580000
value pcbpt;                                                            03585000
integer pcbpt;                                                          03590000
option privileged,uncallable;                                           03595000
                                                                        03600000
comment:    deletes a process from the system.                          03605000
            removes it from scheduling queue                            03610000
            removes it from process structurs                           03615000
            activates its father if required                            03620000
            returns the stack and pcb to system.                        03625000
         ;                                                              03630000
                                                                        03635000
begin                                                                   03640000
      integer  fapt,v,k;                                                03645000
    equate noqueue=0;                                          <<01549>>03650000
                                                                        03655000
    disaproc;                                                  <<01549>>03660000
    tos:=%1000d;                                               <<01549>>03665000
    assemble(xchd);                                            <<01549>>03670000
    tos := pcbpt;                                              <<06646>>03675000
    tos:=noqueue;                                              <<01549>>03680000
    tos:=0;                                                    <<01549>>03685000
    queueproc(*,*,*);                                          <<01549>>03690000
    assemble(xchd;ddel);                                       <<01549>>03695000
      <<break process structure>>                                       03700000
    fapt := sys'pcb(pcbpt + fatherinfowordnum);                <<06646>>03705000
    if ( v := sys'pcb(fapt + soninfowordnum))                  <<06646>>03710000
               = pcbpt then                                    <<06646>>03715000
       sys'pcb(fapt + soninfowordnum) :=                       <<06646>>03720000
       sys'pcb(pcbpt + brotherinfowordnum)                     <<06646>>03725000
      else                                                              03730000
         begin                                                          03735000
there:   if (k := (sys'pcb(v + brotherinfowordnum)))           <<06646>>03740000
                   = pcbpt then                                <<06646>>03745000
            sys'pcb(v + brotherinfowordnum)                    <<06646>>03750000
            := sys'pcb(pcbpt + brotherinfowordnum)             <<06646>>03755000
            else                                               <<06646>>03760000
            begin                                                       03765000
            v:=k;                                                       03770000
            go there;                                                   03775000
            end;                                                        03780000
         end;                                                           03785000
      if logical(sys'pcb(pcbpt+piinfowordnum)).facflag         <<06646>>03790000
         then  awake( fapt,2,0);                                        03795000
         << if ucop has no sons, do nothing >>                 <<05.eb>>03800000
     if (sys'pcb(sysproc(2) + soninfowordnum)) = 0 then        <<06646>>03805000
         enaproc << do nothing >>                              <<05.eb>>03810000
         else  enaproc;                                                 03815000
      disaproc;                                                <<01549>>03820000
      tos:=%1000d;                                             <<01549>>03825000
      assemble(xchd);                                          <<01549>>03830000
     tos := pcbpt;                                             <<06646>>03835000
      assemble(dzro,dzro);     << leave room for parms. >>     <<06659>>03840000
      tos.flushlocflag:=1;                                     <<01549>>03845000
      adjustlocality(*,*,*,*);                                 <<01549>>03850000
      assemble(xchd;ddel);                                     <<01549>>03855000
      enaproc;                                                 <<01549>>03860000
     reldataseg(stkinfo.stkdstfield);                          <<06646>>03865000
      sys'pcb(pcbpt+pqptrwordnum):=-1; <<signal checkalive>>   <<01634>>03870000
      returnentry(syspcbindex,pcbpt/pcbsize);                  <<06646>>03875000
end;  <<burryproc>>                                                     03880000
                                                                        03885000
procedure kill(pin);                                                    03890000
value pin; integer pin;                                                 03895000
option privileged;                                                      03900000
                                                                        03905000
comment:                                                                03910000
         set kill bit in pin pcb and runs burryproc                     03915000
         condition code:                                                03920000
               cce      ok                                              03925000
               ccg      process already terminating                     03930000
               ccl      not a son of caller                             03935000
      ;                                                                 03940000
                                                                        03945000
begin                                                                   03950000
      integer pcbpt;                                           <<06646>>03955000
      integer k,cc;                                                     03960000
                                                                        03965000
      erroron;                                                          03970000
      pcbpt := pin * pcbsize;                                  <<06646>>03975000
                                                               <<06735>>03980000
     << first make sure pin is within range of pcb table >>    <<06735>>03985000
                                                               <<06735>>03990000
     if (pin < 1  lor  pin >= integer(sys'pcb(0))) then        <<06735>>03995000
         begin                                                          04000000
         cc:=ccl;                                                       04005000
         goto fin;                                                      04010000
         end;                                                           04015000
                                                               <<06735>>04020000
      << now make sure it's a son of the caller >>             <<06735>>04025000
                                                               <<06735>>04030000
      if not checkalive(pin) or fatherinfo <> curprc then      <<06735>>04035000
         begin                                                 <<06735>>04040000
         cc := ccl;                                            <<06735>>04045000
         go fin;                                               <<06735>>04050000
         end;                                                  <<06735>>04055000
                                                               <<06735>>04060000
      disaproc;                        <<pseudo disable>>               04065000
      if procstate.aliveflag then                              <<06646>>04070000
         begin                         << alive >>                      04075000
         setcritical;                  <<critical mode>>                04080000
         procstate.aliveflag := 0;                             <<06646>>04085000
         set'psif(pcbpt,%20);                                  <<06646>>04090000
         enaproc;                      <<pseudo enable>>                04095000
         abortprocio(pin);             <<abort io for proc>>            04100000
         awake(pcbpt,%400,0);                                  <<06646>>04105000
         disable;                      <<interrupts>>                   04110000
         if not piinfo.deadflag                                <<06646>>04115000
         then wait(%4000,0);           <<mourning wait>>                04120000
         enable;                                                        04125000
         burryproc(pcbpt);                                     <<06646>>04130000
         resetcritical(0);                                              04135000
         cc:=cce;                                                       04140000
         goto fin;                                                      04145000
         end                                                            04150000
      else                                                              04155000
         begin                        <<already dead>>                  04160000
         enaproc;                      <<pseudo enable>>                04165000
         cc:=ccg;                                                       04170000
fin:     status.(6:2):=cc;                                              04175000
         errorexit(1,0,0);                                              04180000
         end;                                                           04185000
end;  << k i l l  >>                                                    04190000
                                                                        04195000
procedure cleanupjob (expcode, dispose);                       <<04799>>04200000
                                                               <<04199>>04205000
value expcode, dispose;                                        <<04799>>04210000
integer expcode, dispose;                                      <<04799>>04215000
   option privileged, uncallable;                                       04220000
                                                                        04225000
comment - called to terminate a main process.                  <<05.eb>>04230000
   <command> indicates the origination of the close job request.        04235000
             (numbers below are decimal numbers.)              <<04199>>04240000
      0 - :data command.                                                04245000
      1 - :hello command,                                               04250000
      2 - :job command,                                                 04255000
      4 - unspecified jobclose.  <quitjob> or operator,                 04260000
      5 - :bye command,                                                 04265000
      6 - :eoj command.                                                 04270000
    >=7 - ci-detected error during job initiation,                      04275000
          passed thru expcode parm of commandinterp.           <<05.eb>>04280000
      8 - acct/user exist, no group name exists,               <<05.eb>>04285000
      9 - no acct,                                             <<05.eb>>04290000
     10 - acct exists, no user name exists,                    <<05.eb>>04295000
     11 - acct/user exist, no home group exists,               <<05.eb>>04300000
     12 to 16 - logon timeout expired (=12) plus the return    <<01131>>04305000
                value from direclogon.                         <<01131>>04310000
     40 - $stdin open failure.   don't do fjclose.             <<03784>>04315000
     41 - $stdlist open failure. don't do fjclose.             <<03784>>04320000
          note that if the $stdin open fails, no attempt is    <<04199>>04325000
          made to open $stdlist.                               <<04199>>04330000
   for :hello and :job requests, it is assumed that the command         04335000
   image starts at db+0.                                                04340000
   caller must insure the following:                                    04345000
      1. all sons of this main process have been cleaned up.            04350000
      2. if command, that command is legitimate for current job mode.   04355000
   this routine requires that the pcbx of this main process is correct. 04360000
                                                               <<04199>>04365000
   expcode contains command (close job request) in the low     <<04199>>04370000
   order eight bits and the directory failure level (for       <<04199>>04375000
   direclogoff) in the high order eight bits.  logon failures  <<04199>>04380000
   occur only in initjsmp--all other paths to this code will   <<04199>>04385000
   have a zero as the directory failure level.                 <<04199>>04390000
                                                               <<04199>>04395000
   intrinsics used:                                                     04400000
      startdevice                                                       04405000
      reldataseg                                                        04410000
      cleanupfiles                                                      04415000
      abortdseg                                                         04420000
      deallocate                                                        04425000
      getsir                                                            04430000
      relsir                                                            04435000
      exchangedb                                                        04440000
      attio                                                             04445000
      date'line                                                         04450000
      direclogoff                                                       04455000
      chronos, proctime, dascii, print, putmsg,                         04460000
      xddspoolinfo,sfindodd,getjcw,                            <<sp.sz>>04465000
      awake.                                                            04470000
;                                                              <<05.eb>>04475000
<<---------------------------------------------------------->> <<06010>>04480000
<<                                                          >> <<06010>>04485000
<< fix information:  this procedure uses a pointer pxglob   >> <<06010>>04490000
<< to access the information in the pxglobal area of the    >> <<06010>>04495000
<< stack's pcbx.  it is specifically used to get the dst    >> <<06010>>04500000
<< numbers for the job/session's data structures.  this     >> <<06010>>04505000
<< pointer has to be reassigned (reset) after calls to file >> <<06010>>04510000
<< system procedures since these calls may cause the pcbx   >> <<06010>>04515000
<< area to expand.  specifically, the fjclose of stdlist    >> <<06010>>04520000
<< with the "delete" option will (unbeknownst to this       >> <<06010>>04525000
<< procedure) call fsopen which may need an entry in the    >> <<06010>>04530000
<< pxfile area.  as a general rule:  reassign pxglob before >> <<06010>>04535000
<< each use.                                                >> <<06010>>04540000
<<                                                          >> <<06010>>04545000
<<---------------------------------------------------------->> <<06010>>04550000
                                                               <<06010>>04555000
                                                                        04560000
begin                                                                   04565000
<< system stuff >>                                                      04570000
   integer                                                              04575000
            jpnf                 = db+0;                                04580000
                                                               <<03784>>04585000
   define                                                      <<03784>>04590000
      real'device = ( not lpdt'virtual'device )#;              <<06890>>04595000
                                                               <<03784>>04600000
<< pxglob >>                                                            04605000
   integer  pcbglobloc;                                        <<06632>>04610000
   array    qarray(*)            =q+0;                         <<06632>>04615000
   equate timedout = 12;                                       <<01131>>04620000
   equate  stdinfail   = 40,                                   <<03784>>04625000
           stdlistfail = 41;                                   <<03784>>04630000
                                                               <<03784>>04635000
define  command = expcode.(8:8) #,                             <<04199>>04640000
        dirfail = expcode.(0:8) #;                             <<04199>>04645000
                                                               <<04199>>04650000
<< locals >>                                                            04655000
integer                                                        << 8150>>04660000
   creator'pin,   << from jmat. >>                             << 8150>>04665000
   action,        << the reason we are in morgue. >>           << 8150>>04670000
   sub'queue;     << must match creators enable mask. >>       << 8150>>04675000
                                                               << 8150>>04680000
double                                                         << 8150>>04685000
   port'id;       << returned from findprocessport. >>         << 8150>>04690000
                                                               << 8150>>04695000
integer array                                                  << 8150>>04700000
   msgarr(0:2);  << message to be returned to creator. >>      << 8150>>04705000
   integer dirlogofflevel;                                     <<03784>>04710000
   logical wordset; << for freeing entry in jpcnt table >>     <<06672>>04715000
   integer bit; << bit, 0-15 in wordset to free up >>          <<06672>>04720000
   integer                                                     <<0u.eb>>04725000
      logoffmsgno;                                             <<0u.eb>>04730000
   integer cmd := 0, dummy = cmd;                              <<02.eb>>04735000
   integer result;                                             <<04155>>04740000
integer pcbpt;                                                 <<06646>>04745000
integer lpdt'index;                                            <<06890>>04750000
   integer sirvalue;                                           <<06887>>04755000
   integer jcutentry;                                          <<06887>>04760000
   integer jmatx;                                              <<02.eb>>04765000
   integer comlen;                                                      04770000
   byte array                                                           04775000
            comarr (*)           = db+0;                                04780000
   double                                                               04785000
      cputime := 0d,    connecttime := 0d;                              04790000
   integer array jitarr(*)=db+0;  <<job info table>>           <<06888>>04795000
   double array jitcputime(*)=jitcpuc;                         <<06888>>04800000
   logical date;  double time;                                          04805000
                                                               <<05.eb>>04810000
   byte array datebuff(0:27);                                  <<05.eb>>04815000
   byte array logonid(0:34);                                   <<04155>>04820000
   integer  c2 = date,  c1 = time,  c0 = c1+1;                          04825000
   define                                                               04830000
      year2 = c2.(0:7) #,                                      <<06673>>04835000
            year1 = jmatarr(jmatcalendaroff).(0:7) #,          <<06673>>04840000
      day2  = c2.(7:9) #,                                      <<06673>>04845000
            day1  = jmatarr(jmatcalendaroff).(7:9) #,          <<06673>>04850000
      hour2 = c1.(0:8) #,                                      <<06673>>04855000
            hour1 = jmatarr(jmattimeoff).(0:8) #,              <<06673>>04860000
      min2  = c1.(8:8) #,                                      <<06673>>04865000
            min1  = jmatarr(jmattimeoff).(8:8) #,              <<06673>>04870000
      sec2  = c0.(0:8) #,                                      <<06673>>04875000
            sec1  = jmatarr(jmattimeoff+1).(0:8)#;             <<06673>>04880000
   integer maxpri, creates;                                             04885000
   double dvalue;                                              <<sp.sz>>04890000
   pointer xddep;                                              <<sp.sz>>04895000
   logical abortflag;                                          <<sp.sz>>04900000
   integer dfid;                                               <<sp.sz>>04905000
      byte array bdfid(*) = dfid;                              <<01549>>04910000
   integer oddep=xddep;                                        <<sp.sz>>04915000
   integer associate;   <<head of user's association chain>>   <<00552>>04920000
   integer jpcntindex;  << index into jpcntbitmap >>           <<06672>>04925000
   integer array jpcntarr(*) = db+0; << for jpcnt table >>     <<06672>>04930000
    << ..................................................... >><<06673>>04935000
    <<        declarations used to reference the jmat        >><<06673>>04940000
    <<    jmatent -- a local array into which the subject    >><<06673>>04945000
    <<               jmat entry is copied.                   >><<06673>>04950000
    <<    jmatarr -- the array referenced by the include file>><<06673>>04955000
    <<               jmatarr is equivalenced first to jmatent>><<06673>>04960000
    <<               (after a move) and then to db+0 (after  >><<06673>>04965000
    <<               an exchange db.                         >><<06673>>04970000
    <<    jmatinx -- the index used in the include file to   >><<06673>>04975000
    <<               reach the proper entry. in this case    >><<06673>>04980000
    <<               jmatinx is 0.                           >><<06673>>04985000
    <<    jmatentinx -- index into the jmat dst to our entry >><<06673>>04990000
    <<    jstype     -- saved type (job of session)          >><<06673>>04995000
    << ..................................................... >><<06673>>05000000
                                                               <<06673>>05005000
    integer array jmatent(0:jmatentrysize-1);                  <<06673>>05010000
    integer array jmatarr(*);                                  <<06673>>05015000
    integer       jmatinx;                                     <<06673>>05020000
    integer       jmatentinx;                                  <<06673>>05025000
    integer       jstype;                                      <<06673>>05030000
                                                               <<06673>>05035000
    integer       savesir;                                     <<06673>>05040000
    equate        jobterm  =  3;  << job state = terminating >><<06673>>05045000
                                                               <<06673>>05050000
    double        dealloc'parm;  << parm. to deallocate >>     <<06673>>05055000
                                                                        05060000
                                                               <<06673>>05065000
    subroutine def'movefromdseg;                               <<06673>>05070000
                                                               <<06673>>05075000
    subroutine def'movetodseg;                                 <<06673>>05080000
                                                               <<06673>>05085000
<< ........................................................ >> <<06673>>05090000
<<    **********      procedure  body      **********       >> <<06673>>05095000
<< ........................................................ >> <<06673>>05100000
                                                               <<06673>>05105000
<< procedure body >>                                                    05110000
     pxglobal;  <<calculate pxglobal location>>                <<06632>>05115000
   if command = 4 then                                         <<01131>>05120000
     command := 4 + pxg'jobtype                                <<06632>>05125000
   else if timedout<=command and command<stdinfail then        <<03784>>05130000
     command := command - 5;                                   <<01131>>05135000
   abortflag := if command = 4 or command >= 7                 <<sp.sz>>05140000
                or getjcw.(0:1) = 1 <<job aborted>>            <<sp.sz>>05145000
      then true else false;                                    <<sp.sz>>05150000
<< ......................................................... >><<06673>>05155000
<<     here we update the jmat's state to "TERMINATING"      >><<06673>>05160000
<<     and save a local copy of the entry (jmatarr).         >><<06673>>05165000
<< ......................................................... >><<06673>>05170000
                                                               <<06673>>05175000
    @jmatarr := @jmatent;  << point to the local entry >>      <<06673>>05180000
   jmatentinx := pxg'jmatinx * jmatentrysize;                  <<06673>>05185000
   << jmatentinx points at our entry >>                        <<06673>>05190000
                                                               <<06673>>05195000
   savesir := getsir(jmatsir);  << lock the jmat for a bit >>  <<06673>>05200000
   movefromdseg(@jmatarr, jmatdst, jmatentinx, jmatentrysize); <<06673>>05205000
                                                               <<06673>>05210000
   << jmatarr now holds the entry. the include file defines  >><<06673>>05215000
   << reference jmatarr using jmatinx.  since jmatarr is     >><<06673>>05220000
   << local and not db relative, jmatinx should be 0.        >><<06673>>05225000
   jmatinx := 0;                                               <<06673>>05230000
                                                               <<06673>>05235000
   jmatx  := jmatentinx;                                       <<07314>>05240000
   jmatjobstate := jobterm;  << state is terminating >>        <<06673>>05245000
   jstype       := jmatjstype; << remember what we were! >>    <<06673>>05250000
   if jmatwaittillon = 1 then                                  << 8150>>05255000
   begin                                                       << 8150>>05260000
     << if a session is being programmatically created, the >> << 8150>>05265000
     << creator has the option of waiting via ipc to find   >> << 8150>>05270000
     << out if the session made it.  if the session makes it>> << 8150>>05275000
     << to initjsmp and is aborted before sending a message >> << 8150>>05280000
     << to the creator, the creator will wait forever.  when>> << 8150>>05285000
     << the result is sent to the creator, the waittillon   >> << 8150>>05290000
     << bit is turned off.  if the waittillon bit is still  >> << 8150>>05295000
     << on at this point, it means there is somebody waiting>> << 8150>>05300000
     << for the result.  therefore we will send a message   >> << 8150>>05305000
     << of a generic error to the creator.                  >> << 8150>>05310000
                                                               << 8150>>05315000
     creator'pin := jmatcreator;                               << 8150>>05320000
     port'id := findprocessport(creator'pin);                  << 8150>>05325000
     sub'queue := 3;                                           << 8150>>05330000
     msgarr(1) := 3;  << length of message. >>                 << 8150>>05335000
     msgarr(2) := get'dcs'failno(4,7258);                      << 8150>>05340000
     send'db(port'id,sub'queue,msgarr);                        << 8150>>05345000
   end;                                                        << 8150>>05350000
                                                               <<06673>>05355000
   movetodseg(jmatdst, jmatentinx, @jmatarr, 1);<<first word>  <<06673>>05360000
                                                               <<06673>>05365000
   relsir(jmatsir, savesir);                                   <<06673>>05370000
                                                               <<06673>>05375000
   if command < 7 then                                                  05380000
      begin                                                             05385000
         << flush user defined command dst >>                  <<11.eb>>05390000
      if udcdstno <> 0 then reldataseg(udcdstno);              <<11.eb>>05395000
      cleanupfiles;                                                     05400000
      pxglobal;  <<need to recalculate pxglob location>>       <<06632>>05405000
      cleanupvolumes;  <<dismount any private volumes in use>> <<rh.pv>>05410000
      abortdseg (true);                                                 05415000
   << jdt now contains only :file entries.   can be thrown away >>      05420000
   << merge main process acct'g info into jit >>                        05425000
   << print acct'g info:  jit, jcut, jmat >>                            05430000
      exchangedb (pxg'jitdst);                                 <<06632>>05435000
      creates := jitacctinfo;                                  <<06888>>05440000
      tos := jitcputime;                                       <<06888>>05445000
      maxpri := jithipri;                                      <<06888>>05450000
      associate:=jitassocindex;<<get user's assoc. chain head>><<06888>>05455000
      exchangedb (0);                                                   05460000
      while associate<>0 do associate:=delass(associate,       <<00552>>05465000
                            integer(pxg'jitdst));              <<06632>>05470000
      tos := tos +999d;                                                 05475000
      if overflow then                                                  05480000
ovfl:    tos := 2147483d                                                05485000
      else                                                              05490000
         begin                                                          05495000
                                                               <<05.eb>>05500000
         tos := 1000d;                                         <<05.eb>>05505000
         assemble(ddiv; ddel);                                 <<05.eb>>05510000
         end;                                                           05515000
      cputime := tos;                                                   05520000
      date := calendar;                                                 05525000
      time := clock;                                                    05530000
      if year2 < year1 then year2 := year2 +100;                        05535000
      << minutes between 2 time stamps =                                05540000
         (m2-m1) + 60*                                                  05545000
            ((h2-h1) + 24*                                              05550000
               ((d2-d1) + ((y2-1)/4*4-y1+4)/4  + 365*                   05555000
                  (y2-y1)  )  )                                         05560000
         + (s2<s1)                                                      05565000
         implemented as:    >>                                          05570000
      tos := ((year2 -1) &asr(2) &asl(2) -year1 +4) &asr(2);            05575000
      tos := 45;    assemble (mpyl);                                    05580000
      tos := year2 -year1;                                              05585000
      tos := 16425;    assemble (mpyl, dadd);                           05590000
      tos := tos &dasl(5);                                              05595000
      tos := (day2 -day1) *24 +(hour2 -hour1);                          05600000
      tos := 60;    assemble (mpyl, dadd);                              05605000
      tos := tos +double (min2 -min1);                                  05610000
      if sec2 > sec1 then tos := tos +1d;                               05615000
      if pxg'jobtype  = session then                           <<06890>>05620000
         begin                                                          05625000
         connecttime := ds1;                                            05630000
         logoffmsgno := sesslogoff; << session >>              <<05.eb>>05635000
         end                                                   <<0u.eb>>05640000
         else logoffmsgno := joblogoff; << job >>              <<05.eb>>05645000
      if (command < 7) and (jmatproglogon = 0) then            << 8150>>05650000
      << logged on, so print logoff message unless he is    >> << 8150>>05655000
      << being programmatically created, and hasn't respond->> << 8150>>05660000
      << ed yet (terminal might not be turned on).          >> << 8150>>05665000
         begin                                                 <<05.eb>>05670000
         fmtdate(date,time,datebuff);                          <<05.eb>>05675000
         datebuff(27):=0;                                      <<02336>>05680000
         genmsg(syset,logoffmsgno,%22000,@cputime,@ds1,        <<05.eb>>05685000
            @datebuff);                                        <<05.eb>>05690000
        genmsg(syset, conslogoff, %10000,                      <<06673>>05695000
               jmatorigjin,,,,, 0); << to the console >>       <<06673>>05700000
         end;                                                  <<05.eb>>05705000
      if loglogoff then log3(maxpri,creates,cputime,ds1,3);    <<05.eb>>05710000
      end;                                                     <<02.eb>>05715000
<< level of the directory failures (if any) is passed to >>    <<04199>>05720000
<< terminate through the expcode's top eight bits.       >>    <<04199>>05725000
   dirlogofflevel := dirfail;                                  <<04199>>05730000
   result := direclogoff(dirlogofflevel,jmatarr,               <<04155>>05735000
             connecttime,cputime,dummy,dummy,dummy);           <<04155>>05740000
             << ***** account updated ********  >>             <<04155>>05745000
   if result.(11:1) = 1 or result.(10:1) = 1 then              <<04155>>05750000
       begin                                                   <<04155>>05755000
       formuserid(logonid);  << userid for genmsg >>           <<04155>>05760000
       genmsg(syset,negcontime,0,@logonid,,,,,0);              <<04155>>05765000
       end;                                                    <<04155>>05770000
   if result.(9:1)=1 or result.(8:1) = 1 then                  <<04155>>05775000
       begin                                                   <<04155>>05780000
       formuserid(logonid); << userid for genmsg >>            <<04155>>05785000
       genmsg(syset,negcputime,0,@logonid,,,,,0);              <<04155>>05790000
       end;                                                    <<04155>>05795000
   if jmatftbits <> 0 then  << a special logon >>              <<06673>>05800000
      if not cilogtable(2,jmatx,cmd,cmd) then suddendeath      <<02.eb>>05805000
         (509); <<release logon info set by ucop>>             <<02.eb>>05810000
<< close jin and jlist files >>                                         05815000
   if abortflag then                                           <<sp.sz>>05820000
      begin                                                    <<sp.sz>>05825000
      ffileinfo(2,38,bdfid);   << get o# for jlist >>          <<01549>>05830000
      if = and sfindodd( dfid, oddep )                         <<03784>>05835000
         then xddspoolinfo(dvalue,%10001,xddep); <<set abort>> <<sp.sz>>05840000
                                          << flag   in odd  >> <<sp.sz>>05845000
      end;                                                     <<sp.sz>>05850000
                                                               <<04799>>05855000
<<   check if file is to be closed with the delete option >>   <<04799>>05860000
                                                               <<04799>>05865000
   if command < stdinfail   then                               <<04799>>05870000
            fjclose( 2, dispose, 0);                           <<04799>>05875000
                                                               <<04799>>05880000
   if command <> stdinfail   then fjclose( 1, 0, 0 );          <<03784>>05885000
                                                               <<03784>>05890000
<< ucop allocates the $stdin and $stdlist devices for a    >>  <<04199>>05895000
<< job/session.  even so, the fjopen of the $stdfiles in   >>  <<04199>>05900000
<< initjsmp may fail (e.g. no dsts available).  in this    >>  <<04199>>05905000
<< case, it becomes necessary to deallocate these devices. >>  <<04199>>05910000
<< deallocation of real devices is straightforward.        >>  <<04199>>05915000
<< deallocation of virtual devices (when $stdin and/or     >>  <<04199>>05920000
<< $stdlist is spooled) is more tricky:  if fjopen fails   >>  <<04199>>05925000
<< on the virtual $stdin device, the failure will trigger  >>  <<04199>>05930000
<< the necessary deallocations--this is because the $stdin >>  <<04199>>05935000
<< fjopen becomes an fopen of an old spoolfile; if the     >>  <<04199>>05940000
<< fjopen on the virtual $stdlist device fails, however,   >>  <<04199>>05945000
<< none of the allocated resources are released--this is   >>  <<04199>>05950000
<< because the fjopen becomes an fopen of a new spoolfile, >>  <<04199>>05955000
<< and fopen, in this case, thinks there were no allocated >>  <<04199>>05960000
<< resources to release.  deallocation must happen here.   >>  <<04199>>05965000
<< also, if $stdlist fails, we assume that $stdin didn't   >>  <<04199>>05970000
<< fail; so in this case the fjclose above takes care of   >>  <<04199>>05975000
<< deallocating resources.                                 >>  <<04199>>05980000
<<    in summary:  we always need to deallocate $stdlist   >>  <<04199>>05985000
<< if either of the $stdfile fjopens failed.  we only need >>  <<04199>>05990000
<< to deallocate $stdin if and only if both the $stdin     >>  <<04199>>05995000
<< fjopen failed and $stdin was on a real device.          >>  <<04199>>06000000
<<                                                         >>  <<04199>>06005000
<< deallocate high order bits meanings:                    >>  <<04199>>06010000
<<     (2:1) -- stdfile failure.  stdlist (new spoolfile)  >>  <<04199>>06015000
<<              has entry allocated but no disc space      >>  <<04199>>06020000
<<              allocated.  deallocate normally but do not >>  <<04199>>06025000
<<              deallocate disc space.                     >>  <<04199>>06030000
<<     (6:1) -- wait bit.                                  >>  <<04199>>06035000
<<     (7:1) -- primed bit.  do not make open spoolfile    >>  <<04199>>06040000
<<              ready; delete it from the system.          >>  <<04199>>06045000
                                                               <<04199>>06050000
   if command >= stdinfail then                                <<04199>>06055000
   begin                                                       <<04199>>06060000
      tos := %21400;   << first word of deallocate parameter >><<06673>>06065000
      tos := jmatjlistdev;  << second word >>                  <<06673>>06070000
      dealloc'parm := tos;  << the parameter >>                <<06673>>06075000
      deallocate( dealloc'parm );                              <<06673>>06080000
                                                               <<06890>>06085000
      lpdt'index := jmatjindev * size'of'lpdt'entry;           <<06890>>06090000
      if (command = stdinfail) and real'device  then           <<06890>>06095000
         begin        << deallocate input device >>            <<06890>>06100000
           tos := %1400; << first word of deallocate parm >>   <<06673>>06105000
           tos := jmatjindev;  << second word >>               <<06673>>06110000
           dealloc'parm := tos;                                <<06673>>06115000
           deallocate( dealloc'parm );                         <<06673>>06120000
        end;                                                   <<06673>>06125000
   end;                                                        <<04199>>06130000
                                                               <<04199>>06135000
                                                                        06140000
   <<release remaining resources>>                                      06145000
   pxglobal;                                                   <<06632>>06150000
   reldataseg (pxg'jdtdst);    <<release jdt>>                 <<06632>>06155000
   reldataseg (pxg'jitdst);    <<release jit>>                 <<06632>>06160000
   wordset:=pxg'jpcntinx;                                      <<06672>>06165000
   if pxg'jcutinx <> 0 then                                    <<07314>>06170000
      begin   <<release jcut entry>>                           <<07314>>06175000
      jcutentry := (integer(pxg'jcutinx)-1)*jcutentsize        <<07314>>06180000
                                         +jcutheadsize;        <<07314>>06185000
      sirvalue := getsir (jcutsir);                            <<06887>>06190000
      jcutarr(jcutentry) := jcutfreehead;                      <<06887>>06195000
      jcutfreehead := jcutentry;                               <<06887>>06200000
      relsir (jcutsir,sirvalue);                               <<06887>>06205000
      end;                                                              06210000
   savesir:=getsir(jpcntsir);                                  <<06672>>06215000
   exchangedb (jpcntdst);                                               06220000
   jpcntfreentries:=jpcntfreentries+1;                         <<06672>>06225000
   << wordset contains bit id number from pxglob (see above) >><<06672>>06230000
   jpcntindex:=wordset.(5:7); << index into bitmap >>          <<06672>>06235000
   bit:=wordset.(12:4);                                        <<06672>>06240000
   tos:=jpcntbitmap;  << get word that contains entry >>       <<06672>>06245000
   xreg:=bit;                                                  <<06672>>06250000
   assemble(tsbc 0, x); << set to free >>                      <<06672>>06255000
   jpcntbitmap:=tos; << update jpcnt table >>                  <<06672>>06260000
   relsir(jpcntsir,savesir);                                   <<06672>>06265000
   savesir := getsir (jmatsir);                                <<06673>>06270000
   exchangedb (jmatdst);                                                06275000
   << ...................................................... >><<06673>>06280000
   <<   push jmatentinx onto tos because it is passed to     >><<06673>>06285000
   <<   deallocate'jmat as a pointer.  that is, the value in >><<06673>>06290000
   <<   jmatentinx is considered an integer pointer by the   >><<06673>>06295000
   <<   procedure and must be passed thusly while we are     >><<06673>>06300000
   <<  exchange db'd                                         >><<06673>>06305000
   << ...................................................... >><<06673>>06310000
   tos := jmatentinx;                                          <<06673>>06315000
   deallocate'jmat(*);                                         <<06673>>06320000
   @jmatarr := 0;  << point to db+0 in order to get header >>  <<06673>>06325000
   << decrement the job/session count in the jmat header >>    <<06673>>06330000
   if jstype = sessiontype                                     <<06673>>06335000
   then jmatsnum := jmatsnum - 1                               <<06673>>06340000
   else jmatjnum := jmatjnum - 1;                              <<06673>>06345000
   relsir (jmatsir, savesir);                                  <<06673>>06350000
                                                                        06355000
   << return to finish terminate >>                                     06360000
   end    <<cleanupjob>>;                                               06365000
 procedure setpxfixbit(flag);                                  <<01837>>06370000
 value flag;                                                   <<01837>>06375000
 logical flag;                                                 <<01837>>06380000
 option privileged,uncallable;                                 <<01837>>06385000
 begin                                                         <<01837>>06390000
                                                               <<01837>>06395000
<< this procedure set or reset(according to the logical >>     <<01837>>06400000
<< value of flag) bit 2 of pxfixed(%26).  this is done  >>     <<01837>>06405000
<< before the user was granted the use of the system    >>     <<01837>>06410000
<< clock.  this bit will be check by giveclock.         >>     <<01837>>06415000
                                                               <<01837>>06420000
    array qarray(*) = q+0;                                     <<06632>>06425000
    logical pxfixedloc;                                        <<06632>>06430000
                                                               <<01837>>06435000
    pxfixed;                                                   <<06632>>06440000
    status.(6:2) := cce;                                       <<01837>>06445000
    if flag then pxfxclkshare:=1 else                          <<07055>>06450000
    begin                                  << clear bit >>     <<01837>>06455000
       tos := pxfxclkshare;                                    <<06632>>06460000
    asmb (trbc 15);  << test then reset bit 11 >>              <<07055>>06465000
       if  =  then  status.(6:2) := ccl      << bit was set>>  <<01837>>06470000
              else  pxfxclkshare := tos;                       <<06632>>06475000
    end;                                                       <<01837>>06480000
 end;                                                          <<01837>>06485000
 procedure giveclock(plabel);                                  <<01837>>06490000
 value plabel;                                                 <<01837>>06495000
 integer plabel;                                               <<01837>>06500000
 option privileged,uncallable;                                 <<01837>>06505000
 begin                                                         <<01837>>06510000
                                                               <<01837>>06515000
<< this procedure returns the clock to the system so >>        <<01837>>06520000
<< someone else might be use it.  0 of input plabel  >>        <<01837>>06525000
<< indicates that the user does not want to release  >>        <<01837>>06530000
<< the clock yet, but may want to change the interrupt >>      <<01837>>06535000
<< rate later on.                                    >>        <<01837>>06540000
                                                               <<01837>>06545000
    integer  i, cstn, xdsn, indx, pinx;                        <<01837>>06550000
    logical array qarray(*) = q+0;                             <<06632>>06555000
    logical pxfixedloc;                                        <<06632>>06560000
                                                               <<01837>>06565000
    pxfixed;                                                   <<07055>>06570000
    if  not pxfxclkshare  then  return; <<not owner of clock>> <<06632>>06575000
    if  plabel = 0  then                                       <<01837>>06580000
    begin                                                      <<01837>>06585000
       meas'flag.(1:1) := 0;                                   <<06893>>06590000
       delay(200d);                                            <<01837>>06595000
       return;                                                 <<01837>>06600000
    end;                                                       <<01837>>06605000
    trapsoff;                                                  <<01837>>06610000
    status.(6:2) := ccg;                                       <<01837>>06615000
    cstn := plabel.(8:8);                                      <<01837>>06620000
    if =  then  return;            << invalid plabel >>        <<01837>>06625000
    indx := dlabel.(8:8);                                      <<01837>>06630000
    if  =  then  return;                                       <<01837>>06635000
    meas'flag.(1:1) := 0;                                      <<06893>>06640000
    delay(200d);                                               <<01837>>06645000
    status.(6:2) := cce;                                       <<01837>>06650000
    if not label'is'sl'seg(plabel,0) then                      <<06402>>06655000
      if logicalmapping then rel'phy'cst(indx)                 <<06402>>06660000
                        else returnentry(1,indx);              <<06402>>06665000
    pinx := curprc;                                            <<06646>>06670000
   unfreeze(plabel,0,pinx);                                    <<06100>>06675000
    if <>  then  status.(6:2) := ccl;                          <<01837>>06680000
   unlockseg(plabel,0,pinx);                                   <<06100>>06685000
    if <>  then  status.(6:2) := ccl;                          <<01837>>06690000
    xdsn := xds1index;                                         <<01837>>06695000
    if >  then                                                 <<01837>>06700000
    begin                                                      <<01837>>06705000
       xds1index := 0;                                         <<01837>>06710000
       unfreeze(xdsn,1,0);                                     <<01837>>06715000
       if <>  then  status.(6:2) := ccl;                       <<01837>>06720000
       unlockseg(xdsn,1,0);                                    <<01837>>06725000
       if <>  then  status.(6:2) := ccl;                       <<01837>>06730000
    end;                                                       <<01837>>06735000
    xdsn := xds2index;                                         <<01837>>06740000
    if >  then                                                 <<01837>>06745000
    begin                                                      <<01837>>06750000
       xds2index := 0;                                         <<01837>>06755000
       unfreeze(xdsn,1,0);                                     <<01837>>06760000
       if <>  then  status.(6:2) := ccl;                       <<01837>>06765000
       unlockseg(xdsn,1,0);                                    <<01837>>06770000
       if <>  then  status.(6:2) := ccl;                       <<01837>>06775000
    end;                                                       <<01837>>06780000
    dlabel := 0;                                               <<01837>>06785000
    setpxfixbit(false);                                        <<01837>>06790000
 end;                                                          <<01837>>06795000
procedure relclock;                                            <<01837>>06800000
option privileged,uncallable;                                  <<01837>>06805000
                                                               <<01837>>06810000
comment:  this procedure is used for system clock interface.   <<01837>>06815000
          when the system clock is "SHARED" by a user, his     <<01837>>06820000
          pxfixed(%26).(2:1) will be set.  at termination,     <<01837>>06825000
          we check that bit has been reset to indicate that    <<01837>>06830000
          he has release the clock.  otherwise, the procedure  <<01837>>06835000
          giveclock in measio will be called to release it     <<01837>>06840000
          for the user.                                        <<01837>>06845000
          ;                                                    <<01837>>06850000
                                                               <<01837>>06855000
begin                                                          <<01837>>06860000
      integer indx, cstn;                                      <<01837>>06865000
      logical ls0 = s-0;                                       <<01837>>06870000
      integer pointer dsti = 2;                                <<06402>>06875000
                                                               <<01837>>06880000
      if dlabel <> 0 then                                      <<06100>>06885000
      begin                                                    <<01837>>06890000
         indx := cstconv(dlabel,0) + 2 ;                       <<06100>>06895000
         tos := dsti(indx);  << cstx bank >>                   <<06402>>06900000
         tos := dsti(indx+1) + rbtorasdisp;                    <<06659>>06905000
         assemble(lsea; del);                                  <<01837>>06910000
         if  >=  then  goto  exit;  << not assigned region >>  <<01837>>06915000
         tos := tos + rastoobjidentdisp;  << get object id >>  <<06659>>06920000
         assemble(ldea);                                       <<06659>>06925000
         if ls1.objidtype <> objidpgmtype then                 <<06659>>06930000
            begin                                              <<06659>>06935000
            ddel;                                              <<06659>>06940000
            go exit;                                           <<06659>>06945000
            end;                                               <<06659>>06950000
                                                               <<06659>>06955000
          cstn := dlabel;                                      <<c8095>>06960000
                         << mapping flag is zero >>            <<06100>>06965000
         ddel;                                                 <<06659>>06970000
                                                               <<06659>>06975000
         giveclock(cstn);  << release all >>                   <<01837>>06980000
      end;                                                     <<01837>>06985000
 exit:                                                         <<01837>>06990000
      dlabel := 0;                                             <<01837>>06995000
   end;                                                        <<01837>>07000000
procedure expire;                                                       07005000
option privileged,uncallable;                                           07010000
                                                                        07015000
comment: called from terminate.                                         07020000
releases the resources of the caller and provokes its complete          07025000
         deletion from the system.                                      07030000
            stops descendants,                                          07035000
            unloads program,                                            07040000
            close local files,                                          07045000
            closes local xtra data segments                             07050000
            deletes dsecendants,                                        07055000
            etc......                                                   07060000
         if main process then calls cleanupjob.                         07065000
         gets burried either by ucop(if main or not killed) or by father07070000
         note:                                                 <<06890>>07075000
           all arrays must be q-relative direct arrays due to  <<06890>>07080000
           the possiblity of entering this procedure with db   <<06890>>07085000
           not at stack (as in some abnormal termination -     <<06890>>07090000
           i.e. =shutdown, abortjob, etc).                     <<06890>>07095000
                                                               <<06890>>07100000
         ;                                                              07105000
                                                                        07110000
begin                                                                   07115000
      equate jitx=6;                                           <<06632>>07120000
      equate term = 16;                                                 07125000
      equate mille=1000;                                                07130000
      equate timedout = 12;                                    <<01131>>07135000
      equate stdinfail = 40;                                   <<04199>>07140000
      logical tlf:=false, desf;                                         07145000
      integer jit,jobtype,proctype,ldev;                                07150000
      integer devtype,cx,pin,jcutindex,efrols;                 <<06887>>07155000
      integer pinnum;                                          <<wh.21>>07160000
      integer pcbpt;                                           <<06646>>07165000
      integer ldt'index;                                       <<06890>>07170000
      integer lpdt'index;                                      <<06891>>07175000
      integer sircond;            << returned from getsir >>   <<01739>>07180000
      double time;                                                      07185000
      integer array jitarr(*)=db+0;                            <<06888>>07190000
      double array jitcputime(*)=jitcpuc;                      <<06888>>07195000
      integer array ldt(*) = db + 0;                           <<06890>>07200000
      byte array buff(0:7)=q;                                  <<00202>>07205000
      integer param = q - 4;                                            07210000
      logical dont'write'to'terminal := false;                 << 8150>>07215000
      integer array pcbx(*)=q+0;                                        07220000
      logical array qarray(*) = q+0;                           <<06632>>07225000
      integer pcbglobloc;                                      <<06632>>07230000
      logical pxfixedloc;                                      <<06632>>07235000
      integer dispose;                                         <<04799>>07240000
      equate delete = 1;                                       <<04799>>07245000
                                                               <<04799>>07250000
logical                                                        <<06891>>07255000
   do'funbreak := false;                                       <<06891>>07260000
                                                               <<06673>>07265000
      << .................................................. >> <<06673>>07270000
      <<    declarations used to reference the jmat         >> <<06673>>07275000
      <<  jmatarr  -- a local array into which the entry is >> <<06673>>07280000
      <<              copied and which the defines ref.     >> <<06673>>07285000
      <<  jmatinx  -- index into the jmatdst or 0 when used >> <<06673>>07290000
      <<              as an index into jmatarr              >> <<06673>>07295000
      << .................................................. >> <<06673>>07300000
                                                               <<06673>>07305000
      integer         jmatinx;                                 <<06890>>07310000
      integer array   jmatarr(0:jmatentrysize-1) = q;          <<06890>>07315000
                                                               <<06673>>07320000
                                                                        07325000
define                                                         <<04199>>07330000
   failparm = param.(8:8) #,  << expcode failure number >>     <<04199>>07335000
   dirfparm = param.(0:8) #;  << expcode directory fail >>     <<04199>>07340000
      subroutine def'movefromdseg;                             <<04799>>07345000
                                                               <<04199>>07350000
      resetdb(-1);                     <<reset db to logical d seg>>    07355000
      exchangedb(0);                   <<reset db to stack>>            07360000
      disaproc;                                                         07365000
      desf:=false;                                                      07370000
      cx := 0;                                                 <<06646>>07375000
      pcbpt := (curprc);                                       <<06646>>07380000
      desf := if soninfo <> 0 then                             <<06646>>07385000
                 true                                          <<06646>>07390000
              else                                             <<06646>>07395000
                 false;                                        <<06646>>07400000
      while (pinnum:= getprocid(cx := cx + 1) * pcbsize) <> 0  <<06646>>07405000
         do                                                    <<06646>>07410000
            set'psif(pinnum,%10); << stop >>                   <<06646>>07415000
      enaproc;                                                          07420000
                                                                        07425000
      pin := pcbpt/pcbsize;                                    <<06646>>07430000
        pxglobal;  <<calculate pxglob location>>               <<06632>>07435000
      <<check stun'sim flag>>                                  <<06632>>07440000
      if pxg'stunbit                                           <<06632>>07445000
       then                                                    <<01766>>07450000
        begin    <<log the stun simulation>>                   <<01766>>07455000
        pxg'stunbit:=0;                                        <<06632>>07460000
        log'stun'simulation(pin);                              <<01766>>07465000
        end;     <<log the stun simulation>>                   <<01766>>07470000
removestop(-1,-1,double(0),-1);              <<user b.p.>>     <<06677>>07475000
                                                                        07480000
      loosesoftinterrupts;                                     <<03047>>07485000
                                                               <<03047>>07490000
      loosetrlx;                                               <<03047>>07495000
                                                               <<03047>>07500000
                                                               <<06889>>07505000
      pxfixed;  <<image special cleanup>>                      <<06632>>07510000
      if pxfximageplbl <> 0 then                               <<06632>>07515000
         begin                                                          07520000
         tos := pxfximageplbl;                                 <<06674>>07525000
         assemble (pcal 0);                                             07530000
         end;                                                           07535000
      pxfixed;   <<data comm special cleanup>>                 <<06889>>07540000
      if pxfxdstrap <> 0 then                                  <<06889>>07545000
         begin                                                 <<06889>>07550000
         tos := pxfxdstrap;                                    <<06889>>07555000
         assemble (pcal 0);                                    <<06889>>07560000
         end;                                                  <<06889>>07565000
                                                                        07570000
      pxfixed;    << horizon special cleanup >>                <<06892>>07575000
      if pxfxhorzplbl <> 0 then                                <<06892>>07580000
         begin                                                 <<06892>>07585000
         tos := pxfxhorzplbl;                                  <<06892>>07590000
         assemble (pcal 0);                                    <<06892>>07595000
         end;                                                  <<06892>>07600000
                                                               <<06892>>07605000
      pxfixed;  <<statistics gathering cleanup>>               <<06632>>07610000
      if pxfxpclsmask <> 0 then                                <<06632>>07615000
         stopstatistics(pxfxpclsmask);                         <<06674>>07620000
                                                               <<01549>>07625000
      sircond := getsir (meassir);                             <<01739>>07630000
      if gclassenabledmask.class15 then                        <<01739>>07635000
        begin  << process instrumentation enabled >>           <<01739>>07640000
          tos := measprocxdsbank;                              <<01739>>07645000
          tos := measprocxdsbase;                              <<01739>>07650000
          assemble (lsea);          << get entry size >>       <<01739>>07655000
          tos := tos * pin;         << offset to entry >>      <<01739>>07660000
          assemble (ladd);          << absolute ptr to entry >><<01739>>07665000
          tos := tos + logical(cp'terminatetime);              <<01739>>07670000
          tos := timer;       << double word time stamp >>     <<01739>>07675000
          assemble (sdea);    << put terminate time in entry >><<01739>>07680000
          ddel;               << xds bank & address >>         <<01739>>07685000
        end << process instrumentation >>;                     <<01739>>07690000
      relsir (meassir, sircond);                               <<01739>>07695000
                                                               <<01739>>07700000
      pxfixed;  <<shared clock interface cleanup>>             <<06632>>07705000
      if  pxfxclkshare  then  relclock;                        <<06632>>07710000
          << release resourses for clock interface >>          <<01549>>07715000
                                                               <<01149>>07720000
      proctype := procstate.ptypefield;                        <<06646>>07725000
      if proctype = ci'proc  and  failparm < stdinfail  then   <<06891>>07730000
         begin      << ci process >>                           <<06891>>07735000
         pxfixed;                                              <<06891>>07740000
         if pxfxjobtype = session then                         <<06891>>07745000
            begin   << session >>                              <<06891>>07750000
            pxglobal;                                          <<06891>>07755000
                                                               <<06891>>07760000
            << if the break bit is set in the lpdt, but the  >><<06891>>07765000
            << process is not in break mode (i.e. the break  >><<06891>>07770000
            << has not been fully processed) then cannot call>><<06891>>07775000
            << funbreak (unless you want to hang).           >><<06891>>07780000
                                                               <<06891>>07785000
            lpdt'index := pxg'inputldev * size'of'lpdt'entry;  <<06891>>07790000
            if lpdt'break and                                  <<06891>>07795000
               not pxfxbrkmode                                 <<06891>>07800000
               then do'funbreak := false                       <<06891>>07805000
            else do'funbreak := true;                          <<06891>>07810000
                                                               <<06891>>07815000
            if do'funbreak then funbreak(true);                <<06891>>07820000
            end;    << session >>                              <<06891>>07825000
         end;       << ci process >>                           <<06891>>07830000
                                                               <<06891>>07835000
                                                                        07840000
      if proctype <> 2 then                                    <<06646>>07845000
      begin << not main >>                                     <<05.eb>>07850000
      disaproc;                                                         07855000
      tos:=%1000d;                                             <<01549>>07860000
      assemble(xchd);                                          <<01549>>07865000
      tos := pcbpt;                                            <<06646>>07870000
      assemble(dzro,dzro);     << leave room for parms. >>     <<06659>>07875000
      tos.initlocflag:=1;                                      <<01549>>07880000
      adjustlocality(*,*,*,*);                                 <<01549>>07885000
      assemble(xchd;ddel);                                     <<01549>>07890000
      enaproc;                                                 <<01549>>07895000
      end; << of not main >>                                   <<05.eb>>07900000
      unload(pin);                    <<unloads the program>>           07905000
                                                               <<04799>>07910000
<<    check if process is a job or a session     >>            <<04799>>07915000
                                                               <<04799>>07920000
      dispose := 0;                                            <<04799>>07925000
      if proctype  = 2 then                                    <<06646>>07930000
                                                               <<04799>>07935000
<<   process is job/session--now check delete flag >>          <<04799>>07940000
                                                               <<04799>>07945000
        begin                                                  <<04799>>07950000
          jmatinx := pxg'jmatinx;                              <<06673>>07955000
          movefromdseg(@jmatarr, jmatdst,                      <<06673>>07960000
                       jmatinx*jmatentrysize, jmatentrysize);  <<06673>>07965000
          jmatinx := 0; << used in define below >>             <<06673>>07970000
          << we must check to see if this is a session being >><< 8150>>07975000
          << programmatically created.  if the waittillon bit>><< 8150>>07980000
          << in the jmat is set, then the terminal has not   >><< 8150>>07985000
          << been speed sensed yet ( it might not even be    >><< 8150>>07990000
          << turned on) so we will not print a message to the>><< 8150>>07995000
          << users terminal later.                           >><< 8150>>08000000
          if jmatproglogon = 1                                 << 8150>>08005000
             then dont'write'to'terminal := true;              << 8150>>08010000
                                                               << 8150>>08015000
          if jmatsavestdlist = delete then                     <<06673>>08020000
             dispose := 4;                                     <<04799>>08025000
          fproctermjob;                                        <<04809>>08030000
        end                                                    <<04799>>08035000
     else             <<  process is not a job/session  >>     <<04799>>08040000
        fprocterm;          << closes remaining files  >>      <<04799>>08045000
      cleanupvolumes;  << need to dismount all volumes >>      <<01422>>08050000
  cleantape(pin);  <<release labeled tapes>>                   <<tl.02>>08055000
      abortdseg(false);                <<closes local xtra data seg>>   08060000
      abortmail;                                               <<00141>>08065000
      abortrin(pin);                                                    08070000
cleanuplog;   <<cleans up any logging stuff held by the user>> <<00506>>08075000
                                                                        08080000
      if desf then                                             <<wh.21>>08085000
        begin            <<have sons>>                         <<wh.21>>08090000
          cx:=0;                                               <<wh.21>>08095000
          disaproc;      <<pdisable>>                          <<wh.21>>08100000
          while (pinnum:=getprocid(cx:=cx+1)) <> 0 do          <<wh.21>>08105000
            begin        <<soft kill sons that are alive>>     <<wh.21>>08110000
              if sys'pcb(pinnum*pcbsize+procstatewordnum).     <<06646>>08115000
                 aliveflag then                                <<06646>>08120000
                begin    <<alive>>                             <<wh.21>>08125000
                  set'psif(pinnum*pcbsize,%20);                <<06646>>08130000
                end;                                           <<wh.21>>08135000
            end <<while>>;                                     <<wh.21>>08140000
          enaproc;       <<penable>>                           <<wh.21>>08145000
          cx:=0;                                               <<wh.21>>08150000
          while (pinnum:=getprocid(cx:=cx+1)) <> 0 do          <<wh.21>>08155000
            begin        <<abort sons i/o>>                    <<wh.21>>08160000
              if sys'pcb(pinnum*pcbsize+procstatewordnum).     <<06646>>08165000
                aliveflag                                      <<06646>>08170000
                 then                                          <<00141>>08175000
                   begin                                       <<00141>>08180000
                     abortprocio(pinnum); <<abort i/o>>        <<00141>>08185000
                     awake(pinnum*pcbsize,%400,0);             <<00141>>08190000
                                  <<abort mail wait>>          <<00141>>08195000
                     << abort console reply wait >>            <<00813>>08200000
                     remritentry'(pinnum,1);                   <<01400>>08205000
                   end;                                        <<00141>>08210000
            end <<while>>;                                     <<wh.21>>08215000
          disable;                                             <<wh.21>>08220000
          while (pinnum:=getprocid(1)) <> 0 do                 <<wh.21>>08225000
            begin        <<burry sons as they die>>            <<wh.21>>08230000
              if sys'pcb(pinnum*pcbsize +                      <<06646>>08235000
                 piinfowordnum).deadflag then                  <<06646>>08240000
                begin    <<dead >>                             <<wh.21>>08245000
                  enable;                                      <<wh.21>>08250000
                  burryproc(pinnum*pcbsize);                   <<06646>>08255000
                end else                                       <<wh.21>>08260000
                begin    <<not dead>>                          <<wh.21>>08265000
                  if sys'pcb(pinnum*pcbsize+procstatewordnum)  <<06646>>08270000
                     .aliveflag then                           <<06646>>08275000
                    begin     <<son still alive>>              <<wh.21>>08280000
                      wait(%4000,0)  <<wait in mourning>>      <<wh.21>>08285000
                    end else                                   <<wh.21>>08290000
                    begin    <<son not alive>>                 <<wh.21>>08295000
                      <<clear both stop and hybernate bits  >> <<01135>>08300000
                      <<to insure father will not be waiting>> <<01135>>08305000
                      <<on a son who will never terminate   >> <<01135>>08310000
                      clear'psif(pinnum*pcbsize,%14);          <<06646>>08315000
                      sys'pcb(pinnum*pcbsize+                  <<06646>>08320000
                      piinfowordnum).facflag := 1;             <<06646>>08325000
                      wait(2,0);          <<wait on son>>      <<wh.21>>08330000
                    end;                                       <<wh.21>>08335000
                end;                                           <<wh.21>>08340000
              disable;                                         <<wh.21>>08345000
            end <<while>>;                                     <<wh.21>>08350000
        end;                                                   <<wh.21>>08355000
                                                                        08360000
e2:                                                                     08365000
                                                                        08370000
      if proctype=1 then              <<son of main>>                   08375000
      begin                                                             08380000
         mrcapok(false);               <<reset global rin flag>>        08385000
         freelocrin;                                                    08390000
         if <  then suddendeath(300);                                   08395000
      end;                                                              08400000
                                                                        08405000
      <<accumulate cpu time at job/session level>>                      08410000
                                                                        08415000
      disable;                         <<interrupts>>                   08420000
      assemble( zero; rclk );     << double of cpu clock >>             08425000
      time := tos;                                                      08430000
                                                                        08435000
      pxglobal; <<calculate pxglob location>>                  <<06632>>08440000
                                                                        08445000
      ldev := pxg'inputldev;                                   <<06632>>08450000
      jit:= pxg'jitdst;  <<job inf table index>>               <<06632>>08455000
      jobtype:=pxg'jobtype;                                    <<06632>>08460000
      jcutindex:=pxg'jcutinx;   <<job cut off index>>          <<06887>>08465000
                                                                        08470000
      pxfixed; <<calculate location of pxfixed table>>         <<06632>>08475000
                                                                        08480000
      tos := pxfxpcputime1;    << high order of time >>        <<06632>>08485000
      tos := pxfxpcputime2;         <<cpu time loaded>>        <<06632>>08490000
                                                                        08495000
      efrols:=pxfxremptime;     << time remainer >>            <<06632>>08500000
      pxfxremptime:=0;                                         <<06632>>08505000
                                                                        08510000
      enable;                          <<interrupts>>                   08515000
      exchangedb(jit);                                                  08520000
      disable;                                                          08525000
                                                                        08530000
      tos:=jitcputime;   tos := time;  <<load cumulated time>> <<06888>>08535000
      assemble(dadd,dadd);          << form cumulated time >>           08540000
      jitcputime := tos;               <<save cumulated time>> <<06888>>08545000
      if overflow then                 <<greater th 23 days>>           08550000
         jitcputime := %17777777777d;  <<infinite>>            <<06888>>08555000
      enable;                          <<interrupts>>                   08560000
                                                                        08565000
      <<update job cut off : cpu time>>                                 08570000
                                                                        08575000
      if jcutindex<>0 then      <<time limiting>>              <<06887>>08580000
      begin                                                             08585000
         jcutindex:=(jcutindex-1)*jcutentsize+jcutheadsize;    <<07314>>08590000
         tos := 0;   tos := efrols;                                     08595000
         tos := time;                                                   08600000
         disable;                                                       08605000
        tos := jcutcpuc1;      <<job cpu time>>                <<06887>>08610000
        tos := jcutcpuc2;                                      <<06887>>08615000
         assemble(dadd,dadd;ddup);                                      08620000
        jcutcpuc2 := tos;      <<store job cpu time>>          <<06887>>08625000
        jcutcpuc1 := tos;                                      <<06887>>08630000
         enable;                                                        08635000
        tos := jcutcpul;       <<job cpu time limit>>          <<06887>>08640000
         tos:=mille;                   <<cpu time lim in sec>>          08645000
         assemble(lmpy,dcmp);                                           08650000
         if > then tlf:=true;          <<excceded time limit>>          08655000
      end;                                                              08660000
                                                                        08665000
      exchangedb(ldt'dst);                                     <<06890>>08670000
      ldt'index := ldev * size'of'ldt'entry;                   <<06890>>08675000
      devtype := ldt'device'type;                              <<06890>>08680000
                                                                        08685000
      if jobtype = session  and  ldt'control'y'pin = pin then  <<07314>>08690000
        begin  << clean up control y for sessions >>                    08695000
          ldt'control'y'pin := 0;                              <<07314>>08700000
          if devtype=term then iocontrol(ldev,12);  << disable cy >>    08705000
        end;                                                            08710000
                                                                        08715000
      exchangedb(0);                   <<back home>>                    08720000
      if resabortinfo.hassirflag then                          <<06646>>08725000
         suddendeath(314);                                     <<06646>>08730000
         << terminating with sir >>                            <<06.eb>>08735000
                                                                        08740000
      tos := piinfo                                            <<06646>>08745000
      .psimfield;                                              <<01549>>08750000
                                                                        08755000
      if proctype=2 then          <<main process>>                      08760000
      begin                                                             08765000
         if devtype=term then   << clean up terminal state >>           08770000
           begin                                                        08775000
             << reset break and control y state >>             <<02077>>08780000
             attachio (ldev, 0, 0, 0, 30, 0, 0, 0, %13);                08785000
             resetbreakbits(ldev, 0);   << reset control y >>           08790000
             iocontrol(ldev,25);   << reset break flush >>              08795000
             << disable break except to ds psudo terminals >>  <<02077>>08800000
             if get'dsdevice(ldev)<3 then iocontrol(ldev,10);  <<02077>>08805000
           end;                                                         08810000
                                                                        08815000
         if (tos <= 2) and (failparm < timedout) and           << 8150>>08820000
            (dont'write'to'terminal = false) then              << 8150>>08825000
           << the main was aborted >>                          <<01131>>08830000
           begin                                                        08835000
             if jobtype =1 then move buff := ("SESSION",0)     <<0u.eb>>08840000
             else move buff := ("JOB",0);                      <<0u.eb>>08845000
             genmsg(1,if tlf then 252 else 251,%0,@buff);      <<0u.eb>>08850000
             << print j/s aborted by system management or if>> <<0u.eb>>08855000
             << timed out, j/s timed out                   >>  <<0u.eb>>08860000
           end;                                                         08865000
                                                                        08870000
         cleanupjob (param,dispose);                           <<04799>>08875000
e4:                                                                     08880000
         requcop(2, pin, true);    << request ucop service >>           08885000
         suddendeath(301);             <<system error>>                 08890000
      end else                         <<not a main process>>           08895000
      begin                                                             08900000
         if tos=2 then                 <<test for soft kill>>           08905000
         begin                                                          08910000
            tos := fatherinfo;                                 <<06646>>08915000
            disable;                                                    08920000
            piinfo.deadflag := 1;                              <<06646>>08925000
            pcbpt := tos;                                      <<06646>>08930000
            if wakemask.mournwaitflag then                     <<06646>>08935000
              begin           <<father in mourning>>           <<wh.21>>08940000
                awake(pcbpt,%4000,2);                          <<06646>>08945000
              end else                                         <<wh.21>>08950000
              begin          <<must activate father>>          <<wh.21>>08955000
                awake(pcbpt,2,2);                              <<06646>>08960000
              end;                                             <<wh.21>>08965000
            wait(2,0);                 <<if awake fails>>               08970000
         end;                                                           08975000
         goto e4;                      <<got here thru a terminate>>    08980000
      end;                                                              08985000
                                                                        08990000
end;  << e x p i r e  >>                                                08995000
                                                                        09000000
procedure disableclass(classnumber);                           <<01614>>09005000
  value classnumber;                                           <<01614>>09010000
  logical classnumber;                                         <<01614>>09015000
  option uncallable,privileged;                                <<01614>>09020000
                                                               <<01614>>09025000
comment                                                        <<01614>>09030000
                                                               <<01614>>09035000
disableclass will turn off mask bits and decrement counters    <<01614>>09040000
for the mpe iv measurement interface.                          <<01614>>09045000
                                                               <<01614>>09050000
input parameter:                                               <<01614>>09055000
                                                               <<01614>>09060000
class  is the classnumber of statistics to be turned off.      <<01614>>09065000
                                                               <<01614>>09070000
return values:                                                 <<01614>>09075000
                                                               <<01614>>09080000
    cc = ccl ==> process did not have class enabled            <<01614>>09085000
    cc = cce ==> ok                                            <<01614>>09090000
    cc = ccg ==> not used                                      <<01614>>09095000
                                                               <<01614>>09100000
operation                                                      <<01614>>09105000
                                                               <<01614>>09110000
this procedure is on only called from stopstatistics.          <<01614>>09115000
it will first verify that the calling process to stopstatistics<<01614>>09120000
did have the class enabled by looking at it's pclassenblmask in<<01614>>09125000
pcbxfixed area. if the process didnt have it enabled no action <<01614>>09130000
is taken, otherwise its class mask bit is reset and the cor-   <<01614>>09135000
responding enabled counter is decremented in measinfotab. if   <<01614>>09140000
the enabled count falls to zero we turn of the classmask bit   <<01614>>09145000
of gclassenabledmask.                                          <<01614>>09150000
;                                                              <<01614>>09155000
                                                               <<01614>>09160000
begin                                                          <<01614>>09165000
                                                               <<01614>>09170000
integer localcount;                                            <<01614>>09175000
integer pointer pclassenblmask;                                <<01614>>09180000
                                                               <<01614>>09185000
define cc = status.(6:2)#;                                     <<01614>>09190000
                                                               <<01614>>09195000
                                                               <<02533>>09200000
cc:=cce; <<initialize>>                                        <<02533>>09205000
                                                               <<01614>>09210000
push(dl);                                                      <<01614>>09215000
@pclassenblmask:=tos;                                          <<01614>>09220000
@pclassenblmask:=@pclassenblmask-pclassenblmask(-2)+           <<01614>>09225000
                 pclassenblmask'idx;                           <<01614>>09230000
tos := pclassenblmask;                                         <<01614>>09235000
x := classnumber;                                              <<01614>>09240000
asmb(trbc 0,x);                                                <<01614>>09245000
if <> then              <<process did have classenabled>>      <<01614>>09250000
  begin                 <<decrement enabled counter>>          <<01614>>09255000
  case classnumber of                                          <<01614>>09260000
    begin                                                      <<01614>>09265000
      begin                                                    <<01614>>09270000
      class0count  := class0count-1;                           <<01614>>09275000
      localcount:=class0count;                                 <<01614>>09280000
      end;                                                     <<01614>>09285000
      begin                                                    <<01614>>09290000
      class1count  := class1count-1;                           <<01614>>09295000
      localcount:=class1count;                                 <<01614>>09300000
      end;                                                     <<01614>>09305000
      begin                                                    <<01614>>09310000
      class2count  := class2count-1;                           <<01614>>09315000
      localcount:=class2count;                                 <<01614>>09320000
      end;                                                     <<01614>>09325000
      begin                                                    <<01614>>09330000
      class3count  := class3count-1;                           <<01614>>09335000
      localcount:=class3count;                                 <<01614>>09340000
      end;                                                     <<01614>>09345000
      begin                                                    <<01614>>09350000
      class4count  := class4count-1;                           <<01614>>09355000
      localcount:=class4count;                                 <<01614>>09360000
      end;                                                     <<01614>>09365000
      begin                                                    <<01614>>09370000
      class5count  := class5count-1;                           <<01614>>09375000
      localcount:=class5count;                                 <<01614>>09380000
      end;                                                     <<01614>>09385000
      begin                                                    <<01614>>09390000
      class6count  := class6count-1;                           <<01614>>09395000
      localcount:=class6count;                                 <<01614>>09400000
      end;                                                     <<01614>>09405000
      begin                                                    <<01614>>09410000
      class7count  := class7count-1;                           <<01614>>09415000
      localcount:=class7count;                                 <<01614>>09420000
      end;                                                     <<01614>>09425000
      begin                                                    <<01614>>09430000
      class8count  := class8count-1;                           <<01614>>09435000
      localcount:=class8count;                                 <<01614>>09440000
      end;                                                     <<01614>>09445000
      begin                                                    <<01614>>09450000
      class9count  := class9count-1;                           <<01614>>09455000
      localcount:=class9count;                                 <<01614>>09460000
      end;                                                     <<01614>>09465000
      begin                                                    <<01614>>09470000
      class10count := class10count-1;                          <<01614>>09475000
      localcount:=class10count;                                <<01614>>09480000
      end;                                                     <<01614>>09485000
      begin                                                    <<01614>>09490000
      class11count := class11count-1;                          <<01614>>09495000
      localcount:=class11count;                                <<01614>>09500000
      end;                                                     <<01614>>09505000
      begin                                                    <<01614>>09510000
      class12count := class12count-1;                          <<01614>>09515000
      localcount:=class12count;                                <<01614>>09520000
      end;                                                     <<01614>>09525000
      begin                                                    <<01614>>09530000
      class13count := class13count-1;                          <<01614>>09535000
      localcount:=class13count;                                <<01614>>09540000
      end;                                                     <<01614>>09545000
      begin                                                    <<01614>>09550000
      class14count := class14count-1;                          <<01614>>09555000
      localcount:=class14count;                                <<01614>>09560000
      end;                                                     <<01614>>09565000
      begin                                                    <<01614>>09570000
      class15count := class15count-1;                          <<01614>>09575000
      localcount:=class15count;                                <<01614>>09580000
      end;                                                     <<01614>>09585000
    end;   <<of case>>                                         <<01614>>09590000
                                                               <<01614>>09595000
  if localcount = 0 then <<turn off global mask>>              <<01614>>09600000
    begin                                                      <<01614>>09605000
    tos:=gclassenabledmask;                                    <<01614>>09610000
    x:=classnumber;                                            <<01614>>09615000
    asmb(trbc 0,x);                                            <<01614>>09620000
    gclassenabledmask:=tos;                                    <<01614>>09625000
    end;                                                       <<01614>>09630000
  pclassenblmask:=tos;   <<tos is from the first trbc>>        <<01614>>09635000
  end                                                          <<01614>>09640000
else                                                           <<01614>>09645000
   cc:=ccl; <<process did not have class enabled>>             <<01614>>09650000
end;                                                           <<01614>>09655000
                                                               <<01614>>09660000
                                                               <<01614>>09665000
                                                               <<01614>>09670000
procedure stopstatistics(classmask);                           <<01614>>09675000
  value classmask;                                             <<01614>>09680000
  logical classmask;                                           <<01614>>09685000
  option privileged,uncallable;                                <<01614>>09690000
                                                               <<01614>>09695000
                                                               <<01614>>09700000
comment                                                        <<01614>>09705000
*************************************************************  <<01614>>09710000
                                                               <<01614>>09715000
stopstatistics is used to terminate statistics gathering for   <<01614>>09720000
a process which had previously turned on statistics gathering. <<01614>>09725000
                                                               <<01614>>09730000
input parameters:                                              <<01614>>09735000
                                                               <<01614>>09740000
      classmask: a bit mask of statistic classes to be disabled<<01614>>09745000
                                                               <<01614>>09750000
return values:                                                 <<01614>>09755000
                                                               <<01614>>09760000
     cc = ccg ==> did not have class enabled.                  <<01614>>09765000
     cc = cce ==> ok                                           <<01614>>09770000
     cc = ccl ==> could not cleanpup (data seg)                <<01614>>09775000
                                                               <<01614>>09780000
operation:                                                     <<01614>>09785000
                                                               <<01614>>09790000
     stopstatistics will first get the meassir to avoid        <<01614>>09795000
     problems with dual acces to sys global cells. it will     <<01614>>09800000
     then start to turn off the class bits in both the         <<01614>>09805000
     glassenabledmask and pclassenabled mask by calling        <<01614>>09810000
     the disableclass procedure. if any of the classes re-     <<01614>>09815000
     quested to be turned off were not previously turned       <<01614>>09820000
     on by the calling process then ccg will be returned.      <<01614>>09825000
     note: stopstatistics will continue to turn off any        <<01614>>09830000
     classes the user requested regardless if he attempted     <<01614>>09835000
     to turn off one or more not previously enabled. if        <<01614>>09840000
     all classes of either the global or process level class   <<01739>>09845000
     of statistics have been disabled, then the appropiate     <<01739>>09850000
     data segment is released.                                 <<01739>>09855000
                                                               <<01739>>09860000
                                                               <<01614>>09865000
*************************************************************  <<01614>>09870000
;                                                              <<01614>>09875000
                                                               <<01614>>09880000
begin                                                          <<01614>>09885000
logical bitword,          <<loop variable for setting masks>>  <<01614>>09890000
        mysir,            <<used as 2nd parm for relsir>>      <<01614>>09895000
        savex;                                                 <<01614>>09900000
                                                               <<01614>>09905000
integer pointer pclassenblmask;                                <<01614>>09910000
                                                               <<01614>>09915000
 integer indx := 14, xds'num;                                  <<01837>>09920000
                                                               <<01837>>09925000
 define  statxdsbank = measinfotabptr(indx)#,                  <<01837>>09930000
         statxdsbase = measinfotabptr(indx+1)#,                <<01837>>09935000
         statxds'num = measinfotabptr(indx+2)#,                <<01837>>09940000
         user'dfnd'class = classmask.(9:7)#;                   <<01837>>09945000
                                                               <<01837>>09950000
define globalmask = (0:1)#,                                    <<01739>>09955000
       procmask   = (15:1)#,                                   <<01739>>09960000
       globalstatsenbld =  gclassenabledmask.globalmask <> 0#, <<01739>>09965000
       globalstatreq    = classmask.globalmask <> 0#,          <<01739>>09970000
       procstatsenbld   = gclassenabledmask.procmask <> 0#,    <<01739>>09975000
       procstatreq      = classmask.procmask <> 0#,            <<01739>>09980000
       cc = status.(6:2)#;                                     <<01614>>09985000
                                                               <<01614>>09990000
<<**************main*****************>>                        <<01614>>09995000
                                                               <<01614>>10000000
cc:=cce;                                                       <<01614>>10005000
mysir := getsir(meassir);                                      <<01614>>10010000
                                                               <<01614>>10015000
if gclassenabledmask <> 0 and classmask <> 0 then              <<01739>>10020000
   begin                                                       <<01739>>10025000
   savex:=-1;                   <<used to initialize x reg>>   <<01739>>10030000
   bitword:=classmask;          <<loop variable>>              <<01739>>10035000
   while bitword <> 0 do                                       <<01739>>10040000
     begin                                                     <<01739>>10045000
     tos:=bitword;                                             <<01739>>10050000
     x:=savex;                                                 <<01739>>10055000
     asmb(scan,x);                                             <<01739>>10060000
     savex:=x;        <<for use in next scan>>                 <<01739>>10065000
     bitword:=tos;    <<scan bitshifts left until 0>>          <<01739>>10070000
     disableclass(savex);<<turn off global and proc masks>>    <<01739>>10075000
     if <> then cc:=ccg;                                       <<01739>>10080000
     end;                                                      <<01739>>10085000
                                                               <<01739>>10090000
   if not (globalstatsenbld) and measstatxds'num <> 0 then     <<01739>>10095000
      begin   << no longer need data segment >>                <<01739>>10100000
      unfreeze(measstatxds'num,1,0);                           <<01739>>10105000
      if <> then cc:=ccl else                                  <<01739>>10110000
         begin                                                 <<01739>>10115000
         unlockseg(measstatxds'num,1,0);                       <<01739>>10120000
         if <> then cc:=ccl else                               <<01739>>10125000
            begin                                              <<01739>>10130000
            reldataseg(measstatxds'num);                       <<01739>>10135000
            measstatxdsbank:=0;                                <<01739>>10140000
            measstatxdsbase:=0;                                <<01739>>10145000
            measstatxds'num:=0;                                <<01739>>10150000
            end;                                               <<01739>>10155000
         end;                                                  <<01739>>10160000
      end;                                                     <<01739>>10165000
                                                               <<01739>>10170000
                                                               <<01739>>10175000
    savex := user'dfnd'class land (not gclassenabledmask);     <<01837>>10180000
    while  savex <> 0  do                                      <<01837>>10185000
    begin                                                      <<01837>>10190000
       indx := indx + 3;    << index to xds info >>            <<01837>>10195000
       xds'num := statxds'num;                                 <<01837>>10200000
       if  savex and xds'num <> 0  then                        <<01837>>10205000
       begin                                                   <<01837>>10210000
          unfreeze(xds'num, 1, 0);                             <<01837>>10215000
          if  <>  then  cc := ccl  else                        <<01837>>10220000
          begin                                                <<01837>>10225000
             unlockseg(xds'num, 1, 0);                         <<01837>>10230000
             if  <>  then  cc := ccl  else                     <<01837>>10235000
             begin                                             <<01837>>10240000
                reldataseg(xds'num);                           <<01837>>10245000
                statxds'num := 0;                              <<01837>>10250000
                statxdsbank := 0;                              <<01837>>10255000
                statxdsbase := 0;                              <<01837>>10260000
             end;                                              <<01837>>10265000
          end;                                                 <<01837>>10270000
       end;                                                    <<01837>>10275000
       savex := savex&lsr(1);                                  <<01837>>10280000
    end;                                                       <<01837>>10285000
   end                                                         <<01739>>10290000
else                                                           <<01739>>10295000
   cc:=ccg; <<either not enabled or user didnt have enabled>>  <<01739>>10300000
relsir(meassir,mysir);                                         <<01614>>10305000
end;                                                           <<01614>>10310000
procedure log'stun'simulation(pin);                            <<01766>>10315000
value pin;                                                     <<01766>>10320000
integer pin;                                                   <<01766>>10325000
option privileged,uncallable;                                  <<01766>>10330000
begin                                                          <<01766>>10335000
                                                               <<01766>>10340000
equate     stun'type           =  0,      <<sub type>>         <<01766>>10345000
           prog'file'type      =  16;     <<major type>>       <<01766>>10350000
                                                               <<01766>>10355000
byte array prog'file(0:27);                                    <<01766>>10360000
                                                               <<01766>>10365000
<<this procedure is called to log a stackunderflow simulation>><<01766>>10370000
<<for the icf 44/55.                                         >><<01766>>10375000
                                                               <<01766>>10380000
                                                               <<01766>>10385000
procfile(pin,prog'file);      <<get prog file name>>           <<01766>>10390000
<<check if valid prog file name>>                              <<01766>>10395000
if < then move prog'file:="CAN'T DETERMINE PROGRAM FILE";      <<01766>>10400000
tos:=stun'type;               <<log record sub type>>          <<01766>>10405000
tos:=0d;                      <<unused fields>>                <<01766>>10410000
tos:=@prog'file;              <<prog file name>>               <<01766>>10415000
tos:=28;                      <<name length>>                  <<01766>>10420000
tos:=prog'file'type;          <<log record major type>>        <<01766>>10425000
log16;                        <<log event>>                    <<01766>>10430000
end;                                                           <<01766>>10435000
procedure terminate;                                           <<02066>>10440000
option privileged;                                             <<02066>>10445000
                                                               <<02066>>10450000
comment: this is a user callable intrinsic which will          <<02066>>10455000
         terminate a process.  it cuts the stack back          <<02066>>10460000
         to the initial q setting and may be called with       <<02066>>10465000
         with db logically anywhere.                           <<02066>>10470000
************************************************************** <<02066>>10475000
*  terminate must be the first procedure in morgue's         * <<02066>>10480000
*  code segment!  lots of software relies on the delta p     * <<02066>>10485000
*  value in morgues stack marker being zero in order to      * <<02066>>10490000
*  find the parm value supplied on the run command           * <<02066>>10495000
*  any local variables should be q direct, and must do the   * <<07314>>10500000
*  adds to create local variable space in order to insure    * <<07314>>10505000
*  that the entry point is at zero.                          * <<07314>>10510000
*************************************************************; <<02066>>10515000
                                                               <<02066>>10520000
begin                                                          <<02066>>10525000
                                                               <<02066>>10530000
    define mamonitoron = absolute (%1267) #;                   <<02066>>10535000
    equate qini = 3,                                           <<07314>>10540000
           local'var'count = 2;                                <<07314>>10545000
    integer array qarray(*) = q+0;                             <<06632>>10550000
    integer pcbpt = q+1;                                       <<07314>>10555000
    logical pxfixedloc = q+2;                                  <<07314>>10560000
                                                               <<07314>>10565000
    entry terminate';                                          <<02066>>10570000
                                                               <<02066>>10575000
terminate':                                                    <<02066>>10580000
                                                               <<07314>>10585000
    push (status);                <<traps off>>                <<02066>>10590000
    tos.(2:1) := 0;                                            <<02066>>10595000
    set (status);                                              <<02066>>10600000
                                                               <<07314>>10605000
    assemble (adds local'var'count);                           <<07314>>10610000
                                                               <<07314>>10615000
    pcbpt := curprc;                                           <<07314>>10620000
    disable;                                                   <<*7953>>10625000
    procstate.aliveflag := 0;                                  <<06646>>10630000
      if resabortinfo.hassirflag then                          <<h8897>>10635000
         << terminating with sir >>                            <<h8897>>10640000
         suddendeath(314);                                     <<h8897>>10645000
    pxfixed;   <<find location of pxfixed>>                    <<06632>>10650000
    tos := pxfxqreg;               <<initial value of q-db>>   <<06632>>10655000
    tos := a'(a'(qi)-4);          <<stdb>>                     <<02066>>10660000
    push (db);                    <<push actual db>>           <<02066>>10665000
    assemble (delb,sub; add,dup);                              <<02066>>10670000
    set (q,s);                    <<set q,s to qi>>            <<02066>>10675000
    enable;                                                    <<02066>>10680000
    x := mamonitoron;                                          <<02066>>10685000
    if <> then mmstat'(mmstatterminate,0,0,0,0,0,0);           <<06893>>10690000
    expire;                                                    <<02066>>10695000
    help;                         <<for debuger linking>>      <<02066>>10700000
end;  <<termintate>>                                           <<02066>>10705000
                                                               <<02066>>10710000
$control segment=main                                          <<02066>>10715000
end.                                                           <<02066>>10720000
