<< LINES .001/.009 ARE RESERVED FOR SYSTEMS INTEGRATION>>               00005000
$control map,code,uslinit                                               00010000
<< checker -- module 69 >>                                              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
$control segment=checker                                                00055000
$thirty                                                                 00060000
                                                                        00065000
                                                                        00070000
begin                                                                   00075000
                                                               <<06738>>00080000
$include inclsir                                               <<06738>>00085000
define                                                         <<06647>>00090000
   owner = resource#,                                          <<*7762>>00095000
   head  = resource(1)#,                                       <<06647>>00100000
   tail  = resource(2)#,                                       <<06647>>00105000
   qlen  = resource(3)#;                                       <<06647>>00110000
$include inclpcb5                                              <<06647>>00115000
                                                                        00120000
                                                                        00125000
pointer pcb=3;                                                 <<image>>00130000
integer s0 = s-0;                                              <<06665>>00135000
                                                               <<image>>00140000
define iqptr=(8:8)#,                                           <<image>>00145000
       f=absolute#,                                            <<image>>00150000
       mypinnumber=(curprc)/pcbsize#;                          <<06647>>00155000
                                                               <<image>>00160000
                                                               <<image>>00165000
define                                                         <<07315>>00170000
   pdisable  = assemble(psdb)#,                                <<*7556>>00175000
   penable   = assemble(pseb)#,                                <<*7556>>00180000
   disable   = assemble(sed 0)#,                               <<07315>>00185000
   enable    = assemble(sed 1)#;                               <<07315>>00190000
                                                               <<07315>>00195000
                                                               <<image>>00200000
define syssegflag=(6:1)#;                                      <<01549>>00205000
double pointer measbuf=db+%17;                                 <<01549>>00210000
                                                                        00215000
define logicalmapping = logical(absolute(%1220))#;             <<06101>>00220000
                                                               <<06101>>00225000
equate dstix=2;                                                <<06101>>00230000
integer pointer dst=dstix;                                     <<06101>>00235000
array qarray(*) = q+0;                                         <<*7762>>00240000
$include inclpxdl                                              <<*7762>>00245000
$include inclpxft                                              <<*7762>>00250000
$include inclpxgt                                              <<*7762>>00255000
procedure wait(wf,jpcntx);value wf,jpcntx;integer wf,jpcntx;            00260000
option external;                                                        00265000
                                                                        00270000
<<------------------------------------------------------------------->> 00275000
integer procedure sysproc(lp);value lp;integer lp;option external;      00280000
                                                                        00285000
<<------------------------------------------------------------------->> 00290000
logical procedure setcritical; option external;                         00295000
                                                                        00300000
<<------------------------------------------------------------------->> 00305000
logical procedure exchangedb(a);value a;logical a;option external;      00310000
                                                                        00315000
<<------------------------------------------------------------------->> 00320000
procedure resetcritical(a);value a;logical a;option external;           00325000
                                                                        00330000
<<------------------------------------------------------------------->> 00335000
logical procedure getsir(a);value a;logical a;option external;          00340000
                                                                        00345000
<<------------------------------------------------------------------->> 00350000
procedure relsir(a,b);value a,b;logical a,b;option external;            00355000
                                                                        00360000
<<------------------------------------------------------------------->> 00365000
logical procedure setsysdb; option external;                            00370000
                                                                        00375000
<<------------------------------------------------------------------->> 00380000
procedure resetdb(a);value a;logical a;option external;                 00385000
                                                                        00390000
<<------------------------------------------------------------------->> 00395000
procedure  awake(p,n,w);  value p,n,w;  integer p,n,w;                  00400000
option external;                                                        00405000
                                                                        00410000
<<------------------------------------------------------------------->> 00415000
procedure abort(a,b,c);value a,b,c;logical a,b,c;option external;       00420000
                                                                        00425000
<<------------------------------------------------------------------->> 00430000
procedure suddendeath(a); value a; integer a; option external;          00435000
                                                                        00440000
<<------------------------------------------------------------------->> 00445000
procedure help; option external;                                        00450000
                                                                        00455000
<<------------------------------------------------------------------->> 00460000
                                                                        00465000
procedure impaired(a,b,c); value a,b,c; integer a,b; logical c;<<image>>00470000
option privileged,uncallable,external;                         <<image>>00475000
procedure unimpede(a); value a; integer a;                     <<image>>00480000
option privileged,uncallable,external;                         <<image>>00485000
procedure impede(p); value p; integer p;                       <<00085>>00490000
option external;                                               <<00085>>00495000
                                                               <<image>>00500000
                                                                        00505000
double procedure timer;                                        <<01549>>00510000
option external;                                               <<01549>>00515000
                                                                        00520000
                                                                        00525000
integer procedure cstconv(plabel,pcbpt);                       <<06101>>00530000
   value plabel,pcbpt;                                         <<06101>>00535000
   integer plabel,pcbpt;                                       <<06101>>00540000
   option external;                                            <<06101>>00545000
                                                               <<06101>>00550000
logical procedure system(cstn);                                <<06101>>00555000
   value cstn;                                                 <<06101>>00560000
   integer cstn;                                               <<06101>>00565000
   option external;                                            <<06101>>00570000
                                                                        00575000
double procedure proctime;                                              00580000
option privileged;                                                      00585000
                                                                        00590000
                                                                        00595000
comment: returns a double word which is the running time                00600000
         of the caller process in milliseconds.                         00605000
      ;                                                                 00610000
                                                                        00615000
                                                                        00620000
begin                                                                   00625000
                                                                        00630000
      logical pxfixedloc;                                      <<06665>>00635000
      integer x=x;                                                      00640000
                                                                        00645000
                                                                        00650000
      pxfixed;                                                 <<06665>>00655000
      assemble(sed 0);                                                  00660000
      tos:=pxfxpcputime1;                                      <<06665>>00665000
      tos:=pxfxpcputime2;                                      <<06665>>00670000
      tos := 0;                                                         00675000
      assemble( rclk; dadd );                                           00680000
      proctime := tos;                                                  00685000
                                                                        00690000
                                                                        00695000
end;  << p r o c t i m e  >>                                            00700000
                                                                        00705000
                                                                        00710000
<<------------------------------------------------------------------->> 00715000
                                                                        00720000
                                                                        00725000
                                                                        00730000
                                                                        00735000
                                                                        00740000
                                                                        00745000
          << >>                                                         00750000
          <<run time (abort) errors.                                    00755000
               - increment error level                                  00760000
               - clear error word      >>                               00765000
          << >>                                                         00770000
