$CONTROL MAP,CODE,USLINIT                                               00010000
<< message -- modulde 59 >>                                             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=message,main=message                                   00055000
begin                                                                   00060000
comment table structures to support non-$stdlist messages      <<02802>>00065000
                                                               <<02802>>00070000
message buffers dst - pointed to by sysglob %113               <<02802>>00075000
<<*****************************************************>>      <<02802>>00080000
<< word | description                                  >>      <<02802>>00085000
<<*****************************************************>>      <<02802>>00090000
<< 0    | number of buffers in this dst                >>      <<02802>>00095000
<< 1    | length of buffers in this dst (128 currently)>>      <<02802>>00100000
<< 2    | next available buffer ptr - dst relative     >>      <<02802>>00105000
<< 3    | tail available buffer ptr - dst relative     >>      <<02802>>00110000
<< 4-n  | # of buffers * length of buffer "BUFFER" area>>      <<02802>>00115000
<<      | word "0" of each buffer is avail buffer link >>      <<02802>>00120000
<<*****************************************************>>      <<02802>>00125000
                                                               <<02802>>00130000
buffer impeded queue (by pin) - pointed to by sysglob %62      <<02802>>00135000
                                                               <<02802>>00140000
basic ipc (sendmsg) message format                             <<02802>>00145000
<<*****************************************************>>      <<02802>>00150000
<< word | description                                  >>      <<02802>>00155000
<<*****************************************************>>      <<02802>>00160000
<< 0    | integer "2" - msg type 2 to iomessageproc    >>      <<02802>>00165000
<< 1    | ioq index of message attachio to terminal    >>      <<02802>>00170000
<< 2    | message buffer dst offset of buffer used     >>      <<02802>>00175000
<< 3    | not used, currently "0"                      >>      <<02802>>00180000
<<*****************************************************>>      <<02802>>00185000
                                                               <<02802>>00190000
;                                                              <<02802>>00195000
                                                                        00200000
$include inclpcb5                                              <<06590>>00205000
logical pointer pcb = syspcbindex;                             <<06590>>00210000
equate                                                                  00215000
   qi      = 5,                                                         00220000
                                                                        00225000
   msgbase       = %1371,                                               00230000
   msgsir        = %24,                                                 00235000
   fisir         = 37,                                         <<00820>>00240000
   sysdisc       = 1,                                                   00245000
   sysup         = %1073,                                      <<01398>>00250000
   consolecell   = %1074,                                               00255000
   sysdb         = 512,                                        <<00820>>00260000
   cloadid       = sysdb + %75,                                <<00820>>00265000
                                                               <<02802>>00270000
<< if num'msg'bufs is changed, must also change in iomsgproc >><<02802>>00275000
   num'msg'bufs  =16,  <<number of buffers for msg system>>    <<02802>>00280000
   sbufdstn      = %10,                                                 00285000
   sbufsizew     = 128,                                                 00290000
   sbufsize      = 256,                                                 00295000
   sbufsizewm1   = sbufsizew -1;                                        00300000
define                                                         <<06877>>00305000
   sys'console'ldev    =  absolute(consolecell)#;              <<06877>>00310000
                                                                        00315000
define                                                                  00320000
   disable = assemble( sed 0) #,                                        00325000
   enable  = assemble( sed 1) #,                                        00330000
   pdisable= assemble(psdb)#,                                  <<02802>>00335000
   penable = assemble(pseb)#,                                  <<02802>>00340000
                                                               <<02802>>00345000
   iomsgqueue = absolute(%1062)#, <<impeded list head for msg>><<02802>>00350000
   iomsgdst   = absolute(%1113)#; << dst for message buffers >><<06590>>00355000
                                                               <<02802>>00360000
                                                                        00365000
<< message layout equates.  see also, sectperblkd, below. >>   <<04362>>00370000
equate                                                                  00375000
   ccg           = 0,                                                   00380000
   ccl           = 1,                                                   00385000
   cce           = 2,                                                   00390000
                                                                        00395000
   headersize    = 2,                                          <<00711>>00400000
   maxnosets     = 62,                                         <<00711>>00405000
   msgdirsize    = headersize + maxnosets*2 + 2 <<work space>>,<<00711>>00410000
   maxsetnocell  = 0,                                          <<00711>>00415000
   maxrecell     = 1,                                          <<00711>>00420000
   currentrecell = msgdirsize - 1,                             <<00711>>00425000
   recsize           = 40,                                              00430000
   recsizeb          = recsize*2,                                       00435000
   recsizem1         = recsize -1,                                      00440000
   buffsize          = recsize -4,                                      00445000
   buffsizem1        = buffsize -1,                                     00450000
   buffsizeb         = buffsize*2,                                      00455000
   blkfactor         = 16,                                              00460000
   physblk           = 16*40,                                           00465000
   sectorperblk      = physblk/128,                                     00470000
                                                                        00475000
   endofequates      = 0;                                               00480000
                                                               <<04362>>00485000
<< sectors per block defines used for double arithmetic  >>    <<04362>>00490000
<< in readcat.  see sectorperblk equate, above.          >>    <<04362>>00495000
   define                                                      <<04362>>00500000
      sectperblkd     = 5d #;                                  <<04362>>00505000
                                                               <<04362>>00510000
                                                                        00515000
integer                                                                 00520000
   status = q-1,                                                        00525000
   s0 =s-0,                                                             00530000
   s6 = s-6,                                                            00535000
   x = x;                                                               00540000
                                                                        00545000
byte pointer bps0 = s-0;                                                00550000
pointer ps0 = s-0;                                                      00555000
double pointer dps0 = s-0;                                              00560000
                                                                        00565000
define                                                                  00570000
   msgdstn       = absolute(msgbase+2)#,                                00575000
                                                                        00580000
   condcode      = status.(6:2)#,                                       00585000
   ccgretn       = begin                                                00590000
                      condcode := ccg;                                  00595000
                      go outl;                                          00600000
                   end#,                                                00605000
   cclretn       = begin                                                00610000
                      condcode := ccl;                                  00615000
                      go outl;                                          00620000
                   end#,                                                00625000
   def'movefromdseg =                                                   00630000
      movefromdseg(target,dstn,offset,count);                           00635000
         value target,dstn,offset,count;                                00640000
         logical target,dstn,offset,count;                              00645000
      begin                                                             00650000
         x := tos; << save return address >>                            00655000
         assemble(mfds 0);                                              00660000
         tos := x; << restore return address >>                         00665000
      end #,                                                            00670000
                                                                        00675000
   def'movetodseg =                                                     00680000
      movetodseg(dstn,offset,source,count);                             00685000
         value dstn,offset,source,count;                                00690000
         logical dstn,offset,source,count;                              00695000
      begin                                                             00700000
         x := tos;                                                      00705000
         assemble(mtds 0);                                              00710000
         tos := x;                                                      00715000
      end#;                                                    << 7469>>00720000
                                                                        00725000
                                                                        00730000
                                                                        00735000
<< end global decls >>                                                  00740000
                                                                        00745000
        << here are the parm mask definitions >>                        00750000
        << for genmsg & formsg pmasks         >>                        00755000
logical                                                                 00760000
   pmask = q-4;                                                         00765000
define pcb'replydone = 3#;                                     <<06590>>00770000
                                                                        00775000
define                                                                  00780000
   psetno  = ( 3:1) #,                                                  00785000
   pmsgno  = ( 4:1) #,                                                  00790000
   ppmask  = ( 5:1) #,                                                  00795000
   pdest   = (11:1) #,                                                  00800000
   preply  = (12:1) #,                                                  00805000
   poffset = (13:1) #,                                                  00810000
   pdst    = (14:1) #,                                                  00815000
   pcontrol = (15:1) #;                                                 00820000
$include inclpxg                                               << 7469>>00825000
$include incljit                                               << 7469>>00830000
$include inclrit                                               <<04882>>00835000
$include incllpdt                                              <<06224>>00840000
<< apl funny terminal stuff >>                                          00845000
define funnyterm = (2:2)#;                                              00850000
                                                               <<01646>>00855000
equate generalset=1;                                           <<04882>>00860000
equate replywoken=293;                                        <<<04882>>00865000
equate replyimpeded=294;                                      <<<04882>>00870000
equate queuefull=295;                                         <<<04882>>00875000
equate telluser'noroom =296;                                  <<<04882>>00880000
equate tellop'queued'user = 297;                               <<04882>>00885000
                                                               <<01646>>00890000
equate                                                                  00895000
   jmatx        = 3; << index of jmat in pxglobal >>           <<06592>>00900000
                                                               <<06592>>00905000
$set x8=off                                                    <<06592>>00910000
$include incljmat                                              <<06592>>00915000
                                                               <<06592>>00920000
                                                               <<01646>>00925000
define  mypin = curprc/pcbsize#;                               <<06590>>00930000
                                                                        00935000
<< association table definitions >>                            <<01646>>00940000
                                                               <<01646>>00945000
equate                                                         <<01646>>00950000
   ass'sir = 24,       << sir # for association table >>       <<01646>>00955000
   ass'dst = 34,       << dst # for association table >>       <<01646>>00960000
   ass'entrysize = 7;  << size of one entry in table  >>       <<01646>>00965000
                                                               <<01646>>00970000
define                                                         <<01646>>00975000
   ass'jmat = 0).(8:8#;      << jmat index >>                  <<01646>>00980000
                                                               <<01646>>00985000
                                                                        00990000
<< external declarations >>                                             00995000
procedure setlockstatus(labeladdr,purgeok);                    <<06591>>01000000
   value labeladdr,purgeok;                                    <<06591>>01005000
   double labeladdr;                                           <<06591>>01010000
   logical purgeok;                                            <<06591>>01015000
   option uncallable,privileged,external;                      <<06591>>01020000
                                                               <<06591>>01025000
                                                                        01030000
procedure apltranslateout(message,length,transtype);                    01035000
   value length,transtype;integer length,transtype;                     01040000
   byte array message;option external;                                  01045000
                                                                        01050000
intrinsic ascii,binary,dascii,print,fwrite,fcheck,fopen,                01055000
   fgetinfo,freadlabel,fclose;                                          01060000
                                                                        01065000
procedure awake(pin,af,wf);value pin,af,wf;                             01070000
   integer pin,af,wf;option external;                                   01075000
                                                                        01080000
double procedure attachio(a,b,c,d,e,f,g,h,i);                           01085000
   value a,b,c,d,e,f,g,h,i;                                             01090000
   logical a,b,c,d,e,f,g,h,i;                                           01095000
   option external;                                                     01100000
                                                                        01105000
procedure erroron; option external;                                     01110000
                                                               <<01998>>01115000
   logical procedure jobsessionmain;                           <<01998>>01120000
   option uncallable,external;                                 <<01998>>01125000
                                                                        01130000
procedure errorexit(intrinexit,errword,param);                          01135000
   value intrinexit,errword,param;                                      01140000
   logical intrinexit,errword,param;                                    01145000
   option external;                                                     01150000
                                                                        01155000
integer procedure exchangedb(dstx);                                     01160000
   value dstx; logical dstx; option external;                           01165000
procedure fgetcb (newvector,dst,cb,vector,flags,s1,o1,s2,o2);  <<01391>>01170000
   value newvector,dst,cb,vector,flags,s1,o1,s2,o2;            <<01391>>01175000
   integer newvector,dst,vector,s1,o1,s2,o2;                   <<01391>>01180000
   integer pointer cb;                                         <<00820>>01185000
   logical flags;                                              <<00820>>01190000
   option variable,external;                                   <<01391>>01195000
                                                               <<00820>>01200000
integer procedure flabio (ldev,sector,func,flab);              <<00820>>01205000
   value ldev,sector,func;                                     <<00820>>01210000
   integer ldev,func;                                          <<00820>>01215000
   double sector;                                              <<00820>>01220000
   integer array flab;                                         <<00820>>01225000
   option privileged,uncallable,external;                      <<00820>>01230000
                                                               <<00820>>01235000
procedure frelcb (dst,vector,flags);                           <<00820>>01240000
   value dst,vector,flags;                                     <<00820>>01245000
   integer dst,vector;                                         <<00820>>01250000
   logical flags;                                              <<00820>>01255000
   option privileged,uncallable,external;                      <<00820>>01260000
                                                               <<00820>>01265000
                                                                        01270000
integer procedure getdataseg(memsize,vdsize);                           01275000
   value memsize,vdsize;                                                01280000
   integer memsize,vdsize;                                              01285000
   option external;                                                     01290000
                                                                        01295000
integer procedure getsir(sirnum);                                       01300000
   value sirnum; logical sirnum; option external;                       01305000
                                                                        01310000
integer procedure getsysbuf(num,iflag);value num,iflag;                 01315000
   integer num;logical iflag;option external;                           01320000
                                                                        01325000
procedure impede(pinx);                                                 01330000
   value pinx; integer pinx; option external;                           01335000
                                                                        01340000
   procedure log15(i,j,k,l);                                   <<ks.01>>01345000
   value i,j,k,l;                                              <<ks.01>>01350000
   logical i,j,k,l;                                            <<ks.01>>01355000
   option external;                                            <<ks.01>>01360000
                                                               <<04882>>01365000
                                                               <<00820>>01370000
procedure reldataseg(dstnum);                                  <<00820>>01375000
   value dstnum;                                               <<00820>>01380000
   integer dstnum;                                             <<00820>>01385000
   option external;                                            <<00820>>01390000
                                                               <<00820>>01395000
integer procedure relsir(sirnum,a);                                     01400000
   value sirnum,a; logical sirnum,a; option external;                   01405000
                                                               <<07395>>01410000
procedure stackmark( which, delq, stat, relp, xreg );          <<07395>>01415000
   value   which;                                              <<07395>>01420000
   integer which, delq, stat, relp, xreg;                      <<07395>>01425000
