ASMB
  HED .         **   T M S - I M A G E - M O D U L E   ** 
      NAM $ITMS,7 92080-1X111 REV.2026  800606 1200 
  SPC 3 
**********************************************************************
*                                                                    *
*     NAME:   $ITMS     TMS-IMAGE MODULE                             *
*     SOURCE: &$ITMS    92080-18111                                  *
*     BINARY: %$ITMS    ----NONE---    PART OF  $TMSLB  92080-12100  *
*                                                                    *
*     PGMR:   FRANCOIS GAULLIER                                      *
*                                                                    *
**********************************************************************
      SPC 2 
*     **************************************************************
*     * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978.  ALL RIGHTS    *
*     * RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- *
*     * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH-  *
*     * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.  *
*     **************************************************************
  SPC 3 
      ENT $ITMS 
  SPC 1 
      EXT RMPAR,PNAME,EXEC,JASC,PRTN,KLCLS
      EXT $PARS,DBCRC,OPLOG,WRLOG 
      EXT DBOPN,DBCLS,DBUPD,DBDEL,DBUNL 
      EXT DBPUT,DBFND,DBINF,DBGET,DBLCK 
      EXT HASH,BLANC,INAMR,NXINI,NXPAR
      EXT .DDI,.DMP,.DSBR,.DIN
*     EXT DBUGR 
*     EXT DMPTM 
  SPC 1 
A     EQU 0 
B     EQU 1 
      SUP 
  SPC 4 
$ITMS STA LOCTB     SAVE LOCK TABLE ADDR
      STA LOCTE     AND INIT LOCK TABLE POINTERS
      STB PROTB 
      STB PROTE 
      STX .LNAM     SAVE LOG FILE NAME ADDR 
      STY .DMDL     SAVE LOCK FLAG, DBNAMR ADDR 
      LDA .DMDL,I   GET LOCK FLAG 
      AND D1        ISOLATE BIT 1 
      STA DMDLK     SAVE
* 
      ISY           POINT TO DB NAME, LEV ACC, SEC CODE, CR NO, NODE NO 
      CYA 
      LDB .DBNM     GET ADDR OF DB NAMR ARRAY 
      MVW D9        SAVE DB NAME, LEV ACC, SEC CODE, CR NO, NODE NO 
* 
      LDB LOCTB,I   RECALL B REG VALUE
      JSB RMPAR     AND RETREIVE PARAMETER
      DEF *+2 
      DEF P1
  SPC 1 
      LDA P1       GET LU PARAMETER 
      SZA,RSS      SET TO 1 IF NOT SPECIFIED
      CLA,INA 
      STA P1
      STA LU
* 
      JSB EXEC      SWAP THE WHOLE AREA 
      DEF *+3 
      DEF D22 
      DEF D0        SWAP THE ENTIRE PARTITION 
  SPC 2 
   SPC 2
      JSB PNAME     GET PROGRAM NAME
      DEF *+2 
.ILIS DEF ILIST+1 
   SKP
*                   SHEDULE REQUEST ACCEPTED BY THIS PROGRAM: 
*                  ===========================================
* 
* 
* - IF NO STRING IS PASSES: 
* 
*     * THE 4TH PARAMETER IS CHECKED, IF = -1 THEN THE PROGRAM TRY TO 
*       GET A REQUEST BUFFER ON SPECIAL CLASS ALLOCATED BY THIS PROGRAM 
*       AND RETURNED TO USER ON THE DBOPN CALL. IF THE GET FAIL THE 
*       PROGRAM TERMINATES FOR EVER IF IT WAS DORMANT, OR WITH 'SAVE
*       SUSPENSION POINT' OPTION IF IT WAS IN THAT STATE. 
*     * IF THE 4TH PARAMATER IS NOT -1, THEN IT IS ASSUMED TO BE A
*       CLASS I/O WORD AND A CLASS I/O GET IS EXECUTED ON THAT CLASS. 
*         * IF THE GET FAIL, A ERROR MESSAGE IS PRINTED ON THE SYSTEM 
*           CONSOLE AND THE PROGRAM TERMINATES WITH THE CURRENT OPTION. 
*         * IF THE GET SUCCEED, THE FIRST WORD OF THE BUFFER IS ASSUMED 
*           TO BE THE REQUEST CODE. IF IT IS LEGAL (0 =< RQ =<8), THE 
*           REQUEST IS PERFORMED, ELSE THE ERROR MESSAGE IS PRINTED ON
*           THE SYSTEM CONSOLE AND THE PROGRAM TERMINATES WITH THE
*           CURRENT OPTION. 
* 
* 
* - IF A STRING IS PASSES:
* 
*     * THE FIRST WORD OF THE STRING IS ASSUMED TO BE THE REQUEST CODE
*       IF IT IS LEGAL (BETWEEN 0 & 8) THE REQUEST IS PERFORMED.
*       IF THE REQUEST CODE IS NOT LEGAL, THE STRING IS CHECKED AGAINST 
*       ",,1" OPTAIN FROM THE FOLLOWING RTE/FMGR COMMAND "RU,TMSIM,,,1" 
*        * IF THE STRING DOES NOT MATCHE, A MESSAGE IS PRINTED ON THE 
*          TERMINAL USED TO SHEDULE THE PROGRAM, AND THE PROGRAM
*          TERMINATES WITH THE CURRENT OPTION.
*        * IF THE STRING MATCHES, AND THE DATA-BASE IS CLOSE, THE 
*          FOLLOWING MESSAGE IS PRINTED:
*                   NO DATA-BASE CURRENTLY OPEN.
*        * IF THE STRING MATCHES, AND A DATA-BASE IS STILL OPEN, THE
*          USER IS PROMPTED WITH THE FOLLOWING: 
*                   DATA-BASE=
*                   LEVEL WORD= 
*                   SEC-CODE= 
*         IF THE USER ANSWER CORRECTLY, THE DATA-BASE IS CLOSED IMMEDIATLY
*         REGARDLESS OF ANY LOCKING CONSIDERATION, AND THE PROGRAM
*         TERMINATES FOR EVER. (NO SAVE SUSP. OPTION) 
* 
*     THIS PROCEDURE SHOULD BE USE ONLY IN CASE OF EMMERGENCY !!
* 
* 
*     THE ERROR MESSAGE PRINTED ON THE TERMINAL IS THE FOLLOWING: 
* 
*                   /XXXXX : ILLEGAL SCHEDULE REQUEST ! 
   SKP
*      FATAL ERROR #                     MEANING
* 
*      450  [DBOPN]      TMSIM COPY MISSING, NOT LOADED (DONE 
*                             LOCALLY BY TMLIM) 
*      451  [DBOPN]      LEVEL ACCESS WORD IS NOT THE GREATER ONE, OR USE 
*                             OF THIS PROGRAM TO ACCES AN OTHER DATA-BASE 
*      452  [DBOPN]      THE PROGRAM HAS NOT BEEN INITAILIZED 
*                             (NO DBOPN REQUEST)  
*      453  [DBOPN]      CANNOT ALLOCATE CLASS IO 
* 
* 
*      460  [INTERNAL]   UPDATE A FILE NOT SAVED IN THE AUTOMATIC 
*                        SAVED RUN TABLE. 
*      461  [INTERNAL]   CORRUPT TMS-IMAGE DATA STRUCTURES
*      462               ITEM LENGTH IS .GT. 512 WORDS
  SPC 2 
*     NEW IMAGE LOCK STATUS              MEANING
* 
*      400  [IMG-STAT]   ERROR RETURNED WHEN PROCESS SHOULD BE SUSPENDED
*                             AND THE 'NO WAIT' OPTION HAS BEEN SPECIFIED 
*                             OR WHEN ATTEMPTING TO LOCK THE DATA BASE WHEN 
*                             IT IS LOCKED BY ANOTHER PROGRAM (LOCK ON
*                             DEMAND ONLY)
*      401  [IMG-STAT]   DEADLOCK ERROR     
*      402  [IMG-STAT]   LOCK TABLE OVERFLOW
*      403  [IMG-STAT]   UNLOCK RECORD LOCKED BY AN OTHER PROCESS 
*      404  [IMG-STAT]   UNLOCK RECORD WITHOUT HAVING A LOCKID (NEVER 
*                             REQUEST ANY LOCK) 
*      405  [IMG-STAT]   DBPUT IN A MASTER WITHOUT HAVING LOCK THE ENTRY
*                             IN ADVANCE  
*      406  [IMG-STAT]   A PROCESS THAT HAS LOCKED A RECORD SHARED HAS  
*                             TRIED TO LOCK THAT RECORD EXCLUSIVELY.  
*      414  [IMG-STAT]   AN UPDATE OR DELETE ON A MASTER DATA SET HAS 
*                             BEEN ATTEMPTED, HOWEVER THE RUN TABLE 
*                             INDICATES THAT THE RECORD DOES NOT EXIST
*                             AND HAS BEEN LOCKED FOR ADD.  (DBGET CALL 
*                             THAT DID THE LOCK RETURNED A 107) 
*      410  [IMG-STAT]   AN ADD HAS BEEN ATTEMPTED ON A MASTER DATA SET,
*                             HOWEVER, THE RUNTABLE INDICATES THAT THE
*                             RECORD EXISTS AND HAS BEEN LOCKED FOR 
*                             UPDATE/DELETE.  (DBGET CALL THAT DID THE
*                             LOCKED RETURNED A 0)
  SKP 
*                    MAXIMUM VALUE CONSIDERATION
*                    ===========================
* 
*   - IMAGE MAXIMUM VALUE:
* 
*     MAXIMUM NUMBER OF DATA-SET PER DATA-BASE  :  50 
*     MAXIMUM NUMBER OF ITEM PER DATA-BASE      : 255 
*     MAXIMUM NUMBER OF ITEM PER DATA-SET ENTRY : 127 
* 
*     MAXIMUM ENTRY LENGTH                      : 512 WORDS 
*     MAXIMUM ITEM LENGTH                       : 128 WORDS 
* 
* 
*   - TMS-IMAGE COMMUNICATION MAXIMUM BUFFER LENGTH:
* 
*     MAXIMUM BUFFER LENGTH RECEIVED BY THIS PROGRAM IS 
*     FOR A  DBGET CALL : 1+1+2+23+543 = 570 = RBULN
*     WHERE 1,1,2,23 ARE TMS INTERNAL BUFFER
*     AND 512 IS IVALUE (MAX ENTRY LENGTH)
* 
*     MAXIMUM BUFFER LENGTH SEND BY THIS PROGRAM IS 
*     FOR A  DBGET CALL : 2+23+515 = 540 = SBULN
*     WHERE 2,23 ARE TMS INTERNAL BUFFER
*     AND 512 IS THE ENTRY VALUE (MAX ENTRY LENGTH) 
*     ANY BUFFER RETURNED BY  DBINF SHOULD BE SMALLER THAN THAT.
   SKP
      LDA LOCTB     GET FWA OF BUFFER 
      LDB PROTB     GET LWA OF BUFFER 
      CMB,INB 
      ADB LOCTB     COMPUTE LENGTH
      STA PT        SAVE FWA
      CLA 
      STA PT,I
      ISZ PT        CLEAR THE BUFFER
      INB,SZB 
      JMP *-3 
      JMP DEB05 
   SPC 3
ILSHR LDA P1        SET UP LU 
      SZA,RSS 
ILSH3 CLA,INA 
      LDB LU
      STA LU
      STB P1
ILSH5 LDA .ILIS     SET PROGRAM NAME IN THE MESSAGE 
      LDB .MES1 
      MVW D3
      JSB WRTTY     OUTPUT
.MES  DEF MES       "ILLEGAL SHCEDULE REQUEST"
      DEF D18 
      LDA ACTIV     GET ACTIVE FLAG 
      SZA,RSS       PROGRAM ACTIVE ?
      JSB ABORT     NO, TERMINATE PROGRAM 
      LDA P1
      STA LU
      JMP EXIT4     YES, SAVE SUSPENSION POINT
* 
MES   ASC 5, /XXXXX : 
      ASC 13,ILLEGAL SCHEDULE REQUEST ! 
.MES1 DEF MES+1 
* 
ILIST DEC 1 
      BSS 3 
* 
SBULN DEC 540       MAX BUF LEN TO SEND 
RBULN DEC 570       MAX BUF LEN TO RECEIVE
* 
* STATUS BUFFER 
* 
ISTAT BSS 10
* 
* DBINF BUFFER
* 
ISINF BSS 17
* 
CLASS NOP 
LGCLA NOP 
DMDLK NOP           LOCK FLAG 
.DMDL NOP 
* 
  SPC 1 
P1    BSS 3         PARAMETERS GET BY RMPAR 
CLAS# OCT 0         P4 MAY BE THE CLASS I/O WORD
      NOP 
   HED T-M  LIBRARY  <--->   TMS-IMAGE MODULE   COMMUNICATION 
EXIT5 ADA D2        ADJUST MAIL BOX LENGTH
      CLB 
      STB ERCOD     NO FATAL ERROR REPORTED 
      LDB SCODE     RETURN THE TMS-IMSGE-RQ-CODE
      STB ERCOD+1   TO THE CALLER 
  SPC 1 
EXIT6 STA LTEM      SET MAIL BOX LENGTH 
* 
      LDA CLAS#     RELEASE CLASS I/O IF NOT ALREADY DONE 
      JSB KLCLX 
      LDA ECLAS     RECALL CLASS I/O THAT SHOULD BE USED
      STA CLAS#     TO SEND THE RESULT
      LDA PARM      SET UP OPTIONAL CLASS I/0 PARAMETERS
      LDB PARM+1    WITH THOSE SUPPLIED BY THE USER 
      JSB PSAM      SEND ANSWER TO THE USER USING HIS CLASS I/O 
      DEF ERCOD     BUFFER ADDR 
LTEM  NOP           BUFFER LENGTH 
  SPC 1 
EXIT3 LDA RSTAR,I   GET RESTART QUEUE HEAD
      SZA,RSS       SOMETHING TO RESTART ?
      JMP EXIT4     NO, EXIT
      RAL,CLE,ERA   YES, CLEAR BIT 15 
      LDB A,I       REMOVE THAT PROCESS FROM THE
      STB RSTAR,I   RESTART QUEUE 
      CLB 
      STB A,I       CLEAR LINK WORD IN THE PROCESS DIRECTORY
      INA 
      LDB A,I       RECALL CLASS I/O
      STB CLAS#     SET CLASS I/O WORD
      CLB 
      STB A,I       CLEAR CALL I/O IN THE PROCESS DIRECTORY 
      LDA CLAS#     SET CLASS I/O WORD IN A REG.
      JMP DEB15     AND RESTART PROGRAM 
  SPC 1 
EXIT4 LDA CLASS     TRY TO GET A REQUEST ON THE SPECIAL CLASS 
      JSB GSAM      GET NO-WAIT & NO-ABORT
      SSA,RSS       SOMETHING GET ? 
      JMP DEB20     YES, GO PROCESS REQUEST 
* 
RTNFL OCT 0         RETURN FLAG (NOP/RSS) TO RTN PARAM TO CALLER
      JMP EXIT9     IF NOP; EXIT WITHOUT  'PRTN'
* 
SPCLF RSS           CLEARED ONLY WHEN SPECIAL CLOSE 
      JMP SPCLS     REQUEST IS REQUESTED, RETURN TO SPECIAL PROCESS 
* 
      JSB PRTN      SEND RETURN PARAMETERS TO CALLER
      DEF *+2 
      DEF RTPAR     RETURN PARAMETRS BUFFER 
* 
EXIT9 LDA DMDLK     CHECK DEMAND LOCK FLAG
      SLA,RSS       DEMAND LOCKING SPECIFIED? 
      JMP EXI10        NO, TERMINATE
      LDA LKTOT        YES, ARE THERE ANY LOCKED RECS?
      SZA 
      JMP EXI10           YES, DONOT UNLOCK D.B.
      LDA LKFLG           NO, IS THE D.B. ALREADY UNLOCKED? 
      SZA,RSS 
      JMP EXI10               YES, SKIP UNLOCK
      JSB DBUNL               NO LOCKED RECS, UNLOCK D.B. 
      DEF *+5 
      DEF IBASE 
      DEF NCHRS        DUMMY
      DEF D1
      DEF BTEMP 
* 
      CLA 
      STA LKFLG        SET LOCK FLAG TO INDICATE THAT D.B. IS UNLOCKED
      LDA LGCLA        LOGGING? 
      SZA,RSS 
      JMP EXI10           NO, FINISH UP 
      CCA                 YES, LOG UNLOCK 
      STA SCODE        SAVE UNLOCK CODE 
      LDA D32          GET BUFFER LENGTH TO SEND TO DCLOG 
      CLB              DO NOT RETURN TO ANY PROG
      JSB DBLOG        LOG DATA 
