-- DateAndTimeImpl.mesa
-- last edited by Levin on June 8, 1982 11:08 am
-- last edited by Brotz on August 19, 1982  4:12 PM

DIRECTORY
  Ascii USING [SP, TAB],
  DateAndTime USING [Notes],
  Inline USING [COPY, LowHalf],
  Storage USING [Free, Node],
  String USING [EquivalentSubStrings, SubStringDescriptor, UpperCase],
  TimeDefs USING [currentParameters, PackedTime, LocalTimeParameters];

DateAndTimeImpl: PROGRAM
  IMPORTS Inline, Storage, String
  EXPORTS DateAndTime =

BEGIN

hoursPerDay: LONG CARDINAL = 24;
minutesPerHour: LONG CARDINAL = 60;
secondsPerMinute: LONG CARDINAL = 60;
secondsPerDay: LONG CARDINAL = hoursPerDay * minutesPerHour * secondsPerMinute;
baseYear: LONG CARDINAL = 1968;
baseDay: LONG CARDINAL = 1;  -- January 1, 1968 was a Monday (0 = Sunday)
gmtEpoch: LONG CARDINAL = 2114294400;

EpochDays: TYPE = LONG CARDINAL;
lastEpochDays: LONG CARDINAL = LAST[LONG CARDINAL] / secondsPerDay;
YearDays: TYPE = LONG CARDINAL;
lastYearDays: LONG CARDINAL = 366;
Year: TYPE = LONG CARDINAL;
lastYear: LONG CARDINAL = baseYear + (lastEpochDays / (4 * 365 + 1)) * 4;
Month: TYPE = [1 .. 12];
Day: TYPE = [1 .. 31];
Hour: TYPE = LONG CARDINAL;
Minute: TYPE = LONG CARDINAL;
Second: TYPE = LONG CARDINAL;
DeltaMinutes: TYPE = LONG INTEGER;
  --(-hoursPerDay*minutesPerHour..hoursPerDay*minutesPerHour)--
ZoneIndex: TYPE = INTEGER[-12 .. 12];
NAZones: TYPE = ZoneIndex[-11 .. -4];


Unintelligible: PUBLIC ERROR = CODE;


Parse: PUBLIC PROCEDURE [s: STRING]
  RETURNS [dt: TimeDefs.PackedTime, notes: DateAndTime.Notes] =
BEGIN
TokenCount: TYPE = CARDINAL;
TokenIndex: TYPE = CARDINAL;
CharIndex: TYPE = CARDINAL[0 .. 37777B];  -- this upper bound saves a word in Token
CharCount: TYPE = CARDINAL;
Tokens: TYPE = RECORD
  [nTokens: TokenCount _ 0,
  length: TokenIndex _ 0,
  tokens: ARRAY [0 .. 0) OF Token];
Token: TYPE = RECORD
  [SELECT type: * FROM
    alpha => [offset: CharIndex, length: CharCount],
    num => [offset: CharIndex, length: CharCount],
    sep => [char: CHARACTER],
    ENDCASE];
sentinel: CHARACTER = 200C;

AddToken: PROCEDURE [t: Token] =
  BEGIN
  IF input.nTokens = input.length THEN
    BEGIN
    newInput: POINTER TO Tokens _
      Storage.Node[SIZE[Tokens] + ((input.length*3) / 2) * SIZE[Token]];
    newInput.nTokens _ input.nTokens;
    newInput.length _ (input.length * 3) / 2;
    Inline.COPY
      [from: @input.tokens[0], to: @newInput.tokens[0], nwords: input.nTokens*SIZE[Token]];
    Storage.Free[input];
    input _ newInput;
    END;
  input.tokens[input.nTokens] _ t;
  input.nTokens _ input.nTokens + 1;
  END;  -- of AddToken --