option variable, external;                                     <<07395>>01430000
                                                               <<07395>>01435000
                                                                        01440000
procedure sendmsg(destpin,destport,msglength,flags);           <<02802>>01445000
value destpin,destport,msglength,flags;                        <<02802>>01450000
integer destpin,destport,msglength;                            <<02802>>01455000
logical flags;                                                 <<02802>>01460000
option external;                                               <<02802>>01465000
                                                               <<02802>>01470000
integer procedure setcritical;                                 <<02802>>01475000
option external;                                               <<02802>>01480000
                                                               <<02802>>01485000
procedure resetcritical(crit);                                 <<02802>>01490000
value crit;                                                    <<02802>>01495000
integer crit;                                                  <<02802>>01500000
option external;                                               <<02802>>01505000
                                                               <<02802>>01510000
procedure suddendeath(a);value a;integer a;option external;             01515000
                                                                        01520000
procedure wait(a,b);                                                    01525000
   value a,b; logical a,b; option external;                             01530000
                                                                        01535000
<< forward declarations >>                                              01540000
                                                                        01545000
integer procedure consprefix(consreply,buff');                          01550000
   value consreply;                                                     01555000
   logical consreply;                                                   01560000
   array buff';                                                         01565000
   option forward;                                                      01570000
                                                                        01575000
integer procedure genmsg(a,b,c,d,e,f,g,h,i,j,k,l,m);                    01580000
   value a,b,c,d,e,f,g,h,i,j,k,l,m;integer a,b,i,l;                     01585000
   logical c,d,e,f,g,h,j,k,m;option variable,forward;                   01590000
                                                                        01595000
<< procedures >>                                                        01600000
logical procedure put'in'rit'queue(pinx);                      <<04882>>01605000
value pinx;                                                    <<04882>>01610000
integer pinx;                                                  <<04882>>01615000
option privileged,uncallable;                                  <<04882>>01620000
<< this procedure is designed to queue entries that were  >>   <<04882>>01625000
<< unable to be put in the reply information table because>>   <<04882>>01630000
<< it was full.  if there is room in the queue then the   >>   <<04882>>01635000
<< pin for that process will be placed in the queue.  if  >>   <<04882>>01640000
<< there is no room then the pin will not be put in the   >>   <<04882>>01645000
<< queue and messages will be sent to the console and user>>   <<04882>>01650000
                                                               <<04882>>01655000
 begin                                                         <<04882>>01660000
    integer array ritable(*) = db+0;                           <<04882>>01665000
   integer numqueued;                                          <<04882>>01670000
                                                               <<04882>>01675000
put'in'rit'queue := true;                                      <<04882>>01680000
if ritable(queued'entries) <  max'queued'entries then          <<04882>>01685000
   begin                                                       <<04882>>01690000
     ritable(ritable(liq)) := pinx;                            <<04882>>01695000
     ritable(liq) := ritable(liq) + 1;                         <<04882>>01700000
     ritable(queued'entries) := ritable(queued'entries) + 1;   <<04882>>01705000
     numqueued := ritable(queued'entries);                     <<04882>>01710000
     << this is decremented in rem'queued'entry           >>   <<04882>>01715000
     exchangedb(0);                                            <<04882>>01720000
     genmsg(generalset,replyimpeded); << tell user he is queued<<04882>>01725000
     genmsg(generalset,tellop'queued'user,%10000,numqueued,    <<04882>>01730000
           ,,,,0);                                             <<04882>>01735000
   end                                                         <<04882>>01740000
   else begin << no room in queue >>                           <<04882>>01745000
          put'in'rit'queue := false;                           <<04882>>01750000
          exchangedb(0);                                       <<04882>>01755000
          genmsg(generalset,queuefull,,,,,,,0);                <<04882>>01760000
          genmsg(generalset,telluser'noroom)                   <<04882>>01765000
          end;                                                 <<04882>>01770000
end; << put'in'rit'queue >>                                    <<04882>>01775000
                                                                        01780000
$page                                                          << 7592>>01785000
                                                                        01790000
logical procedure putritentry( pinx, dst, offset, reply,       << 7592>>01795000
                              len, buff', sirn );              << 7592>>01800000
   value pinx,dst,offset,reply,len;                                     01805000
   integer pinx,dst,offset,reply,len,sirn;                     << 7592>>01810000
   array buff';                                                         01815000
   option internal;                                                     01820000
comment                                                                 01825000
   places entry in rit. searches through rit & uses first               01830000
   available entry. if none available, this process is                  01835000
   is put into a queue by a call to put'in'rit'queue and then  <<04882>>01840000
   it is impeded until a reply calls rem'queued'entry which    <<04882>>01845000
   will wake the process thats been queued the longest         <<04882>>01850000
   the awoken process will then attempt to enter the rit table <<04882>>01855000
                                                               << 7592>>01860000
   fix note:                                                   << 7592>>01865000
                                                               << 7592>>01870000
   putritentry now takes the rit sir and does not release it if<< 7592>>01875000
   an entry is successfully placed in the rit.  genmsg will    << 7592>>01880000
   release the sir before it waits for the reply.  if the entry<< 7592>>01885000
   cannot be entered, then the sir is released.                << 7592>>01890000
                                                               << 7592>>01895000
   note that putritentry may not be called with someone else   << 7592>>01900000
   holding the rit sir since it releases the sir and impedes   << 7592>>01905000
   if the rit is full.                                         << 7592>>01910000
;                                                                       01915000
                                                               << 7592>>01920000
begin                                                                   01925000
integer                                                                 01930000
   index;                                                               01935000
                                                                        01940000
logical noproblem;                                             <<04882>>01945000
integer array ritable(*) = db+0;                                        01950000
logical pcbpt;                                                 <<06590>>01955000
                                                                        01960000
subroutine def'movetodseg;                                              01965000
                                                                        01970000
<< fill in ritdescriptor >>                                             01975000
   sirn := 0;                                                  <<04811>>01980000
   buff' := pinx;                                                       01985000
   if dst <> 0 then buff'(1) := dst                                     01990000
   else                                                                 01995000
   begin << compute seg. rel. adr. of offset >>                         02000000
      disable;                                                          02005000
      tos := absolute( absolute( qi ) -5);                              02010000
      tos := absolute(x := x-4) +1;                                     02015000
      assemble( lsea );                                                 02020000
      index := tos;                                                     02025000
      ddel;                                                             02030000
      buff'(1) := absolute(x:= x-7); << stack dst # >>                  02035000
      enable;                                                           02040000
      offset := offset+ index;                                          02045000
   end;                                                                 02050000
   buff'(2) := offset;                                                  02055000
   buff'(3) := reply;                                                   02060000
   buff'(6) := 0;  << control word. (vestigial) >>                      02065000
   buff'(rit'msglen) := if len > rit'msgsize then rit'msgsize  <<04882>>02070000
      else len;                                                         02075000
                                                                        02080000
again:                                                                  02085000
noproblem := true; << assume it will work >>                   <<04882>>02090000
pcbpt := curprc;                                               <<06590>>02095000
if procstate.softkillflag = 1                                  <<06590>>02100000
   then begin                                                  <<04882>>02105000
        << softkill bit is set on >>                           <<04882>>02110000
        noproblem := false;                                    <<04882>>02115000
        go around;                                             <<04882>>02120000
        end;                                                   <<04882>>02125000
sirn := getsir(rit'sir);     << use temp variable because>>    <<*7797>>02130000
exchangedb(rit'dst);                                           <<04882>>02135000
                             << we're in split stack mode>>    <<*7589>>02140000
if ritable = ritable(rit'head'maxent) then << table full >>    <<04882>>02145000
begin                                                                   02150000
   noproblem := put'in'rit'queue(pinx);                        <<04882>>02155000
   << using sirn in the relsir works because the procedure>>   <<*7797>>02160000
   << put'in'rit'queue always does an exchangedb(0) so we >>   <<*7797>>02165000
   << are back at this db, not the rits, when we return   >>   <<*7797>>02170000
   << from put'in'rit'queue.                              >>   <<*7797>>02175000
                                                               <<*7797>>02180000
   relsir(rit'sir,sirn);                                       <<*7797>>02185000
   if noproblem then                                           <<04882>>02190000
      begin                                                    <<04882>>02195000
        wait(%40,0);                                           <<04882>>02200000
        genmsg(generalset,replywoken);                         <<04882>>02205000
        go again;  << try again >>                             <<04882>>02210000
        end;                                                   <<04882>>02215000
end;                                                                    02220000
around:                                                        <<04882>>02225000
if noproblem                                                   <<04882>>02230000
   then begin                                                  <<04882>>02235000
          ritable := ritable + 1;                              <<04882>>02240000
          index := rit'headsize - rit'size;                    <<04882>>02245000
                                                               <<04882>>02250000
          do index := index + rit'size until ritable(index)=0; <<04882>>02255000
          << found empty entry >>                              <<04882>>02260000
          exchangedb(0);                                       <<04882>>02265000
          movetodseg(rit'dst,index,@buff',rit'size);           <<04882>>02270000
          end                                                  <<04882>>02275000
       else exchangedb(0);                                     <<04882>>02280000
       putritentry := noproblem;                               <<04882>>02285000
                                                                        02290000
end; << putritentry >>                                                  02295000
$title "LENBUF - FINDS LENGTH, CRLF & CONTINUED"                        02300000
procedure lenbuf(buff,len,crlf,recno);                                  02305000
   byte array buff;                                                     02310000
   integer len;                                                <<02340>>02315000
   double recno;                                               <<02340>>02320000
   logical crlf;                                                        02325000
   option internal;                                                     02330000
begin                                                                   02335000
                                                                        02340000
                                                                        02345000
integer subroutine deblank(buff,width);                                 02350000
   value width; integer width;                                          02355000
   byte array buff;                                                     02360000
comment                                                                 02365000
   deblanks on right                                                    02370000
;                                                                       02375000
begin                                                                   02380000
                                                                        02385000
x := width -1;                                                          02390000
if buff(x) <> " " then deblank := width                                 02395000
else                                                                    02400000
begin                                                                   02405000
   tos := @buff(x);                                                     02410000
   assemble(dup,deca);                                                  02415000
   tos := -x;                                                           02420000
   assemble(cmpb 0);                                                    02425000
   s6 := -tos;  << deblank := -tos >>                                   02430000
   ddel;                                                                02435000
end;                                                                    02440000
                                                                        02445000
end; << deblank >>                                                      02450000
                                                                        02455000
   << find length of msg & if continued on next rec >>                  02460000
crlf := 0;                                                              02465000
len := deblank(buff,buffsizeb);                                         02470000
if buff(x:=len-1) = "&" or buff(x) = "%" then                           02475000
begin                                                                   02480000
   if buff(x) = "&" then crlf := %320;                                  02485000
   recno := recno + 1d; << continued on next record >>         <<02340>>02490000
      << now find length without % or & >>                              02495000
   len := deblank(buff,len -1);                                         02500000
end                                                                     02505000
else  recno := 0d;  << not continued >>                        <<02340>>02510000
                                                                        02515000
end; <<  lenbuf >>                                                      02520000
$title "READCAT"                                                        02525000
procedure readcat( recno, buff', recnolo, recnohi );           <<04707>>02530000
   value recno, recnolo, recnohi;                              <<04707>>02535000
   double recno, recnolo, recnohi;                             <<04707>>02540000
   array buff';                                                         02545000
   option uncallable;                                                   02550000
                                                                        02555000
comment                                                                 02560000
   reads a record from the message catalog.                             02565000
   recno - record number. no checking done on this no.                  02570000
   buff' - buffer as large as record size                               02575000
   cce     everything ok.                                               02580000
   ccl     attachio fail.                                               02585000
                                                               <<04707>>02590000
the attachio call in this procedure is optimized for the mpe   <<04707>>02595000
message facility.  this is indicated by the special values in  <<04707>>02600000
the flags parameter.  this special call requires a base sector <<04707>>02605000
address and a number of sectors in extent to be stacked before <<04707>>02610000
the call--thus, recnolo and recnohi are the limits of the      <<04707>>02615000
search for the message.  when these parameters are zero, there <<04707>>02620000
is no block search specified, and dummy values are given to the<<04707>>02625000
attachio call.                                                 <<04707>>02630000
                                                               <<04707>>02635000
;                                                                       02640000
begin                                                                   02645000
                                                                        02650000
equate                                                         <<04707>>02655000
   atflags = %100001;                                          <<04707>>02660000
                                                               <<04707>>02665000
double                                                         <<04707>>02670000
   atreturn;                                                   <<04707>>02675000
                                                               <<04707>>02680000
integer                                                        <<04707>>02685000
   atretstat = atreturn;                                       <<04707>>02690000
                                                               <<04707>>02695000
integer                                                                 02700000
   currentrec,                                                          02705000
   sects'in'ext,     << sectors in extent (for attachio). >>   <<04707>>02710000
   offset = currentrec,                                                 02715000
   recoffset;                                                           02720000
byte array buff(*)=buff';                                               02725000
<< variables for message disc address calculations.  >>        <<04362>>02730000
                                                               <<04707>>02735000
double tempadrd;     << for calculating sector addresses. >>   <<04707>>02740000
integer tempadrhi  = tempadrd,                                 <<04707>>02745000
        tempadrlo  = tempadrd + 1;                             <<04707>>02750000
                                                               <<04707>>02755000
double baseadr,      << base sector address for search.   >>   <<04707>>02760000
       highadr,      << limit sector address for search.  >>   <<04707>>02765000
       discadr;      << target sector address.            >>   <<04707>>02770000
                                                               <<04707>>02775000
integer  discadhi = discadr,                                   <<04707>>02780000
         discadlo = discadr + 1;                               <<04707>>02785000
                                                               <<04707>>02790000
                                                                        02795000
subroutine def'movefromdseg;                                            02800000
                                                                        02805000
subroutine def'movetodseg;                                              02810000
                                                                        02815000
double subroutine sector( rec );                               <<04707>>02820000
   value rec;                                                  <<04707>>02825000
   double rec;                                                 <<04707>>02830000
begin                                                          <<04707>>02835000
                                                               <<04707>>02840000
<< calculate a record's disc sector address.  first its   >>   <<04707>>02845000
<< sector offset is calculated (note: "//" is double      >>   <<04707>>02850000
<< divide), and this is added to the sysglob message base.>>   <<04707>>02855000
   offset := integer(                                          <<04707>>02860000
                double( rec // logical(blkfactor) )            <<04707>>02865000
                * sectperblkd                                  <<04707>>02870000
                + sectperblkd           );                     <<04707>>02875000
   tempadrhi := integer( absolute( msgbase ).(8:8) );          <<04707>>02880000
   tempadrlo := absolute( msgbase+1 );                         <<04707>>02885000
   tempadrd  := tempadrd + double( offset );                   <<04707>>02890000
   sector := tempadrd;                                         <<04707>>02895000
                                                               <<04707>>02900000
end;                                                           <<04707>>02905000
                                                               <<04707>>02910000
                                                                        02915000
condcode := cce;                                                        02920000
                                                                        02925000
<< get current record, see if recno is in dseg >>                       02930000
                                                                        02935000
movefromdseg(@currentrec,msgdstn,currentrecell,1);                      02940000
if (recno >= double(currentrec)) and                           <<02340>>02945000
   (recno <= double(currentrec+blkfactor-1)) then              <<02340>>02950000
else << go get it >>                                                    02955000
begin                                                                   02960000
   << offset of log. rec. in block >>                          <<02340>>02965000
   recoffset := integer(recno modd logical(blkfactor));        <<02340>>02970000
   discadr := sector( recno );                                 <<04707>>02975000
   if recnolo = 0d then    << no search block specified. >>    <<04707>>02980000
   begin                                                       <<04707>>02985000
      baseadr := discadr - 1d;                                 <<04707>>02990000
      sects'in'ext := 2;                                       <<04707>>02995000
   end                                                         <<04707>>03000000
   else                                                        <<04707>>03005000
   begin                   << calculate search limits.   >>    <<04707>>03010000
      baseadr := sector( recnolo );                            <<04707>>03015000
      sects'in'ext := integer(sector(recnohi)-baseadr) + 1;    <<04707>>03020000
   end;                                                        <<04707>>03025000
   tos := baseadr;   << stacked parms for attachio       >>    <<04707>>03030000
   tos := sects'in'ext;                                        <<04707>>03035000
   atreturn := attachio( absolute(msgbase).(0:8), 0, msgdstn,  <<04707>>03040000
      msgdirsize, 0, physblk,                                  <<04707>>03045000
      discadhi, discadlo, atflags );                           <<04707>>03050000
   ddel; del;  << pop attachio stacked parms >>                <<04707>>03055000
   if atretstat.(8:8) <> 1 then cclretn;                       <<04707>>03060000
                                                                        03065000
   << update current record ptr in dseg >>                              03070000
   currentrec := integer(recno // logical(blkfactor))          <<02340>>03075000
                 * blkfactor;                                  <<02340>>03080000
   movetodseg(msgdstn,currentrecell,@currentrec,1);                     03085000
end;                                                                    03090000
                                                                        03095000
   << recno in dseg. move to stack >>                                   03100000
movefromdseg(@buff',msgdstn,integer(recno-double(currentrec))  <<02340>>03105000
       * recsize + msgdirsize,buffsize);                       <<02340>>03110000
                                                                        03115000
                                                                        03120000
outl:                                                                   03125000
end; << readcat >>                                                      03130000
                                                               <<00820>>03135000
                                                               <<00820>>03140000
$title "FINDMSG"                                                        03145000
double procedure findmsg(setno,msgno,buff',len,crlf);          <<02340>>03150000
   value setno,msgno;                                                   03155000
   integer setno,msgno,len;                                             03160000
   array buff';                                                         03165000
   logical crlf;                                                        03170000
   option internal;                                                     03175000
comment                                                                 03180000
   fetches one line of message from msg catalog. transforms             03185000
   setno & msgno into record number & calls readcat to get              03190000
   msg.  rec no. is calculated by finding starting record               03195000
   number of first message in directory & adding in the                 03200000
   difference between msgno & first msg no. in catalog                  03205000
   (also in directory). if the msg found in the catalog                 03210000
   is not the one desired, a binary search is then done.                03215000
   buff' must be at least as large as record size.                      03220000
parameters                                                              03225000
   setno  = setno from genmsg.                                          03230000
   msgno  = msgno from genmsg.                                          03235000
   buff'  = array for message. must be "BUFFSIZE".                      03240000
   len    = length of message in positive bytes.                        03245000
   crlf   = %320 continue with no crlf.                                 03250000
          = 0 continue next msg. after crlf.                            03255000
returns                                                                 03260000
   - len is the length of the message.                                  03265000
   - findmsg is the record number of the continued msg. 0               03270000
     indicates no continuation.                                         03275000
   - ccg set number of 0, non-existent set or message.                  03280000
   - ccl readcat failed (attatchio error)                               03285000
;                                                                       03290000
begin                                                                   03295000
   integer array recno'array(0:2)=q;                                    03300000
   integer array head'array(0:1) =q;                                    03305000
                                                                        03310000
   integer                                                              03315000
      maxsetno = head'array,    << maxsetnocell >>                      03320000
      numrecs  = head'array +1, << maxrecell >>                         03325000
      msgnolen = maxsetno;      << maxsetno overlaid >>        <<02340>>03330000
   logical                                                              03335000
      sirn;                                                             03340000
                                                                        03345000
  double                                                       <<02340>>03350000
      recno'lo,                 << set'roffset >>              <<02340>>03355000
      recno,                    << set'first'msg >>            <<02340>>03360000
      recno'hi,                 << next'set'roffset >>         <<02340>>03365000
      recbnd,                                                  <<02340>>03370000
      dumrecno,                                                <<02340>>03375000
      recno'new;                                               <<02340>>03380000
                                                               <<02340>>03385000
   integer                                                              03390000
      vector;                                                           03395000
   byte array buff(*)=buff';                                            03400000
                                                                        03405000
subroutine def'movefromdseg;                                            03410000
                                                                        03415000
integer subroutine chkmsgno(rectest);                                   03420000
   value rectest;                                                       03425000
   double rectest;                                             <<02340>>03430000
comment                                                                 03435000
   reads catalog & checks to see if line contains message no.           03440000
   sets msgnolen.                                                       03445000
;                                                                       03450000
begin                                                                   03455000
      << test recno limits.missing msgno will fail, since >>            03460000
      << lo & hi limits contract >>                                     03465000
                                                                        03470000
      if (rectest >= recno'lo) and (rectest <= recno'hi) then  <<02340>>03475000
      begin                                                             03480000
         readcat(rectest,buff',recno'lo,recno'hi);             <<04707>>03485000
         if < then cclretn;                                             03490000
      end                                                               03495000
      else ccgretn;                                                     03500000
                                                                        03505000
      << now find msgno in msg >>                                       03510000
                                                                        03515000
      << extract msgno len for binary >>                                03520000
      tos := @buff;                                                     03525000
      assemble(dup,dup);                                                03530000
      move * := * while n,1;                                            03535000
      msgnolen := -(tos -tos);                                          03540000
                                                               <<01321>>03545000
<< make sure current line isn't a continuation line. >>        <<01321>>03550000
   if msgnolen <> 0  and  rectest > recno'lo then              <<01321>>03555000
   begin                                                       <<01321>>03560000
                                                               <<01321>>03565000
      dumrecno := rectest -1d;                                 <<02340>>03570000
      readcat(dumrecno,buff',recno'lo,recno'hi);               <<04707>>03575000
      lenbuf( buff, len, crlf, dumrecno );                     <<01321>>03580000
      if dumrecno = 0d                                         <<02340>>03585000
         then readcat(rectest,buff',recno'lo,recno'hi)         <<04707>>03590000
         else msgnolen := 0;                                   <<01321>>03595000
                                                               <<01321>>03600000
   end;                                                        <<01321>>03605000
                                                               <<01321>>03610000
      chkmsgno := msgnolen;                                             03615000
end; << chkmsgno >>                                                     03620000
                                                                        03625000
<< procedure main body >>                                               03630000
                                                                        03635000
sirn := getsir(msgsir);                                                 03640000
   << can now use ccretn mechanism >>                                   03645000
                                                                        03650000
condcode := cce;                                                        03655000
if msgdstn = 0 then ccgretn;                                            03660000
if msgno < 0 then ccgretn;                                              03665000
vector := 1; << move forward initially >>                               03670000
                                                                        03675000
                                                                        03680000
<< get maxsetno,numrecs from directory >>                               03685000
movefromdseg(@head'array,msgdstn,0,2);                                  03690000
                                                                        03695000
if setno < 1   << invalid set no >>                                     03700000
   or setno > maxsetno then ccgretn;                                    03705000
                                                                        03710000
<< get set'roffset,set'firstmsg,next'set'roffset >>                     03715000
movefromdseg(@recno'array,msgdstn,setno*2,3);                           03720000
                                                                        03725000
<< recno'lo = set'roffset >>                                            03730000
<< recno    = set'firstmsg >>                                           03735000
<< recno'hi = next'set'roffset >>                                       03740000
recno'lo := double(recno'array);                               <<02340>>03745000
recno := double(recno'array(1));                               <<02340>>03750000
recno'hi := double(recno'array(2));                            <<02340>>03755000
recbnd := double(numrecs);                                     <<02340>>03760000
                                                               <<02340>>03765000
if recno = -1d  then ccgretn;  << set not present >>           <<02340>>03770000
                                                                        03775000
<< set bounds on rec. no. for this set >>                               03780000
recno'hi := if setno = maxsetno then double(numrecs)           <<02340>>03785000
   else recno'hi -1d;                                          <<02340>>03790000
                                                                        03795000
<< set recno for setno,msgno >>                                         03800000
recno := recno'lo + double(msgno) - recno;                     <<02340>>03805000
<< set'roffset +msgno -set'firstmsg >>                                  03810000
if recno >= recno'hi then << set at upper bounds >>                     03815000
begin                                                                   03820000
   recno := recno'hi;                                                   03825000
   vector := -1;                                                        03830000
end;                                                                    03835000
                                                                        03840000
recbnd := -1d; << forces chkmsgno call 1st time thru >>        <<02340>>03845000
   << search for correct msgno loop >>                                  03850000
                                                                        03855000
while true do                                                           03860000
begin                                                                   03865000
   if recbnd <> recno then << go fetch a new message >>                 03870000
      while chkmsgno(recno) = 0  do recno := recno -1d;        <<02340>>03875000
      << if rec doesn't have msgno, go backwards >>                     03880000
      << now have rec containing msgno, find if correct>>               03885000
   tos := binary(buff,msgnolen); <<set in chkmsgno>>                    03890000
   tos := tos -msgno; del;                                              03895000
   if = then << fetched correct msg >>                                  03900000
   begin << move msg over msgno & adjust len >>                         03905000
                                                                        03910000
         << now find end of msg & if cont'd. >>                         03915000
      lenbuf(buff,len,crlf,recno);                                      03920000
      findmsg := recno;                                                 03925000
                                                                        03930000
      len := len-(msgnolen +1);                                         03935000
         << move msg over msgno        >>                               03940000
         << message starts 1 past msgno>>                               03945000
      move buff := buff(msgnolen +1),(len);                             03950000
                                                                        03955000
      go outl; << only successful exit >>                               03960000
                                                                        03965000
   end;                                                                 03970000
                                                                        03975000
      << didn't find msg. no. now binary search >>                      03980000
   if < then vector := +1 else vector := -1;                            03985000
      << if msgno lo, then +1.if hi, then -1 >>                         03990000
   recno'new := (recno + double(recno'array(1+vector)))/2d;    <<02340>>03995000
      << set bound at record with msgno >>                              04000000
   recbnd := recno;                                                     04005000
      << boundary record must be a record containing a >>               04010000
      << message no. recbnd will be either new hi or lo>>               04015000
   do recbnd := recbnd + double(vector)                        <<02340>>04020000
      until chkmsgno(recbnd) <> 0;                             <<02340>>04025000
   recno'array(1-vector) := integer(recbnd); <<new hi or lo >> <<02340>>04030000
   <<vector=1 then want recno'lo; if -1 then recno'hi>>        <<02340>>04035000
   if vector=1 then recno'lo:=double(recno'array(1-vector))    <<02340>>04040000
    else recno'hi:=double(recno'array(1-vector));              <<02340>>04045000
                                                               <<02340>>04050000
   recno := if recno=recno'new then recno+double(vector)       <<02340>>04055000
    else if(recno'new >= recno'lo) and (recno'new <= recno'hi) <<02340>>04060000
         then recno'new  else double(recno'array(1-vector));   <<02340>>04065000
      << if new same as old, bump. if new falls out of>>                04070000
      << limits because of multiple lines/msg set at  >>                04075000
      << new bound                                    >>                04080000
end; << find msgno loop >>                                              04085000
                                                                        04090000
outl:                                                                   04095000
      relsir(msgsir,sirn);                                              04100000
end; << findmsg >>                                                      04105000
$title "FORMSG"                                                         04110000
integer procedure formsg(inbuff,setno,msgno,mask,p1,p2,p3,              04115000
      p4,p5,outbuff,outbuffsize,outlen,dest,control);                   04120000
   value setno,msgno,mask,p1,p2,p3,p4,p5,outbuffsize,                   04125000
      dest,control;                                                     04130000
   byte array inbuff,outbuff;                                           04135000
   integer setno,msgno,outbuffsize,dest,outlen;                         04140000
   logical mask,p1,p2,p3,p4,p5,control;                                 04145000
   option uncallable;                                                   04150000
comment                                                                 04155000
                                                                        04160000
this procedure assembles and routes messages. up to 5                   04165000
parameters can be formatted & inserted. message can come from           04170000
message catalog or be passed in. input message can be                   04175000
catenated with string in output buffer. assembled message is            04180000
placed in ouput buffer. message may then be routed to                   04185000
destination. when output buffer is filled, message is sent to           04190000
destination & buffer refilled until message is complete.                04195000
                                                                        04200000
inbuff   input buffer. if it contains message, message must             04205000
         terminated by a zero. if message is in catalog                 04210000
         inbuff must be 'buffsize'.                                     04215000
                                                                        04220000
setno    message set number.                                            04225000
         = -1  - message is in inbuff.                                  04230000
         = >0  - message set number in catalog.                         04235000
                                                                        04240000
msgno    message number. must be greater than zero.                     04245000
                                                                        04250000
mask     indicates parameter types.                                     04255000
         .(0:1) = no parameters.                                        04260000
         .(1:3) = type of p1.                                           04265000
         .(4:3) = type of p2.                                           04270000
         .(7:3) = type of p3.                                           04275000
         .(10:3)= type of p4.                                           04280000
         .(13:3)= type of p5.                                           04285000
                                                                        04290000
         type = 0 - parm is string byte pointer, terminated             04295000
                    by zero.                                            04300000
                1 - parm is integer.                                    04305000
                2 - parm is double by reference.                        04310000
                3 - ignore this parm.                                   04315000
                                                                        04320000
p1,p2,p3,p4,p5  - parameter, as indicated by mask.                      04325000
                                                                        04330000
outbuff  message is scanned in inbuff & moved to outbuff as    <<00106>>04335000
         is formatted. when buffer is full, message is                  04340000
         routed.                                               <<01321>>04345000
                                                               <<01321>>04350000
                                                                        04355000
outbuffsize  size of outbuff  in positive bytes.               <<00106>>04360000
                                                                        04365000
outlen   length of string in outbuff  in positive bytes.       <<00106>>04370000
         must be set to zero when formsg called if outbuff  is <<00106>>04375000
         empty. outlen > 0 indicates catenation of string               04380000
         in outbuff  with input message.                       <<00106>>04385000
                                                                        04390000
dest     destination.                                                   04395000
         = -fnum  - file number.                                        04400000
         = -2     - $stdlist                                            04405000
         = -1     - nowhere--message disappears.               <<01321>>04410000
         = 0      - not used.                                           04415000
         = ldev   - terminal.                                           04420000
                                                                        04425000
control  (terminals only) flag word.                                    04430000
         .(0:1)  = each write will have cctl %320.                      04435000
                                                                        04440000
         .(2:2)  = funny termtype. translate into apl.                  04445000
                                                                        04450000
         .(14:2) = iotype for attachio.                                 04455000
                   0 - standard.                                        04460000
                   1 - soft preemption.                                 04465000
                   2 - hard preemtpion.                                 04470000
returns  - the next message value in the current message is             04475000
           returned. if none, -1 is returned.                           04480000
                                                               <<01321>>04485000
                                                               <<01321>>04490000
condition code                                                          04495000
           cce = everything ok                                          04500000
           ccg = something wrong, but printed something                 04505000
           ccl = i/o failure (attachio, print, fwrite).                 04510000
;                                                                       04515000
                                                               <<07395>>04520000
<<*********************************************************>>  <<07395>>04525000
<<                                                         >>  <<07395>>04530000
<< fix information:  this fix will print the status and    >>  <<07395>>04535000
<< delta-p of the stack marker that called genmsg and the  >>  <<07395>>04540000
<< stack marker back past that one when a missing message  >>  <<07395>>04545000
<< is detected.  hopefully, this information will help us  >>  <<07395>>04550000
<< find the problem easier.                                >>  <<07395>>04555000
<<                                                         >>  <<07395>>04560000
<<*********************************************************>>  <<07395>>04565000
begin                                                                   04570000
integer                                                                 04575000
   zerostop,                                                            04580000
   tanki,                                                               04585000
   index,                                                               04590000
   inlen,                     <<input buf: length  >>                   04595000
   inx,                       <<input buf: index >>                     04600000
   outx,                      <<output buf: index >>                    04605000
   pnum,                                                                04610000
   final'outdev,    <<actual device for output>>               <<00702>>04615000
   dit,term,                                                   <<00702>>04620000
   dstx,                                                       <<02802>>04625000
   crit,      <<old critical state>>                           <<02802>>04630000
   ioqx,      <<attachio ioq index>>                           <<02802>>04635000
   savestatus,    << status of traps >>                                 04640000
   sirn;                                                                04645000
                                                               <<07395>>04650000
integer                                                        <<07395>>04655000
   which,             << specifies a stack marker for the  >>  <<07395>>04660000
                      << call to stackmark.                >>  <<07395>>04665000
   stat, delp;        << return values from stackmark.     >>  <<07395>>04670000
                                                               <<07395>>04675000
                                                                        04680000
double                                                         <<02340>>04685000
   recno;                                                      <<02340>>04690000
integer lpdt'index; << index into lpdt/incllpdt >>             <<06224>>04695000
                                                               <<02340>>04700000
logical crlf;                                                           04705000
logical up:=true;                                              <<00702>>04710000
equate sysglob=%1000, lpdtbase=%10, lpdtsize=2;                <<00702>>04715000
equate iomsgpin = sysglob+%152;   <<sysdb location of pin>>    <<02802>>04720000
define iomsgproc = absolute(iomsgpin)/pcbsize#;                <<02802>>04725000
define dit'upbit=dit).(1:1#,                                   <<00702>>04730000
       dit'term=dit+7).(5:5#;                                  <<00702>>04735000
                                                               <<01646>>04740000
<< variables for routing device     >>                         <<01646>>04745000
<< messages to the associated user. >>                         <<01646>>04750000
                                                               <<01646>>04755000
integer array                                                  <<01646>>04760000
   msg'dst'buf(0:3),    << message bufs header area >>         <<02802>>04765000
   ass'ent(0:ass'entrysize-1),   << entry from asoc. table >>  <<01646>>04770000
<< ......................................................... >><<06592>>04775000
<<        declarations for referencing the jmat              >><<06592>>04780000
<<   jmatarr -- is a local array into which an entry gets    >><<06592>>04785000
<<              read.  (i.e. jmatarr(0) = entryword 0)       >><<06592>>04790000
<<   jmatinx -- is an index used by the include file to      >><<06592>>04795000
<<              reference a specific entry if jmatarr(0) was >><<06592>>04800000
<<              the first word of the jmatheader. here, since>><<06592>>04805000
<<              jmatarr is local this will be 0.             >><<06592>>04810000
<< ......................................................... >><<06592>>04815000
   jmatarr(0:jmatentrysize-1); << holds entry from jmat >>     <<06592>>04820000
integer                                                        <<06592>>04825000
   jmatinx;    <<  index into jmatarr used by include file  >> <<06592>>04830000
array qarray(*)=q+0;                                           << 7469>>04835000
                                                               << 7469>>04840000
integer pcbglobloc;                                            << 7469>>04845000
                                                               <<01646>>04850000
integer                                                        <<01646>>04855000
   divert'device := 0,  << output device for asoc'd user >>    <<01646>>04860000
   highest'ldev;        << last ldev# in lpdt/asoc. table >>   <<01646>>04865000
                                                               <<01646>>04870000
                                                                        04875000
logical pcbpt;                                                 <<06590>>04880000
pointer inbuff';              <<input buf: word ptr>>                   04885000
pointer outbuff';             <<output buf: word ptr >>                 04890000
integer array parm'ia(*) = p1;<<parm buf: input >>                      04895000
byte array buff1(0:11);       <<parm buf: output >>                     04900000
                                                               <<ks.01>>04905000
   subroutine logit(dest);                                     <<ks.01>>04910000
   value dest;                                                 <<ks.01>>04915000
   integer dest;                                               <<ks.01>>04920000
   begin                                                       <<ks.01>>04925000
      if dest=sys'console'ldev<<output to console?>>           <<06877>>04930000
         then log15(outx,@outbuff,outx,15); <<then log it>>    <<ks.01>>04935000
   end; <<logit>>                                              <<ks.01>>04940000
                                                               <<ks.01>>04945000
subroutine def'movetodseg;                                              04950000
subroutine def'movefromdseg;                                   <<00552>>04955000
integer subroutine getxdsbuf;                                  <<02802>>04960000
<< this procedure obtains an available buffer in >>            <<02802>>04965000
<< the msg system buffer xds and returns its     >>            <<02802>>04970000
<< index.  if no buffer is available, this pin   >>            <<02802>>04975000
<< is impeded, waiting for a buffer.             >>            <<02802>>04980000
begin                                                          <<02802>>04985000
                                                               <<02802>>04990000
<<get msg sir to insure that we have exclusive   >>            <<02802>>04995000
<<access to the msg system buffer.               >>            <<02802>>05000000
                                                               <<02802>>05005000
try'to'get'it'again:                                           <<02802>>05010000
                                                               <<02802>>05015000
sirn := getsir(msgsir);                                        <<02802>>05020000
                                                               <<02802>>05025000
<<move msg buf header to our stack>>                           <<02802>>05030000
movefromdseg(@msg'dst'buf,iomsgdst,0,4);                       <<02802>>05035000
                                                               <<02802>>05040000
<<obtain next buffer in chain>>                                <<02802>>05045000
if msg'dst'buf(2) = 0 then                                     <<02802>>05050000
  begin  <<all buffers are currently being used>>              <<02802>>05055000
  pdisable;                                                    <<02802>>05060000
  relsir(msgsir,sirn); <<release sir>>                         <<02802>>05065000
  <<link this pcb into queue for buffer>>                      <<02802>>05070000
  tos := curprc/pcbsize; << current process pin >>             <<06590>>05075000
  tos := iomsgqueue;   <<first pcb waiting>>                   <<02802>>05080000
  if = then                                                    <<02802>>05085000
    begin << this pin is to be first in-line >>                <<02802>>05090000
    assemble(xch); << put my pin on tos >>                     <<02802>>05095000
    iomsgqueue := tos; << save pin in impede list >>           <<02802>>05100000
                                                               <<02802>>05105000
    << since this is 1st in line, waken iomsgproc as if >>     <<02802>>05110000
    << a timer popped, so it can set up a watchdog timer>>     <<02802>>05115000
    awake(absolute(iomsgpin),%10<<timer>>,0);                  <<02802>>05120000
                                                               <<02802>>05125000
    end                                                        <<02802>>05130000
  else                                                         <<02802>>05135000
    begin  << there are other pins waiting >>                  <<02802>>05140000
    << because iomsgqueue is a pin and the nimppimwordnum >>   <<06590>>05145000
    << is a pcb relative index, we have to be very care-  >>   <<06590>>05150000
    << ful to store the correct value in each location.   >>   <<06590>>05155000
    do tos := lpcb(tos*pcbsize+nimppinwordnum)/pcbsize         <<06590>>05160000
       until =; << find end pin on list >>                     <<02802>>05165000
    assemble(xch);  << put my pin on tos >>                    <<02802>>05170000
    lpcb(x) := s0*pcbsize;                                     <<06590>>05175000
    assemble(del);  << remove my pin from tos >>               <<02802>>05180000
    end;                                                       <<02802>>05185000
                                                               <<02802>>05190000
  << make sure my nimp is zero >>                              <<02802>>05195000
  pcbpt := curprc;                                             <<06590>>05200000
  spcbnimppin := 0;                                            <<06590>>05205000
  << impede, waiting for iomsgproc to release a buffer >>      <<02802>>05210000
  impede(*);  << zero was left on tos >>                       <<02802>>05215000
                                                               <<02802>>05220000
  << now, go and try obtaining buffer all over again >>        <<02802>>05225000
  go to try'to'get'it'again;                                   <<02802>>05230000
  end                                                          <<02802>>05235000
else                                                           <<02802>>05240000
  begin  << there is an avail buffer, so do necessary linking ><<02802>>05245000
                                                               <<02802>>05250000
  << see if next pointer is valid >>                           <<02802>>05255000
  if msg'dst'buf(2) > (msg'dst'buf*msg'dst'buf(1)) <<out of tab<<02802>>05260000
     or                                                        <<02802>>05265000
     (msg'dst'buf(2)-4) mod msg'dst'buf(1) <> 0 then << boundar<<02802>>05270000
    begin                                                      <<02802>>05275000
    relsir(msgsir,sirn);                                       <<02802>>05280000
    return;    << no good - problem exists >>                  <<02802>>05285000
    end;                                                       <<02802>>05290000
                                                               <<02802>>05295000
  << save index as return from typed subroutine >>             <<02802>>05300000
  getxdsbuf := msg'dst'buf(2);                                 <<02802>>05305000
                                                               <<02802>>05310000
  << update pointer to next available buffer >>                <<02802>>05315000
  movefromdseg(@msg'dst'buf(2),iomsgdst,msg'dst'buf(2),1);     <<02802>>05320000
  << if this is the end of avail bufs, mark trlr 0 >>          <<02802>>05325000
  if msg'dst'buf(2) = 0 then                                   <<02802>>05330000
    msg'dst'buf(3) := 0;                                       <<02802>>05335000
  movetodseg(iomsgdst,2,@msg'dst'buf(2),2);                    <<02802>>05340000
                                                               <<02802>>05345000
  relsir(msgsir,sirn);                                         <<02802>>05350000
  end;                                                         <<02802>>05355000
end;  << of subroutine getxdsbuf >>                            <<02802>>05360000
                                                                        05365000
subroutine printit; << handles routing of output >>                     05370000
begin                                                                   05375000
   if control.funnyterm <> 0 then << translate into apl >>              05380000
      apltranslateout(outbuff,outx,control.funnyterm);                  05385000
   if control&csl(1) then crlf := %320; << override >>                  05390000
   if dest < 0 then << return string or fwrite >>                       05395000
   begin  << $stdlist is done here >>                                   05400000
      if dest < -1 then << fwrite >>                                    05405000
      begin                                                             05410000
         pxglobal;                                             << 7469>>05415000
         if (dest=-2) and pxg'jobtype=1<<session>> and         << 7469>>05420000
            jobsessionmain then                                <<01998>>05425000
         begin                                                          05430000
            tos := attachio(pxg'inputldev,0,0,@outbuff',1,     << 7469>>05435000
               -outx,crlf,0,1); << bypass filesys >>                    05440000
         del;                                                           05445000
         if tos.(13:3) <> 1 then cclretn;                               05450000
         end                                                            05455000
         else                                                           05460000
         begin                                                          05465000
            fwrite(-dest,outbuff',-outx,crlf);                          05470000
            if <> then cclretn;                                         05475000
         end;                                                           05480000
      end;                                                              05485000
      << dest = -1, do nothing.  message disappears. >>        <<01321>>05490000
   end                                                                  05495000
   else << dest >= 0, go to some device - no wait i/o>>                 05500000
   begin                                                                05505000
         logit(dest); <<log message possible console msg>>     <<ks.01>>05510000
                                                               <<02802>>05515000
      << make sure enough stack is here b/4 critical >>        <<02802>>05520000
      assemble(adds 255;subs 255);                             <<02802>>05525000
                                                               <<02802>>05530000
      << set critical to not abort while owning buffers >>     <<02802>>05535000
      crit := setcritical;                                     <<02802>>05540000
                                                               <<02802>>05545000
      << get buffer index to place message into >>             <<02802>>05550000
      dstx := getxdsbuf;                                       <<02802>>05555000
      if dstx = 0 then                                         <<02802>>05560000
        begin  << failed to get a buffer >>                    <<02802>>05565000
        resetcritical(crit);                                   <<02802>>05570000
        cclretn;                                               <<02802>>05575000
        end;                                                   <<02802>>05580000
                                                               <<02802>>05585000
      << move data to xds >>                                   <<02802>>05590000
      movetodseg(iomsgdst,dstx,@outbuff',(outx+1)&lsr(1));     <<02802>>05595000
                                                               <<00702>>05600000
<< first determine actual output device,  then if system >>    <<00702>>05605000
<< console and not logged on, allocate                   >>    <<00702>>05610000
<< output message, and if an allocation was done, then   >>    <<00702>>05615000
<< deallocate device                                     >>    <<00702>>05620000
                                                               <<00702>>05625000
final'outdev:=if divert'device=0 then dest else divert'device; <<00702>>05630000
lpdt'index:=final'outdev*integer(lpdt'entry'size);             <<06224>>05635000
if final'outdev=sys'console'ldev then <<sys console>>          <<06877>>05640000
begin                                                          <<00702>>05645000
   << turn traps off in case lpdt is to high up >>             <<04265>>05650000
   << we could get an integer overflow and sf 311 >>           <<04265>>05655000
   push(status);                                               <<04265>>05660000
   savestatus.(15:1) := s0.(2:1);  <<status of traps>>                  05665000
   tos.(2:1) := 0;                                             <<04265>>05670000
   set(status);                                                <<04265>>05675000
   dit:=absolute(sysglob+lpdt'dit'ptr);                        <<06224>>05680000
   << put traps back on >>                                     <<04265>>05685000
   push(status);                                               <<04265>>05690000
   tos.(2:1) := savestatus.(15:1);                             <<07167>>05695000
   set(status);                                                <<04265>>05700000
   up:=logical((dit'upbit)=1);                                 <<06224>>05705000
<< term:=absolute(dit'term); >>  << use default term type >>   <<02316>>05710000
   if not up then                                              <<00702>>05715000
      attachio(final'outdev,0,0,0,24,0,0,0,1);                 <<02316>>05720000
end;                                                           <<00702>>05725000
                                                               <<00702>>05730000
      tos := attachio(final'outdev                             <<02802>>05735000
             ,0,iomsgdst, << where message was put>>           <<02802>>05740000
          dstx,1,-outx,crlf,0,control.(14:2)&lsl(7));          <<02802>>05745000
      assemble(del);                                           <<02802>>05750000
      ioqx := tos;   <<store ioq index>>                       <<02802>>05755000
      if not up then attachio(final'outdev,0,0,0,4,0,0,0,1);   <<00702>>05760000
   <<send ioq to iomessageproc to wait for completion>>        <<02802>>05765000
   tos := 2;  <<msg type 2 is ioq>>                            <<02802>>05770000
   tos := ioqx; <<ioq index>>                                  <<02802>>05775000
   tos := dstx; <<dst used to perform i/o>>                    <<02802>>05780000
   tos := 0;    <<not used>>                                   <<02802>>05785000
   sendmsg(iomsgproc,0<<port 0>>,4<<length of msg>>,%140000);  <<02802>>05790000
                                                               <<02802>>05795000
   <<reset critical so can abort now>>                         <<02802>>05800000
   resetcritical(crit);                                        <<02802>>05805000
                                                               <<02802>>05810000
   end;                                                                 05815000
                                                                        05820000
   outlen := outx; <<indicate contents of outbuff>>                     05825000
   outx := 0; <<reset index to refill outbuff>>                         05830000
end; << printit >>                                                      05835000
                                                                        05840000
subroutine tank(length,string);                                         05845000
   value length;                                                        05850000
   integer length;                                                      05855000
   byte array string;                                                   05860000
begin                                                                   05865000
   if length=0 then return;                                    <<00106>>05870000
   tanki := -1;                                                         05875000
   while (tanki := tanki+1) < length do << tanking loop>>               05880000
   begin                                                                05885000
      if outx >= outbuffsize then printit; <<flush outbuff>>   <<00106>>05890000
      outbuff(outx) := string(tanki);                          <<00106>>05895000
      outx := outx+1;                                          <<00106>>05900000
   end; <<tank loop>>                                                   05905000
end; << tank >>                                                         05910000
                                                                        05915000
subroutine insertparm;                                                  05920000
begin                                                                   05925000
   << catch boundary condition on last char "!" >>             <<00261>>05930000
   if pnum >= 5 then return;                                   <<00261>>05935000
   case *integer((mask &csl(4+pnum*3)) land 3) of << parm x >>          05940000
   begin                                                                05945000
      begin << 0: string parm >>                                        05950000
         tos := parm'ia(pnum);                                          05955000
         assemble(dup,dup);                                             05960000
         scan * until 0,1;                                              05965000
         assemble(xch,sub;xch);                                         05970000
         tank(*,*);                                                     05975000
      end;                                                              05980000
                                                                        05985000
      << 1: integer by value >>                                         05990000
      begin                                                    <<01456>>05995000
                                                               <<01456>>06000000
      if inbuff(index) = "\" then << expect ldev # >>          <<01456>>06005000
      begin                                                    <<01456>>06010000
      highest'ldev:=lpdt'max'entries;                          <<06224>>06015000
         if 1 <= parm'ia(pnum) <= highest'ldev then            <<01456>>06020000
         begin   << valid ldev >>                              <<01456>>06025000
            << get associate table entry for ldev >>           <<01456>>06030000
            sirn := getsir(ass'sir);  << lock asoc. table >>   <<01646>>06035000
            movefromdseg(@ass'ent,ass'dst,                     <<01456>>06040000
               parm'ia(pnum)*ass'entrysize,ass'entrysize);     <<01646>>06045000
            if ass'ent(ass'jmat)<>0 then <<ldev is associated>><<01456>>06050000
            begin                                              <<01456>>06055000
               jmatinx := 0;  << jmatarr is local >>           <<06592>>06060000
               << get new ldev from jmat entry >>              <<01456>>06065000
               movefromdseg(@jmatarr, jmatdst,                 <<06592>>06070000
                            ass'ent(ass'jmat)*jmatentrysize,   <<06592>>06075000
                            jmatentrysize);                    <<06592>>06080000
               divert'device := jmatjlistdev;                  <<06592>>06085000
            end;                                               <<01456>>06090000
            << don't release asoc. table until after getting >><<01646>>06095000
            << jmat entry to ensure its validity.            >><<01646>>06100000
            relsir(ass'sir,sirn);                              <<01646>>06105000
         end;                                                  <<01456>>06110000
      end;                                                     <<01456>>06115000
                                                               <<01456>>06120000
      tank(ascii(parm'ia(pnum),10,buff1),buff1);                        06125000
                                                               <<01456>>06130000
      end;  << of integer by value >>                          <<01456>>06135000
                                                                        06140000
      << 2: double by reference >>                                      06145000
      begin                                                             06150000
         tos := parm'ia(pnum);                                          06155000
         tank(dascii(dps0,10,buff1),buff1); del;                        06160000
      end;                                                              06165000
                                                                        06170000
      ;<< 3 ignore parm >>                                              06175000
                                                                        06180000
   end; << case of parms >>                                             06185000
   pnum := pnum+1;                                                      06190000
end; <<insertparm>>                                                     06195000
                                                                        06200000
<< ........................................................ >> <<06592>>06205000
<<                                                          >> <<06592>>06210000
<<          ***** main body of formsg *****                 >> <<06592>>06215000
<<                                                          >> <<06592>>06220000
<< ........................................................ >> <<06592>>06225000
                                                                        06230000
                                                                        06235000
<< set up variables >>                                                  06240000
crlf := zerostop := 0; << stopper for input string scan >>              06245000
condcode := cce;                                                        06250000
formsg := -1; << set to no continuation >>                              06255000
@inbuff' := @inbuff &lsr(1);                                            06260000
@outbuff' := @outbuff & lsr(1);                                         06265000
                                                                        06270000
<< string passed in, or catalog fetch ? >>                              06275000
if setno = -1 then                                                      06280000
                                                                        06285000
<< string passed in >>                                                  06290000
                                                                        06295000
begin                                                                   06300000
   scan inbuff until 0,1; << stopped by zerostop>>                      06305000
   inlen := tos -@inbuff;                                               06310000
   recno := 0d;  << indicate no continued msgs >>              <<02340>>06315000
end                                                                     06320000
else                                                                    06325000
                                                                        06330000
<< fetch from catalog >>                                                06335000
                                                                        06340000
begin                                                                   06345000
   recno := findmsg(setno,msgno,inbuff',inlen,crlf);                    06350000
   if < then cclretn;                                                   06355000
   if > then <<can't find msg. print diag. msg>>                        06360000
   begin                                                                06365000
      move inbuff := ("MISSING MSG. SET=!. MESSAGE=!.",0);              06370000
      genmsg(-1,@inbuff,%11000,setno,msgno,,,,dest,                     06375000
         ,,,control.(14:2));                                            06380000
      if not mask&csl(1) then                                           06385000
      begin                                                             06390000
         move inbuff := ("PARM(S)= !;!;!;!;!",0);                       06395000
         genmsg(-1,@inbuff,mask,p1,p2,p3,p4,p5,                         06400000
            dest,,,,control.(14:2));                                    06405000
      << if parms present then print them >>                            06410000
      end;                                                              06415000
                                                               <<07395>>06420000
   << print the stack markers for the procedure that       >>  <<07395>>06425000
   << called genmsg and the procedure that called the      >>  <<07395>>06430000
   << genmsg caller.                                       >>  <<07395>>06435000
      move inbuff := "GENMSG CALLER    STATUS:  %         ";   <<07395>>06440000
      move inbuff(27) := "     ; DELTA-P:  %        ";         <<07395>>06445000
      inbuff(53) := 0;                                         <<07395>>06450000
      which := 1;                                              <<07395>>06455000
      stackmark( which, , stat, delp );                        <<07395>>06460000
      if = then                                                <<07395>>06465000
      begin                                                    <<07395>>06470000
         ascii( stat, 8, inbuff(27) );                         <<07395>>06475000
         ascii( delp, 8, inbuff(45) );                         <<07395>>06480000
         genmsg( -1, @inbuff,,,,,,,dest,,,,control.(14:2));    <<07395>>06485000
      end;                                                     <<07395>>06490000
      move inbuff(13) := "+1";                                 <<07395>>06495000
      which := 2;                                              <<07395>>06500000
      stackmark( which, , stat, delp );                        <<07395>>06505000
      if = then                                                <<07395>>06510000
      begin                                                    <<07395>>06515000
         ascii( stat, 8, inbuff(27) );                         <<07395>>06520000
         ascii( delp, 8, inbuff(45) );                         <<07395>>06525000
         genmsg( -1, @inbuff,,,,,,,dest,,,,control.(14:2));    <<07395>>06530000
      end;                                                     <<07395>>06535000
      ccgretn;                                                          06540000
   end;                                                                 06545000
end;                                                                    06550000
                                                                        06555000
<< set up loop variables >>                                             06560000
pnum := index := inx := outx := 0;                                      06565000
outx := outlen; << skip past any initial stuff >>                       06570000
                                                                        06575000
<< now go to work on input string & format >>                           06580000
                                                                        06585000
loop:                                                                   06590000
   if (inbuff(index) = "!") or                                 <<01456>>06595000
      (inbuff(index) = "\") then <<insert parm or next msgno?>><<01456>>06600000
   begin                                                                06605000
      tank(index-inx,inbuff(inx));<<dump buff up to !>>                 06610000
      if inbuff(index+1)=numeric and inlen >index+1 then                06615000
      begin <<next msgno !xxx >>                                        06620000
         formsg := binary(inbuff(x),inlen-x);                           06625000
         if <> then condcode:= ccg; <<bad nextmsg>>                     06630000
         inlen := index;                                                06635000
         inx := index + 1;  << advance past "!" >>             <<01524>>06640000
      end                                                               06645000
      else                                                              06650000
      if not mask&csl(1) then                                           06655000
      begin << parms present >>                                         06660000
         insertparm;                                                    06665000
         inx := index+1; << advance past !>>                            06670000
      end                                                               06675000
      else inx := index; <<! wasn't parm >>                             06680000
   end;                                                                 06685000
                                                                        06690000
   << refill buff? >>                                                   06695000
   if index>=inlen-1 then <<end of line>>                      <<00616>>06700000
   begin                                                                06705000
      if inlen>=0 then tank(index-inx+1,inbuff(inx));          <<00662>>06710000
      if outx <>0  << flush out >>                                      06715000
         or inlen = 0 << need crlf >> then printit;                     06720000
      inx := index:= 0;                                                 06725000
      if recno <> 0d then                                      <<02340>>06730000
      begin                                                             06735000
         sirn := getsir(msgsir);                                        06740000
         readcat(recno,inbuff',0d,0d); << no search block >>   <<04707>>06745000
            << now get length,crlf, cont'd >>                           06750000
         if < then condcode := ccl;                                     06755000
         lenbuf(inbuff,inlen,crlf,recno);                               06760000
         relsir(msgsir,sirn);                                           06765000
         if condcode = ccl then return;                                 06770000
         index := -1; << reset for loop>>                               06775000
      end                                                               06780000
      else                                                              06785000
      go outl << all finished >>                                        06790000
   end;                                                                 06795000
   index := index+1;                                                    06800000
go loop; <<end scan thru msg loop >>                                    06805000
                                                                        06810000
outl:                                                                   06815000
                                                                        06820000
end; << formsg >>                                                       06825000
$page "GENMSG"                                                          06830000
integer procedure genmsg(setno,msgno,mask,parm1,parm2,                  06835000
      parm3,parm4,parm5,dest,reply,offset,dst,control);                 06840000
   value   setno,msgno,mask,parm1,parm2,parm3,parm4,parm5,              06845000
           dest,reply,offset,dst,control;                               06850000
   integer setno,msgno,dest,dst;                                        06855000
   logical mask,parm1,parm2,parm3,parm4,parm5,reply,offset,             06860000
      control;                                                          06865000
   option variable,privileged,uncallable;                               06870000
comment                                                                 06875000
   this procedure is a general message handler. it features:            06880000
   - finding a message in the message catalog & printing it.            06885000
                                                               <<01321>>06890000
   - inserting parameters into messages, either from the                06895000
     message catalog or from an input string.                           06900000
   - printing a message on $stdlist, the system console,                06905000
     to a specified ldev, or to a file.                                 06910000
   - returning the next message number as specified in the              06915000
     message catalog.                                                   06920000
parameters                                                              06925000
   setno - required parm. set number from catalog.                      06930000
   msgno - required parm.                                               06935000
           if setno > 0  - message number within message set.           06940000
                           msgno >= 0.                                  06945000
           if setno = -1 - string to be formatted is passed in,         06950000
                           rather than found in catalog.                06955000
                           'msgno' contains byte address on             06960000
                           word boundary. string must be                06965000
                           terminated by zero.                          06970000
           if setno =-2  - same as -1, except cctl = %320               06975000
                           instead of 0.                                06980000
   mask  - indicates types of any parameters which are passed.          06985000
           mask.(1:3) = type of parm1.                                  06990000
           mask.(4:3) = type of parm2.                                  06995000
           mask.(7:3) = type of parm3.                                  07000000
           mask.(10:3)= type of parm4.                                  07005000
           mask.(13:3)= type of parm5.                                  07010000
                                                                        07015000
           type = 0 - parm is string byte pointer (i.e.                 07020000
                      @string). string is terminated by zero.           07025000
                  1 - parm is integer by value.                         07030000
                  2 - parm is double by reference (i.e.                 07035000
                      @double).                                         07040000
   parmx - parameter, as indicated by mask. parm1 substitutes           07045000
           for the leftmost parameter in the message, parm2             07050000
           for the next parameter to the right, and so forth.           07055000
           if parm(n) if present, parm(n-1) must be present.            07060000
           if parm is a string, a byte address must be passed           07065000
           (i.e. @string).                                              07070000
   dest  - destination of message.                                      07075000
           missing - print on $stdlist. for system processes,           07080000
                     no pcb/no wait i/0 to console. soft-               07085000
                     preemption is done                                 07090000
           = < -2  - negative file number. fwrite to -dest is           07095000
                     done.                                              07100000
           = -2    - $stdlist. if system process, then no pcb/          07105000
                     no wait i/o to console. soft-preemption            07110000
                     is default.                                        07115000
           = -1    - nowhere.  message disappears.             <<01321>>07120000
           = 0     - console, no pcb/no wait i/o. soft-                 07125000
                     preemption is default.                             07130000
                     prefix is added to msg containing time             07135000
                     stamp/[#j/s]/pin/.                                 07140000
   reply - (console only). format specifications for reply.             07145000
           xpected from console message.                                07150000
           reply.( 0:8) = maximum string length                         07155000
                          (reply type 2 & 4 only).             <<00813>>07160000
                                                                        07165000
           reply.(8:8) = reply type.                           <<00620>>07170000
                         0 - number                                     07175000
                         1 - yes or no                                  07180000
                         2 - string                                     07185000
                         3 - yes/no or number                  <<00620>>07190000
                         4 - one string. (currently used for   <<00620>>07195000
                                  the intrinsic printopreply)  <<00620>>07200000
   offset- (console only). word address for formatted reply.            07205000
           if 'dst' is present, then segment relative,                  07210000
           otherwise db relative. replies are formatted as              07215000
           follows:                                                     07220000
           reply type   contents at 'offset'                            07225000
           ----------   -------------------                             07230000
           0 -(num)     binary value of number typed by                 07235000
                        operator.                                       07240000
           1 -(y/n)     true for "YES", false for "NO".                 07245000
           2 -(string)  first word contains character count.            07250000
                        string starts at second word.                   07255000
           3 -(num or                                          <<00620>>07260000
                  y/n)   same as either reply types 0 or 1     <<00620>>07265000
           4 -(1 string) same as reply type 2                  <<00620>>07270000
   dst   - (console only). if present indicates data segment            07275000
           for reply.                                                   07280000
   control - (terminals only) flag word.                                07285000
             .(0:1)  = each write will have cctl %320.                  07290000
                                                                        07295000
             .(2:2)  = funny termtype. translate into apl.              07300000
                                                                        07305000
             .(14:2) = iotype for attachio.                             07310000
                       0 - standard.                                    07315000
                       1 - soft preemption.                             07320000
                       2 - hard preemtpion.                             07325000
console reply rules.                                                    07330000
   replies are formatted by progen and result (not raw input            07335000
   at console) is placed in 'offset'. a '?' is placed at the            07340000
   beginning of the message. type of reply expected must be in          07345000
   the message itself (i.e. '(y/n)' must be supplied).                  07350000
   messages requiring a reply are truncated in reply                    07355000
   information table (current limit = 74 -total prefix size).           07360000
returns                                                                 07365000
   next message number from catalog (!xxx). if none, -1 is              07370000
   returned.                                                            07375000
condition code                                                          07380000
   cce = everything ok                                                  07385000
   ccl = i/o failure (attachio, fwrite).                                07390000
   ccg = something wrong with call.  tried best to print something.     07395000
;                                                                       07400000
begin                                                                   07405000
                                                                        07410000
integer                                                                 07415000
   saveritsir,                                                 << 7488>>07420000
   zero := 0,                                                  <<00813>>07425000
   len,                                                                 07430000
   lpdt'index,                                                 <<06588>>07435000
   outbuffsize,                                                         07440000
   index = outbuffsize,                                                 07445000
   funnyscr = outbuffsize;                                              07450000
                                                                        07455000
logical console; << indicates to add prefix >>                          07460000
                                                                        07465000
byte pointer inbuff;                                                    07470000
integer tmp;                                                   <<04882>>07475000
logical pending; << used to exit procedure w/o op reply >>     <<04882>>07480000
logical noproblem;                                             <<04882>>07485000
pointer outbuff';                                                       07490000
pointer consbuff';                                                      07495000
logical pcbpt;                                                 <<06590>>07500000
array                                                          <<00813>>07505000
   char'zero(0:1);                                             <<00813>>07510000
array qarray(*)=q + 0;                                         << 7469>>07515000
integer pcbglobloc;                                            << 7469>>07520000
                                                                        07525000
                                                                        07530000
subroutine def'movefromdseg;                                            07535000
subroutine def'movetodseg;                                     <<00813>>07540000
                                                                        07545000
                                                                        07550000
subroutine maskparms;                                                   07555000
begin                                                                   07560000
                                                                        07565000
if pmask.ppmask and not mask&csl(1) then                                07570000
begin                                                                   07575000
   pmask := pmask &csr(5); <<right justify>>                            07580000
   index := 0;                                                          07585000
   do begin                                                             07590000
      if not pmask &csr(index) then mask.(13:3)                         07595000
         := 3; << ignore parm >>                                        07600000
      mask := mask &csr(3);                                             07605000
   end until (index := index+1) >=5;                                    07610000
   pmask := pmask &csl(5);                                              07615000
   mask := mask &csr(1);                                                07620000
end                                                                     07625000
else mask := -1; <<ignore all parms>>                                   07630000
                                                                        07635000
end; << maskparms >>                                                    07640000
                                                                        07645000
                                                                        07650000
<< main procedure body >>                                               07655000
<< check to see if the message facility is set up.  if not, >> <<06023>>07660000
<< there is nothing that can be done (since system logging  >> <<06023>>07665000
<< is probably not up either.                               >> <<06023>>07670000
   if msgdstn = 0 then                                         <<06023>>07675000
   begin                                                       <<06023>>07680000
      condcode := ccl;                                         <<06023>>07685000
      return;                                                  <<06023>>07690000
   end;                                                        <<06023>>07695000
                                                               <<06023>>07700000
                                                                        07705000
<<***** variable set-up       *****>>                                   07710000
pending := true;  << assume there is room >>                   <<04882>>07715000
condcode := cce;                                                        07720000
console := << false >> len := 0;                                        07725000
                                                                        07730000
<<***** check required parms       *****>>                              07735000
                                                                        07740000
if not (pmask.psetno lor pmask.pmsgno) then                             07745000
   ccgretn; << omitted required parms >>                                07750000
if pmask.preply and not pmask.poffset then ccgretn;                     07755000
<< offset required for reply >>                                         07760000
                                                                        07765000
<<***** set-up parms          *****>>                                   07770000
                                                                        07775000
maskparms;                                                              07780000
                                                                        07785000
<<***** set-up control      *****>>                                     07790000
                                                                        07795000
if not pmask.pcontrol then control := 0;                                07800000
                                                                        07805000
<<***** resolve destination ******>>                                    07810000
<<      and preemption            >>                                    07815000
                                                                        07820000
pcbpt := curprc;                                               <<06590>>07825000
if pmask.pdest then                                                     07830000
begin << dest supplied, not $stdlist >>                                 07835000
   if dest > 0 then                                                     07840000
   begin << check for valid ldev, may be spooled >>                     07845000
      lpdt'index:=dest*integer(lpdt'entry'size);               <<06588>>07850000
      if lpdt'virtual'device = 1  << possible spoolfile >>     <<06588>>07855000
         then ccgretn;                                                  07860000
   end;                                                                 07865000
   if dest = -2 and procstate.systemprocflag <> 0 then         <<06590>>07870000
   begin << $stdlist for system proc. is console >>                     07875000
      dest := sys'console'ldev;                                <<06877>>07880000
      if control.(14:2) = 0 then control.(14:2) := 1;                   07885000
         << force soft-preemptive >>                                    07890000
   end;                                                                 07895000
   if dest = 0 then << console msg. needs prefix >>                     07900000
   begin                                                                07905000
      dest := sys'console'ldev;                                <<06877>>07910000
      console := true;                                                  07915000
   end;                                                                 07920000
end                                                                     07925000
else                                                                    07930000
if procstate.systemprocflag <> 0 then                          <<06590>>07935000
begin  << no dest supplied >>                                           07940000
   dest := sys'console'ldev;                                   <<06877>>07945000
   if control.(14:2) = 0 then control.(14:2) := 1;                      07950000
      << force soft-preemptive >>                                       07955000
end                                                                     07960000
else dest := -2;                                                        07965000
   << console for system process, $stdlist otherwise>>                  07970000
                                                                        07975000
if (console or pmask.preply) and control.(14:2)=0 then control.(14:2)   07980000
   := 1; << force soft preemptive >>                                    07985000
                                                                        07990000
if dest = -2 then                                                       07995000
begin << if $stdlist, check for funnyterm >>                            08000000
pxglobal;                                                      << 7469>>08005000
   << grab the jmat word containing the funny terminal bits >> <<06592>>08010000
                                                               <<06592>>08015000
   movefromdseg(@funnyscr,jmatdst,pxg'jmatinx                  << 7469>>08020000
                *jmatentrysize + jmatftbitsoff,1);             <<06592>>08025000
                                                               <<06592>>08030000
   control.funnyterm := funnyscr.jmatftbitsext;<< apl? >>      <<06592>>08035000
   << funnyterm may be passed in control, or >>                         08040000
   << found when looking at $stdlist         >>                         08045000
end;                                                                    08050000
                                                                        08055000
<< take care of setno >>                                                08060000
                                                                        08065000
if setno = -2 then                                                      08070000
begin                                                                   08075000
   setno := -1;                                                         08080000
   control.(0:1) := 1;                                                  08085000
end;                                                                    08090000
                                                                        08095000
<<***** done with control *****>>                                       08100000
                                                                        08105000
<<***** set-up input buff   *****>>                                     08110000
                                                                        08115000
if setno = -1 then @inbuff := msgno << supplied >>                      08120000
else                                                                    08125000
begin                                                                   08130000
   assemble(zero; lra s-0);                                             08135000
   @inbuff := tos &lsl(1);                                              08140000
   assemble(adds buffsizem1);                                           08145000
end;                                                                    08150000
                                                                        08155000
<<***** set-up output buff  *****>>                                     08160000
                                                                        08165000
if console or pmask.preply then                                         08170000
begin << allocate output buffer 'system buffer' size >>                 08175000
   << buffer size limited for replys. if reply too long, >>             08180000
   << part of msg will be lost for =recall.              >>             08185000
   assemble( zero; lra s-0 );                                           08190000
   @consbuff' := tos;                                                   08195000
   tos := rit'msgbase +sbufsizewm1;                            <<04882>>08200000
   assemble( adds 0 );                                                  08205000
   outbuffsize := sbufsize; << set buffsize >>                          08210000
   @outbuff' := @consbuff'(rit'msgbase); << base of buff >>    <<04882>>08215000
end                                                                     08220000
else                                                                    08225000
begin << allocate buffer 'recsize'. can re-use buff>>                   08230000
   assemble(zero; lra s-0);                                             08235000
   @outbuff' := tos;                                                    08240000
   assemble( adds buffsizem1);                                          08245000
   outbuffsize := buffsizeb;                                            08250000
end;                                                                    08255000
                                                                        08260000
<<***** put in prefix string in output buff if console***>>             08265000
                                                                        08270000
if console or pmask.preply then len:=consprefix(pmask.preply,  <<00552>>08275000
   outbuff');                                                           08280000
                                                                        08285000
<<***** now assemble message   ***** >>                                 08290000
                                                                        08295000
tmp := len;                                                    <<04882>>08300000
if not pmask.preply then                                       <<04882>>08305000
     genmsg :=formsg(inbuff,setno,msgno,mask,parm1,parm2,parm3 <<04882>>08310000
          ,parm4,parm5,outbuff',outbuffsize,len,dest,control)  <<04882>>08315000
     else genmsg:=formsg(inbuff,setno,msgno,mask,parm1,parm2,  <<04882>>08320000
        parm3,parm4,parm5,outbuff',outbuffsize,tmp,-1,control);<<04882>>08325000
<< the second genmsg will format inbuf to be put in the rit >> <<04882>>08330000
<< but since formsg will be called later, the variable len  >> <<04882>>08335000
<< cannot be changed, so tmp is used. the destination is -1 >> <<04882>>08340000
<< so the message willl not be printed anywhere             >> <<04882>>08345000
     if < then condcode := ccl                                 <<04882>>08350000
          else if > then condcode := ccg;                      <<04882>>08355000
                                                                        08360000
<<***** handle reply (may be for console or outbuffsize)*****>>         08365000
                                                                        08370000
if pmask.preply and condcode <> ccl then                       <<04882>>08375000
<< if no i/o fail, console, & reply >>                                  08380000
begin                                                                   08385000
   if not pmask.pdst then dst := 0;                                     08390000
                                                               <<00813>>08395000
<< ......................................................... >><< 7592>>08400000
<<   place the reply in the reply information table (rit)    >><< 7592>>08405000
<<   note that putritentry takes the rit sir and does not    >><< 7592>>08410000
<<   release it if successful.  this allows us to release the>><< 7592>>08415000
<<   sir before we wait and thus prevent someone from reply- >><< 7592>>08420000
<<   ing too soon and hanging at the wait (an old problem)   >><< 7592>>08425000
<<   if putritentry fails, it releases the sir               >><< 7592>>08430000
<< ......................................................... >><< 7592>>08435000
                                                               << 7592>>08440000
                                                               << 7488>>08445000
   noproblem:=putritentry(mypin,dst,offset,reply,tmp           <<04882>>08450000
                ,consbuff', saveritsir);                       << 7592>>08455000
   if noproblem                                                <<04882>>08460000
      then genmsg :=formsg(inbuff,setno,msgno,mask,parm1,parm2,<<04882>>08465000
                           parm3,parm4,parm5,outbuff',         <<04882>>08470000
                           outbuffsize,len,dest,control)       <<04882>>08475000
      else pending := false; << no room in table >>            <<04882>>08480000
                                                               <<00813>>08485000
   << wait for reply. will awaken when rit entry deleted >>    <<00813>>08490000
      if pending then                                          << 7488>>08495000
      begin                                                    << 7488>>08500000
        << putritentry grabbed the rit sir >>                  << 7592>>08505000
         pdisable;    << keep the machine until we wait >>     << 7488>>08510000
         relsir( rit'sir, saveritsir );                        << 7488>>08515000
         wait( %40, 0 );  << does implicit penable. >>         << 7488>>08520000
      end;                                                     << 7592>>08525000
                                                               <<00813>>08530000
   << check soft kill bit in pcb to see if this process is >>  <<00813>>08535000
   << to be aborted but can't right now because it's >>        <<00813>>08540000
   << critical. >>                                             <<00813>>08545000
   if procstate.softkillflag = 1 or not pending                <<06590>>08550000
      then                                                     <<04882>>08555000
      << trying to abort this process. fake an operator >>     <<00813>>08560000
      << reply of 0 so that process will eventually abort. >>  <<00813>>08565000
      if reply.(8:8) = replytype'strings or                    <<00813>>08570000
               reply.(8:8) = replytype'onestring then          <<00813>>08575000
         begin                                                 <<00813>>08580000
         move char'zero := ( 1 <<byte count>>, "0" );          <<00813>>08585000
         movetodseg(consbuff'(1),consbuff'(2),@char'zero,2);   <<00813>>08590000
         condcode := ccl;                                      <<04882>>08595000
         end                                                   <<00813>>08600000
      else begin                                               <<04882>>08605000
         movetodseg(consbuff'(1),consbuff'(2),@zero,1);        <<00813>>08610000
         condcode := ccl;                                      <<04882>>08615000
         end;                                                  <<04882>>08620000
end;                                                                    08625000
                                                                        08630000
outl:                                                                   08635000
end; << genmsg >>                                                       08640000
$title "GENMSGU"                                                        08645000
procedure genmsgu(a,b);                                                 08650000
   value a,b;integer a,b;                                               08655000
   option privileged;                                                   08660000
begin                                                                   08665000
                                                                        08670000
erroron;                                                                08675000
genmsg(a,b);                                                            08680000
errorexit([10/85,6/2],0,0);<< intrin#85:exit2 >>                        08685000
                                                                        08690000
end; << genmsgu >>                                                      08695000
$title "CONSPREFIX"                                                     08700000
integer procedure consprefix(consreply,buff');                          08705000
   value consreply;                                                     08710000
   logical consreply;                                                   08715000
   array buff';                                                         08720000
   option internal;                                                     08725000
comment                                                                 08730000
   returns "<TIME>[/#J\SXXX]/<PIN>/"                                    08735000
returns - length of prefix.                                             08740000
;                                                                       08745000
begin                                                                   08750000
                                                                        08755000
equate jit = 6;                                                         08760000
                                                                        08765000
integer                                                                 08770000
   index = consprefix;                                                  08775000
                                                                        08780000
array qarray(*)= q + 0;                                        << 7469>>08785000
integer pcbglobloc;                                            << 7469>>08790000
logical                                                                 08795000
   jobnum;                                                              08800000
                                                                        08805000
pointer pxptr;                                                          08810000
                                                               <<06590>>08815000
logical pcbpt;                                                 <<06590>>08820000
                                                                        08825000
double hrsmin;                                                          08830000
integer hrs = hrsmin;                                                   08835000
                                                                        08840000
byte array buff(*) = buff';                                             08845000
intrinsic clock;                                                        08850000
                                                                        08855000
subroutine def'movefromdseg;                                            08860000
                                                                        08865000
   << console prefix :                                                  08870000
   <<  [?][h1]h2:mm[/#{j/s}x12[x3-5]]/pn/                               08875000
   >>                                                                   08880000
pcbpt := curprc;                                               <<06590>>08885000
if consreply then                                                       08890000
begin                                                                   08895000
   buff := "?";                                                         08900000
   index := 1;                                                          08905000
end                                                                     08910000
else index := 0;                                                        08915000
                                                                        08920000
<< get time >>                                                          08925000
                                                                        08930000
hrsmin := clock;                                                        08935000
index := index +ascii(hrs.(0:8),10,buff(index)); << hours >>            08940000
move buff(index) := ":00";                                              08945000
index := index +2;                                                      08950000
ascii(hrs.(8:8),-10,buff(index));<< solves 0-9 min. problem >>          08955000
index := index +1;                                                      08960000
                                                                        08965000
   << get #j/s num >>                                                   08970000
                                                                        08975000
if procstate.systemprocflag = 0 then                           <<06590>>08980000
begin << user process >>                                                08985000
      << put in #j/s number >>                                          08990000
   move buff(index) := "/#";                                            08995000
   index := index +2;                                                   09000000
   pxglobal;                                                   << 7469>>09005000
   movefromdseg(@jobnum,pxg'jitdst,jit'job'info'ptr,1);        << 7469>>09010000
   buff(index) := if jobnum.(0:1) then "J" else "S";                    09015000
   index := index +1;                                                   09020000
   index := index +ascii(jobnum.(2:14),10,buff(index));                 09025000
end;                                                                    09030000
   buff(index) := "/";                                                  09035000
   index := index +1;                                                   09040000
                                                                        09045000
   << add in pin >>                                                     09050000
index := index +ascii(mypin,10,buff(index));                            09055000
buff(index) := "/";                                                     09060000
index := index +1;                                                      09065000
                                                                        09070000
   << consprefix = index >>                                             09075000
                                                                        09080000
end; << consprefix >>                                                   09085000
                                                                        09090000
$title "INITMSG"                                                        09095000
procedure initmsg;                                                      09100000
   option uncallable;                                                   09105000
comment                                                                 09110000
   this procedure initializes the message system.                       09115000
   - the disc address of the message catalog is put in sys db.          09120000
   - the message directory data segment is created & stuffed.           09125000
   - the message dst buffer is obtained and initialized.       <<02802>>09130000
returns                                                                 09135000
   cce = everything ok.                                                 09140000
   ccl = something wrong.                                               09145000
;                                                                       09150000
begin                                                                   09155000
                                                                        09160000
array directory(0:msgdirsize-1);                                        09165000
byte array buff(*) = directory;                                         09170000
                                                                        09175000
integer                                                                 09180000
   dstn1,                                                               09185000
   oldmsgdstn,                                                 <<00820>>09190000
   sirn,                                                                09195000
   catfn,                                                               09200000
   ecode;                                                               09205000
                                                                        09210000
                                                                        09215000
double                                                         <<00820>>09220000
   labeladr,                                                   <<00820>>09225000
   oldlabel;                                                   <<00820>>09230000
logical                                                                 09235000
   labeladr1    = labeladr,                                    <<00820>>09240000
   labeladr2    = labeladr +1,                                 <<00820>>09245000
   oldlabel1    = oldlabel,                                    <<00820>>09250000
   oldlabel2    = oldlabel +1;                                 <<00820>>09255000
equate                                                         <<00820>>09260000
   filelabel'error = 47,                                       <<00820>>09265000
   purgeok         = true,                                     <<00820>>09270000
   nopurge         = false;                                    <<00820>>09275000
                                                                        09280000
subroutine err(num);                                                    09285000
   value num;                                                           09290000
   integer num;                                                         09295000
begin                                                                   09300000
   case num of                                                 <<00820>>09305000
   begin                                                                09310000
   <<0>>begin                                                  <<00820>>09315000
        fcheck(catfn,ecode);                                   <<00820>>09320000
        move buff := ("**FILE ERROR ON CATALOG (!)",0);        <<00820>>09325000
        end;                                                   <<00820>>09330000
   <<1>>begin                                                  <<00820>>09335000
        fcheck(catfn,ecode);                                   <<00820>>09340000
        move buff := ("**GETDATASEG FAILED ON CATALOG",0);     <<00820>>09345000
        end;                                                   <<00820>>09350000
   <<2>>begin                                                  <<00820>>09355000
        ecode := filelabel'error;                              <<00820>>09360000
        move buff := ("**FILE ERROR ON CATALOG (!)",0);        <<00820>>09365000
        end;                                                   <<00820>>09370000
   end;                                                                 09375000
   genmsg(-1,@buff,%10000,ecode);                                       09380000
   condcode := ccl;                                                     09385000
end; << err >>                                                          09390000
                                                                        09395000
subroutine def'movetodseg;                                              09400000
subroutine get'msg'dst;                                        <<02802>>09405000
begin                                                          <<02802>>09410000
                                                               <<02802>>09415000
<<if message dst already exists, return>>                      <<02802>>09420000
if iomsgdst <> 0 then                                          <<02802>>09425000
  return;                                                      <<02802>>09430000
                                                               <<02802>>09435000
<< obtain a dst >>                                             <<02802>>09440000
                                                               <<02802>>09445000
                                                               <<02802>>09450000
<< now, figure length of xds >>                                <<02802>>09455000
dstn1:=(sbufsizew * num'msg'bufs) + 4 <<overhead>> ;           <<02802>>09460000
                                                               <<02802>>09465000
iomsgdst := getdataseg(dstn1,dstn1);                           <<02802>>09470000
if iomsgdst = 0 then                                           <<02802>>09475000
  return;       <<failed to get xds>>                          <<02802>>09480000
                                                               <<02802>>09485000
<< initialize xds >>                                           <<02802>>09490000
directory := num'msg'bufs;     <<number of message buffers>>   <<02802>>09495000
directory(1) := sbufsizew;     <<size of message buffer>>      <<02802>>09500000
directory(2) := 4;             <<pointer to first avail>>      <<02802>>09505000
directory(3) := (sbufsizew*(num'msg'bufs-1))+4; << tail ptr >> <<02802>>09510000
movetodseg(iomsgdst,0,@directory,4);                           <<02802>>09515000
                                                               <<02802>>09520000
<<loop & thread pointers>>                                     <<02802>>09525000
dstn1 := 0;            <<loop buffer index>>                   <<02802>>09530000
ecode := 4;    <<start displacement of buffers>>               <<02802>>09535000
while (dstn1 := dstn1 + 1) < num'msg'bufs do                   <<02802>>09540000
  begin                                                        <<02802>>09545000
  directory := ecode + sbufsizew; <<ptr to next buffer>>       <<02802>>09550000
  movetodseg(iomsgdst,ecode,@directory,1);                     <<02802>>09555000
  ecode := ecode + sbufsizew; <<point to next buffer>>         <<02802>>09560000
  end;                                                         <<02802>>09565000
                                                               <<02802>>09570000
<< place zero link pointer into last buffer >>                 <<02802>>09575000
directory := 0;                                                <<02802>>09580000
movetodseg(iomsgdst,ecode,@directory,1);                       <<02802>>09585000
end;                                                           <<02802>>09590000
                                                               <<02802>>09595000
                                                                        09600000
get'msg'dst;  <<get & init msg buffers>>                       <<02802>>09605000
                                                               <<02802>>09610000
condcode := cce;                                                        09615000
                                                                        09620000
<< open message catalog >>                                              09625000
move buff := "CATALOG ";                                                09630000
catfn := fopen(buff,5,0); <<oldperm,ascii>>                             09635000
if <> then err(0)                                                       09640000
else                                                                    09645000
begin                                                                   09650000
   fgetinfo(catfn,,,,,,,,,,,,,,,,,,,labeladr);                          09655000
   if <> then err(0)                                                    09660000
   else                                                                 09665000
   begin                                                                09670000
                                                                        09675000
      << read label & get message directory >>                          09680000
      freadlabel(catfn,directory,msgdirsize,0);                         09685000
      if <> then err(0)                                                 09690000
      else                                                              09695000
      begin                                                             09700000
                                                                        09705000
         << get data segment for directory & message buffer >>          09710000
         dstn1 := getdataseg(physblk+msgdirsize,physblk+                09715000
            msgdirsize);                                                09720000
         if dstn1 = 0 then err(1)                                       09725000
         else                                                           09730000
         begin                                                          09735000
                                                                        09740000
            << put directory in data seg >>                             09745000
            movetodseg(dstn1,0,@directory,msgdirsize);                  09750000
                                                               <<00820>>09755000
            << make new catalog non-purgeable >>               <<00820>>09760000
            setlockstatus(labeladr,nopurge);                   <<00820>>09765000
            if <> then                                         <<00820>>09770000
            begin                                              <<00820>>09775000
              reldataseg(dstn1);                               <<00820>>09780000
              err(2);                                          <<00820>>09785000
            end                                                <<00820>>09790000
            else                                               <<00820>>09795000
            begin                                              <<00820>>09800000
                                                               <<00820>>09805000
                                                               <<00820>>09810000
               sirn := getsir(msgsir);                         <<00820>>09815000
                                                               <<00820>>09820000
               << save old label and dst >>                    <<00820>>09825000
               oldlabel1 := absolute(msgbase);                 <<00820>>09830000
               oldlabel2 := absolute(x:=x+1);                  <<00820>>09835000
               oldmsgdstn := msgdstn;                          <<00820>>09840000
               << stuff disc address in sysdb.      >>         <<00820>>09845000
               << file must be 1 extent>>                      <<00820>>09850000
               absolute(msgbase) := labeladr1;                 <<00820>>09855000
               absolute(x:=x+1) := labeladr2;                  <<00820>>09860000
                                                               <<00820>>09865000
               << stuff sys db with datseg no. >>              <<00820>>09870000
               msgdstn:= dstn1;  << put in sys db >>           <<00820>>09875000
                                                               <<00820>>09880000
               relsir(msgsir,sirn);                            <<00820>>09885000
                                                               <<00820>>09890000
               << unlock old cat if one existed >>             <<00820>>09895000
               if oldmsgdstn <> 0 then                         <<00820>>09900000
                  setlockstatus(oldlabel,purgeok);             <<00820>>09905000
               if <> then                                      <<00820>>09910000
               begin << restore old catalog >>                 <<00820>>09915000
                  sirn := getsir(msgsir);                      <<00820>>09920000
                  absolute(msgbase) := oldlabel1;              <<00820>>09925000
                  absolute(x:=x+1) := oldlabel2;               <<00820>>09930000
                  msgdstn := oldmsgdstn;                       <<00820>>09935000
                  relsir(msgsir,sirn);                         <<00820>>09940000
                  << release 'new' cat >>                      <<00820>>09945000
                  reldataseg(dstn1);                           <<00820>>09950000
                  setlockstatus(labeladr,purgeok);             <<00820>>09955000
                  err(2);                                      <<00820>>09960000
               end;                                            <<00820>>09965000
            end;                                               <<00820>>09970000
         end;                                                  <<00820>>09975000
      end;                                                              09980000
   end;                                                                 09985000
end;                                                                    09990000
outl:                                                                   09995000
fclose(catfn,0,0);                                                      10000000
end; << initmsg >>                                                      10005000
logical procedure rem'queued'entry(pin);                       <<04882>>10010000
value pin;                                                     <<04882>>10015000
integer pin;                                                   <<04882>>10020000
option privileged,uncallable,variable;                         <<04882>>10025000
<< this procedure removes entries from the rit queue.  if >>   <<04882>>10030000
<< pin is passed in then the queue will be checked for    >>   <<04882>>10035000
<< that specific number and if found it will be deleted   >>   <<04882>>10040000
<< from the queue after the process is awakened and a true>>   <<04882>>10045000
<< will be returned.  if pin is not passed in then the    >>   <<04882>>10050000
<< first entry in the queue will be woken and removed     >>   <<04882>>10055000
                                                               <<04882>>10060000
begin                                                          <<04882>>10065000
  integer sirn;                                                <<04882>>10070000
  integer array ritable(*)=db+0;                               <<04882>>10075000
  logical pmap = q-4;                                          <<04882>>10080000
  integer i;                                                   <<04882>>10085000
  logical found;                                               <<04882>>10090000
  found := false;                                              <<04882>>10095000
                                                               <<04882>>10100000
  sirn := getsir(rit'sir);                                     <<04882>>10105000
  if ritable(queued'entries) > 0 then                          <<04882>>10110000
     begin                                                     <<04882>>10115000
       if pmap.(15:1)=0 then                                   <<04882>>10120000
          begin                                                <<04882>>10125000
            << no pin passed in >>                             <<04882>>10130000
            found := true;                                     <<04882>>10135000
            awake((ritable(fiq))*pcbsize,%40,0);               <<04882>>10140000
            ritable(queued'entries):=ritable(queued'entries)-1;<<04882>>10145000
            i:=0;                                              <<04882>>10150000
            while i < ritable(queued'entries) do               <<04882>>10155000
            begin                                              <<04882>>10160000
              ritable(fiq+i):=ritable(fiq+i+1);                <<04882>>10165000
              i := i+1;                                        <<04882>>10170000
              end;                                             <<04882>>10175000
            ritable(liq):=ritable(liq)-1;                      <<04882>>10180000
            end                                                <<04882>>10185000
       else begin                                              <<04882>>10190000
              << pin was passed in >>                          <<04882>>10195000
              i:=0;                                            <<04882>>10200000
            while((not found)land(i<ritable(queued'entries)))do<<04882>>10205000
                begin                                          <<04882>>10210000
                  if pin = ritable(fiq+i) then                 <<04882>>10215000
                     begin                                     <<04882>>10220000
                       found := true;                          <<04882>>10225000
                       awake(pin*pcbsize,%40,0);               <<04882>>10230000
                       ritable(queued'entries):=               <<04882>>10235000
                               ritable(queued'entries)-1;      <<04882>>10240000
                       end;                                    <<04882>>10245000
                 i:=i+1;                                       <<04882>>10250000
                 end; << while do >>                           <<04882>>10255000
              if found then                                    <<04882>>10260000
                 begin                                         <<04882>>10265000
                   while i <= ritable(queued'entries) do       <<04882>>10270000
                   begin                                       <<04882>>10275000
                     ritable((fiq+i)-1) := ritable(fiq+i);     <<04882>>10280000
                     i := i+1;                                 <<04882>>10285000
                     end;                                      <<04882>>10290000
                   ritable(liq):=ritable(liq)-1;               <<04882>>10295000
                   end;                                        <<04882>>10300000
            end;                                               <<04882>>10305000
       end;<< queued'entries > 0 >>                            <<04882>>10310000
   rem'queued'entry := found;                                  <<04882>>10315000
   relsir(rit'sir,sirn);                                       <<04882>>10320000
   end; << rem'queued'entry >>                                 <<04882>>10325000
$title "REMRITENTRY'"                                          <<01398>>10330000
procedure remritentry'(pin,flag);                              <<01398>>10335000
   value pin, flag; integer pin, flag;                         <<01398>>10340000
option uncallable;                                                      10345000
comment                                                                 10350000
   removes entry from the reply information table (rit),                10355000
   then process is awakened - console is informed.                      10360000
;                                                                       10365000
begin                                                                   10370000
                                                                        10375000
logical found;                                                 <<01398>>10380000
integer                                                                 10385000
   index,                                                               10390000
   limit,                                                               10395000
   savedstn,                                                            10400000
   sirn;                                                                10405000
                                                                        10410000
                                                                        10415000
integer array jmatarr(*) = db + 0;<< array to access jmat >>   <<06592>>10420000
integer       jmatinx; << index to each entry in the jmat >>   <<06592>>10425000
                                                                        10430000
integer array ritable(*) = db+0;                                        10435000
logical pcbpt;                                                 <<06590>>10440000
                                                                        10445000
found := false;  <<assume no rit entry>>                       <<01398>>10450000
savedstn := exchangedb(rit'dst);                               <<04882>>10455000
sirn := getsir(rit'sir);                                       <<04882>>10460000
<< whirl thru table looking for pin in 1st word>>                       10465000
limit := rit'headsize +ritable(rit'head'maxent) *rit'size;     <<04882>>10470000
index := rit'headsize -rit'size;                               <<04882>>10475000
while (index := index +rit'size) < limit do                    <<04882>>10480000
   if ritable(index) = pin then                                         10485000
   begin                                                                10490000
      found := true;   <<there is a rit entry for pin>>        <<01398>>10495000
      ritable(index) := 0;                                              10500000
      ritable := ritable -1; <<decr. entry count >>                     10505000
      pcbpt := pin * pcbsize;                                  <<06590>>10510000
      piinfo.oafield := pcb'replydone;                         <<06590>>10515000
      awake(pcbpt,%40,0); << awake rit wait >>                 <<06590>>10520000
      index := limit; << stop this loop >>                              10525000
   end;                                                                 10530000
relsir(rit'sir,sirn);                                          <<04882>>10535000
if found then rem'queued'entry << get next queued entry  >>    <<04882>>10540000
   else if rem'queued'entry(pin) then go out;                  <<04882>>10545000
   << if the pin wasn't in table he might have been queued >>  <<04882>>10550000
if flag = 1 and                                                <<01398>>10555000
   found    and                                                <<01398>>10560000
   absolute(sysup) <> 0 then                                   <<01398>>10565000
   <<send console msg if requested (flag) and not =shutdown>>  <<01398>>10570000
   begin                                                       <<01398>>10575000
     exchangedb(jmatdst);                                      <<01398>>10580000
     sirn := getsir(jmatsir);                                  <<01398>>10585000
     if jmatlgbits <> 1 then  << a logoff in progress? >>      <<06592>>10590000
        begin        <<  no logoff  >>                         <<06592>>10595000
           relsir(jmatsir,sirn);                               <<01398>>10600000
           exchangedb(0);   <<back to stack for genmsg>>       <<01398>>10605000
           genmsg(1,38,%010000,pin,,,,,0); <<tell operator>>   <<01398>>10610000
        end                                                    <<01398>>10615000
      else                                                     <<01398>>10620000
        relsir(jmatsir,sirn);                                  <<01398>>10625000
   end;                                                        <<01398>>10630000
out:                                                           <<04882>>10635000
exchangedb(savedstn);                                          <<01398>>10640000
                                                                        10645000
end; << remritentry >>                                                  10650000
$title "REMRITENTRY"                                           <<01398>>10655000
procedure remritentry(pin);                                    <<01398>>10660000
   value pin; integer pin;                                     <<01398>>10665000
   option uncallable;                                          <<01398>>10670000
comment removes rit entry without sending a msg to console;    <<01398>>10675000
begin                                                          <<01398>>10680000
   remritentry'(pin,0);                                        <<01398>>10685000
end;                                                           <<01398>>10690000
                                                                        10695000
$control segment=main                                                   10700000
end. << genmsg >>                                                       10705000
