COMPASS/Sample Code

This COMPASS sample code displays the calendar of the year given as a parameter on the terminal. If no parameter is given, then the calendar of the current year is displayed.

          IDENT  CALEND,FWA 
          ABS 
          SST 
          ENTRY  CALEND,RFL=
          SYSCOM B1 
          TITLE  DISPLAY CALENDAR OF A SPECIFIC YEAR. 
          COMMENT  DISPLAY CALENDAR OF A SPECIFIC YEAR. 
 CALEND   SPACE  4,10 
***       CALEND - DISPLAY CALENDAR OF A SPECIFIC YEAR. 
* 
*              THIS PROGRAM DISPLAYS ON THE TERMINAL THE CALENDAR OF
*         THE YEAR GIVEN AS A PARAMETER.  IF NO PARAMETER IS GIVEN
*         THEN THE CALENDAR OF THE CURRENT YEAR IS DISPLAYED. 
          SPACE  4,10 
***       CONTROL STATEMENT CALL. 
* 
*         CALEND, YEAR. 
* 
*         YEAR :  MUST BE IN THE FORMAT:  CYM.  (EACH PART IS OPTIONAL.)
*           C: MAY BE G (FOR GREGORIAN) OR J (FOR JULIAN CALENDAR). 
*                DEFAULT IS  G. 
*           Y: A 1 TO 7-DIGIT NUMBER INDICATING THE YEAR YOU WANT TO
*                DISPLAY THE CALENDAR OF.  IF IT IS NOT IN THE RANGE
*                [ 0 .. 9999 ] (FOR GREGORIAN) OR [ 0 .. 6999 ] (FOR
*                JULIAN CALENDAR) IT IS PUT IN THIS RANGE.  DEFAULT IS
*                THE CURRENT YEAR.
*           M: MAY BE D (INDICATING THAT Y IS DECIMAL) OR B (INDICATING 
*                IT IS OCTAL).  DEFAULT IS D. 
* 
*         CALEND.     DISPLAYS CURRENT GREGORIAN CALENDAR.
*         CALEND, J.  DISPLAYS CURRENT JULIAN CALENDAR. 
          SPACE  4,10 
          ORG    110B 
 FWA      BSS    0
  
*         CONSTANT. 
 BUFL     EQU    401B 
  
*         FET.
 F        BSS    0
 ZZZZZG0  FILEB  FBUF,BUFL,DTY=2RTT 
  
*         STRUCTURED CONSTANTS.
*         MONTH LENGTHS 
 DPM  VFD  5/31,5/29,5/31,5/30,5/31,5/30,5/31,5/31,5/30,5/31,5/30,5/31
 +    VFD  5/31,5/28,5/31,5/30,5/31,5/30,5/31,5/31,5/30,5/31,5/30,5/31
  
*         DAY NAMES.
 DAYT     DATA   L*SUN* 
          DATA   L*MON* 
          DATA   L*TUE* 
          DATA   L*WED* 
          DATA   L*THU* 
          DATA   L*FRI* 
          DATA   L*SAT* 
  
*         CALENDAR TYPES. 
 CT       DATA   A*GREGORIAN* 
          DATA   A*JULIAN*
  
*         OUTPUT STRINGS. 
 HDR1     DATA   20H
          DATA   C*XXXXXXXXXX CALENDAR FOR XXXX*
          DATA   0
          DATA   C*       J A N U A R Y    F E B R U A R Y      M A R C 
,H         A P R I L* 
 HDR1L    EQU    *-HDR1 
  
 HDR2     DATA   0
          DATA   C*           M A Y            J U N E           J U L Y
,         A U G U S T*
 HDR2L    EQU    *-HDR2 
  
 HDR3     DATA   0
          DATA   C*     S E P T E M B E R   O C T O B E R    N O V E M B
, E R   D E C E M B E R*
 HDR3L    EQU    *-HDR3 
  
 LINE     BSS    0
          DUP    77,1 
          DATA   1R 
 LINEL    EQU    *-LINE 
  
 W4M      SPACE  4,10 