* 
EXI10 JSB EXEC      COMPLETE THIS PROGRAM 
      DEF *+4       SAVING SUSPENSION POINT.
      DEF D6
.D0   DEF D0
      DEF D1
  SPC 1 
****************************************************************
  SPC 1 
      JSB RMPAR     RETREIVE SCHEDULE PARAMETERS
      DEF *+2 
      DEF P1        SAVE PARAMETER
* 
DEB05 CLA           SET RETURN FLAG TO NOT USE 'PRTN' 
      STA RTNFL 
  SPC 1 
      JSB EXEC      GET STRING REQUEST
      DEF *+5 
      DEF D14 
      DEF D1
.SCOD DEF SCODE     BUFFER ADDR 
      DEF RBULN     BUFFER LENGTH 
      DST PARM1     SAVE STATUS & LENGTH
      SZA,RSS       STRING GET SUCCED ? 
      JMP DEB18     YES, GO PROCESS REQUEST 
* 
      LDA CLAS#     NO STRING, CHECK FOR A MAIL BOX 
      CPA DM1       WANTS TO GET FROM THE SPECIAL CLASS ? 
      JMP EXIT4     YES, GO DO THE GET
      SZA,RSS       CLASS I/O DEFINED ? 
      JMP ILSH3     NO, PRINT 'ILLEGAL SCHEDULE REQUEST'
DEB15 AND B1.47   YES, RELEASE BUFFER ON THE NEXT GET 
      IOR B20K      BUT DO NOT DEALLOCATE THE CLASS I/O 
      JSB GSAM      GET  NO-WAIT & NO-ABORT 
      SSA           SOMETHING GET ? 
      JMP ILSH3     NO, PRINT MESSAGE AND EXIT
      JMP DEB25     YES, PROCESS THE REQUEST
   SPC 2
DEB18 BLS           SET TLOG IN CHARACTERS
      LDA .SCOD     BUFFER ADDR 
      JSB $PARS     PARSE THE BUFFER
      DEF BTEMP     AND STORE RESULTE INTO  BTEMP 
* 
      LDA BTEMP+1   RECALL FIRST PARAM VALUE
      CPA ARU       IS IT A "RU, .... " COMMAND ? 
      JMP SPCL3     YES, CHECK FOR EMERGENCY PROCEDURE
  SPC 1 
DEB20 CLA           NO CLASS I/O IS DEFINE IN THAT WORD 
      STA CLAS# 
  SPC 2 
DEB25 NOP 
*     JSB DMPTM 
*     DEF *+7 
*     DEF D6
*     DEF SCODE 
*     DEF SMWDS 
*     DEF MNMES 
*     DEF D20 
*     DEF D1
*     JSB DBUGR 
*     DEF *+2 
*     DEF D21 
      LDA SCODE     GET REQUEST CODE
      SSA           NEGATIVE ?
      JMP ILSH3     YES, ERROR
      ADA DM10      .GE. 10 
      SSA,RSS 
      JMP ILSH3     YES, ERROR
      LDA SCODE     NO, RECALL SUBROUTINE CODE
      LDB ACTIV     RECALL ACTIVE FLAG
      SZB           DATA BASE OPEN ?
      JMP DEB30     YES, CONTINUE 
      SZA,RSS       NO, OPEN REQUEST ?
      JMP XDBOP        YES, PROCESS 
      CPA D9           NO, IS IT VERIFY REQUEST?
      JMP XDBVF           YES, PROCESS
      JMP ER452     NO, REJECT THIS CALL
  SPC 1 
DEB30 ADA C.TAB     INDEX IN TABLE
      JMP A,I 
*NMES ASC 10,1$ITMS DATA
  HED  EMERGENCY CLOSE PROCEDURE
SPCL3 LDA BTEMP+8   VERIFY THAT THE 1ST PARAM 
      SZA           IS NOT DEFINED
      JMP ILSH3     ERROR ! 
      LDA BTEMP+12  VERIFY THAT THE 2ND PARAM 
      SZA           IS NOT DEFINED
      JMP ILSHR     ERROR ! 
      LDA BTEMP+16  VERIFY THAT THE 3RD PARAM 
      ADA BTEMP+17  IS "1"
      CPA D2        COMPARE  TYPE+VALUE 
      RSS           OK, DO SPECIAL CLOSE REQUEST
      JMP ILSHR 
  SPC 1 
      LDA P1        RECALL LU 
      SZA,RSS 
      CLA,INA 
      LDB LU
      STA LU        SAVE LU 
      STB P1
      IOR B400
      STA P1+1      SAVE LU FOR INPUT 
  SPC 1 
      LDA ACTIV     DATA-BASE OPEN
      SZA,RSS       OPEN ?
      JMP SPCL9     NO, REPORT ERROR
  SPC 1 
SPCL5 JSB WRTTY     PRINT "DATA-BASE="
      DEF MSDB      BUFFER
      DEF D7
      JSB SPCL0     READ AND PARSE ANSWER 
      CPB D2        ASCII ? 
      RSS           YES, OK 
      JMP SPCL5     NO, TRY AGAIN 
      LDB .DBNM     CHECK IF CORRECT
      CMW D3
      JMP SPCL6     OK, ASK LEVEL WORD
      NOP           DOES NOT MATCH
      JMP ILSH5     REJECT THE SHEDULE REQUEST
* 
SPCL6 JSB WRTTY     PRINT "LEVEL =" 
      DEF MSLE
      DEF D5
      JSB SPCL0     READ AND PARSE ANSWER 
      SZB,RSS       NUL ? 
      LDA .SP       YES, TAKE DEFAULT ASCII VALUE 
      SZB 
      CPB D2        ASCII ? 
      RSS           YES, OK 
      JMP SPCL6     NO, TRY AGAIN 
      LDB .DBN3     CHECK IF CORRECT
      CMW D3
      JMP SPCL7     OK, ASK SEC. CODE 
      NOP           DO NOT COMPARE
      JMP ILSH5     REJECT THE SHEDULE REQUEST
* 
SPCL7 JSB WRTTY     PRINT "SEC.-CODE="
      DEF MSSC      BUFFER
      DEF D7
      JSB SPCL0     READ AND PARSE ANSWER 
      SZB,RSS       NUL ? 
      JMP SPCL7     YES, RE-ISSUE MESAGE
      LDB A,I       CHECK IF CORRECT
      CPB DBNAM+6 
      RSS 
      JMP ILSH5     REJECT THE SHEDULE REQUEST
* 
SPC71 JSB WRTTY     PRINT "CR-NO. ="
      DEF MSCR      MESSAGE BUFFER
      DEF D6
      JSB SPCL0     GET ANSWER
      SZB,RSS       NUL ? 
      JMP SPC71     YES, RE-ISSUE MESSAGE 
      LDB A,I       VERIFY CR. NO.
      CPB DBNAM+7 
      RSS 
      JMP ILSH5     REJECT SCHEDULE REQUEST 
* 
      CLA,INA       SET SCODE FOR  DBCLOSE
      STA SCODE 
      CLA           SET SPECIAL CLOSE FLAG
      STA SPCLF     TO RETURN AFTER THE CLOSE 
      LDA IBASE     SET IMAGE INTERNAL DB#
      STA SCODE+2 
      JMP XDBC0 
* 
SPCLS LDA .DBNM     MOVE DATA-BASE NAME INTO THE MESSAGE
      LDB .MS9X 
      MVW D3
      LDA RTPAR     RECALL DBCLOSE IMAGE STATUS 
      SSA           OK ?
      JMP SPCL8     YES, PRINT MESSAGE
      STA TEMP
      JSB JASC
      DEF *+5 
      DEF TEMP
      DEF MS9+17
      DEF D1
      DEF D6
      LDA .MS8
      LDB .MS9Y 
      MVW D8
SPCL8 JSB WRTTY     PRINT "DATA-BASE XXXXXX SUCCESSFULLY CLOSE" 
      DEF MS9 
      DEF D20 
      JMP EXI10 
  SPC 1 
SPCL9 JSB WRTTY     PRINT "NO DATA-BASE CURRENTLY OPEN" 
      DEF MS7 
      DEF D16 
      JSB ABORT     TERMINATE PROGRAM 
      JMP EXI10 
  SPC 1 
MSDB  ASC 6, DATA-BASE =
      OCT 20137 
MSLE  ASC 4, LEVEL =
      OCT 20137 
MSSC  ASC 6, SEC.-CODE =
      OCT 20137 
MSCR  ASC 5, CR.-NO. =
      OCT 20137 
MS9   ASC 20, DATA-BASE: XXXXXX SUCCESSFULLY CLOSED.
MS7   ASC 16, NO DATA-BASE CURRENTLY OPEN ! 
.MS8  DEF *+1 
      ASC 8,; CLOSE ERROR : 
.SP   DEF *+1 
      ASC 3,
.MS9Y DEF MS9+9 
.MS9X DEF MS9+6 
ARU   ASC 1,RU
.DBN3 DEF DBNAM+3 
  SPC 1 
SPCL0 NOP 
      JSB EXEC      READ ANSWER 
      DEF *+5 
      DEF D1
      DEF P1+1
.BUF  DEF BUF 
      DEF DM7 
      LDA .BUF      RECALL BUFFER ADDR
      JSB $PARS     PARSE BUFFER
      DEF BTEMP     OUTPUT BUFFER 
      LDA .BTE1     ADDR. OF DATA 
      LDB BTEMP     TYPE OF DATA
      JMP SPCL0,I 
* 
.BTE1 DEF BTEMP+1 
  HED  IMAGE / INTERNAL  ERROR PROCESSING 
ERR?  NOP           FOR INTERNAL IMAGE RQ, CHECK STATUS 
      LDA ISTAT     RECALL IMAGE STATUS 
      JSB .ERR? 
      JMP ERR?,I
  SPC 2 
*                   FATAL ERROR PROCESSING  --->  ABORT CALLER
* 
.ERR? NOP 
      SZA,RSS       OK ?
      JMP .ERR?,I   YES, CONTINUE 
EROR  STA ISTAT 
      LDB SCODE 
      SZB,RSS       OPEN REQUEST ?
      JMP XDBC0     YES, CLOSE DATA BASE AND CLEAN UP IF NECESSARY
      CPB D1        CLOSE REQUEST ? 
      JMP RTPRG 
      CPB D8        TBULK REQUEST ? 
      JMP RTPRG 
      DST ERCOD     SET UP ERROR CODE & REQUEST CODE
      STA BTEMP+BTSTA  SET UP IMAGE ERROR STATUS
      LDB LCKID     PASS BACK THE LOCK-ID WORD
      STB BTEMP+BTLID  (IT IS PROC. INDEX DIRECTORY:  PID)
      LDB LCKID+1   PASS BACK THE IMAGE INTERNAL D.B. NO. 
      STB BTEMP+BTIDB 
      LDA D24       SET BUFFER LENGTH 
      JMP EXIT6     AND GO SEND THE ANSWER TO THE CALLER
  SPC 1 
ER452 JSB ABORT     TERMINATE THE PROGRAM 
      LDA D452     DATA-BASE HAS NOT BEEN OPENED
      JMP EROR
  SPC 2 
*                   IMAGE ERROR PROCESSING  --->  THE ERROR NUMBER
*                        IS RETURNED TO THE USER, IN PLACE OF 
*                        THE IMAGE STATUS.
SIMST STA BTEMP+BTSTA 
      JMP XDBF3     RETURN
* 
* 
*                TERMINATE THIS PROGRAM WITHOUT ANY OPTION
*                TO MAKE IT ACTUALLY DORMANT. 
  SPC 1 
ABORT NOP 
      LDA .D0 
      STA .D0+1     SUPPRESS TERMINATE OPTION 
      JMP ABORT,I   AND TERMINATE PROGRAM.
  SPC 1 
RSTAR DEF *+1       RESTART PROCESS QUEUE 
      OCT 0 
  SPC 1 
ACTIV OCT 0         # OF OPEN/CLOSE REQUEST 
  HED DBOPN PROCESSOR 
* 
*     INPUT BUFFER FORMAT:
* 
*                   SCODE        (4)  RQ/CLASS#/PARM1/PARM2 
*                   BUF[1:3]     (3)  DATA-BASE NAME
*                   BUF[4:6]     (3)  LEVEL ACCESS WORD 
*                   BUF[7]       (1)  SECURITY CODE 
*                   BUF[8]       (1)  CARTRIDGE NO. 
*                   BUF[9]       (1)  DS NODE NO. (NOT USED)
*                   BUF[10]      (1)  D.B. OPEN MODE
* 
* OFFSETS INTO BUF
* 
BFDBN EQU 0         DATA BASE NAME OFFSET 
BFLEV EQU 3         LEVEL ACCESS WORD OFFSET
BFSEC EQU 6         SECURITY CODE OFFSET
BFCRN EQU 7         CARTRIDGE NO. OFFSET
BFNOD EQU 8         DS NODE  OFFSET 
BFMD1 EQU 9         OPEN MODE OFFSET
  SPC 1 
*     RETURN VALUE USING 'PRTN' SUBROUTINE: 
* 
*                   RTPAR[1]     (1)  NEG IMAGE INTERNAL DB# / POS ERR CODE 
*                                     DB# IF OK, ERROR CODE IF ERROR
*                   RTPAR[2]     (1)  CLASS IO WD / TMS SUBROUTINE NO.
*                                     CLASS IO IF OK, SUB NO. IF ERROR
*                   RTPAR[3]     (1)  DATA-BASE CRC 
*                   RTPAR[4]     (1)  MAXIMUM ITEM LENGTH 
*                   RTPAR[5]     (1)  MAXIMUM ENTRY LENGTH
* 
* OFFSETS INTO RTPAR
* 
RTERR EQU 0         IMAGE INTERNAL DB# / ERROR CODE 
RTCLA EQU 1         CLASS IO WORD / TMS SUBROUTINE NO.
RTCRC EQU 2         DATA BASE CRC 
RTILN EQU 3         MAX ITEM LENGTH 
RTELN EQU 4         MAX ENTRY LENGTH
  SPC 1 
XDBOP LDA CLAS#     RELEASE MAIL BOX & CLASS
      JSB KLCLX 
* 
      LDA .BUF      GET ADDR OF DB NAMR SUPPLIED BY USER
      LDB .DBNM     GET ADDR OF DB NAMR SUPPLIED BY TMPGN 
      CMW D8        SAME ?
      JMP XDBOK        YES, KEEP PROCESSING 
      NOP              NO, ERROR #451 
      LDA ACTIV        IS DB ALREADY OPEN?
      SZA,RSS   
      JSB ABORT           NO, ABORT 
      LDA D451         GET ERROR CODE 451 
      JMP XDBER        PROCESS ERROR
* 
XDBOK LDA ACTIV     GET ACTIVE FLAG 
      SZA           IS IT THE FIRST ENTRY ? 
*     JMP XDBO4        NO, CHECK THAT IT IS THE SAME DATA BASE  
      JMP XDBO5        NO, CHECK MODE TO SEE THAT IT MATCHES
  SPC 1 
      LDA BUF+BFMD1    YES, FIRST OPEN CALL, SAVE MODE
      STA MODE
* 
      LDA MODE      GET OPEN MODE 
      SSA           IS IT NEG?
      CMA,INA          YES, GET ABS VALUE 
      STA MOD1      SAVE
* 
      JSB BLANC     CREATE DB NAMR FROM NAME, SEC CODE, CR NO.
      DEF *+3 
      DEF IBASE 
      DEF D11 
* 
*     LDA BUF+BFNOD     CHECK DS NODE NO. 
*     SZA 
*     STA IBASE 
* 
      LDA .BUF
      LDB .IBA1 
      MVW D3            MOVE NAME INTO NAMR ARRAY 
* 
      INB 
      CBX               SAVE SEC CODE ADDR
      LDB .ILEV         GET LEVEL ACCESS WD ADDR
      MVW D3
      CXB 
* 
      MVW D2            MOVE SEC CODE AND CR NO. INTO NAMR ARRAY
* 
      LDA B27           GET PARSE CODE (ASCII, INTEGER, INTEGER)
      ADB DM3           POINT TO PARAMETER TYPE FIELD 
      STA B,I           SET PARAMETER TYPE
