.
.
.         T H E   M A D   P A C K E R
.
.                                       JOHN WALKER   FEBRUARY 1975
.
.         THIS PROGRAM, WHICH IS A SEPARATE MAIN PROGRAM WHICH USES
.         VARIOUS UTILITY ROUTINES WITHIN FANG, WILL PACK ALL FILES
.         BELONGING TO A USER OR ALL FILES IN THE SYSTEM IF RUN IN
.         PRIVILEGED MODE.  THIS IS A COMPLETELY SAFE PACK:  ONLY
.         FILES WHICH HAVE VALID SECURE BACKUPS WILL BE PACKED, AND
.         THE FILES WILL BE MARKED UNLOADED WHILE THE PACK IS IN
.         PROGRESS SO THAT AN ERROR OR SYSTEM CRASH WILL ONLY RESULT
.         IN THE FILE BEING ROLLED BACK FROM THE CURRENT BACKUP WHEN
.         NEXT ASSIGNED.  THE ONLY PRECAUTION IN USING THIS PROGRAM
.         IS REGARDING 'START RUNS'.  IF A RUN IS STARTED FROM AN
.         ELEMENT IN A PROGRAM FILE, THE FILE MUST NOT BE PACKED
.         BEFORE THE START RUN RUNS, SINCE THE SYSTEM ONLY REMEMBERS
.         THE ADDRESS OF THE ELEMENT TEXT, AND A PACK, WHICH WOULD
.         MOVE THE ELEMENT, WOULD CAUSE THE SYSTEM TO ERROR THE
.         START RUN UPON NOT FINDING A PROPER ELEMENT IN THE FILE.
.         THEREFORE, THE PRIVILEGED PACK OF ALL SYSTEM FILES SHOULD
.         ONLY BE DONE IN A SYSTEM WITH NO BACKLOG.  IN PACKING THE
.         FILES, CARE IS TAKEN NOT TO SET THE 'CHANGED' FLAG, WHICH
.         CAUSES THE FILE TO BE DUMPED ON THE NEXT SECURE SAVE, AS
.         TO DO SO WOULD CAUSE ALL PACKED FILES TO BE DUMPED ON THE
.         NEXT SAVE, WHICH COULD BE CATASTROPHIC.
.
.         THE MAD PACKER IS INVOKED WITH THE CONTROL STATEMENT:
.
.                   @PACKER,<OPTIONS>
.
.         FOR EITHER THE PRIVILEGED OR NONPRIVILEGED FORM.  NOTE THAT
.         FOR A PRIVILEGED PACK TO BE DONE, THE RUN MUST BE PRIVILEGED
.         AND THE 'Q' OPTION MUST BE SPECIFIED ON THE @PACKER STATEMENT.
.         THIS PREVENTS AN UNINTENDED PRIVILEGED PACK BY A PRIVILEGED
.         USER.
.
.
.         OPTIONS:
.
.         L         LIST FILES NOT PROCESSED AND WHY
.         N         SUPPRESS LISTING OF PACKED FILES
.         Q         FUNCTION IN PRIVILEGE MODE (PACK ALL FILES)
.         T         DON'T ACTUALLY PACK FILES
.         W         KEEP DIRECTORY FILE AROUND AT END OF
.                   EXECUTION.  USE EXISTING FILE IS PRESENT.
.                   (THIS REDUCES THE DGET$ OVERHEAD).
.
.
          AXR$
          DEFUNCT$
          FANG
          LIT$      2
$(1).
.
.
.         OBTAIN THE SYSTEM DIRECTORY VIA DGET$
.
BEGIN     F$MSG     PACKH               EDIT PACKER SIGN-ON LINE
          F$DAY1    R2                  EDIT CURRENT DATE
          F$SKIP    -3                  BACK UP OVER YEAR
          F$CHAR    '-'                 EDIT A DASH
          F$TIME    R2                  EDIT THE TIME OF DAY
          F$SKIP    -3                  BACK UP OVER SECONDS
          F$FD3     ('   ')             OVERLAY SECONDS WITH SPACES
          F$PRT     1                   PRINT SIGN ON LINE
          TNE,U     A4,4                IS CALLER DEMAND ?
          J         DMCLBG              YES.  DON'T SKIP AFTER SIGN-ON
          PRINT$    0,,1                NO.  SKIP AFTER SIGN ON LINE
DMCLBG    IALL$     CGY,BIT(9)          TURN ON CONTINGENCY
          FORK      START               START WITH NAMED ACTIVITY
          EXIT$     .                   TERMINATE THE INITIAL ACTIVITY
.
START     BGET      1792*2              ALLOCATE TRACK BUFFERS FOR DGET$
          LR        R15,('      ')      LOAD SPACES FOR STORE NON ZERO
          SA        A5,OPTIONS          SAVE OPTION BITS
          LA,U      A1,1                LOAD A ONE
          TOP,U     A5,OPTION('L')      FULL LISTING DESIRED ?
          SZ        LONGLIST            NO.  CLEAR LONG LISTING FLAG
          LXI,U     A0,1792,A0          LOAD SECOND BUFFER ADDRESS
          SA        A0,DUMMYDG+4        SET BUFFER ADDRESSES IN PACKET
          SA        A0,DGET+4           ...AND IN REAL PACKET
          MSCON$    DUMMYDG             DO A DUMMY DGET$ TO FIND DIRECTORY SIZE
          TN        A0                  THIS DUMMY DGET SHOULD ERROR
          IERR      .                   OTHERWISE, WE IN A HEAP OF TROUBLE
          SSL       A0,18               ISOLATE STATUS CODE
          AND,U     A0,077              GET DGET$ STATUS IN A1
          TE,U      A1,033              IT IT 'INITIAL RESERVE TOO SMALL' ?
          IERR      .                   NO.  SOME OTHER ERROR
          F$MSG     ASGIMG              EDIT ASSIGN IMAGE FOR DGET$ FILE
          LA        A0,DUMMYDG+3        LOAD TRACKS REQUIRED FOR DIRECTORY
          SA        A0,DGET+3           SET IN CASE WE DON'T DO DGET
          AA,U      A0,40               ALLOW FOR OVERFLOW
          F$DECV    .                   EDIT TRACKS FOR INITIAL RESERVE
          F$MSGR    .                   COPY REST OF ASSIGN IMAGE
          CSF$      FL$                 EDIT ASSIGN OF DGET$ FILE
          TEP       A0,(BIT(33))        WAS FILE ALREADY ASSIGNED ?
          TOP,U     A5,OPTION('W')      YES.  WAS THE 'W' OPTION ON ?
          J         $+2                 NO.  DO THE DGET$
          J         DGALR               YES.  SKIP THE DGET$
          JN        A0,DGASGER          ERROR IF DGET$ FILE UNASSIGNABLE
          MSCON$    DGET                COPY THE FILE DIRECTORY
          JN        A0,DGETER           ERROR IF DGET$ IMPOSSIBLE
