1 /****^  ***********************************************************
   2         *                                                         *
   3         * Copyright, (C) BULL HN Information Systems Inc., 1990   *
   4         *                                                         *
   5         * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   6         *                                                         *
   7         *********************************************************** */
   8 
   9 
  10 
  11 
  12 /****^  HISTORY COMMENTS:
  13   1) change(86-10-20,TLNguyen), approve(86-10-20,MCR7558),
  14      audit(86-10-22,Gilcrease), install(86-10-22,MR12.0-1197):
  15      Correct a declaration of an entry name as 32 characters size
  16   2) change(90-09-27,Itani), approve(90-10-01,MCR8208), audit(90-10-10,Bubric),
  17      install(90-10-14,MR12.4-1040):
  18      Change "calendar" to use the "Pope Gregory XIII" method for calculating
  19      dates. Also make some headers in calendar more descriptive.
  20   3) change(90-10-18,Itani), approve(90-10-18,PBF8208), audit(90-10-18,Bubric),
  21      install(90-10-19,MR12.4-1048):
  22      Changed [(yy/100)*100] To: [divide(yy,100,17,0)*100].
  23                                                    END HISTORY COMMENTS */
  24 
  25 
  26 calendar: proc;
  27 
  28 /*  Info seg describes what this program is supposed to do.
  29 08/20/80  calendar
  30 
  31 Syntax:  calendar {paths} {-control_args}
  32 
  33 
  34 Function:  prints a calendar for one month.  The preceding and
  35 following months are also shown.
  36 
  37 
  38 Arguments:
  39 paths
  40    are segments listing calendar events. See "Input" below.
  41 
  42 
  43 Control arguments:
  44 -date D, -dt D
  45    D is any date acceptable to convert_date_to_binary_. The calendar is
  46    printed for the month containing this -date.  If -date is not given,
  47    current month is printed.
  48 -fw, -fiscal_week
  49    labels boxes with fiscal week.
  50 -wait, -wt
  51    waits for the user to type a newline (carriage return) before
  52    printing the calendar.
  53 -stop, -sp
  54    waits for the user to type a newline (carriage return) before
  55    printing the calendar and again after printing it.
  56 -force, -fc
  57    prints the calendar even if errors are found in the input files.
  58    Prints "Error diagnostics complete." after the error messages (but
  59    only if there were errors).
  60 -box_height, -bht
  61    changes the height of each calendar box from 7 lines to N lines.  If
  62    N < 7, calendars for previous and following months do not appear in
  63    margin.
  64 -julian, -jul
  65    prints "julian dates" in bottom line of each box -- number of day
  66    from beginning of year and number of days remaining in year.
  67 
  68 
  69 New features:
  70 new syntax:  use -date control argument
  71 command aborts if errors are found in any input file.
  72 If old syntax is used, a warning prints after the formfeed at the end
  73 of the calendar.
  74 new_control arguments: -wait, -stop, -force, -box_height, -julian
  75 
  76 
  77 Output: The calendar has the month name and two-digit year at the top
  78 in big letters.  Each calendar box is 16 characters wide;  by default
  79 it is 7 lines high (see -box_height control argument).  The boxes
  80 contain nothing but the number of the day in the month, unless one or
  81 more paths are specified in the command line. Small calendars for
  82 previous and following months are fitted in above or below the main
  83 calendar.
  84 
  85 
  86 Input: Each path specifies a segment containing comment lines that
  87 begin with "*", and lines that set up a string to be inserted into the
  88 calendar.  The latter lines have from two to five fields, separated by
  89 commas.  The first field is always the operation code (date, rel,
  90 repeat, rename, or easter).
  91 
  92 
  93 Date opcode: For the "date" opcode, there are three fields. The second
  94 field is any date acceptable to convert_date_to_binary_. (This date
  95 will be converted relative to the day before the beginning of the
  96 month, so that "Mon" is the first Monday in the month, etc.) The third
  97 field is arbitrary text.  Up to 16 characters are inserted into the
  98 calendar in the appropriate place if the specified date falls in the
  99 calendar month.
 100 
 101 
 102 Rel opcode: For the "rel" opcode, there are five fields. The second is
 103 the month number.  0 indicates the current month, -1 the previous
 104 month, +1 the following month.  The third is a date, relative to the
 105 day before the first of the month.  The fourth field is a date relative
 106 to the third field, which is the day selected. The fifth field is text.
 107 Thus, the line
 108   rel,11,Mon,Tue,Election Day defines the first Tuesday after the first
 109 Monday in November.
 110 
 111 
 112 Repeat opcode: For the "repeat" opcode there are 5 fields.  The second
 113 is the starting date for a series of identical notations.  It may be an
 114 ordinary date, or 0 (to indicate that the series starts at the first of
 115 any month), or a relative date or a date offset.  The third field is
 116 the end date for the series, or an unsigned integer indicating the
 117 number of entries in the series, or 0 to indicate a perpetual series.
 118 The fourth field is the interval expressed as a date offset (e.g.
 119 1week).  The fifth field is text.  Example:
 120   repeat,04/01/80,9weeks,1week,Karate lesson
 121   repeat,Thursday,0,1week,Staff Meeting
 122 
 123 
 124 Easter opcode: For the "easter" opcode, there are only two fields. The
 125 second is text to be inserted into the box for Easter.
 126 
 127 
 128 Rename opcode: For the "rename" opcode, there are three fields. The
 129 second is a day or month name to be replaced by the third.
 130     rename,Monday,segunda-feira
 131   changes the heading for the Monday column.
 132 
 133 
 134 Note:  If an entry is more than 16 characters, multiple date and rel
 135 entries may be used.  For example:
 136    rel,2,Mon,2weeks,Washington's
 137    rel,2,Mon,2weeks,birthday
 138 
 139 
 140 Example file: The following is an example file that defines permanent
 141 holidays.
 142   * holidays
 143   date,01/01,New Year's Day
 144   date,02/02,Ground Hog Day
 145   rel,2,Mon,2 weeks,Washington Bday
 146   easter,Easter
 147   rel,5,sun,1 week,Mothers Day
 148   rel,5,05/24,Mon,Memorial Day
 149   date,07/04,Independence Day
 150   rel,9,0,Mon,Labor Day
 151   rel,10,Mon,1 week,Columbus Day
 152   rel,10,Mon,3 weeks,Veterans Day
 153   rel,11,Mon,Tue,Election Day
 154   rel,11,Thu,3 weeks,Thanksgiving
 155   date,12/25,Christmas Day
 156   repeat,02/29/04,0,4years,Leap Day
 157   * end
 158 
 159    THVV 12/73 */
 160 /* Modified 12/77 by Dennis Capps to allow rel to calculate dates relative to previous or following month. */
 161 /* modified 01/78 THVV for rename */
 162 /* Modified 04/80 by Dennis Capps to use clock builtin and to add repeat opcode */
 163 /* Modified 08/80 by Dennis Capps for Multics argument syntax, -stop, -wait, -force, -box_height, -julian. */
 164 /* Modified 09/80 by Dennis Capps to fix bug in Easter. */
 165 /* Modified 10/86 by Tai L. Nguyen to allow an entry name of 32 characters long */
 166 /* ^L */
 167 
 168 declare             /* Pointers */
 169 ap                  pointer,            /* -> an argument. */
 170 ap2                 pointer,            /* -> an argument. */
 171 ifdp                pointer,            /* -> data on input files. */
 172 lp                  pointer,            /* -> the current input line. */
 173 olp                 pointer,            /* -> set of output lines for a week. */
 174 pfp                 pointer,            /* -> to structure for small calendars. */
 175 seg_ptr             pointer,            /* -> input file currently being scanned. */
 176 storp               pointer,            /* -> storage space for calendar notes. */
 177 temp_seg_ptr        pointer;            /* -> temp seg for large amts of storage. */
 178 
 179 declare             /* Fixed binary numbers. */
 180 al                  fixed bin,                    /* Length of argument. */
 181 al2                 fixed bin,                    /* Length of argument. */
 182 an                  fixed bin,                    /* Argument number. */
 183 box_height          fixed bin init(7),            /* Number of lines in a calendar box. */
 184 century             fixed bin,                    /* Calendar century. */
 185 day_chain_roots(31) fixed bin init ((31)0),       /* Indices of first cells of lists in storage, one per day. */
 186 days_mo             fixed bin,                    /* # days in this month. */
 187 days_mop            fixed bin,                    /* # days in previous month. */
 188 days_mof            fixed bin,                    /* # days in next month. */
 189 days_yr             fixed bin,                    /* # days in year. */
 190 ec                  fixed bin (35),               /* Error code. */
 191 ec2                 fixed bin (35),               /* Error code. */
 192 fld_ix(5)           fixed bin,                    /* Positions in input line of up to 5 data fields. */
 193 fld_ln(5)           fixed bin,                    /* Lengths of the up to 5 data fields in each input line. */
 194 how_many_fields     fixed bin,                    /* The number of fields in the current input line. */
 195 i                   fixed bin,                    /* Temporary. */
 196 inf                 fixed bin,                    /* Index for loop on input files. */
 197 input_line_count    fixed bin,                    /* Count of lines processed so far in current input file. */
 198 jj                  fixed bin,                    /* Temporary */
 199 jjj                 fixed bin,                    /* Temporary */
 200 last_cell_no        fixed bin init(0),            /* Index of most recently "allocated" cell in the storage array. */
 201 lchr                fixed bin,                    /* No of chars in input line sans final NL. */
 202 lchrnl              fixed bin,                    /* no of chars in input line including final NL. */
 203 max_cells           fixed bin init(24000) internal static options(constant),
 204 repeat_count        fixed bin,                    /* For repeat opcode: no of times to write note. */
 205 size                fixed bin,                    /* Number of lines available after julian date. */
 206 x                   fixed bin;                    /* Temporary. */
 207 
 208 declare   /* Date and time variables */
 209 bom                 fixed bin (71),               /* Microsecond which starts this month. */
 210 bomf                fixed bin(71),                /* Microsecond which starts following month. */
 211 bomp                fixed bin(71),                /* Microsecond which starts previous month. */
 212 end_absda           fixed bin,                    /* # days since 1 Jan 1901 of end of repeat. */
 213 fb71                fixed bin (71),               /* Temporary microsecond time. */
 214 fb71a               fixed bin (71),               /* Temporary microsecond time. */
 215 fwbase              fixed bin,                    /* # days since 1 Jan 1901 of first Monday in year */
 216 mo_absda            fixed bin,                    /* # days since 1 Jan 1901 of this month. */
 217 mo_absdaf           fixed bin,                    /* # days since 1 Jan 1901 of beginning of following month. */
 218 rbom                fixed bin (71),               /* Microsecond which starts a month. Temp for rel. */
 219 sr_absda            fixed bin,                    /* # days since 1 Jan 1901 of start of repeat. */
 220 yr_absda            fixed bin;                    /* # days since 1 Jan 1901 of 1 Jan this year. */
 221 
 222 declare             /* Character Strings */
 223 bchr                char (al) unal based (ap),    /* Argument. */
 224 bchr2               char (al2) unal based (ap2),  /* Argument. */
 225 current_line        char(168) aligned,            /* Storage space for the current input line. */
 226 input_line          char(lchr) aligned based(lp), /* The current input line. */
 227 whole_seg           char (131071) based (seg_ptr) aligned;
 228 
 229 declare             /* Bit strings. */
 230 ave_switch          bit(1) init("0"b),            /* Error in value of an argument. */
 231 error_switch        bit(1) init("0"b),            /* Error in line of an input file. */
 232 force_switch        bit(1) init("0"b),            /* Ctl arg present.  Print in spite of errors. */
 233 fwsw                bit (1) init ("0"b),          /* Ctl arg present.  Print fiscal week. */
 234 julian_switch       bit(1) init("0"b),            /* Ctl arg present.  Print julian dates. */
 235 stop_switch         bit(1) init("0"b),            /* Ctl arg present.  Pause before and after calendar. */
 236 syntax_warning      bit(1) init("0"b),            /* Found obsolete syntax. */
 237 wait_switch         bit(1) init("0"b);            /* Ctl arg present.  Pause before calendar. */
 238 
 239 dcl (addr, clock, divide, fixed, hbound, index, length, ltrim, max, min, mod, null, reverse, rtrim, substr, verify) builtin;
 240 
 241 declare cleanup condition;
 242 
 243 declare             /* External entries */
 244 bigletter_                    entry (char (*) aligned, entry),
 245 com_err_                      entry options (variable),
 246 convert_date_to_binary_       entry (char (*), fixed bin (71), fixed bin (35)),
 247 convert_date_to_binary_$relative        entry (char (*), fixed bin (71), fixed bin (71), fixed bin (35)),
 248 cu_$arg_count                 entry (fixed bin),
 249 cu_$arg_ptr                   entry (fixed bin, ptr, fixed bin, fixed bin (35)),
 250 cv_dec_check_                 entry (char (*), fixed bin (35)) returns (fixed bin),
 251 datebin_                      entry (fixed bin (71), fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin,
 252                                     fixed bin, fixed bin, fixed bin),
 253 datebin_$revert               entry (fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin (71)),
 254 expand_path_                  entry (ptr, fixed bin, ptr, ptr, fixed bin (35)),
 255 get_temp_segment_             entry (char(*), ptr, fixed bin(35)),
 256 hcs_$initiate_count           entry (char (*) aligned, char (*) aligned, char (*) aligned,
 257                                     fixed bin (24), fixed bin (2), ptr, fixed bin (35)),
 258 hcs_$terminate_noname         entry (ptr, fixed bin (35)),
 259 ioa_$rsnnl                    entry options (variable),
 260 iox_$get_line                 entry (ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35)),
 261 iox_$put_chars                entry (ptr, ptr, fixed bin (21), fixed bin (35)),
 262 release_temp_segment_         entry (char(*), ptr, fixed bin(35));
 263 
 264 
 265 declare             /* External constants. */
 266 iox_$user_input               ptr ext,
 267 iox_$user_output              ptr ext;
 268 
 269 declare
 270 error_table_$bad_conversion   fixed bin (35) ext,
 271 error_table_$badopt           fixed bin (35) ext;
 272 
 273 /* Data structures. */
 274 declare
 275 1 if_data aligned based(ifdp),
 276      2 how_many     fixed bin,          /* Count of input files. */
 277      2 pad          fixed bin,
 278      2 if(100) aligned,                 /* Info for each input file. */
 279           3 ifptr   ptr,
 280           3 bitc    fixed bin(24),
 281           3 dn      char(168),
 282           3 en      char(32),
 283      2 next_storage_block     ptr;      /* For addr only. */
 284 
 285 /* End of new variables section. */
 286 
 287 dcl (absda, mm, dd, yy, hh, minute, ss, wkd, shf) fixed bin,          /* Breakdown of date. */
 288     (wkdp, wkdf) fixed bin,                                 /* Starting day of week for prev & foll months. */
 289     (mmp, mmf, yyp, yyf) fixed bin,                         /* Previous & following mo. & year containing. */
 290     (xmm, xyy, xdd, x1) fixed bin,                          /* Breakdown of date to remember. */
 291      titlestr char (16) aligned,                            /* Title for calendar, e.g. "January 74" */
 292     (day_of_month, day_of_week) fixed bin,
 293     (cursor, k, n, jpf, kpf) fixed bin, /* temps. */
 294     (srday, endday, interval) fixed bin,                    /* repeat variables */
 295      nchr fixed bin,                                        /* length of current input file */
 296      command char (8),                                      /* opcode */
 297     d fixed bin,                                            /* .. */
 298      llth fixed bin (21) init (120),                        /* Length of a line. */
 299      boy fixed bin (71),                                    /* .. of this year */
 300      fwno fixed bin;                                        /* fiscal week no. */
 301 
 302 declare
 303 1 week_setup aligned based (olp),
 304      2 line (box_height) aligned,                 /* One formatted week. 7 lines by default. */
 305           3 day (7) unal,                         /* (16 + 1) * 7 = 119 */
 306                4 brk char (1),
 307                4 text char (16),
 308           3 rtbar char (1) unal,                  /* 119 + 1 = 120 */
 309      2 next_storage_block     ptr;                /* For addr only. */
 310 
 311 dcl 1 prevfoll unal based (pfp),
 312     2 headerp char (22) unal,
 313     2 pad1 char (8) unal,
 314     2 headerf char (21) unal,
 315     2 pad2 char (69) unal,
 316     2 week (6) unal,
 317       3 blank char (1),
 318       3 dayp (7) char (3),
 319       3 space char (8),
 320       3 dayf (7) char (3),
 321       3 morepad char (69);
 322 
 323 dcl 1 storage (max_cells) aligned based(storp),             /* Stores text for memorable dates. */
 324     2 date fixed bin (71),
 325     2 link fixed bin,                                       /* points to next entry on list. */
 326     2 pad fixed bin,
 327     2 text char (16);                                       /* Text placed in box. */
 328 
 329 dcl  moname (12) char (9) aligned init
 330     ("January", "February", "March", "April", "May", "June",
 331      "July", "August", "September", "October", "November", "December");
 332 
 333 dcl  ndays (12) fixed bin init
 334     (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
 335 
 336 dcl  head char (121) aligned;
 337 dcl  wkdname (7) char (16) aligned init
 338     ("Sunday", "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday");
 339 
 340 
 341 dcl  bar char (121) aligned int static init
 342     ("------------------------------------------------------------------------------------------------------------------------
 343 ");
 344 dcl  horizline char (121) aligned init (" ");
 345 
 346 dcl  NL char (1) aligned int static init ("
 347 ");
 348 
 349 dcl  FF char (1) int static init ("^L");
 350 
 351 /* ======================================================== */
 352 
 353           on cleanup call cleanup_proc();
 354 
 355           /* Get a large amt of storage. */
 356           call get_temp_segment_("calendar",temp_seg_ptr,ec);
 357           if ec ^= 0 then
 358                do;
 359                call com_err_(ec, "calendar","System error attempting to get a temporary segment.");
 360                call cleanup_proc();
 361                return;
 362                end;
 363 
 364           ifdp      = temp_seg_ptr;
 365           if_data.how_many    = 0;
 366           fb71      = clock();          /* This is the default time if "-date" ctl arg not used. */
 367 
 368           /* Process command arguments. */
 369           call cu_$arg_count(x);        /* Neater than waiting for error_table_$no_arg. */
 370 
 371           do an = 1 to x;               /* Collect all the arguments. */
 372           call cu_$arg_ptr(an,ap,al,ec);
 373           if ec ^= 0 then               /* Has to be real error, not just out of args. */
 374                goto fatal_arg_error;
 375 
 376           if substr(bchr,1,1) = "-" then          /* Got a control argument. */
 377                do;
 378                if bchr = "-date" | bchr = "-dt" then
 379                     do;
 380                     an = an + 1;        /* Get value from following argument. */
 381                     call cu_$arg_ptr(an,ap2,al2,ec);
 382                     if ec ^= 0 then     /* This is a real error, even if just out of args.  */
 383                          goto fatal_arg_error;
 384                     call convert_date_to_binary_(bchr2,fb71,ec);
 385                     if ec ^= 0 then     /* This error is important enough to be fatal. */
 386                          goto fatal_arg_val_error;
 387                     end;
 388 
 389                else
 390                if bchr = "-sp" | bchr = "-stop" then
 391                     stop_switch = "1"b;
 392 
 393                else
 394                if bchr = "-wt" | bchr = "-wait" then
 395                     wait_switch = "1"b;
 396 
 397                else
 398                if bchr = "-fc" | bchr = "-force" then
 399                     force_switch = "1"b;
 400 
 401                else
 402                if bchr = "-fw" | bchr = "-fiscal_week" then
 403                     fwsw = "1"b;
 404 
 405                else
 406                if bchr = "-jul" | bchr = "-julian" then
 407                     julian_switch = "1"b;
 408 
 409                else
 410                if bchr = "-bht" | bchr = "-box_height" then
 411                     do;
 412                     an = an + 1;
 413                     call cu_$arg_ptr(an,ap2,al2,ec);        /* Get the value. */
 414                     if ec ^= 0 then     /* This too is a real error, even if just out of args. */
 415                          do;
 416 fatal_arg_error:         call com_err_(ec,"calendar","Argument number ^d.  Command terminated.",an);
 417                          call cleanup_proc();
 418                          return;
 419                          end;
 420                     i = cv_dec_check_(bchr2,ec);
 421                     if ec ^= 0 then
 422                          do;            /* This error is important enough to be fatal. */
 423                          ec = error_table_$bad_conversion;
 424 fatal_arg_val_error:     call com_err_(ec,"calendar","Argument ^d: ^a.  Command terminated.",an,bchr2);
 425                          call cleanup_proc();
 426                          return;
 427                          end;
 428                     box_height = i;     /* Change from default (init) value. */
 429                     end;
 430 
 431                else do;
 432                     ec = error_table_$badopt;
 433                     goto arg_value_error;
 434                     end;
 435                end; /* Control arguments */
 436 
 437           else do;                      /* Got a pathname of an input file. */
 438                i    = if_data.how_many + 1;       /* Put info in next empty cell. */
 439                call expand_path_(ap,al,addr(if_data.if(i).dn),addr(if_data.if(i).en),ec);
 440                if ec ^= 0 then          /* Ought to be an error, but might be old syntax. */
 441                     if an = 1 then goto try_date;
 442                               else goto arg_value_error;
 443                call hcs_$initiate_count(if_data.if(i).dn,if_data.if(i).en,"",if_data.if(i).bitc,1,
 444                                         if_data.if(i).ifptr,ec);
 445                if if_data.if(i).ifptr = null then /* Ought to be an error, but ... */
 446                     if an = 1 then                /* .. check for old syntax. */
 447                          do;
 448 try_date:                call convert_date_to_binary_(bchr,fb71a,ec2);
 449                          if ec2 = 0 then
 450                               do;
 451                               fb71 = fb71a;
 452                               syntax_warning = "1"b;
 453                               end;
 454                          else goto arg_value_error;
 455                          end;
 456                     else do;
 457 arg_value_error:         call com_err_(ec,"calendar","Argument ^d: ^a.",an, bchr);
 458                          ave_switch = "1"b;
 459                          end;
 460                else if_data.how_many = i;         /* Data all good.  Keep the file. */
 461                end;
 462           end;      /* Argument loop. */
 463 
 464           if ave_switch then
 465                do;
 466                call com_err_(0,"calendar","Errors in command arguments.  Command aborted.");
 467                call cleanup_proc();
 468                return;
 469                end;
 470 
 471           /* Initialize basic time and date variables. */
 472           call datebin_ (fb71, absda, mm, dd, yy, hh, minute, ss, wkd, shf);
 473           call datebin_$revert (1, 1, yy, 0, 0, 0, boy);    /* Get beginning of year. */
 474           call datebin_ (boy, yr_absda, i, i, i, i, i, i, wkd, i);
 475           century =  divide (yy, 100, 17, 0) * 100;         /* Find current century. */
 476           if wkd >= 6 then wkd = wkd - 7;
 477           fwbase = yr_absda + 1 - wkd;                      /* Locate a "virtual monday" preceding the first */
 478           call datebin_$revert (mm, 1, yy, 0, 0, 0, bom);   /* Locate beginning of month. */
 479           call datebin_ (bom, mo_absda, mm, dd, yy, hh, minute, ss, wkd, shf);
 480           days_mo = ndays (mm);                             /* Get # of days in this month. */
 481           days_yr = 365;
 482           if (mm = 2) then if (leap_year(yy)) then
 483                do;
 484                     days_mo = days_mo + 1;
 485                     days_yr = days_yr + 1;
 486                end;
 487           fwno = 1 + divide ((mo_absda+mod (8-wkd, 7)) - fwbase, 7, 17, 0); /* Calculate first fiscal week no. for Monday */
 488 
 489 /* Calculate beginning of month for previous and following months. */
 490           if mm = 1 then do; mmp = 12; yyp = yy - 1; end;
 491           else do; mmp = mm - 1; yyp = yy; end;
 492           if mm = 12 then do; mmf = 1; yyf = yy + 1; end;
 493           else do; mmf = mm + 1; yyf = yy; end;
 494           days_mop  = ndays(mmp);
 495           days_mof  = ndays(mmf);
 496           if mmp = 2 then if leap_year(yyp) then days_mop = days_mop + 1;
 497           if mmf = 2 then if leap_year(yyf) then days_mof = days_mof + 1;
 498           call datebin_$revert (mmp, 1, yyp, 0, 0, 0, bomp);
 499           call datebin_$revert (mmf, 1, yyf, 0, 0, 0, bomf);
 500           call datebin_ (bomp, i        , i, i, i, i, i, i, wkdp, i);
 501           call datebin_ (bomf, mo_absdaf, i, i, i, i, i, i, wkdf, i);
 502 
 503           olp       = addr(if_data.next_storage_block);
 504           storp     = addr(week_setup.next_storage_block);
 505           lp        = addr(current_line);
 506 
 507 /* Now process all input files for events to be printed this month. */
 508 
 509           do inf = 1 to if_data.how_many;
 510                seg_ptr = if_data.if(inf).ifptr;
 511                nchr = divide (if_data.if(inf).bitc, 9, 17, 0);        /* Get length of file. */
 512                k = 1;
 513                input_line_count = 0;              /* count the lines so can give info in error message. */
 514                do while (k < nchr);                         /* Scan file */
 515                     lchrnl = index (substr (whole_seg, k), NL);       /* Find end of line */
 516                     if lchrnl = 0 then lchr, lchrnl = nchr-k+1;
 517                                   else lchr = lchrnl - 1;
 518                     current_line = substr (whole_seg, k, lchr);       /* Copy one line. */
 519                     input_line_count = input_line_count + 1;
 520                     if substr (current_line, 1, 1) = "*" then go to skip; /* Ignore comments. */
 521                     call parse_line(how_many_fields);
 522                     if how_many_fields = 0 then goto bad;
 523                     command = substr (input_line,fld_ix(1),fld_ln(1));
 524                     if command = "date" then do;
 525                          if how_many_fields < 3 then goto bad1;
 526                          call convert_date_to_binary_$relative (substr (input_line,fld_ix(2),fld_ln(2)), fb71, bom-1, ec);
 527                          if ec ^= 0 then go to bad;         /* Convert to binary. */
 528                          call datebin_ (fb71, x1, xmm, xdd, xyy, x1, x1, x1, x1, x1);
 529                          if xmm = mm then if xyy = yy then  /* If current month and year then remember it. */
 530                               call fill_in_note(xdd,fb71,substr(input_line,fld_ix(3),min(16,fld_ln(3))));
 531                     end;
 532                     else if command = "rel" then do;        /* A date relative to another. */
 533                          if how_many_fields < 5 then goto bad1;
 534                          if substr (input_line, fld_ix(2), 2) = "-1" then xmm = mmp;
 535                          else
 536                          if substr (input_line, fld_ix(2), 2) = "+1" then xmm = mmf;
 537                          else do;
 538                               xmm = cv_dec_check_ (substr (input_line,fld_ix(2),fld_ln(2)), ec);
 539                               if ec ^= 0 then go to bad1;
 540                               if xmm = 0 then xmm = mm;
 541                          end;
 542                          if xmm = mmp then rbom = bomp;
 543                          else if xmm = mm then rbom = bom;
 544                          else if xmm = mmf then rbom = bomf;
 545                          else goto skip;
 546                          /* Get first date.  */
 547                          if substr (input_line, fld_ix(3), fld_ln(3)) = "0" then fb71a = rbom-1; /* Special case. */
 548                          else do;
 549                               call convert_date_to_binary_$relative(substr(input_line,fld_ix(3),fld_ln(3)),fb71a,rbom-1,ec);
 550                               if ec ^= 0 then go to bad;
 551                          end;
 552                          /* Now second date relative to first. */
 553                          call convert_date_to_binary_$relative (substr (input_line, fld_ix(4), fld_ln(4)), fb71, fb71a, ec);
 554                          if ec ^= 0 then go to bad;
 555                          call datebin_ (fb71, x1, xmm, xdd, xyy, x1, x1, x1, x1, x1);
 556                          if xmm = mm then if xyy = yy then  /* If current month and year then remember it. */
 557                               call fill_in_note(xdd,fb71,substr(input_line,fld_ix(5),min(16,fld_ln(5))));
 558                     end;
 559                     else if command = "repeat" then
 560                          do;
 561                          if how_many_fields < 5 then goto bad;
 562 
 563                          /* Get interval */
 564                          if substr(input_line,fld_ix(4),fld_ln(4)) = "0" then interval = 1;         /* i.e., one day. */
 565                          else do;
 566                               call convert_date_to_binary_$relative(substr(input_line,fld_ix(4),fld_ln(4)),
 567                                                                       fb71,bom,ec);
 568                               if ec ^= 0 then goto bad;
 569                               call datebin_(fb71,absda,x1,x1,x1,x1,x1,x1,x1,x1);
 570                               interval = max(1,absda-mo_absda);       /* No neg interval.  >= one day. */
 571                               end;
 572 
 573                          /* Get start date */
 574                          if substr(input_line,fld_ix(2),fld_ln(2)) = "0" then
 575                               do;
 576                               sr_absda = mo_absda;          /* Need this if have to calculate end date from repeat count. */
 577                               srday    = 1;
 578                               end;
 579                          else do;
 580                               call convert_date_to_binary_$relative(substr(input_line,fld_ix(2),fld_ln(2)),
 581                                                                       fb71,bom-1,ec);
 582                               if ec ^= 0 then goto bad;
 583                               if fb71 >= bomf then goto skip;         /* Starts after end of month. */
 584                               /* Starting date is before or in this month.  If in the month, srday in the following call
 585                                  is valid.  If not, sr_absda is needed to calculate it.  sr_absda might also be needed
 586                                  if it is necessary to calculate the end date from a repeat count. */
 587                               call datebin_(fb71,sr_absda,x1,srday,x1,x1,x1,x1,x1,x1);
 588                               if fb71 < bom then  /* Start before month. First target day in month is: */
 589                                    srday = interval - mod(mo_absda-1-sr_absda, interval);
 590                               end;
 591 
 592                          /* Get end date or count of notes. */
 593                          if substr(input_line,fld_ix(3),fld_ln(3)) = "0" then
 594                               endday    = days_mo;
 595                          else
 596                          if verify(rtrim(ltrim(substr(input_line,fld_ix(3),fld_ln(3)))), "0123456789") = 0 then
 597                               do;       /* This is all digits, so must be a count of the number of notes. */
 598                               repeat_count = fixed(substr(input_line,fld_ix(3),fld_ln(3)));
 599                               end_absda = sr_absda + ((repeat_count - 1) * interval);
 600                               if end_absda < mo_absda then goto skip; /* Ends before this month. */
 601                               if end_absda >= mo_absdaf then endday = days_mo;  /* Ends next mo or later. */
 602                               else endday = end_absda - mo_absda + 1;           /* Ends some time within month. */
 603                               end;
 604                          else do;
 605                               call convert_date_to_binary_$relative(substr(input_line,fld_ix(3),fld_ln(3)),
 606                                                                       fb71,bom-1,ec);
 607                               if ec ^= 0 then goto bad;
 608                               if fb71 < bom then goto skip;           /* Ends before start of month. */
 609                               if fb71 >= bomf then endday = days_mo;  /* Ends next month or later. */
 610                               else call datebin_(fb71,x1,x1,endday,x1,x1,x1,x1,x1,x1);
 611                               end;
 612 
 613                          /* Fill in notes for target days. */
 614                          do d = srday to endday by interval;
 615                          call datebin_$revert(xmm,d,xyy,0,0,0,fb71);
 616                          call fill_in_note(d,fb71,substr(input_line,fld_ix(5),min(16,fld_ln(5))));
 617                          end; /* LOOP */
 618                     end;      /* "repeat" opcode */
 619                     else if command = "easter" then do;     /* Easter day */
 620                          if mm = 3 | mm = 4 then            /* Can only occur in March or April. */
 621                               call calculate_easter(yy,xmm,xdd);
 622                          else goto skip;
 623                          if xmm = mm then do;               /* Comes this month?  Yes, put it on the list. */
 624                               call datebin_$revert (xmm, xdd, yy, 0, 0, 0, fb71);
 625                               call fill_in_note(xdd,fb71,substr(input_line,fld_ix(2),min(16,fld_ln(2))));
 626                          end;
 627                     end;
 628                     else if command = "rename" then do;
 629                          do jjj = 1 to 12;
 630                               if moname(jjj) = substr(input_line,fld_ix(2),fld_ln(2)) then
 631                                         moname(jjj) = substr(input_line,fld_ix(3));
 632                          end;
 633                          do jjj = 1 to 7;
 634                               if wkdname (jjj) = substr (input_line, fld_ix(2), fld_ln(2)) then
 635                                         wkdname (jjj) = substr (input_line, fld_ix(3));
 636                          end;
 637                     end;
 638                     else do;                                /* Invalid opcode. */
 639 bad1:                    ec = 0;                            /* No system err code. */
 640 bad:                     call com_err_ (ec, "calendar", "Illegal command on line ^d in ^a: ^a",
 641                                         input_line_count, if_data.if(inf).en, input_line);
 642                          error_switch = "1"b;
 643                     end;
 644 skip:               k = k+lchrnl;                           /* Move to start of next line. */
 645                end;                                         /* End of file scan. */
 646           end;      /* Loop on input files. */
 647 
 648           /* If there were errors, quit unless user said to print anyway. */
 649           if error_switch then
 650                if force_switch then
 651                     call com_err_(0,"calendar","Error diagnostics complete.");
 652                else do;
 653                     call com_err_(0,"calendar","Errors in input files.  Command aborted.");
 654                     call cleanup_proc();
 655                     return;
 656                     end;
 657 
 658           if stop_switch | wait_switch then       /* Wait for newline. */
 659                call iox_$get_line(iox_$user_input,lp,168,0,ec);
 660 
 661 /* Put out the calendar. */
 662 
 663           call ioa_$rsnnl ("^a ^d", titlestr, i, moname (mm), yy - century);
 664           call bigletter_ (titlestr, writer);               /* Write fancy heading. */
 665           head = NL;
 666           cursor = 2;
 667           do day_of_week = 1 to 7;
 668                i = divide (17 - length (rtrim (wkdname (day_of_week))), 2, 17, 0); /* Center weekday name */
 669                substr (head, cursor+i, 17-i) = wkdname (day_of_week); /* stringsize raised, so what */
 670                cursor = cursor + 17;
 671           end;
 672           substr (head, cursor, 1) = NL;
 673           call iox_$put_chars (iox_$user_output, addr (head), (cursor), ec);
 674 
 675           if wkd = 7 then wkd = 0;                          /* How many days in first week? */
 676           i = wkd * 17;                                     /* How much of the top horiz line to leave out. */
 677           substr (horizline, i+1) = substr (bar, i+1, length (bar)-i);
 678           call iox_$put_chars (iox_$user_output, addr (horizline), length (horizline), ec); /* Write line of dashes */
 679           line (*).brk (*) = "|";
 680           line (*).rtbar = "|";
 681           do day_of_week = 1 to wkd;                        /* Blank out missing days and their vertical lines. */
 682                line(*).brk(day_of_week) = " ";
 683                line (*).text (day_of_week) = "";
 684           end;
 685 
 686           /* First week short? */
 687           if wkd > 1 & box_height > 6 then do;              /* At least 3 blank boxes in first week, room for 1-2 little */
 688                pfp = addr (line);                           /* Overlay small calendars on week storage. */
 689                call previous_month;                         /* Fill in previous month. */
 690           end;
 691           if wkd > 2 & box_height > 6 then                  /* Room enough for both small calendars in first week. */
 692                call follow_month;                           /* Fill in following month. */
 693 
 694           day_of_month = 1;
 695           if julian_switch & box_height > 1 then
 696                do;
 697                size = box_height - 1;
 698                jj  = mo_absda - yr_absda + 1;
 699                jjj = days_yr - jj;
 700                end;
 701           else size = box_height;
 702           do while ("1"b);
 703                if fwsw & day_of_week = 2 then do;           /* Want Honeywell fiscal weeks? */
 704                     call ioa_$rsnnl (" FW ^2d^7x^2d ", line (1).text (2), (0), fwno, day_of_month);
 705                     fwno = fwno + 1;
 706                end;
 707                else call ioa_$rsnnl ("^15d ", line (1).text (day_of_week), (0), day_of_month);
 708                                                             /* First line in box is number of day. */
 709                if julian_switch & box_height > 1 then       /* Last line is julian, if user wants and enough room. */
 710                     do;
 711                     call ioa_$rsnnl("^3d^10x^3d",line(box_height).text(day_of_week),(0),jj,jjj);
 712                     jj  = jj  + 1;
 713                     jjj = jjj - 1;
 714                     end;
 715                do i = size to 2 by -1;                      /* Fill in rest of box. */
 716                     if day_chain_roots (day_of_month) = 0 then line (i).text (day_of_week) = ""; /* .. either blank, or */
 717                     else do;                                /* .. text from storage. */
 718                          line (i).text (day_of_week) = storage.text (day_chain_roots (day_of_month));
 719                          day_chain_roots (day_of_month) = storage.link (day_chain_roots (day_of_month)); /* Unlink datum from chain. */
 720                     end;
 721                end;
 722                day_of_week = day_of_week + 1;
 723                day_of_month = day_of_month + 1;
 724                day_of_month =  check_start_Gregory(yy, mm, day_of_month);
 725                if day_of_month > days_mo then go to out;    /* Done with the month? */
 726                if day_of_week > 7 then do;                  /* Done with the week? */
 727                     call putweek;                           /* Yes. Write one week. */
 728                     line(*).brk(*), line(*).rtbar = "|";    /* Restore vertical lines in case small cal zapped */
 729 
 730                     day_of_week = 1;                        /* Reset day of week. */
 731                     call iox_$put_chars (iox_$user_output, addr (bar), length (bar), ec);
 732                end;
 733           end;
 734 
 735 out:      if wkd < 3 & box_height > 6 then do;              /* Insert previous and following month, if appropriate. */
 736                if wkd = 0 & days_mo = 28 then do;           /* February starting on Sunday --> No blank partial week. */
 737                     call putweek;                           /* Print the fourth week as is. */
 738                     call iox_$put_chars (iox_$user_output, addr (bar), length(bar), ec);
 739                     llth = 51;                              /* Length of two small calendars. */
 740                     pfp = addr (line);                      /* Overlay small calendars on week storage. */
 741                     do i = 1 to 3;                          /* Get rid of vertical lines. */
 742                     line(*).day(i).brk = " ";
 743                     line(*).day(i).text = " ";              /* And old text. */
 744                     end;
 745                end;
 746                else do;
 747                     pfp = addr (line (1).day (5).text);     /* Overlay small calendars on end of last week. */
 748                     line(*).day(day_of_week).text = " ";    /* Blank out this day's text. */
 749                     line(*).rtbar = " ";                    /* And final vertical bar. */
 750                     do i = day_of_week + 1 to 7;            /* Blank out rest of week. */
 751                          line (*).day (i).brk = " ";        /* Get rid of excess vertical lines. */
 752                          line (*).day (i).text = " ";       /* And the text they contained. */
 753                     end;                                    /* Loop */
 754                end;                                         /* else */
 755                call follow_month;                           /* Set up small calendar for following month. */
 756                if wkd < 2 then call previous_month;         /* And previous if necessary. */
 757           end;
 758           else llth = 1 + (day_of_week-1) * 17;             /* no small cal's.  Calculate length of last week. */
 759 
 760           call putweek;                                     /* Write last week with calendars. (Or just calendars.) */
 761 
 762           llth = 1 + (day_of_week-1) * 17;                  /* Length of bottom horiz line on last week. */
 763           if ^(wkd = 0 & days_mo = 28 & box_height > 6) then          /*  Write bottom line unless just calendars. */
 764                call iox_$put_chars (iox_$user_output, addr (bar), llth, ec); /* Write partial line of dashes */
 765           call iox_$put_chars (iox_$user_output, addr (FF), 1, ec); /* Write FF */
 766 
 767           /* May need to wait for user to put paper in terminal. */
 768           if stop_switch then
 769                call iox_$get_line(iox_$user_input,lp,168,0,ec);
 770 
 771           if syntax_warning then
 772                call com_err_(0,"calendar","WARNING: You are using an obsolete syntax.^/New syntax is: calendar {paths} {-ctlargs}^/Type ""help calendar"" for details.");
 773 
 774           do day_of_month = 1 to days_mo;
 775                day_of_month =  check_start_Gregory(yy, mm, day_of_month);
 776                do jj = 1 to 100 while (day_chain_roots (day_of_month) ^= 0);
 777                     call com_err_ (0, "calendar", "Item cannot fit in ^a ^d: ^a",
 778                          moname (mm), day_of_month, storage.text (day_chain_roots (day_of_month)));
 779                     day_chain_roots (day_of_month) = storage.link (day_chain_roots (day_of_month));
 780                end;
 781           end;
 782 
 783           call cleanup_proc();
 784 
 785           return;
 786 
 787 /* -------------------------------------------------------- */
 788 
 789 fill_in_note:       proc(day,abs_time,note);
 790 
 791 declare
 792 day                 fixed bin,          /* The day of the month which is getting this note. */
 793 abs_time            fixed bin(71),      /* The clock reading for the beginning of this day. */
 794 note                char(16);           /* What to write in the box. */
 795 
 796 /*  Some variables are declared in the parent block:
 797 last_cell_no        fixed bin:          Index of most recently "allocated" cell in storage array.
 798 max_cells           fixed bin:          The maximum number of such cells.
 799 storage:            A structure used to hold the notes until time to print the calendar.
 800 day_chain_roots(31) fixed bin:          Indices of first cell in chain of notes for the days of the month.
 801 */
 802 
 803           last_cell_no = last_cell_no + 1;        /* Allocate another cell in storage. */
 804           if last_cell_no > max_cells then goto too_many_notes;
 805 
 806           storage.link(last_cell_no)    = day_chain_roots(day);       /* Chain this cell into list for this day. */
 807           day_chain_roots(day)          = last_cell_no;               /* After this, fill in the cell. */
 808           storage.date(last_cell_no)    = abs_time;         /* CAVEAT:  If this is ever used anywhere, should figure
 809                                                                         out if this is an appropriate value. */
 810           storage.text(last_cell_no)    = note;
 811           return;
 812 
 813 too_many_notes:               /* Ran out of room in storage. */
 814           call com_err_(0,"calendar","Maximum number of calendar entries exceeded.");
 815           return;
 816 
 817 end fill_in_note;
 818 
 819 /* -------------------------------------------------------- */
 820 
 821 parse_line:         proc(no_of_fields);
 822                     /* The first field starts at the first non-blank character.
 823                        All other fields start at the first character after the comma. */
 824 
 825 declare
 826 no_of_fields        fixed bin,          /* Returned.  The number of fields found on the input line. */
 827 (i, f, c)           fixed bin;          /* Temporaries. */
 828 
 829 /* Declared in the outer block.
 830 fld_ix(5) fixed bin:          Positions of up to 5 fields in the input line. This proc fills in.
 831 fld_ln(5) fixed bin:          Lengths of the up to 5 fields on the input line.  This proc fills in.
 832 input_line char(lchr) aligned based(lp): The current input line.
 833 lchr      fixed bin:          The number of characters in the current input line (sans final NL).
 834 */
 835 
 836           i = 1;
 837           fld_ln(*) = 0;
 838           i = verify(input_line," ");   /* first non-blank character. */
 839           if i = 0 then                 /* All blank, no fields. */
 840                do;
 841                f = 0;
 842                goto done;
 843                end;
 844 
 845           do f = 1 to hbound(fld_ln,1) while(i < lchr);
 846           fld_ix(f) = i;
 847           c = index(substr(input_line,i), ",");   /* End of field. */
 848           if c = 0 then                           /* No comma, last field. */
 849                do;
 850                fld_ln(f) = lchr - i + 1;
 851                goto done;
 852                end;
 853           fld_ln(f) = c - 1;
 854           i = i + c;                              /* Start of next field. */
 855           if i > lchr then goto done;             /* Line ends with comma, no more fields. */
 856           end;      /* Loop */
 857 
 858           f = f - 1;          /* Loop index is too high. */
 859 
 860 done:     no_of_fields = f;
 861           return;
 862 
 863 end parse_line;
 864 
 865 /* -------------------------------------------------------- */
 866 
 867 putweek:  proc;                                             /* Writes one week's data.  No. lines is box_height. */
 868 
 869                do i = 1 to box_height;
 870                     call iox_$put_chars (iox_$user_output, addr (line (i)), llth, ec);
 871                     call iox_$put_chars (iox_$user_output, addr (NL), 1, ec);
 872                end;
 873 
 874           end putweek;
 875 
 876 /* -------------------------------------------------------- */
 877 
 878 writer:   proc (xp, xl);                                    /* Called by bigletter_ to write header. */
 879 
 880 dcl  xp ptr, xl fixed bin;
 881 dcl  bcs char (xl) based (xp);
 882 dcl  i fixed bin (21);
 883 
 884                if bcs ^= "" then do;
 885                     i = xl + 1 - verify (reverse (bcs), " ");
 886                     call iox_$put_chars (iox_$user_output, xp, i, ec);
 887                end;
 888                call iox_$put_chars (iox_$user_output, addr (NL), 1, ec); /* Write NL */
 889 
 890           end writer;
 891 
 892 /* -------------------------------------------------------- */
 893 
 894 previous_month: proc;
 895 
 896                call ioa_$rsnnl (" ^9a^7x^4d", prevfoll.headerp, n, moname (mmp), yyp);
 897                i = 1;
 898                if wkdp = 7 then wkdp = 0;
 899                do kpf = 1 to wkdp;
 900                     prevfoll.week (1).dayp (kpf) = " ";
 901                end;
 902                do jpf = 1 to days_mop;
 903                     jpf =  check_start_Gregory(yyp, mmp, jpf);
 904                     call ioa_$rsnnl ("^2d ", prevfoll.week (i).dayp (kpf), n, jpf);
 905                     kpf = kpf + 1;
 906                     if kpf > 7 then do;
 907                          kpf = 1;
 908                          i = i + 1;
 909                     end;
 910                end;                                         /* jpf loop */
 911 
 912                do while (i <= 6);
 913                     do jpf = kpf to 7;
 914                          prevfoll.week (i).dayp (jpf) = " ";
 915                     end;                                    /* jpf loop */
 916                     i = i + 1;
 917                     kpf = 1;
 918                end;                                         /* while */
 919           end previous_month;
 920 
 921 /* -------------------------------------------------------- */
 922 
 923 follow_month: proc;
 924 
 925                call ioa_$rsnnl ("^9a^7x^4d ", prevfoll.headerf, n, moname (mmf), yyf);
 926                i = 1;
 927                if wkdf = 7 then wkdf = 0;
 928                do kpf = 1 to wkdf;
 929                     prevfoll.week (1).dayf (kpf) = " ";
 930                end;
 931                do jpf = 1 to days_mof;
 932                     jpf =  check_start_Gregory(yyf, mmf, jpf);
 933                     call ioa_$rsnnl ("^2d ", prevfoll.week (i).dayf (kpf), n, jpf);
 934                     kpf = kpf + 1;
 935                     if kpf > 7 then do;
 936                          kpf = 1;
 937                          i = i + 1;
 938                     end;
 939                end;                                         /* jpf loop */
 940 
 941                do while (i <= 6);
 942                     do jpf = kpf to 7;
 943                          prevfoll.week (i).dayf (jpf) = " ";
 944                     end;                                    /* jpf loop */
 945                     i = i + 1;
 946                     kpf = 1;
 947                end;                                         /* while */
 948           end follow_month;
 949 
 950 /* -------------------------------------------------------- */
 951 ^L
 952 calculate_easter:   proc(year, month, day);
 953 
 954 declare
 955 day       fixed bin,
 956 month     fixed bin,
 957 year      fixed bin,
 958 (a, b, c, d, e, g, h, i, k, l, m) fixed bin;
 959 
 960           /* The following calculation of the Date for Easter follows the algorithm
 961              given in the New Scientist magazine, issue No. 228 (Vol. 9) page 828 (30 March 1961). */
 962           a = mod(year,19);             /* Find position of year in 19-year Lunar Cycle, called the Golden Number. */
 963           b = divide(year,100,35);      c = mod(year,100);  /* b is century number, c is year number within century*/
 964           d = divide(b,4,35);           e = mod(b,4);       /* These are used in leap year adjustments. */
 965           i = divide(c,4,35);           k = mod(c,4);       /* Also related to leap year. */
 966 
 967           /* The next step computes a correction factor used in the following step
 968              which computes the number of days between the spring equinox
 969              and the first full moon thereafter.  The correction factor is needed
 970              to keep the approximation in line with the observed behavior of the moon.
 971              It moves the full moon date back by one day eight times in every 2500 years,
 972              in century years three apart, with four years at the end of the cycle.
 973              The constant 13 corrects the correction for the fact that this
 974              cycle was decreed to start in the year 1800. */
 975           g = divide(8*b+13,25,35);
 976 
 977           /* Now the number of days after the equinox (21 March, by definition) that
 978              we find the next full moon.  This is a number between 0 and 29.
 979              The term 19*a advances the full moon 19 days for each year of the
 980              Lunar Cycle, for a total of 361 days in the 19 years.  The other 4.24 days
 981              are made up when a returns to zero on the next cycle.  Thus, the
 982              full moon dates repeat every 19 years.  The term b-d advances the
 983              date by one day for three out of every four century years, the
 984              years which are not leap years although divisible by 4.
 985              The term g is the correction factor calculated above, and 15
 986              adjusts this whole calculation to the actual conditions at that
 987              date on which the scheme began, probably in Oct of 1582. */
 988           h = mod(19*a + b - d - g + 15, 30);
 989 
 990           /* Now we are interested in how many days we have to wait after the
 991              full moon until we get a Sunday (which has to be definitely after
 992              the full moon).  The following step calculates a number l which is
 993              one less than the number of days.  Every ordinary year ends on the
 994              same day of the week on which it started;  a leap year ends on the
 995              day of the week following the one on which it started.  Thus, if
 996              it is known on what day of the week a date occurred in any year
 997              it is possible to calculate its day of the week in another year
 998              by marching through the week one day for each regular year and
 999              two for each leap year.
1000                   The term k is the number of ordinary years
1001              since the last leap year;  each such year brings the date of the
1002              full moon one day closer to Sunday, and so reduces the number of
1003              days to be waited (unless it goes negative, but modular arithmetic
1004              theory makes -1 = 6 where the modulus is 7).
1005                   The term i is the number of leap years so far in the current century.
1006              each leap year has with it three ordinary years, and each such group
1007              advances the day of the week by 5 days.  But in modulo 7 arithmetic
1008              subtracting 5 days is equivalent to adding 2 days.  So we add
1009              two days for each group of four years in the current century.
1010                   Since a century consists of 25 groups of four years, it advances
1011              the day of the week by 124 or 125 days depending on whether the
1012              century year is an ordinary or leap year.  The remainders when
1013              these numbers are divided by seven are 5 and 6 respectively.
1014              The term e is the number of ordinary century years since the
1015              last leap century year.  As with the groups of four years, we
1016              add two days for each rather than subtract 5 for each.
1017                   Every fourth century year is a leap year;  therefore,
1018              each group of four centuries advances the day of the week by
1019              3*5+6 = 21 days, or 0 in modulo 7 arithmetic, and no
1020              term is necessary for time before the last leap century year.
1021              The constant term 32 adjusts the calculation for the day of the
1022              week of the equinox when the scheme was put into effect.  It also
1023              is larger than necessary by 28 in order to assure that the
1024              subtractions of k and h never reduce the dividend below 0.
1025                   Thus, mod(2*e + 2*i - k + 32, 7) gives one less than the number
1026              of days between the equinox and its following Sunday.  But we need to
1027              calculate the number of days after the full moon.  The term h,
1028              calculated in the previous step, gives the number of days after
1029              the equinox that the full moon occurs.  Each of those days brings
1030              the full moon closer to the actual Sunday of Easter,
1031              so it reduces the number of days after the full moon until Easter.
1032              (Again, if h > 6, modular arithmetic theory readjusts the result to
1033              another cycle of 0 to 6, and here the constant 32 keeps the dividend > 0.)   */
1034           l = mod(2*e + 2*i - k + 32 - h, 7);
1035 
1036           /* The calendar set up by Pope Gregory XIII and his advisor, the astronomer
1037              Clavius, provided for official full moon dates as well as matching
1038              the equinoxes and solstices with their nominal dates.  But, since
1039              the period of the moon is not an exact number of days, some fudging
1040              was needed here as elsewhere in the calendar system.  Some of the
1041              periods between successive full moons in the Lunar Cycle are 30 days,
1042              some 29 days.  Clavius then arranged the periods carefully so
1043              that if a full moon fell on 20 March (the day before the equinox),
1044              the period following it would be of 29 days.  The effect of this
1045              arrangement is that Easter can never occur later than 25 April.
1046              The above calculations assume uniform 30-day lunar periods.  In rare
1047              cases (e.g., 1954 and 1981) one of these 29-day lunar periods causes
1048              the full moon to fall on a Saturday where a 30-day period would put
1049              it on a Sunday.  The following step calculates the fudge factor for
1050              this situation.  The result m is 0 if no fudging is necessary, or
1051              1 if fudging is required.     */
1052           m = divide(a + 11*h + 19*l, 433, 35);
1053 
1054           /* Now we have calculated the number of days which will elapse between
1055              21 march and Easter: h + (l + 1) - 7*m.  The next two steps
1056              turn this into a month and day.  In the first expression, the constant
1057              90 assures that the the quotient will be at least 3 (= March).
1058              If the elapsed days exceed 9, then the quotient will be 4 (= April).
1059              In the second expression, if month = 3 then 33*month + 19 = 118 and the
1060              remainder of that part of the expression is 22;  when month = 3,
1061              l + h - 7*m < 10, so 22 < day <= 31.
1062              If month = 4, 33*month = 132, and since h + l - 7*m > 9, the whole
1063              expression satisfies 5*32 = 160 < expr.  The remainder is greater
1064              than 0 and less than 26.   */
1065           month     = divide(h + l - 7*m + 90, 25, 35);
1066           day       = mod(h + l - 7*m +33*month + 19, 32);
1067 
1068           return;
1069 
1070 end calculate_easter;
1071 ^L
1072 cleanup_proc:       proc;
1073 
1074           do if_data.how_many = if_data.how_many to 1 by -1;
1075           if if_data.if(if_data.how_many).ifptr ^= null then
1076                do;
1077                call hcs_$terminate_noname(if_data.if(if_data.how_many).ifptr,ec);
1078                if_data.if(if_data.how_many).ifptr = null;
1079                end;
1080           end;
1081 
1082           if temp_seg_ptr ^= null then
1083                call release_temp_segment_("calendar",temp_seg_ptr,ec);
1084 
1085           return;
1086 
1087 end cleanup_proc;
1088 /* -------------------------------------------------------- */
1089 
1090 leap_year:  proc (year) returns(bit(1));
1091             dcl year fixed bin;
1092 
1093             if mod (year, 4) = 0 then
1094 /* Centesimal years are common years unless divisible by 400.  */
1095 /* This was done to correct the error in the Julian calendar.  */
1096                if mod(year, 100)=0 & mod(year, 400)^=0 & year>1582 then
1097                       return("0"b);
1098                else   return("1"b);
1099             else return("0"b);
1100 
1101        end leap_year;
1102 /* -------------------------------------------------------- */
1103 
1104 check_start_Gregory:
1105             proc (year, month, day_of_month) returns (fixed bin);
1106             dcl (year, month, day_of_month) fixed bin;
1107 
1108 /* In the Gregorian calendar, October 5 through the 14 are removed. */
1109 
1110             if year = 1582 & month = 10 & day_of_month = 5 then
1111                    return(15);
1112             else   return(day_of_month);
1113 
1114        end check_start_Gregory;
1115 
1116 
1117 /* -------------------------------------------------------- */
1118      end calendar;