* 
      CLA 
      STA NCHRS 
      JSB INAMR         CREATE NAMR 
      DEF *+5 
      DEF IBAS1 
      DEF IBASE+1 
      DEF D20 
      DEF NCHRS 
* 
  SPC 1 
      JSB DBOPN     OPEN THE DATA BASE
      DEF *+5 
      DEF IBASE     DATA BASE NAMR
      DEF BUF+BFLEV LEVEL ACCESS WORD 
      DEF MOD1      MODE
      DEF ISTAT     STATUS
      JSB ERR?      OK? 
      LDA ISTAT+1   RECALL LEVEL ACCESS 
      CPA D15      IS IT THE HIGHEST LEVEL ?
      JMP XDBO0     YES, CHECK THE OPEN MODE
      LDA D451      NO, DBOPN ERR# 451: BAD LEVEL ACCESS WORD 
      JMP EROR      PASSES ERROR BACK TO CALLING PRG & TERMINATE
  SPC 1 
XDBO0 LDA MOD1      GET MODE
      CPA D1        MODE 1 (SHARED READ/WRITE) ?
      JMP XDBO1        YES, LOCK DATA BASE, ENABLE RECORD LOCKING 
      CLA              NO, DISABLE DEMAND LOCKING 
      STA DMDLK 
      JMP XDBO2 
* 
XDBO1 CLA           ENABLE RECORD LOCKING 
      STA LOCK1 
      STA LKTOT     SET NO. OF RECS LOCKED TO 0 
      STA LKFLG     SET LOCK FLAG TO INDICATE THAT D.B. IS UNLOCKED 
      LDA DMDLK     GET DEMAND LOCK FLAG
      SLA 
      JMP XDBO2     DEMAND LOCKING, DO NOT LOCK D.B. NOW
      JSB DBLCK     LOCK THE WHOLE DATA BASE
      DEF *+5 
      DEF IBASE 
      DEF NCHRS     USED AS DUMMY VARIABLE
      DEF D2        LOCK WITHOUT WAIT 
      DEF ISTAT 
      JSB ERR?      ERROR?
      CLA,INA 
      STA LKFLG     SET LOCK FLAG TO INDICATE THAT D.B. IS LOCKED 
* 
XDBO2 JSB DBCRC     CALCULATE THE DATA-BASE CRC 
      DEF *+6       AND RETURN MAXIMUM VALUE
      DEF IBASE     DATA BASE NAMR
      DEF RTPAR+RTCRC  CRC
      DEF RTPAR+RTILN  MAX ITEM LENGTH
      DEF RTPAR+RTELN  MAX ENTRY LENGTH 
      DEF ISTAT     STATUS
      JSB ERR?      OK ?
*     CHECK FOR MAX ENTRY LEN .LE. 512
* 
      LDA RTPAR+RTELN 
      CMA,INA 
      ADA D512
      SSA,RSS 
      JMP XDBO3 
      LDA D512
      STA RTPAR+RTELN 
* 
XDBO3 LDA MODE      GET OPEN MODE 
      CPA DM3       EXCLUSIVE OPEN WITH LOGGING BYPASS ?
      JMP XDBO7     YES, SKIP LOG FILE INITIALIZATION 
* 
      LDA .LNAM,I   LOGGING USED? 
      SZA,RSS 
      JMP XDBO7        NO, SKIP THE LOGGING OF THE DATABASE OPEN
      CLA              YES, OPEN LOG FILE 
      JSB OPLOG 
.LNAM NOP           NAME OR DEV LU
      DEF P1        CONSOLE LU
      STB LGCLA     SAVE CLASS IO WD
      JSB .ERR?     CHECK FOR ERROR 
* 
      LDA D32       GET WORD COUNT
      CLB           GET RETURN CLASS
      JSB DBLOG     LOG DATA
* 
XDBO7 JSB GTCLW     ALLOCATE CLASS IO WD
      STA CLASS     SAVE
* 
OKOPN ISZ ACTIV     BUMP ACTIVE FLAG
      LDB CLASS     RETURN SPECIAL CLASS# TO CALLER 
