$CONTROL MAP,CODE,USLINIT                                               00010000
<< asoctabl - module as >>                                              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
$title "ASSOCIATE FILE BUILDER"                                         00055000
$control map,code,privileged                                            00060000
$control segment=main                                                   00065000
begin                                                                   00070000
comment                                                                 00075000
                                                                        00080000
   the format of the associate file is as follows:                      00085000
   it is a fixed-length binary file consisting of nine word records.    00090000
   record number 0 contains the next available record # in the 1st word 00095000
   with the rest of the record unused.                                  00100000
                                                                        00105000
   record numbers 1 thru 999 contain the first user who may associate   00110000
   devices 1 thru 999.  if no user may associate a device the first     00115000
   word of the record is zero, otherwise, the record is formatted as    00120000
   follows:                                                             00125000
      the first four words contain the username in ascii or "@       "  00130000
      if it is wildcarded.                                              00135000
      the next four words contain the account name in ascii or          00140000
      "@       " if wildcarded.                                         00145000
      the next four words contain the class name in ascii.              00150000
      the last word contains the record # of the next record for this   00155000
      device or zero if no more records.                                00160000
;                                                                       00165000
$page "DATA STORAGE"                                                    00170000
                                                               <<01041>>00175000
entry list;  <<entry point to list asociate.pub.sys>>          <<01041>>00180000
                                                               <<01041>>00185000
equate ent'len=13; <<length of entries in asociate.pub.sys>>            00190000
                                                               <<02327>>00195000
                                                               <<02327>>00200000
define                                                         <<02327>>00205000
ptitle = ("ASOCTBL5          (C) HEWLETT PACKARD CO., 1979")#; <<07369>>00210000
equate vuuff'col = 9; << index into ptitle >>                  <<04633>>00215000
define turnofftraps =                                          <<04634>>00220000
       begin                                                   <<04634>>00225000
       push(status);                                           <<04634>>00230000
       tos.(2:1):=0;                                           <<04634>>00235000
       set(status);                                            <<04634>>00240000
       end #;                                                  <<04634>>00245000
                                                               <<02327>>00250000
integer numchar;                                               <<02327>>00255000
$include inclvuf                                               <<04633>>00260000
integer array dupfilename(0:13);                                        00265000
integer s0=s-0;                                                         00270000
equate carriage'return=13;                                              00275000
define specialbit=(10:1)#, delimiter=(11:5)#;                           00280000
double dl:=[8/"=",8/".",8/",",8/carriage'return]d;                      00285000
byte array dl'(*)=dl;                                                   00290000
byte array                                                     <<07369>>00295000
   bufout (0:40);                                              <<07369>>00300000
array wbufout (*) = bufout;                                    <<07369>>00305000
double array parms(0:35);                                               00310000
byte pointer current'parm; <<pointer to current parameter>>             00315000
integer current'length; <<length of current parameter>>                 00320000
integer current'delimiter; <<delimiter of current parameter>>           00325000
integer len;    << length of version message >>                <<07369>>00330000
logical special'char; <<true if current parameter had special chars>>   00335000
integer i,length,parmno; <<current parameter number>>                   00340000
integer numparms,inputfile:=0,outputfile:=0;                            00345000
equate equals=0, period=1, comma=2, cr=3; <<delimiter #'s>>             00350000
integer array l'input(0:39); <<input buffer>>                           00355000
byte array input(*)=l'input;                                            00360000
integer array assoc'entry(0:ent'len-1)=db; <<associate entry>>          00365000
byte array assoc'username(*)=assoc'entry(0);                            00370000
byte array assoc'acctname(*)=assoc'entry(4);                            00375000
byte array assoc'class(*)=assoc'entry(8);                               00380000
integer assoc'nextp=assoc'entry+12;                                     00385000
byte array infilename(0:16),outfilename(0:15);                 <<*8725>>00390000
equate assmsgset=21; <<genmsg message set for sasstbl>>                 00395000
equate duplicatefile=100; <<error # for duplicate file>>                00400000
logical stdin; <<true if input file is $stdin>>                         00405000
logical error:=false; <<true is any syntax errors in input>>            00410000
$include inclldt5                                              <<06219>>00415000
integer array classinfo(0:4); <<buffer for getclass>>          <<06219>>00420000
integer                                                        <<06219>>00425000
   x = x,                                                      <<06219>>00430000
   entrylength;  << length of dct entry >>                     <<06219>>00435000
