Retro1.org codex

*DECK     XABTAPP 
USETEXT NIPDEF
USETEXT APPSTAT 
USETEXT ACB 
USETEXT AT
USETEXT DRHDR 
USETEXT DUMPFLG 
USETEXT FLIST 
USETEXT NWLHEAD 
USETEXT OVERLAY 
USETEXT PARAMS
USETEXT PT
USETEXT PWL 
USETEXT SWAPIN
      PRGM XABTAPP;          # ABORT APPLICATION                       #
 
 STARTIMS;
 #
*1DC  XABTAPP 
* 
*     1. PROC NAME           AUTHOR              DATE 
*        XABTAPP             P.C.TAM             80/02/07 
* 
*     2. FUNCTIONAL DESCRIPTION.
*        THIS ROUTINE IS RESPONSIBLE FOR ABORTING THE UCP.
* 
*     3. METHOD USED. 
*          DETERMINE IF ACB EXISTS FOR APPLICATION TO ABORT 
*          SEND FAIL/APP SUP MSG TO NVF IF ACB EXISTS 
*          CREATE SCP FUNCTION TO ABORT APP AND END CONNECTIONS WITH NAM
*          ISSUE SCP CALL 
*          PROCESS SCP FUNCTION RETURN CODES
* 
*     4. ENTRY PARAMETERS.
*          ABTADDR           ACB, NWL, OR BUFFER ADDRESS
*          ABTAPPF           REASON CODE FOR ABORTING APPLICATION 
*          ABTJOBID          APP JOB ID WORD IF ABTADDR = BUFFER ADDRESS
*          ABTSIZE           SIZE OF BUFFER IF ABTADDR = BUFFER ADDRESS 
* 
*     5. EXIT PARAMETERS. 
*          FAILADR           SET IF NIP GETS SCP RC = RCUCPGONE 
* 
*     6. COMDECKS CALLED AND SYMPL TEXTS USED.
*        APPSTAT   DRHDR     DUMPFLG
*        FLIST     NIPDEF    NWLHEAD
*        OPSIZE    OVERLAY   PARAMS    ACB
*        SWAPIN    AT        PT 
* 
*     7. ROUTINES AND OVERLAYS CALLED.
*          MRELS             RELEASE BUFFER SPACE 
*          OSCCALL           SYS-CTL-PT CALL
*          OSCPSI     OVL    SCHEDULE APPLICATION (NO PCB EXIST)
*          OVLCALL           LOAD AND EXECUTE OVERLAY 
*          RDUMP             DUMP NIP-S FIELD LENGTH
*          XTRACE            TRACES CALLS 
*          MGETS             ALLOCATE BUFFER
* 
*     8. DAYFILE MESSAGES.   AT NIP-S CONTROL POINT 
*          *NOT YET NETTED ON*
*          *NON-EXISTENT APPLICATION ID*
*          *APP WORK LIST ADDR=0* 
*          *BAD WORD/ENTRY COUNT* 
*          *SECURITY VIOLATION* 
*          *ADDRESS OUT OF RANGE* 
*          *INVALID MINACN/MAXACN ON NETON* 
*          *INVALID APPLICATION NAME ON NETON*
*          *BAD AIP OPCODE* 
*          *OVER 500 SUP MSGS QUEUED FOR APP* 
*          *EXTRA WORK LIST*
*          *FILE LIMIT/FNT SPACE ERROR* 
* 
*        THIS PROGRAM IS A PRIMARY OVERLAY LOADED BY SUBROUTINE 
*        OVLCALL.  WHEN EXECUTION HAS COMPLETED, A JUMP IS MADE TO
*        LOCATION RJMAIN TO RETURN TO THE CALLING PROGRAM.
* 
*        W A R N I N G - THIS PROGRAM CANNOT EXCEED THE PRIMARY 
*CALL OPSIZE
* 
*        THIS OVERLAY IS CALLED BY HHIR, XSACB AND XSAPP. 
* 
 #
 STOPIMS; 
# 
 INPUT PARAMETERS            #
# PARAMS1 = INDEX USED TO EXTRACT MESSAGE                              #
# OUTPUT PARAMETERS  NONE 
  
                    EXTERNAL VARIABLES
# 
  XREF BEGIN
    PROC MGETS ;
    PROC MRELS;              # RELEASE BUFFER SPACE                    #
    PROC OSCCALL;            # SYS-CTL-PT FUNCTION                     #
    PROC OVLCALL; 
    PROC RDUMP; 
    PROC XTRACE;
    LABEL RJMAIN;            # RETURN ADDRESS IN OVLCALL               #
    END 
# 
                    LOCAL VARIABLES 
# 
ARRAY OFMESSAGES [1:XMSGNUM] S(4);
   BEGIN
   ITEM ABTMSG C(0,0,38) = ["NOT YET NETTED ON",
                            "NONEXISTENT APPLICATION ID", 
                            "APP WORK LIST ADDR=0", 
                            "BAD WORD/ENTRY COUNT", 
                            "SECURITY VIOLATION", 
                            "ADDRESS OUT OF RANGE", 
                            "INVALID MINACN/MAXACN ON NETON", 
                            "INVALID APPLICATION NAME ON NETON",
                            "BAD AIP OPCODE", 
                            "OVER 500 SUP MSGS QUEUED FOR APP", 
                            "EXTRA WORK LIST",
                            "FILE LIMIT/FNT SPACE ERROR", 
                            "ABORT CONDITION SET FOR CONCB",
                            "ABORT CONDITION SET FOR SHUT/DOWN",
                            "ABORT CONDITION SET FOR FCINACT",
                            "MASTER REQUEST SLAVE TO ABORT"] ;
   ITEM ABTMSGWD U(0,0,60); 
   ITEM ENDTEXT I(3,48,12) = [XMSGNUM(0)];
   END
 ITEM DFDADDR ;              # DAYFILE MESSAGE ADDRESS                 #
 ITEM IDX;                   # INDEX                                   #
 ITEM SCPADDR ;                        # ADDRESS OF FUNCTION LIST      #