Tokenize: PROCEDURE RETURNS [ok: BOOLEAN _ TRUE] =
  BEGIN
  state: {initial, num, alpha} _ initial;
  i: CARDINAL _ 0;
  tStart: CARDINAL;
  AddToken[[sep[sentinel]]];
  DO
    char: CHARACTER;
    SELECT TRUE FROM
      i = s.length => char _ sentinel;
      s[i] = Ascii.TAB => char _ Ascii.SP;
      s[i] IN [40C  ..  177C] => char _ s[i];
      ENDCASE => RETURN[FALSE];
    SELECT char FROM
      IN ['0 .. '9] =>
        SELECT state FROM
          initial => {state _ num; tStart _ i};
          num => NULL;
          alpha =>
            {AddToken[[alpha[offset: tStart, length: i - tStart]]]; state _ num; tStart _ i};
          ENDCASE;
      ',, '., ':, '/, '-, '+, Ascii.SP, sentinel =>
        BEGIN
        SELECT state FROM
          initial => NULL;
          num => {AddToken[[num[offset: tStart, length: i - tStart]]]; state _ initial};
          alpha => {AddToken[[alpha[offset: tStart, length: i - tStart]]]; state _ initial};
          ENDCASE;
        -- The effect of the following is to ignore spaces as separators unless there is
        -- nothing else, and to complain if two separator characters are adjacent.
        WITH t: input.tokens[input.nTokens - 1] SELECT FROM
          sep =>
            IF t.char = Ascii.SP THEN t.char _ char
            ELSE IF char ~= Ascii.SP THEN RETURN[FALSE];
          ENDCASE => AddToken[[sep[char]]];
        IF char = sentinel THEN EXIT;
        END;
      ENDCASE =>
        SELECT state FROM
          initial => {state _ alpha; tStart _ i};
          num => {AddToken[[num[offset: tStart, length: i - tStart]]]; state _ alpha; tStart _ i};
          alpha => NULL;
          ENDCASE;
    i _ i + 1;
    ENDLOOP;
  END;  -- of Tokenize --

year: Year;
month: Month;
day: Day;
hour: Hour;
minute: Minute;
second: Second;
zoneAdjust: DeltaMinutes;
dst: BOOLEAN;

cumDays: ARRAY [FIRST[Month] - 1 .. LAST[Month]] OF CARDINAL
  = [0, 31, 60, 91, 121, 152, 182, 213, 244, 274, 305, 335, 366];

OutOfRange: ERROR = CODE;

