$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
