         REF      M:LL
* TITLE - SIGMA 5/7 COBOL-65        C:TRP    RUNTIME SUBR, TRAP HANDLER
         SYSTEM   BPM
         SYSTEM   SIG7FDP
         TITLE    'C:TRP OBJECT PROGRAM SUBROUTINE'
*
* OBJECT TIME TRAP SUBROUTINE
*
*    EACH COBOL OBJECT PROGRAM ISSUES THE FOLLOWING CALL IN HOUSEKEEPING
*        M:TRAP   C:TRP,(TRAP,FP,DEC),(IGNORE,FX)
*    THUS ONLY FP (FLOATING-POINT ARITHMETIC) AND DEC (DECIMAL ARITH-
*    METIC) TRAPS REACH THIS POINT.
*    THE PURPOSE OF THIS ROUTINE IS TO IGNORE ALL OF THESE TRAP
*    CONDITIONS EXCEPT FOR ILLEGAL DECIMAL DATA. THIS CONDITION ALSO IS
*    IGNORED IF C:TRN IS SET NON-ZERO TO DENOTE THAT A COBOL 'IF NOT
*    NUMERIC' TEST IS IN PROCESS
*    BLANK IN SIGN POSITION OF OPERAND OF PACK INSTRUCTION WILL BE
*    REPLACED IN WORK AREA PACKTEM BY X'C0'.  IF PACK TRAPS AGAIN
*    ON THIS SAME DATA, JOB WILL BE ABORTED BY MONITOR.
         DEF      C:TRP,C:TRN
STEPCD   EQU      6                 STEP CODE FOR M:ERR OR M:XXX        TRP
C:TRP    RES      0
         LW,9     INTERNAL          WAS THIS A TRAP FROM THIS CODE      C:TRP
         BNEZ     BAD%PACK          ..YES. GO KILL JOB                  C:TRP
         LW,2     0,1               SAVE INSTRUCTION ADDRESS            C:TRP
         STW,2    INST%ADR                                              C:TRP
         LI,7     X'45'             DECIMAL TRAP LOCATION ADDRESS
         CW,7     18,1              WAS IT A DECIMAL TRAP
         BE       C:TRPB            YES
C:TRPA   RES      0
         MTW,1    INST%ADR          SET TO RETURN TO NEXT INST          C:TRP
         LI,6     -20                                                   C:TRP
         LW,8     *0                                                    C:TRP
         AI,8     1                                                     C:TRP
         AW,6     *8,6                                                  C:TRP
         MSP,6    *0                SHORTEN STACK TO PREV SIZE          C:TRP
         LCI      15                                                    C:TRP
         LM,1     3,1               RESTORE REGISTERS 1-11              C:TRP
         LCF      INST%ADR          SET CONDITION CODE                  C:TRP
         B        *INST%ADR         CONTINUE USER PROGRAM               C:TRP
C:TRPB   RES      0
         LW,7     C:TRN             IS TRAP TO BE IGNORED
         BNEZ     C:TRPA             YES
         LC       *1                WAS IT ILLEGAL DATA                 C:TRP
         BCR,8    C:TRPA            NO--IGNORE IT                       C:TRP
         LI,2     0                                                     C:TRP
         LW,5     0,1               INSTRUCTION                         C:TRP
         AND,5    ADDR%MSK           ADDRESS TO  R5                     C:TRP
         LW,7     0,5               INSTRUCTION                         C:TRP
         AND,7    INDX%MSK           INDEX REGISTER TO R7               C:TRP
         BEZ      NO%INDX                                               C:TRP
         SCS,7    15                ..RIGHT JUSTIFIED                   C:TRP
         AW,7     1                                                     C:TRP
         LW,2     2,7               2 = USER'S INDEX VALUE              C:TRP
NO%INDX  LW,7     0,5               INSTRUCTION                         C:TRP
         AND,7    LNTH%MSK           LENGTH TO R6 (BITS 8-11)           C:TRP
         SCS,7    13                                                    C:TRP
         BNEZ    %+2                                                    C:TRP
         AI,7     32                                                    C:TRP
         AI,7     -2                                                    C:TRP