CollectValue: PROCEDURE [t: num Token, low, high: CARDINAL]
  RETURNS [value: CARDINAL _ 0] =
  BEGIN
  FOR j: CharIndex IN [t.offset .. t.offset + t.length) DO
    -- We would like to catch a bounds fault here and turn it into OutOfRange.
    -- Unfortunately, the current implementation of catch phrases doesn't support
    -- this, since a catch phrase is only attached to procedure calls.  Accordingly,
    -- we have to do the test by hand.  The actual test is a bit too stringent, but
    -- it doesn't really matter.
    IF value > LAST[CARDINAL] / 10 - 1 THEN ERROR OutOfRange;
    value _ value * 10 + (s[j] - '0);
  ENDLOOP;
  IF ~(value IN [low .. high]) THEN ERROR OutOfRange
  END;  -- of CollectValue --

ParseDate: PROCEDURE [first: TokenIndex] RETURNS [next: TokenIndex] =
  BEGIN
  -- The following computation isn't exactly correct, since it doesn't account for the
  -- absence of leap days in century years not divisible by 400.  As it happens, the
  -- actual values for baseYear and LAST[EpochDays] are such that there is only one
  -- such day, and it doesn't affect the arithmetic.

  BogusMonth: ERROR = CODE;

  ParseMonth: PROCEDURE [t: alpha Token] RETURNS [month: Month] =
    BEGIN
    MonthNames: TYPE = ARRAY Month OF STRING;
    english: MonthNames _
      ["January"L, "February"L, "March"L, "April"L, "May"L, "June"L,
      "July"L, "August"L, "September"L, "October"L, "November"L, "December"L];
    roman: MonthNames _
      ["I"L, "II"L, "III"L, "IV"L, "V"L, "VI"L, "VII"L, "VIII"L, "IX"L, "X"L, "XI"L, "XII"L];
    table: POINTER TO MonthNames =
      SELECT String.UpperCase[s[t.offset]] FROM
        'I, 'V, 'X => @roman,
        ENDCASE => @english;
    ss: String.SubStringDescriptor _ [base: s, offset: t.offset, length: t.length];
    IF t.length < 3 THEN ERROR BogusMonth;
    FOR month IN Month DO
      mm: String.SubStringDescriptor _ [base: table[month], offset: 0, length: t.length];
      IF String.EquivalentSubStrings[@mm, @ss] THEN EXIT;
      REPEAT
      FINISHED => ERROR BogusMonth;
      ENDLOOP;
    END;  -- of ParseMonth --

  CollectYear: PROCEDURE [y: num Token] RETURNS [Year] =
    BEGIN
    RETURN[1900 + CollectValue[y, Inline.LowHalf[baseYear - 1900], 99
      ! OutOfRange => CONTINUE]];
    RETURN[CollectValue[y, Inline.LowHalf[baseYear], Inline.LowHalf[lastYear]]];
    END;  -- of CollectYear --

  CollectMonth: PROCEDURE [m: num Token] RETURNS [Month] = INLINE
    {RETURN[CollectValue[m, 1, 31]]};

  CollectDay: PROCEDURE [d: num Token, m: Month] RETURNS [Day] = INLINE
    {RETURN[CollectValue[d, 1, cumDays[m] - cumDays[m - 1]]]};

  DO
    ENABLE OutOfRange => GO TO bogus;
    second, third: TokenIndex;
    t: num Token;

    GetThird: PROCEDURE =
      BEGIN
      WITH token: input.tokens[third] SELECT FROM
        num => t _ token;
        ENDCASE => ERROR Unintelligible;
      END;  -- of GetThird --

    IF input.nTokens < first + 3 OR input.tokens[first].type = sep THEN GO TO bogus;
    -- Assert: 'first' is alpha or num and at least two tokens follow it.
    IF input.tokens[second_first+1].type = sep THEN second _ second + 1;
    -- Assert: 'second' is alpha or num.
    -- Ergo, second+1 < input.nTokens since input.tokens[input.nTokens-1].type = sep
    IF input.tokens[third_second+1].type = sep THEN
      {IF third = input.nTokens-1 THEN GO TO bogus; third _ third + 1};
    -- Assert: 'third' is alpha or num.  If we are really processing a date, 'third' will
    -- have to be numeric to make sense.  However, we might be processing something
    -- like Wednesday, 26 May 1981, in which there is a valid date, but
    -- 'first' isn't pointing to it yet (it's still on Wednesday).  So, we don't check
    -- that 'third' is numeric until we are sure that 'first' is pointing to something
    -- reasonable.
    WITH f: input.tokens[first] SELECT FROM
      alpha =>
        BEGIN
        -- The first token is alpha.  If it isn't a recognizable month, it might be
        -- some form of the day of the week.  Whatever it is, we simply skip
        -- over it (and the separator following it, if any) and try again.
        month _ ParseMonth[f ! BogusMonth => {first _ second; LOOP}];
        -- 'first' corresponds to a valid month.  We now require that 'second' be
        -- the day of the month and 'third' be the year.
        WITH d: input.tokens[second] SELECT FROM
          num => day _ CollectDay[d, month];
          ENDCASE => GO TO bogus;
        GetThird[];
        year _ CollectYear[t];
        END;
      num =>
        BEGIN
        GetThird[];
        WITH s: input.tokens[second] SELECT FROM
          alpha =>
            BEGIN
            -- The second token is alpha, so we will require it to be the month.
            month _ ParseMonth[s ! BogusMonth => GO TO bogus];
            -- Now we must decide if we have <day><month><year> or <year><month><day>
            day _ CollectDay[f, month ! OutOfRange => GO TO yearFirst];
            year _ CollectYear[t];
            EXITS
            yearFirst => {year _ CollectYear[f]; day _ CollectDay[t, month]};
            END;
          num =>
            BEGIN
            -- All three parts are numeric.
            year _ CollectYear[t ! OutOfRange => GO TO yearFirst];
            month _ CollectMonth[f ! OutOfRange => GO TO dayFirst];
            day _ CollectDay[s, month];
            EXITS
            yearFirst =>
              {year _ CollectYear[f]; month _ CollectMonth[s]; day _ CollectDay[t, month]};
            dayFirst => {month _ CollectMonth[s]; day _ CollectDay[f, month]};
            END;
          ENDCASE;
        END;
      ENDCASE;
    next _ third + 1;
    EXIT
    ENDLOOP;
  -- Be sure we weren't slipped a bogus leap year...
  IF month = 2 AND day = 29 AND ~LeapYear[year] THEN GO TO bogus;
  EXITS
  bogus => ERROR Unintelligible;
  END;  -- of ParseDate --

