182 lines
7.3 KiB
Plaintext
182 lines
7.3 KiB
Plaintext
* CALENDAR FOR REAL PROGRAMMERS 05/03/2017
|
|
CALENDAR CSECT
|
|
USING CALENDAR,R13 BASE REGISTER
|
|
B 72(R15) SKIP MY SAVEAREA
|
|
DC 17F'0' MY SAVEAREA
|
|
STM R14,R12,12(R13) SAVE CALLER'S REGISTERS
|
|
ST R13,4(R15) LINK BACKWARD
|
|
ST R15,8(R13) LINK FORWARD
|
|
LR R13,R15 SET ADDRESSABILITY
|
|
L R4,YEAR YEAR
|
|
SRDA R4,32 .
|
|
D R4,=F'4' YEAR//4
|
|
LTR R4,R4 IF YEAR//4=0
|
|
BNZ LYNOT
|
|
L R4,YEAR YEAR
|
|
SRDA R4,32 .
|
|
D R4,=F'100' YEAR//100
|
|
LTR R4,R4 IF YEAR//100=0
|
|
BNZ LY
|
|
L R4,YEAR YEAR
|
|
SRDA R4,32 .
|
|
D R4,=F'400' IF YEAR//400
|
|
LTR R4,R4 IF YEAR//400=0
|
|
BNZ LYNOT
|
|
LY MVC ML+2,=H'29' ML(2)=29 LEAPYEAR
|
|
LYNOT SR R10,R10 LTD1=0
|
|
LA R6,1 I=1
|
|
LOOPI1 C R6,=F'31' DO I=1 TO 31
|
|
BH ELOOPI1
|
|
XDECO R6,XDEC EDIT I
|
|
LA R14,TD1 TD1
|
|
AR R14,R10 TD1+LTD1
|
|
MVC 0(3,R14),XDEC+9 SUB(TD1,LTD1+1,3)=PIC(I,3)
|
|
LA R10,3(R10) LTD1+3
|
|
LA R6,1(R6) I=I+1
|
|
B LOOPI1
|
|
ELOOPI1 LA R6,1 I=1
|
|
LOOPI2 C R6,=F'12' DO I=1 TO 12
|
|
BH ELOOPI2
|
|
ST R6,M M=I
|
|
MVC D,=F'1' D=1
|
|
MVC YY,YEAR YY=YEAR
|
|
L R4,M M
|
|
C R4,=F'3' IF M<3
|
|
BNL GE3
|
|
L R2,M M
|
|
LA R2,12(R2) M+12
|
|
ST R2,M M=M+12
|
|
L R2,YY YY
|
|
BCTR R2,0 YY-1
|
|
ST R2,YY YY=YY-1
|
|
GE3 L R2,YY YY
|
|
LR R1,R2 YY
|
|
SRA R1,2 YY/4
|
|
AR R2,R1 YY+(YY/4)
|
|
L R4,YY YY
|
|
SRDA R4,32 .
|
|
D R4,=F'100' YY/100
|
|
SR R2,R5 YY+(YY/4)-(YY/100)
|
|
L R4,YY YY
|
|
SRDA R4,32 .
|
|
D R4,=F'400' YY/400
|
|
AR R2,R5 YY+(YY/4)-(YY/100)+(YY/400)
|
|
A R2,D R2=YY+(YY/4)-(YY/100)+(YY/400)+D
|
|
LA R5,153 153
|
|
M R4,M 153*M
|
|
LA R5,8(R5) 153*M+8
|
|
D R4,=F'5' (153*M+8)/5
|
|
AR R5,R2 ((153*M+8)/5+R2
|
|
LA R4,0 .
|
|
D R4,=F'7' R4=MOD(R5,7) 0=SUN 1=MON ... 6=SAT
|
|
LTR R4,R4 IF J=0
|
|
BNZ JNE0
|
|
LA R4,7 J=7
|
|
JNE0 BCTR R4,0 J-1
|
|
MH R4,=H'3' J*3
|
|
LR R10,R4 J1=J*3
|
|
LR R1,R6 I
|
|
SLA R1,1 *2
|
|
LH R11,ML-2(R1) ML(I)
|
|
MH R11,=H'3' J2=ML(I)*3
|
|
MVC TD2,BLANK TD2=' '
|
|
LA R4,TD1 @TD1
|
|
LR R5,R11 J2
|
|
LA R2,TD2 @TD2
|
|
AR R2,R10 @TD2+J1
|
|
LR R3,R5 J2
|
|
MVCL R2,R4 SUB(TD2,J1+1,J2)=SUB(TD1,1,J2)
|
|
LR R1,R6 I
|
|
MH R1,=H'144' *144
|
|
LA R14,DA-144(R1) @DA(I)
|
|
MVC 0(144,R14),TD2 DA(I)=TD2
|
|
LA R6,1(R6) I=I+1
|
|
B LOOPI2
|
|
ELOOPI2 XPRNT SNOOPY,132 PRINT SNOOPY
|
|
L R1,YEAR YEAR
|
|
XDECO R1,PG+56 EDIT YEAR
|
|
XPRNT PG,L'PG PRINT YEAR
|
|
MVC WDLINE,BLANK WDLINE=' '
|
|
LA R10,1 LWDLINE=1
|
|
LA R8,1 K=1
|
|
LOOPK3 C R8,=F'6' DO K=1 TO 6
|
|
BH ELOOPK3
|
|
LA R4,WDLINE @WDLINE
|
|
AR R4,R10 +LWDLINE
|
|
MVC 0(20,R4),WDNA SUB(WDLINE,LWDLINE+1,20)=WDNA
|
|
LA R10,20(R10) LWDLINE=LWDLINE+20
|
|
C R8,=F'6' IF K<6
|
|
BNL ITERK3
|
|
LA R10,2(R10) LWDLINE=LWDLINE+2
|
|
ITERK3 LA R8,1(R8) K=K+1
|
|
B LOOPK3
|
|
ELOOPK3 LA R6,1 I=1
|
|
LOOPI4 C R6,=F'12' DO I=1 TO 12 BY 6
|
|
BH ELOOPI4
|
|
MVC MOLINE,BLANK MOLINE=' '
|
|
LA R10,6 LMOLINE=6
|
|
LR R8,R6 K=I
|
|
LOOPK4 LA R2,5(R6) I+5
|
|
CR R8,R2 DO K=I TO I+5
|
|
BH ELOOPK4
|
|
LR R1,R8 K
|
|
MH R1,=H'10' *10
|
|
LA R3,MO-10(R1) MO(K)
|
|
LA R4,MOLINE @MOLINE
|
|
AR R4,R10 +LMOLINE
|
|
MVC 0(10,R4),0(R3) SUB(MOLINE,LMOLINE+1,10)=MO(K)
|
|
LA R10,22(R10) LMOLINE=LMOLINE+22
|
|
LA R8,1(R8) K=K+1
|
|
B LOOPK4
|
|
ELOOPK4 XPRNT MOLINE,L'MOLINE PRINT MONTHS
|
|
XPRNT WDLINE,L'WDLINE PRINT DAYS OF WEEK
|
|
LA R7,1 J=1
|
|
LOOPJ4 C R7,=F'106' DO J=1 TO 106 BY 21
|
|
BH ELOOPJ4
|
|
MVC PG,BLANK CLEAR BUFFER
|
|
LA R9,PG PGI=0
|
|
LR R8,R6 K=I
|
|
LOOPK5 LA R2,5(R6) I+5
|
|
CR R8,R2 DO K=I TO I+5
|
|
BH ELOOPK5
|
|
LR R1,R8 K
|
|
MH R1,=H'144' *144
|
|
LA R4,DA-144(R1) DA(K)
|
|
BCTR R4,0 -1
|
|
AR R4,R7 +J
|
|
MVC 0(21,R9),0(R4) SUBSTR(DA(K),J,21)
|
|
LA R9,22(R9) PGI=PGI+22
|
|
LA R8,1(R8) K=K+1
|
|
B LOOPK5
|
|
ELOOPK5 XPRNT PG,L'PG PRINT BUFFER
|
|
LA R7,21(R7) J=J+21
|
|
B LOOPJ4
|
|
ELOOPJ4 LA R6,6(R6) I=I+6
|
|
B LOOPI4
|
|
ELOOPI4 L R13,4(0,R13) RESTORE PREVIOUS SAVEAREA POINTER
|
|
LM R14,R12,12(R13) RESTORE CALLER'S REGISTERS
|
|
XR R15,R15 SET RETURN CODE TO 0
|
|
BR R14 RETURN TO CALLER
|
|
SNOOPY DC CL57' ',CL18'INSERT SNOOPY HERE',CL57' '
|
|
YEAR DC F'1969' <== 1969
|
|
MO DC CL10' JANUARY ',CL10' FEBRUARY ',CL10' MARCH '
|
|
DC CL10' APRIL ',CL10' MAY ',CL10' JUNE '
|
|
DC CL10' JULY ',CL10' AUGUST ',CL10'SEPTEMBER '
|
|
DC CL10' OCTOBER ',CL10' NOVEMBER ',CL10' DECEMBER '
|
|
ML DC H'31',H'28',H'31',H'30',H'31',H'30'
|
|
DC H'31',H'31',H'30',H'31',H'30',H'31'
|
|
WDNA DC CL20'MO TU WE TH FR SA SU'
|
|
M DS F
|
|
D DS F
|
|
YY DS F
|
|
TD1 DS CL93
|
|
TD2 DS CL144
|
|
MOLINE DS CL132
|
|
WDLINE DS CL132
|
|
PG DC CL132' ' BUFFER FOR THE LINE PRINTER
|
|
XDEC DS CL12
|
|
BLANK DC CL144' '
|
|
DA DS 12CL144
|
|
YREGS
|
|
END CALENDAR
|