DGALR     BRELP     DGET+4,,H2          RELEASE THE TRACK BUFFERS
          F$DT      .                   CLEAR THE EDITING LINE
          PCT$,4    PRIVL               GET PRIVILEGE FLAG FOR THE RUN
          LA,S2     A0,PRIVL            LOAD ABORT/PRIVILEGE FLAGS
          AND,U     A0,040              ISOLATE DLOC$ FLAG
          LA        A5,OPTIONS          LOAD OPTION BITS
          TOP,U     A5,OPTION('Q')      IS PRIVILEGE REQUESTED ?
          LA,U      A1                  NO.  DON'T ATTEMPT PRIVILEGE
          SA        A1,PRIVL            SET UP PRIVILEGE RUN FLAG
          TZ        PRIVL               IS THE CALLER PRIVILEGED ?
          J         PRVSKPC             YES.  NO NEED TO GET PROJECT
          PCT$,5    PROJECT             GET 'AL' INDEX TO QUALIFIER TABLE
          LA,H1     A1,PROJECT          LOAD INDEX TO QUALIFIER TABLE
          AH        A1,(2,1)            SET TO READ RUN'S PROJECT
          LA,U      A0,PROJECT          LOAD ADDRESS OF BUFFER FOR PROJECT
          PCT$      .                   GET PROJECT FOR THE RUN
PRVSKPC   LA        A0,DGET+3           LOAD TRACKS IN DIRECTORY
          MSI,U     A0,ENTSIZ           COMPUTE BUFFER SPACE REQUIRED
          AA,U      A0,DTITML           ADD FIXED PORTION OF BUFFER LENGTH
          BGET      .                   ALLOCATE FDSUBS WORK BUFFER
          SA        A0,WKBUF            SAVE WORK BUFFER ADDRESS
          LA        A3,WKBUF            LOAD WORK BUFFER ADDRESS
          DL        A0,(LJSF$2 'DGET$') LOAD FILE NAME
          DS        A0,,A3              SET FILE NAME IN WORK BUFFER
          LMJ       X11,FDINIT          INITIALISE DIRECTORY READER
          JNZ       A0,INITER           ERROR IF CANNOT READ DIRECTORY
.
.
.         SCAN DIRECTORY FOR MAIN ITEMS
.
.         EACH MAIN ITEM IS VALIDATED TO DECIDE WHETHER IT IS WORTH
.         PROCESSING.
.
NEXTITEM  LA        A3,WKBUF            LOAD WORK BUFFER ADDRESS
          SZ        ATTEMPT             CLEAR PACK ATTEMPT MADE FLAG
          LMJ       X11,FDNDI           READ NEXT DIRECTORY ITEM
          TNE,U     A0,1                END OF DIRECTORY ?
          J         DIREND              YES.  ALL DONE
          JNZ       A0,NDIERR           ERROR IF STATUS NONZERO
          LA,S1     A0,,A2              LOAD DIRECTORY ITEM TYPE
          AND,U     A0,020              ISOLATE MAIN ITEM BIT
          TE,U      A1,020              IS THIS A MAIN ITEM ?
          J         NEXTITEM            NO.  IGNORE IT
          TZ        PRIVL               IS THE CALLER PRIVILEGED ?
          J         PVALLF              YES.  PERMIT SCAN OF ALL FILES
          DL        A0,PROJECT          LOAD PROJECT OF USER'S RUN
          DTE       A0,5,A2             SAME AS PROJECT OF FILE ?
          J         NEXTITEM            NO.  IGNORE THE FILE
PVALLF    LA        A0,TOTFIL           LOAD TOTAL FILE COUNT
          AA,U      A0,1                INCREMENT TOTAL FILE COUNT
          SA        A0,TOTFIL           UPDATE TOTAL FILE COUNT
.
.         DETERMINE WHETHER MAIN ITEM IS PROBABLY WORTH PACKING
.
          LMJ       X5,VALIDATE         CHECK MAIN ITEM FOR PACKABILITY
          J         NOPACK              NOT PACKABLE.  TELL USER WHY
