$CONTROL MAP,CODE,USLINIT                                               00010000
<< makecat -- module 40 >>                                              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=priv,main=makecat << module 40 >>                      00055000
begin                                                                   00060000
                                                                        00065000
                                                                        00070000
<< quit procedure errors >>                                             00075000
                                                                        00080000
equate                                                                  00085000
   insuffcaperr     = 1,                                                00090000
   openinerr        = 2,                                                00095000
   opencaterr       = 3,                                                00100000
   writelabelerr    = 4,                                                00105000
   closecaterr      = 5,                                                00110000
   initmsgerr       = 6,                                                00115000
   makehelperr      = 7,                                                00120000
   henlargerror     = 8,                                       <<01310>>00125000
   zendquiterrs     = 0;                                                00130000
                                                                        00135000
equate                                                                  00140000
   qi      = 5,                                                         00145000
                                                                        00150000
   msgbase       = %1371,                                               00155000
   msgsir        = %24,                                                 00160000
   sysdisc       = 1,                                                   00165000
   consolecell   = %1074,                                               00170000
   sbufdstn      = %10,                                                 00175000
   sbufsizew     = 128,                                                 00180000
   sbufsize      = 256,                                                 00185000
   sbufsizewm1   = sbufsizew -1;                                        00190000
                                                                        00195000
define                                                                  00200000
   disable = assemble( sed 0) #,                                        00205000
   enable  = assemble( sed 1) #,                                        00210000
   mypin = ((absolute(cpcb) -absolute(pcbb))/ pcbsize)#,                00215000
   sysproc = logical(absolute(absolute(cpcb) +9).(6:1))#;               00220000
                                                                        00225000
equate                                                                  00230000
   ccg           = 0,                                                   00235000
   ccl           = 1,                                                   00240000
   cce           = 2,                                                   00245000
   stopper       = 0,                                                   00250000
                                                                        00255000
   headersize    = 2,                                          <<00711>>00260000
   maxnosets     = 62, <<(sector-4 word header-work area)/2>>  <<00711>>00265000
   msgdirsize    = maxnosets*2 + headersize + 2<<work area>>,  <<00711>>00270000
   maxsetnocell  = 0,                                          <<00711>>00275000
   maxrecell     = 1,                                          <<00711>>00280000
   currentrecell = msgdirsize - 1,                             <<00711>>00285000
   recsize           = 40,                                              00290000
   recsizeb          = recsize*2,                                       00295000
   recsizem1         = recsize -1,                                      00300000
   buffsize          = recsize -4,                                      00305000
   buffsizem1        = buffsize -1,                                     00310000
   buffsizeb         = buffsize*2,                                      00315000
   blkfactor         = 16,                                              00320000
   physblk           = blkfactor * recsize,                    <<01310>>00325000
   sectorperblk      = physblk/128,                                     00330000
                                                                        00335000
   hrecsize          = 40,                                              00340000
   hrecsizem1        = hrecsize -1,                                     00345000
   hrecsizeb         = hrecsize *2,                                     00350000
   hbuffsize         = hrecsize -4,                                     00355000
   hbuffsizeb        = hrecsizeb -8,<<help never sees linenos>>         00360000
   hbuffsizem1       = hbuffsize - 1,                          <<01310>>00365000
   hblkfactor        = 16,                                     <<01310>>00370000
   hphysblk          = hblkfactor * hrecsize,                  <<01310>>00375000
   hsectorperblk     = hphysblk / 128,                         <<01310>>00380000
   hmaxdirsize       = hphysblk * 4,                           <<01310>>00385000
   hmaxdirsizeb      = hmaxdirsize * 2,                        <<01310>>00390000
   hmaxdirsizem1     = hmaxdirsize - 1,                        <<01310>>00395000
   hnextnumlbls      = 4 * hsectorperblk,                      <<01310>>00400000
   hnextnumwords     = hnextnumlbls * 128,                     <<01310>>00405000
   hinnumulbls       = 4 * hsectorperblk - 1,                  <<01310>>00410000
   hfirst'blk'space  = hinnumulbls * 128;                      <<01310>>00415000
                                                               <<01310>>00420000
integer                                                        <<01310>>00425000
   hlabels'written         := 0,                               <<01310>>00430000
   hwords'written          := 0,                               <<01310>>00435000
   hlabels'in'next'block   := hinnumulbls,                     <<01310>>00440000
   hwords'in'next'block    := hfirst'blk'space,                <<01310>>00445000
   hnumofulabels           := hinnumulbls;                     <<01310>>00450000
                                                                        00455000
integer                                                                 00460000
   status = q-1,                                                        00465000
   s0 =s-0,                                                             00470000
   x = x;                                                               00475000
                                                                        00480000
byte pointer bps0 = s-0;                                                00485000
pointer ps0 = s-0;                                                      00490000
double pointer dps0 = s-0;                                              00495000
                                                                        00500000
define                                                                  00505000
   msgdstn       = absolute(msgbase+2)#,                                00510000
                                                                        00515000
   condcode      = status.(6:2)#,                                       00520000
   ccgretn       = begin                                                00525000
                      condcode := ccg;                                  00530000
                      go outl;                                          00535000
                   end#,                                                00540000
   cclretn       = begin                                                00545000
                      condcode := ccl;                                  00550000
                      go outl;                                          00555000
                   end#,                                                00560000
   def'movefromdseg =                                                   00565000
      movefromdseg(target,dstn,offset,count);                           00570000
         value target,dstn,offset,count;                                00575000
         logical target,dstn,offset,count;                              00580000
      begin                                                             00585000
         x := tos; << save return address >>                            00590000
         assemble(mfds 0);                                              00595000
         tos := x; << restore return address >>                         00600000
      end #,                                                            00605000
                                                                        00610000
   def'movetodseg =                                                     00615000
      movetodseg(dstn,offset,source,count);                             00620000
         value dstn,offset,source,count;                                00625000
         logical dstn,offset,source,count;                              00630000
      begin                                                             00635000
         x := tos;                                                      00640000
         assemble(mtds 0);                                              00645000
         tos := x;                                                      00650000
      end#;                                                    <<06564>>00655000
                                                                        00660000
                                                                        00665000
                                                                        00670000
<< end global decls >>                                                  00675000
                                                                        00680000
                                                                        00685000
<< data for makecat >>                                                  00690000
                                                                        00695000
integer array directory(0:msgdirsize-1) := msgdirsize(0);               00700000
                                                                        00705000
array fnarray(0:3) =db;                                                 00710000
integer                 << err(parm) >>                                 00715000
   infn = fnarray,      << 0 >>                                         00720000
   catfn = infn+1,      << 1 >>                                         00725000
   listfn = catfn+1,    << 2 >>                                         00730000
   catoldfn = listfn+1; << 3 >>                                         00735000
                                                                        00740000
equate                                                                  00745000
   infnx     = 0,                                                       00750000
   catfnx    = 1,                                                       00755000
   listfnx   = 2,                                                       00760000
   catoldfnx = 3;                                                       00765000
                                                                        00770000
double catsize;                                                         00775000
                                                                        00780000
logical install := true; <<stays this way entering thru dir>>           00785000
logical buildmode :=true; << for build parameter >>                     00790000
                                                                        00795000
byte array buff(0:79);                                                  00800000
array buff'(*)=buff;                                                    00805000
                                                                        00810000
                                                                        00815000
entry build,dir,help;                                                   00820000
                                                                        00825000
<< external declarations >>                                             00830000
                                                                        00835000
intrinsic fclose,fwrite,fwritelabel,print,fopen,fgetinfo,               00840000
   who,terminate,setjcw,search,printfileinfo,freadlabel,       <<01310>>00845000
   fcontrol,getjcw,                                            <<04571>>00850000
   fspace,fwritedir,mycommand,frename,ascii,fread,fcheck,binary;        00855000
                                                                        00860000
                                                                        00865000
integer procedure findparm(string,parmptr,delptr);                      00870000
   byte array string; byte pointer parmptr,delptr;                      00875000
   option variable,external;                                            00880000
                                                                        00885000
integer procedure genmsg(a,b,c,d,e,f,g,h,i,j,k,l,m);                    00890000
   value a,b,c,d,e,f,g,h,i,j,k,l,m;                                     00895000
   logical a,b,c,d,e,f,g,h,i,j,k,l,m;                                   00900000
   option variable,external;                                            00905000
                                                                        00910000
procedure getusermode; option external;                                 00915000
procedure getprivmode; option external;                                 00920000
                                                                        00925000
procedure initmsg; option external;                                     00930000
                                                                        00935000
integer procedure nextparm(string,parmptr,delptr);                      00940000
   byte array string; byte pointer parmptr,delptr;                      00945000
   option variable,external;                                            00950000
                                                                        00955000
                                                                        00960000
<< forward declarations >>                                              00965000
                                                                        00970000
