*
*        THIS PROG KEYS A FILE (KEYM,3) INTEGER VALUES
*        JUST SAY !KEY <FID>
*
         SYSTEM   BPM
         SYSTEM   SIG5
         REF      ERREXIT           I/O ERROR MSG PRINTER
         REF      SCAN:C            J:CCBUF SCANNER
         DEF      START
         CSECT    1
START    EQU      %
         LW,1     FPT+1             GOTTA CLEAR THE
         AND,1    L(-1-X'200')       "PASSWORD" FLAG
         STW,1    FPT+1
         LI,1     0                 ALSO CLEAR THE DUMMY
         STW,1    FPT+7              FILENAME VLP
         LI,8     FPT+7             VLP AREA
         BAL,14   SCAN:C            GO FILL 'EM IN!
         BCS,8    SORRY             BAD SCAN
         BCR,6    S02               => NO ACN OR PASS
         BCR,2    S01               => NO ACN. JUST PASS
         STCF     1                 SHOVE RESULT INTO REG 1
         LI,3     X'08'             YES..
         STS,3    FPT+1              SET FLAG
         LC       1                 RESTORE CONDITIONS
         BCR,4    S02               => NO PASS
S01      LI,3     X'200'            YES..
         STS,3    FPT+1              SET FLAG
          M:PT      0                   NO PROTECTION HERE
S02,FPT  M:OPEN   M:SI,IN,(KEYM,3),FILE,PASS,;
                  (ERR,ERREXIT),(ABN,ERREXIT),(FPARAM,FP)
          M:PT      1                   PROTECTION AGAIN
         M:CLOSE  M:SI,SAVE         SURE DOES!
          LI,R4     15                  MOVE FID,ACCOUNT,PASS
          LI,R6     0                    TO F:WRK FPT
RENMOVE   EQU       %
          LW,R5     M:SI+22,R6          GET A WORD
          STW,R5    WRKFPT+6,R6          AND MOVE IT
          AI,R6     1                   BUMP TO NEXT
          BDR,R4    RENMOVE             DO ALL WORDS
         AI,R6    -3                BACK UP TO PASS VLP
         LW,R5    WRKFPT+6,R6       GET VLP WORD
         AND,R5   L(X'FF00FFFF')    DROP 'LAST PARAM' BIT
         STW,R5   WRKFPT+6,R6       PUT BACK
*
*        MOVE READ,WRITE,EXEC ACCOUNTS AND EXP.DATE
*
         LI,7     0                 FPT INDEX
         LI,R6    FP+10             FPARAM POINTER
         LB,8     *R6               GET VLP TYPE
         CI,8     X'03'             PASSWORD?
         BNE      M01               => NOPE
         AI,R6    3                 YES. SKIP IT.
         LB,8     *R6               GET NEXT VLP TYPE
M01      CI,8     X'15'             ACCESS VEHICLE NAME?
         BNE      M02               => NO. MUST BE GOOD STUFF.
         LI,1     3                 YES. GOTTA SKIP
         LB,1     *R6,1              OVER THIS
         AW,R6    1                   PARAM
         AI,R6    1                    TOO!
M02      EQU      %
         LB,8     *R6               GET VLP TYPE
         CI,8     X'0F'             ACCESS DATE?
         BE       M03               => YUP. ALL DONE
         LW,1     *R6               GET FPARAM WORD
         STW,1    WRKFPT+21,7        AND MOVE TO FPT
         AI,R6    1                 BUMP
         AI,7     1                  POINTERS
         B        M02               DO ALL TILL DONE
*
M03      AI,7     -3                BACK UP TO LAST VLP IN FPT
         LI,R6    X'10000'          'LAST' INDICATOR
         AWM,R6   WRKFPT+21,7       SET 'LAST PARAM'
         DEF      OPENOUT           FOR DEBUG
OPENOUT  M:OPEN,E WRKFPT            OPEN OUTPUT FILE
         M:OPEN   M:SI,IN,(ERR,ERREXIT),(ABN,ERREXIT)
         M:PRINT  (MESS,MSG)        QUIET DOWN IMPATIENT USER
         LW,R4    L(X'03000000')    KEYLEN
