bigletter_.pl1 11/04/82 1905.9rew 11/04/82 1613.4 75024 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ bigletter_: proc (inchar, writer); /* BIGLETTER_ - Create "big letters" for printing. Used by IO Daemon subroutine "head_sheet_" and routine "make_tape_labels", and others. This routine can make two sizes of letters: 9x8 large letters, and 5x5 small ones. The letters are printed according to a format matrix which shows where a mark should be made. Each input letter is looked up in a "translation alphabet" -- if not found, the letter is skipped. Only 132 characters will be put out on a line - this is 13 9x8 letters or 22 5x5 letters. An entry point is provided for the user who insists on making his own alphabet and format matrix, for the 8x9 case only. the $init entry sets this up, and the $var is used to write. THVV */ dcl inchar char (*); /* Input character string to be written. */ dcl writer entry (ptr, fixed bin); /* Input user program to write one line. */ dcl 1 letters (0:128) based (bigp) aligned, /* The matrix to be used. Subscript 0 is not used. */ 2 bits bit (item) aligned; /* 36 or 72 bit elements. */ dcl 1 letter based (letp) aligned, /* A single letter in the array. */ 2 bitrow (high) bit (wide) unal; /* .. consists of a matrix of bits */ dcl 1 letters9 (0: 128) based (bigp) aligned, /* Special for 9x8 */ 2 bits bit (72) aligned; dcl 1 letter9 based (letp) aligned, 2 bitrow9 bit (72); dcl 1 letters5 (0: 128) based (bigp) aligned, /* Special for 5x5 */ 2 bits bit (36) aligned; dcl 1 letter5 based (letp) aligned, 2 bitrow5 bit (36); dcl cx fixed bin (8) unal based (addr (c)); /* For convert char to number in fast case. */ dcl i fixed bin, /* index in input string */ ii fixed bin, /* horizontal index in output char */ m fixed bin, /* Constant part of above */ row fixed bin, /* vertical index in output */ inch char (22), /* Copy of input. */ incl fixed bin, /* Length of input. */ x fixed bin, /* horizontal index in output buffer */ k fixed bin, /* index of character in alphabet. */ c char (1) aligned, /* temp for one char of inchar */ big_letterp ptr int static init (null), /* pointer to user-supplied format matrix */ alpha char (128) aligned, /* actual lookup alphabet used. */ item fixed bin, /* width of element in "letters" -- 36 or 72 */ high fixed bin, /* letter height */ wide fixed bin, /* letter width */ bigp ptr, /* pointer to actual alphabet format matrix */ letp ptr; /* pointer to current letter format matrix */ dcl alphabet char (128) aligned int static init (""); /* user-supplied lookup alphabet */ dcl fill char (1) aligned int static init ("*"); /* user-supplied fill character */ dcl (letseg_$letseg, letseg_$littles) fixed bin ext; /* System alphabet format matrices */ dcl (null, length, substr, index) builtin; dcl linebuf char (132) aligned; /* Output buffer for one line. */ /* ===================================================== */ regular: bigp = addr (letseg_$letseg); /* Regular 9 x 8 big letters, upper and lower case. */ inch = inchar; /* Copy input for speed. */ incl = length (inchar) + 1 - verify (reverse (inchar), " "); m = 0; do row = 1 to 9; /* Will put out nine lines. */ linebuf = ""; /* Clean out line buffer. */ x = 1; /* Reset to left margin. */ do i = 1 to incl; /* Loop over the input string. */ c = substr (inch, i, 1); /* Get one character. */ if unspec (c) = "000001000"b then do; /* handle backpsace */ if x > 10 then x = x - 10; /* .. overstriking will work */ go to skip0; end; if x > 125 then go to skip0; /* write max of 132 */ k = cx - 31; if k <= 0 then go to skip0; if k = 1 then do; /* Special-case blanks. */ x = x +10; go to skip0; end; if fill ^= " " then c = fill; /* Default makes all *'s - user can change. */ letp = addr (letters9 (k)); /* Find format matrix for the "K"th letter */ do ii = 1 to 8; /* Minor loop is over the letter width. */ if substr (bitrow9, m+ii, 1) then substr (linebuf, x, 1) = c; x = x + 1; /* Go to next column */ end; x = x + 2; /* Make room between letters. */ skip0: end; call writer (addr (linebuf), 132); /* Give the line to the user procedure. */ m = m + 8; /* Increment array index. */ end; return; /* Finished. */ /* Entry point to make 5 x 5 characters. */ five: entry (inchar, writer); bigp = addr (letseg_$littles); /* Find 5x5 letters. */ inch = inchar; /* Copy input for speed. */ incl = length (inchar) + 1 - verify (reverse (inchar), " "); m = 0; do row = 1 to 5; /* Will put out five lines. */ linebuf = ""; /* Clean out line buffer. */ x = 1; /* Reset to left margin. */ do i = 1 to incl; /* Loop over the input string. */ c = substr (inch, i, 1); /* Get one character. */ if unspec (c) = "000001000"b then do; /* handle backpsace */ if x > 7 then x = x - 7; /* .. overstriking will work */ go to skip1; end; if x > 128 then go to skip1; /* write max of 132 */ k = cx - 31; if k <= 0 then go to skip1; if k = 1 then do; /* Special-case blanks. */ x = x + 7; go to skip1; end; if fill ^= " " then c = fill; /* Default makes all *'s - user can change. */ letp = addr (letters5 (k)); /* Find format matrix for the "K"th letter */ do ii = 1 to 5; /* Minor loop is over the letter width. */ if substr (bitrow5, m+ii, 1) then substr (linebuf, x, 1) = c; x = x + 1; /* Go to next column */ end; x = x + 2; /* Make room between letters. */ skip1: end; call writer (addr (linebuf), 132); /* Give the line to the user procedure. */ m = m + 5; /* Increment array index. */ end; return; /* Finished. */ /* Entry to use user-specified alphabel for 9 x 8 characters */ var: entry (inchar, writer); if big_letterp = null then go to regular; /* If user never init'ed, use regular big letters */ bigp = big_letterp; /* Retrieve saved matrix pointer */ alpha = alphabet; /* .. and saved lookup alphabet */ wide = 8; /* Set sizes */ high = 9; /* ... */ item = 72; /* ... */ /* The main loop is on the height of the letters. */ inch = inchar; /* Copy input for speed. */ incl = length (inchar) + 1 - verify (reverse (inchar), " "); do row = 1 to high; /* Will put out "high" lines. */ linebuf = ""; /* Clean out line buffer. */ x = 1; /* Reset to left margin. */ do i = 1 to incl; /* Loop over the input string. */ c = substr (inch, i, 1); /* Get one character. */ if unspec (c) = "000001000"b then do; /* handle backpsace */ if x > (wide+2) then x = x-wide-2; /* .. overstriking will work */ go to skip; end; if x+wide > 133 then go to skip; /* write max of 132 */ k = index (alpha, c); /* Look up input character in lookup alphabet */ if k = 0 then go to skip; /* If not found, ignore character. */ if fill ^= " " then c = fill; /* Default makes all *'s - user can change. */ letp = addr (letters (k)); /* Find format matrix for the "K"th letter */ do ii = 1 to wide; /* Minor loop is over the letter width. */ if substr (bitrow (row), ii, 1) then substr (linebuf, x, 1) = c; x = x + 1; /* Go to next column */ end; x = x + 2; /* Make room between letters. */ skip: end; call writer (addr (linebuf), 132); /* Give the line to the user procedure. */ end; return; /* Finished. */ /* --------------------------------------------- */ init: entry (xp, a, f); /* Entry for the user who wants to play. */ dcl xp ptr, (a, f) char (*); fill = f; alphabet = a; big_letterp = xp; return; end bigletter_;  calendar.pl1 10/19/90 1706.2rew 10/19/90 1655.4 417852 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1990 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-10-20,TLNguyen), approve(86-10-20,MCR7558), audit(86-10-22,Gilcrease), install(86-10-22,MR12.0-1197): Correct a declaration of an entry name as 32 characters size 2) change(90-09-27,Itani), approve(90-10-01,MCR8208), audit(90-10-10,Bubric), install(90-10-14,MR12.4-1040): Change "calendar" to use the "Pope Gregory XIII" method for calculating dates. Also make some headers in calendar more descriptive. 3) change(90-10-18,Itani), approve(90-10-18,PBF8208), audit(90-10-18,Bubric), install(90-10-19,MR12.4-1048): Changed [(yy/100)*100] To: [divide(yy,100,17,0)*100]. END HISTORY COMMENTS */ 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. */ /* Modified 10/86 by Tai L. Nguyen to allow an entry name of 32 characters long */ /* */ 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. */ 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. */ century fixed bin, /* Calendar century. */ 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; /* 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(32), 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 */ d 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 (" "); /* ======================================================== */ 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); century = divide (yy, 100, 17, 0) * 100; /* Find current century. */ 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. */ days_yr = 365; if (mm = 2) then if (leap_year(yy)) then do; days_mo = days_mo + 1; days_yr = days_yr + 1; end; 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 leap_year(yyp) then days_mop = days_mop + 1; if mmf = 2 then if leap_year(yyf) 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 - century); 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; day_of_month = check_start_Gregory(yy, mm, day_of_month); 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; day_of_month = check_start_Gregory(yy, mm, day_of_month); 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^7x^4d", prevfoll.headerp, n, moname (mmp), yyp); 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; jpf = check_start_Gregory(yyp, mmp, jpf); 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^7x^4d ", prevfoll.headerf, n, moname (mmf), yyf); 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; jpf = check_start_Gregory(yyf, mmf, jpf); 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; /* -------------------------------------------------------- */ 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; 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; /* -------------------------------------------------------- */ leap_year: proc (year) returns(bit(1)); dcl year fixed bin; if mod (year, 4) = 0 then /* Centesimal years are common years unless divisible by 400. */ /* This was done to correct the error in the Julian calendar. */ if mod(year, 100)=0 & mod(year, 400)^=0 & year>1582 then return("0"b); else return("1"b); else return("0"b); end leap_year; /* -------------------------------------------------------- */ check_start_Gregory: proc (year, month, day_of_month) returns (fixed bin); dcl (year, month, day_of_month) fixed bin; /* In the Gregorian calendar, October 5 through the 14 are removed. */ if year = 1582 & month = 10 & day_of_month = 5 then return(15); else return(day_of_month); end check_start_Gregory; /* -------------------------------------------------------- */ end calendar;  letseg_.alm 11/04/82 1905.9rew 11/04/82 1632.1 47871 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** name letseg_ segdef letseg segdef littles letseg: oct 000000000000,000000000000 oct 000000000000,000000000000 oct 060140300601,403000014030 oct 314630000000,000000000000 oct 000220447762,237711022000 oct 000041766207,701337404000 oct 001617460301,406031743400 oct 060220440604,460641474000 oct 030140000000,000000000000 oct 006030140300,601403003003 oct 600600601403,006014060300 oct 000142312657,753246214000 oct 000000300617,743006000000 oct 000000000000,000030060200 oct 000000000007,700000000000 oct 000000000000,000030060000 oct 006014060301,406030140300 oct 060631463146,314631414000 oct 030160140300,601403037400 oct 170430030140,603014077400 oct 376030140700,300301476000 oct 006034170663,157700601400 oct 771403007600,600643074000 oct 160621403706,314631436000 oct 776030140603,014030060000 oct 060631460606,314631414000 oct 060631461740,300611416000 oct 000000003006,000030060000 oct 000000003006,000030060200 oct 006030140603,003003003003 oct 000000003740,017600000000 oct 600600600600,603014060300 oct 170410020103,406014000060 oct 375006355132,264547677000 oct 170773036077,770360741400 oct 771413027714,130360777000 oct 375407006014,030060277000 oct 771413036074,170360576000 oct 777403007754,030060177400 oct 777403007754,030060140000 oct 375407006014,770360677000 oct 607417037774,170360741400 oct 170140300601,403006036000 oct 006014030060,170360677000 oct 615463307015,431461541400 oct 601403006014,030060177400 oct 607637336674,170360741400 oct 607617236674,571761741400 oct 375417036074,170360677000 oct 771413027714,030060140000 oct 375417036074,170362677002 oct 771413027714,130360741400 oct 375407003740,140340677000 oct 776140300601,403006014000 oct 607417036074,170360677000 oct 607417036074,154617014000 oct 607417036675,574760700400 oct 606630740603,614660741400 oct 403415461701,403006014000 oct 776014060301,406030177400 oct 036060140300,601403006017 oct 601401401401,401401401403 oct 740300601403,006014030360 oct 020120000000,000000000000 oct 000000000000,000000000377 oct 060060000000,000000000000 oct 000000003740,157760677400 oct 601403007754,170360777000 oct 000000003774,030060077400 oct 006014033774,170360677400 oct 000000003754,177660077000 oct 000160607703,006014030000 oct 000000003754,031760677000 oct 601403007754,170360741400 oct 000000300003,403006036000 oct 000000300001,403006154370 oct 001403146617,033063143000 oct 000001700601,403006017000 oct 000000005555,573366755400 oct 000000005754,170360741400 oct 000000003754,170360677000 oct 000000007754,170377540300 oct 000000003754,170337601407 oct 000000005616,630060140000 oct 000000003754,017600677000 oct 000000303741,403006014000 oct 000000006074,170360677400 oct 000000006074,154617014000 oct 000000006075,573371641000 oct 000000006063,603017141400 oct 000000006066,146607014170 oct 000000003740,603014077000 oct 006030140141,600603003003 oct 040100200400,002004010020 oct 600600603003,414014060300 oct 170020000000,000000000000 oct 000000000000,000000000000 littles: oct 000000000000 oct 000000000000 oct 102040020000 oct 240000000000 oct 257527650000 oct 372161370000 oct 635042714000 oct 212145370000 oct 021000000000 oct 144102030000 oct 301020460000 oct 112775220000 oct 002371000000 oct 000001440000 oct 000160000000 oct 000000010000 oct 021042100000 oct 105212420000 oct 106041070000 oct 311042174000 oct 740560370000 oct 430770204000 oct 770360370000 oct 164364270000 oct 761042100000 oct 311144460000 oct 311360460000 oct 000040020000 oct 003001440000 oct 104202020000 oct 017407600000 oct 101010420000 oct 350421020000 oct 772674174000 oct 105374304000 oct 750764370000 oct 370204074000 oct 750614370000 oct 770364174000 oct 770364100000 oct 370274274000 oct 430774304000 oct 342041070000 oct 020414270000 oct 431304504000 oct 410204174000 oct 435654304000 oct 434654704000 oct 350614270000 oct 750764100000 oct 350614674000 oct 750764304000 oct 370160370000 oct 762041020000 oct 430614270000 oct 430612420000 oct 430656704000 oct 425042504000 oct 425041020000 oct 761042174000 oct 344102070000 oct 404040404000 oct 341020470000 oct 042400000000 oct 000000174000 oct 040400000000 oct 105374304000 oct 750764370000 oct 370204074000 oct 750614370000 oct 770364174000 oct 770364100000 oct 370274274000 oct 430774304000 oct 342041070000 oct 020414270000 oct 431304504000 oct 410204174000 oct 435654304000 oct 434654704000 oct 350614270000 oct 750764100000 oct 350614674000 oct 750764304000 oct 370160370000 oct 762041020000 oct 430614270000 oct 430612420000 oct 430656704000 oct 425042504000 oct 425041020000 oct 761042174000 oct 144302030000 oct 102001020000 oct 301030460000 oct 341000000000 oct 000000000000 end bull_copyright_notice.txt 08/30/05 1008.4r 08/30/05 1007.3 00020025 ----------------------------------------------------------- Historical Background This edition of the Multics software materials and documentation is provided and donated to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. as a contribution to computer science knowledge. This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology, Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull and Bull HN Information Systems Inc. to the development of this operating system. Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970), renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for managing computer hardware properly and for executing programs. Many subsequent operating systems incorporated Multics principles. Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. . ----------------------------------------------------------- Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without fee is hereby granted,provided that the below copyright notice and historical background appear in all copies and that both the copyright notice and historical background and this permission notice appear in supporting documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining to distribution of the programs without specific prior written permission. Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc. Copyright 2006 by Bull HN Information Systems Inc. Copyright 2006 by Bull SAS All Rights Reserved