**        W4M - WRITE A 4-MONTH ROW OF THE CALENDAR.
* 
*         ENTRY  (X5) = 5/LENGTH OF FIRST MONTH, 5/LENGTH OF SECOND...
*                (X0) = 48/X, 12/START DAY OF FIRST MONTH 
  
 W4M      SUBR               ENTRY / EXIT 
          MX4    -12
          BX0    -X4*X0 
          SB4    4           MONTHS PER ROW 
 W4M1     LX5    5
          MX7    -5 
          BX6    -X7*X5      LENGTH OF MONTH
          BX2    -X4*X0      START DAY OF MONTH 
          IX3    X2+X6       SUM THEM 
          SX2    7           TAKE MOD 7 
          SX1    X3 
          IX1    X1/X2
          SX2    X1 
          LX2    3           *8 
          IX2    X2-X1       *7 
          IX3    X3-X2       START DAY OF NEXT MONTH
          LX0    12 
          BX0    X0+X3
          SB4    B4-B1
          NE     B4,W4M1     REPEAT FOR 4 MONTHS
          SA0    B0          LINE COUNTER 
 W4M2     LX0    60-12*4
          LX5    60-5*4 
          SB4    B0+         MONTH COUNTER
          SB3    4           MONTHS PER LINE
          SB5    6           DAYS PER MONTH PER LINE
 W4M3     MX7    -12
          BX3    -X7*X0      START DAY OF THIS MONTH
          LX0    12 
          MX7    -5 
          LX5    5
          BX4    -X7*X5      LENGTH OF THIS MONTH 
          SB6    B0+         DAY COUNTER
 W4M4     SX7    1R 
          SB2    B6+B6
          SB2    B2+B6       3*B6 
          SX1    B4 
          LX1    4           16*B4
          SB2    B2+B4
          SB2    B2+B4
          SX1    X1+B2
          SX1    X1+LINE+6   X1 = LINE + 18*B4 + 3*B6 + 6 
          SA7    X1          INITIALIZE TO BLANKS 
          SA7    A7+B1
          SB7    B6+B6       2*B6 
          SB7    B7+B7       4*B6 
          SB7    B7+B7       8*B6 
          SB7    B7-B6       7*B6 
          SB7    B7+A0
          SB2    X3 
          SB7    B7-B2
          SB7    B7+B1       DAY NUMBER = 7*B6 + A0 - X3 + 1
          LT     B7,B1,W4M7  IF NULL ENTRY (B7 .LE. 0)
          SB2    X4          LENGTH OF MONTH
          GT     B7,B2,W4M7  IF NULL ENTRY (B7 .GT. X4) 
          SB2    10 
          LT     B7,B2,W4M6  IF ONE CHARACTER 
          SX7    1R0
 W4M5     SB7    B7-B2
          SX7    X7+B1
          GE     B7,B2,W4M5  UNTIL B7 < 10
          SA7    X1+
 W4M6     SX7    B7+1R0 
          SA7    X1+1 
 W4M7     SB6    B6+B1
          NE     B6,B5,W4M4  NEXT DAY 
          SB4    B4+B1
          NE     B4,B3,W4M3  NEXT MONTH 
          SA1    DAYT+A0     SET DAY NAME 
          MX2    -6 
          LX1    6
          BX7    -X2*X1 
          SA7    LINE+1 
          LX1    6
          BX7    -X2*X1 
          SA7    A7+B1
          LX1    6
          BX7    -X2*X1 
          SA7    A7+B1
          WRITES F,LINE,LINEL 
          SA0    A0+1        INCREMENT LINE NUMBER
          SB7    A0-7        CHECK IF .EQ. 7
          NE     B7,W4M2     NEXT LINE
          JP     W4MX        RETURN 
 CALEND   SPACE  4,10 
*         MAIN PROGRAM. 
  
 CALEND   SB1    1
          SA2    ACTR        NUMBER OF PARAMETERS 
          SB2    X2+
          LE     B2,B1,CAL1  IF ONE OR ZERO PARAMETERS
          SX1    =C* TOO MANY PARAMETERS.*
          EQ     ERR         ABORT
  
 CAL1     R=     A1,ARGR
          MX4    42 
          BX2    X4*X1       GET PARAMETER
          LX2    6
          BX3    -X4*X2      GET FIRST CHARACTER
          BX5    X4*X2       REST OF PARAMETER (YEAR) 
          SB7    B1          DECIMAL BASE FOR CONVERSION
          SB6    B1          INDICATE JULIAN CALENDAR 
          SB3    X3-1RJ 
          EQ     B3,CAL1.1   IF JULIAN CALENDAR 
          SB6    B0+         INDICATE GREGORIAN CALENDAR
          SB3    X3-1RG 
          EQ     B3,CAL1.1   IF GREGORIAN CALENDAR
          BX5    X4*X1       IF NO CALENDAR TYPE SPECIFIED (GREGORIAN)
  
 CAL1.1   ZR     X5,CAL2     IF NO YEAR (DEF. CURRENT YEAR) 
          RJ     DXB         CONVERT TO BINARY
          SX1    =C* ERROR IN PARAMETER.* 
          NZ     X4,ERR      IF CONVERSION ERROR
          ZR     X6,ERR      IF 0 YEAR
          SX2    10000
          EQ     B6,CAL1.2   IF GREGORIAN CALENDAR
          SX2    7000        IF JULIAN CALENDAR 
 CAL1.2   SX4    X2 
          BX7    X6 
          IX2    X7/X2
          IX2    X2*X4
          IX6    X6-X2       YEAR MOD (10000 OR 7000) 
          EQ     CAL2.1      CONTINUE BELOW 
  
 CAL2     SA0    B6 
          PDATE  CALEND      GET CURRENT DATE 
          SB6    A0 
          MX4    -6 
          SA1    CALEND 
          AX1    30 
          BX3    -X4*X1 
          SX6    X3+1970     CURRENT YEAR 
 CAL2.1   EQ     B6,CAL3     IF GREGORIAN CALENDAR
  