.
.         BASED UPON THE MAIN ITEM, THIS FILE IS A CANDIDATE FOR PACKING.
.         NOW TRY TO ASSIGN THE FILE AND DETERMINE FOR SURE WHETHER TO
.         PACK THE FILE.
.
          F$MSG     FUSE                EDIT @USE IMAGE
          F$FD2     1,A2                EDIT QUALIFIER
          F$CHAR    '*'                 EDIT ASTERISK BEFORE FILE NAME
          F$FD2     3,A2                EDIT FILE NAME
          F$CHAR    '('                 EDIT LEFT PARENTHESIS
          F$DECV    17,A2,T3            EDIT ABSOLUTE F-CYCLE FOR FILE
          F$CHAR    ')'                 EDIT CLOSING PARENTHESIS
          CSF$      FL$                 ATTACH INTERNAL NAME TO FILE
          F$DT      .                   CLEAR THE IMAGE
          LA        A0,TOTASG           LOAD TOTAL FILES ASSIGNED
          AA,U      A0,1                INCREMENT FILES ASSIGNED
          SA        A0,TOTASG           UPDATE TOTAL ASSIGNS
          CSF$      FASG                TRY TO ASSIGN THE FILE
          JN        A0,FASGER           ERROR IF FILE UNASSIGNABLE
          LA,U      A1,1                LOAD A ONE
          TEP       A0,(BIT(33))        WAS FILE ALREADY ASSIGNED ?
          LA,U      A1                  YES.  FLAG SO IT WON'T BE FREE'D
          SA        A1,ASGFLAG          MARK FILE ASSIGNED TO PACKER
.
.         IF THE CALLER IS NOT PRIVILEGED, WE CANNOR PROCESS FILES WHICH
.         HAVE KEYS BECAUSE DGET$ WILL NOT GIVE US KEYS OF FILES EVEN
.         IF THEY ARE ON OUR OWN PROJECT.  IF THE 'KEY NOT PRESENT' BITS
.         ARE ON IN THE ASSIGN STATUS, WE MUST DECLINE TO PROCESS THE FILE.
.
          AND       A0,(BIT(24,25))     ISOLATE 'KEY NOT PRESENT' BITS
          TZ        PRIVL               IS THE CALLER PRIVILEGED ?
          J         PVKYSOK             YES.  KEYS ARE ALWAYS OK
          JNZ       A1,NOKEYS           NO.  DOES FILE HAVE KEYS ?
          TZ        ASGFLAG             WAS FILE ALREADY ASSIGNED TO RUN ?
          J         PVKYSOK             NO.  FACILITY STATUS BITS ARE VALID
          FITEM$    PFDT,9              YES.  GET ASSIGNMENT STATUS
          LA,S2     A0,PFDT+6           LOAD ASSIGNMENT STATUS BITS
          AND,U     A0,BIT(3,4)         ISOLATE KEYS NEEDED BITS
          JNZ       A1,NOKEYS           TAKE NO KEYS EXIT IF ASSIGNED
.                                       BY USER WITHOUT KEYS
.
.
.         NOW THAT WE HAVE THE FILE ASSIGNED, WE DO A DREAD AND RE-VALIDATE
.         THE MAIN ITEM RETURNED.  THIS PROTECTS US AGAINST THE STATUS OF
.         THE FILE HAVING CHANGED BETWEEN THE TIME WE DID THE DGET$ AND
.         THE TIME WE ASSIGNED THE FILE.
.
PVKYSOK   MSCON$    READMI              READ MAIN ITEM OF THE FILE
          JN        A0,NORDMI           ERROR IF WE CAN'T READ MAIN ITEM
          LA,U      A2,MI               LOAD DREAD$ MAIN ITEM BUFFER
          LMJ       X5,VALIDATE         RE-CHECK FILE STATUS
          J         CHANGED             DON'T PROCESS FILE IF NOW INVALID
.
.         FILE IS STILL OK.  READ UP SECTOR ZERO OF THE FILE AND SEE
.         IF IT'S REALLY A PROGRAM FILE.  IF SO, WE'LL GO PACK IT.  THE
.         SECTOR ZERO BUFFER WILL BE USED AT THE COMPLETION OF THE
.         PACK TO DETERMINE WHETHER THE FILE WAS INITIALLY PREPPED.  IF
.         SO, WE'LL RE-PREP THE FILE.
.
          IOW$      RDSEC0              READ SECTOR ZERO OF THE FILE
          TZ,S1     RDSEC0+3            WAS STATUS OK ON READ ?
          J         RDERR               NO.  CAN'T PROCESS FILE THEN
          LA        A0,SEC0             LOAD FIRST WORD OF BUFFER
          TE        A0,('**PF**')       IS IT A PROGRAM FILE ?
          J         NOTPF               NO.  DON'T PROCESS NON-PROGRAM FILE
.
          LA        A0,TOTPCK           LOAD TOTAL FILES PACKED
          AA,U      A0,1                INCREMENT TOTAL PACK COUNT
          SA        A0,TOTPCK           UPDATE TOTAL FILES PACKED
          LA        A0,OPTIONS          LOAD OPTION BITS
          TEP,U     A0,OPTION('T')      IS THE 'T' OPTION ON ?
          J         PKSKIP              YES.  SKIP THE PACK
.
.         HERE WE GO... MARK THE FILE UNLOADED SO IT'LL ROLL BACK
.         IF WE BOMB OR THE SYSTEM CRASHED WHILE WE'RE DIDDLING
.         WITH IT.
.
          SNZ       ATTEMPT             MARK PACK ATTEMPT MADE
          TDATE$    .                   GET UNLOAD TIME FOR THE FILE
          SA        A0,DUNLD+3          SET TIME OF UNLOAD IN MSCON$ PACKET
          MSCON$    DUNLD               MARK THE FILE UNLOADED
          JN        A0,DUNLER           ERROR IF CAN'T MARK UNLOADED
.
.
.         PACK THE FILE
.
.
          LX,U      X8,CDB              LOAD COMMAND BUFFER ADDRESS
          SNZ       CDB+CDBACT          MARK COMMAND SUCCESSFUL
          LA,U      A0,RTPK             LOAD RETURN FROM PACK
          SA        A0,RETURN           SAVE RETURN POINT
          LMJ       X5,PARBUF           ALLOCATE PARAMETER BUFFERS
          LMJ       X11,PACK            GO PACK THE FILE
          J         PKERR               PACK ERRORED.  EDIT MESSAGE