procedure erroron;                                                      00775000
  option  privileged,uncallable;                                        00780000
  begin                                                                 00785000
          equate     cpcb=4,                                            00790000
                     syxl=9,                                            00795000
                     sysl=3;                                            00800000
          define     sysf=(11:1)#;                                      00805000
          define     syxf=(6:1)#;                                       00810000
          define     trapfld=(2:1)#;                                    00815000
          define pcbpt = curprc#;                              <<*7762>>00820000
          integer pxfixedloc;                                  <<*7762>>00825000
          logical status=q-1;                                           00830000
          integer index;                                       <<*7762>>00835000
          << >>                                                         00840000
      <<  if absolute(%1430).(2:1) then help;  >>              <<*7762>>00845000
          status.trapfld:=0;        <<turn off traps>>                  00850000
          if procstate.systemprocflag then return;             <<06647>>00855000
          pxfixed;                                             <<06665>>00860000
          tos:=pxfxerrlevel;                                   <<06665>>00865000
          if = then stkinfo.insystemflag := 1;                 <<06739>>00870000
          tos:=tos+1;                                                   00875000
          assemble(dup,dup);                                            00880000
          pxfxerrlevel:=tos;                                   <<06665>>00885000
          index:=tos;                                          <<06665>>00890000
          tos:=tos-6;                                                   00895000
          if > then return;                                             00900000
          if < then                                                     00905000
               begin pxfxintrerr:=0;                           <<06665>>00910000
                     index:=index+1;                           <<06665>>00915000
               end;                                                     00920000
          pxfxintrerr:=0;                                      <<06665>>00925000
  end;                                                                  00930000
                                                                        00935000
                                                                        00940000
<<------------------------------------------------------------------->> 00945000
                                                                        00950000
                                                                        00955000
                                                                        00960000
                                                                        00965000
                                                                        00970000
                                                                        00975000
          << >>                                                         00980000
          <<run time (abort) errors.                                    00985000
               - get error word from relative level                     00990000
               - 0 if invalid level or index   >>                       00995000
          << >>                                                         01000000
logical procedure errorget(l);                                          01005000
  value   l;                                                            01010000
  integer l;                                                            01015000
  option  privileged,uncallable;                                        01020000
  begin                                                                 01025000
          equate     cpcb=4,                                            01030000
                     syxl=9;                                            01035000
          define     syxf=(6:1)#;                                       01040000
          define pcbpt = curprc#;                              <<*7762>>01045000
          integer pxfixedloc;                                  <<*7762>>01050000
          integer index;                                       <<*7762>>01055000
          << >>                                                         01060000
          if procstate.systemprocflag then return;             <<06647>>01065000
          if l<0 then                                                   01070000
               begin tos:=0;                                            01075000
                     goto fin;                                          01080000
               end;                                                     01085000
          pxfixed;                                             <<06665>>01090000
          tos:=pxfxerrlevel+logical(l);                        <<06665>>01095000
          assemble(dup);                                                01100000
          if tos>6 then                                                 01105000
               begin tos:=0;                                            01110000
                     goto fin;                                          01115000
               end;                                                     01120000
          index:=tos;                                          <<06665>>01125000
          tos:=pxfxintrerr;                                    <<l7554>>01130000
  fin:    errorget:=tos;                                       <<l7554>>01135000
  end;                                                                  01140000
                                                                        01145000
                                                                        01150000
<<------------------------------------------------------------------->> 01155000
                                                                        01160000
                                                                        01165000
                                                                        01170000
                                                                        01175000
                                                                        01180000
                                                                        01185000
          << >>                                                         01190000
          <<run time (abort) errors.                                    01195000
               - put error word into rel level   >>                     01200000
          << >>                                                         01205000
procedure errorput(errword,l);                                          01210000
  value   errword,l;                                                    01215000
  integer errword,l;                                                    01220000
  option  privileged,uncallable;                                        01225000
  begin                                                                 01230000
          equate     cpcb=4,                                            01235000
                     syxl=9;                                            01240000
          define     syxf=(6:1)#;                                       01245000
          define pcbpt = curprc#;                              <<*7762>>01250000
          integer pxfixedloc;                                  <<*7762>>01255000
          integer index;                                       <<*7762>>01260000
          << >>                                                         01265000
          if procstate.systemprocflag then return;             <<06647>>01270000
          pxfixed;                                             <<06665>>01275000
          index:=logical(l)+pxfxerrlevel;                      <<06665>>01280000
          if not(1<= index <=6) then return;                   <<*7762>>01285000
          pxfxintrerr:=errword;                                <<06665>>01290000
  end;                                                                  01295000
                                                                        01300000
<<------------------------------------------------------------------->> 01305000
                                                                        01310000
                                                                        01315000
                                                                        01320000
                                                                        01325000
                                                                        01330000
                                                                        01335000
          << >>                                                         01340000
          <<run time (abort) errors.                                    01345000
               if stov flag set then abort                              01350000
                     if error level<=1                                  01355000
               if intrinsic # = 99 then ignore carry and no abort       01360000
               if errword <>0 then (error)                              01365000
                     -insert error word                                 01370000
                     -if intrinsic # =0 do not abort                    01375000
                     -if error level <=1 then abort                     01380000
               reset q:=q-deltaq                                        01385000
               carry bit in  status:= 1 if error                        01390000
                                   := 0 if no error                     01395000
               decrement error level                                    01400000
               exit through this previous stack marker                  01405000
                 using parameter count(n)                               01410000
                                                                        01415000
               intrinexit.(0:10)   = intrinsic error #                  01420000
                         .(10:6)   = parameter count (n)                01425000
               errword .(0:8)      = parameter                          01430000
                       .(8:8)      = error byte                         01435000
               param = additional info if abort occurs     >>           01440000
          << >>                                                         01445000
procedure errorexit(intrinexit,errword,param);                          01450000
  value   intrinexit,errword,param;                                     01455000
  logical intrinexit,errword,param;                                     01460000
  option  privileged,uncallable;                                        01465000
  begin                                                                 01470000
          equate type=1, mark=2, mode=[8/mark,8/type];                  01475000
          equate sotype=0, socode=20, somode=[8/mark,8/sotype];         01480000
          equate     cpcb=4,                                            01485000
                     sysl=3,                                            01490000
                     syxl=9,                                            01495000
                     stovl=9;                                           01500000
          define     stovf=(5:1)#;                                      01505000
          define     syxf=(6:1)#;                                       01510000
          define     sysf=(11:1)#;                                      01515000
          define     ifld= (0:10)#,                                     01520000
                     nfld =(10:6)#,                                     01525000
                     cfld =(5:1)#;                                      01530000
          array qarray(*)=q+0;                                 <<06665>>01535000
          integer pxfixedloc;                                  <<*7762>>01540000
          integer index;                                       <<*7762>>01545000
          integer pcbpt;                                       <<*7762>>01550000
          integer karry:=0;                                             01555000
          logical deltaq=q+0, status=q-1;                               01560000
          << >>                                                         01565000
          pcbpt := curprc;                                     <<06647>>01570000
      <<  if absolute(%1430).(0:1) then help;     >>           <<*7762>>01575000
          if procstate.systemprocflag then goto cont;          <<06647>>01580000
          pxfixed;                                             <<06665>>01585000
          tos:=pxfxerrlevel;            <<decr error level>>   <<06665>>01590000
          if <= then                                                    01595000
               begin tos:=tos+1;                                        01600000
                     index:=0;                                 <<06665>>01605000
                     pxfxintrerr:=0;                           <<06665>>01610000
                     index:=1;                                 <<06665>>01615000
                     pxfxintrerr:=0;                           <<06665>>01620000
               end;                                                     01625000
          tos:=tos-1;                                                   01630000
          assemble(dup,dup);                                            01635000
          pxfxerrlevel:=tos;                                   <<06665>>01640000
          assemble(test);                                               01645000
          if > then goto contx;    <<stack ovflw check>>                01650000
          stkinfo.insystemflag := 0;                           <<06647>>01655000
          if procstate.stovflag                                <<06647>>01660000
          then                                                 <<04488>>01665000
             begin                                             <<04488>>01670000
             comment: let kernel routines know process is      <<04488>>01675000
                aborting.  note that errorexit doesn't check   <<04488>>01680000
                stovabort bit since currently stov->abort->debu<<04488>>01685000
                ->errorexit must result in another call to     <<04488>>01690000
                abort. stovabort bit is left on to allow you   <<04488>>01695000
                to get into debug. we count on last call to    <<04488>>01700000
                errorexit to catch stov. and go back to abort; <<04488>>01705000
             disable;                                          <<07315>>01710000
             procstate.stovflag := 0; << must turn this off!!>><<07315>>01715000
             resabortinfo.stovabortflag := 1;                  <<06647>>01720000
             enable;                                           <<07315>>01725000
             abort(somode,socode,0);                           <<04488>>01730000
             end;                                              <<04488>>01735000
  contx:  tos:=errword;             <<error word>>                      01740000
          if = then goto cont;     <<no error>>                         01745000
          karry:=1;                                                     01750000
          assemble(xch,dup);                                            01755000
          if tos>=6 then                                                01760000
               begin del;                                               01765000
                     tos:=5;                                            01770000
               end;                                                     01775000
          index:=tos+1;                                        <<06665>>01780000
          pxfxintrerr:=tos;            <<put error word>>      <<06665>>01785000
          assemble(test);                                               01790000
          if > then goto cont;     <<nested error >>                    01795000
          if intrinexit.ifld=0 then goto cont;                          01800000
          abort(mode,intrinexit,param);                                 01805000
  cont:   tos:=%031400;             <<exit instruction>>                01810000
          tos:=tos lor intrinexit.nfld;                                 01815000
          tos:=karry;                                                   01820000
          tos := intrinexit.ifld;                                       01825000
          assemble( sed 0 );                                            01830000
          push(q);                                                      01835000
          tos:=deltaq;                                                  01840000
          tos:=tos-tos;                                                 01845000
          set(q);                                                       01850000
          if  tos = 99  then  del  else  status.cfld := tos;            01855000
          assemble(xeq 0);         << e x i t  n >>                     01860000
          help;   << debug linking call >>                              01865000
  end;                                                                  01870000
                                                                        01875000