procedure err(a);value a;integer a;option forward;                      00975000
                                                                        00980000
procedure openhelpcat; option forward;                                  00985000
                                                                        00990000
procedure openin; option forward;                                       00995000
                                                                        01000000
procedure scanhelpcat;option forward;                                   01005000
                                                               <<01310>>01010000
procedure quit( num );                                         <<01310>>01015000
   value num;  integer num;                                    <<01310>>01020000
   option forward;                                             <<01310>>01025000
                                                                        01030000
$control segment=user                                                   01035000
                                                                        01040000
$title "CAPABILITYOK"                                                   01045000
logical procedure capabilityok;                                         01050000
begin                                                                   01055000
                                                                        01060000
double capd;                                                            01065000
logical capi = capd;                                                    01070000
byte array username(0:7),groupname(0:7),                                01075000
           acctname(0:7);                                               01080000
logical wrongcapability:=false;                                         01085000
                                                                        01090000
who(,capd,,username,groupname,acctname);                                01095000
if buildmode = true                                                     01100000
   then if ((username="MANAGER ") land (acctname="SYS     "))           01105000
        then capabilityok:=true                                         01110000
        else begin                                                      01115000
             wrongcapability:=true;                                     01120000
             move buff:=("** USER MUST BE MANAGER.SYS ",                01125000
                       "FOR BUILD"),2;                                  01130000
             end;                                                       01135000
   else if capi.(5:1) or capi.(0:1)                                     01140000
           then capabilityok:=true                                      01145000
           else begin                                                   01150000
                wrongcapability:=true;                                  01155000
                move buff:=("**USER LACKS OP(OPERATOR) OR SM",          01160000
                     "(SYSTEM MANAGER) CAPABILITY. "),2;                01165000
                end;                                                    01170000