.
.
.         PACK COMPLETE.  IF THE FILE WAS PREPPED, RE-PREP IT.
.
RTPK      SZ        PREPFLAG            CLEAR RE-PREP DONE
          TNZ,H2    SEC0+15             IS ENTRY POINT TABLE PRESENT ?
          TZ,H1     SEC0+16             IS ENTRY POINT TABLE LENGTH NONZERO ?
          J         $+2                 YES.  FILE SHOULD BE RE-PREPPED
          J         RTPR                NO.  FILE WASN'T PREPPED TO START WITH
          SNZ       PREPFLAG            MARK PREP DONE ON FILE
          LA        A0,TOTPREP          LOAD TOTAL FILES PREPPED
          AA,U      A0,1                INCREMENT PREP COUNT
          SA        A0,TOTPREP          UPDATE TOTAL PREP COUNT
          LA,U      A0,RTPR             LOAD RETURN POINT FROM PREP
          SA        A0,RETURN           SET RETURN POINT FOR COMPLETE
          SNZ       CDB+CDBACT          MARK COMMAND SUCCESSFUL
          LX,U      X8,CDB              LOAD COMMAND DESCRIPTOR
          LMJ       X5,PARBUF           ALLOCATE PARAMETER BUFFERS
          LMJ       X11,PREPARE         PREPARE AN ENTRY POINT TABLE
          J         PRPERR              EDIT MESSAGE FOR PREP ERROR
RTPR      LA,U      A2,MI               RELOAD MAIN ITEM ADDRESS
.
.         ALL DONE PACKING.  MARK THE FILE LOADED AGAIN.
.
PKDONE    SZ        DUNLD+3             SET TO MARK FILE LOADED
          MSCON$    DUNLD               MARK THE FILE LOADED
          JN        A0,LDBERR           ERROR.  CAN'T MARK FILE LOADED
.
.         COMPUTE TRACKS RELEASED BY PACKING THE FILE
.
PKSKIP    FITEM$    PFDT,10             RETURN ASSIGNMENT INFORMATION
          LA,H1     A15,MI+23           LOAD ORIGINAL HIGHEST TRACK
          ANA,H1    A15,PFDT+9          COMPUTE TRACKS SAVED BY PACKING
          TNZ       ASGFLAG             DID WE ASSIGN THE FILE ?
          J         PKFUNM              NO.  JUST RELEASE THE USE NAME
          CSF$      FFREE               @FREE THE FILE.  ALL DONE
          J         PKFDN               GO UPDATE TOTAL TRACKS RELEASED
.
PKFUNM    CSF$      FUFREE              RELEASE THE INTERNAL NAME
PKFDN     SZ        ASGFLAG             CLEAR FILE ASSIGNED FLAG
          LA        A0,TOTREL           LOAD TOTAL TRACK RELEASED
          AA        A0,A15              ADD TRACKS PACKED FROM THIS FILE
          SA        A0,TOTREL           UPDATE TOTAL TRACKS RELEASED
.
.         EDIT A MESSAGE TELLING HOW MUCH WE SAVED
.
          LA,U      A2,MI               LOAD MAIN ITEM ADDRESS
          LMJ       X5,EFNAME           EDIT FILE NAME
          F$SKIP    1                   SKIP AFTER FILE NAME
          TZ        DEMAND              ABBREVIATED LISTING ?
          J         NODF                YES.  SKIP TAB
          F$COL     32                  TAB TO SENTINEL COLUMN
          JZ        A15,NOPKSVF         SKIP IF PACK SAVED NOTHING
          F$CHAR    '*'                 EDIT AN ASTERISK TO FLAG SAVINGS
NOPKSVF   F$COL     35                  TAB TO CENTRE OF PAGE
NODF      F$MSG     PKDNM               EDIT PACK COMPLETE MESSAGE
          TNZ       PREPFLAG            DID WE RE-PREP ?
          J         NOPPM               NO.  SKIP MESSAGE
          F$MSG1    PREPM               EDIT 'RE-PREPPED'
NOPPM     F$MSGR    .                   COPY TO TRACK COUNT
          F$DECV    A15                 EDIT TRACKS SAVED
          F$MSGR    .                   COMPLETE THE MESSAGE
          F$PRT     1                   PRINT COMPLETION MESSAGE
          J         NEXTITEM            READ NEXT DIRECTORY ITEM
.
.
.         ALL FILES HAVE BEEN PROCESSED.  TERMINATE
.
DIREND    LA        A0,OPTIONS          LOAD OPTIONS
          TEP,U     A0,OPTION('W')      SAVE DGET$ FILE ?
          J         SVDGET              YES.  DON'T RELEASE DGET$ FILE
          CSF$      FREEDG              RELEASE THE DGET$ FILE
.
.         EDIT SUMMARY MESSAGE
.
SVDGET    F$MSG     PKSUMM              EDIT PACK SUMMARY MESSAGE
          F$DECV    TOTFIL              EDIT TOTAL FILES EXAMINED
          F$MSGR    .                   COPY MESSAGE
          F$DECV    TOTASG              EDIT TOTAL FILES ASSIGNED
          F$MSGR    .                   COPY TO END OF FIRST LINE
          F$PRT     2                   PRINT FIRST SUMMARY LINE
          F$MSG     PKSUM1              EDIT SECOND SUMMARY LINE
          F$DECV    TOTPCK              EDIT TOTAL FILES PACKED
          F$MSGR    .                   COPY MESSAGE
          F$DECV    TOTPREP             EDIT NUMBER OF FILES RE-PREPPED
          F$MSGR    .                   COPY MESSAGE
          F$DECV    TOTREL              EDIT TOTAL TRACKS RELEASED
          F$MSGR    .                   COPY TO END OF MESSAGE
          F$PRT     1                   PRINT LAST SUMMARY LINE
          EXIT$     .                   TERMINATE
.
.
.         ROUTINE TO HANDLE VARIOUS ERRORS OR ABNORMAL STATUSES
.
NOKEYS    REASON    RKEYS               'FILE HAS KEYS.  CANNOT BE PACKED'
          J         NOPACK              DON'T PACK IT IF IT HAS KEYS