#**********************************************************************#
BEGIN 
      CONTROL IFEQ DEBUG,1 ;
        XTRACE("XABTA") ; 
      CONTROL FI; 
# 
      INITIAL SET UP FOR ABORTING APPLICATION 
# 
      ACBADDR = 0;
      P<DRHDRWD> = ABTADDR; 
# 
      DETERMINE THE BUFFER INPUT IS AN ACB OR A NWL OR A BUFFER 
# 
 
      IF BLKID[0] EQ ACBIDVALUE 
        OR BLKID[0] EQ NONMOVEABLE
      THEN
        BEGIN                          # ABTADDR IS AN ACB ADDRESS     #
        ACBADDR = ABTADDR ;            # ACB ADDRESS                   #
        P<ACB> = ACBADDR ;
        JOBID = ACBJNWD[0] ;           # SAVE THE JOB SEQUENCE NUMBER  #
        END                            # ABTADDR IS AN ACB ADDRESS     #
      ELSE
        BEGIN                          # BUFFER IS A NWL O BUFFER      #
        P<NWLHEADER> = ABTADDR ;
        IF BLKID[0] EQ NWLIDVALUE 
        THEN
          JOBID = NWLJOBID[0] ;        # SAVE THE J S N                #
        ELSE
          JOBID = ABTJOBID ;
 
# 
        LOCATION THE ACB FOR THE JOB ID NAME
# 
        FOR IDX = 1 STEP 1 WHILE IDX LQ ATHAN[0]
                                  AND ACBADDR EQ 0
        DO
          BEGIN 
          P<ACB> = ATACBA[IDX] ;
          IF P<ACB> NQ 0
             AND ACBJNWD[0] EQ JOBID
          THEN
            ACBADDR = P<ACB> ;
          END 
 
        IF ACBADDR NQ 0 
        THEN  # ACB EXISTS #
           ACBNWLWD[0] = 0;  # CLEARS NWL PTRS #
        MRELS(P<DRHDRWD>) ;            # RELEASE THE NWL               #
        END                            # BUFFER IS A NWL OR BUFFER     #
 
      MGETS(FLSIZE+SWPISIZE+5,SCPADDR,TRUE); # BUFFER FOR SCP LIST     #
      P<DRHDRWD> = 0 ;
# 
      COPY DAYFILE MESSAGE INTO SCP BUFFER FUNCTION LIST
# 
      DFDADDR = SCPADDR + FLSIZE + 1 ;  # DAYFILE MESSAGE              #
      FOR IDX = 0 STEP 1 UNTIL 3
      DO
        CMWORD[DFDADDR+IDX] = CMWORD[LOC(ABTMSGWD[ABTAPPF]) + IDX] ;
 
#     SET UP THE FUNCTION LIST         #
      P<FLHEAD> = SCPADDR ; 
      FLID[0] = NAFLIDVALUE ; 
      FLBS[0] = FLSIZE ;
      FLJOBID[0] = JOBID ;
      FLUCPA[0] = 1 ; 
      FLSCPA[0] = DFDADDR ;  # DAYFILE MESSAGE ADDRESS                 #
      P<FLE> = SCPADDR + BLKHSIZE ; 
      FLFC[0] = SFREGR ;
 
      OSCCALL(FLE) ;
 
      IF FLRC[0] EQ RCSWAPPEDOUT
      THEN
        BEGIN                          # APPL. DAS BEEN SWAPPED OUT    #
        PARAMS1 = SCPADDR ;            # SET UP THE SWAP IN LIST       #
        PARAMS2 = SCPADDR + FLSIZE + 5 ;
        PARAMS3 = SCPADDR + FLSIZE ;
        P<DRHDRWD> = SCPADDR + FLSIZE ; 
        BLKBS[0] = 5 ;
        OVLNAME = OSCPSIP ; 
        OVLCALL ; 
        END                            # APPL. HAS BEEN SWAPPED OUT    #
      ELSE
        BEGIN                          # ZERO AND OTHER REASON CODE    #
        IF FLRC[0] EQ RCUCPGONE 
              OR FLRC[0] EQ RCSTCBAD
        THEN                           # APPLICATION IS GONE           #
          BEGIN                        # APPLICATION IS GONE           #
          IF ACBADDR NQ 0 
          THEN                         # BUT ACB STILL EXITS           #
            FAILADR = ACBADDR ;        # MAKE FAIL APPL.               #
          ELSE
            BEGIN                      # APPLICATION IS GONE           #
            DMPFLG = DXABTAP1 ;        # DUMP FLAG                     #
            RDUMP ; 
            END                        # APPLICATION IS GONE           #
          END                          # APPLICATION IS GONE           #
 
        BLKBS[SCPADDR] = FLSIZE + SWPISIZE + 5 ;
        MRELS(SCPADDR) ;               # RELEASE THE FLIST BUFFER      #
        END                            # ZERO OR OTHER REASON CODE     #
      ABTAPPF = 0;
      GOTO RJMAIN;           # RETURN TO CALLING PROGRAM               #
END 
TERM