Multics
21 Jan 1981

calendar.pl1

History | People | Library | Sites | About

This Multics source file was rescued from the messed-up source archive at MIT.

This application program prints a calendar. There was an interesting bug in this routine for Easter 1981. See Dennis Capps's lengthy comments on the Easter routine.

Notice the handler for the "cleanup" condition which is invoked if the program is quit and released. This handler ensures that the address space is cleaned up and the temporary segment released.

For a modern implementation of the same idea, take a look at my 1997 version in Perl.

Back to Multics Source index.

            calendar.pl1                    01/21/81  0906.1rew 01/21/81  0904.5      399420



/* ******************************************************
   *                                                    *
   *                                                    *
   * Copyright (c) 1972 by Massachusetts Institute of   *
   * Technology and Honeywell Information Systems, Inc. *
   *                                                    *
   *                                                    *
   ****************************************************** */

calendar: proc;

/*  Info seg describes what this program is supposed to do.
08/20/80  calendar

Syntax:  calendar {paths} {-control_args}


Function:  prints a calendar for one month.  The preceding and
following months are also shown.


Arguments:
paths
   are segments listing calendar events. See "Input" below.


Control arguments:
-date D, -dt D
   D is any date acceptable to convert_date_to_binary_. The calendar is
   printed for the month containing this -date.  If -date is not given,
   current month is printed.
-fw, -fiscal_week
   labels boxes with fiscal week.
-wait, -wt
   waits for the user to type a newline (carriage return) before
   printing the calendar.
-stop, -sp
   waits for the user to type a newline (carriage return) before
   printing the calendar and again after printing it.
-force, -fc
   prints the calendar even if errors are found in the input files.
   Prints "Error diagnostics complete." after the error messages (but
   only if there were errors).
-box_height, -bht
   changes the height of each calendar box from 7 lines to N lines.  If
   N < 7, calendars for previous and following months do not appear in
   margin.
-julian, -jul
   prints "julian dates" in bottom line of each box -- number of day
   from beginning of year and number of days remaining in year.


New features:
new syntax:  use -date control argument
command aborts if errors are found in any input file.
If old syntax is used, a warning prints after the formfeed at the end
of the calendar.
new_control arguments: -wait, -stop, -force, -box_height, -julian


Output: The calendar has the month name and two-digit year at the top
in big letters.  Each calendar box is 16 characters wide;  by default
it is 7 lines high (see -box_height control argument).  The boxes
contain nothing but the number of the day in the month, unless one or
more paths are specified in the command line. Small calendars for
previous and following months are fitted in above or below the main
calendar.


Input: Each path specifies a segment containing comment lines that
begin with "*", and lines that set up a string to be inserted into the
calendar.  The latter lines have from two to five fields, separated by
commas.  The first field is always the operation code (date, rel,
repeat, rename, or easter).


Date opcode: For the "date" opcode, there are three fields. The second
field is any date acceptable to convert_date_to_binary_. (This date
will be converted relative to the day before the beginning of the
month, so that "Mon" is the first Monday in the month, etc.) The third
field is arbitrary text.  Up to 16 characters are inserted into the
calendar in the appropriate place if the specified date falls in the
calendar month.


Rel opcode: For the "rel" opcode, there are five fields. The second is
the month number.  0 indicates the current month, -1 the previous
month, +1 the following month.  The third is a date, relative to the
day before the first of the month.  The fourth field is a date relative
to the third field, which is the day selected. The fifth field is text.
Thus, the line
  rel,11,Mon,Tue,Election Day defines the first Tuesday after the first
Monday in November.


Repeat opcode: For the "repeat" opcode there are 5 fields.  The second
is the starting date for a series of identical notations.  It may be an
ordinary date, or 0 (to indicate that the series starts at the first of
any month), or a relative date or a date offset.  The third field is
the end date for the series, or an unsigned integer indicating the
number of entries in the series, or 0 to indicate a perpetual series.
The fourth field is the interval expressed as a date offset (e.g.
1week).  The fifth field is text.  Example:
  repeat,04/01/80,9weeks,1week,Karate lesson
  repeat,Thursday,0,1week,Staff Meeting


Easter opcode: For the "easter" opcode, there are only two fields. The
second is text to be inserted into the box for Easter.


Rename opcode: For the "rename" opcode, there are three fields. The
second is a day or month name to be replaced by the third.
    rename,Monday,segunda-feira
  changes the heading for the Monday column.


Note:  If an entry is more than 16 characters, multiple date and rel
entries may be used.  For example:
   rel,2,Mon,2weeks,Washington's
   rel,2,Mon,2weeks,birthday


Example file: The following is an example file that defines permanent
holidays.
  * holidays
  date,01/01,New Year's Day
  date,02/02,Ground Hog Day
  rel,2,Mon,2 weeks,Washington Bday
  easter,Easter
  rel,5,sun,1 week,Mothers Day
  rel,5,05/24,Mon,Memorial Day
  date,07/04,Independence Day
  rel,9,0,Mon,Labor Day
  rel,10,Mon,1 week,Columbus Day
  rel,10,Mon,3 weeks,Veterans Day
  rel,11,Mon,Tue,Election Day
  rel,11,Thu,3 weeks,Thanksgiving
  date,12/25,Christmas Day
  repeat,02/29/04,0,4years,Leap Day
  * end

   THVV 12/73 */
/* Modified 12/77 by Dennis Capps to allow rel to calculate dates relative to previous or following month. */
/* modified 01/78 THVV for rename */
/* Modified 04/80 by Dennis Capps to use clock builtin and to add repeat opcode */
/* Modified 08/80 by Dennis Capps for Multics argument syntax, -stop, -wait, -force, -box_height, -julian. */
/* Modified 09/80 by Dennis Capps to fix bug in Easter. */
/*  */

declare     /* Pointers */
ap      pointer,        /* -> an argument. */
ap2     pointer,        /* -> an argument. */
ifdp        pointer,        /* -> data on input files. */
lp      pointer,        /* -> the current input line. */
olp     pointer,        /* -> set of output lines for a week. */
p       pointer,        /* Temporary */
pfp     pointer,        /* -> to structure for small calendars. */
seg_ptr     pointer,        /* -> input file currently being scanned. */
storp       pointer,        /* -> storage space for calendar notes. */
temp_seg_ptr    pointer;        /* -> temp seg for large amts of storage. */