$include incldct                                               <<06987>>00440000
logical pointer                                                <<06219>>00445000
   dct;  << space for array is built on stack >>               <<06219>>00450000
integer pointer                                                <<06987>>00455000
   dct'i;                                                      <<06987>>00460000
integer array classname(0:3); <<classname buffer>>                      00465000
define                                                         <<06219>>00470000
   def'movefromdseg=                                           <<06219>>00475000
   movefromdseg(target,dstn,offset,count);                     <<06219>>00480000
   value target,dstn,offset,count;                             <<06219>>00485000
   logical target,dstn,offset,count;                           <<06219>>00490000
   begin                                                       <<06219>>00495000
      x := tos;                                                <<06219>>00500000
      assemble (mfds 0);                                       <<06219>>00505000
      tos := x;   << restore return address>>                  <<06219>>00510000
   end#;                                                       <<06219>>00515000
byte array classname'(*)=classname;                                     00520000
integer array prompt(0:1);                                              00525000
byte array output'buf(0:79);                                   <<02327>>00530000
logical array output'buf'(*) = output'buf;                     <<02327>>00535000
                                                                        00540000
logical procedure getclass(a,b,c,d,e);                                  00545000
value b,c,d;                                                            00550000
integer array a,e;                                                      00555000
logical b;                                                              00560000
integer c,d;                                                            00565000
option external,variable;                                               00570000
                                                                        00575000
integer procedure genmsg(a,b,c,d,e,f,g,h,i,j,k,l,m);                    00580000
value a,b,c,d,e,f,g,h,i,j,k,l,m;                                        00585000
integer a,b,i,l;                                                        00590000
logical c,d,e,f,g,h,j,k,m;                                              00595000
option privileged,variable,external;                                    00600000
                                                                        00605000
