Source code in the pl/m programming language

100H:
BDOS: PROCEDURE (FN, ARG); DECLARE FN BYTE, ARG ADDRESS; GO TO 5; END BDOS;
EXIT: PROCEDURE; CALL BDOS(0,0); END EXIT;
PRINT: PROCEDURE (S); DECLARE S ADDRESS; CALL BDOS(9,S); END PRINT;
PRINT$CHAR: PROCEDURE (C); DECLARE C BYTE; CALL BDOS(2,C); END PRINT$CHAR;

PRINT$NUMBER: PROCEDURE (N);
    DECLARE S (6) BYTE INITIAL ('.....$');
    DECLARE (N, P) ADDRESS, C BASED P BYTE;
    P = .S(5);
DIGIT:
    P = P-1;
    C = N MOD 10 + '0';
    N = N / 10;
    IF N >0 THEN GO TO DIGIT;
    CALL PRINT(P);
END PRINT$NUMBER;

PRINT$DATE: PROCEDURE (YEAR, MONTH, DAY);
    DECLARE YEAR ADDRESS, (MONTH, DAY) BYTE;
    CALL PRINT$NUMBER(MONTH);
    CALL PRINT$CHAR('/');
    CALL PRINT$NUMBER(DAY);
    CALL PRINT$CHAR('/');
    CALL PRINT$NUMBER(YEAR);
END PRINT$DATE;

DAY$NAME: PROCEDURE (N) ADDRESS;
    DECLARE N BYTE;
    DO CASE N;
        RETURN .'SUNDAY$';
        RETURN .'MONDAY$';
        RETURN .'TUESDAY$';
        RETURN .'WEDNESDAY$';
        RETURN .'THURSDAY$';
        RETURN .'FRIDAY$';
        RETURN .'SATURDAY$';
   END;
END DAY$NAME;

LEAP$YEAR: PROCEDURE (YEAR) BYTE;
    DECLARE YEAR ADDRESS;
    RETURN (YEAR MOD 4 = 0) AND ((YEAR MOD 100 <> 0) OR (YEAR MOD 400 = 0));
END LEAP$YEAR;
    
WEEK$DAY: PROCEDURE (YEAR, MONTH, DAY) BYTE;
    DECLARE LEAP$DOOM DATA (4,1,7,4,2,6,4,1,5,3,7,5);
    DECLARE NORM$DOOM DATA (3,7,7,4,2,6,4,1,5,3,7,5);
    DECLARE YEAR ADDRESS, (MONTH, DAY) BYTE;
    DECLARE (C, R, S, T, C$ANCHOR, DOOM$DAY, ANCHOR$DAY) BYTE;
    
    C = YEAR / 100;
    R = YEAR MOD 100;
    S = R / 12;
    T = R MOD 12;
    C$ANCHOR = (5 * (C MOD 4) + 2) MOD 7;
    DOOM$DAY = (S + T + T/4 + C$ANCHOR) MOD 7;
    IF LEAP$YEAR(YEAR)
        THEN ANCHOR$DAY = LEAP$DOOM(MONTH-1);
        ELSE ANCHOR$DAY = NORM$DOOM(MONTH-1);
    
    RETURN (DOOM$DAY + DAY - ANCHOR$DAY + 7) MOD 7;
END WEEK$DAY;

FORMAT$OUT: PROCEDURE (YEAR, MONTH, DAY);
    DECLARE YEAR ADDRESS, (MONTH, DAY) BYTE;
    CALL PRINT$DATE(YEAR, MONTH, DAY);
    CALL PRINT(.': $');
    CALL PRINT(DAY$NAME(WEEK$DAY(YEAR, MONTH, DAY)));
    CALL PRINT(.(13,10,'$'));
END FORMAT$OUT;

DECLARE YEARS (7) ADDRESS INITIAL (1800, 1875, 1915, 1970, 2043, 2077, 2101);
DECLARE MONTHS (7) BYTE   INITIAL (   1,    3,   12,   12,    5,    2,    4);
DECLARE DAYS (7) BYTE     INITIAL (   6,   29,    7,   23,   14,   12,    2);

DECLARE I BYTE;
DO I=0 TO LAST(DAYS);
    CALL FORMAT$OUT(YEARS(I), MONTHS(I), DAYS(I));
END;
CALL EXIT;
EOF