MAXLNTH  RES      0                                                     C:TRP
         LW,6     0,5                                                   C:TRP
         AND,6    NEGINDEX                                              C:TRP
         OR,6     PCK%INST          PACK INSTRUCTION IN R6              C:TRP
         ANLZ,3   6                 GET ACTUAL BYTE ADDR TO R3          C:TRP
         AW,7     3                                                     C:TRP
         LB,8     0,7               IS IT A BLANK                       C:TRP
         CI,8     X'40'                                                 C:TRP
         BNE      BAD%PACK          NO. GO KILL JOB                     C:TRP
         LI,8     X'C0'             YES.                                C:TRP
         STB,8    0,7                TRY A ZERO                         C:TRP
         MTW,1    INTERNAL           SET INTERNAL PACK FLAG             C:TRP
         EXU      6                 PACK AGAIN                          C:TRP
         STCF      INST%ADR                                             C:TRP
         LB,8     INST%ADR                                              C:TRP
         OR,8     =X'80'           SET ABORT BIT FOR SORT               C:TRP
         STB,8    INST%ADR                                              C:TRP
         MTW,-1   INTERNAL          PACK SUCCESSFUL **                  C:TRP
         LI,8     X'40'             RESTORE HIS BLANK                   C:TRP
         STB,8    0,7                                                   C:TRP
         LCI      4                                                     C:TRP
         STM,12   14,1                                                  C:TRP
         B        C:TRPA            GO BACK TO HIM                      C:TRP
C:TRN    DATA     0                                                     C:TRP
         REF      M:DO                                                  C:TRP
*                                                                       C:TRP
*                                                                       C:TRP
*                                                                       C:TRP
BAD%PACK RES      0                                                     C:TRP
         LW,12    INTERNAL          DID I ALTER DATA                    C:TRP
         BEZ      NO%CHNG           NO.                                 C:TRP
         LI,2     %+3                                                   C:TRP
         STW,2    0,1                                                   C:TRP
         CAL1,9   5                                                     C:TRP
         LI,12    X'40'              RESTORE USER'S DATA                C:TRP
         STB,12   0,7                                                   C:TRP
NO%CHNG  RES      0                                                     C:TRP
         SLS,3    -2                                                    C:TRP
         STW,3    WORD%ST                                               C:TRP
         AI,3     8                                                     C:TRP
         STW,3    WORD%ND                                               C:TRP
         M:WRITE  M:DO,(BUF,SKPMSG),(SIZE,20)     DON'T OVERPRINT       C:TRP
         M:WRITE  M:DO,(BUF,ERRMSG),(SIZE,20)                           C:TRP
         M:SNAP   'INST',(*INST%ADR)                                    C:TRP
         LI,2     %+3                                                   C:TRP
         LI,3     X'1FFFF'                                              C:TRP
         STS,2    INST%ADR                                              C:TRP
         B        C:TRPA                                                C:TRP
         M:SNAP   'DATA',(*WORD%ST,*WORD%ND)                            C:TRP
         LB,1     X'2B'             GET SYSTEM DATA            EL00775  TRP
         SLS,1    -4                                           EL00775  TRP
         CI,1     7                 CPV                        EL00775  TRP
         BE       CPVSYS            JUMP IF CPV OR UTS          EL00875 LIO
         CI,1     6                 UTS                        EL00775  TRP
         BE       CPVSYS            JUMP IF CPV OR UTS          EL00875 LIO
         M:XXX                          D    I    E                     C:TRP
CPVSYS   RES      0                 ENTRY IF NOT CPV OR UTS    EL00775  TRP
         M:XXX    STEPCD            SET STEP CODE FOR ABORT 10/8/74     TRP
*                                                                       C:TRP
*                                                                       C:TRP
*                                                                       C:TRP
INTERNAL DATA     0                                                     C:TRP
NEGINDEX DATA     X'7FF1FFFF'      MASK TO DELETE INDEX                 C:TRP
LNTH%MSK DATA     X'00F00000'                                           C:TRP
INDX%MSK DATA     X'000E0000'                                           C:TRP
ADDR%MSK DATA     X'0001FFFF'                                           C:TRP
PCK%INST PZE      0,2                                                   C:TRP
INST%ADR DATA     0                                                     C:TRP
WORD%ST  DATA     0                                                     C:TRP
WORD%ND  DATA     0                                                     C:TRP
ZRO      DATA     0                                                     C:TRP
SKPMSG   TEXT     '                    '                                C:TRP
ERRMSG   TEXT     ' ILLEGAL DECIMAL    '                                C:TRP
         END                                                            C:TRP