declare     /* Fixed binary numbers. */
al      fixed bin,      /* Length of argument. */
al2     fixed bin,      /* Length of argument. */
an      fixed bin,      /* Argument number. */
box_height  fixed bin init(7),      /* Number of lines in a calendar box. */
day_chain_roots(31) fixed bin init ((31)0), /* Indices of first cells of lists in storage, one per day. */
days_mo     fixed bin,      /* # days in this month. */
days_mop        fixed bin,      /* # days in previous month. */
days_mof        fixed bin,      /* # days in next month. */
days_yr     fixed bin,      /* # days in year. */
ec      fixed bin (35),     /* Error code. */
ec2     fixed bin (35),     /* Error code. */
fld_ix(5)       fixed bin,      /* Positions in input line of up to 5 data fields. */
fld_ln(5)       fixed bin,      /* Lengths of the up to 5 data fields in each input line. */
how_many_fields fixed bin,      /* The number of fields in the current input line. */
i       fixed bin,      /* Temporary. */
inf     fixed bin,      /* Index for loop on input files. */
input_line_count    fixed bin,      /* Count of lines processed so far in current input file. */
jj      fixed bin,      /* Temporary */
jjj     fixed bin,      /* Temporary */
last_cell_no    fixed bin init(0),      /* Index of most recently "allocated" cell in the storage array. */
lchr        fixed bin,      /* No of chars in input line sans final NL. */
lchrnl      fixed bin,      /* no of chars in input line including final NL. */
max_cells       fixed bin init(24000) internal static options(constant),
repeat_count    fixed bin,      /* For repeat opcode: no of times to write note. */
size        fixed bin,      /* Number of lines available after julian date. */
x       fixed bin;      /* Temporary. */

declare /* Date and time variables */
bom     fixed bin (71),     /* Microsecond which starts this month. */
bomf        fixed bin(71),      /* Microsecond which starts following month. */
bomp        fixed bin(71),      /* Microsecond which starts previous month. */
end_absda       fixed bin,      /* # days since 1 Jan 1901 of end of repeat. */
fb71        fixed bin (71),     /* Temporary microsecond time. */
fb71a       fixed bin (71),     /* Temporary microsecond time. */
fwbase      fixed bin,      /* # days since 1 Jan 1901 of first Monday in year */
mo_absda        fixed bin,      /* # days since 1 Jan 1901 of this month. */
mo_absdaf       fixed bin,      /* # days since 1 Jan 1901 of beginning of following month. */
rbom        fixed bin (71),     /* Microsecond which starts a month. Temp for rel. */
sr_absda        fixed bin,      /* # days since 1 Jan 1901 of start of repeat. */
yr_absda        fixed bin;      /* # days since 1 Jan 1901 of 1 Jan this year. */

declare     /* Character Strings */
bchr        char (al) unal based (ap),  /* Argument. */
bchr2       char (al2) unal based (ap2),    /* Argument. */
current_line    char(168) aligned,      /* Storage space for the current input line. */
input_line  char(lchr) aligned based(lp),   /* The current input line. */
whole_seg       char (131071) based (seg_ptr) aligned;

declare     /* Bit strings. */
ave_switch  bit(1) init("0"b),      /* Error in value of an argument. */
error_switch    bit(1) init("0"b),      /* Error in line of an input file. */
force_switch    bit(1) init("0"b),      /* Ctl arg present.  Print in spite of errors. */
fwsw        bit (1) init ("0"b),    /* Ctl arg present.  Print fiscal week. */
julian_switch   bit(1) init("0"b),      /* Ctl arg present.  Print julian dates. */
stop_switch bit(1) init("0"b),      /* Ctl arg present.  Pause before and after calendar. */
syntax_warning  bit(1) init("0"b),      /* Found obsolete syntax. */
wait_switch bit(1) init("0"b);      /* Ctl arg present.  Pause before calendar. */

dcl (addr, clock, divide, fixed, hbound, index, length, ltrim, max, min, mod, null, reverse, rtrim, substr, verify) builtin;

declare cleanup condition;

declare     /* External entries */
bigletter_      entry (char (*) aligned, entry),
com_err_            entry options (variable),
convert_date_to_binary_ entry (char (*), fixed bin (71), fixed bin (35)),
convert_date_to_binary_$relative    entry (char (*), fixed bin (71), fixed bin (71), fixed bin (35)),
cu_$arg_count       entry (fixed bin),
cu_$arg_ptr     entry (fixed bin, ptr, fixed bin, fixed bin (35)),
cv_dec_check_       entry (char (*), fixed bin (35)) returns (fixed bin),
datebin_            entry (fixed bin (71), fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin,
                  fixed bin, fixed bin, fixed bin),
datebin_$revert     entry (fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin (71)),
expand_path_        entry (ptr, fixed bin, ptr, ptr, fixed bin (35)),
get_temp_segment_       entry (char(*), ptr, fixed bin(35)),
hcs_$initiate_count     entry (char (*) aligned, char (*) aligned, char (*) aligned,
                  fixed bin (24), fixed bin (2), ptr, fixed bin (35)),
hcs_$terminate_noname   entry (ptr, fixed bin (35)),
ioa_$rsnnl      entry options (variable),
iox_$get_line       entry (ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35)),
iox_$put_chars      entry (ptr, ptr, fixed bin (21), fixed bin (35)),
release_temp_segment_   entry (char(*), ptr, fixed bin(35));


declare     /* External constants. */
iox_$user_input     ptr ext,
iox_$user_output        ptr ext;

declare
error_table_$bad_conversion fixed bin (35) ext,
error_table_$badopt     fixed bin (35) ext,
error_table_$inconsistent   fixed bin (35) ext;

