|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 8467 (0x2113) Types: TextFile Notes: R1k Text-file segment
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000 └─ ⟦cfc2e13cd⟧ »Space Info Vol 2« └─⟦0f1737f92⟧ └─⟦this⟧
with system; with v_i_time; package body CALENDAR is type time_float is digits 9; package local_time is function clock return time; seconds_from_gmt: time_float; function daylight_savings(year, julian_day: integer) return time_float; end; seconds_per_day : constant := 86400.0; function is_leap_year(year: year_number) return boolean is begin return year mod 4 = 0; end; function days_in_month(month: month_number; of_year: year_number) return day_number is begin case month is when 1 | 3 | 5 | 7..8 | 10 | 12 => return 31; when 2 => if is_leap_year(of_year) then return 29; else return 28; end if; when others => return 30; end case; end; function clock return time is begin return local_time.clock; end; function year (date: time) return year_number is year : year_number; month : month_number; day : day_number; seconds: day_duration; begin split(date, year, month, day, seconds); return year; end; function month (date: time) return month_number is year : year_number; month : month_number; day : day_number; seconds: day_duration; begin split(date, year, month, day, seconds); return month; end; function day (date: time) return day_number is year : year_number; month : month_number; day : day_number; seconds: day_duration; begin split(date, year, month, day, seconds); return day; end; function seconds(date: time) return day_duration is year : year_number; month : month_number; day : day_number; seconds: day_duration; begin split(date, year, month, day, seconds); return seconds; end; function julian_day_of(year : year_number; month : month_number; day : day_number) return integer is j, m, y, c, ya: integer; begin if month > 2 then m := month - 3; y := year; else m := month + 9; y := year - 1; end if; c := y / 100; ya := y - 100 * c; return (146097*c)/4 + (1461*ya)/4 + (153*m+2)/5 + day + 1721119; end julian_day_of; procedure date_from_julian_day(jday: integer; year : out year_number; month : out month_number; day : out day_number) is j: integer := jday - 1721119; y: integer := (4*j-1)/146097; d, m: integer; begin j := 4*j - 1 - 146097 * y; d := j / 4; j := (4*d+3)/1461; d := 4*d + 3 - 1461*j; d := (d+4) / 4; m := (5*d-3)/153; d := 5*d - 3 - 153*m; day := (d+5) / 5; y := 100*y + j; if m < 10 then month := m + 3; year := y; else month := m - 9; year := y + 1; end if; end date_from_julian_day; procedure split (date : in time; year : out year_number; month : out month_number; day : out day_number; seconds: out day_duration) is s: time_float := time_float(date.sec); jday: integer := date.julian_day; y: integer; begin s := time_float(date.sec) - local_time.seconds_from_gmt; if s < 0.0 then jday := jday - 1; s := s + seconds_per_day; end if; date_from_julian_day(jday, y, month, day); s := s + local_time.daylight_savings(y, jday); if s >= seconds_per_day then jday := jday + 1; s := s - seconds_per_day; date_from_julian_day(jday, y, month, day); end if; seconds := duration(s); year := y; end; function time_of(year : year_number; month : month_number; day : day_number; seconds: day_duration := 0.0) return time is date: time; s: time_float := time_float(seconds); begin if day > days_in_month(month, year) then raise time_error; end if; date.julian_day := julian_day_of(year, month, day); if s >= seconds_per_day then date.julian_day := date.julian_day + 1; s := s - seconds_per_day; end if; s := s - local_time.daylight_savings(year, date.julian_day); if s < 0.0 then date.julian_day := date.julian_day - 1; s := s + seconds_per_day; end if; s := time_float(s) + local_time.seconds_from_gmt; if s >= seconds_per_day then date.julian_day := date.julian_day + 1; s := s - seconds_per_day; end if; date.sec := duration(s); -- date is now converted to GMT, normalized return date; end; function "+"(a, b: integer) return integer is begin if a < 0 and then b < 0 then if (integer'first - a - b) > 0 then raise time_error; end if; elsif a > 0 and then b > 0 then if (integer'last - a - b) < 0 then raise time_error; end if; end if; return standard."+"(a, b); end; function "+" (left: time; right: duration) return time is date: time; check: year_number; secs: duration; begin date.julian_day := left.julian_day; begin secs := left.sec + right; exception when numeric_error | constraint_error => secs := (left.sec - seconds_per_day) + right; date.julian_day := date.julian_day + 1; end; date.sec := secs; if date.sec < 0.0 or else date.sec >= seconds_per_day then while date.sec >= seconds_per_day loop date.julian_day := date.julian_day + 1; date.sec := date.sec - seconds_per_day; end loop; while date.sec < 0.0 loop date.julian_day := date.julian_day - 1; date.sec := date.sec + seconds_per_day; end loop; end if; check := year(date); return date; exception when others => raise time_error; end; function "+" (left: duration;right: time) return time is begin return right + left; end; function "-" (left: time; right: duration) return time is begin return left + (- right); end; function "-" (left: time; right: time) return duration is day_diff : integer := left.julian_day - right.julian_day; diff: duration := left.sec + (-right.sec); begin return duration(day_diff * integer(seconds_per_day)) + diff; exception when numeric_error | constraint_error => raise time_error; end; function "<" (left, right: time) return boolean is begin return left.julian_day < right.julian_day OR ELSE (left.julian_day = right.julian_day and then left.sec < right.sec); end; function "<=" (left, right: time) return boolean is begin return left.julian_day < right.julian_day OR ELSE (left.julian_day = right.julian_day and then left.sec <= right.sec); end; function ">" (left, right: time) return boolean is begin return left.julian_day > right.julian_day OR ELSE (left.julian_day = right.julian_day and then left.sec > right.sec); end; function ">=" (left, right: time) return boolean is begin return left.julian_day > right.julian_day OR ELSE (left.julian_day = right.julian_day and then left.sec >= right.sec); end; procedure set_clock(date: time; timer_support_arg: system.address := system.NO_ADDR) is begin v_i_time.set_time(date.julian_day, date.sec, timer_support_arg); end; pragma external_name(set_clock, "__SET_CLOCK"); procedure delay_until(date: time) is begin v_i_time.delay_until(date.julian_day, date.sec); end; pragma external_name(delay_until, "__DELAY_UNTIL"); package body local_time is separate; end