<<------------------------------------------------------------------->> 01880000
                                                                        01885000
                                                                        01890000
                                                                        01895000
                                                                        01900000
                                                                        01905000
                                                                        01910000
double procedure chek (intrinsic, flags, parms, capmask, optvmask);     01915000
                                                                        01920000
   value intrinsic, flags, parms, capmask, optvmask;                    01925000
   logical intrinsic, flags, optvmask;                                  01930000
   double parms, capmask;                                               01935000
   option variable, privileged, uncallable;                             01940000
begin                                                                   01945000
<< parameter equivalences >>                                            01950000
   logical pmask = q-4;                                                 01955000
   define                                                               01960000
      wdsofparms        = integer (intrinsic.(10:6))#,                  01965000
      anydb        = flags & csl(1) #,                                  01970000
      wdsoftype         = integer (flags.(8:2)) #,                      01975000
      caporcheck   = flags & lsr(5) #,                                  01980000
      numparms          = integer (flags.(11:5)) #;                     01985000
   logical                                                              01990000
      cap1              = capmask,                                      01995000
      cap2              = cap1+1;                                       02000000
<< hang codes >>                                                        02005000
   equate                                                               02010000
      illdb             = 1,       <<illegal db>>                       02015000
      illcap            = 2,       <<illegal capability>>               02020000
      omittedparm       = 3,       <<omitted parameter>>                02025000
      illcall           = 4,       <<incorrect s-register>>             02030000
      boundsviol        = 5;       <<parameter address violation>>      02035000
<< misc & system stuff >>                                               02040000
   integer pxfixedloc;                                         <<*7762>>02045000
   integer pcbglobloc;                                         <<06665>>02050000
   integer xreg = x;                                                    02055000
   integer deltaq = q;                                                  02060000
   integer                                                              02065000
      s0 = s-0,                                                         02070000
      s1 = s-1,                                                         02075000
      s2 = s-2;                                                         02080000
   logical                                                              02085000
      ls0 = s-0;                                                        02090000
   logical array                                                        02095000
      lq0arr (*) = q-0,                                                 02100000
      lq1arr (*) = q-1,                                                 02105000
      lq3arr (*) = q-3,                                                 02110000
      lq4arr (*) = q-4;                                                 02115000
   integer array                                                        02120000
      dbarr (*) = db+0,                                                 02125000
      q1arr (*) = q-1,                                                  02130000
      q2arr (*) = q-2;                                                  02135000
   integer pointer                                                      02140000
      dst = 2,                                                          02145000
      ics = 7,                                                 <<*7762>>02150000
      cst = 1;                                                          02155000
   define getsysseg = & lsr (4)  #;                                     02160000
   equate cpcb = 4;                                                     02165000
   equate cheksa = 6;                                                   02170000
   logical status = q-1;                                                02175000
   define carrycc = status.(5:3) #;                                     02180000
   equate ccg = 0,   ccl = 1,   cce = 2;                       <<01200>>02185000
<< random variables >>                                                  02190000
   define pcbpt = curprc#;                                     <<*7762>>02195000
   integer parmp;                                              <<*7762>>02200000
   integer pcnt := 1;                                                   02205000
   logical dbstack := true;                                             02210000
   logical no'abort := false; << flag for special entry pt >>  <<*7762>>02215000
   double lims = q-13;    <<chek return>>                               02220000
   integer                                                              02225000
      lowlim = lims,                                                    02230000
      uplim = lims+1;                                                   02235000
   switch parmswitch :=                                                 02240000
      skip1, skip2, wordaddr, byteaddr;                                 02245000
                                                               <<01200>>02250000
   entry chek'noabort;          << chek with minimal aborts >> <<01200>>02255000
   label start;                 << common code for entry pts >><<01200>>02260000
                                                                        02265000
                                                                        02270000
<< >>                                                                   02275000
   goto start;                                                 <<01200>>02280000
                                                               <<01200>>02285000
<< chek'noabort is an entry point which will not abort the   >><<01200>>02290000
<< calling process as often as chek does.  chek'noabort will >><<01200>>02295000
<< only abort the calling process if it is in split stack    >><<01200>>02300000
<< mode or if the address of the 'error' parameter is bad or >><<01200>>02305000
<< if the 'error' parameter is omitted.  note that it is     >><<01200>>02310000
<< assumed that the 'error' parameter is the 1st paramter in >><<01200>>02315000
<< the calling sequence of the intrinsic calling             >><<01200>>02320000
<< chek'noabort.  cce indicates all parameters checked out   >><<01200>>02325000
<< ok.  ccl indicates an error condition.  the exact error   >><<01200>>02330000
<< is reported in the intrinsic error reporting area of the  >><<01200>>02335000
<< pxfixed area of the pcbx.  the error codes are the same   >><<01200>>02340000
<< as those used to abort the process (e.g. 2 = incorrect    >><<01200>>02345000
<< capability, etc.  see previous page).                     >><<01200>>02350000
chek'noabort:                                                  <<01200>>02355000
   no'abort := true;                                           <<01200>>02360000
                                                               <<01200>>02365000