.
NOTPF     REASON    RNOTPF              'NOT A PROGRAM FILE'
          J         NOPACK              DON'T PACK IT
.
RDERR     REASON    RRDER               'COULD NOT READ SECTOR ZERO'
          J         NOPACK              DON'T PACK FILE
.
FASGER    REASON    RFLA                'FILE UNASSIGNABLE'
          J         NOPACK              DON'T PACK FILE
.
NORDMI    REASON    RNMI                'COULD NOT DREAD$ MAIN ITEM'
          J         NOPACK              DON'T PACK THE FILE
.
DUNLER    REASON    RDUN                'COULD NOT MARK FILE UNLOADED'
          J         NOPACK              DON'T PACK THE FILE
.
PKERR     REASON    RPKERR              'ERROR PACKING FILE.'
          LA,U      A2,MI               LOAD MAIN ITEM ADDRESS
          J         NOPACK              GO PRINT THE ERROR MESSAGE
.
PRPERR    REASON    RPRERR              'ERROR RE-PREPPING FILE.'
          LA,U      A2,MI               LOAD MAIN ITEM ADDRESS
          J         NOPACK              PRINT THE ERROR MESSAGE
.
LDBERR    REASON    RDLB                'COULD NOT MARK FILE LOADED'
          SNAP$,'A'
          J         NOPACK              ACTUALLY A MORE SERIOUS ERROR
.
DGASGER   PRINT$    ('DG ASG'),1
          EXIT$     .
.
IERR*     J         $-$                 INTERNAL ERROR
          SNAP$,'A' 0,,'IERR  '         SNAP 'A' REGISTERS
          EABT$     .
.
INITER    .                             ERROR FROM FDINIT
NDIERR    LA        A0,A5               ERROR FROM FDNDI, LOAD PRINT$ WORD
          PRINT$    .                   PRINT ERROR MESSAGE FROM FDSUBS
          EABT$     .                   TERMINATE
.
DGETER    SA        A0,A4               SAVE DGET$ STATUS CODE
          F$MSG     DGER                EDIT DGET$ ERROR MESSAGE
          F$OCTF    12,A4               EDIT DGET$ STATUS
          F$PRT     2                   PRINT DGET$ ERROR MESSAGE
          EABT$     .                   TERMINATE
.
.
.         EDIT REASON WHY FILE NOT PROCESSED
.
NOPACK    TZ        ATTEMPT             WAS PACK ATTEMPTED ON FILE ?
          J         NPKPR               YES.  LIST ANY ERROR
          TNZ       LONGLIST            LONG LISTING DESIRED ?
          J         NEXTITEM            NO.  DON'T EDIT UNPROCESSED FILES
NPKPR     LMJ       X5,EFNAME           EDIT FILE NAME
          F$SKIP    1                   SKIP AFTER FILE NAME
          TZ        DEMAND              SHORT FORMAT LISTING ?
          J         NOPB                YES.  SKIP TAB
          F$COL     40                  TAB TO MIDDLE OF PAGE
NOPB      F$MSG     R4,,W               EDIT MESSAGE FOR REASON
          F$PRT     1                   PRINT THE LISTING
NOPOUT    TNZ       ASGFLAG             IS FILE ASSIGNED TO US ?
          J         NEXTITEM            NO.  PROCESS THE NEXT MAIN ITEM
          CSF$      FFREE               YES.  @FREE THE FILE
          SZ        ASGFLAG             MARK FILE NOT ASSIGNED
          J         NEXTITEM            RETURN TO PROCESS NEXT FILE
.
.
.         EDIT REASON FOR NOT PROCESSING A FILE WHICH HAS
.         CHANGED BETWEEN THE DGET$ AND THE DREAD$.
.
CHANGED   TNZ       LONGLIST            LONG LISTING DESIRED ?
          J         NEXTITEM            NO.  DON'T LIST UNPROCESSED FILES
          LMJ       X5,EFNAME           EDIT THE FILE NAME
          F$SKIP    1                   SKIP AFTER FILE NAME
          TZ        DEMAND              ABBREVIATED LISTING FOR DEMAND ?
          J         NOCB                YES.  SKIP TAB
          F$COL     40                  TAB TO CENTRE OF PAGE
NOCB      F$FD4     ('CHANGED: ')       LABEL FILE AS CHANGED
          F$MSG     R4,,W               EDIT REASON FOR REJECTION
          F$PRT     1                   PRINT REASON FOR REJECTION
          J         NOPOUT              PROCESS THE NEXT ITEM
.
.         SUBROUTINE TO EDIT A FILE NAME FROM MAIN ITEM
.
.         LA,U      A2,<MAIN ITEM>
.         LMJ       X5,EFNAME
.         <RETURN>
.
EFNAME    F$FD2     1,A2                EDIT QUALIFIER
          F$CHAR    '*'                 EDIT ASTERISK BEFORE FILE NAME
          F$FD2     3,A2                EDIT FILE NAME
          LA,T3     A0,17,A2            LOAD ABSOLUTE F-CYCLE
          TNE,U     A0,1                IS IT F-CYCLE 1 ?
          J         0,X5                YES.  RETURN TO CALLER
          F$CHAR    '('                 EDIT LEFT PARENTHESIS
          F$DECV    17,A2,T3            EDIT F-CYCLE NUMBER
          F$CHAR    ')'                 EDIT RIGHT PARENTHESIS
          J         0,X5                RETURN TO CALLER
.
.         RETURN TO PROCESSING AFTER FANG COMMAND COMPLETION
.
COMPLETE* LA        A1,CDB+CDBPC        LOAD LINK TO FIRST PARAMETER
PBRELN    JZ        A1,PBRELE           QUIT IF ALL PARAMETERS RELEASED
          LA        A0,A1               LOAD ADDRESS OF CURRENT BUFFER
          LA        A1,PBLINK,A1        LOAD LINK TO NEXT PARAMETER
          BRELP     A0                  RELEASE THIS PARAMETER BUFFER
          J         PBRELN              RETURN TO RELEASE NEXT ONE