/* Data structures. */
declare
1 if_data aligned based(ifdp),
     2 how_many fixed bin,  /* Count of input files. */
     2 pad  fixed bin,
     2 if(100) aligned,     /* Info for each input file. */
    3 ifptr ptr,
    3 bitc  fixed bin(24),
    3 dn    char(168),
    3 en    char(23),
     2 next_storage_block   ptr;    /* For addr only. */

/* End of new variables section. */

dcl (absda, mm, dd, yy, hh, minute, ss, wkd, shf) fixed bin,    /* Breakdown of date. */
    (wkdp, wkdf) fixed bin,             /* Starting day of week for prev & foll months. */
    (mmp, mmf, yyp, yyf) fixed bin,         /* Previous & following mo. & year containing. */
    (xmm, xyy, xdd, x1) fixed bin,          /* Breakdown of date to remember. */
     titlestr char (16) aligned,            /* Title for calendar, e.g. "January 74" */
    (day_of_month, day_of_week) fixed bin,
    (cursor, k, n, jpf, kpf) fixed bin, /* temps. */
    (srday, endday, interval) fixed bin,        /* repeat variables */
     nchr fixed bin,                /* length of current input file */
     command char (8),              /* opcode */
    (a, b, c, d, e, f) fixed bin,           /* .. */
     llth fixed bin (21) init (120),            /* Length of a line. */
     boy fixed bin (71),                /* .. of this year */
     fwno fixed bin;                /* fiscal week no. */

declare
1 week_setup aligned based (olp),
     2 line (box_height) aligned,       /* One formatted week. 7 lines by default. */
    3 day (7) unal,         /* (16 + 1) * 7 = 119 */
         4 brk char (1),
         4 text char (16),
    3 rtbar char (1) unal,      /* 119 + 1 = 120 */
     2 next_storage_block   ptr;        /* For addr only. */

dcl 1 prevfoll unal based (pfp),
    2 headerp char (22) unal,
    2 pad1 char (8) unal,
    2 headerf char (21) unal,
    2 pad2 char (69) unal,
    2 week (6) unal,
      3 blank char (1),
      3 dayp (7) char (3),
      3 space char (8),
      3 dayf (7) char (3),
      3 morepad char (69);

dcl 1 storage (max_cells) aligned based(storp),     /* Stores text for memorable dates. */
    2 date fixed bin (71),
    2 link fixed bin,               /* points to next entry on list. */
    2 pad fixed bin,
    2 text char (16);               /* Text placed in box. */

dcl  moname (12) char (9) aligned init
    ("January", "February", "March", "April", "May", "June",
     "July", "August", "September", "October", "November", "December");

dcl  ndays (12) fixed bin init
    (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);

dcl  head char (121) aligned;
dcl  wkdname (7) char (16) aligned init
    ("Sunday", "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday");