ParseTime: PROCEDURE [first: TokenIndex] RETURNS [next: TokenIndex] =
  BEGIN
  ENABLE OutOfRange => GO TO bogus;

  CollectHour: PROCEDURE [h: num Token] RETURNS [Hour] =
    {RETURN[CollectValue[h, 0, 23]]};

  CollectMinute: PROCEDURE [m: num Token] RETURNS [Minute] = INLINE
    {RETURN[CollectValue[m, 0, 59]]};

  CollectSecond: PROCEDURE [s: num Token] RETURNS [Second] = INLINE
    {RETURN[CollectValue[s, 0, 59]]};

  IsAMPM: PROCEDURE [t: TokenIndex] RETURNS [BOOLEAN] =
    BEGIN
    WITH m: input.tokens[t] SELECT FROM
      alpha =>
        IF m.length = 2 AND String.UpperCase[s[m.offset+1]] = 'M THEN
          BEGIN
          offset: Hour _ 0;
          SELECT String.UpperCase[s[m.offset]] FROM
            'A => offset _ 0;
            'P => offset _ 12;
            ENDCASE => RETURN [FALSE];
          IF ~(hour IN [1 .. 12]) THEN ERROR Unintelligible;
          hour _ (hour MOD 12) + offset;
          RETURN [TRUE];
          END;
      ENDCASE;
    RETURN [FALSE];
    END;  -- of IsAMPM --

  n: num Token;
  next _ first + 1;
  hour _ minute _ second _ 0;
  WITH f: input.tokens[first] SELECT FROM
    num => n _ f;
    sep => IF f.char = sentinel THEN {notes _ noTime; RETURN} ELSE GO TO bogus;
    ENDCASE => GO TO bogus;
  SELECT n.length FROM
    1, 2, 4, 6 => NULL;
    ENDCASE => GO TO bogus;
  hour _ CollectHour[[num[offset: n.offset, length: MIN[n.length, 2]]]];
  IF n.length <= 2 THEN
    BEGIN
    -- A separator must follow a 1- or 2- digit hour field.
    IF next + 1 >= input.nTokens OR input.tokens[next].type ~= sep THEN GO TO bogus;
    -- Assert: input.tokens[next+1] is alpha or num.
    next _ next + 1;
    WITH s: input.tokens[next] SELECT FROM
      num => n _ s;
      ENDCASE => GO TO bogus;
    SELECT n.length FROM
      2, 4 => next _ next + 1;
      ENDCASE => GO TO bogus;
    END
  ELSE {n.offset _ n.offset + 2; n.length _ n.length - 2};
  minute _ CollectMinute[[num[offset: n.offset, length: 2]]];
  -- Assert: 'next' indexes the token following the minutes.
  IF n.length > 2 THEN
  -- The minutes and seconds are concatenated.
  second _ CollectSecond[[num[offset: n.offset+2, length: 2]]]
  ELSE
  -- Now look for optional seconds field.  We assume it is present if there is a
  -- colon separator following the minutes.
  WITH sep: input.tokens[next] SELECT FROM
    sep =>
      IF sep.char = ': THEN
        -- Assert: input.tokens[next+1] is alpha or num.
        WITH s: input.tokens[next+1] SELECT FROM
          num => {second _ CollectSecond[s]; next _ next + 2};
          ENDCASE => GO TO bogus;
    ENDCASE;
  -- Assert: 'next' indexes the token following the last time part (minutes or seconds).
  WITH s: input.tokens[next] SELECT FROM
    sep => IF s.char ~= sentinel AND IsAMPM[next+1] THEN next _ next + 2;
    alpha => IF IsAMPM[next] THEN next _ next + 1;
    ENDCASE;
  EXITS
  bogus => ERROR Unintelligible;
  END;  -- of ParseTime --

