1 /* Timestamp functions for Emacs
2
3 Copyright (C) 1985-1987, 1989, 1993-2023 Free Software Foundation, Inc.
4
5 This file is part of GNU Emacs.
6
7 GNU Emacs is free software: you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation, either version 3 of the License, or (at
10 your option) any later version.
11
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
19
20 #include <config.h>
21
22 /* Work around GCC bug 102671. */
23 #if 10 <= __GNUC__
24 # pragma GCC diagnostic ignored "-Wanalyzer-null-dereference"
25 #endif
26
27 #include "systime.h"
28
29 #include "blockinput.h"
30 #include "bignum.h"
31 #include "coding.h"
32 #include "lisp.h"
33 #include "pdumper.h"
34
35 #include <strftime.h>
36
37 #include <errno.h>
38 #include <limits.h>
39 #include <math.h>
40 #include <stdio.h>
41 #include <stdlib.h>
42
43 #ifdef WINDOWSNT
44 extern clock_t sys_clock (void);
45 #endif
46
47 #ifdef HAVE_TIMEZONE_T
48 # include <sys/param.h>
49 # if defined __NetBSD_Version__ && __NetBSD_Version__ < 700000000
50 # define HAVE_TZALLOC_BUG true
51 # endif
52 #endif
53 #ifndef HAVE_TZALLOC_BUG
54 # define HAVE_TZALLOC_BUG false
55 #endif
56
57 enum { TM_YEAR_BASE = 1900 };
58
59 #ifndef HAVE_TM_GMTOFF
60 # define HAVE_TM_GMTOFF false
61 #endif
62
63 #ifndef TIME_T_MIN
64 # define TIME_T_MIN TYPE_MINIMUM (time_t)
65 #endif
66 #ifndef TIME_T_MAX
67 # define TIME_T_MAX TYPE_MAXIMUM (time_t)
68 #endif
69
70 /* Compile with -DFASTER_TIMEFNS=0 to disable common optimizations and
71 allow easier testing of some slow-path code. */
72 #ifndef FASTER_TIMEFNS
73 # define FASTER_TIMEFNS 1
74 #endif
75
76 /* current-time-list defaults to t, typically generating (HI LO US PS)
77 timestamps. To change the default to nil, generating (TICKS . HZ)
78 timestamps, compile with -DCURRENT_TIME_LIST=0. */
79 #ifndef CURRENT_TIME_LIST
80 enum { CURRENT_TIME_LIST = true };
81 #endif
82
83 #if FIXNUM_OVERFLOW_P (1000000000)
84 static Lisp_Object timespec_hz;
85 #else
86 # define timespec_hz make_fixnum (TIMESPEC_HZ)
87 #endif
88
89 #define TRILLION 1000000000000
90 #if FIXNUM_OVERFLOW_P (TRILLION)
91 static Lisp_Object trillion;
92 # define ztrillion (*xbignum_val (trillion))
93 #else
94 # define trillion make_fixnum (TRILLION)
95 # if ULONG_MAX < TRILLION || !FASTER_TIMEFNS
96 mpz_t ztrillion;
97 # endif
98 #endif
99
100 /* True if the nonzero Lisp integer HZ divides evenly into a trillion. */
101 static bool
102 trillion_factor (Lisp_Object hz)
103 {
104 if (FASTER_TIMEFNS)
105 {
106 if (FIXNUMP (hz))
107 return TRILLION % XFIXNUM (hz) == 0;
108 if (!FIXNUM_OVERFLOW_P (TRILLION))
109 return false;
110 }
111 verify (TRILLION <= INTMAX_MAX);
112 intmax_t ihz;
113 return integer_to_intmax (hz, &ihz) && TRILLION % ihz == 0;
114 }
115
116 /* Return a struct timeval that is roughly equivalent to T.
117 Use the least timeval not less than T.
118 Return an extremal value if the result would overflow. */
119 struct timeval
120 make_timeval (struct timespec t)
121 {
122 struct timeval tv;
123 tv.tv_sec = t.tv_sec;
124 tv.tv_usec = t.tv_nsec / 1000;
125
126 if (t.tv_nsec % 1000 != 0)
127 {
128 if (tv.tv_usec < 999999)
129 tv.tv_usec++;
130 else if (tv.tv_sec < TIME_T_MAX)
131 {
132 tv.tv_sec++;
133 tv.tv_usec = 0;
134 }
135 }
136
137 return tv;
138 }
139
140 /* Yield A's UTC offset, or an unspecified value if unknown. */
141 static long int
142 tm_gmtoff (struct tm *a)
143 {
144 #if HAVE_TM_GMTOFF
145 return a->tm_gmtoff;
146 #else
147 return 0;
148 #endif
149 }
150
151 /* Yield A - B, measured in seconds.
152 This function is copied from the GNU C Library. */
153 static int
154 tm_diff (struct tm *a, struct tm *b)
155 {
156 /* Compute intervening leap days correctly even if year is negative.
157 Take care to avoid int overflow in leap day calculations,
158 but it's OK to assume that A and B are close to each other. */
159 int a4 = (a->tm_year >> 2) + (TM_YEAR_BASE >> 2) - ! (a->tm_year & 3);
160 int b4 = (b->tm_year >> 2) + (TM_YEAR_BASE >> 2) - ! (b->tm_year & 3);
161 int a100 = a4 / 25 - (a4 % 25 < 0);
162 int b100 = b4 / 25 - (b4 % 25 < 0);
163 int a400 = a100 >> 2;
164 int b400 = b100 >> 2;
165 int intervening_leap_days = (a4 - b4) - (a100 - b100) + (a400 - b400);
166 int years = a->tm_year - b->tm_year;
167 int days = (365 * years + intervening_leap_days
168 + (a->tm_yday - b->tm_yday));
169 return (60 * (60 * (24 * days + (a->tm_hour - b->tm_hour))
170 + (a->tm_min - b->tm_min))
171 + (a->tm_sec - b->tm_sec));
172 }
173
174 enum { tzeqlen = sizeof "TZ=" - 1 };
175
176 /* Time zones equivalent to current local time and to UTC, respectively. */
177 static timezone_t local_tz;
178 static timezone_t const utc_tz = 0;
179
180 static struct tm *
181 emacs_localtime_rz (timezone_t tz, time_t const *t, struct tm *tm)
182 {
183 #ifdef WINDOWSNT
184 /* The Windows CRT functions are "optimized for speed", so they don't
185 check for timezone and DST changes if they were last called less
186 than 1 minute ago (see http://support.microsoft.com/kb/821231).
187 So all Emacs features that repeatedly call time functions (e.g.,
188 display-time) are in real danger of missing timezone and DST
189 changes. Calling tzset before each localtime call fixes that. */
190 tzset ();
191 #endif
192 tm = localtime_rz (tz, t, tm);
193 if (!tm && errno == ENOMEM)
194 memory_full (SIZE_MAX);
195 return tm;
196 }
197
198 static AVOID
199 invalid_time_zone_specification (Lisp_Object zone)
200 {
201 xsignal2 (Qerror, build_string ("Invalid time zone specification"), zone);
202 }
203
204 /* Free a timezone, except do not free the time zone for local time.
205 Freeing utc_tz is also a no-op. */
206 static void
207 xtzfree (timezone_t tz)
208 {
209 if (tz != local_tz)
210 tzfree (tz);
211 }
212
213 /* Convert the Lisp time zone rule ZONE to a timezone_t object.
214 The returned value either is 0, or is LOCAL_TZ, or is newly allocated.
215 If SETTZ, set Emacs local time to the time zone rule; otherwise,
216 the caller should eventually pass the returned value to xtzfree. */
217 static timezone_t
218 tzlookup (Lisp_Object zone, bool settz)
219 {
220 static char const tzbuf_format[] = "<%+.*"pI"d>%s%"pI"d:%02d:%02d";
221 char const *trailing_tzbuf_format = tzbuf_format + sizeof "<%+.*"pI"d" - 1;
222 char tzbuf[sizeof tzbuf_format + 2 * INT_STRLEN_BOUND (EMACS_INT)];
223 char const *zone_string;
224 timezone_t new_tz;
225
226 if (NILP (zone))
227 return local_tz;
228 else if (BASE_EQ (zone, make_fixnum (0)) || BASE2_EQ (zone, Qt))
229 {
230 zone_string = "UTC0";
231 new_tz = utc_tz;
232 }
233 else
234 {
235 bool plain_integer = FIXNUMP (zone);
236
237 if (BASE2_EQ (zone, Qwall))
238 zone_string = 0;
239 else if (STRINGP (zone))
240 zone_string = SSDATA (ENCODE_SYSTEM (zone));
241 else if (plain_integer || (CONSP (zone) && FIXNUMP (XCAR (zone))
242 && CONSP (XCDR (zone))))
243 {
244 Lisp_Object abbr UNINIT;
245 if (!plain_integer)
246 {
247 abbr = XCAR (XCDR (zone));
248 zone = XCAR (zone);
249 }
250
251 EMACS_INT abszone = eabs (XFIXNUM (zone)), hour = abszone / (60 * 60);
252 int hour_remainder = abszone % (60 * 60);
253 int min = hour_remainder / 60, sec = hour_remainder % 60;
254
255 if (plain_integer)
256 {
257 int prec = 2;
258 EMACS_INT numzone = hour;
259 if (hour_remainder != 0)
260 {
261 prec += 2, numzone = 100 * numzone + min;
262 if (sec != 0)
263 prec += 2, numzone = 100 * numzone + sec;
264 }
265 sprintf (tzbuf, tzbuf_format, prec,
266 XFIXNUM (zone) < 0 ? -numzone : numzone,
267 &"-"[XFIXNUM (zone) < 0], hour, min, sec);
268 zone_string = tzbuf;
269 }
270 else
271 {
272 AUTO_STRING (leading, "<");
273 AUTO_STRING_WITH_LEN (trailing, tzbuf,
274 sprintf (tzbuf, trailing_tzbuf_format,
275 &"-"[XFIXNUM (zone) < 0],
276 hour, min, sec));
277 zone_string = SSDATA (concat3 (leading, ENCODE_SYSTEM (abbr),
278 trailing));
279 }
280 }
281 else
282 invalid_time_zone_specification (zone);
283
284 new_tz = tzalloc (zone_string);
285
286 if (HAVE_TZALLOC_BUG && !new_tz && errno != ENOMEM && plain_integer
287 && XFIXNUM (zone) % (60 * 60) == 0)
288 {
289 /* tzalloc mishandles POSIX strings; fall back on tzdb if
290 possible (Bug#30738). */
291 sprintf (tzbuf, "Etc/GMT%+"pI"d", - (XFIXNUM (zone) / (60 * 60)));
292 new_tz = tzalloc (zone_string);
293 }
294
295 if (!new_tz)
296 {
297 if (errno == ENOMEM)
298 memory_full (SIZE_MAX);
299 invalid_time_zone_specification (zone);
300 }
301 }
302
303 if (settz)
304 {
305 block_input ();
306 emacs_setenv_TZ (zone_string);
307 tzset ();
308 timezone_t old_tz = local_tz;
309 local_tz = new_tz;
310 tzfree (old_tz);
311 unblock_input ();
312 }
313
314 return new_tz;
315 }
316
317 void
318 init_timefns (void)
319 {
320 #ifdef HAVE_UNEXEC
321 /* A valid but unlikely setting for the TZ environment variable.
322 It is OK (though a bit slower) if the user chooses this value. */
323 static char dump_tz_string[] = "TZ=UtC0";
324
325 /* When just dumping out, set the time zone to a known unlikely value
326 and skip the rest of this function. */
327 if (will_dump_with_unexec_p ())
328 {
329 xputenv (dump_tz_string);
330 tzset ();
331 return;
332 }
333 #endif
334
335 char *tz = getenv ("TZ");
336
337 #ifdef HAVE_UNEXEC
338 /* If the execution TZ happens to be the same as the dump TZ,
339 change it to some other value and then change it back,
340 to force the underlying implementation to reload the TZ info.
341 This is needed on implementations that load TZ info from files,
342 since the TZ file contents may differ between dump and execution. */
343 if (tz && strcmp (tz, &dump_tz_string[tzeqlen]) == 0)
344 {
345 ++*tz;
346 tzset ();
347 --*tz;
348 }
349 #endif
350
351 /* Set the time zone rule now, so that the call to putenv is done
352 before multiple threads are active. */
353 tzlookup (tz ? build_string (tz) : Qwall, true);
354 }
355
356 /* Report that a time value is out of range for Emacs. */
357 static AVOID
358 time_overflow (void)
359 {
360 error ("Specified time is not representable");
361 }
362
363 static AVOID
364 time_error (int err)
365 {
366 switch (err)
367 {
368 case ENOMEM: memory_full (SIZE_MAX);
369 case EOVERFLOW: time_overflow ();
370 default: error ("Invalid time specification");
371 }
372 }
373
374 static AVOID
375 invalid_hz (Lisp_Object hz)
376 {
377 xsignal2 (Qerror, build_string ("Invalid time frequency"), hz);
378 }
379
380 /* Return the upper part of the time T (everything but the bottom 16 bits). */
381 static Lisp_Object
382 hi_time (time_t t)
383 {
384 return INT_TO_INTEGER (t >> LO_TIME_BITS);
385 }
386
387 /* Return the bottom bits of the time T. */
388 static Lisp_Object
389 lo_time (time_t t)
390 {
391 return make_fixnum (t & ((1 << LO_TIME_BITS) - 1));
392 }
393
394 /* When converting a double to a fraction TICKS / HZ, HZ is equal to
395 FLT_RADIX * P where 0 <= P < FLT_RADIX_POWER_SIZE. The tiniest
396 nonzero double uses the maximum P. */
397 enum { flt_radix_power_size = DBL_MANT_DIG - DBL_MIN_EXP + 1 };
398
399 /* A integer vector of size flt_radix_power_size. The Pth entry
400 equals FLT_RADIX**P. */
401 static Lisp_Object flt_radix_power;
402
403 /* Convert the finite number T into an Emacs time *RESULT, truncating
404 toward minus infinity. Signal an error if unsuccessful. */
405 static void
406 decode_float_time (double t, struct lisp_time *result)
407 {
408 Lisp_Object ticks, hz;
409 if (t == 0)
410 {
411 ticks = make_fixnum (0);
412 hz = make_fixnum (1);
413 }
414 else
415 {
416 int scale = double_integer_scale (t);
417 /* FIXME: `double_integer_scale` often returns values that are
418 "pessimistic" (i.e. larger than necessary), so 3.5 gets converted
419 to (7881299347898368 . 2251799813685248) rather than (7 . 2).
420 On 64bit systems, this should not matter very much, tho. */
421 eassume (scale < flt_radix_power_size);
422
423 if (scale < 0)
424 {
425 /* T is finite but so large that HZ would be less than 1 if
426 T's precision were represented exactly. SCALE must be
427 nonnegative, as the (TICKS . HZ) representation requires
428 HZ to be at least 1. So use SCALE = 0, which converts T to
429 (T . 1), which is the exact numeric value with too-large HZ,
430 which is typically better than signaling overflow. */
431 scale = 0;
432 }
433
434 /* Compute TICKS, HZ such that TICKS / HZ exactly equals T, where HZ is
435 T's frequency or 1, whichever is greater. Here, “frequency” means
436 1/precision. Cache HZ values in flt_radix_power. */
437 double scaled = scalbn (t, scale);
438 eassert (trunc (scaled) == scaled);
439 ticks = double_to_integer (scaled);
440 hz = AREF (flt_radix_power, scale);
441 if (NILP (hz))
442 {
443 mpz_ui_pow_ui (mpz[0], FLT_RADIX, scale);
444 hz = make_integer_mpz ();
445 ASET (flt_radix_power, scale, hz);
446 }
447 }
448 result->ticks = ticks;
449 result->hz = hz;
450 }
451
452 /* Make a 4-element timestamp (HI LO US PS) from TICKS and HZ.
453 Drop any excess precision. */
454 static Lisp_Object
455 ticks_hz_list4 (Lisp_Object ticks, Lisp_Object hz)
456 {
457 /* mpz[0] = floor ((ticks * trillion) / hz). */
458 mpz_t const *zticks = bignum_integer (&mpz[0], ticks);
459 #if FASTER_TIMEFNS && TRILLION <= ULONG_MAX
460 mpz_mul_ui (mpz[0], *zticks, TRILLION);
461 #else
462 mpz_mul (mpz[0], *zticks, ztrillion);
463 #endif
464 mpz_fdiv_q (mpz[0], mpz[0], *bignum_integer (&mpz[1], hz));
465
466 /* mpz[0] = floor (mpz[0] / trillion), with US = the high six digits of the
467 12-digit remainder, and PS = the low six digits. */
468 #if FASTER_TIMEFNS && TRILLION <= ULONG_MAX
469 unsigned long int fullps = mpz_fdiv_q_ui (mpz[0], mpz[0], TRILLION);
470 int us = fullps / 1000000;
471 int ps = fullps % 1000000;
472 #else
473 mpz_fdiv_qr (mpz[0], mpz[1], mpz[0], ztrillion);
474 int ps = mpz_fdiv_q_ui (mpz[1], mpz[1], 1000000);
475 int us = mpz_get_ui (mpz[1]);
476 #endif
477
478 /* mpz[0] = floor (mpz[0] / 1 << LO_TIME_BITS), with lo = remainder. */
479 unsigned long ulo = mpz_get_ui (mpz[0]);
480 if (mpz_sgn (mpz[0]) < 0)
481 ulo = -ulo;
482 int lo = ulo & ((1 << LO_TIME_BITS) - 1);
483 mpz_fdiv_q_2exp (mpz[0], mpz[0], LO_TIME_BITS);
484
485 return list4 (make_integer_mpz (), make_fixnum (lo),
486 make_fixnum (us), make_fixnum (ps));
487 }
488
489 /* Set ROP to T. */
490 static void
491 mpz_set_time (mpz_t rop, time_t t)
492 {
493 if (EXPR_SIGNED (t))
494 mpz_set_intmax (rop, t);
495 else
496 mpz_set_uintmax (rop, t);
497 }
498
499 /* Store into mpz[0] a clock tick count for T, assuming a
500 TIMESPEC_HZ-frequency clock. Use mpz[1] as a temp. */
501 static void
502 timespec_mpz (struct timespec t)
503 {
504 /* mpz[0] = sec * TIMESPEC_HZ + nsec. */
505 mpz_set_ui (mpz[0], t.tv_nsec);
506 mpz_set_time (mpz[1], t.tv_sec);
507 mpz_addmul_ui (mpz[0], mpz[1], TIMESPEC_HZ);
508 }
509
510 /* Convert T to a Lisp integer counting TIMESPEC_HZ ticks. */
511 static Lisp_Object
512 timespec_ticks (struct timespec t)
513 {
514 /* For speed, use intmax_t arithmetic if it will do. */
515 intmax_t accum;
516 if (FASTER_TIMEFNS
517 && !ckd_mul (&accum, t.tv_sec, TIMESPEC_HZ)
518 && !ckd_add (&accum, accum, t.tv_nsec))
519 return make_int (accum);
520
521 /* Fall back on bignum arithmetic. */
522 timespec_mpz (t);
523 return make_integer_mpz ();
524 }
525
526 /* Convert T to a Lisp integer counting HZ ticks, taking the floor.
527 Assume T is valid, but check HZ. */
528 static Lisp_Object
529 lisp_time_hz_ticks (struct lisp_time t, Lisp_Object hz)
530 {
531 /* The idea is to return the floor of ((T.ticks * HZ) / T.hz). */
532
533 /* For speed, just return T.ticks if T.hz == HZ. */
534 if (FASTER_TIMEFNS && BASE_EQ (t.hz, hz))
535 return t.ticks;
536
537 /* Check HZ for validity. */
538 if (FIXNUMP (hz))
539 {
540 if (XFIXNUM (hz) <= 0)
541 invalid_hz (hz);
542
543 /* For speed, use intmax_t arithmetic if it will do. */
544 intmax_t ticks;
545 if (FASTER_TIMEFNS && FIXNUMP (t.ticks) && FIXNUMP (t.hz)
546 && !ckd_mul (&ticks, XFIXNUM (t.ticks), XFIXNUM (hz)))
547 return make_int (ticks / XFIXNUM (t.hz)
548 - (ticks % XFIXNUM (t.hz) < 0));
549 }
550 else if (! (BIGNUMP (hz) && 0 < mpz_sgn (*xbignum_val (hz))))
551 invalid_hz (hz);
552
553 /* Fall back on bignum arithmetic. */
554 mpz_mul (mpz[0],
555 *bignum_integer (&mpz[0], t.ticks),
556 *bignum_integer (&mpz[1], hz));
557 mpz_fdiv_q (mpz[0], mpz[0], *bignum_integer (&mpz[1], t.hz));
558 return make_integer_mpz ();
559 }
560
561 /* Convert T to a Lisp integer counting seconds, taking the floor. */
562 static Lisp_Object
563 lisp_time_seconds (struct lisp_time t)
564 {
565 /* The idea is to return the floor of T.ticks / T.hz. */
566
567 if (!FASTER_TIMEFNS)
568 return lisp_time_hz_ticks (t, make_fixnum (1));
569
570 /* For speed, use EMACS_INT arithmetic if it will do. */
571 if (FIXNUMP (t.ticks) && FIXNUMP (t.hz))
572 return make_fixnum (XFIXNUM (t.ticks) / XFIXNUM (t.hz)
573 - (XFIXNUM (t.ticks) % XFIXNUM (t.hz) < 0));
574
575 /* For speed, inline what lisp_time_hz_ticks would do. */
576 mpz_fdiv_q (mpz[0],
577 *bignum_integer (&mpz[0], t.ticks),
578 *bignum_integer (&mpz[1], t.hz));
579 return make_integer_mpz ();
580 }
581
582 /* Convert T to a Lisp timestamp. */
583 Lisp_Object
584 make_lisp_time (struct timespec t)
585 {
586 if (current_time_list)
587 {
588 time_t s = t.tv_sec;
589 int ns = t.tv_nsec;
590 return list4 (hi_time (s), lo_time (s),
591 make_fixnum (ns / 1000), make_fixnum (ns % 1000 * 1000));
592 }
593 else
594 return timespec_to_lisp (t);
595 }
596
597 /* Return (TICKS . HZ) for time T. */
598 Lisp_Object
599 timespec_to_lisp (struct timespec t)
600 {
601 return Fcons (timespec_ticks (t), timespec_hz);
602 }
603
604 /* Return NUMERATOR / DENOMINATOR, rounded to the nearest double.
605 Arguments must be Lisp integers, and DENOMINATOR must be positive. */
606 static double
607 frac_to_double (Lisp_Object numerator, Lisp_Object denominator)
608 {
609 intmax_t intmax_numerator, intmax_denominator;
610 if (FASTER_TIMEFNS
611 && integer_to_intmax (numerator, &intmax_numerator)
612 && integer_to_intmax (denominator, &intmax_denominator)
613 && intmax_numerator % intmax_denominator == 0)
614 return intmax_numerator / intmax_denominator;
615
616 /* Compute number of base-FLT_RADIX digits in numerator and denominator. */
617 mpz_t const *n = bignum_integer (&mpz[0], numerator);
618 mpz_t const *d = bignum_integer (&mpz[1], denominator);
619 ptrdiff_t ndig = mpz_sizeinbase (*n, FLT_RADIX);
620 ptrdiff_t ddig = mpz_sizeinbase (*d, FLT_RADIX);
621
622 /* Scale with SCALE when doing integer division. That is, compute
623 (N * FLT_RADIX**SCALE) / D [or, if SCALE is negative, N / (D *
624 FLT_RADIX**-SCALE)] as a bignum, convert the bignum to double,
625 then divide the double by FLT_RADIX**SCALE. First scale N
626 (or scale D, if SCALE is negative) ... */
627 ptrdiff_t scale = ddig - ndig + DBL_MANT_DIG;
628 if (scale < 0)
629 {
630 mpz_mul_2exp (mpz[1], *d, - (scale * LOG2_FLT_RADIX));
631 d = &mpz[1];
632 }
633 else
634 {
635 /* min so we don't scale tiny numbers as if they were normalized. */
636 scale = min (scale, flt_radix_power_size - 1);
637
638 mpz_mul_2exp (mpz[0], *n, scale * LOG2_FLT_RADIX);
639 n = &mpz[0];
640 }
641 /* ... and then divide, with quotient Q and remainder R. */
642 mpz_t *q = &mpz[2];
643 mpz_t *r = &mpz[3];
644 mpz_tdiv_qr (*q, *r, *n, *d);
645
646 /* The amount to add to the absolute value of Q so that truncating
647 it to double will round correctly. */
648 int incr;
649
650 /* Round the quotient before converting it to double.
651 If the quotient is less than FLT_RADIX ** DBL_MANT_DIG,
652 round to the nearest integer; otherwise, it is less than
653 FLT_RADIX ** (DBL_MANT_DIG + 1) and round it to the nearest
654 multiple of FLT_RADIX. Break ties to even. */
655 if (mpz_sizeinbase (*q, FLT_RADIX) <= DBL_MANT_DIG)
656 {
657 /* Converting to double will use the whole quotient so add 1 to
658 its absolute value as per round-to-even; i.e., if the doubled
659 remainder exceeds the denominator, or exactly equals the
660 denominator and adding 1 would make the quotient even. */
661 mpz_mul_2exp (*r, *r, 1);
662 int cmp = mpz_cmpabs (*r, *d);
663 incr = cmp > 0 || (cmp == 0 && (FASTER_TIMEFNS && FLT_RADIX == 2
664 ? mpz_odd_p (*q)
665 : mpz_tdiv_ui (*q, FLT_RADIX) & 1));
666 }
667 else
668 {
669 /* Converting to double will discard the quotient's low-order digit,
670 so add FLT_RADIX to its absolute value as per round-to-even. */
671 int lo_2digits = mpz_tdiv_ui (*q, FLT_RADIX * FLT_RADIX);
672 eassume (0 <= lo_2digits && lo_2digits < FLT_RADIX * FLT_RADIX);
673 int lo_digit = lo_2digits % FLT_RADIX;
674 incr = ((lo_digit > FLT_RADIX / 2
675 || (lo_digit == FLT_RADIX / 2 && FLT_RADIX % 2 == 0
676 && ((lo_2digits / FLT_RADIX) & 1
677 || mpz_sgn (*r) != 0)))
678 ? FLT_RADIX : 0);
679 }
680
681 /* Increment the absolute value of the quotient by INCR. */
682 if (!FASTER_TIMEFNS || incr != 0)
683 (mpz_sgn (*n) < 0 ? mpz_sub_ui : mpz_add_ui) (*q, *q, incr);
684
685 /* Rescale the integer Q back to double. This step does not round. */
686 return scalbn (mpz_get_d (*q), -scale);
687 }
688
689 /* From a valid timestamp (TICKS . HZ), generate the corresponding
690 time values.
691
692 If RESULT is not null, store into *RESULT the converted time.
693 Otherwise, store into *DRESULT the number of seconds since the
694 start of the POSIX Epoch.
695
696 Return zero, which indicates success. */
697 static int
698 decode_ticks_hz (Lisp_Object ticks, Lisp_Object hz,
699 struct lisp_time *result, double *dresult)
700 {
701 if (result)
702 {
703 result->ticks = ticks;
704 result->hz = hz;
705 }
706 else
707 *dresult = frac_to_double (ticks, hz);
708 return 0;
709 }
710
711 /* Lisp timestamp classification. */
712 enum timeform
713 {
714 TIMEFORM_INVALID = 0,
715 TIMEFORM_HI_LO, /* seconds in the form (HI << LO_TIME_BITS) + LO. */
716 TIMEFORM_HI_LO_US, /* seconds plus microseconds (HI LO US) */
717 TIMEFORM_NIL, /* current time in nanoseconds */
718 TIMEFORM_HI_LO_US_PS, /* seconds plus micro and picoseconds (HI LO US PS) */
719 TIMEFORM_FLOAT, /* time as a float */
720 TIMEFORM_TICKS_HZ /* fractional time: HI is ticks, LO is ticks per second */
721 };
722
723 /* From the non-float form FORM and the time components HIGH, LOW, USEC
724 and PSEC, generate the corresponding time value. If LOW is
725 floating point, the other components should be zero and FORM should
726 not be TIMEFORM_TICKS_HZ.
727
728 If RESULT is not null, store into *RESULT the converted time.
729 Otherwise, store into *DRESULT the number of seconds since the
730 start of the POSIX Epoch. Unsuccessful calls may or may not store
731 results.
732
733 Return zero if successful, an error number otherwise. */
734 static int
735 decode_time_components (enum timeform form,
736 Lisp_Object high, Lisp_Object low,
737 Lisp_Object usec, Lisp_Object psec,
738 struct lisp_time *result, double *dresult)
739 {
740 switch (form)
741 {
742 case TIMEFORM_INVALID:
743 return EINVAL;
744
745 case TIMEFORM_TICKS_HZ:
746 if (INTEGERP (high)
747 && !NILP (Fnatnump (low)) && !BASE_EQ (low, make_fixnum (0)))
748 return decode_ticks_hz (high, low, result, dresult);
749 return EINVAL;
750
751 case TIMEFORM_FLOAT:
752 eassume (false);
753
754 case TIMEFORM_NIL:
755 return decode_ticks_hz (timespec_ticks (current_timespec ()),
756 timespec_hz, result, dresult);
757
758 default:
759 break;
760 }
761
762 if (! (INTEGERP (high) && INTEGERP (low)
763 && FIXNUMP (usec) && FIXNUMP (psec)))
764 return EINVAL;
765 EMACS_INT us = XFIXNUM (usec);
766 EMACS_INT ps = XFIXNUM (psec);
767
768 /* Normalize out-of-range lower-order components by carrying
769 each overflow into the next higher-order component. */
770 us += ps / 1000000 - (ps % 1000000 < 0);
771 mpz_t *s = &mpz[1];
772 mpz_set_intmax (*s, us / 1000000 - (us % 1000000 < 0));
773 mpz_add (*s, *s, *bignum_integer (&mpz[0], low));
774 mpz_addmul_ui (*s, *bignum_integer (&mpz[0], high), 1 << LO_TIME_BITS);
775 ps = ps % 1000000 + 1000000 * (ps % 1000000 < 0);
776 us = us % 1000000 + 1000000 * (us % 1000000 < 0);
777
778 Lisp_Object hz;
779 switch (form)
780 {
781 case TIMEFORM_HI_LO:
782 /* Floats and nil were handled above, so it was an integer. */
783 mpz_swap (mpz[0], *s);
784 hz = make_fixnum (1);
785 break;
786
787 case TIMEFORM_HI_LO_US:
788 mpz_set_ui (mpz[0], us);
789 mpz_addmul_ui (mpz[0], *s, 1000000);
790 hz = make_fixnum (1000000);
791 break;
792
793 case TIMEFORM_HI_LO_US_PS:
794 {
795 #if FASTER_TIMEFNS && TRILLION <= ULONG_MAX
796 unsigned long i = us;
797 mpz_set_ui (mpz[0], i * 1000000 + ps);
798 mpz_addmul_ui (mpz[0], *s, TRILLION);
799 #else
800 intmax_t i = us;
801 mpz_set_intmax (mpz[0], i * 1000000 + ps);
802 mpz_addmul (mpz[0], *s, ztrillion);
803 #endif
804 hz = trillion;
805 }
806 break;
807
808 default:
809 eassume (false);
810 }
811
812 return decode_ticks_hz (make_integer_mpz (), hz, result, dresult);
813 }
814
815 /* Decode a Lisp timestamp SPECIFIED_TIME that represents a time.
816
817 If DECODE_SECS_ONLY, ignore and do not validate any sub-second
818 components of an old-format SPECIFIED_TIME.
819
820 If RESULT is not null, store into *RESULT the converted time;
821 otherwise, store into *DRESULT the number of seconds since the
822 start of the POSIX Epoch. Unsuccessful calls may or may not store
823 results.
824
825 Return the form of SPECIFIED-TIME. Signal an error if unsuccessful. */
826 static enum timeform
827 decode_lisp_time (Lisp_Object specified_time, bool decode_secs_only,
828 struct lisp_time *result, double *dresult)
829 {
830 Lisp_Object high = make_fixnum (0);
831 Lisp_Object low = specified_time;
832 Lisp_Object usec = make_fixnum (0);
833 Lisp_Object psec = make_fixnum (0);
834 enum timeform form = TIMEFORM_HI_LO;
835
836 if (NILP (specified_time))
837 form = TIMEFORM_NIL;
838 else if (CONSP (specified_time))
839 {
840 high = XCAR (specified_time);
841 low = XCDR (specified_time);
842 if (CONSP (low))
843 {
844 Lisp_Object low_tail = XCDR (low);
845 low = XCAR (low);
846 if (! decode_secs_only)
847 {
848 if (CONSP (low_tail))
849 {
850 usec = XCAR (low_tail);
851 low_tail = XCDR (low_tail);
852 if (CONSP (low_tail))
853 {
854 psec = XCAR (low_tail);
855 form = TIMEFORM_HI_LO_US_PS;
856 }
857 else
858 form = TIMEFORM_HI_LO_US;
859 }
860 else if (!NILP (low_tail))
861 {
862 usec = low_tail;
863 form = TIMEFORM_HI_LO_US;
864 }
865 }
866 }
867 else
868 {
869 form = TIMEFORM_TICKS_HZ;
870 }
871
872 /* Require LOW to be an integer, as otherwise the computation
873 would be considerably trickier. */
874 if (! INTEGERP (low))
875 form = TIMEFORM_INVALID;
876 }
877 else if (FASTER_TIMEFNS && INTEGERP (specified_time))
878 {
879 decode_ticks_hz (specified_time, make_fixnum (1), result, dresult);
880 return form;
881 }
882 else if (FLOATP (specified_time))
883 {
884 double d = XFLOAT_DATA (specified_time);
885 if (!isfinite (d))
886 time_error (isnan (d) ? EDOM : EOVERFLOW);
887 if (result)
888 decode_float_time (d, result);
889 else
890 *dresult = d;
891 return TIMEFORM_FLOAT;
892 }
893
894 int err = decode_time_components (form, high, low, usec, psec,
895 result, dresult);
896 if (err)
897 time_error (err);
898 return form;
899 }
900
901 /* Convert a non-float Lisp timestamp SPECIFIED_TIME to double.
902 Signal an error if unsuccessful. */
903 double
904 float_time (Lisp_Object specified_time)
905 {
906 double t;
907 decode_lisp_time (specified_time, false, 0, &t);
908 return t;
909 }
910
911 /* Convert Z to time_t, returning true if it fits. */
912 static bool
913 mpz_time (mpz_t const z, time_t *t)
914 {
915 if (TYPE_SIGNED (time_t))
916 {
917 intmax_t i;
918 if (! (mpz_to_intmax (z, &i) && TIME_T_MIN <= i && i <= TIME_T_MAX))
919 return false;
920 *t = i;
921 }
922 else
923 {
924 uintmax_t i;
925 if (! (mpz_to_uintmax (z, &i) && i <= TIME_T_MAX))
926 return false;
927 *t = i;
928 }
929 return true;
930 }
931
932 /* Convert T to struct timespec, returning an invalid timespec
933 if T does not fit. */
934 static struct timespec
935 lisp_to_timespec (struct lisp_time t)
936 {
937 struct timespec result = invalid_timespec ();
938 int ns;
939 mpz_t *q = &mpz[0];
940 mpz_t const *qt = q;
941
942 /* Floor-divide (T.ticks * TIMESPEC_HZ) by T.hz,
943 yielding quotient Q (tv_sec) and remainder NS (tv_nsec).
944 Return an invalid timespec if Q does not fit in time_t.
945 For speed, prefer fixnum arithmetic if it works. */
946 if (FASTER_TIMEFNS && BASE_EQ (t.hz, timespec_hz))
947 {
948 if (FIXNUMP (t.ticks))
949 {
950 EMACS_INT s = XFIXNUM (t.ticks) / TIMESPEC_HZ;
951 ns = XFIXNUM (t.ticks) % TIMESPEC_HZ;
952 if (ns < 0)
953 s--, ns += TIMESPEC_HZ;
954 if ((TYPE_SIGNED (time_t) ? TIME_T_MIN <= s : 0 <= s)
955 && s <= TIME_T_MAX)
956 {
957 result.tv_sec = s;
958 result.tv_nsec = ns;
959 }
960 return result;
961 }
962 else
963 ns = mpz_fdiv_q_ui (*q, *xbignum_val (t.ticks), TIMESPEC_HZ);
964 }
965 else if (FASTER_TIMEFNS && BASE_EQ (t.hz, make_fixnum (1)))
966 {
967 ns = 0;
968 if (FIXNUMP (t.ticks))
969 {
970 EMACS_INT s = XFIXNUM (t.ticks);
971 if ((TYPE_SIGNED (time_t) ? TIME_T_MIN <= s : 0 <= s)
972 && s <= TIME_T_MAX)
973 {
974 result.tv_sec = s;
975 result.tv_nsec = ns;
976 }
977 return result;
978 }
979 else
980 qt = xbignum_val (t.ticks);
981 }
982 else
983 {
984 mpz_mul_ui (*q, *bignum_integer (q, t.ticks), TIMESPEC_HZ);
985 mpz_fdiv_q (*q, *q, *bignum_integer (&mpz[1], t.hz));
986 ns = mpz_fdiv_q_ui (*q, *q, TIMESPEC_HZ);
987 }
988
989 /* Check that Q fits in time_t, not merely in T.tv_sec. With some versions
990 of MinGW, tv_sec is a 64-bit type, whereas time_t is a 32-bit type. */
991 time_t sec;
992 if (mpz_time (*qt, &sec))
993 {
994 result.tv_sec = sec;
995 result.tv_nsec = ns;
996 }
997 return result;
998 }
999
1000 /* Convert (HIGH LOW USEC PSEC) to struct timespec.
1001 Return true if successful. */
1002 bool
1003 list4_to_timespec (Lisp_Object high, Lisp_Object low,
1004 Lisp_Object usec, Lisp_Object psec,
1005 struct timespec *result)
1006 {
1007 struct lisp_time t;
1008 if (decode_time_components (TIMEFORM_HI_LO_US_PS, high, low, usec, psec,
1009 &t, 0))
1010 return false;
1011 *result = lisp_to_timespec (t);
1012 return timespec_valid_p (*result);
1013 }
1014
1015 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1016 If SPECIFIED_TIME is nil, use the current time.
1017 Signal an error if SPECIFIED_TIME does not represent a time.
1018 If PFORM, store the time's form into *PFORM. */
1019 static struct lisp_time
1020 lisp_time_struct (Lisp_Object specified_time, enum timeform *pform)
1021 {
1022 struct lisp_time t;
1023 enum timeform form = decode_lisp_time (specified_time, false, &t, 0);
1024 if (pform)
1025 *pform = form;
1026 return t;
1027 }
1028
1029 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1030 Discard any low-order (sub-ns) resolution.
1031 If SPECIFIED_TIME is nil, use the current time.
1032 Signal an error if SPECIFIED_TIME does not represent a timespec. */
1033 struct timespec
1034 lisp_time_argument (Lisp_Object specified_time)
1035 {
1036 struct lisp_time lt = lisp_time_struct (specified_time, 0);
1037 struct timespec t = lisp_to_timespec (lt);
1038 if (! timespec_valid_p (t))
1039 time_overflow ();
1040 return t;
1041 }
1042
1043 /* Like lisp_time_argument, except decode only the seconds part, and
1044 do not check the subseconds part. */
1045 static time_t
1046 lisp_seconds_argument (Lisp_Object specified_time)
1047 {
1048 struct lisp_time lt;
1049 decode_lisp_time (specified_time, true, <, 0);
1050 struct timespec t = lisp_to_timespec (lt);
1051 if (! timespec_valid_p (t))
1052 time_overflow ();
1053 return t.tv_sec;
1054 }
1055
1056 /* Return the sum of the Lisp integers A and B.
1057 Subtract instead of adding if SUBTRACT.
1058 This function is tuned for small B. */
1059 static Lisp_Object
1060 lispint_arith (Lisp_Object a, Lisp_Object b, bool subtract)
1061 {
1062 bool mpz_done = false;
1063
1064 if (FASTER_TIMEFNS && FIXNUMP (b))
1065 {
1066 if (BASE_EQ (b, make_fixnum (0)))
1067 return a;
1068
1069 /* For speed, use EMACS_INT arithmetic if it will do. */
1070 if (FIXNUMP (a))
1071 return make_int (subtract
1072 ? XFIXNUM (a) - XFIXNUM (b)
1073 : XFIXNUM (a) + XFIXNUM (b));
1074
1075 /* For speed, use mpz_add_ui/mpz_sub_ui if it will do. */
1076 if (eabs (XFIXNUM (b)) <= ULONG_MAX)
1077 {
1078 ((XFIXNUM (b) < 0) == subtract ? mpz_add_ui : mpz_sub_ui)
1079 (mpz[0], *xbignum_val (a), eabs (XFIXNUM (b)));
1080 mpz_done = true;
1081 }
1082 }
1083
1084 /* Fall back on bignum arithmetic if necessary. */
1085 if (!mpz_done)
1086 (subtract ? mpz_sub : mpz_add) (mpz[0],
1087 *bignum_integer (&mpz[0], a),
1088 *bignum_integer (&mpz[1], b));
1089 return make_integer_mpz ();
1090 }
1091
1092 /* Given Lisp operands A and B, add their values, and return the
1093 result as a Lisp timestamp. Subtract instead of adding if SUBTRACT. */
1094 static Lisp_Object
1095 time_arith (Lisp_Object a, Lisp_Object b, bool subtract)
1096 {
1097 enum timeform aform, bform;
1098 struct lisp_time ta = lisp_time_struct (a, &aform);
1099 struct lisp_time tb = lisp_time_struct (b, &bform);
1100 Lisp_Object ticks, hz;
1101
1102 if (FASTER_TIMEFNS && BASE_EQ (ta.hz, tb.hz))
1103 {
1104 hz = ta.hz;
1105 ticks = lispint_arith (ta.ticks, tb.ticks, subtract);
1106 }
1107 else
1108 {
1109 /* The plan is to decompose ta into na/da and tb into nb/db.
1110 Start by computing da and db, their minimum (which will be
1111 needed later) and the iticks temporary that will become
1112 available once only their minimum is needed. */
1113 mpz_t const *da = bignum_integer (&mpz[1], ta.hz);
1114 mpz_t const *db = bignum_integer (&mpz[2], tb.hz);
1115 bool da_lt_db = mpz_cmp (*da, *db) < 0;
1116 mpz_t const *hzmin = da_lt_db ? da : db;
1117 mpz_t *iticks = &mpz[da_lt_db + 1];
1118
1119 /* The plan is to compute (na * (db/g) + nb * (da/g)) / lcm (da, db)
1120 where g = gcd (da, db). Start by computing g. */
1121 mpz_t *g = &mpz[3];
1122 mpz_gcd (*g, *da, *db);
1123
1124 /* fa = da/g, fb = db/g. */
1125 mpz_t *fa = &mpz[4], *fb = &mpz[3];
1126 mpz_divexact (*fa, *da, *g);
1127 mpz_divexact (*fb, *db, *g);
1128
1129 /* ihz = fa * db. This is equal to lcm (da, db). */
1130 mpz_t *ihz = &mpz[0];
1131 mpz_mul (*ihz, *fa, *db);
1132
1133 /* iticks = (fb * na) OP (fa * nb), where OP is + or -. */
1134 mpz_t const *na = bignum_integer (iticks, ta.ticks);
1135 mpz_mul (*iticks, *fb, *na);
1136 mpz_t const *nb = bignum_integer (&mpz[3], tb.ticks);
1137 (subtract ? mpz_submul : mpz_addmul) (*iticks, *fa, *nb);
1138
1139 /* Normalize iticks/ihz by dividing both numerator and
1140 denominator by ig = gcd (iticks, ihz). For speed, though,
1141 skip this division if ihz = 1. */
1142 mpz_t *ig = &mpz[3];
1143 mpz_gcd (*ig, *iticks, *ihz);
1144 if (!FASTER_TIMEFNS || mpz_cmp_ui (*ig, 1) > 0)
1145 {
1146 mpz_divexact (*iticks, *iticks, *ig);
1147 mpz_divexact (*ihz, *ihz, *ig);
1148
1149 /* However, if dividing the denominator by ig would cause the
1150 denominator to become less than hzmin, rescale the denominator
1151 upwards by multiplying the normalized numerator and denominator
1152 so that the resulting denominator becomes at least hzmin.
1153 This rescaling avoids returning a timestamp that is less precise
1154 than both a and b. */
1155 if (!FASTER_TIMEFNS || mpz_cmp (*ihz, *hzmin) < 0)
1156 {
1157 /* Rescale straightforwardly. Although this might not
1158 yield the minimal denominator that preserves numeric
1159 value and is at least hzmin, calculating such a
1160 denominator would be too expensive because it would
1161 require testing multisets of factors of lcm (da, db). */
1162 mpz_t *rescale = &mpz[3];
1163 mpz_cdiv_q (*rescale, *hzmin, *ihz);
1164 mpz_mul (*iticks, *iticks, *rescale);
1165 mpz_mul (*ihz, *ihz, *rescale);
1166 }
1167 }
1168
1169 /* mpz[0] and iticks now correspond to the (HZ . TICKS) pair. */
1170 hz = make_integer_mpz ();
1171 mpz_swap (mpz[0], *iticks);
1172 ticks = make_integer_mpz ();
1173 }
1174
1175 /* Return an integer if the timestamp resolution is 1,
1176 otherwise the (TICKS . HZ) form if !current_time_list or if
1177 either input used (TICKS . HZ) form or the result can't be expressed
1178 exactly in (HI LO US PS) form, otherwise the (HI LO US PS) form
1179 for backward compatibility. */
1180 return (BASE_EQ (hz, make_fixnum (1))
1181 ? ticks
1182 : (!current_time_list
1183 || aform == TIMEFORM_TICKS_HZ
1184 || bform == TIMEFORM_TICKS_HZ
1185 || !trillion_factor (hz))
1186 ? Fcons (ticks, hz)
1187 : ticks_hz_list4 (ticks, hz));
1188 }
1189
1190 DEFUN ("time-add", Ftime_add, Stime_add, 2, 2, 0,
1191 doc: /* Return the sum of two time values A and B, as a time value.
1192 See `format-time-string' for the various forms of a time value.
1193 For example, nil stands for the current time. */)
1194 (Lisp_Object a, Lisp_Object b)
1195 {
1196 return time_arith (a, b, false);
1197 }
1198
1199 DEFUN ("time-subtract", Ftime_subtract, Stime_subtract, 2, 2, 0,
1200 doc: /* Return the difference between two time values A and B, as a time value.
1201 You can use `float-time' to convert the difference into elapsed seconds.
1202 See `format-time-string' for the various forms of a time value.
1203 For example, nil stands for the current time. */)
1204 (Lisp_Object a, Lisp_Object b)
1205 {
1206 /* Subtract nil from nil correctly, and handle other eq values
1207 quicker while we're at it. This means (time-subtract X X) does
1208 not signal an error if X is not a valid time value, but that's OK. */
1209 if (BASE_EQ (a, b))
1210 return make_lisp_time ((struct timespec) {0});
1211
1212 return time_arith (a, b, true);
1213 }
1214
1215 /* Return negative, 0, positive if A < B, A == B, A > B respectively.
1216 A and B should be Lisp time values. */
1217 static EMACS_INT
1218 time_cmp (Lisp_Object a, Lisp_Object b)
1219 {
1220 /* Compare nil to nil correctly, and handle other eq values quicker
1221 while we're at it. This means (time-equal-p X X) does not signal
1222 an error if X is not a valid time value, but that's OK. */
1223 if (BASE_EQ (a, b))
1224 return 0;
1225
1226 /* Compare (X . Z) to (Y . Z) quickly if X and Y are fixnums.
1227 Do not inspect Z, as it is OK to not signal if A and B are invalid.
1228 Also, compare X to Y quickly if X and Y are fixnums. */
1229 if (FASTER_TIMEFNS)
1230 {
1231 Lisp_Object x = a, y = b;
1232 if (CONSP (a) && CONSP (b) && BASE_EQ (XCDR (a), XCDR (b)))
1233 x = XCAR (a), y = XCAR (b);
1234 if (FIXNUMP (x) && FIXNUMP (y))
1235 return XFIXNUM (x) - XFIXNUM (y);
1236 }
1237
1238 /* Compare (ATICKS . AZ) to (BTICKS . BHZ) by comparing
1239 ATICKS * BHZ to BTICKS * AHZ. */
1240 struct lisp_time ta = lisp_time_struct (a, 0);
1241 struct lisp_time tb = lisp_time_struct (b, 0);
1242 mpz_t const *za = bignum_integer (&mpz[0], ta.ticks);
1243 mpz_t const *zb = bignum_integer (&mpz[1], tb.ticks);
1244 if (! (FASTER_TIMEFNS && BASE_EQ (ta.hz, tb.hz)))
1245 {
1246 /* This could be sped up by looking at the signs, sizes, and
1247 number of bits of the two sides; see how GMP does mpq_cmp.
1248 It may not be worth the trouble here, though. */
1249 mpz_mul (mpz[0], *za, *bignum_integer (&mpz[2], tb.hz));
1250 mpz_mul (mpz[1], *zb, *bignum_integer (&mpz[2], ta.hz));
1251 za = &mpz[0];
1252 zb = &mpz[1];
1253 }
1254 return mpz_cmp (*za, *zb);
1255 }
1256
1257 DEFUN ("time-less-p", Ftime_less_p, Stime_less_p, 2, 2, 0,
1258 doc: /* Return non-nil if time value A is less than time value B.
1259 See `format-time-string' for the various forms of a time value.
1260 For example, nil stands for the current time. */)
1261 (Lisp_Object a, Lisp_Object b)
1262 {
1263 return time_cmp (a, b) < 0 ? Qt : Qnil;
1264 }
1265
1266 DEFUN ("time-equal-p", Ftime_equal_p, Stime_equal_p, 2, 2, 0,
1267 doc: /* Return non-nil if A and B are equal time values.
1268 See `format-time-string' for the various forms of a time value. */)
1269 (Lisp_Object a, Lisp_Object b)
1270 {
1271 /* A nil arg compares unequal to a non-nil arg. This also saves the
1272 expense of current_timespec if either arg is nil. */
1273 return NILP (a) == NILP (b) && time_cmp (a, b) == 0 ? Qt : Qnil;
1274 }
1275
1276
1277 DEFUN ("float-time", Ffloat_time, Sfloat_time, 0, 1, 0,
1278 doc: /* Return the current time, as a float number of seconds since the epoch.
1279 If SPECIFIED-TIME is given, it is a time value to convert to float
1280 instead of the current time. See `format-time-string' for the various
1281 forms of a time value.
1282
1283 WARNING: Since the result is floating point, it may not be exact.
1284 If precise time stamps are required, use either `time-convert',
1285 or (if you need time as a string) `format-time-string'. */)
1286 (Lisp_Object specified_time)
1287 {
1288 return (FLOATP (specified_time) ? specified_time
1289 : make_float (float_time (specified_time)));
1290 }
1291
1292 /* Write information into buffer S of size MAXSIZE, according to the
1293 FORMAT of length FORMAT_LEN, using time information taken from *TP.
1294 Use the time zone specified by TZ.
1295 Use NS as the number of nanoseconds in the %N directive.
1296 Return the number of bytes written, not including the terminating
1297 '\0'. If S is NULL, nothing will be written anywhere; so to
1298 determine how many bytes would be written, use NULL for S and
1299 ((size_t) -1) for MAXSIZE.
1300
1301 This function behaves like nstrftime, except it allows null
1302 bytes in FORMAT. */
1303 static size_t
1304 emacs_nmemftime (char *s, size_t maxsize, const char *format,
1305 size_t format_len, const struct tm *tp, timezone_t tz, int ns)
1306 {
1307 int saved_errno = errno;
1308 size_t total = 0;
1309
1310 /* Loop through all the null-terminated strings in the format
1311 argument. Normally there's just one null-terminated string, but
1312 there can be arbitrarily many, concatenated together, if the
1313 format contains '\0' bytes. nstrftime stops at the first
1314 '\0' byte so we must invoke it separately for each such string. */
1315 for (;;)
1316 {
1317 errno = 0;
1318 size_t result = nstrftime (s, maxsize, format, tp, tz, ns);
1319 if (result == 0 && errno != 0)
1320 return result;
1321 if (s)
1322 s += result + 1;
1323
1324 maxsize -= result + 1;
1325 total += result;
1326 size_t len = strlen (format);
1327 if (len == format_len)
1328 break;
1329 total++;
1330 format += len + 1;
1331 format_len -= len + 1;
1332 }
1333
1334 errno = saved_errno;
1335 return total;
1336 }
1337
1338 static Lisp_Object
1339 format_time_string (char const *format, ptrdiff_t formatlen,
1340 struct timespec t, Lisp_Object zone, struct tm *tmp)
1341 {
1342 char buffer[4000];
1343 char *buf = buffer;
1344 ptrdiff_t size = sizeof buffer;
1345 size_t len;
1346 int ns = t.tv_nsec;
1347 USE_SAFE_ALLOCA;
1348
1349 timezone_t tz = tzlookup (zone, false);
1350 /* On some systems, like 32-bit MinGW, tv_sec of struct timespec is
1351 a 64-bit type, but time_t is a 32-bit type. emacs_localtime_rz
1352 expects a pointer to time_t value. */
1353 time_t tsec = t.tv_sec;
1354 tmp = emacs_localtime_rz (tz, &tsec, tmp);
1355 if (! tmp)
1356 {
1357 int localtime_errno = errno;
1358 xtzfree (tz);
1359 time_error (localtime_errno);
1360 }
1361 synchronize_system_time_locale ();
1362
1363 while (true)
1364 {
1365 errno = 0;
1366 len = emacs_nmemftime (buf, size, format, formatlen, tmp, tz, ns);
1367 if (len != 0 || errno == 0)
1368 break;
1369 eassert (errno == ERANGE);
1370
1371 /* Buffer was too small, so make it bigger and try again. */
1372 len = emacs_nmemftime (NULL, SIZE_MAX, format, formatlen, tmp, tz, ns);
1373 if (STRING_BYTES_BOUND <= len)
1374 {
1375 xtzfree (tz);
1376 string_overflow ();
1377 }
1378 size = len + 1;
1379 buf = SAFE_ALLOCA (size);
1380 }
1381
1382 xtzfree (tz);
1383 AUTO_STRING_WITH_LEN (bufstring, buf, len);
1384 Lisp_Object result = code_convert_string_norecord (bufstring,
1385 Vlocale_coding_system, 0);
1386 SAFE_FREE ();
1387 return result;
1388 }
1389
1390 DEFUN ("format-time-string", Fformat_time_string, Sformat_time_string, 1, 3, 0,
1391 doc: /* Use FORMAT-STRING to format the time value TIME.
1392 A time value that is omitted or nil stands for the current time,
1393 a number stands for that many seconds, an integer pair (TICKS . HZ)
1394 stands for TICKS/HZ seconds, and an integer list (HI LO US PS) stands
1395 for HI*2**16 + LO + US/10**6 + PS/10**12 seconds. This function
1396 treats seconds as time since the epoch of 1970-01-01 00:00:00 UTC.
1397
1398 The optional ZONE is omitted or nil for Emacs local time, t for
1399 Universal Time, `wall' for system wall clock time, or a string as in
1400 the TZ environment variable. It can also be a list (as from
1401 `current-time-zone') or an integer (as from `decode-time') applied
1402 without consideration for daylight saving time.
1403
1404 The value is a copy of FORMAT-STRING, but with certain constructs replaced
1405 by text that describes the specified date and time in TIME:
1406
1407 %Y is the year, %y year without century, %C the century.
1408 %G is the year corresponding to the ISO week, %g year corresponding
1409 to the ISO week, without century.
1410 %m is the numeric month.
1411 %b and %h are the locale's abbreviated month name, %B the full name.
1412 (%h is not supported on MS-Windows.)
1413 %d is the day of the month, zero-padded, %e is blank-padded.
1414 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
1415 %a is the locale's abbreviated name of the day of week, %A the full name.
1416 %U is the week number starting on Sunday, %W starting on Monday,
1417 %V the week number according to ISO 8601.
1418 %j is the day of the year.
1419
1420 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
1421 only blank-padded, %l is like %I blank-padded.
1422 %p is the locale's equivalent of either AM or PM.
1423 %q is the calendar quarter (1–4).
1424 %M is the minute (00-59).
1425 %S is the second (00-59; 00-60 on platforms with leap seconds)
1426 %s is the number of seconds since 1970-01-01 00:00:00 +0000.
1427 %N is the nanosecond, %6N the microsecond, %3N the millisecond, etc.
1428 %Z is the time zone abbreviation, %z is the numeric form.
1429
1430 %c is the locale's date and time format.
1431 %x is the locale's "preferred" date format.
1432 %D is like "%m/%d/%y".
1433 %F is the ISO 8601 date format (like "%+4Y-%m-%d").
1434
1435 %R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
1436 %X is the locale's "preferred" time format.
1437
1438 Finally, %n is a newline, %t is a tab, %% is a literal %, and
1439 unrecognized %-sequences stand for themselves.
1440
1441 A %-sequence can contain optional flags, field width, and a modifier
1442 (in that order) after the `%'. The flags are:
1443
1444 `-' Do not pad the field.
1445 `_' Pad with spaces.
1446 `0' Pad with zeros.
1447 `+' Pad with zeros and put `+' before nonnegative year numbers with >4 digits.
1448 `^' Use upper case characters if possible.
1449 `#' Use opposite case characters if possible.
1450
1451 A field width N is an unsigned decimal integer with a leading digit
1452 nonzero. %NX is like %X, but takes up at least N positions. The
1453 field width is (on GNU/Linux and some other systems) in measured in
1454 bytes, not characters. It depends on the locale what the width (in
1455 characters) %NX will end up being, especially when there are non-ASCII
1456 characters in %X.
1457
1458 The modifiers are:
1459
1460 `E' Use the locale's alternative version.
1461 `O' Use the locale's number symbols.
1462
1463 For example, to produce full ISO 8601 format, use "%FT%T%z".
1464
1465 usage: (format-time-string FORMAT-STRING &optional TIME ZONE) */)
1466 (Lisp_Object format_string, Lisp_Object timeval, Lisp_Object zone)
1467 {
1468 struct timespec t = lisp_time_argument (timeval);
1469 struct tm tm;
1470
1471 CHECK_STRING (format_string);
1472 format_string = code_convert_string_norecord (format_string,
1473 Vlocale_coding_system, 1);
1474 return format_time_string (SSDATA (format_string), SBYTES (format_string),
1475 t, zone, &tm);
1476 }
1477
1478 DEFUN ("decode-time", Fdecode_time, Sdecode_time, 0, 3, 0,
1479 doc: /* Decode a timestamp into (SEC MINUTE HOUR DAY MONTH YEAR DOW DST UTCOFF).
1480 The optional TIME is the time value to convert. See
1481 `format-time-string' for the various forms of a time value.
1482
1483 The optional ZONE is omitted or nil for Emacs local time, t for
1484 Universal Time, `wall' for system wall clock time, or a string as in
1485 the TZ environment variable. It can also be a list (as from
1486 `current-time-zone') or an integer (the UTC offset in seconds) applied
1487 without consideration for daylight saving time.
1488
1489 The optional FORM specifies the form of the SEC member. If `integer',
1490 SEC is an integer; if t, SEC is an integer or (TICKS . HZ) timestamp
1491 with the same precision as TIME. An omitted or nil FORM is currently
1492 treated like `integer', but this may change in future Emacs versions.
1493
1494 To access (or alter) the elements in the time value, the
1495 `decoded-time-second', `decoded-time-minute', `decoded-time-hour',
1496 `decoded-time-day', `decoded-time-month', `decoded-time-year',
1497 `decoded-time-weekday', `decoded-time-dst' and `decoded-time-zone'
1498 accessors can be used.
1499
1500 The list has the following nine members: SEC is an integer or
1501 Lisp timestamp representing a nonnegative value less than 60
1502 \(or less than 61 if the operating system supports leap seconds).
1503 MINUTE is an integer between 0 and 59. HOUR is an integer
1504 between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
1505 integer between 1 and 12. YEAR is the year number, an integer; 0
1506 represents 1 BC. DOW is the day of week, an integer between 0 and 6,
1507 where 0 is Sunday. DST is t if daylight saving time is in effect,
1508 nil if it is not in effect, and -1 if daylight saving information is
1509 not available. UTCOFF is an integer indicating the UTC offset in
1510 seconds, i.e., the number of seconds east of Greenwich. (Note that
1511 Common Lisp has different meanings for DOW and UTCOFF, and its
1512 SEC is always an integer between 0 and 59.)
1513
1514 usage: (decode-time &optional TIME ZONE FORM) */)
1515 (Lisp_Object specified_time, Lisp_Object zone, Lisp_Object form)
1516 {
1517 /* Compute broken-down local time LOCAL_TM from SPECIFIED_TIME and ZONE. */
1518 struct lisp_time lt = lisp_time_struct (specified_time, 0);
1519 struct timespec ts = lisp_to_timespec (lt);
1520 if (! timespec_valid_p (ts))
1521 time_overflow ();
1522 time_t time_spec = ts.tv_sec;
1523 struct tm local_tm, gmt_tm;
1524 timezone_t tz = tzlookup (zone, false);
1525 struct tm *tm = emacs_localtime_rz (tz, &time_spec, &local_tm);
1526 int localtime_errno = errno;
1527 xtzfree (tz);
1528
1529 if (!tm)
1530 time_error (localtime_errno);
1531
1532 /* Let YEAR = LOCAL_TM.tm_year + TM_YEAR_BASE. */
1533 Lisp_Object year;
1534 if (FASTER_TIMEFNS
1535 && MOST_NEGATIVE_FIXNUM - TM_YEAR_BASE <= local_tm.tm_year
1536 && local_tm.tm_year <= MOST_POSITIVE_FIXNUM - TM_YEAR_BASE)
1537 {
1538 /* Avoid overflow when INT_MAX - TM_YEAR_BASE < local_tm.tm_year. */
1539 EMACS_INT tm_year_base = TM_YEAR_BASE;
1540 year = make_fixnum (local_tm.tm_year + tm_year_base);
1541 }
1542 else
1543 {
1544 mpz_set_si (mpz[0], local_tm.tm_year);
1545 mpz_add_ui (mpz[0], mpz[0], TM_YEAR_BASE);
1546 year = make_integer_mpz ();
1547 }
1548
1549 /* Compute SEC from LOCAL_TM.tm_sec and HZ. */
1550 Lisp_Object hz = lt.hz, sec;
1551 if (BASE_EQ (hz, make_fixnum (1)) || !BASE2_EQ (form, Qt))
1552 sec = make_fixnum (local_tm.tm_sec);
1553 else
1554 {
1555 /* Let TICKS = HZ * LOCAL_TM.tm_sec + mod (LT.ticks, HZ)
1556 and SEC = (TICKS . HZ). */
1557 Lisp_Object ticks;
1558 intmax_t n;
1559 if (FASTER_TIMEFNS && FIXNUMP (lt.ticks) && FIXNUMP (hz)
1560 && !ckd_mul (&n, XFIXNUM (hz), local_tm.tm_sec)
1561 && !ckd_add (&n, n, (XFIXNUM (lt.ticks) % XFIXNUM (hz)
1562 + (XFIXNUM (lt.ticks) % XFIXNUM (hz) < 0
1563 ? XFIXNUM (hz) : 0))))
1564 ticks = make_int (n);
1565 else
1566 {
1567 mpz_fdiv_r (mpz[0],
1568 *bignum_integer (&mpz[0], lt.ticks),
1569 *bignum_integer (&mpz[1], hz));
1570 mpz_addmul_ui (mpz[0], *bignum_integer (&mpz[1], hz),
1571 local_tm.tm_sec);
1572 ticks = make_integer_mpz ();
1573 }
1574 sec = Fcons (ticks, hz);
1575 }
1576
1577 return CALLN (Flist,
1578 sec,
1579 make_fixnum (local_tm.tm_min),
1580 make_fixnum (local_tm.tm_hour),
1581 make_fixnum (local_tm.tm_mday),
1582 make_fixnum (local_tm.tm_mon + 1),
1583 year,
1584 make_fixnum (local_tm.tm_wday),
1585 (local_tm.tm_isdst < 0 ? make_fixnum (-1)
1586 : local_tm.tm_isdst == 0 ? Qnil : Qt),
1587 (HAVE_TM_GMTOFF
1588 ? make_fixnum (tm_gmtoff (&local_tm))
1589 : gmtime_r (&time_spec, &gmt_tm)
1590 ? make_fixnum (tm_diff (&local_tm, &gmt_tm))
1591 : Qnil));
1592 }
1593
1594 /* Return OBJ - OFFSET, checking that OBJ is a valid integer and that
1595 the result is representable as an int. 0 <= OFFSET <= TM_YEAR_BASE. */
1596 static int
1597 check_tm_member (Lisp_Object obj, int offset)
1598 {
1599 if (FASTER_TIMEFNS && INT_MAX <= MOST_POSITIVE_FIXNUM - TM_YEAR_BASE)
1600 {
1601 CHECK_FIXNUM (obj);
1602 EMACS_INT n = XFIXNUM (obj);
1603 int i;
1604 if (ckd_sub (&i, n, offset))
1605 time_overflow ();
1606 return i;
1607 }
1608 else
1609 {
1610 CHECK_INTEGER (obj);
1611 mpz_sub_ui (mpz[0], *bignum_integer (&mpz[0], obj), offset);
1612 intmax_t i;
1613 if (! (mpz_to_intmax (mpz[0], &i) && INT_MIN <= i && i <= INT_MAX))
1614 time_overflow ();
1615 return i;
1616 }
1617 }
1618
1619 DEFUN ("encode-time", Fencode_time, Sencode_time, 1, MANY, 0,
1620 doc: /* Convert TIME to a timestamp.
1621
1622 TIME is a list (SECOND MINUTE HOUR DAY MONTH YEAR IGNORED DST ZONE)
1623 in the style of `decode-time', so that (encode-time (decode-time ...)) works.
1624 In this list, ZONE can be nil for Emacs local time, t for Universal
1625 Time, `wall' for system wall clock time, or a string as in the TZ
1626 environment variable. ZONE can also be a list (as from
1627 `current-time-zone') or an integer (as from `decode-time') applied
1628 without consideration for daylight saving time. If ZONE specifies a
1629 time zone with daylight-saving transitions, DST is t for daylight
1630 saving time, nil for standard time, and -1 to cause the daylight
1631 saving flag to be guessed.
1632
1633 TIME can also be a list (SECOND MINUTE HOUR DAY MONTH YEAR), which is
1634 equivalent to (SECOND MINUTE HOUR DAY MONTH YEAR nil -1 nil).
1635
1636 As an obsolescent calling convention, if this function is called with
1637 6 or more arguments, the first 6 arguments are SECOND, MINUTE, HOUR,
1638 DAY, MONTH, and YEAR, and specify the components of a decoded time.
1639 If there are more than 6 arguments the *last* argument is used as ZONE
1640 and any other extra arguments are ignored, so that (apply
1641 #\\='encode-time (decode-time ...)) works. In this obsolescent
1642 convention, DST is -1 and ZONE defaults to nil.
1643
1644 The range of supported years is at least 1970 to the near future.
1645 Out-of-range values for SECOND through MONTH are brought into range
1646 via date arithmetic. This can be tricky especially when combined with
1647 DST; see Info node `(elisp)Time Conversion' for details and caveats.
1648
1649 usage: (encode-time TIME &rest OBSOLESCENT-ARGUMENTS) */)
1650 (ptrdiff_t nargs, Lisp_Object *args)
1651 {
1652 struct tm tm;
1653 Lisp_Object zone = Qnil;
1654 Lisp_Object a = args[0];
1655 Lisp_Object secarg, minarg, hourarg, mdayarg, monarg, yeararg;
1656 tm.tm_isdst = -1;
1657
1658 if (nargs == 1)
1659 {
1660 Lisp_Object tail = a;
1661 for (int i = 0; i < 6; i++, tail = XCDR (tail))
1662 CHECK_CONS (tail);
1663 secarg = XCAR (a); a = XCDR (a);
1664 minarg = XCAR (a); a = XCDR (a);
1665 hourarg = XCAR (a); a = XCDR (a);
1666 mdayarg = XCAR (a); a = XCDR (a);
1667 monarg = XCAR (a); a = XCDR (a);
1668 yeararg = XCAR (a); a = XCDR (a);
1669 if (! NILP (a))
1670 {
1671 CHECK_CONS (a);
1672 a = XCDR (a);
1673 CHECK_CONS (a);
1674 Lisp_Object dstflag = XCAR (a); a = XCDR (a);
1675 CHECK_CONS (a);
1676 zone = XCAR (a);
1677 if (SYMBOLP (dstflag) && !FIXNUMP (zone) && !CONSP (zone))
1678 tm.tm_isdst = !NILP (dstflag);
1679 }
1680 }
1681 else if (nargs < 6)
1682 xsignal2 (Qwrong_number_of_arguments, Qencode_time, make_fixnum (nargs));
1683 else
1684 {
1685 if (6 < nargs)
1686 zone = args[nargs - 1];
1687 secarg = a;
1688 minarg = args[1];
1689 hourarg = args[2];
1690 mdayarg = args[3];
1691 monarg = args[4];
1692 yeararg = args[5];
1693 }
1694
1695 /* Let SEC = floor (LT.ticks / HZ), with SUBSECTICKS the remainder. */
1696 struct lisp_time lt;
1697 decode_lisp_time (secarg, false, <, 0);
1698 Lisp_Object hz = lt.hz, sec, subsecticks;
1699 if (FASTER_TIMEFNS && BASE_EQ (hz, make_fixnum (1)))
1700 {
1701 sec = lt.ticks;
1702 subsecticks = make_fixnum (0);
1703 }
1704 else
1705 {
1706 mpz_fdiv_qr (mpz[0], mpz[1],
1707 *bignum_integer (&mpz[0], lt.ticks),
1708 *bignum_integer (&mpz[1], hz));
1709 sec = make_integer_mpz ();
1710 mpz_swap (mpz[0], mpz[1]);
1711 subsecticks = make_integer_mpz ();
1712 }
1713 tm.tm_sec = check_tm_member (sec, 0);
1714 tm.tm_min = check_tm_member (minarg, 0);
1715 tm.tm_hour = check_tm_member (hourarg, 0);
1716 tm.tm_mday = check_tm_member (mdayarg, 0);
1717 tm.tm_mon = check_tm_member (monarg, 1);
1718 tm.tm_year = check_tm_member (yeararg, TM_YEAR_BASE);
1719
1720 timezone_t tz = tzlookup (zone, false);
1721 tm.tm_wday = -1;
1722 time_t value = mktime_z (tz, &tm);
1723 int mktime_errno = errno;
1724 xtzfree (tz);
1725
1726 if (tm.tm_wday < 0)
1727 time_error (mktime_errno);
1728
1729 if (BASE_EQ (hz, make_fixnum (1)))
1730 return (current_time_list
1731 ? list2 (hi_time (value), lo_time (value))
1732 : INT_TO_INTEGER (value));
1733 else
1734 {
1735 struct lisp_time val1 = { INT_TO_INTEGER (value), make_fixnum (1) };
1736 Lisp_Object secticks = lisp_time_hz_ticks (val1, hz);
1737 Lisp_Object ticks = lispint_arith (secticks, subsecticks, false);
1738 return Fcons (ticks, hz);
1739 }
1740 }
1741
1742 DEFUN ("time-convert", Ftime_convert, Stime_convert, 1, 2, 0,
1743 doc: /* Convert TIME value to a Lisp timestamp of the given FORM.
1744 Truncate the returned value toward minus infinity.
1745
1746 If FORM is a positive integer, return a pair of integers (TICKS . FORM),
1747 where TICKS is the number of clock ticks and FORM is the clock frequency
1748 in ticks per second.
1749
1750 If FORM is t, return (TICKS . PHZ), where PHZ is a suitable clock
1751 frequency in ticks per second.
1752
1753 If FORM is `integer', return an integer count of seconds.
1754
1755 If FORM is `list', return an integer list (HIGH LOW USEC PSEC), where
1756 HIGH has the most significant bits of the seconds, LOW has the least
1757 significant 16 bits, and USEC and PSEC are the microsecond and
1758 picosecond counts.
1759
1760 If FORM is nil, the behavior depends on `current-time-list',
1761 but new code should not rely on it. */)
1762 (Lisp_Object time, Lisp_Object form)
1763 {
1764 /* FIXME: Any reason why we don't offer a `float` output format option as
1765 well, since we accept it as input? */
1766 struct lisp_time t;
1767 enum timeform input_form = decode_lisp_time (time, false, &t, 0);
1768 if (NILP (form))
1769 form = current_time_list ? Qlist : Qt;
1770 if (symbols_with_pos_enabled && SYMBOL_WITH_POS_P (form))
1771 form = SYMBOL_WITH_POS_SYM (form);
1772 if (BASE_EQ (form, Qlist))
1773 return ticks_hz_list4 (t.ticks, t.hz);
1774 if (BASE_EQ (form, Qinteger))
1775 return FASTER_TIMEFNS && INTEGERP (time) ? time : lisp_time_seconds (t);
1776 if (BASE_EQ (form, Qt))
1777 form = t.hz;
1778 if (FASTER_TIMEFNS
1779 && input_form == TIMEFORM_TICKS_HZ && BASE_EQ (form, XCDR (time)))
1780 return time;
1781 return Fcons (lisp_time_hz_ticks (t, form), form);
1782 }
1783
1784 DEFUN ("current-time", Fcurrent_time, Scurrent_time, 0, 0, 0,
1785 doc: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
1786 If the variable `current-time-list' is nil, the time is returned as a
1787 pair of integers (TICKS . HZ), where TICKS counts clock ticks and HZ
1788 is the clock ticks per second. Otherwise, the time is returned as a
1789 list of integers (HIGH LOW USEC PSEC) where HIGH has the most
1790 significant bits of the seconds, LOW has the least significant 16
1791 bits, and USEC and PSEC are the microsecond and picosecond counts.
1792
1793 You can use `time-convert' to get a particular timestamp form
1794 regardless of the value of `current-time-list'. */)
1795 (void)
1796 {
1797 return make_lisp_time (current_timespec ());
1798 }
1799
1800 #ifdef CLOCKS_PER_SEC
1801 DEFUN ("current-cpu-time", Fcurrent_cpu_time, Scurrent_cpu_time, 0, 0, 0,
1802 doc: /* Return the current CPU time along with its resolution.
1803 The return value is a pair (CPU-TICKS . TICKS-PER-SEC).
1804 The CPU-TICKS counter can wrap around, so values cannot be meaningfully
1805 compared if too much time has passed between them. */)
1806 (void)
1807 {
1808 return Fcons (make_int (clock ()), make_int (CLOCKS_PER_SEC));
1809 }
1810 #endif
1811
1812 DEFUN ("current-time-string", Fcurrent_time_string, Scurrent_time_string,
1813 0, 2, 0,
1814 doc: /* Return the current local time, as a human-readable string.
1815 Programs can use this function to decode a time,
1816 since the number of columns in each field is fixed
1817 if the year is in the range 1000-9999.
1818 The format is `Sun Sep 16 01:03:52 1973'.
1819 However, see also the functions `decode-time' and `format-time-string'
1820 which provide a much more powerful and general facility.
1821
1822 If SPECIFIED-TIME is given, it is the time value to format instead of
1823 the current time. See `format-time-string' for the various forms of a
1824 time value.
1825
1826 The optional ZONE is omitted or nil for Emacs local time, t for
1827 Universal Time, `wall' for system wall clock time, or a string as in
1828 the TZ environment variable. It can also be a list (as from
1829 `current-time-zone') or an integer (as from `decode-time') applied
1830 without consideration for daylight saving time. */)
1831 (Lisp_Object specified_time, Lisp_Object zone)
1832 {
1833 time_t value = lisp_seconds_argument (specified_time);
1834 timezone_t tz = tzlookup (zone, false);
1835
1836 /* Convert to a string in ctime format, except without the trailing
1837 newline, and without the 4-digit year limit. Don't use asctime
1838 or ctime, as they might dump core if the year is outside the
1839 range -999 .. 9999. */
1840 struct tm tm;
1841 struct tm *tmp = emacs_localtime_rz (tz, &value, &tm);
1842 int localtime_errno = errno;
1843 xtzfree (tz);
1844 if (! tmp)
1845 time_error (localtime_errno);
1846
1847 static char const wday_name[][4] =
1848 { "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat" };
1849 static char const mon_name[][4] =
1850 { "Jan", "Feb", "Mar", "Apr", "May", "Jun",
1851 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" };
1852 intmax_t year_base = TM_YEAR_BASE;
1853 char buf[sizeof "Mon Apr 30 12:49:17 " + INT_STRLEN_BOUND (int) + 1];
1854 int len = sprintf (buf, "%s %s%3d %02d:%02d:%02d %"PRIdMAX,
1855 wday_name[tm.tm_wday], mon_name[tm.tm_mon], tm.tm_mday,
1856 tm.tm_hour, tm.tm_min, tm.tm_sec,
1857 tm.tm_year + year_base);
1858
1859 return make_unibyte_string (buf, len);
1860 }
1861
1862 DEFUN ("current-time-zone", Fcurrent_time_zone, Scurrent_time_zone, 0, 2, 0,
1863 doc: /* Return the offset and name for the local time zone.
1864 This returns a list of the form (OFFSET NAME).
1865 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
1866 A negative value means west of Greenwich.
1867 NAME is a string giving the name of the time zone.
1868 If SPECIFIED-TIME is given, the time zone offset is determined from it
1869 instead of using the current time. The argument should be a Lisp
1870 time value; see `format-time-string' for the various forms of a time
1871 value.
1872
1873 The optional ZONE is omitted or nil for Emacs local time, t for
1874 Universal Time, `wall' for system wall clock time, or a string as in
1875 the TZ environment variable. It can also be a list (as from
1876 `current-time-zone') or an integer (as from `decode-time') applied
1877 without consideration for daylight saving time.
1878
1879 Some operating systems cannot provide all this information to Emacs;
1880 in this case, `current-time-zone' returns a list containing nil for
1881 the data it can't find. */)
1882 (Lisp_Object specified_time, Lisp_Object zone)
1883 {
1884 struct timespec value;
1885 struct tm local_tm, gmt_tm;
1886 Lisp_Object zone_offset, zone_name;
1887
1888 zone_offset = Qnil;
1889 value = make_timespec (lisp_seconds_argument (specified_time), 0);
1890 zone_name = format_time_string ("%Z", sizeof "%Z" - 1, value,
1891 zone, &local_tm);
1892
1893 /* gmtime_r expects a pointer to time_t, but tv_sec of struct
1894 timespec on some systems (MinGW) is a 64-bit field. */
1895 time_t tsec = value.tv_sec;
1896 if (HAVE_TM_GMTOFF || gmtime_r (&tsec, &gmt_tm))
1897 {
1898 long int offset = (HAVE_TM_GMTOFF
1899 ? tm_gmtoff (&local_tm)
1900 : tm_diff (&local_tm, &gmt_tm));
1901 zone_offset = make_fixnum (offset);
1902 if (SCHARS (zone_name) == 0)
1903 {
1904 /* No local time zone name is available; use numeric zone instead. */
1905 long int hour = offset / 3600;
1906 int min_sec = offset % 3600;
1907 int amin_sec = min_sec < 0 ? - min_sec : min_sec;
1908 int min = amin_sec / 60;
1909 int sec = amin_sec % 60;
1910 int min_prec = min_sec ? 2 : 0;
1911 int sec_prec = sec ? 2 : 0;
1912 char buf[sizeof "+0000" + INT_STRLEN_BOUND (long int)];
1913 zone_name = make_formatted_string (buf, "%c%.2ld%.*d%.*d",
1914 (offset < 0 ? '-' : '+'),
1915 hour, min_prec, min, sec_prec, sec);
1916 }
1917 }
1918
1919 return list2 (zone_offset, zone_name);
1920 }
1921
1922 DEFUN ("set-time-zone-rule", Fset_time_zone_rule, Sset_time_zone_rule, 1, 1, 0,
1923 doc: /* Set the Emacs local time zone using TZ, a string specifying a time zone rule.
1924 If TZ is nil or `wall', use system wall clock time; this differs from
1925 the usual Emacs convention where nil means current local time. If TZ
1926 is t, use Universal Time. If TZ is a list (as from
1927 `current-time-zone') or an integer (as from `decode-time'), use the
1928 specified time zone without consideration for daylight saving time.
1929
1930 Instead of calling this function, you typically want something else.
1931 To temporarily use a different time zone rule for just one invocation
1932 of `decode-time', `encode-time', or `format-time-string', pass the
1933 function a ZONE argument. To change local time consistently
1934 throughout Emacs, call (setenv "TZ" TZ): this changes both the
1935 environment of the Emacs process and the variable
1936 `process-environment', whereas `set-time-zone-rule' affects only the
1937 former. */)
1938 (Lisp_Object tz)
1939 {
1940 tzlookup (NILP (tz) ? Qwall : tz, true);
1941 return Qnil;
1942 }
1943
1944 /* A buffer holding a string of the form "TZ=value", intended
1945 to be part of the environment. If TZ is supposed to be unset,
1946 the buffer string is "tZ=". */
1947 static char *tzvalbuf;
1948
1949 /* Get the local time zone rule. */
1950 char *
1951 emacs_getenv_TZ (void)
1952 {
1953 return tzvalbuf[0] == 'T' ? tzvalbuf + tzeqlen : 0;
1954 }
1955
1956 /* Set the local time zone rule to TZSTRING, which can be null to
1957 denote wall clock time. Do not record the setting in LOCAL_TZ.
1958
1959 This function is not thread-safe, in theory because putenv is not,
1960 but mostly because of the static storage it updates. Other threads
1961 that invoke localtime etc. may be adversely affected while this
1962 function is executing. */
1963
1964 int
1965 emacs_setenv_TZ (const char *tzstring)
1966 {
1967 static ptrdiff_t tzvalbufsize;
1968 ptrdiff_t tzstringlen = tzstring ? strlen (tzstring) : 0;
1969 char *tzval = tzvalbuf;
1970 bool new_tzvalbuf = tzvalbufsize <= tzeqlen + tzstringlen;
1971
1972 if (new_tzvalbuf)
1973 {
1974 /* Do not attempt to free the old tzvalbuf, since another thread
1975 may be using it. In practice, the first allocation is large
1976 enough and memory does not leak. */
1977 tzval = xpalloc (NULL, &tzvalbufsize,
1978 tzeqlen + tzstringlen - tzvalbufsize + 1, -1, 1);
1979 tzvalbuf = tzval;
1980 tzval[1] = 'Z';
1981 tzval[2] = '=';
1982 }
1983
1984 if (tzstring)
1985 {
1986 /* Modify TZVAL in place. Although this is dicey in a
1987 multithreaded environment, we know of no portable alternative.
1988 Calling putenv or setenv could crash some other thread. */
1989 tzval[0] = 'T';
1990 strcpy (tzval + tzeqlen, tzstring);
1991 }
1992 else
1993 {
1994 /* Turn 'TZ=whatever' into an empty environment variable 'tZ='.
1995 Although this is also dicey, calling unsetenv here can crash Emacs.
1996 See Bug#8705. */
1997 tzval[0] = 't';
1998 tzval[tzeqlen] = 0;
1999 }
2000
2001
2002 #ifndef WINDOWSNT
2003 /* Modifying *TZVAL merely requires calling tzset (which is the
2004 caller's responsibility). However, modifying TZVAL requires
2005 calling putenv; although this is not thread-safe, in practice this
2006 runs only on startup when there is only one thread. */
2007 bool need_putenv = new_tzvalbuf;
2008 #else
2009 /* MS-Windows 'putenv' copies the argument string into a block it
2010 allocates, so modifying *TZVAL will not change the environment.
2011 However, the other threads run by Emacs on MS-Windows never call
2012 'xputenv' or 'putenv' or 'unsetenv', so the original cause for the
2013 dicey in-place modification technique doesn't exist there in the
2014 first place. */
2015 bool need_putenv = true;
2016 #endif
2017 if (need_putenv)
2018 xputenv (tzval);
2019
2020 return 0;
2021 }
2022
2023 #if (ULONG_MAX < TRILLION || !FASTER_TIMEFNS) && !defined ztrillion
2024 # define NEED_ZTRILLION_INIT 1
2025 #endif
2026
2027 #ifdef NEED_ZTRILLION_INIT
2028 static void
2029 syms_of_timefns_for_pdumper (void)
2030 {
2031 mpz_init_set_ui (ztrillion, 1000000);
2032 mpz_mul_ui (ztrillion, ztrillion, 1000000);
2033 }
2034 #endif
2035
2036 void
2037 syms_of_timefns (void)
2038 {
2039 #ifndef timespec_hz
2040 timespec_hz = make_int (TIMESPEC_HZ);
2041 staticpro (×pec_hz);
2042 #endif
2043 #ifndef trillion
2044 trillion = make_int (1000000000000);
2045 staticpro (&trillion);
2046 #endif
2047
2048 DEFSYM (Qencode_time, "encode-time");
2049
2050 DEFVAR_BOOL ("current-time-list", current_time_list,
2051 doc: /* Whether `current-time' should return list or (TICKS . HZ) form.
2052
2053 This boolean variable is a transition aid. If t, `current-time' and
2054 related functions return timestamps in list form, typically
2055 \(HIGH LOW USEC PSEC); otherwise, they use (TICKS . HZ) form.
2056 Currently this variable defaults to t, for behavior compatible with
2057 previous Emacs versions. Developers are encouraged to test
2058 timestamp-related code with this variable set to nil, as it will
2059 default to nil in a future Emacs version, and will be removed in some
2060 version after that. */);
2061 current_time_list = CURRENT_TIME_LIST;
2062
2063 defsubr (&Scurrent_time);
2064 #ifdef CLOCKS_PER_SEC
2065 defsubr (&Scurrent_cpu_time);
2066 #endif
2067 defsubr (&Stime_convert);
2068 defsubr (&Stime_add);
2069 defsubr (&Stime_subtract);
2070 defsubr (&Stime_less_p);
2071 defsubr (&Stime_equal_p);
2072 defsubr (&Sformat_time_string);
2073 defsubr (&Sfloat_time);
2074 defsubr (&Sdecode_time);
2075 defsubr (&Sencode_time);
2076 defsubr (&Scurrent_time_string);
2077 defsubr (&Scurrent_time_zone);
2078 defsubr (&Sset_time_zone_rule);
2079
2080 flt_radix_power = make_nil_vector (flt_radix_power_size);
2081 staticpro (&flt_radix_power);
2082
2083 #ifdef NEED_ZTRILLION_INIT
2084 pdumper_do_now_and_after_load (syms_of_timefns_for_pdumper);
2085 #endif
2086 }