.
PBRELE    BRELC     .                   RELEASE MEMORY USED BY COMMAND
          LX        X11,RETURN          LOAD RETURN POINT TO PROGRAM
          TNZ       CDB+CDBACT          DID COMMAND ERROR ?
          ANX,U     X11,1               YES.  TAKE ERROR RETURN
          J         0,X11               RETURN TO CALLER
.
.         SET UP PARAMETER BUFFER CHAIN FOR FANG COMMAND
.
PARBUF    BGET      P1L                 ALLOCATE FIRST PARAMETER BUFFER
          SA        A0,CDB+CDBPC        ATTACH BUFFER TO COMMAND
          AA        A0,(1,0)            GET INCREMENT FOR COPY
          LA        A1,(1,PARAM)        LOAD POINTER TO BUFFER
          LR,U      R1,P1L              LOAD LENGTH OF BUFFER
          BT        A0,,*A1             COPY FIRST PARAMETER TO BUFFER
          BGET      P2L                 ALLOCATE BUFFER FOR FILE PARAMETER
          LA        A2,CDB+CDBPC        LOAD ADDRESS OF FIRST PARAMETER
          SA        A0,PBLINK,A2        CHAIN TO FIRST PARAMETER
          AA        A0,(1,0)            GET INCREMENT TO COPY
          LA        A1,(1,PARAMF)       LOAD POINTER TO CANNED PARAMETER
          LR,U      R1,P2L              LOAD LENGTH OF FILE PARAMETER
          BT        A0,,*A1             COPY FILE PARAMETER TO BUFFER
          J         0,X5                RETURN TO CALLER
.
.         INTERCEPT ROUTINES FOR ILLEGAL ENTRIES TO FANG
.
ICOUT*    .
EOTWRT*   .
ENCIPHER* .
          IERR      .                   CANNOT GET HERE !!
.
.         CONTINGENCY ROUTINE TO ENABLE HANDLING OF I/O ERRORS
.
$(2).
CGY       RES       2                   CONTINGENCY PARAMETER STORAGE
          J         $(1)                ENTER IBANK FOR PROCESSING
$(1)      SA        A0,CGYSA0           SAVE A0 AT ENTRANCE
          LA,S1     A0,CGY              LOAD ERROR TYPE
          TE,U      A0,1                IS IT AN I/O ERROR ?
          J         CGYERR              NO.  IT'S A REAL ERROR
          LA,H2     A0,CGY              LOAD ADDRESS OF ERROR
          AA,U      A0,1                SET TO RETURN AFTER ER
          SA        A0,CGY              SET IN PACKET, CLEARING H1
          LA        A0,CGYSA0           RELOAD A0
          CEND$     .                   I FEEL A DRAFT...
          J         *CGY                RETURN TO CALLER
.
CGYERR    SZ,H1     CGY                 CLEAR ERROR CODE
          LA        A0,CGYSA0           RELOAD A0
          IALL$     0                   CLEAR THE CONTINGENCY SETTING
          J         *CGY                GO DO IT AGAIN
/.
.
.         EXAMINE MAIN ITEM
.
.         LA,U      A2,<MAIN ITEM BUFFER>
.         LMJ       X5,VALIDATE
.         <RETURN>                      DON'T PROCESS FILE.
.                                       R4 = MESSAGE EXPLAINING WHY
.         <RETURN>                      FILE SHOULD BE PROCESSED
.
.
P         PROC      1,1
REASON*   NAME      0
          LR,U      R4,P(1,1),P(1,2)
          END
.
P         PROC      0,1
REJECT*   NAME      0
          J         0,X5                REJECT THE FILE
          END
.
.
VALIDATE  REASON    REQT                INDICATE BAD EQUIPMENT TYPE
          LA,S1     A0,17,A2            LOAD EQUIPMENT TYPE FOR THE FILE
          TG,U      A0,030              BELOW FASTRAND TYPES ?
          TG,U      A0,037+1            NO.  WITHIN FASTRAND RANGE ?
          REJECT    .                   NO.  CAN'T PACK NON-FASTRAND FILE
.
.         CHECK INHIBIT FLAGS.  FILE MUST BE NEITHER READ-ONLY, WRITE-ONLY,
.         OR 'G' OPTION TO PASS THIS TEST.
.
          REASON    RINHBT              LOAD INHIBIT FLAGS AS REASON
          LA,S2     A0,17,A2            LOAD INHIBIT BITS FOR FILE
          AND,U     A0,BIT(0,1,5)       ISOLATE READ-, WRITE-ONLY, AND GUARD BITS
          TZ        A1                  IS THE FILE INHIBITED ?
          REJECT    .                   YES.  DON'T PROCESS IT
.
.         CHECK DISABLE FLAGS.  TO PASS THIS STEP, THE FILE MUST BE
.         NEITHER HARDWARE NOR SECURE DISABLED.
.
          REASON    RDSBL               SET DISABLE AS REASON
          LA,S1     A0,11,A2            LOAD DISABLE FLAGS
          AND,U     A0,BIT(2,4)         ISOLATE SECURE AND HARDWARE BITS
          TZ        A1                  IS FILE DISABLED ?
          REJECT    .                   YES.  DON'T TOUCH A DISABLED FILE