start:                                                         <<*7762>>02370000
                                                               <<*7762>>02375000
   << calulate -( q disp of user s ) >>                        <<*7762>>02380000
   parmp := -( deltaq+wdsofparms+wdsoftype+4);                 <<*7762>>02385000
                                                               <<*7762>>02390000
   << check if db is at stack by comparing   >>                <<*7762>>02395000
   << present db with that at time of launch >>                <<*7762>>02400000
   disable;                                                    <<*7762>>02405000
   push( db, sbank );                                          <<*7762>>02410000
   tos := ics(-4);                                             <<*7762>>02415000
   enable;                                                     <<*7762>>02420000
   assemble( dcmp );                                           <<*7762>>02425000
   if <> then                                                  <<*7762>>02430000
      begin  << db is not at stack >>                          <<*7762>>02435000
      << note: db must be a logical data segment, however. >>  <<*7762>>02440000
      if not(anydb) then                                       <<*7762>>02445000
         begin                                                 <<*7762>>02450000
         tos := illdb;                                         <<*7762>>02455000
         no'abort := false;                                    <<*7762>>02460000
         goto hangit0;                                         <<*7762>>02465000
         end;                                                  <<*7762>>02470000
      tos := dst(dbxdsinfo.xdsdstfield&asl(2));                <<*7762>>02475000
      uplim := tos.(3:13)&asl(2)-1; << xdst seg size >>        <<*7762>>02480000
      lowlim := 0;                                             <<*7762>>02485000
      dbstack := false;                                        <<*7762>>02490000
      tos := 4;  << status - carry bit >>                      <<*7762>>02495000
      end                                                      <<*7762>>02500000
   else                                                        <<*7762>>02505000
      begin  << db is at stack >>                              <<*7762>>02510000
      uplim := @lq0arr + parmp;                                <<*7762>>02515000
      push( dl );                                              <<*7762>>02520000
      lowlim := tos;                                           <<*7762>>02525000
      tos := 0;  << status - carry bit >>                      <<*7762>>02530000
      end;                                                     <<*7762>>02535000
                                                               <<*7762>>02540000
   << determime if intrinsic called by system code >>          <<*7762>>02545000
                                                               <<*7762>>02550000
   tos := lq1arr(-deltaq).(8:8); << seg number >>              <<*7762>>02555000
   tos.(0:1) := if logicalmapping then q2arr(-deltaq).(1:1)    <<*7762>>02560000
                   else 1;                                     <<*7762>>02565000
   xreg := tos;                                                <<*7762>>02570000
   if system( xreg ) then                                      <<*7762>>02575000
      begin                                                    <<*7762>>02580000
      tos := tos+ccg;                                          <<*7762>>02585000
      carrycc := tos;                                          <<*7762>>02590000
      return;                                                  <<*7762>>02595000
      end;                                                     <<*7762>>02600000
   tos := tos+cce;                                             <<*7762>>02605000
   carrycc := tos;                                             <<*7762>>02610000
                                                               <<*7762>>02615000
   << capability check >>                                      <<*7762>>02620000
                                                               <<*7762>>02625000
   if pmask & lsr(1) then                                               02630000
      begin                                                             02635000
      pxglobal;                                                <<06665>>02640000
      tos := pxg'userattributes land cap1;                     <<06665>>02645000
   pxfixed;                                                    <<06665>>02650000
      tos := pxfxcap land cap2;                                <<06665>>02655000
      if caporcheck then                                                02660000
         begin    <<"OR" check: 1 must be on >>                         02665000
         assemble (dtst, ddel);                                         02670000
         if = then                                                      02675000
illhang:    begin                                                       02680000
            tos := illcap;                                              02685000
            goto hangit0;                                               02690000
            end;                                                        02695000
         end                                                            02700000
      else    <<"AND" check: all required must be on>>                  02705000
         if tos <> capmask then goto illhang;                           02710000
      end;                                                              02715000
<< check option variable >>                                             02720000
   if pmask then                                                        02725000
      if (lq4arr(-deltaq) lor optvmask) <> not ((-1) & lsl(numparms))   02730000
      then                                                              02735000
         begin                                                          02740000
         tos := omittedparm;                                            02745000
         tos :=(not (lq4arr (-deltaq) lor optvmask))& lsl (16-numparms);02750000
         assemble (                                                     02755000
            scan 0;                                                     02760000
            xax, inca);                                                 02765000
         << force abort if 1st parameter was omitted >>        <<01200>>02770000
         if s0 = 1 then no'abort := false;                     <<01200>>02775000
         goto hangit;                                                   02780000
         end;                                                           02785000
<< valid call?    (i.e. user s >= dl+3) >>                              02790000
   push (q, dl);                                                        02795000
   assemble (sub, neg);    << -(q displ. of dl) >>                      02800000
   if tos+3 > parmp then                                                02805000
      begin                                                             02810000
      tos := illcall;                                                   02815000
      goto hangit0;                                                     02820000
      end;                                                              02825000
<< check parameter bounds >>                                            02830000
   if not (pmask & lsr(2)) then goto exit;                              02835000
   tos := parms;                                                        02840000
   if = then goto exit;                                                 02845000
   parmp := parmp+wdsoftype+1;                                          02850000
   do begin                                                             02855000
      tos := ls0 land 3;                                                02860000
      if pmask and not (lq4arr(-deltaq) & lsr (numparms-pcnt)) then     02865000
         begin                                                          02870000
         if tos <> 1 then goto skip1;                                   02875000
         goto skip2;                                                    02880000
         end;                                                           02885000
      goto * parmswitch (tos);                                          02890000
      wordaddr:                                                         02895000
         xreg :=lq0arr (parmp);                                         02900000
         goto checkparm;                                                02905000
      byteaddr:                                                         02910000
         tos := lq0arr(parmp) & lsr(1);                                 02915000
         if dbstack and s0 > uplim then assemble (tsbc 0);              02920000
         xreg := tos;                                                   02925000
      checkparm:                                                        02930000
         tos := lims;                                                   02935000
         assemble (cprb skip1);                                         02940000
            begin                                                       02945000
            tos := boundsviol;                                          02950000
            tos := pcnt;                                                02955000
            << force abort if 1st parameter out of bounds >>   <<01200>>02960000
            if s0 = 1 then no'abort := false;                  <<01200>>02965000
            goto hangit;                                                02970000
            end;                                                        02975000
      skip2:                                                            02980000
         parmp := parmp+1;                                              02985000
      skip1:                                                            02990000
         parmp := parmp+1;                                              02995000
         pcnt := pcnt+1;                                                03000000
         tos := tos & dlsr(2);                                          03005000
      end                                                               03010000
   until =;                                                             03015000
exit:                                                                   03020000
   return;                                                              03025000
<< go hang >>                                                           03030000
hangit0:                                                                03035000
   tos := 0;                                                            03040000
