COMPASS/Sample Code
From Wikipedia, the free encyclopedia
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 CONTANTS.
* 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