.
.         CHECK DESCRIPTOR BITS.  TO PASS THIS TEST, THE FILE MUST BE
.         LOADED, BACKED UP, HAVE A GOOD MAIN ITEM SECTOR 1, BE ON
.         FIXED STORAGE (NOT A PACK), AND HAVE NONE OF THE 'BECOMING'
.         BITS SET (FILE IS TO BECOME READ-ONLY/WRITE-ONLY), AND HAVE
.         THE DROP FLAG CLEAR.
.
          LA,T1     A0,12,A2            LOAD DESCRIPTOR BITS
          REASON    RUNL                LOAD 'FILE UNLOADED' AS REASON
          TEP,U     A0,BIT(11)          IS FILE UNLOADED ?
          REJECT    .                   YES.  IGNORE IT
          REASON    RNBKU               LOAD NOT BACKED UP AS REASON
          TOP,U     A0,BIT(10)          DOES BACKUP EXIST ?
          REJECT    .                   NO.  DON'T PACK A NON-BACKED UP FILE
          REASON    RBMIS1              LOAD BAD MAIN ITEM SECTOR 1 STATUS
          TEP,U     A0,BIT(7)           IS MAIN ITEM EXTENSION BAD ?
          REJECT    .                   YES.  DON'T PROCESS FILE
          REASON    RNOTFX              LOAD REMOVABLE FILE AS REASON
          TEP,U     A0,BIT(3)           IS FILE ON REMOVABLE PACK ?
          REJECT    .                   YES.  THAT'S THE USER'S PROBLEM
          REASON    RFCHG               LOAD 'FILE BEING CHANGED' AS REASON
          AND,U     A0,BIT(0,1,2)       IS FILE BEING CHANGED ?
          TZ        A1                  (DROP FLAG, READ- OR WRITE-ONLY) ?
          REJECT    .                   YES.  CANNOT PROCESS THE FILE
.
.         CHECK WHETHER THE BACKUP IS CURRENT.  IF NOT, WE DON'T RISK
.         DESTROYING CHANGES TO THE FILE BY PACKING IT.
.
          REASON    RNCURR              REASON: 'BACKUP NOT CURRENT'
          TZ        10,A2               FIRST WRITE AFTER BACKUP ZERO ?
          REJECT    .                   YES.  FILE CHANGED SINCE BACKUP MADE
.
.         IF HIGHEST TRACK REFERENCED IS NOT AT LEAST 29, THE FILE
.         IS NOT A PROGRAM FILE (LESS THAN 28), OR CANNOT POSSIBLY
.         BE CONTRACTED BY A PACK (EQUAL TO 28).
.
          REASON    RNENUF              LOAD HIGHEST TRACK WRITTEN TOO LOW
          LA,H1     A0,23,A2            LOAD HIGHEST TRACK REFERENCED
          TLE,U     A0,29               IS IT AT LEAST TRACK 29 ?
          REJECT    .                   NO.  DON'T PROCESS FILE
.
.         SCAN THE GRANULE ALLOCATION WORDS.  IF THE FILE IS TRACK
.         GRANULARITY, IT MUST HAVE AT LEAST THREE GRANULES ASSIGNED
.         TO BENEFIT FROM A PACK.  IF POSITION GRANULARITY, IT MUST
.         HAVE TWO OR MORE GRANULES TO BENEFIT.
.
          REASON    RGRANCT             LOAD INSUFFICIENT GRANULES REASON
          LA,U      A0                  CLEAR GRANULE COUNTER
          LR,U      R1,7                LOAD LOOP COUNTER
          LA,U      A3,,A2              LOAD ADDRESS OF MAIN ITEM BUFFER
          AA        A3,(1,0)            LOAD INCREMENT TO SCAN GRANULE COUNTS
          AA,H2     A0,20,*A3           ACCUMULATE GRANULE COUNTS
          JGD       R1,$-1              LOOP FOR ALL EQUIPMENT TYPES
          TP        13,A2               IS FILE POSITION GRANULARITY ?
          AA,U      A0,1                YES.  TWO POSITIONS ARE ENOUGH
          TLE,U     A0,3                IS FILE WORTH PACKING ?
          REJECT    .                   NO.  NO BENEFIT FROM PACK
.
.         ***
.
.         NOW SEE IF IT'S ONE OF THE ASS-HOLE 'CTS$' FILES WHICH
.         HAVE A '**PF**' SENTINEL BUT AREN'T PROGRAM FILES.
.
          REASON    RCTSFL              LOAD REASON 'CTS FILE'
          DL        A0,1,A2             LOAD QUALIFIER FOR FILE
          DSL       A0,24               MAKE ROOM FOR CTS$
          AA        A0,('CTS$@@')       FORM GENERATED FILE NAME
          DTE       A0,3,A2             IS IT A CTS$FILE ?
          J         $+2                 NO.  LET IT PASS
          REJECT    .                   YES.  CAN'T PROCESS IT
.
.         FILE IS SELECTED.  RETURN TO PACK ROUTINE
.
          J         1,X5                RETURN TO PROCESS THE FILE
