gcc/ada/libgnat/g-catiio.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --                G N A T . C A L E N D A R . T I M E _ I O                 --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                     Copyright (C) 1999-2020, AdaCore                     --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 with Ada.Calendar;            use Ada.Calendar;
  33 with Ada.Characters.Handling;
  34 with Ada.Strings.Unbounded;   use Ada.Strings.Unbounded;
  35 with Ada.Text_IO;
  36
  37 with GNAT.Case_Util;
  38
  39 package body GNAT.Calendar.Time_IO is
  40
  41    type Month_Name is
  42      (January,
  43       February,
  44       March,
  45       April,
  46       May,
  47       June,
  48       July,
  49       August,
  50       September,
  51       October,
  52       November,
  53       December);
  54
  55    function Month_Name_To_Number
  56      (Str : String) return Ada.Calendar.Month_Number;
  57    --  Converts a string that contains an abbreviated month name to a month
  58    --  number. Constraint_Error is raised if Str is not a valid month name.
  59    --  Comparison is case insensitive
  60
  61    type Padding_Mode is (None, Zero, Space);
  62
  63    type Sec_Number is mod 2 ** 64;
  64    --  Type used to compute the number of seconds since 01/01/1970. A 32 bit
  65    --  number will cover only a period of 136 years. This means that for date
  66    --  past 2106 the computation is not possible. A 64 bits number should be
  67    --  enough for a very large period of time.
  68
  69    -----------------------
  70    -- Local Subprograms --
  71    -----------------------
  72
  73    function Am_Pm (H : Natural) return String;
  74    --  Return AM or PM depending on the hour H
  75
  76    function Hour_12 (H : Natural) return Positive;
  77    --  Convert a 1-24h format to a 0-12 hour format
  78
  79    function Image (Str : String; Length : Natural := 0) return String;
  80    --  Return Str capitalized and cut to length number of characters. If
  81    --  length is 0, then no cut operation is performed.
  82
  83    function Image
  84      (N       : Sec_Number;
  85       Padding : Padding_Mode := Zero;
  86       Length  : Natural := 0) return String;
  87    --  Return image of N. This number is eventually padded with zeros or spaces
  88    --  depending of the length required. If length is 0 then no padding occurs.
  89
  90    function Image
  91      (N       : Natural;
  92       Padding : Padding_Mode := Zero;
  93       Length  : Natural := 0) return String;
  94    --  As above with N provided in Integer format
  95
  96    procedure Parse_ISO_8861_UTC
  97       (Date    : String;
  98        Time    : out Ada.Calendar.Time;
  99        Success : out Boolean);
 100    --  Subsidiary of function Value. It parses the string Date, interpreted as
 101    --  an ISO 8861 time representation, and returns corresponding Time value.
 102    --  Success is set to False when the string is not a supported ISO 8861
 103    --  date. The following regular expression defines the supported format:
 104    --
 105    --    (yyyymmdd | yyyy'-'mm'-'dd)'T'(hhmmss | hh':'mm':'ss)
 106    --      [ ('Z' | ('.' | ',') s{s} | ('+'|'-')hh':'mm) ]
 107    --
 108    --  Trailing characters (in particular spaces) are not allowed.
 109    --
 110    --  Examples:
 111    --
 112    --    2017-04-14T14:47:06    20170414T14:47:06    20170414T144706
 113    --    2017-04-14T14:47:06,12 20170414T14:47:06.12
 114    --    2017-04-14T19:47:06+05 20170414T09:00:06-05:47
 115
 116    -----------
 117    -- Am_Pm --
 118    -----------
 119
 120    function Am_Pm (H : Natural) return String is
 121    begin
 122       if H = 0 or else H > 12 then
 123          return "PM";
 124       else
 125          return "AM";
 126       end if;
 127    end Am_Pm;
 128
 129    -------------
 130    -- Hour_12 --
 131    -------------
 132
 133    function Hour_12 (H : Natural) return Positive is
 134    begin
 135       if H = 0 then
 136          return 12;
 137       elsif H <= 12 then
 138          return H;
 139       else --  H > 12
 140          return H - 12;
 141       end if;
 142    end Hour_12;
 143
 144    -----------
 145    -- Image --
 146    -----------
 147
 148    function Image
 149      (Str    : String;
 150       Length : Natural := 0) return String
 151    is
 152       use Ada.Characters.Handling;
 153       Local : constant String :=
 154                 To_Upper (Str (Str'First)) &
 155                   To_Lower (Str (Str'First + 1 .. Str'Last));
 156    begin
 157       if Length = 0 then
 158          return Local;
 159       else
 160          return Local (1 .. Length);
 161       end if;
 162    end Image;
 163
 164    -----------
 165    -- Image --
 166    -----------
 167
 168    function Image
 169      (N       : Natural;
 170       Padding : Padding_Mode := Zero;
 171       Length  : Natural := 0) return String
 172    is
 173    begin
 174       return Image (Sec_Number (N), Padding, Length);
 175    end Image;
 176
 177    function Image
 178      (N       : Sec_Number;
 179       Padding : Padding_Mode := Zero;
 180       Length  : Natural := 0) return String
 181    is
 182       function Pad_Char return String;
 183
 184       --------------
 185       -- Pad_Char --
 186       --------------
 187
 188       function Pad_Char return String is
 189       begin
 190          case Padding is
 191             when None  => return "";
 192             when Zero  => return "00";
 193             when Space => return "  ";
 194          end case;
 195       end Pad_Char;
 196
 197       --  Local Declarations
 198
 199       NI  : constant String := Sec_Number'Image (N);
 200       NIP : constant String := Pad_Char & NI (2 .. NI'Last);
 201
 202    --  Start of processing for Image
 203
 204    begin
 205       if Length = 0 or else Padding = None then
 206          return NI (2 .. NI'Last);
 207       else
 208          return NIP (NIP'Last - Length + 1 .. NIP'Last);
 209       end if;
 210    end Image;
 211
 212    -----------
 213    -- Image --
 214    -----------
 215
 216    function Image
 217      (Date    : Ada.Calendar.Time;
 218       Picture : Picture_String) return String
 219    is
 220       Padding : Padding_Mode := Zero;
 221       --  Padding is set for one directive
 222
 223       Result : Unbounded_String;
 224
 225       Year       : Year_Number;
 226       Month      : Month_Number;
 227       Day        : Day_Number;
 228       Hour       : Hour_Number;
 229       Minute     : Minute_Number;
 230       Second     : Second_Number;
 231       Sub_Second : Second_Duration;
 232
 233       P : Positive;
 234
 235    begin
 236       --  Get current time in split format
 237
 238       Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);
 239
 240       --  Null picture string is error
 241
 242       if Picture = "" then
 243          raise Picture_Error with "null picture string";
 244       end if;
 245
 246       --  Loop through characters of picture string, building result
 247
 248       Result := Null_Unbounded_String;
 249       P := Picture'First;
 250       while P <= Picture'Last loop
 251
 252          --  A directive has the following format "%[-_]."
 253
 254          if Picture (P) = '%' then
 255             Padding := Zero;
 256
 257             if P = Picture'Last then
 258                raise Picture_Error with "picture string ends with '%";
 259             end if;
 260
 261             --  Check for GNU extension to change the padding
 262
 263             if Picture (P + 1) = '-' then
 264                Padding := None;
 265                P := P + 1;
 266
 267             elsif Picture (P + 1) = '_' then
 268                Padding := Space;
 269                P := P + 1;
 270             end if;
 271
 272             if P = Picture'Last then
 273                raise Picture_Error with "picture string ends with '- or '_";
 274             end if;
 275
 276             case Picture (P + 1) is
 277
 278                --  Literal %
 279
 280                when '%' =>
 281                   Result := Result & '%';
 282
 283                --  A newline
 284
 285                when 'n' =>
 286                   Result := Result & ASCII.LF;
 287
 288                --  A horizontal tab
 289
 290                when 't' =>
 291                   Result := Result & ASCII.HT;
 292
 293                --  Hour (00..23)
 294
 295                when 'H' =>
 296                   Result := Result & Image (Hour, Padding, 2);
 297
 298                --  Hour (01..12)
 299
 300                when 'I' =>
 301                   Result := Result & Image (Hour_12 (Hour), Padding, 2);
 302
 303                --  Hour ( 0..23)
 304
 305                when 'k' =>
 306                   Result := Result & Image (Hour, Space, 2);
 307
 308                --  Hour ( 1..12)
 309
 310                when 'l' =>
 311                   Result := Result & Image (Hour_12 (Hour), Space, 2);
 312
 313                --  Minute (00..59)
 314
 315                when 'M' =>
 316                   Result := Result & Image (Minute, Padding, 2);
 317
 318                --  AM/PM
 319
 320                when 'p' =>
 321                   Result := Result & Am_Pm (Hour);
 322
 323                --  Time, 12-hour (hh:mm:ss [AP]M)
 324
 325                when 'r' =>
 326                   Result := Result &
 327                     Image (Hour_12 (Hour), Padding, Length => 2) & ':' &
 328                     Image (Minute, Padding, Length => 2) & ':' &
 329                     Image (Second, Padding, Length => 2) & ' ' &
 330                     Am_Pm (Hour);
 331
 332                --   Seconds since 1970-01-01  00:00:00 UTC
 333                --   (a nonstandard extension)
 334
 335                when 's' =>
 336                   declare
 337                      --  Compute the number of seconds using Ada.Calendar.Time
 338                      --  values rather than Julian days to account for Daylight
 339                      --  Savings Time.
 340
 341                      Neg : Boolean  := False;
 342                      Sec : Duration := Date - Time_Of (1970, 1, 1, 0.0);
 343
 344                   begin
 345                      --  Avoid rounding errors and perform special processing
 346                      --  for dates earlier than the Unix Epoc.
 347
 348                      if Sec > 0.0 then
 349                         Sec := Sec - 0.5;
 350                      elsif Sec < 0.0 then
 351                         Neg := True;
 352                         Sec := abs (Sec + 0.5);
 353                      end if;
 354
 355                      --  Prepend a minus sign to the result since Sec_Number
 356                      --  cannot handle negative numbers.
 357
 358                      if Neg then
 359                         Result :=
 360                           Result & "-" & Image (Sec_Number (Sec), None);
 361                      else
 362                         Result := Result & Image (Sec_Number (Sec), None);
 363                      end if;
 364                   end;
 365
 366                --  Second (00..59)
 367
 368                when 'S' =>
 369                   Result := Result & Image (Second, Padding, Length => 2);
 370
 371                --  Milliseconds (3 digits)
 372                --  Microseconds (6 digits)
 373                --  Nanoseconds  (9 digits)
 374
 375                when 'i' | 'e' | 'o' =>
 376                   declare
 377                      Sub_Sec : constant Long_Integer :=
 378                                  Long_Integer (Sub_Second * 1_000_000_000);
 379
 380                      Img1  : constant String := Sub_Sec'Img;
 381                      Img2  : constant String :=
 382                                "00000000" & Img1 (Img1'First + 1 .. Img1'Last);
 383                      Nanos : constant String :=
 384                                Img2 (Img2'Last - 8 .. Img2'Last);
 385
 386                   begin
 387                      case Picture (P + 1) is
 388                         when 'i' =>
 389                            Result := Result &
 390                              Nanos (Nanos'First .. Nanos'First + 2);
 391
 392                         when 'e' =>
 393                            Result := Result &
 394                              Nanos (Nanos'First .. Nanos'First + 5);
 395
 396                         when 'o' =>
 397                            Result := Result & Nanos;
 398
 399                         when others =>
 400                            null;
 401                      end case;
 402                   end;
 403
 404                --  Time, 24-hour (hh:mm:ss)
 405
 406                when 'T' =>
 407                   Result := Result &
 408                     Image (Hour, Padding, Length => 2)   & ':' &
 409                     Image (Minute, Padding, Length => 2) & ':' &
 410                     Image (Second, Padding, Length => 2);
 411
 412                --  Locale's abbreviated weekday name (Sun..Sat)
 413
 414                when 'a' =>
 415                   Result := Result &
 416                     Image (Day_Name'Image (Day_Of_Week (Date)), 3);
 417
 418                --  Locale's full weekday name, variable length
 419                --  (Sunday..Saturday)
 420
 421                when 'A' =>
 422                   Result := Result &
 423                     Image (Day_Name'Image (Day_Of_Week (Date)));
 424
 425                --  Locale's abbreviated month name (Jan..Dec)
 426
 427                when 'b' | 'h' =>
 428                   Result := Result &
 429                     Image (Month_Name'Image (Month_Name'Val (Month - 1)), 3);
 430
 431                --  Locale's full month name, variable length
 432                --  (January..December).
 433
 434                when 'B' =>
 435                   Result := Result &
 436                     Image (Month_Name'Image (Month_Name'Val (Month - 1)));
 437
 438                --  Locale's date and time (Sat Nov 04 12:02:33 EST 1989)
 439
 440                when 'c' =>
 441                   case Padding is
 442                      when Zero =>
 443                         Result := Result & Image (Date, "%a %b %d %T %Y");
 444                      when Space =>
 445                         Result := Result & Image (Date, "%a %b %_d %_T %Y");
 446                      when None =>
 447                         Result := Result & Image (Date, "%a %b %-d %-T %Y");
 448                   end case;
 449
 450                --   Day of month (01..31)
 451
 452                when 'd' =>
 453                   Result := Result & Image (Day, Padding, 2);
 454
 455                --  Date (mm/dd/yy)
 456
 457                when 'D' | 'x' =>
 458                   Result := Result &
 459                               Image (Month, Padding, 2) & '/' &
 460                               Image (Day, Padding, 2) & '/' &
 461                               Image (Year, Padding, 2);
 462
 463                --  Day of year (001..366)
 464
 465                when 'j' =>
 466                   Result := Result & Image (Day_In_Year (Date), Padding, 3);
 467
 468                --  Month (01..12)
 469
 470                when 'm' =>
 471                   Result := Result & Image (Month, Padding, 2);
 472
 473                --  Week number of year with Sunday as first day of week
 474                --  (00..53)
 475
 476                when 'U' =>
 477                   declare
 478                      Offset : constant Natural :=
 479                                 (Julian_Day (Year, 1, 1) + 1) mod 7;
 480
 481                      Week : constant Natural :=
 482                               1 + ((Day_In_Year (Date) - 1) + Offset) / 7;
 483
 484                   begin
 485                      Result := Result & Image (Week, Padding, 2);
 486                   end;
 487
 488                --  Day of week (0..6) with 0 corresponding to Sunday
 489
 490                when 'w' =>
 491                   declare
 492                      DOW : constant Natural range 0 .. 6 :=
 493                              (if Day_Of_Week (Date) = Sunday
 494                               then 0
 495                               else Day_Name'Pos (Day_Of_Week (Date)));
 496                   begin
 497                      Result := Result & Image (DOW, Length => 1);
 498                   end;
 499
 500                --  Week number of year with Monday as first day of week
 501                --  (00..53)
 502
 503                when 'W' =>
 504                   Result := Result & Image (Week_In_Year (Date), Padding, 2);
 505
 506                --  Last two digits of year (00..99)
 507
 508                when 'y' =>
 509                   declare
 510                      Y : constant Natural := Year - (Year / 100) * 100;
 511                   begin
 512                      Result := Result & Image (Y, Padding, 2);
 513                   end;
 514
 515                --   Year (1970...)
 516
 517                when 'Y' =>
 518                   Result := Result & Image (Year, None, 4);
 519
 520                when others =>
 521                   raise Picture_Error with
 522                     "unknown format character in picture string";
 523             end case;
 524
 525             --  Skip past % and format character
 526
 527             P := P + 2;
 528
 529          --  Character other than % is copied into the result
 530
 531          else
 532             Result := Result & Picture (P);
 533             P := P + 1;
 534          end if;
 535       end loop;
 536
 537       return To_String (Result);
 538    end Image;
 539
 540    --------------------------
 541    -- Month_Name_To_Number --
 542    --------------------------
 543
 544    function Month_Name_To_Number
 545      (Str : String) return Ada.Calendar.Month_Number
 546    is
 547       subtype String3 is String (1 .. 3);
 548       Abbrev_Upper_Month_Names :
 549         constant array (Ada.Calendar.Month_Number) of String3 :=
 550          ("JAN", "FEB", "MAR", "APR", "MAY", "JUN",
 551           "JUL", "AUG", "SEP", "OCT", "NOV", "DEC");
 552       --  Short version of the month names, used when parsing date strings
 553
 554       S : String := Str;
 555
 556    begin
 557       GNAT.Case_Util.To_Upper (S);
 558
 559       for J in Abbrev_Upper_Month_Names'Range loop
 560          if Abbrev_Upper_Month_Names (J) = S then
 561             return J;
 562          end if;
 563       end loop;
 564
 565       return Abbrev_Upper_Month_Names'First;
 566    end Month_Name_To_Number;
 567
 568    ------------------------
 569    -- Parse_ISO_8861_UTC --
 570    ------------------------
 571
 572    procedure Parse_ISO_8861_UTC
 573       (Date    : String;
 574        Time    : out Ada.Calendar.Time;
 575        Success : out Boolean)
 576    is
 577       Index : Positive := Date'First;
 578       --  The current character scan index. After a call to Advance, Index
 579       --  points to the next character.
 580
 581       End_Of_Source_Reached : exception;
 582       --  An exception used to signal that the scan pointer has reached the
 583       --  end of the source string.
 584
 585       Wrong_Syntax : exception;
 586       --  An exception used to signal that the scan pointer has reached an
 587       --  unexpected character in the source string.
 588
 589       procedure Advance;
 590       pragma Inline (Advance);
 591       --  Past the current character of Date
 592
 593       procedure Advance_Digits (Num_Digits : Positive);
 594       pragma Inline (Advance_Digits);
 595       --  Past the given number of digit characters
 596
 597       function Scan_Day return Day_Number;
 598       pragma Inline (Scan_Day);
 599       --  Scan the two digits of a day number and return its value
 600
 601       function Scan_Hour return Hour_Number;
 602       pragma Inline (Scan_Hour);
 603       --  Scan the two digits of an hour number and return its value
 604
 605       function Scan_Minute return Minute_Number;
 606       pragma Inline (Scan_Minute);
 607       --  Scan the two digits of a minute number and return its value
 608
 609       function Scan_Month return Month_Number;
 610       pragma Inline (Scan_Month);
 611       --  Scan the two digits of a month number and return its value
 612
 613       function Scan_Second return Second_Number;
 614       pragma Inline (Scan_Second);
 615       --  Scan the two digits of a second number and return its value
 616
 617       function Scan_Separator (Expected_Symbol : Character) return Boolean;
 618       pragma Inline (Scan_Separator);
 619       --  If the current symbol matches the Expected_Symbol then advance the
 620       --  scanner index and return True; otherwise do nothing and return False
 621
 622       procedure Scan_Separator (Required : Boolean; Separator : Character);
 623       pragma Inline (Scan_Separator);
 624       --  If Required then check that the current character matches Separator
 625       --  and advance the scanner index; if not Required then do nothing.
 626
 627       function Scan_Subsecond return Second_Duration;
 628       pragma Inline (Scan_Subsecond);
 629       --  Scan all the digits of a subsecond number and return its value
 630
 631       function Scan_Year return Year_Number;
 632       pragma Inline (Scan_Year);
 633       --  Scan the four digits of a year number and return its value
 634
 635       function Symbol return Character;
 636       pragma Inline (Symbol);
 637       --  Return the current character being scanned
 638
 639       -------------
 640       -- Advance --
 641       -------------
 642
 643       procedure Advance is
 644       begin
 645          --  Signal the end of the source string. This stops a complex scan by
 646          --  bottoming up any recursive calls till control reaches routine Scan
 647          --  which handles the exception. Certain scanning scenarios may handle
 648          --  this exception on their own.
 649
 650          if Index > Date'Last then
 651             raise End_Of_Source_Reached;
 652
 653          --  Advance the scan pointer as long as there are characters to scan,
 654          --  in other words, the scan pointer has not passed the end of the
 655          --  source string.
 656
 657          else
 658             Index := Index + 1;
 659          end if;
 660       end Advance;
 661
 662       --------------------
 663       -- Advance_Digits --
 664       --------------------
 665
 666       procedure Advance_Digits (Num_Digits : Positive) is
 667       begin
 668          for J in 1 .. Num_Digits loop
 669             if Symbol not in '0' .. '9' then
 670                raise Wrong_Syntax;
 671             end if;
 672
 673             Advance; --  past digit
 674          end loop;
 675       end Advance_Digits;
 676
 677       --------------
 678       -- Scan_Day --
 679       --------------
 680
 681       function Scan_Day return Day_Number is
 682          From : constant Positive := Index;
 683       begin
 684          Advance_Digits (Num_Digits => 2);
 685          return Day_Number'Value (Date (From .. Index - 1));
 686       end Scan_Day;
 687
 688       ---------------
 689       -- Scan_Hour --
 690       ---------------
 691
 692       function Scan_Hour return Hour_Number is
 693          From : constant Positive := Index;
 694       begin
 695          Advance_Digits (Num_Digits => 2);
 696          return Hour_Number'Value (Date (From .. Index - 1));
 697       end Scan_Hour;
 698
 699       -----------------
 700       -- Scan_Minute --
 701       -----------------
 702
 703       function Scan_Minute return Minute_Number is
 704          From : constant Positive := Index;
 705       begin
 706          Advance_Digits (Num_Digits => 2);
 707          return Minute_Number'Value (Date (From .. Index - 1));
 708       end Scan_Minute;
 709
 710       ----------------
 711       -- Scan_Month --
 712       ----------------
 713
 714       function Scan_Month return Month_Number is
 715          From : constant Positive := Index;
 716       begin
 717          Advance_Digits (Num_Digits => 2);
 718          return Month_Number'Value (Date (From .. Index - 1));
 719       end Scan_Month;
 720
 721       -----------------
 722       -- Scan_Second --
 723       -----------------
 724
 725       function Scan_Second return Second_Number is
 726          From : constant Positive := Index;
 727       begin
 728          Advance_Digits (Num_Digits => 2);
 729          return Second_Number'Value (Date (From .. Index - 1));
 730       end Scan_Second;
 731
 732       --------------------
 733       -- Scan_Separator --
 734       --------------------
 735
 736       function Scan_Separator (Expected_Symbol : Character) return Boolean is
 737       begin
 738          if Symbol = Expected_Symbol then
 739             Advance;
 740             return True;
 741          else
 742             return False;
 743          end if;
 744       end Scan_Separator;
 745
 746       --------------------
 747       -- Scan_Separator --
 748       --------------------
 749
 750       procedure Scan_Separator (Required : Boolean; Separator : Character) is
 751       begin
 752          if Required then
 753             if Symbol /= Separator then
 754                raise Wrong_Syntax;
 755             end if;
 756
 757             Advance; --  Past the separator
 758          end if;
 759       end Scan_Separator;
 760
 761       --------------------
 762       -- Scan_Subsecond --
 763       --------------------
 764
 765       function Scan_Subsecond return Second_Duration is
 766          From : constant Positive := Index;
 767       begin
 768          Advance_Digits (Num_Digits => 1);
 769
 770          while Symbol in '0' .. '9'
 771            and then Index < Date'Length
 772          loop
 773             Advance;
 774          end loop;
 775
 776          if Symbol not in '0' .. '9' then
 777             raise Wrong_Syntax;
 778          end if;
 779
 780          Advance;
 781          return Second_Duration'Value ("0." & Date (From .. Index - 1));
 782       end Scan_Subsecond;
 783
 784       ---------------
 785       -- Scan_Year --
 786       ---------------
 787
 788       function Scan_Year return Year_Number is
 789          From : constant Positive := Index;
 790       begin
 791          Advance_Digits (Num_Digits => 4);
 792          return Year_Number'Value (Date (From .. Index - 1));
 793       end Scan_Year;
 794
 795       ------------
 796       -- Symbol --
 797       ------------
 798
 799       function Symbol return Character is
 800       begin
 801          --  Signal the end of the source string. This stops a complex scan by
 802          --  bottoming up any recursive calls till control reaches routine Scan
 803          --  which handles the exception. Certain scanning scenarios may handle
 804          --  this exception on their own.
 805
 806          if Index > Date'Last then
 807             raise End_Of_Source_Reached;
 808
 809          else
 810             return Date (Index);
 811          end if;
 812       end Symbol;
 813
 814       --  Local variables
 815
 816       Date_Separator : constant Character := '-';
 817       Hour_Separator : constant Character := ':';
 818
 819       Day          : Day_Number;
 820       Month        : Month_Number;
 821       Year         : Year_Number;
 822       Hour         : Hour_Number     := 0;
 823       Minute       : Minute_Number   := 0;
 824       Second       : Second_Number   := 0;
 825       Subsec       : Second_Duration := 0.0;
 826
 827       Local_Hour   : Hour_Number     := 0;
 828       Local_Minute : Minute_Number   := 0;
 829       Local_Sign   : Character       := ' ';
 830       Local_Disp   : Duration;
 831
 832       Sep_Required : Boolean := False;
 833       --  True if a separator is seen (and therefore required after it!)
 834
 835    begin
 836       --  Parse date
 837
 838       Year := Scan_Year;
 839       Sep_Required := Scan_Separator (Date_Separator);
 840
 841       Month := Scan_Month;
 842       Scan_Separator (Sep_Required, Date_Separator);
 843
 844       Day := Scan_Day;
 845
 846       if Index < Date'Last and then Symbol = 'T' then
 847          Advance;
 848
 849          --  Parse time
 850
 851          Hour := Scan_Hour;
 852          Sep_Required := Scan_Separator (Hour_Separator);
 853
 854          Minute := Scan_Minute;
 855          Scan_Separator (Sep_Required, Hour_Separator);
 856
 857          Second := Scan_Second;
 858
 859          --  [('Z' | ('.' | ',') s{s} | ('+'|'-')hh:mm)]
 860
 861          if Index <= Date'Last then
 862
 863             --  Suffix 'Z' just confirms that this is an UTC time. No further
 864             --  action needed.
 865
 866             if Symbol = 'Z' then
 867                Advance;
 868
 869             --  A decimal fraction shall have at least one digit, and has as
 870             --  many digits as supported by the underlying implementation.
 871             --  The valid decimal separators are those specified in ISO 31-0,
 872             --  i.e. the comma [,] or full stop [.]. Of these, the comma is
 873             --  the preferred separator of ISO-8861.
 874
 875             elsif Symbol = ',' or else Symbol = '.' then
 876                Advance; --  past decimal separator
 877                Subsec := Scan_Subsecond;
 878
 879             --  Difference between local time and UTC: It shall be expressed
 880             --  as positive (i.e. with the leading plus sign [+]) if the local
 881             --  time is ahead of or equal to UTC of day and as negative (i.e.
 882             --  with the leading minus sign [-]) if it is behind UTC of day.
 883             --  The minutes time element of the difference may only be omitted
 884             --  if the difference between the time scales is exactly an
 885             --  integral number of hours.
 886
 887             elsif Symbol = '+' or else Symbol = '-' then
 888                Local_Sign := Symbol;
 889                Advance;
 890                Local_Hour := Scan_Hour;
 891
 892                --  Past ':'
 893
 894                if Index < Date'Last and then Symbol = Hour_Separator then
 895                   Advance;
 896                   Local_Minute := Scan_Minute;
 897                end if;
 898
 899                --  Compute local displacement
 900
 901                Local_Disp := Local_Hour * 3600.0 + Local_Minute * 60.0;
 902             else
 903                raise Wrong_Syntax;
 904             end if;
 905          end if;
 906       end if;
 907
 908       --  Sanity checks. The check on Index ensures that there are no trailing
 909       --  characters.
 910
 911       if Index /= Date'Length + 1
 912         or else not Year'Valid
 913         or else not Month'Valid
 914         or else not Day'Valid
 915         or else not Hour'Valid
 916         or else not Minute'Valid
 917         or else not Second'Valid
 918         or else not Subsec'Valid
 919         or else not Local_Hour'Valid
 920         or else not Local_Minute'Valid
 921       then
 922          raise Wrong_Syntax;
 923       end if;
 924
 925       --  Compute time without local displacement
 926
 927       if Local_Sign = ' ' then
 928          Time := Time_Of (Year, Month, Day, Hour, Minute, Second, Subsec);
 929
 930       --  Compute time with positive local displacement
 931
 932       elsif Local_Sign = '+' then
 933          Time :=
 934            Time_Of (Year, Month, Day, Hour, Minute, Second, Subsec) -
 935              Local_Disp;
 936
 937       --  Compute time with negative local displacement
 938
 939       elsif Local_Sign = '-' then
 940          Time :=
 941            Time_Of (Year, Month, Day, Hour, Minute, Second, Subsec) +
 942              Local_Disp;
 943       end if;
 944
 945       --  Notify that the input string was successfully parsed
 946
 947       Success := True;
 948
 949    exception
 950       when End_Of_Source_Reached
 951          | Wrong_Syntax
 952       =>
 953          Time :=
 954            Time_Of (Year_Number'First, Month_Number'First, Day_Number'First);
 955          Success := False;
 956    end Parse_ISO_8861_UTC;
 957
 958    -----------
 959    -- Value --
 960    -----------
 961
 962    function Value (Date : String) return Ada.Calendar.Time is
 963       D          : String (1 .. 21);
 964       D_Length   : constant Natural := Date'Length;
 965
 966       Year   : Year_Number;
 967       Month  : Month_Number;
 968       Day    : Day_Number;
 969       Hour   : Hour_Number;
 970       Minute : Minute_Number;
 971       Second : Second_Number;
 972
 973       procedure Extract_Date
 974         (Year       : out Year_Number;
 975          Month      : out Month_Number;
 976          Day        : out Day_Number;
 977          Time_Start : out Natural);
 978       --  Try and extract a date value from string D. Time_Start is set to the
 979       --  first character that could be the start of time data.
 980
 981       procedure Extract_Time
 982         (Index       : Positive;
 983          Hour        : out Hour_Number;
 984          Minute      : out Minute_Number;
 985          Second      : out Second_Number;
 986          Check_Space : Boolean := False);
 987       --  Try and extract a time value from string D starting from position
 988       --  Index. Set Check_Space to True to check whether the character at
 989       --  Index - 1 is a space. Raise Constraint_Error if the portion of D
 990       --  corresponding to the date is not well formatted.
 991
 992       ------------------
 993       -- Extract_Date --
 994       ------------------
 995
 996       procedure Extract_Date
 997         (Year       : out Year_Number;
 998          Month      : out Month_Number;
 999          Day        : out Day_Number;
1000          Time_Start : out Natural)
1001       is
1002       begin
1003          if D (3) = '-' or else D (3) = '/' then
1004             if D_Length = 8 or else D_Length = 17 then
1005
1006                --  Formats are "yy*mm*dd" or "yy*mm*dd hh:mm:ss"
1007
1008                if D (6) /= D (3) then
1009                   raise Constraint_Error;
1010                end if;
1011
1012                Year  := Year_Number'Value ("20" & D (1 .. 2));
1013                Month := Month_Number'Value       (D (4 .. 5));
1014                Day   := Day_Number'Value         (D (7 .. 8));
1015                Time_Start := 10;
1016
1017             elsif D_Length = 10 or else D_Length = 19 then
1018
1019                --  Formats are "mm*dd*yyyy" or "mm*dd*yyyy hh:mm:ss"
1020
1021                if D (6) /= D (3) then
1022                   raise Constraint_Error;
1023                end if;
1024
1025                Year  := Year_Number'Value  (D (7 .. 10));
1026                Month := Month_Number'Value (D (1 .. 2));
1027                Day   := Day_Number'Value   (D (4 .. 5));
1028                Time_Start := 12;
1029
1030             elsif D_Length = 11 or else D_Length = 20 then
1031
1032                --  Formats are "dd*mmm*yyyy" or "dd*mmm*yyyy hh:mm:ss"
1033
1034                if D (7) /= D (3) then
1035                   raise Constraint_Error;
1036                end if;
1037
1038                Year  := Year_Number'Value  (D (8 .. 11));
1039                Month := Month_Name_To_Number (D (4 .. 6));
1040                Day   := Day_Number'Value   (D (1 .. 2));
1041                Time_Start := 13;
1042
1043             else
1044                raise Constraint_Error;
1045             end if;
1046
1047          elsif D (3) = ' ' then
1048             if D_Length = 11 or else D_Length = 20 then
1049
1050                --  Possible formats are "dd mmm yyyy", "dd mmm yyyy hh:mm:ss"
1051
1052                if D (7) /= ' ' then
1053                   raise Constraint_Error;
1054                end if;
1055
1056                Year  := Year_Number'Value  (D (8 .. 11));
1057                Month := Month_Name_To_Number (D (4 .. 6));
1058                Day   := Day_Number'Value   (D (1 .. 2));
1059                Time_Start := 13;
1060
1061             else
1062                raise Constraint_Error;
1063             end if;
1064
1065          else
1066             if D_Length = 8 or else D_Length = 17 then
1067
1068                --  Possible formats are "yyyymmdd" or "yyyymmdd hh:mm:ss"
1069
1070                Year  := Year_Number'Value (D (1 .. 4));
1071                Month := Month_Number'Value (D (5 .. 6));
1072                Day   := Day_Number'Value (D (7 .. 8));
1073                Time_Start := 10;
1074
1075             elsif D_Length = 10 or else D_Length = 19 then
1076
1077                --  Possible formats are "yyyy*mm*dd" or "yyyy*mm*dd hh:mm:ss"
1078
1079                if (D (5) /= '-' and then D (5) /= '/')
1080                  or else D (8) /= D (5)
1081                then
1082                   raise Constraint_Error;
1083                end if;
1084
1085                Year  := Year_Number'Value (D (1 .. 4));
1086                Month := Month_Number'Value (D (6 .. 7));
1087                Day   := Day_Number'Value (D (9 .. 10));
1088                Time_Start := 12;
1089
1090             elsif D_Length = 11 or else D_Length = 20 then
1091
1092                --  Possible formats are "yyyy*mmm*dd"
1093
1094                if (D (5) /= '-' and then D (5) /= '/')
1095                  or else D (9) /= D (5)
1096                then
1097                   raise Constraint_Error;
1098                end if;
1099
1100                Year  := Year_Number'Value (D (1 .. 4));
1101                Month := Month_Name_To_Number (D (6 .. 8));
1102                Day   := Day_Number'Value (D (10 .. 11));
1103                Time_Start := 13;
1104
1105             elsif D_Length = 12 or else D_Length = 21 then
1106
1107                --  Formats are "mmm dd, yyyy" or "mmm dd, yyyy hh:mm:ss"
1108
1109                if D (4) /= ' '
1110                  or else D (7) /= ','
1111                  or else D (8) /= ' '
1112                then
1113                   raise Constraint_Error;
1114                end if;
1115
1116                Year  := Year_Number'Value (D (9 .. 12));
1117                Month := Month_Name_To_Number (D (1 .. 3));
1118                Day   := Day_Number'Value (D (5 .. 6));
1119                Time_Start := 14;
1120
1121             else
1122                raise Constraint_Error;
1123             end if;
1124          end if;
1125       end Extract_Date;
1126
1127       ------------------
1128       -- Extract_Time --
1129       ------------------
1130
1131       procedure Extract_Time
1132         (Index       : Positive;
1133          Hour        : out Hour_Number;
1134          Minute      : out Minute_Number;
1135          Second      : out Second_Number;
1136          Check_Space : Boolean := False)
1137       is
1138       begin
1139          --  If no time was specified in the string (do not allow trailing
1140          --  character either)
1141
1142          if Index = D_Length + 2 then
1143             Hour   := 0;
1144             Minute := 0;
1145             Second := 0;
1146
1147          else
1148             --  Not enough characters left ?
1149
1150             if Index /= D_Length - 7 then
1151                raise Constraint_Error;
1152             end if;
1153
1154             if Check_Space and then D (Index - 1) /= ' ' then
1155                raise Constraint_Error;
1156             end if;
1157
1158             if D (Index + 2) /= ':' or else D (Index + 5) /= ':' then
1159                raise Constraint_Error;
1160             end if;
1161
1162             Hour   := Hour_Number'Value   (D (Index     .. Index + 1));
1163             Minute := Minute_Number'Value (D (Index + 3 .. Index + 4));
1164             Second := Second_Number'Value (D (Index + 6 .. Index + 7));
1165          end if;
1166       end Extract_Time;
1167
1168       --  Local Declarations
1169
1170       Success    : Boolean;
1171       Time_Start : Natural := 1;
1172       Time       : Ada.Calendar.Time;
1173
1174    --  Start of processing for Value
1175
1176    begin
1177       --  Let's try parsing Date as a supported ISO-8861 format. If we do not
1178       --  succeed, then retry using all the other GNAT supported formats.
1179
1180       Parse_ISO_8861_UTC (Date, Time, Success);
1181
1182       if Success then
1183          return Time;
1184       end if;
1185
1186       --  Length checks
1187
1188       if D_Length /= 8
1189         and then D_Length /= 10
1190         and then D_Length /= 11
1191         and then D_Length /= 12
1192         and then D_Length /= 17
1193         and then D_Length /= 19
1194         and then D_Length /= 20
1195         and then D_Length /= 21
1196       then
1197          raise Constraint_Error;
1198       end if;
1199
1200       --  After the correct length has been determined, it is safe to create
1201       --  a local string copy in order to avoid String'First N arithmetic.
1202
1203       D (1 .. D_Length) := Date;
1204
1205       if D_Length /= 8 or else D (3) /= ':' then
1206          Extract_Date (Year, Month, Day, Time_Start);
1207          Extract_Time (Time_Start, Hour, Minute, Second, Check_Space => True);
1208
1209       else
1210          declare
1211             Discard : Second_Duration;
1212          begin
1213             Split (Clock, Year, Month, Day, Hour, Minute, Second,
1214                    Sub_Second => Discard);
1215          end;
1216
1217          Extract_Time (1, Hour, Minute, Second, Check_Space => False);
1218       end if;
1219
1220       --  Sanity checks
1221
1222       if not Year'Valid
1223         or else not Month'Valid
1224         or else not Day'Valid
1225         or else not Hour'Valid
1226         or else not Minute'Valid
1227         or else not Second'Valid
1228       then
1229          raise Constraint_Error;
1230       end if;
1231
1232       return Time_Of (Year, Month, Day, Hour, Minute, Second);
1233    end Value;
1234
1235    --------------
1236    -- Put_Time --
1237    --------------
1238
1239    procedure Put_Time (Date : Ada.Calendar.Time; Picture : Picture_String) is
1240    begin
1241       Ada.Text_IO.Put (Image (Date, Picture));
1242    end Put_Time;
1243
1244 end GNAT.Calendar.Time_IO;