hangit:                                                                 03045000
   tos := intrinsic;                                                    03050000
   assemble (cab, cab);                                                 03055000
   tos:=tos&lsl(8);                                                     03060000
   tos:=tos lor tos;                                                    03065000
   tos:=0;                                                              03070000
   if no'abort then                                            <<01200>>03075000
      begin  << do not abort calling process >>                <<01200>>03080000
      erroron;   << so errorexit won't abort >>                <<01200>>03085000
      carrycc := ccl;                                          <<01200>>03090000
      end                                                      <<01200>>03095000
   else                                                        <<01200>>03100000
      begin  << abort calling process >>                       <<01200>>03105000
      << cut back 1 stack marker to effect return to user >>   <<01200>>03110000
      disable;                                                 <<*7911>>03115000
      push (q);                                                <<01200>>03120000
      tos := tos - deltaq;                                     <<01200>>03125000
      set (q);                                                 <<01200>>03130000
      enable;                                                  <<*7911>>03135000
      end;                                                     <<01200>>03140000
   << either abort caller or return to intrinsic with error  >><<01200>>03145000
   << reported in the pxfixed area of pcbx.                  >><<01200>>03150000
   errorexit(*,*,*);                                                    03155000
   end    <<chek>>;                                                     03160000
                                                                        03165000
<<------------------------------------------------------------------->> 03170000
                                                                        03175000
                                                                        03180000
                                                                        03185000
                                                                        03190000
                                                                        03195000
                                                                        03200000
                                                                        03205000
procedure requcop(request,pin,uwait);                                   03210000
value request,pin,uwait; logical request,pin,uwait;                     03215000
option privileged,uncallable;                                           03220000
                                                                        03225000
comment: sets a request for ucop.                                       03230000
         uwait means that the requestor goes in wait mode until         03235000
         the request has been executed.                                 03240000
         does not set critical bit.                                     03245000
         ;                                                              03250000
                                                                        03255000
begin                                                                   03260000
      equate urldsn=9;                                                  03265000
                                                                        03270000
      logical db;                                                       03275000
      integer p1,p2,x=x;                                                03280000
      double array ur(*)=db+0;                                          03285000
      integer array url(*)=db+0;                                        03290000
                                                                        03295000
      tos:=request;                                                     03300000
      tos:=pin;                                                         03305000
      db:=exchangedb(urldsn);                                           03310000
                                                                        03315000
      <<test for url overload:>>                                        03320000
      disable;                                                          03325000
      p1:=url(1);                                                       03330000
      p2:=url(2);                                                       03335000
      if (p2-p1)=1 or p1-p2=url(0)+2 then                               03340000
      begin         <<overload>>                                        03345000
         suddendeath(1);                                                03350000
      end else                                                          03355000
      begin                                                             03360000
         x:=p1;                                                         03365000
         ur(x):=tos;           <<set request>>                          03370000
         url(1):=if url(1)=url(0)+1 then 2 else url(1)+1;      <<06051>>03375000
         awake( sysproc(2),%20,if uwait then %40 else 0 );              03380000
         if < and uwait then wait(%40,0);                               03385000
         enable;                                                        03390000
         exchangedb(db);                                                03395000
      end;                                                              03400000
end;  <<requcop>>                                                       03405000
<<------------------------------------------------------------------->> 03410000
                                                                        03415000
                                                                        03420000
                                                                        03425000
                                                                        03430000
                                                                        03435000
                                                                        03440000
                                                                        03445000
                                                                        03450000
                                                                        03455000
procedure getprivmode;                                                  03460000
option privileged;                                                      03465000
                                                                        03470000
comment: get privileged mode for the code to be rin by the caller,      03475000
         by means of changing the privileged mode bit in the            03480000
         status.                                                        03485000
                                                                        03490000
         returns                                                        03495000
            cce   if ok                                                 03500000
            ccg   if already in privileged mode.                        03505000
                                                                        03510000
         error code: 200.                                               03515000
      ;                                                                 03520000
                                                                        03525000
                                                                        03530000
                                                                        03535000
begin                                                                   03540000
      equate cce=2,ccg=0,cstb=0,cstxb=1;                                03545000
      equate errn=200, exitn=0;                                         03550000
      equate errex=[10/errn,6/exitn];                                   03555000
      integer x=x,status=q-1,cstx,cc;                                   03560000
      integer deltap = q-2;                                    <<06101>>03565000
      erroron;                                                          03570000
                                                                        03575000
      tos:=0;<<for cstconv returned value>>                             03580000
      tos:=status;                                             <<06101>>03585000
      if logicalmapping then tos.(0:1):=deltap.(1:1);          <<06101>>03590000
      x:=cstconv(*,0);                                         <<06101>>03595000
      tos:=dst(x);                                             <<06101>>03600000
      tos:=tos&csl(2);                 <<privileged mode bit>>          03605000
      if tos then goto pm1;            <<already in priv mode>>         03610000
      chek(errex,%100040,,double(%100));                                03615000
pm1:  tos:=status;                                                      03620000
      assemble(dup);                                                    03625000
      if tos<0 then cc:=ccg else                                        03630000
      begin                                                             03635000
         cc:=cce;                                                       03640000
         tos.(0:1):=1;                 <<privileged mode on>>           03645000
      end;                                                              03650000
      tos.(6:2):=cc;                   <<store of cond code>>           03655000
      status:=tos;                                                      03660000
      errorexit(errex,0,0);                                             03665000
                                                                        03670000
end;  << g e t p r i v m o d e  >>                                      03675000
                                                                        03680000
<<------------------------------------------------------------------->> 03685000
                                                                        03690000
                                                                        03695000
                                                                        03700000
                                                                        03705000
procedure getusermode;                                                  03710000
option privileged;                                                      03715000
                                                                        03720000
comment: get user mode in status (privileged mode turned off)           03725000
         returns                                                        03730000
         cce   if ok                                                    03735000
         ccg   if already in user mode.                                 03740000
                                                                        03745000
         error code: 201.                                               03750000
      ;                                                                 03755000
                                                                        03760000
                                                                        03765000
begin                                                                   03770000
     equate ccg=0, cce=2;                                               03775000
      equate  cpcb=4;                                          <<06665>>03780000
      equate deltaq=0, ploc=-2;                                <<00423>>03785000
      equate errn=201, exitn=0;                                         03790000
      equate errex=[10/errn,6/exitn];                                   03795000
      logical pxfixedloc;                                      <<06665>>03800000
      integer cc;                                                       03805000
      integer initq; <<height of stack before 1st marker>>     <<00423>>03810000
      define pcbpt = curprc#;                                  <<*7762>>03815000
      integer x=x;                                             <<00423>>03820000
      integer s0=s-0;                                          <<00423>>03825000
      logical status=q-1;                                      <<00423>>03830000
      logical p=q-2;                                           <<00423>>03835000
      pointer stackmarker;                                     <<00423>>03840000
      pointer cst = 1;                                         <<00423>>03845000
      define sysbit = (6:1)#;                                  <<04487>>03850000
      define not'sysseg = (not status.(8:8) < %300  or  not    <<00423>>03855000
                       cst(status.(8:8)&lsl(2)+1).syssegflag)#;<<04588>>03860000
      define pendctly=piinfo.psimfield=5#;                     <<06647>>03865000
                                                                        03870000
      erroron;                                                          03875000
      tos:=status;                                                      03880000
      cc:= if < then cce else ccg;                                      03885000
      tos.(0:1):=0;                    <<turn off the priv mode bit>>   03890000
      tos.(6:2):=cc;                   <<store cond code>>              03895000
      status:=tos;                                                      03900000
      if pendctly and not'sysseg then                          <<00423>>03905000
         begin                                                 <<00423>>03910000
         comment:                                              <<00423>>03915000
            execute pending controly when exit this            <<00423>>03920000
            procedure.;                                        <<00423>>03925000
         pxfixed;                                              <<00423>>03930000
         initq:=pxfxqreg;                                      <<06665>>03935000
         push(q);                                              <<00423>>03940000
         @stackmarker:=tos;                                    <<00423>>03945000
                                                               <<00423>>03950000
         <<find pending clty marker>>                          <<00423>>03955000
         while stackmarker(ploc).(0:1) <> 1 and                <<06101>>03960000
               @stackmarker > initq do                         <<00423>>03965000
            begin                                              <<00423>>03970000
            if integer(stackmarker(deltaq)) >= 4 then                   03975000
               @stackmarker:=@stackmarker-                     <<00423>>03980000
                             integer(stackmarker(deltaq))      <<00423>>03985000
            else <<bad stackmarker--stop search>>              <<00423>>03990000
               @stackmarker:=initq;                            <<00423>>03995000
            end;                                               <<00423>>04000000
         if @stackmarker > initq then                          <<00423>>04005000
            begin <<found pend ctly marker>>                   <<00423>>04010000
            stackmarker(ploc).(0:1) := 0;                      <<06101>>04015000
            p.(0:1) := 1;                                      <<06101>>04020000
            end;                                               <<00423>>04025000
         end;                                                  <<00423>>04030000
      errorexit(errex,0,0);                                             04035000
                                                                        04040000
