$CONTROL USLINIT,MAP,CODE,SOURCE                                        00010000
<< jobtable - module 74 >>                                     <<00745>>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=jobtable                                               00060000
$control privileged                                                     00065000
begin                                                                   00070000
$page "***   GENERAL/GLOBAL EQUIVALENCES   ***"                         00075000
integer                                                                 00080000
         db0   = db+0  ,                                                00085000
         s0    = s-0   ,                                                00090000
         s3    = s-3   ,                                                00095000
         s5    = s-5   ,                                                00100000
         x     = x     ,                                                00105000
         xreg  = x     ;                                                00110000
integer pointer                                                         00115000
         ps0   = s-0   ,                                                00120000
         ps1   = s-1   ;                                                00125000
byte pointer                                                            00130000
         bps0  = s-0   ,                                                00135000
         bps1  = s-1   ;                                                00140000
                                                                        00145000
                                                                        00150000
   << system global / pointer >>                                        00155000
pointer                                                                 00160000
         sys'dst   = 2    ;                                             00165000
   << job directory table declarations >>                      <<u.rao>>00170000
integer jdtbase = db+0,  <<segment sizes>>                     <<u.rao>>00175000
        jdsdadr = jdtbase+1,  <<address of jdt dsd>>           <<u.rao>>00180000
        jtfdadr = jdsdadr+1,  <<address of job temp file dir>> <<u.rao>>00185000
        jfeqadr = jtfdadr+1,  <<address of file eq table>>     <<u.rao>>00190000
        jleqadr = jfeqadr+1,  <<address of line eq table>>     <<u.rao>>00195000
        jjcwadr = jleqadr+1,  <<address of jcw table>>         <<u.rao>>00200000
        jfreespcadr = jjcwadr+1,  <<address of free space>>    <<u.rao>>00205000
        jdtworkspcbase = jfreespcadr+1,  <<jdt work space>>    <<u.rao>>00210000
        jdsjnum = jdtworkspcbase+15,  <<job number>>           <<u.rao>>00215000
        jesmpn  = jdsjnum+1;   <<main pin number>>             <<u.rao>>00220000
integer pointer                                                <<u.rao>>00225000
        jdsdptr = jdsdadr,                                     <<u.rao>>00230000
        jtfdptr = jtfdadr,                                     <<u.rao>>00235000
        jfeqptr = jfeqadr,                                     <<u.rao>>00240000
        jleqptr = jleqadr,                                     <<u.rao>>00245000
        jjcwptr = jjcwadr,                                     <<u.rao>>00250000
        jfreespcptr = jfreespcadr;                             <<u.rao>>00255000
integer array                                                  <<u.rao>>00260000
        jdtworkspc(*) = jdtworkspcbase,                        <<u.rao>>00265000
        jdtarr(*) = jdtbase;                                   <<u.rao>>00270000
equate numjdtptrs = 6;  <<number of pointers in table>>        <<u.rao>>00275000
define                                                         <<u.rao>>00280000
   def'movefromdseg =                                          <<u.rao>>00285000
      movefromdseg(target,dstn,offset,count);                  <<u.rao>>00290000
         value target,dstn,offset,count;                       <<u.rao>>00295000
         logical target,dstn,offset,count;                     <<u.rao>>00300000
      begin                                                    <<u.rao>>00305000
         x := tos; << save return address >>                   <<u.rao>>00310000
         assemble(mfds 0);                                     <<u.rao>>00315000
         tos := x; << restore return address >>                <<u.rao>>00320000
      end #,                                                   <<u.rao>>00325000
                                                               <<u.rao>>00330000
   def'movetodseg =                                            <<u.rao>>00335000
      movetodseg(dstn,offset,source,count);                    <<u.rao>>00340000
         value dstn,offset,source,count;                       <<u.rao>>00345000
         logical dstn,offset,source,count;                     <<u.rao>>00350000
      begin                                                    <<u.rao>>00355000
         x := tos;                                             <<u.rao>>00360000
         assemble(mtds 0);                                     <<u.rao>>00365000
         tos := x;                                             <<u.rao>>00370000
      end #;                                                   <<u.rao>>00375000
                                                               <<u.rao>>00380000
$set x8=off                                                    <<06596>>00385000
$include incljmat                                              <<06596>>00390000
$include inclpxg                                               <<06595>>00395000
$page "***   JOBTABLE   ***"                                            00400000
integer procedure altdsegsize(ix,size);                                 00405000
   value ix,size;                                                       00410000
   integer ix,size;                                                     00415000
   option external;                                                     00420000
                                                                        00425000
integer procedure getsir(sir);                                          00430000
   value sir;                                                           00435000
   integer sir;                                                         00440000
   option external;                                                     00445000
                                                                        00450000
procedure relsir(sir,fl);                                               00455000
   value sir,fl;                                                        00460000
   integer sir,fl;                                                      00465000
   option external;                                                     00470000
                                                                        00475000
logical procedure exchangedb (dstx);                                    00480000
   value dstx;                                                          00485000
   logical dstx;                                                        00490000
   option external;                                                     00495000
                                                                        00500000
integer procedure lockjir;                                              00505000
   option external;                                                     00510000
                                                               << 8147>>00515000
procedure transjcwequate(eq,jcw,errnum,errptr);                << 8147>>00520000
byte array eq;                                                 << 8147>>00525000
integer jcw,errnum,errptr;                                     << 8147>>00530000
option external;                                               << 8147>>00535000
                                                               << 8147>>00540000
                                                                        00545000
procedure unlockjir(b);                                                 00550000
   value   b;                                                           00555000
   logical b;                                                           00560000
   option external;                                                     00565000
                                                                        00570000
procedure suddendeath(a);                                               00575000
   value a;                                                             00580000
   integer a;                                                           00585000
   option external;                                                     00590000
                                                                        00595000
procedure help;                                                         00600000
   option external;                                                     00605000
                                                                        00610000
intrinsic binary,mycommand,dbinary;                            <<04696>>00615000
                                                                        00620000
procedure errorexit (i,e,p);                                   <<u.rao>>00625000
   value   i,e,p;                                              <<u.rao>>00630000
   logical i,e,p;                                              <<u.rao>>00635000
   option external;                                            <<u.rao>>00640000
                                                               <<u.rao>>00645000
procedure erroron;                                             <<u.rao>>00650000
   option external;                                            <<u.rao>>00655000
                                                               <<u.rao>>00660000
   double procedure chek(intrin,flags,parms,capmask,optvmask); <<u.rao>>00665000
   value intrin,flags,parms,capmask,optvmask;                  <<u.rao>>00670000
   logical intrin,flags,optvmask;                              <<u.rao>>00675000
   double parms,capmask;                                       <<u.rao>>00680000
   option variable,external;                                   <<u.rao>>00685000
                                                               <<u.rao>>00690000
                                                                        00695000
                                                                        00700000
procedure packandpoint (fileref, len, gpntr, apntr);                    00705000
   byte array fileref;                                                  00710000
   integer len;                                                         00715000
   logical gpntr, apntr;                                                00720000
   option uncallable;                                                   00725000
<< this procedure analyzes <fileref> and ensures that it is in a        00730000
   legitimate file reference format.                                    00735000
   returns:                                                             00740000
      ccl- invalid name.                                                00745000
      cce- okay:                                                        00750000
      <gpntr> is byte pointer to group name, or 0.                      00755000
      <apntr> is byte pointer to account name, or 0.                    00760000
   >>                                                                   00765000
begin                                                                   00770000
   integer flag := -1;                                                  00775000
   logical status = q-1;                                                00780000
   equate  cce = 2 ,                                                    00785000
           ccg = 0 ,                                                    00790000
           ccl = 1 ;                                                    00795000
   define  cc = status.(6:2) #;                                         00800000
                                                                        00805000
logical subroutine doname (name);                                       00810000
   value name;                                                          00815000
   logical name;                                                        00820000
<< scans <name> to ensure that it is legitimate;                        00825000
   if <name> exactly satisfies <len>, then cce return to packandpoint   00830000
      caller.                                                           00835000
   allows for lockword following first name;                            00840000
   if still characters left and delimiter is ".", then                  00845000
      returns byte pointer to next name.>>                              00850000
 begin                                                                  00855000
   if bps1 <> alpha then goto error;                                    00860000
   tos := name;                                                         00865000
   assemble (dup, dup);                                                 00870000
   move * := * while ans, 0;                                            00875000
   assemble (cab, sub);                                                 00880000
   if = then goto error;                                                00885000
   if tos > 8 then goto error;                                          00890000
   if (s0 -@fileref) = len then                                         00895000
      begin                                                             00900000
      tos := cce;                                                       00905000
      goto exit;                                                        00910000
      end;                                                              00915000
   if > then goto error;                                                00920000
   flag := flag +1;                                                     00925000
   if = and bps0 = "/" then                                             00930000
      begin                                                             00935000
      assemble (dup, inca);                                             00940000
      tos := doname (*);                                                00945000
      end                                                               00950000
   else                                                                 00955000
      begin                                                             00960000
      if bps0 <> "." then goto error;                                   00965000
      tos := tos +1;                                                    00970000
      end;                                                              00975000
   s3 := tos;                                                           00980000
   end    <<subroutine doname>>;                                        00985000
                                                                        00990000
   gpntr := 0;                                                          00995000
   apntr := 0;                                                          01000000
   doname (apntr := doname (gpntr := doname (@fileref)));               01005000
error:                                                                  01010000
   tos := ccl;                                                          01015000
exit:                                                          <<u.rao>>01020000
   cc := tos;                                                  <<u.rao>>01025000
   end    <<packandpoint>>;                                    <<u.rao>>01030000
