1 /* Lisp functions pertaining to editing.
3 Copyright (C) 1985-1987, 1989, 1993-2015 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
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
10 (at your option) any later version.
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.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
22 #include <sys/types.h>
32 #ifdef HAVE_SYS_UTSNAME_H
33 #include <sys/utsname.h>
38 /* systime.h includes <sys/time.h> which, on some systems, is required
39 for <sys/resource.h>; thus systime.h must be included before
43 #if defined HAVE_SYS_RESOURCE_H
44 #include <sys/resource.h>
55 #include "intervals.h"
56 #include "character.h"
61 #include "blockinput.h"
63 #define TM_YEAR_BASE 1900
66 extern Lisp_Object
w32_get_internal_run_time (void);
69 static struct lisp_time
lisp_time_struct (Lisp_Object
, int *);
70 static Lisp_Object
format_time_string (char const *, ptrdiff_t, struct timespec
,
71 Lisp_Object
, struct tm
*);
72 static long int tm_gmtoff (struct tm
*);
73 static int tm_diff (struct tm
*, struct tm
*);
74 static void update_buffer_properties (ptrdiff_t, ptrdiff_t);
75 static Lisp_Object
styled_format (ptrdiff_t, Lisp_Object
*, bool);
77 #ifndef HAVE_TM_GMTOFF
78 # define HAVE_TM_GMTOFF false
81 enum { tzeqlen
= sizeof "TZ=" - 1 };
83 /* Time zones equivalent to current local time, to wall clock time,
84 and to UTC, respectively. */
85 static timezone_t local_tz
;
86 static timezone_t wall_clock_tz
;
87 static timezone_t
const utc_tz
= 0;
89 /* A valid but unlikely setting for the TZ environment variable.
90 It is OK (though a bit slower) if the user chooses this value. */
91 static char dump_tz_string
[] = "TZ=UtC0";
93 /* The cached value of Vsystem_name. This is used only to compare it
94 to Vsystem_name, so it need not be visible to the GC. */
95 static Lisp_Object cached_system_name
;
98 init_and_cache_system_name (void)
101 cached_system_name
= Vsystem_name
;
105 emacs_localtime_rz (timezone_t tz
, time_t const *t
, struct tm
*tm
)
107 tm
= localtime_rz (tz
, t
, tm
);
108 if (!tm
&& errno
== ENOMEM
)
109 memory_full (SIZE_MAX
);
114 emacs_mktime_z (timezone_t tz
, struct tm
*tm
)
117 time_t t
= mktime_z (tz
, tm
);
118 if (t
== (time_t) -1 && errno
== ENOMEM
)
119 memory_full (SIZE_MAX
);
123 /* Allocate a timezone, signaling on failure. */
125 xtzalloc (char const *name
)
127 timezone_t tz
= tzalloc (name
);
129 memory_full (SIZE_MAX
);
133 /* Free a timezone, except do not free the time zone for local time.
134 Freeing utc_tz is also a no-op. */
136 xtzfree (timezone_t tz
)
142 /* Convert the Lisp time zone rule ZONE to a timezone_t object.
143 The returned value either is 0, or is LOCAL_TZ, or is newly allocated.
144 If SETTZ, set Emacs local time to the time zone rule; otherwise,
145 the caller should eventually pass the returned value to xtzfree. */
147 tzlookup (Lisp_Object zone
, bool settz
)
149 static char const tzbuf_format
[] = "XXX%s%"pI
"d:%02d:%02d";
150 char tzbuf
[sizeof tzbuf_format
+ INT_STRLEN_BOUND (EMACS_INT
)];
151 char const *zone_string
;
156 else if (EQ (zone
, Qt
))
158 zone_string
= "UTC0";
163 if (EQ (zone
, Qwall
))
165 else if (STRINGP (zone
))
166 zone_string
= SSDATA (zone
);
167 else if (INTEGERP (zone
))
169 EMACS_INT abszone
= eabs (XINT (zone
)), hour
= abszone
/ (60 * 60);
170 int min
= (abszone
/ 60) % 60, sec
= abszone
% 60;
171 sprintf (tzbuf
, tzbuf_format
, &"-"[XINT (zone
) < 0], hour
, min
, sec
);
175 xsignal2 (Qerror
, build_string ("Invalid time zone specification"),
177 new_tz
= xtzalloc (zone_string
);
183 emacs_setenv_TZ (zone_string
);
184 timezone_t old_tz
= local_tz
;
194 init_editfns (bool dumping
)
196 const char *user_name
;
198 struct passwd
*pw
; /* password entry for the current user */
201 /* Set up system_name even when dumping. */
202 init_and_cache_system_name ();
205 /* When just dumping out, set the time zone to a known unlikely value
206 and skip the rest of this function. */
210 xputenv (dump_tz_string
);
217 char *tz
= getenv ("TZ");
219 #if !defined CANNOT_DUMP && defined HAVE_TZSET
220 /* If the execution TZ happens to be the same as the dump TZ,
221 change it to some other value and then change it back,
222 to force the underlying implementation to reload the TZ info.
223 This is needed on implementations that load TZ info from files,
224 since the TZ file contents may differ between dump and execution. */
225 if (tz
&& strcmp (tz
, &dump_tz_string
[tzeqlen
]) == 0)
233 /* Set the time zone rule now, so that the call to putenv is done
234 before multiple threads are active. */
235 wall_clock_tz
= xtzalloc (0);
236 tzlookup (tz
? build_string (tz
) : Qwall
, true);
238 pw
= getpwuid (getuid ());
240 /* We let the real user name default to "root" because that's quite
241 accurate on MS-DOS and because it lets Emacs find the init file.
242 (The DVX libraries override the Djgpp libraries here.) */
243 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "root");
245 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "unknown");
248 /* Get the effective user name, by consulting environment variables,
249 or the effective uid if those are unset. */
250 user_name
= getenv ("LOGNAME");
253 user_name
= getenv ("USERNAME"); /* it's USERNAME on NT */
254 #else /* WINDOWSNT */
255 user_name
= getenv ("USER");
256 #endif /* WINDOWSNT */
259 pw
= getpwuid (geteuid ());
260 user_name
= pw
? pw
->pw_name
: "unknown";
262 Vuser_login_name
= build_string (user_name
);
264 /* If the user name claimed in the environment vars differs from
265 the real uid, use the claimed name to find the full name. */
266 tem
= Fstring_equal (Vuser_login_name
, Vuser_real_login_name
);
268 tem
= Vuser_login_name
;
271 uid_t euid
= geteuid ();
272 tem
= make_fixnum_or_float (euid
);
274 Vuser_full_name
= Fuser_full_name (tem
);
278 Vuser_full_name
= build_string (p
);
279 else if (NILP (Vuser_full_name
))
280 Vuser_full_name
= build_string ("unknown");
282 #ifdef HAVE_SYS_UTSNAME_H
286 Voperating_system_release
= build_string (uts
.release
);
289 Voperating_system_release
= Qnil
;
293 DEFUN ("char-to-string", Fchar_to_string
, Schar_to_string
, 1, 1, 0,
294 doc
: /* Convert arg CHAR to a string containing that character.
295 usage: (char-to-string CHAR) */)
296 (Lisp_Object character
)
299 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
301 CHECK_CHARACTER (character
);
302 c
= XFASTINT (character
);
304 len
= CHAR_STRING (c
, str
);
305 return make_string_from_bytes ((char *) str
, 1, len
);
308 DEFUN ("byte-to-string", Fbyte_to_string
, Sbyte_to_string
, 1, 1, 0,
309 doc
: /* Convert arg BYTE to a unibyte string containing that byte. */)
314 if (XINT (byte
) < 0 || XINT (byte
) > 255)
315 error ("Invalid byte");
317 return make_string_from_bytes ((char *) &b
, 1, 1);
320 DEFUN ("string-to-char", Fstring_to_char
, Sstring_to_char
, 1, 1, 0,
321 doc
: /* Return the first character in STRING. */)
322 (register Lisp_Object string
)
324 register Lisp_Object val
;
325 CHECK_STRING (string
);
328 if (STRING_MULTIBYTE (string
))
329 XSETFASTINT (val
, STRING_CHAR (SDATA (string
)));
331 XSETFASTINT (val
, SREF (string
, 0));
334 XSETFASTINT (val
, 0);
338 DEFUN ("point", Fpoint
, Spoint
, 0, 0, 0,
339 doc
: /* Return value of point, as an integer.
340 Beginning of buffer is position (point-min). */)
344 XSETFASTINT (temp
, PT
);
348 DEFUN ("point-marker", Fpoint_marker
, Spoint_marker
, 0, 0, 0,
349 doc
: /* Return value of point, as a marker object. */)
352 return build_marker (current_buffer
, PT
, PT_BYTE
);
355 DEFUN ("goto-char", Fgoto_char
, Sgoto_char
, 1, 1, "NGoto char: ",
356 doc
: /* Set point to POSITION, a number or marker.
357 Beginning of buffer is position (point-min), end is (point-max).
359 The return value is POSITION. */)
360 (register Lisp_Object position
)
362 if (MARKERP (position
))
363 set_point_from_marker (position
);
364 else if (INTEGERP (position
))
365 SET_PT (clip_to_bounds (BEGV
, XINT (position
), ZV
));
367 wrong_type_argument (Qinteger_or_marker_p
, position
);
372 /* Return the start or end position of the region.
373 BEGINNINGP means return the start.
374 If there is no region active, signal an error. */
377 region_limit (bool beginningp
)
381 if (!NILP (Vtransient_mark_mode
)
382 && NILP (Vmark_even_if_inactive
)
383 && NILP (BVAR (current_buffer
, mark_active
)))
384 xsignal0 (Qmark_inactive
);
386 m
= Fmarker_position (BVAR (current_buffer
, mark
));
388 error ("The mark is not set now, so there is no region");
390 /* Clip to the current narrowing (bug#11770). */
391 return make_number ((PT
< XFASTINT (m
)) == beginningp
393 : clip_to_bounds (BEGV
, XFASTINT (m
), ZV
));
396 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
397 doc
: /* Return the integer value of point or mark, whichever is smaller. */)
400 return region_limit (1);
403 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
404 doc
: /* Return the integer value of point or mark, whichever is larger. */)
407 return region_limit (0);
410 DEFUN ("mark-marker", Fmark_marker
, Smark_marker
, 0, 0, 0,
411 doc
: /* Return this buffer's mark, as a marker object.
412 Watch out! Moving this marker changes the mark position.
413 If you set the marker not to point anywhere, the buffer will have no mark. */)
416 return BVAR (current_buffer
, mark
);
420 /* Find all the overlays in the current buffer that touch position POS.
421 Return the number found, and store them in a vector in VEC
425 overlays_around (EMACS_INT pos
, Lisp_Object
*vec
, ptrdiff_t len
)
427 Lisp_Object overlay
, start
, end
;
428 struct Lisp_Overlay
*tail
;
429 ptrdiff_t startpos
, endpos
;
432 for (tail
= current_buffer
->overlays_before
; tail
; tail
= tail
->next
)
434 XSETMISC (overlay
, tail
);
436 end
= OVERLAY_END (overlay
);
437 endpos
= OVERLAY_POSITION (end
);
440 start
= OVERLAY_START (overlay
);
441 startpos
= OVERLAY_POSITION (start
);
446 /* Keep counting overlays even if we can't return them all. */
451 for (tail
= current_buffer
->overlays_after
; tail
; tail
= tail
->next
)
453 XSETMISC (overlay
, tail
);
455 start
= OVERLAY_START (overlay
);
456 startpos
= OVERLAY_POSITION (start
);
459 end
= OVERLAY_END (overlay
);
460 endpos
= OVERLAY_POSITION (end
);
472 DEFUN ("get-pos-property", Fget_pos_property
, Sget_pos_property
, 2, 3, 0,
473 doc
: /* Return the value of POSITION's property PROP, in OBJECT.
474 Almost identical to `get-char-property' except for the following difference:
475 Whereas `get-char-property' returns the property of the char at (i.e. right
476 after) POSITION, this pays attention to properties's stickiness and overlays's
477 advancement settings, in order to find the property of POSITION itself,
478 i.e. the property that a char would inherit if it were inserted
480 (Lisp_Object position
, register Lisp_Object prop
, Lisp_Object object
)
482 CHECK_NUMBER_COERCE_MARKER (position
);
485 XSETBUFFER (object
, current_buffer
);
486 else if (WINDOWP (object
))
487 object
= XWINDOW (object
)->contents
;
489 if (!BUFFERP (object
))
490 /* pos-property only makes sense in buffers right now, since strings
491 have no overlays and no notion of insertion for which stickiness
493 return Fget_text_property (position
, prop
, object
);
496 EMACS_INT posn
= XINT (position
);
498 Lisp_Object
*overlay_vec
, tem
;
499 struct buffer
*obuf
= current_buffer
;
502 set_buffer_temp (XBUFFER (object
));
504 /* First try with room for 40 overlays. */
505 Lisp_Object overlay_vecbuf
[40];
506 noverlays
= ARRAYELTS (overlay_vecbuf
);
507 overlay_vec
= overlay_vecbuf
;
508 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
510 /* If there are more than 40,
511 make enough space for all, and try again. */
512 if (ARRAYELTS (overlay_vecbuf
) < noverlays
)
514 SAFE_ALLOCA_LISP (overlay_vec
, noverlays
);
515 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
517 noverlays
= sort_overlays (overlay_vec
, noverlays
, NULL
);
519 set_buffer_temp (obuf
);
521 /* Now check the overlays in order of decreasing priority. */
522 while (--noverlays
>= 0)
524 Lisp_Object ol
= overlay_vec
[noverlays
];
525 tem
= Foverlay_get (ol
, prop
);
528 /* Check the overlay is indeed active at point. */
529 Lisp_Object start
= OVERLAY_START (ol
), finish
= OVERLAY_END (ol
);
530 if ((OVERLAY_POSITION (start
) == posn
531 && XMARKER (start
)->insertion_type
== 1)
532 || (OVERLAY_POSITION (finish
) == posn
533 && XMARKER (finish
)->insertion_type
== 0))
534 ; /* The overlay will not cover a char inserted at point. */
544 { /* Now check the text properties. */
545 int stickiness
= text_property_stickiness (prop
, position
, object
);
547 return Fget_text_property (position
, prop
, object
);
548 else if (stickiness
< 0
549 && XINT (position
) > BUF_BEGV (XBUFFER (object
)))
550 return Fget_text_property (make_number (XINT (position
) - 1),
558 /* Find the field surrounding POS in *BEG and *END. If POS is nil,
559 the value of point is used instead. If BEG or END is null,
560 means don't store the beginning or end of the field.
562 BEG_LIMIT and END_LIMIT serve to limit the ranged of the returned
563 results; they do not effect boundary behavior.
565 If MERGE_AT_BOUNDARY is non-nil, then if POS is at the very first
566 position of a field, then the beginning of the previous field is
567 returned instead of the beginning of POS's field (since the end of a
568 field is actually also the beginning of the next input field, this
569 behavior is sometimes useful). Additionally in the MERGE_AT_BOUNDARY
570 non-nil case, if two fields are separated by a field with the special
571 value `boundary', and POS lies within it, then the two separated
572 fields are considered to be adjacent, and POS between them, when
573 finding the beginning and ending of the "merged" field.
575 Either BEG or END may be 0, in which case the corresponding value
579 find_field (Lisp_Object pos
, Lisp_Object merge_at_boundary
,
580 Lisp_Object beg_limit
,
581 ptrdiff_t *beg
, Lisp_Object end_limit
, ptrdiff_t *end
)
583 /* Fields right before and after the point. */
584 Lisp_Object before_field
, after_field
;
585 /* True if POS counts as the start of a field. */
586 bool at_field_start
= 0;
587 /* True if POS counts as the end of a field. */
588 bool at_field_end
= 0;
591 XSETFASTINT (pos
, PT
);
593 CHECK_NUMBER_COERCE_MARKER (pos
);
596 = get_char_property_and_overlay (pos
, Qfield
, Qnil
, NULL
);
598 = (XFASTINT (pos
) > BEGV
599 ? get_char_property_and_overlay (make_number (XINT (pos
) - 1),
601 /* Using nil here would be a more obvious choice, but it would
602 fail when the buffer starts with a non-sticky field. */
605 /* See if we need to handle the case where MERGE_AT_BOUNDARY is nil
606 and POS is at beginning of a field, which can also be interpreted
607 as the end of the previous field. Note that the case where if
608 MERGE_AT_BOUNDARY is non-nil (see function comment) is actually the
609 more natural one; then we avoid treating the beginning of a field
611 if (NILP (merge_at_boundary
))
613 Lisp_Object field
= Fget_pos_property (pos
, Qfield
, Qnil
);
614 if (!EQ (field
, after_field
))
616 if (!EQ (field
, before_field
))
618 if (NILP (field
) && at_field_start
&& at_field_end
)
619 /* If an inserted char would have a nil field while the surrounding
620 text is non-nil, we're probably not looking at a
621 zero-length field, but instead at a non-nil field that's
622 not intended for editing (such as comint's prompts). */
623 at_field_end
= at_field_start
= 0;
626 /* Note about special `boundary' fields:
628 Consider the case where the point (`.') is between the fields `x' and `y':
632 In this situation, if merge_at_boundary is non-nil, consider the
633 `x' and `y' fields as forming one big merged field, and so the end
634 of the field is the end of `y'.
636 However, if `x' and `y' are separated by a special `boundary' field
637 (a field with a `field' char-property of 'boundary), then ignore
638 this special field when merging adjacent fields. Here's the same
639 situation, but with a `boundary' field between the `x' and `y' fields:
643 Here, if point is at the end of `x', the beginning of `y', or
644 anywhere in-between (within the `boundary' field), merge all
645 three fields and consider the beginning as being the beginning of
646 the `x' field, and the end as being the end of the `y' field. */
651 /* POS is at the edge of a field, and we should consider it as
652 the beginning of the following field. */
653 *beg
= XFASTINT (pos
);
655 /* Find the previous field boundary. */
658 if (!NILP (merge_at_boundary
) && EQ (before_field
, Qboundary
))
659 /* Skip a `boundary' field. */
660 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
663 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
665 *beg
= NILP (p
) ? BEGV
: XFASTINT (p
);
672 /* POS is at the edge of a field, and we should consider it as
673 the end of the previous field. */
674 *end
= XFASTINT (pos
);
676 /* Find the next field boundary. */
678 if (!NILP (merge_at_boundary
) && EQ (after_field
, Qboundary
))
679 /* Skip a `boundary' field. */
680 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
683 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
685 *end
= NILP (pos
) ? ZV
: XFASTINT (pos
);
691 DEFUN ("delete-field", Fdelete_field
, Sdelete_field
, 0, 1, 0,
692 doc
: /* Delete the field surrounding POS.
693 A field is a region of text with the same `field' property.
694 If POS is nil, the value of point is used for POS. */)
698 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
700 del_range (beg
, end
);
704 DEFUN ("field-string", Ffield_string
, Sfield_string
, 0, 1, 0,
705 doc
: /* Return the contents of the field surrounding POS as a string.
706 A field is a region of text with the same `field' property.
707 If POS is nil, the value of point is used for POS. */)
711 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
712 return make_buffer_string (beg
, end
, 1);
715 DEFUN ("field-string-no-properties", Ffield_string_no_properties
, Sfield_string_no_properties
, 0, 1, 0,
716 doc
: /* Return the contents of the field around POS, without text properties.
717 A field is a region of text with the same `field' property.
718 If POS is nil, the value of point is used for POS. */)
722 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
723 return make_buffer_string (beg
, end
, 0);
726 DEFUN ("field-beginning", Ffield_beginning
, Sfield_beginning
, 0, 3, 0,
727 doc
: /* Return the beginning of the field surrounding POS.
728 A field is a region of text with the same `field' property.
729 If POS is nil, the value of point is used for POS.
730 If ESCAPE-FROM-EDGE is non-nil and POS is at the beginning of its
731 field, then the beginning of the *previous* field is returned.
732 If LIMIT is non-nil, it is a buffer position; if the beginning of the field
733 is before LIMIT, then LIMIT will be returned instead. */)
734 (Lisp_Object pos
, Lisp_Object escape_from_edge
, Lisp_Object limit
)
737 find_field (pos
, escape_from_edge
, limit
, &beg
, Qnil
, 0);
738 return make_number (beg
);
741 DEFUN ("field-end", Ffield_end
, Sfield_end
, 0, 3, 0,
742 doc
: /* Return the end of the field surrounding POS.
743 A field is a region of text with the same `field' property.
744 If POS is nil, the value of point is used for POS.
745 If ESCAPE-FROM-EDGE is non-nil and POS is at the end of its field,
746 then the end of the *following* field is returned.
747 If LIMIT is non-nil, it is a buffer position; if the end of the field
748 is after LIMIT, then LIMIT will be returned instead. */)
749 (Lisp_Object pos
, Lisp_Object escape_from_edge
, Lisp_Object limit
)
752 find_field (pos
, escape_from_edge
, Qnil
, 0, limit
, &end
);
753 return make_number (end
);
756 DEFUN ("constrain-to-field", Fconstrain_to_field
, Sconstrain_to_field
, 2, 5, 0,
757 doc
: /* Return the position closest to NEW-POS that is in the same field as OLD-POS.
758 A field is a region of text with the same `field' property.
760 If NEW-POS is nil, then use the current point instead, and move point
761 to the resulting constrained position, in addition to returning that
764 If OLD-POS is at the boundary of two fields, then the allowable
765 positions for NEW-POS depends on the value of the optional argument
766 ESCAPE-FROM-EDGE: If ESCAPE-FROM-EDGE is nil, then NEW-POS is
767 constrained to the field that has the same `field' char-property
768 as any new characters inserted at OLD-POS, whereas if ESCAPE-FROM-EDGE
769 is non-nil, NEW-POS is constrained to the union of the two adjacent
770 fields. Additionally, if two fields are separated by another field with
771 the special value `boundary', then any point within this special field is
772 also considered to be `on the boundary'.
774 If the optional argument ONLY-IN-LINE is non-nil and constraining
775 NEW-POS would move it to a different line, NEW-POS is returned
776 unconstrained. This is useful for commands that move by line, like
777 \\[next-line] or \\[beginning-of-line], which should generally respect field boundaries
778 only in the case where they can still move to the right line.
780 If the optional argument INHIBIT-CAPTURE-PROPERTY is non-nil, and OLD-POS has
781 a non-nil property of that name, then any field boundaries are ignored.
783 Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
784 (Lisp_Object new_pos
, Lisp_Object old_pos
, Lisp_Object escape_from_edge
,
785 Lisp_Object only_in_line
, Lisp_Object inhibit_capture_property
)
787 /* If non-zero, then the original point, before re-positioning. */
788 ptrdiff_t orig_point
= 0;
790 Lisp_Object prev_old
, prev_new
;
793 /* Use the current point, and afterwards, set it. */
796 XSETFASTINT (new_pos
, PT
);
799 CHECK_NUMBER_COERCE_MARKER (new_pos
);
800 CHECK_NUMBER_COERCE_MARKER (old_pos
);
802 fwd
= (XINT (new_pos
) > XINT (old_pos
));
804 prev_old
= make_number (XINT (old_pos
) - 1);
805 prev_new
= make_number (XINT (new_pos
) - 1);
807 if (NILP (Vinhibit_field_text_motion
)
808 && !EQ (new_pos
, old_pos
)
809 && (!NILP (Fget_char_property (new_pos
, Qfield
, Qnil
))
810 || !NILP (Fget_char_property (old_pos
, Qfield
, Qnil
))
811 /* To recognize field boundaries, we must also look at the
812 previous positions; we could use `Fget_pos_property'
813 instead, but in itself that would fail inside non-sticky
814 fields (like comint prompts). */
815 || (XFASTINT (new_pos
) > BEGV
816 && !NILP (Fget_char_property (prev_new
, Qfield
, Qnil
)))
817 || (XFASTINT (old_pos
) > BEGV
818 && !NILP (Fget_char_property (prev_old
, Qfield
, Qnil
))))
819 && (NILP (inhibit_capture_property
)
820 /* Field boundaries are again a problem; but now we must
821 decide the case exactly, so we need to call
822 `get_pos_property' as well. */
823 || (NILP (Fget_pos_property (old_pos
, inhibit_capture_property
, Qnil
))
824 && (XFASTINT (old_pos
) <= BEGV
825 || NILP (Fget_char_property
826 (old_pos
, inhibit_capture_property
, Qnil
))
827 || NILP (Fget_char_property
828 (prev_old
, inhibit_capture_property
, Qnil
))))))
829 /* It is possible that NEW_POS is not within the same field as
830 OLD_POS; try to move NEW_POS so that it is. */
833 Lisp_Object field_bound
;
836 field_bound
= Ffield_end (old_pos
, escape_from_edge
, new_pos
);
838 field_bound
= Ffield_beginning (old_pos
, escape_from_edge
, new_pos
);
840 if (/* See if ESCAPE_FROM_EDGE caused FIELD_BOUND to jump to the
841 other side of NEW_POS, which would mean that NEW_POS is
842 already acceptable, and it's not necessary to constrain it
844 ((XFASTINT (field_bound
) < XFASTINT (new_pos
)) ? fwd
: !fwd
)
845 /* NEW_POS should be constrained, but only if either
846 ONLY_IN_LINE is nil (in which case any constraint is OK),
847 or NEW_POS and FIELD_BOUND are on the same line (in which
848 case the constraint is OK even if ONLY_IN_LINE is non-nil). */
849 && (NILP (only_in_line
)
850 /* This is the ONLY_IN_LINE case, check that NEW_POS and
851 FIELD_BOUND are on the same line by seeing whether
852 there's an intervening newline or not. */
853 || (find_newline (XFASTINT (new_pos
), -1,
854 XFASTINT (field_bound
), -1,
855 fwd
? -1 : 1, &shortage
, NULL
, 1),
857 /* Constrain NEW_POS to FIELD_BOUND. */
858 new_pos
= field_bound
;
860 if (orig_point
&& XFASTINT (new_pos
) != orig_point
)
861 /* The NEW_POS argument was originally nil, so automatically set PT. */
862 SET_PT (XFASTINT (new_pos
));
869 DEFUN ("line-beginning-position",
870 Fline_beginning_position
, Sline_beginning_position
, 0, 1, 0,
871 doc
: /* Return the character position of the first character on the current line.
872 With optional argument N, scan forward N - 1 lines first.
873 If the scan reaches the end of the buffer, return that position.
875 This function ignores text display directionality; it returns the
876 position of the first character in logical order, i.e. the smallest
877 character position on the line.
879 This function constrains the returned position to the current field
880 unless that position would be on a different line than the original,
881 unconstrained result. If N is nil or 1, and a front-sticky field
882 starts at point, the scan stops as soon as it starts. To ignore field
883 boundaries, bind `inhibit-field-text-motion' to t.
885 This function does not move point. */)
888 ptrdiff_t charpos
, bytepos
;
895 scan_newline_from_point (XINT (n
) - 1, &charpos
, &bytepos
);
897 /* Return END constrained to the current input field. */
898 return Fconstrain_to_field (make_number (charpos
), make_number (PT
),
899 XINT (n
) != 1 ? Qt
: Qnil
,
903 DEFUN ("line-end-position", Fline_end_position
, Sline_end_position
, 0, 1, 0,
904 doc
: /* Return the character position of the last character on the current line.
905 With argument N not nil or 1, move forward N - 1 lines first.
906 If scan reaches end of buffer, return that position.
908 This function ignores text display directionality; it returns the
909 position of the last character in logical order, i.e. the largest
910 character position on the line.
912 This function constrains the returned position to the current field
913 unless that would be on a different line than the original,
914 unconstrained result. If N is nil or 1, and a rear-sticky field ends
915 at point, the scan stops as soon as it starts. To ignore field
916 boundaries bind `inhibit-field-text-motion' to t.
918 This function does not move point. */)
930 clipped_n
= clip_to_bounds (PTRDIFF_MIN
+ 1, XINT (n
), PTRDIFF_MAX
);
931 end_pos
= find_before_next_newline (orig
, 0, clipped_n
- (clipped_n
<= 0),
934 /* Return END_POS constrained to the current input field. */
935 return Fconstrain_to_field (make_number (end_pos
), make_number (orig
),
939 /* Save current buffer state for `save-excursion' special form.
940 We (ab)use Lisp_Misc_Save_Value to allow explicit free and so
941 offload some work from GC. */
944 save_excursion_save (void)
946 return make_save_obj_obj_obj_obj
949 /* Selected window if current buffer is shown in it, nil otherwise. */
950 (EQ (XWINDOW (selected_window
)->contents
, Fcurrent_buffer ())
951 ? selected_window
: Qnil
),
955 /* Restore saved buffer before leaving `save-excursion' special form. */
958 save_excursion_restore (Lisp_Object info
)
960 Lisp_Object tem
, tem1
;
963 tem
= Fmarker_buffer (XSAVE_OBJECT (info
, 0));
964 /* If we're unwinding to top level, saved buffer may be deleted. This
965 means that all of its markers are unchained and so tem is nil. */
974 tem
= XSAVE_OBJECT (info
, 0);
976 unchain_marker (XMARKER (tem
));
978 /* If buffer was visible in a window, and a different window was
979 selected, and the old selected window is still showing this
980 buffer, restore point in that window. */
981 tem
= XSAVE_OBJECT (info
, 2);
983 && !EQ (tem
, selected_window
)
984 && (tem1
= XWINDOW (tem
)->contents
,
985 (/* Window is live... */
987 /* ...and it shows the current buffer. */
988 && XBUFFER (tem1
) == current_buffer
)))
989 Fset_window_point (tem
, make_number (PT
));
998 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
999 doc
: /* Save point, and current buffer; execute BODY; restore those things.
1000 Executes BODY just like `progn'.
1001 The values of point and the current buffer are restored
1002 even in case of abnormal exit (throw or error).
1004 If you only want to save the current buffer but not point,
1005 then just use `save-current-buffer', or even `with-current-buffer'.
1007 Before Emacs 25.1, `save-excursion' used to save the mark state.
1008 To save the marker state as well as the point and buffer, use
1009 `save-mark-and-excursion'.
1011 usage: (save-excursion &rest BODY) */)
1014 register Lisp_Object val
;
1015 ptrdiff_t count
= SPECPDL_INDEX ();
1017 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
1019 val
= Fprogn (args
);
1020 return unbind_to (count
, val
);
1023 DEFUN ("save-current-buffer", Fsave_current_buffer
, Ssave_current_buffer
, 0, UNEVALLED
, 0,
1024 doc
: /* Record which buffer is current; execute BODY; make that buffer current.
1025 BODY is executed just like `progn'.
1026 usage: (save-current-buffer &rest BODY) */)
1029 ptrdiff_t count
= SPECPDL_INDEX ();
1031 record_unwind_current_buffer ();
1032 return unbind_to (count
, Fprogn (args
));
1035 DEFUN ("buffer-size", Fbuffer_size
, Sbuffer_size
, 0, 1, 0,
1036 doc
: /* Return the number of characters in the current buffer.
1037 If BUFFER, return the number of characters in that buffer instead. */)
1038 (Lisp_Object buffer
)
1041 return make_number (Z
- BEG
);
1044 CHECK_BUFFER (buffer
);
1045 return make_number (BUF_Z (XBUFFER (buffer
))
1046 - BUF_BEG (XBUFFER (buffer
)));
1050 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
1051 doc
: /* Return the minimum permissible value of point in the current buffer.
1052 This is 1, unless narrowing (a buffer restriction) is in effect. */)
1056 XSETFASTINT (temp
, BEGV
);
1060 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
1061 doc
: /* Return a marker to the minimum permissible value of point in this buffer.
1062 This is the beginning, unless narrowing (a buffer restriction) is in effect. */)
1065 return build_marker (current_buffer
, BEGV
, BEGV_BYTE
);
1068 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
1069 doc
: /* Return the maximum permissible value of point in the current buffer.
1070 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1071 is in effect, in which case it is less. */)
1075 XSETFASTINT (temp
, ZV
);
1079 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
1080 doc
: /* Return a marker to the maximum permissible value of point in this buffer.
1081 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1082 is in effect, in which case it is less. */)
1085 return build_marker (current_buffer
, ZV
, ZV_BYTE
);
1088 DEFUN ("gap-position", Fgap_position
, Sgap_position
, 0, 0, 0,
1089 doc
: /* Return the position of the gap, in the current buffer.
1090 See also `gap-size'. */)
1094 XSETFASTINT (temp
, GPT
);
1098 DEFUN ("gap-size", Fgap_size
, Sgap_size
, 0, 0, 0,
1099 doc
: /* Return the size of the current buffer's gap.
1100 See also `gap-position'. */)
1104 XSETFASTINT (temp
, GAP_SIZE
);
1108 DEFUN ("position-bytes", Fposition_bytes
, Sposition_bytes
, 1, 1, 0,
1109 doc
: /* Return the byte position for character position POSITION.
1110 If POSITION is out of range, the value is nil. */)
1111 (Lisp_Object position
)
1113 CHECK_NUMBER_COERCE_MARKER (position
);
1114 if (XINT (position
) < BEG
|| XINT (position
) > Z
)
1116 return make_number (CHAR_TO_BYTE (XINT (position
)));
1119 DEFUN ("byte-to-position", Fbyte_to_position
, Sbyte_to_position
, 1, 1, 0,
1120 doc
: /* Return the character position for byte position BYTEPOS.
1121 If BYTEPOS is out of range, the value is nil. */)
1122 (Lisp_Object bytepos
)
1126 CHECK_NUMBER (bytepos
);
1127 pos_byte
= XINT (bytepos
);
1128 if (pos_byte
< BEG_BYTE
|| pos_byte
> Z_BYTE
)
1131 /* There are multibyte characters in the buffer.
1132 The argument of BYTE_TO_CHAR must be a byte position at
1133 a character boundary, so search for the start of the current
1135 while (!CHAR_HEAD_P (FETCH_BYTE (pos_byte
)))
1137 return make_number (BYTE_TO_CHAR (pos_byte
));
1140 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
1141 doc
: /* Return the character following point, as a number.
1142 At the end of the buffer or accessible region, return 0. */)
1147 XSETFASTINT (temp
, 0);
1149 XSETFASTINT (temp
, FETCH_CHAR (PT_BYTE
));
1153 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
1154 doc
: /* Return the character preceding point, as a number.
1155 At the beginning of the buffer or accessible region, return 0. */)
1160 XSETFASTINT (temp
, 0);
1161 else if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1163 ptrdiff_t pos
= PT_BYTE
;
1165 XSETFASTINT (temp
, FETCH_CHAR (pos
));
1168 XSETFASTINT (temp
, FETCH_BYTE (PT_BYTE
- 1));
1172 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
1173 doc
: /* Return t if point is at the beginning of the buffer.
1174 If the buffer is narrowed, this means the beginning of the narrowed part. */)
1182 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
1183 doc
: /* Return t if point is at the end of the buffer.
1184 If the buffer is narrowed, this means the end of the narrowed part. */)
1192 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
1193 doc
: /* Return t if point is at the beginning of a line. */)
1196 if (PT
== BEGV
|| FETCH_BYTE (PT_BYTE
- 1) == '\n')
1201 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
1202 doc
: /* Return t if point is at the end of a line.
1203 `End of a line' includes point being at the end of the buffer. */)
1206 if (PT
== ZV
|| FETCH_BYTE (PT_BYTE
) == '\n')
1211 DEFUN ("char-after", Fchar_after
, Schar_after
, 0, 1, 0,
1212 doc
: /* Return character in current buffer at position POS.
1213 POS is an integer or a marker and defaults to point.
1214 If POS is out of range, the value is nil. */)
1217 register ptrdiff_t pos_byte
;
1222 XSETFASTINT (pos
, PT
);
1227 pos_byte
= marker_byte_position (pos
);
1228 if (pos_byte
< BEGV_BYTE
|| pos_byte
>= ZV_BYTE
)
1233 CHECK_NUMBER_COERCE_MARKER (pos
);
1234 if (XINT (pos
) < BEGV
|| XINT (pos
) >= ZV
)
1237 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1240 return make_number (FETCH_CHAR (pos_byte
));
1243 DEFUN ("char-before", Fchar_before
, Schar_before
, 0, 1, 0,
1244 doc
: /* Return character in current buffer preceding position POS.
1245 POS is an integer or a marker and defaults to point.
1246 If POS is out of range, the value is nil. */)
1249 register Lisp_Object val
;
1250 register ptrdiff_t pos_byte
;
1255 XSETFASTINT (pos
, PT
);
1260 pos_byte
= marker_byte_position (pos
);
1262 if (pos_byte
<= BEGV_BYTE
|| pos_byte
> ZV_BYTE
)
1267 CHECK_NUMBER_COERCE_MARKER (pos
);
1269 if (XINT (pos
) <= BEGV
|| XINT (pos
) > ZV
)
1272 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1275 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1278 XSETFASTINT (val
, FETCH_CHAR (pos_byte
));
1283 XSETFASTINT (val
, FETCH_BYTE (pos_byte
));
1288 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 1, 0,
1289 doc
: /* Return the name under which the user logged in, as a string.
1290 This is based on the effective uid, not the real uid.
1291 Also, if the environment variables LOGNAME or USER are set,
1292 that determines the value of this function.
1294 If optional argument UID is an integer or a float, return the login name
1295 of the user with that uid, or nil if there is no such user. */)
1301 /* Set up the user name info if we didn't do it before.
1302 (That can happen if Emacs is dumpable
1303 but you decide to run `temacs -l loadup' and not dump. */
1304 if (NILP (Vuser_login_name
))
1305 init_editfns (false);
1308 return Vuser_login_name
;
1310 CONS_TO_INTEGER (uid
, uid_t
, id
);
1314 return (pw
? build_string (pw
->pw_name
) : Qnil
);
1317 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
1319 doc
: /* Return the name of the user's real uid, as a string.
1320 This ignores the environment variables LOGNAME and USER, so it differs from
1321 `user-login-name' when running under `su'. */)
1324 /* Set up the user name info if we didn't do it before.
1325 (That can happen if Emacs is dumpable
1326 but you decide to run `temacs -l loadup' and not dump. */
1327 if (NILP (Vuser_login_name
))
1328 init_editfns (false);
1329 return Vuser_real_login_name
;
1332 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
1333 doc
: /* Return the effective uid of Emacs.
1334 Value is an integer or a float, depending on the value. */)
1337 uid_t euid
= geteuid ();
1338 return make_fixnum_or_float (euid
);
1341 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
1342 doc
: /* Return the real uid of Emacs.
1343 Value is an integer or a float, depending on the value. */)
1346 uid_t uid
= getuid ();
1347 return make_fixnum_or_float (uid
);
1350 DEFUN ("group-gid", Fgroup_gid
, Sgroup_gid
, 0, 0, 0,
1351 doc
: /* Return the effective gid of Emacs.
1352 Value is an integer or a float, depending on the value. */)
1355 gid_t egid
= getegid ();
1356 return make_fixnum_or_float (egid
);
1359 DEFUN ("group-real-gid", Fgroup_real_gid
, Sgroup_real_gid
, 0, 0, 0,
1360 doc
: /* Return the real gid of Emacs.
1361 Value is an integer or a float, depending on the value. */)
1364 gid_t gid
= getgid ();
1365 return make_fixnum_or_float (gid
);
1368 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 1, 0,
1369 doc
: /* Return the full name of the user logged in, as a string.
1370 If the full name corresponding to Emacs's userid is not known,
1373 If optional argument UID is an integer or float, return the full name
1374 of the user with that uid, or nil if there is no such user.
1375 If UID is a string, return the full name of the user with that login
1376 name, or nil if there is no such user. */)
1380 register char *p
, *q
;
1384 return Vuser_full_name
;
1385 else if (NUMBERP (uid
))
1388 CONS_TO_INTEGER (uid
, uid_t
, u
);
1393 else if (STRINGP (uid
))
1396 pw
= getpwnam (SSDATA (uid
));
1400 error ("Invalid UID specification");
1406 /* Chop off everything after the first comma. */
1407 q
= strchr (p
, ',');
1408 full
= make_string (p
, q
? q
- p
: strlen (p
));
1410 #ifdef AMPERSAND_FULL_NAME
1412 q
= strchr (p
, '&');
1413 /* Substitute the login name for the &, upcasing the first character. */
1416 Lisp_Object login
= Fuser_login_name (make_number (pw
->pw_uid
));
1418 char *r
= SAFE_ALLOCA (strlen (p
) + SBYTES (login
) + 1);
1419 memcpy (r
, p
, q
- p
);
1420 char *s
= lispstpcpy (&r
[q
- p
], login
);
1421 r
[q
- p
] = upcase ((unsigned char) r
[q
- p
]);
1423 full
= build_string (r
);
1426 #endif /* AMPERSAND_FULL_NAME */
1431 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
1432 doc
: /* Return the host name of the machine you are running on, as a string. */)
1435 if (EQ (Vsystem_name
, cached_system_name
))
1436 init_and_cache_system_name ();
1437 return Vsystem_name
;
1440 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
1441 doc
: /* Return the process ID of Emacs, as a number. */)
1444 pid_t pid
= getpid ();
1445 return make_fixnum_or_float (pid
);
1451 # define TIME_T_MIN TYPE_MINIMUM (time_t)
1454 # define TIME_T_MAX TYPE_MAXIMUM (time_t)
1457 /* Report that a time value is out of range for Emacs. */
1459 time_overflow (void)
1461 error ("Specified time is not representable");
1467 error ("Invalid time specification");
1470 /* Check a return value compatible with that of decode_time_components. */
1472 check_time_validity (int validity
)
1483 /* Return the upper part of the time T (everything but the bottom 16 bits). */
1487 time_t hi
= t
>> LO_TIME_BITS
;
1489 /* Check for overflow, helping the compiler for common cases where
1490 no runtime check is needed, and taking care not to convert
1491 negative numbers to unsigned before comparing them. */
1492 if (! ((! TYPE_SIGNED (time_t)
1493 || MOST_NEGATIVE_FIXNUM
<= TIME_T_MIN
>> LO_TIME_BITS
1494 || MOST_NEGATIVE_FIXNUM
<= hi
)
1495 && (TIME_T_MAX
>> LO_TIME_BITS
<= MOST_POSITIVE_FIXNUM
1496 || hi
<= MOST_POSITIVE_FIXNUM
)))
1502 /* Return the bottom bits of the time T. */
1506 return t
& ((1 << LO_TIME_BITS
) - 1);
1509 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
1510 doc
: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
1511 The time is returned as a list of integers (HIGH LOW USEC PSEC).
1512 HIGH has the most significant bits of the seconds, while LOW has the
1513 least significant 16 bits. USEC and PSEC are the microsecond and
1514 picosecond counts. */)
1517 return make_lisp_time (current_timespec ());
1520 static struct lisp_time
1521 time_add (struct lisp_time ta
, struct lisp_time tb
)
1523 EMACS_INT hi
= ta
.hi
+ tb
.hi
;
1524 int lo
= ta
.lo
+ tb
.lo
;
1525 int us
= ta
.us
+ tb
.us
;
1526 int ps
= ta
.ps
+ tb
.ps
;
1527 us
+= (1000000 <= ps
);
1528 ps
-= (1000000 <= ps
) * 1000000;
1529 lo
+= (1000000 <= us
);
1530 us
-= (1000000 <= us
) * 1000000;
1531 hi
+= (1 << LO_TIME_BITS
<= lo
);
1532 lo
-= (1 << LO_TIME_BITS
<= lo
) << LO_TIME_BITS
;
1533 return (struct lisp_time
) { hi
, lo
, us
, ps
};
1536 static struct lisp_time
1537 time_subtract (struct lisp_time ta
, struct lisp_time tb
)
1539 EMACS_INT hi
= ta
.hi
- tb
.hi
;
1540 int lo
= ta
.lo
- tb
.lo
;
1541 int us
= ta
.us
- tb
.us
;
1542 int ps
= ta
.ps
- tb
.ps
;
1544 ps
+= (ps
< 0) * 1000000;
1546 us
+= (us
< 0) * 1000000;
1548 lo
+= (lo
< 0) << LO_TIME_BITS
;
1549 return (struct lisp_time
) { hi
, lo
, us
, ps
};
1553 time_arith (Lisp_Object a
, Lisp_Object b
,
1554 struct lisp_time (*op
) (struct lisp_time
, struct lisp_time
))
1557 struct lisp_time ta
= lisp_time_struct (a
, &alen
);
1558 struct lisp_time tb
= lisp_time_struct (b
, &blen
);
1559 struct lisp_time t
= op (ta
, tb
);
1560 if (! (MOST_NEGATIVE_FIXNUM
<= t
.hi
&& t
.hi
<= MOST_POSITIVE_FIXNUM
))
1562 Lisp_Object val
= Qnil
;
1564 switch (max (alen
, blen
))
1567 val
= Fcons (make_number (t
.ps
), val
);
1570 val
= Fcons (make_number (t
.us
), val
);
1573 val
= Fcons (make_number (t
.lo
), val
);
1574 val
= Fcons (make_number (t
.hi
), val
);
1581 DEFUN ("time-add", Ftime_add
, Stime_add
, 2, 2, 0,
1582 doc
: /* Return the sum of two time values A and B, as a time value. */)
1583 (Lisp_Object a
, Lisp_Object b
)
1585 return time_arith (a
, b
, time_add
);
1588 DEFUN ("time-subtract", Ftime_subtract
, Stime_subtract
, 2, 2, 0,
1589 doc
: /* Return the difference between two time values A and B, as a time value. */)
1590 (Lisp_Object a
, Lisp_Object b
)
1592 return time_arith (a
, b
, time_subtract
);
1595 DEFUN ("time-less-p", Ftime_less_p
, Stime_less_p
, 2, 2, 0,
1596 doc
: /* Return non-nil if time value T1 is earlier than time value T2. */)
1597 (Lisp_Object t1
, Lisp_Object t2
)
1600 struct lisp_time a
= lisp_time_struct (t1
, &t1len
);
1601 struct lisp_time b
= lisp_time_struct (t2
, &t2len
);
1602 return ((a
.hi
!= b
.hi
? a
.hi
< b
.hi
1603 : a
.lo
!= b
.lo
? a
.lo
< b
.lo
1604 : a
.us
!= b
.us
? a
.us
< b
.us
1610 DEFUN ("get-internal-run-time", Fget_internal_run_time
, Sget_internal_run_time
,
1612 doc
: /* Return the current run time used by Emacs.
1613 The time is returned as a list (HIGH LOW USEC PSEC), using the same
1614 style as (current-time).
1616 On systems that can't determine the run time, `get-internal-run-time'
1617 does the same thing as `current-time'. */)
1620 #ifdef HAVE_GETRUSAGE
1621 struct rusage usage
;
1625 if (getrusage (RUSAGE_SELF
, &usage
) < 0)
1626 /* This shouldn't happen. What action is appropriate? */
1629 /* Sum up user time and system time. */
1630 secs
= usage
.ru_utime
.tv_sec
+ usage
.ru_stime
.tv_sec
;
1631 usecs
= usage
.ru_utime
.tv_usec
+ usage
.ru_stime
.tv_usec
;
1632 if (usecs
>= 1000000)
1637 return make_lisp_time (make_timespec (secs
, usecs
* 1000));
1638 #else /* ! HAVE_GETRUSAGE */
1640 return w32_get_internal_run_time ();
1641 #else /* ! WINDOWSNT */
1642 return Fcurrent_time ();
1643 #endif /* WINDOWSNT */
1644 #endif /* HAVE_GETRUSAGE */
1648 /* Make a Lisp list that represents the Emacs time T. T may be an
1649 invalid time, with a slightly negative tv_nsec value such as
1650 UNKNOWN_MODTIME_NSECS; in that case, the Lisp list contains a
1651 correspondingly negative picosecond count. */
1653 make_lisp_time (struct timespec t
)
1655 time_t s
= t
.tv_sec
;
1657 return list4i (hi_time (s
), lo_time (s
), ns
/ 1000, ns
% 1000 * 1000);
1660 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1661 Set *PHIGH, *PLOW, *PUSEC, *PPSEC to its parts; do not check their values.
1662 Return 2, 3, or 4 to indicate the effective length of SPECIFIED_TIME
1663 if successful, 0 if unsuccessful. */
1665 disassemble_lisp_time (Lisp_Object specified_time
, Lisp_Object
*phigh
,
1666 Lisp_Object
*plow
, Lisp_Object
*pusec
,
1669 Lisp_Object high
= make_number (0);
1670 Lisp_Object low
= specified_time
;
1671 Lisp_Object usec
= make_number (0);
1672 Lisp_Object psec
= make_number (0);
1675 if (CONSP (specified_time
))
1677 high
= XCAR (specified_time
);
1678 low
= XCDR (specified_time
);
1681 Lisp_Object low_tail
= XCDR (low
);
1683 if (CONSP (low_tail
))
1685 usec
= XCAR (low_tail
);
1686 low_tail
= XCDR (low_tail
);
1687 if (CONSP (low_tail
))
1688 psec
= XCAR (low_tail
);
1692 else if (!NILP (low_tail
))
1703 /* When combining components, require LOW to be an integer,
1704 as otherwise it would be a pain to add up times. */
1705 if (! INTEGERP (low
))
1708 else if (INTEGERP (specified_time
))
1718 /* Convert T into an Emacs time *RESULT, truncating toward minus infinity.
1719 Return true if T is in range, false otherwise. */
1721 decode_float_time (double t
, struct lisp_time
*result
)
1723 double lo_multiplier
= 1 << LO_TIME_BITS
;
1724 double emacs_time_min
= MOST_NEGATIVE_FIXNUM
* lo_multiplier
;
1725 if (! (emacs_time_min
<= t
&& t
< -emacs_time_min
))
1728 double small_t
= t
/ lo_multiplier
;
1729 EMACS_INT hi
= small_t
;
1730 double t_sans_hi
= t
- hi
* lo_multiplier
;
1732 long double fracps
= (t_sans_hi
- lo
) * 1e12L
;
1733 #ifdef INT_FAST64_MAX
1734 int_fast64_t ifracps
= fracps
;
1735 int us
= ifracps
/ 1000000;
1736 int ps
= ifracps
% 1000000;
1738 int us
= fracps
/ 1e6L
;
1739 int ps
= fracps
- us
* 1e6L
;
1742 ps
+= (ps
< 0) * 1000000;
1744 us
+= (us
< 0) * 1000000;
1746 lo
+= (lo
< 0) << LO_TIME_BITS
;
1754 /* From the time components HIGH, LOW, USEC and PSEC taken from a Lisp
1755 list, generate the corresponding time value.
1756 If LOW is floating point, the other components should be zero.
1758 If RESULT is not null, store into *RESULT the converted time.
1759 If *DRESULT is not null, store into *DRESULT the number of
1760 seconds since the start of the POSIX Epoch.
1762 Return 1 if successful, 0 if the components are of the
1763 wrong type, and -1 if the time is out of range. */
1765 decode_time_components (Lisp_Object high
, Lisp_Object low
, Lisp_Object usec
,
1767 struct lisp_time
*result
, double *dresult
)
1769 EMACS_INT hi
, lo
, us
, ps
;
1770 if (! (INTEGERP (high
)
1771 && INTEGERP (usec
) && INTEGERP (psec
)))
1773 if (! INTEGERP (low
))
1777 double t
= XFLOAT_DATA (low
);
1778 if (result
&& ! decode_float_time (t
, result
))
1784 else if (NILP (low
))
1786 struct timespec now
= current_timespec ();
1789 result
->hi
= hi_time (now
.tv_sec
);
1790 result
->lo
= lo_time (now
.tv_sec
);
1791 result
->us
= now
.tv_nsec
/ 1000;
1792 result
->ps
= now
.tv_nsec
% 1000 * 1000;
1795 *dresult
= now
.tv_sec
+ now
.tv_nsec
/ 1e9
;
1807 /* Normalize out-of-range lower-order components by carrying
1808 each overflow into the next higher-order component. */
1809 us
+= ps
/ 1000000 - (ps
% 1000000 < 0);
1810 lo
+= us
/ 1000000 - (us
% 1000000 < 0);
1811 hi
+= lo
>> LO_TIME_BITS
;
1812 ps
= ps
% 1000000 + 1000000 * (ps
% 1000000 < 0);
1813 us
= us
% 1000000 + 1000000 * (us
% 1000000 < 0);
1814 lo
&= (1 << LO_TIME_BITS
) - 1;
1818 if (! (MOST_NEGATIVE_FIXNUM
<= hi
&& hi
<= MOST_POSITIVE_FIXNUM
))
1829 *dresult
= (us
* 1e6
+ ps
) / 1e12
+ lo
+ dhi
* (1 << LO_TIME_BITS
);
1836 lisp_to_timespec (struct lisp_time t
)
1838 if (! ((TYPE_SIGNED (time_t) ? TIME_T_MIN
>> LO_TIME_BITS
<= t
.hi
: 0 <= t
.hi
)
1839 && t
.hi
<= TIME_T_MAX
>> LO_TIME_BITS
))
1840 return invalid_timespec ();
1841 time_t s
= (t
.hi
<< LO_TIME_BITS
) + t
.lo
;
1842 int ns
= t
.us
* 1000 + t
.ps
/ 1000;
1843 return make_timespec (s
, ns
);
1846 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1847 Store its effective length into *PLEN.
1848 If SPECIFIED_TIME is nil, use the current time.
1849 Signal an error if SPECIFIED_TIME does not represent a time. */
1850 static struct lisp_time
1851 lisp_time_struct (Lisp_Object specified_time
, int *plen
)
1853 Lisp_Object high
, low
, usec
, psec
;
1855 int len
= disassemble_lisp_time (specified_time
, &high
, &low
, &usec
, &psec
);
1856 int val
= len
? decode_time_components (high
, low
, usec
, psec
, &t
, 0) : 0;
1857 check_time_validity (val
);
1862 /* Like lisp_time_struct, except return a struct timespec.
1863 Discard any low-order digits. */
1865 lisp_time_argument (Lisp_Object specified_time
)
1868 struct lisp_time lt
= lisp_time_struct (specified_time
, &len
);
1869 struct timespec t
= lisp_to_timespec (lt
);
1870 if (! timespec_valid_p (t
))
1875 /* Like lisp_time_argument, except decode only the seconds part,
1876 and do not check the subseconds part. */
1878 lisp_seconds_argument (Lisp_Object specified_time
)
1880 Lisp_Object high
, low
, usec
, psec
;
1883 int val
= disassemble_lisp_time (specified_time
, &high
, &low
, &usec
, &psec
);
1886 val
= decode_time_components (high
, low
, make_number (0),
1887 make_number (0), &t
, 0);
1889 && ! ((TYPE_SIGNED (time_t)
1890 ? TIME_T_MIN
>> LO_TIME_BITS
<= t
.hi
1892 && t
.hi
<= TIME_T_MAX
>> LO_TIME_BITS
))
1895 check_time_validity (val
);
1896 return (t
.hi
<< LO_TIME_BITS
) + t
.lo
;
1899 DEFUN ("float-time", Ffloat_time
, Sfloat_time
, 0, 1, 0,
1900 doc
: /* Return the current time, as a float number of seconds since the epoch.
1901 If SPECIFIED-TIME is given, it is the time to convert to float
1902 instead of the current time. The argument should have the form
1903 (HIGH LOW) or (HIGH LOW USEC) or (HIGH LOW USEC PSEC). Thus,
1904 you can use times from `current-time' and from `file-attributes'.
1905 SPECIFIED-TIME can also have the form (HIGH . LOW), but this is
1906 considered obsolete.
1908 WARNING: Since the result is floating point, it may not be exact.
1909 If precise time stamps are required, use either `current-time',
1910 or (if you need time as a string) `format-time-string'. */)
1911 (Lisp_Object specified_time
)
1914 Lisp_Object high
, low
, usec
, psec
;
1915 if (! (disassemble_lisp_time (specified_time
, &high
, &low
, &usec
, &psec
)
1916 && decode_time_components (high
, low
, usec
, psec
, 0, &t
)))
1918 return make_float (t
);
1921 /* Write information into buffer S of size MAXSIZE, according to the
1922 FORMAT of length FORMAT_LEN, using time information taken from *TP.
1923 Use the time zone specified by TZ.
1924 Use NS as the number of nanoseconds in the %N directive.
1925 Return the number of bytes written, not including the terminating
1926 '\0'. If S is NULL, nothing will be written anywhere; so to
1927 determine how many bytes would be written, use NULL for S and
1928 ((size_t) -1) for MAXSIZE.
1930 This function behaves like nstrftime, except it allows null
1931 bytes in FORMAT and it does not support nanoseconds. */
1933 emacs_nmemftime (char *s
, size_t maxsize
, const char *format
,
1934 size_t format_len
, const struct tm
*tp
, timezone_t tz
, int ns
)
1938 /* Loop through all the null-terminated strings in the format
1939 argument. Normally there's just one null-terminated string, but
1940 there can be arbitrarily many, concatenated together, if the
1941 format contains '\0' bytes. nstrftime stops at the first
1942 '\0' byte so we must invoke it separately for each such string. */
1951 result
= nstrftime (s
, maxsize
, format
, tp
, tz
, ns
);
1955 if (result
== 0 && s
[0] != '\0')
1960 maxsize
-= result
+ 1;
1962 len
= strlen (format
);
1963 if (len
== format_len
)
1967 format_len
-= len
+ 1;
1971 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 1, 3, 0,
1972 doc
: /* Use FORMAT-STRING to format the time TIME, or now if omitted.
1973 TIME is specified as (HIGH LOW USEC PSEC), as returned by
1974 `current-time' or `file-attributes'. The obsolete form (HIGH . LOW)
1975 is also still accepted.
1976 The optional ZONE is omitted or nil for Emacs local time, t for
1977 Universal Time, `wall' for system wall clock time, or a string as in
1978 `set-time-zone-rule' for a time zone rule.
1979 The value is a copy of FORMAT-STRING, but with certain constructs replaced
1980 by text that describes the specified date and time in TIME:
1982 %Y is the year, %y within the century, %C the century.
1983 %G is the year corresponding to the ISO week, %g within the century.
1984 %m is the numeric month.
1985 %b and %h are the locale's abbreviated month name, %B the full name.
1986 (%h is not supported on MS-Windows.)
1987 %d is the day of the month, zero-padded, %e is blank-padded.
1988 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
1989 %a is the locale's abbreviated name of the day of week, %A the full name.
1990 %U is the week number starting on Sunday, %W starting on Monday,
1991 %V according to ISO 8601.
1992 %j is the day of the year.
1994 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
1995 only blank-padded, %l is like %I blank-padded.
1996 %p is the locale's equivalent of either AM or PM.
1999 %N is the nanosecond, %6N the microsecond, %3N the millisecond, etc.
2000 %Z is the time zone name, %z is the numeric form.
2001 %s is the number of seconds since 1970-01-01 00:00:00 +0000.
2003 %c is the locale's date and time format.
2004 %x is the locale's "preferred" date format.
2005 %D is like "%m/%d/%y".
2006 %F is the ISO 8601 date format (like "%Y-%m-%d").
2008 %R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
2009 %X is the locale's "preferred" time format.
2011 Finally, %n is a newline, %t is a tab, %% is a literal %.
2013 Certain flags and modifiers are available with some format controls.
2014 The flags are `_', `-', `^' and `#'. For certain characters X,
2015 %_X is like %X, but padded with blanks; %-X is like %X,
2016 but without padding. %^X is like %X, but with all textual
2017 characters up-cased; %#X is like %X, but with letter-case of
2018 all textual characters reversed.
2019 %NX (where N stands for an integer) is like %X,
2020 but takes up at least N (a number) positions.
2021 The modifiers are `E' and `O'. For certain characters X,
2022 %EX is a locale's alternative version of %X;
2023 %OX is like %X, but uses the locale's number symbols.
2025 For example, to produce full ISO 8601 format, use "%FT%T%z".
2027 usage: (format-time-string FORMAT-STRING &optional TIME ZONE) */)
2028 (Lisp_Object format_string
, Lisp_Object timeval
, Lisp_Object zone
)
2030 struct timespec t
= lisp_time_argument (timeval
);
2033 CHECK_STRING (format_string
);
2034 format_string
= code_convert_string_norecord (format_string
,
2035 Vlocale_coding_system
, 1);
2036 return format_time_string (SSDATA (format_string
), SBYTES (format_string
),
2041 format_time_string (char const *format
, ptrdiff_t formatlen
,
2042 struct timespec t
, Lisp_Object zone
, struct tm
*tmp
)
2046 ptrdiff_t size
= sizeof buffer
;
2048 Lisp_Object bufstring
;
2052 timezone_t tz
= tzlookup (zone
, false);
2053 tmp
= emacs_localtime_rz (tz
, &t
.tv_sec
, tmp
);
2059 synchronize_system_time_locale ();
2064 len
= emacs_nmemftime (buf
, size
, format
, formatlen
, tmp
, tz
, ns
);
2065 if ((0 < len
&& len
< size
) || (len
== 0 && buf
[0] == '\0'))
2068 /* Buffer was too small, so make it bigger and try again. */
2069 len
= emacs_nmemftime (NULL
, SIZE_MAX
, format
, formatlen
, tmp
, tz
, ns
);
2070 if (STRING_BYTES_BOUND
<= len
)
2076 buf
= SAFE_ALLOCA (size
);
2080 bufstring
= make_unibyte_string (buf
, len
);
2082 return code_convert_string_norecord (bufstring
, Vlocale_coding_system
, 0);
2085 DEFUN ("decode-time", Fdecode_time
, Sdecode_time
, 0, 2, 0,
2086 doc
: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST UTCOFF).
2087 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED),
2088 as from `current-time' and `file-attributes', or nil to use the
2089 current time. The obsolete form (HIGH . LOW) is also still accepted.
2090 The optional ZONE is omitted or nil for Emacs local time, t for
2091 Universal Time, `wall' for system wall clock time, or a string as in
2092 `set-time-zone-rule' for a time zone rule.
2094 The list has the following nine members: SEC is an integer between 0
2095 and 60; SEC is 60 for a leap second, which only some operating systems
2096 support. MINUTE is an integer between 0 and 59. HOUR is an integer
2097 between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
2098 integer between 1 and 12. YEAR is an integer indicating the
2099 four-digit year. DOW is the day of week, an integer between 0 and 6,
2100 where 0 is Sunday. DST is t if daylight saving time is in effect,
2101 otherwise nil. UTCOFF is an integer indicating the UTC offset in
2102 seconds, i.e., the number of seconds east of Greenwich. (Note that
2103 Common Lisp has different meanings for DOW and UTCOFF.)
2105 usage: (decode-time &optional TIME ZONE) */)
2106 (Lisp_Object specified_time
, Lisp_Object zone
)
2108 time_t time_spec
= lisp_seconds_argument (specified_time
);
2109 struct tm local_tm
, gmt_tm
;
2110 timezone_t tz
= tzlookup (zone
, false);
2111 struct tm
*tm
= emacs_localtime_rz (tz
, &time_spec
, &local_tm
);
2115 && MOST_NEGATIVE_FIXNUM
- TM_YEAR_BASE
<= local_tm
.tm_year
2116 && local_tm
.tm_year
<= MOST_POSITIVE_FIXNUM
- TM_YEAR_BASE
))
2119 /* Avoid overflow when INT_MAX < EMACS_INT_MAX. */
2120 EMACS_INT tm_year_base
= TM_YEAR_BASE
;
2122 return CALLN (Flist
,
2123 make_number (local_tm
.tm_sec
),
2124 make_number (local_tm
.tm_min
),
2125 make_number (local_tm
.tm_hour
),
2126 make_number (local_tm
.tm_mday
),
2127 make_number (local_tm
.tm_mon
+ 1),
2128 make_number (local_tm
.tm_year
+ tm_year_base
),
2129 make_number (local_tm
.tm_wday
),
2130 local_tm
.tm_isdst
? Qt
: Qnil
,
2132 ? make_number (tm_gmtoff (&local_tm
))
2133 : gmtime_r (&time_spec
, &gmt_tm
)
2134 ? make_number (tm_diff (&local_tm
, &gmt_tm
))
2138 /* Return OBJ - OFFSET, checking that OBJ is a valid fixnum and that
2139 the result is representable as an int. Assume OFFSET is small and
2142 check_tm_member (Lisp_Object obj
, int offset
)
2147 if (! (INT_MIN
+ offset
<= n
&& n
- offset
<= INT_MAX
))
2152 DEFUN ("encode-time", Fencode_time
, Sencode_time
, 6, MANY
, 0,
2153 doc
: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
2154 This is the reverse operation of `decode-time', which see.
2155 The optional ZONE is omitted or nil for Emacs local time, t for
2156 Universal Time, `wall' for system wall clock time, or a string as in
2157 `set-time-zone-rule' for a time zone rule. It can also be a list (as
2158 from `current-time-zone') or an integer (as from `decode-time')
2159 applied without consideration for daylight saving time.
2161 You can pass more than 7 arguments; then the first six arguments
2162 are used as SECOND through YEAR, and the *last* argument is used as ZONE.
2163 The intervening arguments are ignored.
2164 This feature lets (apply 'encode-time (decode-time ...)) work.
2166 Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed;
2167 for example, a DAY of 0 means the day preceding the given month.
2168 Year numbers less than 100 are treated just like other year numbers.
2169 If you want them to stand for years in this century, you must do that yourself.
2171 Years before 1970 are not guaranteed to work. On some systems,
2172 year values as low as 1901 do work.
2174 usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
2175 (ptrdiff_t nargs
, Lisp_Object
*args
)
2179 Lisp_Object zone
= (nargs
> 6 ? args
[nargs
- 1] : Qnil
);
2181 tm
.tm_sec
= check_tm_member (args
[0], 0);
2182 tm
.tm_min
= check_tm_member (args
[1], 0);
2183 tm
.tm_hour
= check_tm_member (args
[2], 0);
2184 tm
.tm_mday
= check_tm_member (args
[3], 0);
2185 tm
.tm_mon
= check_tm_member (args
[4], 1);
2186 tm
.tm_year
= check_tm_member (args
[5], TM_YEAR_BASE
);
2191 timezone_t tz
= tzlookup (zone
, false);
2192 value
= emacs_mktime_z (tz
, &tm
);
2195 if (value
== (time_t) -1)
2198 return list2i (hi_time (value
), lo_time (value
));
2201 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
,
2203 doc
: /* Return the current local time, as a human-readable string.
2204 Programs can use this function to decode a time,
2205 since the number of columns in each field is fixed
2206 if the year is in the range 1000-9999.
2207 The format is `Sun Sep 16 01:03:52 1973'.
2208 However, see also the functions `decode-time' and `format-time-string'
2209 which provide a much more powerful and general facility.
2211 If SPECIFIED-TIME is given, it is a time to format instead of the
2212 current time. The argument should have the form (HIGH LOW . IGNORED).
2213 Thus, you can use times obtained from `current-time' and from
2214 `file-attributes'. SPECIFIED-TIME can also have the form (HIGH . LOW),
2215 but this is considered obsolete.
2217 The optional ZONE is omitted or nil for Emacs local time, t for
2218 Universal Time, `wall' for system wall clock time, or a string as in
2219 `set-time-zone-rule' for a time zone rule. */)
2220 (Lisp_Object specified_time
, Lisp_Object zone
)
2222 time_t value
= lisp_seconds_argument (specified_time
);
2223 timezone_t tz
= tzlookup (zone
, false);
2225 /* Convert to a string in ctime format, except without the trailing
2226 newline, and without the 4-digit year limit. Don't use asctime
2227 or ctime, as they might dump core if the year is outside the
2228 range -999 .. 9999. */
2230 struct tm
*tmp
= emacs_localtime_rz (tz
, &value
, &tm
);
2235 static char const wday_name
[][4] =
2236 { "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat" };
2237 static char const mon_name
[][4] =
2238 { "Jan", "Feb", "Mar", "Apr", "May", "Jun",
2239 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" };
2240 printmax_t year_base
= TM_YEAR_BASE
;
2241 char buf
[sizeof "Mon Apr 30 12:49:17 " + INT_STRLEN_BOUND (int) + 1];
2242 int len
= sprintf (buf
, "%s %s%3d %02d:%02d:%02d %"pMd
,
2243 wday_name
[tm
.tm_wday
], mon_name
[tm
.tm_mon
], tm
.tm_mday
,
2244 tm
.tm_hour
, tm
.tm_min
, tm
.tm_sec
,
2245 tm
.tm_year
+ year_base
);
2247 return make_unibyte_string (buf
, len
);
2250 /* Yield A - B, measured in seconds.
2251 This function is copied from the GNU C Library. */
2253 tm_diff (struct tm
*a
, struct tm
*b
)
2255 /* Compute intervening leap days correctly even if year is negative.
2256 Take care to avoid int overflow in leap day calculations,
2257 but it's OK to assume that A and B are close to each other. */
2258 int a4
= (a
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (a
->tm_year
& 3);
2259 int b4
= (b
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (b
->tm_year
& 3);
2260 int a100
= a4
/ 25 - (a4
% 25 < 0);
2261 int b100
= b4
/ 25 - (b4
% 25 < 0);
2262 int a400
= a100
>> 2;
2263 int b400
= b100
>> 2;
2264 int intervening_leap_days
= (a4
- b4
) - (a100
- b100
) + (a400
- b400
);
2265 int years
= a
->tm_year
- b
->tm_year
;
2266 int days
= (365 * years
+ intervening_leap_days
2267 + (a
->tm_yday
- b
->tm_yday
));
2268 return (60 * (60 * (24 * days
+ (a
->tm_hour
- b
->tm_hour
))
2269 + (a
->tm_min
- b
->tm_min
))
2270 + (a
->tm_sec
- b
->tm_sec
));
2273 /* Yield A's UTC offset, or an unspecified value if unknown. */
2275 tm_gmtoff (struct tm
*a
)
2278 return a
->tm_gmtoff
;
2284 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 2, 0,
2285 doc
: /* Return the offset and name for the local time zone.
2286 This returns a list of the form (OFFSET NAME).
2287 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
2288 A negative value means west of Greenwich.
2289 NAME is a string giving the name of the time zone.
2290 If SPECIFIED-TIME is given, the time zone offset is determined from it
2291 instead of using the current time. The argument should have the form
2292 (HIGH LOW . IGNORED). Thus, you can use times obtained from
2293 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
2294 have the form (HIGH . LOW), but this is considered obsolete.
2295 Optional second arg ZONE is omitted or nil for the local time zone, or
2296 a string as in `set-time-zone-rule'.
2298 Some operating systems cannot provide all this information to Emacs;
2299 in this case, `current-time-zone' returns a list containing nil for
2300 the data it can't find. */)
2301 (Lisp_Object specified_time
, Lisp_Object zone
)
2303 struct timespec value
;
2304 struct tm local_tm
, gmt_tm
;
2305 Lisp_Object zone_offset
, zone_name
;
2308 value
= make_timespec (lisp_seconds_argument (specified_time
), 0);
2309 zone_name
= format_time_string ("%Z", sizeof "%Z" - 1, value
,
2312 if (HAVE_TM_GMTOFF
|| gmtime_r (&value
.tv_sec
, &gmt_tm
))
2314 long int offset
= (HAVE_TM_GMTOFF
2315 ? tm_gmtoff (&local_tm
)
2316 : tm_diff (&local_tm
, &gmt_tm
));
2317 zone_offset
= make_number (offset
);
2318 if (SCHARS (zone_name
) == 0)
2320 /* No local time zone name is available; use "+-NNNN" instead. */
2321 long int m
= offset
/ 60;
2322 long int am
= offset
< 0 ? - m
: m
;
2323 long int hour
= am
/ 60;
2325 char buf
[sizeof "+00" + INT_STRLEN_BOUND (long int)];
2326 zone_name
= make_formatted_string (buf
, "%c%02ld%02d",
2327 (offset
< 0 ? '-' : '+'),
2332 return list2 (zone_offset
, zone_name
);
2335 DEFUN ("set-time-zone-rule", Fset_time_zone_rule
, Sset_time_zone_rule
, 1, 1, 0,
2336 doc
: /* Set the Emacs local time zone using TZ, a string specifying a time zone rule.
2337 If TZ is nil or `wall', use system wall clock time. If TZ is t, use
2338 Universal Time. If TZ is an integer, treat it as in `encode-time'.
2340 Instead of calling this function, you typically want something else.
2341 To temporarily use a different time zone rule for just one invocation
2342 of `decode-time', `encode-time', or `format-time-string', pass the
2343 function a ZONE argument. To change local time consistently
2344 throughout Emacs, call (setenv "TZ" TZ): this changes both the
2345 environment of the Emacs process and the variable
2346 `process-environment', whereas `set-time-zone-rule' affects only the
2350 tzlookup (NILP (tz
) ? Qwall
: tz
, true);
2354 /* A buffer holding a string of the form "TZ=value", intended
2355 to be part of the environment. If TZ is supposed to be unset,
2356 the buffer string is "tZ=". */
2357 static char *tzvalbuf
;
2359 /* Get the local time zone rule. */
2361 emacs_getenv_TZ (void)
2363 return tzvalbuf
[0] == 'T' ? tzvalbuf
+ tzeqlen
: 0;
2366 /* Set the local time zone rule to TZSTRING, which can be null to
2367 denote wall clock time. Do not record the setting in LOCAL_TZ.
2369 This function is not thread-safe, in theory because putenv is not,
2370 but mostly because of the static storage it updates. Other threads
2371 that invoke localtime etc. may be adversely affected while this
2372 function is executing. */
2375 emacs_setenv_TZ (const char *tzstring
)
2377 static ptrdiff_t tzvalbufsize
;
2378 ptrdiff_t tzstringlen
= tzstring
? strlen (tzstring
) : 0;
2379 char *tzval
= tzvalbuf
;
2380 bool new_tzvalbuf
= tzvalbufsize
<= tzeqlen
+ tzstringlen
;
2384 /* Do not attempt to free the old tzvalbuf, since another thread
2385 may be using it. In practice, the first allocation is large
2386 enough and memory does not leak. */
2387 tzval
= xpalloc (NULL
, &tzvalbufsize
,
2388 tzeqlen
+ tzstringlen
- tzvalbufsize
+ 1, -1, 1);
2396 /* Modify TZVAL in place. Although this is dicey in a
2397 multithreaded environment, we know of no portable alternative.
2398 Calling putenv or setenv could crash some other thread. */
2400 strcpy (tzval
+ tzeqlen
, tzstring
);
2404 /* Turn 'TZ=whatever' into an empty environment variable 'tZ='.
2405 Although this is also dicey, calling unsetenv here can crash Emacs.
2413 /* MS-Windows implementation of 'putenv' copies the argument
2414 string into a block it allocates, so modifying tzval string
2415 does not change the environment. OTOH, the other threads run
2416 by Emacs on MS-Windows never call 'xputenv' or 'putenv' or
2417 'unsetenv', so the original cause for the dicey in-place
2418 modification technique doesn't exist there in the first
2424 /* Although this is not thread-safe, in practice this runs only
2425 on startup when there is only one thread. */
2432 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
2433 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
2434 type of object is Lisp_String). INHERIT is passed to
2435 INSERT_FROM_STRING_FUNC as the last argument. */
2438 general_insert_function (void (*insert_func
)
2439 (const char *, ptrdiff_t),
2440 void (*insert_from_string_func
)
2441 (Lisp_Object
, ptrdiff_t, ptrdiff_t,
2442 ptrdiff_t, ptrdiff_t, bool),
2443 bool inherit
, ptrdiff_t nargs
, Lisp_Object
*args
)
2448 for (argnum
= 0; argnum
< nargs
; argnum
++)
2451 if (CHARACTERP (val
))
2453 int c
= XFASTINT (val
);
2454 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2457 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2458 len
= CHAR_STRING (c
, str
);
2461 str
[0] = CHAR_TO_BYTE8 (c
);
2464 (*insert_func
) ((char *) str
, len
);
2466 else if (STRINGP (val
))
2468 (*insert_from_string_func
) (val
, 0, 0,
2474 wrong_type_argument (Qchar_or_string_p
, val
);
2479 insert1 (Lisp_Object arg
)
2485 /* Callers passing one argument to Finsert need not gcpro the
2486 argument "array", since the only element of the array will
2487 not be used after calling insert or insert_from_string, so
2488 we don't care if it gets trashed. */
2490 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
2491 doc
: /* Insert the arguments, either strings or characters, at point.
2492 Point and before-insertion markers move forward to end up
2493 after the inserted text.
2494 Any other markers at the point of insertion remain before the text.
2496 If the current buffer is multibyte, unibyte strings are converted
2497 to multibyte for insertion (see `string-make-multibyte').
2498 If the current buffer is unibyte, multibyte strings are converted
2499 to unibyte for insertion (see `string-make-unibyte').
2501 When operating on binary data, it may be necessary to preserve the
2502 original bytes of a unibyte string when inserting it into a multibyte
2503 buffer; to accomplish this, apply `string-as-multibyte' to the string
2504 and insert the result.
2506 usage: (insert &rest ARGS) */)
2507 (ptrdiff_t nargs
, Lisp_Object
*args
)
2509 general_insert_function (insert
, insert_from_string
, 0, nargs
, args
);
2513 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
2515 doc
: /* Insert the arguments at point, inheriting properties from adjoining text.
2516 Point and before-insertion markers move forward to end up
2517 after the inserted text.
2518 Any other markers at the point of insertion remain before the text.
2520 If the current buffer is multibyte, unibyte strings are converted
2521 to multibyte for insertion (see `unibyte-char-to-multibyte').
2522 If the current buffer is unibyte, multibyte strings are converted
2523 to unibyte for insertion.
2525 usage: (insert-and-inherit &rest ARGS) */)
2526 (ptrdiff_t nargs
, Lisp_Object
*args
)
2528 general_insert_function (insert_and_inherit
, insert_from_string
, 1,
2533 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
2534 doc
: /* Insert strings or characters at point, relocating markers after the text.
2535 Point and markers move forward to end up after the inserted text.
2537 If the current buffer is multibyte, unibyte strings are converted
2538 to multibyte for insertion (see `unibyte-char-to-multibyte').
2539 If the current buffer is unibyte, multibyte strings are converted
2540 to unibyte for insertion.
2542 If an overlay begins at the insertion point, the inserted text falls
2543 outside the overlay; if a nonempty overlay ends at the insertion
2544 point, the inserted text falls inside that overlay.
2546 usage: (insert-before-markers &rest ARGS) */)
2547 (ptrdiff_t nargs
, Lisp_Object
*args
)
2549 general_insert_function (insert_before_markers
,
2550 insert_from_string_before_markers
, 0,
2555 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers
,
2556 Sinsert_and_inherit_before_markers
, 0, MANY
, 0,
2557 doc
: /* Insert text at point, relocating markers and inheriting properties.
2558 Point and markers move forward to end up after the inserted text.
2560 If the current buffer is multibyte, unibyte strings are converted
2561 to multibyte for insertion (see `unibyte-char-to-multibyte').
2562 If the current buffer is unibyte, multibyte strings are converted
2563 to unibyte for insertion.
2565 usage: (insert-before-markers-and-inherit &rest ARGS) */)
2566 (ptrdiff_t nargs
, Lisp_Object
*args
)
2568 general_insert_function (insert_before_markers_and_inherit
,
2569 insert_from_string_before_markers
, 1,
2574 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 1, 3,
2575 "(list (read-char-by-name \"Insert character (Unicode name or hex): \")\
2576 (prefix-numeric-value current-prefix-arg)\
2578 doc
: /* Insert COUNT copies of CHARACTER.
2579 Interactively, prompt for CHARACTER. You can specify CHARACTER in one
2582 - As its Unicode character name, e.g. \"LATIN SMALL LETTER A\".
2583 Completion is available; if you type a substring of the name
2584 preceded by an asterisk `*', Emacs shows all names which include
2585 that substring, not necessarily at the beginning of the name.
2587 - As a hexadecimal code point, e.g. 263A. Note that code points in
2588 Emacs are equivalent to Unicode up to 10FFFF (which is the limit of
2589 the Unicode code space).
2591 - As a code point with a radix specified with #, e.g. #o21430
2592 (octal), #x2318 (hex), or #10r8984 (decimal).
2594 If called interactively, COUNT is given by the prefix argument. If
2595 omitted or nil, it defaults to 1.
2597 Inserting the character(s) relocates point and before-insertion
2598 markers in the same ways as the function `insert'.
2600 The optional third argument INHERIT, if non-nil, says to inherit text
2601 properties from adjoining text, if those properties are sticky. If
2602 called interactively, INHERIT is t. */)
2603 (Lisp_Object character
, Lisp_Object count
, Lisp_Object inherit
)
2606 register ptrdiff_t n
;
2608 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2611 CHECK_CHARACTER (character
);
2613 XSETFASTINT (count
, 1);
2614 CHECK_NUMBER (count
);
2615 c
= XFASTINT (character
);
2617 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2618 len
= CHAR_STRING (c
, str
);
2620 str
[0] = c
, len
= 1;
2621 if (XINT (count
) <= 0)
2623 if (BUF_BYTES_MAX
/ len
< XINT (count
))
2625 n
= XINT (count
) * len
;
2626 stringlen
= min (n
, sizeof string
- sizeof string
% len
);
2627 for (i
= 0; i
< stringlen
; i
++)
2628 string
[i
] = str
[i
% len
];
2629 while (n
> stringlen
)
2632 if (!NILP (inherit
))
2633 insert_and_inherit (string
, stringlen
);
2635 insert (string
, stringlen
);
2638 if (!NILP (inherit
))
2639 insert_and_inherit (string
, n
);
2645 DEFUN ("insert-byte", Finsert_byte
, Sinsert_byte
, 2, 3, 0,
2646 doc
: /* Insert COUNT (second arg) copies of BYTE (first arg).
2647 Both arguments are required.
2648 BYTE is a number of the range 0..255.
2650 If BYTE is 128..255 and the current buffer is multibyte, the
2651 corresponding eight-bit character is inserted.
2653 Point, and before-insertion markers, are relocated as in the function `insert'.
2654 The optional third arg INHERIT, if non-nil, says to inherit text properties
2655 from adjoining text, if those properties are sticky. */)
2656 (Lisp_Object byte
, Lisp_Object count
, Lisp_Object inherit
)
2658 CHECK_NUMBER (byte
);
2659 if (XINT (byte
) < 0 || XINT (byte
) > 255)
2660 args_out_of_range_3 (byte
, make_number (0), make_number (255));
2661 if (XINT (byte
) >= 128
2662 && ! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2663 XSETFASTINT (byte
, BYTE8_TO_CHAR (XINT (byte
)));
2664 return Finsert_char (byte
, count
, inherit
);
2668 /* Making strings from buffer contents. */
2670 /* Return a Lisp_String containing the text of the current buffer from
2671 START to END. If text properties are in use and the current buffer
2672 has properties in the range specified, the resulting string will also
2673 have them, if PROPS is true.
2675 We don't want to use plain old make_string here, because it calls
2676 make_uninit_string, which can cause the buffer arena to be
2677 compacted. make_string has no way of knowing that the data has
2678 been moved, and thus copies the wrong data into the string. This
2679 doesn't effect most of the other users of make_string, so it should
2680 be left as is. But we should use this function when conjuring
2681 buffer substrings. */
2684 make_buffer_string (ptrdiff_t start
, ptrdiff_t end
, bool props
)
2686 ptrdiff_t start_byte
= CHAR_TO_BYTE (start
);
2687 ptrdiff_t end_byte
= CHAR_TO_BYTE (end
);
2689 return make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
);
2692 /* Return a Lisp_String containing the text of the current buffer from
2693 START / START_BYTE to END / END_BYTE.
2695 If text properties are in use and the current buffer
2696 has properties in the range specified, the resulting string will also
2697 have them, if PROPS is true.
2699 We don't want to use plain old make_string here, because it calls
2700 make_uninit_string, which can cause the buffer arena to be
2701 compacted. make_string has no way of knowing that the data has
2702 been moved, and thus copies the wrong data into the string. This
2703 doesn't effect most of the other users of make_string, so it should
2704 be left as is. But we should use this function when conjuring
2705 buffer substrings. */
2708 make_buffer_string_both (ptrdiff_t start
, ptrdiff_t start_byte
,
2709 ptrdiff_t end
, ptrdiff_t end_byte
, bool props
)
2711 Lisp_Object result
, tem
, tem1
;
2712 ptrdiff_t beg0
, end0
, beg1
, end1
, size
;
2714 if (start_byte
< GPT_BYTE
&& GPT_BYTE
< end_byte
)
2716 /* Two regions, before and after the gap. */
2719 beg1
= GPT_BYTE
+ GAP_SIZE
- BEG_BYTE
;
2720 end1
= end_byte
+ GAP_SIZE
- BEG_BYTE
;
2724 /* The only region. */
2731 if (! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2732 result
= make_uninit_multibyte_string (end
- start
, end_byte
- start_byte
);
2734 result
= make_uninit_string (end
- start
);
2737 memcpy (SDATA (result
), BYTE_POS_ADDR (beg0
), size
);
2739 memcpy (SDATA (result
) + size
, BEG_ADDR
+ beg1
, end1
- beg1
);
2741 /* If desired, update and copy the text properties. */
2744 update_buffer_properties (start
, end
);
2746 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
2747 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
2749 if (XINT (tem
) != end
|| !NILP (tem1
))
2750 copy_intervals_to_string (result
, current_buffer
, start
,
2757 /* Call Vbuffer_access_fontify_functions for the range START ... END
2758 in the current buffer, if necessary. */
2761 update_buffer_properties (ptrdiff_t start
, ptrdiff_t end
)
2763 /* If this buffer has some access functions,
2764 call them, specifying the range of the buffer being accessed. */
2765 if (!NILP (Vbuffer_access_fontify_functions
))
2767 /* But don't call them if we can tell that the work
2768 has already been done. */
2769 if (!NILP (Vbuffer_access_fontified_property
))
2772 = Ftext_property_any (make_number (start
), make_number (end
),
2773 Vbuffer_access_fontified_property
,
2779 CALLN (Frun_hook_with_args
, Qbuffer_access_fontify_functions
,
2780 make_number (start
), make_number (end
));
2784 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
2785 doc
: /* Return the contents of part of the current buffer as a string.
2786 The two arguments START and END are character positions;
2787 they can be in either order.
2788 The string returned is multibyte if the buffer is multibyte.
2790 This function copies the text properties of that part of the buffer
2791 into the result string; if you don't want the text properties,
2792 use `buffer-substring-no-properties' instead. */)
2793 (Lisp_Object start
, Lisp_Object end
)
2795 register ptrdiff_t b
, e
;
2797 validate_region (&start
, &end
);
2801 return make_buffer_string (b
, e
, 1);
2804 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties
,
2805 Sbuffer_substring_no_properties
, 2, 2, 0,
2806 doc
: /* Return the characters of part of the buffer, without the text properties.
2807 The two arguments START and END are character positions;
2808 they can be in either order. */)
2809 (Lisp_Object start
, Lisp_Object end
)
2811 register ptrdiff_t b
, e
;
2813 validate_region (&start
, &end
);
2817 return make_buffer_string (b
, e
, 0);
2820 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
2821 doc
: /* Return the contents of the current buffer as a string.
2822 If narrowing is in effect, this function returns only the visible part
2826 return make_buffer_string_both (BEGV
, BEGV_BYTE
, ZV
, ZV_BYTE
, 1);
2829 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
2831 doc
: /* Insert before point a substring of the contents of BUFFER.
2832 BUFFER may be a buffer or a buffer name.
2833 Arguments START and END are character positions specifying the substring.
2834 They default to the values of (point-min) and (point-max) in BUFFER.
2836 Point and before-insertion markers move forward to end up after the
2838 Any other markers at the point of insertion remain before the text.
2840 If the current buffer is multibyte and BUFFER is unibyte, or vice
2841 versa, strings are converted from unibyte to multibyte or vice versa
2842 using `string-make-multibyte' or `string-make-unibyte', which see. */)
2843 (Lisp_Object buffer
, Lisp_Object start
, Lisp_Object end
)
2845 register EMACS_INT b
, e
, temp
;
2846 register struct buffer
*bp
, *obuf
;
2849 buf
= Fget_buffer (buffer
);
2853 if (!BUFFER_LIVE_P (bp
))
2854 error ("Selecting deleted buffer");
2860 CHECK_NUMBER_COERCE_MARKER (start
);
2867 CHECK_NUMBER_COERCE_MARKER (end
);
2872 temp
= b
, b
= e
, e
= temp
;
2874 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
2875 args_out_of_range (start
, end
);
2877 obuf
= current_buffer
;
2878 set_buffer_internal_1 (bp
);
2879 update_buffer_properties (b
, e
);
2880 set_buffer_internal_1 (obuf
);
2882 insert_from_buffer (bp
, b
, e
- b
, 0);
2886 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
2888 doc
: /* Compare two substrings of two buffers; return result as number.
2889 Return -N if first string is less after N-1 chars, +N if first string is
2890 greater after N-1 chars, or 0 if strings match. Each substring is
2891 represented as three arguments: BUFFER, START and END. That makes six
2892 args in all, three for each substring.
2894 The value of `case-fold-search' in the current buffer
2895 determines whether case is significant or ignored. */)
2896 (Lisp_Object buffer1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object buffer2
, Lisp_Object start2
, Lisp_Object end2
)
2898 register EMACS_INT begp1
, endp1
, begp2
, endp2
, temp
;
2899 register struct buffer
*bp1
, *bp2
;
2900 register Lisp_Object trt
2901 = (!NILP (BVAR (current_buffer
, case_fold_search
))
2902 ? BVAR (current_buffer
, case_canon_table
) : Qnil
);
2903 ptrdiff_t chars
= 0;
2904 ptrdiff_t i1
, i2
, i1_byte
, i2_byte
;
2906 /* Find the first buffer and its substring. */
2909 bp1
= current_buffer
;
2913 buf1
= Fget_buffer (buffer1
);
2916 bp1
= XBUFFER (buf1
);
2917 if (!BUFFER_LIVE_P (bp1
))
2918 error ("Selecting deleted buffer");
2922 begp1
= BUF_BEGV (bp1
);
2925 CHECK_NUMBER_COERCE_MARKER (start1
);
2926 begp1
= XINT (start1
);
2929 endp1
= BUF_ZV (bp1
);
2932 CHECK_NUMBER_COERCE_MARKER (end1
);
2933 endp1
= XINT (end1
);
2937 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
2939 if (!(BUF_BEGV (bp1
) <= begp1
2941 && endp1
<= BUF_ZV (bp1
)))
2942 args_out_of_range (start1
, end1
);
2944 /* Likewise for second substring. */
2947 bp2
= current_buffer
;
2951 buf2
= Fget_buffer (buffer2
);
2954 bp2
= XBUFFER (buf2
);
2955 if (!BUFFER_LIVE_P (bp2
))
2956 error ("Selecting deleted buffer");
2960 begp2
= BUF_BEGV (bp2
);
2963 CHECK_NUMBER_COERCE_MARKER (start2
);
2964 begp2
= XINT (start2
);
2967 endp2
= BUF_ZV (bp2
);
2970 CHECK_NUMBER_COERCE_MARKER (end2
);
2971 endp2
= XINT (end2
);
2975 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
2977 if (!(BUF_BEGV (bp2
) <= begp2
2979 && endp2
<= BUF_ZV (bp2
)))
2980 args_out_of_range (start2
, end2
);
2984 i1_byte
= buf_charpos_to_bytepos (bp1
, i1
);
2985 i2_byte
= buf_charpos_to_bytepos (bp2
, i2
);
2987 while (i1
< endp1
&& i2
< endp2
)
2989 /* When we find a mismatch, we must compare the
2990 characters, not just the bytes. */
2995 if (! NILP (BVAR (bp1
, enable_multibyte_characters
)))
2997 c1
= BUF_FETCH_MULTIBYTE_CHAR (bp1
, i1_byte
);
2998 BUF_INC_POS (bp1
, i1_byte
);
3003 c1
= BUF_FETCH_BYTE (bp1
, i1
);
3004 MAKE_CHAR_MULTIBYTE (c1
);
3008 if (! NILP (BVAR (bp2
, enable_multibyte_characters
)))
3010 c2
= BUF_FETCH_MULTIBYTE_CHAR (bp2
, i2_byte
);
3011 BUF_INC_POS (bp2
, i2_byte
);
3016 c2
= BUF_FETCH_BYTE (bp2
, i2
);
3017 MAKE_CHAR_MULTIBYTE (c2
);
3023 c1
= char_table_translate (trt
, c1
);
3024 c2
= char_table_translate (trt
, c2
);
3027 return make_number (- 1 - chars
);
3029 return make_number (chars
+ 1);
3034 /* The strings match as far as they go.
3035 If one is shorter, that one is less. */
3036 if (chars
< endp1
- begp1
)
3037 return make_number (chars
+ 1);
3038 else if (chars
< endp2
- begp2
)
3039 return make_number (- chars
- 1);
3041 /* Same length too => they are equal. */
3042 return make_number (0);
3046 subst_char_in_region_unwind (Lisp_Object arg
)
3048 bset_undo_list (current_buffer
, arg
);
3052 subst_char_in_region_unwind_1 (Lisp_Object arg
)
3054 bset_filename (current_buffer
, arg
);
3057 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
3058 Ssubst_char_in_region
, 4, 5, 0,
3059 doc
: /* From START to END, replace FROMCHAR with TOCHAR each time it occurs.
3060 If optional arg NOUNDO is non-nil, don't record this change for undo
3061 and don't mark the buffer as really changed.
3062 Both characters must have the same length of multi-byte form. */)
3063 (Lisp_Object start
, Lisp_Object end
, Lisp_Object fromchar
, Lisp_Object tochar
, Lisp_Object noundo
)
3065 register ptrdiff_t pos
, pos_byte
, stop
, i
, len
, end_byte
;
3066 /* Keep track of the first change in the buffer:
3067 if 0 we haven't found it yet.
3068 if < 0 we've found it and we've run the before-change-function.
3069 if > 0 we've actually performed it and the value is its position. */
3070 ptrdiff_t changed
= 0;
3071 unsigned char fromstr
[MAX_MULTIBYTE_LENGTH
], tostr
[MAX_MULTIBYTE_LENGTH
];
3073 ptrdiff_t count
= SPECPDL_INDEX ();
3074 #define COMBINING_NO 0
3075 #define COMBINING_BEFORE 1
3076 #define COMBINING_AFTER 2
3077 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
3078 int maybe_byte_combining
= COMBINING_NO
;
3079 ptrdiff_t last_changed
= 0;
3081 = !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3086 validate_region (&start
, &end
);
3087 CHECK_CHARACTER (fromchar
);
3088 CHECK_CHARACTER (tochar
);
3089 fromc
= XFASTINT (fromchar
);
3090 toc
= XFASTINT (tochar
);
3094 len
= CHAR_STRING (fromc
, fromstr
);
3095 if (CHAR_STRING (toc
, tostr
) != len
)
3096 error ("Characters in `subst-char-in-region' have different byte-lengths");
3097 if (!ASCII_CHAR_P (*tostr
))
3099 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
3100 complete multibyte character, it may be combined with the
3101 after bytes. If it is in the range 0xA0..0xFF, it may be
3102 combined with the before and after bytes. */
3103 if (!CHAR_HEAD_P (*tostr
))
3104 maybe_byte_combining
= COMBINING_BOTH
;
3105 else if (BYTES_BY_CHAR_HEAD (*tostr
) > len
)
3106 maybe_byte_combining
= COMBINING_AFTER
;
3117 pos_byte
= CHAR_TO_BYTE (pos
);
3118 stop
= CHAR_TO_BYTE (XINT (end
));
3121 /* If we don't want undo, turn off putting stuff on the list.
3122 That's faster than getting rid of things,
3123 and it prevents even the entry for a first change.
3124 Also inhibit locking the file. */
3125 if (!changed
&& !NILP (noundo
))
3127 record_unwind_protect (subst_char_in_region_unwind
,
3128 BVAR (current_buffer
, undo_list
));
3129 bset_undo_list (current_buffer
, Qt
);
3130 /* Don't do file-locking. */
3131 record_unwind_protect (subst_char_in_region_unwind_1
,
3132 BVAR (current_buffer
, filename
));
3133 bset_filename (current_buffer
, Qnil
);
3136 if (pos_byte
< GPT_BYTE
)
3137 stop
= min (stop
, GPT_BYTE
);
3140 ptrdiff_t pos_byte_next
= pos_byte
;
3142 if (pos_byte
>= stop
)
3144 if (pos_byte
>= end_byte
) break;
3147 p
= BYTE_POS_ADDR (pos_byte
);
3149 INC_POS (pos_byte_next
);
3152 if (pos_byte_next
- pos_byte
== len
3153 && p
[0] == fromstr
[0]
3155 || (p
[1] == fromstr
[1]
3156 && (len
== 2 || (p
[2] == fromstr
[2]
3157 && (len
== 3 || p
[3] == fromstr
[3]))))))
3160 /* We've already seen this and run the before-change-function;
3161 this time we only need to record the actual position. */
3166 modify_text (pos
, XINT (end
));
3168 if (! NILP (noundo
))
3170 if (MODIFF
- 1 == SAVE_MODIFF
)
3172 if (MODIFF
- 1 == BUF_AUTOSAVE_MODIFF (current_buffer
))
3173 BUF_AUTOSAVE_MODIFF (current_buffer
)++;
3176 /* The before-change-function may have moved the gap
3177 or even modified the buffer so we should start over. */
3181 /* Take care of the case where the new character
3182 combines with neighboring bytes. */
3183 if (maybe_byte_combining
3184 && (maybe_byte_combining
== COMBINING_AFTER
3185 ? (pos_byte_next
< Z_BYTE
3186 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
3187 : ((pos_byte_next
< Z_BYTE
3188 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
3189 || (pos_byte
> BEG_BYTE
3190 && ! ASCII_CHAR_P (FETCH_BYTE (pos_byte
- 1))))))
3192 Lisp_Object tem
, string
;
3194 struct gcpro gcpro1
;
3196 tem
= BVAR (current_buffer
, undo_list
);
3199 /* Make a multibyte string containing this single character. */
3200 string
= make_multibyte_string ((char *) tostr
, 1, len
);
3201 /* replace_range is less efficient, because it moves the gap,
3202 but it handles combining correctly. */
3203 replace_range (pos
, pos
+ 1, string
,
3205 pos_byte_next
= CHAR_TO_BYTE (pos
);
3206 if (pos_byte_next
> pos_byte
)
3207 /* Before combining happened. We should not increment
3208 POS. So, to cancel the later increment of POS,
3212 INC_POS (pos_byte_next
);
3214 if (! NILP (noundo
))
3215 bset_undo_list (current_buffer
, tem
);
3222 record_change (pos
, 1);
3223 for (i
= 0; i
< len
; i
++) *p
++ = tostr
[i
];
3225 last_changed
= pos
+ 1;
3227 pos_byte
= pos_byte_next
;
3233 signal_after_change (changed
,
3234 last_changed
- changed
, last_changed
- changed
);
3235 update_compositions (changed
, last_changed
, CHECK_ALL
);
3238 unbind_to (count
, Qnil
);
3243 static Lisp_Object
check_translation (ptrdiff_t, ptrdiff_t, ptrdiff_t,
3246 /* Helper function for Ftranslate_region_internal.
3248 Check if a character sequence at POS (POS_BYTE) matches an element
3249 of VAL. VAL is a list (([FROM-CHAR ...] . TO) ...). If a matching
3250 element is found, return it. Otherwise return Qnil. */
3253 check_translation (ptrdiff_t pos
, ptrdiff_t pos_byte
, ptrdiff_t end
,
3256 int initial_buf
[16];
3257 int *buf
= initial_buf
;
3258 ptrdiff_t buf_size
= ARRAYELTS (initial_buf
);
3260 ptrdiff_t buf_used
= 0;
3261 Lisp_Object result
= Qnil
;
3263 for (; CONSP (val
); val
= XCDR (val
))
3272 if (! VECTORP (elt
))
3275 if (len
<= end
- pos
)
3277 for (i
= 0; i
< len
; i
++)
3281 unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
3284 if (buf_used
== buf_size
)
3286 bufalloc
= xpalloc (bufalloc
, &buf_size
, 1, -1,
3288 if (buf
== initial_buf
)
3289 memcpy (bufalloc
, buf
, sizeof initial_buf
);
3292 buf
[buf_used
++] = STRING_CHAR_AND_LENGTH (p
, len1
);
3295 if (XINT (AREF (elt
, i
)) != buf
[i
])
3300 result
= XCAR (val
);
3311 DEFUN ("translate-region-internal", Ftranslate_region_internal
,
3312 Stranslate_region_internal
, 3, 3, 0,
3313 doc
: /* Internal use only.
3314 From START to END, translate characters according to TABLE.
3315 TABLE is a string or a char-table; the Nth character in it is the
3316 mapping for the character with code N.
3317 It returns the number of characters changed. */)
3318 (Lisp_Object start
, Lisp_Object end
, register Lisp_Object table
)
3320 register unsigned char *tt
; /* Trans table. */
3321 register int nc
; /* New character. */
3322 int cnt
; /* Number of changes made. */
3323 ptrdiff_t size
; /* Size of translate table. */
3324 ptrdiff_t pos
, pos_byte
, end_pos
;
3325 bool multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3326 bool string_multibyte
IF_LINT (= 0);
3328 validate_region (&start
, &end
);
3329 if (CHAR_TABLE_P (table
))
3331 if (! EQ (XCHAR_TABLE (table
)->purpose
, Qtranslation_table
))
3332 error ("Not a translation table");
3338 CHECK_STRING (table
);
3340 if (! multibyte
&& (SCHARS (table
) < SBYTES (table
)))
3341 table
= string_make_unibyte (table
);
3342 string_multibyte
= SCHARS (table
) < SBYTES (table
);
3343 size
= SBYTES (table
);
3348 pos_byte
= CHAR_TO_BYTE (pos
);
3349 end_pos
= XINT (end
);
3350 modify_text (pos
, end_pos
);
3353 for (; pos
< end_pos
; )
3355 register unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
3356 unsigned char *str
, buf
[MAX_MULTIBYTE_LENGTH
];
3362 oc
= STRING_CHAR_AND_LENGTH (p
, len
);
3369 /* Reload as signal_after_change in last iteration may GC. */
3371 if (string_multibyte
)
3373 str
= tt
+ string_char_to_byte (table
, oc
);
3374 nc
= STRING_CHAR_AND_LENGTH (str
, str_len
);
3379 if (! ASCII_CHAR_P (nc
) && multibyte
)
3381 str_len
= BYTE8_STRING (nc
, buf
);
3394 val
= CHAR_TABLE_REF (table
, oc
);
3395 if (CHARACTERP (val
))
3397 nc
= XFASTINT (val
);
3398 str_len
= CHAR_STRING (nc
, buf
);
3401 else if (VECTORP (val
) || (CONSP (val
)))
3403 /* VAL is [TO_CHAR ...] or (([FROM-CHAR ...] . TO) ...)
3404 where TO is TO-CHAR or [TO-CHAR ...]. */
3409 if (nc
!= oc
&& nc
>= 0)
3411 /* Simple one char to one char translation. */
3416 /* This is less efficient, because it moves the gap,
3417 but it should handle multibyte characters correctly. */
3418 string
= make_multibyte_string ((char *) str
, 1, str_len
);
3419 replace_range (pos
, pos
+ 1, string
, 1, 0, 1);
3424 record_change (pos
, 1);
3425 while (str_len
-- > 0)
3427 signal_after_change (pos
, 1, 1);
3428 update_compositions (pos
, pos
+ 1, CHECK_BORDER
);
3438 val
= check_translation (pos
, pos_byte
, end_pos
, val
);
3445 /* VAL is ([FROM-CHAR ...] . TO). */
3446 len
= ASIZE (XCAR (val
));
3454 string
= Fconcat (1, &val
);
3458 string
= Fmake_string (make_number (1), val
);
3460 replace_range (pos
, pos
+ len
, string
, 1, 0, 1);
3461 pos_byte
+= SBYTES (string
);
3462 pos
+= SCHARS (string
);
3463 cnt
+= SCHARS (string
);
3464 end_pos
+= SCHARS (string
) - len
;
3472 return make_number (cnt
);
3475 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
3476 doc
: /* Delete the text between START and END.
3477 If called interactively, delete the region between point and mark.
3478 This command deletes buffer text without modifying the kill ring. */)
3479 (Lisp_Object start
, Lisp_Object end
)
3481 validate_region (&start
, &end
);
3482 del_range (XINT (start
), XINT (end
));
3486 DEFUN ("delete-and-extract-region", Fdelete_and_extract_region
,
3487 Sdelete_and_extract_region
, 2, 2, 0,
3488 doc
: /* Delete the text between START and END and return it. */)
3489 (Lisp_Object start
, Lisp_Object end
)
3491 validate_region (&start
, &end
);
3492 if (XINT (start
) == XINT (end
))
3493 return empty_unibyte_string
;
3494 return del_range_1 (XINT (start
), XINT (end
), 1, 1);
3497 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
3498 doc
: /* Remove restrictions (narrowing) from current buffer.
3499 This allows the buffer's full text to be seen and edited. */)
3502 if (BEG
!= BEGV
|| Z
!= ZV
)
3503 current_buffer
->clip_changed
= 1;
3505 BEGV_BYTE
= BEG_BYTE
;
3506 SET_BUF_ZV_BOTH (current_buffer
, Z
, Z_BYTE
);
3507 /* Changing the buffer bounds invalidates any recorded current column. */
3508 invalidate_current_column ();
3512 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
3513 doc
: /* Restrict editing in this buffer to the current region.
3514 The rest of the text becomes temporarily invisible and untouchable
3515 but is not deleted; if you save the buffer in a file, the invisible
3516 text is included in the file. \\[widen] makes all visible again.
3517 See also `save-restriction'.
3519 When calling from a program, pass two arguments; positions (integers
3520 or markers) bounding the text that should remain visible. */)
3521 (register Lisp_Object start
, Lisp_Object end
)
3523 CHECK_NUMBER_COERCE_MARKER (start
);
3524 CHECK_NUMBER_COERCE_MARKER (end
);
3526 if (XINT (start
) > XINT (end
))
3529 tem
= start
; start
= end
; end
= tem
;
3532 if (!(BEG
<= XINT (start
) && XINT (start
) <= XINT (end
) && XINT (end
) <= Z
))
3533 args_out_of_range (start
, end
);
3535 if (BEGV
!= XFASTINT (start
) || ZV
!= XFASTINT (end
))
3536 current_buffer
->clip_changed
= 1;
3538 SET_BUF_BEGV (current_buffer
, XFASTINT (start
));
3539 SET_BUF_ZV (current_buffer
, XFASTINT (end
));
3540 if (PT
< XFASTINT (start
))
3541 SET_PT (XFASTINT (start
));
3542 if (PT
> XFASTINT (end
))
3543 SET_PT (XFASTINT (end
));
3544 /* Changing the buffer bounds invalidates any recorded current column. */
3545 invalidate_current_column ();
3550 save_restriction_save (void)
3552 if (BEGV
== BEG
&& ZV
== Z
)
3553 /* The common case that the buffer isn't narrowed.
3554 We return just the buffer object, which save_restriction_restore
3555 recognizes as meaning `no restriction'. */
3556 return Fcurrent_buffer ();
3558 /* We have to save a restriction, so return a pair of markers, one
3559 for the beginning and one for the end. */
3561 Lisp_Object beg
, end
;
3563 beg
= build_marker (current_buffer
, BEGV
, BEGV_BYTE
);
3564 end
= build_marker (current_buffer
, ZV
, ZV_BYTE
);
3566 /* END must move forward if text is inserted at its exact location. */
3567 XMARKER (end
)->insertion_type
= 1;
3569 return Fcons (beg
, end
);
3574 save_restriction_restore (Lisp_Object data
)
3576 struct buffer
*cur
= NULL
;
3577 struct buffer
*buf
= (CONSP (data
)
3578 ? XMARKER (XCAR (data
))->buffer
3581 if (buf
&& buf
!= current_buffer
&& !NILP (BVAR (buf
, pt_marker
)))
3582 { /* If `buf' uses markers to keep track of PT, BEGV, and ZV (as
3583 is the case if it is or has an indirect buffer), then make
3584 sure it is current before we update BEGV, so
3585 set_buffer_internal takes care of managing those markers. */
3586 cur
= current_buffer
;
3587 set_buffer_internal (buf
);
3591 /* A pair of marks bounding a saved restriction. */
3593 struct Lisp_Marker
*beg
= XMARKER (XCAR (data
));
3594 struct Lisp_Marker
*end
= XMARKER (XCDR (data
));
3595 eassert (buf
== end
->buffer
);
3597 if (buf
/* Verify marker still points to a buffer. */
3598 && (beg
->charpos
!= BUF_BEGV (buf
) || end
->charpos
!= BUF_ZV (buf
)))
3599 /* The restriction has changed from the saved one, so restore
3600 the saved restriction. */
3602 ptrdiff_t pt
= BUF_PT (buf
);
3604 SET_BUF_BEGV_BOTH (buf
, beg
->charpos
, beg
->bytepos
);
3605 SET_BUF_ZV_BOTH (buf
, end
->charpos
, end
->bytepos
);
3607 if (pt
< beg
->charpos
|| pt
> end
->charpos
)
3608 /* The point is outside the new visible range, move it inside. */
3609 SET_BUF_PT_BOTH (buf
,
3610 clip_to_bounds (beg
->charpos
, pt
, end
->charpos
),
3611 clip_to_bounds (beg
->bytepos
, BUF_PT_BYTE (buf
),
3614 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3616 /* These aren't needed anymore, so don't wait for GC. */
3617 free_marker (XCAR (data
));
3618 free_marker (XCDR (data
));
3619 free_cons (XCONS (data
));
3622 /* A buffer, which means that there was no old restriction. */
3624 if (buf
/* Verify marker still points to a buffer. */
3625 && (BUF_BEGV (buf
) != BUF_BEG (buf
) || BUF_ZV (buf
) != BUF_Z (buf
)))
3626 /* The buffer has been narrowed, get rid of the narrowing. */
3628 SET_BUF_BEGV_BOTH (buf
, BUF_BEG (buf
), BUF_BEG_BYTE (buf
));
3629 SET_BUF_ZV_BOTH (buf
, BUF_Z (buf
), BUF_Z_BYTE (buf
));
3631 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3635 /* Changing the buffer bounds invalidates any recorded current column. */
3636 invalidate_current_column ();
3639 set_buffer_internal (cur
);
3642 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
3643 doc
: /* Execute BODY, saving and restoring current buffer's restrictions.
3644 The buffer's restrictions make parts of the beginning and end invisible.
3645 \(They are set up with `narrow-to-region' and eliminated with `widen'.)
3646 This special form, `save-restriction', saves the current buffer's restrictions
3647 when it is entered, and restores them when it is exited.
3648 So any `narrow-to-region' within BODY lasts only until the end of the form.
3649 The old restrictions settings are restored
3650 even in case of abnormal exit (throw or error).
3652 The value returned is the value of the last form in BODY.
3654 Note: if you are using both `save-excursion' and `save-restriction',
3655 use `save-excursion' outermost:
3656 (save-excursion (save-restriction ...))
3658 usage: (save-restriction &rest BODY) */)
3661 register Lisp_Object val
;
3662 ptrdiff_t count
= SPECPDL_INDEX ();
3664 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
3665 val
= Fprogn (body
);
3666 return unbind_to (count
, val
);
3669 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
3670 doc
: /* Display a message at the bottom of the screen.
3671 The message also goes into the `*Messages*' buffer, if `message-log-max'
3672 is non-nil. (In keyboard macros, that's all it does.)
3675 In batch mode, the message is printed to the standard error stream,
3676 followed by a newline.
3678 The first argument is a format control string, and the rest are data
3679 to be formatted under control of the string. See `format' for details.
3681 Note: Use (message "%s" VALUE) to print the value of expressions and
3682 variables to avoid accidentally interpreting `%' as format specifiers.
3684 If the first argument is nil or the empty string, the function clears
3685 any existing message; this lets the minibuffer contents show. See
3686 also `current-message'.
3688 usage: (message FORMAT-STRING &rest ARGS) */)
3689 (ptrdiff_t nargs
, Lisp_Object
*args
)
3692 || (STRINGP (args
[0])
3693 && SBYTES (args
[0]) == 0))
3700 Lisp_Object val
= Fformat_message (nargs
, args
);
3706 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
3707 doc
: /* Display a message, in a dialog box if possible.
3708 If a dialog box is not available, use the echo area.
3709 The first argument is a format control string, and the rest are data
3710 to be formatted under control of the string. See `format' for details.
3712 If the first argument is nil or the empty string, clear any existing
3713 message; let the minibuffer contents show.
3715 usage: (message-box FORMAT-STRING &rest ARGS) */)
3716 (ptrdiff_t nargs
, Lisp_Object
*args
)
3725 Lisp_Object val
= Fformat_message (nargs
, args
);
3726 Lisp_Object pane
, menu
;
3727 struct gcpro gcpro1
;
3729 pane
= list1 (Fcons (build_string ("OK"), Qt
));
3731 menu
= Fcons (val
, pane
);
3732 Fx_popup_dialog (Qt
, menu
, Qt
);
3738 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
3739 doc
: /* Display a message in a dialog box or in the echo area.
3740 If this command was invoked with the mouse, use a dialog box if
3741 `use-dialog-box' is non-nil.
3742 Otherwise, use the echo area.
3743 The first argument is a format control string, and the rest are data
3744 to be formatted under control of the string. See `format' for details.
3746 If the first argument is nil or the empty string, clear any existing
3747 message; let the minibuffer contents show.
3749 usage: (message-or-box FORMAT-STRING &rest ARGS) */)
3750 (ptrdiff_t nargs
, Lisp_Object
*args
)
3752 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3754 return Fmessage_box (nargs
, args
);
3755 return Fmessage (nargs
, args
);
3758 DEFUN ("current-message", Fcurrent_message
, Scurrent_message
, 0, 0, 0,
3759 doc
: /* Return the string currently displayed in the echo area, or nil if none. */)
3762 return current_message ();
3766 DEFUN ("propertize", Fpropertize
, Spropertize
, 1, MANY
, 0,
3767 doc
: /* Return a copy of STRING with text properties added.
3768 First argument is the string to copy.
3769 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
3770 properties to add to the result.
3771 usage: (propertize STRING &rest PROPERTIES) */)
3772 (ptrdiff_t nargs
, Lisp_Object
*args
)
3774 Lisp_Object properties
, string
;
3775 struct gcpro gcpro1
, gcpro2
;
3778 /* Number of args must be odd. */
3779 if ((nargs
& 1) == 0)
3780 error ("Wrong number of arguments");
3782 properties
= string
= Qnil
;
3783 GCPRO2 (properties
, string
);
3785 /* First argument must be a string. */
3786 CHECK_STRING (args
[0]);
3787 string
= Fcopy_sequence (args
[0]);
3789 for (i
= 1; i
< nargs
; i
+= 2)
3790 properties
= Fcons (args
[i
], Fcons (args
[i
+ 1], properties
));
3792 Fadd_text_properties (make_number (0),
3793 make_number (SCHARS (string
)),
3794 properties
, string
);
3795 RETURN_UNGCPRO (string
);
3798 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
3799 doc
: /* Format a string out of a format-string and arguments.
3800 The first argument is a format control string.
3801 The other arguments are substituted into it to make the result, a string.
3803 The format control string may contain %-sequences meaning to substitute
3804 the next available argument:
3806 %s means print a string argument. Actually, prints any object, with `princ'.
3807 %d means print as number in decimal (%o octal, %x hex).
3808 %X is like %x, but uses upper case.
3809 %e means print a number in exponential notation.
3810 %f means print a number in decimal-point notation.
3811 %g means print a number in exponential notation
3812 or decimal-point notation, whichever uses fewer characters.
3813 %c means print a number as a single character.
3814 %S means print any object as an s-expression (using `prin1').
3816 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
3817 Use %% to put a single % into the output.
3819 A %-sequence may contain optional flag, width, and precision
3820 specifiers, as follows:
3822 %<flags><width><precision>character
3824 where flags is [+ #-0]+, width is [0-9]+, and precision is .[0-9]+
3826 The + flag character inserts a + before any positive number, while a
3827 space inserts a space before any positive number; these flags only
3828 affect %d, %e, %f, and %g sequences, and the + flag takes precedence.
3829 The - and 0 flags affect the width specifier, as described below.
3831 The # flag means to use an alternate display form for %o, %x, %X, %e,
3832 %f, and %g sequences: for %o, it ensures that the result begins with
3833 \"0\"; for %x and %X, it prefixes the result with \"0x\" or \"0X\";
3834 for %e, %f, and %g, it causes a decimal point to be included even if
3835 the precision is zero.
3837 The width specifier supplies a lower limit for the length of the
3838 printed representation. The padding, if any, normally goes on the
3839 left, but it goes on the right if the - flag is present. The padding
3840 character is normally a space, but it is 0 if the 0 flag is present.
3841 The 0 flag is ignored if the - flag is present, or the format sequence
3842 is something other than %d, %e, %f, and %g.
3844 For %e, %f, and %g sequences, the number after the "." in the
3845 precision specifier says how many decimal places to show; if zero, the
3846 decimal point itself is omitted. For %s and %S, the precision
3847 specifier truncates the string to the given width.
3849 usage: (format STRING &rest OBJECTS) */)
3850 (ptrdiff_t nargs
, Lisp_Object
*args
)
3852 return styled_format (nargs
, args
, false);
3855 DEFUN ("format-message", Fformat_message
, Sformat_message
, 1, MANY
, 0,
3856 doc
: /* Format a string out of a format-string and arguments.
3857 The first argument is a format control string.
3858 The other arguments are substituted into it to make the result, a string.
3860 This acts like ‘format’, except it also replaces each left single
3861 quotation mark (\\=‘) and grave accent (\\=`) by a left quote, and each
3862 right single quotation mark (\\=’) and apostrophe (\\=') by a right quote.
3863 The left and right quote replacement characters are specified by
3864 ‘text-quoting-style’.
3866 usage: (format-message STRING &rest OBJECTS) */)
3867 (ptrdiff_t nargs
, Lisp_Object
*args
)
3869 return styled_format (nargs
, args
, true);
3872 /* Implement ‘format-message’ if MESSAGE is true, ‘format’ otherwise. */
3875 styled_format (ptrdiff_t nargs
, Lisp_Object
*args
, bool message
)
3877 ptrdiff_t n
; /* The number of the next arg to substitute. */
3878 char initial_buffer
[4000];
3879 char *buf
= initial_buffer
;
3880 ptrdiff_t bufsize
= sizeof initial_buffer
;
3881 ptrdiff_t max_bufsize
= STRING_BYTES_BOUND
+ 1;
3883 ptrdiff_t buf_save_value_index
IF_LINT (= 0);
3884 char *format
, *end
, *format_start
;
3885 ptrdiff_t formatlen
, nchars
;
3886 /* True if the format is multibyte. */
3887 bool multibyte_format
= 0;
3888 /* True if the output should be a multibyte string,
3889 which is true if any of the inputs is one. */
3891 /* When we make a multibyte string, we must pay attention to the
3892 byte combining problem, i.e., a byte may be combined with a
3893 multibyte character of the previous string. This flag tells if we
3894 must consider such a situation or not. */
3895 bool maybe_combine_byte
;
3897 bool arg_intervals
= 0;
3900 /* discarded[I] is 1 if byte I of the format
3901 string was not copied into the output.
3902 It is 2 if byte I was not the first byte of its character. */
3905 /* Each element records, for one argument,
3906 the start and end bytepos in the output string,
3907 whether the argument has been converted to string (e.g., due to "%S"),
3908 and whether the argument is a string with intervals.
3909 info[0] is unused. Unused elements have -1 for start. */
3912 ptrdiff_t start
, end
;
3913 bool_bf converted_to_string
: 1;
3914 bool_bf intervals
: 1;
3917 /* It should not be necessary to GCPRO ARGS, because
3918 the caller in the interpreter should take care of that. */
3920 CHECK_STRING (args
[0]);
3921 format_start
= SSDATA (args
[0]);
3922 formatlen
= SBYTES (args
[0]);
3924 /* Allocate the info and discarded tables. */
3927 if ((SIZE_MAX
- formatlen
) / sizeof (struct info
) <= nargs
)
3928 memory_full (SIZE_MAX
);
3929 info
= SAFE_ALLOCA ((nargs
+ 1) * sizeof *info
+ formatlen
);
3930 discarded
= (char *) &info
[nargs
+ 1];
3931 for (i
= 0; i
< nargs
+ 1; i
++)
3934 info
[i
].intervals
= info
[i
].converted_to_string
= 0;
3936 memset (discarded
, 0, formatlen
);
3939 /* Try to determine whether the result should be multibyte.
3940 This is not always right; sometimes the result needs to be multibyte
3941 because of an object that we will pass through prin1.
3942 or because a grave accent or apostrophe is requoted,
3943 and in that case, we won't know it here. */
3944 multibyte_format
= STRING_MULTIBYTE (args
[0]);
3945 multibyte
= multibyte_format
;
3946 for (n
= 1; !multibyte
&& n
< nargs
; n
++)
3947 if (STRINGP (args
[n
]) && STRING_MULTIBYTE (args
[n
]))
3950 int quoting_style
= message
? text_quoting_style () : -1;
3952 /* If we start out planning a unibyte result,
3953 then discover it has to be multibyte, we jump back to retry. */
3960 /* Scan the format and store result in BUF. */
3961 format
= format_start
;
3962 end
= format
+ formatlen
;
3963 maybe_combine_byte
= 0;
3965 while (format
!= end
)
3967 /* The values of N and FORMAT when the loop body is entered. */
3969 char *format0
= format
;
3970 char const *convsrc
= format
;
3971 unsigned char format_char
= *format
++;
3973 /* Bytes needed to represent the output of this conversion. */
3974 ptrdiff_t convbytes
= 1;
3976 if (format_char
== '%')
3978 /* General format specifications look like
3980 '%' [flags] [field-width] [precision] format
3985 field-width ::= [0-9]+
3986 precision ::= '.' [0-9]*
3988 If a field-width is specified, it specifies to which width
3989 the output should be padded with blanks, if the output
3990 string is shorter than field-width.
3992 If precision is specified, it specifies the number of
3993 digits to print after the '.' for floats, or the max.
3994 number of chars to print from a string. */
3996 bool minus_flag
= false;
3997 bool plus_flag
= false;
3998 bool space_flag
= false;
3999 bool sharp_flag
= false;
4000 bool zero_flag
= false;
4001 ptrdiff_t field_width
;
4002 bool precision_given
;
4003 uintmax_t precision
= UINTMAX_MAX
;
4011 case '-': minus_flag
= true; continue;
4012 case '+': plus_flag
= true; continue;
4013 case ' ': space_flag
= true; continue;
4014 case '#': sharp_flag
= true; continue;
4015 case '0': zero_flag
= true; continue;
4020 /* Ignore flags when sprintf ignores them. */
4021 space_flag
&= ~ plus_flag
;
4022 zero_flag
&= ~ minus_flag
;
4025 uintmax_t w
= strtoumax (format
, &num_end
, 10);
4026 if (max_bufsize
<= w
)
4030 precision_given
= *num_end
== '.';
4031 if (precision_given
)
4032 precision
= strtoumax (num_end
+ 1, &num_end
, 10);
4036 error ("Format string ends in middle of format specifier");
4038 memset (&discarded
[format0
- format_start
], 1, format
- format0
);
4039 conversion
= *format
++;
4040 if (conversion
== '%')
4042 discarded
[format
- format_start
] = 1;
4046 error ("Not enough arguments for format string");
4048 /* For 'S', prin1 the argument, and then treat like 's'.
4049 For 's', princ any argument that is not a string or
4050 symbol. But don't do this conversion twice, which might
4051 happen after retrying. */
4052 if ((conversion
== 'S'
4053 || (conversion
== 's'
4054 && ! STRINGP (args
[n
]) && ! SYMBOLP (args
[n
]))))
4056 if (! info
[n
].converted_to_string
)
4058 Lisp_Object noescape
= conversion
== 'S' ? Qnil
: Qt
;
4059 args
[n
] = Fprin1_to_string (args
[n
], noescape
);
4060 info
[n
].converted_to_string
= 1;
4061 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
4069 else if (conversion
== 'c')
4071 if (FLOATP (args
[n
]))
4073 double d
= XFLOAT_DATA (args
[n
]);
4074 args
[n
] = make_number (FIXNUM_OVERFLOW_P (d
) ? -1 : d
);
4077 if (INTEGERP (args
[n
]) && ! ASCII_CHAR_P (XINT (args
[n
])))
4084 args
[n
] = Fchar_to_string (args
[n
]);
4085 info
[n
].converted_to_string
= 1;
4088 if (info
[n
].converted_to_string
)
4093 if (SYMBOLP (args
[n
]))
4095 args
[n
] = SYMBOL_NAME (args
[n
]);
4096 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
4103 if (conversion
== 's')
4105 /* handle case (precision[n] >= 0) */
4107 ptrdiff_t width
, padding
, nbytes
;
4108 ptrdiff_t nchars_string
;
4110 ptrdiff_t prec
= -1;
4111 if (precision_given
&& precision
<= TYPE_MAXIMUM (ptrdiff_t))
4114 /* lisp_string_width ignores a precision of 0, but GNU
4115 libc functions print 0 characters when the precision
4116 is 0. Imitate libc behavior here. Changing
4117 lisp_string_width is the right thing, and will be
4118 done, but meanwhile we work with it. */
4121 width
= nchars_string
= nbytes
= 0;
4125 width
= lisp_string_width (args
[n
], prec
, &nch
, &nby
);
4128 nchars_string
= SCHARS (args
[n
]);
4129 nbytes
= SBYTES (args
[n
]);
4133 nchars_string
= nch
;
4139 if (convbytes
&& multibyte
&& ! STRING_MULTIBYTE (args
[n
]))
4140 convbytes
= count_size_as_multibyte (SDATA (args
[n
]), nbytes
);
4142 padding
= width
< field_width
? field_width
- width
: 0;
4144 if (max_bufsize
- padding
<= convbytes
)
4146 convbytes
+= padding
;
4147 if (convbytes
<= buf
+ bufsize
- p
)
4151 memset (p
, ' ', padding
);
4158 && !ASCII_CHAR_P (*((unsigned char *) p
- 1))
4159 && STRING_MULTIBYTE (args
[n
])
4160 && !CHAR_HEAD_P (SREF (args
[n
], 0)))
4161 maybe_combine_byte
= 1;
4163 p
+= copy_text (SDATA (args
[n
]), (unsigned char *) p
,
4165 STRING_MULTIBYTE (args
[n
]), multibyte
);
4167 info
[n
].start
= nchars
;
4168 nchars
+= nchars_string
;
4169 info
[n
].end
= nchars
;
4173 memset (p
, ' ', padding
);
4178 /* If this argument has text properties, record where
4179 in the result string it appears. */
4180 if (string_intervals (args
[n
]))
4181 info
[n
].intervals
= arg_intervals
= 1;
4186 else if (! (conversion
== 'c' || conversion
== 'd'
4187 || conversion
== 'e' || conversion
== 'f'
4188 || conversion
== 'g' || conversion
== 'i'
4189 || conversion
== 'o' || conversion
== 'x'
4190 || conversion
== 'X'))
4191 error ("Invalid format operation %%%c",
4192 STRING_CHAR ((unsigned char *) format
- 1));
4193 else if (! (INTEGERP (args
[n
]) || FLOATP (args
[n
])))
4194 error ("Format specifier doesn't match argument type");
4199 /* Maximum precision for a %f conversion such that the
4200 trailing output digit might be nonzero. Any precision
4201 larger than this will not yield useful information. */
4202 USEFUL_PRECISION_MAX
=
4204 * (FLT_RADIX
== 2 || FLT_RADIX
== 10 ? 1
4205 : FLT_RADIX
== 16 ? 4
4208 /* Maximum number of bytes generated by any format, if
4209 precision is no more than USEFUL_PRECISION_MAX.
4210 On all practical hosts, %f is the worst case. */
4212 sizeof "-." + (DBL_MAX_10_EXP
+ 1) + USEFUL_PRECISION_MAX
,
4214 /* Length of pM (that is, of pMd without the
4216 pMlen
= sizeof pMd
- 2
4218 verify (USEFUL_PRECISION_MAX
> 0);
4221 ptrdiff_t padding
, sprintf_bytes
;
4222 uintmax_t excess_precision
, numwidth
;
4223 uintmax_t leading_zeros
= 0, trailing_zeros
= 0;
4225 char sprintf_buf
[SPRINTF_BUFSIZE
];
4227 /* Copy of conversion specification, modified somewhat.
4228 At most three flags F can be specified at once. */
4229 char convspec
[sizeof "%FFF.*d" + pMlen
];
4231 /* Avoid undefined behavior in underlying sprintf. */
4232 if (conversion
== 'd' || conversion
== 'i')
4235 /* Create the copy of the conversion specification, with
4236 any width and precision removed, with ".*" inserted,
4237 and with pM inserted for integer formats. */
4241 *f
= '-'; f
+= minus_flag
;
4242 *f
= '+'; f
+= plus_flag
;
4243 *f
= ' '; f
+= space_flag
;
4244 *f
= '#'; f
+= sharp_flag
;
4245 *f
= '0'; f
+= zero_flag
;
4248 if (conversion
== 'd' || conversion
== 'i'
4249 || conversion
== 'o' || conversion
== 'x'
4250 || conversion
== 'X')
4252 memcpy (f
, pMd
, pMlen
);
4254 zero_flag
&= ~ precision_given
;
4261 if (precision_given
)
4262 prec
= min (precision
, USEFUL_PRECISION_MAX
);
4264 /* Use sprintf to format this number into sprintf_buf. Omit
4265 padding and excess precision, though, because sprintf limits
4266 output length to INT_MAX.
4268 There are four types of conversion: double, unsigned
4269 char (passed as int), wide signed int, and wide
4270 unsigned int. Treat them separately because the
4271 sprintf ABI is sensitive to which type is passed. Be
4272 careful about integer overflow, NaNs, infinities, and
4273 conversions; for example, the min and max macros are
4274 not suitable here. */
4275 if (conversion
== 'e' || conversion
== 'f' || conversion
== 'g')
4277 double x
= (INTEGERP (args
[n
])
4279 : XFLOAT_DATA (args
[n
]));
4280 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4282 else if (conversion
== 'c')
4284 /* Don't use sprintf here, as it might mishandle prec. */
4285 sprintf_buf
[0] = XINT (args
[n
]);
4286 sprintf_bytes
= prec
!= 0;
4288 else if (conversion
== 'd')
4290 /* For float, maybe we should use "%1.0f"
4291 instead so it also works for values outside
4292 the integer range. */
4294 if (INTEGERP (args
[n
]))
4298 double d
= XFLOAT_DATA (args
[n
]);
4301 x
= TYPE_MINIMUM (printmax_t
);
4307 x
= TYPE_MAXIMUM (printmax_t
);
4312 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4316 /* Don't sign-extend for octal or hex printing. */
4318 if (INTEGERP (args
[n
]))
4319 x
= XUINT (args
[n
]);
4322 double d
= XFLOAT_DATA (args
[n
]);
4327 x
= TYPE_MAXIMUM (uprintmax_t
);
4332 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4335 /* Now the length of the formatted item is known, except it omits
4336 padding and excess precision. Deal with excess precision
4337 first. This happens only when the format specifies
4338 ridiculously large precision. */
4339 excess_precision
= precision
- prec
;
4340 if (excess_precision
)
4342 if (conversion
== 'e' || conversion
== 'f'
4343 || conversion
== 'g')
4345 if ((conversion
== 'g' && ! sharp_flag
)
4346 || ! ('0' <= sprintf_buf
[sprintf_bytes
- 1]
4347 && sprintf_buf
[sprintf_bytes
- 1] <= '9'))
4348 excess_precision
= 0;
4351 if (conversion
== 'g')
4353 char *dot
= strchr (sprintf_buf
, '.');
4355 excess_precision
= 0;
4358 trailing_zeros
= excess_precision
;
4361 leading_zeros
= excess_precision
;
4364 /* Compute the total bytes needed for this item, including
4365 excess precision and padding. */
4366 numwidth
= sprintf_bytes
+ excess_precision
;
4367 padding
= numwidth
< field_width
? field_width
- numwidth
: 0;
4368 if (max_bufsize
- sprintf_bytes
<= excess_precision
4369 || max_bufsize
- padding
<= numwidth
)
4371 convbytes
= numwidth
+ padding
;
4373 if (convbytes
<= buf
+ bufsize
- p
)
4375 /* Copy the formatted item from sprintf_buf into buf,
4376 inserting padding and excess-precision zeros. */
4378 char *src
= sprintf_buf
;
4380 int exponent_bytes
= 0;
4381 bool signedp
= src0
== '-' || src0
== '+' || src0
== ' ';
4382 int significand_bytes
;
4384 && ((src
[signedp
] >= '0' && src
[signedp
] <= '9')
4385 || (src
[signedp
] >= 'a' && src
[signedp
] <= 'f')
4386 || (src
[signedp
] >= 'A' && src
[signedp
] <= 'F')))
4388 leading_zeros
+= padding
;
4392 if (excess_precision
4393 && (conversion
== 'e' || conversion
== 'g'))
4395 char *e
= strchr (src
, 'e');
4397 exponent_bytes
= src
+ sprintf_bytes
- e
;
4402 memset (p
, ' ', padding
);
4410 memset (p
, '0', leading_zeros
);
4412 significand_bytes
= sprintf_bytes
- signedp
- exponent_bytes
;
4413 memcpy (p
, src
, significand_bytes
);
4414 p
+= significand_bytes
;
4415 src
+= significand_bytes
;
4416 memset (p
, '0', trailing_zeros
);
4417 p
+= trailing_zeros
;
4418 memcpy (p
, src
, exponent_bytes
);
4419 p
+= exponent_bytes
;
4421 info
[n
].start
= nchars
;
4422 nchars
+= leading_zeros
+ sprintf_bytes
+ trailing_zeros
;
4423 info
[n
].end
= nchars
;
4427 memset (p
, ' ', padding
);
4438 /* Named constants for the UTF-8 encodings of U+2018 LEFT SINGLE
4439 QUOTATION MARK and U+2019 RIGHT SINGLE QUOTATION MARK. */
4442 uLSQM0
= 0xE2, uLSQM1
= 0x80, uLSQM2
= 0x98,
4443 /* uRSQM0 = 0xE2, uRSQM1 = 0x80, */ uRSQM2
= 0x99
4446 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
4448 if ((format_char
== '`' || format_char
== '\'')
4449 && quoting_style
== CURVE_QUOTING_STYLE
)
4456 convsrc
= format_char
== '`' ? uLSQM
: uRSQM
;
4459 else if (format_char
== '`' && quoting_style
== STRAIGHT_QUOTING_STYLE
)
4461 else if (format_char
== uLSQM0
&& CURVE_QUOTING_STYLE
< quoting_style
4463 && (unsigned char) format
[0] == uLSQM1
4464 && ((unsigned char) format
[1] == uLSQM2
4465 || (unsigned char) format
[1] == uRSQM2
))
4467 convsrc
= (((unsigned char) format
[1] == uLSQM2
4468 && quoting_style
== GRAVE_QUOTING_STYLE
)
4471 memset (&discarded
[format0
+ 1 - format_start
], 2, 2);
4475 /* Copy a single character from format to buf. */
4476 if (multibyte_format
)
4478 /* Copy a whole multibyte character. */
4480 && !ASCII_CHAR_P (*((unsigned char *) p
- 1))
4481 && !CHAR_HEAD_P (format_char
))
4482 maybe_combine_byte
= 1;
4484 while (! CHAR_HEAD_P (*format
))
4487 convbytes
= format
- format0
;
4488 memset (&discarded
[format0
+ 1 - format_start
], 2,
4491 else if (multibyte
&& !ASCII_CHAR_P (format_char
))
4493 int c
= BYTE8_TO_CHAR (format_char
);
4494 convbytes
= CHAR_STRING (c
, str
);
4495 convsrc
= (char *) str
;
4500 if (convbytes
<= buf
+ bufsize
- p
)
4502 memcpy (p
, convsrc
, convbytes
);
4509 /* There wasn't enough room to store this conversion or single
4510 character. CONVBYTES says how much room is needed. Allocate
4511 enough room (and then some) and do it again. */
4513 ptrdiff_t used
= p
- buf
;
4515 if (max_bufsize
- used
< convbytes
)
4517 bufsize
= used
+ convbytes
;
4518 bufsize
= bufsize
< max_bufsize
/ 2 ? bufsize
* 2 : max_bufsize
;
4520 if (buf
== initial_buffer
)
4522 buf
= xmalloc (bufsize
);
4523 sa_must_free
= true;
4524 buf_save_value_index
= SPECPDL_INDEX ();
4525 record_unwind_protect_ptr (xfree
, buf
);
4526 memcpy (buf
, initial_buffer
, used
);
4530 buf
= xrealloc (buf
, bufsize
);
4531 set_unwind_protect_ptr (buf_save_value_index
, xfree
, buf
);
4541 if (bufsize
< p
- buf
)
4544 if (maybe_combine_byte
)
4545 nchars
= multibyte_chars_in_text ((unsigned char *) buf
, p
- buf
);
4546 val
= make_specified_string (buf
, nchars
, p
- buf
, multibyte
);
4548 /* If the format string has text properties, or any of the string
4549 arguments has text properties, set up text properties of the
4552 if (string_intervals (args
[0]) || arg_intervals
)
4554 Lisp_Object len
, new_len
, props
;
4555 struct gcpro gcpro1
;
4557 /* Add text properties from the format string. */
4558 len
= make_number (SCHARS (args
[0]));
4559 props
= text_property_list (args
[0], make_number (0), len
, Qnil
);
4564 ptrdiff_t bytepos
= 0, position
= 0, translated
= 0;
4568 /* Adjust the bounds of each text property
4569 to the proper start and end in the output string. */
4571 /* Put the positions in PROPS in increasing order, so that
4572 we can do (effectively) one scan through the position
4573 space of the format string. */
4574 props
= Fnreverse (props
);
4576 /* BYTEPOS is the byte position in the format string,
4577 POSITION is the untranslated char position in it,
4578 TRANSLATED is the translated char position in BUF,
4579 and ARGN is the number of the next arg we will come to. */
4580 for (list
= props
; CONSP (list
); list
= XCDR (list
))
4587 /* First adjust the property start position. */
4588 pos
= XINT (XCAR (item
));
4590 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
4591 up to this position. */
4592 for (; position
< pos
; bytepos
++)
4594 if (! discarded
[bytepos
])
4595 position
++, translated
++;
4596 else if (discarded
[bytepos
] == 1)
4599 if (translated
== info
[argn
].start
)
4601 translated
+= info
[argn
].end
- info
[argn
].start
;
4607 XSETCAR (item
, make_number (translated
));
4609 /* Likewise adjust the property end position. */
4610 pos
= XINT (XCAR (XCDR (item
)));
4612 for (; position
< pos
; bytepos
++)
4614 if (! discarded
[bytepos
])
4615 position
++, translated
++;
4616 else if (discarded
[bytepos
] == 1)
4619 if (translated
== info
[argn
].start
)
4621 translated
+= info
[argn
].end
- info
[argn
].start
;
4627 XSETCAR (XCDR (item
), make_number (translated
));
4630 add_text_properties_from_list (val
, props
, make_number (0));
4633 /* Add text properties from arguments. */
4635 for (n
= 1; n
< nargs
; ++n
)
4636 if (info
[n
].intervals
)
4638 len
= make_number (SCHARS (args
[n
]));
4639 new_len
= make_number (info
[n
].end
- info
[n
].start
);
4640 props
= text_property_list (args
[n
], make_number (0), len
, Qnil
);
4641 props
= extend_property_ranges (props
, new_len
);
4642 /* If successive arguments have properties, be sure that
4643 the value of `composition' property be the copy. */
4644 if (n
> 1 && info
[n
- 1].end
)
4645 make_composition_value_copy (props
);
4646 add_text_properties_from_list (val
, props
,
4647 make_number (info
[n
].start
));
4653 /* If we allocated BUF or INFO with malloc, free it too. */
4659 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
4660 doc
: /* Return t if two characters match, optionally ignoring case.
4661 Both arguments must be characters (i.e. integers).
4662 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
4663 (register Lisp_Object c1
, Lisp_Object c2
)
4666 /* Check they're chars, not just integers, otherwise we could get array
4667 bounds violations in downcase. */
4668 CHECK_CHARACTER (c1
);
4669 CHECK_CHARACTER (c2
);
4671 if (XINT (c1
) == XINT (c2
))
4673 if (NILP (BVAR (current_buffer
, case_fold_search
)))
4679 /* FIXME: It is possible to compare multibyte characters even when
4680 the current buffer is unibyte. Unfortunately this is ambiguous
4681 for characters between 128 and 255, as they could be either
4682 eight-bit raw bytes or Latin-1 characters. Assume the former for
4683 now. See Bug#17011, and also see casefiddle.c's casify_object,
4684 which has a similar problem. */
4685 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4687 if (SINGLE_BYTE_CHAR_P (i1
))
4688 i1
= UNIBYTE_TO_CHAR (i1
);
4689 if (SINGLE_BYTE_CHAR_P (i2
))
4690 i2
= UNIBYTE_TO_CHAR (i2
);
4693 return (downcase (i1
) == downcase (i2
) ? Qt
: Qnil
);
4696 /* Transpose the markers in two regions of the current buffer, and
4697 adjust the ones between them if necessary (i.e.: if the regions
4700 START1, END1 are the character positions of the first region.
4701 START1_BYTE, END1_BYTE are the byte positions.
4702 START2, END2 are the character positions of the second region.
4703 START2_BYTE, END2_BYTE are the byte positions.
4705 Traverses the entire marker list of the buffer to do so, adding an
4706 appropriate amount to some, subtracting from some, and leaving the
4707 rest untouched. Most of this is copied from adjust_markers in insdel.c.
4709 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
4712 transpose_markers (ptrdiff_t start1
, ptrdiff_t end1
,
4713 ptrdiff_t start2
, ptrdiff_t end2
,
4714 ptrdiff_t start1_byte
, ptrdiff_t end1_byte
,
4715 ptrdiff_t start2_byte
, ptrdiff_t end2_byte
)
4717 register ptrdiff_t amt1
, amt1_byte
, amt2
, amt2_byte
, diff
, diff_byte
, mpos
;
4718 register struct Lisp_Marker
*marker
;
4720 /* Update point as if it were a marker. */
4724 TEMP_SET_PT_BOTH (PT
+ (end2
- end1
),
4725 PT_BYTE
+ (end2_byte
- end1_byte
));
4726 else if (PT
< start2
)
4727 TEMP_SET_PT_BOTH (PT
+ (end2
- start2
) - (end1
- start1
),
4728 (PT_BYTE
+ (end2_byte
- start2_byte
)
4729 - (end1_byte
- start1_byte
)));
4731 TEMP_SET_PT_BOTH (PT
- (start2
- start1
),
4732 PT_BYTE
- (start2_byte
- start1_byte
));
4734 /* We used to adjust the endpoints here to account for the gap, but that
4735 isn't good enough. Even if we assume the caller has tried to move the
4736 gap out of our way, it might still be at start1 exactly, for example;
4737 and that places it `inside' the interval, for our purposes. The amount
4738 of adjustment is nontrivial if there's a `denormalized' marker whose
4739 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
4740 the dirty work to Fmarker_position, below. */
4742 /* The difference between the region's lengths */
4743 diff
= (end2
- start2
) - (end1
- start1
);
4744 diff_byte
= (end2_byte
- start2_byte
) - (end1_byte
- start1_byte
);
4746 /* For shifting each marker in a region by the length of the other
4747 region plus the distance between the regions. */
4748 amt1
= (end2
- start2
) + (start2
- end1
);
4749 amt2
= (end1
- start1
) + (start2
- end1
);
4750 amt1_byte
= (end2_byte
- start2_byte
) + (start2_byte
- end1_byte
);
4751 amt2_byte
= (end1_byte
- start1_byte
) + (start2_byte
- end1_byte
);
4753 for (marker
= BUF_MARKERS (current_buffer
); marker
; marker
= marker
->next
)
4755 mpos
= marker
->bytepos
;
4756 if (mpos
>= start1_byte
&& mpos
< end2_byte
)
4758 if (mpos
< end1_byte
)
4760 else if (mpos
< start2_byte
)
4764 marker
->bytepos
= mpos
;
4766 mpos
= marker
->charpos
;
4767 if (mpos
>= start1
&& mpos
< end2
)
4771 else if (mpos
< start2
)
4776 marker
->charpos
= mpos
;
4780 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
4781 doc
: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
4782 The regions should not be overlapping, because the size of the buffer is
4783 never changed in a transposition.
4785 Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
4786 any markers that happen to be located in the regions.
4788 Transposing beyond buffer boundaries is an error. */)
4789 (Lisp_Object startr1
, Lisp_Object endr1
, Lisp_Object startr2
, Lisp_Object endr2
, Lisp_Object leave_markers
)
4791 register ptrdiff_t start1
, end1
, start2
, end2
;
4792 ptrdiff_t start1_byte
, start2_byte
, len1_byte
, len2_byte
, end2_byte
;
4793 ptrdiff_t gap
, len1
, len_mid
, len2
;
4794 unsigned char *start1_addr
, *start2_addr
, *temp
;
4796 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
, tmp_interval3
;
4799 XSETBUFFER (buf
, current_buffer
);
4800 cur_intv
= buffer_intervals (current_buffer
);
4802 validate_region (&startr1
, &endr1
);
4803 validate_region (&startr2
, &endr2
);
4805 start1
= XFASTINT (startr1
);
4806 end1
= XFASTINT (endr1
);
4807 start2
= XFASTINT (startr2
);
4808 end2
= XFASTINT (endr2
);
4811 /* Swap the regions if they're reversed. */
4814 register ptrdiff_t glumph
= start1
;
4822 len1
= end1
- start1
;
4823 len2
= end2
- start2
;
4826 error ("Transposed regions overlap");
4827 /* Nothing to change for adjacent regions with one being empty */
4828 else if ((start1
== end1
|| start2
== end2
) && end1
== start2
)
4831 /* The possibilities are:
4832 1. Adjacent (contiguous) regions, or separate but equal regions
4833 (no, really equal, in this case!), or
4834 2. Separate regions of unequal size.
4836 The worst case is usually No. 2. It means that (aside from
4837 potential need for getting the gap out of the way), there also
4838 needs to be a shifting of the text between the two regions. So
4839 if they are spread far apart, we are that much slower... sigh. */
4841 /* It must be pointed out that the really studly thing to do would
4842 be not to move the gap at all, but to leave it in place and work
4843 around it if necessary. This would be extremely efficient,
4844 especially considering that people are likely to do
4845 transpositions near where they are working interactively, which
4846 is exactly where the gap would be found. However, such code
4847 would be much harder to write and to read. So, if you are
4848 reading this comment and are feeling squirrely, by all means have
4849 a go! I just didn't feel like doing it, so I will simply move
4850 the gap the minimum distance to get it out of the way, and then
4851 deal with an unbroken array. */
4853 start1_byte
= CHAR_TO_BYTE (start1
);
4854 end2_byte
= CHAR_TO_BYTE (end2
);
4856 /* Make sure the gap won't interfere, by moving it out of the text
4857 we will operate on. */
4858 if (start1
< gap
&& gap
< end2
)
4860 if (gap
- start1
< end2
- gap
)
4861 move_gap_both (start1
, start1_byte
);
4863 move_gap_both (end2
, end2_byte
);
4866 start2_byte
= CHAR_TO_BYTE (start2
);
4867 len1_byte
= CHAR_TO_BYTE (end1
) - start1_byte
;
4868 len2_byte
= end2_byte
- start2_byte
;
4870 #ifdef BYTE_COMBINING_DEBUG
4873 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4874 len2_byte
, start1
, start1_byte
)
4875 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4876 len1_byte
, end2
, start2_byte
+ len2_byte
)
4877 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4878 len1_byte
, end2
, start2_byte
+ len2_byte
))
4883 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4884 len2_byte
, start1
, start1_byte
)
4885 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4886 len1_byte
, start2
, start2_byte
)
4887 || count_combining_after (BYTE_POS_ADDR (start2_byte
),
4888 len2_byte
, end1
, start1_byte
+ len1_byte
)
4889 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4890 len1_byte
, end2
, start2_byte
+ len2_byte
))
4895 /* Hmmm... how about checking to see if the gap is large
4896 enough to use as the temporary storage? That would avoid an
4897 allocation... interesting. Later, don't fool with it now. */
4899 /* Working without memmove, for portability (sigh), so must be
4900 careful of overlapping subsections of the array... */
4902 if (end1
== start2
) /* adjacent regions */
4904 modify_text (start1
, end2
);
4905 record_change (start1
, len1
+ len2
);
4907 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4908 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4909 /* Don't use Fset_text_properties: that can cause GC, which can
4910 clobber objects stored in the tmp_intervals. */
4911 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4913 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4917 /* First region smaller than second. */
4918 if (len1_byte
< len2_byte
)
4920 temp
= SAFE_ALLOCA (len2_byte
);
4922 /* Don't precompute these addresses. We have to compute them
4923 at the last minute, because the relocating allocator might
4924 have moved the buffer around during the xmalloc. */
4925 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4926 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4928 memcpy (temp
, start2_addr
, len2_byte
);
4929 memcpy (start1_addr
+ len2_byte
, start1_addr
, len1_byte
);
4930 memcpy (start1_addr
, temp
, len2_byte
);
4933 /* First region not smaller than second. */
4935 temp
= SAFE_ALLOCA (len1_byte
);
4936 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4937 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4938 memcpy (temp
, start1_addr
, len1_byte
);
4939 memcpy (start1_addr
, start2_addr
, len2_byte
);
4940 memcpy (start1_addr
+ len2_byte
, temp
, len1_byte
);
4944 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
4945 len1
, current_buffer
, 0);
4946 graft_intervals_into_buffer (tmp_interval2
, start1
,
4947 len2
, current_buffer
, 0);
4948 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4949 update_compositions (start1
+ len2
, end2
, CHECK_TAIL
);
4951 /* Non-adjacent regions, because end1 != start2, bleagh... */
4954 len_mid
= start2_byte
- (start1_byte
+ len1_byte
);
4956 if (len1_byte
== len2_byte
)
4957 /* Regions are same size, though, how nice. */
4961 modify_text (start1
, end1
);
4962 modify_text (start2
, end2
);
4963 record_change (start1
, len1
);
4964 record_change (start2
, len2
);
4965 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4966 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4968 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr1
, 0);
4970 set_text_properties_1 (startr1
, endr1
, Qnil
, buf
, tmp_interval3
);
4972 tmp_interval3
= validate_interval_range (buf
, &startr2
, &endr2
, 0);
4974 set_text_properties_1 (startr2
, endr2
, Qnil
, buf
, tmp_interval3
);
4976 temp
= SAFE_ALLOCA (len1_byte
);
4977 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4978 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4979 memcpy (temp
, start1_addr
, len1_byte
);
4980 memcpy (start1_addr
, start2_addr
, len2_byte
);
4981 memcpy (start2_addr
, temp
, len1_byte
);
4984 graft_intervals_into_buffer (tmp_interval1
, start2
,
4985 len1
, current_buffer
, 0);
4986 graft_intervals_into_buffer (tmp_interval2
, start1
,
4987 len2
, current_buffer
, 0);
4990 else if (len1_byte
< len2_byte
) /* Second region larger than first */
4991 /* Non-adjacent & unequal size, area between must also be shifted. */
4995 modify_text (start1
, end2
);
4996 record_change (start1
, (end2
- start1
));
4997 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4998 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4999 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
5001 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
5003 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
5005 /* holds region 2 */
5006 temp
= SAFE_ALLOCA (len2_byte
);
5007 start1_addr
= BYTE_POS_ADDR (start1_byte
);
5008 start2_addr
= BYTE_POS_ADDR (start2_byte
);
5009 memcpy (temp
, start2_addr
, len2_byte
);
5010 memcpy (start1_addr
+ len_mid
+ len2_byte
, start1_addr
, len1_byte
);
5011 memmove (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
5012 memcpy (start1_addr
, temp
, len2_byte
);
5015 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
5016 len1
, current_buffer
, 0);
5017 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
5018 len_mid
, current_buffer
, 0);
5019 graft_intervals_into_buffer (tmp_interval2
, start1
,
5020 len2
, current_buffer
, 0);
5023 /* Second region smaller than first. */
5027 record_change (start1
, (end2
- start1
));
5028 modify_text (start1
, end2
);
5030 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
5031 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
5032 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
5034 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
5036 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
5038 /* holds region 1 */
5039 temp
= SAFE_ALLOCA (len1_byte
);
5040 start1_addr
= BYTE_POS_ADDR (start1_byte
);
5041 start2_addr
= BYTE_POS_ADDR (start2_byte
);
5042 memcpy (temp
, start1_addr
, len1_byte
);
5043 memcpy (start1_addr
, start2_addr
, len2_byte
);
5044 memcpy (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
5045 memcpy (start1_addr
+ len2_byte
+ len_mid
, temp
, len1_byte
);
5048 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
5049 len1
, current_buffer
, 0);
5050 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
5051 len_mid
, current_buffer
, 0);
5052 graft_intervals_into_buffer (tmp_interval2
, start1
,
5053 len2
, current_buffer
, 0);
5056 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
5057 update_compositions (end2
- len1
, end2
, CHECK_BORDER
);
5060 /* When doing multiple transpositions, it might be nice
5061 to optimize this. Perhaps the markers in any one buffer
5062 should be organized in some sorted data tree. */
5063 if (NILP (leave_markers
))
5065 transpose_markers (start1
, end1
, start2
, end2
,
5066 start1_byte
, start1_byte
+ len1_byte
,
5067 start2_byte
, start2_byte
+ len2_byte
);
5068 fix_start_end_in_overlays (start1
, end2
);
5071 signal_after_change (start1
, end2
- start1
, end2
- start1
);
5077 syms_of_editfns (void)
5079 DEFSYM (Qbuffer_access_fontify_functions
, "buffer-access-fontify-functions");
5080 DEFSYM (Qwall
, "wall");
5082 DEFVAR_LISP ("inhibit-field-text-motion", Vinhibit_field_text_motion
,
5083 doc
: /* Non-nil means text motion commands don't notice fields. */);
5084 Vinhibit_field_text_motion
= Qnil
;
5086 DEFVAR_LISP ("buffer-access-fontify-functions",
5087 Vbuffer_access_fontify_functions
,
5088 doc
: /* List of functions called by `buffer-substring' to fontify if necessary.
5089 Each function is called with two arguments which specify the range
5090 of the buffer being accessed. */);
5091 Vbuffer_access_fontify_functions
= Qnil
;
5095 obuf
= Fcurrent_buffer ();
5096 /* Do this here, because init_buffer_once is too early--it won't work. */
5097 Fset_buffer (Vprin1_to_string_buffer
);
5098 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
5099 Fset (Fmake_local_variable (Qbuffer_access_fontify_functions
), Qnil
);
5103 DEFVAR_LISP ("buffer-access-fontified-property",
5104 Vbuffer_access_fontified_property
,
5105 doc
: /* Property which (if non-nil) indicates text has been fontified.
5106 `buffer-substring' need not call the `buffer-access-fontify-functions'
5107 functions if all the text being accessed has this property. */);
5108 Vbuffer_access_fontified_property
= Qnil
;
5110 DEFVAR_LISP ("system-name", Vsystem_name
,
5111 doc
: /* The host name of the machine Emacs is running on. */);
5112 Vsystem_name
= cached_system_name
= Qnil
;
5114 DEFVAR_LISP ("user-full-name", Vuser_full_name
,
5115 doc
: /* The full name of the user logged in. */);
5117 DEFVAR_LISP ("user-login-name", Vuser_login_name
,
5118 doc
: /* The user's name, taken from environment variables if possible. */);
5119 Vuser_login_name
= Qnil
;
5121 DEFVAR_LISP ("user-real-login-name", Vuser_real_login_name
,
5122 doc
: /* The user's name, based upon the real uid only. */);
5124 DEFVAR_LISP ("operating-system-release", Voperating_system_release
,
5125 doc
: /* The release of the operating system Emacs is running on. */);
5127 defsubr (&Spropertize
);
5128 defsubr (&Schar_equal
);
5129 defsubr (&Sgoto_char
);
5130 defsubr (&Sstring_to_char
);
5131 defsubr (&Schar_to_string
);
5132 defsubr (&Sbyte_to_string
);
5133 defsubr (&Sbuffer_substring
);
5134 defsubr (&Sbuffer_substring_no_properties
);
5135 defsubr (&Sbuffer_string
);
5136 defsubr (&Sget_pos_property
);
5138 defsubr (&Spoint_marker
);
5139 defsubr (&Smark_marker
);
5141 defsubr (&Sregion_beginning
);
5142 defsubr (&Sregion_end
);
5144 /* Symbol for the text property used to mark fields. */
5145 DEFSYM (Qfield
, "field");
5147 /* A special value for Qfield properties. */
5148 DEFSYM (Qboundary
, "boundary");
5150 defsubr (&Sfield_beginning
);
5151 defsubr (&Sfield_end
);
5152 defsubr (&Sfield_string
);
5153 defsubr (&Sfield_string_no_properties
);
5154 defsubr (&Sdelete_field
);
5155 defsubr (&Sconstrain_to_field
);
5157 defsubr (&Sline_beginning_position
);
5158 defsubr (&Sline_end_position
);
5160 defsubr (&Ssave_excursion
);
5161 defsubr (&Ssave_current_buffer
);
5163 defsubr (&Sbuffer_size
);
5164 defsubr (&Spoint_max
);
5165 defsubr (&Spoint_min
);
5166 defsubr (&Spoint_min_marker
);
5167 defsubr (&Spoint_max_marker
);
5168 defsubr (&Sgap_position
);
5169 defsubr (&Sgap_size
);
5170 defsubr (&Sposition_bytes
);
5171 defsubr (&Sbyte_to_position
);
5177 defsubr (&Sfollowing_char
);
5178 defsubr (&Sprevious_char
);
5179 defsubr (&Schar_after
);
5180 defsubr (&Schar_before
);
5182 defsubr (&Sinsert_before_markers
);
5183 defsubr (&Sinsert_and_inherit
);
5184 defsubr (&Sinsert_and_inherit_before_markers
);
5185 defsubr (&Sinsert_char
);
5186 defsubr (&Sinsert_byte
);
5188 defsubr (&Suser_login_name
);
5189 defsubr (&Suser_real_login_name
);
5190 defsubr (&Suser_uid
);
5191 defsubr (&Suser_real_uid
);
5192 defsubr (&Sgroup_gid
);
5193 defsubr (&Sgroup_real_gid
);
5194 defsubr (&Suser_full_name
);
5195 defsubr (&Semacs_pid
);
5196 defsubr (&Scurrent_time
);
5197 defsubr (&Stime_add
);
5198 defsubr (&Stime_subtract
);
5199 defsubr (&Stime_less_p
);
5200 defsubr (&Sget_internal_run_time
);
5201 defsubr (&Sformat_time_string
);
5202 defsubr (&Sfloat_time
);
5203 defsubr (&Sdecode_time
);
5204 defsubr (&Sencode_time
);
5205 defsubr (&Scurrent_time_string
);
5206 defsubr (&Scurrent_time_zone
);
5207 defsubr (&Sset_time_zone_rule
);
5208 defsubr (&Ssystem_name
);
5209 defsubr (&Smessage
);
5210 defsubr (&Smessage_box
);
5211 defsubr (&Smessage_or_box
);
5212 defsubr (&Scurrent_message
);
5214 defsubr (&Sformat_message
);
5216 defsubr (&Sinsert_buffer_substring
);
5217 defsubr (&Scompare_buffer_substrings
);
5218 defsubr (&Ssubst_char_in_region
);
5219 defsubr (&Stranslate_region_internal
);
5220 defsubr (&Sdelete_region
);
5221 defsubr (&Sdelete_and_extract_region
);
5223 defsubr (&Snarrow_to_region
);
5224 defsubr (&Ssave_restriction
);
5225 defsubr (&Stranspose_regions
);