end;  << g e t u s e r m o d e  >>                                      04045000
                                                                        04050000
<<------------------------------------------------------------------->> 04055000
                                                                        04060000
                                                                        04065000
                                                                        04070000
                                                                        04075000
integer procedure jpcountx;                                             04080000
option uncallable,privileged;                                           04085000
                                                                        04090000
comment:    gets the jpcount index from pcbx's caller;                  04095000
                                                                        04100000
begin                                                                   04105000
      array qarray(*) = q+0;                                   <<06665>>04110000
      integer pcbglobloc;                                      <<06665>>04115000
      pxglobal;                                                <<06665>>04120000
      jpcountx:=pxg'jpcntinx;                                  <<06665>>04125000
                                                                        04130000
end;  << j p c o u n t x  >>                                            04135000
                                                                        04140000
                                                                        04145000
<<------------------------------------------------------------------->> 04150000
                                                                        04155000
                                                                        04160000
                                                                        04165000
                                                                        04170000
                                                                        04175000
                                                                        04180000
                                                                        04185000
logical procedure lockjir;                                              04190000
option privileged,uncallable;                                           04195000
comment: gets the lock number for the job and get the sir;              04200000
begin                                                                   04205000
      lockjir:=getsir(jpcountx+first'jobsir);                  <<06738>>04210000
end;                                                                    04215000
<<------------------------------------------------------------------->> 04220000
                                                                        04225000
                                                                        04230000
                                                                        04235000
                                                                        04240000
                                                                        04245000
                                                                        04250000
procedure unlockjir(a);                                                 04255000
value a; integer a;                                                     04260000
option privileged,uncallable;                                           04265000
begin                                                                   04270000
      relsir(jpcountx+first'jobsir,a);                         <<06738>>04275000
end;                                                                    04280000
$page                                                          <<image>>04285000
procedure qproc (resource,procno);                             <<image>>04290000
value            resource,procno ;                             <<image>>04295000
integer pointer  resource        ;                             <<image>>04300000
logical                   procno ;                             <<image>>04305000
                                                               <<image>>04310000
option privileged,uncallable ;                                 <<image>>04315000
comment                                                        <<06647>>04320000
   the following procedure adds in procno to the queue of      <<06647>>04325000
processes waiting on a certain resource. this queue is laced   <<06647>>04330000
thru the pcb's previous impeded and next impeded pin, words.   <<06647>>04335000
as a standard matter all pins are specified as pcb relative    <<06647>>04340000
indexes ( i. e. pin * pcbsize ). this is valid for the nature  <<06647>>04345000
of the procno parameter as well as the fields in the pcb       <<06647>>04350000
itself. the resource parameter has to be at least 4 words in   <<06647>>04355000
size. the general format of the resource array is as follows:  <<06647>>04360000
                                                               <<06647>>04365000
   +------------------------------------+                      <<06647>>04370000
   !        owner pcb index             !                      <<06647>>04375000
   !------------------------------------!                      <<06647>>04380000
   !        head pcb index              !                      <<06647>>04385000
   !------------------------------------!                      <<06647>>04390000
   !        tail pcb index              !                      <<06647>>04395000
   !------------------------------------!                      <<06647>>04400000
   !        queue length                !                      <<06647>>04405000
   +------------------------------------+                      <<06647>>04410000
                                                               <<06647>>04415000
;                                                              <<06647>>04420000
begin                                                          <<image>>04425000
logical                                                        <<06647>>04430000
   pcbpt;                                                      <<06647>>04435000
if head = 0 and tail = 0 then                                  <<06647>>04440000
   begin                                                       <<06647>>04445000
   head := tail := procno;                                     <<06740>>04450000
   qlen := 0;                                                  <<06647>>04455000
   end                                                         <<06647>>04460000
else                                                           <<06647>>04465000
   begin                                                       <<06647>>04470000
   pcbpt := tail;                                              <<06647>>04475000
   nimppin := procno;                                          <<06647>>04480000
   pcbpt := procno;                                            <<07315>>04485000
   pimppin := tail;                                            <<07315>>04490000
   tail := procno;                                             <<06647>>04495000
   end;                                                        <<06647>>04500000
pcbpt := procno;                                               <<06740>>04505000
nimppin := 0;                                                  <<06740>>04510000
end; <<of qproc>>                                              <<image>>04515000
$page                                                          <<image>>04520000
integer procedure dqproc (resource);                           <<image>>04525000
value                     resource ;                           <<image>>04530000
integer pointer           resource ;                           <<image>>04535000
                                                               <<image>>04540000
option privileged,uncallable;                                  <<image>>04545000
                                                               <<image>>04550000
comment                                                        <<image>>04555000
de-queues a process from the list of processes waiting on      <<image>>04560000
the resource identified by 'resource'. see qproc for more      <<image>>04565000
info. the pin of the process dequeued is returned in the       <<image>>04570000
name. this may be zero if there were no waiters.               <<image>>04575000
;                                                              <<image>>04580000
                                                               <<image>>04585000
begin                                                          <<image>>04590000
                                                               <<image>>04595000
integer                                                        <<06647>>04600000
   newpix;                                                     <<06647>>04605000
logical                                                        <<06647>>04610000
   pcbpt;                                                      <<06647>>04615000
                                                               <<image>>04620000
<<is anyone waiting?>>                                         <<image>>04625000
if head = 0 then                                               <<06647>>04630000
   return;                                                     <<06647>>04635000
newpix := dqproc := head;                                      <<06647>>04640000
pcbpt := head;                                                 <<06647>>04645000
if nimppin = 0 then                                            <<06647>>04650000
   begin                                                       <<06647>>04655000
   head := 0;                                                  <<06740>>04660000
   tail := 0;                                                  <<06740>>04665000
   end                                                         <<06647>>04670000
else                                                           <<06647>>04675000
   begin                                                       <<06647>>04680000
   head := nimppin;                                            <<06647>>04685000
   pcbpt := head;                                              <<07315>>04690000
   pimppin := 0;                                               <<07315>>04695000
   end;                                                        <<06647>>04700000
pcbpt := newpix;                                               <<06647>>04705000
nimppin := 0;                                                  <<06647>>04710000
end; << of dqproc >>                                           <<image>>04715000
$page "                           'RELEASE'"                   <<image>>04720000
procedure release(resource,altres,wakeup);                     <<06647>>04725000
value resource,altres,wakeup;                                  <<06647>>04730000
logical wakeup;                                                <<06647>>04735000
logical pointer resource,altres;                               <<06647>>04740000
                                                               <<image>>04745000
option privileged,uncallable;                                  <<image>>04750000
<<************************************************************ <<image>>04755000
<<                                                             <<image>>04760000
<< release control of the user  resource represented by the    <<image>>04765000
<< parameter 'res'. if there was a queue for this resource the <<image>>04770000
<< one or all of the waiters are activated depending on the    <<image>>04775000
<< setting of parameter 'wakeup'. if 'altres' is enabled then  <<image>>04780000
<< all processes that would have been activated are transferre <<image>>04785000
<< to the fifo queue for the resource represented by 'altres'. <<image>>04790000
<< they are transferred in the same order as they queued for   <<image>>04795000
<< 'res' and they are not activated.                           <<image>>04800000
<<                                                             <<image>>04805000
<<parameters:                                                  <<image>>04810000
<<-----------                                                  <<image>>04815000
<<                                                             <<image>>04820000
<<  res       pointer to the doubleword wait field representin <<image>>04825000
<<            the resource to be released. see 'obtain'        <<image>>04830000
<<                                                             <<image>>04835000
<<  altres    pointer to the doubleword waitfield representing <<image>>04840000
<<            the alternate resource to which waiters are      <<image>>04845000
<<            transferred. if this field is < zero then waiter <<image>>04850000
<<            are activated immediately with no queue transfer <<image>>04855000
<<            taking place.                                    <<image>>04860000
<<                                                             <<image>>04865000
<<  wakeup    =1 wake only the first waiter in the queue       <<image>>04870000
<<            =0 wake all waiters in the queue.                <<image>>04875000
<<                                                             <<image>>04880000
<<condition code:                                              <<image>>04885000
<<---------------                                              <<image>>04890000
<<                                                             <<image>>04895000
<<            not affected.                                    <<image>>04900000
<<                                                             <<image>>04905000
<<************************************************************ <<image>>04910000
                                                               <<image>>04915000
begin                                                          <<image>>04920000
                                                               <<image>>04925000
integer x=x;                                                   <<image>>04930000
                                                               <<image>>04935000
logical                                                        <<06647>>04940000
   pcbpt;                                                      <<06647>>04945000
equate waitfield=1,                                            <<image>>04950000
       ignore=-1,                                              <<*7556>>04955000
       dummypin = 1;                                           <<*7556>>04960000
$page                                                          <<image>>04965000
                                                               <<image>>04970000
<<release the resource>>                                       <<image>>04975000
<<-------------------->>                                       <<image>>04980000
pdisable;                                                      <<*7556>>04985000
                                                               <<*7556>>04990000
                                                               <<*7556>>04995000
if owner <> dummypin then                                      <<*7556>>05000000
   begin                                                       <<*7556>>05005000
   if owner <> curprc then                                     <<*7556>>05010000
      begin   << can't release it unless we own it! >>         <<*7556>>05015000
      penable;                                                 <<*7556>>05020000
      return;                                                  <<*7556>>05025000
      end;                                                     <<*7556>>05030000
   end;                                                        <<*7556>>05035000
                                                               <<*7556>>05040000
owner := 0;                                                    <<06647>>05045000
                                                               <<image>>05050000
<<anyone waiting? >>                                           <<image>>05055000
<<---------------->>                                           <<image>>05060000
if head <> 0 and tail <> 0 then                                <<06740>>05065000
                                                               <<image>>05070000
do   begin                                                     <<image>>05075000
     <<give resource to waiter(s) >>                           <<image>>05080000
     owner := dqproc(resource);                                <<06647>>05085000
     <<transfer him to alt q?>>                                <<image>>05090000
     if @altres<>ignore then qproc(altres,owner)               <<06647>>05095000
                        else unimpede(owner);                  <<06647>>05100000
     end                                                       <<image>>05105000
                                                               <<image>>05110000
until wakeup or (head = 0 land tail = 0);                      <<06740>>05115000
penable;                                                       <<*7556>>05120000
end; <<of release>>                                            <<image>>05125000
$page "                        'OBTAIN'"                       <<image>>05130000
integer procedure obtain(resource,altres);                     <<06647>>05135000
value resource,altres;                                         <<06647>>05140000
logical pointer resource,altres;                               <<06647>>05145000
option privileged,uncallable;                                  <<image>>05150000
<<************************************************************ <<image>>05155000
<<                                                             <<image>>05160000
<<  this routine is used to take control of the resource       <<image>>05165000
<<  represented by the parameter 'res'. if this resource       <<image>>05170000
<<  is in use, the calling process will wait in a fifo         <<image>>05175000
<<  queue for it. if a wait is necessary, the resource rep-    <<image>>05180000
<<  resented by 'altres' will be released before the           <<image>>05185000
<<  calling process is suspended. it is guaranteed that no     <<image>>05190000
<<  interrupts will occur between giving up altres and         <<image>>05195000
<<  suspending.                                                <<image>>05200000
<<  the procedure also returns the caller's pin in the name.   <<image>>05205000
<<  this is done to provide a quick, mpe-independent way of    <<image>>05210000
<<  obtaining your pin without computing it each time.         <<image>>05215000
<<                                                             <<image>>05220000
<<  parameters:                                                <<image>>05225000
<<  -----------                                                <<image>>05230000
<<                                                             <<image>>05235000
<<     res   pointer to a doubleword 'wait field'              <<image>>05240000
<<           representing the resource. it has the following   <<image>>05245000
<<           layout:                                           <<image>>05250000
<<                                                             <<image>>05255000
<<                                                             <<00085>>05260000
<<  the owners pin can be equal to 1 which is interpreted      <<00085>>05265000
<<  as a dummy process and is never treated as a real pin.     <<00085>>05270000
<<                                                             <<image>>05275000
<<   altres  represents alternate resource as above. if this   <<image>>05280000
<<           parameter has a negative value then no alternate  <<image>>05285000
<<           resource exists and we will not attempt to        <<image>>05290000
<<           release it.                                       <<image>>05295000
<<                                                             <<image>>05300000
<<  condition code:                                            <<image>>05305000
<<  ---------------                                            <<image>>05310000
<<                                                             <<image>>05315000
<<           not affected                                      <<image>>05320000
<<                                                             <<image>>05325000
<<************************************************************ <<image>>05330000
                                                               <<image>>05335000
begin                                                          <<image>>05340000
logical                                                        <<06647>>05345000
   pcbpt;                                                      <<06647>>05350000
equate ignore=-1,                                              <<image>>05355000
       dummypin = 1,                                           <<07315>>05360000
       onewaiter=1;                                            <<image>>05365000
                                                               <<image>>05370000
integer                                                        <<06647>>05375000
   pix = obtain;                                               <<06647>>05380000
double savetime;                                               <<01549>>05385000
integer s0=s-0;                                                <<01549>>05390000
logical ls0=s-0;                                               <<01549>>05395000
$page                                                          <<image>>05400000
integer x=x;                                                   <<01549>>05405000
pix := (curprc)/pcbsize;                                       <<06647>>05410000
                                                               <<image>>05415000
<<find out if resource free>>                                  <<image>>05420000
<<------------------------->>                                  <<image>>05425000
pdisable;                                                      <<*7556>>05430000
if owner = 0 then                                              <<06647>>05435000
                                                               <<image>>05440000
   begin                                                       <<image>>05445000
   <<yes. i can take it right now>>                            <<image>>05450000
   <<---------------------------->>                            <<image>>05455000
   owner := curprc;                                            <<*7762>>05460000
   penable;                                                    <<*7556>>05465000
   return;                                                     <<image>>05470000
   end                                                         <<*7556>>05475000
else                                                           <<*7556>>05480000
   if owner = curprc then                                      <<*7556>>05485000
     begin    << opps...already own it! >>                     <<*7556>>05490000
     penable;                                                  <<*7556>>05495000
     return;                                                   <<*7556>>05500000
     end                                                       <<*7556>>05505000
                                                               <<image>>05510000
else                                                           <<image>>05515000
                                                               <<image>>05520000
   begin                                                       <<image>>05525000
   <<got to wait in line. release the alternate                <<image>>05530000
<<   resource if so instructed in 'altres'    >>               <<image>>05535000
   <<----------------------------------------->>               <<image>>05540000
   if @altres <> ignore then release(altres,ignore,onewaiter); <<image>>05545000
   qproc(resource,curprc);                                     <<*7762>>05550000
   if owner = dummypin then                                    <<07315>>05555000
      impede(0) <<dont impair cos this raises impeders pri>>   <<00085>>05560000
   else                                                        <<00085>>05565000
     impaired(owner/pcbsize,@resource,false);                  <<06647>>05570000
                                                               <<00085>>05575000
comment                                                        <<00085>>05580000
   'impaired' is an mpe routine which deactivates the calling  <<image>>05585000
   process. before it does so, it compares the priority of the <<image>>05590000
   caller with the priority of the current owner of the resourc<<image>>05595000
   it then ensures that the owner runs at the same or higher   <<image>>05600000
   priority than the caller. it is assumed that the process has<<image>>05605000
   set critical while using this facility. when it finally call<<image>>05610000
   resetcritical, that routine checks to see if the calling    <<image>>05615000
   process has been raised in priority in this way. if it has, <<image>>05620000
   it is put back down to its original priority.               <<image>>05625000
                                                               <<image>>05630000
   when we wake up again, we will be the new owner of the resou<<image>>05635000
;                                                              <<image>>05640000
   end;                                                        <<image>>05645000
end; <<of obtain>>                                             <<image>>05650000
$page " INTRINSIC MYPIN "                                      <<image>>05655000
logical procedure mypin;                                       <<image>>05660000
                                                               <<image>>05665000
option privileged,uncallable;                                  <<image>>05670000
                                                               <<image>>05675000
<<*************************************************************<<image>>05680000
                                                               <<image>>05685000
<<      returns the pin of the calling process                 <<image>>05690000
                                                               <<image>>05695000
<<*************************************************************<<image>>05700000
                                                               <<image>>05705000
begin                                                          <<image>>05710000
mypin := (curprc)/pcbsize;                                     <<06647>>05715000
end;                                                           <<image>>05720000
<<------------------------------------------------------------------->> 05725000
$page "   NEXTPROC"                                            <<00085>>05730000
                                                               <<00085>>05735000
integer procedure nextproc (pin);                              <<00085>>05740000
value                       pin ;                              <<00085>>05745000
integer                     pin ;                              <<00085>>05750000
option privileged,uncallable;                                  <<00085>>05755000
                                                               <<00085>>05760000
<< this procedure is used to determine the successor process in  00085  05765000
   the queue of impeded processes. it does this by locating the  00085  05770000
   pcb for the process pin and returning the contents of its     00085  05775000
   iqptr (impeded queue pointer), which is the pin of the next   00085  05780000
   process in the queue.                                         00085  05785000
>>                                                             <<00085>>05790000
                                                               <<00085>>05795000
begin                                                          <<00085>>05800000
                                                               <<00085>>05805000
                                                               <<00085>>05810000
nextproc := pcb(curprc+nimppinwordnum)/pcbsize;                <<06647>>05815000
                                                               <<00085>>05820000
end;                                                           <<00085>>05825000
$page "     PINJOBMAP"                                         <<00085>>05830000
                                                               <<00085>>05835000
procedure pinjobmap (pin,buff,jobnum);                         <<00085>>05840000
value                pin             ;                         <<00085>>05845000
byte array               buff        ;                         <<00085>>05850000
integer              pin,     jobnum ;                         <<00085>>05855000
option privileged,uncallable;                                  <<00085>>05860000
                                                               <<00085>>05865000
<<given a process identified by pin, this procedure returns the  00085  05870000
 job number that corresponds to it. this is returned in buff as  00085  05875000
an ascii string of the form #snnnn or #jnnnn. it is also return  00085  05880000
in jobnum as follows. the high order 2 bits are 1 for a session  00085  05885000
and 2 for a job. the low order 14 bits contain the job/session   00085  05890000
   number in binary.                                             00085  05895000
>>                                                             <<00085>>05900000
                                                               <<00085>>05905000
begin                                                          <<00085>>05910000
array jobtab(*)=db+0;                                          <<00085>>05915000
integer jnum;                                                  <<00085>>05920000
byte pointer p;                                                <<00085>>05925000
equate pjxref=50;                                              <<00085>>05930000
                                                               <<00085>>05935000
intrinsic ascii;                                               <<00085>>05940000
                                                               <<00085>>05945000
logical procedure exchangedb (dst);                            <<00085>>05950000
value                         dst ;                            <<00085>>05955000
logical                       dst ;                            <<00085>>05960000
option external;                                               <<00085>>05965000
                                                               <<00085>>05970000
<<go get the job info>>                                        <<00085>>05975000
exchangedb(pjxref);                                            <<00085>>05980000
jnum:=jobtab(pin);                                             <<00085>>05985000
exchangedb(0);                                                 <<00085>>05990000
                                                               <<00085>>05995000
<<form the ascii jobnum>>                                      <<00085>>06000000
if jnum=0 then                                                 <<00085>>06005000
   move buff:="???"                                            <<00085>>06010000
else                                                           <<00085>>06015000
   begin                                                       <<00085>>06020000
   if jnum.(0:2)=1 then                                        <<00085>>06025000
      move buff:="#S",2                                        <<00085>>06030000
   else                                                        <<00085>>06035000
      move buff:="#J",2;                                       <<00085>>06040000
   @p:=tos;                                                    <<00085>>06045000
   ascii(jnum.(2:14),10,p);                                    <<00085>>06050000
   end;                                                        <<00085>>06055000
jobnum:=jnum;                                                  <<00085>>06060000
end;                                                           <<00085>>06065000
                                                                        06070000
                                                                        06075000
$control segment=main                                                   06080000
                                                                        06085000
         end;                                                           06090000