OKRTN LDA IBASE     RETURN GOOD STATUS (NEG IMAGE INTERNAL DB#) 
      CMA,INA 
   SPC 1
RTPRG DST RTPAR     SAVE RETURN PARAMETERS
      LDA .RSS      AND SET THE RETURN FLAG TO
      STA RTNFL     USE 'PRTN' SUBROUTINE 
      JMP EXIT3     RETURN
  SPC 2 
*XDBO4 LDA .BUF      CHECK THAT NAME, LEVEL AC WD, SEC CODE, CR NO.,  
*     LDB .DBNM     AND NODE NO. ARE THE SAME 
*     CMW D9
*     JMP XDBO5     OK, SAME DATA-BASE, CHECK OPEN MODE 
*     NOP           NOT THE SAME
*     LDA D451      DBOPN ERR# 451: OPEN AN OTHER DATA BASE 
*     JMP XDBER 
* 
XDBO5 LDB BUF+BFMD1 GET USER OPEN MODE
      CPB MODE      SAME AS D.B. OPEN MODE? 
      JMP XDBO6        YES, CHECK THAT IT IS NOT MODE 3 
      LDA D152         NO, ERROR 152, INCOMPATIBLE OPEN MODE
      JMP XDBER 
* 
XDBO6 LDB MOD1
      CPB D3        MODE 3? 
      RSS              YES, ERROR 
      JMP OKOPN        NO, OK 
      LDA D150      ERROR 150, D.B. IS OPENED EXCLUSIVELY TO OTHER USER 
* 
XDBER LDB SCODE     OPEN ERROR, RETURN BAD STATUS 
      JMP RTPRG 
  SPC 1 
RTPAR BSS 5 
.RSS  RSS 
.DBNM DEF DBNAM 
DBNAM ASC 6,......  DB NAME AND LEVEL ACCESS WD 
      OCT 0         SEC CODE
      OCT 0         CR NO.
      OCT 0         D.S. NODE (NOT USED)
MODE  OCT 0         OPEN MODE 
MOD1  BSS 1 
NCHRS BSS 1         SCRATCH CHARACTER COUNT 
IBAS1 BSS 10        SCRATCH NAMR ARRAY
.IBA1 DEF IBAS1 
  HED DBCLS PROCESSOR 
* 
*     INPUT BUFFER FORMAT:
* 
*                   SCODE        (4)  RQ/CLASS#/PARM1/PARM2 
   SPC 1
*     RETURN VALUE USING 'PRTN' SUBROUTINE: 
* 
*                   RTPAR[1]     (1)  0 / ERROR CODE
*                   RTPAR[2]     (1)  CLASS IO WD / TMS SUB CODE
*                                     CLASS IO IF OK, SUB CODE IF ERR 
* 
* NOTE: THE DATA SET CLOSE FEATURE HAS NOT BEEN IMPLEMENTED.
  SPC 1 
XDBCL LDA CLAS#     RELEASE MAIL BOX & CLASS I/O
      JSB KLCLX 
* 
      CCA           DECREMENT ACTIVE FLAG 
      ADA ACTIV 
      STA ACTIV 
      SZA           LAST DBCLS REQUEST ?
      JMP OKRTN     NO, FORGET THE REQUEST
  SPC 1 
XDBC0 JSB ABORT     SET UP TO TERMINATE PROGRAM 
* 
*     JSB DMPTM 
*     DEF *+7 
*     DEF D6
*     DEF BUF 
*     DEF D22 
*     DEF MSDB2 
*     DEF D10 
*     DEF D1
      JSB DBCLS     CLOSE THE DATA BASE 
      DEF *+5 
      DEF IBASE     IMAGE INTERNAL DB#
      DEF D1        DUMMY 
      DEF D1        CLOSE ALL FILES 
      DEF IBAS1     DUMMY STATUS (NO CHECK IS MADE) 
*     JSB DMPTM 
*     DEF *+7 
*     DEF D6
*     DEF ISTAT 
*     DEF D10 
*     DEF MSDB1 
*     DEF D10 
*     DEF D0
  SPC 1 
      LDA CLASS     RELEASE THE CLASS I/O 
      JSB KLCLX 
      CLA 
      STA CLASS 
  SPC 1 
      LDB PROTB     RELEASE CLASS I/O USED TO SUSPEND 
XDBC3 CPB PROTE     PROCESSES: END OF DIRECTORY ? 
      JMP XDBC8     YES, TERMINATE THE PROGRAM
* 
      ADB DM1 
      LDA B,I       GET CLASS I/O WORD
      ADB DM2       BUMP POINTER
      SZA,RSS       CLASS HERE ?
      JMP XDBC3     NO, SKIP RELEASE
      STB TEMP      SAVE POINTER
      JSB KLCLX     YES, DEALLOCATE THE CLASS 
      LDB TEMP      AND CONTINUE
      JMP XDBC3 
  SPC 1 
XDBC8 CLA           THE RESTART QUEUE IS EMPTY !
      STA RSTAR,I 
      STA DMDLK     DISABLE LOCK ON DEMAND
* 
      LDA LGCLA        YES, CHECK FOR LOGGING 
      SZA,RSS 
      JMP XDBC9           NO LOGGING, RETURN IMMEDIATELY
      LDA D32             LOGGING USED, GET WORD COUNT OF BUFFER
      CLB                 SET RETURN CLASS TO 0 
      JSB DBLOG     LOG THIS OPERATION
* 
      CLA,INA       SET TERMINATE FLAG
      JSB OPLOG     CLOSE LOG FILE
      DEF .LNAM,I 
      DEF P1
      CLA 
      STA LGCLA     CLEAR LOGGING CLASS 
* 
XDBC9 LDB SCODE     GET OPERATION 
      CPB D1        NORMAL CLOSE (SPECIFIC CLOSE REQUEST?)
      JMP OKRTN        YES, RETURN
      LDA ISTAT        NO, GET ERROR CODE 
      JMP RTPRG     RETURN ERROR STATUS 
  HED TBULK PROCESSOR 
* 
*     INPUT BUFFER FORMAT:
* 
*                   SCODE        (1)  SUBROUTINE CODE 
*                   ECLAS        (1)  LOCKID WORD 
   SPC 1
*     RETURN VALUE USING 'PRTN' SUBROUTINE: 
* 
*                   RTPAR[1]     (1)  0 / ERROR CODE
*                   RTPAR[2]     (1)  TMS-SUBROUTINE CODE IF ERROR
  SPC 1 
XTBUL LDA CLAS#     RELEASE MAIL BOX & CLASS I/O
      JSB KLCLX 
* 
      LDA D2        FORCE LOCKW TO UNLOCK REQUEST 
      LDB ECLAS     GET THE LOCKID WORD 
      DST LOCKW     AND STORE THEM WHERE THEY USE TO BE 
* 
      JSB SPIDD     ACCESS PROCESS ID DIRECTORY 
      JMP UNLER         ERROR 404, TRY TO UNLOCK WITH OUT HAVING LOCK ID
  SPC 1 
      LDA PIDPT,I   RECALL # OF RECORDS LOCKED BY 
      RAL,CLE,ERA   THIS PROCESS
      STA PIDPT,I   AND CLEAR BIT 15 (BIT X)
      SZA,RSS       ANY RECORD OWNED ?
      JMP OKRTN     NO, RETURN
      LDA LOCTB     YES, SEARCH ALL THOSE ENTRY IN THE LOCK TABLE 
      STA PT0       INIT STARTING OF LOCK TABLE ADDR. 
* 
XTBU3 STA PT        SET POINTER FOR UNLCK ROUTINE 
      CPA LOCTE     END OF LOCK TABLE ? 
      JMP UNLE1     YES, ERROR 461, CORRUPT DATA STRUCTURES 
      LDA PT,I      GET ENTRY FROM THE LOCK TABLE 
      ALF,ALF 
      AND B377     ISOLATE PIDX 
      CPA PIDX      ENTRY BELONG TO THIS PROCESS ?
      JSB UNLCK     YES, RELEASE ENTRY
      LDA PIDPT,I   RECALL # OF RECORD LOCKED 
      SZA,RSS       ALL RELEASED ?
      JMP OKRTN     YES, RETURN 
      LDA PT        NO, CONTINUE
      ADA D3        BUMP POINTER
      JMP XTBU3 
* 
UNLER LDA D404      ERROR 404, TRY TO UNLOCK WITHOUT LOCK ID
      JMP EROR
UNLE1 LDA D461      CORRUPT DATA STRUCTURES 
      JMP EROR
  HED  DBGET PROCESSOR
* 
*     INPUT BUFFER FORMAT:
* 
*                   SCODE        (4)  RQ/CLASS#/PARM1/PARM2 
*                   BUF[1]       (1)  LOCK WORD 
*                   BUF[2]       (1)  TMS LOCK ID (TMS DB# / DS#) 
*                   BUF[3]       (1)  IMAGE INTERNAL DB#
*                   BUF[4:6]     (3)  SCRATCH AREA
*                   BUF[7:13]    (7)  IMAGE RUN TABLE 
*                   BUF[14]      (1)  DBGET MODE
*                   BUF[15:22]   (8)  DATA SET NAME 
*                   BUF[23]      (1)  ILIST LENGTH
*                   BUF[24:X]    (N)  ILIST 
*                   BUF[X+1:Y]   (M)  IARG
* 
* OFFSETS INTO BUF
* 
BFLKW EQU 0         TMS LOCK WORD 
BFLID EQU 1         TMS LOCK ID (TMS DB# / LOCK ID) 
BFIDB EQU 2         IMAGE INTERNAL DB#
BFSCR EQU 3         SCRATCH WORDS (3) 
BFIRT EQU 6         IMAGE RUN TABLE 
BFMOD EQU 13        MODE
BFDSN EQU 14        DATA SET NAME 
BFNLL EQU 22        NAME LIST (ILIST) LENGTH
BFNLS EQU 23        NAME LIST (ILIST) 
* 
* OFFSETS INTO IMAGE RUNTABLE 
* 
RTCRR EQU 0         CURRENT RECORD IN CHAIN 
RTPRR EQU 2         PREVIOUS RECORD IN CHAIN
RTNXR EQU 4         NEXT RECORD IN CHAIN
RTCCP EQU 6         CURRENT CHAIN POINTER 
  SPC 1 
*     OUTPUT BUFFER FORMAT: 
* 
*                   ERCOD        (2)  ERROR CODE/SUB # (TMS INTERNAL) 
*                   BTEMP[1:10]  (10) IMAGE STATUS  
*                   BTEMP[11]    (1)  LOCK ID 
*                   BTEMP[12]    (1)  IMAGE INTERNAL DB#
*                   BTEMP[13:15] (3)  SCRATCH WORDS 
*                   BTEMP[16:22] (7)  IMAGE RUN TABLE 
*                   BTEMP[23]    (1)  ENTRY LENGTH
*                   BTEMP[24:X]  (N)  DATA RETREIVED (ENTRY VALUE)
* 
* OFFSETS INTO BTEMP
* 
BTLID EQU 10        LOCK ID  OFFSET 
BTIDB EQU 11        IMAGE INTERNAL DB#
BTSCR EQU 12        SCRATCH WORDS 
BTIRT EQU 15        IMAGE RUN TABLE 
BTSTA EQU 0         IMAGE STATUS
BTELN EQU 22        ENTRY LENGTH
BTDAT EQU 23        DATA RETREIVED
* 
*       LOGIC TO RELEASE PREV AND NEXT RECS ON CHAINED READS MAY BE 
*       NECESSARY.
  SPC 1 
XDBGE JSB LCKDB     LOCK DATA BASE IF NECESSARY 
      DEF BUF+BFLKW      LOCK WORD
      LDA .BDSN     GET DATA SET NAME 
      JSB DSNUM     ---> DATA SET NUMBER (INTO DS#) 
* 
      LDA BUF+BFNLL  GET ILIST LENGTH 
      ADA .GET1      AND CALCULATE START ADDR OF IARG 
      STA .GET2 
* 
      LDA BUF+BFMOD RECALL MODE 
      STA LOCKM     SAVE
      CPA D4
      JMP XDBG2     DIRECTED READ 
      CPA D7
      JMP XDBG2     KEYED READ
      JSB RSTRT     YES, RESTORE RUN TABLE FOR RE-READ, CHAINED READS,
*                        AND SEQUENTIAL READS 
      JMP XDBU7     ERROR RETURN
  SPC 1 
XDBG2 JSB DBGET     READ FROM DATA BASE 
      DEF *+8 
      DEF BUF+BFIDB 
      DEF DS#       DATA SET NUMBER 
      DEF BUF+BFMOD MODE
      DEF BTEMP+BTSTA  STATUS RETURNED HERE 
.GET1 DEF BUF+BFNLS  ILIST
      DEF BTEMP+BTDAT  DATA BUFFER
.GET2 BSS 1            IARG ADDR
      LDA BTEMP+BTSTA+1 
      STA NWDS
      LDA BTEMP+BTSTA  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      JSB CHECK     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
      JSB SAVRT     SAVE RUN TABLE
  SPC 1 
***   JSB DBUGR 
***   DEF *+2 
***   DEF D1
*     LDA BUF+BFMOD RECALL DBGET MODE 
      JSB LOCK      LOCK/UNLCK ENTRY AS REQUESTED 
  SPC 1 
      LDA NWDS      RECALL NO. OF WDS TRANSFERRED 
      STA BTEMP+BTELN  STORE IN RETURN BUFFER 
      INA 
XDBG9 ADA D22            CALCULATE NO. OF WDS TO RETURN 
  SPC 1 
      LDB LCKID     PASSES BACK THE LOCK-ID WORD
      STB BTEMP+BTLID  (IT IS PROC. INDEX DIRECTORY:  PID)
      LDB LCKID+1   PASSES BACK ALSO THE NEXT WORD
      STB BTEMP+BTIDB 
  SPC 1 
      JMP EXIT5     AND RETURN
  SPC 1 
NWDS  BSS 1 
  HED DBFND PROCESSOR 
* 
*     INPUT BUFFER FORMAT:
* 
*                   SCODE        (4)  RQ/CLASS#/PARM1/PARM2 
*                   BUF[1]       (1)  LOCK WORD 
*                   BUF[2]       (1)  TMS LOCK ID (TMS DB# / DS#) 
*                   BUF[3]       (1)  IMAGE INTERNAL DB#
*                   BUF[4:6]     (3)  SCRATCH AREA
*                   BUF[7:13]    (7)  IMAGE RUN TABLE 
*                   BUF[14]      (1)  DBGET MODE
*                   BUF[15:22]   (8)  DATA SET NAME 
*                   BUF[23]      (1)  ITEM LENGTH 
*                   BUF[24:X]    (N)  ITEM LIST 
*                   BUF[X+1:Y]   (M)  IARG
* 
* OFFSETS INTO BUF (DEFINED IN TBGET CALL)
* 
  SPC 1 
*     OUTPUT BUFFER FORMAT: 
* 
*                   ERCOD        (2)  ERROR CODE/SUB # (TMS INTERNAL) 
*                   BTEMP[1:10]  (10) IMAGE STATUS TABLE
*                   BTEMP[11]    (1)  LOCK ID 
*                   BTEMP[12]    (1)  IMAGE INTERNAL DB#
*                   BTEMP[13:15] (3)  SCRATCH WORDS 
*                   BTEMP[16:22] (7)  IMAGE RUN TABLE 
* 
* OFFSETS INTO BTEMP (DEFINED IN TBGET CALL)
* 
  SPC 2 
XDBFN JSB LCKDB     LOCK DATA BASE IF NECESSARY 
      DEF BUF+BFLKW      LOCK WORD
      LDA .BDSN     GET DATA SET NAME 
      JSB DSNUM     --->  DATA SET NUMBER 
* 
      LDA BUF+BFNLL  GET ILIST LENGTH 
      ADA .FND1      TO CALCULATE ADDR OF IARG ARRAY
      STA .FND2 
* 
      JSB DBFND     SET UP THE CHAIN
      DEF *+7 
      DEF BUF+BFIDB  IMAGE INTERNAL DB# 
      DEF DS#    DATA SET NO. 
      DEF D1     MODE 
      DEF BTEMP+BTSTA  STATUS 
.FND1 DEF BUF+BFNLS    KEY ITEM NAMELIST (ILIST)
.FND2 BSS 1            KEY ITEM VALUELIST (IARG)
      LDA BTEMP+BTSTA   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
      JSB CHECK     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
* 
      JSB SAVRT     SAVE RUN TABLE
  SPC 1 
      CLA           SET MODE=0 FOR DBFND REQUEST
      STA LOCKM     
      JSB LOCK      LOCK/UNLOCK ENTRY AS REQUESTED
  SPC 1 
XDBF3 CLA           TO AJUST BUFFER LENGTH
      JMP XDBG9 
   HED DBPUT PROCESSOR
* 
*     INPUT BUFFER FORMAT:
* 
*                   SCODE        (4)  RQ/CLASS#/PARM1/PARM2 
*                   BUF[1]       (1)  LOCK WORD 
*                   BUF[2]       (1)  TMS LOCK ID (TMS DB# / DS#) 
*                   BUF[3]       (1)  IMAGE INTERNAL DB#
*                   BUF[4:6]     (3)  SCRATCH AREA
*                   BUF[7:13]    (7)  IMAGE RUN TABLE 
*                   BUF[14]      (1)  DBGET MODE
*                   BUF[15:22]   (8)  DATA SET NAME 
*                   BUF[23]      (1)  NAME LIST LENGTH
*                   BUF[24:X]    (N)  NAME LIST 
*                   BUF[X+1:Y]   (M)  VALUE LIST
* 
* OFFSETS INTO BUF (DEFINED IN TBGET) 
* 
  SPC 1 
*     OUTPUT BUFFER FORMAT: 
* 
*                   ERCOD        (2)  ERROR CODE/SUB # (TMS INTERNAL) 
*                   BTEMP[1:10]  (10) IMAGE STATUS
  SPC 2 
XDBPU LDA .BF02     GET DATA SET NAME 
      JSB DSNUM     ---> DATA SET NUMBER
* 
      LDA DSTYP     CHECK DATA SET TYPE 
      CPA M.        IS IT MASTER? 
      JMP XDBP1        YES, D.B. SHOULD BE LOCKED 
      JSB LCKDB        NO, DETAIL, LOCK D.B.
      DEF D1             FORCE LOCKING
* 
XDBP1 LDA BUF+BFNLL RECALL # OF ITEM
      ADA .BF05 
      STA XDBP3     SET IVALU ADDR
   SPC 1
      LDA D8        SET MODE=8 FOR DBPUT REQUEST
      STA LOCKM 
      JSB LOCK      UNLOCK REQUEST AS REQUESTED 
  SPC 1 
      JSB DBPUT     STORE DATA INTO THE DATA BASE 
      DEF *+7 
      DEF BUF+BFIDB  IMAGE INTERNAL DB# 
      DEF DS#       DATA SET NUMBER 
      DEF D1        DUMMY MODE ARG
      DEF BTEMP+BTSTA  STATUS 
.BF05 DEF BUF+BFNLS  NAME LIST
XDBP3 NOP            VALUE LIST 
      LDA BTEMP+BTSTA  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      JSB CHECK     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
* 
*     JSB DMPTM 
*     DEF *+7 
*     DEF D6
*     DEF BUF+BFNLS 
*     DEF BUF+BFNLL 
*     DEF ITMES 
*     DEF D10 
*     DEF D1
*     JSB DMPTM 
*     DEF *+7 
*     DEF D6
*     DEF XDBP3,I 
*     DEF D201
*     DEF ITMES 
*     DEF D10 
*     DEF D1
* 
XDBP5 LDA LGCLA     CHECK FOR LOGGING 
      SZA 
      JMP XDBP7        LOGGING IS USED, LOG THIS OPERATION
* 
XDBP6 LDA D10          NO LOGGING, RETURN DIRECTLY
      JMP EXIT5     RETURN
* 
XDBP7 LDA .ERCD     GET ADDR OF STATUS BUFFER 
      LDB .ERCL     GET ADDR OF STATUS BUFFER TO SEND TO DCLOG
      MVW D12       MOVE TO DCLOG BUFFER
      CLB 
      STB ERCOL     SET OK STATUS IN DCLOG BUFFER 
      LDB SCODE 
      STB ERCOL+1   MOVE SUBROUTINE CODE TO DCLOG BUFFER
* 
      LDA SMWDS     CALCULATE LENGTH OF BUFFER TO SEND TO DCLOG 
      ADA D31 
      LDB ECLAS     GET RUETURN CLASS 
      JSB DBLOG     LOG THIS OPERATION
      JMP EXIT3     CHECK FOR NEW OPERATION, DCLOG WILL HANDLE RETURN 
  SPC 1 
.BF02 DEF BUF+BFDSN 
   HED DBUPD PROCESSOR
* 
*     INPUT BUFFER FORMAT:
* 
*                   SCODE        (4)  RQ/CLASS#/PARM1/PARM2 
*                   BUF[1]       (1)  LOCK WORD 
*                   BUF[2]       (1)  TMS LOCK ID (TMS DB# / DS#) 
*                   BUF[3]       (1)  IMAGE INTERNAL DB#
*                   BUF[4:6]     (3)  SCRATCH AREA
*                   BUF[7:13]    (7)  IMAGE RUN TABLE 
*                   BUF[14]      (1)  DBGET MODE
*                   BUF[15:22]   (8)  DATA SET NAME 
*                   BUF[23]      (1)  NAME LIST LENGTH
*                   BUF[24:X]    (N)  NAME LIST 
*                   BUF[X+1:Y]   (M)  VALUE LIST
* 
* OFFSETS INTO BUF (DEFINED IN TBGET AND TBPUT CALLS) 
* 
  SPC 1 
*     OUTPUT BUFFER FORMAT: 
* 
*                   ERCOD        (2)  ERROR CODE/SUB # (TMS INTERNAL) 
*                   BTEMP[1:10]  (10) IMAGE STATUS
  SPC 2 
XDBUP LDA .BF02     GET DATA SET NAME 
      JSB DSNUM     ---> DATA SET NUMBER
* 
      LDA D9        SET LOCK MODE TO 9 FOR DBUPD/DEDEL
      STA LOCKM 
      JSB RSTRT     RESTORE RUN TABLE 
      JMP XDBU7     WRONG DATA SET ---> ERROR # 460 
   SPC 1
*     LDA D9        SET MODE=9 FOR DBUPD
      JSB LOCK      UNLOCK ENTRY AS REQUESTED 
   SPC 1
      LDA BUF+BFNLL   RECALL # OF ITEM
      ADA .BF12 
      STA XDBU3     SET IVALU ADDR
* 
      JSB DBUPD     UPDATE ITEM VALUE IN AN ENTRY 
      DEF *+7 
      DEF BUF+BFIDB  IMAGE INTERNAL DB# 
      DEF DS#       DATA SET NAME 
      DEF D1        DUMMY MODE
      DEF BTEMP+BTSTA  STATUS 
.BF12 DEF BUF+BFNLS   NAME LIST 
XDBU3 NOP            VALUE LIST 
      LDA BTEMP+BTSTA  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      JSB CHECK     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
* 
      JMP XDBP5     TERMINATE LIKE  DBPUT 
  SPC 3 
XDBU7 LDA D460     BAD RUN TABLE SAVED
      JMP EROR      ERROR #  460
  HED DBDEL PROCESSOR 
* 
*     INPUT BUFFER FORMAT:
* 
*                   SCODE        (4)  RQ/CLASS#/PARM1/PARM2 
*                   BUF[1]       (1)  LOCK WORD 
*                   BUF[2]       (1)  TMS LOCK ID (TMS DB# / DS#) 
*                   BUF[3]       (1)  IMAGE INTERNAL DB#
*                   BUF[4:6]     (3)  SCRATCH AREA
*                   BUF[7:13]    (7)  IMAGE RUN TABLE 
*                   BUF[14]      (1)  DBGET MODE
*                   BUF[15:22]   (8)  DATA SET NAME 
* 
* OFFSETS INTO BUF (DEFINED IN TBGET CALL)
* 
  SPC 1 
*     OUTPUT BUFFER FORMAT: 
* 
*                   ERCOD        (2)  ERROR CODE/SUB # (TMS INTERNAL) 
*                   BTEMP[1:10]  (10) IMAGE STATUS
  SPC 2 
XDBDE LDA .BF02     GET DATA SET NAME 
      JSB DSNUM     ---> DATA SET NUMBER
* 
      LDA D9        SET LOCK MODE TO 9 FOR DBDEL/DBUPD
      STA LOCKM 
      JSB RSTRT     RESTORE RUN TABLE 
      JMP XDBU7     WRONG DATA SET ---> ERROR#460 
   SPC 1
*     LDA D9        SET MODE=9 FOR DBDEL
      JSB LOCK      UNLOCK ENTRY AS REQUESTED 
  SPC 1 
      JSB DBDEL     DELETE ENTRY IN A DATA SET
      DEF *+5 
      DEF BUF+BFIDB  IMAGE INTERNAL DB# 
      DEF DS#       DATA SET NUMBER 
      DEF D1        DUMMY MODE
      DEF BTEMP+BTSTA  STATUS 
      LDA BTEMP+BTSTA  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      JSB CHECK     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
* 
      JMP XDBP5     RETURN TO USER PROGRAM
  HED DBINF PROCESSOR 
* 
*     INPUT BUFFER FORMAT:
* 
*                   SCODE        (4)  RQ/CLASS#/PARM1/PARM2 
*                   BUF[1:13]    (13) NOT USED
*                   BUF[14]      (1)  DBINF MODE
*                   BUF[15:22]   (8)  DATA SET NAME 
* 
* 
*     OUTPUT BUFFER FORMAT: 
* 
*                   ERCOD        (2)  ERROR CODE/SUB # (TMS INTERNAL) 
*                   BTEMP[1:10]  (10) STATUS
*                   BTEMP[11:X]  (N)  DBINF INFORMATION 
* 
* OFFSET INTO BTEMP:
* 
BTINF EQU 10        DBINF INFORMATION 
* 
* 
XDBIN JSB DBINF     EXECUTE CALL
      DEF *+6 
      DEF BUF+BFIDB IMAGE INTERNAL D.B. NO. 
.BDSN DEF BUF+BFDSN     DATA SET NO.
      DEF BUF+BFMOD MODE
      DEF BTEMP+BTSTA  STATUS RETURN
      DEF BTEMP+BTINF  INFORMATION RETURN 
      LDA BTEMP+BTSTA  GET STATUS 
      JSB CHECK        CHECK FOR ERROR
* 
      LDA BTEMP+BTSTA+1  GET NO .OF WDS TRANSFERRED 
      ADA D10          CALCULATE NO. OF WDS TO RETURN 
      JMP EXIT5        RETURN 
  HED RETURN DATA BASE INFORMATION
* 
* THIS IS A SPECIAL ENTRY POINT THAT IS CALLED BY TMPGN TO VERIFY 
* CERTAIN DATA-BASE INFORMATION 
* 
*     INPUT BUFFER FORMAT:
* 
*                   SCODE        (4)  RQ/0/0/0
*                   BUF[1:3]     (3)  DATA-BASE NAME
*                   BUF[4:6]     (3)  LEVEL ACCESS
*                   BUF[7]       (1)  SEC. CODE 
*                   BUF[8]       (1)  CR. NO. 
* 
*     OUTPUT BUFFER FORMAT: 
* 
*                   PARM[1]      (1)  STATUS (0 OR 3) 
*                   PARM[2]      (1)  ACTIVE FLAG (NO. OF PROCESSES 
*                                     ACCESSING D.B.) 
*                   BUF[1]       (3)  D.B. NAME (RETURNED IF ACTIVE)
*                   BUF[4]       (3)  LEVEL ACCESS (RETURNED IF 
*                                     ACTIVE) 
*                   BUF[7]       (1)  SEC. CODE. (RETURNED IF ACTIVE) 
*                   BUF[8]       (1)  CR. NO. (RETURNED IF ACTIVE)
*                   BUF[9]       (1)  LOCK ON TMP COPY/LOCK ON DEMAND 
*                                     FLAG
*                   BUF[10-12]   (3)  LOG FILE NAME 
*                   BUF[13]      (1)  SEC. CODE 
*                   BUF[14]      (1)  CR. NO. 
* 
* 
XDBVF LDA .DMDL,I   GET TMP COPY/DEMAND LOCK FLAG 
      STA BUF+8     SAVE IN RETURN BUFFER 
* 
      LDA .LNAM     GET ADDR OF LOG FILE NAME 
      LDB .BF09     GET ADDR OF RETURN BUFFER 
      MVW D5        MOVE LOG FILE NAME TO RETURN BUFFER 
* 
      LDA ACTIV     GET ACTIVE FLAG 
      STA PARM+1    SAVE IN RETURN BUFFER 
* 
      SZA,RSS       IS THIS PROGRAM ACTIVE (IS D.B. BEING ACCESSED) 
      JMP XDBV2        NO, SKIB D.B. NAME VERIFICATION
* 
      LDA .BUF      GET ADDR OF DB NAME SUPPLIED BY USER
      LDB .DBNM     GET ADDR OF DB NAME USED BY PROGRAM 
      CMW D8        DO NAMES MATCH? 
      JMP XDBV2        YES, RETURN 0 ERROR CODE 
      NOP 
      LDA D3           NO, RETURN ERROR CODE OF 3 
      RSS 
XDBV2 CLA 
      STA PARM      SET ERROR CODE
* 
      LDA .DBNM     RETURN D.B. NAME
      LDB .BUF
      MVW D8
* 
      JSB EXEC      SEND INFORMATION TO CALLER
      DEF *+5 
      DEF D14 
      DEF D2
      DEF PARM
      DEF D16 
* 
      LDA ACTIV     IS THIS PROG ACTIVE?
      SZA,RSS 
      JSB ABORT        NO, ABORT
      JMP EXI10     TERMINATE 
* 
.BF09 DEF BUF+9 
  HED !!!!
  SPC 2 
CHECK NOP           !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
      SZA,RSS 
      JMP CHECK,I 
      LDB SCODE 
      CPB D2        GET CALL? 
      JMP CHEC1        YES, CHECK IF ERROR 107
      CPB D3        FIND CALL?
      JMP CHEC1        YES, CHECK IF ERROR 107
      JMP SIMST        NO, RETURN WITH ERROR
CHEC1 CPA D107
      JMP CHECK,I 
      JMP SIMST        RETURN WITH ERROR
* 
  HED UTILITY SUBROUTINE
DSNUM NOP           FIND DATA SET NUMBER
      STA DSNU3 
      JSB DBINF     DATA SET NAME  --->  DATA SET # 
      DEF *+6 
      DEF BUF+BFIDB 
DSNU3 NOP           DATA SET NAME 
      DEF D201      MODE
      DEF ISTAT     STATUS
      DEF ISINF     DATA RETURN 
      JSB CHECK     OK ?
DSNU7 LDA ISINF 
      SSA 
      CMA,INA       MAKE SURE DS# IS POS
      STA DS#       SET DATA SET NUMBER 
      JSB DBINF     DS#  --->  TYPE/CAPACITY/ENTRY LENGTH 
      DEF *+6 
      DEF BUF+BFIDB  IMAGE INTERNAL DB# 
      DEF DS#       DATA SET NUMBER 
      DEF D202      MODE
      DEF ISTAT     STATUS
      DEF ISINF     DATA RETURN 
      JSB CHECK     OK ?
      LDA .IST8     MOVE INFO 
      LDB .DSTP 
      MVW D2
      ADA D3
      MVW D4
* 
      LDA ENTLN     CHECK FOR ENTRY .GT. 512 WDS
      ADA DM513 
      SSA           .LE. 512 ?
      JMP DSNUM,I      YES, RETURN
      LDA D462         NO, ERROR
      JMP SIMST 
* 
.IST8 DEF ISINF+8 
.DSTP DEF DSTYP 
DS#   NOP           DATA SET NUMBER 
DSTYP NOP           DATA SET TYPE (ASCII) 
ENTLN NOP           ENTRY LENGTH
NOENT BSS 2         NO. OF ENTERIES 
CAPAC BSS 2         DATA SET CAPACITY 
ITEM# NOP           KEY ITEM NUMBER 
ITMLN NOP           ITEM LENGTH 
  SPC 1 
KYITM NOP           RETREIVE KEY ITEM CHARACTERITICS
      JSB DBINF     DS#  --->  KEY ITEM # 
      DEF *+6 
      DEF BUF+BFIDB 
      DEF DS# 
      DEF D302      MODE 302
      DEF ISTAT     STATUS
      DEF ISINF     RUNTABLE
      JSB ERR?      OK
      LDA ISINF    GET KEY ITEM # 
      STA KYSAV    SAVE FOR FUTURE USE
      JSB GITLN     GET ITEM LEN
      STA LNSAV     SAVE LENGTH FOR FUTURE USE
* 
* CALCULATE KEY ITEM VALUE OFFSET IN IMAGE BUFFER 
* 
      CLA 
      STA KYOFF     SET OFFSET TO 0 
* 
      LDA LOCKM     GET LOCK MODE 
      CPA D7        KEYED READ? 
      JMP KYIT3        YES, RETURN
* 
      JSB DBINF     GET LIST OF ALL ITEMS IN THE DATA SET 
      DEF *+6 
      DEF BUF+BFIDB 
      DEF DS# 
      DEF D104
      DEF ISTAT 
      DEF ITLST     LIST RETURNED HERE
      JSB ERR?      ERROR?
* 
      LDA BUF+BFNLS     GET FIRST WORD IN NAME LIST 
      CPA @BLNK         @  CONSTRUCT? 
      JMP NOLST            YES, NO LIST SPECIFIED, CHECK ALL ITEMS
      ADA DM128            NO, IS IT A NUMBER LIST OR NAME LIST?
      STA LSTYP               (NEG.-NUMBER LIST, POS.-NAME LIST)
      SSA 
      JMP NULST               NUMBER LIST, GO TO NUMBER LIST SECTION
* 
* NAME LIST, PERFORM INITIALIZATION FOR OFFSET COMPUTATION
* 
      LDA BUF+BFNLL     GET WORD LENGTH OF NAME LIST
      ALS               CONVERT TO BYTE LENGTH
      STA BYTLN 
* 
      JSB NXINI     INITIALIZE NAME LIST PARSEING ROUTINE 
      DEF *+4 
      DEF BUF+BFNLS 
      DEF D1
      DEF BYTLN 
      JMP SELST 
* 
* NUMBER LIST, INITIALIZE OFFSET COMPUTATION
* 
NULST LDA .NULS     GET ADDR OF FIRST ITEM NUMBER IN NUMBER LIST
      STA SOURC        (NUMBER LIST IS SPECIFIED BY USER) 
      JMP SELST 
* 
* NO LIST, INITIALIZE OFFSET COMPUTAION 
* 
NOLST LDA .ITL1     GET ADDR OF FIRST ITEM  (FROM LIST OF ALL ITEMS IN
      STA SOURC        DATA SET -- ALL ITEMS MUST BE CHECKED) 
      CCA           SET LIST TYPE FLAG TO INDICATE NUMBER LIST
      STA LSTYP 
* 
* SEARCH ITEM LIST UNTIL KEY ITEM IS FOUND, CALCULATE OFFSET AS 
* SEARCH IS PERFORMED 
* 
SELST LDA LSTYP     GET LIST TYPE 
      SSA           NUMBER LIST?
      JMP SELS1        YES, GET NUMERIC ITEM
* 
      JSB BLANC     BLANC NAME DESTINATION FIRST
      DEF *+3 
      DEF ITEMN 
      DEF D8
      JSB NXPAR     NAME LIST, GET ITEM NAME
      DEF *+4 
      DEF ITEMN     ITEM NAME 
      DEF DUMMY     ITEM LENGTH 
      DEF BLNCM     LIST TERMINATOR - " ,"
      JMP SELS2 
* 
SELS1 LDA SOURC,I   GET ITEM NO.
      STA ITEMN 
      ISZ SOURC 
* 
SELS2 LDA .ITEN     GET ADDR OF ITEM NAME/NUMBER
      JSB GIT#L     GET ITEM NUMBER, ITEM LENGTH
      LDA ITEM# 
      CPA KYSAV     IS IT THE KEY ITEM? 
      JMP KYIT3        YES, RETURN
* 
      LDA ITMLN        NO, ADD ITEM LENGTH TO OFFSET
      ADA KYOFF 
      STA KYOFF 
      JMP SELST 
* 
KYIT3 LDA LNSAV     GET KEY ITEM LENGTH 
      STA ITMLN 
      JMP KYITM,I 
* 
KYOFF BSS 1         KEY ITEM OFFSET 
BYTLN BSS 1         BYTE LENGTH OF NAME/NUMBER LIST 
LSTYP BSS 1         LIST TYPE (NEG - NUMBER, POS - NAME)
KYSAV BSS 1         TEMPORARY STORAGE FOR KEY ITEM
LNSAV BSS 1         TEMPORARY STORAGE FOR KEY ITEM LENGTH 
SOURC BSS 1 
DUMMY BSS 1 
BLNCM ASC 1, ,      " ,"
@BLNK ASC 1,@       "@ "
.NULS DEF BUF+BFNLS+1     NUMBER LIST ADDR
.ITL1 DEF ITLST+1         ADDR OF LIST OF ALL ITEMS IN DATA SET 
.ITEN DEF ITEMN 
  SPC 1 
GIT#L NOP           GET ITEM # & LEN FROM ITEM NAME 
      STA GTM#3     SET ITEM NAME ADDR
      LDA A,I       GET FIRST CHAR. OR NUM. 
      STA ISINF 
      ADA DM256     IS IT ALREADY 
      SSA           A NUMBER ?
      JMP GTM#7     YES, SKIP THE DBINF 
      JSB DBINF     ITEM NAME  --->  ITEM # 
      DEF *+6 
      DEF BUF+BFIDB  IMAGE INTERNAL DB# 
GTM#3 NOP           ITEM NAME 
      DEF D101      MODE
      DEF ISTAT     STATUS
      DEF ISINF     DATA RETURN 
      JSB ERR?      OK ?
GTM#7 LDA ISINF  GET ITEM # 
      SSA 
      CMA,INA    MAKE SURE IT IS POS
      JSB GITLN     RETREIVE ITEM LENGTH
      JMP GIT#L,I 
* 
  SPC 1 
GITLN NOP           GET ITEM LENGTH 
      STA ITEM#     SAVE ITEM # 
      JSB DBINF     ITEM #  --->  ITEM LENGTH 
      DEF *+6 
      DEF BUF+BFIDB  IMAGE INTERNAL DB# 
      DEF ITEM#     ITEM NUMBER 
      DEF D102      MODE 102
      DEF ISTAT     STATUS
      DEF ISINF  INFORMATION BUFFER 
      JSB ERR?      OK ?
      LDA ISINF+9  GET ITEM LENGTH
      MPY ISINF+10  MPY BY NO OF SUB ITEMS
* 
      LDB ISINF+8   CHECK FOR BYTE COUNT OR WORD COUNT
      CLE 
      CPB X.          (ASC 1,X) 
      ERA                 BYTE COUNT, DIVIDE BY 2 
      SEZ                 REMAINDER?
      INA                 YES, ALLOCATE ONE MORE WORD 
      STA ITMLN 
      JMP GITLN,I 
  SPC 2 
SAVRT NOP           SAVE RUN TABLE INFORMATION
      LDA DSTYP     CHECK IF DETAIL OR MASTER DS
      CPA D.
      JMP SAVR2     DETAIL, USE DBINF CALL TO SAVE RUNTABLE 
* 
      DLD BTEMP+BTSTA+2  MASTER DATA SET, SAVE RUN TABLE INFO 
      DST BTEMP+BTSCR+1  RETURNED IN ISTAT  
      DST BTEMP+BTIRT+RTCRR 
      CLA 
      CLB     
      DST BTEMP+BTIRT+RTPRR 
      DST BTEMP+BTIRT+RTNXR 
      STA BTEMP+BTIRT+RTCCP 
      JMP SAVR4 
* 
SAVR2 JSB DBINF     SAVE RUN TABLE
      DEF *+6 
      DEF BUF+BFIDB    IMAGE INTERNAL DB# 
      DEF DS#          DATA SET # 
      DEF D401         MODE 401 
      DEF ISTAT        STATUS 
      DEF BTEMP+BTIRT  RUN TABLE ADDR 
      JSB ERR?     OK ? 
      CLA 
      STA BTEMP+BTSCR+1 
      STA BTEMP+BTSCR+2 
* 
SAVR4 LDA DS#       SAVE DATA-SET # 
      STA BTEMP+BTSCR 
      JMP SAVRT,I 
* 
  SPC 1 
RSTRT NOP           RESTORE RUN TABLE 
      LDA BUF+BFSCR RECALL DATA SET # SAVED 
      CPA DS#       SAME DATA SET ? 
      RSS              YES, CHECK DATA SET TYPE 
      JMP RSTR0        NO, CHECK TYPE OF CALL 
* 
      LDA DSTYP     CHECK IF MASTER OR DETAIL DATA SET
      CPA M.
      JMP RSTR1     MASTER DATA SET, USE DIRECTED READ TO RESTORE POSITION
      LDA LOCKM     DETAIL DATA SET, CHECK TYPE OF CALL 
      CPA D2        FORWARD SERIAL READ?
      JMP RSTR1        YES, USE DIRECTED READ TO RESTORE POSITION 
      CPA D3        BACKWARD SERIAL READ? 
      JMP RSTR1        YES, USE DIRECTED READ TO RESTORE POSITION 
      JMP RSTR2     NOT SERIAL READ, USE DBINF CALL TO RESTORE POSITION 
* 
RSTR0 LDA LOCKM     RECALL LOCK MODE
      CPA D2        FORWARD SERIAL READ?
      RSS              YES
      CPA D3        NO, BACKWARD SERIAL READ
      RSS              YES  
      JMP RSTRT,I      NO, ERROR
* 
      CLA           MUST BE FIRST SERIAL READ ON THIS DATA SET
      STA BUF+BFIRT+RTCRR  SET CURRENT RECORD NO. TO 0
      NOP                  AND RESTORE POSTITION
* 
RSTR1 JSB DBGET     MASTER DATA SET, USE DIRECTED READ TO RESTORE POS 
      DEF *+8 
      DEF BUF+BFIDB IMAGE INTERNAL DB#
      DEF DS# 
      DEF D4
      DEF ISTAT 
      DEF D0        DO NOT RETURN ANY DATA
      DEF BTEMP+BTDAT 
      DEF BUF+BFIRT+RTCRR 
      JMP RSTR4 
* 
RSTR2 JSB DBINF     RESTORE THE POSITION
      DEF *+6 
      DEF BUF+BFIDB  IMAGE INTERNAL DB# 
      DEF DS#        DATA SET NO. 
      DEF D402       MODE 402 
      DEF ISTAT      STATUS RETURN
      DEF BUF+BFIRT  RUNTABLE 
* 
RSTR4 JSB ERR?      OK ?
      LDA DS#       RESTORE INITIAL MAIL BOX BUFFER 
      STA BUF+BFSCR FOR LOCK ALGORITM ! 
      ISZ RSTRT     RETURN OK (P+2) 
      JMP RSTRT,I 
  SPC 1 
D.    ASC 1,D 
M.    ASC 1,M 
X.    ASC 1,X 
  SPC 2 
PSAM  NOP           PUT MAIL BOX INTO SAM 
      DST PARM1     SET PARAMETERS
      LDA PSAM,I    GET BUFFER ADDR 
      STA PSAM2 
      ISZ PSAM
      JSB EXEC      CALL I/O WRITE/READ 
      DEF *+8 
      DEF NAB20     WRITE/READ REQUEST
      DEF D0        DUMMY LU
PSAM2 NOP           BUFFER ADDR 
      DEF PSAM,I    BUFFER LENGTH 
      DEF PARM1 
      DEF PARM2 
      DEF CLAS#     CALL I/O WORD 
      JMP PSER      ERROR 
      SZA 
      JMP PSER
*     JSB DMPTM 
*     DEF *+7 
*     DEF D6
*     DEF PSAM2,I 
*     DEF PSAM,I
*     DEF MES2
*     DEF D10 
*     DEF D1
      ISZ PSAM      SET RETURN ADDR 
      JMP PSAM,I
* 
PSER  DST PSME1 
      JSB OUTMS     OUTPUT ERROR MESSAGE
      DEF PSMES 
      DEF D32 
      JMP XDBC0     CLOSE D.B., TERMINATE PROGRAM 
* 
NAB20 OCT 100024
* 
PSMES BSS 5 
      ASC 8, CLASS IO ERROR 
PSME1 BSS 2 
      ASC 17,, TERMINATING TO PROTECT DATA BASE 
  SPC 2 
GSAM  NOP 
      IOR BIT15     SET NO-WAIT BIT 
      STA TEMP
      JSB EXEC      CLASS I/O GET 
      DEF *+7 
      DEF NAB21     GET  NO-ABORT 
      DEF TEMP      CLASS I/O WORD
      DEF SCODE     BUFFER ADDR 
      DEF RBULN     BUFFER LENGTH 
      DEF PARM1 
      DEF PARM2 
      CCA           ABORT RETURN, NOTHING HAS BEEN GET
      STA SAVA
      STB SMWDS 
*     JSB DMPTM 
*     DEF *+7 
*     DEF D6
*     DEF SCODE 
*     DEF RBULN 
*     DEF MES1
*     DEF D10 
*     DEF D1
      LDA SAVA
      JMP GSAM,I    RETURN OK 
* 
NAB19 OCT 100023
NAB21 OCT 100025
SMWDS BSS 1         NO. OF WORDS RECEIVED BY CLASS IO GET 
SAVA  BSS 1 
  SPC 2 
GTCLW NOP           ALLOCATED A CLASS I/O 
      CLA           WHEN OWNER CLASS I/O WILL BE RELEASE
      STA GTCLX     THIS SUBROUTINE WILL BE REPLACED
      JSB EXEC      BY THE SYSTEM ROUTINE.
      DEF *+5       THE CLASS MUST BE OWNED BY THE CALLING PROGRAM
      DEF NAB19     SO THE ABORT PROCEDURE WILL BE EASIER 
      DEF D0        I.E.: THE PROGRAM WILL BE ABORTED 
      DEF *         AND HOPFULLY THE CLASS I/O RELEASED.
      DEF GTCLX 
      JMP PSER
      LDA GTCLX 
      IOR B20K      SET BIT13 'DO NOT DEALLOACATE'
      STA GTCLX 
      JSB EXEC
      DEF *+5 
      DEF NAB21 
      DEF GTCLX 
      DEF * 
      DEF D0
      JMP PSER
      LDA GTCLX 
      JMP GTCLW,I 
* 
GTCLX NOP 
  SPC 1 
KLCLX NOP 
      STA KLCL3     SAVE CLASS I/O WORD 
      JSB KLCLS     RELEASE THE CLASS 
      DEF *+2 
      DEF KLCL3 
      JMP KLCLX,I 
* 
KLCL3 NOP 
  SPC 3 
DBLOG NOP          LOG DATABASE OPERATIONS
      STA LGCNT    SAVE WORD COUNT
      STB RTNCL    SAVE RETURN CLASS
      JSB WRLOG    LOG DATA 
      DEF SCODL    BUFFER 
      DEF LGCNT 
      DEF LGCLA    DCLOG CLASS
      DEF RTNCL    RETURN CLASS 
      DEF PARM     SPECIAL PARAMETER #1 
      DEF PARM+1   SPECIAL PARAMETER #2 
      JSB .ERR?    CHECK FOR ERROR
      JMP DBLOG,I  NO ERROR, RETURN 
* 
LGCNT NOP          WORD COUNT 
RTNCL NOP          RETURN CLASS 
   SPC 2
LCKDB NOP          LOCK D.B. IF DEMAND LOCKING
      LDA DMDLK    GET DEMAND LOCK FLAG 
      LDB LCKDB,I  GET LOCK WORD
      LDB B,I 
      ISZ LCKDB    INCREMENT RETURN ADDR
      SLA,RSS 
      JMP LCKDB,I  NO DEMAND LOCKING RETURN 
      SLB,RSS 
      JMP LCKDB,I  NO LOCKING REQUESTED, RETURN 
      LDA LKFLG    IS DATA BASE ALREADY LOCKED? 
      SZA             NO, LOCK D.B. 
      JMP LCKDB,I     YES, RETURN 
* 
      JSB DBLCK       NO, LOCK D.B. 
      DEF *+5 
      DEF BUF+BFIDB 
      DEF NCHRS       DUMMY 
      DEF D2          NO WAIT 
      DEF ISTAT 
      LDA ISTAT       CHECK STATUS
      SZA 
      JMP LCKD2       ERROR!!!
      CLA,INA 
      STA LKFLG       SET LOCK FLAG TO INDICATE THAT THE D.B. IS LOCKED 
      JMP LCKDB,I     OK, RETURN
* 
LCKD2 LDA D400        LOCK ERROR, #400
      JMP SIMST       RETURN
* 
LKTOT OCT 0           TOTAL NO. OF RECS LOCKED
LKFLG OCT 0           D.B. LOCK INDICATOR 
  SPC 2 
OUTMS NOP          OUTPUT ERROR MESSAGE 
      LDB OUTMS,I  GET MESSAGE ADDR 
      ISZ OUTMS    INCREMENT RETURN ADDR
      LDA OUTMS,I  GET WORD COUNT ADDR
      STA OUTM2 
      STB OUTM1 
      LDA SPCSL    GET " /" 
      STA B,I 
      INB 
      LDA .ILIS    GET ADDR OF PROGRAM NAME 
      MVW D3       MOVE TO MESSAGE BUFFER 
      LDA COLSP    GET ": " 
      STA B,I 
      JSB WRTTY    OUTPUT MESSAGE 
OUTM1 NOP          MESSAGE BUFFER 
OUTM2 NOP          WORD COUNT 
      ISZ OUTMS    INCREMENT RETURN ADDR
      JMP OUTMS,I  RETURN 
* 
SPCSL ASC 1, /
COLSP ASC 1,: 
  SPC 2 
WRTTY NOP          WRITE TO TTY 
      LDA WRTTY,I  GET MESSAGE BUFFER ADDR
      ISZ WRTTY    INCREMENT RETURN ADDR
      LDB WRTTY,I  GET WORD COUNT 
      ISZ WRTTY    INCREMENT RETURN ADDR
      DST WRTT1    SAVE MESSAGE BUFFER AND WORD COUNT 
      JSB EXEC     OUTPUT MESSAGE 
      DEF *+5 
      DEF D2
      DEF LU
WRTT1 BSS 2 
      JMP WRTTY,I  RETURN 
* 
LU    BSS 1 
   HED   *** LOCKING MECHANISM  *** 
*               THE FORMAT OF THE BUFFER USED IS AS FOLLOWS:
* 
   SPC 2
* 
*                        15            8 7 6 5         0
*  ADDRESS               ******************************** 
*              L         *     PIDX     *   *   DS #    *<--- LOCTB  (PT) 
*    !         O         *     RECORD # (DOUBLE INT)    * 
*    !         C         *                              * 
*    !         K         ******************************** 
*    !               --->*     PIDX     *W  *   DS #    *  [W] BIT IS THE 
*    !               !   *     RECORD # (DOUBLE INT)    * 'SOMEONE WAITING' 
*    !               !   *                              * 
*    !         T     !   ******************************** 
*    !         A     !   *     ....               ....  *  FREE ENTRY 
*    !         B     !   *             0                * 
*    !         L     !   *             0                * 
*    !  +      E     !   ********************************  [N] BIT IS THE 
*    !               !   *     ....     *  N*     ....  *  'NON-EXCLUSIVE 
*    !               !   *     ....               ....  *   LOCK FLAG'
*    !               !   *     ....               ....  * 
*    !               !   ******************************** 
*    !               !   *                              *<--- LOCTE 
*    !               !   *                              * 
*    !               !   .                              . 
*  \ ! /             !   .                              . 
*   \!/              !
*    .               !
*                    !
*                    !   .                              . 
*               P    !   *                              *<--- PROTE 
*               R    !   ******************************** 
*               O    !   *1*  LINK IN RESTART QUEUE     *  PROCESS IN 
*               C    !   *       CLASS I/O WORD         *  RESTART QUEUE
*               E    !   *X*   # OF RECORDS LOCKED      * 
*               S    !   ******************************** 
*               S    ----+    POINTER TO LOCK TABLE     *  PROCESS WAITING
*                        *       CLASS I/O WORD         *  ON A RECORD
*               D        *X*   # OF RECORDS LOCKED      * 
*               I        ******************************** 
*               R        *             0                * 
*               E        *             0                * 
*               C        *X*   # OF RECORDS LOCKED      *<--- PROTB  (PIDPT)
*               T        ******************************** 
*               O 
*               R        [X]  FLAG SET WHEN PID IS ALLOCATED
*               Y                 AND CLEAR WHEN PID IS DEALLOACTED 
* 
* 
  SPC 2 
*     PIDX    IS THE PROCESS ID INDEX IN PROCESS DIRECTORY
* 
*     PIDPT   IS THE PROCESS ID POINTER INTO THE PROCESS DIRECTORY
   SKP
*                   LOCK PERFORM ALL LOCKING/UNLOCKING FUNCTION 
* 
*     CALLING SEQUENCE: 
*        LDA MODE    (IDENTIFY IMAGE FUNCTION PERFORMED)
*        JSB LOCK 
*           RETURN ONLY IF FUNCTION IS CORRECTLY PERFORMED. 
* 
*     IF AN ERROR IS FOUND OR IF THE PROCESS NEED TO BE SUSPENDED 
*     EXIT IS DONE DIRECTLY. (NO RETURN TO CALLING PRG) 
  SPC 1 
LOCK  NOP 
LOCK1 JMP LOCK,I    THIS LINE IS NOP'ED FOR OPEN MODE =1
*     STA LOCKM     SAVE MODE 
* 
      LDA LOCKW     GET FUNCTION TO BE PERFORMED
      AND D3        MASK BIT 0 & 1 - LOCK & UNLCK BIT 
      SZA,RSS       ANY FUNCTION REQUESTED ?
      JMP LOCK,I    NO, RETURN TO CALLER
* 
      LDA LOCKW     RECALL LOCK WORD TO 
      AND D4        SET THE LOCK EXCLUSIVE FLAG 
      ALF           FROM BIT2 TO BIT6 
      STA LCKXF     SET LOCK EXCLUSIVE FLAG 
  SPC 1 
      JSB SPIDD     ACCESS PROCESS ID DIRECTORY 
      RSS           PID WAS NOT DEFINED, AND UNLOCK IS REQUESTED !
      JMP LCK03     PID IS OK, CONTINUE THE LOCKING/UNLOCKING PROCESS 
  SPC 1 
      LDA LOCKM     LOCKID WAS NOT DEFINED, CHECK THE RQ
      ADA DM8               
      SSA           DBFND, DBGET? (MODE 0-7)
      JMP LOCK,I       YES, RETURN, NO ERROR
      SZA           DBPUT? (MODE 8) 
      JMP LCKE5        NO, IMAGE ERROR # 405  
      LDA DSTYP        YES, PUT, RECALL THE DATA-SET TYPE 
      CPA D.        PUT IN A DETAIL DATA-SET ?
      JMP LOCK,I    YES, IT IS OK, FORGET THE UNLOCK
      JMP LCKE5     NO, PUT IN A MASTER, THE ENTRY MUST HAVE BEEN LOCKED
  SPC 1 
LCK03 CLA           INIT ITEM LENGTH TO ZERO
      STA ITMLN     USED ONLY IN CASE OF SUSPEND
* 
      LDB BTEMP+BTSTA  RECALL USER'S CALL IMAGE STATUS
      LDA LOCKM     RECALL MODE 
      CPA D7        KEYED READ ?
      JMP LCK40     YES, PERFORM KEYED CALL LOCK
      CPA D8        NO, DBPUT REQUEST ? 
      JMP LCK50     YES,
      CPA D9        NO, DBUPD/DBDEL REQUEST ? 
      JMP LCK50     YES 
      SZB           IMAGE ERROR ? 
      JMP LOCK,I    YES, FORGET THE LOCK
      SZA,RSS       DBFND CALL ?
      JMP LCK13     YES, LOCK NEXT RECORD ONLY
      DLD BTEMP+BTIRT+RTCRR  NO, LOCK CURRENT RECORD
      DST REC#
      JSB LKX00     ACCESS LOCK TABLE 
      NOP 
      NOP 
      LDA LOCKM     RECALL MODE 
      CPA D5        FORWARD CHAINED READ REQUEST
      JMP LCK15        YES, CHECK FOR "LOCK AHEAD"
      CPA D6        BACKWARD CHAINED READ REQUEST 
      JMP LCK15        YES, CHECK FOR "LOCK AHEAD"
      JMP LOCK,I       NO, EXIT 
* 
LCK13 LDA .BF12     RECALL ITEM NAME ADDR TO RETREIVE 
      JSB GIT#L     ITEM LENGTH (USED IN CASE OF SUSP.) 
* 
LCK15 LDA LOCKW     GET LOCK WORD 
      AND D8        ISOLATE "LOCK NEXT" BIT (3) 
      SZA,RSS       LOCK NEXT RECORD? 
      JMP LCK17        NO, CHECK FOR "LOCK PREV"
      DLD BTEMP+BTIRT+RTNXR  GET NEXT REC NO. 
      DST REC#
      IOR B         DOUBLE WD CHECK FOR 0 
      SZA,RSS       NEXT REC EXIST? 
      JMP LCK17        NO, SKIP LOCK
      JSB LKX00        YES, LOCK IT 
      NOP 
      NOP 
* 
LCK17 LDA LOCKW     GET LOCK WORD 
      AND D16       ISOLATE "LOCK PREV" BIT (4) 
      SZA,RSS       LOCK PREV RECORD? 
      JMP LOCK,I       NO, RETURN 
      DLD BTEMP+BTIRT+RTPRR  GET PREV REC NO. 
      DST REC#
      IOR B         DOUBLE WD CHECK FOR 0 
      SZA,RSS       PREV REC EXIST? 
      JMP LOCK,I       NO, SKIP LOCK, RETURN
      JSB LKX00        YES, LOCK IT 
      NOP 
      NOP 
      JMP LOCK,I    YES, RETURN 
  SPC 1 
LCK40 LDA .GET2     GET KEY VALUE ADDR
      LDX BTEMP+BTSCR+1   GET REC# OF ITEM
      LDY BTEMP+BTSCR+2 
      SZB,RSS       USER'S IMAGE STATUS OK? 
      JMP LCK57        YES, PROCESS LOCK  
      CPB D107         NO, IS IT ENTRY NOT THERE ?
      JMP LCK51           YES, PROCESS LOCK IN ADVANCE
      JMP LOCK,I          NO, FORGET THE LOCK 
  SPC 1 
LCK50 LDB DSTYP     GET THE DATA-SET TYPE 
      CPB D.        DETAIL DATA-SET ? 
      JMP LCK60        YES, CHECK IMAGE CALL  
      LDX BUF+BFSCR+1  NO, MASTER DATA SET, RECALL PRIMARY REC #  
      LDY BUF+BFSCR+2 
      CPA D9        DBUPD, DBDEL REQUEST ?
      JMP LCK54        YES, REC# WAS IN THE SAVED RUN TBL 
      LDA XDBP3        NO, COMPUTE THE REC# FROM THE KEY VALUE  
* 
LCK51 STA LCK53     SET KEY VALU ADDR FOR HASHING ROUTINE 
      JSB KYITM     RETREIVE KEY ITEM CHARACTERISTIC
      LDA KYOFF     GET KEY ITEM OFFSET 
      ADA LCK53     CALCULATE KEY ITEM ADDR 
      STA LCK53 
      JSB HASH      RETREIVE RECORD NUMBER OF 
      DEF *+3       PRIMARY ENTRY FOR THAT KEY VALUE
      DEF ITMLN     KEY ITEM LENGTH 
LCK53 NOP           KEY ITEM VALUE
* 
      DST DBLWD     RECORD NO. CALCULATION, MAY NOT BE CORRECT
      JSB .DDI
      DEF CAPAC 
      JSB .DMP
      DEF CAPAC 
      JSB .DSBR 
      DEF DBLWD 
      JSB .DIN
      DST BTEMP+BTSCR+1  SAVE REC#
      DST BTEMP+BTIRT+RTCRR 
      CAX 
      CBY 
      CCA           SET FLAG TO INDICATE THAT RECORD IS NON-EXISTENT
      STA BTEMP+BTIRT+RTCCP 
      JMP LCK57 
* 
LCK54 LDB BUF+BFIRT+RTCCP  GET NON-EXISTENT RECORD INDICATOR
      SSB           DBUPD, DBDEL, DOES RECORD EXIST?
      JMP LCE14        NO, ERROR 414  
* 
LCK57 STX REC#      RECORD NUMBER OF PRIMARY ENTRY
      STY REC#+1
      JSB LKX00     ACCESS LOCK TABLE 
      JMP LCK58            RECORD NOT LOCKED BY CALLING PROCESS 
      JMP LCK58            RECORD IS LOCKED IN SHARED MODE
      JMP LOCK,I    AND RETURN
* 
LCK58 LDA LOCKM     GET LOCK MODE 
      CPA D8        DBPUT?
      JMP LCKE5          YES, ERROR 405, REC SHARED OR NOT LOCKED 
      CPA D9        DBUPD, DBDEL? 
      JMP LCKE5          YES, ERROR 405, REC SHARED OR NOT LOCKED 
      JMP LOCK,I
  SPC 1 
LCK60 LDX BUF+BFIRT  DETAIL DATA SET, RECALL REC # FROM SAVED RUN TBL 
      LDY BUF+BFIRT+1 
      CPA D9        DBUPD,DBDEL REQUEST ? 
      JMP LCK57     YES, PERFORM THE LOCK 
      JMP LOCK,I    DBPUT, EXIT 
* 
DBLWD BSS 2         TEMPORARY DOUBLE INTEGER STORAGE
  SPC 2 
*                   ACCESS OF THE LOCK TABLE, AND UPDATE OF THE 
*                   LOCK TABLE TO REFLECT THE LOCK/UNLOCK FUNCTION. 
* 
*                   PRIOR CALLING THIS FUNCTION, SET UP THE FOLLOWING:
*                   PIDPT, REC#, DS#, PIDX
* 
*                   RETURN POINTS:
* 
*                                P+1 - RECORD NOT LOCKED, LOCK NOT
*                                      REQUESTED
*                                P+2 - SHARED LOCK
*                                P+3 - NORMAL RETURN, FUNCTION
*                                      EXECUTED 
  SPC 1 
LKX00 NOP 
* 
      JSB SLTBL     SEARCH IN LOCK TABLE
      JMP LKX50     RECORD IS NOT LOCKED
      JMP LKX70     RECORD IS LOCKED
      LDA LOCKW     RECORD IS LOCKED BY THE CALLING PROCESS 
      ISZ LKX00 
      ISZ LKX00 
* 
      SLA,RSS       LOCK REQUEST ?
      JMP LKX30     NO, MUST BE UNLOCK THEN 
* 
      LDA PT,I      YES, IT DOES NOT MATTER IF A UNLCK
      AND BIT6      IS ALSO SPECIFIED, VERIFY THAT
      LDB LCKXF     A NON-EXCULSIVE LOCK IS NOT TRANSFORMED 
      XOR B         INTO A EXCLUSIF LOCK
      SZA           SAME KIND ? 
      SZB           NO, NEW LOCK NON-EXCLUSIVE ?
      JMP LKX00,I   YES, RETURN BUT DO NOT CHANGE THE KIND
      JMP LCKE6     NO, ERROR: TRY TO NON-EXCLUS. --> EXCLUSI.
* 
LKX30 LDA PT,I      GET TYPE OF LOCK
      AND BIT6      CHECK IF NON-EXCLUSIVE
      SZA,RSS 
      JMP LKX31     EXCLUSIVE, PERFORM UNLOCK 
      LDA LOCKM     NON-EX, CHECK TYPE OF CALL
      CPA D8        DBPUT?
      JMP LCKE5     YES, ERROR, CANNOT PUT WITH NON-EX LOCK 
      CPA D9        DBUPD/DBDEL?
      JMP LCKE5     YES, ERROR, CANNOT UPD/DEL WITH NON-EX LOCK 
LKX31 LDA PT        UNLOCK THE RECORD 
      ADA D3        INITIALIZE THE BEGINING 
      STA PT0       OF THE LOCK TABLE 
      JSB UNLCK     AND PERFORM THE UNLOCK FUNCTION 
      JMP LKX00,I   AND EXIT
  SPC 1 
*                   ADD AN ENTRY IN THE LOCK TABLE. 
* 
LKX50 LDA LOCKW     RECALL LOCK WORD
      SLA,RSS       LOCK REQUESTED ?
      JMP LKX00,I      NO, RETURN TO CALLER 
LKX52 JSB PACK         YES, PACK LOCK TABLE IF NECESSARY
      LDA PIDX      ADD AN ENTRY IN THE LOCK TABLE  
      ALF,ALF 
      IOR DS#       MERGE PID INDEX WITH DATA SET # 
      IOR LCKXF     MERGE EXCLUSIVE/NON-EXCLUSIVE FLAG
      LDB PTHOL     GET ADDR OF LAST EMPTY ENTRY
      STA B,I       TO STORE IT INTO THE TABLE
      INB 
      LDA .REC#     SAVE ALSO RECORD NUMBER 
      MVW D2        INTO THE TABLE
      LDA PTHOL     WAS IT AT THE 
      CPA LOCTE     END OF THE LOCK TABLE ? 
      STB LOCTE     YES, UPDATE END OF LOCK TABLE 
      ISZ PIDPT,I   INCREMENT # OF RECORD LOCKED
      ISZ LKTOT     INCREMENT TOTAL NO. OF RECS LOCKED
      JMP LKX00,I   AND RETURN TO CALLER
  SPC 2 
*                   SUSPEND CALLING PROCESS IF IT IS A LOCK REQUEST 
*                     WITH WAIT OPTION AND NO DEADLOCK OCCURS.
* 
LKX70 ISZ LKX00 
      LDB LOCKW     RECALL LOCK WORD
      RBR,SLB       UNLOCK REQUESTED ?
      JMP LCKE3     YES, ERROR # 403
* 
      LDA LCKXF     IS EXCLUSIVE LOCK 
      SZA,RSS       REQUESTED ? 
      JMP LKX71     YES, SUSPEND THE PROCESS
      LDA PT,I      NO, HOW IS THE RECORD LOCKED
      AND BIT6
      SZA,RSS       RECORD LOCKED EXCLUSIVELY ? 
      JMP LKX71     YES, SO SUSPEND THE PROCESS 
      JMP LKX52     NON-EXCLUSIVE LOCK, GO LOCK RECORD
* 
*LKX75 LDA PT        NO, MAKE SURE THAT RECORD IS NOT 
*     ADA D3        ALREADY OWNED BY THE CARRENT PROCESS
*     JSB SLTB0     SCAN THE END OF THE LOCK TABLE
*     JMP LKX52     END OF TABLE, THIS REC. CAN BE LOCKED (NON-EXCLUS.) 
*     LDA PT,I      AN OTHER ENTRY WHICH LOCK THE SAME
*     AND BIT6      RECORD HAS BEEN FOUND, VERIFY THAT
*     SZA,RSS       IT IS LOCKED WITH NON-EXCLUSIVE OPTION
*     HLT 13B       EXCLUSIVE LOCK !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
*     LDA PT,I      RECALL FIRST WORD IN THE LOCK TBALE 
*     ALF,ALF       TO RETEIVE THE OWNER OF THAT ENTRY
*     AND B377     GET PID
*     CPA PIDX      IS THE OWNER THE CURRENT PROCESS ?
*     JMP LKX00,I   YES, ALREADY OWNED, FORGET THE REQUEST
*     JMP LKX75     NO, CONTINUE SCANNING UP TO THE END OF TABLE
* 
LKX71 LDA D400     NO WAIT ERROR = 400
      LDB LOCKW     RECAL LOCK WORD 
      SSB           NO WAIT REQUEST ? 
      JMP SIMST     YES, RETURN ERROR# 400 TO USER IN IMAGE ST
* 
      LDA PT,I      RETREIVE IF THERE IS A DEADLOCK CONDITION 
LKX72 ALF,ALF       ISOLATE OWNER OF THE RECORD 
      AND B377
      CPA PIDX      IS OWNER IS THE CALLING PROCESS ? (ALWAYS FAIL 1ST TIME)
      JMP LCKE1     YES, DEADLOCK CONDITION, ERROR # 401
      CMA,INA       NO, CHECK IF THE OWNER IS SUSPENDED 
      INA 
      MPY D3        RETREIVE POINTER ON A RECORD FROM 
      ADA PROTB     THE PROCESS ID DIRECTORY
      ADA DM2       TO ACCESS POINTER 
      LDB A,I       GET POINTER TO RECORD LOCK TABLE
      LDA B,I       GET RECORD OWNER-DS# FROM LOCK TABLE
      SZB,RSS       PROCESS SUSPENDED ? 
      JMP LKX74     NO, PROCEED WITH THE SUSPEND
      SSB,RSS       CHECK IF IN RESTART QUEUE, IF YES SKIP
      JMP LKX72     NOT RST. QUEUE, IT IS SUSP., TRACK DOWN ONE MORE
* 
LKX74 LDA SMWDS   RECALL ITEM LENGTH TO SAVE
      STA LKX77     SET BUFFER LEN
      JSB PSAM      SEND BUFFER INTO SAM
      DEF SCODE     BUFFER ADDR 
LKX77 NOP           BUFFER LENGTH 
* 
      LDA CLAS#     OK, SUSPEND THE CALLING PROCESS 
      LDB PIDPT     SAVE CLASS I/O INTO THE PID DIRECTORY 
      ADB DM1 
      STA B,I 
      ADB DM1       UPDATE POINTER
      LDA PT        AND SAVE POINTER TO RECORD LOCK TABLE 
      STA B,I       INTO THE DIRECTORY
      LDA PT,I      RECALL THE RECORD LOCK ENTRY
      IOR BIT7      TO SET 'SOMEONE IS WAITING' BIT 
      STA PT,I
      JMP EXIT3     EXIT WITHOUT DOING THE IMAGE CALL 
  SPC 2 
LCKE3 LDA D403     ERROR # 403, UNLCK REC. LOCKED BY AN OTHER 
      JMP SIMST     GO SET IMAGE STATUS 
* 
LCKE5 LDA D405     ERROR # 405, PUT IN A MASTER WITHOUT LOCK ID 
      JMP SIMST 
* 
LCKE6 LDA D406     ERROR # 406, GO FROM NON-EXCLUSIVE TO
      JMP SIMST     EXCLUSIVE LOCK IN THE SAME PROCESS
* 
LCKE1 LDA D401     DEADLOCK ERROR = 401 
      JMP SIMST     GO SET IMAGE STATUS 
* 
LCE14 LDA D414     RECORD DOEST NOT EXIST, ERROR 414
      JMP SIMST 
* 
LCE10 LDA D410     RECORD EXISTS, ERROR 410 
      JMP SIMST 
  SPC 1 
REC#  BSS 2 
.REC# DEF REC#
LCKXF NOP           EXCLUSIVE LOCK FLAG IN BIT 6
   SKP
*                   UNLOCK: CLEAR AN ENTRY IN THE LOCK TABLE
*                           OR RESTART A WAITING PROCESS AND GIVE THAT
*                              ENTRY TO THIS WAITING PROCESS. 
* 
*     THE ADDRESS OF THE ENTRY CLEARED OR PASSED IS IN  PT
* 
*   NOTE: WHEN A NON-ECLUSIVE LOCK IS RESTARTED AFTER BEING SUSPSENDED
*         IT BECOMES A EXCLUSIVE LOCK REQUEST, ALSO ONLY ONE PROCESS IS 
*         RESTARTED AT A TIME EVEN IF MORE THAN ONE NON-ECLUSIVE LOCK 
*         REQUEST IS SUSPENDED (WHEN A PROCESS IS RESTARTED NO CHECK IS 
*         MADE FOR EXCLUSIVE/NON-EXCLUSIVE LOCK). 
*         THOSE ARE NOT ACTUALLY BUGS BUT CAN BE IMPROVE IN THE FUTURE! 
* 
UNLCK NOP 
      LDA PT,I      RECALL THE ENTRY FROM THE LOCK TABLE
      ALF,ALF       ROTATE TO GET 'SOMEONE IS WAITING' BIT
      SSA,RSS       SOMEONE WAITING ? 
      JMP UNLC8     NO, CLEAR ENTRY 
* 
      RAL           CHECK 'NON-EXCLUSIVE LOCK' BIT
      SSA 
      JMP ULC72     NO-EXCL., VERIFY THAT NO OTHER ENTRY EXIST
* 
ULC40 CLA           EXCLUSIVE LOCK, SEARCH WHICH PROCESS WAIT 
      STA TEMP      INIT # OF WAITERS COUNTER 
      LDA PROTE     SEARCH WAITERS
ULC42 JSB SRCWT     IN THE PROCESS ID DIRECTORY 
      JMP ULC45     END OF DIRECTORY RETURN 
      STA TEMP1     SAVE DIRECTORY ADDR OF THE WAITER 
      ISZ TEMP      COUNT THE # OF WAITER 
      JMP ULC42     AND LOOP UNTIL END
ULC45 LDA TEMP      GET # OF WAITERS
      SZA,RSS       MUST BE AT LEAST ONE
      JMP UNLE1     ERROR, DATA STRUCTURES CORRUPT!!!!!!!!!!!!!!!!!!
  SPC 1 
*                   PASSES THIS ENTRY TO ONE OF THE WAITERS AND 
*                   RESTART IT. 
* 
      LDB RSTAR     YES, RESTART WAITERS, GET RESTART 
ULC52 LDA B,I       QUEUE HEAD, GET NEXT ELEMENT OF THE QUEUE 
      SZA,RSS       END OF QUEUE ?
      JMP ULC54     YES, ADD THE NEW ONE
      RAL,CLE,ERA   NO, CLEAR BIT 15 AND
      LDB A         GO GET NEXT ONE 
      JMP ULC52 
* 
ULC54 STA TEMP1,I   SET NEW END OF QUEUE
      LDA TEMP1     SET BIT15 IN THE ADDR TO INDICATE 
      IOR BIT15     LINK INTO THE RESTART QUEUE INSTEAD OF
      STA B,I       POINTER TO LOCK TABLE.
      LDB TEMP1     RECALL ADDR INTO THE PROCESS DIRECTORY
      ADB D2        TO ACCESS THE # OF RECORD LOCKED
      ISZ B,I       INCREMENT # OF RECORDS LOCKED 
      JSB SPIDX     COMPUTE THE PIDX OF THE WAITER
      ALF,ALF       ROTATE IT INTO UPPER BYTE 
      STA TEMP1     AND SAVE IT 
      LDA PT,I      GIVE THIS RECORD TO THE WAITER
      AND MASK1     CLEAR OLD PIDX AND 'NON-EXCLUS. LOCK' FLAG
      IOR TEMP1     AND PUT THE NEW ONE 
      LDB TEMP      RECALL # OF WAITERS 
      CPB D1        ONLY ONE WAITERS ?
      AND NBIT7     YES, CLEAR BIT [W]
      STA PT,I      AND STORE IT BACK 
      JMP UNLC9 
  SPC 1 
*                   NO-EXCLUSIVE LOCKED RECORD IS RELEASED, 
*                   DO NOT RESTART THE WAITER, BUT SET WAIT BIT 
*                   IN ONE OF THOSE IDENTICAL ENTRY IN THE LOCK TABLE 
*                   AND MAKE ALL WAITERS WAIT ON THAT ENTRY 
* 
ULC72 LDB PT        RE-INIT RC# & DS# ( FOR THE TBULK COMMAND 
      LDA B,I 
      AND B77 
      STA DS# 
      INB 
      DLD B,I 
      DST REC#
* 
      LDA PT        SAVE CURRENT POINTER IN THE LOCK TABLE
      STA TEMP
      INA           AND CLEAR TEMPORARILY THIS ENTRY
      CLB 
      STB A,I       TO MAKE SURE AN OTHER ONE IS FOUND
      INA 
      STB A,I 
* 
      LDA PT0       RECALL THE STARTING OF THE LOCK TABLE 
      JSB SLTB0     AND SCAN THE END OF THE LOCK TABLE
      JMP ULC75     NO OTHER ENTRY LIKE THIS, RESTART WAITER
      LDB PT        AN OTHER ENTRY IS FOUND, RESTORE PT 
      LDA TEMP      AND SAVE THE NEW ENTRY POINTER
      STA PT        INTO TEMP 
      STB TEMP
      LDA B,I 
      IOR BIT7      SET THE "WAIT BIT" INTO THAT ENTRY
      STA B,I 
* 
      LDA PROTE     MAKE ALL THE WAITERS
ULC73 JSB SRCWT     WAIT ON THIS NEW ENTRY
      JMP UNLC8     NO MORE WAITERS, CLEAR THE ENTRY IN LOCK TABLE
      LDB TEMP      RECALL LOCK TABLE ENTRY ADDR
      STB A,I       AND STORE IT INTO THE DIRECTORY 
      JMP ULC73     LOOP UNTIL END OF DIRECTORY 
* 
ULC75 LDB TEMP      SINCE NO IDENTICAL ENTRY EXIST IN THE 
      STB PT        LOCK TABLE, RESTORE THE ENTRY AND 
      INB           RESTART THE WAITING PROCESS 
      LDA .REC# 
      MVW D2
      JMP ULC40     RESTART THE WAITER
  SPC 1 
*                   DELETE AN ENTRY IN THE LOCK TABLE.
* 
UNLC8 CLA 
      LDB PT        CLEAR THE ENTRY IN THE LOCK TABLE 
      STA B,I 
      INB 
      STA B,I 
      INB 
      STA B,I 
* 
UNLC9 LDA PIDPT,I 
      ADA DM1       DECREMENT # OF RECORD OWNED BY THE
      STA PIDPT,I   CURRENT PROCESS 
      LDA LKTOT     DECREMENT TOTAL # OF RECS LOCKED
      SZA,RSS       IS NO. OF RECS LOCKED ZERO? 
      JMP UNLCK,I      YES, RETURN
      ADA DM1          NO, DECREMENT
      STA LKTOT 
      JMP UNLCK,I   AND EXIT
  SPC 2 
SRCWT NOP           SEARCH THE WAITERS INTO THE PROCESS 
      CPA PROTE     ID DIRECTORY, FIRST CALL ?
      RSS           YES, DO NOT BUMP POINTER
SRCW3 ADA D2        NO, BUMP POINTER
      CPA PROTB     END OF DIRECTORY ?
      JMP SRCWT,I   YES, RETURN P+1 
      INA           NO, CHECK THIS ENTRY
      LDB A,I       GET POINTER TO LOCK TABLE ENTRY 
      CPB PT        WAITING ON THIS ENTRY ? 
      RSS           YES, RETURN P+2 
      JMP SRCW3     NO, CONTINUE
      ISZ SRCWT 
      JMP SRCWT,I 
  SPC 5 
*                   SEARCH IN THE PROCESS ID DIRECTORY
* 
*     CALLING SEQUENCE: 
*        JSB SPIDD
*           RETURN P+1 - UNLOCK REQUEST AND NO LOCK ID IS DEFINED !!
*           RETURN P+2 - OLD OR NEW PID 
* 
*        ON RETURN P+2, PIDPT & PIDX ARE SET UP 
  SPC 1 
SPIDD NOP           SEARCH IN PROCESS ID DIRECTORY
      LDA LCKID     RECALL LOCKID WORD (DB#-PID) FROM 
      AND PIDMS     USER BUFFER AND ISOLATE PID 
      STA PIDX      SET PID 
      SZA           IS PID DEFINED ?
      JMP SPID4        YES, SETUP PIDPT 
      LDA LOCKW        NO, RECALL LOCK WORD 
      RAR,SLA       UNLOCK REQUEST ?
      JMP SPIDD,I      YES, ERROR 
* 
* PID IS NOT DEFINED, ADD NEW ENTRY 
* 
      JSB PACK      PACK LOCK TABLE IF NECESSARY
      LDB PROTB     GET START OF PROCESS ID DIRECTORY 
SPID2 CPB PROTE     END OF DIRECTORY ?
      JMP SPID3     YES, SETUP NEW PID
      LDA B,I       GET # OF RECORD LOCKED
      SZA,RSS       PID FREE HERE ? 
      JMP SPID3     YES 
      ADB DM3       NO, GO TO NEXT ENTRY
      JMP SPID2     CONTINUE
* 
SPID3 STB PIDPT     INIT PIDPT
      JSB SPIDX     COMPUTE PIDX
      STA PIDX      SET PID (FIRST IS ONE)
      IOR LCKID     MERGE WITH DB# TO BUILD LOCKIDWORD
      STA LCKID     SET IT THERE IN CASE OF SUSPEND 
      LDB PIDPT     RESTORE B TO
      LDA BIT15     INIT THE PROCESS ID DIRECTORY 
      STA B,I       SET # OF REC. LCK 
      ADB DM1 
      CLA 
      STA B,I       SET CLASS I/O WORD
      ADB DM1 
      STA B,I       SET POINTER TO LCK TABLE
      LDA PIDPT     WAS IT A NEW PID
      CPA PROTE     ADDED AT THE END ?
      RSS           YES, UPDATE END OF DIRECTORY
      JMP SPID5     NO, RETURN OK 
      ADB DM1       YES, UPDATE B AND 
      STB PROTE     SET NEW END OF PROCESS ID DIREC.
      JMP SPID5     AND RETURN OK 
* 
SPID4 CMA,INA       CALCULATE THE PID POINTER 
      INA 
      MPY D3
      ADA PROTB 
      STA PIDPT     SET PID POINTER 
SPID5 ISZ SPIDD 
      JMP SPIDD,I   AND RETURN OK 
* 
PIDMS OCT 17777     PID # MASK
  SPC 3 
SPIDX NOP 
      CMB,INB 
      ADB PROTB     COMPUTE 
      CLA           DIRECTORY INDEX=[(PROTB-PIDPT) 3]+1 
      SWP 
      DIV D3
      INA           (PID# MUST BE < 17777 OCTAL) !!!
      JMP SPIDX,I   EXIT WITH A=PIDX
  SPC 2 
*                   SEARCH IN RECORD LOCK TABLE 
* 
*     CALLING SEQUENCE: 
*                   PRIOR CALLING THIS FUNCTION, SET UP THE FOLLOWING:
*                   REC#, DS#, PIDX 
*        JSB SLTBL
*           RETURN P+1  - RECORD NOT LOCKED 
*           RETURN P+2  - RECORD IS LOCKED BY AN OTHER PROCESS
*           RETURN P+3  - RECORD IS LOCKED BY THE CALLING PROCESS 
* 
*        ON RETURN P+2 & P+3, THE ADDRESS OF THE ENTRY ACCESSED 
*                             IS SAVED INTO  PT, AND THE ADDRESS OF 
*                             THE LAST EMPTY ENTRY IN THE LOCK TABLE
*                             IS SAVED INTO  PTHOL
  SPC 2 
SLTBL NOP           SEARCH IN LOCK TABLE
      CLA           SET "OTHER PROCESS FLAG" TO 0 
      STA SLTFL 
      STA PT1       SET FIRST "OTHER RECORD" TO 0 
      DLD REC#      CHECK THAT REC# IS NEVER NUL (0)
      IOR B         DOUBLE INTEGER CHECK FOR 0
      SZA,RSS 
      JMP UNLE1     ERROR, DATA STRUCTURES CORRUPT!!!!!!!!!!!!!!!!!!!!
      LDA LOCTE     INIT LAST EMPTY ENTRY IN LOCK TABLE 
      STA PTHOL     WITH THE END OF TABLE 
      LDA LOCTB     GET FIRST ADDR OF LOCK TABLE
* 
SLT01 JSB SLTB0     LOOK IN THE LOCK TABLE
      JMP SLT03     END OF TABLE, RETURN
      LDA PT,I      RECALL FIRST WORD OF THE ENTRY IN THE 
      ALF,ALF       LOCK TABLE AND ISOLATE THE PID
      AND B377
      CPA PIDX      RECORD OWNED BY THE CALLING PROCESS ? 
      JMP SLT02     YES, EXIT P+3 (RECORD BELONG TO CALLING PROCESS)
      ISZ SLTFL     NO, RECORD LOCKED BY OTHER PROCESS, INC FLAG
      LDA PT            GET ENTRY ADDR
      LDB PT1           GET FIRST "OTHER PROCESS" 
      SZB,RSS           FIRST "OTHER PROCESS" ?  (.EQ.0)
      STA PT1                YES, SAVE ENTRY ADDR 
      ADA D3            POINT TO NEXT ENTRY 
      JMP SLT01         KEEP SEARCHING UNTIL PROCESS FOUND OR EOT 
* 
SLT02 ISZ SLTBL         INCREMENT RETURN ADDR 
      ISZ SLTBL               BY 2
      JMP SLTBL,I       RETURN
* 
SLT03 LDA SLTFL         ANY "OTHER PROCESSES" FOUND?
      SZA,RSS 
      JMP SLTBL,I            NO, RETURN P+1 
      LDA PT1                YES, GET FIRST "OTHER PROCESS" 
      STA PT             SET UP PT
      ISZ SLTBL          INC RETURN ADDR
      JMP SLTBL,I        RETURN P+2 
* 
SLTFL OCT 0             "OTHER PROCESS" FLAG
PT1   OCT 0             FIRST "OTHER PROCESS" 
  SPC 2 
SLTB0 NOP 
SLTL2 STA PT
      CPA LOCTE     END OF LOCK TABLE ? 
      JMP SLTB0,I   YES, EXIT P+1 (RECORD NOT FOUND)
      INA 
      LDB .REC# 
      CMW D2
      JMP SLTL3 
      NOP 
      JMP SLTL4 
SLTL3 LDA PT,I
      AND B77       MASK OUT DATA SET # 
      CPA DS#       IS IT THE SAME DATA-SET ? 
      JMP SLTL6     YES, RETURN P+2 
SLTL4 LDA PT        GO TO NEXT ENTRY
      LDB A,I 
      SZB,RSS       IS THAT ENTRY EMPTY ? 
      STA PTHOL     YES, UPDATE LAST EMPTY ENTRY IN THE LOCK TABLE
      ADA D3
      JMP SLTL2     CONTINUE
* 
SLTL6 ISZ SLTB0     RETURN P+2  ( RECORD FIND IN THE
      JMP SLTB0,I   LOCK TABLE) 
   SPC 2
PIDPT NOP           PID DIRECTORY POINTER 
PIDX  NOP           PID DIRECTORY INDEX 
PT    NOP 
PT0   NOP 
PTHOL NOP           LAST EMPTY ENTRY IN THE LOCK TABLE
* 
LOCTB NOP           FWA OF LOCK TABLE 
LOCTE NOP           LWA OF LOCK TABLE 
PROTB NOP           FWA OF DIRECTORY (DIRECTORY IS BACKWARD)
PROTE NOP           LWA OF DIRECTORY
LOCKM NOP 
* 
BIT6  OCT 100 
BIT7  OCT 200 
NBIT7 OCT 177577
B77   OCT 77
MASK1 OCT 277       CLEAR UPPER BYTE & BIT 6
  SPC 3 
*                     THIS PROGRAM PACKS THE LOCK TABLE 
  SPC 1 
PACK  NOP 
      LDB LOCTE     CHECK IF PACK IS NEEDED 
      ADB D5
      CMB,INB 
      ADB PROTE 
      SSB,RSS       NEEDED ?
      JMP PACK,I    NO, RETURN IMMEDIATELY
* 
      LDA LOCTB     YES, GET START ADDR OF LOCK TABLE 
      STA PACKA     INIT FROM POINTER 
      STA PACKB     INIT TO POINTER 
* 
PACK2 LDA PACKA     CHECK FOR END OF TABLE
      CPA LOCTE     END OF TABLE ?
      JMP PACK8     YES 
      LDA PACKA,I   GET AN ENTRY
      SZA,RSS       ENTRY HERE ?
      JMP PACK4     NO, ENTRY EMPTY 
PACK3 LDA PACKA     YES, STORE IT BACK
      LDB PACKB 
      MVW D3
      LDA PACKA,I 
      AND BIT7      MASK OUT SOMEONE IS WAITING BIT 
      SZA,RSS       IS SOMEONE WAITING ?
      JMP PACK7     NO, FORGET DIRECTORY BUSINESS 
* 
      LDA PROTB     YES, UPDATE DIRECTORY CONTENT 
PACK6 CPA PROTE     TO REFLECT THE CHANGE 
      JMP PACK7     IT IS THE END OF DIRECTORY
      ADA DM2       TO GET LOCK TABLE POINTER 
      LDB A,I       GET POINTER 
      ADA DM1 
      CPB PACKA     DIRECTORY REFERS TO THE MODIFIED ONE ?
      INA,RSS       YES, MODIFY DIRECTORY 
      JMP PACK6     NO, CONTINUE
      LDB PACKB     SET NEW POINTER VALUE 
      STB A,I       INTO THE DIRECTORY
      ADA DM1 
      JMP PACK6     CONTINUE
* 
PACK7 ISZ PACKA     BUMP POINTERS TO LOCK TABLE 
      ISZ PACKA 
      ISZ PACKA 
      ISZ PACKB 
      ISZ PACKB 
      ISZ PACKB 
      JMP PACK2     AND LOOP UNTIL END OF LOCK TABLE
* 
PACK4 ISZ PACKA     SKIP THE EMPTY SPACE
      ISZ PACKA 
      ISZ PACKA 
      LDA PACKA     CHECK FOR END OF TABLE
      CPA LOCTE     END OF LOCK TABLE ? 
      JMP PACK8        YES  
      DLD PACKA,I      NO, GET ENTRY  
      LDA PACKA 
      SZA,RSS       ENTRY EMPTY ? 
      JMP PACK4        YES, LOOP ON EMPTY ENTRY 
      JMP PACK3        NO, STORE ENTRY AND UPDATE DIRECTORY 
  SPC 1 
PACK8 LDA PACKB     SET UP NEW END OF LOCK TABLE
      CPA LOCTE     ONE HOLE FOUND ?
      JMP PACK9        NO, FATAL ERROR
      STA LOCTE        YES, SET NEW END OF LOCK TABLE 
      STA PTHOL     SET NEW LAST EMPTY ENTRY
      JMP PACK,I
* 
PACK9 LDA D402     ERROR LOCK TABLE OVERFLOW
      JMP SIMST     GO SET IMAGE STATUS 
  SPC 1 
PACKA NOP 
PACKB NOP 
  HED CONSTANTS & VARAIBLES 
DM513 DEC -513
DM256 DEC -256
DM128 DEC -128
DM10  DEC -10 
DM8   DEC -8
DM7   DEC -7
DM3   DEC -3
DM2   DEC -2
DM1   DEC -1
D0    DEC 0 
D1    DEC 1 
D2    DEC 2 
D3    DEC 3 
D4    DEC 4 
D5    DEC 5 
D6    DEC 6 
D7    DEC 7 
D8    DEC 8 
D9    DEC 9 
D10   DEC 10
D11   DEC 11
D12   DEC 12
D14   DEC 14
D15   DEC 15
D16   DEC 16
D18   DEC 18
D20   DEC 20
D22   DEC 22
D24   DEC 24
D31   DEC 31
D32   DEC 32
D101  DEC 101 
D102  DEC 102 
D104  DEC 104 
D107  DEC 107 
D150  DEC 150 
D152  DEC 152 
D201  DEC 201 
D202  DEC 202 
D302  DEC 302 
D400  DEC 400 
D401  DEC 401 
D402  DEC 402 
D403  DEC 403 
D404  DEC 404 
D405  DEC 405 
D406  DEC 406 
D414  DEC 414 
D410  DEC 410 
D451  DEC 451 
D452  DEC 452 
D460  DEC 460 
D461  DEC 461 
D462  DEC 462 
D512  DEC 512 
B27   OCT 27
B377  OCT 377 
B400  OCT 400 
B1.47 OCT 17777 
B20K  OCT 20000 
* 
BIT15 OCT 100000
  SPC 1 
TEMP  NOP 
TEMP1 NOP 
PARM1 NOP 
PARM2 NOP 
   SPC 1
C.TAB DEF *+1,I 
      DEF XDBOP     0  - DBOPN
      DEF XDBCL     1  - DBCLS
      DEF XDBGE     2  - DBGET
      DEF XDBFN     3  - DBFND
      DEF XDBPU     4  - DBPUT
      DEF XDBUP     5  - DBUPD
      DEF XDBDE     6  - DBDEL
      DEF XDBIN     7  - DBINF
      DEF XTBUL     8  - TBULK
      DEF XDBVF     9  - SPECIAL VERIFY 
* 
* 
* 
ITLST BSS 128       USED TO HOLD LIST OF ALL ITEMS IN A DATA SET
ITEMN BSS 8         USED TO HOLD ITEM NAME
      ASC 1,
   HED BUFFERS USE TO COMMUNICATE WITH THE USER PROGRAM 
*                   DO NOT DISTURB NEXT LOCATIONS 
* 
.ERCD DEF ERCOD 
.ERCL DEF ERCOL 
.ILEV DEF ILEVL 
SCODL DEC 2         BUFFER USED TO SEND DATA TO DCLOG 
      BSS 3 
ERCOL BSS 12        IMAGE ERROR CODE AND RUN TABLE
      DEC 0 
IBASE BSS 11        DATA BASE NAMR ARRAY (IBASE)
ILEVL BSS 3         LEVEL ACCESS WD 
SCODE NOP           BUFFER USED TO GET THE REQUEST
ECLAS NOP 
PARM  BSS 2 
BUF   BSS 566       (1+1+2+23+543=570)
  SPC 3 
ERCOD BSS 2         BUFFER USED TO SEND THE ANSWER
BTEMP BSS 538       (2+23+515=540)
  SPC 2 
LOCKW EQU BUF+BFLKW 
LCKID EQU BUF+BFLID 
  SPC 3 
      UNS 
* 
      ORG *         DEFINE LAST LOCATION
      END 
                                                                                      