COMPSRR 
COMMON
          CTEXT  COMPSRR - SET R-REGISTER.
          IF     -DEF,QUAL$,1 
          QUAL   COMPSRR
*         COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC.  1992. 
 SRR      SPACE  4
***       SRR - SET R-REGISTER. 
*         D. O. HAMNES.      92/03/18.
 SRR      SPACE  4,15 
***       *COMPSRR* MAY BE USED TO SET AND RESTORE THE VALUE OF 
*         THE R-REGISTER ON MAINFRAMES WHICH SUPPORT R-REGISTERS. 
* 
*         IF *SRR$* IS DEFINED, THEN THE CONTENTS OF DIRECT CELLS 
*         T1 AND T2 WILL NOT BE RESTORED.  IF NOT DEFINED,
*         THEN THEY WILL BE RESTORED TO THEIR VALUES UPON ENTRY.
* 
*         IF *PRR$* IS DEFINED, THEN THE PRESET ROUTINE *PRR* WILL
*         BE DEFINED IN A REMOTE BLOCK LABELED *PRR*. 
* 
*         IF *PIR$* IS DEFINED, THEN THE SPECIAL PRESET ROUTINE 
*         *PIR* WILL BE DEFINED.  IF *PRR$* IS ALSO DEFINED, THEN 
*         THE CODE FOR THIS ROUTINE WILL ALSO BE IN THE *PRR* REMOTE
*         BLOCK.
 SRR      SPACE  4,15 
**        SRR - SET R-REGISTER. 
* 
*         ENTRY  (RRRB - RRRC) = R-REGISTER VALUE TO BE SET.
* 
*         EXIT   (R) = (RRRB - RRRC), IF R-REGISTER PRESENT.
*                (T1 - T2) RESTORED IF SRR$ NOT DEFINED.
*                (RRRD - RRRE) = (R) UPON ENTRY.
* 
*         USES   T0, T1, T2.
* 
*         CALLS  NONE.
  
  
 SRR      SUBR               ENTRY/EXIT 
 SRRA     UJN    RRR1        SAVE DIRECT CELLS IF DESIRED 
*         UJN    SRRX        (R-REGISTERS NOT SUPPORTED)
 RRR      SPACE  4,15 
**        RRR - RESTORE R-REGISTER. 
* 
*         ENTRY  (RRRD - RRRE) = R-REGISTER VALUE TO BE SET.
*                (NORMALLY ESTABLISHED BY *SRR*). 
* 
*         EXIT   (R) = (RRRD - RRRE), IF R-REGISTER PRESENT.
*                (T1 - T2) RESTORED IF SRR$ NOT DEFINED.
* 
*         USES   T0, T1, T2.
* 
*         CALLS  NONE.
  
  
 RRR2     LDC    ** 
 RRRD     EQU    *-1
          STD    T1 
          LDC    ** 
 RRRE     EQU    *-1
          STD    T2 
          LRD    T1 
          SOM    RRRH 
  
*         RESTORE DIRECT CELLS. 
  
 RRR3     BSS    0
 SRR$     IF     -DEF,SRR$
          LDC    **          RESTORE DIRECT CELLS WHICH ARE USED
 RRRF     EQU    *-1
          STD    T1 
          LDC    ** 
 RRRG     EQU    *-1
          STD    T2 
 SRR$     ENDIF 
          LDD    T0 
          ZJN    SRRX        IF *SRR* CALL
*         UJN    RRRX        RETURN TO CALLER OF *RRR*
  
 RRR      SUBR               ENTRY/EXIT 
 RRRA     AOM    RRRH 
*         UJN    RRRX        (R-REGISTERS NOT SUPPORTED)
  
*         SAVE DIRECT CELLS.
  
 RRR1     BSS    0
 SRR$     IF     -DEF,SRR$
          LDD    T1 
          STM    RRRF 
          LDD    T2 
          STM    RRRG 
 SRR$     ENDIF 
 RRRH     LDN    0
*         LDN    1           (RRR ENTRY POINT)
          STD    T0 
          NJN    RRR2        IF RESTORE 
  
