1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26 calendar: proc;
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134 Note
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168 declare
169 ap pointer,
170 ap2 pointer,
171 ifdp pointer,
172 lp pointer,
173 olp pointer,
174 pfp pointer,
175 seg_ptr pointer,
176 storp pointer,
177 temp_seg_ptr pointer;
178
179 declare
180 al fixed bin,
181 al2 fixed bin,
182 an fixed bin,
183 box_height fixed bin init(7),
184 century fixed bin,
185 day_chain_roots(31) fixed bin init ((31)0),
186 days_mo fixed bin,
187 days_mop fixed bin,
188 days_mof fixed bin,
189 days_yr fixed bin,
190 ec fixed bin (35),
191 ec2 fixed bin (35),
192 fld_ix(5) fixed bin,
193 fld_ln(5) fixed bin,
194 how_many_fields fixed bin,
195 i fixed bin,
196 inf fixed bin,
197 input_line_count fixed bin,
198 jj fixed bin,
199 jjj fixed bin,
200 last_cell_no fixed bin init(0),
201 lchr fixed bin,
202 lchrnl fixed bin,
203 max_cells fixed bin init(24000) internal static options(constant),
204 repeat_count fixed bin, note
205 size fixed bin,
206 x fixed bin;
207
208 declare
209 bom fixed bin (71),
210 bomf fixed bin(71),
211 bomp fixed bin(71),
212 end_absda fixed bin,
213 fb71 fixed bin (71),
214 fb71a fixed bin (71),
215 fwbase fixed bin,
216 mo_absda fixed bin,
217 mo_absdaf fixed bin,
218 rbom fixed bin (71),
219 sr_absda fixed bin,
220 yr_absda fixed bin;
221
222 declare
223 bchr char (al) unal based (ap),
224 bchr2 char (al2) unal based (ap2),
225 current_line char(168) aligned,
226 input_line char(lchr) aligned based(lp),
227 whole_seg char (131071) based (seg_ptr) aligned;
228
229 declare
230 ave_switch bit(1) init("0"b),
231 error_switch bit(1) init("0"b),
232 force_switch bit(1) init("0"b),
233 fwsw bit (1) init ("0"b),
234 julian_switch bit(1) init("0"b),
235 stop_switch bit(1) init("0"b),
236 syntax_warning bit(1) init("0"b),
237 wait_switch bit(1) init("0"b);
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
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
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
274 declare
275 1 if_data aligned based(ifdp),
276 2 how_many fixed bin,
277 2 pad fixed bin,
278 2 if(100) aligned,
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;
284
285
286
287 dcl (absda, mm, dd, yy, hh, minute, ss, wkd, shf) fixed bin,
288 (wkdp, wkdf) fixed bin,
289 (mmp, mmf, yyp, yyf) fixed bin,
290 (xmm, xyy, xdd, x1) fixed bin,
291 titlestr char (16) aligned,
292 (day_of_month, day_of_week) fixed bin,
293 (cursor, k, n, jpf, kpf) fixed bin,
294 (srday, endday, interval) fixed bin,
295 nchr fixed bin,
296 command char (8),
297 d fixed bin,
298 llth fixed bin (21) init (120),
299 boy fixed bin (71),
300 fwno fixed bin;
301
302 declare
303 1 week_setup aligned based (olp),
304 2 line (box_height) aligned,
305 3 day (7) unal,
306 4 brk char (1),
307 4 text char (16),
308 3 rtbar char (1) unal,
309 2 next_storage_block ptr;
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),
324 2 date fixed bin (71),
325 2 link fixed bin,
326 2 pad fixed bin,
327 2 text char (16);
328
329 dcl moname (12) char (9) aligned init
330 ("January", "February", "March", "April", "May", "June",
331 "July", "August", "September", "October", "November", "December");
332
333 dcl ndays (12) fixed bin init
334 (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
335
336 dcl head char (121) aligned;
337 dcl wkdname (7) char (16) aligned init
338 ("Sunday", "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday");
339
340
341 dcl bar char (121) aligned int static init
342 ("
343 ");
344 dcl horizline char (121) aligned init (" ");
345
346 dcl NL char (1) aligned int static init ("
347 ");
348
349 dcl FF char (1) int static init ("^L");
350
351
352
353 on cleanup call cleanup_proc();
354
355
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();
367
368
369 call cu_$arg_count(x);
370
371 do an = 1 to x;
372 call cu_$arg_ptr(an,ap,al,ec);
373 if ec ^= 0 then
374 goto fatal_arg_error;
375
376 if substr(bchr,1,1) = "-" then
377 do;
378 if bchr = "-date" | bchr = "-dt" then
379 do;
380 an = an + 1;
381 call cu_$arg_ptr(an,ap2,al2,ec);
382 if ec ^= 0 then
383 goto fatal_arg_error;
384 call convert_date_to_binary_(bchr2,fb71,ec);
385 if ec ^= 0 then
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);
414 if ec ^= 0 then
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;
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;
429 end;
430
431 else do;
432 ec = error_table_$badopt;
433 goto arg_value_error;
434 end;
435 end;
436
437 else do;
438 i = if_data.how_many + 1;
439 call expand_path_(ap,al,addr(if_data.if(i).dn),addr(if_data.if(i).en),ec);
440 if ec ^= 0 then
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
446 if an = 1 then
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;
461 end;
462 end;
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
472 call datebin_ (fb71, absda, mm, dd, yy, hh, minute, ss, wkd, shf);
473 call datebin_$revert (1, 1, yy, 0, 0, 0, boy);
474 call datebin_ (boy, yr_absda, i, i, i, i, i, i, wkd, i);
475 century = divide (yy, 100, 17, 0) * 100;
476 if wkd >= 6 then wkd = wkd - 7;
477 fwbase = yr_absda + 1 - wkd;
478 call datebin_$revert (mm, 1, yy, 0, 0, 0, bom);
479 call datebin_ (bom, mo_absda, mm, dd, yy, hh, minute, ss, wkd, shf);
480 days_mo = ndays (mm);
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);
488
489
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
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);
512 k = 1;
513 input_line_count = 0;
514 do while (k < nchr);
515 lchrnl = index (substr (whole_seg, k), NL);
516 if lchrnl = 0 then lchr, lchrnl = nchr-k+1;
517 else lchr = lchrnl - 1;
518 current_line = substr (whole_seg, k, lchr);
519 input_line_count = input_line_count + 1;
520 if substr (current_line, 1, 1) = "*" then go to skip;
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;
528 call datebin_ (fb71, x1, xmm, xdd, xyy, x1, x1, x1, x1, x1);
529 if xmm = mm then if xyy = yy then
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;
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
547 if substr (input_line, fld_ix(3), fld_ln(3)) = "0" then fb71a = rbom-1;
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
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
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
564 if substr(input_line,fld_ix(4),fld_ln(4)) = "0" then interval = 1;
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);
571 end;
572
573
574 if substr(input_line,fld_ix(2),fld_ln(2)) = "0" then
575 do;
576 sr_absda = mo_absda;
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;
584
585
586
587 call datebin_(fb71,sr_absda,x1,srday,x1,x1,x1,x1,x1,x1);
588 if fb71 < bom then
589 srday = interval - mod(mo_absda-1-sr_absda, interval);
590 end;
591
592
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;
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;
601 if end_absda >= mo_absdaf then endday = days_mo;
602 else endday = end_absda - mo_absda + 1;
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;
609 if fb71 >= bomf then endday = days_mo;
610 else call datebin_(fb71,x1,x1,endday,x1,x1,x1,x1,x1,x1);
611 end;
612
613
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;
618 end;
619 else if command = "easter" then do;
620 if mm = 3 | mm = 4 then
621 call calculate_easter(yy,xmm,xdd);
622 else goto skip;
623 if xmm = mm then do;
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;
639 bad1: ec = 0;
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;
645 end;
646 end;
647
648
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
659 call iox_$get_line(iox_$user_input,lp,168,0,ec);
660
661
662
663 call ioa_$rsnnl ("^a ^d", titlestr, i, moname (mm), yy - century);
664 call bigletter_ (titlestr, writer);
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);
669 substr (head, cursor+i, 17-i) = wkdname (day_of_week);
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;
676 i = wkd * 17;
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);
679 line (*).brk (*) = "|";
680 line (*).rtbar = "|";
681 do day_of_week = 1 to wkd;
682 line(*).brk(day_of_week) = " ";
683 line (*).text (day_of_week) = "";
684 end;
685
686
687 if wkd > 1 & box_height > 6 then do;
688 pfp = addr (line);
689 call previous_month;
690 end;
691 if wkd > 2 & box_height > 6 then
692 call follow_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;
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
709 if julian_switch & box_height > 1 then
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;
716 if day_chain_roots (day_of_month) = 0 then line (i).text (day_of_week) = "";
717 else do;
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));
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;
726 if day_of_week > 7 then do;
727 call putweek;
728 line(*).brk(*), line(*).rtbar = "|";
729
730 day_of_week = 1;
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;
736 if wkd = 0 & days_mo = 28 then do;
737 call putweek;
738 call iox_$put_chars (iox_$user_output, addr (bar), length(bar), ec);
739 llth = 51;
740 pfp = addr (line);
741 do i = 1 to 3;
742 line(*).day(i).brk = " ";
743 line(*).day(i).text = " ";
744 end;
745 end;
746 else do;
747 pfp = addr (line (1).day (5).text);
748 line(*).day(day_of_week).text = " ";
749 line(*).rtbar = " ";
750 do i = day_of_week + 1 to 7;
751 line (*).day (i).brk = " ";
752 line (*).day (i).text = " ";
753 end;
754 end;
755 call follow_month;
756 if wkd < 2 then call previous_month;
757 end;
758 else llth = 1 + (day_of_week-1) * 17;
759
760 call putweek;
761
762 llth = 1 + (day_of_week-1) * 17;
763 if ^(wkd = 0 & days_mo = 28 & box_height > 6) then
764 call iox_$put_chars (iox_$user_output, addr (bar), llth, ec);
765 call iox_$put_chars (iox_$user_output, addr (FF), 1, ec);
766
767
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, note
793 abs_time fixed bin(71),
794 note char(16);
795
796
797
798
799
800
801
802
803 last_cell_no = last_cell_no + 1;
804 if last_cell_no > max_cells then goto too_many_notes;
805
806 storage.link(last_cell_no) = day_chain_roots(day);
807 day_chain_roots(day) = last_cell_no;
808 storage.date(last_cell_no) = abs_time;
809
810 storage.text(last_cell_no) = note;
811 return;
812
813 too_many_notes:
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
823
824
825 declare
826 no_of_fields fixed bin,
827 (i, f, c) fixed bin;
828
829
830
831
832
833
834
835
836 i = 1;
837 fld_ln(*) = 0;
838 i = verify(input_line," ");
839 if i = 0 then
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), ",");
848 if c = 0 then
849 do;
850 fld_ln(f) = lchr - i + 1;
851 goto done;
852 end;
853 fld_ln(f) = c - 1;
854 i = i + c;
855 if i > lchr then goto done;
856 end;
857
858 f = f - 1;
859
860 done: no_of_fields = f;
861 return;
862
863 end parse_line;
864
865
866
867 putweek: proc;
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);
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);
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;
911
912 do while (i <= 6);
913 do jpf = kpf to 7;
914 prevfoll.week (i).dayp (jpf) = " ";
915 end;
916 i = i + 1;
917 kpf = 1;
918 end;
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;
940
941 do while (i <= 6);
942 do jpf = kpf to 7;
943 prevfoll.week (i).dayf (jpf) = " ";
944 end;
945 i = i + 1;
946 kpf = 1;
947 end;
948 end follow_month;
949
950
951 ^L
952 calculate_easter: proc(year, month, day);
953
954 declare
955 day fixed bin,
956 month fixed bin,
957 year fixed bin,
958 (a, b, c, d, e, g, h, i, k, l, m) fixed bin;
959
960
961
962 a = mod(year,19);
963 b = divide(year,100,35); c = mod(year,100);
964 d = divide(b,4,35); e = mod(b,4);
965 i = divide(c,4,35); k = mod(c,4);
966
967
968
969
970
971
972
973
974
975 g = divide(8*b+13,25,35);
976
977
978
979
980
981
982
983
984
985
986
987
988 h = mod(19*a + b - d - g + 15, 30);
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034 l = mod(2*e + 2*i - k + 32 - h, 7);
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052 m = divide(a + 11*h + 19*l, 433, 35);
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065 month = divide(h + l - 7*m + 90, 25, 35);
1066 day = mod(h + l - 7*m +33*month + 19, 32);
1067
1068 return;
1069
1070 end calculate_easter;
1071 ^L
1072 cleanup_proc: proc;
1073
1074 do if_data.how_many = if_data.how_many to 1 by -1;
1075 if if_data.if(if_data.how_many).ifptr ^= null then
1076 do;
1077 call hcs_$terminate_noname(if_data.if(if_data.how_many).ifptr,ec);
1078 if_data.if(if_data.how_many).ifptr = null;
1079 end;
1080 end;
1081
1082 if temp_seg_ptr ^= null then
1083 call release_temp_segment_("calendar",temp_seg_ptr,ec);
1084
1085 return;
1086
1087 end cleanup_proc;
1088
1089
1090 leap_year: proc (year) returns(bit(1));
1091 dcl year fixed bin;
1092
1093 if mod (year, 4) = 0 then
1094
1095
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
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;