1 /* Lisp functions pertaining to editing. -*- coding: utf-8 -*-
3 Copyright (C) 1985-1987, 1989, 1993-2016 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 (at
10 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 "composite.h"
56 #include "intervals.h"
57 #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
;
962 tem
= Fmarker_buffer (XSAVE_OBJECT (info
, 0));
963 /* If we're unwinding to top level, saved buffer may be deleted. This
964 means that all of its markers are unchained and so tem is nil. */
971 tem
= XSAVE_OBJECT (info
, 0);
973 unchain_marker (XMARKER (tem
));
975 /* If buffer was visible in a window, and a different window was
976 selected, and the old selected window is still showing this
977 buffer, restore point in that window. */
978 tem
= XSAVE_OBJECT (info
, 2);
980 && !EQ (tem
, selected_window
)
981 && (tem1
= XWINDOW (tem
)->contents
,
982 (/* Window is live... */
984 /* ...and it shows the current buffer. */
985 && XBUFFER (tem1
) == current_buffer
)))
986 Fset_window_point (tem
, make_number (PT
));
993 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
994 doc
: /* Save point, and current buffer; execute BODY; restore those things.
995 Executes BODY just like `progn'.
996 The values of point and the current buffer are restored
997 even in case of abnormal exit (throw or error).
999 If you only want to save the current buffer but not point,
1000 then just use `save-current-buffer', or even `with-current-buffer'.
1002 Before Emacs 25.1, `save-excursion' used to save the mark state.
1003 To save the marker state as well as the point and buffer, use
1004 `save-mark-and-excursion'.
1006 usage: (save-excursion &rest BODY) */)
1009 register Lisp_Object val
;
1010 ptrdiff_t count
= SPECPDL_INDEX ();
1012 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
1014 val
= Fprogn (args
);
1015 return unbind_to (count
, val
);
1018 DEFUN ("save-current-buffer", Fsave_current_buffer
, Ssave_current_buffer
, 0, UNEVALLED
, 0,
1019 doc
: /* Record which buffer is current; execute BODY; make that buffer current.
1020 BODY is executed just like `progn'.
1021 usage: (save-current-buffer &rest BODY) */)
1024 ptrdiff_t count
= SPECPDL_INDEX ();
1026 record_unwind_current_buffer ();
1027 return unbind_to (count
, Fprogn (args
));
1030 DEFUN ("buffer-size", Fbuffer_size
, Sbuffer_size
, 0, 1, 0,
1031 doc
: /* Return the number of characters in the current buffer.
1032 If BUFFER is not nil, return the number of characters in that buffer
1035 This does not take narrowing into account; to count the number of
1036 characters in the accessible portion of the current buffer, use
1037 `(- (point-max) (point-min))', and to count the number of characters
1038 in some other BUFFER, use
1039 `(with-current-buffer BUFFER (- (point-max) (point-min)))'. */)
1040 (Lisp_Object buffer
)
1043 return make_number (Z
- BEG
);
1046 CHECK_BUFFER (buffer
);
1047 return make_number (BUF_Z (XBUFFER (buffer
))
1048 - BUF_BEG (XBUFFER (buffer
)));
1052 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
1053 doc
: /* Return the minimum permissible value of point in the current buffer.
1054 This is 1, unless narrowing (a buffer restriction) is in effect. */)
1058 XSETFASTINT (temp
, BEGV
);
1062 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
1063 doc
: /* Return a marker to the minimum permissible value of point in this buffer.
1064 This is the beginning, unless narrowing (a buffer restriction) is in effect. */)
1067 return build_marker (current_buffer
, BEGV
, BEGV_BYTE
);
1070 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
1071 doc
: /* Return the maximum permissible value of point in the current buffer.
1072 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1073 is in effect, in which case it is less. */)
1077 XSETFASTINT (temp
, ZV
);
1081 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
1082 doc
: /* Return a marker to the maximum permissible value of point in this buffer.
1083 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1084 is in effect, in which case it is less. */)
1087 return build_marker (current_buffer
, ZV
, ZV_BYTE
);
1090 DEFUN ("gap-position", Fgap_position
, Sgap_position
, 0, 0, 0,
1091 doc
: /* Return the position of the gap, in the current buffer.
1092 See also `gap-size'. */)
1096 XSETFASTINT (temp
, GPT
);
1100 DEFUN ("gap-size", Fgap_size
, Sgap_size
, 0, 0, 0,
1101 doc
: /* Return the size of the current buffer's gap.
1102 See also `gap-position'. */)
1106 XSETFASTINT (temp
, GAP_SIZE
);
1110 DEFUN ("position-bytes", Fposition_bytes
, Sposition_bytes
, 1, 1, 0,
1111 doc
: /* Return the byte position for character position POSITION.
1112 If POSITION is out of range, the value is nil. */)
1113 (Lisp_Object position
)
1115 CHECK_NUMBER_COERCE_MARKER (position
);
1116 if (XINT (position
) < BEG
|| XINT (position
) > Z
)
1118 return make_number (CHAR_TO_BYTE (XINT (position
)));
1121 DEFUN ("byte-to-position", Fbyte_to_position
, Sbyte_to_position
, 1, 1, 0,
1122 doc
: /* Return the character position for byte position BYTEPOS.
1123 If BYTEPOS is out of range, the value is nil. */)
1124 (Lisp_Object bytepos
)
1128 CHECK_NUMBER (bytepos
);
1129 pos_byte
= XINT (bytepos
);
1130 if (pos_byte
< BEG_BYTE
|| pos_byte
> Z_BYTE
)
1133 /* There are multibyte characters in the buffer.
1134 The argument of BYTE_TO_CHAR must be a byte position at
1135 a character boundary, so search for the start of the current
1137 while (!CHAR_HEAD_P (FETCH_BYTE (pos_byte
)))
1139 return make_number (BYTE_TO_CHAR (pos_byte
));
1142 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
1143 doc
: /* Return the character following point, as a number.
1144 At the end of the buffer or accessible region, return 0. */)
1149 XSETFASTINT (temp
, 0);
1151 XSETFASTINT (temp
, FETCH_CHAR (PT_BYTE
));
1155 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
1156 doc
: /* Return the character preceding point, as a number.
1157 At the beginning of the buffer or accessible region, return 0. */)
1162 XSETFASTINT (temp
, 0);
1163 else if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1165 ptrdiff_t pos
= PT_BYTE
;
1167 XSETFASTINT (temp
, FETCH_CHAR (pos
));
1170 XSETFASTINT (temp
, FETCH_BYTE (PT_BYTE
- 1));
1174 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
1175 doc
: /* Return t if point is at the beginning of the buffer.
1176 If the buffer is narrowed, this means the beginning of the narrowed part. */)
1184 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
1185 doc
: /* Return t if point is at the end of the buffer.
1186 If the buffer is narrowed, this means the end of the narrowed part. */)
1194 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
1195 doc
: /* Return t if point is at the beginning of a line. */)
1198 if (PT
== BEGV
|| FETCH_BYTE (PT_BYTE
- 1) == '\n')
1203 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
1204 doc
: /* Return t if point is at the end of a line.
1205 `End of a line' includes point being at the end of the buffer. */)
1208 if (PT
== ZV
|| FETCH_BYTE (PT_BYTE
) == '\n')
1213 DEFUN ("char-after", Fchar_after
, Schar_after
, 0, 1, 0,
1214 doc
: /* Return character in current buffer at position POS.
1215 POS is an integer or a marker and defaults to point.
1216 If POS is out of range, the value is nil. */)
1219 register ptrdiff_t pos_byte
;
1224 XSETFASTINT (pos
, PT
);
1229 pos_byte
= marker_byte_position (pos
);
1230 if (pos_byte
< BEGV_BYTE
|| pos_byte
>= ZV_BYTE
)
1235 CHECK_NUMBER_COERCE_MARKER (pos
);
1236 if (XINT (pos
) < BEGV
|| XINT (pos
) >= ZV
)
1239 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1242 return make_number (FETCH_CHAR (pos_byte
));
1245 DEFUN ("char-before", Fchar_before
, Schar_before
, 0, 1, 0,
1246 doc
: /* Return character in current buffer preceding position POS.
1247 POS is an integer or a marker and defaults to point.
1248 If POS is out of range, the value is nil. */)
1251 register Lisp_Object val
;
1252 register ptrdiff_t pos_byte
;
1257 XSETFASTINT (pos
, PT
);
1262 pos_byte
= marker_byte_position (pos
);
1264 if (pos_byte
<= BEGV_BYTE
|| pos_byte
> ZV_BYTE
)
1269 CHECK_NUMBER_COERCE_MARKER (pos
);
1271 if (XINT (pos
) <= BEGV
|| XINT (pos
) > ZV
)
1274 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1277 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1280 XSETFASTINT (val
, FETCH_CHAR (pos_byte
));
1285 XSETFASTINT (val
, FETCH_BYTE (pos_byte
));
1290 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 1, 0,
1291 doc
: /* Return the name under which the user logged in, as a string.
1292 This is based on the effective uid, not the real uid.
1293 Also, if the environment variables LOGNAME or USER are set,
1294 that determines the value of this function.
1296 If optional argument UID is an integer or a float, return the login name
1297 of the user with that uid, or nil if there is no such user. */)
1303 /* Set up the user name info if we didn't do it before.
1304 (That can happen if Emacs is dumpable
1305 but you decide to run `temacs -l loadup' and not dump. */
1306 if (NILP (Vuser_login_name
))
1307 init_editfns (false);
1310 return Vuser_login_name
;
1312 CONS_TO_INTEGER (uid
, uid_t
, id
);
1316 return (pw
? build_string (pw
->pw_name
) : Qnil
);
1319 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
1321 doc
: /* Return the name of the user's real uid, as a string.
1322 This ignores the environment variables LOGNAME and USER, so it differs from
1323 `user-login-name' when running under `su'. */)
1326 /* Set up the user name info if we didn't do it before.
1327 (That can happen if Emacs is dumpable
1328 but you decide to run `temacs -l loadup' and not dump. */
1329 if (NILP (Vuser_login_name
))
1330 init_editfns (false);
1331 return Vuser_real_login_name
;
1334 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
1335 doc
: /* Return the effective uid of Emacs.
1336 Value is an integer or a float, depending on the value. */)
1339 uid_t euid
= geteuid ();
1340 return make_fixnum_or_float (euid
);
1343 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
1344 doc
: /* Return the real uid of Emacs.
1345 Value is an integer or a float, depending on the value. */)
1348 uid_t uid
= getuid ();
1349 return make_fixnum_or_float (uid
);
1352 DEFUN ("group-gid", Fgroup_gid
, Sgroup_gid
, 0, 0, 0,
1353 doc
: /* Return the effective gid of Emacs.
1354 Value is an integer or a float, depending on the value. */)
1357 gid_t egid
= getegid ();
1358 return make_fixnum_or_float (egid
);
1361 DEFUN ("group-real-gid", Fgroup_real_gid
, Sgroup_real_gid
, 0, 0, 0,
1362 doc
: /* Return the real gid of Emacs.
1363 Value is an integer or a float, depending on the value. */)
1366 gid_t gid
= getgid ();
1367 return make_fixnum_or_float (gid
);
1370 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 1, 0,
1371 doc
: /* Return the full name of the user logged in, as a string.
1372 If the full name corresponding to Emacs's userid is not known,
1375 If optional argument UID is an integer or float, return the full name
1376 of the user with that uid, or nil if there is no such user.
1377 If UID is a string, return the full name of the user with that login
1378 name, or nil if there is no such user. */)
1382 register char *p
, *q
;
1386 return Vuser_full_name
;
1387 else if (NUMBERP (uid
))
1390 CONS_TO_INTEGER (uid
, uid_t
, u
);
1395 else if (STRINGP (uid
))
1398 pw
= getpwnam (SSDATA (uid
));
1402 error ("Invalid UID specification");
1408 /* Chop off everything after the first comma. */
1409 q
= strchr (p
, ',');
1410 full
= make_string (p
, q
? q
- p
: strlen (p
));
1412 #ifdef AMPERSAND_FULL_NAME
1414 q
= strchr (p
, '&');
1415 /* Substitute the login name for the &, upcasing the first character. */
1418 Lisp_Object login
= Fuser_login_name (make_number (pw
->pw_uid
));
1420 char *r
= SAFE_ALLOCA (strlen (p
) + SBYTES (login
) + 1);
1421 memcpy (r
, p
, q
- p
);
1422 char *s
= lispstpcpy (&r
[q
- p
], login
);
1423 r
[q
- p
] = upcase ((unsigned char) r
[q
- p
]);
1425 full
= build_string (r
);
1428 #endif /* AMPERSAND_FULL_NAME */
1433 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
1434 doc
: /* Return the host name of the machine you are running on, as a string. */)
1437 if (EQ (Vsystem_name
, cached_system_name
))
1438 init_and_cache_system_name ();
1439 return Vsystem_name
;
1442 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
1443 doc
: /* Return the process ID of Emacs, as a number. */)
1446 pid_t pid
= getpid ();
1447 return make_fixnum_or_float (pid
);
1453 # define TIME_T_MIN TYPE_MINIMUM (time_t)
1456 # define TIME_T_MAX TYPE_MAXIMUM (time_t)
1459 /* Report that a time value is out of range for Emacs. */
1461 time_overflow (void)
1463 error ("Specified time is not representable");
1466 static _Noreturn
void
1469 error ("Invalid time specification");
1472 /* Check a return value compatible with that of decode_time_components. */
1474 check_time_validity (int validity
)
1485 /* Return the upper part of the time T (everything but the bottom 16 bits). */
1489 time_t hi
= t
>> LO_TIME_BITS
;
1491 /* Check for overflow, helping the compiler for common cases where
1492 no runtime check is needed, and taking care not to convert
1493 negative numbers to unsigned before comparing them. */
1494 if (! ((! TYPE_SIGNED (time_t)
1495 || MOST_NEGATIVE_FIXNUM
<= TIME_T_MIN
>> LO_TIME_BITS
1496 || MOST_NEGATIVE_FIXNUM
<= hi
)
1497 && (TIME_T_MAX
>> LO_TIME_BITS
<= MOST_POSITIVE_FIXNUM
1498 || hi
<= MOST_POSITIVE_FIXNUM
)))
1504 /* Return the bottom bits of the time T. */
1508 return t
& ((1 << LO_TIME_BITS
) - 1);
1511 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
1512 doc
: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
1513 The time is returned as a list of integers (HIGH LOW USEC PSEC).
1514 HIGH has the most significant bits of the seconds, while LOW has the
1515 least significant 16 bits. USEC and PSEC are the microsecond and
1516 picosecond counts. */)
1519 return make_lisp_time (current_timespec ());
1522 static struct lisp_time
1523 time_add (struct lisp_time ta
, struct lisp_time tb
)
1525 EMACS_INT hi
= ta
.hi
+ tb
.hi
;
1526 int lo
= ta
.lo
+ tb
.lo
;
1527 int us
= ta
.us
+ tb
.us
;
1528 int ps
= ta
.ps
+ tb
.ps
;
1529 us
+= (1000000 <= ps
);
1530 ps
-= (1000000 <= ps
) * 1000000;
1531 lo
+= (1000000 <= us
);
1532 us
-= (1000000 <= us
) * 1000000;
1533 hi
+= (1 << LO_TIME_BITS
<= lo
);
1534 lo
-= (1 << LO_TIME_BITS
<= lo
) << LO_TIME_BITS
;
1535 return (struct lisp_time
) { hi
, lo
, us
, ps
};
1538 static struct lisp_time
1539 time_subtract (struct lisp_time ta
, struct lisp_time tb
)
1541 EMACS_INT hi
= ta
.hi
- tb
.hi
;
1542 int lo
= ta
.lo
- tb
.lo
;
1543 int us
= ta
.us
- tb
.us
;
1544 int ps
= ta
.ps
- tb
.ps
;
1546 ps
+= (ps
< 0) * 1000000;
1548 us
+= (us
< 0) * 1000000;
1550 lo
+= (lo
< 0) << LO_TIME_BITS
;
1551 return (struct lisp_time
) { hi
, lo
, us
, ps
};
1555 time_arith (Lisp_Object a
, Lisp_Object b
,
1556 struct lisp_time (*op
) (struct lisp_time
, struct lisp_time
))
1559 struct lisp_time ta
= lisp_time_struct (a
, &alen
);
1560 struct lisp_time tb
= lisp_time_struct (b
, &blen
);
1561 struct lisp_time t
= op (ta
, tb
);
1562 if (! (MOST_NEGATIVE_FIXNUM
<= t
.hi
&& t
.hi
<= MOST_POSITIVE_FIXNUM
))
1564 Lisp_Object val
= Qnil
;
1566 switch (max (alen
, blen
))
1569 val
= Fcons (make_number (t
.ps
), val
);
1572 val
= Fcons (make_number (t
.us
), val
);
1575 val
= Fcons (make_number (t
.lo
), val
);
1576 val
= Fcons (make_number (t
.hi
), val
);
1583 DEFUN ("time-add", Ftime_add
, Stime_add
, 2, 2, 0,
1584 doc
: /* Return the sum of two time values A and B, as a time value. */)
1585 (Lisp_Object a
, Lisp_Object b
)
1587 return time_arith (a
, b
, time_add
);
1590 DEFUN ("time-subtract", Ftime_subtract
, Stime_subtract
, 2, 2, 0,
1591 doc
: /* Return the difference between two time values A and B, as a time value. */)
1592 (Lisp_Object a
, Lisp_Object b
)
1594 return time_arith (a
, b
, time_subtract
);
1597 DEFUN ("time-less-p", Ftime_less_p
, Stime_less_p
, 2, 2, 0,
1598 doc
: /* Return non-nil if time value T1 is earlier than time value T2. */)
1599 (Lisp_Object t1
, Lisp_Object t2
)
1602 struct lisp_time a
= lisp_time_struct (t1
, &t1len
);
1603 struct lisp_time b
= lisp_time_struct (t2
, &t2len
);
1604 return ((a
.hi
!= b
.hi
? a
.hi
< b
.hi
1605 : a
.lo
!= b
.lo
? a
.lo
< b
.lo
1606 : a
.us
!= b
.us
? a
.us
< b
.us
1612 DEFUN ("get-internal-run-time", Fget_internal_run_time
, Sget_internal_run_time
,
1614 doc
: /* Return the current run time used by Emacs.
1615 The time is returned as a list (HIGH LOW USEC PSEC), using the same
1616 style as (current-time).
1618 On systems that can't determine the run time, `get-internal-run-time'
1619 does the same thing as `current-time'. */)
1622 #ifdef HAVE_GETRUSAGE
1623 struct rusage usage
;
1627 if (getrusage (RUSAGE_SELF
, &usage
) < 0)
1628 /* This shouldn't happen. What action is appropriate? */
1631 /* Sum up user time and system time. */
1632 secs
= usage
.ru_utime
.tv_sec
+ usage
.ru_stime
.tv_sec
;
1633 usecs
= usage
.ru_utime
.tv_usec
+ usage
.ru_stime
.tv_usec
;
1634 if (usecs
>= 1000000)
1639 return make_lisp_time (make_timespec (secs
, usecs
* 1000));
1640 #else /* ! HAVE_GETRUSAGE */
1642 return w32_get_internal_run_time ();
1643 #else /* ! WINDOWSNT */
1644 return Fcurrent_time ();
1645 #endif /* WINDOWSNT */
1646 #endif /* HAVE_GETRUSAGE */
1650 /* Make a Lisp list that represents the Emacs time T. T may be an
1651 invalid time, with a slightly negative tv_nsec value such as
1652 UNKNOWN_MODTIME_NSECS; in that case, the Lisp list contains a
1653 correspondingly negative picosecond count. */
1655 make_lisp_time (struct timespec t
)
1657 time_t s
= t
.tv_sec
;
1659 return list4i (hi_time (s
), lo_time (s
), ns
/ 1000, ns
% 1000 * 1000);
1662 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1663 Set *PHIGH, *PLOW, *PUSEC, *PPSEC to its parts; do not check their values.
1664 Return 2, 3, or 4 to indicate the effective length of SPECIFIED_TIME
1665 if successful, 0 if unsuccessful. */
1667 disassemble_lisp_time (Lisp_Object specified_time
, Lisp_Object
*phigh
,
1668 Lisp_Object
*plow
, Lisp_Object
*pusec
,
1671 Lisp_Object high
= make_number (0);
1672 Lisp_Object low
= specified_time
;
1673 Lisp_Object usec
= make_number (0);
1674 Lisp_Object psec
= make_number (0);
1677 if (CONSP (specified_time
))
1679 high
= XCAR (specified_time
);
1680 low
= XCDR (specified_time
);
1683 Lisp_Object low_tail
= XCDR (low
);
1685 if (CONSP (low_tail
))
1687 usec
= XCAR (low_tail
);
1688 low_tail
= XCDR (low_tail
);
1689 if (CONSP (low_tail
))
1690 psec
= XCAR (low_tail
);
1694 else if (!NILP (low_tail
))
1705 /* When combining components, require LOW to be an integer,
1706 as otherwise it would be a pain to add up times. */
1707 if (! INTEGERP (low
))
1710 else if (INTEGERP (specified_time
))
1720 /* Convert T into an Emacs time *RESULT, truncating toward minus infinity.
1721 Return true if T is in range, false otherwise. */
1723 decode_float_time (double t
, struct lisp_time
*result
)
1725 double lo_multiplier
= 1 << LO_TIME_BITS
;
1726 double emacs_time_min
= MOST_NEGATIVE_FIXNUM
* lo_multiplier
;
1727 if (! (emacs_time_min
<= t
&& t
< -emacs_time_min
))
1730 double small_t
= t
/ lo_multiplier
;
1731 EMACS_INT hi
= small_t
;
1732 double t_sans_hi
= t
- hi
* lo_multiplier
;
1734 long double fracps
= (t_sans_hi
- lo
) * 1e12L
;
1735 #ifdef INT_FAST64_MAX
1736 int_fast64_t ifracps
= fracps
;
1737 int us
= ifracps
/ 1000000;
1738 int ps
= ifracps
% 1000000;
1740 int us
= fracps
/ 1e6L
;
1741 int ps
= fracps
- us
* 1e6L
;
1744 ps
+= (ps
< 0) * 1000000;
1746 us
+= (us
< 0) * 1000000;
1748 lo
+= (lo
< 0) << LO_TIME_BITS
;
1756 /* From the time components HIGH, LOW, USEC and PSEC taken from a Lisp
1757 list, generate the corresponding time value.
1758 If LOW is floating point, the other components should be zero.
1760 If RESULT is not null, store into *RESULT the converted time.
1761 If *DRESULT is not null, store into *DRESULT the number of
1762 seconds since the start of the POSIX Epoch.
1764 Return 1 if successful, 0 if the components are of the
1765 wrong type, and -1 if the time is out of range. */
1767 decode_time_components (Lisp_Object high
, Lisp_Object low
, Lisp_Object usec
,
1769 struct lisp_time
*result
, double *dresult
)
1771 EMACS_INT hi
, lo
, us
, ps
;
1772 if (! (INTEGERP (high
)
1773 && INTEGERP (usec
) && INTEGERP (psec
)))
1775 if (! INTEGERP (low
))
1779 double t
= XFLOAT_DATA (low
);
1780 if (result
&& ! decode_float_time (t
, result
))
1786 else if (NILP (low
))
1788 struct timespec now
= current_timespec ();
1791 result
->hi
= hi_time (now
.tv_sec
);
1792 result
->lo
= lo_time (now
.tv_sec
);
1793 result
->us
= now
.tv_nsec
/ 1000;
1794 result
->ps
= now
.tv_nsec
% 1000 * 1000;
1797 *dresult
= now
.tv_sec
+ now
.tv_nsec
/ 1e9
;
1809 /* Normalize out-of-range lower-order components by carrying
1810 each overflow into the next higher-order component. */
1811 us
+= ps
/ 1000000 - (ps
% 1000000 < 0);
1812 lo
+= us
/ 1000000 - (us
% 1000000 < 0);
1813 hi
+= lo
>> LO_TIME_BITS
;
1814 ps
= ps
% 1000000 + 1000000 * (ps
% 1000000 < 0);
1815 us
= us
% 1000000 + 1000000 * (us
% 1000000 < 0);
1816 lo
&= (1 << LO_TIME_BITS
) - 1;
1820 if (! (MOST_NEGATIVE_FIXNUM
<= hi
&& hi
<= MOST_POSITIVE_FIXNUM
))
1831 *dresult
= (us
* 1e6
+ ps
) / 1e12
+ lo
+ dhi
* (1 << LO_TIME_BITS
);
1838 lisp_to_timespec (struct lisp_time t
)
1840 if (! ((TYPE_SIGNED (time_t) ? TIME_T_MIN
>> LO_TIME_BITS
<= t
.hi
: 0 <= t
.hi
)
1841 && t
.hi
<= TIME_T_MAX
>> LO_TIME_BITS
))
1842 return invalid_timespec ();
1843 time_t s
= (t
.hi
<< LO_TIME_BITS
) + t
.lo
;
1844 int ns
= t
.us
* 1000 + t
.ps
/ 1000;
1845 return make_timespec (s
, ns
);
1848 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1849 Store its effective length into *PLEN.
1850 If SPECIFIED_TIME is nil, use the current time.
1851 Signal an error if SPECIFIED_TIME does not represent a time. */
1852 static struct lisp_time
1853 lisp_time_struct (Lisp_Object specified_time
, int *plen
)
1855 Lisp_Object high
, low
, usec
, psec
;
1857 int len
= disassemble_lisp_time (specified_time
, &high
, &low
, &usec
, &psec
);
1860 int val
= decode_time_components (high
, low
, usec
, psec
, &t
, 0);
1861 check_time_validity (val
);
1866 /* Like lisp_time_struct, except return a struct timespec.
1867 Discard any low-order digits. */
1869 lisp_time_argument (Lisp_Object specified_time
)
1872 struct lisp_time lt
= lisp_time_struct (specified_time
, &len
);
1873 struct timespec t
= lisp_to_timespec (lt
);
1874 if (! timespec_valid_p (t
))
1879 /* Like lisp_time_argument, except decode only the seconds part,
1880 and do not check the subseconds part. */
1882 lisp_seconds_argument (Lisp_Object specified_time
)
1884 Lisp_Object high
, low
, usec
, psec
;
1887 int val
= disassemble_lisp_time (specified_time
, &high
, &low
, &usec
, &psec
);
1890 val
= decode_time_components (high
, low
, make_number (0),
1891 make_number (0), &t
, 0);
1893 && ! ((TYPE_SIGNED (time_t)
1894 ? TIME_T_MIN
>> LO_TIME_BITS
<= t
.hi
1896 && t
.hi
<= TIME_T_MAX
>> LO_TIME_BITS
))
1899 check_time_validity (val
);
1900 return (t
.hi
<< LO_TIME_BITS
) + t
.lo
;
1903 DEFUN ("float-time", Ffloat_time
, Sfloat_time
, 0, 1, 0,
1904 doc
: /* Return the current time, as a float number of seconds since the epoch.
1905 If SPECIFIED-TIME is given, it is the time to convert to float
1906 instead of the current time. The argument should have the form
1907 \(HIGH LOW) or (HIGH LOW USEC) or (HIGH LOW USEC PSEC). Thus,
1908 you can use times from `current-time' and from `file-attributes'.
1909 SPECIFIED-TIME can also have the form (HIGH . LOW), but this is
1910 considered obsolete.
1912 WARNING: Since the result is floating point, it may not be exact.
1913 If precise time stamps are required, use either `current-time',
1914 or (if you need time as a string) `format-time-string'. */)
1915 (Lisp_Object specified_time
)
1918 Lisp_Object high
, low
, usec
, psec
;
1919 if (! (disassemble_lisp_time (specified_time
, &high
, &low
, &usec
, &psec
)
1920 && decode_time_components (high
, low
, usec
, psec
, 0, &t
)))
1922 return make_float (t
);
1925 /* Write information into buffer S of size MAXSIZE, according to the
1926 FORMAT of length FORMAT_LEN, using time information taken from *TP.
1927 Use the time zone specified by TZ.
1928 Use NS as the number of nanoseconds in the %N directive.
1929 Return the number of bytes written, not including the terminating
1930 '\0'. If S is NULL, nothing will be written anywhere; so to
1931 determine how many bytes would be written, use NULL for S and
1932 ((size_t) -1) for MAXSIZE.
1934 This function behaves like nstrftime, except it allows null
1935 bytes in FORMAT and it does not support nanoseconds. */
1937 emacs_nmemftime (char *s
, size_t maxsize
, const char *format
,
1938 size_t format_len
, const struct tm
*tp
, timezone_t tz
, int ns
)
1942 /* Loop through all the null-terminated strings in the format
1943 argument. Normally there's just one null-terminated string, but
1944 there can be arbitrarily many, concatenated together, if the
1945 format contains '\0' bytes. nstrftime stops at the first
1946 '\0' byte so we must invoke it separately for each such string. */
1955 result
= nstrftime (s
, maxsize
, format
, tp
, tz
, ns
);
1959 if (result
== 0 && s
[0] != '\0')
1964 maxsize
-= result
+ 1;
1966 len
= strlen (format
);
1967 if (len
== format_len
)
1971 format_len
-= len
+ 1;
1975 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 1, 3, 0,
1976 doc
: /* Use FORMAT-STRING to format the time TIME, or now if omitted.
1977 TIME is specified as (HIGH LOW USEC PSEC), as returned by
1978 `current-time' or `file-attributes'. The obsolete form (HIGH . LOW)
1979 is also still accepted. The optional ZONE is omitted or nil for Emacs
1980 local time, t for Universal Time, `wall' for system wall clock time,
1981 or a string as in the TZ environment variable.
1983 The value is a copy of FORMAT-STRING, but with certain constructs replaced
1984 by text that describes the specified date and time in TIME:
1986 %Y is the year, %y within the century, %C the century.
1987 %G is the year corresponding to the ISO week, %g within the century.
1988 %m is the numeric month.
1989 %b and %h are the locale's abbreviated month name, %B the full name.
1990 (%h is not supported on MS-Windows.)
1991 %d is the day of the month, zero-padded, %e is blank-padded.
1992 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
1993 %a is the locale's abbreviated name of the day of week, %A the full name.
1994 %U is the week number starting on Sunday, %W starting on Monday,
1995 %V according to ISO 8601.
1996 %j is the day of the year.
1998 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
1999 only blank-padded, %l is like %I blank-padded.
2000 %p is the locale's equivalent of either AM or PM.
2003 %N is the nanosecond, %6N the microsecond, %3N the millisecond, etc.
2004 %Z is the time zone name, %z is the numeric form.
2005 %s is the number of seconds since 1970-01-01 00:00:00 +0000.
2007 %c is the locale's date and time format.
2008 %x is the locale's "preferred" date format.
2009 %D is like "%m/%d/%y".
2010 %F is the ISO 8601 date format (like "%Y-%m-%d").
2012 %R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
2013 %X is the locale's "preferred" time format.
2015 Finally, %n is a newline, %t is a tab, %% is a literal %.
2017 Certain flags and modifiers are available with some format controls.
2018 The flags are `_', `-', `^' and `#'. For certain characters X,
2019 %_X is like %X, but padded with blanks; %-X is like %X,
2020 but without padding. %^X is like %X, but with all textual
2021 characters up-cased; %#X is like %X, but with letter-case of
2022 all textual characters reversed.
2023 %NX (where N stands for an integer) is like %X,
2024 but takes up at least N (a number) positions.
2025 The modifiers are `E' and `O'. For certain characters X,
2026 %EX is a locale's alternative version of %X;
2027 %OX is like %X, but uses the locale's number symbols.
2029 For example, to produce full ISO 8601 format, use "%FT%T%z".
2031 usage: (format-time-string FORMAT-STRING &optional TIME ZONE) */)
2032 (Lisp_Object format_string
, Lisp_Object timeval
, Lisp_Object zone
)
2034 struct timespec t
= lisp_time_argument (timeval
);
2037 CHECK_STRING (format_string
);
2038 format_string
= code_convert_string_norecord (format_string
,
2039 Vlocale_coding_system
, 1);
2040 return format_time_string (SSDATA (format_string
), SBYTES (format_string
),
2045 format_time_string (char const *format
, ptrdiff_t formatlen
,
2046 struct timespec t
, Lisp_Object zone
, struct tm
*tmp
)
2050 ptrdiff_t size
= sizeof buffer
;
2052 Lisp_Object bufstring
;
2056 timezone_t tz
= tzlookup (zone
, false);
2057 tmp
= emacs_localtime_rz (tz
, &t
.tv_sec
, tmp
);
2063 synchronize_system_time_locale ();
2068 len
= emacs_nmemftime (buf
, size
, format
, formatlen
, tmp
, tz
, ns
);
2069 if ((0 < len
&& len
< size
) || (len
== 0 && buf
[0] == '\0'))
2072 /* Buffer was too small, so make it bigger and try again. */
2073 len
= emacs_nmemftime (NULL
, SIZE_MAX
, format
, formatlen
, tmp
, tz
, ns
);
2074 if (STRING_BYTES_BOUND
<= len
)
2080 buf
= SAFE_ALLOCA (size
);
2084 bufstring
= make_unibyte_string (buf
, len
);
2086 return code_convert_string_norecord (bufstring
, Vlocale_coding_system
, 0);
2089 DEFUN ("decode-time", Fdecode_time
, Sdecode_time
, 0, 2, 0,
2090 doc
: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST UTCOFF).
2091 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED),
2092 as from `current-time' and `file-attributes', or nil to use the
2093 current time. The obsolete form (HIGH . LOW) is also still accepted.
2094 The optional ZONE is omitted or nil for Emacs local time, t for
2095 Universal Time, `wall' for system wall clock time, or a string as in
2096 the TZ environment variable.
2098 The list has the following nine members: SEC is an integer between 0
2099 and 60; SEC is 60 for a leap second, which only some operating systems
2100 support. MINUTE is an integer between 0 and 59. HOUR is an integer
2101 between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
2102 integer between 1 and 12. YEAR is an integer indicating the
2103 four-digit year. DOW is the day of week, an integer between 0 and 6,
2104 where 0 is Sunday. DST is t if daylight saving time is in effect,
2105 otherwise nil. UTCOFF is an integer indicating the UTC offset in
2106 seconds, i.e., the number of seconds east of Greenwich. (Note that
2107 Common Lisp has different meanings for DOW and UTCOFF.)
2109 usage: (decode-time &optional TIME ZONE) */)
2110 (Lisp_Object specified_time
, Lisp_Object zone
)
2112 time_t time_spec
= lisp_seconds_argument (specified_time
);
2113 struct tm local_tm
, gmt_tm
;
2114 timezone_t tz
= tzlookup (zone
, false);
2115 struct tm
*tm
= emacs_localtime_rz (tz
, &time_spec
, &local_tm
);
2119 && MOST_NEGATIVE_FIXNUM
- TM_YEAR_BASE
<= local_tm
.tm_year
2120 && local_tm
.tm_year
<= MOST_POSITIVE_FIXNUM
- TM_YEAR_BASE
))
2123 /* Avoid overflow when INT_MAX < EMACS_INT_MAX. */
2124 EMACS_INT tm_year_base
= TM_YEAR_BASE
;
2126 return CALLN (Flist
,
2127 make_number (local_tm
.tm_sec
),
2128 make_number (local_tm
.tm_min
),
2129 make_number (local_tm
.tm_hour
),
2130 make_number (local_tm
.tm_mday
),
2131 make_number (local_tm
.tm_mon
+ 1),
2132 make_number (local_tm
.tm_year
+ tm_year_base
),
2133 make_number (local_tm
.tm_wday
),
2134 local_tm
.tm_isdst
? Qt
: Qnil
,
2136 ? make_number (tm_gmtoff (&local_tm
))
2137 : gmtime_r (&time_spec
, &gmt_tm
)
2138 ? make_number (tm_diff (&local_tm
, &gmt_tm
))
2142 /* Return OBJ - OFFSET, checking that OBJ is a valid fixnum and that
2143 the result is representable as an int. Assume OFFSET is small and
2146 check_tm_member (Lisp_Object obj
, int offset
)
2151 if (! (INT_MIN
+ offset
<= n
&& n
- offset
<= INT_MAX
))
2156 DEFUN ("encode-time", Fencode_time
, Sencode_time
, 6, MANY
, 0,
2157 doc
: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
2158 This is the reverse operation of `decode-time', which see.
2159 The optional ZONE is omitted or nil for Emacs local time, t for
2160 Universal Time, `wall' for system wall clock time, or a string as in
2161 the TZ environment variable. It can also be a list (as from
2162 `current-time-zone') or an integer (as from `decode-time') applied
2163 without consideration for daylight saving time.
2165 You can pass more than 7 arguments; then the first six arguments
2166 are used as SECOND through YEAR, and the *last* argument is used as ZONE.
2167 The intervening arguments are ignored.
2168 This feature lets (apply \\='encode-time (decode-time ...)) work.
2170 Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed;
2171 for example, a DAY of 0 means the day preceding the given month.
2172 Year numbers less than 100 are treated just like other year numbers.
2173 If you want them to stand for years in this century, you must do that yourself.
2175 Years before 1970 are not guaranteed to work. On some systems,
2176 year values as low as 1901 do work.
2178 usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
2179 (ptrdiff_t nargs
, Lisp_Object
*args
)
2183 Lisp_Object zone
= (nargs
> 6 ? args
[nargs
- 1] : Qnil
);
2185 tm
.tm_sec
= check_tm_member (args
[0], 0);
2186 tm
.tm_min
= check_tm_member (args
[1], 0);
2187 tm
.tm_hour
= check_tm_member (args
[2], 0);
2188 tm
.tm_mday
= check_tm_member (args
[3], 0);
2189 tm
.tm_mon
= check_tm_member (args
[4], 1);
2190 tm
.tm_year
= check_tm_member (args
[5], TM_YEAR_BASE
);
2195 timezone_t tz
= tzlookup (zone
, false);
2196 value
= emacs_mktime_z (tz
, &tm
);
2199 if (value
== (time_t) -1)
2202 return list2i (hi_time (value
), lo_time (value
));
2205 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
,
2207 doc
: /* Return the current local time, as a human-readable string.
2208 Programs can use this function to decode a time,
2209 since the number of columns in each field is fixed
2210 if the year is in the range 1000-9999.
2211 The format is `Sun Sep 16 01:03:52 1973'.
2212 However, see also the functions `decode-time' and `format-time-string'
2213 which provide a much more powerful and general facility.
2215 If SPECIFIED-TIME is given, it is a time to format instead of the
2216 current time. The argument should have the form (HIGH LOW . IGNORED).
2217 Thus, you can use times obtained from `current-time' and from
2218 `file-attributes'. SPECIFIED-TIME can also have the form (HIGH . LOW),
2219 but this is considered obsolete.
2221 The optional ZONE is omitted or nil for Emacs local time, t for
2222 Universal Time, `wall' for system wall clock time, or a string as in
2223 the TZ environment variable. */)
2224 (Lisp_Object specified_time
, Lisp_Object zone
)
2226 time_t value
= lisp_seconds_argument (specified_time
);
2227 timezone_t tz
= tzlookup (zone
, false);
2229 /* Convert to a string in ctime format, except without the trailing
2230 newline, and without the 4-digit year limit. Don't use asctime
2231 or ctime, as they might dump core if the year is outside the
2232 range -999 .. 9999. */
2234 struct tm
*tmp
= emacs_localtime_rz (tz
, &value
, &tm
);
2239 static char const wday_name
[][4] =
2240 { "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat" };
2241 static char const mon_name
[][4] =
2242 { "Jan", "Feb", "Mar", "Apr", "May", "Jun",
2243 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" };
2244 printmax_t year_base
= TM_YEAR_BASE
;
2245 char buf
[sizeof "Mon Apr 30 12:49:17 " + INT_STRLEN_BOUND (int) + 1];
2246 int len
= sprintf (buf
, "%s %s%3d %02d:%02d:%02d %"pMd
,
2247 wday_name
[tm
.tm_wday
], mon_name
[tm
.tm_mon
], tm
.tm_mday
,
2248 tm
.tm_hour
, tm
.tm_min
, tm
.tm_sec
,
2249 tm
.tm_year
+ year_base
);
2251 return make_unibyte_string (buf
, len
);
2254 /* Yield A - B, measured in seconds.
2255 This function is copied from the GNU C Library. */
2257 tm_diff (struct tm
*a
, struct tm
*b
)
2259 /* Compute intervening leap days correctly even if year is negative.
2260 Take care to avoid int overflow in leap day calculations,
2261 but it's OK to assume that A and B are close to each other. */
2262 int a4
= (a
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (a
->tm_year
& 3);
2263 int b4
= (b
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (b
->tm_year
& 3);
2264 int a100
= a4
/ 25 - (a4
% 25 < 0);
2265 int b100
= b4
/ 25 - (b4
% 25 < 0);
2266 int a400
= a100
>> 2;
2267 int b400
= b100
>> 2;
2268 int intervening_leap_days
= (a4
- b4
) - (a100
- b100
) + (a400
- b400
);
2269 int years
= a
->tm_year
- b
->tm_year
;
2270 int days
= (365 * years
+ intervening_leap_days
2271 + (a
->tm_yday
- b
->tm_yday
));
2272 return (60 * (60 * (24 * days
+ (a
->tm_hour
- b
->tm_hour
))
2273 + (a
->tm_min
- b
->tm_min
))
2274 + (a
->tm_sec
- b
->tm_sec
));
2277 /* Yield A's UTC offset, or an unspecified value if unknown. */
2279 tm_gmtoff (struct tm
*a
)
2282 return a
->tm_gmtoff
;
2288 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 2, 0,
2289 doc
: /* Return the offset and name for the local time zone.
2290 This returns a list of the form (OFFSET NAME).
2291 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
2292 A negative value means west of Greenwich.
2293 NAME is a string giving the name of the time zone.
2294 If SPECIFIED-TIME is given, the time zone offset is determined from it
2295 instead of using the current time. The argument should have the form
2296 \(HIGH LOW . IGNORED). Thus, you can use times obtained from
2297 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
2298 have the form (HIGH . LOW), but this is considered obsolete.
2299 Optional second arg ZONE is omitted or nil for the local time zone, or
2300 a string as in the TZ environment variable.
2302 Some operating systems cannot provide all this information to Emacs;
2303 in this case, `current-time-zone' returns a list containing nil for
2304 the data it can't find. */)
2305 (Lisp_Object specified_time
, Lisp_Object zone
)
2307 struct timespec value
;
2308 struct tm local_tm
, gmt_tm
;
2309 Lisp_Object zone_offset
, zone_name
;
2312 value
= make_timespec (lisp_seconds_argument (specified_time
), 0);
2313 zone_name
= format_time_string ("%Z", sizeof "%Z" - 1, value
,
2316 if (HAVE_TM_GMTOFF
|| gmtime_r (&value
.tv_sec
, &gmt_tm
))
2318 long int offset
= (HAVE_TM_GMTOFF
2319 ? tm_gmtoff (&local_tm
)
2320 : tm_diff (&local_tm
, &gmt_tm
));
2321 zone_offset
= make_number (offset
);
2322 if (SCHARS (zone_name
) == 0)
2324 /* No local time zone name is available; use "+-NNNN" instead. */
2325 long int m
= offset
/ 60;
2326 long int am
= offset
< 0 ? - m
: m
;
2327 long int hour
= am
/ 60;
2329 char buf
[sizeof "+00" + INT_STRLEN_BOUND (long int)];
2330 zone_name
= make_formatted_string (buf
, "%c%02ld%02d",
2331 (offset
< 0 ? '-' : '+'),
2336 return list2 (zone_offset
, zone_name
);
2339 DEFUN ("set-time-zone-rule", Fset_time_zone_rule
, Sset_time_zone_rule
, 1, 1, 0,
2340 doc
: /* Set the Emacs local time zone using TZ, a string specifying a time zone rule.
2342 If TZ is nil or `wall', use system wall clock time; this differs from
2343 the usual Emacs convention where nil means current local time. If TZ
2344 is t, use Universal Time. If TZ is an integer, treat it as in
2347 Instead of calling this function, you typically want something else.
2348 To temporarily use a different time zone rule for just one invocation
2349 of `decode-time', `encode-time', or `format-time-string', pass the
2350 function a ZONE argument. To change local time consistently
2351 throughout Emacs, call (setenv "TZ" TZ): this changes both the
2352 environment of the Emacs process and the variable
2353 `process-environment', whereas `set-time-zone-rule' affects only the
2357 tzlookup (NILP (tz
) ? Qwall
: tz
, true);
2361 /* A buffer holding a string of the form "TZ=value", intended
2362 to be part of the environment. If TZ is supposed to be unset,
2363 the buffer string is "tZ=". */
2364 static char *tzvalbuf
;
2366 /* Get the local time zone rule. */
2368 emacs_getenv_TZ (void)
2370 return tzvalbuf
[0] == 'T' ? tzvalbuf
+ tzeqlen
: 0;
2373 /* Set the local time zone rule to TZSTRING, which can be null to
2374 denote wall clock time. Do not record the setting in LOCAL_TZ.
2376 This function is not thread-safe, in theory because putenv is not,
2377 but mostly because of the static storage it updates. Other threads
2378 that invoke localtime etc. may be adversely affected while this
2379 function is executing. */
2382 emacs_setenv_TZ (const char *tzstring
)
2384 static ptrdiff_t tzvalbufsize
;
2385 ptrdiff_t tzstringlen
= tzstring
? strlen (tzstring
) : 0;
2386 char *tzval
= tzvalbuf
;
2387 bool new_tzvalbuf
= tzvalbufsize
<= tzeqlen
+ tzstringlen
;
2391 /* Do not attempt to free the old tzvalbuf, since another thread
2392 may be using it. In practice, the first allocation is large
2393 enough and memory does not leak. */
2394 tzval
= xpalloc (NULL
, &tzvalbufsize
,
2395 tzeqlen
+ tzstringlen
- tzvalbufsize
+ 1, -1, 1);
2403 /* Modify TZVAL in place. Although this is dicey in a
2404 multithreaded environment, we know of no portable alternative.
2405 Calling putenv or setenv could crash some other thread. */
2407 strcpy (tzval
+ tzeqlen
, tzstring
);
2411 /* Turn 'TZ=whatever' into an empty environment variable 'tZ='.
2412 Although this is also dicey, calling unsetenv here can crash Emacs.
2420 /* MS-Windows implementation of 'putenv' copies the argument
2421 string into a block it allocates, so modifying tzval string
2422 does not change the environment. OTOH, the other threads run
2423 by Emacs on MS-Windows never call 'xputenv' or 'putenv' or
2424 'unsetenv', so the original cause for the dicey in-place
2425 modification technique doesn't exist there in the first
2431 /* Although this is not thread-safe, in practice this runs only
2432 on startup when there is only one thread. */
2439 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
2440 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
2441 type of object is Lisp_String). INHERIT is passed to
2442 INSERT_FROM_STRING_FUNC as the last argument. */
2445 general_insert_function (void (*insert_func
)
2446 (const char *, ptrdiff_t),
2447 void (*insert_from_string_func
)
2448 (Lisp_Object
, ptrdiff_t, ptrdiff_t,
2449 ptrdiff_t, ptrdiff_t, bool),
2450 bool inherit
, ptrdiff_t nargs
, Lisp_Object
*args
)
2455 for (argnum
= 0; argnum
< nargs
; argnum
++)
2458 if (CHARACTERP (val
))
2460 int c
= XFASTINT (val
);
2461 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2464 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2465 len
= CHAR_STRING (c
, str
);
2468 str
[0] = CHAR_TO_BYTE8 (c
);
2471 (*insert_func
) ((char *) str
, len
);
2473 else if (STRINGP (val
))
2475 (*insert_from_string_func
) (val
, 0, 0,
2481 wrong_type_argument (Qchar_or_string_p
, val
);
2486 insert1 (Lisp_Object arg
)
2492 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
2493 doc
: /* Insert the arguments, either strings or characters, at point.
2494 Point and after-insertion markers move forward to end up
2495 after the inserted text.
2496 Any other markers at the point of insertion remain before the text.
2498 If the current buffer is multibyte, unibyte strings are converted
2499 to multibyte for insertion (see `string-make-multibyte').
2500 If the current buffer is unibyte, multibyte strings are converted
2501 to unibyte for insertion (see `string-make-unibyte').
2503 When operating on binary data, it may be necessary to preserve the
2504 original bytes of a unibyte string when inserting it into a multibyte
2505 buffer; to accomplish this, apply `string-as-multibyte' to the string
2506 and insert the result.
2508 usage: (insert &rest ARGS) */)
2509 (ptrdiff_t nargs
, Lisp_Object
*args
)
2511 general_insert_function (insert
, insert_from_string
, 0, nargs
, args
);
2515 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
2517 doc
: /* Insert the arguments at point, inheriting properties from adjoining text.
2518 Point and after-insertion markers move forward to end up
2519 after the inserted text.
2520 Any other markers at the point of insertion remain before the text.
2522 If the current buffer is multibyte, unibyte strings are converted
2523 to multibyte for insertion (see `unibyte-char-to-multibyte').
2524 If the current buffer is unibyte, multibyte strings are converted
2525 to unibyte for insertion.
2527 usage: (insert-and-inherit &rest ARGS) */)
2528 (ptrdiff_t nargs
, Lisp_Object
*args
)
2530 general_insert_function (insert_and_inherit
, insert_from_string
, 1,
2535 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
2536 doc
: /* Insert strings or characters at point, relocating markers after the text.
2537 Point and markers move forward to end up after the inserted text.
2539 If the current buffer is multibyte, unibyte strings are converted
2540 to multibyte for insertion (see `unibyte-char-to-multibyte').
2541 If the current buffer is unibyte, multibyte strings are converted
2542 to unibyte for insertion.
2544 If an overlay begins at the insertion point, the inserted text falls
2545 outside the overlay; if a nonempty overlay ends at the insertion
2546 point, the inserted text falls inside that overlay.
2548 usage: (insert-before-markers &rest ARGS) */)
2549 (ptrdiff_t nargs
, Lisp_Object
*args
)
2551 general_insert_function (insert_before_markers
,
2552 insert_from_string_before_markers
, 0,
2557 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers
,
2558 Sinsert_and_inherit_before_markers
, 0, MANY
, 0,
2559 doc
: /* Insert text at point, relocating markers and inheriting properties.
2560 Point and markers move forward to end up after the inserted text.
2562 If the current buffer is multibyte, unibyte strings are converted
2563 to multibyte for insertion (see `unibyte-char-to-multibyte').
2564 If the current buffer is unibyte, multibyte strings are converted
2565 to unibyte for insertion.
2567 usage: (insert-before-markers-and-inherit &rest ARGS) */)
2568 (ptrdiff_t nargs
, Lisp_Object
*args
)
2570 general_insert_function (insert_before_markers_and_inherit
,
2571 insert_from_string_before_markers
, 1,
2576 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 1, 3,
2577 "(list (read-char-by-name \"Insert character (Unicode name or hex): \")\
2578 (prefix-numeric-value current-prefix-arg)\
2580 doc
: /* Insert COUNT copies of CHARACTER.
2581 Interactively, prompt for CHARACTER. You can specify CHARACTER in one
2584 - As its Unicode character name, e.g. \"LATIN SMALL LETTER A\".
2585 Completion is available; if you type a substring of the name
2586 preceded by an asterisk `*', Emacs shows all names which include
2587 that substring, not necessarily at the beginning of the name.
2589 - As a hexadecimal code point, e.g. 263A. Note that code points in
2590 Emacs are equivalent to Unicode up to 10FFFF (which is the limit of
2591 the Unicode code space).
2593 - As a code point with a radix specified with #, e.g. #o21430
2594 (octal), #x2318 (hex), or #10r8984 (decimal).
2596 If called interactively, COUNT is given by the prefix argument. If
2597 omitted or nil, it defaults to 1.
2599 Inserting the character(s) relocates point and before-insertion
2600 markers in the same ways as the function `insert'.
2602 The optional third argument INHERIT, if non-nil, says to inherit text
2603 properties from adjoining text, if those properties are sticky. If
2604 called interactively, INHERIT is t. */)
2605 (Lisp_Object character
, Lisp_Object count
, Lisp_Object inherit
)
2608 register ptrdiff_t n
;
2610 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2613 CHECK_CHARACTER (character
);
2615 XSETFASTINT (count
, 1);
2616 CHECK_NUMBER (count
);
2617 c
= XFASTINT (character
);
2619 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2620 len
= CHAR_STRING (c
, str
);
2622 str
[0] = c
, len
= 1;
2623 if (XINT (count
) <= 0)
2625 if (BUF_BYTES_MAX
/ len
< XINT (count
))
2627 n
= XINT (count
) * len
;
2628 stringlen
= min (n
, sizeof string
- sizeof string
% len
);
2629 for (i
= 0; i
< stringlen
; i
++)
2630 string
[i
] = str
[i
% len
];
2631 while (n
> stringlen
)
2634 if (!NILP (inherit
))
2635 insert_and_inherit (string
, stringlen
);
2637 insert (string
, stringlen
);
2640 if (!NILP (inherit
))
2641 insert_and_inherit (string
, n
);
2647 DEFUN ("insert-byte", Finsert_byte
, Sinsert_byte
, 2, 3, 0,
2648 doc
: /* Insert COUNT (second arg) copies of BYTE (first arg).
2649 Both arguments are required.
2650 BYTE is a number of the range 0..255.
2652 If BYTE is 128..255 and the current buffer is multibyte, the
2653 corresponding eight-bit character is inserted.
2655 Point, and before-insertion markers, are relocated as in the function `insert'.
2656 The optional third arg INHERIT, if non-nil, says to inherit text properties
2657 from adjoining text, if those properties are sticky. */)
2658 (Lisp_Object byte
, Lisp_Object count
, Lisp_Object inherit
)
2660 CHECK_NUMBER (byte
);
2661 if (XINT (byte
) < 0 || XINT (byte
) > 255)
2662 args_out_of_range_3 (byte
, make_number (0), make_number (255));
2663 if (XINT (byte
) >= 128
2664 && ! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2665 XSETFASTINT (byte
, BYTE8_TO_CHAR (XINT (byte
)));
2666 return Finsert_char (byte
, count
, inherit
);
2670 /* Making strings from buffer contents. */
2672 /* Return a Lisp_String containing the text of the current buffer from
2673 START to END. If text properties are in use and the current buffer
2674 has properties in the range specified, the resulting string will also
2675 have them, if PROPS is true.
2677 We don't want to use plain old make_string here, because it calls
2678 make_uninit_string, which can cause the buffer arena to be
2679 compacted. make_string has no way of knowing that the data has
2680 been moved, and thus copies the wrong data into the string. This
2681 doesn't effect most of the other users of make_string, so it should
2682 be left as is. But we should use this function when conjuring
2683 buffer substrings. */
2686 make_buffer_string (ptrdiff_t start
, ptrdiff_t end
, bool props
)
2688 ptrdiff_t start_byte
= CHAR_TO_BYTE (start
);
2689 ptrdiff_t end_byte
= CHAR_TO_BYTE (end
);
2691 return make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
);
2694 /* Return a Lisp_String containing the text of the current buffer from
2695 START / START_BYTE to END / END_BYTE.
2697 If text properties are in use and the current buffer
2698 has properties in the range specified, the resulting string will also
2699 have them, if PROPS is true.
2701 We don't want to use plain old make_string here, because it calls
2702 make_uninit_string, which can cause the buffer arena to be
2703 compacted. make_string has no way of knowing that the data has
2704 been moved, and thus copies the wrong data into the string. This
2705 doesn't effect most of the other users of make_string, so it should
2706 be left as is. But we should use this function when conjuring
2707 buffer substrings. */
2710 make_buffer_string_both (ptrdiff_t start
, ptrdiff_t start_byte
,
2711 ptrdiff_t end
, ptrdiff_t end_byte
, bool props
)
2713 Lisp_Object result
, tem
, tem1
;
2714 ptrdiff_t beg0
, end0
, beg1
, end1
, size
;
2716 if (start_byte
< GPT_BYTE
&& GPT_BYTE
< end_byte
)
2718 /* Two regions, before and after the gap. */
2721 beg1
= GPT_BYTE
+ GAP_SIZE
- BEG_BYTE
;
2722 end1
= end_byte
+ GAP_SIZE
- BEG_BYTE
;
2726 /* The only region. */
2733 if (! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2734 result
= make_uninit_multibyte_string (end
- start
, end_byte
- start_byte
);
2736 result
= make_uninit_string (end
- start
);
2739 memcpy (SDATA (result
), BYTE_POS_ADDR (beg0
), size
);
2741 memcpy (SDATA (result
) + size
, BEG_ADDR
+ beg1
, end1
- beg1
);
2743 /* If desired, update and copy the text properties. */
2746 update_buffer_properties (start
, end
);
2748 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
2749 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
2751 if (XINT (tem
) != end
|| !NILP (tem1
))
2752 copy_intervals_to_string (result
, current_buffer
, start
,
2759 /* Call Vbuffer_access_fontify_functions for the range START ... END
2760 in the current buffer, if necessary. */
2763 update_buffer_properties (ptrdiff_t start
, ptrdiff_t end
)
2765 /* If this buffer has some access functions,
2766 call them, specifying the range of the buffer being accessed. */
2767 if (!NILP (Vbuffer_access_fontify_functions
))
2769 /* But don't call them if we can tell that the work
2770 has already been done. */
2771 if (!NILP (Vbuffer_access_fontified_property
))
2774 = Ftext_property_any (make_number (start
), make_number (end
),
2775 Vbuffer_access_fontified_property
,
2781 CALLN (Frun_hook_with_args
, Qbuffer_access_fontify_functions
,
2782 make_number (start
), make_number (end
));
2786 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
2787 doc
: /* Return the contents of part of the current buffer as a string.
2788 The two arguments START and END are character positions;
2789 they can be in either order.
2790 The string returned is multibyte if the buffer is multibyte.
2792 This function copies the text properties of that part of the buffer
2793 into the result string; if you don't want the text properties,
2794 use `buffer-substring-no-properties' instead. */)
2795 (Lisp_Object start
, Lisp_Object end
)
2797 register ptrdiff_t b
, e
;
2799 validate_region (&start
, &end
);
2803 return make_buffer_string (b
, e
, 1);
2806 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties
,
2807 Sbuffer_substring_no_properties
, 2, 2, 0,
2808 doc
: /* Return the characters of part of the buffer, without the text properties.
2809 The two arguments START and END are character positions;
2810 they can be in either order. */)
2811 (Lisp_Object start
, Lisp_Object end
)
2813 register ptrdiff_t b
, e
;
2815 validate_region (&start
, &end
);
2819 return make_buffer_string (b
, e
, 0);
2822 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
2823 doc
: /* Return the contents of the current buffer as a string.
2824 If narrowing is in effect, this function returns only the visible part
2828 return make_buffer_string_both (BEGV
, BEGV_BYTE
, ZV
, ZV_BYTE
, 1);
2831 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
2833 doc
: /* Insert before point a substring of the contents of BUFFER.
2834 BUFFER may be a buffer or a buffer name.
2835 Arguments START and END are character positions specifying the substring.
2836 They default to the values of (point-min) and (point-max) in BUFFER.
2838 Point and before-insertion markers move forward to end up after the
2840 Any other markers at the point of insertion remain before the text.
2842 If the current buffer is multibyte and BUFFER is unibyte, or vice
2843 versa, strings are converted from unibyte to multibyte or vice versa
2844 using `string-make-multibyte' or `string-make-unibyte', which see. */)
2845 (Lisp_Object buffer
, Lisp_Object start
, Lisp_Object end
)
2847 register EMACS_INT b
, e
, temp
;
2848 register struct buffer
*bp
, *obuf
;
2851 buf
= Fget_buffer (buffer
);
2855 if (!BUFFER_LIVE_P (bp
))
2856 error ("Selecting deleted buffer");
2862 CHECK_NUMBER_COERCE_MARKER (start
);
2869 CHECK_NUMBER_COERCE_MARKER (end
);
2874 temp
= b
, b
= e
, e
= temp
;
2876 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
2877 args_out_of_range (start
, end
);
2879 obuf
= current_buffer
;
2880 set_buffer_internal_1 (bp
);
2881 update_buffer_properties (b
, e
);
2882 set_buffer_internal_1 (obuf
);
2884 insert_from_buffer (bp
, b
, e
- b
, 0);
2888 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
2890 doc
: /* Compare two substrings of two buffers; return result as number.
2891 Return -N if first string is less after N-1 chars, +N if first string is
2892 greater after N-1 chars, or 0 if strings match.
2893 The first substring is in BUFFER1 from START1 to END1 and the second
2894 is in BUFFER2 from START2 to END2.
2895 The value of `case-fold-search' in the current buffer
2896 determines whether case is significant or ignored. */)
2897 (Lisp_Object buffer1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object buffer2
, Lisp_Object start2
, Lisp_Object end2
)
2899 register EMACS_INT begp1
, endp1
, begp2
, endp2
, temp
;
2900 register struct buffer
*bp1
, *bp2
;
2901 register Lisp_Object trt
2902 = (!NILP (BVAR (current_buffer
, case_fold_search
))
2903 ? BVAR (current_buffer
, case_canon_table
) : Qnil
);
2904 ptrdiff_t chars
= 0;
2905 ptrdiff_t i1
, i2
, i1_byte
, i2_byte
;
2907 /* Find the first buffer and its substring. */
2910 bp1
= current_buffer
;
2914 buf1
= Fget_buffer (buffer1
);
2917 bp1
= XBUFFER (buf1
);
2918 if (!BUFFER_LIVE_P (bp1
))
2919 error ("Selecting deleted buffer");
2923 begp1
= BUF_BEGV (bp1
);
2926 CHECK_NUMBER_COERCE_MARKER (start1
);
2927 begp1
= XINT (start1
);
2930 endp1
= BUF_ZV (bp1
);
2933 CHECK_NUMBER_COERCE_MARKER (end1
);
2934 endp1
= XINT (end1
);
2938 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
2940 if (!(BUF_BEGV (bp1
) <= begp1
2942 && endp1
<= BUF_ZV (bp1
)))
2943 args_out_of_range (start1
, end1
);
2945 /* Likewise for second substring. */
2948 bp2
= current_buffer
;
2952 buf2
= Fget_buffer (buffer2
);
2955 bp2
= XBUFFER (buf2
);
2956 if (!BUFFER_LIVE_P (bp2
))
2957 error ("Selecting deleted buffer");
2961 begp2
= BUF_BEGV (bp2
);
2964 CHECK_NUMBER_COERCE_MARKER (start2
);
2965 begp2
= XINT (start2
);
2968 endp2
= BUF_ZV (bp2
);
2971 CHECK_NUMBER_COERCE_MARKER (end2
);
2972 endp2
= XINT (end2
);
2976 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
2978 if (!(BUF_BEGV (bp2
) <= begp2
2980 && endp2
<= BUF_ZV (bp2
)))
2981 args_out_of_range (start2
, end2
);
2985 i1_byte
= buf_charpos_to_bytepos (bp1
, i1
);
2986 i2_byte
= buf_charpos_to_bytepos (bp2
, i2
);
2988 while (i1
< endp1
&& i2
< endp2
)
2990 /* When we find a mismatch, we must compare the
2991 characters, not just the bytes. */
2996 if (! NILP (BVAR (bp1
, enable_multibyte_characters
)))
2998 c1
= BUF_FETCH_MULTIBYTE_CHAR (bp1
, i1_byte
);
2999 BUF_INC_POS (bp1
, i1_byte
);
3004 c1
= BUF_FETCH_BYTE (bp1
, i1
);
3005 MAKE_CHAR_MULTIBYTE (c1
);
3009 if (! NILP (BVAR (bp2
, enable_multibyte_characters
)))
3011 c2
= BUF_FETCH_MULTIBYTE_CHAR (bp2
, i2_byte
);
3012 BUF_INC_POS (bp2
, i2_byte
);
3017 c2
= BUF_FETCH_BYTE (bp2
, i2
);
3018 MAKE_CHAR_MULTIBYTE (c2
);
3024 c1
= char_table_translate (trt
, c1
);
3025 c2
= char_table_translate (trt
, c2
);
3028 return make_number (- 1 - chars
);
3030 return make_number (chars
+ 1);
3035 /* The strings match as far as they go.
3036 If one is shorter, that one is less. */
3037 if (chars
< endp1
- begp1
)
3038 return make_number (chars
+ 1);
3039 else if (chars
< endp2
- begp2
)
3040 return make_number (- chars
- 1);
3042 /* Same length too => they are equal. */
3043 return make_number (0);
3047 subst_char_in_region_unwind (Lisp_Object arg
)
3049 bset_undo_list (current_buffer
, arg
);
3053 subst_char_in_region_unwind_1 (Lisp_Object arg
)
3055 bset_filename (current_buffer
, arg
);
3058 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
3059 Ssubst_char_in_region
, 4, 5, 0,
3060 doc
: /* From START to END, replace FROMCHAR with TOCHAR each time it occurs.
3061 If optional arg NOUNDO is non-nil, don't record this change for undo
3062 and don't mark the buffer as really changed.
3063 Both characters must have the same length of multi-byte form. */)
3064 (Lisp_Object start
, Lisp_Object end
, Lisp_Object fromchar
, Lisp_Object tochar
, Lisp_Object noundo
)
3066 register ptrdiff_t pos
, pos_byte
, stop
, i
, len
, end_byte
;
3067 /* Keep track of the first change in the buffer:
3068 if 0 we haven't found it yet.
3069 if < 0 we've found it and we've run the before-change-function.
3070 if > 0 we've actually performed it and the value is its position. */
3071 ptrdiff_t changed
= 0;
3072 unsigned char fromstr
[MAX_MULTIBYTE_LENGTH
], tostr
[MAX_MULTIBYTE_LENGTH
];
3074 ptrdiff_t count
= SPECPDL_INDEX ();
3075 #define COMBINING_NO 0
3076 #define COMBINING_BEFORE 1
3077 #define COMBINING_AFTER 2
3078 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
3079 int maybe_byte_combining
= COMBINING_NO
;
3080 ptrdiff_t last_changed
= 0;
3082 = !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3087 validate_region (&start
, &end
);
3088 CHECK_CHARACTER (fromchar
);
3089 CHECK_CHARACTER (tochar
);
3090 fromc
= XFASTINT (fromchar
);
3091 toc
= XFASTINT (tochar
);
3095 len
= CHAR_STRING (fromc
, fromstr
);
3096 if (CHAR_STRING (toc
, tostr
) != len
)
3097 error ("Characters in `subst-char-in-region' have different byte-lengths");
3098 if (!ASCII_CHAR_P (*tostr
))
3100 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
3101 complete multibyte character, it may be combined with the
3102 after bytes. If it is in the range 0xA0..0xFF, it may be
3103 combined with the before and after bytes. */
3104 if (!CHAR_HEAD_P (*tostr
))
3105 maybe_byte_combining
= COMBINING_BOTH
;
3106 else if (BYTES_BY_CHAR_HEAD (*tostr
) > len
)
3107 maybe_byte_combining
= COMBINING_AFTER
;
3118 pos_byte
= CHAR_TO_BYTE (pos
);
3119 stop
= CHAR_TO_BYTE (XINT (end
));
3122 /* If we don't want undo, turn off putting stuff on the list.
3123 That's faster than getting rid of things,
3124 and it prevents even the entry for a first change.
3125 Also inhibit locking the file. */
3126 if (!changed
&& !NILP (noundo
))
3128 record_unwind_protect (subst_char_in_region_unwind
,
3129 BVAR (current_buffer
, undo_list
));
3130 bset_undo_list (current_buffer
, Qt
);
3131 /* Don't do file-locking. */
3132 record_unwind_protect (subst_char_in_region_unwind_1
,
3133 BVAR (current_buffer
, filename
));
3134 bset_filename (current_buffer
, Qnil
);
3137 if (pos_byte
< GPT_BYTE
)
3138 stop
= min (stop
, GPT_BYTE
);
3141 ptrdiff_t pos_byte_next
= pos_byte
;
3143 if (pos_byte
>= stop
)
3145 if (pos_byte
>= end_byte
) break;
3148 p
= BYTE_POS_ADDR (pos_byte
);
3150 INC_POS (pos_byte_next
);
3153 if (pos_byte_next
- pos_byte
== len
3154 && p
[0] == fromstr
[0]
3156 || (p
[1] == fromstr
[1]
3157 && (len
== 2 || (p
[2] == fromstr
[2]
3158 && (len
== 3 || p
[3] == fromstr
[3]))))))
3161 /* We've already seen this and run the before-change-function;
3162 this time we only need to record the actual position. */
3167 modify_text (pos
, XINT (end
));
3169 if (! NILP (noundo
))
3171 if (MODIFF
- 1 == SAVE_MODIFF
)
3173 if (MODIFF
- 1 == BUF_AUTOSAVE_MODIFF (current_buffer
))
3174 BUF_AUTOSAVE_MODIFF (current_buffer
)++;
3177 /* The before-change-function may have moved the gap
3178 or even modified the buffer so we should start over. */
3182 /* Take care of the case where the new character
3183 combines with neighboring bytes. */
3184 if (maybe_byte_combining
3185 && (maybe_byte_combining
== COMBINING_AFTER
3186 ? (pos_byte_next
< Z_BYTE
3187 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
3188 : ((pos_byte_next
< Z_BYTE
3189 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
3190 || (pos_byte
> BEG_BYTE
3191 && ! ASCII_CHAR_P (FETCH_BYTE (pos_byte
- 1))))))
3193 Lisp_Object tem
, string
;
3195 tem
= BVAR (current_buffer
, undo_list
);
3197 /* Make a multibyte string containing this single character. */
3198 string
= make_multibyte_string ((char *) tostr
, 1, len
);
3199 /* replace_range is less efficient, because it moves the gap,
3200 but it handles combining correctly. */
3201 replace_range (pos
, pos
+ 1, string
,
3203 pos_byte_next
= CHAR_TO_BYTE (pos
);
3204 if (pos_byte_next
> pos_byte
)
3205 /* Before combining happened. We should not increment
3206 POS. So, to cancel the later increment of POS,
3210 INC_POS (pos_byte_next
);
3212 if (! NILP (noundo
))
3213 bset_undo_list (current_buffer
, tem
);
3218 record_change (pos
, 1);
3219 for (i
= 0; i
< len
; i
++) *p
++ = tostr
[i
];
3221 last_changed
= pos
+ 1;
3223 pos_byte
= pos_byte_next
;
3229 signal_after_change (changed
,
3230 last_changed
- changed
, last_changed
- changed
);
3231 update_compositions (changed
, last_changed
, CHECK_ALL
);
3234 unbind_to (count
, Qnil
);
3239 static Lisp_Object
check_translation (ptrdiff_t, ptrdiff_t, ptrdiff_t,
3242 /* Helper function for Ftranslate_region_internal.
3244 Check if a character sequence at POS (POS_BYTE) matches an element
3245 of VAL. VAL is a list (([FROM-CHAR ...] . TO) ...). If a matching
3246 element is found, return it. Otherwise return Qnil. */
3249 check_translation (ptrdiff_t pos
, ptrdiff_t pos_byte
, ptrdiff_t end
,
3252 int initial_buf
[16];
3253 int *buf
= initial_buf
;
3254 ptrdiff_t buf_size
= ARRAYELTS (initial_buf
);
3256 ptrdiff_t buf_used
= 0;
3257 Lisp_Object result
= Qnil
;
3259 for (; CONSP (val
); val
= XCDR (val
))
3268 if (! VECTORP (elt
))
3271 if (len
<= end
- pos
)
3273 for (i
= 0; i
< len
; i
++)
3277 unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
3280 if (buf_used
== buf_size
)
3282 bufalloc
= xpalloc (bufalloc
, &buf_size
, 1, -1,
3284 if (buf
== initial_buf
)
3285 memcpy (bufalloc
, buf
, sizeof initial_buf
);
3288 buf
[buf_used
++] = STRING_CHAR_AND_LENGTH (p
, len1
);
3291 if (XINT (AREF (elt
, i
)) != buf
[i
])
3296 result
= XCAR (val
);
3307 DEFUN ("translate-region-internal", Ftranslate_region_internal
,
3308 Stranslate_region_internal
, 3, 3, 0,
3309 doc
: /* Internal use only.
3310 From START to END, translate characters according to TABLE.
3311 TABLE is a string or a char-table; the Nth character in it is the
3312 mapping for the character with code N.
3313 It returns the number of characters changed. */)
3314 (Lisp_Object start
, Lisp_Object end
, register Lisp_Object table
)
3316 register unsigned char *tt
; /* Trans table. */
3317 register int nc
; /* New character. */
3318 int cnt
; /* Number of changes made. */
3319 ptrdiff_t size
; /* Size of translate table. */
3320 ptrdiff_t pos
, pos_byte
, end_pos
;
3321 bool multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3322 bool string_multibyte
IF_LINT (= 0);
3324 validate_region (&start
, &end
);
3325 if (CHAR_TABLE_P (table
))
3327 if (! EQ (XCHAR_TABLE (table
)->purpose
, Qtranslation_table
))
3328 error ("Not a translation table");
3334 CHECK_STRING (table
);
3336 if (! multibyte
&& (SCHARS (table
) < SBYTES (table
)))
3337 table
= string_make_unibyte (table
);
3338 string_multibyte
= SCHARS (table
) < SBYTES (table
);
3339 size
= SBYTES (table
);
3344 pos_byte
= CHAR_TO_BYTE (pos
);
3345 end_pos
= XINT (end
);
3346 modify_text (pos
, end_pos
);
3349 for (; pos
< end_pos
; )
3351 register unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
3352 unsigned char *str
, buf
[MAX_MULTIBYTE_LENGTH
];
3358 oc
= STRING_CHAR_AND_LENGTH (p
, len
);
3365 /* Reload as signal_after_change in last iteration may GC. */
3367 if (string_multibyte
)
3369 str
= tt
+ string_char_to_byte (table
, oc
);
3370 nc
= STRING_CHAR_AND_LENGTH (str
, str_len
);
3375 if (! ASCII_CHAR_P (nc
) && multibyte
)
3377 str_len
= BYTE8_STRING (nc
, buf
);
3390 val
= CHAR_TABLE_REF (table
, oc
);
3391 if (CHARACTERP (val
))
3393 nc
= XFASTINT (val
);
3394 str_len
= CHAR_STRING (nc
, buf
);
3397 else if (VECTORP (val
) || (CONSP (val
)))
3399 /* VAL is [TO_CHAR ...] or (([FROM-CHAR ...] . TO) ...)
3400 where TO is TO-CHAR or [TO-CHAR ...]. */
3405 if (nc
!= oc
&& nc
>= 0)
3407 /* Simple one char to one char translation. */
3412 /* This is less efficient, because it moves the gap,
3413 but it should handle multibyte characters correctly. */
3414 string
= make_multibyte_string ((char *) str
, 1, str_len
);
3415 replace_range (pos
, pos
+ 1, string
, 1, 0, 1, 0);
3420 record_change (pos
, 1);
3421 while (str_len
-- > 0)
3423 signal_after_change (pos
, 1, 1);
3424 update_compositions (pos
, pos
+ 1, CHECK_BORDER
);
3434 val
= check_translation (pos
, pos_byte
, end_pos
, val
);
3441 /* VAL is ([FROM-CHAR ...] . TO). */
3442 len
= ASIZE (XCAR (val
));
3450 string
= Fconcat (1, &val
);
3454 string
= Fmake_string (make_number (1), val
);
3456 replace_range (pos
, pos
+ len
, string
, 1, 0, 1, 0);
3457 pos_byte
+= SBYTES (string
);
3458 pos
+= SCHARS (string
);
3459 cnt
+= SCHARS (string
);
3460 end_pos
+= SCHARS (string
) - len
;
3468 return make_number (cnt
);
3471 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
3472 doc
: /* Delete the text between START and END.
3473 If called interactively, delete the region between point and mark.
3474 This command deletes buffer text without modifying the kill ring. */)
3475 (Lisp_Object start
, Lisp_Object end
)
3477 validate_region (&start
, &end
);
3478 del_range (XINT (start
), XINT (end
));
3482 DEFUN ("delete-and-extract-region", Fdelete_and_extract_region
,
3483 Sdelete_and_extract_region
, 2, 2, 0,
3484 doc
: /* Delete the text between START and END and return it. */)
3485 (Lisp_Object start
, Lisp_Object end
)
3487 validate_region (&start
, &end
);
3488 if (XINT (start
) == XINT (end
))
3489 return empty_unibyte_string
;
3490 return del_range_1 (XINT (start
), XINT (end
), 1, 1);
3493 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
3494 doc
: /* Remove restrictions (narrowing) from current buffer.
3495 This allows the buffer's full text to be seen and edited. */)
3498 if (BEG
!= BEGV
|| Z
!= ZV
)
3499 current_buffer
->clip_changed
= 1;
3501 BEGV_BYTE
= BEG_BYTE
;
3502 SET_BUF_ZV_BOTH (current_buffer
, Z
, Z_BYTE
);
3503 /* Changing the buffer bounds invalidates any recorded current column. */
3504 invalidate_current_column ();
3508 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
3509 doc
: /* Restrict editing in this buffer to the current region.
3510 The rest of the text becomes temporarily invisible and untouchable
3511 but is not deleted; if you save the buffer in a file, the invisible
3512 text is included in the file. \\[widen] makes all visible again.
3513 See also `save-restriction'.
3515 When calling from a program, pass two arguments; positions (integers
3516 or markers) bounding the text that should remain visible. */)
3517 (register Lisp_Object start
, Lisp_Object end
)
3519 CHECK_NUMBER_COERCE_MARKER (start
);
3520 CHECK_NUMBER_COERCE_MARKER (end
);
3522 if (XINT (start
) > XINT (end
))
3525 tem
= start
; start
= end
; end
= tem
;
3528 if (!(BEG
<= XINT (start
) && XINT (start
) <= XINT (end
) && XINT (end
) <= Z
))
3529 args_out_of_range (start
, end
);
3531 if (BEGV
!= XFASTINT (start
) || ZV
!= XFASTINT (end
))
3532 current_buffer
->clip_changed
= 1;
3534 SET_BUF_BEGV (current_buffer
, XFASTINT (start
));
3535 SET_BUF_ZV (current_buffer
, XFASTINT (end
));
3536 if (PT
< XFASTINT (start
))
3537 SET_PT (XFASTINT (start
));
3538 if (PT
> XFASTINT (end
))
3539 SET_PT (XFASTINT (end
));
3540 /* Changing the buffer bounds invalidates any recorded current column. */
3541 invalidate_current_column ();
3546 save_restriction_save (void)
3548 if (BEGV
== BEG
&& ZV
== Z
)
3549 /* The common case that the buffer isn't narrowed.
3550 We return just the buffer object, which save_restriction_restore
3551 recognizes as meaning `no restriction'. */
3552 return Fcurrent_buffer ();
3554 /* We have to save a restriction, so return a pair of markers, one
3555 for the beginning and one for the end. */
3557 Lisp_Object beg
, end
;
3559 beg
= build_marker (current_buffer
, BEGV
, BEGV_BYTE
);
3560 end
= build_marker (current_buffer
, ZV
, ZV_BYTE
);
3562 /* END must move forward if text is inserted at its exact location. */
3563 XMARKER (end
)->insertion_type
= 1;
3565 return Fcons (beg
, end
);
3570 save_restriction_restore (Lisp_Object data
)
3572 struct buffer
*cur
= NULL
;
3573 struct buffer
*buf
= (CONSP (data
)
3574 ? XMARKER (XCAR (data
))->buffer
3577 if (buf
&& buf
!= current_buffer
&& !NILP (BVAR (buf
, pt_marker
)))
3578 { /* If `buf' uses markers to keep track of PT, BEGV, and ZV (as
3579 is the case if it is or has an indirect buffer), then make
3580 sure it is current before we update BEGV, so
3581 set_buffer_internal takes care of managing those markers. */
3582 cur
= current_buffer
;
3583 set_buffer_internal (buf
);
3587 /* A pair of marks bounding a saved restriction. */
3589 struct Lisp_Marker
*beg
= XMARKER (XCAR (data
));
3590 struct Lisp_Marker
*end
= XMARKER (XCDR (data
));
3591 eassert (buf
== end
->buffer
);
3593 if (buf
/* Verify marker still points to a buffer. */
3594 && (beg
->charpos
!= BUF_BEGV (buf
) || end
->charpos
!= BUF_ZV (buf
)))
3595 /* The restriction has changed from the saved one, so restore
3596 the saved restriction. */
3598 ptrdiff_t pt
= BUF_PT (buf
);
3600 SET_BUF_BEGV_BOTH (buf
, beg
->charpos
, beg
->bytepos
);
3601 SET_BUF_ZV_BOTH (buf
, end
->charpos
, end
->bytepos
);
3603 if (pt
< beg
->charpos
|| pt
> end
->charpos
)
3604 /* The point is outside the new visible range, move it inside. */
3605 SET_BUF_PT_BOTH (buf
,
3606 clip_to_bounds (beg
->charpos
, pt
, end
->charpos
),
3607 clip_to_bounds (beg
->bytepos
, BUF_PT_BYTE (buf
),
3610 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3612 /* These aren't needed anymore, so don't wait for GC. */
3613 free_marker (XCAR (data
));
3614 free_marker (XCDR (data
));
3615 free_cons (XCONS (data
));
3618 /* A buffer, which means that there was no old restriction. */
3620 if (buf
/* Verify marker still points to a buffer. */
3621 && (BUF_BEGV (buf
) != BUF_BEG (buf
) || BUF_ZV (buf
) != BUF_Z (buf
)))
3622 /* The buffer has been narrowed, get rid of the narrowing. */
3624 SET_BUF_BEGV_BOTH (buf
, BUF_BEG (buf
), BUF_BEG_BYTE (buf
));
3625 SET_BUF_ZV_BOTH (buf
, BUF_Z (buf
), BUF_Z_BYTE (buf
));
3627 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3631 /* Changing the buffer bounds invalidates any recorded current column. */
3632 invalidate_current_column ();
3635 set_buffer_internal (cur
);
3638 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
3639 doc
: /* Execute BODY, saving and restoring current buffer's restrictions.
3640 The buffer's restrictions make parts of the beginning and end invisible.
3641 \(They are set up with `narrow-to-region' and eliminated with `widen'.)
3642 This special form, `save-restriction', saves the current buffer's restrictions
3643 when it is entered, and restores them when it is exited.
3644 So any `narrow-to-region' within BODY lasts only until the end of the form.
3645 The old restrictions settings are restored
3646 even in case of abnormal exit (throw or error).
3648 The value returned is the value of the last form in BODY.
3650 Note: if you are using both `save-excursion' and `save-restriction',
3651 use `save-excursion' outermost:
3652 (save-excursion (save-restriction ...))
3654 usage: (save-restriction &rest BODY) */)
3657 register Lisp_Object val
;
3658 ptrdiff_t count
= SPECPDL_INDEX ();
3660 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
3661 val
= Fprogn (body
);
3662 return unbind_to (count
, val
);
3665 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
3666 doc
: /* Display a message at the bottom of the screen.
3667 The message also goes into the `*Messages*' buffer, if `message-log-max'
3668 is non-nil. (In keyboard macros, that's all it does.)
3671 In batch mode, the message is printed to the standard error stream,
3672 followed by a newline.
3674 The first argument is a format control string, and the rest are data
3675 to be formatted under control of the string. See `format-message' for
3678 Note: (message "%s" VALUE) displays the string VALUE without
3679 interpreting format characters like `%', `\\=`', and `\\=''.
3681 If the first argument is nil or the empty string, the function clears
3682 any existing message; this lets the minibuffer contents show. See
3683 also `current-message'.
3685 usage: (message FORMAT-STRING &rest ARGS) */)
3686 (ptrdiff_t nargs
, Lisp_Object
*args
)
3689 || (STRINGP (args
[0])
3690 && SBYTES (args
[0]) == 0))
3697 Lisp_Object val
= Fformat_message (nargs
, args
);
3703 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
3704 doc
: /* Display a message, in a dialog box if possible.
3705 If a dialog box is not available, use the echo area.
3706 The first argument is a format control string, and the rest are data
3707 to be formatted under control of the string. See `format-message' for
3710 If the first argument is nil or the empty string, clear any existing
3711 message; let the minibuffer contents show.
3713 usage: (message-box FORMAT-STRING &rest ARGS) */)
3714 (ptrdiff_t nargs
, Lisp_Object
*args
)
3723 Lisp_Object val
= Fformat_message (nargs
, args
);
3724 Lisp_Object pane
, menu
;
3726 pane
= list1 (Fcons (build_string ("OK"), Qt
));
3727 menu
= Fcons (val
, pane
);
3728 Fx_popup_dialog (Qt
, menu
, Qt
);
3733 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
3734 doc
: /* Display a message in a dialog box or in the echo area.
3735 If this command was invoked with the mouse, use a dialog box if
3736 `use-dialog-box' is non-nil.
3737 Otherwise, use the echo area.
3738 The first argument is a format control string, and the rest are data
3739 to be formatted under control of the string. See `format-message' for
3742 If the first argument is nil or the empty string, clear any existing
3743 message; let the minibuffer contents show.
3745 usage: (message-or-box FORMAT-STRING &rest ARGS) */)
3746 (ptrdiff_t nargs
, Lisp_Object
*args
)
3748 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3750 return Fmessage_box (nargs
, args
);
3751 return Fmessage (nargs
, args
);
3754 DEFUN ("current-message", Fcurrent_message
, Scurrent_message
, 0, 0, 0,
3755 doc
: /* Return the string currently displayed in the echo area, or nil if none. */)
3758 return current_message ();
3762 DEFUN ("propertize", Fpropertize
, Spropertize
, 1, MANY
, 0,
3763 doc
: /* Return a copy of STRING with text properties added.
3764 First argument is the string to copy.
3765 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
3766 properties to add to the result.
3767 usage: (propertize STRING &rest PROPERTIES) */)
3768 (ptrdiff_t nargs
, Lisp_Object
*args
)
3770 Lisp_Object properties
, string
;
3773 /* Number of args must be odd. */
3774 if ((nargs
& 1) == 0)
3775 error ("Wrong number of arguments");
3777 properties
= string
= Qnil
;
3779 /* First argument must be a string. */
3780 CHECK_STRING (args
[0]);
3781 string
= Fcopy_sequence (args
[0]);
3783 for (i
= 1; i
< nargs
; i
+= 2)
3784 properties
= Fcons (args
[i
], Fcons (args
[i
+ 1], properties
));
3786 Fadd_text_properties (make_number (0),
3787 make_number (SCHARS (string
)),
3788 properties
, string
);
3792 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
3793 doc
: /* Format a string out of a format-string and arguments.
3794 The first argument is a format control string.
3795 The other arguments are substituted into it to make the result, a string.
3797 The format control string may contain %-sequences meaning to substitute
3798 the next available argument:
3800 %s means print a string argument. Actually, prints any object, with `princ'.
3801 %d means print as number in decimal (%o octal, %x hex).
3802 %X is like %x, but uses upper case.
3803 %e means print a number in exponential notation.
3804 %f means print a number in decimal-point notation.
3805 %g means print a number in exponential notation
3806 or decimal-point notation, whichever uses fewer characters.
3807 %c means print a number as a single character.
3808 %S means print any object as an s-expression (using `prin1').
3810 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
3811 Use %% to put a single % into the output.
3813 A %-sequence may contain optional flag, width, and precision
3814 specifiers, as follows:
3816 %<flags><width><precision>character
3818 where flags is [+ #-0]+, width is [0-9]+, and precision is .[0-9]+
3820 The + flag character inserts a + before any positive number, while a
3821 space inserts a space before any positive number; these flags only
3822 affect %d, %e, %f, and %g sequences, and the + flag takes precedence.
3823 The - and 0 flags affect the width specifier, as described below.
3825 The # flag means to use an alternate display form for %o, %x, %X, %e,
3826 %f, and %g sequences: for %o, it ensures that the result begins with
3827 \"0\"; for %x and %X, it prefixes the result with \"0x\" or \"0X\";
3828 for %e, %f, and %g, it causes a decimal point to be included even if
3829 the precision is zero.
3831 The width specifier supplies a lower limit for the length of the
3832 printed representation. The padding, if any, normally goes on the
3833 left, but it goes on the right if the - flag is present. The padding
3834 character is normally a space, but it is 0 if the 0 flag is present.
3835 The 0 flag is ignored if the - flag is present, or the format sequence
3836 is something other than %d, %e, %f, and %g.
3838 For %e, %f, and %g sequences, the number after the "." in the
3839 precision specifier says how many decimal places to show; if zero, the
3840 decimal point itself is omitted. For %s and %S, the precision
3841 specifier truncates the string to the given width.
3843 usage: (format STRING &rest OBJECTS) */)
3844 (ptrdiff_t nargs
, Lisp_Object
*args
)
3846 return styled_format (nargs
, args
, false);
3849 DEFUN ("format-message", Fformat_message
, Sformat_message
, 1, MANY
, 0,
3850 doc
: /* Format a string out of a format-string and arguments.
3851 The first argument is a format control string.
3852 The other arguments are substituted into it to make the result, a string.
3854 This acts like `format', except it also replaces each left single
3855 quotation mark (\\=‘) and grave accent (\\=`) by a left quote, and each
3856 right single quotation mark (\\=’) and apostrophe (\\=') by a right quote.
3857 The left and right quote replacement characters are specified by
3858 `text-quoting-style'.
3860 usage: (format-message STRING &rest OBJECTS) */)
3861 (ptrdiff_t nargs
, Lisp_Object
*args
)
3863 return styled_format (nargs
, args
, true);
3866 /* Implement ‘format-message’ if MESSAGE is true, ‘format’ otherwise. */
3869 styled_format (ptrdiff_t nargs
, Lisp_Object
*args
, bool message
)
3871 ptrdiff_t n
; /* The number of the next arg to substitute. */
3872 char initial_buffer
[4000];
3873 char *buf
= initial_buffer
;
3874 ptrdiff_t bufsize
= sizeof initial_buffer
;
3875 ptrdiff_t max_bufsize
= STRING_BYTES_BOUND
+ 1;
3877 ptrdiff_t buf_save_value_index
IF_LINT (= 0);
3880 /* When we make a multibyte string, we must pay attention to the
3881 byte combining problem, i.e., a byte may be combined with a
3882 multibyte character of the previous string. This flag tells if we
3883 must consider such a situation or not. */
3884 bool maybe_combine_byte
;
3885 bool arg_intervals
= false;
3888 /* Each element records, for one argument,
3889 the start and end bytepos in the output string,
3890 whether the argument has been converted to string (e.g., due to "%S"),
3891 and whether the argument is a string with intervals. */
3894 ptrdiff_t start
, end
;
3895 bool_bf converted_to_string
: 1;
3896 bool_bf intervals
: 1;
3899 CHECK_STRING (args
[0]);
3900 char *format_start
= SSDATA (args
[0]);
3901 ptrdiff_t formatlen
= SBYTES (args
[0]);
3903 /* Allocate the info and discarded tables. */
3904 ptrdiff_t alloca_size
;
3905 if (INT_MULTIPLY_WRAPV (nargs
, sizeof *info
, &alloca_size
)
3906 || INT_ADD_WRAPV (sizeof *info
, alloca_size
, &alloca_size
)
3907 || INT_ADD_WRAPV (formatlen
, alloca_size
, &alloca_size
)
3908 || SIZE_MAX
< alloca_size
)
3909 memory_full (SIZE_MAX
);
3910 /* info[0] is unused. Unused elements have -1 for start. */
3911 info
= SAFE_ALLOCA (alloca_size
);
3912 memset (info
, 0, alloca_size
);
3913 for (ptrdiff_t i
= 0; i
< nargs
+ 1; i
++)
3915 /* discarded[I] is 1 if byte I of the format
3916 string was not copied into the output.
3917 It is 2 if byte I was not the first byte of its character. */
3918 char *discarded
= (char *) &info
[nargs
+ 1];
3920 /* Try to determine whether the result should be multibyte.
3921 This is not always right; sometimes the result needs to be multibyte
3922 because of an object that we will pass through prin1.
3923 or because a grave accent or apostrophe is requoted,
3924 and in that case, we won't know it here. */
3926 /* True if the format is multibyte. */
3927 bool multibyte_format
= STRING_MULTIBYTE (args
[0]);
3928 /* True if the output should be a multibyte string,
3929 which is true if any of the inputs is one. */
3930 bool multibyte
= multibyte_format
;
3931 for (ptrdiff_t i
= 1; !multibyte
&& i
< nargs
; i
++)
3932 if (STRINGP (args
[i
]) && STRING_MULTIBYTE (args
[i
]))
3935 int quoting_style
= message
? text_quoting_style () : -1;
3937 /* If we start out planning a unibyte result,
3938 then discover it has to be multibyte, we jump back to retry. */
3945 /* Scan the format and store result in BUF. */
3946 format
= format_start
;
3947 end
= format
+ formatlen
;
3948 maybe_combine_byte
= false;
3950 while (format
!= end
)
3952 /* The values of N and FORMAT when the loop body is entered. */
3954 char *format0
= format
;
3955 char const *convsrc
= format
;
3956 unsigned char format_char
= *format
++;
3958 /* Bytes needed to represent the output of this conversion. */
3959 ptrdiff_t convbytes
= 1;
3961 if (format_char
== '%')
3963 /* General format specifications look like
3965 '%' [flags] [field-width] [precision] format
3970 field-width ::= [0-9]+
3971 precision ::= '.' [0-9]*
3973 If a field-width is specified, it specifies to which width
3974 the output should be padded with blanks, if the output
3975 string is shorter than field-width.
3977 If precision is specified, it specifies the number of
3978 digits to print after the '.' for floats, or the max.
3979 number of chars to print from a string. */
3981 bool minus_flag
= false;
3982 bool plus_flag
= false;
3983 bool space_flag
= false;
3984 bool sharp_flag
= false;
3985 bool zero_flag
= false;
3991 case '-': minus_flag
= true; continue;
3992 case '+': plus_flag
= true; continue;
3993 case ' ': space_flag
= true; continue;
3994 case '#': sharp_flag
= true; continue;
3995 case '0': zero_flag
= true; continue;
4000 /* Ignore flags when sprintf ignores them. */
4001 space_flag
&= ~ plus_flag
;
4002 zero_flag
&= ~ minus_flag
;
4005 uintmax_t raw_field_width
= strtoumax (format
, &num_end
, 10);
4006 if (max_bufsize
<= raw_field_width
)
4008 ptrdiff_t field_width
= raw_field_width
;
4010 bool precision_given
= *num_end
== '.';
4011 uintmax_t precision
= (precision_given
4012 ? strtoumax (num_end
+ 1, &num_end
, 10)
4017 error ("Format string ends in middle of format specifier");
4019 char conversion
= *format
++;
4020 memset (&discarded
[format0
- format_start
], 1,
4021 format
- format0
- (conversion
== '%'));
4022 if (conversion
== '%')
4027 error ("Not enough arguments for format string");
4029 /* For 'S', prin1 the argument, and then treat like 's'.
4030 For 's', princ any argument that is not a string or
4031 symbol. But don't do this conversion twice, which might
4032 happen after retrying. */
4033 if ((conversion
== 'S'
4034 || (conversion
== 's'
4035 && ! STRINGP (args
[n
]) && ! SYMBOLP (args
[n
]))))
4037 if (! info
[n
].converted_to_string
)
4039 Lisp_Object noescape
= conversion
== 'S' ? Qnil
: Qt
;
4040 args
[n
] = Fprin1_to_string (args
[n
], noescape
);
4041 info
[n
].converted_to_string
= true;
4042 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
4050 else if (conversion
== 'c')
4052 if (FLOATP (args
[n
]))
4054 double d
= XFLOAT_DATA (args
[n
]);
4055 args
[n
] = make_number (FIXNUM_OVERFLOW_P (d
) ? -1 : d
);
4058 if (INTEGERP (args
[n
]) && ! ASCII_CHAR_P (XINT (args
[n
])))
4065 args
[n
] = Fchar_to_string (args
[n
]);
4066 info
[n
].converted_to_string
= true;
4069 if (info
[n
].converted_to_string
)
4074 if (SYMBOLP (args
[n
]))
4076 args
[n
] = SYMBOL_NAME (args
[n
]);
4077 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
4084 if (conversion
== 's')
4086 /* handle case (precision[n] >= 0) */
4088 ptrdiff_t prec
= -1;
4089 if (precision_given
&& precision
<= TYPE_MAXIMUM (ptrdiff_t))
4092 /* lisp_string_width ignores a precision of 0, but GNU
4093 libc functions print 0 characters when the precision
4094 is 0. Imitate libc behavior here. Changing
4095 lisp_string_width is the right thing, and will be
4096 done, but meanwhile we work with it. */
4098 ptrdiff_t width
, nbytes
;
4099 ptrdiff_t nchars_string
;
4101 width
= nchars_string
= nbytes
= 0;
4105 width
= lisp_string_width (args
[n
], prec
, &nch
, &nby
);
4108 nchars_string
= SCHARS (args
[n
]);
4109 nbytes
= SBYTES (args
[n
]);
4113 nchars_string
= nch
;
4119 if (convbytes
&& multibyte
&& ! STRING_MULTIBYTE (args
[n
]))
4120 convbytes
= count_size_as_multibyte (SDATA (args
[n
]), nbytes
);
4123 = width
< field_width
? field_width
- width
: 0;
4125 if (max_bufsize
- padding
<= convbytes
)
4127 convbytes
+= padding
;
4128 if (convbytes
<= buf
+ bufsize
- p
)
4132 memset (p
, ' ', padding
);
4139 && !ASCII_CHAR_P (*((unsigned char *) p
- 1))
4140 && STRING_MULTIBYTE (args
[n
])
4141 && !CHAR_HEAD_P (SREF (args
[n
], 0)))
4142 maybe_combine_byte
= true;
4144 p
+= copy_text (SDATA (args
[n
]), (unsigned char *) p
,
4146 STRING_MULTIBYTE (args
[n
]), multibyte
);
4148 info
[n
].start
= nchars
;
4149 nchars
+= nchars_string
;
4150 info
[n
].end
= nchars
;
4154 memset (p
, ' ', padding
);
4159 /* If this argument has text properties, record where
4160 in the result string it appears. */
4161 if (string_intervals (args
[n
]))
4162 info
[n
].intervals
= arg_intervals
= true;
4167 else if (! (conversion
== 'c' || conversion
== 'd'
4168 || conversion
== 'e' || conversion
== 'f'
4169 || conversion
== 'g' || conversion
== 'i'
4170 || conversion
== 'o' || conversion
== 'x'
4171 || conversion
== 'X'))
4172 error ("Invalid format operation %%%c",
4173 STRING_CHAR ((unsigned char *) format
- 1));
4174 else if (! NUMBERP (args
[n
]))
4175 error ("Format specifier doesn't match argument type");
4180 /* Maximum precision for a %f conversion such that the
4181 trailing output digit might be nonzero. Any precision
4182 larger than this will not yield useful information. */
4183 USEFUL_PRECISION_MAX
=
4185 * (FLT_RADIX
== 2 || FLT_RADIX
== 10 ? 1
4186 : FLT_RADIX
== 16 ? 4
4189 /* Maximum number of bytes generated by any format, if
4190 precision is no more than USEFUL_PRECISION_MAX.
4191 On all practical hosts, %f is the worst case. */
4193 sizeof "-." + (DBL_MAX_10_EXP
+ 1) + USEFUL_PRECISION_MAX
,
4195 /* Length of pM (that is, of pMd without the
4197 pMlen
= sizeof pMd
- 2
4199 verify (USEFUL_PRECISION_MAX
> 0);
4201 /* Avoid undefined behavior in underlying sprintf. */
4202 if (conversion
== 'd' || conversion
== 'i')
4205 /* Create the copy of the conversion specification, with
4206 any width and precision removed, with ".*" inserted,
4207 and with pM inserted for integer formats.
4208 At most three flags F can be specified at once. */
4209 char convspec
[sizeof "%FFF.*d" + pMlen
];
4213 *f
= '-'; f
+= minus_flag
;
4214 *f
= '+'; f
+= plus_flag
;
4215 *f
= ' '; f
+= space_flag
;
4216 *f
= '#'; f
+= sharp_flag
;
4217 *f
= '0'; f
+= zero_flag
;
4220 if (conversion
== 'd' || conversion
== 'i'
4221 || conversion
== 'o' || conversion
== 'x'
4222 || conversion
== 'X')
4224 memcpy (f
, pMd
, pMlen
);
4226 zero_flag
&= ~ precision_given
;
4233 if (precision_given
)
4234 prec
= min (precision
, USEFUL_PRECISION_MAX
);
4236 /* Use sprintf to format this number into sprintf_buf. Omit
4237 padding and excess precision, though, because sprintf limits
4238 output length to INT_MAX.
4240 There are four types of conversion: double, unsigned
4241 char (passed as int), wide signed int, and wide
4242 unsigned int. Treat them separately because the
4243 sprintf ABI is sensitive to which type is passed. Be
4244 careful about integer overflow, NaNs, infinities, and
4245 conversions; for example, the min and max macros are
4246 not suitable here. */
4247 char sprintf_buf
[SPRINTF_BUFSIZE
];
4248 ptrdiff_t sprintf_bytes
;
4249 if (conversion
== 'e' || conversion
== 'f' || conversion
== 'g')
4251 double x
= (INTEGERP (args
[n
])
4253 : XFLOAT_DATA (args
[n
]));
4254 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4256 else if (conversion
== 'c')
4258 /* Don't use sprintf here, as it might mishandle prec. */
4259 sprintf_buf
[0] = XINT (args
[n
]);
4260 sprintf_bytes
= prec
!= 0;
4262 else if (conversion
== 'd')
4264 /* For float, maybe we should use "%1.0f"
4265 instead so it also works for values outside
4266 the integer range. */
4268 if (INTEGERP (args
[n
]))
4272 double d
= XFLOAT_DATA (args
[n
]);
4275 x
= TYPE_MINIMUM (printmax_t
);
4281 x
= TYPE_MAXIMUM (printmax_t
);
4286 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4290 /* Don't sign-extend for octal or hex printing. */
4292 if (INTEGERP (args
[n
]))
4293 x
= XUINT (args
[n
]);
4296 double d
= XFLOAT_DATA (args
[n
]);
4301 x
= TYPE_MAXIMUM (uprintmax_t
);
4306 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4309 /* Now the length of the formatted item is known, except it omits
4310 padding and excess precision. Deal with excess precision
4311 first. This happens only when the format specifies
4312 ridiculously large precision. */
4313 uintmax_t excess_precision
= precision
- prec
;
4314 uintmax_t leading_zeros
= 0, trailing_zeros
= 0;
4315 if (excess_precision
)
4317 if (conversion
== 'e' || conversion
== 'f'
4318 || conversion
== 'g')
4320 if ((conversion
== 'g' && ! sharp_flag
)
4321 || ! ('0' <= sprintf_buf
[sprintf_bytes
- 1]
4322 && sprintf_buf
[sprintf_bytes
- 1] <= '9'))
4323 excess_precision
= 0;
4326 if (conversion
== 'g')
4328 char *dot
= strchr (sprintf_buf
, '.');
4330 excess_precision
= 0;
4333 trailing_zeros
= excess_precision
;
4336 leading_zeros
= excess_precision
;
4339 /* Compute the total bytes needed for this item, including
4340 excess precision and padding. */
4341 uintmax_t numwidth
= sprintf_bytes
+ excess_precision
;
4343 = numwidth
< field_width
? field_width
- numwidth
: 0;
4344 if (max_bufsize
- sprintf_bytes
<= excess_precision
4345 || max_bufsize
- padding
<= numwidth
)
4347 convbytes
= numwidth
+ padding
;
4349 if (convbytes
<= buf
+ bufsize
- p
)
4351 /* Copy the formatted item from sprintf_buf into buf,
4352 inserting padding and excess-precision zeros. */
4354 char *src
= sprintf_buf
;
4356 int exponent_bytes
= 0;
4357 bool signedp
= src0
== '-' || src0
== '+' || src0
== ' ';
4359 && ((src
[signedp
] >= '0' && src
[signedp
] <= '9')
4360 || (src
[signedp
] >= 'a' && src
[signedp
] <= 'f')
4361 || (src
[signedp
] >= 'A' && src
[signedp
] <= 'F')))
4363 leading_zeros
+= padding
;
4367 if (excess_precision
4368 && (conversion
== 'e' || conversion
== 'g'))
4370 char *e
= strchr (src
, 'e');
4372 exponent_bytes
= src
+ sprintf_bytes
- e
;
4377 memset (p
, ' ', padding
);
4385 memset (p
, '0', leading_zeros
);
4387 int significand_bytes
4388 = sprintf_bytes
- signedp
- exponent_bytes
;
4389 memcpy (p
, src
, significand_bytes
);
4390 p
+= significand_bytes
;
4391 src
+= significand_bytes
;
4392 memset (p
, '0', trailing_zeros
);
4393 p
+= trailing_zeros
;
4394 memcpy (p
, src
, exponent_bytes
);
4395 p
+= exponent_bytes
;
4397 info
[n
].start
= nchars
;
4398 nchars
+= leading_zeros
+ sprintf_bytes
+ trailing_zeros
;
4399 info
[n
].end
= nchars
;
4403 memset (p
, ' ', padding
);
4414 /* Named constants for the UTF-8 encodings of U+2018 LEFT SINGLE
4415 QUOTATION MARK and U+2019 RIGHT SINGLE QUOTATION MARK. */
4418 uLSQM0
= 0xE2, uLSQM1
= 0x80, uLSQM2
= 0x98,
4419 /* uRSQM0 = 0xE2, uRSQM1 = 0x80, */ uRSQM2
= 0x99
4422 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
4424 if ((format_char
== '`' || format_char
== '\'')
4425 && quoting_style
== CURVE_QUOTING_STYLE
)
4432 convsrc
= format_char
== '`' ? uLSQM
: uRSQM
;
4435 else if (format_char
== '`' && quoting_style
== STRAIGHT_QUOTING_STYLE
)
4437 else if (format_char
== uLSQM0
&& CURVE_QUOTING_STYLE
< quoting_style
4439 && (unsigned char) format
[0] == uLSQM1
4440 && ((unsigned char) format
[1] == uLSQM2
4441 || (unsigned char) format
[1] == uRSQM2
))
4443 convsrc
= (((unsigned char) format
[1] == uLSQM2
4444 && quoting_style
== GRAVE_QUOTING_STYLE
)
4447 memset (&discarded
[format0
+ 1 - format_start
], 2, 2);
4451 /* Copy a single character from format to buf. */
4452 if (multibyte_format
)
4454 /* Copy a whole multibyte character. */
4456 && !ASCII_CHAR_P (*((unsigned char *) p
- 1))
4457 && !CHAR_HEAD_P (format_char
))
4458 maybe_combine_byte
= true;
4460 while (! CHAR_HEAD_P (*format
))
4463 convbytes
= format
- format0
;
4464 memset (&discarded
[format0
+ 1 - format_start
], 2,
4467 else if (multibyte
&& !ASCII_CHAR_P (format_char
))
4469 int c
= BYTE8_TO_CHAR (format_char
);
4470 convbytes
= CHAR_STRING (c
, str
);
4471 convsrc
= (char *) str
;
4476 if (convbytes
<= buf
+ bufsize
- p
)
4478 memcpy (p
, convsrc
, convbytes
);
4485 /* There wasn't enough room to store this conversion or single
4486 character. CONVBYTES says how much room is needed. Allocate
4487 enough room (and then some) and do it again. */
4489 ptrdiff_t used
= p
- buf
;
4490 if (max_bufsize
- used
< convbytes
)
4492 bufsize
= used
+ convbytes
;
4493 bufsize
= bufsize
< max_bufsize
/ 2 ? bufsize
* 2 : max_bufsize
;
4495 if (buf
== initial_buffer
)
4497 buf
= xmalloc (bufsize
);
4498 sa_must_free
= true;
4499 buf_save_value_index
= SPECPDL_INDEX ();
4500 record_unwind_protect_ptr (xfree
, buf
);
4501 memcpy (buf
, initial_buffer
, used
);
4505 buf
= xrealloc (buf
, bufsize
);
4506 set_unwind_protect_ptr (buf_save_value_index
, xfree
, buf
);
4514 if (bufsize
< p
- buf
)
4517 if (maybe_combine_byte
)
4518 nchars
= multibyte_chars_in_text ((unsigned char *) buf
, p
- buf
);
4519 Lisp_Object val
= make_specified_string (buf
, nchars
, p
- buf
, multibyte
);
4521 /* If the format string has text properties, or any of the string
4522 arguments has text properties, set up text properties of the
4525 if (string_intervals (args
[0]) || arg_intervals
)
4527 /* Add text properties from the format string. */
4528 Lisp_Object len
= make_number (SCHARS (args
[0]));
4529 Lisp_Object props
= text_property_list (args
[0], make_number (0),
4533 ptrdiff_t bytepos
= 0, position
= 0, translated
= 0;
4536 /* Adjust the bounds of each text property
4537 to the proper start and end in the output string. */
4539 /* Put the positions in PROPS in increasing order, so that
4540 we can do (effectively) one scan through the position
4541 space of the format string. */
4542 props
= Fnreverse (props
);
4544 /* BYTEPOS is the byte position in the format string,
4545 POSITION is the untranslated char position in it,
4546 TRANSLATED is the translated char position in BUF,
4547 and ARGN is the number of the next arg we will come to. */
4548 for (Lisp_Object list
= props
; CONSP (list
); list
= XCDR (list
))
4550 Lisp_Object item
= XCAR (list
);
4552 /* First adjust the property start position. */
4553 ptrdiff_t pos
= XINT (XCAR (item
));
4555 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
4556 up to this position. */
4557 for (; position
< pos
; bytepos
++)
4559 if (! discarded
[bytepos
])
4560 position
++, translated
++;
4561 else if (discarded
[bytepos
] == 1)
4564 if (translated
== info
[argn
].start
)
4566 translated
+= info
[argn
].end
- info
[argn
].start
;
4572 XSETCAR (item
, make_number (translated
));
4574 /* Likewise adjust the property end position. */
4575 pos
= XINT (XCAR (XCDR (item
)));
4577 for (; position
< pos
; bytepos
++)
4579 if (! discarded
[bytepos
])
4580 position
++, translated
++;
4581 else if (discarded
[bytepos
] == 1)
4584 if (translated
== info
[argn
].start
)
4586 translated
+= info
[argn
].end
- info
[argn
].start
;
4592 XSETCAR (XCDR (item
), make_number (translated
));
4595 add_text_properties_from_list (val
, props
, make_number (0));
4598 /* Add text properties from arguments. */
4600 for (ptrdiff_t i
= 1; i
< nargs
; i
++)
4601 if (info
[i
].intervals
)
4603 len
= make_number (SCHARS (args
[i
]));
4604 Lisp_Object new_len
= make_number (info
[i
].end
- info
[i
].start
);
4605 props
= text_property_list (args
[i
], make_number (0), len
, Qnil
);
4606 props
= extend_property_ranges (props
, new_len
);
4607 /* If successive arguments have properties, be sure that
4608 the value of `composition' property be the copy. */
4609 if (1 < i
&& info
[i
- 1].end
)
4610 make_composition_value_copy (props
);
4611 add_text_properties_from_list (val
, props
,
4612 make_number (info
[i
].start
));
4616 /* If we allocated BUF or INFO with malloc, free it too. */
4622 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
4623 doc
: /* Return t if two characters match, optionally ignoring case.
4624 Both arguments must be characters (i.e. integers).
4625 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
4626 (register Lisp_Object c1
, Lisp_Object c2
)
4629 /* Check they're chars, not just integers, otherwise we could get array
4630 bounds violations in downcase. */
4631 CHECK_CHARACTER (c1
);
4632 CHECK_CHARACTER (c2
);
4634 if (XINT (c1
) == XINT (c2
))
4636 if (NILP (BVAR (current_buffer
, case_fold_search
)))
4642 /* FIXME: It is possible to compare multibyte characters even when
4643 the current buffer is unibyte. Unfortunately this is ambiguous
4644 for characters between 128 and 255, as they could be either
4645 eight-bit raw bytes or Latin-1 characters. Assume the former for
4646 now. See Bug#17011, and also see casefiddle.c's casify_object,
4647 which has a similar problem. */
4648 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4650 if (SINGLE_BYTE_CHAR_P (i1
))
4651 i1
= UNIBYTE_TO_CHAR (i1
);
4652 if (SINGLE_BYTE_CHAR_P (i2
))
4653 i2
= UNIBYTE_TO_CHAR (i2
);
4656 return (downcase (i1
) == downcase (i2
) ? Qt
: Qnil
);
4659 /* Transpose the markers in two regions of the current buffer, and
4660 adjust the ones between them if necessary (i.e.: if the regions
4663 START1, END1 are the character positions of the first region.
4664 START1_BYTE, END1_BYTE are the byte positions.
4665 START2, END2 are the character positions of the second region.
4666 START2_BYTE, END2_BYTE are the byte positions.
4668 Traverses the entire marker list of the buffer to do so, adding an
4669 appropriate amount to some, subtracting from some, and leaving the
4670 rest untouched. Most of this is copied from adjust_markers in insdel.c.
4672 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
4675 transpose_markers (ptrdiff_t start1
, ptrdiff_t end1
,
4676 ptrdiff_t start2
, ptrdiff_t end2
,
4677 ptrdiff_t start1_byte
, ptrdiff_t end1_byte
,
4678 ptrdiff_t start2_byte
, ptrdiff_t end2_byte
)
4680 register ptrdiff_t amt1
, amt1_byte
, amt2
, amt2_byte
, diff
, diff_byte
, mpos
;
4681 register struct Lisp_Marker
*marker
;
4683 /* Update point as if it were a marker. */
4687 TEMP_SET_PT_BOTH (PT
+ (end2
- end1
),
4688 PT_BYTE
+ (end2_byte
- end1_byte
));
4689 else if (PT
< start2
)
4690 TEMP_SET_PT_BOTH (PT
+ (end2
- start2
) - (end1
- start1
),
4691 (PT_BYTE
+ (end2_byte
- start2_byte
)
4692 - (end1_byte
- start1_byte
)));
4694 TEMP_SET_PT_BOTH (PT
- (start2
- start1
),
4695 PT_BYTE
- (start2_byte
- start1_byte
));
4697 /* We used to adjust the endpoints here to account for the gap, but that
4698 isn't good enough. Even if we assume the caller has tried to move the
4699 gap out of our way, it might still be at start1 exactly, for example;
4700 and that places it `inside' the interval, for our purposes. The amount
4701 of adjustment is nontrivial if there's a `denormalized' marker whose
4702 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
4703 the dirty work to Fmarker_position, below. */
4705 /* The difference between the region's lengths */
4706 diff
= (end2
- start2
) - (end1
- start1
);
4707 diff_byte
= (end2_byte
- start2_byte
) - (end1_byte
- start1_byte
);
4709 /* For shifting each marker in a region by the length of the other
4710 region plus the distance between the regions. */
4711 amt1
= (end2
- start2
) + (start2
- end1
);
4712 amt2
= (end1
- start1
) + (start2
- end1
);
4713 amt1_byte
= (end2_byte
- start2_byte
) + (start2_byte
- end1_byte
);
4714 amt2_byte
= (end1_byte
- start1_byte
) + (start2_byte
- end1_byte
);
4716 for (marker
= BUF_MARKERS (current_buffer
); marker
; marker
= marker
->next
)
4718 mpos
= marker
->bytepos
;
4719 if (mpos
>= start1_byte
&& mpos
< end2_byte
)
4721 if (mpos
< end1_byte
)
4723 else if (mpos
< start2_byte
)
4727 marker
->bytepos
= mpos
;
4729 mpos
= marker
->charpos
;
4730 if (mpos
>= start1
&& mpos
< end2
)
4734 else if (mpos
< start2
)
4739 marker
->charpos
= mpos
;
4743 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
4744 doc
: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
4745 The regions should not be overlapping, because the size of the buffer is
4746 never changed in a transposition.
4748 Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
4749 any markers that happen to be located in the regions.
4751 Transposing beyond buffer boundaries is an error. */)
4752 (Lisp_Object startr1
, Lisp_Object endr1
, Lisp_Object startr2
, Lisp_Object endr2
, Lisp_Object leave_markers
)
4754 register ptrdiff_t start1
, end1
, start2
, end2
;
4755 ptrdiff_t start1_byte
, start2_byte
, len1_byte
, len2_byte
, end2_byte
;
4756 ptrdiff_t gap
, len1
, len_mid
, len2
;
4757 unsigned char *start1_addr
, *start2_addr
, *temp
;
4759 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
, tmp_interval3
;
4762 XSETBUFFER (buf
, current_buffer
);
4763 cur_intv
= buffer_intervals (current_buffer
);
4765 validate_region (&startr1
, &endr1
);
4766 validate_region (&startr2
, &endr2
);
4768 start1
= XFASTINT (startr1
);
4769 end1
= XFASTINT (endr1
);
4770 start2
= XFASTINT (startr2
);
4771 end2
= XFASTINT (endr2
);
4774 /* Swap the regions if they're reversed. */
4777 register ptrdiff_t glumph
= start1
;
4785 len1
= end1
- start1
;
4786 len2
= end2
- start2
;
4789 error ("Transposed regions overlap");
4790 /* Nothing to change for adjacent regions with one being empty */
4791 else if ((start1
== end1
|| start2
== end2
) && end1
== start2
)
4794 /* The possibilities are:
4795 1. Adjacent (contiguous) regions, or separate but equal regions
4796 (no, really equal, in this case!), or
4797 2. Separate regions of unequal size.
4799 The worst case is usually No. 2. It means that (aside from
4800 potential need for getting the gap out of the way), there also
4801 needs to be a shifting of the text between the two regions. So
4802 if they are spread far apart, we are that much slower... sigh. */
4804 /* It must be pointed out that the really studly thing to do would
4805 be not to move the gap at all, but to leave it in place and work
4806 around it if necessary. This would be extremely efficient,
4807 especially considering that people are likely to do
4808 transpositions near where they are working interactively, which
4809 is exactly where the gap would be found. However, such code
4810 would be much harder to write and to read. So, if you are
4811 reading this comment and are feeling squirrely, by all means have
4812 a go! I just didn't feel like doing it, so I will simply move
4813 the gap the minimum distance to get it out of the way, and then
4814 deal with an unbroken array. */
4816 start1_byte
= CHAR_TO_BYTE (start1
);
4817 end2_byte
= CHAR_TO_BYTE (end2
);
4819 /* Make sure the gap won't interfere, by moving it out of the text
4820 we will operate on. */
4821 if (start1
< gap
&& gap
< end2
)
4823 if (gap
- start1
< end2
- gap
)
4824 move_gap_both (start1
, start1_byte
);
4826 move_gap_both (end2
, end2_byte
);
4829 start2_byte
= CHAR_TO_BYTE (start2
);
4830 len1_byte
= CHAR_TO_BYTE (end1
) - start1_byte
;
4831 len2_byte
= end2_byte
- start2_byte
;
4833 #ifdef BYTE_COMBINING_DEBUG
4836 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4837 len2_byte
, start1
, start1_byte
)
4838 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4839 len1_byte
, end2
, start2_byte
+ len2_byte
)
4840 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4841 len1_byte
, end2
, start2_byte
+ len2_byte
))
4846 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4847 len2_byte
, start1
, start1_byte
)
4848 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4849 len1_byte
, start2
, start2_byte
)
4850 || count_combining_after (BYTE_POS_ADDR (start2_byte
),
4851 len2_byte
, end1
, start1_byte
+ len1_byte
)
4852 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4853 len1_byte
, end2
, start2_byte
+ len2_byte
))
4858 /* Hmmm... how about checking to see if the gap is large
4859 enough to use as the temporary storage? That would avoid an
4860 allocation... interesting. Later, don't fool with it now. */
4862 /* Working without memmove, for portability (sigh), so must be
4863 careful of overlapping subsections of the array... */
4865 if (end1
== start2
) /* adjacent regions */
4867 modify_text (start1
, end2
);
4868 record_change (start1
, len1
+ len2
);
4870 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4871 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4872 /* Don't use Fset_text_properties: that can cause GC, which can
4873 clobber objects stored in the tmp_intervals. */
4874 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4876 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4880 /* First region smaller than second. */
4881 if (len1_byte
< len2_byte
)
4883 temp
= SAFE_ALLOCA (len2_byte
);
4885 /* Don't precompute these addresses. We have to compute them
4886 at the last minute, because the relocating allocator might
4887 have moved the buffer around during the xmalloc. */
4888 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4889 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4891 memcpy (temp
, start2_addr
, len2_byte
);
4892 memcpy (start1_addr
+ len2_byte
, start1_addr
, len1_byte
);
4893 memcpy (start1_addr
, temp
, len2_byte
);
4896 /* First region not smaller than second. */
4898 temp
= SAFE_ALLOCA (len1_byte
);
4899 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4900 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4901 memcpy (temp
, start1_addr
, len1_byte
);
4902 memcpy (start1_addr
, start2_addr
, len2_byte
);
4903 memcpy (start1_addr
+ len2_byte
, temp
, len1_byte
);
4907 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
4908 len1
, current_buffer
, 0);
4909 graft_intervals_into_buffer (tmp_interval2
, start1
,
4910 len2
, current_buffer
, 0);
4911 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4912 update_compositions (start1
+ len2
, end2
, CHECK_TAIL
);
4914 /* Non-adjacent regions, because end1 != start2, bleagh... */
4917 len_mid
= start2_byte
- (start1_byte
+ len1_byte
);
4919 if (len1_byte
== len2_byte
)
4920 /* Regions are same size, though, how nice. */
4924 modify_text (start1
, end1
);
4925 modify_text (start2
, end2
);
4926 record_change (start1
, len1
);
4927 record_change (start2
, len2
);
4928 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4929 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4931 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr1
, 0);
4933 set_text_properties_1 (startr1
, endr1
, Qnil
, buf
, tmp_interval3
);
4935 tmp_interval3
= validate_interval_range (buf
, &startr2
, &endr2
, 0);
4937 set_text_properties_1 (startr2
, endr2
, Qnil
, buf
, tmp_interval3
);
4939 temp
= SAFE_ALLOCA (len1_byte
);
4940 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4941 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4942 memcpy (temp
, start1_addr
, len1_byte
);
4943 memcpy (start1_addr
, start2_addr
, len2_byte
);
4944 memcpy (start2_addr
, temp
, len1_byte
);
4947 graft_intervals_into_buffer (tmp_interval1
, start2
,
4948 len1
, current_buffer
, 0);
4949 graft_intervals_into_buffer (tmp_interval2
, start1
,
4950 len2
, current_buffer
, 0);
4953 else if (len1_byte
< len2_byte
) /* Second region larger than first */
4954 /* Non-adjacent & unequal size, area between must also be shifted. */
4958 modify_text (start1
, end2
);
4959 record_change (start1
, (end2
- start1
));
4960 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4961 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4962 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4964 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4966 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4968 /* holds region 2 */
4969 temp
= SAFE_ALLOCA (len2_byte
);
4970 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4971 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4972 memcpy (temp
, start2_addr
, len2_byte
);
4973 memcpy (start1_addr
+ len_mid
+ len2_byte
, start1_addr
, len1_byte
);
4974 memmove (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
4975 memcpy (start1_addr
, temp
, len2_byte
);
4978 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4979 len1
, current_buffer
, 0);
4980 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4981 len_mid
, current_buffer
, 0);
4982 graft_intervals_into_buffer (tmp_interval2
, start1
,
4983 len2
, current_buffer
, 0);
4986 /* Second region smaller than first. */
4990 record_change (start1
, (end2
- start1
));
4991 modify_text (start1
, end2
);
4993 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4994 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4995 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4997 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4999 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
5001 /* holds region 1 */
5002 temp
= SAFE_ALLOCA (len1_byte
);
5003 start1_addr
= BYTE_POS_ADDR (start1_byte
);
5004 start2_addr
= BYTE_POS_ADDR (start2_byte
);
5005 memcpy (temp
, start1_addr
, len1_byte
);
5006 memcpy (start1_addr
, start2_addr
, len2_byte
);
5007 memmove (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
5008 memcpy (start1_addr
+ len2_byte
+ len_mid
, temp
, len1_byte
);
5011 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
5012 len1
, current_buffer
, 0);
5013 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
5014 len_mid
, current_buffer
, 0);
5015 graft_intervals_into_buffer (tmp_interval2
, start1
,
5016 len2
, current_buffer
, 0);
5019 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
5020 update_compositions (end2
- len1
, end2
, CHECK_BORDER
);
5023 /* When doing multiple transpositions, it might be nice
5024 to optimize this. Perhaps the markers in any one buffer
5025 should be organized in some sorted data tree. */
5026 if (NILP (leave_markers
))
5028 transpose_markers (start1
, end1
, start2
, end2
,
5029 start1_byte
, start1_byte
+ len1_byte
,
5030 start2_byte
, start2_byte
+ len2_byte
);
5031 fix_start_end_in_overlays (start1
, end2
);
5034 signal_after_change (start1
, end2
- start1
, end2
- start1
);
5040 syms_of_editfns (void)
5042 DEFSYM (Qbuffer_access_fontify_functions
, "buffer-access-fontify-functions");
5043 DEFSYM (Qwall
, "wall");
5045 DEFVAR_LISP ("inhibit-field-text-motion", Vinhibit_field_text_motion
,
5046 doc
: /* Non-nil means text motion commands don't notice fields. */);
5047 Vinhibit_field_text_motion
= Qnil
;
5049 DEFVAR_LISP ("buffer-access-fontify-functions",
5050 Vbuffer_access_fontify_functions
,
5051 doc
: /* List of functions called by `buffer-substring' to fontify if necessary.
5052 Each function is called with two arguments which specify the range
5053 of the buffer being accessed. */);
5054 Vbuffer_access_fontify_functions
= Qnil
;
5058 obuf
= Fcurrent_buffer ();
5059 /* Do this here, because init_buffer_once is too early--it won't work. */
5060 Fset_buffer (Vprin1_to_string_buffer
);
5061 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
5062 Fset (Fmake_local_variable (Qbuffer_access_fontify_functions
), Qnil
);
5066 DEFVAR_LISP ("buffer-access-fontified-property",
5067 Vbuffer_access_fontified_property
,
5068 doc
: /* Property which (if non-nil) indicates text has been fontified.
5069 `buffer-substring' need not call the `buffer-access-fontify-functions'
5070 functions if all the text being accessed has this property. */);
5071 Vbuffer_access_fontified_property
= Qnil
;
5073 DEFVAR_LISP ("system-name", Vsystem_name
,
5074 doc
: /* The host name of the machine Emacs is running on. */);
5075 Vsystem_name
= cached_system_name
= Qnil
;
5077 DEFVAR_LISP ("user-full-name", Vuser_full_name
,
5078 doc
: /* The full name of the user logged in. */);
5080 DEFVAR_LISP ("user-login-name", Vuser_login_name
,
5081 doc
: /* The user's name, taken from environment variables if possible. */);
5082 Vuser_login_name
= Qnil
;
5084 DEFVAR_LISP ("user-real-login-name", Vuser_real_login_name
,
5085 doc
: /* The user's name, based upon the real uid only. */);
5087 DEFVAR_LISP ("operating-system-release", Voperating_system_release
,
5088 doc
: /* The release of the operating system Emacs is running on. */);
5090 defsubr (&Spropertize
);
5091 defsubr (&Schar_equal
);
5092 defsubr (&Sgoto_char
);
5093 defsubr (&Sstring_to_char
);
5094 defsubr (&Schar_to_string
);
5095 defsubr (&Sbyte_to_string
);
5096 defsubr (&Sbuffer_substring
);
5097 defsubr (&Sbuffer_substring_no_properties
);
5098 defsubr (&Sbuffer_string
);
5099 defsubr (&Sget_pos_property
);
5101 defsubr (&Spoint_marker
);
5102 defsubr (&Smark_marker
);
5104 defsubr (&Sregion_beginning
);
5105 defsubr (&Sregion_end
);
5107 /* Symbol for the text property used to mark fields. */
5108 DEFSYM (Qfield
, "field");
5110 /* A special value for Qfield properties. */
5111 DEFSYM (Qboundary
, "boundary");
5113 defsubr (&Sfield_beginning
);
5114 defsubr (&Sfield_end
);
5115 defsubr (&Sfield_string
);
5116 defsubr (&Sfield_string_no_properties
);
5117 defsubr (&Sdelete_field
);
5118 defsubr (&Sconstrain_to_field
);
5120 defsubr (&Sline_beginning_position
);
5121 defsubr (&Sline_end_position
);
5123 defsubr (&Ssave_excursion
);
5124 defsubr (&Ssave_current_buffer
);
5126 defsubr (&Sbuffer_size
);
5127 defsubr (&Spoint_max
);
5128 defsubr (&Spoint_min
);
5129 defsubr (&Spoint_min_marker
);
5130 defsubr (&Spoint_max_marker
);
5131 defsubr (&Sgap_position
);
5132 defsubr (&Sgap_size
);
5133 defsubr (&Sposition_bytes
);
5134 defsubr (&Sbyte_to_position
);
5140 defsubr (&Sfollowing_char
);
5141 defsubr (&Sprevious_char
);
5142 defsubr (&Schar_after
);
5143 defsubr (&Schar_before
);
5145 defsubr (&Sinsert_before_markers
);
5146 defsubr (&Sinsert_and_inherit
);
5147 defsubr (&Sinsert_and_inherit_before_markers
);
5148 defsubr (&Sinsert_char
);
5149 defsubr (&Sinsert_byte
);
5151 defsubr (&Suser_login_name
);
5152 defsubr (&Suser_real_login_name
);
5153 defsubr (&Suser_uid
);
5154 defsubr (&Suser_real_uid
);
5155 defsubr (&Sgroup_gid
);
5156 defsubr (&Sgroup_real_gid
);
5157 defsubr (&Suser_full_name
);
5158 defsubr (&Semacs_pid
);
5159 defsubr (&Scurrent_time
);
5160 defsubr (&Stime_add
);
5161 defsubr (&Stime_subtract
);
5162 defsubr (&Stime_less_p
);
5163 defsubr (&Sget_internal_run_time
);
5164 defsubr (&Sformat_time_string
);
5165 defsubr (&Sfloat_time
);
5166 defsubr (&Sdecode_time
);
5167 defsubr (&Sencode_time
);
5168 defsubr (&Scurrent_time_string
);
5169 defsubr (&Scurrent_time_zone
);
5170 defsubr (&Sset_time_zone_rule
);
5171 defsubr (&Ssystem_name
);
5172 defsubr (&Smessage
);
5173 defsubr (&Smessage_box
);
5174 defsubr (&Smessage_or_box
);
5175 defsubr (&Scurrent_message
);
5177 defsubr (&Sformat_message
);
5179 defsubr (&Sinsert_buffer_substring
);
5180 defsubr (&Scompare_buffer_substrings
);
5181 defsubr (&Ssubst_char_in_region
);
5182 defsubr (&Stranslate_region_internal
);
5183 defsubr (&Sdelete_region
);
5184 defsubr (&Sdelete_and_extract_region
);
5186 defsubr (&Snarrow_to_region
);
5187 defsubr (&Ssave_restriction
);
5188 defsubr (&Stranspose_regions
);