libgfortran/intrinsics/date_and_time.c

   1 /* Implementation of the DATE_AND_TIME intrinsic.
   2    Copyright (C) 2003, 2004, 2005, 2006, 2007, 2009 Free Software Foundation, Inc.
   3    Contributed by Steven Bosscher.
   4
   5 This file is part of the GNU Fortran 95 runtime library (libgfortran).
   6
   7 Libgfortran is free software; you can redistribute it and/or
   8 modify it under the terms of the GNU General Public
   9 License as published by the Free Software Foundation; either
  10 version 2 of the License, or (at your option) any later version.
  11
  12 In addition to the permissions in the GNU General Public License, the
  13 Free Software Foundation gives you unlimited permission to link the
  14 compiled version of this file into combinations with other programs,
  15 and to distribute those combinations without any restriction coming
  16 from the use of this file.  (The General Public License restrictions
  17 do apply in other respects; for example, they cover modification of
  18 the file, and distribution when not linked into a combine
  19 executable.)
  20
  21 Libgfortran is distributed in the hope that it will be useful,
  22 but WITHOUT ANY WARRANTY; without even the implied warranty of
  23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  24 GNU General Public License for more details.
  25
  26 You should have received a copy of the GNU General Public
  27 License along with libgfortran; see the file COPYING.  If not,
  28 write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  29 Boston, MA 02110-1301, USA.  */
  30
  31 #include "libgfortran.h"
  32 #include <string.h>
  33 #include <assert.h>
  34 #include <stdlib.h>
  35
  36 #undef HAVE_NO_DATE_TIME
  37 #if TIME_WITH_SYS_TIME
  38 #  include <sys/time.h>
  39 #  include <time.h>
  40 #else
  41 #  if HAVE_SYS_TIME_H
  42 #    include <sys/time.h>
  43 #  else
  44 #    ifdef HAVE_TIME_H
  45 #      include <time.h>
  46 #    else
  47 #      define HAVE_NO_DATE_TIME
  48 #    endif  /* HAVE_TIME_H  */
  49 #  endif  /* HAVE_SYS_TIME_H  */
  50 #endif  /* TIME_WITH_SYS_TIME  */
  51
  52 #ifndef abs
  53 #define abs(x) ((x)>=0 ? (x) : -(x))
  54 #endif
  55
  56 /* DATE_AND_TIME ([DATE, TIME, ZONE, VALUES])
  57
  58    Description: Returns data on the real-time clock and date in a form
  59    compatible with the representations defined in ISO 8601:1988.
  60
  61    Class: Non-elemental subroutine.
  62
  63    Arguments:
  64
  65    DATE (optional) shall be scalar and of type default character, and
  66    shall be of length at least 8 in order to contain the complete
  67    value. It is an INTENT(OUT) argument. Its leftmost 8 characters
  68    are assigned a value of the form CCYYMMDD, where CC is the century,
  69    YY the year within the century, MM the month within the year, and
  70    DD the day within the month. If there is no date available, they
  71    are assigned blanks.
  72
  73    TIME (optional) shall be scalar and of type default character, and
  74    shall be of length at least 10 in order to contain the complete
  75    value. It is an INTENT(OUT) argument. Its leftmost 10 characters
  76    are assigned a value of the form hhmmss.sss, where hh is the hour
  77    of the day, mm is the minutes of the hour, and ss.sss is the
  78    seconds and milliseconds of the minute. If there is no clock
  79    available, they are assigned blanks.
  80
  81    ZONE (optional) shall be scalar and of type default character, and
  82    shall be of length at least 5 in order to contain the complete
  83    value. It is an INTENT(OUT) argument. Its leftmost 5 characters
  84    are assigned a value of the form [+-]hhmm, where hh and mm are the
  85    time difference with respect to Coordinated Universal Time (UTC) in
  86    hours and parts of an hour expressed in minutes, respectively. If
  87    there is no clock available, they are assigned blanks.
  88
  89    VALUES (optional) shall be of type default integer and of rank
  90    one. It is an INTENT(OUT) argument. Its size shall be at least
  91    8. The values returned in VALUES are as follows:
  92
  93       VALUES(1) the year (for example, 2003), or -HUGE(0) if there is
  94       no date available;
  95
  96       VALUES(2) the month of the year, or -HUGE(0) if there
  97       is no date available;
  98
  99       VALUES(3) the day of the month, or -HUGE(0) if there is no date
 100       available;
 101
 102       VALUES(4) the time difference with respect to Coordinated
 103       Universal Time (UTC) in minutes, or -HUGE(0) if this information
 104       is not available;
 105
 106       VALUES(5) the hour of the day, in the range of 0 to 23, or
 107       -HUGE(0) if there is no clock;
 108
 109       VALUES(6) the minutes of the hour, in the range 0 to 59, or
 110       -HUGE(0) if there is no clock;
 111
 112       VALUES(7) the seconds of the minute, in the range 0 to 60, or
 113       -HUGE(0) if there is no clock;
 114
 115       VALUES(8) the milliseconds of the second, in the range 0 to
 116       999, or -HUGE(0) if there is no clock.
 117
 118    NULL pointer represent missing OPTIONAL arguments.  All arguments
 119    have INTENT(OUT).  Because of the -i8 option, we must implement
 120    VALUES for INTEGER(kind=4) and INTEGER(kind=8).
 121
 122    Based on libU77's date_time_.c.
 123
 124    TODO :
 125    - Check year boundaries.
 126 */
 127 #define DATE_LEN 8
 128 #define TIME_LEN 10
 129 #define ZONE_LEN 5
 130 #define VALUES_SIZE 8
 131
 132 extern void date_and_time (char *, char *, char *, gfc_array_i4 *,
 133                            GFC_INTEGER_4, GFC_INTEGER_4, GFC_INTEGER_4);
 134 export_proto(date_and_time);
 135
 136 void
 137 date_and_time (char *__date, char *__time, char *__zone,
 138                gfc_array_i4 *__values, GFC_INTEGER_4 __date_len,
 139                GFC_INTEGER_4 __time_len, GFC_INTEGER_4 __zone_len)
 140 {
 141   int i;
 142   char date[DATE_LEN + 1];
 143   char timec[TIME_LEN + 1];
 144   char zone[ZONE_LEN + 1];
 145   GFC_INTEGER_4 values[VALUES_SIZE];
 146
 147 #ifndef HAVE_NO_DATE_TIME
 148   time_t lt;
 149   struct tm local_time;
 150   struct tm UTC_time;
 151
 152 #if HAVE_GETTIMEOFDAY
 153   {
 154     struct timeval tp;
 155
 156     if (!gettimeofday (&tp, NULL))
 157       {
 158          lt = tp.tv_sec;
 159          values[7] = tp.tv_usec / 1000;
 160       }
 161     else
 162       {
 163          lt = time (NULL);
 164          values[7] = 0;
 165       }
 166   }
 167 #else
 168   lt = time (NULL);
 169   values[7] = 0;
 170 #endif /* HAVE_GETTIMEOFDAY */
 171
 172   if (lt != (time_t) -1)
 173     {
 174       local_time = *localtime (&lt);
 175       UTC_time = *gmtime (&lt);
 176
 177       /* All arguments can be derived from VALUES.  */
 178       values[0] = 1900 + local_time.tm_year;
 179       values[1] = 1 + local_time.tm_mon;
 180       values[2] = local_time.tm_mday;
 181       values[3] = (local_time.tm_min - UTC_time.tm_min +
 182                    60 * (local_time.tm_hour - UTC_time.tm_hour +
 183                      24 * (local_time.tm_yday - UTC_time.tm_yday)));
 184       values[4] = local_time.tm_hour;
 185       values[5] = local_time.tm_min;
 186       values[6] = local_time.tm_sec;
 187
 188 #if HAVE_SNPRINTF
 189       if (__date)
 190         snprintf (date, DATE_LEN + 1, "%04d%02d%02d",
 191                   values[0], values[1], values[2]);
 192       if (__time)
 193         snprintf (timec, TIME_LEN + 1, "%02d%02d%02d.%03d",
 194                   values[4], values[5], values[6], values[7]);
 195
 196       if (__zone)
 197         snprintf (zone, ZONE_LEN + 1, "%+03d%02d",
 198                   values[3] / 60, abs (values[3] % 60));
 199 #else
 200       if (__date)
 201         sprintf (date, "%04d%02d%02d", values[0], values[1], values[2]);
 202
 203       if (__time)
 204         sprintf (timec, "%02d%02d%02d.%03d",
 205                  values[4], values[5], values[6], values[7]);
 206
 207       if (__zone)
 208         sprintf (zone, "%+03d%02d",
 209                  values[3] / 60, abs (values[3] % 60));
 210 #endif
 211     }
 212   else
 213     {
 214       memset (date, ' ', DATE_LEN);
 215       date[DATE_LEN] = '\0';
 216
 217       memset (timec, ' ', TIME_LEN);
 218       timec[TIME_LEN] = '\0';
 219
 220       memset (zone, ' ', ZONE_LEN);
 221       zone[ZONE_LEN] = '\0';
 222
 223       for (i = 0; i < VALUES_SIZE; i++)
 224         values[i] = - GFC_INTEGER_4_HUGE;
 225     }
 226 #else /* if defined HAVE_NO_DATE_TIME  */
 227   /* We really have *nothing* to return, so return blanks and HUGE(0).  */
 228
 229   memset (date, ' ', DATE_LEN);
 230   date[DATE_LEN] = '\0';
 231
 232   memset (timec, ' ', TIME_LEN);
 233   timec[TIME_LEN] = '\0';
 234
 235   memset (zone, ' ', ZONE_LEN);
 236   zone[ZONE_LEN] = '\0';
 237
 238   for (i = 0; i < VALUES_SIZE; i++)
 239     values[i] = - GFC_INTEGER_4_HUGE;
 240 #endif  /* HAVE_NO_DATE_TIME  */
 241
 242   /* Copy the values into the arguments.  */
 243   if (__values)
 244     {
 245       index_type len, delta, elt_size;
 246
 247       elt_size = GFC_DESCRIPTOR_SIZE (__values);
 248       len = __values->dim[0].ubound + 1 - __values->dim[0].lbound;
 249       delta = __values->dim[0].stride;
 250       if (delta == 0)
 251         delta = 1;
 252
 253       assert (len >= VALUES_SIZE);
 254       /* Cope with different type kinds.  */
 255       if (elt_size == 4)
 256         {
 257           GFC_INTEGER_4 *vptr4 = __values->data;
 258
 259           for (i = 0; i < VALUES_SIZE; i++, vptr4 += delta)
 260             *vptr4 = values[i];
 261         }
 262       else if (elt_size == 8)
 263         {
 264           GFC_INTEGER_8 *vptr8 = (GFC_INTEGER_8 *)__values->data;
 265
 266           for (i = 0; i < VALUES_SIZE; i++, vptr8 += delta)
 267             {
 268               if (values[i] == - GFC_INTEGER_4_HUGE)
 269                 *vptr8 = - GFC_INTEGER_8_HUGE;
 270               else
 271                 *vptr8 = values[i];
 272             }
 273         }
 274       else
 275         abort ();
 276     }
 277
 278   if (__zone)
 279     {
 280       assert (__zone_len >= ZONE_LEN);
 281       fstrcpy (__zone, ZONE_LEN, zone, ZONE_LEN);
 282     }
 283
 284   if (__time)
 285     {
 286       assert (__time_len >= TIME_LEN);
 287       fstrcpy (__time, TIME_LEN, timec, TIME_LEN);
 288     }
 289
 290   if (__date)
 291     {
 292       assert (__date_len >= DATE_LEN);
 293       fstrcpy (__date, DATE_LEN, date, DATE_LEN);
 294     }
 295 }
 296
 297
 298 /* SECNDS (X) - Non-standard
 299
 300    Description: Returns the system time of day, or elapsed time, as a GFC_REAL_4
 301    in seconds.
 302
 303    Class: Non-elemental subroutine.
 304
 305    Arguments:
 306
 307    X must be REAL(4) and the result is of the same type.  The accuracy is system
 308    dependent.
 309
 310    Usage:
 311
 312         T = SECNDS (X)
 313
 314    yields the time in elapsed seconds since X.  If X is 0.0, T is the time in
 315    seconds since midnight. Note that a time that spans midnight but is less than
 316    24hours will be calculated correctly.  */
 317
 318 extern GFC_REAL_4 secnds (GFC_REAL_4 *);
 319 export_proto(secnds);
 320
 321 GFC_REAL_4
 322 secnds (GFC_REAL_4 *x)
 323 {
 324   GFC_INTEGER_4 values[VALUES_SIZE];
 325   GFC_REAL_4 temp1, temp2;
 326
 327   /* Make the INTEGER*4 array for passing to date_and_time.  */
 328   gfc_array_i4 *avalues = internal_malloc_size (sizeof (gfc_array_i4));
 329   avalues->data = &values[0];
 330   GFC_DESCRIPTOR_DTYPE (avalues) = ((GFC_DTYPE_REAL << GFC_DTYPE_TYPE_SHIFT)
 331                                         & GFC_DTYPE_TYPE_MASK) +
 332                                     (4 << GFC_DTYPE_SIZE_SHIFT);
 333
 334   avalues->dim[0].ubound = 7;
 335   avalues->dim[0].lbound = 0;
 336   avalues->dim[0].stride = 1;
 337
 338   date_and_time (NULL, NULL, NULL, avalues, 0, 0, 0);
 339
 340   free_mem (avalues);
 341
 342   temp1 = 3600.0 * (GFC_REAL_4)values[4] +
 343             60.0 * (GFC_REAL_4)values[5] +
 344                    (GFC_REAL_4)values[6] +
 345            0.001 * (GFC_REAL_4)values[7];
 346   temp2 = fmod (*x, 86400.0);
 347   temp2 = (temp1 - temp2 >= 0.0) ? temp2 : (temp2 - 86400.0);
 348   return temp1 - temp2;
 349 }
 350
 351
 352
 353 /* ITIME(X) - Non-standard
 354
 355    Description: Returns the current local time hour, minutes, and seconds
 356    in elements 1, 2, and 3 of X, respectively.  */
 357
 358 static void
 359 itime0 (int x[3])
 360 {
 361 #ifndef HAVE_NO_DATE_TIME
 362   time_t lt;
 363   struct tm local_time;
 364
 365   lt = time (NULL);
 366
 367   if (lt != (time_t) -1)
 368     {
 369       local_time = *localtime (&lt);
 370
 371       x[0] = local_time.tm_hour;
 372       x[1] = local_time.tm_min;
 373       x[2] = local_time.tm_sec;
 374     }
 375 #else
 376   x[0] = x[1] = x[2] = -1;
 377 #endif
 378 }
 379
 380 extern void itime_i4 (gfc_array_i4 *);
 381 export_proto(itime_i4);
 382
 383 void
 384 itime_i4 (gfc_array_i4 *__values)
 385 {
 386   int x[3], i;
 387   index_type len, delta;
 388   GFC_INTEGER_4 *vptr;
 389
 390   /* Call helper function.  */
 391   itime0(x);
 392
 393   /* Copy the value into the array.  */
 394   len = __values->dim[0].ubound + 1 - __values->dim[0].lbound;
 395   assert (len >= 3);
 396   delta = __values->dim[0].stride;
 397   if (delta == 0)
 398     delta = 1;
 399
 400   vptr = __values->data;
 401   for (i = 0; i < 3; i++, vptr += delta)
 402     *vptr = x[i];
 403 }
 404
 405
 406 extern void itime_i8 (gfc_array_i8 *);
 407 export_proto(itime_i8);
 408
 409 void
 410 itime_i8 (gfc_array_i8 *__values)
 411 {
 412   int x[3], i;
 413   index_type len, delta;
 414   GFC_INTEGER_8 *vptr;
 415
 416   /* Call helper function.  */
 417   itime0(x);
 418
 419   /* Copy the value into the array.  */
 420   len = __values->dim[0].ubound + 1 - __values->dim[0].lbound;
 421   assert (len >= 3);
 422   delta = __values->dim[0].stride;
 423   if (delta == 0)
 424     delta = 1;
 425
 426   vptr = __values->data;
 427   for (i = 0; i < 3; i++, vptr += delta)
 428     *vptr = x[i];
 429 }
 430
 431
 432
 433 /* IDATE(X) - Non-standard
 434
 435    Description: Fills TArray with the numerical values at the current
 436    local time. The day (in the range 1-31), month (in the range 1-12),
 437    and year appear in elements 1, 2, and 3 of X, respectively.
 438    The year has four significant digits.  */
 439
 440 static void
 441 idate0 (int x[3])
 442 {
 443 #ifndef HAVE_NO_DATE_TIME
 444   time_t lt;
 445   struct tm local_time;
 446
 447   lt = time (NULL);
 448
 449   if (lt != (time_t) -1)
 450     {
 451       local_time = *localtime (&lt);
 452
 453       x[0] = local_time.tm_mday;
 454       x[1] = 1 + local_time.tm_mon;
 455       x[2] = 1900 + local_time.tm_year;
 456     }
 457 #else
 458   x[0] = x[1] = x[2] = -1;
 459 #endif
 460 }
 461
 462 extern void idate_i4 (gfc_array_i4 *);
 463 export_proto(idate_i4);
 464
 465 void
 466 idate_i4 (gfc_array_i4 *__values)
 467 {
 468   int x[3], i;
 469   index_type len, delta;
 470   GFC_INTEGER_4 *vptr;
 471
 472   /* Call helper function.  */
 473   idate0(x);
 474
 475   /* Copy the value into the array.  */
 476   len = __values->dim[0].ubound + 1 - __values->dim[0].lbound;
 477   assert (len >= 3);
 478   delta = __values->dim[0].stride;
 479   if (delta == 0)
 480     delta = 1;
 481
 482   vptr = __values->data;
 483   for (i = 0; i < 3; i++, vptr += delta)
 484     *vptr = x[i];
 485 }
 486
 487
 488 extern void idate_i8 (gfc_array_i8 *);
 489 export_proto(idate_i8);
 490
 491 void
 492 idate_i8 (gfc_array_i8 *__values)
 493 {
 494   int x[3], i;
 495   index_type len, delta;
 496   GFC_INTEGER_8 *vptr;
 497
 498   /* Call helper function.  */
 499   idate0(x);
 500
 501   /* Copy the value into the array.  */
 502   len = __values->dim[0].ubound + 1 - __values->dim[0].lbound;
 503   assert (len >= 3);
 504   delta = __values->dim[0].stride;
 505   if (delta == 0)
 506     delta = 1;
 507
 508   vptr = __values->data;
 509   for (i = 0; i < 3; i++, vptr += delta)
 510     *vptr = x[i];
 511 }
 512
 513
 514
 515 /* GMTIME(STIME, TARRAY) - Non-standard
 516
 517    Description: Given a system time value STime, fills TArray with values
 518    extracted from it appropriate to the GMT time zone using gmtime(3).
 519
 520    The array elements are as follows:
 521
 522       1. Seconds after the minute, range 0-59 or 0-61 to allow for leap seconds
 523       2. Minutes after the hour, range 0-59
 524       3. Hours past midnight, range 0-23
 525       4. Day of month, range 0-31
 526       5. Number of months since January, range 0-11
 527       6. Years since 1900
 528       7. Number of days since Sunday, range 0-6
 529       8. Days since January 1
 530       9. Daylight savings indicator: positive if daylight savings is in effect,
 531          zero if not, and negative if the information isn't available.  */
 532
 533 static void
 534 gmtime_0 (const time_t * t, int x[9])
 535 {
 536   struct tm lt;
 537
 538   lt = *gmtime (t);
 539   x[0] = lt.tm_sec;
 540   x[1] = lt.tm_min;
 541   x[2] = lt.tm_hour;
 542   x[3] = lt.tm_mday;
 543   x[4] = lt.tm_mon;
 544   x[5] = lt.tm_year;
 545   x[6] = lt.tm_wday;
 546   x[7] = lt.tm_yday;
 547   x[8] = lt.tm_isdst;
 548 }
 549
 550 extern void gmtime_i4 (GFC_INTEGER_4 *, gfc_array_i4 *);
 551 export_proto(gmtime_i4);
 552
 553 void
 554 gmtime_i4 (GFC_INTEGER_4 * t, gfc_array_i4 * tarray)
 555 {
 556   int x[9], i;
 557   index_type len, delta;
 558   GFC_INTEGER_4 *vptr;
 559   time_t tt;
 560
 561   /* Call helper function.  */
 562   tt = (time_t) *t;
 563   gmtime_0(&tt, x);
 564
 565   /* Copy the values into the array.  */
 566   len = tarray->dim[0].ubound + 1 - tarray->dim[0].lbound;
 567   assert (len >= 9);
 568   delta = tarray->dim[0].stride;
 569   if (delta == 0)
 570     delta = 1;
 571
 572   vptr = tarray->data;
 573   for (i = 0; i < 9; i++, vptr += delta)
 574     *vptr = x[i];
 575 }
 576
 577 extern void gmtime_i8 (GFC_INTEGER_8 *, gfc_array_i8 *);
 578 export_proto(gmtime_i8);
 579
 580 void
 581 gmtime_i8 (GFC_INTEGER_8 * t, gfc_array_i8 * tarray)
 582 {
 583   int x[9], i;
 584   index_type len, delta;
 585   GFC_INTEGER_8 *vptr;
 586   time_t tt;
 587
 588   /* Call helper function.  */
 589   tt = (time_t) *t;
 590   gmtime_0(&tt, x);
 591
 592   /* Copy the values into the array.  */
 593   len = tarray->dim[0].ubound + 1 - tarray->dim[0].lbound;
 594   assert (len >= 9);
 595   delta = tarray->dim[0].stride;
 596   if (delta == 0)
 597     delta = 1;
 598
 599   vptr = tarray->data;
 600   for (i = 0; i < 9; i++, vptr += delta)
 601     *vptr = x[i];
 602 }
 603
 604
 605
 606
 607 /* LTIME(STIME, TARRAY) - Non-standard
 608
 609    Description: Given a system time value STime, fills TArray with values
 610    extracted from it appropriate to the local time zone using localtime(3).
 611
 612    The array elements are as follows:
 613
 614       1. Seconds after the minute, range 0-59 or 0-61 to allow for leap seconds
 615       2. Minutes after the hour, range 0-59
 616       3. Hours past midnight, range 0-23
 617       4. Day of month, range 0-31
 618       5. Number of months since January, range 0-11
 619       6. Years since 1900
 620       7. Number of days since Sunday, range 0-6
 621       8. Days since January 1
 622       9. Daylight savings indicator: positive if daylight savings is in effect,
 623          zero if not, and negative if the information isn't available.  */
 624
 625 static void
 626 ltime_0 (const time_t * t, int x[9])
 627 {
 628   struct tm lt;
 629
 630   lt = *localtime (t);
 631   x[0] = lt.tm_sec;
 632   x[1] = lt.tm_min;
 633   x[2] = lt.tm_hour;
 634   x[3] = lt.tm_mday;
 635   x[4] = lt.tm_mon;
 636   x[5] = lt.tm_year;
 637   x[6] = lt.tm_wday;
 638   x[7] = lt.tm_yday;
 639   x[8] = lt.tm_isdst;
 640 }
 641
 642 extern void ltime_i4 (GFC_INTEGER_4 *, gfc_array_i4 *);
 643 export_proto(ltime_i4);
 644
 645 void
 646 ltime_i4 (GFC_INTEGER_4 * t, gfc_array_i4 * tarray)
 647 {
 648   int x[9], i;
 649   index_type len, delta;
 650   GFC_INTEGER_4 *vptr;
 651   time_t tt;
 652
 653   /* Call helper function.  */
 654   tt = (time_t) *t;
 655   ltime_0(&tt, x);
 656
 657   /* Copy the values into the array.  */
 658   len = tarray->dim[0].ubound + 1 - tarray->dim[0].lbound;
 659   assert (len >= 9);
 660   delta = tarray->dim[0].stride;
 661   if (delta == 0)
 662     delta = 1;
 663
 664   vptr = tarray->data;
 665   for (i = 0; i < 9; i++, vptr += delta)
 666     *vptr = x[i];
 667 }
 668
 669 extern void ltime_i8 (GFC_INTEGER_8 *, gfc_array_i8 *);
 670 export_proto(ltime_i8);
 671
 672 void
 673 ltime_i8 (GFC_INTEGER_8 * t, gfc_array_i8 * tarray)
 674 {
 675   int x[9], i;
 676   index_type len, delta;
 677   GFC_INTEGER_8 *vptr;
 678   time_t tt;
 679
 680   /* Call helper function.  */
 681   tt = (time_t) * t;
 682   ltime_0(&tt, x);
 683
 684   /* Copy the values into the array.  */
 685   len = tarray->dim[0].ubound + 1 - tarray->dim[0].lbound;
 686   assert (len >= 9);
 687   delta = tarray->dim[0].stride;
 688   if (delta == 0)
 689     delta = 1;
 690
 691   vptr = tarray->data;
 692   for (i = 0; i < 9; i++, vptr += delta)
 693     *vptr = x[i];
 694 }
 695
 696