intrinsic fgetinfo,printfileinfo,frelate,print,fopen,fclose,mycommand;  00610000
intrinsic fwritedir,freaddir,fcheck,ferrmsg,binary,fread,terminate;     00615000
intrinsic fupdate, loadproc;                                   <<07440>>00620000
$page "FILEERR -- REPORT FILE ERRORS & TERMINATE"                       00625000
procedure fileerr(filenumber);                                          00630000
value filenumber;                                                       00635000
integer filenumber;                                                     00640000
begin                                                                   00645000
   integer filelength:=0,errnum,msglgth;                                00650000
   array msgbuf(0:49);                                                  00655000
   byte array msgbuf'(*)=msgbuf;                                        00660000
                                                                        00665000
   fcheck(filenumber,errnum); <<get error #>>                           00670000
   if filenumber<> 0 then                                               00675000
   begin                                                                00680000
      fgetinfo(filenumber,msgbuf');<<get file name>>                    00685000
      scan msgbuf' until "  ",1;<<calculate file name length>>          00690000
      filelength:=tos-@msgbuf'+1;                                       00695000
      msgbuf'(filelength-1):="-";                                       00700000
      printfileinfo(filenumber);<<print tombstone>>                     00705000
   end;                                                                 00710000
   ferrmsg(errnum,msgbuf((filelength+1)&asr(1)),msglgth);               00715000
   print(msgbuf,-msglgth-filelength,0);                                 00720000
   if outputfile<>0 then fclose(outputfile,4,0); <<delete output file>> 00725000
   if inputfile<>0 then fclose(inputfile,0,0);                          00730000
   terminate;                                                           00735000
end;                                                                    00740000
$page "LISTASS -- LIST ASOCIATE.PUB.SYS"                       <<01041>>00745000
procedure listass;                                             <<01041>>00750000
begin                                                          <<01041>>00755000
   integer no'of'classes:=0, no'of'users:=1, i;                <<01041>>00760000
   byte pointer bps0=s-0;                                      <<01041>>00765000
   logical eol,eof,found;                                      <<01041>>00770000
   double recno;                                               <<01041>>00775000
   equate max'no'of'classes=50, classes'users=4, classes'name=0,        00780000
          classes'length=5, classes'name'l=4;                  <<01041>>00785000
   array classes(0:max'no'of'classes*classes'length-1);        <<01041>>00790000
   byte array classes'(*)=classes;                             <<01041>>00795000
   equate users'username=0, users'acctname=4, users'next=8,    <<01041>>00800000
          users'length=9;                                      <<01041>>00805000
   array users(0:users'length-1);                              <<01041>>00810000
   byte array users'(*)=users, user'(0:8), acct'(0:8);         <<01041>>00815000
                                                               <<01041>>00820000
                                                               <<01041>>00825000
   move infilename:="ASOCIATE.PUB.SYS ";                       <<01041>>00830000
   inputfile:=fopen(infilename,%2001,0);                       <<01041>>00835000
   if <> then <<unable to list asociate.pub.sys>>              <<01041>>00840000
   begin                                                       <<01041>>00845000
      genmsg(assmsgset,20); <<no association table>>           <<01041>>00850000
      fclose(inputfile,0,0);                                   <<01041>>00855000
      terminate;                                               <<01041>>00860000
   end;                                                        <<01041>>00865000
                                                               <<01041>>00870000
   freaddir(inputfile,assoc'entry,ent'len,0d);                 <<01041>>00875000
   if <> then fileerr(inputfile);                              <<01041>>00880000
   outputfile:=fopen(,%2000,5,users'length,,,,,,double(assoc'entry));   00885000
   if <> then fileerr(outputfile);                             <<01041>>00890000
$page                                                          <<01041>>00895000
<< now ready to build device class name table by doing a scan of>>      00900000
<< asociate.pub.sys                                             >>      00905000
                                                               <<01041>>00910000
   eof:=false;                                                 <<01041>>00915000
   recno:=0d;                                                  <<01041>>00920000
   do                                                          <<01041>>00925000
   begin                                                       <<01041>>00930000
      recno:=recno+1d;                                         <<01041>>00935000
      freaddir(inputfile,assoc'entry,ent'len,recno);           <<01041>>00940000
      if <> then eof:=true                                     <<01041>>00945000
      else                                                     <<01041>>00950000
      if assoc'entry<>0 then <<have a valid entry>>            <<01041>>00955000
      begin                                                    <<01041>>00960000
         found:=false;                                         <<01041>>00965000
         i:=no'of'classes;                                     <<01041>>00970000
         while not found and (i:=i-1)>=0 do                    <<01041>>00975000
            if assoc'class=classes'(i*classes'length*2),       <<01041>>00980000
               (classes'name'l*2) then found:=true;            <<01041>>00985000
         if not found then <<add class to class table>>        <<01041>>00990000
         begin                                                 <<01041>>00995000
            move classes'(no'of'classes*classes'length*2):=    <<01041>>01000000
               assoc'class,(classes'name'l*2);                 <<01041>>01005000
            classes(no'of'classes*classes'length+classes'users):=       01010000
               no'of'users;                                    <<01041>>01015000
            i:=no'of'classes-1;                                <<01041>>01020000
            no'of'classes:=no'of'classes+1;                    <<01041>>01025000
            go to adduser;                                     <<01041>>01030000
         end                                                   <<01041>>01035000
         else <<entry is found for class>>                     <<01041>>01040000
         begin <<scan to see if user exists for this class>>   <<01041>>01045000
            freaddir(outputfile,users,users'length,            <<01041>>01050000
                     double(classes(i*classes'length+classes'users)));  01055000
            eol:=found:=false;                                 <<01041>>01060000
            do                                                 <<01041>>01065000
            if users'(users'username*2)=assoc'username,(8) and <<01041>>01070000
               users'(users'acctname*2)=assoc'acctname,(8) then<<01041>>01075000
               found:=true                                     <<01041>>01080000
            else                                               <<01041>>01085000
            if users(users'next)<>0 then                       <<01041>>01090000
               freaddir(outputfile,users,users'length,         <<01041>>01095000
                  double(users(users'next)))                   <<01041>>01100000
            else eol:=true                                     <<01041>>01105000
            until eol or found;                                <<01041>>01110000
            if eol then                                        <<01041>>01115000
            begin                                              <<01041>>01120000
               users(users'next):=no'of'users;                 <<01041>>01125000
               fupdate(outputfile,users,users'length);         <<01041>>01130000
adduser:                                                       <<01041>>01135000
               move users'(users'username*2):=assoc'username,(8);       01140000
               move users'(users'acctname*2):=assoc'acctname,(8);       01145000
               users(users'next):=0;                           <<01041>>01150000
               fwritedir(outputfile,users,users'length,        <<01041>>01155000
                  double(no'of'users));                        <<01041>>01160000
               no'of'users:=no'of'users+1;                     <<01041>>01165000
            end;                                               <<01041>>01170000
         end;                                                  <<01041>>01175000
      end;                                                     <<01041>>01180000
   end                                                         <<01041>>01185000
   until eof;                                                  <<01041>>01190000
$page                                                          <<01041>>01195000
                                                               <<01041>>01200000
<< have built temp file... now list on $stdlist>>              <<01041>>01205000
                                                               <<01041>>01210000
   i:=-1;                                                      <<01041>>01215000
   while (i:=i+1)<no'of'classes do                             <<01041>>01220000
   begin                                                       <<01041>>01225000
      recno:=double(classes(i*classes'length+classes'users));  <<01041>>01230000
      scan classes'(i*classes'length*2+classes'name*2)         <<01041>>01235000
         until [8/0,8/" "],1;                                  <<01041>>01240000
      bps0:=0;                                                 <<01041>>01245000
      do                                                       <<01041>>01250000
      begin                                                    <<01041>>01255000
         freaddir(outputfile,users,users'length,recno);        <<01041>>01260000
         if users'(users'username*2)<>"@" then                 <<01041>>01265000
         begin                                                 <<01041>>01270000
            move user':=users'(users'username*2) while an,1;   <<01041>>01275000
            bps0:=0;                                           <<01041>>01280000
            del;                                               <<01041>>01285000
         end                                                   <<01041>>01290000
         else move user':=("@",0);                             <<01041>>01295000
         if users'(users'acctname*2)<>"@" then                 <<01041>>01300000
         begin                                                 <<01041>>01305000
            move acct':=users'(users'acctname*2) while an,1;   <<01041>>01310000
            bps0:=0;                                           <<01041>>01315000
            del;                                               <<01041>>01320000
         end                                                   <<01041>>01325000
         else move acct':=("@",0);                             <<01041>>01330000
         genmsg(assmsgset,22,0,                                <<01041>>01335000
                @classes'(i*classes'length*2),@user',@acct');  <<01041>>01340000
         recno:=double(users(users'next));                     <<01041>>01345000
      end                                                      <<01041>>01350000
      until recno=0d;                                          <<01041>>01355000
   end;                                                        <<01041>>01360000
   return;                                                     <<01041>>01365000
end;                                                           <<01041>>01370000
$page "INSERT -- INSERT ASSOCIATE RECORDS INTO ASSOCIATE FILE"          01375000
procedure insert(devices,associate);                                    01380000
integer array devices;                                         <<06987>>01385000
integer array associate;                                                01390000
begin                                                                   01395000
   integer array oldass(0:ent'len-1),zeroent(0:ent'len-1);              01400000
   integer i:=0;                                                        01405000
                                                                        01410000
   while (i:=i+1)<= devices do <<add entry for each dev given>><<06987>>01415000
   begin                                                                01420000
      freaddir(outputfile,oldass,ent'len,double(devices(i)));  <<06987>>01425000
      if <> then fileerr(outputfile);                                   01430000
      if oldass=0 then <<no records for this device yet>>               01435000
      begin                                                             01440000
         associate(12):=0; <<set end of record chain>>                  01445000
         fwritedir(outputfile,associate,ent'len,               <<06987>>01450000
                   double(devices(i)));                        <<06987>>01455000
         if <> then fileerr(outputfile);                                01460000
      end                                                               01465000
      else <<records exist, chain new in front of old records>>         01470000
      begin                                                             01475000
         freaddir(outputfile,zeroent,ent'len,0d);<<allocate new record>>01480000
         if <> then fileerr(outputfile);                                01485000
         fwritedir(outputfile,oldass,ent'len,double(zeroent));          01490000
         if <> then fileerr(outputfile);                                01495000
         associate(12):=zeroent; <<point to old head of chain>>         01500000
         fwritedir(outputfile,associate,ent'len,               <<06987>>01505000
                    double(devices(i)));                       <<06987>>01510000
         if <> then fileerr(outputfile);                                01515000
         zeroent:=zeroent+1;                                            01520000
         fwritedir(outputfile,zeroent,ent'len,0d); <<upd next av. rec.>>01525000
         if <> then fileerr(outputfile);                                01530000
      end;                                                              01535000
   end;                                                                 01540000
end;                                                                    01545000
$page "PRINTCARET -- PRINT '>' UNDER ERROR"                             01550000
procedure printcaret(bp);                                               01555000
value bp;                                                               01560000
byte pointer bp;                                                        01565000
begin                                                                   01570000
   integer i;                                                           01575000
   array buffer'(0:35);                                                 01580000
   byte array buffer(*)=buffer';                                        01585000
                                                                        01590000
   buffer':="  ";  <<blank fill>>                                       01595000
   move buffer'(1):=buffer',(35);                                       01600000
   i:=@bp-@input+(if stdin then 1 else 0);                              01605000
   buffer(i):="^";                                                      01610000
   print (buffer',-i-1,0);                                              01615000
end;                                                                    01620000
$page "*** OUTER BLOCK ***"                                             01625000
logical subroutine verifyname;                                          01630000
begin                                                                   01635000
   comment                                                              01640000
      verifies that the name pointer to by current'parm is valid        01645000
      account or user name.                                             01650000
   ;                                                                    01655000
   if not (1<=current'length<=8) or                                     01660000
      special'char and (current'length>1 or current'parm<>"@") or       01665000
      not special'char and current'parm<>alpha then                     01670000
   begin                                                                01675000
      error:=true;                                                      01680000
      printcaret(current'parm);                                         01685000
      genmsg(assmsgset,10);                                             01690000
   verifyname:=false;                                                   01695000
   end else verifyname:=true;                                           01700000
end;                                                                    01705000
                                                                        01710000
subroutine getnextparm;                                                 01715000
begin                                                                   01720000
   comment                                                              01725000
      sets up the description of the next parameter in                  01730000
      current'parm, current'length, current'delimiter & special'char.   01735000
   ;                                                                    01740000
   if parmno>=numparms then return;                                     01745000
   tos:=parms(parmno);                                                  01750000
   parmno:=parmno+1;                                                    01755000
   current'delimiter:=s0.delimiter;                                     01760000
   special'char:=s0.specialbit=1;                                       01765000
   current'length:=tos&lsr(8);                                          01770000
   @current'parm:=tos;                                                  01775000
end;                                                                    01780000
subroutine def'movefromdseg;                                   <<06219>>01785000
$page                                                                   01790000
subroutine heading;                                            <<04633>>01795000
<< prints the heading >>                                       <<04633>>01800000
begin                                                          <<04633>>01805000
move output'buf := ptitle,2;                                   <<02327>>01810000
<< get # chars. by subtracting the address of output'buf(0)>>  <<02327>>01815000
<<from the offset  determined by move, found on tos         >> <<02327>>01820000
numchar := tos-@output'buf;                                    <<02327>>01825000
move output'buf(vuuff'col ):=official'vuuff;                   <<04633>>01830000
print(output'buf',-numchar,%60); <<print header, doube space >><<02327>>01835000
end; << heading >>                                             <<04633>>01840000
heading;                                                       <<04633>>01845000
<<  make sure that this version is not running on an mpeiv>>   <<07369>>01850000
<<  system.  if it is kill it.                            >>   <<07369>>01855000
move bufout := "MPE ";  << the procedure mpe >>                <<07440>>01860000
loadproc( bufout, 0, len );  << search system sl, len=label>>  <<07440>>01865000
if =                                                           <<07440>>01870000
then begin                                                     <<07440>>01875000
  tos := 0;   << this will be the return value >>              <<07440>>01880000
  tos := len;                                                  <<07440>>01885000
  assemble( pcal 0 );  << call "MPE" >>                        <<07440>>01890000
  if tos = 5 then goto mpev;                                   <<07440>>01895000
end;                                                           <<07440>>01900000
                                                               <<07440>>01905000
len := move bufout :=                                          <<07440>>01910000
    "This version will work only on MPEV-E";                   <<*8725>>01915000
print (wbufout,-len,0);                                        <<07440>>01920000
terminate;                                                     <<07440>>01925000
mpev:  << we only get here if running on an mpe-v system >>    <<07440>>01930000
                                                               <<07440>>01935000
turnofftraps;                                                  <<04634>>01940000
prompt:="> ";                                                           01945000
move infilename:="INPUT ";                                              01950000
inputfile:=fopen(infilename,%47,,-80); <<open input file>>     <<01008>>01955000
if <> then                                                              01960000
begin                                                                   01965000
   genmsg(assmsgset,4);                                                 01970000
   fileerr(0);                                                          01975000
end;                                                                    01980000
i:=frelate(inputfile,2); <<is input file duplicative with $stdlist>>    01985000
stdin:=if i<0 then true else false;                                     01990000
                                                                        01995000
move outfilename:="ASOCIATE.PUB.SYS ";                                  02000000
<< open asociate.pub.sys exclusive, input/output access>>      <<*8725>>02005000
outputfile:=fopen(outfilename,0,%104,ent'len,,,,,,2048d);      <<*8725>>02010000
if <> then                                                              02015000
begin                                                                   02020000
   genmsg(assmsgset,8);                                                 02025000
   fileerr(0);                                                          02030000
end;                                                                    02035000
                                                                        02040000
for i:=1 until ent'len-1  do assoc'entry(i):=0; <<init. associate file>>02045000
<< write out 1000 to record 0 of asociate.pub.sys >>           <<*8725>>02050000
assoc'entry:=1000; <<next avail. rec for overflow entries >>   <<*8725>>02055000
fwritedir(outputfile,assoc'entry,ent'len,0d);                           02060000
if <> then fileerr(outputfile);                                         02065000
assoc'entry:=0;                                                         02070000
<< initialize the asociate.pub.sys file to all zeros >>        <<*8211>>02075000
for i:=1 until 999 do                                          <<*8211>>02080000
begin                                                                   02085000
   fwritedir(outputfile,assoc'entry,ent'len,double(i));                 02090000
   if <> then fileerr(outputfile);                                      02095000
end;                                                                    02100000
                                                                        02105000
error:=false;                                                           02110000
                                                                        02115000
readloop:                                                               02120000
                                                                        02125000
if stdin then print(prompt,-1,%320);                                    02130000
length:=fread(inputfile,l'input,-72);                                   02135000
if < then fileerr(inputfile)                                            02140000
else if > then <<end of file>>                                          02145000
begin                                                                   02150000
eof:                                                                    02155000
   fclose(inputfile,0,0); <<finished processing input>>                 02160000
   fclose(outputfile,if error then 4 else 1, 0); <<save new file, if o>>02165000
   if <> then <<might be duplicate file>>                               02170000
   begin                                                                02175000
      fcheck(outputfile,i); <<get error reason>>                        02180000
      if i=duplicatefile then <<delete old file, then save new file>>   02185000
      begin                                                             02190000
         fgetinfo(outputfile,dupfilename); <<get name of output file>>  02195000
         if <> then fileerr(outputfile);                                02200000
         i:=fopen(dupfilename,%2001,%300);<<share,no file equation>>    02205000
         if <> then                                                     02210000
         begin <<couldn't delete old associate file>>                   02215000
            genmsg(assmsgset,1);                                        02220000
            fileerr(0);                                                 02225000
         end;                                                           02230000
         fclose(i,4,0); <<delete old associate file>>                   02235000
         if <> then                                                     02240000
         begin <<couldn't do close to delete associate file>>           02245000
            genmsg(assmsgset,1);                                        02250000
            fileerr(i);                                                 02255000
         end;                                                           02260000
         fclose(outputfile,1,0); <<save new associate file>>            02265000
         if <> then fileerr(outputfile);                                02270000
      end else fileerr(outputfile);                                     02275000
   end;                                                                 02280000
   terminate;                                                           02285000
end                                                                     02290000
else <<got a record in>>                                                02295000
begin                                                                   02300000
   if not stdin then print(l'input,-length,0);                          02305000
   if length=0 or input="$" then go to readloop; <<comment found>>      02310000
   if length=4 and (input="EXIT" or input="exit") then go to eof;       02315000
   input(length):=carriage'return;                                      02320000
   mycommand(input,dl',35,numparms,parms); <<parse input line>>         02325000
                                                                        02330000
   if numparms<3 then <<must have at least ldev=user.acct>>             02335000
   begin                                                                02340000
      error:=true;                                                      02345000
      genmsg(assmsgset,2);                                              02350000
      go to readloop;                                                   02355000
   end;                                                                 02360000
   parmno:=0;                                                           02365000
   getnextparm; <<get device # or device class name>>                   02370000
   if current'delimiter<>equals then <<must have = following device>>   02375000
   begin                                                                02380000
      error:=true;                                                      02385000
      genmsg(assmsgset,3);                                              02390000
      go to readloop;                                                   02395000
   end;                                                                 02400000
   if current'length>8 then <<bad classname>>                           02405000
   begin                                                                02410000
      error:=true;                                                      02415000
      genmsg(assmsgset,5);                                              02420000
      go to readloop;                                                   02425000
   end;                                                                 02430000
   move classname:="        ";                                          02435000
   move classname':=current'parm,(current'length);                      02440000
   if not getclass(classinfo,false,,,classname) then <<no such <<06219>>02445000
<< getclass returns the following to classinfo            >>   <<06219>>02450000
<< returnbuf - 0: segment relative address of entry       >>   <<06219>>02455000
<<             1: dct index of entry  (entry #)           >>   <<06219>>02460000
<<             2: word 4 (5th word) of dct entry. contains>>   <<06219>>02465000
<<                cyclical ptr., class access type, sq bit>>   <<06219>>02470000
<<             3: mpe4: left bye is # of ldev's in class, >>   <<06219>>02475000
<<                right byte is first ldev                >>   <<06219>>02480000
<<                mpe5: # of ldev's in class              >>   <<06219>>02485000
<<             4: mpe4: see below                         >>   <<06219>>02490000
<<                mpe5: first ldev in class.              >>   <<06219>>02495000
<<             4+ (mpe4) or 5+ (mpe5): returned on if     >>   <<06219>>02500000
<<                everything true. remaining ldev's in cls>>   <<06219>>02505000
<<********************************************************>>   <<06219>>02510000
                                                               <<06219>>02515000
   begin                                                                02520000
      error:=true;                                                      02525000
      genmsg(assmsgset,6);                                              02530000
      go to readloop;                                                   02535000
   end;                                                                 02540000
                                                               <<06219>>02545000
  comment -- we need to access the list of ldev's in the dct   <<06219>>02550000
  entry.  unfortunately, the length of the lst is arbitrary    <<06219>>02555000
  and varies from entry to entry.  this, to make a local copy  <<06219>>02560000
  of the entry, we must buld space for it on the stack.        <<06219>>02565000
  ;  << end comment >>                                         <<06219>>02570000
                                                               <<06219>>02575000
  <<============ expand the stack here  ==================>>   <<06219>>02580000
   push (s);                                                   <<06219>>02585000
   @dct := tos +1;                                             <<06219>>02590000
   assemble (adds 6); << get first 6 words to get length >>    <<06219>>02595000
   movefromdseg(@dct,dct'dst,classinfo,6);                     <<06987>>02600000
   entrylength := dct'words'in'entry;                          <<06219>>02605000
   assemble(subs 6); << got length, get whole entry >>         <<06219>>02610000
   tos := entrylength;                                         <<06219>>02615000
   assemble(adds 0); << hope stack is big enough >>            <<06219>>02620000
   movefromdseg(@dct,dct'dst,classinfo,entrylength);           <<06987>>02625000
   @dct'i := @dct + dct'first'ldev -1 ; << # of devices >>     <<06987>>02630000
                                                               <<06219>>02635000
                                                                        02640000
<< have device class entry, now parse user.acct >>             <<06219>>02645000
                                                                        02650000
   move assoc'class:=classname',(8);                                    02655000
   while parmno<numparms do                                             02660000
   begin                                                                02665000
      getnextparm;                                                      02670000
      if not verifyname then go to readloop; <<bad username>>           02675000
      if current'delimiter<>period then <<expected "." after username>> 02680000
      begin                                                             02685000
         error:=true;                                                   02690000
         printcaret(current'parm(current'length));                      02695000
         genmsg(assmsgset,7);                                           02700000
         go to readloop;                                                02705000
      end;                                                              02710000
      move assoc'username:="        ";                                  02715000
      move assoc'username:=current'parm,(current'length);               02720000
                                                                        02725000
      getnextparm;                                                      02730000
      if not verifyname then go to readloop; <<invalid acct name>>      02735000
      if current'delimiter<>comma and current'delimiter<>cr then        02740000
      begin                                                             02745000
         error:=true;                                                   02750000
         printcaret(current'parm(current'length));                      02755000
         genmsg(assmsgset,9);                                           02760000
         go to readloop;                                                02765000
      end;                                                              02770000
      move assoc'acctname:="        ";                                  02775000
      move assoc'acctname:=current'parm,(current'length);               02780000
                                                                        02785000
      insert(dct'i,assoc'entry);                               <<06987>>02790000
   end;                                                                 02795000
end;                                                                    02800000
go to readloop;                                                         02805000
                                                               <<01041>>02810000
<< list asociate.pub.sys entry point>>                         <<01041>>02815000
list:                                                          <<01041>>02820000
   heading;                                                    <<04633>>02825000
   turnofftraps;                                               <<04634>>02830000
   listass;                                                    <<01041>>02835000
   terminate;                                                  <<01041>>02840000
                                                               <<01041>>02845000
end.                                                                    02850000