ParseZone: PROCEDURE [first: TokenIndex] RETURNS [next: TokenIndex] =
  BEGIN

  BadZone: ERROR = CODE;

  CollectSymbolic: PROCEDURE [z: alpha Token] =
    BEGIN
    char: CHARACTER _ s[z.offset];
    SELECT z.length FROM
      1 =>
        BEGIN
        zones: PACKED ARRAY ZoneIndex OF CHARACTER =
          ['M, 'L, 'K, 'I, 'H, 'G, 'F, 'E, 'D, 'C, 'B, 'A,
           'Z,
           'N, 'O, 'P, 'Q, 'R, 'S, 'T, 'U, 'V, 'W, 'X, 'Y];
        FOR hour: ZoneIndex IN ZoneIndex DO
          IF char = zones[hour] THEN {zoneAdjust _ hour*minutesPerHour; EXIT};
          REPEAT
          FINISHED => GO TO badZone;
          ENDLOOP;
        END;
      3 =>
        BEGIN
        naZones: PACKED ARRAY NAZones OF CHARACTER =
          ['B, 'H, 'Y, 'P, 'M, 'C, 'E, 'A];
        IF String.UpperCase[s[z.offset+2]] ~= 'T THEN GO TO badZone;
        SELECT String.UpperCase[s[z.offset+1]] FROM
          'S, 'M => NULL;  -- treat "mean" same as "standard"
          'D => dst _ TRUE;
          ENDCASE => GO TO badZone;
        SELECT char FROM
          'G => IF dst THEN GO TO badZone;
          'N => IF dst THEN GO TO badZone ELSE zoneAdjust _ -(3*minutesPerHour+30);
          ENDCASE =>
            FOR hour: NAZones IN NAZones DO
              IF char = naZones[hour] THEN {zoneAdjust _ hour*minutesPerHour; EXIT};
              REPEAT
              FINISHED => GO TO badZone;
              ENDLOOP;
        END;
      ENDCASE => GO TO badZone;
    EXITS
    badZone => ERROR BadZone;
    END;  -- of CollectSymbolic --

  CollectAbsolute: PROCEDURE [z: num Token] RETURNS [DeltaMinutes] =
    BEGIN
    hour: Hour;
    minute: Minute;
    IF z.length ~= 4 THEN ERROR OutOfRange;
    hour _ CollectValue[[num[offset: z.offset, length: 2]], 0, 23];
    minute _ CollectValue[[num[offset: z.offset + 2, length: 2]], 0, 59];
    RETURN [hour * minutesPerHour + minute];
    END;  -- of CollectAbsolute --

  zoneAdjust _ 0;
  dst _ FALSE;
  IF notes = noTime THEN RETURN;
  next _ first;
  WITH z: input.tokens[next] SELECT FROM
    sep =>
      BEGIN
      zone: Token;
      SELECT z.char FROM
        Ascii.SP, '+, '- => zone _ input.tokens[next + 1];
        ENDCASE => GO TO noZone;  -- includes sentinel
      WITH zone: zone SELECT FROM
        num =>
          SELECT z.char FROM
            Ascii.SP => GO TO noZone;
            '+ => zoneAdjust _ CollectAbsolute[zone];
            '- => zoneAdjust _ -CollectAbsolute[zone];
            ENDCASE;  -- can't happen
        alpha =>
          IF z.char = '+ THEN GO TO bogus
          ELSE CollectSymbolic
            [zone ! BadZone => IF z.char = Ascii.SP THEN GO TO noZone ELSE GO TO bogus];
        ENDCASE;  -- can't happen
      next _ next + 1;
      END;
    alpha => CollectSymbolic[z ! BadZone => GO TO noZone];
    ENDCASE => GO TO noZone;
  EXITS
  bogus => ERROR Unintelligible;
  noZone => notes _ noZone;
  END;  -- of ParseZone --

ConsumeSpace: PROCEDURE [t: TokenIndex] RETURNS [TokenIndex] =
  BEGIN
  WITH s: input.tokens[t] SELECT FROM
    sep => IF s.char = Ascii.SP THEN RETURN[t + 1];
    ENDCASE;
  RETURN[t];
  END;  -- of ConsumeSpace --

LeapYear: PROCEDURE [year: Year] RETURNS [BOOLEAN] =
  {RETURN[year MOD 4 = 0 AND (year MOD 100 ~= 0 OR year MOD 400 = 0)]};

