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-2018, 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          Success := False;
 954    end Parse_ISO_8861_UTC;
 955
 956    -----------
 957    -- Value --
 958    -----------
 959
 960    function Value (Date : String) return Ada.Calendar.Time is
 961       D          : String (1 .. 21);
 962       D_Length   : constant Natural := Date'Length;
 963
 964       Year   : Year_Number;
 965       Month  : Month_Number;
 966       Day    : Day_Number;
 967       Hour   : Hour_Number;
 968       Minute : Minute_Number;
 969       Second : Second_Number;
 970
 971       procedure Extract_Date
 972         (Year       : out Year_Number;
 973          Month      : out Month_Number;
 974          Day        : out Day_Number;
 975          Time_Start : out Natural);
 976       --  Try and extract a date value from string D. Time_Start is set to the
 977       --  first character that could be the start of time data.
 978
 979       procedure Extract_Time
 980         (Index       : Positive;
 981          Hour        : out Hour_Number;
 982          Minute      : out Minute_Number;
 983          Second      : out Second_Number;
 984          Check_Space : Boolean := False);
 985       --  Try and extract a time value from string D starting from position
 986       --  Index. Set Check_Space to True to check whether the character at
 987       --  Index - 1 is a space. Raise Constraint_Error if the portion of D
 988       --  corresponding to the date is not well formatted.
 989
 990       ------------------
 991       -- Extract_Date --
 992       ------------------
 993
 994       procedure Extract_Date
 995         (Year       : out Year_Number;
 996          Month      : out Month_Number;
 997          Day        : out Day_Number;
 998          Time_Start : out Natural)
 999       is