dcl  bar char (121) aligned int static init
    ("------------------------------------------------------------------------------------------------------------------------
");
dcl  horizline char (121) aligned init (" ");

dcl  NL char (1) aligned int static init ("
");

dcl  FF char (1) int static init ("^L");

/* ======================================================== */

    on cleanup call cleanup_proc();

    /* Get a large amt of storage. */
    call get_temp_segment_("calendar",temp_seg_ptr,ec);
    if ec ^= 0 then
         do;
         call com_err_(ec, "calendar","System error attempting to get a temporary segment.");
         call cleanup_proc();
         return;
         end;

    ifdp    = temp_seg_ptr;
    if_data.how_many    = 0;
    fb71    = clock();  /* This is the default time if "-date" ctl arg not used. */

    /* Process command arguments. */
    call cu_$arg_count(x);  /* Neater than waiting for error_table_$no_arg. */

    do an = 1 to x;     /* Collect all the arguments. */
    call cu_$arg_ptr(an,ap,al,ec);
    if ec ^= 0 then     /* Has to be real error, not just out of args. */
         goto fatal_arg_error;

    if substr(bchr,1,1) = "-" then  /* Got a control argument. */
         do;
         if bchr = "-date" | bchr = "-dt" then
        do;
        an = an + 1;    /* Get value from following argument. */
        call cu_$arg_ptr(an,ap2,al2,ec);
        if ec ^= 0 then /* This is a real error, even if just out of args.  */
             goto fatal_arg_error;
        call convert_date_to_binary_(bchr2,fb71,ec);
        if ec ^= 0 then /* This error is important enough to be fatal. */
             goto fatal_arg_val_error;
        end;

         else
         if bchr = "-sp" | bchr = "-stop" then
        stop_switch = "1"b;

         else
         if bchr = "-wt" | bchr = "-wait" then
        wait_switch = "1"b;

         else
         if bchr = "-fc" | bchr = "-force" then
        force_switch = "1"b;

         else
         if bchr = "-fw" | bchr = "-fiscal_week" then
        fwsw = "1"b;

         else
         if bchr = "-jul" | bchr = "-julian" then
        julian_switch = "1"b;

         else
         if bchr = "-bht" | bchr = "-box_height" then
        do;
        an = an + 1;
        call cu_$arg_ptr(an,ap2,al2,ec);    /* Get the value. */
        if ec ^= 0 then /* This too is a real error, even if just out of args. */
             do;
fatal_arg_error:         call com_err_(ec,"calendar","Argument number ^d.  Command terminated.",an);
             call cleanup_proc();
             return;
             end;
        i = cv_dec_check_(bchr2,ec);
        if ec ^= 0 then
             do;        /* This error is important enough to be fatal. */
             ec = error_table_$bad_conversion;
fatal_arg_val_error:     call com_err_(ec,"calendar","Argument ^d: ^a.  Command terminated.",an,bchr2);
             call cleanup_proc();
             return;
             end;
        box_height = i; /* Change from default (init) value. */
        end;

         else do;
        ec = error_table_$badopt;
        goto arg_value_error;
        end;
         end;   /* Control arguments */

    else do;            /* Got a pathname of an input file. */
         i  = if_data.how_many + 1; /* Put info in next empty cell. */
         call expand_path_(ap,al,addr(if_data.if(i).dn),addr(if_data.if(i).en),ec);
         if ec ^= 0 then    /* Ought to be an error, but might be old syntax. */
        if an = 1 then goto try_date;
            else goto arg_value_error;
         call hcs_$initiate_count(if_data.if(i).dn,if_data.if(i).en,"",if_data.if(i).bitc,1,
                if_data.if(i).ifptr,ec);
         if if_data.if(i).ifptr = null then /* Ought to be an error, but ... */
        if an = 1 then      /* .. check for old syntax. */
             do;
try_date:            call convert_date_to_binary_(bchr,fb71a,ec2);
             if ec2 = 0 then
            do;
            fb71 = fb71a;
            syntax_warning = "1"b;
            end;
             else goto arg_value_error;
             end;
        else do;
arg_value_error:         call com_err_(ec,"calendar","Argument ^d: ^a.",an, bchr);
             ave_switch = "1"b;
             end;
         else if_data.how_many = i; /* Data all good.  Keep the file. */
         end;
    end;    /* Argument loop. */

    if ave_switch then
         do;
         call com_err_(0,"calendar","Errors in command arguments.  Command aborted.");
         call cleanup_proc();
         return;
         end;

    /* Initialize basic time and date variables. */
    call datebin_ (fb71, absda, mm, dd, yy, hh, minute, ss, wkd, shf);
    call datebin_$revert (1, 1, yy, 0, 0, 0, boy);  /* Get beginning of year. */
    call datebin_ (boy, yr_absda, i, i, i, i, i, i, wkd, i);
    if wkd >= 6 then wkd = wkd - 7;
    fwbase = yr_absda + 1 - wkd;            /* Locate a "virtual monday" preceding the first */
    call datebin_$revert (mm, 1, yy, 0, 0, 0, bom); /* Locate beginning of month. */
    call datebin_ (bom, mo_absda, mm, dd, yy, hh, minute, ss, wkd, shf);
    days_mo = ndays (mm);           /* Get # of days in this month. */
    if mod (yy, 4) = 0 then     /* Leap year. */
         do;
         if mm = 2 then days_mo = days_mo + 1;
         days_yr = 366;
         end;
    else days_yr = 365;
    fwno = 1 + divide ((mo_absda+mod (8-wkd, 7)) - fwbase, 7, 17, 0); /* Calculate first fiscal week no. for Monday */

/* Calculate beginning of month for previous and following months. */
    if mm = 1 then do; mmp = 12; yyp = yy - 1; end;
    else do; mmp = mm - 1; yyp = yy; end;
    if mm = 12 then do; mmf = 1; yyf = yy + 1; end;
    else do; mmf = mm + 1; yyf = yy; end;
    days_mop    = ndays(mmp);
    days_mof    = ndays(mmf);
    if mmp = 2 then if mod(yyp,4)=0 then days_mop = days_mop + 1;
    if mmf = 2 then if mod(yyf,4)=0 then days_mof = days_mof + 1;
    call datebin_$revert (mmp, 1, yyp, 0, 0, 0, bomp);
    call datebin_$revert (mmf, 1, yyf, 0, 0, 0, bomf);
    call datebin_ (bomp, i        , i, i, i, i, i, i, wkdp, i);
    call datebin_ (bomf, mo_absdaf, i, i, i, i, i, i, wkdf, i);

    olp = addr(if_data.next_storage_block);
    storp   = addr(week_setup.next_storage_block);
    lp  = addr(current_line);

/* Now process all input files for events to be printed this month. */

    do inf = 1 to if_data.how_many;
         seg_ptr = if_data.if(inf).ifptr;
         nchr = divide (if_data.if(inf).bitc, 9, 17, 0);    /* Get length of file. */
         k = 1;
         input_line_count = 0;      /* count the lines so can give info in error message. */
         do while (k < nchr);            /* Scan file */
        lchrnl = index (substr (whole_seg, k), NL); /* Find end of line */
        if lchrnl = 0 then lchr, lchrnl = nchr-k+1;
                else lchr = lchrnl - 1;
        current_line = substr (whole_seg, k, lchr); /* Copy one line. */
        input_line_count = input_line_count + 1;
        if substr (current_line, 1, 1) = "*" then go to skip; /* Ignore comments. */
        call parse_line(how_many_fields);
        if how_many_fields = 0 then goto bad;
        command = substr (input_line,fld_ix(1),fld_ln(1));
        if command = "date" then do;
             if how_many_fields < 3 then goto bad1;
             call convert_date_to_binary_$relative (substr (input_line,fld_ix(2),fld_ln(2)), fb71, bom-1, ec);
             if ec ^= 0 then go to bad; /* Convert to binary. */
             call datebin_ (fb71, x1, xmm, xdd, xyy, x1, x1, x1, x1, x1);
             if xmm = mm then if xyy = yy then  /* If current month and year then remember it. */
            call fill_in_note(xdd,fb71,substr(input_line,fld_ix(3),min(16,fld_ln(3))));
        end;
        else if command = "rel" then do;    /* A date relative to another. */
             if how_many_fields < 5 then goto bad1;
             if substr (input_line, fld_ix(2), 2) = "-1" then xmm = mmp;
             else
             if substr (input_line, fld_ix(2), 2) = "+1" then xmm = mmf;
             else do;
            xmm = cv_dec_check_ (substr (input_line,fld_ix(2),fld_ln(2)), ec);
            if ec ^= 0 then go to bad1;
            if xmm = 0 then xmm = mm;
             end;
             if xmm = mmp then rbom = bomp;
             else if xmm = mm then rbom = bom;
             else if xmm = mmf then rbom = bomf;
             else goto skip;
             /* Get first date.  */
             if substr (input_line, fld_ix(3), fld_ln(3)) = "0" then fb71a = rbom-1; /* Special case. */
             else do;
            call convert_date_to_binary_$relative(substr(input_line,fld_ix(3),fld_ln(3)),fb71a,rbom-1,ec);
            if ec ^= 0 then go to bad;
             end;
             /* Now second date relative to first. */
             call convert_date_to_binary_$relative (substr (input_line, fld_ix(4), fld_ln(4)), fb71, fb71a, ec);
             if ec ^= 0 then go to bad;
             call datebin_ (fb71, x1, xmm, xdd, xyy, x1, x1, x1, x1, x1);
             if xmm = mm then if xyy = yy then  /* If current month and year then remember it. */
            call fill_in_note(xdd,fb71,substr(input_line,fld_ix(5),min(16,fld_ln(5))));
        end;
        else if command = "repeat" then
             do;
             if how_many_fields < 5 then goto bad;

             /* Get interval */
             if substr(input_line,fld_ix(4),fld_ln(4)) = "0" then interval = 1; /* i.e., one day. */
             else do;
            call convert_date_to_binary_$relative(substr(input_line,fld_ix(4),fld_ln(4)),
                            fb71,bom,ec);
            if ec ^= 0 then goto bad;
            call datebin_(fb71,absda,x1,x1,x1,x1,x1,x1,x1,x1);
            interval = max(1,absda-mo_absda);   /* No neg interval.  >= one day. */
            end;

             /* Get start date */
             if substr(input_line,fld_ix(2),fld_ln(2)) = "0" then
            do;
            sr_absda = mo_absda;    /* Need this if have to calculate end date from repeat count. */
            srday    = 1;
            end;
             else do;
            call convert_date_to_binary_$relative(substr(input_line,fld_ix(2),fld_ln(2)),
                            fb71,bom-1,ec);
            if ec ^= 0 then goto bad;
            if fb71 >= bomf then goto skip;  /* Starts after end of month. */
            /* Starting date is before or in this month.  If in the month, srday in the following call
               is valid.  If not, sr_absda is needed to calculate it.  sr_absda might also be needed
               if it is necessary to calculate the end date from a repeat count. */
            call datebin_(fb71,sr_absda,x1,srday,x1,x1,x1,x1,x1,x1);
            if fb71 < bom then   /* Start before month. First target day in month is: */
                 srday = interval - mod(mo_absda-1-sr_absda, interval);
            end;

             /* Get end date or count of notes. */
             if substr(input_line,fld_ix(3),fld_ln(3)) = "0" then
            endday    = days_mo;
             else
             if verify(rtrim(ltrim(substr(input_line,fld_ix(3),fld_ln(3)))), "0123456789") = 0 then
            do; /* This is all digits, so must be a count of the number of notes. */
            repeat_count = fixed(substr(input_line,fld_ix(3),fld_ln(3)));
            end_absda = sr_absda + ((repeat_count - 1) * interval);
            if end_absda < mo_absda then goto skip;  /* Ends before this month. */
            if end_absda >= mo_absdaf then endday = days_mo; /* Ends next mo or later. */
            else endday = end_absda - mo_absda + 1;     /* Ends some time within month. */
            end;
             else do;
            call convert_date_to_binary_$relative(substr(input_line,fld_ix(3),fld_ln(3)),
                            fb71,bom-1,ec);
            if ec ^= 0 then goto bad;
            if fb71 < bom then goto skip;        /* Ends before start of month. */
            if fb71 >= bomf then endday = days_mo;   /* Ends next month or later. */
            else call datebin_(fb71,x1,x1,endday,x1,x1,x1,x1,x1,x1);
            end;

             /* Fill in notes for target days. */
             do d = srday to endday by interval;
             call datebin_$revert(xmm,d,xyy,0,0,0,fb71);
             call fill_in_note(d,fb71,substr(input_line,fld_ix(5),min(16,fld_ln(5))));
             end;   /* LOOP */
        end;    /* "repeat" opcode */
        else if command = "easter" then do; /* Easter day */
             if mm = 3 | mm = 4 then        /* Can only occur in March or April. */
            call calculate_easter(yy,xmm,xdd);
             else goto skip;
             if xmm = mm then do;       /* Comes this month?  Yes, put it on the list. */
            call datebin_$revert (xmm, xdd, yy, 0, 0, 0, fb71);
            call fill_in_note(xdd,fb71,substr(input_line,fld_ix(2),min(16,fld_ln(2))));
             end;
        end;
        else if command = "rename" then do;
             do jjj = 1 to 12;
            if moname(jjj) = substr(input_line,fld_ix(2),fld_ln(2)) then
                moname(jjj) = substr(input_line,fld_ix(3));
             end;
             do jjj = 1 to 7;
            if wkdname (jjj) = substr (input_line, fld_ix(2), fld_ln(2)) then
                wkdname (jjj) = substr (input_line, fld_ix(3));
             end;
        end;
        else do;                /* Invalid opcode. */
bad1:            ec = 0;            /* No system err code. */
bad:             call com_err_ (ec, "calendar", "Illegal command on line ^d in ^a: ^a",
                input_line_count, if_data.if(inf).en, input_line);
             error_switch = "1"b;
        end;
skip:       k = k+lchrnl;           /* Move to start of next line. */
         end;                   /* End of file scan. */
    end;    /* Loop on input files. */

    /* If there were errors, quit unless user said to print anyway. */
    if error_switch then
         if force_switch then
        call com_err_(0,"calendar","Error diagnostics complete.");
         else do;
        call com_err_(0,"calendar","Errors in input files.  Command aborted.");
        call cleanup_proc();
        return;
        end;

    if stop_switch | wait_switch then   /* Wait for newline. */
         call iox_$get_line(iox_$user_input,lp,168,0,ec);

/* Put out the calendar. */

    call ioa_$rsnnl ("^a ^d", titlestr, i, moname (mm), yy-1900);
    call bigletter_ (titlestr, writer);     /* Write fancy heading. */
    head = NL;
    cursor = 2;
    do day_of_week = 1 to 7;
         i = divide (17 - length (rtrim (wkdname (day_of_week))), 2, 17, 0); /* Center weekday name */
         substr (head, cursor+i, 17-i) = wkdname (day_of_week); /* stringsize raised, so what */
         cursor = cursor + 17;
    end;
    substr (head, cursor, 1) = NL;
    call iox_$put_chars (iox_$user_output, addr (head), (cursor), ec);

    if wkd = 7 then wkd = 0;            /* How many days in first week? */
    i = wkd * 17;               /* How much of the top horiz line to leave out. */
    substr (horizline, i+1) = substr (bar, i+1, length (bar)-i);
    call iox_$put_chars (iox_$user_output, addr (horizline), length (horizline), ec); /* Write line of dashes */
    line (*).brk (*) = "|";
    line (*).rtbar = "|";
    do day_of_week = 1 to wkd;          /* Blank out missing days and their vertical lines. */
         line(*).brk(day_of_week) = " ";
         line (*).text (day_of_week) = "";
    end;

    /* First week short? */
    if wkd > 1 & box_height > 6 then do;      /* At least 3 blank boxes in first week, room for 1-2 little */
         pfp = addr (line);         /* Overlay small calendars on week storage. */
         call previous_month;           /* Fill in previous month. */
    end;
    if wkd > 2 & box_height > 6 then      /* Room enough for both small calendars in first week. */
         call follow_month;         /* Fill in following month. */

    day_of_month = 1;
    if julian_switch & box_height > 1 then
         do;
         size = box_height - 1;
         jj  = mo_absda - yr_absda + 1;
         jjj = days_yr - jj;
         end;
    else size = box_height;
    do while ("1"b);
         if fwsw & day_of_week = 2 then do;     /* Want Honeywell fiscal weeks? */
        call ioa_$rsnnl (" FW ^2d^7x^2d ", line (1).text (2), (0), fwno, day_of_month);
        fwno = fwno + 1;
         end;
         else call ioa_$rsnnl ("^15d ", line (1).text (day_of_week), (0), day_of_month);
                        /* First line in box is number of day. */
         if julian_switch & box_height > 1 then  /* Last line is julian, if user wants and enough room. */
        do;
        call ioa_$rsnnl("^3d^10x^3d",line(box_height).text(day_of_week),(0),jj,jjj);
        jj  = jj  + 1;
        jjj = jjj - 1;
        end;
         do i = size to 2 by -1;            /* Fill in rest of box. */
        if day_chain_roots (day_of_month) = 0 then line (i).text (day_of_week) = ""; /* .. either blank, or */
        else do;                /* .. text from storage. */
             line (i).text (day_of_week) = storage.text (day_chain_roots (day_of_month));
             day_chain_roots (day_of_month) = storage.link (day_chain_roots (day_of_month)); /* Unlink datum from chain. */
        end;
         end;
         day_of_week = day_of_week + 1;
         day_of_month = day_of_month + 1;
         if day_of_month > days_mo then go to out;   /* Done with the month? */
         if day_of_week > 7 then do;     /* Done with the week? */
        call putweek;           /* Yes. Write one week. */
        line(*).brk(*), line(*).rtbar = "|";    /* Restore vertical lines in case small cal zapped */

        day_of_week = 1;            /* Reset day of week. */
        call iox_$put_chars (iox_$user_output, addr (bar), length (bar), ec);
         end;
    end;

out:    if wkd < 3 & box_height > 6 then do;      /* Insert previous and following month, if appropriate. */
         if wkd = 0 & days_mo = 28 then do;     /* February starting on Sunday --> No blank partial week. */
        call putweek;           /* Print the fourth week as is. */
        call iox_$put_chars (iox_$user_output, addr (bar), length(bar), ec);
        llth = 51;          /* Length of two small calendars. */
        pfp = addr (line);          /* Overlay small calendars on week storage. */
        do i = 1 to 3;          /* Get rid of vertical lines. */
        line(*).day(i).brk = " ";
        line(*).day(i).text = " ";      /* And old text. */
        end;
         end;
         else do;
        pfp = addr (line (1).day (5).text); /* Overlay small calendars on end of last week. */
        line(*).day(day_of_week).text = " ";    /* Blank out this day's text. */
        line(*).rtbar = " ";        /* And final vertical bar. */
        do i = day_of_week + 1 to 7;        /* Blank out rest of week. */
             line (*).day (i).brk = " ";    /* Get rid of excess vertical lines. */
             line (*).day (i).text = " ";   /* And the text they contained. */
        end;                /* Loop */
         end;                   /* else */
         call follow_month;         /* Set up small calendar for following month. */
         if wkd < 2 then call previous_month;    /* And previous if necessary. */
    end;
    else llth = 1 + (day_of_week-1) * 17;       /* no small cal's.  Calculate length of last week. */

    call putweek;               /* Write last week with calendars. (Or just calendars.) */

    llth = 1 + (day_of_week-1) * 17;        /* Length of bottom horiz line on last week. */
    if ^(wkd = 0 & days_mo = 28 & box_height > 6) then   /*  Write bottom line unless just calendars. */
         call iox_$put_chars (iox_$user_output, addr (bar), llth, ec); /* Write partial line of dashes */
    call iox_$put_chars (iox_$user_output, addr (FF), 1, ec); /* Write FF */

    /* May need to wait for user to put paper in terminal. */
    if stop_switch then
         call iox_$get_line(iox_$user_input,lp,168,0,ec);

    if syntax_warning then
         call com_err_(0,"calendar","WARNING: You are using an obsolete syntax.^/New syntax is: calendar {paths} {-ctlargs}^/Type ""help calendar"" for details.");

    do day_of_month = 1 to days_mo;
         do jj = 1 to 100 while (day_chain_roots (day_of_month) ^= 0);
        call com_err_ (0, "calendar", "Item cannot fit in ^a ^d: ^a",
             moname (mm), day_of_month, storage.text (day_chain_roots (day_of_month)));
        day_chain_roots (day_of_month) = storage.link (day_chain_roots (day_of_month));
         end;
    end;

    call cleanup_proc();

    return;

/* -------------------------------------------------------- */

fill_in_note:   proc(day,abs_time,note);

declare
day     fixed bin,  /* The day of the month which is getting this note. */
abs_time        fixed bin(71),  /* The clock reading for the beginning of this day. */
note        char(16);       /* What to write in the box. */

/*  Some variables are declared in the parent block:
last_cell_no    fixed bin:  Index of most recently "allocated" cell in storage array.
max_cells       fixed bin:  The maximum number of such cells.
storage:        A structure used to hold the notes until time to print the calendar.
day_chain_roots(31) fixed bin:  Indices of first cell in chain of notes for the days of the month.
*/

    last_cell_no = last_cell_no + 1;    /* Allocate another cell in storage. */
    if last_cell_no > max_cells then goto too_many_notes;

    storage.link(last_cell_no)  = day_chain_roots(day); /* Chain this cell into list for this day. */
    day_chain_roots(day)    = last_cell_no;     /* After this, fill in the cell. */
    storage.date(last_cell_no)  = abs_time; /* CAVEAT:  If this is ever used anywhere, should figure
                              out if this is an appropriate value. */
    storage.text(last_cell_no)  = note;
    return;

too_many_notes:     /* Ran out of room in storage. */
    call com_err_(0,"calendar","Maximum number of calendar entries exceeded.");
    return;

end fill_in_note;

/* -------------------------------------------------------- */

parse_line: proc(no_of_fields);
        /* The first field starts at the first non-blank character.
           All other fields start at the first character after the comma. */

declare
no_of_fields    fixed bin,  /* Returned.  The number of fields found on the input line. */
(i, f, c)       fixed bin;  /* Temporaries. */

/* Declared in the outer block.
fld_ix(5)   fixed bin:  Positions of up to 5 fields in the input line. This proc fills in.
fld_ln(5)   fixed bin:  Lengths of the up to 5 fields on the input line.  This proc fills in.
input_line char(lchr) aligned based(lp): The current input line.
lchr    fixed bin:  The number of characters in the current input line (sans final NL).
*/

    i = 1;
    fld_ln(*) = 0;
    i = verify(input_line," "); /* first non-blank character. */
    if i = 0 then       /* All blank, no fields. */
         do;
         f = 0;
         goto done;
         end;

    do f = 1 to hbound(fld_ln,1) while(i < lchr);
    fld_ix(f) = i;
    c = index(substr(input_line,i), ",");   /* End of field. */
    if c = 0 then           /* No comma, last field. */
         do;
         fld_ln(f) = lchr - i + 1;
         goto done;
         end;
    fld_ln(f) = c - 1;
    i = i + c;          /* Start of next field. */
    if i > lchr then goto done;      /* Line ends with comma, no more fields. */
    end;    /* Loop */

    f = f - 1;  /* Loop index is too high. */

done:   no_of_fields = f;
    return;

end parse_line;

/* -------------------------------------------------------- */

putweek:    proc;                   /* Writes one week's data.  No. lines is box_height. */

         do i = 1 to box_height;
        call iox_$put_chars (iox_$user_output, addr (line (i)), llth, ec);
        call iox_$put_chars (iox_$user_output, addr (NL), 1, ec);
         end;

    end putweek;

/* -------------------------------------------------------- */

writer: proc (xp, xl);              /* Called by bigletter_ to write header. */

dcl  xp ptr, xl fixed bin;
dcl  bcs char (xl) based (xp);
dcl  i fixed bin (21);

         if bcs ^= "" then do;
        i = xl + 1 - verify (reverse (bcs), " ");
        call iox_$put_chars (iox_$user_output, xp, i, ec);
         end;
         call iox_$put_chars (iox_$user_output, addr (NL), 1, ec); /* Write NL */

    end writer;

/* -------------------------------------------------------- */

previous_month: proc;

         call ioa_$rsnnl (" ^9a^9x^2d", prevfoll.headerp, n, moname (mmp), yyp-1900);
         i = 1;
         if wkdp = 7 then wkdp = 0;
         do kpf = 1 to wkdp;
        prevfoll.week (1).dayp (kpf) = " ";
         end;
         do jpf = 1 to days_mop;
        call ioa_$rsnnl ("^2d ", prevfoll.week (i).dayp (kpf), n, jpf);
        kpf = kpf + 1;
        if kpf > 7 then do;
             kpf = 1;
             i = i + 1;
        end;
         end;                   /* jpf loop */

         do while (i <= 6);
        do jpf = kpf to 7;
             prevfoll.week (i).dayp (jpf) = " ";
        end;                /* jpf loop */
        i = i + 1;
        kpf = 1;
         end;                   /* while */
    end previous_month;

/* -------------------------------------------------------- */

follow_month: proc;

         call ioa_$rsnnl ("^9a^9x^2d ", prevfoll.headerf, n, moname (mmf), yyf-1900);
         i = 1;
         if wkdf = 7 then wkdf = 0;
         do kpf = 1 to wkdf;
        prevfoll.week (1).dayf (kpf) = " ";
         end;
         do jpf = 1 to days_mof;
        call ioa_$rsnnl ("^2d ", prevfoll.week (i).dayf (kpf), n, jpf);
        kpf = kpf + 1;
        if kpf > 7 then do;
             kpf = 1;
             i = i + 1;
        end;
         end;                   /* jpf loop */

         do while (i <= 6);
        do jpf = kpf to 7;
             prevfoll.week (i).dayf (jpf) = " ";
        end;                /* jpf loop */
        i = i + 1;
        kpf = 1;
         end;                   /* while */
    end follow_month;

/* -------------------------------------------------------- */
%page;
calculate_easter:   proc(year, month, day);

declare
day fixed bin,
month   fixed bin,
year    fixed bin,
(a, b, c, d, e, g, h, i, k, l, m) fixed bin;

    /* The following calculation of the Date for Easter follows the algorithm
       given in the New Scientist magazine, issue No. 228 (Vol. 9) page 828 (30 March 1961). */
    a = mod(year,19);       /* Find position of year in 19-year Lunar Cycle, called the Golden Number. */
    b = divide(year,100,35);    c = mod(year,100);  /* b is century number, c is year number within century*/
    d = divide(b,4,35);     e = mod(b,4);   /* These are used in leap year adjustments. */
    i = divide(c,4,35);     k = mod(c,4);   /* Also related to leap year. */

    /* The next step computes a correction factor used in the following step
       which computes the number of days between the spring equinox
       and the first full moon thereafter.  The correction factor is needed
       to keep the approximation in line with the observed behavior of the moon.
       It moves the full moon date back by one day eight times in every 2500 years,
       in century years three apart, with four years at the end of the cycle.
       The constant 13 corrects the correction for the fact that this
       cycle was decreed to start in the year 1800. */
    g = divide(8*b+13,25,35);

    /* Now the number of days after the equinox (21 March, by definition) that
       we find the next full moon.  This is a number between 0 and 29.
       The term 19*a advances the full moon 19 days for each year of the
       Lunar Cycle, for a total of 361 days in the 19 years.  The other 4.24 days
       are made up when a returns to zero on the next cycle.  Thus, the
       full moon dates repeat every 19 years.  The term b-d advances the
       date by one day for three out of every four century years, the
       years which are not leap years although divisible by 4.
       The term g is the correction factor calculated above, and 15
       adjusts this whole calculation to the actual conditions at that
       date on which the scheme began, probably in Oct of 1582. */
    h = mod(19*a + b - d - g + 15, 30);

    /* Now we are interested in how many days we have to wait after the
       full moon until we get a Sunday (which has to be definitely after
       the full moon).  The following step calculates a number l which is
       one less than the number of days.  Every ordinary year ends on the
       same day of the week on which it started;  a leap year ends on the
       day of the week following the one on which it started.  Thus, if
       it is known on what day of the week a date occurred in any year
       it is possible to calculate its day of the week in another year
       by marching through the week one day for each regular year and
       two for each leap year.
            The term k is the number of ordinary years
       since the last leap year;  each such year brings the date of the
       full moon one day closer to Sunday, and so reduces the number of
       days to be waited (unless it goes negative, but modular arithmetic
       theory makes -1 = 6 where the modulus is 7).
            The term i is the number of leap years so far in the current century.
       each leap year has with it three ordinary years, and each such group
       advances the day of the week by 5 days.  But in modulo 7 arithmetic
       subtracting 5 days is equivalent to adding 2 days.  So we add
       two days for each group of four years in the current century.
            Since a century consists of 25 groups of four years, it advances
       the day of the week by 124 or 125 days depending on whether the
       century year is an ordinary or leap year.  The remainders when
       these numbers are divided by seven are 5 and 6 respectively.
       The term e is the number of ordinary century years since the
       last leap century year.  As with the groups of four years, we
       add two days for each rather than subtract 5 for each.
            Every fourth century year is a leap year;  therefore,
       each group of four centuries advances the day of the week by
       3*5+6 = 21 days, or 0 in modulo 7 arithmetic, and no
       term is necessary for time before the last leap century year.
       The constant term 32 adjusts the calculation for the day of the
       week of the equinox when the scheme was put into effect.  It also
       is larger than necessary by 28 in order to assure that the
       subtractions of k and h never reduce the dividend below 0.
            Thus, mod(2*e + 2*i - k + 32, 7) gives one less than the number
       of days between the equinox and its following Sunday.  But we need to
       calculate the number of days after the full moon.  The term h,
       calculated in the previous step, gives the number of days after
       the equinox that the full moon occurs.  Each of those days brings
       the full moon closer to the actual Sunday of Easter,
       so it reduces the number of days after the full moon until Easter.
       (Again, if h > 6, modular arithmetic theory readjusts the result to
       another cycle of 0 to 6, and here the constant 32 keeps the dividend > 0.)   */
    l = mod(2*e + 2*i - k + 32 - h, 7);

    /* The calendar set up by Pope Gregory XIII and his advisor, the astronomer
       Clavius, provided for official full moon dates as well as matching
       the equinoxes and solstices with their nominal dates.  But, since
       the period of the moon is not an exact number of days, some fudging
       was needed here as elsewhere in the calendar system.  Some of the
       periods between successive full moons in the Lunar Cycle are 30 days,
       some 29 days.  Clavius then arranged the periods carefully so
       that if a full moon fell on 20 March (the day before the equinox),
       the period following it would be of 29 days.  The effect of this
       arrangement is that Easter can never occur later than 25 April.
       The above calculations assume uniform 30-day lunar periods.  In rare
       cases (e.g., 1954 and 1981) one of these 29-day lunar periods causes
       the full moon to fall on a Saturday where a 30-day period would put
       it on a Sunday.  The following step calculates the fudge factor for
       this situation.  The result m is 0 if no fudging is necessary, or
       1 if fudging is required.     */
    m = divide(a + 11*h + 19*l, 433, 35);

    /* Now we have calculated the number of days which will elapse between
       21 march and Easter: h + (l + 1) - 7*m.  The next two steps
       turn this into a month and day.  In the first expression, the constant
       90 assures that the the quotient will be at least 3 (= March).
       If the elapsed days exceed 9, then the quotient will be 4 (= April).
       In the second expression, if month = 3 then 33*month + 19 = 118 and the
       remainder of that part of the expression is 22;  when month = 3,
       l + h - 7*m < 10, so 22 < day <= 31.
       If month = 4, 33*month = 132, and since h + l - 7*m > 9, the whole
       expression satisfies 5*32 = 160 < expr.  The remainder is greater
       than 0 and less than 26.   */
    month   = divide(h + l - 7*m + 90, 25, 35);
    day = mod(h + l - 7*m +33*month + 19, 32);

    return;

end calculate_easter;
%page;
cleanup_proc:   proc;

    do if_data.how_many = if_data.how_many to 1 by -1;
    if if_data.if(if_data.how_many).ifptr ^= null then
         do;
         call hcs_$terminate_noname(if_data.if(if_data.how_many).ifptr,ec);
         if_data.if(if_data.how_many).ifptr = null;
         end;
    end;

    if temp_seg_ptr ^= null then
         call release_temp_segment_("calendar",temp_seg_ptr,ec);

    return;

end cleanup_proc;

/* -------------------------------------------------------- */

     end calendar;

"This material is presented to ensure dissemination of scholarly and technical work. Copyright and all rights therein are retained by authors or by other copyright holders. All persons copying this information are expected to adhere to the terms and constraints invoked by each author's copyright. In most cases, these works may not be reposted without the explicit permission of the copyright holder."