*         SAVE PRESENT VALUE OF R-REGISTER AND
*         SET SAVED VALUE.
  
          SRD    T1 
          LDD    T1          SAVE CP RA 
          STM    RRRD 
          LDD    T2 
          STM    RRRE 
          LDC    **          SET SAVED R-REGISTER VALUE 
 RRRB     EQU    *-1
          STD    T1 
          LDC    ** 
 RRRC     EQU    *-1
          STD    T2 
          LRD    T1 
          LJM    RRR3        RESTORE DIRECT CELLS 
 PRR      SPACE  4,10 
**        PRR - PRESET *COMPSRR* CODE.
* 
*         EXIT   DETERMINATION HAS BEEN MADE AS TO WHETHER R-REGISTERS
*                ARE SUPPORTTED ON THE MACHINE.  IF THEY ARE NOT, THEN
*                THE FIRST INSTRUCTION OF EACH OF *SRR* AND *RRR* IS
*                SET TO EXIT THE ROUTINE. 
*                (A) .LT. 0, IF R-REGISTERS NOT SUPPORTED.
*                (A) .GE. 0, IF R-REGISTERS SUPPORTED.
* 
*         USES   CM - CM+4. 
* 
*         MACROS ISTORE.
  
  
 PRR$     IF     DEF,PRR$,1 
 PRR      RMT 
 PRR      SUBR               ENTRY/EXIT 
          LDC    MABL 
          CRD    CM 
          LDD    CM+1 
          SHN    21-13
          PJN    PRRX        IF 180 CLASS MACHINE 
          ISTORE SRRA,(UJN SRRX)
          ISTORE RRRA,(UJN RRRX)
          LDC    400000 
          UJN    PRRX        RETURN 
 PRR$     IF     DEF,PRR$,1 
 PRR      RMT 
 PIR      SPACE  4,10 
**        PIR - PRESET WITH IAF R-REGISTER. 
* 
*         ENTRY  IAF HAS BEEN DETERMINED TO BE ACCESSIBLE.
* 
*         EXIT   (TA) = 4000B, IF R-REGISTERS PRESENT.
*                     = IAF RA/100B, IF R-REGISTERS NOT PRESENT.
* 
*         USES   CM - CM+4, TA. 
* 
*         CALLS  PRR. 
  
  
 PIR$     IF     DEF,PIR$ 
 PRR$     IF     DEF,PRR$,1 
 PRR      RMT 
 PIR      SUBR               ENTRY/EXIT 
          RJM    PRR         PRESET RESTORE R-REGISTER ROUTINES 
          MJN    PIR1        IF R-REGISTERS NOT SUPPORTED 
  
*         PRESET FOR MACHINE WITH R-REGISTER. 
  
 .A       IF     DEF,/REM/VCPT
          LDC    /REM/VCPT*200+FLSW 
 .A       ELSE
          LDC    //VCPT*200+FLSW
 .A       ENDIF 
          CRD    CM 
          LDD    CM+2 
          STM    RRRB 
          LDD    CM+3 
          STM    RRRC 
          LDC    4000B       SET R-REGISTER USE BIT 
          STD    TA 
          UJN    PIRX        RETURN 
  
*         PRESET FOR MACHINE WITHOUT R-REGISTER.
  
 PIR1     BSS    0
 .A       IF     DEF,/REM/VCPT
          LDC    /REM/VCPT*200+FLSW 
 .A       ELSE
          LDC    //VCPT*200+FLSW
 .A       ENDIF 
          CRD    CM 
          LDD    CM+3        SET IAF RA/100B
          STD    TA 
          LJM    PIRX        RETURN 
 PRR$     IF     DEF,PRR$,1 
          RMT 
 PIR$     ENDIF 
          SPACE  4
 QUAL$    IF     -DEF,QUAL$ 
          QUAL   *
 SRR      EQU    /COMPSRR/SRR 
 RRR      EQU    /COMPSRR/RRR 
 PRR      EQU    /COMPSRR/PRR 
 PIR$     IF     DEF,PIR$ 
 PIR      EQU    /COMPSRR/PIR 
 PIR$     ENDIF 
 QUAL$    ENDIF 
          ENDX