*         JULIAN.  (X6) = YEAR IN [ 0 .. 6999 ].
  
          SX3    28 
          SX4    X3 
          SX5    X6          SAVE YEAR IN X5
          IX6    X6/X3
          IX6    X6*X4
          IX6    X5-X6       YEAR MOD 28
          MX4    -2 
          BX4    -X4*X6      MOD 4
          CX4    X4 
          CX4    X4 
          SA0    DPM+X4 
          SX4    X6+19
          AX4    2           / 4
          IX0    X6+X4       KYR
          EQ     CAL6        CONTINUE TO TAKE MOD 7 
  
*         GREGORIAN.  (X6) = YEAR IN [ 0 .. 9999 ]. 
  
 CAL3     SA0    DPM+1       ASSUME NOT LEAP YEAR 
          SX3    400
          SX4    X3 
          SX5    X6          SAVE YEAR IN X5
          IX6    X6/X3
          IX6    X6*X4
          IX6    X5-X6       YEAR MOD 400 (MYR) 
          SX1    X6          SAVE MYR IN X1 
          AX6    2           MYR/4
          SX3    100
          SX4    X1 
          IX4    X4/X3       MYR/100
          IX0    X1+X6
          IX0    X0-X4       (KYR) = MYR + MYR/4 - MYR/100
          SX6    X5 
          SX3    100
          IX6    X6/X3
          SX3    100
          IX6    X6*X3
          IX6    X5-X6       YEAR MOD 100 
          ZR     X6,CAL4     IF / 100 CHECK ALSO IF / 400 
          MX7    -2 
          BX7    -X7*X5      YEAR MOD 4 
          ZR     X7,CAL5     IF /  4 (LEAP YEAR)
          EQ     CAL6        NOT LEAP 
  
 CAL4     NZ     X1,CAL6     IF NOT LEAP (NOT / 400)
 CAL5     SX0    X0+6 
          SA0    DPM         LEAP YEAR
  
*         GREGORIAN OR JULIAN CALENDAR. 
  
 CAL6     SX3    7
          BX6    X0 
          IX6    X6/X3
          SX3    X6 
          LX3    3           *8 
          IX6    X3-X6       *7 
          IX0    X0-X6       KYR MOD 7 (1ST JANUARY)
          SA1    CT+B6
          BX6    X1 
          SA6    HDR1+2      SET CALENDAR TYPE
          SX1    X5+10000    ZERO PAD FROM LEFT 
          MX5    24          PREPARE MASK 
          LX5    -24
          RJ     CDD         CONVERT YEAR TO DISPLAY CODE 
          LX6    12 
          BX7    X5*X6
          SA1    HDR1+4 
          BX6    -X5*X1 
          BX7    X6+X7
          SA7    A1+         PUT YEAR IN HEADER 
          RETURN F,R
          PROTECT  ,ON
          REQUEST  F,U,N
          WRITEW F,HDR1,HDR1L 
          SA5    A0          GET DPM OR DPM+1 
          RJ     W4M
          WRITEW F,HDR2,HDR2L 
          RJ     W4M
          WRITEW F,HDR3,HDR3L 
          RJ     W4M
          WRITER F,R
          MESSAGE  HDR2,1,R 
          ENDRUN
  
 ERR      MESSAGE  X1,3,R 
          ABORT 
  
*         EXTERNAL TEXT.
  
 COMCPL   XTEXT  COMCCDD
 COMCPL   XTEXT  COMCCIO
 COMCPL   XTEXT  COMCCPM
 COMCPL   XTEXT  COMCDXB
 COMCPL   XTEXT  COMCLFM
 COMCPL   XTEXT  COMCSYS
 COMCPL   XTEXT  COMCWTS
 COMCPL   XTEXT  COMCWTW
 BUFFERS  SPACE  4,10 
          USE    BUFFERS
 FBUF     EQU    *
 RFL=     EQU    FBUF+BUFL+10 
          LIST   -R 
  
          END