logical procedure parsejobid(jobid, result);                   <<u.rao>>01035000
byte array jobid;                                              <<u.rao>>01040000
integer array result;                                          <<u.rao>>01045000
option privileged, uncallable;                                 <<u.rao>>01050000
<<function:  parse a jobid for cxtell, constell, conswarn.>>   <<u.rao>>01055000
<<input:                                                    >> <<u.rao>>01060000
<<   jobid - byte pointer to job id.  can have any of the   >> <<u.rao>>01065000
<<        following forms.                                  >> <<u.rao>>01070000
<<                                                          >> <<u.rao>>01075000
<<        [#]{s/j}nnn                                       >> <<u.rao>>01080000
<<        [[jsname],]username.acctname                      >> <<u.rao>>01085000
<<        @                                                 >> <<u.rao>>01090000
<<        @s                                                >> <<u.rao>>01095000
<<        @j                                                >> <<u.rao>>01100000
<<                                                          >> <<u.rao>>01105000
<<   output:                                                >> <<u.rao>>01110000
<<                                                          >> <<u.rao>>01115000
<<        result is a 17 word array to which is returned the>> <<u.rao>>01120000
<<           output of the parse as follows.                >> <<u.rao>>01125000
<<           result(13) identifies the type of jobid parsed.>> <<u.rao>>01130000
<<                                                          >> <<u.rao>>01135000
<<              0 => job number                             >> <<u.rao>>01140000
<<              1 => jsname, user.acct                      >> <<u.rao>>01145000
<<              2 => user.acct                              >> <<u.rao>>01150000
<<              3 => @.acct                                 >> <<u.rao>>01155000
<<              4 => @s                                     >> <<u.rao>>01160000
<<              5 => @j                                     >> <<u.rao>>01165000
<<              6 => @                                      >> <<u.rao>>01170000
<<                                                          >> <<u.rao>>01175000
<<           if 0, the job number will be in the jmat       >> <<u.rao>>01180000
<<              format in result(0).                        >> <<u.rao>>01185000
<<           if 1, result(1) = user name                    >> <<u.rao>>01190000
<<                 result(5) = acct name                    >> <<u.rao>>01195000
<<                 result(9) = job name                     >> <<u.rao>>01200000
<<           if 2, result(1) = user name                    >> <<u.rao>>01205000
<<                 result(5) = acct name                    >> <<u.rao>>01210000
<<           if 3, result(5) = acct name                    >> <<u.rao>>01215000
<<           if 4,5,6 then result(0) - result(12) garbage   >> <<u.rao>>01220000
<<           result(14) = byte pointer to first character   >> <<u.rao>>01225000
<<              following character in result(15).          >> <<u.rao>>01230000
<<           result(15) = first non-blank character         >> <<u.rao>>01235000
<<              following jobid.                            >> <<u.rao>>01240000
<<                                                          >> <<u.rao>>01245000
<<        if an error occurred in parse, parsejobid will    >> <<u.rao>>01250000
<<           return false  (else true).                     >> <<u.rao>>01255000
<<           result(14) will be a byte pointer to the place >> <<u.rao>>01260000
<<              in jobid where the error was found.         >> <<u.rao>>01265000
<<           result(15) will be the internal error number   >> <<u.rao>>01270000
<<           result(16) will be the ordinal of the parameter>> <<u.rao>>01275000
<<              in error.                                   >> <<u.rao>>01280000
<<                                                          >> <<u.rao>>01285000
<<                                                          >> <<u.rao>>01290000
begin                                                          <<u.rao>>01295000
integer tokenlen;  <<length of current part of jobid>>         <<u.rao>>01300000
byte pointer tokenptr;  <<current place in jobid>>             <<u.rao>>01305000
   <<also when error encountered, points to error location>>   <<u.rao>>01310000
byte pointer idptr;  <<points to next place in jobid>>         <<u.rao>>01315000
byte pointer delim;  <<points ot current delimiter>>           <<u.rao>>01320000
define jobfield = (0:2)#;                                      <<u.rao>>01325000
equate jobflag = 2,                                            <<u.rao>>01330000
       sessionflag = 1;                                        <<u.rao>>01335000
byte array bresult(*) = result;                                <<u.rao>>01340000
integer errnum := 0;                                           <<u.rao>>01345000
equate jobnum = 0,                                             <<u.rao>>01350000
       fullname = 1,                                           <<u.rao>>01355000
       userid = 2,                                             <<u.rao>>01360000
       allofacct = 3,                                          <<u.rao>>01365000
       allsessions = 4,                                        <<u.rao>>01370000
       alljobs = 5,                                            <<u.rao>>01375000
       all = 6;                                                <<u.rao>>01380000
equate invjobnumber = 1,                                       <<u.rao>>01385000
       invsessionnum = 2,                                      <<u.rao>>01390000
       xpctjors = 3,                                           <<u.rao>>01395000
       xpctjsorat = 4,                                         <<u.rao>>01400000
       jobxpctjustat = 5,                                      <<u.rao>>01405000
       jobnametoolong = 6,                                     <<u.rao>>01410000
       jobxpctalpha = 7,                                       <<u.rao>>01415000
       usernamemissing = 8,                                    <<u.rao>>01420000
       usernametoolong = 9,                                    <<u.rao>>01425000
       userxpctalpha = 10,                                     <<u.rao>>01430000
       xpctperioddelim = 11,                                   <<u.rao>>01435000
       acctnamemissing = 12,                                   <<u.rao>>01440000
       acctxpctnamntat = 13,                                   <<u.rao>>01445000
       acctnametoolong = 14,                                   <<u.rao>>01450000
       acctxpctalpha = 15,                                     <<u.rao>>01455000
       jobidmissing = 16;                                      <<u.rao>>01460000
logical subroutine getnext;                                    <<u.rao>>01465000
<<gets next token from jobid>>                                 <<u.rao>>01470000
begin                                                          <<u.rao>>01475000
tokenlen := 0;                                                 <<u.rao>>01480000
scan idptr while %6440, 1;  <<skip leading blanks>>            <<u.rao>>01485000
@tokenptr := tos;                                              <<u.rao>>01490000
if carry then   <<no more non-blank characters>>               <<u.rao>>01495000
   getnext := false                                            <<u.rao>>01500000
else                                                           <<u.rao>>01505000
   begin  <<look for "@" sign>>                                <<u.rao>>01510000
   getnext := true;                                            <<u.rao>>01515000
   if tokenptr <> "@" then                                     <<u.rao>>01520000
      begin                                                    <<u.rao>>01525000
      if tokenptr="#" then   <<skip past it>>                  <<u.rao>>01530000
         tos := @tokenptr+1                                    <<u.rao>>01535000
      else                                                     <<u.rao>>01540000
         tos := @tokenptr;                                     <<u.rao>>01545000
      assemble(dup);                                           <<u.rao>>01550000
      move * := * while ans,1;                                 <<u.rao>>01555000
      tokenlen := s0-@tokenptr;                                <<u.rao>>01560000
      scan * while %6440, 1;  <<skip blanks to next delim>>    <<u.rao>>01565000
      @delim := s0;  <<pointer to delimiter>>                  <<u.rao>>01570000
      @idptr := tos+1;                                         <<u.rao>>01575000
      end                                                      <<u.rao>>01580000
   else if tokenptr(1) <> " " and tokenptr(1) <> %15 then      <<u.rao>>01585000
      begin                                                    <<u.rao>>01590000
      @idptr := @tokenptr+1;  <<skip "@">>                     <<u.rao>>01595000
      getnext;                                                 <<u.rao>>01600000
      @tokenptr := @tokenptr-1;                                <<u.rao>>01605000
      tokenlen := tokenlen+1;                                  <<u.rao>>01610000
      end                                                      <<u.rao>>01615000
   else   <<has trailing blank(s)>>                            <<u.rao>>01620000
      begin                                                    <<u.rao>>01625000
      tokenlen := 1;  <<for "@">>                              <<u.rao>>01630000
      scan tokenptr(1) while %6440,1;  <<find first non-blank>><<u.rao>>01635000
      @delim := tos;  <<first non-blank after "@">>            <<u.rao>>01640000
      @idptr := @delim+1;                                      <<u.rao>>01645000
      end;                                                     <<u.rao>>01650000
   end;                                                        <<u.rao>>01655000
end;                                                           <<u.rao>>01660000
subroutine parsejsnumber;                                      <<u.rao>>01665000
begin                                                          <<u.rao>>01670000
<<on entrance, the entity believed to be a job or session numbe<<u.rao>>01675000
<<has been tokenized and any leading "#" has been stripped.  >><<u.rao>>01680000
<<this subroutine converts the id into a format compatible with<<u.rao>>01685000
<<the jmat format for job numbers.  if any errors, the return>><<u.rao>>01690000
<<values are completely set up inside parsejsnumber.>>         <<u.rao>>01695000
result(13) := jobnum;  <<type of parsed id>>                   <<u.rao>>01700000
result(15) := 0;  <<error code>>                               <<u.rao>>01705000
if tokenptr = "J" then   <<job>>                               <<u.rao>>01710000
   begin                                                       <<u.rao>>01715000
   result := binary(tokenptr(1), tokenlen-1);                  <<u.rao>>01720000
   if <> or not(1<=result<=16383) then  <<invalid number>>     <<u.rao>>01725000
      begin                                                    <<u.rao>>01730000
      result(14) := @tokenptr(1);                              <<u.rao>>01735000
      result(15) := invjobnumber;                              <<u.rao>>01740000
      end                                                      <<u.rao>>01745000
   else  <<good job number, complete formatting>>              <<u.rao>>01750000
      result.jobfield := jobflag;                              <<u.rao>>01755000
   end                                                         <<u.rao>>01760000
else if tokenptr="S" then   <<session>>                        <<u.rao>>01765000
   begin                                                       <<u.rao>>01770000
   result := binary(tokenptr(1), tokenlen-1);                  <<u.rao>>01775000
   if <> or not(1<=result<=16383) then                         <<u.rao>>01780000
      begin                                                    <<u.rao>>01785000
      result(14) := @tokenptr(1);                              <<u.rao>>01790000
      result(15) := invsessionnum;                             <<u.rao>>01795000
      end                                                      <<u.rao>>01800000
   else  <<good session number>>                               <<u.rao>>01805000
      result.jobfield := sessionflag;                          <<u.rao>>01810000
   end                                                         <<u.rao>>01815000
else   <<not j or s, what is it?>>                             <<u.rao>>01820000
   begin                                                       <<u.rao>>01825000
   result(14) := @tokenptr;                                    <<u.rao>>01830000
   result(15) := xpctjors;                                     <<u.rao>>01835000
   end;                                                        <<u.rao>>01840000
if result(15)=0 then   <<good parse - finish up>>              <<u.rao>>01845000
   begin                                                       <<u.rao>>01850000
   parsejobid := true;                                         <<u.rao>>01855000
   result(14) := @idptr;                                       <<u.rao>>01860000
   result(15) := delim;                                        <<u.rao>>01865000
   end;                                                        <<u.rao>>01870000
end;   <<subroutine parsejsnumber>>                            <<u.rao>>01875000
subroutine parsejsname;                                        <<u.rao>>01880000
begin                                                          <<u.rao>>01885000
<<on entrance, the first name has been tokenized by getnext,>> <<u.rao>>01890000
<<the return values to the procedure have been initialized to>><<u.rao>>01895000
<<syntax error and we are sure that the jobid is not a >>      <<u.rao>>01900000
<<j/s number.  we do not know if anything else weird is present<<u.rao>>01905000
<<on return, either an error has been detected, in which case>><<u.rao>>01910000
<<the return values are properly set, or no error was detected,<<u.rao>>01915000
<<in which case result is properly set.>>                      <<u.rao>>01920000
result(1) := "  ";                                             <<u.rao>>01925000
move result(2) := result(1), (11);  <<init return>>            <<u.rao>>01930000
result(13) := userid;  <<default type of jobid>>               <<u.rao>>01935000
result(16) := 0;  <<current parameter number>>                 <<u.rao>>01940000
if delim = "," then   <<job name part present>>                <<u.rao>>01945000
   begin                                                       <<u.rao>>01950000
   result(16) := 1; <<first token>>                            <<u.rao>>01955000
   if tokenlen = 0 then                                        <<u.rao>>01960000
      <<ignore - same as not specified>>                       <<u.rao>>01965000
      if not getnext then   <<no more tokens available>>       <<u.rao>>01970000
         errnum := usernamemissing                             <<u.rao>>01975000
      else  <<really ignore>>                                  <<u.rao>>01980000
   else if tokenptr = "@" and tokenlen>1 then                  <<u.rao>>01985000
      begin                                                    <<u.rao>>01990000
      @tokenptr := @tokenptr+1;                                <<u.rao>>01995000
      errnum := jobxpctjustat                                  <<u.rao>>02000000
      end                                                      <<u.rao>>02005000
   else if tokenlen>8 then                                     <<u.rao>>02010000
      errnum := jobnametoolong                                 <<u.rao>>02015000
   else if tokenptr<>alpha and tokenptr<>"@" then              <<u.rao>>02020000
      errnum := jobxpctalpha                                   <<u.rao>>02025000
   else   <<looks ok>>                                         <<u.rao>>02030000
      begin  <<put upshifted copy in result>>                  <<u.rao>>02035000
      move bresult(18) := tokenptr while ans;                  <<u.rao>>02040000
      result(13) := fullname;  <<jobid parsed type>>           <<u.rao>>02045000
      if not getnext then                                      <<u.rao>>02050000
         errnum := usernamemissing;                            <<u.rao>>02055000
      end;                                                     <<u.rao>>02060000
   end;                                                        <<u.rao>>02065000
if errnum = 0 then   <<no errors yet - continue parse>>        <<u.rao>>02070000
   begin <<do user.acct part>>                                 <<u.rao>>02075000
   result(16) := result(16)+1;                                 <<u.rao>>02080000
   if tokenlen = 0 then                                        <<u.rao>>02085000
      errnum := usernamemissing                                <<u.rao>>02090000
   else if tokenptr="@" then                                   <<u.rao>>02095000
      if tokenlen=1 then  <<could be "@" or "@.acct">>         <<u.rao>>02100000
         if delim<>"." then  <<just plain "@">>                <<u.rao>>02105000
            result(13) := all  <<every job or session>>        <<u.rao>>02110000
         else   <<@.acct>>                                     <<u.rao>>02115000
            result(13) := allofacct  <<all of particular acct>><<u.rao>>02120000
      else if tokenlen=2 then  <<could be @s or @j>>           <<u.rao>>02125000
         if tokenptr(1) = "S" then                             <<u.rao>>02130000
            result(13) := allsessions                          <<u.rao>>02135000
         else if tokenptr(1) = "J" then                        <<u.rao>>02140000
            result(13) := alljobs                              <<u.rao>>02145000
         else   <<don't recognize first character>>            <<u.rao>>02150000
            begin                                              <<u.rao>>02155000
            @tokenptr := @tokenptr+1;                          <<u.rao>>02160000
            errnum := xpctjors                                 <<u.rao>>02165000
            end                                                <<u.rao>>02170000
      else                                                     <<u.rao>>02175000
         errnum := xpctjsorat                                  <<u.rao>>02180000
   else if tokenlen>8 then                                     <<u.rao>>02185000
      errnum := usernametoolong                                <<u.rao>>02190000
   else if tokenptr <> alpha then                              <<u.rao>>02195000
      errnum := userxpctalpha                                  <<u.rao>>02200000
   else if delim <> "." then                                   <<u.rao>>02205000
      begin                                                    <<u.rao>>02210000
      @tokenptr := @delim;                                     <<u.rao>>02215000
      errnum := xpctperioddelim                                <<u.rao>>02220000
      end                                                      <<u.rao>>02225000
   else                                                        <<u.rao>>02230000
      move bresult(2) := tokenptr while ans;                   <<u.rao>>02235000
   <<pretty much finished now.  just parse acct name, if any>> <<u.rao>>02240000
   if errnum = 0 and result(13) < allsessions then             <<u.rao>>02245000
      begin   <<expecting acct name>>                          <<u.rao>>02250000
      result(16) := result(16)+1;                              <<u.rao>>02255000
      if not getnext or tokenlen=0 then                        <<u.rao>>02260000
         errnum := acctnamemissing                             <<u.rao>>02265000
      else if tokenptr="@" then                                <<u.rao>>02270000
         errnum := acctxpctnamntat                             <<u.rao>>02275000
      else if tokenlen>8 then                                  <<u.rao>>02280000
         errnum := acctnametoolong                             <<u.rao>>02285000
      else if tokenptr<>alpha then                             <<u.rao>>02290000
         errnum := acctxpctalpha                               <<u.rao>>02295000
      else  <<acct name parsed - now finish up>>               <<u.rao>>02300000
         move bresult(10) := tokenptr while ans;               <<u.rao>>02305000
      end                                                      <<u.rao>>02310000
   end;                                                        <<u.rao>>02315000
if errnum <> 0 then                                            <<u.rao>>02320000
   begin                                                       <<u.rao>>02325000
   result(14) := @tokenptr;                                    <<u.rao>>02330000
   result(15) := errnum;                                       <<u.rao>>02335000
   end                                                         <<u.rao>>02340000
else                                                           <<u.rao>>02345000
   begin                                                       <<u.rao>>02350000
   parsejobid := true;                                         <<u.rao>>02355000
   result(15) := delim;                                        <<u.rao>>02360000
   result(14) := @idptr;                                       <<u.rao>>02365000
   end;                                                        <<u.rao>>02370000
end;   <<subroutine parsejsname>>                              <<u.rao>>02375000
<<             outer block of procedure               >>       <<u.rao>>02380000
<<first step is misc initialization>>                          <<u.rao>>02385000
@idptr := @tokenptr := @jobid;                                 <<u.rao>>02390000
result(16) := 1;                                               <<u.rao>>02395000
<<errnum initialized to 0 in declarations>>                    <<u.rao>>02400000
<<parsejobid assumed initialized to false>>                    <<u.rao>>02405000
<<  get first token to choose between job name or number>>     <<u.rao>>02410000
if not getnext then    <<jobid missing>>                       <<u.rao>>02415000
   begin                                                       <<u.rao>>02420000
   result(14) := @tokenptr;                                    <<u.rao>>02425000
   result(15) := jobidmissing;                                 <<u.rao>>02430000
   end                                                         <<u.rao>>02435000
else if tokenptr = "#" then                                    <<u.rao>>02440000
   begin  <<assume j/s number>>                                <<u.rao>>02445000
   @tokenptr := @tokenptr+1;  <<skip "#">>                     <<u.rao>>02450000
   tokenlen := tokenlen-1;                                     <<u.rao>>02455000
   parsejsnumber;                                              <<u.rao>>02460000
   end                                                         <<u.rao>>02465000
else if delim <> "." and delim <> "," and                      <<u.rao>>02470000
   (tokenptr="J" or tokenptr="S") then                         <<u.rao>>02475000
      parsejsnumber                                            <<u.rao>>02480000
else   <<assume actual [jsname,]user.acct>>                    <<u.rao>>02485000
   parsejsname;                                                <<u.rao>>02490000
end;   <<parsejobid>>                                          <<u.rao>>02495000
logical procedure scanjmat(nextindex, jobid, result);          <<u.rao>>02500000
integer nextindex;                                             <<u.rao>>02505000
integer array jobid;                                           <<u.rao>>02510000
integer array result;                                          <<u.rao>>02515000
option privileged, uncallable;                                 <<04.ro>>02520000
<<function:  finds next qualified entry in jmat based on     >><<u.rao>>02525000
<<           nextindex and the information in jobid.         >><<u.rao>>02530000
<<input:                                                     >><<u.rao>>02535000
<<       nextindex - jmat index of jmat entry at which scan  >><<u.rao>>02540000
<<          will be started.  this typically will be the     >><<u.rao>>02545000
<<          value returned from the last call to scanjmat.   >><<u.rao>>02550000
<<          note that the first legal index in the jmat is 1.>><<u.rao>>02555000
<<       jobid - a formatted array containing the qualifying >><<u.rao>>02560000
<<          information.                                     >><<u.rao>>02565000
<<             jobid(13) = 0 => job number                   >><<u.rao>>02570000
<<                         1 => job name, user.acct          >><<u.rao>>02575000
<<                         2 => user.acct                    >><<u.rao>>02580000
<<                         3 => @.acct                       >><<u.rao>>02585000
<<                         4 => @s                           >><<u.rao>>02590000
<<                         5 => @j                           >><<u.rao>>02595000
<<                         6 => @   (all jobs and sessions)  >><<u.rao>>02600000
<<             if jobid(12) = 0, the job number is formatted >><<u.rao>>02605000
<<                in jobid(0).                               >><<u.rao>>02610000
<<             if jobid(12) >= 4, the rest of jobid can be   >><<u.rao>>02615000
<<                ignored.                                   >><<u.rao>>02620000
<<             otherwise, jobid has the job, user and account>><<u.rao>>02625000
<<                names in the form required by the jmat,    >><<u.rao>>02630000
<<                starting at jobid(1).                      >><<u.rao>>02635000
<<output:                                                    >><<u.rao>>02640000
<<         scanjmat - true if scan found candidate,          >><<u.rao>>02645000
<<            false if end of jmat encountered first.        >><<u.rao>>02650000
<<                                                           >><<u.rao>>02655000
<<         nextindex -   jmat index of this candidate, plus 1>><<u.rao>>02660000
<<                                                           >><<u.rao>>02665000
<<         result(0) -   jmat entry element 0.               >><<u.rao>>02670000
<<         result(1) -   $stdlist ldev.                      >><<u.rao>>02675000
<<         result(2) -   funny terminal (apl) bits.          >><<u.rao>>02680000
<<                                                           >><<u.rao>>02685000
<<         jobid(0) -    job type and number for this candidate<<u.rao>>02690000
<<         jobid(1-4) -  user name.                          >><<u.rao>>02695000
<<         jobid(5-8) -  account name.                       >><<u.rao>>02700000
<<         jobid(9-12) - job name, if any, or blanks.        >><<u.rao>>02705000
<<                                                           >><<u.rao>>02710000
<<                                                           >><<u.rao>>02715000
begin                                                          <<u.rao>>02720000
<< ....................................................... >>  <<06596>>02725000
<<       declarations for referencing the jmat             >>  <<06596>>02730000
<<   jmatarr -- a local array which holds a jmat entry     >>  <<06596>>02735000
<<   jmatinx -- the index used in the include file defs.   >>  <<06596>>02740000
<<              to reference each entry.  this will be 0   >>  <<06596>>02745000
<<              in this case since jmatarr is local and    >>  <<06596>>02750000
<<              pointing directly to the entry.            >>  <<06596>>02755000
<< ....................................................... >>  <<06596>>02760000
integer array jmatarr(0:jmatentrysize-1);  << jmat entry >>    <<06596>>02765000
byte array bjmatarr(*) = jmatarr;                              <<06596>>02770000
integer    jmatinx;  << index into the jmatarr >>              <<06596>>02775000
byte array bjobid(*) = jobid;                                  <<u.rao>>02780000
integer comparelen;   <<length of byte compare when needed.>>  <<u.rao>>02785000
integer tcompareoffset;  <<byte offset from jmatentry(0)   >>  <<u.rao>>02790000
integer scompareoffset;  <<byte offset from jobid(0)       >>  <<u.rao>>02795000
integer oldsir;  <<holds return from getsir>>                  <<u.rao>>02800000
logical foundentry;   <<flag to show found candidate.      >>  <<u.rao>>02805000
integer jstype; << either job, session, or everything >>       <<06596>>02810000
integer lastjmatindex; << end of table >>                      <<06596>>02815000
equate tblquantum = 128; << quantum of sizes in jmat >>        <<06596>>02820000
equate allsessions = 4;                                        <<u.rao>>02825000
equate jobtypesession = 1,                                     <<06596>>02830000
       jobtypejob = 2;                                         <<06596>>02835000
                                                               <<06596>>02840000
<< ........................................................ >> <<06596>>02845000
logical subroutine getjmatentry;                               <<u.rao>>02850000
begin                                                          <<u.rao>>02855000
<<this subroutine whirls through the jmat looking for the>>    <<u.rao>>02860000
<<next non-garbage entry.  if one is found before the end>>    <<u.rao>>02865000
<<of the jmat the subroutine returns true and the entry>>      <<u.rao>>02870000
<<will reside in jmatarr.>>                                    <<06596>>02875000
if nextindex <= lastjmatindex then                             <<u.rao>>02880000
   begin                                                       <<00745>>02885000
   do   <<loop through jmat>>                                  <<u.rao>>02890000
      begin                                                    <<u.rao>>02895000
      tos := @jmatarr;                                         <<06596>>02900000
      tos := jmatdst;                                          <<u.rao>>02905000
      tos := nextindex*jmatentrysize;                          <<u.rao>>02910000
      tos := jmatentrysize;                                    <<u.rao>>02915000
      assemble(mfds);                                          <<u.rao>>02920000
      nextindex := nextindex+1;                                <<u.rao>>02925000
      end                                                      <<u.rao>>02930000
   until (jmatjobstate <> 0) or (nextindex > lastjmatindex);   <<06596>>02935000
   if jmatjobstate <> 0 then getjmatentry := true;             <<06596>>02940000
   end;                                                        <<00745>>02945000
end;   <<subroutine getjmatentry>>                             <<u.rao>>02950000
                                                               <<06596>>02955000
<< ........................................................ >> <<06596>>02960000
                                                               <<06596>>02965000
<<  **** initialization and main portion of scanjmat ****  >>  <<06596>>02970000
                                                               <<06596>>02975000
jmatinx := 0; << jmatarr is local  >>                          <<06596>>02980000
oldsir := getsir(jmatsir);                                     <<u.rao>>02985000
tos := @jmatarr;                                               <<06596>>02990000
tos := jmatdst;                                                <<u.rao>>02995000
tos := 0;                                                      <<u.rao>>03000000
tos := jmatentrysize;                                          <<06596>>03005000
assemble(mfds);  <<get jmat global data>>                      <<u.rao>>03010000
<< the last index is the current size (which is stored in the ><<06596>>03015000
<< jmat header after being multiplied by tblquantum) divided  ><<06596>>03020000
<< by the size of an entry -- minus one:                      ><<06596>>03025000
lastjmatindex := (jmatcursize*tblquantum) / jmatentrysize  - 1;<<06596>>03030000
if jobid(13) < allsessions then   <<compare is necessary>>     <<u.rao>>03035000
   begin                                                       <<u.rao>>03040000
   <<set parameters for compare>>                              <<u.rao>>03045000
   case jobid(13) of                                           <<u.rao>>03050000
      begin                                                    <<u.rao>>03055000
                                                               <<u.rao>>03060000
         begin   <<job/session number>>                        <<u.rao>>03065000
         comparelen := 2;                                      <<u.rao>>03070000
         tcompareoffset := jmatjsnooff*2;<< off. to j/s no. >> <<06596>>03075000
         scompareoffset := 0;  <<bytes from start of jobid>>   <<u.rao>>03080000
         end;                                                  <<u.rao>>03085000
                                                               <<u.rao>>03090000
         begin   <<fully qualified job id>>                    <<u.rao>>03095000
         comparelen := (jmatnamelen*3)*2;  << bytes >>         <<06596>>03100000
         tcompareoffset := jmatusernameoff*2;                  <<06596>>03105000
         scompareoffset := 2;                                  <<u.rao>>03110000
         end;                                                  <<u.rao>>03115000
                                                               <<u.rao>>03120000
         begin   <<user.acct>>                                 <<u.rao>>03125000
         comparelen := (jmatnamelen*2)*2;                      <<06596>>03130000
         tcompareoffset := jmatusernameoff*2;                  <<06596>>03135000
         scompareoffset := 2;                                  <<u.rao>>03140000
         end;                                                  <<u.rao>>03145000
                                                               <<u.rao>>03150000
         begin   <<@.acct>>                                    <<u.rao>>03155000
         comparelen := jmatnamelen*2;                          <<06596>>03160000
         tcompareoffset := jmatacctnameoff*2;                  <<06596>>03165000
         scompareoffset := 10;                                 <<u.rao>>03170000
         end;                                                  <<u.rao>>03175000
      end;   <<case statement>>                                <<u.rao>>03180000
                                                               <<06596>>03185000
<< at this point we are ready to start scanning through the >> <<06596>>03190000
<< jmat entries until a qualifying one is found.            >> <<06596>>03195000
<< scompareoffset and tcompareoffset, as set above,         >> <<06596>>03200000
<< determine the qualifications necessary in the test below.>> <<06596>>03205000
                                                               <<06596>>03210000
   do                                                          <<u.rao>>03215000
      foundentry := getjmatentry                               <<u.rao>>03220000
      until not foundentry <<no more in jmat>>   or            <<u.rao>>03225000
         (bjobid(scompareoffset) = bjmatarr(tcompareoffset),   <<06596>>03230000
            (comparelen));  <<have match>>                     <<u.rao>>03235000
   end                                                         <<u.rao>>03240000
else   <<@, @s, @j - find next qualifying job type>>           <<u.rao>>03245000
   begin                                                       <<u.rao>>03250000
   case jobid(13) - allsessions of                             <<u.rao>>03255000
      begin                                                    <<u.rao>>03260000
      jstype := jobtypesession;   <<all sessions>>             <<06596>>03265000
      jstype := jobtypejob;       <<all jobs>>                 <<06596>>03270000
      jstype := -1;   <<everything>>                           <<06596>>03275000
      end;   <<mask is now set up>>                            <<u.rao>>03280000
   do                                                          <<u.rao>>03285000
      foundentry := getjmatentry   <<scan for entry>>          <<u.rao>>03290000
      until not foundentry  <<jmat exhausted>>                 <<u.rao>>03295000
        or ((jmatjstype = jstype)  or  (jstype = -1));         <<06596>>03300000
   end;                                                        <<u.rao>>03305000
<<now return scan results>>                                    <<u.rao>>03310000
if foundentry then   <<have a winner>>                         <<u.rao>>03315000
   begin                                                       <<u.rao>>03320000
   result := jmatarr;                                          <<06596>>03325000
   result(1) := jmatjlistdev;                                  <<06596>>03330000
   result(2) := jmatftbits;                                    <<06596>>03335000
   jobid(0)   := jmatarr(jmatjsnooff); << js number and type>> <<06596>>03340000
   move jobid(1) := jmatarr(jmatusernameoff),                  <<06596>>03345000
                 (jmatnamelen * 3); << move all three names >> <<06596>>03350000
   scanjmat := true;                                           <<u.rao>>03355000
   end;                                                        <<u.rao>>03360000
relsir(jmatsir, oldsir);                                       <<u.rao>>03365000
end;   <<procedure scanjmat>>                                  <<u.rao>>03370000
                                                                        03375000
                                                                        03380000
procedure crunch(n1,n2,n3,dest,nwords);                                 03385000
    integer nwords;                                                     03390000
    integer array dest;                                                 03395000
    byte array n1,n2,n3;                                                03400000
   option privileged, uncallable;                                       03405000
         <<procedure to put entry names into standard form.           >>03410000
         <<high order bit of first byte of each name part is turned on>>03415000
         <<each name part must be terminated by a non-alphanumeric.   >>03420000
         <<n1,n2,n3 - name parts to be concatenated to form entry name>>03425000
         <<dest - array where entry name is to be stored.             >>03430000
         <<nwords:= size of entry name in words (output)              >>03435000
         <<note: db must be pointing to the stack                     >>03440000
         <<      array "DEST" must be at least 25 bytes long          >>03445000
   begin                                                                03450000
    integer array                                                       03455000
         isrc(0:14)=q                                                   03460000
        ,idest(0:12) = q                                                03465000
   ;byte array                                                          03470000
         bsrc(*) = isrc                                                 03475000
        ,bdest(*) = idest                                               03480000
   ;byte pointer                                                        03485000
         bp                                                             03490000
   ;integer i   <<used as a loop variable>>                    <<u.rao>>03495000
   ;                                                                    03500000
   i := -1;                                                             03505000
   while (i:=i+1)<8 do                                                  03510000
      begin   <<combine sources into local array>>                      03515000
      bsrc(i) := n1(i);                                                 03520000
      bsrc(i+10) := n2(i);                                              03525000
      bsrc(i+20) := n3(i);                                              03530000
      end;                                                              03535000
   tos := @bdest;                                                       03540000
   assemble(dup);                                                       03545000
   i := -10;                                                            03550000
   while (i:=i+10)<21 do                                                03555000
      begin                                                             03560000
      bsrc(i+8) := " ";   <<to insure termination>>                     03565000
      assemble(dup);                                                    03570000
      @bp := tos;                                                       03575000
      move * := bsrc(i) while an,1;                                     03580000
      bp := logical(bp) lor %200;   <<turn on high bit of first byte>>  03585000
      end;                                                              03590000
   bps0 := " ";   <<in case string ends not on word boundary>>          03595000
   assemble(xch; lsub; inca; lsr 1);                                    03600000
   nwords := tos;                                                       03605000
   tos := @dest;   <<target>>                                           03610000
   tos := @idest;   <<source>>                                          03615000
   tos := nwords;   <<word count>>                                      03620000
   assemble(move 3);   <<move to caller array>>                         03625000
   end;   <<crunch>>                                                    03630000
$page                                                          << 8498>>03635000
<<***********************************************************>><< 8498>>03640000
<<                                                           >><< 8498>>03645000
<< procedure uncrunch                                        >><< 8498>>03650000
<<                                                           >><< 8498>>03655000
<< purpose:  to take as input, a byte array in the form of a >><< 8498>>03660000
<<           byte array output from crunch, and uncrunch it  >><< 8498>>03665000
<<           into the file, group, and account names.        >><< 8498>>03670000
<<                                                           >><< 8498>>03675000
<<***********************************************************>><< 8498>>03680000
                                                               << 8498>>03685000
procedure uncrunch( fname, fname'size, file, group, acct );    << 8498>>03690000
  value fname'size;                                            << 8498>>03695000
  integer fname'size;                                          << 8498>>03700000
  byte array fname, file, group, acct;                         << 8498>>03705000
  option privileged, uncallable;                               << 8498>>03710000
                                                               << 8498>>03715000
begin                                                          << 8498>>03720000
integer i := 0,                                                << 8498>>03725000
        j := -1,                                               << 8498>>03730000
        m := 0;                                                << 8498>>03735000
                                                               << 8498>>03740000
while ( i < fname'size ) do                                    << 8498>>03745000
  begin                                                        << 8498>>03750000
  if fname( i ) >= %200                                        << 8498>>03755000
    then begin                                                 << 8498>>03760000
         fname( i ) := fname( i ) - %200;                      << 8498>>03765000
         j := j + 1;                                           << 8498>>03770000
         m := 0;                                               << 8498>>03775000
         end;                                                  << 8498>>03780000
                                                               << 8498>>03785000
  case j of                                                    << 8498>>03790000
       begin                                                   << 8498>>03795000
                                                               << 8498>>03800000
       << 0 >> << file name  >>                                << 8498>>03805000
       file( m ) := fname( i );                                << 8498>>03810000
                                                               << 8498>>03815000
       << 1 >> << group name >>                                << 8498>>03820000
       group( m ) := fname( i );                               << 8498>>03825000
                                                               << 8498>>03830000
       << 2 >> << acct name  >>                                << 8498>>03835000
       acct( m ) := fname( i );                                << 8498>>03840000
                                                               << 8498>>03845000
       end; << case >>                                         << 8498>>03850000
                                                               << 8498>>03855000
  m := m + 1;                                                  << 8498>>03860000
  i := i + 1;                                                  << 8498>>03865000
                                                               << 8498>>03870000
  end;  << while >>                                            << 8498>>03875000
                                                               << 8498>>03880000
end;  << procedure uncrunch >>                                 << 8498>>03885000
$page                                                          << 8498>>03890000
<<***********************************************************>><< 8498>>03895000
<<                                                           >><< 8498>>03900000
<< procedure get'ordered'index                               >><< 8498>>03905000
<<                                                           >><< 8498>>03910000
<< purpose:  to return a jdt relative index to where a new   >><< 8498>>03915000
<<           entry should be placed in a candidate table.    >><< 8498>>03920000
<<           the new entries will be placed in order in the  >><< 8498>>03925000
<<           table by the caller at the index.               >><< 8498>>03930000
<<           order will be defined to be alphabetic first by >><< 8498>>03935000
<<           account, then group and then the file name      >><< 8498>>03940000
<<                                                           >><< 8498>>03945000
<<***********************************************************>><< 8498>>03950000
                                                               << 8498>>03955000
integer procedure get'ordered'index( file, group, acct,        << 8498>>03960000
                                            table, pxgjdt );   << 8498>>03965000
    value table, pxgjdt;                                       << 8498>>03970000
    integer table, pxgjdt;                                     << 8498>>03975000
    byte array file, group, acct;                              << 8498>>03980000
    option privileged, uncallable;                             << 8498>>03985000
                                                               << 8498>>03990000
begin                                                          << 8498>>03995000
<< this procedure is called in split-stack mode.  db is      >><< 8498>>04000000
<< pointing at the jdt in question.  the algorithm is as     >><< 8498>>04005000
<< follows:  1.  get the head pointer to table table         >><< 8498>>04010000
<<           2.  get an entry                                >><< 8498>>04015000
<<           3.  uncrunch the formal file name in the entry  >><< 8498>>04020000
<<           4.  if file, group, and acct are less than this >><< 8498>>04025000
<<               uncrunched formal file name, go to 2.       >><< 8498>>04030000
<<           5.  if file, group, and acct are greater than   >><< 8498>>04035000
<<               this entry, return this entry's jdt         >><< 8498>>04040000
<<               index.                                      >><< 8498>>04045000
<< assumes that the candidate entry does not exist in table! >><< 8498>>04050000
                                                               << 8498>>04055000
logical array qarray( 0:36 )  = q;                             << 8498>>04060000
byte    array qarray'b(*)     = qarray;                        << 8498>>04065000
                                                               << 8498>>04070000
logical array designator'l(*) = qarray( 0 ); << 13 words >>    << 8498>>04075000
byte    array designator(*)   = designator'l;                  << 8498>>04080000
                                                               << 8498>>04085000
byte    array u'file(*)       = qarray( 13 );   << 4 words >>  << 8498>>04090000
byte    array u'group(*)      = qarray( 17 );   << 4 words >>  << 8498>>04095000
byte    array u'acct(*)       = qarray( 21 );   << 4 words >>  << 8498>>04100000
                                                               << 8498>>04105000
byte    array f'file(*)       = qarray( 25 );   << 4 words >>  << 8498>>04110000
byte    array f'group(*)      = qarray( 29 );   << 4 words >>  << 8498>>04115000
byte    array f'acct(*)       = qarray( 33 );   << 4 words >>  << 8498>>04120000
                                                               << 8498>>04125000
logical first'time := true;                                    << 8498>>04130000
                                                               << 8498>>04135000
                                                               << 8498>>04140000
integer pointer table'head,                                    << 8498>>04145000
                table'tail,                                    << 8498>>04150000
                entry'i,                                       << 8498>>04155000
                save'entry;                                    << 8498>>04160000
                                                               << 8498>>04165000
integer entry'size,                                            << 8498>>04170000
        i,                                                     << 8498>>04175000
        designator'size,                                       << 8498>>04180000
        r'value;                                               << 8498>>04185000
                                                                        04190000
                                                               << 8498>>04195000
<<***********************************************************>><< 8498>>04200000
<<                                                           >><< 8498>>04205000
<< subroutine determine                                      >><< 8498>>04210000
<<                                                           >><< 8498>>04215000
<< purpose: to determine if the formal designator is the     >><< 8498>>04220000
<<          is at an entry index where that index will used  >><< 8498>>04225000
<<          as the index for a new entry.                    >><< 8498>>04230000
<<                                                           >><< 8498>>04235000
<<***********************************************************>><< 8498>>04240000
<< acct, group, file are the input arrays to get'odered'index>><< 8498>>04245000
<< u'acct, u'group, u'file are created by uncrunch           >><< 8498>>04250000
                                                               << 8498>>04255000
subroutine determine( r'val );                                 << 8498>>04260000
   integer r'val;                                              << 8498>>04265000
                                                               << 8498>>04270000
begin                                                          << 8498>>04275000
r'val := 0;                                                    << 8498>>04280000
if f'acct < u'acct,( 8 )                                       << 8498>>04285000
   then                                                        << 8498>>04290000
   r'val := @save'entry                                        << 8498>>04295000
   else                                                        << 8498>>04300000
    if f'acct = u'acct,( 8 )                                   << 8498>>04305000
       then                                                    << 8498>>04310000
        if f'group < u'group ,( 8 )                            << 8498>>04315000
           then                                                << 8498>>04320000
            r'val := @save'entry                               << 8498>>04325000
           else                                                << 8498>>04330000
            if f'group = u'group, ( 8 )                        << 8498>>04335000
               then                                            << 8498>>04340000
                if f'file < u'file, ( 8 )                      << 8498>>04345000
                   then                                        << 8498>>04350000
                    r'val := @save'entry                       << 8498>>04355000
                   else << 1.  f'file <> u'file (assumption) >><< 8498>>04360000
                        << 2.  f'file > u'file drop out and  >><< 8498>>04365000
                        <<     to get a new entry          >>  << 8498>>04370000
                                                               << 8498>>04375000
               else << 1.  f'group > u'group - drop out and >> << 8498>>04380000
                    <<     to get a new entry             >>   << 8498>>04385000
                                                               << 8498>>04390000
       else;  << 1.  f'acct > u'acct - drop out >>             << 8498>>04395000
              <<     to get a new entry       >>               << 8498>>04400000
                                                               << 8498>>04405000
end;  << subroutine determine >>                               << 8498>>04410000
@table'head := jdtarr( table );    << addr start of table    >><< 8498>>04415000
@table'tail := jdtarr( table + 1 ); << addr start of table+1 >><< 8498>>04420000
                                                               << 8498>>04425000
r'value := 0;                                                  << 8498>>04430000
                                                               << 8498>>04435000
if @table'head = @table'tail                                   << 8498>>04440000
   then r'value := @table'tail                                 << 8498>>04445000
   else begin                                                  << 8498>>04450000
        << whirl through candidate table looking for  >>       << 8498>>04455000
        << mr. goodentry                              >>       << 8498>>04460000
        @entry'i := @table'head;                               << 8498>>04465000
        while (( @entry'i < @table'tail )                      << 8498>>04470000
                        land                                   << 8498>>04475000
               (     r'value = 0      )) do                    << 8498>>04480000
          begin                                                << 8498>>04485000
          @save'entry := @entry'i;                             << 8498>>04490000
                                                               << 8498>>04495000
          << get entry size in words >>                        << 8498>>04500000
          entry'size := entry'i.(0:8);                         << 8498>>04505000
                                                               << 8498>>04510000
          << get formal file name size words >>                << 8498>>04515000
          designator'size := entry'i.(8:8);                    << 8498>>04520000
                                                               << 8498>>04525000
          << set entry to formal designator and set up the >>  << 8498>>04530000
          << byte array designator                         >>  << 8498>>04535000
                                                               << 8498>>04540000
          @entry'i := @entry'i + 1;                            << 8498>>04545000
          exchangedb( 0 );                                     << 8498>>04550000
          << need to exchange to db to play with q relative >> << 8498>>04555000
          << arrays.                                        >> << 8498>>04560000
          move designator(0) := "                          ";  << 8498>>04565000
                                                               << 8498>>04570000
          << load up the designator'l with designator name  >> << 8498>>04575000
                                                               << 8498>>04580000
          tos := @designator'l;                                << 8498>>04585000
          tos := pxgjdt;                                       << 8498>>04590000
          tos := @entry'i;                                     << 8498>>04595000
          tos := designator'size;                              << 8498>>04600000
          assemble( mfds  4 );                                 << 8498>>04605000
          << set up and call uncrunch >>                       << 8498>>04610000
          move u'file  := "        ";                          << 8498>>04615000
          move u'group := "        ";                          << 8498>>04620000
          move u'acct  := "        ";                          << 8498>>04625000
                                                               << 8498>>04630000
          designator'size := designator'size * 2; << bytes >>  << 8498>>04635000
                                                               << 8498>>04640000
          uncrunch( designator, designator'size, u'file,       << 8498>>04645000
                    u'group   , u'acct );                      << 8498>>04650000
                                                               << 8498>>04655000
          if first'time = true                                 << 8498>>04660000
             then begin                                        << 8498>>04665000
                                                               << 8498>>04670000
                  i := 0;                                      << 8498>>04675000
                  while i < 8 do                               << 8498>>04680000
                     begin                                     << 8498>>04685000
                     f'file( i )  := file( i );                << 8498>>04690000
                     f'group( i ) := group( i );               << 8498>>04695000
                     f'acct( i )  := acct( i );                << 8498>>04700000
                     i := i + 1;                               << 8498>>04705000
                     end;  << while >>                         << 8498>>04710000
                  first'time := false;                         << 8498>>04715000
                  end; << begin >>                             << 8498>>04720000
                                                               << 8498>>04725000
                                                               << 8498>>04730000
          << now we check to see if this entry is the entry >> << 8498>>04735000
          << that we want.                                  >> << 8498>>04740000
                                                               << 8498>>04745000
          determine( r'value );                                << 8498>>04750000
                                                               << 8498>>04755000
          exchangedb( pxgjdt );                                << 8498>>04760000
                                                               << 8498>>04765000
          @entry'i := @save'entry + entry'size;                << 8498>>04770000
          end; << while >>                                     << 8498>>04775000
                                                               << 8498>>04780000
          if r'value = 0                                       << 8498>>04785000
             then r'value := @table'tail;                      << 8498>>04790000
                                                               << 8498>>04795000
        end; << else begin >>                                  << 8498>>04800000
                                                               << 8498>>04805000
get'ordered'index := r'value;                                  << 8498>>04810000
                                                               << 8498>>04815000
end;    << procedure get'ordered'index >>                      << 8498>>04820000
                                                                        04825000
integer procedure findjtentry(n1,n2,n3,tno,a,pxgjdt);                   04830000
    value tno;                                                          04835000
    integer tno,pxgjdt;                                                 04840000
    byte array n1,n2,n3;                                                04845000
    logical a;                                                          04850000
    option uncallable,privileged;                                       04855000
         <<procedure to find an entry in the job table                >>04860000
         <<n1,n2,n3 = names to be concatenated and searched (input)   >>04865000
         <<tno = table # (1,2 or 3) (input)                           >>04870000
         <<tno = 0- exchangedb,getsir,pass back pxgjsir,a,pxgjdt      >>04875000
         <<         but do no more                                    >>04880000
         <<a := lockjir return value                                   >04885000
         <<pxgjdt:= job table dst# (output)                           >>04890000
         <<findjtentry:= seg.rel.adr.of entry (:=0 if not found)      >>04895000
         <<upon entry, db must be pointing at the stack               >>04900000
         <<upon exit, db will be pointing at the job table            >>04905000
        << tno = 1 - data segment table                      >><< 8498>>04910000
        << tno = 2 - temporary file table                    >><< 8498>>04915000
        << tno = 3 file equation table                       >><< 8498>>04920000
   begin                                                                04925000
    array qarray(*) = q + 0;                                   <<06595>>04930000
    integer pcbglobloc;                                        <<06595>>04935000
    integer                                                             04940000
         i                                                              04945000
        ,namsize   <<#words in concatenated entry name>>                04950000
        ,idno = q-10   <<index of entry word 0 (seg.rel.adr.)>>         04955000
   ;integer array                                                       04960000
         crunched(0:12) = q   <<q-rel.array for name>>                  04965000
   ;integer pointer                                                     04970000
         pxpntr                                                         04975000
   ;                                                                    04980000
<< get the jdt dst number from the pxglobal area >>            <<06288>>04985000
                                                               <<06288>>04990000
   pxglobal;                                                   <<06595>>04995000
   pxgjdt := pxg'jdtdst;                                       <<06595>>05000000
   if tno>0 then                                                        05005000
      << crunch file, group, and acct to formal desg format >> << 8498>>05010000
      crunch(n1,n2,n3,crunched,namsize);                                05015000
   a := lockjir;                                                        05020000
<< exchange db to the jdt dst  >>                              <<06288>>05025000
   exchangedb(pxgjdt);                                                  05030000
   if tno = 0 then return;   <<dummy call>>                             05035000
   jdtworkspc := namsize;   <<work area>>                      <<u.rao>>05040000
   i := -1;                                                             05045000
   while (i:=i+1) < namsize do                                          05050000
      begin   <<move crunched name into work area>>                     05055000
      jdtworkspc(i+1) := crunched(i);                          <<u.rao>>05060000
      end;                                                              05065000
   i := jdtarr(tno);   <<starting index of proper table>>      <<u.rao>>05070000
   while i < jdtarr(tno+1) do                                  <<u.rao>>05075000
      begin   <<search until found or index=start of next table>>       05080000
      tos := (@jdtarr(i)&lsl(1))+1;   <<current entry>>        <<u.rao>>05085000
      tos := @jdtworkspc&lsl(1)+1;  <<goal name>>              <<u.rao>>05090000
      tos := (namsize&lsl(1))+1;   <<#char>>                            05095000
      assemble(cmpb 3);                                                 05100000
      if = then                                                         05105000
         begin                                                          05110000
         idno := i;   <<index of entry>>                                05115000
         return;                                                        05120000
         end;                                                           05125000
      i := i + jdtarr(i).(0:8);   <<inc.to next entry>>        <<u.rao>>05130000
      end;                                                              05135000
   idno := 0;                                                           05140000
   end;   <<findjtentry>>                                               05145000
                                                                        05150000
                                                                        05155000
integer procedure xretjtentry(n1,n2,n3,size,info);                      05160000
    integer size;                                                       05165000
    integer array info;                                                 05170000
    byte array n1,n2,n3;                                                05175000
   option privileged, uncallable;                                       05180000
         <<trace pointers originating from given entry and return     >>05185000
         <<info found in final entry. search is done in table #3      >>05190000
         <<input:.....................................................>>05195000
         <<n1,n2,n3 - name of entry whose pointers are to be traced   >>05200000
         <<output:....................................................>>05205000
         <<size     - #words of info returned to caller               >>05210000
         <<info     - information found in final entry                >>05215000
         <<xretjtentry                                                >>05220000
         <<      =0 - ok                                              >>05225000
         <<      =1 - entry given cannot be found                     >>05230000
         <<      =2 - entry pointing to non-existent entry            >>05235000
   begin                                                                05240000
    logical                                                             05245000
         a   <<redundant lockjir return value>>                         05250000
        ,b   <<lockjir return value>>                                   05255000
   ;integer array                                                       05260000
        in1(0:17) = q   <<local array for unpacking names>>    <<u.rao>>05265000
   ;byte array                                                          05270000
         bn1(*) = in1                                                   05275000
        ;integer                                                        05280000
         i,j,k                                                          05285000
        ,pxgjdt   <<job table dst#>>                                    05290000
        ,savedl                                                         05295000
        ,adrin1   <<db-rel.adr.of in1(*)>>                              05300000
        ,bn2,bn3                                                        05305000
   ;                                                                    05310000
   push(dl);                                                            05315000
   savedl := tos;                                                       05320000
   adrin1 := @in1;                                                      05325000
<< return an index into the jdt for the given table >>         <<06288>>05330000
   i := findjtentry(n1,n2,n3,3,b,pxgjdt);                               05335000
<< ******* caution: db  is at the jdt dst now  >>              <<06288>>05340000
   if i=0 then                                                          05345000
      begin   <<entry cannot be found>>                                 05350000
      xretjtentry := 1;                                                 05355000
exit: exchangedb(0);                                                    05360000
      unlockjir(b);                                                     05365000
      return;                                                           05370000
      end;                                                              05375000
next:                                                                   05380000
<< the info string begins at the word following the formal>>   <<06288>>05385000
<< name designator at the beginning of each entry in a    >>   <<06288>>05390000
<< table.                                                 >>   <<06288>>05395000
<<     k is at the 2nd word of the pmask                  >>   <<06288>>05400000
                                                               <<06288>>05405000
   k := i + jdtarr(i).(8:8) + 2;   <<index of 2nd word of info><<u.rao>>05410000
<< check the pmask (word 2) for pointers to the file equ. >>   <<06288>>05415000
   if jdtarr(k).(6:1) = 0 then go endofline;   <<no more pointe<<u.rao>>05420000
   j := jdtarr(k+1).(0:8);   <<size of name in info (bytes)>>  <<u.rao>>05425000
   tos := adrin1 - savedl;   <<dl-rel.target>>                          05430000
<< address of beginning of name-actual designator is put  >>   <<06288>>05435000
<< on tos.                                                >>   <<06288>>05440000
                                                               <<06288>>05445000
   tos := k+2;   <<db-rel.source>>                                      05450000
   tos := (j+1)&lsr(1);   <<word count>>                                05455000
   assemble(mvbl 3);   <<move info name into local array>>              05460000
   exchangedb(0);                                                       05465000
   packandpoint(bn1,j,bn2,bn3);                                         05470000
   bn1 (j) := " ";                                                      05475000
   i := findjtentry(bn1,bn2,bn3,3,a,pxgjdt);                            05480000
<< db is at jdt dst here  >>                                   <<06288>>05485000
   if i=0 then                                                          05490000
      begin   <<pointing to non-existent entry>>                        05495000
      xretjtentry := 2;                                                 05500000
      go exit;                                                          05505000
      end;                                                              05510000
   exchangedb(pxgjdt);                                                  05515000
   go next;                                                             05520000
endofline:                                                              05525000
   j := jdtarr(i).(0:8);   <<entry size>>                      <<u.rao>>05530000
   tos := @info-savedl;   <<dl-rel.target>>                             05535000
   tos := i;   <<db-rel.source>>                                        05540000
   tos := j;   <<word count>>                                           05545000
   assemble(mvbl 3);                                                    05550000
   exchangedb(0);                                                       05555000
   size := j;                                                           05560000
   go exit;                                                             05565000
end;   <<procedure xretjtentry>>                                        05570000
                                                                        05575000
                                                                        05580000
integer procedure retjtentry(n1,n2,n3,size,info);                       05585000
    integer size;                                                       05590000
    integer array info;                                                 05595000
    byte array n1,n2,n3;                                                05600000
option privileged, uncallable;                                          05605000
         <<return job table entry information                         >>05610000
         <<n1,n2,n3 = names to be concatenated and searched (input)   >>05615000
         <<size = 1,2 or 3 indicating which table to search (input)   >>05620000
         <<size:= #words of information put in "INFO" (output)        >>05625000
         <<info:= information portion of table entry (output)         >>05630000
         <<retjtentry:= 0 if ok, 1 if entry cannot be found (output)  >>05635000
   begin                                                                05640000
    integer                                                             05645000
         pxgjdt   <<job table dst#>>                                    05650000
        ,i,j,k                                                          05655000
        ,qsize   <<size of info (words)>>                               05660000
        ,savedl                                                         05665000
   ;logical                                                             05670000
         a   <<lockjir return value>>                                   05675000
   ;                                                                    05680000
   push(dl);                                                            05685000
   savedl := tos;                                                       05690000
   i := findjtentry(n1,n2,n3,size,a,pxgjdt);                            05695000
<< db is at jdt dst here  >>                                   <<06288>>05700000
   if i = 0 then                                                        05705000
      begin   <<entry cannot be found>>                                 05710000
      retjtentry := 1;                                                  05715000
      exchangedb(0);                                                    05720000
      unlockjir(a);                                            <<u.rao>>05725000
      return;                                                           05730000
      help;                                                             05735000
      end;                                                              05740000
<< the info string begins at the word following the formal >>  <<06288>>05745000
<< name designator at the beginning of each entry in table >>  <<06288>>05750000
                                                               <<06288>>05755000
   k := jdtarr(i);   <<entry size / name size>>                <<u.rao>>05760000
   j := k.(8:8) + i + 1;   <<info starting index>>                      05765000
   qsize := k.(0:8) + i - j;   <<#words of info>>                       05770000
   tos := @info - savedl;   <<dl-rel.>>                                 05775000
<< start at info string; put address on tos.               >>  <<06288>>05780000
   tos := @jdtarr(j);   <<db-rel.>>                            <<u.rao>>05785000
   tos := qsize;   <<word count>>                                       05790000
   assemble(mvbl 3);                                                    05795000
   exchangedb(0);                                                       05800000
   size := qsize;                                                       05805000
   unlockjir(a);                                               <<u.rao>>05810000
   end;   <<retjtentry>>                                                05815000
                                                                        05820000
                                                                        05825000
integer procedure remjtentry(n1,n2,n3,tno,adr);                         05830000
    value tno,adr;                                                      05835000
    integer tno,adr;                                                    05840000
    byte array n1,n2,n3;                                                05845000
   option privileged, uncallable;                                       05850000
         <<procedure to remove an entry from the job table            >>05855000
         <<n1,n2,n3 - name parts of entry to be removed (input)       >>05860000
         <<tno - table # (1,2 or 3) from which to remove entry (input)>>05865000
         <<adr = 0 - use n1,n2,n3 to find entry                       >>05870000
         <<adr > 0 - entry to be removed starts at this address       >>05875000
         <<remjtentry.(8:8) = 0 - ok, entry deleted          >><<04573>>05880000
         <<                 = 1 - no such entry              >><<04573>>05885000
         <<remjtentry.(0:8) = old file reference count. this >><<04573>>05890000
         <<                   is returned to preserve this   >><<04573>>05895000
         <<                   value when adding new file     >><<04573>>05900000
         <<                   equations of the same name that>><<04573>>05905000
         <<                   is being deleted.              >><<04573>>05910000
         <<note: db must be pointing to the stack                     >>05915000
        << tno = 1 - data segment table                      >><< 8498>>05920000
        << tno = 2 - temporary file table                    >><< 8498>>05925000
        << tno = 3 file equation table                       >><< 8498>>05930000
option privileged, uncallable;                                          05935000
   begin                                                                05940000
    integer                                                             05945000
        i,j                                                             05950000
        ,pxgjdt   <<job table dst#>>                                    05955000
        ,segsize   <<current actual size of job table segment>>         05960000
         ,actlnameword  <<index to actual name/dev len.>>      <<04573>>05965000
         ,refcount := 0 <<reference count value        >>      <<04573>>05970000
         ,z             <<word length of name/dev      >>      <<04573>>05975000
         ,refcntindex   <<index to ref. count word     >>      <<04573>>05980000
         ;                                                     <<04573>>05985000
   logical                                                     <<04573>>05990000
         a   <<lockjir return value>>                                   05995000
   ;                                                                    06000000
   if adr = 0 then                                                      06005000
      i := findjtentry(n1,n2,n3,tno,a,pxgjdt)                           06010000
   else                                                                 06015000
      begin                                                             06020000
      i := adr;                                                         06025000
       <<dummy call-exch.db,lockjir,pass back a,pxgjdt>>                06030000
      findjtentry(j,j,j,0,a,pxgjdt);                                    06035000
      end;                                                              06040000
   if i=0 then                                                          06045000
      begin   <<entry cannot be found>>                                 06050000
      remjtentry := 1;                                                  06055000
exit: remjtentry.(0:8) := refcount;                            <<04573>>06060000
      exchangedb(0);                                           <<04573>>06065000
      unlockjir(a);                                                     06070000
      return;                                                           06075000
      end;                                                              06080000
    <<compress data to eliminate entry>>                                06085000
<< find out if the reference count is greater than zero. >>    <<04573>>06090000
<< this value will be returned as the upper 8 bits of the>>    <<04573>>06095000
<< remjtentry integer value returned.                    >>    <<04573>>06100000
<<                                                       >>    <<04573>>06105000
if tno = 3 then                                                <<04906>>06110000
begin                                                          <<04906>>06115000
actlnameword := i + jdtarr(i).(8:8) + 3;                       <<04573>>06120000
z := (jdtarr(actlnameword).(0:8) + 1)&lsr(1)                   <<04573>>06125000
   + (jdtarr(actlnameword).(8:8) + 1)&lsr(1);                  <<04573>>06130000
   refcntindex := (actlnameword + z + 10 );<<refcnt. word>>    <<04573>>06135000
   refcount := (jdtarr(refcntindex)).(0:6);                    <<04573>>06140000
end;                                                           <<04906>>06145000
<< remove the entry by writing from the end of the entry   >>  <<06288>>06150000
<< (next entry) to the beginning of the freespace over the >>  <<06288>>06155000
<< entry being removed ie. move the table up in the jdt.   >>  <<06288>>06160000
                                                               <<06288>>06165000
   tos := i;   <<target>>                                               06170000
<< put  address of entrysize + index into jdt on tos.      >>  <<06288>>06175000
   tos := jdtarr(i).(0:8)+i;   <<source>>                      <<u.rao>>06180000
   assemble(dup);                                                       06185000
   j := tos;                                                            06190000
   tos _ jfreespcadr-j;   <<word count (positive)>>            <<u.rao>>06195000
   i := jdtarr(i).(0:8);                                       <<u.rao>>06200000
   assemble(move 3);                                                    06205000
   j := tno;                                                            06210000
<< update the starting addresses of subsequent tables by   >>  <<06288>>06215000
<< subtracting out the size of entry being removed  (i).   >>  <<06288>>06220000
   while (j:=j+1) <= numjdtptrs do                             <<u.rao>>06225000
      begin   <<reduce starting addresses of subsequent tables>>        06230000
      jdtarr(j) := jdtarr(j)-i;                                <<u.rao>>06235000
      end;                                                              06240000
   segsize := (sys'dst(pxgjdt&lsl(2)).(3:13))&lsl(2)-1;                 06245000
   j _ jfreespcadr-segsize;                                    <<u.rao>>06250000
   altdsegsize(pxgjdt,j);                                               06255000
   if  <>  then  suddendeath(500);  << fatal error >>                   06260000
   go exit;                                                             06265000
end;   <<remjtentry>>                                                   06270000
                                                                        06275000
                                                                        06280000
procedure deljtentries(keyname,keynamesize,tno,pxgjdt,savedl);          06285000
    value tno,pxgjdt,savedl,keynamesize;                                06290000
    integer tno,pxgjdt,savedl,keynamesize;                              06295000
    byte array keyname;                                                 06300000
    option internal,privileged,uncallable;                              06305000
         <<delete all entries pointing to entry "KEYNAME"             >>06310000
         <<db must be pointing at the stack                           >>06315000
         <<keyname = name of entry in standard form                   >>06320000
         <<keynamesize = size of keyname in words                     >>06325000
         <<tno = table #                                              >>06330000
         <<pxgjdt = dst# of job table                                 >>06335000
         <<savedl = value of dl                                       >>06340000
        << tno = 1 - data segment table                      >><< 8498>>06345000
        << tno = 2 - temporary file table                    >><< 8498>>06350000
        << tno = 3 file equation table                       >><< 8498>>06355000
   begin                                                                06360000
    integer array                                                       06365000
         irawtestname(0:17)                                             06370000
        ,ientryname(0:14)                                               06375000
        ,itestname(0:14)                                                06380000
   ;byte array                                                          06385000
         testname(*) = itestname   <<name from info.-std.form>>         06390000
        ,entryname(*) = ientryname   <<name of entry from which         06395000
                                       "TESTNAME" came (std.form)>>     06400000
        ,rawtestname(*) = irawtestname   <<info.name (raw form)>>       06405000
   ;integer                                                             06410000
         rawtestnamesize   <<bytes>>                                    06415000
        ,testnamesize   <<words>>                                       06420000
        ,i,j,k                                                          06425000
        ,entrynamesize   <<words>>                                      06430000
        ,entrysize   <<words>>                                          06435000
        ,adrientryname   <<db-rel.adr of ientryname>>                   06440000
        ,adrirawtestname   <<db-rel.adr of irawtestname>>               06445000
   ;                                                                    06450000
   adrientryname := @ientryname;                                        06455000
   adrirawtestname := @irawtestname;                                    06460000
start:                                                                  06465000
   exchangedb(pxgjdt);                                                  06470000
   i := jdtarr(tno);   <<starting index of proper table>>      <<u.rao>>06475000
   while i < jdtarr(tno+1) do                                  <<u.rao>>06480000
      begin   <<cycle on entry>>                                        06485000
       <<move entry name to local array>>                               06490000
      entrysize := jdtarr(i).(0:8);                            <<u.rao>>06495000
      tos := adrientryname - savedl;   <<dl-rel.target>>                06500000
      tos := i+1;   <<db-rel.source>>                                   06505000
      tos := jdtarr(i).(8:8);   <<word count>>                 <<u.rao>>06510000
      assemble(dup; stor entrynamesize;);                               06515000
      assemble(mvbl 3);   <<move db to dl>>                             06520000
      k := jdtarr(i+entrynamesize+2);<<save 2nd word of pmask>><<00272>>06525000
       <<move info name to local array>>                                06530000
      j := i+entrynamesize+4;   <<adr.of info.name>>                    06535000
      tos := adrirawtestname - savedl;   <<dl-rel.target>>              06540000
      tos := j;   <<db-rel.source>>                                     06545000
      rawtestnamesize := jdtarr(j-1).(0:8);                    <<u.rao>>06550000
      tos := (rawtestnamesize+1)&lsr(1);   <<word count>>               06555000
      assemble(mvbl 3);   <<db to dl move>>                             06560000
      exchangedb(0);                                                    06565000
   <<if not a back reference or no actual name then skip test>><<00272>>06570000
      if k.(6:1)=0 or rawtestnamesize=0 then go inc;           <<00272>>06575000
       <<put info.name in standard form>>                               06580000
      packandpoint(rawtestname,rawtestnamesize,j,k);                    06585000
   rawtestname (rawtestnamesize) := " ";                                06590000
   << note: j and k are stacked because crunch expects byte >> <<00271>>06595000
   << arrays as parameters and j and k are declared as      >> <<00271>>06600000
   << integers in this routine.  type mixing is dangerous!! >> <<00271>>06605000
      tos := @rawtestname;                                     <<00271>>06610000
      tos := j;                                                <<00271>>06615000
      tos := k;                                                <<00271>>06620000
      crunch(*,*,*,itestname,testnamesize);                    <<00271>>06625000
      if testnamesize = keynamesize then                                06630000
         begin   <<see if testname same as keyname>>                    06635000
         tos := @keyname;   <<target>>                                  06640000
         tos := @testname;   <<source>>                                 06645000
         tos := keynamesize & lsl(1);   <<byte count>>                  06650000
         assemble(cmpb 3);                                              06655000
         if = then                                                      06660000
            begin   <<delete entry and all entries pointing at it>>     06665000
            remjtentry(j,j,j,tno,i);                                    06670000
            deljtentries(entryname,entrynamesize,tno,pxgjdt,savedl);    06675000
            go start;   <<start search over again>>                     06680000
            end;                                                        06685000
         end;                                                           06690000
inc:                                                                    06695000
      i := i+entrysize;                                                 06700000
      exchangedb(pxgjdt);                                               06705000
      end;                                                              06710000
   exchangedb(0);                                                       06715000
   end;   <<deljtentries>>                                              06720000
                                                                        06725000
                                                                        06730000
integer procedure xremjtentry(n1,n2,n3,tno);                            06735000
    value tno;                                                          06740000
    integer tno;                                                        06745000
    byte array n1,n2,n3;                                                06750000
option privileged, uncallable;                                          06755000
   begin                                                                06760000
         <<procedure to remove from the job table an entry (n1,n2,n3) >>06765000
         <<and all other entries directly or indirectly pointing at   >>06770000
         <<it. also, if the entry (n1,n2,n3) points to another entry, >>06775000
         <<decrement the ref.count for that entry. if this ref.count  >>06780000
         <<goes to zero, delete the entry.                            >>06785000
         <<n1,n2,n3 - name of entry to be deleted.                    >>06790000
         <<tno - table#(1,2 or 3) from which entry is to be deleted. >> 06795000
         <<xremjtentry:= 0 - ok,entry deleted.                        >>06800000
         <<           := 1 - no such entry.                           >>06805000
         <<           := 2 - n1,n2,n3 pointing to non-existent entry. >>06810000
         <<           := 3 - ref.count already zero in entry pointed  >>06815000
         <<                  to by entry n1,n2,n3.                    >>06820000
         <<note: db must be pointing to the stack.                    >>06825000
        << tno = 1 - data segment table                      >><< 8498>>06830000
        << tno = 2 - temporary file table                    >><< 8498>>06835000
        << tno = 3 file equation table                       >><< 8498>>06840000
    logical                                                             06845000
         a   <<lockjir return value (not used)>>                        06850000
        ,b   <<lockjir return value>>                                   06855000
   ;integer                                                             06860000
         pxgjdt   <<job table dst#>>                                    06865000
        ,i,j,k,l      <<miscellaneous dummies>>                <<u.rao>>06870000
        ,savedl                                                         06875000
        ,adrin1   <<db-rel.adr of in1>>                                 06880000
        ,keyadr   <<adr.of entry n1,n2,n3>>                             06885000
   ;integer array                                                       06890000
        in1(0:17) = q                                          <<u.rao>>06895000
   ;byte array                                                          06900000
         bn1(*) = in1                                                   06905000
   ;logical                                                             06910000
         bn2                                                            06915000
        ,bn3                                                            06920000
   ;byte pointer                                               <<00069>>06925000
         cn2                                                   <<00069>>06930000
        ,cn3                                                   <<00069>>06935000
   ;                                                                    06940000
   push(dl);                                                            06945000
   savedl := tos;                                                       06950000
   b := lockjir;                                                        06955000
   adrin1 := @in1;                                                      06960000
   keyadr := i := findjtentry(n1,n2,n3,tno,a,pxgjdt);                   06965000
   if i=0 then                                                          06970000
      begin   <<no such entry>>                                         06975000
      xremjtentry := 1;                                                 06980000
exit1:                                                                  06985000
      exchangedb(0);                                                    06990000
exit2:                                                                  06995000
      unlockjir(b);                                                     07000000
      return;                                                           07005000
      end;                                                              07010000
<< i = index into jdt of entry                             >>  <<06288>>07015000
<< k = 2nd word of info string; info is the rest of the    >>  <<06288>>07020000
<<     entry following the formal designator name          >>  <<06288>>07025000
   k := i+jdtarr(i).(8:8)+2;   <<index of 2nd word in info>>   <<u.rao>>07030000
   if jdtarr(k).(6:1) = 1 then                                 <<u.rao>>07035000
      begin   <<decrement ref.count in entry pointed at>>               07040000
      j := jdtarr(k+1).(0:8);   <<size of name in info(bytes)>><<u.rao>>07045000
      tos := adrin1 - savedl;   <<dl-rel.target>>                       07050000
      tos := k+2;   <<db-rel.source>>                                   07055000
      tos := (j+1)&lsr(1);   <<word count>>                             07060000
      assemble(mvbl 3);   <<move info.name to local array>>             07065000
      exchangedb(0);                                                    07070000
      packandpoint(bn1,j,bn2,bn3);                                      07075000
      bn1 (j) := " ";                                                   07080000
      @cn2:=bn2;                                               <<00069>>07085000
      @cn3:=bn3;                                               <<00069>>07090000
      i := findjtentry(bn1,cn2,cn3,tno,a,pxgjdt);              <<00069>>07095000
      if i=0 then                                                       07100000
         begin   <<n1,n2,n3 pointing at non-existent entry>>            07105000
         xremjtentry := 2;                                              07110000
         go exit1;                                                      07115000
         end;                                                           07120000
      k := i+jdtarr(i).(8:8)+2;   <<index of second word in inf<<u.rao>>07125000
     k:=k+1;                                                   <<forms>>07130000
<< l = name-actual designator length + dev length in words.>>  <<06288>>07135000
     l:=(jdtarr(k).(0:8)+1)&lsr(1)                                      07140000
     +(jdtarr(k).(8:8)+1)&lsr(1);                                       07145000
<< k = index to the reference cound word in jfeq table     >>  <<06288>>07150000
     k:=(k+l+10);                                              <<forms>>07155000
      l := jdtarr(k).(0:6);   <<ref.count>>                    <<u.rao>>07160000
      if l=0 then                                                       07165000
         begin   <<ref.count already zero>>                             07170000
         xremjtentry := 3;                                              07175000
         go exit1;                                                      07180000
         end;                                                           07185000
      jdtarr(k).(0:6) := l-1;   <<decrement ref.count>>        <<u.rao>>07190000
      end;                                                              07195000
   exchangedb(0);                                                       07200000
   remjtentry(j,j,j,tno,keyadr);                                        07205000
   crunch(n1,n2,n3,bn1,i);                                              07210000
   deljtentries(bn1,i,tno,pxgjdt,savedl);                               07215000
   go exit2;                                                            07220000
   end;   <<xremjtentry>>                                               07225000
                                                                        07230000
                                                                        07235000
integer procedure addjtentry(n1,n2,n3,tno,size,info);                   07240000
    value size,tno;                                                     07245000
    integer size,tno;                                                   07250000
    integer array info;                                                 07255000
    byte array n1,n2,n3;                                                07260000
option privileged, uncallable;                                          07265000
   begin                                                                07270000
         <<procedure to add entry to the job table.                   >>07275000
         <<n1,n2,n3 - name of entry being added.                      >>07280000
         <<tno = 1,2 or 3 - table# to which entry is to be added.     >>07285000
         <<    = -1,-2 or -3 - use -tno as the table# and do not issue>>07290000
         <<                    an error #2. in case of duplicate, the >>07295000
         <<                    old entry is deleted and the new added.>>07300000
         <<    = 0 - special call to add an entry to table #1. name   >>07305000
         <<          length is always 1 word (not put in std.form);   >>07310000
         <<          info is 2 words (4 word entry). no check is made >>07315000
         <<          for duplicate names.                             >>07320000
         <<size - length of "INFO" in words.                          >>07325000
         <<info - information to be put in table entry.               >>07330000
         <<addjtentry:= 0 - entry added.                              >>07335000
         <<          := 1 - no room for new entry.                    >>07340000
         <<          := 2 - duplicate name.                           >>07345000
         <<note: db must be pointing to the stack.                    >>07350000
        << tno = 1 - data segment table                      >><< 8498>>07355000
        << tno = 2 - temporary file table                    >><< 8498>>07360000
        << tno = 3 file equation table                       >><< 8498>>07365000
   integer pointer savetos; <<pmask1 word target addr >>       <<04573>>07370000
    integer                                                             07375000
        i,j                                                    <<u.rao>>07380000
        ,entry'i << index from determine >>                    << 8498>>07385000
        ,savedl   <<stack rel.adr.of dl>>                               07390000
        ,pxgjdt   <<job table dst#>>                                    07395000
        ,segsize   <<current actual size of job table segment>>         07400000
        ,refcount := 0   <<file reference count         >>     <<04573>>07405000
        ,result := 0     <<return value for remjtentry  >>     <<04573>>07410000
        ,actualdevlen    <<from info string name/dev len>>     <<04573>>07415000
        ,inforefindex    <<ref cnt index for info string>>     <<04573>>07420000
        ,upperinfo       << bits (0:8) of info string word 2>> <<04573>>07425000
        ,lowerinfo       << bits (8:8) of info string word 2>> <<04573>>07430000
   ;logical                                                             07435000
         a   <<lockjir return value>>                                   07440000
        ,specall := false  <<tno<0, no error #2 to be issued (if true)>>07445000
   ;                                                                    07450000
   push(dl);                                                            07455000
   savedl := tos;                                                       07460000
   if tno < 0 then                                                      07465000
      begin                                                             07470000
      tno := -tno;                                                      07475000
      specall := true;                                                  07480000
      end;                                                              07485000
   j.(0:8) := n1;   <<save id for table#1 (special call)>>              07490000
   j.(8:8) := n1(1);                                                    07495000
fix:                                                                    07500000
   i := findjtentry(n1,n2,n3,tno,a,pxgjdt);                             07505000
       << am now operating in split stack mode with the >>     <<04573>>07510000
       << stack pointing to the jdt dst.  findjtentrty  >>     <<04573>>07515000
       << puts the caller into split stack mode.        >>     <<04573>>07520000
   if tno = 0 then                                                      07525000
      begin   <<special add to table #1>>                               07530000
      jdtworkspc := %2001;   <<entry size=4, name size=1>>     <<u.rao>>07535000
      jdtworkspc(1) := j;   <<entry name>>                     <<u.rao>>07540000
      size := 2;   <<info size>>                                        07545000
      i := 4;   <<entry size>>                                          07550000
      go seg;                                                           07555000
      end;                                                              07560000
   if i <> 0 then                                                       07565000
      if not specall then                                               07570000
         begin   <<duplicate name>>                                     07575000
         addjtentry := 2;                                               07580000
exit:    exchangedb(0);                                                 07585000
         unlockjir(a);                                                  07590000
         return;                                                        07595000
         end                                                            07600000
      else                                                              07605000
         begin   <<delete old entry>>                                   07610000
         exchangedb(0);                                                 07615000
         result := remjtentry(n1,n2,n3,tno,0);                 <<04573>>07620000
 <<                                                      >>    <<04573>>07625000
 << remjtentry returns an integer value. bits (8:8) are  >>    <<04573>>07630000
 << the return value of remjtentry  and are 0 or 1. bits >>    <<04573>>07635000
 << (0:8) are the reference count from the removed file. >>    <<04573>>07640000
 << ths is done to preserve this value so that the file  >>    <<04573>>07645000
 << being replaced with a file equation with the same    >>    <<04573>>07650000
 << name will not lose track of any pointer files point- >>    <<04573>>07655000
 << ing to the file being replaced.                      >>    <<04573>>07660000
                                                               <<04573>>07665000
         refcount := result.(0:8);                             <<04573>>07670000
         unlockjir(a);  go fix;  << wrong name in work area >>          07675000
         end;                                                           07680000
       << am in split stack mode with stack at jdt dst  >>     <<04573>>07685000
   <<                                                       >> << 8498>>07690000
   << this is where we add the new entry to the table.  by  >> << 8498>>07695000
   << now, we have the new entry's size in the jdt work     >> << 8498>>07700000
   << area and we have the size of the packed formal        >> << 8498>>07705000
   << formal designator in the jdt work area.  size is the  >> << 8498>>07710000
   << length (in words) of the information (info) that will    << 8498>>07715000
   << be stored in the new entry.                           >> << 8498>>07720000
   <<                                                       >> << 8498>>07725000
   i := jdtworkspc.(8:8);   <<name size>>                      <<u.rao>>07730000
   i := size + i + 1;   <<new entry size>>                              07735000
   jdtworkspc.(0:8) := i;   <<store entry size in work area>>  <<u.rao>>07740000
seg:                                                                    07745000
   << now determine if we can expand the jdt by the newly   >> << 8498>>07750000
   << computed length of the new entry (i).                 >> << 8498>>07755000
   << segsize is gotten from the dst table.                 >> << 8498>>07760000
   << the jdt free space area is at the tail of the jdt.  j >> << 8498>>07765000
   << is the number of extra words needed to fit the new    >> << 8498>>07770000
   << entry after the number of words in the free space area>> << 8498>>07775000
   << is computed (segsize - jfreespcadr).  if there is no  >> << 8498>>07780000
   << room, exit the procedure with addjtentry=1.           >> << 8498>>07785000
   segsize := (sys'dst(pxgjdt&lsl(2)).(3:13))&lsl(2)-1;                 07790000
   j := i - (segsize-jfreespcadr);   <<#extra words needed>>   <<u.rao>>07795000
   if (segsize+j) > jdtarr then                                <<u.rao>>07800000
      begin   <<no more room>>                                          07805000
nmr:                                                                    07810000
      addjtentry := 1;                                                  07815000
      go exit;                                                          07820000
      end;                                                              07825000
   if j > 0 then                                                        07830000
      begin   <<increase seg.size>>                                     07835000
      altdsegsize(pxgjdt,j);                                            07840000
      if <> then                                                        07845000
         go nmr;   <<no more room>>                                     07850000
      end;                                                              07855000
                                                               << 8498>>07860000
   << if tno = 2, then the temporary file table is being     >><< 8498>>07865000
   << updated.  we want to put it into the table in order    >><< 8498>>07870000
   << find entry index where new entry should be placed      >><< 8498>>07875000
   << we attempt to place the entries in sorted order.  the  >><< 8498>>07880000
   << procedure determine returns a jdt relative index of    >><< 8498>>07885000
   << where the new entry should be placed in the table.  the>><< 8498>>07890000
   << order is first by account, then by group and then by   >><< 8498>>07895000
   << file name.  there will be no collisions since any      >><< 8498>>07900000
   << dupilcates would be been removed by now (depending upon>><< 8498>>07905000
   << if addjtentry was called from xaddjtentry or not).     >><< 8498>>07910000
                                                               << 8498>>07915000
   if tno <> 2                                                 << 8498>>07920000
      then entry'i := jdtarr( tno + 1 )                        << 8498>>07925000
      else entry'i := get'ordered'index( n1, n2, n3, tno,      << 8498>>07930000
                                                 pxgjdt   );   << 8498>>07935000
                                                               << 8498>>07940000
   << now we move an entire part of the jdt, from the index  >><< 8498>>07945000
   << entry'i to the end of the last table in the jdt (the   >><< 8498>>07950000
   << last word before the start of the freespace area), down>><< 8498>>07955000
   << i words.                                               >><< 8498>>07960000
                                                               << 8498>>07965000
    <<move part of data  down to fit new entry>>                        07970000
   tos := jfreespcadr + i - 1;   <<target>>                    <<u.rao>>07975000
   tos := jfreespcadr - 1;   <<source>>                        <<u.rao>>07980000
   tos := entry'i-jfreespcadr;  << will be a negative value >> << 8498>>07985000
   assemble(move 3);                                                    07990000
                                                               << 8498>>07995000
   << now we move the new entry from the jdt work area to   >> << 8498>>08000000
   << its new index entry'i.  it will fit since we just made>> << 8498>>08005000
   << room for its i words of length.                       >> << 8498>>08010000
                                                               << 8498>>08015000
    <<move entry size, name size & name into new entry>>                08020000
   tos := entry'i; << target where new entry will be placed >> << 8498>>08025000
   tos := @jdtworkspc;                                         <<u.rao>>08030000
   TOS := JDTWORKSPC.(8:8) + 1;   <<#WORDS (NAME SIZE+1 FOR "SI<<U.RAO>>08035000
   assemble(move 2);                                                    08040000
                                                               << 8498>>08045000
   << now move the info into the new entry (in tos)        >>  << 8498>>08050000
                                                               << 8498>>08055000
   @savetos := tos;  <<save target address, beginning of >>    <<04573>>08060000
                     <<info string                       >>    <<04573>>08065000
   tos := @savetos;  <<put target back, move info in     >>    <<04573>>08070000
   tos := @info - savedl;   <<dl-rel.source adr.>>                      08075000
   tos := size;   <<word count (positive)>>                             08080000
   assemble(mvlb 3);   <<dl+ to db+ move>>                              08085000
                                                               << 8498>>08090000
   << if the entry was added to the file equation table    >>  << 8498>>08095000
   << update its reference count.  it was saved earlier in >>  << 8498>>08100000
   << case the new entry was a duplicate of a previous one >>  << 8498>>08105000
                                                               << 8498>>08110000
   if tno = 3 then  << reference count only in jfeq. >>        <<04906>>08115000
   begin                                                       <<04906>>08120000
      upperinfo := savetos(2).(0:8); <<actual desig. length >> <<04906>>08125000
      lowerinfo := savetos(2).(8:8); <<device length        >> <<04906>>08130000
      actualdevlen := (upperinfo + lowerinfo + 1)&lsr(1);      <<04906>>08135000
      inforefindex := 12 + actualdevlen; <<ref count index>>   <<04906>>08140000
      savetos(inforefindex).(0:6) := refcount.(10:6);          <<04906>>08145000
   end;                                                        <<04906>>08150000
                                                               << 8498>>08155000
   << now whirl through the pointers to the tables and     >>  << 8498>>08160000
   << adjust their pointers by i words.  (only if their    >>  << 8498>>08165000
   << pointers are below entry'i, the spot where the new   >>  << 8498>>08170000
   << entry was added.                                     >>  << 8498>>08175000
                                                               << 8498>>08180000
   j := if tno=0 then 1 else tno;                                       08185000
   while (j:=j+1) <= numjdtptrs do                             <<u.rao>>08190000
      begin   <<increase starting addresses of subsequent tables>>      08195000
      jdtarr(j) := jdtarr(j)+i;                                <<u.rao>>08200000
      end;                                                              08205000
   go exit;                                                             08210000
end;   <<addjtentry>>                                                   08215000
                                                                        08220000
                                                                        08225000
integer procedure xaddjtentry(n1,n2,n3,tno,size,info,                   08230000
                                           xn1,xn2,xn3);                08235000
    value size,tno;                                                     08240000
    integer size,tno;                                                   08245000
    byte array n1,n2,n3,xn1,xn2,xn3;                                    08250000
    integer array info;                                                 08255000
option privileged, uncallable;                                          08260000
         <<add entry n1,n2,n3 to job-table                            >>08265000
         <<increment reference count in existing entry xn1,xn2,xn3    >>08270000
         <<tno = table # (1,2 or 3) (input)                           >>08275000
         <<size = #words of info (input)                              >>08280000
         <<info = array of information (input)                        >>08285000
         <<xaddjtentry:= 0 - everything ok                            >>08290000
         <<           := 1 - no room for new entry n1,n2,n3           >>08295000
         <<           := 2 - duplicate name n1,n2,n3                  >>08300000
         <<           := 3 - no such entry xn1,xn2,xn3                >>08305000
         <<           := 4 - reference count overflow                 >>08310000
         <<           := 5 - circular list                  >> <<00834>>08315000
        << tno = 1 - data segment table                      >><< 8498>>08320000
        << tno = 2 - temporary file table                    >><< 8498>>08325000
        << tno = 3 file equation table                       >><< 8498>>08330000
   begin                                                                08335000
   integer array                                               <<u.rao>>08340000
         in1(0:17)=q                                                    08345000
        ,lhs(0:12)   <<crunched lhs>>                                   08350000
        ,chainel(0:12)   <<crunched rhs chain element>>                 08355000
   ;byte array                                                          08360000
         bn1(*) = in1                                                   08365000
        ,blhs(*) = lhs                                                  08370000
        ,bchainel(*) = chainel                                          08375000
   ;integer                                                             08380000
         k                                                              08385000
        ,abstno   <<abs(tno)>>                                          08390000
        ,rhsadr   <<adr.of rhs(xn1,xn2,xn3) in table>>                  08395000
        ,adrin1   <<adr of in1(*)>>                                     08400000
        ,savedl                                                         08405000
        ,bn2,bn3                                                        08410000
        ,nwds   <<for compare>>                                         08415000
   ;integer                                                             08420000
        i,j                                                             08425000
        ,pxgjdt   <<table dst #>>                                       08430000
   ;logical                                                             08435000
         a   <<lockjir return value (not used)>>                        08440000
        ,error := false                                                 08445000
        ,b   <<lockjir return value>>                                   08450000
   ;                                                                    08455000
   adrin1 := @in1;                                                      08460000
   push(dl);                                                            08465000
   savedl := tos;                                                       08470000
   abstno := if tno>0 then tno else -tno;                               08475000
   b := lockjir;                                                        08480000
<< look for existing entry name tghat has been referenced  >>  <<06288>>08485000
<< to by entry being added.                                >>  <<06288>>08490000
<< findjtentry leaves db at jdt dst.                       >>  <<06288>>08495000
                                                               <<06288>>08500000
   rhsadr := i := findjtentry(xn1,xn2,xn3,abstno,a,pxgjdt);             08505000
   if i=0 then                                                          08510000
      begin   <<entry cannot be found>>                                 08515000
      xaddjtentry := 3;   <<no such entry>>                             08520000
exit1:                                                                  08525000
      exchangedb(0);                                                    08530000
exit: unlockjir(b);                                                     08535000
      if error then remjtentry(n1,n2,n3,abstno,0);                      08540000
      return;                                                           08545000
      end;                                                              08550000
   exchangedb(0);                                                       08555000
   crunch(n1,n2,n3,lhs,nwds);   <<crunch lhs>>                          08560000
   j := findjtentry(n1,n2,n3,abstno,a,pxgjdt);                          08565000
   if j=0 then go rhsok;                                                08570000
   if i=j then                                                          08575000
      begin   <<error, n pointing at xn>>                               08580000
      xaddjtentry := 3;                                                 08585000
      go exit1;                                                         08590000
      end;                                                              08595000
next:                                                                   08600000
   k := i+jdtarr(i).(8:8)+2;   <<index of 2nd word of info>>   <<u.rao>>08605000
   if jdtarr(k).(6:1) = 0 then go rhsok;   <<no more pointers>><<u.rao>>08610000
   j := jdtarr(k+1).(0:8);   <<size (bytes) of name in info>>  <<u.rao>>08615000
   tos := adrin1 - savedl;   <<dl-rel target>>                          08620000
   tos := k+2;   <<dl-rel source>>                                      08625000
   tos := (j+1)&lsr(1);   <<word count>>                                08630000
   assemble (mvbl 3);   <<move info name to local array>>               08635000
   exchangedb(0);                                                       08640000
   packandpoint(bn1,j,bn2,bn3);                                         08645000
   bn1 (j) := " ";                                                      08650000
   crunch(bn1,bn2,bn3,chainel,nwds);   <<crunch rhs chain element>>     08655000
   tos := @blhs;   <<target>>                                           08660000
   tos := @bchainel;   <<source>>                                       08665000
   tos := nwds&lsl(1);   <<byte count>>                                 08670000
   assemble(cmpb 3);                                                    08675000
   if = then                                                            08680000
      begin   <<error, circular link list>>                             08685000
      xaddjtentry := 5;                                        <<00834>>08690000
      go exit;                                                          08695000
      end;                                                              08700000
   i := findjtentry(bn1,bn2,bn3,abstno,a,pxgjdt);                       08705000
   if i=0 then suddendeath(501);   <<pointer to non-existent entry>>    08710000
   go next;                                                             08715000
rhsok:   <<no loops, rhs entry exists>>                                 08720000
   exchangedb(0);                                                       08725000
   i := addjtentry(n1,n2,n3,tno,size,info);                             08730000
   if i<>0 then                                                         08735000
      begin   <<error>>                                                 08740000
      xaddjtentry := i;                                                 08745000
      error := true;                                                    08750000
      go exit;                                                          08755000
      end;                                                              08760000
   j := findjtentry(xn1,xn2,xn3,abstno,a,pxgjdt);                       08765000
<< j = index of entry in jdt.                              >>  <<06288>>08770000
<< db is at jdt dst.                                       >>  <<06288>>08775000
<< i = index to second word of info string.                >>  <<06288>>08780000
   i := j + jdtarr(j).(8:8) + 2;                               <<u.rao>>08785000
<< make i index to name-actual designator.                 >>  <<06288>>08790000
<< j := name lengtrh + device name length                  >>  <<06288>>08795000
     i:=i+1;                                                   <<forms>>08800000
     j:=(jdtarr(i).(0:8)+1)&lsr(1)                                      08805000
     +(jdtarr(i).(8:8)+1)&lsr(1);                                       08810000
<< i = index to reference count word.                      >>  <<06288>>08815000
     i:=(i+j+10);                                              <<forms>>08820000
   if (j:=jdtarr(i).(0:6)) = 63 then                           <<u.rao>>08825000
      begin   <<reference count overflow>>                              08830000
      xaddjtentry := 4;                                                 08835000
      error := true;                                                    08840000
      go exit1;                                                         08845000
      end;                                                              08850000
   jdtarr(i).(0:6) := j+1;   <<inc.ref.count>>                 <<u.rao>>08855000
   go exit1;                                                            08860000
   end;   <<xaddjtentry>>                                               08865000
                                                                        08870000
                                                                        08875000
integer procedure xjdt(func,id,dstno);                                  08880000
    value func,id,dstno;                                                08885000
    integer func,id,dstno;                                              08890000
   option privileged, uncallable;                                       08895000
         <<procedure to maintain table #1 of job tables.              >>08900000
         <<id - name of entry (1 word, not in standard form).         >>08905000
         <<dstno - data segment table # associated with "ID" in table.>>08910000
         <<func = 0 - search: use id to find entry (dstno not used).  >>08915000
         <<           if entry exists, return xjdt=dst#(3rd word),    >>08920000
         <<           increment ref (4th word). if entry does not     >>08925000
         <<           exist, return xjdt=0.                           >>08930000
         <<func = 1 - put: use id to find entry. if entry exists,     >>08935000
         <<           return xjdt=dst# (3rd word), increment ref (4th >>08940000
         <<           word). if entry does not exist, add new entry   >>08945000
         <<           (id,dstno,ref=1), return xjdt=0. if insufficient>>08950000
         <<           room for new entry, return xjdt=-1.             >>08955000
         <<func = 2 - release: if id<>0, then use id to find entry. if>>08960000
         <<           id=0, then use dstno to find entry. if entry    >>08965000
         <<           cannot be found, then return xjdt=0. if entry is>>08970000
         <<           found and 3rd word (dst#) = dstno then decrement>>08975000
         <<           reference count, return xjdt=original ref. if   >>08980000
         <<           ref goes to zero, then delete entry.            >>08985000
         <<func = 3 - destroy: return xjdt=0 if table is empty.       >>08990000
         <<           otherwise find last entry in table,             >>08995000
         <<           set xjdt=dst# (3rd word) and delete the entry.  >>09000000
         <<func = 4 - release: same as func=2, except don't>>  <<00428>>09005000
         <<           delete entry if ref goes to 0.       >>  <<00428>>09010000
         <<note: upon entry, db must be pointing to the stack.        >>09015000
   begin                                                                09020000
    integer array                                                       09025000
        dummy(0:2)=q   <<id,dstno,ref>>                        <<u.rao>>09030000
   ;byte array                                                          09035000
         bdummy(*) = dummy                                              09040000
   ;integer                                                             09045000
         pxgjdt     <<jdt dst#>>                               <<u.rao>>09050000
        ,i,j,k,l                                                        09055000
   ;logical                                                             09060000
         a   <<getsir return value (not used)>>                         09065000
        ,b   <<lockjir return value>>                                   09070000
   ;                                                                    09075000
   xjdt := 0;                                                           09080000
   b := lockjir;                                                        09085000
   findjtentry(j,j,j,0,a,pxgjdt);   <<dummy call>>                      09090000
   i := jdsdadr;   <<starting adr.of table #1>>                <<u.rao>>09095000
   j := jtfdadr;   <<starting adr.of table #2>>                <<u.rao>>09100000
   if func = 3 then                                                     09105000
      begin   <<destroy>>                                               09110000
      if i=j then                                                       09115000
         begin   <<no entries left>>                                    09120000
         xjdt := 0;                                                     09125000
exit1:   exchangedb(0);                                                 09130000
exit2:   unlockjir(b);                                                  09135000
         return;                                                        09140000
         end;                                                           09145000
       <<delete last entry & return dst# (3rd word)>>                   09150000
      j := j-4;                                                         09155000
      xjdt := jdtarr(j+2);   <<dst #>>                         <<u.rao>>09160000
      exchangedb(0);                                                    09165000
      remjtentry(j,j,j,1,j);                                            09170000
      go exit2;                                                         09175000
      end;                                                              09180000
   if (func=2 or func=4) and id=0 then                         <<00428>>09185000
      begin   <<search on dstno>>                                       09190000
      k := 2;                                                           09195000
      l := dstno;                                                       09200000
      end                                                               09205000
   else                                                                 09210000
      begin   <<search on id>>                                          09215000
      k := 1;                                                           09220000
      l := id;                                                          09225000
      end;                                                              09230000
   i := i+k;                                                            09235000
   while i<j do                                                         09240000
      begin   <<cycle on entry>>                                        09245000
      if jdtarr(i) = l then                                    <<u.rao>>09250000
         begin                                                          09255000
         i := i-k;   <<point to 1st word>>                              09260000
         go found;                                                      09265000
         end;                                                           09270000
      i := i+4;                                                         09275000
      end;                                                              09280000
    <<entry cannot be found>>                                           09285000
   if func <> 1 then                                                    09290000
      go exit1;                                                         09295000
    <<add entry>>                                                       09300000
   exchangedb(0);                                                       09305000
   dummy := id;                                                         09310000
   dummy(1) := dstno;                                                   09315000
   dummy(2) := 1;   <<ref.count>>                                       09320000
   i := addjtentry(bdummy,j,j,0,2,dummy(1));   <<special call>>         09325000
   if i=1 then                                                          09330000
      xjdt := -1;   <<no room>>                                         09335000
   go exit2;                                                            09340000
found:                                                                  09345000
    <<note: i=index of 1st word of entry>>                              09350000
   if func < 2 then                                                     09355000
      begin   <<"SEARCH" or "PUT">>                                     09360000
      xjdt := jdtarr(i+2);   <<dst #>>                         <<u.rao>>09365000
      jdtarr(i+3) := jdtarr(i+3)+1;   <<inc.ref.count>>        <<u.rao>>09370000
      go exit1;                                                         09375000
      end;                                                              09380000
    <<func=2 or 4 - "RELEASE">>                                <<00428>>09385000
   if dstno = jdtarr(i+2) then                                 <<u.rao>>09390000
      begin                                                             09395000
      xjdt := j := jdtarr(i+3);   <<original ref.count>>       <<u.rao>>09400000
      << decrement ref count in jdt and remove entry from >>   <<00428>>09405000
      << jdt only if count = 0 and func = 2.              >>   <<00428>>09410000
      if (jdtarr(i+3) := j-1) = 0 and func = 2 then            <<00428>>09415000
         begin   <<remove entry>>                                       09420000
         exchangedb(0);                                                 09425000
         remjtentry(j,j,j,1,i);                                         09430000
         go exit2;                                                      09435000
         end;                                                           09440000
      end;                                                              09445000
   go exit1;                                                            09450000
   end;   <<procedure xjdt>>                                            09455000
                                                                        09460000
                                                                        09465000
integer procedure csjtentryloc(linegroup,entrysize,tno,dstno,           09470000
    jir);                                                               09475000
    value tno;                                                          09480000
    byte array linegroup;                                               09485000
    integer entrysize,tno,dstno;                                        09490000
    logical jir;                                                        09495000
   option privileged,uncallable;                                        09500000
         <<procedure to determine if cs entries exist                 >>09505000
         <<linegroup - name of line or group                          >>09510000
         <<entrysize - size of entry (words), if found                >>09515000
         <<tno - table number: 4 = line table, 5 = group table        >>09520000
         <<dstno - data segment table number of jdt                   >>09525000
   begin                                                                09530000
    logical                                                             09535000
         a   <<redundant lockjir return value>>                         09540000
        ,b   <<lockjir return value>>                                   09545000
    ;integer array                                                      09550000
        in1(0:3) = q   <<local array for storing names>>       <<u.rao>>09555000
    ;integer                                                            09560000
         i,k                                                            09565000
        ,savedl                                                         09570000
        ,adrin1   <<dl - rel. addr. of in1(*)>>                         09575000
    ;                                                                   09580000
    byte array n2(0:1),n3(*)=n2,bn1(*)=in1;                             09585000
    push(dl);                                                           09590000
    savedl _ tos;                                                       09595000
    adrin1 _ @in1;                                                      09600000
    n2 _ " ";                                                           09605000
    i _ findjtentry(linegroup,n2,n3,tno,b,dstno);                       09610000
<< db is at the jdt dst now >>                                 <<06288>>09615000
    while i<>0                                                 <<u.rao>>09620000
<< look at reference count bit from the pmask word 2.      >>  <<06288>>09625000
      and logical(jdtarr(k:=i+jdtarr(i).(8:8)+2).(6:1)) do     <<u.rao>>09630000
       begin                                                            09635000
       tos _ adrin1 - savedl;                                           09640000
       tos _ k+2;                                                       09645000
       tos _ 4;   <<size of name (words)>>                              09650000
       assemble(mvbl);                                                  09655000
       exchangedb(0);                                                   09660000
       i _ findjtentry(bn1,n2,n3,tno,a,dstno);                          09665000
<< db is at the jdt dst now >>                                 <<06288>>09670000
       end;                                                             09675000
    if (csjtentryloc _ i) <> 0 then                                     09680000
       begin                                                            09685000
       i := jdtarr(i)&lsr(8);                                  <<u.rao>>09690000
       k _ b;                                                           09695000
       end else unlockjir(b);                                           09700000
    exchangedb(0);                                                      09705000
    entrysize _ i;                                                      09710000
    jir _ k;                                                            09715000
end <<csjtentryloc>>;                                                   09720000
integer procedure retpmask(n1,n2,n3,pmaskhi,pmasklo);                   09725000
logical pmaskhi,pmasklo;                                                09730000
byte array n1,n2,n3;                                                    09735000
option privileged,uncallable;                                           09740000
<<                                                   >>                 09745000
<<  procedure to obtain information concerning which >>                 09750000
<<  parameters a user has specified in a file        >>                 09755000
<<  equation                                         >>                 09760000
<<                                                   >>                 09765000
<<  input: n1,n2,n3  file name in standard format    >>                 09770000
<<                                                   >>                 09775000
<<  output: pmaskhi = first word of pmask parameter  >>                 09780000
<<                    in file equation table entry   >>                 09785000
<<          pmasklo = remaining bits of pmask        >>                 09790000
<<                                                   >>                 09795000
<<          retpmask= 0 ok                           >>                 09800000
<<                  = 1 entry not found              >>                 09805000
<<                                                   >>                 09810000
<<                                                   >>                 09815000
<<  format of pmaskhi :                              >>                 09820000
<<       bit 0    blockfactor                        >>                 09825000
<<           1    recsize                            >>                 09830000
<<           2    disposition                        >>                 09835000
<<           3    numbuffers                         >>                 09840000
<<           4    inhibit buffering                  >>                 09845000
<<           5    exclusive                          >>                 09850000
<<           6    multi-record                       >>                 09855000
<<           7    access type                        >>                 09860000
<<           8    copy/nocopy                        >>        <<02557>>09865000
<<           9    carriage control                   >>                 09870000
<<          10    record format                      >>                 09875000
<<          11    default designation                >>                 09880000
<<          12    ascii/binary                       >>                 09885000
<<          13    domain                             >>                 09890000
<<          14    device                             >>                 09895000
<<          15    name                               >>                 09900000
<<                                                   >>                 09905000
<<  format of pmasklo:                               >>                 09910000
<<       bit   0   file type                         >>        <<02557>>09915000
<<             1   labelled tape                     >>        <<02557>>09920000
<<             2   forms message                     >>                 09925000
<<             3   user labels                       >>                 09930000
<<             4   reserved for native language      >>        << 8498>>09935000
<<             5   reserved for advanced net (vterm) >>        << 8498>>09940000
<<             6   this is a back reference entry    >>                 09945000
<<             7   dynamic locking                   >>                 09950000
<<             8   wait/nowait                       >>                 09955000
<<             9   multi-access                      >>                 09960000
<<            10   numcop                            >>                 09965000
<<            11   outpri                            >>                 09970000
<<            12   filecode                          >>                 09975000
<<            13   filesize                          >>                 09980000
<<            14   numexts                           >>                 09985000
<<            15   init alloc                        >>                 09990000
<<                                                   >>                 09995000
<< if bit = 1, then user specified the parameter in  >>                 10000000
<<            in a file equation                     >>                 10005000
<<                                                   >>                 10010000
<<            used by image/3000                     >>                 10015000
<<                                                   >>                 10020000
<<                                                   >>                 10025000
                                                                        10030000
begin                                                                   10035000
integer size;                                                           10040000
integer array info(0:255);                                              10045000
                                                                        10050000
size := 3;                                                              10055000
if (retpmask := retjtentry(n1,n2,n3,size,info))  = 0      then          10060000
  begin                                                                 10065000
  pmaskhi := info;                                                      10070000
  pmasklo := info(1);                                                   10075000
  end;                                                                  10080000
end;                                                                    10085000
integer procedure xretpmask(n1,n2,n3,pmaskhi,pmasklo);         <<02557>>10090000
   logical pmaskhi,pmasklo;                                    <<02557>>10095000
   byte array n1,n2,n3;                                        <<02557>>10100000
   option privileged,uncallable;                               <<02557>>10105000
                                                               <<02557>>10110000
comment                                                        <<02557>>10115000
                                                               <<02557>>10120000
   procedure to obtain information concerning which parameters <<02557>>10125000
a user has specified in a file equation.  unlike retpmask, it  <<02557>>10130000
traces down the pointer file equations until it reaches the end<<02557>>10135000
of the chain.                                                  <<02557>>10140000
                                                               <<02557>>10145000
input:  n1,n2,n3 -- file name in standard format               <<02557>>10150000
                                                               <<02557>>10155000
output: pmaskhi  -- first word of pmask parameter in file      <<02557>>10160000
                    equation table entry.                      <<02557>>10165000
        pmasklo  -- remaining bits of pmask.                   <<02557>>10170000
                                                               <<02557>>10175000
        retpmask  = 0, ok                                      <<02557>>10180000
                  = 1, entry not found                         <<02557>>10185000
                  = 2, an entry points to a non-existent entry <<02557>>10190000
                                                               <<02557>>10195000
the pmask bit definitions are the same as those listed in      <<02557>>10200000
the header comment for retpmask.                               <<02557>>10205000
                                                               <<02557>>10210000
;   << end of comment >>                                       <<02557>>10215000
                                                               <<02557>>10220000
begin                                                          <<02557>>10225000
integer                                                        <<02557>>10230000
   namesize,   << length of formal name in words >>            <<02557>>10235000
   size;       << return from xretjtentry >>                   <<02557>>10240000
integer array                                                  <<02557>>10245000
   info(0:255);  << file equation entry returned >>            <<02557>>10250000
                                                               <<02557>>10255000
   if (xretpmask := xretjtentry(n1,n2,n3,size,info)) = 0 then  <<02557>>10260000
      begin                                                    <<02557>>10265000
      namesize := info.(8:8);                                  <<02557>>10270000
      pmaskhi := info(namesize + 1);                           <<02557>>10275000
      pmasklo := info(x + 1);                                  <<02557>>10280000
      end;                                                     <<02557>>10285000
                                                               <<02557>>10290000
end;   << of xretjtentry >>                                    <<02557>>10295000
logical procedure searchjcw(goal, jcwadr, jcwvalue);           <<u.rao>>10300000
byte array goal;                                               <<u.rao>>10305000
integer jcwadr,jcwvalue;                                       <<u.rao>>10310000
option privileged,uncallable;                                  <<u.rao>>10315000
begin                                                          <<u.rao>>10320000
<<this procedure searches the jcw table in the jdt for  >>     <<u.rao>>10325000
<<the id "GOAL".                                        >>     <<u.rao>>10330000
<<input:  goal - a byte array containing the name of the>>     <<u.rao>>10335000
<<      desired jcw, with byte 0 being the length.      >>     <<u.rao>>10340000
<<      of the name.                                    >>     <<u.rao>>10345000
<<output: searchjcw - true if found in table else false >>     <<u.rao>>10350000
<<   jcwadr - if search was successful, word offset to  >>     <<u.rao>>10355000
<<            start of entry from start of jdt.         >>     <<u.rao>>10360000
<<   jcwvalue - if search was successful, actual value  >>     <<u.rao>>10365000
<<            of jcw.                                   >>     <<u.rao>>10370000
<<method is a straightforward loop through the table.   >>     <<u.rao>>10375000
integer jdtdst;   <<holds jdt dst number>>                     <<u.rao>>10380000
double jcwtablimits;  <<bounds on jcw part of jdt>>            <<u.rao>>10385000
integer nextjcwadr = jcwtablimits;  <<address of next entry>>  <<u.rao>>10390000
integer jcwtabend = jcwtablimits+1; <<address of end of table>><<u.rao>>10395000
integer array candidatew(0:128);  <<local copy for search>>    <<u.rao>>10400000
byte array candidate(*) = candidatew;                          <<u.rao>>10405000
array qarray(*) = q + 0;                                       <<06595>>10410000
integer pcbglobloc;                                            <<06595>>10415000
searchjcw := false;                                            <<u.rao>>10420000
pxglobal;                                                      <<06595>>10425000
jdtdst := pxg'jdtdst;                                          <<06595>>10430000
<<first get bounds on jcw table>>                              <<u.rao>>10435000
tos := @jcwtablimits;                                          <<u.rao>>10440000
tos := jdtdst;                                                 <<u.rao>>10445000
tos := @jjcwadr;                                               <<u.rao>>10450000
tos := 2;                                                      <<u.rao>>10455000
assemble(mfds);                                                <<u.rao>>10460000
<<next do loop through jcw table>>                             <<u.rao>>10465000
while nextjcwadr < jcwtabend do                                <<u.rao>>10470000
   begin                                                       <<u.rao>>10475000
   <<strategy is 1) make local copy from table, >>             <<u.rao>>10480000
   << 2) compare candidate with goal, >>                       <<u.rao>>10485000
   << 3) if hit, return values else update nextjcwadr>>        <<u.rao>>10490000
   tos := @candidatew;                                         <<u.rao>>10495000
   tos := jdtdst;                                              <<u.rao>>10500000
   tos := nextjcwadr;  <<source address in jdt>>               <<u.rao>>10505000
   <<next we stack transfer count.  it is the min of>>         <<u.rao>>10510000
   <<the space left in the table or 129>>                      <<u.rao>>10515000
   if jcwtabend-nextjcwadr > 129 then                          <<u.rao>>10520000
      tos := 129  <<max possible entry size>>                  <<u.rao>>10525000
   else                                                        <<u.rao>>10530000
      tos := jcwtabend - nextjcwadr;                           <<u.rao>>10535000
   assemble(mfds);                                             <<u.rao>>10540000
   <<now we have the local copy of the entry.  do compare>>    <<u.rao>>10545000
   if goal = candidate, (goal+1) then  <<a hit>>               <<u.rao>>10550000
      begin   <<return values, kill search>>                   <<u.rao>>10555000
      jcwadr := nextjcwadr;                                    <<u.rao>>10560000
      searchjcw := true;                                       <<u.rao>>10565000
      jcwvalue := candidatew(candidate&lsr(1)+1);              <<u.rao>>10570000
      nextjcwadr := jcwtabend;  <<kills while loop>>           <<u.rao>>10575000
      end                                                      <<u.rao>>10580000
   else   <<point to next entry for next loop>>                <<u.rao>>10585000
      nextjcwadr := nextjcwadr+integer(candidate)&lsr(1)+2;    <<u.rao>>10590000
   end;   << of while loop>>                                   <<u.rao>>10595000
end;   <<procedure searchjcw>>                                 <<u.rao>>10600000
procedure findjcw(jcwname, jcwvalue, error);                   <<u.rao>>10605000
byte array jcwname;                                            <<u.rao>>10610000
logical jcwvalue;                                              <<u.rao>>10615000
integer error;                                                 <<u.rao>>10620000
option privileged;   <<callable intrinsic>>                    <<u.rao>>10625000
begin                                                          <<u.rao>>10630000
<<this intrinsic searches the jdt jcw table for jcwname.>>     <<u.rao>>10635000
<<the work is actually done by searchjcw.  this procedure>>    <<u.rao>>10640000
<<primarily checks the parameters.>>                           <<u.rao>>10645000
equate findjcwnum = 86,   <<intrinsic number>>                 <<u.rao>>10650000
       findjcwparms = 3,  <<number of parameters>>             <<u.rao>>10655000
       findjcwmode = [10/findjcwnum, 6/findjcwparms];          <<u.rao>>10660000
integer namelen;   <<holds length of name in bytes>>           <<u.rao>>10665000
byte array copy(0:255);  <<holds local copy of jcwname>>       <<u.rao>>10670000
integer dummy;   <<unused parameter to searchjcw>>             <<u.rao>>10675000
equate   <<possible error returns>>                            <<u.rao>>10680000
   nametoobig = 1,  <<name > 255 characters long>>             <<u.rao>>10685000
   noleadingalpha = 2,  <<name does not start with alpha>>     <<u.rao>>10690000
   jcwnotfound = 3;   <<this id not found in jcw table>>       <<u.rao>>10695000
logical savejir;  <<holds return from lockjir>>                <<u.rao>>10700000
erroron;                                                       <<u.rao>>10705000
chek(findjcwmode, 3, [2/2, 2/2, 2/3]d);                        <<u.rao>>10710000
error := 0;                                                    <<u.rao>>10715000
move jcwname := jcwname while an,1;                            <<u.rao>>10720000
namelen := tos-@jcwname;                                       <<u.rao>>10725000
if namelen > 255 then                                          <<u.rao>>10730000
   error := nametoobig                                         <<u.rao>>10735000
else if jcwname <> alpha then                                  <<u.rao>>10740000
   error := noleadingalpha                                     <<u.rao>>10745000
else  <<no apparent errors, try for value>>                    <<u.rao>>10750000
   begin                                                       <<u.rao>>10755000
   copy := namelen;                                            <<u.rao>>10760000
   move copy(1) := jcwname while ans;  <<upshift>>             <<u.rao>>10765000
   savejir := lockjir;                                         <<u.rao>>10770000
  error := 0;                                                  << 8147>>10775000
   if not searchjcw(copy, dummy, jcwvalue)                     << 8147>>10780000
     then transjcwequate(jcwname,jcwvalue,error,dummy); << kj  << 8147>>10785000
   if error <> 0 then                                          << 8147>>10790000
            error := jcwnotfound;                              << 8147>>10795000
   unlockjir(savejir);                                         <<u.rao>>10800000
   end;                                                        <<u.rao>>10805000
errorexit(findjcwmode, 0, 0);                                  <<u.rao>>10810000
end;                                                           <<u.rao>>10815000
procedure putjcw(jcwname, jcwvalue, error);                    <<u.rao>>10820000
byte array jcwname;                                            <<u.rao>>10825000
logical jcwvalue;                                              <<u.rao>>10830000
integer error;                                                 <<u.rao>>10835000
option privileged;                                             <<u.rao>>10840000
begin                                                          <<u.rao>>10845000
<<this intrinsic updates the value of a jcw in the jdt.>>      <<u.rao>>10850000
<<if an entry for jcwname does not exist, putjcw also  >>      <<u.rao>>10855000
<<creates a new entry.                                 >>      <<u.rao>>10860000
<<input: jcwname is a byte array holding the name of   >>      <<u.rao>>10865000
<<       the desired jcw.  the name must start with an >>      <<u.rao>>10870000
<<       alpha character, be less than 256 characters  >>      <<u.rao>>10875000
<<       long, and be terminated with a non-alphanumeric>>     <<u.rao>>10880000
<<       character.  it may also be "@", in which      >>      <<04.ro>>10885000
<<       case it results in all existing jcw's being   >>      <<04.ro>>10890000
<<       set to jcwvalue.                              >>      <<04.ro>>10895000
<<       jcwvalue is the value to which jcw jcwname is >>      <<u.rao>>10900000
<<       to be set.                                    >>      <<u.rao>>10905000
<<output: error - 0 if no errors occurred              >>      <<u.rao>>10910000
<<                1 if name > 255 characters long      >>      <<u.rao>>10915000
<<                2 if name does not start with an alpha>>     <<u.rao>>10920000
<<                3 if unable to complete due to lack  >>      <<u.rao>>10925000
<<                  of space in jdt.                   >>      <<u.rao>>10930000
<<                4 name has a special jcw meaning     >>      <<04696>>10935000
                                                               <<u.rao>>10940000
integer namelen;  <<# bytes in name>>                          <<u.rao>>10945000
byte namelenb = namelen;  <<for looking at entries>>           <<04.ro>>10950000
array copyw(0:128);  <<contains prototype entry>>              <<u.rao>>10955000
byte array copy(*) = copyw;                                    <<u.rao>>10960000
logical savejir;  <<hold return from lockjir>>                 <<u.rao>>10965000
integer jdtdst;  <<holds dst # for jdt from pxglob>>           <<u.rao>>10970000
integer oldvalue;  <<dummy for searchjcw call - unused>>       <<u.rao>>10975000
integer jcwadr;  <<if valid, entry pointer from searchjcw>>    <<u.rao>>10980000
integer entrysize;  <<length of whole entry in words>>         <<u.rao>>10985000
double dbeqv; << holds the value from intrinsic dbinary >>     <<04696>>10990000
integer segsize;  <<current length of jdt>>                    <<u.rao>>10995000
integer array localjdt(0:numjdtptrs)=q;  <<copy of jdt ptr arra<<u.rao>>11000000
integer localfspcadr = localjdt+numjdtptrs;                    <<u.rao>>11005000
integer localjjcw = localjdt+5;  <<jcw table address>>         <<04.ro>>11010000
array qarray(*) = q + 0;                                       <<06595>>11015000
integer pcbglobloc;                                            <<06595>>11020000
equate nametoobig = 1,                                         <<u.rao>>11025000
       noleadingalpha = 2,                                     <<u.rao>>11030000
       outofspace = 3,                                         <<04696>>11035000
       nameisreserved = 4;                                     <<04696>>11040000
equate putjcwnum = 85,                                         <<u.rao>>11045000
       putjcwparms = 3,                                        <<u.rao>>11050000
       putjcwmode = [10/putjcwnum, 6/putjcwparms];             <<u.rao>>11055000
                                                               <<04696>>11060000
logical subroutine illegalname;                                <<04696>>11065000
<< this subroutine checks to see if the jcwname is a valid>>   <<04696>>11070000
<< jcwvalue.  if so then illegalname becomes true >>           <<04696>>11075000
<< the last 6 jcw's dealing with date and time are being >>    << 8147>>11080000
<< added for t-mit.  if any more system jcw's are added, >>    << 8147>>11085000
<< an array should be set up with each of the names and  >>    << 8147>>11090000
<< the search intrinsic should be used.                  >>    << 8147>>11095000
    begin                                                      <<04696>>11100000
      illegalname := false;                                    <<04696>>11105000
      dbeqv := -1d;                                            <<04696>>11110000
      if jcwname ="OK" and namelen >= 2 then                   <<04696>>11115000
         begin                                                 <<04696>>11120000
           if namelen = 2                                      <<04696>>11125000
              then illegalname := true                         <<04696>>11130000
              else begin                                       <<04696>>11135000
                     dbeqv := dbinary(jcwname(2),namelen-2);   <<04696>>11140000
                     if = and (dbeqv >=0d) and (dbeqv <=65535d)<<04696>>11145000
                        then illegalname := true;              <<04696>>11150000
                   end;                                        <<04696>>11155000
         end                                                   <<04696>>11160000
      else if jcwname ="WARN" and namelen >= 4 then            <<04696>>11165000
              begin                                            <<04696>>11170000
                if namelen = 4                                 <<04696>>11175000
                   then illegalname := true else               <<04696>>11180000
                   begin                                       <<04696>>11185000
                     dbeqv := dbinary(jcwname(4),namelen-4);   <<04696>>11190000
                     if = and(dbeqv >=0d) and (dbeqv <=49151d) <<04696>>11195000
                         then illegalname := true;             <<04696>>11200000
                   end;                                        <<04696>>11205000
         end                                                   <<04696>>11210000
      else if jcwname ="FATAL" and namelen >= 5 then           <<04696>>11215000
              begin                                            <<04696>>11220000
                if namelen = 5                                 <<04696>>11225000
                   then illegalname := true else               <<04696>>11230000
                   begin                                       <<04696>>11235000
                     dbeqv := dbinary(jcwname(5),namelen-5);   <<04696>>11240000
                     if = and(dbeqv >=0d) and (dbeqv <=32767d) <<04696>>11245000
                        then illegalname := true;              <<04696>>11250000
                    end;                                       <<04696>>11255000
         end                                                   <<04696>>11260000
      else if jcwname ="SYSTEM" and namelen >= 6 then          <<04696>>11265000
              begin                                            <<04696>>11270000
                if namelen = 6                                 <<04696>>11275000
                   then illegalname := true else               <<04696>>11280000
                   begin                                       <<04696>>11285000
                     dbeqv := dbinary(jcwname(6),namelen-6);   <<04696>>11290000
                     if = and(dbeqv >=0d) and (dbeqv <= 16383d)<<04696>>11295000
                        then illegalname := true;              <<04696>>11300000
                   end;                                        <<04696>>11305000
         end                                                   << 8147>>11310000
      else if jcwname="HPDAY" and namelen = 5                 <<< 8147>>11315000
              then illegalname := true                         << 8147>>11320000
      else if jcwname="HPDATE" and namelen = 6                <<< 8147>>11325000
              then illegalname := true                         << 8147>>11330000
      else if jcwname="HPMONTH" and namelen = 7               <<< 8147>>11335000
              then illegalname := true                         << 8147>>11340000
      else if jcwname="HPYEAR" and namelen = 6                <<< 8147>>11345000
              then illegalname := true                         << 8147>>11350000
      else if jcwname="HPHOUR" and namelen = 6                <<< 8147>>11355000
              then illegalname := true                         << 8147>>11360000
      else if jcwname="HPMINUTE" and namelen = 8              <<< 8147>>11365000
              then illegalname := true;                        << 8147>>11370000
       end;  << illegalname >>                                 <<04696>>11375000
                                                               <<04696>>11380000
erroron;                                                       <<u.rao>>11385000
chek(putjcwmode, 3, [2/2, 2/2, 2/3]d);                         <<u.rao>>11390000
error := 0;  <<assume no errors>>                              <<u.rao>>11395000
move jcwname := jcwname while an,1;  <<scan for end of name>>  <<u.rao>>11400000
namelen := tos-@jcwname;  <<length in bytes>>                  <<u.rao>>11405000
if namelen>255 then                                            <<u.rao>>11410000
   error := nametoobig                                         <<04.ro>>11415000
else if jcwname = "@" then                                     <<04.ro>>11420000
   begin  <<do all existing jcw's>>                            <<04.ro>>11425000
   <<involves scanning table for all entries>>                 <<04.ro>>11430000
   savejir := lockjir;  << lock down jdt>>                     <<04.ro>>11435000
   pxglobal;                                                   <<06595>>11440000
   jdtdst := pxg'jdtdst;                                       <<06595>>11445000
   <<next get bounds on jcw array from jdt pointers>>          <<04.ro>>11450000
   tos := @localjjcw;                                          <<04.ro>>11455000
   tos := jdtdst;                                              <<04.ro>>11460000
   tos := @jjcwadr;                                            <<04.ro>>11465000
   tos := 2;                                                   <<04.ro>>11470000
   assemble(mfds);                                             <<04.ro>>11475000
   <<next do loop through jcw array, modifying values>>        <<04.ro>>11480000
   while localjjcw < localfspcadr do                           <<04.ro>>11485000
      begin                                                    <<04.ro>>11490000
      tos := @namelen;  <<first get name length>>              <<04.ro>>11495000
      tos := jdtdst;                                           <<04.ro>>11500000
      tos := localjjcw;                                        <<04.ro>>11505000
      tos := 1;                                                <<04.ro>>11510000
      assemble(mfds);                                          <<04.ro>>11515000
      localjjcw := localjjcw+integer(namelenb+2)&lsr(1);       <<04.ro>>11520000
      <<now write new value into table>>                       <<04.ro>>11525000
      tos := jdtdst;                                           <<04.ro>>11530000
      tos := localjjcw;                                        <<04.ro>>11535000
      tos := @jcwvalue;                                        <<04.ro>>11540000
      tos := 1;                                                <<04.ro>>11545000
      assemble(mtds);                                          <<04.ro>>11550000
      localjjcw := localjjcw+1;                                <<04.ro>>11555000
      end;                                                     <<04.ro>>11560000
   unlockjir(savejir);                                         <<04.ro>>11565000
   end <<of "@" case>>                                         <<04.ro>>11570000
else if jcwname <> alpha then                                  <<u.rao>>11575000
   error := noleadingalpha                                     <<u.rao>>11580000
else if illegalname then                                       <<04696>>11585000
   begin                                                       << 8147>>11590000
   if jcwname = "HP"  << must be sys res. jcw >>               << 8147>>11595000
      then error := 5                                          << 8147>>11600000
      else error := nameisreserved;                            << 8147>>11605000
   end                                                         << 8147>>11610000
else                                                           <<04696>>11615000
   begin  <<no apparent errors - set value>>                   <<u.rao>>11620000
   copy := namelen;  <<must put on word bdy, pack>>            <<u.rao>>11625000
   move copy(1) := jcwname while ans;  <<upshift local copy>>  <<u.rao>>11630000
   savejir := lockjir;  <<lock down jdt>>                      <<u.rao>>11635000
   pxglobal;                                                   <<06595>>11640000
   jdtdst := pxg'jdtdst;                                       <<06595>>11645000
   if searchjcw(copy, jcwadr, oldvalue) then                   <<u.rao>>11650000
      begin  <<name exists, just replace value>>               <<u.rao>>11655000
      tos := jdtdst;                                           <<u.rao>>11660000
      tos := jcwadr+namelen&lsr(1)+1;  <<offset to jcwvalue>>  <<u.rao>>11665000
      tos := @jcwvalue;  <<source>>                            <<u.rao>>11670000
      tos := 1;  <<just transfer value>>                       <<u.rao>>11675000
      assemble(mtds);                                          <<u.rao>>11680000
      end                                                      <<u.rao>>11685000
   else   <<name does not exist.  must add name to table>>     <<u.rao>>11690000
      begin                                                    <<u.rao>>11695000
      <<problem is to allocate space to hold new value>>       <<u.rao>>11700000
      <<first check to see if space exists in jdt>>            <<u.rao>>11705000
      entrysize := namelen&lsr(1)+2;                           <<u.rao>>11710000
      segsize := (sys'dst(jdtdst&lsl(2)).(3:13))&lsl(2)-1;     <<u.rao>>11715000
      <<get copy of jdt pointers>>                             <<u.rao>>11720000
      tos := @localjdt;                                        <<u.rao>>11725000
      tos := jdtdst;                                           <<u.rao>>11730000
      tos := @jdtbase;                                         <<u.rao>>11735000
      tos := numjdtptrs+1;                                     <<u.rao>>11740000
      assemble(mfds);                                          <<u.rao>>11745000
      if entrysize+localfspcadr > localjdt then                <<u.rao>>11750000
         error := outofspace                                   <<u.rao>>11755000
      else   <<should be possible to fit in expanded jdt>>     <<u.rao>>11760000
         begin                                                 <<u.rao>>11765000
         if segsize < entrysize+localfspcadr then              <<u.rao>>11770000
            begin   <<need to enlarge segment>>                <<u.rao>>11775000
            altdsegsize(jdtdst,entrysize+localfspcadr-segsize);<<u.rao>>11780000
            if <> then    <<real problem here, perhaps>>       <<u.rao>>11785000
               begin                                           <<u.rao>>11790000
               error := outofspace;                            <<u.rao>>11795000
               unlockjir(savejir);                             <<u.rao>>11800000
               errorexit(putjcwmode, 0, 0);                    <<u.rao>>11805000
               return                                          <<u.rao>>11810000
               end;                                            <<u.rao>>11815000
            end;                                               <<u.rao>>11820000
         <<at this point we know we have enough space in>>     <<u.rao>>11825000
         <<the jdt for the entry.  now move data in>>          <<u.rao>>11830000
         copyw(entrysize-1) := jcwvalue;  <<finalize entry>>   <<u.rao>>11835000
         tos := jdtdst;                                        <<u.rao>>11840000
         tos := localfspcadr;                                  <<u.rao>>11845000
         tos := @copyw;                                        <<u.rao>>11850000
         tos := entrysize;                                     <<u.rao>>11855000
         assemble(mtds);                                       <<u.rao>>11860000
         <<finally update the freespace pointer in the jdt>>   <<u.rao>>11865000
         localfspcadr := localfspcadr+entrysize;               <<u.rao>>11870000
         tos := jdtdst;                                        <<u.rao>>11875000
         tos := @jfreespcadr;                                  <<u.rao>>11880000
         tos := @localfspcadr;                                 <<u.rao>>11885000
         tos := 1;  <<just fixup free space pointer>>          <<u.rao>>11890000
         assemble(mtds);                                       <<u.rao>>11895000
         end;                                                  <<u.rao>>11900000
      end;                                                     <<u.rao>>11905000
   unlockjir(savejir);                                         <<u.rao>>11910000
   end;                                                        <<u.rao>>11915000
errorexit(putjcwmode, 0, 0);                                   <<u.rao>>11920000
end;                                                           <<u.rao>>11925000
logical procedure getjcw;                                      <<u.rao>>11930000
option privileged;                                             <<u.rao>>11935000
<<this callable intrinsic returns the current value of the>>   <<u.rao>>11940000
<<specific jcw "JCW" to the user.>>                            <<u.rao>>11945000
begin                                                          <<u.rao>>11950000
equate getjcwerrmode = [10/73,6/0];                            <<u.rao>>11955000
integer result = getjcw;  <<avoids spl llbl>>                  <<u.rao>>11960000
double name := "JCW ";                                         <<u.rao>>11965000
integer errorrtn;  <<a dummy since should not fail>>           <<u.rao>>11970000
erroron;                                                       <<u.rao>>11975000
findjcw(name, result, errorrtn);                               <<u.rao>>11980000
errorexit(getjcwerrmode, 0, 0);                                <<u.rao>>11985000
end;                                                           <<u.rao>>11990000
procedure setjcw(newjcw);                                      <<u.rao>>11995000
value newjcw;                                                  <<u.rao>>12000000
integer newjcw;                                                <<u.rao>>12005000
<<this callable intrinsic updates jcw "JCW" in the jdt >>      <<u.rao>>12010000
<<to the value newjcw through the intrinsic putjcw.>>          <<u.rao>>12015000
begin                                                          <<u.rao>>12020000
equate setjcwerrmode = [10/72, 6/1];                           <<u.rao>>12025000
double name := "JCW ";                                         <<u.rao>>12030000
integer errorrtn;  <<a dummy>>                                 <<u.rao>>12035000
erroron;                                                       <<u.rao>>12040000
putjcw(name, newjcw, errorrtn);                                <<u.rao>>12045000
errorexit(setjcwerrmode, 0, 0);                                <<u.rao>>12050000
end;                                                           <<u.rao>>12055000
$control segment=main                                          <<u.rao>>12060000
end.                                                           <<u.rao>>12065000