1000       begin
1001          if D (3) = '-' or else D (3) = '/' then
1002             if D_Length = 8 or else D_Length = 17 then
1003
1004                --  Formats are "yy*mm*dd" or "yy*mm*dd hh:mm:ss"
1005
1006                if D (6) /= D (3) then
1007                   raise Constraint_Error;
1008                end if;
1009
1010                Year  := Year_Number'Value ("20" & D (1 .. 2));
1011                Month := Month_Number'Value       (D (4 .. 5));
1012                Day   := Day_Number'Value         (D (7 .. 8));
1013                Time_Start := 10;
1014
1015             elsif D_Length = 10 or else D_Length = 19 then
1016
1017                --  Formats are "mm*dd*yyyy" or "mm*dd*yyyy hh:mm:ss"
1018
1019                if D (6) /= D (3) then
1020                   raise Constraint_Error;
1021                end if;
1022
1023                Year  := Year_Number'Value  (D (7 .. 10));
1024                Month := Month_Number'Value (D (1 .. 2));
1025                Day   := Day_Number'Value   (D (4 .. 5));
1026                Time_Start := 12;
1027
1028             elsif D_Length = 11 or else D_Length = 20 then
1029
1030                --  Formats are "dd*mmm*yyyy" or "dd*mmm*yyyy hh:mm:ss"
1031
1032                if D (7) /= D (3) then
1033                   raise Constraint_Error;
1034                end if;
1035
1036                Year  := Year_Number'Value  (D (8 .. 11));
1037                Month := Month_Name_To_Number (D (4 .. 6));
1038                Day   := Day_Number'Value   (D (1 .. 2));
1039                Time_Start := 13;
1040
1041             else
1042                raise Constraint_Error;
1043             end if;
1044
1045          elsif D (3) = ' ' then
1046             if D_Length = 11 or else D_Length = 20 then
1047
1048                --  Possible formats are "dd mmm yyyy", "dd mmm yyyy hh:mm:ss"
1049
1050                if D (7) /= ' ' then
1051                   raise Constraint_Error;
1052                end if;
1053
1054                Year  := Year_Number'Value  (D (8 .. 11));
1055                Month := Month_Name_To_Number (D (4 .. 6));
1056                Day   := Day_Number'Value   (D (1 .. 2));
1057                Time_Start := 13;
1058
1059             else
1060                raise Constraint_Error;
1061             end if;
1062
1063          else
1064             if D_Length = 8 or else D_Length = 17 then
1065
1066                --  Possible formats are "yyyymmdd" or "yyyymmdd hh:mm:ss"
1067
1068                Year  := Year_Number'Value (D (1 .. 4));
1069                Month := Month_Number'Value (D (5 .. 6));
1070                Day   := Day_Number'Value (D (7 .. 8));
1071                Time_Start := 10;
1072
1073             elsif D_Length = 10 or else D_Length = 19 then
1074
1075                --  Possible formats are "yyyy*mm*dd" or "yyyy*mm*dd hh:mm:ss"
1076
1077                if (D (5) /= '-' and then D (5) /= '/')
1078                  or else D (8) /= D (5)
1079                then
1080                   raise Constraint_Error;
1081                end if;
1082
1083                Year  := Year_Number'Value (D (1 .. 4));
1084                Month := Month_Number'Value (D (6 .. 7));
1085                Day   := Day_Number'Value (D (9 .. 10));
1086                Time_Start := 12;
1087
1088             elsif D_Length = 11 or else D_Length = 20 then
1089
1090                --  Possible formats are "yyyy*mmm*dd"
1091
1092                if (D (5) /= '-' and then D (5) /= '/')
1093                  or else D (9) /= D (5)
1094                then
1095                   raise Constraint_Error;
1096                end if;
1097
1098                Year  := Year_Number'Value (D (1 .. 4));
1099                Month := Month_Name_To_Number (D (6 .. 8));
1100                Day   := Day_Number'Value (D (10 .. 11));
1101                Time_Start := 13;
1102
1103             elsif D_Length = 12 or else D_Length = 21 then
1104
1105                --  Formats are "mmm dd, yyyy" or "mmm dd, yyyy hh:mm:ss"
1106
1107                if D (4) /= ' '
1108                  or else D (7) /= ','
1109                  or else D (8) /= ' '
1110                then
1111                   raise Constraint_Error;
1112                end if;
1113
1114                Year  := Year_Number'Value (D (9 .. 12));
1115                Month := Month_Name_To_Number (D (1 .. 3));
1116                Day   := Day_Number'Value (D (5 .. 6));
1117                Time_Start := 14;
1118
1119             else
1120                raise Constraint_Error;
1121             end if;
1122          end if;
1123       end Extract_Date;
1124
1125       ------------------
1126       -- Extract_Time --
1127       ------------------
1128
1129       procedure Extract_Time
1130         (Index       : Positive;
1131          Hour        : out Hour_Number;
1132          Minute      : out Minute_Number;
1133          Second      : out Second_Number;
1134          Check_Space : Boolean := False)
1135       is
1136       begin
1137          --  If no time was specified in the string (do not allow trailing
1138          --  character either)
1139
1140          if Index = D_Length + 2 then
1141             Hour   := 0;
1142             Minute := 0;
1143             Second := 0;
1144
1145          else
1146             --  Not enough characters left ?
1147
1148             if Index /= D_Length - 7 then
1149                raise Constraint_Error;
1150             end if;
1151
1152             if Check_Space and then D (Index - 1) /= ' ' then
1153                raise Constraint_Error;
1154             end if;
1155
1156             if D (Index + 2) /= ':' or else D (Index + 5) /= ':' then
1157                raise Constraint_Error;
1158             end if;
1159
1160             Hour   := Hour_Number'Value   (D (Index     .. Index + 1));
1161             Minute := Minute_Number'Value (D (Index + 3 .. Index + 4));
1162             Second := Second_Number'Value (D (Index + 6 .. Index + 7));
1163          end if;
1164       end Extract_Time;
1165
1166       --  Local Declarations
1167
1168       Success    : Boolean;
1169       Time_Start : Natural := 1;
1170       Time       : Ada.Calendar.Time;
1171
1172    --  Start of processing for Value
1173
1174    begin
1175       --  Let's try parsing Date as a supported ISO-8861 format. If we do not
1176       --  succeed, then retry using all the other GNAT supported formats.
1177
1178       Parse_ISO_8861_UTC (Date, Time, Success);
1179
1180       if Success then
1181          return Time;
1182       end if;
1183
1184       --  Length checks
1185
1186       if D_Length /= 8
1187         and then D_Length /= 10
1188         and then D_Length /= 11
1189         and then D_Length /= 12
1190         and then D_Length /= 17
1191         and then D_Length /= 19
1192         and then D_Length /= 20
1193         and then D_Length /= 21
1194       then
1195          raise Constraint_Error;
1196       end if;
1197
1198       --  After the correct length has been determined, it is safe to create
1199       --  a local string copy in order to avoid String'First N arithmetic.
1200
1201       D (1 .. D_Length) := Date;
1202
1203       if D_Length /= 8 or else D (3) /= ':' then
1204          Extract_Date (Year, Month, Day, Time_Start);
1205          Extract_Time (Time_Start, Hour, Minute, Second, Check_Space => True);
1206
1207       else
1208          declare
1209             Discard : Second_Duration;
1210          begin
1211             Split (Clock, Year, Month, Day, Hour, Minute, Second,
1212                    Sub_Second => Discard);
1213          end;
1214
1215          Extract_Time (1, Hour, Minute, Second, Check_Space => False);
1216       end if;
1217
1218       --  Sanity checks
1219
1220       if not Year'Valid
1221         or else not Month'Valid
1222         or else not Day'Valid
1223         or else not Hour'Valid
1224         or else not Minute'Valid
1225         or else not Second'Valid
1226       then
1227          raise Constraint_Error;
1228       end if;
1229
1230       return Time_Of (Year, Month, Day, Hour, Minute, Second);
1231    end Value;
1232
1233    --------------
1234    -- Put_Time --
1235    --------------
1236
1237    procedure Put_Time (Date : Ada.Calendar.Time; Picture : Picture_String) is
1238    begin
1239       Ada.Text_IO.Put (Image (Date, Picture));
1240    end Put_Time;
1241
1242 end GNAT.Calendar.Time_IO;