YearBoundaries: PROCEDURE [year: Year, span: LONG CARDINAL]
  RETURNS [LONG CARDINAL] = INLINE
  -- The following expression computes the number of years y in
  -- [FIRST[Year]..year) for which y MOD span is 0.
  {RETURN[(year + span - 1) / span - (baseYear + span - 1) / span]};

DetermineZoneCorrection: PROCEDURE =
  -- We need to compute the local time parameters in effect at this zone on the
  -- date in question.  Note that this is an imperfect simulation, since it assumes
  -- uniform dates and times for start and end of daylight savings time within
  -- the local zone.
  BEGIN

  FirstSundayAfter: PROCEDURE [ed: EpochDays] RETURNS [EpochDays] =
    {RETURN [ed+7-((ed+baseDay) MOD 7)]};

  ltp: TimeDefs.LocalTimeParameters _
  --  [direction: west, zone: 8, zoneMinutes: 0, beginDST: , endDST: ];
  -- ltp _ System.GetLocalTimeParameters
  --   [ ! System.LocalTimeParametersUnknown =>
  --   {notes_IF notes = noZone THEN zoneGuessed ELSE timeAndZoneGuessed;CONTINUE}];
  ltp _ TimeDefs.currentParameters^;
  ltp.beginDST _ Inline.LowHalf[FirstSundayAfter
    [epochToJan1 + --Apr23-- (112 + (IF LeapYear[year] THEN 1 ELSE 0))] - epochToJan1];
  ltp.endDST _ Inline.LowHalf[FirstSundayAfter
    [epochToJan1 + --Oct24-- (294 + (IF LeapYear[year] THEN 1 ELSE 0))] - epochToJan1];
  zoneAdjust _ ltp.zone * minutesPerHour + ltp.zoneminutes;
  IF ltp.direction = west THEN zoneAdjust _ - zoneAdjust;
  dst _ SELECT jan1ToDate FROM
    IN (ltp.beginDST .. ltp.endDST) =>  TRUE,
    = ltp.beginDST =>  (hour >= 2),
    = ltp.endDST =>  (hour < 2),
    ENDCASE => FALSE;
  END;  -- of DetermineZoneCorrection --

-- Main Body of Parse --

nextToken: TokenIndex _ SUCC[FIRST[TokenIndex]];
epochToJan1: EpochDays;
jan1ToDate: YearDays;
input: POINTER TO Tokens _ Storage.Node[SIZE[Tokens] + 20 * SIZE[Token]];
input.nTokens _ 0;
input.length _ 20;
notes _ normal;
IF ~Tokenize[] THEN ERROR Unintelligible;
-- Assert:  The input has been tokenized such that:
--   input.tokens[0] = input.tokens[input.nTokens-1] = [sep[sentinel]]
--   for all i IN (0..input.nTokens-1):
--      if input.tokens[i].type = sep, then
--         input.tokens[i-1].type ~= sep and input.tokens[i+1].type ~= sep
BEGIN
nextToken _ ParseDate[nextToken ! Unintelligible => GO TO tryTimeFirst];
nextToken _ ConsumeSpace[nextToken];
nextToken _ ParseTime[nextToken];
[] _ ParseZone[nextToken];
EXITS
tryTimeFirst =>
  BEGIN
  nextToken _ ParseTime[nextToken];
  nextToken _ ParseZone[nextToken];
  nextToken _ ConsumeSpace[nextToken];
  [] _ ParseDate[nextToken];
  END;
END;

epochToJan1 _ (year - baseYear) * 365
  + YearBoundaries[year, 4] - YearBoundaries[year, 100] + YearBoundaries[year, 400];
jan1ToDate _
  cumDays[month - 1] + (day - 1) - (IF ~LeapYear[year] AND month > 2 THEN 1 ELSE 0);
IF notes ~= normal THEN DetermineZoneCorrection[];
-- The following gross arithmetic is required to avoid overflows.
dt _ ((epochToJan1 + jan1ToDate) + (gmtEpoch / secondsPerDay)) * secondsPerDay
    + ((hour - (IF dst THEN 1 ELSE 0)) * minutesPerHour + minute - zoneAdjust)
      * secondsPerMinute
    + second;
Storage.Free[input];
END;  -- of Parse --

END.
(635)\f1