COMPILATION LISTING OF SEGMENT calendar Compiled by: Multics PL/I Compiler, Release 33b, of October 17, 1990 Compiled at: ACTC Technologies Inc. Compiled on: 10/19/90 1655.4 mdt Fri Options: optimize map 1 /****^ *********************************************************** 2* * * 3* * Copyright, (C) BULL HN Information Systems Inc., 1990 * 4* * * 5* * Copyright, (C) Honeywell Information Systems Inc., 1982 * 6* * * 7* *********************************************************** */ 8 9 10 11 12 /****^ HISTORY COMMENTS: 13* 1) change(86-10-20,TLNguyen), approve(86-10-20,MCR7558), 14* audit(86-10-22,Gilcrease), install(86-10-22,MR12.0-1197): 15* Correct a declaration of an entry name as 32 characters size 16* 2) change(90-09-27,Itani), approve(90-10-01,MCR8208), audit(90-10-10,Bubric), 17* install(90-10-14,MR12.4-1040): 18* Change "calendar" to use the "Pope Gregory XIII" method for calculating 19* dates. Also make some headers in calendar more descriptive. 20* 3) change(90-10-18,Itani), approve(90-10-18,PBF8208), audit(90-10-18,Bubric), 21* install(90-10-19,MR12.4-1048): 22* Changed [(yy/100)*100] To: [divide(yy,100,17,0)*100]. 23* END HISTORY COMMENTS */ 24 25 26 calendar: proc; 27 28 /* Info seg describes what this program is supposed to do. 29*08/20/80 calendar 30* 31*Syntax: calendar {paths} {-control_args} 32* 33* 34*Function: prints a calendar for one month. The preceding and 35*following months are also shown. 36* 37* 38*Arguments: 39*paths 40* are segments listing calendar events. See "Input" below. 41* 42* 43*Control arguments: 44*-date D, -dt D 45* D is any date acceptable to convert_date_to_binary_. The calendar is 46* printed for the month containing this -date. If -date is not given, 47* current month is printed. 48*-fw, -fiscal_week 49* labels boxes with fiscal week. 50*-wait, -wt 51* waits for the user to type a newline (carriage return) before 52* printing the calendar. 53*-stop, -sp 54* waits for the user to type a newline (carriage return) before 55* printing the calendar and again after printing it. 56*-force, -fc 57* prints the calendar even if errors are found in the input files. 58* Prints "Error diagnostics complete." after the error messages (but 59* only if there were errors). 60*-box_height, -bht 61* changes the height of each calendar box from 7 lines to N lines. If 62* N < 7, calendars for previous and following months do not appear in 63* margin. 64*-julian, -jul 65* prints "julian dates" in bottom line of each box -- number of day 66* from beginning of year and number of days remaining in year. 67* 68* 69*New features: 70*new syntax: use -date control argument 71*command aborts if errors are found in any input file. 72*If old syntax is used, a warning prints after the formfeed at the end 73*of the calendar. 74*new_control arguments: -wait, -stop, -force, -box_height, -julian 75* 76* 77*Output: The calendar has the month name and two-digit year at the top 78*in big letters. Each calendar box is 16 characters wide; by default 79*it is 7 lines high (see -box_height control argument). The boxes 80*contain nothing but the number of the day in the month, unless one or 81*more paths are specified in the command line. Small calendars for 82*previous and following months are fitted in above or below the main 83*calendar. 84* 85* 86*Input: Each path specifies a segment containing comment lines that 87*begin with "*", and lines that set up a string to be inserted into the 88*calendar. The latter lines have from two to five fields, separated by 89*commas. The first field is always the operation code (date, rel, 90*repeat, rename, or easter). 91* 92* 93*Date opcode: For the "date" opcode, there are three fields. The second 94*field is any date acceptable to convert_date_to_binary_. (This date 95*will be converted relative to the day before the beginning of the 96*month, so that "Mon" is the first Monday in the month, etc.) The third 97*field is arbitrary text. Up to 16 characters are inserted into the 98*calendar in the appropriate place if the specified date falls in the 99*calendar month. 100* 101* 102*Rel opcode: For the "rel" opcode, there are five fields. The second is 103*the month number. 0 indicates the current month, -1 the previous 104*month, +1 the following month. The third is a date, relative to the 105*day before the first of the month. The fourth field is a date relative 106*to the third field, which is the day selected. The fifth field is text. 107*Thus, the line 108* rel,11,Mon,Tue,Election Day defines the first Tuesday after the first 109*Monday in November. 110* 111* 112*Repeat opcode: For the "repeat" opcode there are 5 fields. The second 113*is the starting date for a series of identical notations. It may be an 114*ordinary date, or 0 (to indicate that the series starts at the first of 115*any month), or a relative date or a date offset. The third field is 116*the end date for the series, or an unsigned integer indicating the 117*number of entries in the series, or 0 to indicate a perpetual series. 118*The fourth field is the interval expressed as a date offset (e.g. 119*1week). The fifth field is text. Example: 120* repeat,04/01/80,9weeks,1week,Karate lesson 121* repeat,Thursday,0,1week,Staff Meeting 122* 123* 124*Easter opcode: For the "easter" opcode, there are only two fields. The 125*second is text to be inserted into the box for Easter. 126* 127* 128*Rename opcode: For the "rename" opcode, there are three fields. The 129*second is a day or month name to be replaced by the third. 130* rename,Monday,segunda-feira 131* changes the heading for the Monday column. 132* 133* 134*Note: If an entry is more than 16 characters, multiple date and rel 135*entries may be used. For example: 136* rel,2,Mon,2weeks,Washington's 137* rel,2,Mon,2weeks,birthday 138* 139* 140*Example file: The following is an example file that defines permanent 141*holidays. 142* * holidays 143* date,01/01,New Year's Day 144* date,02/02,Ground Hog Day 145* rel,2,Mon,2 weeks,Washington Bday 146* easter,Easter 147* rel,5,sun,1 week,Mothers Day 148* rel,5,05/24,Mon,Memorial Day 149* date,07/04,Independence Day 150* rel,9,0,Mon,Labor Day 151* rel,10,Mon,1 week,Columbus Day 152* rel,10,Mon,3 weeks,Veterans Day 153* rel,11,Mon,Tue,Election Day 154* rel,11,Thu,3 weeks,Thanksgiving 155* date,12/25,Christmas Day 156* repeat,02/29/04,0,4years,Leap Day 157* * end 158* 159* THVV 12/73 */ 160 /* Modified 12/77 by Dennis Capps to allow rel to calculate dates relative to previous or following month. */ 161 /* modified 01/78 THVV for rename */ 162 /* Modified 04/80 by Dennis Capps to use clock builtin and to add repeat opcode */ 163 /* Modified 08/80 by Dennis Capps for Multics argument syntax, -stop, -wait, -force, -box_height, -julian. */ 164 /* Modified 09/80 by Dennis Capps to fix bug in Easter. */ 165 /* Modified 10/86 by Tai L. Nguyen to allow an entry name of 32 characters long */ 166 /* */ 167 168 declare /* Pointers */ 169 ap pointer, /* -> an argument. */ 170 ap2 pointer, /* -> an argument. */ 171 ifdp pointer, /* -> data on input files. */ 172 lp pointer, /* -> the current input line. */ 173 olp pointer, /* -> set of output lines for a week. */ 174 pfp pointer, /* -> to structure for small calendars. */ 175 seg_ptr pointer, /* -> input file currently being scanned. */ 176 storp pointer, /* -> storage space for calendar notes. */ 177 temp_seg_ptr pointer; /* -> temp seg for large amts of storage. */ 178 179 declare /* Fixed binary numbers. */ 180 al fixed bin, /* Length of argument. */ 181 al2 fixed bin, /* Length of argument. */ 182 an fixed bin, /* Argument number. */ 183 box_height fixed bin init(7), /* Number of lines in a calendar box. */ 184 century fixed bin, /* Calendar century. */ 185 day_chain_roots(31) fixed bin init ((31)0), /* Indices of first cells of lists in storage, one per day. */ 186 days_mo fixed bin, /* # days in this month. */ 187 days_mop fixed bin, /* # days in previous month. */ 188 days_mof fixed bin, /* # days in next month. */ 189 days_yr fixed bin, /* # days in year. */ 190 ec fixed bin (35), /* Error code. */ 191 ec2 fixed bin (35), /* Error code. */ 192 fld_ix(5) fixed bin, /* Positions in input line of up to 5 data fields. */ 193 fld_ln(5) fixed bin, /* Lengths of the up to 5 data fields in each input line. */ 194 how_many_fields fixed bin, /* The number of fields in the current input line. */ 195 i fixed bin, /* Temporary. */ 196 inf fixed bin, /* Index for loop on input files. */ 197 input_line_count fixed bin, /* Count of lines processed so far in current input file. */ 198 jj fixed bin, /* Temporary */ 199 jjj fixed bin, /* Temporary */ 200 last_cell_no fixed bin init(0), /* Index of most recently "allocated" cell in the storage array. */ 201 lchr fixed bin, /* No of chars in input line sans final NL. */ 202 lchrnl fixed bin, /* no of chars in input line including final NL. */ 203 max_cells fixed bin init(24000) internal static options(constant), 204 repeat_count fixed bin, /* For repeat opcode: no of times to write note. */ 205 size fixed bin, /* Number of lines available after julian date. */ 206 x fixed bin; /* Temporary. */ 207 208 declare /* Date and time variables */ 209 bom fixed bin (71), /* Microsecond which starts this month. */ 210 bomf fixed bin(71), /* Microsecond which starts following month. */ 211 bomp fixed bin(71), /* Microsecond which starts previous month. */ 212 end_absda fixed bin, /* # days since 1 Jan 1901 of end of repeat. */ 213 fb71 fixed bin (71), /* Temporary microsecond time. */ 214 fb71a fixed bin (71), /* Temporary microsecond time. */ 215 fwbase fixed bin, /* # days since 1 Jan 1901 of first Monday in year */ 216 mo_absda fixed bin, /* # days since 1 Jan 1901 of this month. */ 217 mo_absdaf fixed bin, /* # days since 1 Jan 1901 of beginning of following month. */ 218 rbom fixed bin (71), /* Microsecond which starts a month. Temp for rel. */ 219 sr_absda fixed bin, /* # days since 1 Jan 1901 of start of repeat. */ 220 yr_absda fixed bin; /* # days since 1 Jan 1901 of 1 Jan this year. */ 221 222 declare /* Character Strings */ 223 bchr char (al) unal based (ap), /* Argument. */ 224 bchr2 char (al2) unal based (ap2), /* Argument. */ 225 current_line char(168) aligned, /* Storage space for the current input line. */ 226 input_line char(lchr) aligned based(lp), /* The current input line. */ 227 whole_seg char (131071) based (seg_ptr) aligned; 228 229 declare /* Bit strings. */ 230 ave_switch bit(1) init("0"b), /* Error in value of an argument. */ 231 error_switch bit(1) init("0"b), /* Error in line of an input file. */ 232 force_switch bit(1) init("0"b), /* Ctl arg present. Print in spite of errors. */ 233 fwsw bit (1) init ("0"b), /* Ctl arg present. Print fiscal week. */ 234 julian_switch bit(1) init("0"b), /* Ctl arg present. Print julian dates. */ 235 stop_switch bit(1) init("0"b), /* Ctl arg present. Pause before and after calendar. */ 236 syntax_warning bit(1) init("0"b), /* Found obsolete syntax. */ 237 wait_switch bit(1) init("0"b); /* Ctl arg present. Pause before calendar. */ 238 239 dcl (addr, clock, divide, fixed, hbound, index, length, ltrim, max, min, mod, null, reverse, rtrim, substr, verify) builtin; 240 241 declare cleanup condition; 242 243 declare /* External entries */ 244 bigletter_ entry (char (*) aligned, entry), 245 com_err_ entry options (variable), 246 convert_date_to_binary_ entry (char (*), fixed bin (71), fixed bin (35)), 247 convert_date_to_binary_$relative entry (char (*), fixed bin (71), fixed bin (71), fixed bin (35)), 248 cu_$arg_count entry (fixed bin), 249 cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)), 250 cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin), 251 datebin_ entry (fixed bin (71), fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, 252 fixed bin, fixed bin, fixed bin), 253 datebin_$revert entry (fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin (71)), 254 expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35)), 255 get_temp_segment_ entry (char(*), ptr, fixed bin(35)), 256 hcs_$initiate_count entry (char (*) aligned, char (*) aligned, char (*) aligned, 257 fixed bin (24), fixed bin (2), ptr, fixed bin (35)), 258 hcs_$terminate_noname entry (ptr, fixed bin (35)), 259 ioa_$rsnnl entry options (variable), 260 iox_$get_line entry (ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35)), 261 iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)), 262 release_temp_segment_ entry (char(*), ptr, fixed bin(35)); 263 264 265 declare /* External constants. */ 266 iox_$user_input ptr ext, 267 iox_$user_output ptr ext; 268 269 declare 270 error_table_$bad_conversion fixed bin (35) ext, 271 error_table_$badopt fixed bin (35) ext; 272 273 /* Data structures. */ 274 declare 275 1 if_data aligned based(ifdp), 276 2 how_many fixed bin, /* Count of input files. */ 277 2 pad fixed bin, 278 2 if(100) aligned, /* Info for each input file. */ 279 3 ifptr ptr, 280 3 bitc fixed bin(24), 281 3 dn char(168), 282 3 en char(32), 283 2 next_storage_block ptr; /* For addr only. */ 284 285 /* End of new variables section. */ 286 287 dcl (absda, mm, dd, yy, hh, minute, ss, wkd, shf) fixed bin, /* Breakdown of date. */ 288 (wkdp, wkdf) fixed bin, /* Starting day of week for prev & foll months. */ 289 (mmp, mmf, yyp, yyf) fixed bin, /* Previous & following mo. & year containing. */ 290 (xmm, xyy, xdd, x1) fixed bin, /* Breakdown of date to remember. */ 291 titlestr char (16) aligned, /* Title for calendar, e.g. "January 74" */ 292 (day_of_month, day_of_week) fixed bin, 293 (cursor, k, n, jpf, kpf) fixed bin, /* temps. */ 294 (srday, endday, interval) fixed bin, /* repeat variables */ 295 nchr fixed bin, /* length of current input file */ 296 command char (8), /* opcode */ 297 d fixed bin, /* .. */ 298 llth fixed bin (21) init (120), /* Length of a line. */ 299 boy fixed bin (71), /* .. of this year */ 300 fwno fixed bin; /* fiscal week no. */ 301 302 declare 303 1 week_setup aligned based (olp), 304 2 line (box_height) aligned, /* One formatted week. 7 lines by default. */ 305 3 day (7) unal, /* (16 + 1) * 7 = 119 */ 306 4 brk char (1), 307 4 text char (16), 308 3 rtbar char (1) unal, /* 119 + 1 = 120 */ 309 2 next_storage_block ptr; /* For addr only. */ 310 311 dcl 1 prevfoll unal based (pfp), 312 2 headerp char (22) unal, 313 2 pad1 char (8) unal, 314 2 headerf char (21) unal, 315 2 pad2 char (69) unal, 316 2 week (6) unal, 317 3 blank char (1), 318 3 dayp (7) char (3), 319 3 space char (8), 320 3 dayf (7) char (3), 321 3 morepad char (69); 322 323 dcl 1 storage (max_cells) aligned based(storp), /* Stores text for memorable dates. */ 324 2 date fixed bin (71), 325 2 link fixed bin, /* points to next entry on list. */ 326 2 pad fixed bin, 327 2 text char (16); /* Text placed in box. */ 328 329 dcl moname (12) char (9) aligned init 330 ("January", "February", "March", "April", "May", "June", 331 "July", "August", "September", "October", "November", "December"); 332 333 dcl ndays (12) fixed bin init 334 (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31); 335 336 dcl head char (121) aligned; 337 dcl wkdname (7) char (16) aligned init 338 ("Sunday", "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday"); 339 340 341 dcl bar char (121) aligned int static init 342 ("------------------------------------------------------------------------------------------------------------------------ 343 "); 344 dcl horizline char (121) aligned init (" "); 345 346 dcl NL char (1) aligned int static init (" 347 "); 348 349 dcl FF char (1) int static init (" "); 350 351 /* ======================================================== */ 352 353 on cleanup call cleanup_proc(); 354 355 /* Get a large amt of storage. */ 356 call get_temp_segment_("calendar",temp_seg_ptr,ec); 357 if ec ^= 0 then 358 do; 359 call com_err_(ec, "calendar","System error attempting to get a temporary segment."); 360 call cleanup_proc(); 361 return; 362 end; 363 364 ifdp = temp_seg_ptr; 365 if_data.how_many = 0; 366 fb71 = clock(); /* This is the default time if "-date" ctl arg not used. */ 367 368 /* Process command arguments. */ 369 call cu_$arg_count(x); /* Neater than waiting for error_table_$no_arg. */ 370 371 do an = 1 to x; /* Collect all the arguments. */ 372 call cu_$arg_ptr(an,ap,al,ec); 373 if ec ^= 0 then /* Has to be real error, not just out of args. */ 374 goto fatal_arg_error; 375 376 if substr(bchr,1,1) = "-" then /* Got a control argument. */ 377 do; 378 if bchr = "-date" | bchr = "-dt" then 379 do; 380 an = an + 1; /* Get value from following argument. */ 381 call cu_$arg_ptr(an,ap2,al2,ec); 382 if ec ^= 0 then /* This is a real error, even if just out of args. */ 383 goto fatal_arg_error; 384 call convert_date_to_binary_(bchr2,fb71,ec); 385 if ec ^= 0 then /* This error is important enough to be fatal. */ 386 goto fatal_arg_val_error; 387 end; 388 389 else 390 if bchr = "-sp" | bchr = "-stop" then 391 stop_switch = "1"b; 392 393 else 394 if bchr = "-wt" | bchr = "-wait" then 395 wait_switch = "1"b; 396 397 else 398 if bchr = "-fc" | bchr = "-force" then 399 force_switch = "1"b; 400 401 else 402 if bchr = "-fw" | bchr = "-fiscal_week" then 403 fwsw = "1"b; 404 405 else 406 if bchr = "-jul" | bchr = "-julian" then 407 julian_switch = "1"b; 408 409 else 410 if bchr = "-bht" | bchr = "-box_height" then 411 do; 412 an = an + 1; 413 call cu_$arg_ptr(an,ap2,al2,ec); /* Get the value. */ 414 if ec ^= 0 then /* This too is a real error, even if just out of args. */ 415 do; 416 fatal_arg_error: call com_err_(ec,"calendar","Argument number ^d. Command terminated.",an); 417 call cleanup_proc(); 418 return; 419 end; 420 i = cv_dec_check_(bchr2,ec); 421 if ec ^= 0 then 422 do; /* This error is important enough to be fatal. */ 423 ec = error_table_$bad_conversion; 424 fatal_arg_val_error: call com_err_(ec,"calendar","Argument ^d: ^a. Command terminated.",an,bchr2); 425 call cleanup_proc(); 426 return; 427 end; 428 box_height = i; /* Change from default (init) value. */ 429 end; 430 431 else do; 432 ec = error_table_$badopt; 433 goto arg_value_error; 434 end; 435 end; /* Control arguments */ 436 437 else do; /* Got a pathname of an input file. */ 438 i = if_data.how_many + 1; /* Put info in next empty cell. */ 439 call expand_path_(ap,al,addr(if_data.if(i).dn),addr(if_data.if(i).en),ec); 440 if ec ^= 0 then /* Ought to be an error, but might be old syntax. */ 441 if an = 1 then goto try_date; 442 else goto arg_value_error; 443 call hcs_$initiate_count(if_data.if(i).dn,if_data.if(i).en,"",if_data.if(i).bitc,1, 444 if_data.if(i).ifptr,ec); 445 if if_data.if(i).ifptr = null then /* Ought to be an error, but ... */ 446 if an = 1 then /* .. check for old syntax. */ 447 do; 448 try_date: call convert_date_to_binary_(bchr,fb71a,ec2); 449 if ec2 = 0 then 450 do; 451 fb71 = fb71a; 452 syntax_warning = "1"b; 453 end; 454 else goto arg_value_error; 455 end; 456 else do; 457 arg_value_error: call com_err_(ec,"calendar","Argument ^d: ^a.",an, bchr); 458 ave_switch = "1"b; 459 end; 460 else if_data.how_many = i; /* Data all good. Keep the file. */ 461 end; 462 end; /* Argument loop. */ 463 464 if ave_switch then 465 do; 466 call com_err_(0,"calendar","Errors in command arguments. Command aborted."); 467 call cleanup_proc(); 468 return; 469 end; 470 471 /* Initialize basic time and date variables. */ 472 call datebin_ (fb71, absda, mm, dd, yy, hh, minute, ss, wkd, shf); 473 call datebin_$revert (1, 1, yy, 0, 0, 0, boy); /* Get beginning of year. */ 474 call datebin_ (boy, yr_absda, i, i, i, i, i, i, wkd, i); 475 century = divide (yy, 100, 17, 0) * 100; /* Find current century. */ 476 if wkd >= 6 then wkd = wkd - 7; 477 fwbase = yr_absda + 1 - wkd; /* Locate a "virtual monday" preceding the first */ 478 call datebin_$revert (mm, 1, yy, 0, 0, 0, bom); /* Locate beginning of month. */ 479 call datebin_ (bom, mo_absda, mm, dd, yy, hh, minute, ss, wkd, shf); 480 days_mo = ndays (mm); /* Get # of days in this month. */ 481 days_yr = 365; 482 if (mm = 2) then if (leap_year(yy)) then 483 do; 484 days_mo = days_mo + 1; 485 days_yr = days_yr + 1; 486 end; 487 fwno = 1 + divide ((mo_absda+mod (8-wkd, 7)) - fwbase, 7, 17, 0); /* Calculate first fiscal week no. for Monday */ 488 489 /* Calculate beginning of month for previous and following months. */ 490 if mm = 1 then do; mmp = 12; yyp = yy - 1; end; 491 else do; mmp = mm - 1; yyp = yy; end; 492 if mm = 12 then do; mmf = 1; yyf = yy + 1; end; 493 else do; mmf = mm + 1; yyf = yy; end; 494 days_mop = ndays(mmp); 495 days_mof = ndays(mmf); 496 if mmp = 2 then if leap_year(yyp) then days_mop = days_mop + 1; 497 if mmf = 2 then if leap_year(yyf) then days_mof = days_mof + 1; 498 call datebin_$revert (mmp, 1, yyp, 0, 0, 0, bomp); 499 call datebin_$revert (mmf, 1, yyf, 0, 0, 0, bomf); 500 call datebin_ (bomp, i , i, i, i, i, i, i, wkdp, i); 501 call datebin_ (bomf, mo_absdaf, i, i, i, i, i, i, wkdf, i); 502 503 olp = addr(if_data.next_storage_block); 504 storp = addr(week_setup.next_storage_block); 505 lp = addr(current_line); 506 507 /* Now process all input files for events to be printed this month. */ 508 509 do inf = 1 to if_data.how_many; 510 seg_ptr = if_data.if(inf).ifptr; 511 nchr = divide (if_data.if(inf).bitc, 9, 17, 0); /* Get length of file. */ 512 k = 1; 513 input_line_count = 0; /* count the lines so can give info in error message. */ 514 do while (k < nchr); /* Scan file */ 515 lchrnl = index (substr (whole_seg, k), NL); /* Find end of line */ 516 if lchrnl = 0 then lchr, lchrnl = nchr-k+1; 517 else lchr = lchrnl - 1; 518 current_line = substr (whole_seg, k, lchr); /* Copy one line. */ 519 input_line_count = input_line_count + 1; 520 if substr (current_line, 1, 1) = "*" then go to skip; /* Ignore comments. */ 521 call parse_line(how_many_fields); 522 if how_many_fields = 0 then goto bad; 523 command = substr (input_line,fld_ix(1),fld_ln(1)); 524 if command = "date" then do; 525 if how_many_fields < 3 then goto bad1; 526 call convert_date_to_binary_$relative (substr (input_line,fld_ix(2),fld_ln(2)), fb71, bom-1, ec); 527 if ec ^= 0 then go to bad; /* Convert to binary. */ 528 call datebin_ (fb71, x1, xmm, xdd, xyy, x1, x1, x1, x1, x1); 529 if xmm = mm then if xyy = yy then /* If current month and year then remember it. */ 530 call fill_in_note(xdd,fb71,substr(input_line,fld_ix(3),min(16,fld_ln(3)))); 531 end; 532 else if command = "rel" then do; /* A date relative to another. */ 533 if how_many_fields < 5 then goto bad1; 534 if substr (input_line, fld_ix(2), 2) = "-1" then xmm = mmp; 535 else 536 if substr (input_line, fld_ix(2), 2) = "+1" then xmm = mmf; 537 else do; 538 xmm = cv_dec_check_ (substr (input_line,fld_ix(2),fld_ln(2)), ec); 539 if ec ^= 0 then go to bad1; 540 if xmm = 0 then xmm = mm; 541 end; 542 if xmm = mmp then rbom = bomp; 543 else if xmm = mm then rbom = bom; 544 else if xmm = mmf then rbom = bomf; 545 else goto skip; 546 /* Get first date. */ 547 if substr (input_line, fld_ix(3), fld_ln(3)) = "0" then fb71a = rbom-1; /* Special case. */ 548 else do; 549 call convert_date_to_binary_$relative(substr(input_line,fld_ix(3),fld_ln(3)),fb71a,rbom-1,ec); 550 if ec ^= 0 then go to bad; 551 end; 552 /* Now second date relative to first. */ 553 call convert_date_to_binary_$relative (substr (input_line, fld_ix(4), fld_ln(4)), fb71, fb71a, ec); 554 if ec ^= 0 then go to bad; 555 call datebin_ (fb71, x1, xmm, xdd, xyy, x1, x1, x1, x1, x1); 556 if xmm = mm then if xyy = yy then /* If current month and year then remember it. */ 557 call fill_in_note(xdd,fb71,substr(input_line,fld_ix(5),min(16,fld_ln(5)))); 558 end; 559 else if command = "repeat" then 560 do; 561 if how_many_fields < 5 then goto bad; 562 563 /* Get interval */ 564 if substr(input_line,fld_ix(4),fld_ln(4)) = "0" then interval = 1; /* i.e., one day. */ 565 else do; 566 call convert_date_to_binary_$relative(substr(input_line,fld_ix(4),fld_ln(4)), 567 fb71,bom,ec); 568 if ec ^= 0 then goto bad; 569 call datebin_(fb71,absda,x1,x1,x1,x1,x1,x1,x1,x1); 570 interval = max(1,absda-mo_absda); /* No neg interval. >= one day. */ 571 end; 572 573 /* Get start date */ 574 if substr(input_line,fld_ix(2),fld_ln(2)) = "0" then 575 do; 576 sr_absda = mo_absda; /* Need this if have to calculate end date from repeat count. */ 577 srday = 1; 578 end; 579 else do; 580 call convert_date_to_binary_$relative(substr(input_line,fld_ix(2),fld_ln(2)), 581 fb71,bom-1,ec); 582 if ec ^= 0 then goto bad; 583 if fb71 >= bomf then goto skip; /* Starts after end of month. */ 584 /* Starting date is before or in this month. If in the month, srday in the following call 585* is valid. If not, sr_absda is needed to calculate it. sr_absda might also be needed 586* if it is necessary to calculate the end date from a repeat count. */ 587 call datebin_(fb71,sr_absda,x1,srday,x1,x1,x1,x1,x1,x1); 588 if fb71 < bom then /* Start before month. First target day in month is: */ 589 srday = interval - mod(mo_absda-1-sr_absda, interval); 590 end; 591 592 /* Get end date or count of notes. */ 593 if substr(input_line,fld_ix(3),fld_ln(3)) = "0" then 594 endday = days_mo; 595 else 596 if verify(rtrim(ltrim(substr(input_line,fld_ix(3),fld_ln(3)))), "0123456789") = 0 then 597 do; /* This is all digits, so must be a count of the number of notes. */ 598 repeat_count = fixed(substr(input_line,fld_ix(3),fld_ln(3))); 599 end_absda = sr_absda + ((repeat_count - 1) * interval); 600 if end_absda < mo_absda then goto skip; /* Ends before this month. */ 601 if end_absda >= mo_absdaf then endday = days_mo; /* Ends next mo or later. */ 602 else endday = end_absda - mo_absda + 1; /* Ends some time within month. */ 603 end; 604 else do; 605 call convert_date_to_binary_$relative(substr(input_line,fld_ix(3),fld_ln(3)), 606 fb71,bom-1,ec); 607 if ec ^= 0 then goto bad; 608 if fb71 < bom then goto skip; /* Ends before start of month. */ 609 if fb71 >= bomf then endday = days_mo; /* Ends next month or later. */ 610 else call datebin_(fb71,x1,x1,endday,x1,x1,x1,x1,x1,x1); 611 end; 612 613 /* Fill in notes for target days. */ 614 do d = srday to endday by interval; 615 call datebin_$revert(xmm,d,xyy,0,0,0,fb71); 616 call fill_in_note(d,fb71,substr(input_line,fld_ix(5),min(16,fld_ln(5)))); 617 end; /* LOOP */ 618 end; /* "repeat" opcode */ 619 else if command = "easter" then do; /* Easter day */ 620 if mm = 3 | mm = 4 then /* Can only occur in March or April. */ 621 call calculate_easter(yy,xmm,xdd); 622 else goto skip; 623 if xmm = mm then do; /* Comes this month? Yes, put it on the list. */ 624 call datebin_$revert (xmm, xdd, yy, 0, 0, 0, fb71); 625 call fill_in_note(xdd,fb71,substr(input_line,fld_ix(2),min(16,fld_ln(2)))); 626 end; 627 end; 628 else if command = "rename" then do; 629 do jjj = 1 to 12; 630 if moname(jjj) = substr(input_line,fld_ix(2),fld_ln(2)) then 631 moname(jjj) = substr(input_line,fld_ix(3)); 632 end; 633 do jjj = 1 to 7; 634 if wkdname (jjj) = substr (input_line, fld_ix(2), fld_ln(2)) then 635 wkdname (jjj) = substr (input_line, fld_ix(3)); 636 end; 637 end; 638 else do; /* Invalid opcode. */ 639 bad1: ec = 0; /* No system err code. */ 640 bad: call com_err_ (ec, "calendar", "Illegal command on line ^d in ^a: ^a", 641 input_line_count, if_data.if(inf).en, input_line); 642 error_switch = "1"b; 643 end; 644 skip: k = k+lchrnl; /* Move to start of next line. */ 645 end; /* End of file scan. */ 646 end; /* Loop on input files. */ 647 648 /* If there were errors, quit unless user said to print anyway. */ 649 if error_switch then 650 if force_switch then 651 call com_err_(0,"calendar","Error diagnostics complete."); 652 else do; 653 call com_err_(0,"calendar","Errors in input files. Command aborted."); 654 call cleanup_proc(); 655 return; 656 end; 657 658 if stop_switch | wait_switch then /* Wait for newline. */ 659 call iox_$get_line(iox_$user_input,lp,168,0,ec); 660 661 /* Put out the calendar. */ 662 663 call ioa_$rsnnl ("^a ^d", titlestr, i, moname (mm), yy - century); 664 call bigletter_ (titlestr, writer); /* Write fancy heading. */ 665 head = NL; 666 cursor = 2; 667 do day_of_week = 1 to 7; 668 i = divide (17 - length (rtrim (wkdname (day_of_week))), 2, 17, 0); /* Center weekday name */ 669 substr (head, cursor+i, 17-i) = wkdname (day_of_week); /* stringsize raised, so what */ 670 cursor = cursor + 17; 671 end; 672 substr (head, cursor, 1) = NL; 673 call iox_$put_chars (iox_$user_output, addr (head), (cursor), ec); 674 675 if wkd = 7 then wkd = 0; /* How many days in first week? */ 676 i = wkd * 17; /* How much of the top horiz line to leave out. */ 677 substr (horizline, i+1) = substr (bar, i+1, length (bar)-i); 678 call iox_$put_chars (iox_$user_output, addr (horizline), length (horizline), ec); /* Write line of dashes */ 679 line (*).brk (*) = "|"; 680 line (*).rtbar = "|"; 681 do day_of_week = 1 to wkd; /* Blank out missing days and their vertical lines. */ 682 line(*).brk(day_of_week) = " "; 683 line (*).text (day_of_week) = ""; 684 end; 685 686 /* First week short? */ 687 if wkd > 1 & box_height > 6 then do; /* At least 3 blank boxes in first week, room for 1-2 little */ 688 pfp = addr (line); /* Overlay small calendars on week storage. */ 689 call previous_month; /* Fill in previous month. */ 690 end; 691 if wkd > 2 & box_height > 6 then /* Room enough for both small calendars in first week. */ 692 call follow_month; /* Fill in following month. */ 693 694 day_of_month = 1; 695 if julian_switch & box_height > 1 then 696 do; 697 size = box_height - 1; 698 jj = mo_absda - yr_absda + 1; 699 jjj = days_yr - jj; 700 end; 701 else size = box_height; 702 do while ("1"b); 703 if fwsw & day_of_week = 2 then do; /* Want Honeywell fiscal weeks? */ 704 call ioa_$rsnnl (" FW ^2d^7x^2d ", line (1).text (2), (0), fwno, day_of_month); 705 fwno = fwno + 1; 706 end; 707 else call ioa_$rsnnl ("^15d ", line (1).text (day_of_week), (0), day_of_month); 708 /* First line in box is number of day. */ 709 if julian_switch & box_height > 1 then /* Last line is julian, if user wants and enough room. */ 710 do; 711 call ioa_$rsnnl("^3d^10x^3d",line(box_height).text(day_of_week),(0),jj,jjj); 712 jj = jj + 1; 713 jjj = jjj - 1; 714 end; 715 do i = size to 2 by -1; /* Fill in rest of box. */ 716 if day_chain_roots (day_of_month) = 0 then line (i).text (day_of_week) = ""; /* .. either blank, or */ 717 else do; /* .. text from storage. */ 718 line (i).text (day_of_week) = storage.text (day_chain_roots (day_of_month)); 719 day_chain_roots (day_of_month) = storage.link (day_chain_roots (day_of_month)); /* Unlink datum from chain. */ 720 end; 721 end; 722 day_of_week = day_of_week + 1; 723 day_of_month = day_of_month + 1; 724 day_of_month = check_start_Gregory(yy, mm, day_of_month); 725 if day_of_month > days_mo then go to out; /* Done with the month? */ 726 if day_of_week > 7 then do; /* Done with the week? */ 727 call putweek; /* Yes. Write one week. */ 728 line(*).brk(*), line(*).rtbar = "|"; /* Restore vertical lines in case small cal zapped */ 729 730 day_of_week = 1; /* Reset day of week. */ 731 call iox_$put_chars (iox_$user_output, addr (bar), length (bar), ec); 732 end; 733 end; 734 735 out: if wkd < 3 & box_height > 6 then do; /* Insert previous and following month, if appropriate. */ 736 if wkd = 0 & days_mo = 28 then do; /* February starting on Sunday --> No blank partial week. */ 737 call putweek; /* Print the fourth week as is. */ 738 call iox_$put_chars (iox_$user_output, addr (bar), length(bar), ec); 739 llth = 51; /* Length of two small calendars. */ 740 pfp = addr (line); /* Overlay small calendars on week storage. */ 741 do i = 1 to 3; /* Get rid of vertical lines. */ 742 line(*).day(i).brk = " "; 743 line(*).day(i).text = " "; /* And old text. */ 744 end; 745 end; 746 else do; 747 pfp = addr (line (1).day (5).text); /* Overlay small calendars on end of last week. */ 748 line(*).day(day_of_week).text = " "; /* Blank out this day's text. */ 749 line(*).rtbar = " "; /* And final vertical bar. */ 750 do i = day_of_week + 1 to 7; /* Blank out rest of week. */ 751 line (*).day (i).brk = " "; /* Get rid of excess vertical lines. */ 752 line (*).day (i).text = " "; /* And the text they contained. */ 753 end; /* Loop */ 754 end; /* else */ 755 call follow_month; /* Set up small calendar for following month. */ 756 if wkd < 2 then call previous_month; /* And previous if necessary. */ 757 end; 758 else llth = 1 + (day_of_week-1) * 17; /* no small cal's. Calculate length of last week. */ 759 760 call putweek; /* Write last week with calendars. (Or just calendars.) */ 761 762 llth = 1 + (day_of_week-1) * 17; /* Length of bottom horiz line on last week. */ 763 if ^(wkd = 0 & days_mo = 28 & box_height > 6) then /* Write bottom line unless just calendars. */ 764 call iox_$put_chars (iox_$user_output, addr (bar), llth, ec); /* Write partial line of dashes */ 765 call iox_$put_chars (iox_$user_output, addr (FF), 1, ec); /* Write FF */ 766 767 /* May need to wait for user to put paper in terminal. */ 768 if stop_switch then 769 call iox_$get_line(iox_$user_input,lp,168,0,ec); 770 771 if syntax_warning then 772 call com_err_(0,"calendar","WARNING: You are using an obsolete syntax.^/New syntax is: calendar {paths} {-ctlargs}^/Type ""help calendar"" for details."); 773 774 do day_of_month = 1 to days_mo; 775 day_of_month = check_start_Gregory(yy, mm, day_of_month); 776 do jj = 1 to 100 while (day_chain_roots (day_of_month) ^= 0); 777 call com_err_ (0, "calendar", "Item cannot fit in ^a ^d: ^a", 778 moname (mm), day_of_month, storage.text (day_chain_roots (day_of_month))); 779 day_chain_roots (day_of_month) = storage.link (day_chain_roots (day_of_month)); 780 end; 781 end; 782 783 call cleanup_proc(); 784 785 return; 786 787 /* -------------------------------------------------------- */ 788 789 fill_in_note: proc(day,abs_time,note); 790 791 declare 792 day fixed bin, /* The day of the month which is getting this note. */ 793 abs_time fixed bin(71), /* The clock reading for the beginning of this day. */ 794 note char(16); /* What to write in the box. */ 795 796 /* Some variables are declared in the parent block: 797*last_cell_no fixed bin: Index of most recently "allocated" cell in storage array. 798*max_cells fixed bin: The maximum number of such cells. 799*storage: A structure used to hold the notes until time to print the calendar. 800*day_chain_roots(31) fixed bin: Indices of first cell in chain of notes for the days of the month. 801**/ 802 803 last_cell_no = last_cell_no + 1; /* Allocate another cell in storage. */ 804 if last_cell_no > max_cells then goto too_many_notes; 805 806 storage.link(last_cell_no) = day_chain_roots(day); /* Chain this cell into list for this day. */ 807 day_chain_roots(day) = last_cell_no; /* After this, fill in the cell. */ 808 storage.date(last_cell_no) = abs_time; /* CAVEAT: If this is ever used anywhere, should figure 809* out if this is an appropriate value. */ 810 storage.text(last_cell_no) = note; 811 return; 812 813 too_many_notes: /* Ran out of room in storage. */ 814 call com_err_(0,"calendar","Maximum number of calendar entries exceeded."); 815 return; 816 817 end fill_in_note; 818 819 /* -------------------------------------------------------- */ 820 821 parse_line: proc(no_of_fields); 822 /* The first field starts at the first non-blank character. 823* All other fields start at the first character after the comma. */ 824 825 declare 826 no_of_fields fixed bin, /* Returned. The number of fields found on the input line. */ 827 (i, f, c) fixed bin; /* Temporaries. */ 828 829 /* Declared in the outer block. 830*fld_ix(5) fixed bin: Positions of up to 5 fields in the input line. This proc fills in. 831*fld_ln(5) fixed bin: Lengths of the up to 5 fields on the input line. This proc fills in. 832*input_line char(lchr) aligned based(lp): The current input line. 833*lchr fixed bin: The number of characters in the current input line (sans final NL). 834**/ 835 836 i = 1; 837 fld_ln(*) = 0; 838 i = verify(input_line," "); /* first non-blank character. */ 839 if i = 0 then /* All blank, no fields. */ 840 do; 841 f = 0; 842 goto done; 843 end; 844 845 do f = 1 to hbound(fld_ln,1) while(i < lchr); 846 fld_ix(f) = i; 847 c = index(substr(input_line,i), ","); /* End of field. */ 848 if c = 0 then /* No comma, last field. */ 849 do; 850 fld_ln(f) = lchr - i + 1; 851 goto done; 852 end; 853 fld_ln(f) = c - 1; 854 i = i + c; /* Start of next field. */ 855 if i > lchr then goto done; /* Line ends with comma, no more fields. */ 856 end; /* Loop */ 857 858 f = f - 1; /* Loop index is too high. */ 859 860 done: no_of_fields = f; 861 return; 862 863 end parse_line; 864 865 /* -------------------------------------------------------- */ 866 867 putweek: proc; /* Writes one week's data. No. lines is box_height. */ 868 869 do i = 1 to box_height; 870 call iox_$put_chars (iox_$user_output, addr (line (i)), llth, ec); 871 call iox_$put_chars (iox_$user_output, addr (NL), 1, ec); 872 end; 873 874 end putweek; 875 876 /* -------------------------------------------------------- */ 877 878 writer: proc (xp, xl); /* Called by bigletter_ to write header. */ 879 880 dcl xp ptr, xl fixed bin; 881 dcl bcs char (xl) based (xp); 882 dcl i fixed bin (21); 883 884 if bcs ^= "" then do; 885 i = xl + 1 - verify (reverse (bcs), " "); 886 call iox_$put_chars (iox_$user_output, xp, i, ec); 887 end; 888 call iox_$put_chars (iox_$user_output, addr (NL), 1, ec); /* Write NL */ 889 890 end writer; 891 892 /* -------------------------------------------------------- */ 893 894 previous_month: proc; 895 896 call ioa_$rsnnl (" ^9a^7x^4d", prevfoll.headerp, n, moname (mmp), yyp); 897 i = 1; 898 if wkdp = 7 then wkdp = 0; 899 do kpf = 1 to wkdp; 900 prevfoll.week (1).dayp (kpf) = " "; 901 end; 902 do jpf = 1 to days_mop; 903 jpf = check_start_Gregory(yyp, mmp, jpf); 904 call ioa_$rsnnl ("^2d ", prevfoll.week (i).dayp (kpf), n, jpf); 905 kpf = kpf + 1; 906 if kpf > 7 then do; 907 kpf = 1; 908 i = i + 1; 909 end; 910 end; /* jpf loop */ 911 912 do while (i <= 6); 913 do jpf = kpf to 7; 914 prevfoll.week (i).dayp (jpf) = " "; 915 end; /* jpf loop */ 916 i = i + 1; 917 kpf = 1; 918 end; /* while */ 919 end previous_month; 920 921 /* -------------------------------------------------------- */ 922 923 follow_month: proc; 924 925 call ioa_$rsnnl ("^9a^7x^4d ", prevfoll.headerf, n, moname (mmf), yyf); 926 i = 1; 927 if wkdf = 7 then wkdf = 0; 928 do kpf = 1 to wkdf; 929 prevfoll.week (1).dayf (kpf) = " "; 930 end; 931 do jpf = 1 to days_mof; 932 jpf = check_start_Gregory(yyf, mmf, jpf); 933 call ioa_$rsnnl ("^2d ", prevfoll.week (i).dayf (kpf), n, jpf); 934 kpf = kpf + 1; 935 if kpf > 7 then do; 936 kpf = 1; 937 i = i + 1; 938 end; 939 end; /* jpf loop */ 940 941 do while (i <= 6); 942 do jpf = kpf to 7; 943 prevfoll.week (i).dayf (jpf) = " "; 944 end; /* jpf loop */ 945 i = i + 1; 946 kpf = 1; 947 end; /* while */ 948 end follow_month; 949 950 /* -------------------------------------------------------- */ 951 952 calculate_easter: proc(year, month, day); 953 954 declare 955 day fixed bin, 956 month fixed bin, 957 year fixed bin, 958 (a, b, c, d, e, g, h, i, k, l, m) fixed bin; 959 960 /* The following calculation of the Date for Easter follows the algorithm 961* given in the New Scientist magazine, issue No. 228 (Vol. 9) page 828 (30 March 1961). */ 962 a = mod(year,19); /* Find position of year in 19-year Lunar Cycle, called the Golden Number. */ 963 b = divide(year,100,35); c = mod(year,100); /* b is century number, c is year number within century*/ 964 d = divide(b,4,35); e = mod(b,4); /* These are used in leap year adjustments. */ 965 i = divide(c,4,35); k = mod(c,4); /* Also related to leap year. */ 966 967 /* The next step computes a correction factor used in the following step 968* which computes the number of days between the spring equinox 969* and the first full moon thereafter. The correction factor is needed 970* to keep the approximation in line with the observed behavior of the moon. 971* It moves the full moon date back by one day eight times in every 2500 years, 972* in century years three apart, with four years at the end of the cycle. 973* The constant 13 corrects the correction for the fact that this 974* cycle was decreed to start in the year 1800. */ 975 g = divide(8*b+13,25,35); 976 977 /* Now the number of days after the equinox (21 March, by definition) that 978* we find the next full moon. This is a number between 0 and 29. 979* The term 19*a advances the full moon 19 days for each year of the 980* Lunar Cycle, for a total of 361 days in the 19 years. The other 4.24 days 981* are made up when a returns to zero on the next cycle. Thus, the 982* full moon dates repeat every 19 years. The term b-d advances the 983* date by one day for three out of every four century years, the 984* years which are not leap years although divisible by 4. 985* The term g is the correction factor calculated above, and 15 986* adjusts this whole calculation to the actual conditions at that 987* date on which the scheme began, probably in Oct of 1582. */ 988 h = mod(19*a + b - d - g + 15, 30); 989 990 /* Now we are interested in how many days we have to wait after the 991* full moon until we get a Sunday (which has to be definitely after 992* the full moon). The following step calculates a number l which is 993* one less than the number of days. Every ordinary year ends on the 994* same day of the week on which it started; a leap year ends on the 995* day of the week following the one on which it started. Thus, if 996* it is known on what day of the week a date occurred in any year 997* it is possible to calculate its day of the week in another year 998* by marching through the week one day for each regular year and 999* two for each leap year. 1000* The term k is the number of ordinary years 1001* since the last leap year; each such year brings the date of the 1002* full moon one day closer to Sunday, and so reduces the number of 1003* days to be waited (unless it goes negative, but modular arithmetic 1004* theory makes -1 = 6 where the modulus is 7). 1005* The term i is the number of leap years so far in the current century. 1006* each leap year has with it three ordinary years, and each such group 1007* advances the day of the week by 5 days. But in modulo 7 arithmetic 1008* subtracting 5 days is equivalent to adding 2 days. So we add 1009* two days for each group of four years in the current century. 1010* Since a century consists of 25 groups of four years, it advances 1011* the day of the week by 124 or 125 days depending on whether the 1012* century year is an ordinary or leap year. The remainders when 1013* these numbers are divided by seven are 5 and 6 respectively. 1014* The term e is the number of ordinary century years since the 1015* last leap century year. As with the groups of four years, we 1016* add two days for each rather than subtract 5 for each. 1017* Every fourth century year is a leap year; therefore, 1018* each group of four centuries advances the day of the week by 1019* 3*5+6 = 21 days, or 0 in modulo 7 arithmetic, and no 1020* term is necessary for time before the last leap century year. 1021* The constant term 32 adjusts the calculation for the day of the 1022* week of the equinox when the scheme was put into effect. It also 1023* is larger than necessary by 28 in order to assure that the 1024* subtractions of k and h never reduce the dividend below 0. 1025* Thus, mod(2*e + 2*i - k + 32, 7) gives one less than the number 1026* of days between the equinox and its following Sunday. But we need to 1027* calculate the number of days after the full moon. The term h, 1028* calculated in the previous step, gives the number of days after 1029* the equinox that the full moon occurs. Each of those days brings 1030* the full moon closer to the actual Sunday of Easter, 1031* so it reduces the number of days after the full moon until Easter. 1032* (Again, if h > 6, modular arithmetic theory readjusts the result to 1033* another cycle of 0 to 6, and here the constant 32 keeps the dividend > 0.) */ 1034 l = mod(2*e + 2*i - k + 32 - h, 7); 1035 1036 /* The calendar set up by Pope Gregory XIII and his advisor, the astronomer 1037* Clavius, provided for official full moon dates as well as matching 1038* the equinoxes and solstices with their nominal dates. But, since 1039* the period of the moon is not an exact number of days, some fudging 1040* was needed here as elsewhere in the calendar system. Some of the 1041* periods between successive full moons in the Lunar Cycle are 30 days, 1042* some 29 days. Clavius then arranged the periods carefully so 1043* that if a full moon fell on 20 March (the day before the equinox), 1044* the period following it would be of 29 days. The effect of this 1045* arrangement is that Easter can never occur later than 25 April. 1046* The above calculations assume uniform 30-day lunar periods. In rare 1047* cases (e.g., 1954 and 1981) one of these 29-day lunar periods causes 1048* the full moon to fall on a Saturday where a 30-day period would put 1049* it on a Sunday. The following step calculates the fudge factor for 1050* this situation. The result m is 0 if no fudging is necessary, or 1051* 1 if fudging is required. */ 1052 m = divide(a + 11*h + 19*l, 433, 35); 1053 1054 /* Now we have calculated the number of days which will elapse between 1055* 21 march and Easter: h + (l + 1) - 7*m. The next two steps 1056* turn this into a month and day. In the first expression, the constant 1057* 90 assures that the the quotient will be at least 3 (= March). 1058* If the elapsed days exceed 9, then the quotient will be 4 (= April). 1059* In the second expression, if month = 3 then 33*month + 19 = 118 and the 1060* remainder of that part of the expression is 22; when month = 3, 1061* l + h - 7*m < 10, so 22 < day <= 31. 1062* If month = 4, 33*month = 132, and since h + l - 7*m > 9, the whole 1063* expression satisfies 5*32 = 160 < expr. The remainder is greater 1064* than 0 and less than 26. */ 1065 month = divide(h + l - 7*m + 90, 25, 35); 1066 day = mod(h + l - 7*m +33*month + 19, 32); 1067 1068 return; 1069 1070 end calculate_easter; 1071 1072 cleanup_proc: proc; 1073 1074 do if_data.how_many = if_data.how_many to 1 by -1; 1075 if if_data.if(if_data.how_many).ifptr ^= null then 1076 do; 1077 call hcs_$terminate_noname(if_data.if(if_data.how_many).ifptr,ec); 1078 if_data.if(if_data.how_many).ifptr = null; 1079 end; 1080 end; 1081 1082 if temp_seg_ptr ^= null then 1083 call release_temp_segment_("calendar",temp_seg_ptr,ec); 1084 1085 return; 1086 1087 end cleanup_proc; 1088 /* -------------------------------------------------------- */ 1089 1090 leap_year: proc (year) returns(bit(1)); 1091 dcl year fixed bin; 1092 1093 if mod (year, 4) = 0 then 1094 /* Centesimal years are common years unless divisible by 400. */ 1095 /* This was done to correct the error in the Julian calendar. */ 1096 if mod(year, 100)=0 & mod(year, 400)^=0 & year>1582 then 1097 return("0"b); 1098 else return("1"b); 1099 else return("0"b); 1100 1101 end leap_year; 1102 /* -------------------------------------------------------- */ 1103 1104 check_start_Gregory: 1105 proc (year, month, day_of_month) returns (fixed bin); 1106 dcl (year, month, day_of_month) fixed bin; 1107 1108 /* In the Gregorian calendar, October 5 through the 14 are removed. */ 1109 1110 if year = 1582 & month = 10 & day_of_month = 5 then 1111 return(15); 1112 else return(day_of_month); 1113 1114 end check_start_Gregory; 1115 1116 1117 /* -------------------------------------------------------- */ 1118 end calendar; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 10/19/90 1655.4 calendar.pl1 >spec>install>1048>calendar.pl1 NAMES DECLARED IN THIS COMPILATION. IDENTIFIER OFFSET LOC STORAGE CLASS DATA TYPE ATTRIBUTES AND REFERENCES (* indicates a set context) NAMES DECLARED BY DECLARE STATEMENT. FF 000050 internal static char(1) initial packed unaligned dcl 349 set ref 765 765 NL 000047 internal static char(1) initial dcl 346 set ref 515 665 672 871 871 888 888 a 000714 automatic fixed bin(17,0) dcl 954 set ref 962* 988 1052 abs_time parameter fixed bin(71,0) dcl 791 ref 789 808 absda 000336 automatic fixed bin(17,0) dcl 287 set ref 472* 569* 570 addr builtin function dcl 239 ref 439 439 439 439 503 504 505 673 673 678 678 688 731 731 738 738 740 747 763 763 765 765 870 870 871 871 888 888 al 000122 automatic fixed bin(17,0) dcl 179 set ref 372* 376 378 378 389 389 393 393 397 397 401 401 405 405 409 409 439* 448 448 457 457 al2 000123 automatic fixed bin(17,0) dcl 179 set ref 381* 384 384 413* 420 420 424 424 an 000124 automatic fixed bin(17,0) dcl 179 set ref 371* 372* 380* 380 381* 412* 412 413* 416* 424* 440 445 457* ap 000100 automatic pointer dcl 168 set ref 372* 376 378 378 389 389 393 393 397 397 401 401 405 405 409 409 439* 448 457 ap2 000102 automatic pointer dcl 168 set ref 381* 384 413* 420 424 ave_switch 000320 automatic bit(1) initial packed unaligned dcl 229 set ref 229* 458* 464 b 000715 automatic fixed bin(17,0) dcl 954 set ref 963* 964 964 975 988 bar 000010 internal static char(121) initial dcl 341 set ref 677 677 731 731 731 731 738 738 738 738 763 763 bchr based char packed unaligned dcl 222 set ref 376 378 378 389 389 393 393 397 397 401 401 405 405 409 409 448* 457* bchr2 based char packed unaligned dcl 222 set ref 384* 420* 424* bcs based char packed unaligned dcl 881 ref 884 885 bigletter_ 000052 constant entry external dcl 243 ref 664 bitc 4 based fixed bin(24,0) array level 3 dcl 274 set ref 443* 511 bom 000222 automatic fixed bin(71,0) dcl 208 set ref 478* 479* 526 543 566* 580 588 605 608 bomf 000224 automatic fixed bin(71,0) dcl 208 set ref 499* 501* 544 583 609 bomp 000226 automatic fixed bin(71,0) dcl 208 set ref 498* 500* 542 box_height 000125 automatic fixed bin(17,0) initial dcl 179 set ref 179* 428* 504 679 680 682 683 687 691 695 697 701 709 711 728 728 735 742 743 748 749 751 752 763 869 boy 000404 automatic fixed bin(71,0) dcl 287 set ref 473* 474* brk based char(1) array level 4 packed packed unaligned dcl 302 set ref 679* 682* 728* 742* 751* c 000654 automatic fixed bin(17,0) dcl 825 in procedure "parse_line" set ref 847* 848 853 854 c 000716 automatic fixed bin(17,0) dcl 954 in procedure "calculate_easter" set ref 963* 965 965 century 000126 automatic fixed bin(17,0) dcl 179 set ref 475* 663 cleanup 000330 stack reference condition dcl 241 ref 353 clock builtin function dcl 239 ref 366 com_err_ 000054 constant entry external dcl 243 ref 359 416 424 457 466 640 649 653 771 777 813 command 000400 automatic char(8) packed unaligned dcl 287 set ref 523* 524 532 559 619 628 convert_date_to_binary_ 000056 constant entry external dcl 243 ref 384 448 convert_date_to_binary_$relative 000060 constant entry external dcl 243 ref 526 549 553 566 580 605 cu_$arg_count 000062 constant entry external dcl 243 ref 369 cu_$arg_ptr 000064 constant entry external dcl 243 ref 372 381 413 current_line 000246 automatic char(168) dcl 222 set ref 505 518* 520 cursor 000367 automatic fixed bin(17,0) dcl 287 set ref 666* 669 670* 670 672 673 cv_dec_check_ 000066 constant entry external dcl 243 ref 420 538 d 000402 automatic fixed bin(17,0) dcl 287 in procedure "calendar" set ref 614* 615* 616* d 000717 automatic fixed bin(17,0) dcl 954 in procedure "calculate_easter" set ref 964* 988 date based fixed bin(71,0) array level 2 dcl 323 set ref 808* datebin_ 000070 constant entry external dcl 243 ref 472 474 479 500 501 528 555 569 587 610 datebin_$revert 000072 constant entry external dcl 243 ref 473 478 498 499 615 624 day parameter fixed bin(17,0) dcl 954 in procedure "calculate_easter" set ref 952 1066* day based structure array level 3 in structure "week_setup" packed packed unaligned dcl 302 in procedure "calendar" day parameter fixed bin(17,0) dcl 791 in procedure "fill_in_note" ref 789 806 807 day_chain_roots 000127 automatic fixed bin(17,0) initial array dcl 179 set ref 179* 716 718 719* 719 776 777 779* 779 806 807* day_of_month 000365 automatic fixed bin(17,0) dcl 287 in procedure "calendar" set ref 694* 704* 707* 716 718 719 719 723* 723 724* 724* 725 774* 775* 775* 776 777* 777 779 779* day_of_month parameter fixed bin(17,0) dcl 1106 in procedure "check_start_Gregory" ref 1104 1110 1112 day_of_week 000366 automatic fixed bin(17,0) dcl 287 set ref 667* 668 669* 681* 682 683* 703 707 711 716 718 722* 722 726 730* 748 750 758 762 dayf 45(18) based char(3) array level 3 packed packed unaligned dcl 311 set ref 929* 933* 943* dayp 36(09) based char(3) array level 3 packed packed unaligned dcl 311 set ref 900* 904* 914* days_mo 000166 automatic fixed bin(17,0) dcl 179 set ref 480* 484* 484 593 601 609 725 736 763 774 days_mof 000170 automatic fixed bin(17,0) dcl 179 set ref 495* 497* 497 931 days_mop 000167 automatic fixed bin(17,0) dcl 179 set ref 494* 496* 496 902 days_yr 000171 automatic fixed bin(17,0) dcl 179 set ref 481* 485* 485 699 dd 000340 automatic fixed bin(17,0) dcl 287 set ref 472* 479* divide builtin function dcl 239 ref 475 487 511 668 963 964 965 975 1052 1065 dn 5 based char(168) array level 3 dcl 274 set ref 439 439 443* e 000720 automatic fixed bin(17,0) dcl 954 set ref 964* 1034 ec 000172 automatic fixed bin(35,0) dcl 179 set ref 356* 357 359* 372* 373 381* 382 384* 385 413* 414 416* 420* 421 423* 424* 432* 439* 440 443* 457* 526* 527 538* 539 549* 550 553* 554 566* 568 580* 582 605* 607 639* 640* 658* 673* 678* 731* 738* 763* 765* 768* 870* 871* 886* 888* 1077* 1082* ec2 000173 automatic fixed bin(35,0) dcl 179 set ref 448* 449 en 57 based char(32) array level 3 dcl 274 set ref 439 439 443* 640* end_absda 000230 automatic fixed bin(17,0) dcl 208 set ref 599* 600 601 602 endday 000375 automatic fixed bin(17,0) dcl 287 set ref 593* 601* 602* 609* 610* 614 error_switch 000321 automatic bit(1) initial packed unaligned dcl 229 set ref 229* 642* 649 error_table_$bad_conversion 000120 external static fixed bin(35,0) dcl 269 ref 423 error_table_$badopt 000122 external static fixed bin(35,0) dcl 269 ref 432 expand_path_ 000074 constant entry external dcl 243 ref 439 f 000653 automatic fixed bin(17,0) dcl 825 set ref 841* 845* 846 850 853* 858* 858 860 fb71 000232 automatic fixed bin(71,0) dcl 208 set ref 366* 384* 451* 472* 526* 528* 529* 553* 555* 556* 566* 569* 580* 583 587* 588 605* 608 609 610* 615* 616* 624* 625* fb71a 000234 automatic fixed bin(71,0) dcl 208 set ref 448* 451 547* 549* 553* fixed builtin function dcl 239 ref 598 fld_ix 000174 automatic fixed bin(17,0) array dcl 179 set ref 523 526 526 529 529 534 535 538 538 547 549 549 553 553 556 556 564 566 566 574 580 580 593 595 598 605 605 616 616 625 625 630 630 634 634 846* fld_ln 000201 automatic fixed bin(17,0) array dcl 179 set ref 523 526 526 529 529 538 538 547 549 549 553 553 556 556 564 566 566 574 580 580 593 595 598 605 605 616 616 625 625 630 634 837* 845 850* 853* force_switch 000322 automatic bit(1) initial packed unaligned dcl 229 set ref 229* 397* 649 fwbase 000236 automatic fixed bin(17,0) dcl 208 set ref 477* 487 fwno 000406 automatic fixed bin(17,0) dcl 287 set ref 487* 704* 705* 705 fwsw 000323 automatic bit(1) initial packed unaligned dcl 229 set ref 229* 401* 703 g 000721 automatic fixed bin(17,0) dcl 954 set ref 975* 988 get_temp_segment_ 000076 constant entry external dcl 243 ref 356 h 000722 automatic fixed bin(17,0) dcl 954 set ref 988* 1034 1052 1065 1066 hbound builtin function dcl 239 ref 845 hcs_$initiate_count 000100 constant entry external dcl 243 ref 443 hcs_$terminate_noname 000102 constant entry external dcl 243 ref 1077 head 000467 automatic char(121) dcl 336 set ref 665* 669* 672* 673 673 headerf 7(18) based char(21) level 2 packed packed unaligned dcl 311 set ref 925* headerp based char(22) level 2 packed packed unaligned dcl 311 set ref 896* hh 000342 automatic fixed bin(17,0) dcl 287 set ref 472* 479* horizline 000562 automatic char(121) initial dcl 344 set ref 344* 677* 678 678 678 678 how_many based fixed bin(17,0) level 2 dcl 274 set ref 365* 438 460* 509 1074* 1074* 1075 1077 1078* how_many_fields 000206 automatic fixed bin(17,0) dcl 179 set ref 521* 522 525 533 561 i 000100 automatic fixed bin(21,0) dcl 882 in procedure "writer" set ref 885* 886* i 000723 automatic fixed bin(17,0) dcl 954 in procedure "calculate_easter" set ref 965* 1034 i 000207 automatic fixed bin(17,0) dcl 179 in procedure "calendar" set ref 420* 428 438* 439 439 439 439 443 443 443 443 445 460 474* 474* 474* 474* 474* 474* 474* 500* 500* 500* 500* 500* 500* 500* 500* 501* 501* 501* 501* 501* 501* 501* 663* 668* 669 669 676* 677 677 677 715* 716 718* 741* 742 743* 750* 751 752* 869* 870 870* 897* 904 908* 908 912 914 916* 916 926* 933 937* 937 941 943 945* 945 i 000652 automatic fixed bin(17,0) dcl 825 in procedure "parse_line" set ref 836* 838* 839 845 846 847 850 854* 854 855 if 2 based structure array level 2 dcl 274 if_data based structure level 1 dcl 274 ifdp 000104 automatic pointer dcl 168 set ref 364* 365 438 439 439 439 439 443 443 443 443 445 460 503 509 510 511 640 1074 1074 1075 1075 1077 1077 1078 1078 ifptr 2 based pointer array level 3 dcl 274 set ref 443* 445 510 1075 1077* 1078* index builtin function dcl 239 ref 515 847 inf 000210 automatic fixed bin(17,0) dcl 179 set ref 509* 510 511 640* input_line based char dcl 222 set ref 523 526 526 529 529 534 535 538 538 547 549 549 553 553 556 556 564 566 566 574 580 580 593 595 598 605 605 616 616 625 625 630 630 634 634 640* 838 847 input_line_count 000211 automatic fixed bin(17,0) dcl 179 set ref 513* 519* 519 640* interval 000376 automatic fixed bin(17,0) dcl 287 set ref 564* 570* 588 588 599 614 ioa_$rsnnl 000104 constant entry external dcl 243 ref 663 704 707 711 896 904 925 933 iox_$get_line 000106 constant entry external dcl 243 ref 658 768 iox_$put_chars 000110 constant entry external dcl 243 ref 673 678 731 738 763 765 870 871 886 888 iox_$user_input 000114 external static pointer dcl 265 set ref 658* 768* iox_$user_output 000116 external static pointer dcl 265 set ref 673* 678* 731* 738* 763* 765* 870* 871* 886* 888* jj 000212 automatic fixed bin(17,0) dcl 179 set ref 698* 699 711* 712* 712 776* jjj 000213 automatic fixed bin(17,0) dcl 179 set ref 629* 630 630* 633* 634 634* 699* 711* 713* 713 jpf 000372 automatic fixed bin(17,0) dcl 287 set ref 902* 903* 903* 904* 913* 914* 931* 932* 932* 933* 942* 943* julian_switch 000324 automatic bit(1) initial packed unaligned dcl 229 set ref 229* 405* 695 709 k 000724 automatic fixed bin(17,0) dcl 954 in procedure "calculate_easter" set ref 965* 1034 k 000370 automatic fixed bin(17,0) dcl 287 in procedure "calendar" set ref 512* 514 515 516 518 644* 644 kpf 000373 automatic fixed bin(17,0) dcl 287 set ref 899* 900* 904 905* 905 906 907* 913 917* 928* 929* 933 934* 934 935 936* 942 946* l 000725 automatic fixed bin(17,0) dcl 954 set ref 1034* 1052 1065 1066 last_cell_no 000214 automatic fixed bin(17,0) initial dcl 179 set ref 179* 803* 803 804 806 807 808 810 lchr 000215 automatic fixed bin(17,0) dcl 179 set ref 516* 517* 518 523 526 526 529 529 534 535 538 538 547 549 549 553 553 556 556 564 566 566 574 580 580 593 595 598 605 605 616 616 625 625 630 630 634 634 640 640 838 845 847 850 855 lchrnl 000216 automatic fixed bin(17,0) dcl 179 set ref 515* 516 516* 517 644 length builtin function dcl 239 ref 668 677 678 678 731 731 738 738 line based structure array level 2 dcl 302 set ref 688 740 870 870 link 2 based fixed bin(17,0) array level 2 dcl 323 set ref 719 779 806* llth 000403 automatic fixed bin(21,0) initial dcl 287 set ref 287* 739* 758* 762* 763* 870* lp 000106 automatic pointer dcl 168 set ref 505* 523 526 526 529 529 534 535 538 538 547 549 549 553 553 556 556 564 566 566 574 580 580 593 595 598 605 605 616 616 625 625 630 630 634 634 640 658* 768* 838 847 ltrim builtin function dcl 239 ref 595 m 000726 automatic fixed bin(17,0) dcl 954 set ref 1052* 1065 1066 max builtin function dcl 239 ref 570 max_cells constant fixed bin(17,0) initial dcl 179 ref 323 804 min builtin function dcl 239 ref 529 529 556 556 616 616 625 625 minute 000343 automatic fixed bin(17,0) dcl 287 set ref 472* 479* mm 000337 automatic fixed bin(17,0) dcl 287 set ref 472* 478* 479* 480 482 490 491 492 493 529 540 543 556 620 620 623 663 724* 775* 777 mmf 000352 automatic fixed bin(17,0) dcl 287 set ref 492* 493* 495 497 499* 535 544 925 932* mmp 000351 automatic fixed bin(17,0) dcl 287 set ref 490* 491* 494 496 498* 534 542 896 903* mo_absda 000237 automatic fixed bin(17,0) dcl 208 set ref 479* 487 570 576 588 600 602 698 mo_absdaf 000240 automatic fixed bin(17,0) dcl 208 set ref 501* 601 mod builtin function dcl 239 ref 487 588 962 963 964 965 988 1034 1066 1093 1093 1093 moname 000407 automatic char(9) initial array dcl 329 set ref 329* 329* 329* 329* 329* 329* 329* 329* 329* 329* 329* 329* 630 630* 663* 777* 896* 925* month parameter fixed bin(17,0) dcl 1106 in procedure "check_start_Gregory" ref 1104 1110 month parameter fixed bin(17,0) dcl 954 in procedure "calculate_easter" set ref 952 1065* 1066 n 000371 automatic fixed bin(17,0) dcl 287 set ref 896* 904* 925* 933* nchr 000377 automatic fixed bin(17,0) dcl 287 set ref 511* 514 516 ndays 000453 automatic fixed bin(17,0) initial array dcl 333 set ref 333* 333* 333* 333* 333* 333* 333* 333* 333* 333* 333* 333* 480 494 495 next_storage_block based pointer level 2 in structure "week_setup" dcl 302 in procedure "calendar" set ref 504 next_storage_block 12432 based pointer level 2 in structure "if_data" dcl 274 in procedure "calendar" set ref 503 no_of_fields parameter fixed bin(17,0) dcl 825 set ref 821 860* note parameter char(16) packed unaligned dcl 791 ref 789 810 null builtin function dcl 239 ref 445 1075 1078 1082 olp 000110 automatic pointer dcl 168 set ref 503* 504 679 680 682 683 688 704 707 711 716 718 728 728 740 742 743 747 748 749 751 752 870 870 pfp 000112 automatic pointer dcl 168 set ref 688* 740* 747* 896 900 904 914 925 929 933 943 prevfoll based structure level 1 packed packed unaligned dcl 311 rbom 000242 automatic fixed bin(71,0) dcl 208 set ref 542* 543* 544* 547 549 release_temp_segment_ 000112 constant entry external dcl 243 ref 1082 repeat_count 000217 automatic fixed bin(17,0) dcl 179 set ref 598* 599 reverse builtin function dcl 239 ref 885 rtbar 35(27) based char(1) array level 3 packed packed unaligned dcl 302 set ref 680* 728* 749* rtrim builtin function dcl 239 ref 595 668 seg_ptr 000114 automatic pointer dcl 168 set ref 510* 515 518 shf 000346 automatic fixed bin(17,0) dcl 287 set ref 472* 479* size 000220 automatic fixed bin(17,0) dcl 179 set ref 697* 701* 715 sr_absda 000244 automatic fixed bin(17,0) dcl 208 set ref 576* 587* 588 599 srday 000374 automatic fixed bin(17,0) dcl 287 set ref 577* 587* 588* 614 ss 000344 automatic fixed bin(17,0) dcl 287 set ref 472* 479* stop_switch 000325 automatic bit(1) initial packed unaligned dcl 229 set ref 229* 389* 658 768 storage based structure array level 1 dcl 323 storp 000116 automatic pointer dcl 168 set ref 504* 718 719 777 779 806 808 810 substr builtin function dcl 239 set ref 376 515 518 520 523 526 526 529 529 534 535 538 538 547 549 549 553 553 556 556 564 566 566 574 580 580 593 595 598 605 605 616 616 625 625 630 630 634 634 669* 672* 677* 677 847 syntax_warning 000326 automatic bit(1) initial packed unaligned dcl 229 set ref 229* 452* 771 temp_seg_ptr 000120 automatic pointer dcl 168 set ref 356* 364 1082 1082* text 4 based char(16) array level 2 in structure "storage" dcl 323 in procedure "calendar" set ref 718 777* 810* text 0(09) based char(16) array level 4 in structure "week_setup" packed packed unaligned dcl 302 in procedure "calendar" set ref 683* 704* 707* 711* 716* 718* 743* 747 748* 752* titlestr 000361 automatic char(16) dcl 287 set ref 663* 664* verify builtin function dcl 239 ref 595 838 885 wait_switch 000327 automatic bit(1) initial packed unaligned dcl 229 set ref 229* 393* 658 week 36 based structure array level 2 packed packed unaligned dcl 311 week_setup based structure level 1 dcl 302 whole_seg based char(131071) dcl 222 ref 515 518 wkd 000345 automatic fixed bin(17,0) dcl 287 set ref 472* 474* 476 476* 476 477 479* 487 675 675* 676 681 687 691 735 736 756 763 wkdf 000350 automatic fixed bin(17,0) dcl 287 set ref 501* 927 927* 928 wkdname 000526 automatic char(16) initial array dcl 337 set ref 337* 337* 337* 337* 337* 337* 337* 634 634* 668 669 wkdp 000347 automatic fixed bin(17,0) dcl 287 set ref 500* 898 898* 899 x 000221 automatic fixed bin(17,0) dcl 179 set ref 369* 371 x1 000360 automatic fixed bin(17,0) dcl 287 set ref 528* 528* 528* 528* 528* 528* 555* 555* 555* 555* 555* 555* 569* 569* 569* 569* 569* 569* 569* 569* 587* 587* 587* 587* 587* 587* 587* 610* 610* 610* 610* 610* 610* 610* 610* xdd 000357 automatic fixed bin(17,0) dcl 287 set ref 528* 529* 555* 556* 620* 624* 625* xl parameter fixed bin(17,0) dcl 880 ref 878 884 885 885 xmm 000355 automatic fixed bin(17,0) dcl 287 set ref 528* 529 534* 535* 538* 540 540* 542 543 544 555* 556 615* 620* 623 624* xp parameter pointer dcl 880 set ref 878 884 885 886* xyy 000356 automatic fixed bin(17,0) dcl 287 set ref 528* 529 555* 556 615* year parameter fixed bin(17,0) dcl 1091 in procedure "leap_year" ref 1090 1093 1093 1093 1093 year parameter fixed bin(17,0) dcl 1106 in procedure "check_start_Gregory" ref 1104 1110 year parameter fixed bin(17,0) dcl 954 in procedure "calculate_easter" ref 952 962 963 963 yr_absda 000245 automatic fixed bin(17,0) dcl 208 set ref 474* 477 698 yy 000341 automatic fixed bin(17,0) dcl 287 set ref 472* 473* 475 478* 479* 482* 490 491 492 493 529 556 620* 624* 663 724* 775* yyf 000354 automatic fixed bin(17,0) dcl 287 set ref 492* 493* 497* 499* 925* 932* yyp 000353 automatic fixed bin(17,0) dcl 287 set ref 490* 491* 496* 498* 896* 903* NAMES DECLARED BY EXPLICIT CONTEXT. arg_value_error 001620 constant label dcl 457 ref 433 442 449 bad 004026 constant label dcl 640 ref 522 527 550 554 561 568 582 607 bad1 004025 constant label dcl 639 ref 525 533 539 calculate_easter 006663 constant entry internal dcl 952 ref 620 calendar 000373 constant entry external dcl 26 check_start_Gregory 007147 constant entry internal dcl 1104 ref 724 775 903 932 cleanup_proc 007001 constant entry internal dcl 1072 ref 353 360 417 425 467 654 783 done 006100 constant label dcl 860 ref 842 851 855 fatal_arg_error 001276 constant label dcl 416 ref 373 382 fatal_arg_val_error 001366 constant label dcl 424 ref 385 fill_in_note 005712 constant entry internal dcl 789 ref 529 556 616 625 follow_month 006457 constant entry internal dcl 923 ref 691 755 leap_year 007105 constant entry internal dcl 1090 ref 482 496 497 out 005172 constant label dcl 735 ref 725 parse_line 005771 constant entry internal dcl 821 ref 521 previous_month 006256 constant entry internal dcl 894 ref 689 756 putweek 006104 constant entry internal dcl 867 ref 727 737 760 skip 004100 constant label dcl 644 ref 520 544 583 600 608 620 too_many_notes 005741 constant label dcl 813 ref 804 try_date 001565 constant label dcl 448 ref 440 writer 006163 constant entry internal dcl 878 ref 664 664 THERE WERE NO NAMES DECLARED BY CONTEXT OR IMPLICATION. STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 10006 10132 7515 10016 Length 10402 7515 124 233 271 42 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME calendar 849 external procedure is an external procedure. on unit on line 353 64 on unit fill_in_note internal procedure shares stack frame of external procedure calendar. parse_line internal procedure shares stack frame of external procedure calendar. putweek internal procedure shares stack frame of external procedure calendar. writer 78 internal procedure is assigned to an entry variable. previous_month internal procedure shares stack frame of external procedure calendar. follow_month internal procedure shares stack frame of external procedure calendar. calculate_easter internal procedure shares stack frame of external procedure calendar. cleanup_proc 90 internal procedure is called by several nonquick procedures. leap_year internal procedure shares stack frame of external procedure calendar. check_start_Gregory internal procedure shares stack frame of external procedure calendar. STORAGE FOR INTERNAL STATIC VARIABLES. LOC IDENTIFIER BLOCK NAME 000010 bar calendar 000047 NL calendar 000050 FF calendar STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME calendar 000100 ap calendar 000102 ap2 calendar 000104 ifdp calendar 000106 lp calendar 000110 olp calendar 000112 pfp calendar 000114 seg_ptr calendar 000116 storp calendar 000120 temp_seg_ptr calendar 000122 al calendar 000123 al2 calendar 000124 an calendar 000125 box_height calendar 000126 century calendar 000127 day_chain_roots calendar 000166 days_mo calendar 000167 days_mop calendar 000170 days_mof calendar 000171 days_yr calendar 000172 ec calendar 000173 ec2 calendar 000174 fld_ix calendar 000201 fld_ln calendar 000206 how_many_fields calendar 000207 i calendar 000210 inf calendar 000211 input_line_count calendar 000212 jj calendar 000213 jjj calendar 000214 last_cell_no calendar 000215 lchr calendar 000216 lchrnl calendar 000217 repeat_count calendar 000220 size calendar 000221 x calendar 000222 bom calendar 000224 bomf calendar 000226 bomp calendar 000230 end_absda calendar 000232 fb71 calendar 000234 fb71a calendar 000236 fwbase calendar 000237 mo_absda calendar 000240 mo_absdaf calendar 000242 rbom calendar 000244 sr_absda calendar 000245 yr_absda calendar 000246 current_line calendar 000320 ave_switch calendar 000321 error_switch calendar 000322 force_switch calendar 000323 fwsw calendar 000324 julian_switch calendar 000325 stop_switch calendar 000326 syntax_warning calendar 000327 wait_switch calendar 000336 absda calendar 000337 mm calendar 000340 dd calendar 000341 yy calendar 000342 hh calendar 000343 minute calendar 000344 ss calendar 000345 wkd calendar 000346 shf calendar 000347 wkdp calendar 000350 wkdf calendar 000351 mmp calendar 000352 mmf calendar 000353 yyp calendar 000354 yyf calendar 000355 xmm calendar 000356 xyy calendar 000357 xdd calendar 000360 x1 calendar 000361 titlestr calendar 000365 day_of_month calendar 000366 day_of_week calendar 000367 cursor calendar 000370 k calendar 000371 n calendar 000372 jpf calendar 000373 kpf calendar 000374 srday calendar 000375 endday calendar 000376 interval calendar 000377 nchr calendar 000400 command calendar 000402 d calendar 000403 llth calendar 000404 boy calendar 000406 fwno calendar 000407 moname calendar 000453 ndays calendar 000467 head calendar 000526 wkdname calendar 000562 horizline calendar 000652 i parse_line 000653 f parse_line 000654 c parse_line 000714 a calculate_easter 000715 b calculate_easter 000716 c calculate_easter 000717 d calculate_easter 000720 e calculate_easter 000721 g calculate_easter 000722 h calculate_easter 000723 i calculate_easter 000724 k calculate_easter 000725 l calculate_easter 000726 m calculate_easter writer 000100 i writer THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. alloc_char_temp call_ext_out_desc call_ext_out call_int_this call_int_other return_mac mdfx1 enable_op shorten_stack ext_entry int_entry any_to_any_truncate_ clock_mac THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. bigletter_ com_err_ convert_date_to_binary_ convert_date_to_binary_$relative cu_$arg_count cu_$arg_ptr cv_dec_check_ datebin_ datebin_$revert expand_path_ get_temp_segment_ hcs_$initiate_count hcs_$terminate_noname ioa_$rsnnl iox_$get_line iox_$put_chars release_temp_segment_ THE FOLLOWING EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. error_table_$bad_conversion error_table_$badopt iox_$user_input iox_$user_output LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 26 000372 179 000400 229 000416 287 000426 329 000430 333 000560 337 000640 344 000722 353 000725 356 000747 357 000772 359 000774 360 001022 361 001026 364 001027 365 001031 366 001032 369 001034 371 001043 372 001053 373 001070 376 001072 378 001077 380 001110 381 001111 382 001126 384 001130 385 001154 387 001156 389 001157 393 001172 397 001205 401 001220 405 001233 409 001246 412 001256 413 001257 414 001274 416 001276 417 001330 418 001334 420 001335 421 001361 423 001363 424 001366 425 001427 426 001433 428 001434 429 001436 432 001437 433 001442 435 001443 438 001444 439 001447 440 001475 442 001502 443 001503 445 001552 448 001565 449 001611 451 001613 452 001615 455 001617 457 001620 458 001664 459 001666 460 001667 462 001671 464 001673 466 001675 467 001724 468 001730 472 001731 473 001762 474 002013 475 002037 476 002043 477 002050 478 002054 479 002104 480 002135 481 002140 482 002142 484 002152 485 002153 487 002154 490 002165 490 002170 490 002172 490 002175 491 002176 491 002200 492 002202 492 002205 492 002207 492 002212 493 002213 493 002215 494 002217 495 002222 496 002225 497 002236 498 002247 499 002277 500 002327 501 002352 503 002376 504 002401 505 002407 509 002411 510 002421 511 002425 512 002431 513 002433 514 002434 515 002437 516 002457 517 002466 518 002470 519 002473 520 002474 521 002500 522 002502 523 002504 524 002512 525 002517 526 002522 527 002562 528 002565 529 002612 531 002633 532 002634 533 002641 534 002644 535 002656 538 002663 539 002713 540 002716 542 002722 543 002727 544 002734 547 002740 549 002754 550 003013 553 003016 554 003053 555 003056 556 003103 558 003124 559 003125 561 003131 564 003134 566 003145 568 003200 569 003203 570 003225 574 003233 576 003242 577 003244 578 003246 580 003247 582 003306 583 003311 587 003314 588 003340 593 003354 595 003366 598 003430 599 003445 600 003452 601 003454 602 003461 603 003464 605 003465 607 003524 608 003527 609 003532 610 003537 614 003562 615 003602 616 003630 617 003643 618 003646 619 003647 620 003653 623 003662 624 003665 625 003713 627 003726 628 003727 629 003733 630 003741 632 003766 633 003770 634 003775 636 004022 637 004024 639 004025 640 004026 642 004076 644 004100 645 004102 646 004103 649 004105 653 004141 654 004170 655 004174 658 004175 663 004223 664 004264 665 004304 666 004310 667 004312 668 004317 669 004340 670 004350 671 004352 672 004354 673 004361 675 004401 676 004405 677 004410 678 004417 679 004437 680 004467 681 004504 682 004513 683 004535 684 004557 687 004561 688 004567 689 004571 691 004572 694 004601 695 004603 697 004610 698 004612 699 004616 700 004621 701 004622 703 004624 704 004631 705 004673 706 004674 707 004675 709 004733 711 004740 712 005010 713 005011 715 005013 716 005021 718 005040 719 005061 721 005064 722 005067 723 005070 724 005071 725 005073 726 005076 727 005101 728 005102 730 005146 731 005150 733 005171 735 005172 736 005200 737 005205 738 005206 739 005227 740 005231 741 005233 742 005241 743 005263 744 005305 745 005307 747 005310 748 005315 749 005337 750 005354 751 005363 752 005405 753 005427 755 005431 756 005432 757 005436 758 005437 760 005444 762 005445 763 005452 765 005501 768 005522 771 005546 774 005577 775 005607 776 005611 777 005622 779 005673 780 005701 781 005703 783 005705 785 005711 789 005712 803 005714 804 005715 806 005720 807 005726 808 005731 810 005733 811 005740 813 005741 815 005770 821 005771 836 005773 837 005775 838 006006 839 006022 841 006023 842 006024 845 006025 846 006036 847 006040 848 006057 850 006060 851 006064 853 006065 854 006067 855 006071 856 006074 858 006076 860 006100 861 006103 867 006104 869 006105 870 006115 871 006136 872 006157 874 006161 878 006162 884 006170 885 006200 886 006216 888 006233 890 006255 894 006256 896 006257 897 006316 898 006320 899 006324 900 006333 901 006340 902 006342 903 006351 904 006353 905 006413 906 006414 907 006417 908 006421 910 006422 912 006424 913 006427 914 006435 915 006450 916 006452 917 006453 918 006455 919 006456 923 006457 925 006460 926 006521 927 006523 928 006527 929 006537 930 006544 931 006546 932 006555 933 006557 934 006617 935 006620 936 006623 937 006625 939 006626 941 006630 942 006633 943 006641 944 006654 945 006656 946 006657 947 006661 948 006662 952 006663 962 006665 963 006671 963 006675 964 006701 964 006704 965 006710 965 006713 975 006716 988 006723 1034 006734 1052 006750 1065 006760 1066 006771 1068 006777 1072 007000 1074 007006 1075 007017 1077 007030 1078 007042 1080 007051 1082 007054 1085 007104 1090 007105 1093 007107 1098 007134 1099 007141 1104 007147 1110 007151 1112 007165 ----------------------------------------------------------- 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