/.
.
$(2).
.
.         REASONS FOR NOT PROCESSING FILES
.
RDSBL     'FILE IS DISABLED&'
REQT      'NOT FASTRAND FORMAT&'
RINHBT    'READ-ONLY, WRITE-ONLY, OR ''G'' OPTION&'
RUNL      'UNLOADED&'
RNBKU     'NO BACKUP FOR FILE&'
RBMIS1    'BACKUP SECTOR LOST&'
RNOTFX    'REMOVABLE DISC FILE&'
RFCHG     'FILE MODES BEING CHANGED&'
RNCURR    'FILE CHANGED SINCE BACKUP MADE&'
RNENUF    'INSUFFICIENT SIZE TO BE A PROGRAM FILE&'
RGRANCT   'TOO SMALL TO BENEFIT FROM PACK&'
RCTSFL    'CTS$ FILE - NOT PACKABLE&'
RKEYS     'CANNOT PACK A FILE WITH KEYS&'
RNOTPF    'NOT A PROGRAM FILE&'
RRDER     'COULD NOT READ FILE&'
RFLA      'FILE UNASSIGNABLE&'
RNMI      'COULD NOT RETRIEVE MAIN ITEM&'
RDUN      'COULD NOT MARK FILE UNLOADED&'
RPKERR    '* ERROR PACKING FILE&'
RPRERR    '* ERROR RE-PREPPING FILE&'
RDLB      '* COULD NOT MARK FILE LOADED *&'
.
PACKH     'PACKER 1.0 &'
PKDNM     'PACKED&.  & TRACKS RELEASED.&'
PKSUMM    'END PACKER.  & FILES EXAMINED, & FILES ASSIGNED.&'
PKSUM1    '             & PACKED, & RE-PREPPED, & TRACKS RELEASED.&'
PREPM     ', PREPPED&'
.
DGER      'DGET$ ERROR.  STATUS:  &'
.
.         IMAGES FOR CSF$
.
ASGIMG    '@ASG,TJ DGET$,F/&/TRK&'      'J' OPTION FOR PAGING
FUSE      '@USE $PACK,&'                TO ATTACH INTERNAL NAME TO FILE
FASG      '@ASG,AGQXZ $PACK . '         TO ASSIGN FILE TO BE PACKED
FFREE     '@FREE,AR $PACK . '           TO FREE FILE JUST PACKED
FUFREE    '@FREE,A $PACK . '
FREEDG    '@FREE DGET$ . '
.
.         MSCON$ PACKETS
.
DUMMYDG   *         DGET$               TO FIND SIZE OF DGET$ FILE
          'DIAG$       '
          RES       1
          *         $-$,$-$             BUFFERS GO HERE
.
DGET      *         DGET$               TO ACTUALLY DO THE DGET$
          'DGET$       '
          RES       1
          *         $-$,$-$
.
READMI    *         DREAD$              TO READ MAIN ITEM OF FILE
          '$PACK       '
          *         03401,MI            READ MAIN ITEM
          *         0
.
DUNLD     *         DUNLD$              TO MARK FILE UNLOADED/LOADED
          '$PACK       '
          RES       1
.
RDSEC0    IO$PKT,R$ '$PACK' 28,SEC0 0
.
.         PACKETS TO INVOKE FANG COMMAND PROCESSES
.
.         COMMAND BUFFER
.
CDB       QUEUE     .                   CDBQ
          *         PARAM,$-$           CDBPC,CDBACT
          *         IMB,0               IMAGE,FLAGS
          *         0                   OPTIONS (NONE)
          QUEUE     .                   QUEUE FOR BUFFERS
.
.         IMAGE BUFFER
.
IMB       *         1,0                 STATEMENT 1.
          RES       14                  IMAGE TEXT (GARBAGE)
.
.
.         ELEMENT CLASS PARAMETER
.
PARAM     *         ELTCLASS,PARAMF     TYPE
          *         0
          *         PFDT,010000         FDT, ALL ELEMENTS FLAG
          RES       ELL-($-PARAM)       PFP PACKET
P1L       EQU       $-PARAM
.
PARAMF    *         FILE,0              TYPE, LINK (NULL)
          *         0                   QUEUE WORD
          *         PFDT                FDT POINTER
P2L       EQU       $-PARAMF
.
.         FILE DESCRIPTOR PACKET
.
PFDT      '$PACK       '                INTERNAL NAME
          RES       9                   FITEM$ PACKET
          *         0,0                 FDREADC,FDWRITE,FDPROT
          *         0                   FREE WORD
          *         1,0                 IN-USE FLAG, NO NEXT FDT
          *         0                   CURRENT ADDRESS
          *         020000,224          TYPE, LENGTH OF BLOCK
          *         '?'                 READ KEY
          *         '?'                 WRITE KEY
          *         0                   IN-PROGRESS ADDRESS
          *         0D                  CRYPTOGRAPHIC KEY
.
.         SIMULATION OF FANG DATA ENVIRONMENT
.
CMDLOCK*  PVQUEUE   1                   COMMAND QUEUE
INPROCQ*  QUEUE     0                   IN-PROGRESS COMMAND QUEUE
CMDQUE*   QUEUE     0                   COMMAND QUEUE
PRINTER*  PVQUEUE   1                   PRINTER LOCK QUEUE
.
LOOKAHEAD* *        4                   BUFFERING FACTOR
DEMAND*   *         0                   LISTING MODE FOR FANG
FDCHAIN*  *         PFDT                FDT CHAIN
SHADUP*   *         0                   RDIT$ SHUT UP FLAG
TYPOUTST* *         0                   RDIT$ TYPE AND READ OUTSTANDING FLAG
.
.
.         PROCESSING STATISTICS
.
TOTREL    *         0                   TOTAL TRACKS RELEASED
TOTFIL    *         0                   TOTAL FILES EXAMINED
TOTASG    *         0                   TOTAL FILES ASSIGNED
TOTPREP   *         0                   TOTAL FILES RE-PREPPED
TOTPCK    *         0                   TOTAL FILES PACKED
.
LONGLIST  EQUF      $,,S1               'L' OPTION FLAG
PREPFLAG  EQUF      $,,S2               RE-PREP DONE FLAG
ASGFLAG   EQUF      $,,S3               FILE IS ASSIGNED FLAG
WKBUF     EQUF      $,,H2               WORK BUFFER POINTER
          *         010000,$-$
.
ATTEMPT   EQUF      $,,S1               PACK ATTEMPT MADE FLAG
          *         0
.
PRIVL     *         0                   PRIVILEGED CALLER FLAG
CGYSA0    *         0                   A0 SAVE FOR CONTINGENCY
.
PROJECT   *         0D                  PROJECT OF CALLER
.
RETURN    EQUF      $,,H1               RETURN POINT FROM COMMAND
          *         0,0
.
OPTIONS   RES       1                   OPTION BITS
.
SEC0      RES       28                  SECTOR ZERO OF USER FILE
MI        RES       28                  MAIN ITEM OF USER FILE
.
          END       BEGIN