RENREAD   EQU       %
         M:READ   M:SI,(SIZE,140),(ERR,ERR2),(ABN,ERR2),WAIT
         LW,R6    M:SI+4            GET ARS
         SLS,R6   -17
         AI,R6    -1                REL TO ZERO
         BLEZ     WRITE             => ARS<= BYTE
A00      LB,R5    IOBUF,R6          GET A BYTE
         CI,R5    ' '               BLANK?
         BNE      WRITE             => NOPE.
         BDR,R6   A00               YUP. DO NEXT TO LEFT
WRITE    EQU      %
         AI,R6    1                 REL TO ONE (1)
         AI,R4    1000              NEXT KEY
         STW,R4   KEY               SET KEY
         M:WRITE  F:WRK,(SIZE,*R6),WAIT,(KEY,KEY),NEWKEY,;
                  (ERR,ERREXIT),(ABN,ERREXIT)
          B         RENREAD              AND CONTINUE TILL EOF
*
*         FINISHED--CLOSE FILES
*
*
ERR2     EQU      %
         LB,R4    R10               GET ERR CODE
         CI,R4    6                 EOD?
         BNE      ERREXIT           => NOPE
          M:CLOSE   M:SI                DESTROY ORIGINAL FILE
          M:CLOSE   F:WRK,SAVE          RETAIN RENUMBERED
*
*        PRINT LAST RECORD KEY #
*
         LW,3     KEY               GET KEY
         AND,3    L(X'FFFFFF')      DROP KEYLEN
         DW,3     L(1000)           MAKE REL TO 1
         LI,1     3                 LOOPIE
EBC      LI,2     0
         DW,2     =10
         LB,2     TAB,2
         STB,2    #RECS+4,1
         AI,1     -1
         BGEZ     EBC
         LI,1     -4                LOOPER
EDIT     LB,0     #RECS+5,1
         CI,0     '0'
         BNE      PRNT
         LI,0     ' '
         STB,0    #RECS+5,1
         BIR,1    EDIT
PRNT     M:PRINT  (MESS,#RECS)
         M:EXIT                     DONE!
*
SORRY    M:PRINT  (MESS,EH)
         M:EXIT
*
EH       TEXTC    ' Eh?'
TAB      TEXT     '0123456789'
          PAGE
         CSECT    0
MSG      TEXTC    '..COPYING'  KEEPS USER QUIET
#RECS    TEXTC    '..LAST RECORD :     '
         TEXT     '0000'
KEY      DATA     0
IOBUF    RES,1    140
*
*        THE OLD HAND-CODED FPT!!!
*
         BOUND    4
         DEF      WRKFPT            FOR DEBUGGING
         DEF      FP                ALSO
WRKFPT   GEN,8,24 X'14',F:WRK       CODE,DCB
         DATA     X'C1400339'       PASS,EXP,WR,RD,ACN
         DATA     ERREXIT           ERR
         DATA     ERREXIT           ABN
         DATA     2                 MODE=OUT
         DATA     2                 SAVE
         DO1      60
         DATA     '    '            VLP SLOTS
*
*        FPARAM BUFFER.
*
FP       RES      90
*
         PAGE
*         DATA CONTROL BLOCK--USER FILE
*
M:SI      DSECT     2
*
*
*
*
M:SI     M:DCB    FILE,KEYED,SEQUEN,(RECL,140),PASS,(KEYM,3),;
                  (BUF,IOBUF),(ERR,ERREXIT),(ABN,ERREXIT)
          PAGE
*
*         DATA CONTROL BLOCK--WORK FILE
*
F:WRK     DSECT     2
*
*
F:WRK     M:DCB     FILE,KEYED,SEQUEN,(RECL,140),PASS,(KEYM,3),;
                  (EXECUTE,16),(READ,16),(WRITE,16),EXPIRE,;
                  (BUF,IOBUF),(ABN,ERREXIT),(ERR,ERREXIT)
         PAGE
R4       EQU      4
R5       EQU      5
R6       EQU      6
R10      EQU      10
         END      START