if wrongcapability = true                                               01175000
   then print(buff',-(s0-@buff),0);del;                                 01180000
end; << procedure capabilityok >>                                       01185000
$title "BUZZFETCH"                                             <<01507>>01190000
$page                                                          <<01507>>01195000
integer procedure buzzfetch( string );                         <<01507>>01200000
   value string;                                               <<01507>>01205000
   byte pointer string;                                        <<01507>>01210000
   option internal;                                            <<01507>>01215000
comment                                                        <<01507>>01220000
   returns buzz number from buzz word array.  returns "0"      <<01507>>01225000
   if no match is found.                                       <<01507>>01230000
;                                                              <<01507>>01235000
                                                               <<01507>>01240000
begin                                                          <<01507>>01245000
                                                               <<01507>>01250000
   integer len;                                                <<01507>>01255000
                                                               <<01507>>01260000
   byte array dict(*)    = pb  :=                              <<01507>>01265000
      5,3, "ALL",          << 1 >>                             <<01507>>01270000
      5,3, "SET",          << 2 >>                             <<01507>>01275000
      7,5, "ENTRY",        << 3 >>                             <<01507>>01280000
      6,4, "ITEM",         << 4 >>                             <<01507>>01285000
      9,7, "SUBITEM",      << 5 >>                             <<01507>>01290000
     11,9, "STARTHELP",    << 6 >>                             <<04571>>01295000
     10,8, "STOPHELP",     << 7 >>                             <<04571>>01300000
      8,6, "SUBSET",       << 8 >>                             <<01507>>01305000
     10,8, "CONTINUE",     << 9 >>                             <<01507>>01310000
      0;                                                       <<01507>>01315000
                                                               <<01507>>01320000
   byte array endict(*) = pb := 0;  << end address of dict >>  <<01507>>01325000
                                                               <<01507>>01330000
   byte pointer dictp;                                         <<01507>>01335000
                                                               <<01507>>01340000
                                                               <<01507>>01345000
   tos := 0;                << set up db dictionary array. >>  <<01507>>01350000
   @dictp := @s0 & lsl(1);  << byte address.               >>  <<01507>>01355000
   tos := x                 << word length of dict.        >>  <<01507>>01360000
       := (@endict - @dict + 1 ) & lsr(1);                     <<01507>>01365000
   assemble( adds 0 );      << allocate space.             >>  <<01507>>01370000
   tos := @dictp & lsr(1);  << word address of target.     >>  <<01507>>01375000
   tos := @dict & lsr(1);   << word address of source.     >>  <<01507>>01380000
   tos := x;                << count of source.            >>  <<01507>>01385000
   assemble( move pb );     << put dictionary into stack.  >>  <<01507>>01390000
                                                               <<01507>>01395000
   move string := string while ans,1;                          <<01507>>01400000
   len := tos - @string;                                       <<01507>>01405000
                                                               <<01507>>01410000
   buzzfetch := search( string, len, dictp );                  <<01507>>01415000
                                                               <<01507>>01420000
end;  << buzzfetch >>                                          <<01507>>01425000
$title "CLOSECAT"                                                       01430000
procedure closecat(perm);                                               01435000
   value perm;                                                          01440000
   logical perm;                                                        01445000
begin                                                                   01450000
                                                                        01455000
integer                                                                 01460000
   domain,                                                              01465000
   len,                                                                 01470000
   i;                                                                   01475000
                                                                        01480000
byte array buff(0:27);                                                  01485000
byte array buff1(0:27);                                                 01490000
                                                                        01495000
subroutine erretn(findex);                                              01500000
   value findex;                                                        01505000
   integer findex;                                                      01510000
begin                                                                   01515000
   err(findex);                                                         01520000
   condcode := ccl;                                                     01525000
   go outl;                                                             01530000
end; << erretn >>                                                       01535000
                                                                        01540000
subroutine rename(fnx);                                                 01545000
   value fnx;integer fnx;                                               01550000
begin                                                                   01555000
      i := 0;                                                           01560000
      move buff := "CAT";                                               01565000
      do begin                                                          01570000
         i := i+1;                                                      01575000
         buff(ascii(i,10,buff(3)) +3) := " ";                           01580000
         frename(fnarray(fnx),buff);                                    01585000
      end until = or i >9999;                                           01590000
      if <> then erretn(fnx);                                           01595000
      fclose(fnarray(fnx),domain,0);<<close with new name>>             01600000
      if <> then erretn(fnx);                                           01605000
end; << rename >>                                                       01610000
                                                                        01615000
condcode := cce;                                                        01620000
domain := if perm then 1 else 2;                                        01625000
fclose(catfn,domain,0);                                                 01630000
if <> then                                                              01635000
begin                                                                   01640000
   if perm then << old cat is perm, already open? >>                    01645000
   begin                                                                01650000
      fgetinfo(catfn,buff1);                                            01655000
      fgetinfo(infn,buff);                                              01660000
      scan buff until " ",1;                                            01665000
      len := tos -@buff;                                                01670000
      if buff1 = buff,(len) then << already open>>                      01675000
         rename(infnx)                                                  01680000
      else                                                              01685000
      begin                                                             01690000
         move buff := "CATALOG ";                                       01695000
         catoldfn := fopen(buff,1,%100); <<perm;ecxl>>                  01700000
         if <> then erretn(catoldfnx);                                  01705000
         rename(catoldfnx);                                             01710000
      end;                                                              01715000
   end                                                                  01720000
   else                                                                 01725000
   begin << old cat is temp, open it >>                                 01730000
      move buff := "CATALOG ";                                          01735000
      catoldfn := fopen(buff,2,%100); << temp, excl acc >>              01740000
      if <> then erretn(catoldfnx);                                     01745000
      rename(catoldfnx);                                                01750000
   end;                                                                 01755000
   fclose(catfn,domain,0); << try again >>                              01760000
   if <> then erretn(catfnx);                                           01765000
end;                                                                    01770000
                                                                        01775000
outl:                                                                   01780000
end; << closecat >>                                                     01785000
$title "CLOSEHELPCAT"                                                   01790000
procedure closehelpcat;                                                 01795000
begin                                                                   01800000
condcode := cce;                                                        01805000
fclose(infn,0,0);                                                       01810000
if <> then                                                              01815000
begin                                                                   01820000
   err(0);                                                              01825000
   condcode := ccl;                                                     01830000
end                                                                     01835000
else                                                                    01840000
begin                                                                   01845000
   fclose( catfn, 9, 0 );  << return unused space. >>          <<01310>>01850000
   if <> then                                                           01855000
   begin                                                                01860000
      err(1);                                                           01865000
      condcode := ccl;                                                  01870000
   end;                                                                 01875000
end;                                                                    01880000
                                                                        01885000
end; << closehelpcat >>                                                 01890000
                                                                        01895000
$title "DIRFILLIN"                                                      01900000
procedure dirfillin(directory);                                         01905000
   integer array directory;                                             01910000
comment fills in directory holes when missing sets occur                01915000
   after an existing set.                                               01920000
   if set <n+1> is missing, recoffset <n+1> is filled in                01925000
   with recoffset of next existing set.  this gives upper               01930000
   bounds for set <n>.                                                  01935000
   all missing message sets are marked with a "-1" as the      <<01297>>01940000
   first message number.                                       <<01297>>01945000
   note:  the last message set is always a valid entry.        <<01297>>01950000
;                                                              <<01297>>01955000
                                                               <<01297>>01960000
begin                                                          <<01297>>01965000
                                                               <<01297>>01970000
integer  i, j;       << index variables.                   >>  <<01297>>01975000
pointer                                                        <<01297>>01980000
   ptr,              << missing set pointer.               >>  <<01297>>01985000
   maxset'ptr;       << points to the last set entry.      >>  <<01297>>01990000
                                                               <<01297>>01995000
   @maxset'ptr := @directory( directory( maxsetnocell ) * 2 ); <<01297>>02000000
                                                               <<01297>>02005000
   @ptr := @directory( 2 );   << entry for first set.      >>  <<01297>>02010000
   do                                                          <<01297>>02015000
   begin                                                       <<01297>>02020000
                                                               <<01297>>02025000
   << find the next missing set entry, if there.           >>  <<01297>>02030000
      while  ( ptr <> 0 )  and  ( @ptr < @maxset'ptr )         <<01297>>02035000
         do  @ptr := @ptr(2);                                  <<01297>>02040000
                                                               <<01297>>02045000
   << if a missing set entry was found, find the next      >>  <<01297>>02050000
   << valid set entry.                                     >>  <<01297>>02055000
      i := 0;                                                  <<01297>>02060000
      if  ptr = 0  then                                        <<01297>>02065000
      begin                                                    <<01297>>02070000
                                                               <<01297>>02075000
         do i := i + 2        << find next valid entry.    >>  <<01297>>02080000
         until  ptr( i ) <> 0;                                 <<01297>>02085000
                                                               <<01297>>02090000
      <<  "PTR" and "PTR( I-2 )" define a gap of missing   >>  <<01297>>02095000
      <<  set entries.  fill the holes...                  >>  <<01297>>02100000
         for j := 0 step 2 until i-2 do                        <<01297>>02105000
         begin                                                 <<01297>>02110000
            ptr( j ) := ptr( i );                              <<01297>>02115000
            ptr( j+1 ) := -1;                                  <<01297>>02120000
         end;                                                  <<01297>>02125000
                                                               <<01297>>02130000
      end;                                                     <<01297>>02135000
                                                               <<01297>>02140000
   << continue search for missing message set entries.     >>  <<01297>>02145000
      @ptr := @ptr( i+2 );                                     <<01297>>02150000
                                                               <<01297>>02155000
   end                                                         <<01297>>02160000
   until  @ptr >= @maxset'ptr;                                 <<01297>>02165000
                                                               <<01297>>02170000
end;  << dirfillin >>                                          <<01297>>02175000
$title "ERR"                                                            02180000
$control segment=priv1                                                  02185000
procedure err(findex);                                                  02190000
   value findex; integer findex;                                        02195000
   option privileged;                                                   02200000
begin                                                                   02205000
                                                                        02210000
integer                                                                 02215000
   ecode;                                                               02220000
                                                                        02225000
fcheck(fnarray(findex),ecode);                                          02230000
tos := @buff;                                                           02235000
move * := "** FILE ERROR ON ",2;                                        02240000
case findex of                                                          02245000
begin                                                                   02250000
   move * := "INPUT",2;                                                 02255000
   move * := "CATALOG",2;                                               02260000
   move * := "LIST",2;                                                  02265000
   move * := "OLD CATALOG",2;                                           02270000
end;                                                                    02275000
move * := (" (!)",0);                                                   02280000
genmsg(-1,@buff,%10000,ecode);                                          02285000
                                                                        02290000
end; << err >>                                                          02295000
$title "MAKEHELP"                                                       02300000
$control segment=user                                                   02305000
logical procedure makehelp;                                             02310000
begin                                                                   02315000
                                                                        02320000
openin;                                                                 02325000
if <> then go outl;                                                     02330000
openhelpcat;                                                            02335000
if <> then go outl;                                                     02340000
scanhelpcat;                                                            02345000
if <> then go outl;                                                     02350000
closehelpcat;                                                           02355000
if <> then go outl;                                                     02360000
makehelp := true;                                                       02365000
                                                                        02370000
outl:                                                                   02375000
end; << makehelp >>                                                     02380000
$title "OPENCAT"                                                        02385000
$control segment=user                                                   02390000
procedure opencat(on'sdisc);                                            02395000
   value on'sdisc;                                                      02400000
   logical on'sdisc;                                                    02405000
begin                                                                   02410000
   byte array buff(0:7);                                                02415000
   byte array dev(0:5);                                                 02420000
                                                                        02425000
condcode := cce;                                                        02430000
move buff := "CATALOG ";                                                02435000
if on'sdisc then move dev := "1 "                                       02440000
else move dev := "DISC ";                                               02445000
catfn := fopen(buff,4,5,                                                02450000
   recsize,dev,,1,blkfactor,,catsize,1);                                02455000
<< new, write access >>                                                 02460000
if <> then                                                              02465000
begin                                                                   02470000
   err(catfnx);                                                         02475000
   cclretn;                                                             02480000
end;                                                                    02485000
outl:                                                                   02490000
end; << opencat >>                                                      02495000
$title "OPENHELPCAT"                                                    02500000
procedure openhelpcat;                                                  02505000
begin                                                                   02510000
                                                                        02515000
byte array buff(0:7);                                                   02520000
                                                                        02525000
condcode := cce;                                                        02530000
                                                               <<01310>>02535000
<< open helpcat with enough space for key continuation.    >>  <<01310>>02540000
   catsize := catsize + catsize & dlsr(3);                     <<01310>>02545000
                                                               <<01310>>02550000
move buff := "HELPCAT ";                                                02555000
catfn := fopen(buff,4,5,hrecsize,,,hnumofulabels,              <<01310>>02560000
   hblkfactor,,catsize,32); << new, write access >>            <<01310>>02565000
if <> then                                                              02570000
begin                                                                   02575000
   err(catfnx);                                                         02580000
   cclretn;                                                             02585000
end;                                                                    02590000
                                                                        02595000
outl:                                                                   02600000
end; << openhelpcat >>                                                  02605000
$title "ENLARGEHDIR"                                           <<01310>>02610000
procedure enlargehdir( filenum, recno, dir', dirx );           <<01310>>02615000
                                                               <<01310>>02620000
   value   recno;                                              <<01310>>02625000
   integer filenum, recno, dirx;                               <<01310>>02630000
   integer array dir';                                         <<01310>>02635000
                                                               <<01310>>02640000
<< the "HELP" directory has been found to be too small >>      <<01310>>02645000
<< to contain all the entries in the help catalog.     >>      <<01310>>02650000
<< this procedure will enlarge the directory space.    >>      <<01310>>02655000
<< this is done by creating a new file with more user  >>      <<01310>>02660000
<< label (directory) space, copying the old user       >>      <<01310>>02665000
<< labels, and copying the old file.  the old file     >>      <<01310>>02670000
<< is assumed to be the file currently being built for >>      <<01310>>02675000
<< the help catalog.  this file is destroyed and the   >>      <<01310>>02680000
<< new file's number takes its place.                  >>      <<01310>>02685000
                                                               <<01310>>02690000
begin                                                          <<01310>>02695000
                                                               <<01310>>02700000
   integer                                                     <<01310>>02705000
      old,   << old file number (to be deleted).       >>      <<01310>>02710000
      new,   << new file number that replaces old file >>      <<01310>>02715000
      i,     << index counter.                         >>      <<01310>>02720000
      len;   << length of copy record transferred.     >>      <<01310>>02725000
                                                               <<01310>>02730000
   logical                                                     <<01310>>02735000
      dummy := 0, << required by fcontrol.             >>      <<01310>>02740000
      continue;   << looping flag.                     >>      <<01310>>02745000
                                                               <<01310>>02750000
   logical array                                               <<01310>>02755000
      work(0:127);<< working storage for copying.      >>      <<01310>>02760000
                                                               <<01310>>02765000
   byte array                                                  <<01310>>02770000
      dir(*) = dir';                                           <<01310>>02775000
                                                               <<01310>>02780000
   subroutine printx( length );  << prints "BUFF" >>           <<01310>>02785000
      value length;   integer length;                          <<01310>>02790000
   begin                                                       <<01310>>02795000
      fwrite( listfn, buff', -length, 0 );                     <<01310>>02800000
   end;                                                        <<01310>>02805000
<< can a file be created with a large enough directory?   >>   <<01310>>02810000
   if (hlabels'written + hlabels'in'next'block + hnextnumlbls) <<01310>>02815000
      > 255   then                                             <<01310>>02820000
   begin                                                       <<01310>>02825000
                                                               <<01310>>02830000
   << 255 is the maximum number of user labels.  there is >>   <<01310>>02835000
   << no room for a large enough directory.               >>   <<01310>>02840000
      move buff := "** OVERFLOWS DIRECTORY.  REC=", 2;         <<01310>>02845000
      tos := ascii( recno+1, 10, bps0 );                       <<01310>>02850000
      tos := tos + tos; << add length of ascii to string. >>   <<01310>>02855000
      printx( tos - @buff );                                   <<01310>>02860000
      cclretn;                                                 <<01310>>02865000
                                                               <<01310>>02870000
   end  << not enough user labels.  >>                         <<01310>>02875000
   else                                                        <<01310>>02880000
   begin                                                       <<01310>>02885000
                                                               <<01310>>02890000
   << a larger directory can be created.  make a new file.>>   <<01310>>02895000
      old := filenum;                                          <<01310>>02900000
      hnumofulabels := hnumofulabels + hnextnumlbls;           <<01310>>02905000
      move buff := "HELPCAT ";                                 <<01310>>02910000
      new := fopen( buff, 4, 5, hrecsize,,, hnumofulabels,     <<01310>>02915000
                    hblkfactor,, catsize, 32 );                <<01310>>02920000
      if <> then                                               <<01310>>02925000
      begin                                                    <<01310>>02930000
                                                               <<01310>>02935000
      << an error occurred while attempting to open file. >>   <<01310>>02940000
         move buff := "** UNABLE TO OPEN LARGER FILE.", 2;     <<01310>>02945000
         printx( tos - @buff );                                <<01310>>02950000
         cclretn;                                              <<01310>>02955000
                                                               <<01310>>02960000
      end;                                                     <<01310>>02965000
                                                               <<01310>>02970000
   << copy the old directory into the new, larger one.    >>   <<01310>>02975000
      for i := 0 until hlabels'written - 1  do                 <<01310>>02980000
      begin                                                    <<01310>>02985000
                                                               <<01310>>02990000
      << read a label from old directory.  check for error>>   <<01310>>02995000
         freadlabel( old, work, 128, i );                      <<01310>>03000000
         if <> then                                            <<01310>>03005000
         begin                                                 <<01310>>03010000
            move buff := "UNABLE TO READ DIRECTORY", 2;        <<01310>>03015000
            printx( tos - @buff );                             <<01310>>03020000
            cclretn;                                           <<01310>>03025000
         end                                                   <<01310>>03030000
         else  << freadlabel was okay.                    >>   <<01310>>03035000
         begin                                                 <<01310>>03040000
                                                               <<01310>>03045000
         << write the label to the new file.  error check.>>   <<01310>>03050000
            fwritelabel( new, work, 128, i );                  <<01310>>03055000
            if > then                                          <<01310>>03060000
            begin                                              <<01310>>03065000
               move buff := "ENLARGED DIRECTORY TOO SMALL.", 2;<<01310>>03070000
               printx( tos - @buff );                          <<01310>>03075000
               cclretn;                                        <<01310>>03080000
            end                                                <<01310>>03085000
            else if < then  << fwritelabel error.         >>   <<01310>>03090000
            begin                                              <<01310>>03095000
               move buff := "COPYING ERROR (DIRECTORY).", 2;   <<01310>>03100000
               printx( tos - @buff );                          <<01310>>03105000
               cclretn;                                        <<01310>>03110000
            end;                                               <<01310>>03115000
                                                               <<01310>>03120000
         end;  << fwritelabel checks >>                        <<01310>>03125000
                                                               <<01310>>03130000
      end;  << directory copying loop >>                       <<01310>>03135000
                                                               <<01310>>03140000
   << copy the old file contents into the new file.       >>   <<01310>>03145000
      fcontrol( old, 5, dummy );  << "REWIND" >>               <<01310>>03150000
      if <> then                                               <<01310>>03155000
      begin                                                    <<01310>>03160000
         move buff := "UNABLE TO 'REWIND' OLD FILE.", 2;       <<01310>>03165000
         printx( tos - @buff );                                <<01310>>03170000
         cclretn;                                              <<01310>>03175000
      end;                                                     <<01310>>03180000
                                                               <<01310>>03185000
      continue := true;                                        <<01310>>03190000
      while continue do                                        <<01310>>03195000
      begin                                                    <<01310>>03200000
                                                               <<01310>>03205000
      << read a record from the old file.  error check.   >>   <<01310>>03210000
         len := fread( old, work, hrecsize );                  <<01310>>03215000
         if > then continue:=false  << last rec was read. >>   <<01310>>03220000
         else if < then  << fread error.                  >>   <<01310>>03225000
         begin                                                 <<01310>>03230000
            move buff := "READING ERROR WHILE ENLARGING.", 2;  <<01310>>03235000
            printx( tos - @buff );                             <<01310>>03240000
            cclretn;                                           <<01310>>03245000
         end                                                   <<01310>>03250000
                                                               <<01310>>03255000
         else   << fread was okay.                        >>   <<01310>>03260000
         begin                                                 <<01310>>03265000
                                                               <<01310>>03270000
         << write record to new file.  check for errors.  >>   <<01310>>03275000
            fwrite( new, work, len, 0 );                       <<01310>>03280000
            if > then   << new file too small.            >>   <<01310>>03285000
            begin                                              <<01310>>03290000
               move buff := "ENLARGED FILE TOO SMALL.", 2;     <<01310>>03295000
               printx( tos - @buff );                          <<01310>>03300000
               cclretn;                                        <<01310>>03305000
            end                                                <<01310>>03310000
            else if < then  << fwrite error.              >>   <<01310>>03315000
            begin                                              <<01310>>03320000
               move buff := "COPYING ERROR (FILE).", 2;        <<01310>>03325000
               printx( tos - @buff );                          <<01310>>03330000
               cclretn;                                        <<01310>>03335000
            end;                                               <<01310>>03340000
                                                               <<01310>>03345000
         end;  << fwrite checks.  >>                           <<01310>>03350000
                                                               <<01310>>03355000
      end;  << file copying loop.  >>                          <<01310>>03360000
                                                               <<01310>>03365000
   << fill out the next directory block.                  >>   <<01310>>03370000
      for i := dirx until hwords'in'next'block*2 - 2           <<01310>>03375000
          do  dir( i ) := 0;                                   <<01310>>03380000
                                                               <<01310>>03385000
   << write the contents of "DIR" and reset counters.     >>   <<01310>>03390000
      for i := 0 until hlabels'in'next'block - 1  do           <<01310>>03395000
      begin                                                    <<01310>>03400000
                                                               <<01310>>03405000
         fwritelabel( new, dir'( i*128 ), 128,                 <<01310>>03410000
                      hlabels'written + i       );             <<01310>>03415000
         if <> then                                            <<01310>>03420000
         begin                                                 <<01310>>03425000
            err( catfnx );                                     <<01310>>03430000
            cclretn;                                           <<01310>>03435000
         end;                                                  <<01310>>03440000
                                                               <<01310>>03445000
      end;                                                     <<01310>>03450000
                                                               <<01310>>03455000
      dirx := 0;                                               <<01310>>03460000
      hlabels'written := hlabels'written                       <<01310>>03465000
                         + hlabels'in'next'block;              <<01310>>03470000
      hwords'written := hwords'written                         <<01310>>03475000
                         + hwords'in'next'block;               <<01310>>03480000
      hlabels'in'next'block := hnextnumlbls;                   <<01310>>03485000
      hwords'in'next'block := hnextnumwords;                   <<01310>>03490000
      for i := 0 until hmaxdirsizem1                           <<01310>>03495000
          do dir'(i) := 0;                                     <<01310>>03500000
                                                               <<01310>>03505000
   << replace old file with new.  delete old file.        >>   <<01310>>03510000
      filenum := new;                                          <<01310>>03515000
      fclose( old, 4, 0 );                                     <<01310>>03520000
                                                               <<01310>>03525000
   end;  << else clause:  can make bigger directory.      >>   <<01310>>03530000
                                                               <<01310>>03535000
   condcode := cce;                                            <<01310>>03540000
   outl:   << jump off point for "CCLRETN".               >>   <<01310>>03545000
                                                               <<01310>>03550000
end;   << enlargehdir >>                                       <<01310>>03555000
$title "OPENIN"                                                         03560000
procedure openin;                                                       03565000
begin                                                                   03570000
                                                                        03575000
byte array buff(0:7);                                                   03580000
                                                                        03585000
condcode := cce;                                                        03590000
   move buff := "INPUT ";                                               03595000
infn := fopen(buff,5,5); <<oldperm,ascii;write>>                        03600000
if <> then                                                              03605000
begin                                                                   03610000
   err(infnx);                                                          03615000
   cclretn;                                                             03620000
end;                                                                    03625000
fgetinfo(infn,,,,,,,,,,catsize);                                        03630000
if <> then                                                              03635000
begin                                                                   03640000
   err(infnx);                                                          03645000
   cclretn;                                                             03650000
end;                                                                    03655000
outl:                                                                   03660000
end; << openin >>                                                       03665000
$title "SCANCAT"                                                        03670000
procedure scancat(directory);                                           03675000
   integer array directory;                                             03680000
comment:                                                                03685000
   scans message catalog to determine validity & make directory.        03690000
   first column specialties are "$" and numberic. "$SET X" indicates    03695000
   the start of a new set "X". "$" anything else is a comment.          03700000
   "&" or "%" indicates message is continued on the following line.     03705000
   comments can not be imbedded within continued messages. the          03710000
   directory contains the record offset for each message set & th       03715000
   starting message number.                                             03720000
condition code                                                          03725000
   cce = everything ok                                                  03730000
   ccl = problem of some type                                           03735000
;                                                                       03740000
begin                                                                   03745000
                                                                        03750000
integer                                                                 03755000
   msgno'old,                                                           03760000
   msgno,                                                               03765000
   maxsetno,                                                            03770000
   setno,                                                               03775000
   i,                                                          <<00210>>03780000
   recno,                                                               03785000
   len,                                                                 03790000
   plen;                                                                03795000
                                                                        03800000
logical                                                                 03805000
   stuffdir,                                                            03810000
   lined,                                                      <<00210>>03815000
   continue;                                                            03820000
                                                                        03825000
byte pointer                                                            03830000
   ptr;                                                                 03835000
                                                                        03840000
                                                                        03845000
                                                                        03850000
   array buff'(0:66);                                                   03855000
   byte array buff(*)=buff';                                            03860000
   array buff'old'(0:recsize);                                          03865000
   byte array buff'old(*)=buff'old';                                    03870000
                                                                        03875000
                                                                        03880000
subroutine printwarn( len );                                   <<01321>>03885000
   value len;  integer len;                                    <<01321>>03890000
begin                                                          <<01321>>03895000
                                                               <<01321>>03900000
<< does not set condition code--just prints warning. >>        <<01321>>03905000
   fwrite( listfn, buff', -len, 0 );                           <<01321>>03910000
                                                               <<01321>>03915000
end;  << printwarn >>                                          <<01321>>03920000
                                                               <<01321>>03925000
                                                                        03930000
subroutine printx(length);                                              03935000
   value length; integer length;                                        03940000
begin                                                                   03945000
   fwrite(listfn,buff',-length,0);                                      03950000
   condcode := ccl; << found an error >>                                03955000
end; << printx >>                                                       03960000
                                                                        03965000
subroutine printxset(len);                                              03970000
   value len;                                                           03975000
   integer len;                                                         03980000
comment adds " .SET=<SETNO>" to msg                                     03985000
;                                                                       03990000
begin                                                                   03995000
   move buff(len) := " .SET= ",2;                                       04000000
   tos := ascii(setno,10,bps0);                                         04005000
   tos := tos +tos; <<add ascii to end addr >>                          04010000
   printx(tos-@buff);                                                   04015000
end; << printxset >>                                                    04020000
                                                                        04025000
subroutine writecatalog;                                                04030000
begin                                                                   04035000
   fwrite(catfn,buff',-len,0);                                          04040000
   if <> then                                                           04045000
   begin                                                                04050000
      err(catfnx);                                                      04055000
      cclretn;                                                          04060000
   end;                                                                 04065000
end; << writecatalog >>                                                 04070000
                                                                        04075000
subroutine stuffdir';                                                   04080000
begin                                                                   04085000
   if stuffdir then                                                     04090000
   begin                                                                04095000
      if directory(setno*2) <> 0 then << duplicate set >>               04100000
      begin << warn, but take last occurrence >>                        04105000
         move buff := ("** WARNING. DUPLICATE SET NO. ",                04110000
            "IN RECORD "),2;                                            04115000
         tos := ascii(recno+1,10,bps0);                                 04120000
         tos := tos+tos; << add ascii to end adr >>                     04125000
         move * := ". LAST ONE USED",2;                                 04130000
         printxset(tos-@buff);                                          04135000
         condcode := cce; << reset to ok (printx sets) >>               04140000
      end;                                                              04145000
      directory(setno*2) := recno; << starting msg addr>>               04150000
      directory(x:=x+1) := msgno; << starting msg no. >>                04155000
      stuffdir := false;                                                04160000
   end;                                                                 04165000
end; << stuffdir >>                                                     04170000
                                                                        04175000
logical subroutine chkcontinue;                                         04180000
begin                                                                   04185000
   lined:=true;                                                <<00210>>04190000
   for i:=len-8 until len-1                                    <<00210>>04195000
      do if buff(i)<>numeric then lined:=false;                <<00210>>04200000
   x:=len - (if lined then 8 else 0);                          <<00210>>04205000
   do x:=x-1 until x<0 or buff(x)<>" ";<<find last non-blank>> <<00135>>04210000
   if x>=0 and (buff(x)="&" or buff(x)="%")                    <<00135>>04215000
      then chkcontinue:=true;                                  <<00135>>04220000
end; << chkcontinue >>                                                  04225000
                                                                        04230000
subroutine finishup;                                                    04235000
begin                                                                   04240000
   if maxsetno=0 then << no set for msgs >>                             04245000
   begin                                                                04250000
      printx(len);                                                      04255000
      move buff := "**MISSING MESSAGE SET NO.",2;                       04260000
      printx(tos-@buff);                                                04265000
      cclretn;                                                          04270000
   end;                                                                 04275000
   stuffdir';   << in case the last set had no messages. >>    <<01297>>04280000
   directory(maxsetnocell) := maxsetno;                                 04285000
   directory(maxrecell) := recno-1;                                     04290000
   go outl;<< everything done >>                                        04295000
end; << finishup >>                                                     04300000
                                                                        04305000
subroutine lookforset;                                                  04310000
begin                                                                   04315000
                                                                        04320000
plen := findparm(buff(1),ptr);                                          04325000
if plen = 3 and ptr = "SET" then                                        04330000
begin                                                                   04335000
   plen := nextparm(ptr(plen),ptr);                                     04340000
   move ptr := ptr while n,1;                                           04345000
   plen := tos -@ptr;                                                   04350000
   setno := binary(ptr,plen);                                           04355000
   if <> then << not numeric >>                                         04360000
   begin                                                                04365000
      printx(len);                                                      04370000
      move buff := "     ^";                                            04375000
      printx(7);                                                        04380000
      move buff := "**EXPECTED NUMERIC",2;                              04385000
      printx(tos-@buff);                                                04390000
   end                                                                  04395000
   else                                                                 04400000
   begin                                                                04405000
      if setno =0 or setno > maxnosets then                             04410000
      begin                                                             04415000
         printx(len);                                                   04420000
         move buff :="**INVALID SET NO. MAXIMUM=",2;                    04425000
         tos := ascii(maxsetno,10,s0);                                  04430000
         printx((tos+tos)-@buff);                                       04435000
         setno := 0; << make invalid >>                                 04440000
      end                                                               04445000
      else                                                              04450000
      begin                                                             04455000
                                                                        04460000
      << now have valid set no. >>                                      04465000
         if setno > maxsetno then maxsetno := setno;                    04470000
         stuffdir := true; << fill dir when msg found>>                 04475000
         msgno := -1; << found new set. reset >>                        04480000
      end;                                                              04485000
   end;                                                                 04490000
end                                                                     04495000
else continue := false;                                                 04500000
<< found comment. not allowed in continued msgs >>                      04505000
                                                                        04510000
end; << lookforset >>                                                   04515000
                                                                        04520000
subroutine lookformsgno;                                                04525000
begin                                                                   04530000
                                                                        04535000
msgno'old :=msgno;                                                      04540000
move buff := buff while n,1;                                            04545000
msgno := binary(buff,s0-@buff); del;                                    04550000
if <> then                                                              04555000
begin                                                                   04560000
   printx(len);                                                         04565000
   buff := "^";                                                         04570000
   printx(1);                                                           04575000
   move buff := "**EXPECTED NUMERIC",2;                                 04580000
   printxset(tos-@buff);                                                04585000
end                                                                     04590000
else                                                                    04595000
begin                                                                   04600000
   if continue then   << number in col 1 of continue line.>>   <<01321>>04605000
   begin                                                                04610000
      continue := chkcontinue;                                 <<01321>>04615000
      msgno := msgno'old;                                      <<01321>>04620000
      printwarn( len );                                        <<01321>>04625000
      move buff := "^  TREATED AS CONTINUATION LINE.", 2;      <<01321>>04630000
      printwarn( tos - @buff );                                <<01321>>04635000
      return;                                                  <<01321>>04640000
   end;                                                                 04645000
   if msgno <= msgno'old then                                           04650000
   begin                                                                04655000
      printx(len);                                                      04660000
      move buff := ("**MESSAGE NO. NOT ASCENDING",                      04665000
         " LAST NO.="),2;                                               04670000
      tos := ascii(msgno'old,10,bps0);                                  04675000
      assemble(add);                                                    04680000
      printxset(tos-@buff);                                             04685000
   end;                                                                 04690000
                                                                        04695000
      << found valid msg no. >>                                         04700000
                                                                        04705000
   stuffdir'; << place first msg info in dir. >>                        04710000
   << now check for continue >>                                         04715000
   continue := chkcontinue;                                             04720000
end;                                                                    04725000
                                                                        04730000
end; << lookformsgno >>                                                 04735000
                                                                        04740000
subroutine lookforcontinue;                                             04745000
begin                                                                   04750000
      if not continue then                                              04755000
      begin << was looking for start of msg >>                          04760000
         printx(len);                                                   04765000
         buff := "^";                                                   04770000
         printx(1);                                                     04775000
         move buff := "**EXPECTED MESSAGE NO.",2;                       04780000
         printxset(tos-@buff);                                          04785000
      end                                                               04790000
      else continue := chkcontinue;                                     04795000
end; << lookforcontinue >>                                              04800000
                                                                        04805000
                                                                        04810000
<< main body >>                                                         04815000
                                                                        04820000
<< open list file >>                                                    04825000
move buff := "LIST ";                                                   04830000
listfn := fopen(buff,%14,1,-132);                                       04835000
if <> then                                                              04840000
begin                                                                   04845000
   err(listfnx);                                                        04850000
   cclretn;                                                             04855000
end;                                                                    04860000
                                                                        04865000
<< set up >>                                                            04870000
continue := stuffdir := false;                                          04875000
condcode := cce;                                                        04880000
msgno := msgno'old := -1;                                               04885000
directory := recno := maxsetno := setno := 0;                           04890000
move directory(1) := directory,(msgdirsize-1);                          04895000
                                                                        04900000
loop:                                                                   04905000
   len := fread(infn,buff',-recsizeb);                                  04910000
   if < then                                                            04915000
   begin                                                                04920000
      err(infnx);                                                       04925000
      cclretn;                                                          04930000
   end;                                                                 04935000
   if > then finishup; << finish & get out >>                           04940000
   move buff'old' := buff',(recsize);                                   04945000
   writecatalog;                                                        04950000
                                                                        04955000
   << look for $ >>                                                     04960000
   if buff = "$" then lookforset                                        04965000
   else                                                                 04970000
                                                                        04975000
   << no $. look for msgno >>                                           04980000
   if buff = numeric then lookformsgno                                  04985000
   else lookforcontinue;                                                04990000
   << not $, not start of msg. must be continue >>                      04995000
                                                                        05000000
   << everything done >>                                                05005000
   recno := recno+1;                                                    05010000
   go loop;                                                             05015000
                                                                        05020000
outl:                                                                   05025000
end; << scancat >>                                                      05030000
$title "SCANHELPCAT"                                                    05035000
procedure scanhelpcat;                                                  05040000
comment                                                                 05045000
   builds directory & places in userlabels. currently uses 1            05050000
   physical block (40 words in record x 16 records per block)           05055000
   1st word of directory is directory size in words.                    05060000
   directory is "SEARCH" format with 2 bytes for record no.             05065000
   format :                                                             05070000
      9,5,"FILE",lrecno,rrecno,                                         05075000
                                                                        05080000
condition code                                                          05085000
   cce = everything ok                                                  05090000
   ccl = problem of some type                                           05095000
;                                                                       05100000
begin                                                                   05105000
                                                                        05110000
equate                                                                  05115000
   maxkeys       = 16,                                                  05120000
   maxkeysm1     = maxkeys -1;                                          05125000
                                                                        05130000
integer                                                                 05135000
   msgno'old,                                                           05140000
   msgno,                                                               05145000
   maxsetno,                                                            05150000
   setno,                                                               05155000
   recno,                                                               05160000
   len,                                                                 05165000
   keyrecno,                                                            05170000
   helpsetno,                                                           05175000
   keybufflen,                                                          05180000
   numparms,                                                            05185000
   entrytype,                                                           05190000
   dummy,                                                               05195000
   dirx,                                                                05200000
   index = dummy,                                                       05205000
   entryx;                                                              05210000
                                                                        05215000
logical                                                                 05220000
   helpset,                                                             05225000
   stuffkey,                                                            05230000
   endofset,                                                            05235000
   subset,                                                              05240000
   subsetonly,                                                 <<04571>>05245000
   stophelp,                                                            05250000
   starthelp,                                                  <<04571>>05255000
   stophelpending;                                                      05260000
                                                                        05265000
integer                                                                 05270000
   i,                                                          <<01310>>05275000
   continue'lines:=0, << counts "\CONTINUE" entries. >>        <<01310>>05280000
   parm1len,                                                            05285000
   parm2len;                                                            05290000
                                                                        05295000
double                                                         <<01310>>05300000
   templinenum,                                                <<04570>>05305000
   linenum;                                                    <<01310>>05310000
byte pointer                                                            05315000
   parm1,                                                               05320000
   parm2;                                                               05325000
                                                                        05330000
array keybuff'(0:hrecsizem1);                                           05335000
byte array keybuff(*) = keybuff';                                       05340000
integer array dir'(0:hmaxdirsizem1);                           <<01310>>05345000
byte array dir(*) = dir';                                               05350000
                                                                        05355000
   array buff'(0:66);                                                   05360000
   byte array buff(*)=buff';                                            05365000
                                                                        05370000
   logical array tbuff(0:hrecsizem1);                          <<01310>>05375000
   byte array tbuffb(*) = tbuff;                               <<01310>>05380000
                                                                        05385000
intrinsic freaddir, dbinary, dascii;                           <<01310>>05390000
                                                                        05395000
<<********************************************************>>   <<04570>>05400000
<<                                                        >>   <<04570>>05405000
<<               p r i n t x             subroutine       >>   <<04570>>05410000
<<                                                        >>   <<04570>>05415000
<<********************************************************>>   <<04570>>05420000
subroutine printx(length);                                              05425000
   value length; integer length;                                        05430000
begin                                                                   05435000
   fwrite(listfn,buff',-length,0);                                      05440000
   condcode := ccl; << found an error >>                                05445000
end; << printx >>                                                       05450000
                                                                        05455000
subroutine writecatalog;                                                05460000
                                                               <<04570>>05465000
<<  this subroutine writes out the input record read from >>   <<04570>>05470000
<<  the input file out to the new help catalog at the same>>   <<04570>>05475000
<<  record.  for records following a \subset command and  >>   <<04570>>05480000
<<  a \stophelp output is not done (the records are not   >>   <<04570>>05485000
<<  written to the output file) until a \starthelp command>>   <<04570>>05490000
<<  is read in.                                           >>   <<04570>>05495000
                                                               <<04570>>05500000
begin                                                                   05505000
   if subsetonly lor                                           <<04571>>05510000
      (subset land stophelpending) lor                         <<04571>>05515000
      (subset land starthelp)  then                            <<04571>>05520000
      begin                                                    <<04571>>05525000
      subsetonly := false;                                     <<04571>>05530000
      starthelp := false;                                      <<04571>>05535000
      end                                                      <<04571>>05540000
   else                                                                 05545000
   begin                                                                05550000
      fwritedir(catfn,buff',-len,double(recno));                        05555000
      if <> then                                                        05560000
      begin                                                             05565000
         err(catfnx);                                                   05570000
         cclretn;                                                       05575000
      end;                                                              05580000
      recno := recno + 1;  <<output record number>>            <<04571>>05585000
   end;                                                                 05590000
end; << writecatalog >>                                                 05595000
                                                                        05600000
<<********************************************************>>   <<04570>>05605000
<<                                                        >>   <<04570>>05610000
<<          s t u f f h e l p d i r     subroutine        >>   <<04570>>05615000
<<                                                        >>   <<04570>>05620000
<<********************************************************>>   <<04570>>05625000
subroutine stuffhelpdir;                                                05630000
begin                                                                   05635000
if dirx + parm2len + 4 >= hwords'in'next'block*2 then          <<01310>>05640000
begin << directory too large >>                                         05645000
    enlargehdir( catfn, recno, dir', dirx );                   <<01310>>05650000
    if condcode = ccl then quit( henlargerror );               <<01310>>05655000
end;                                                           <<01310>>05660000
                                                               <<01310>>05665000
                                                               <<01310>>05670000
dir(dirx)                   := parm2len + 4;                   <<01310>>05675000
dir(dirx:=dirx+1)           := parm2len;                       <<01310>>05680000
move dir(dirx:=dirx+1)      := parm2,(parm2len);               <<01310>>05685000
dir(dirx:=dirx+parm2len)    := recno.(0:8);                    <<01310>>05690000
dir(dirx:=dirx+1)           := recno.(8:8);                    <<01310>>05695000
dirx := dirx + 1;                                              <<01310>>05700000
                                                               <<01310>>05705000
                                                               <<01310>>05710000
                                                                        05715000
end; << stuffhelpdir >>                                                 05720000
                                                                        05725000
                                                                        05730000
<<********************************************************>>   <<04570>>05735000
<<                                                        >>   <<04570>>05740000
<<               d o s t u f f k e y     subroutine       >>   <<04570>>05745000
<<                                                        >>   <<04570>>05750000
<<********************************************************>>   <<04570>>05755000
subroutine dostuffkey;                                                  05760000
begin << rewrites entry with key words>>                                05765000
                                                                        05770000
stuffkey := false;                                                      05775000
                                                               <<01310>>05780000
fwritedir(catfn,keybuff',hrecsize,double(                               05785000
   keyrecno + continue'lines ) );                              <<01310>>05790000
if <> then                                                              05795000
begin                                                                   05800000
   err(catfnx);                                                         05805000
   cclretn;                                                             05810000
end;                                                                    05815000
                                                                        05820000
end; << subroutine dostuffkey >>                                        05825000
                                                                        05830000
                                                                        05835000
<<********************************************************>>   <<04570>>05840000
<<                                                        >>   <<04570>>05845000
<<               f i n i s h u p         subroutine       >>   <<04570>>05850000
<<                                                        >>   <<04570>>05855000
<<********************************************************>>   <<04570>>05860000
subroutine finishup;                                                    05865000
begin                                                                   05870000
   if endofset then << helpset ended with "\ALL">>                      05875000
   begin                                                                05880000
      if stuffkey then dostuffkey;<<put keys from last entry>>          05885000
      dir(dirx) := 0; << stopper >>                                     05890000
      hwords'written := hwords'written + ( dirx&lsr(1) );      <<01310>>05895000
      index := 0;                                                       05900000
      do begin                                                          05905000
         fwritelabel( catfn, dir'(index*128), 128,             <<01310>>05910000
                      index + hlabels'written         );       <<01310>>05915000
         if <> then                                                     05920000
         begin                                                          05925000
            err(catfnx);                                                05930000
            cclretn;                                                    05935000
         end;                                                           05940000
         index := index +1;                                             05945000
         dirx := dirx - 256;                                   <<01310>>05950000
      end until <= ;                                                    05955000
      freadlabel( catfn, dir', 128, 0 );                       <<01310>>05960000
      dir := hwords'written.(0:8);                             <<01310>>05965000
      dir(1) := hwords'written.(8:8);                          <<01310>>05970000
      fwritelabel( catfn, dir', 128, 0 );                      <<01310>>05975000
   end                                                                  05980000
   else                                                                 05985000
   begin                                                                05990000
      move buff := ("**MISSING '\ALL' AT END OF",                       05995000
         "HELPSET"),2;                                                  06000000
      printx(tos -@buff);                                               06005000
   end;                                                                 06010000
   go outl; << everything done >>                                       06015000
end; << finishup >>                                                     06020000
                                                                        06025000
<<********************************************************>>   <<04570>>06030000
<<                                                        >>   <<04570>>06035000
<<               l o o k f o r h e l p   subroutine       >>   <<04570>>06040000
<<                                                        >>   <<04570>>06045000
<<********************************************************>>   <<04570>>06050000
subroutine lookforhelp;                                                 06055000
begin                                                                   06060000
                                                                        06065000
endofset := false; << want last record to be "\ALL">>                   06070000
   buff(hrecsizeb) :=  stopper;<< stopper >>                            06075000
   parm1len := findparm(buff(1),parm1);                                 06080000
   parm2len := nextparm(parm1(parm1len),parm2);                         06085000
   case buzzfetch(parm1) of                                             06090000
   begin                                                                06095000
                                                                        06100000
<<0:galley cmd>>  ;                                                     06105000
<<1:all - end of helpset >>                                             06110000
      begin                                                             06115000
         endofset := true;                                              06120000
      end;                                                              06125000
<<2: set   >>                                                           06130000
      ; << not used >>                                                  06135000
<<3: entry>>                                                   <<04571>>06140000
      begin                                                             06145000
         if stuffkey then <<put keys from last entry in cat>>           06150000
            dostuffkey;                                                 06155000
         stuffhelpdir;                                                  06160000
         keyrecno := recno; << key list adr >>                          06165000
         keybuff' := "  ";                                              06170000
         move keybuff'(1) := keybuff',(hrecsizem1);                     06175000
         move keybuff(hbuffsizeb) := buff(hbuffsizeb),(8);              06180000
            << line nos >>                                              06185000
         keybuff := "\";                                                06190000
         move keybuff(1) := parm1,(parm1len);                           06195000
         keybuff(parm1len +1) := "=";                                   06200000
         move keybuff(parm1len +2) := parm2,(parm2len);                 06205000
         keybufflen := parm1len + parm2len +2;                          06210000
         continue'lines := 0;                                  <<01310>>06215000
      end;                                                              06220000
<<4: item >>      go subitem;                                           06225000
<<5:subitem>>                                                           06230000
      begin                                                             06235000
subitem:                                                                06240000
      stuffkey := true;                                        <<01310>>06245000
  << item keywords are moved to buffer keybuff until the >>    <<04570>>06250000
  << total length of keybuff plus the next keyword is 72 >>    <<04570>>06255000
  << or greater.  when it reaches greater than 72 the    >>    <<04570>>06260000
  << space is made for continuation lines by moving the  >>    <<04570>>06265000
  << records in the output catalog down and inserting    >>    <<04570>>06270000
  << the keyword buffer keybuff.                         >>    <<04570>>06275000
  <<                                                     >>    <<04570>>06280000
      if hbuffsizeb <= keybufflen + parm2len + 1 then          <<01310>>06285000
         begin                                                          06290000
                                                               <<01310>>06295000
      << make room for the continuation line if possible.  >>  <<01310>>06300000
      << note:  current record has not yet been written.   >>  <<01310>>06305000
         for i := recno-1 step -1                              <<01310>>06310000
                  until keyrecno + continue'lines + 1  do      <<01310>>06315000
         begin                                                 <<01310>>06320000
            freaddir( catfn, tbuff, hrecsize, double(i) );     <<01310>>06325000
    <<  read output file record i  >>                          <<04570>>06330000
            if <> then                                         <<01310>>06335000
            begin                                              <<01310>>06340000
               move buff := "CONTINUATION FREADDIR ERROR.", 2; <<01310>>06345000
               printx( tos - @buff );                          <<01310>>06350000
               go outl;                                        <<01310>>06355000
            end;                                               <<01310>>06360000
    << write output file record i to output rec. i+1 >>        <<04570>>06365000
            fwritedir( catfn, tbuff, hrecsize, double(i+1) );  <<01310>>06370000
            if <> then                                         <<01310>>06375000
            begin                                              <<01310>>06380000
               move buff := "CONTINUATION FWRITEDIR ERROR.", 2;<<01310>>06385000
               printx( tos - @buff );                          <<01310>>06390000
               go outl;                                        <<01310>>06395000
            end;                                               <<01310>>06400000
         end;                                                  <<01310>>06405000
         recno := recno + 1;                                   <<01310>>06410000
                                                               <<01310>>06415000
      << update counters and create new line.              >>  <<01310>>06420000
         keybuff( keybufflen ) := ",";                         <<01310>>06425000
         keybufflen := keybufflen + 1;                         <<01310>>06430000
         dostuffkey;                                           <<01310>>06435000
                                                               <<01310>>06440000
      << handle the line numbers.                          >>  <<01310>>06445000
         freaddir( catfn, tbuff, hrecsize,                     <<01310>>06450000
                   double( keyrecno + continue'lines )     );  <<01310>>06455000
  << check for valid line numbers in columns 73 to 80 >>       <<04570>>06460000
      templinenum := dbinary(tbuffb(72),8);                    <<04570>>06465000
      if <> then                                               <<04570>>06470000
         begin                                                 <<04570>>06475000
         move buff :=                                          <<04570>>06480000
"INVALID LINE NUMBER IN INPUT TEXT, COLUMNS 73 TO 80",2;       <<04570>>06485000
         printx(tos-@buff);                                    <<04570>>06490000
         go outl;                                              <<04570>>06495000
         end;                                                  <<04570>>06500000
      linenum := templinenum + 1d;  << for comparison  >>      <<04570>>06505000
         freaddir( catfn, tbuff, hrecsize,                     <<01310>>06510000
                   double( keyrecno + continue'lines + 1 )  ); <<01310>>06515000
         if ( dbinary( tbuffb(72), 8 ) )   <=   linenum then   <<01310>>06520000
         begin                                                 <<01310>>06525000
            move buff :=                                       <<01310>>06530000
                 "INSUFF. LINE # SPACE FOR CONTINUATION",2 ;   <<01310>>06535000
            printx( tos - @buff );                             <<01310>>06540000
            go outl;                                           <<01310>>06545000
         end;                                                  <<01310>>06550000
                                                               <<01310>>06555000
         keybuff := " ";                                       <<01310>>06560000
         keybuff( 1 ) := " ";                                  <<01310>>06565000
         move keybuff'(1) := keybuff', (hrecsizem1);           <<01310>>06570000
         move keybuff := "\CONTINUE ";                         <<01310>>06575000
         keybufflen := 9;                                      <<01310>>06580000
         continue'lines := continue'lines + 1;                 <<01310>>06585000
                                                               <<01310>>06590000
         i := dascii( linenum, 10, tbuffb );                   <<01310>>06595000
         move keybuff(72) := "00000000";                       <<01310>>06600000
         move keybuff( 80-i ) := tbuffb, (i);                  <<01310>>06605000
         dostuffkey;                                           <<01310>>06610000
                                                               <<01310>>06615000
         if hbuffsizeb >= keybufflen + parm2len + 1 then       <<01310>>06620000
            go subitem;                                        <<01310>>06625000
         printx( len );                                        <<01310>>06630000
         move buff := "**KEYWORD LIST WON'T FIT", 2;           <<01310>>06635000
         printx( tos - @buff );                                <<01310>>06640000
         go outl;                                              <<01310>>06645000
      end;                                                     <<01310>>06650000
                                                               <<01310>>06655000
      if parm2len > 0 then                                     <<01310>>06660000
      begin                                                    <<01310>>06665000
         keybuff( keybufflen ) := ",";                         <<01310>>06670000
         move keybuff(keybufflen+1) := parm2,(parm2len);       <<01310>>06675000
         keybufflen := keybufflen + parm2len + 1;              <<01310>>06680000
      end;                                                     <<01310>>06685000
                                                               <<01310>>06690000
   end;                                                        <<01310>>06695000
                                                               <<01310>>06700000
<<6: starthelp >>                                                       06705000
      begin                                                    <<04571>>06710000
      stophelpending := false;                                          06715000
      starthelp := true;                                       <<04571>>06720000
      end;                                                     <<04571>>06725000
<<7: stophelp >>                                                        06730000
      stophelpending := true;                                           06735000
<<8: subset >>                                                          06740000
      begin                                                    <<04571>>06745000
      subset := true;                                                   06750000
      subsetonly := false;                                     <<04571>>06755000
      end;                                                     <<04571>>06760000
<<9: continue >>                                               <<01310>>06765000
      go loop;  << if a continuation line is needed, >>        <<01310>>06770000
                << it will be added elsewhere.       >>        <<01310>>06775000
                                                                        06780000
   end; << case >>                                                      06785000
end; << lookforhelp >>                                                  06790000
                                                                        06795000
                                                                        06800000
<< main body >>                                                         06805000
                                                                        06810000
<< open list file >>                                                    06815000
move buff := "LIST ";                                                   06820000
listfn := fopen(buff,%14,1,-132);                                       06825000
if <> then                                                              06830000
begin                                                                   06835000
   err(listfnx);                                                        06840000
   cclretn;                                                             06845000
end;                                                                    06850000
                                                                        06855000
<< set up >>                                                            06860000
subsetonly := starthelp := false;                              <<04571>>06865000
subset := stophelp := stophelpending := stuffkey := false;              06870000
condcode := cce;                                                        06875000
recno := msgno := msgno'old := maxsetno := setno:=0;                    06880000
helpsetno := 0;                                                         06885000
dirx := 2;                                                              06890000
                                                                        06895000
loop:                                                                   06900000
   len := fread(infn,buff',-hrecsizeb);                                 06905000
   if < then                                                            06910000
   begin                                                                06915000
      err(infnx);                                                       06920000
      cclretn;                                                          06925000
   end;                                                                 06930000
   if > then finishup; << finish & get out >>                           06935000
                                                                        06940000
   if buff = "\" then lookforhelp;                                      06945000
        << regular records with no "\" are just read in >>     <<04570>>06950000
        << and written back out to the new help catalog.>>     <<04570>>06955000
                                                               <<04570>>06960000
   writecatalog;                                                        06965000
                                                                        06970000
   << everything done >>                                                06975000
   go loop;                                                             06980000
                                                                        06985000
outl:                                                                   06990000
end;  << scanhelpcat >>                                        <<01310>>06995000
$title "QUIT"                                                           07000000
procedure quit(num);                                                    07005000
   value num;integer num;                                               07010000
begin                                                                   07015000
   setjcw(getjcw lor %100000);  << fatal error >>              <<04571>>07020000
   terminate;                                                           07025000
end; << quit >>                                                         07030000
$title "MAIN BODY"                                                      07035000
$control segment=priv                                                   07040000
                                                                        07045000
subroutine def'movetodseg;                                              07050000
                                                                        07055000
subroutine turnofftraps;                                       <<00812>>07060000
   begin                                                       <<00812>>07065000
   push(status);                                               <<00812>>07070000
   tos.(2:1) := 0;                                             <<00812>>07075000
   set(status);                                                <<00812>>07080000
   end;                                                        <<00812>>07085000
                                                               <<00812>>07090000
<< main body of program >>                                              07095000
                                                                        07100000
      <<                                                >>              07105000
      << main entry point:                              >>              07110000
      <<    -opens on "DISC".                           >>              07115000
      <<    -closes catalog as temporary                >>              07120000
      <<    -if oldtemp catalog, renames as catxxxx     >>              07125000
      <<                                                >>              07130000
      << build entry point:                             >>              07135000
      <<    - opens on "1", system disc.                >>              07140000
      <<    - closes catalog as permanent.              >>              07145000
      <<    - if old catalog, renames as catxxxx        >>              07150000
      <<                                                >>              07155000
      << dir entry point: just calls initmsg            >>              07160000
                                                                        07165000
main: install := false;                                                 07170000
      buildmode:=false;                                                 07175000
                                                                        07180000
build:                                                                  07185000
                                                                        07190000
turnofftraps;                                                  <<00812>>07195000
getusermode;                                                            07200000
if install then if not capabilityok then quit(insuffcaperr);            07205000
openin; << open input file >>                                           07210000
if <> then quit(openinerr);                                             07215000
opencat(install);                                                       07220000
if <> then quit(opencaterr);                                            07225000
scancat(directory);                                                     07230000
if = then << perfect msg cat, now put dir in dseg >>                    07235000
begin                                                                   07240000
   directory(currentrecell) :=directory(maxrecell)+1;                   07245000
   << set current ptr above limit for initialization>>                  07250000
                                                                        07255000
   dirfillin(directory); << fill in holes >>                            07260000
   fwritelabel(catfn,directory,msgdirsize);                             07265000
   << put directory in catalog >>                                       07270000
                                                                        07275000
   if <> then                                                           07280000
   begin                                                                07285000
      err(catfnx);                                                      07290000
      quit(writelabelerr);                                              07295000
   end;                                                                 07300000
   closecat(install);                                                   07305000
   if <> then quit(closecaterr);                                        07310000
   getprivmode;                                                         07315000
   if install then                                                      07320000
   begin                                                                07325000
dir:                                                                    07330000
      buildmode:=false;                                                 07335000
      turnofftraps;                                            <<00812>>07340000
   getprivmode;                                                <<14.eb>>07345000
      if not capabilityok then quit(insuffcaperr);                      07350000
      initmsg; << set up dataseg, sys db cells >>                       07355000
      if <> then quit(initmsgerr);                                      07360000
      move buff := "** NEW CATALOG INSTALLED",2;                        07365000
      print(buff',-(s0-@buff),0);del;                                   07370000
   end                                                                  07375000
   else                                                                 07380000
   begin                                                                07385000
      move buff := "** VALID MESSAGE CATALOG",2;                        07390000
      print(buff',-(s0-@buff),0);del;                                   07395000
   end;                                                                 07400000
end                                                                     07405000
else                                                                    07410000
begin                                                                   07415000
   getprivmode;                                                         07420000
   move buff := "** MESSAGE CATALOG CONTAINS ERROR",2;                  07425000
   print(buff',-(s0-@buff),0);del;                                      07430000
end;                                                                    07435000
                                                                        07440000
return;                                                                 07445000
                                                                        07450000
help:   << makehelp entry point >>                                      07455000
                                                                        07460000
turnofftraps;                                                  <<00812>>07465000
getusermode;                                                            07470000
if not makehelp then quit(makehelperr);                                 07475000
getprivmode;                                                            07480000
                                                                        07485000
end. << makecat >>                                                      07490000
