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 2012 version in JavaScript.
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."