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, return the number of characters in that buffer instead. */)
1033 (Lisp_Object buffer
)
1036 return make_number (Z
- BEG
);
1039 CHECK_BUFFER (buffer
);
1040 return make_number (BUF_Z (XBUFFER (buffer
))
1041 - BUF_BEG (XBUFFER (buffer
)));
1045 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
1046 doc
: /* Return the minimum permissible value of point in the current buffer.
1047 This is 1, unless narrowing (a buffer restriction) is in effect. */)
1051 XSETFASTINT (temp
, BEGV
);
1055 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
1056 doc
: /* Return a marker to the minimum permissible value of point in this buffer.
1057 This is the beginning, unless narrowing (a buffer restriction) is in effect. */)
1060 return build_marker (current_buffer
, BEGV
, BEGV_BYTE
);
1063 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
1064 doc
: /* Return the maximum permissible value of point in the current buffer.
1065 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1066 is in effect, in which case it is less. */)
1070 XSETFASTINT (temp
, ZV
);
1074 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
1075 doc
: /* Return a marker to the maximum permissible value of point in this buffer.
1076 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1077 is in effect, in which case it is less. */)
1080 return build_marker (current_buffer
, ZV
, ZV_BYTE
);
1083 DEFUN ("gap-position", Fgap_position
, Sgap_position
, 0, 0, 0,
1084 doc
: /* Return the position of the gap, in the current buffer.
1085 See also `gap-size'. */)
1089 XSETFASTINT (temp
, GPT
);
1093 DEFUN ("gap-size", Fgap_size
, Sgap_size
, 0, 0, 0,
1094 doc
: /* Return the size of the current buffer's gap.
1095 See also `gap-position'. */)
1099 XSETFASTINT (temp
, GAP_SIZE
);
1103 DEFUN ("position-bytes", Fposition_bytes
, Sposition_bytes
, 1, 1, 0,
1104 doc
: /* Return the byte position for character position POSITION.
1105 If POSITION is out of range, the value is nil. */)
1106 (Lisp_Object position
)
1108 CHECK_NUMBER_COERCE_MARKER (position
);
1109 if (XINT (position
) < BEG
|| XINT (position
) > Z
)
1111 return make_number (CHAR_TO_BYTE (XINT (position
)));
1114 DEFUN ("byte-to-position", Fbyte_to_position
, Sbyte_to_position
, 1, 1, 0,
1115 doc
: /* Return the character position for byte position BYTEPOS.
1116 If BYTEPOS is out of range, the value is nil. */)
1117 (Lisp_Object bytepos
)
1121 CHECK_NUMBER (bytepos
);
1122 pos_byte
= XINT (bytepos
);
1123 if (pos_byte
< BEG_BYTE
|| pos_byte
> Z_BYTE
)
1126 /* There are multibyte characters in the buffer.
1127 The argument of BYTE_TO_CHAR must be a byte position at
1128 a character boundary, so search for the start of the current
1130 while (!CHAR_HEAD_P (FETCH_BYTE (pos_byte
)))
1132 return make_number (BYTE_TO_CHAR (pos_byte
));
1135 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
1136 doc
: /* Return the character following point, as a number.
1137 At the end of the buffer or accessible region, return 0. */)
1142 XSETFASTINT (temp
, 0);
1144 XSETFASTINT (temp
, FETCH_CHAR (PT_BYTE
));
1148 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
1149 doc
: /* Return the character preceding point, as a number.
1150 At the beginning of the buffer or accessible region, return 0. */)
1155 XSETFASTINT (temp
, 0);
1156 else if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1158 ptrdiff_t pos
= PT_BYTE
;
1160 XSETFASTINT (temp
, FETCH_CHAR (pos
));
1163 XSETFASTINT (temp
, FETCH_BYTE (PT_BYTE
- 1));
1167 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
1168 doc
: /* Return t if point is at the beginning of the buffer.
1169 If the buffer is narrowed, this means the beginning of the narrowed part. */)
1177 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
1178 doc
: /* Return t if point is at the end of the buffer.
1179 If the buffer is narrowed, this means the end of the narrowed part. */)
1187 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
1188 doc
: /* Return t if point is at the beginning of a line. */)
1191 if (PT
== BEGV
|| FETCH_BYTE (PT_BYTE
- 1) == '\n')
1196 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
1197 doc
: /* Return t if point is at the end of a line.
1198 `End of a line' includes point being at the end of the buffer. */)
1201 if (PT
== ZV
|| FETCH_BYTE (PT_BYTE
) == '\n')
1206 DEFUN ("char-after", Fchar_after
, Schar_after
, 0, 1, 0,
1207 doc
: /* Return character in current buffer at position POS.
1208 POS is an integer or a marker and defaults to point.
1209 If POS is out of range, the value is nil. */)
1212 register ptrdiff_t pos_byte
;
1217 XSETFASTINT (pos
, PT
);
1222 pos_byte
= marker_byte_position (pos
);
1223 if (pos_byte
< BEGV_BYTE
|| pos_byte
>= ZV_BYTE
)
1228 CHECK_NUMBER_COERCE_MARKER (pos
);
1229 if (XINT (pos
) < BEGV
|| XINT (pos
) >= ZV
)
1232 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1235 return make_number (FETCH_CHAR (pos_byte
));
1238 DEFUN ("char-before", Fchar_before
, Schar_before
, 0, 1, 0,
1239 doc
: /* Return character in current buffer preceding position POS.
1240 POS is an integer or a marker and defaults to point.
1241 If POS is out of range, the value is nil. */)
1244 register Lisp_Object val
;
1245 register ptrdiff_t pos_byte
;
1250 XSETFASTINT (pos
, PT
);
1255 pos_byte
= marker_byte_position (pos
);
1257 if (pos_byte
<= BEGV_BYTE
|| pos_byte
> ZV_BYTE
)
1262 CHECK_NUMBER_COERCE_MARKER (pos
);
1264 if (XINT (pos
) <= BEGV
|| XINT (pos
) > ZV
)
1267 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1270 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1273 XSETFASTINT (val
, FETCH_CHAR (pos_byte
));
1278 XSETFASTINT (val
, FETCH_BYTE (pos_byte
));
1283 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 1, 0,
1284 doc
: /* Return the name under which the user logged in, as a string.
1285 This is based on the effective uid, not the real uid.
1286 Also, if the environment variables LOGNAME or USER are set,
1287 that determines the value of this function.
1289 If optional argument UID is an integer or a float, return the login name
1290 of the user with that uid, or nil if there is no such user. */)
1296 /* Set up the user name info if we didn't do it before.
1297 (That can happen if Emacs is dumpable
1298 but you decide to run `temacs -l loadup' and not dump. */
1299 if (NILP (Vuser_login_name
))
1300 init_editfns (false);
1303 return Vuser_login_name
;
1305 CONS_TO_INTEGER (uid
, uid_t
, id
);
1309 return (pw
? build_string (pw
->pw_name
) : Qnil
);
1312 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
1314 doc
: /* Return the name of the user's real uid, as a string.
1315 This ignores the environment variables LOGNAME and USER, so it differs from
1316 `user-login-name' when running under `su'. */)
1319 /* Set up the user name info if we didn't do it before.
1320 (That can happen if Emacs is dumpable
1321 but you decide to run `temacs -l loadup' and not dump. */
1322 if (NILP (Vuser_login_name
))
1323 init_editfns (false);
1324 return Vuser_real_login_name
;
1327 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
1328 doc
: /* Return the effective uid of Emacs.
1329 Value is an integer or a float, depending on the value. */)
1332 uid_t euid
= geteuid ();
1333 return make_fixnum_or_float (euid
);
1336 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
1337 doc
: /* Return the real uid of Emacs.
1338 Value is an integer or a float, depending on the value. */)
1341 uid_t uid
= getuid ();
1342 return make_fixnum_or_float (uid
);
1345 DEFUN ("group-gid", Fgroup_gid
, Sgroup_gid
, 0, 0, 0,
1346 doc
: /* Return the effective gid of Emacs.
1347 Value is an integer or a float, depending on the value. */)
1350 gid_t egid
= getegid ();
1351 return make_fixnum_or_float (egid
);
1354 DEFUN ("group-real-gid", Fgroup_real_gid
, Sgroup_real_gid
, 0, 0, 0,
1355 doc
: /* Return the real gid of Emacs.
1356 Value is an integer or a float, depending on the value. */)
1359 gid_t gid
= getgid ();
1360 return make_fixnum_or_float (gid
);
1363 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 1, 0,
1364 doc
: /* Return the full name of the user logged in, as a string.
1365 If the full name corresponding to Emacs's userid is not known,
1368 If optional argument UID is an integer or float, return the full name
1369 of the user with that uid, or nil if there is no such user.
1370 If UID is a string, return the full name of the user with that login
1371 name, or nil if there is no such user. */)
1375 register char *p
, *q
;
1379 return Vuser_full_name
;
1380 else if (NUMBERP (uid
))
1383 CONS_TO_INTEGER (uid
, uid_t
, u
);
1388 else if (STRINGP (uid
))
1391 pw
= getpwnam (SSDATA (uid
));
1395 error ("Invalid UID specification");
1401 /* Chop off everything after the first comma. */
1402 q
= strchr (p
, ',');
1403 full
= make_string (p
, q
? q
- p
: strlen (p
));
1405 #ifdef AMPERSAND_FULL_NAME
1407 q
= strchr (p
, '&');
1408 /* Substitute the login name for the &, upcasing the first character. */
1411 Lisp_Object login
= Fuser_login_name (make_number (pw
->pw_uid
));
1413 char *r
= SAFE_ALLOCA (strlen (p
) + SBYTES (login
) + 1);
1414 memcpy (r
, p
, q
- p
);
1415 char *s
= lispstpcpy (&r
[q
- p
], login
);
1416 r
[q
- p
] = upcase ((unsigned char) r
[q
- p
]);
1418 full
= build_string (r
);
1421 #endif /* AMPERSAND_FULL_NAME */
1426 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
1427 doc
: /* Return the host name of the machine you are running on, as a string. */)
1430 if (EQ (Vsystem_name
, cached_system_name
))
1431 init_and_cache_system_name ();
1432 return Vsystem_name
;
1435 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
1436 doc
: /* Return the process ID of Emacs, as a number. */)
1439 pid_t pid
= getpid ();
1440 return make_fixnum_or_float (pid
);
1446 # define TIME_T_MIN TYPE_MINIMUM (time_t)
1449 # define TIME_T_MAX TYPE_MAXIMUM (time_t)
1452 /* Report that a time value is out of range for Emacs. */
1454 time_overflow (void)
1456 error ("Specified time is not representable");
1459 static _Noreturn
void
1462 error ("Invalid time specification");
1465 /* Check a return value compatible with that of decode_time_components. */
1467 check_time_validity (int validity
)
1478 /* Return the upper part of the time T (everything but the bottom 16 bits). */
1482 time_t hi
= t
>> LO_TIME_BITS
;
1484 /* Check for overflow, helping the compiler for common cases where
1485 no runtime check is needed, and taking care not to convert
1486 negative numbers to unsigned before comparing them. */
1487 if (! ((! TYPE_SIGNED (time_t)
1488 || MOST_NEGATIVE_FIXNUM
<= TIME_T_MIN
>> LO_TIME_BITS
1489 || MOST_NEGATIVE_FIXNUM
<= hi
)
1490 && (TIME_T_MAX
>> LO_TIME_BITS
<= MOST_POSITIVE_FIXNUM
1491 || hi
<= MOST_POSITIVE_FIXNUM
)))
1497 /* Return the bottom bits of the time T. */
1501 return t
& ((1 << LO_TIME_BITS
) - 1);
1504 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
1505 doc
: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
1506 The time is returned as a list of integers (HIGH LOW USEC PSEC).
1507 HIGH has the most significant bits of the seconds, while LOW has the
1508 least significant 16 bits. USEC and PSEC are the microsecond and
1509 picosecond counts. */)
1512 return make_lisp_time (current_timespec ());
1515 static struct lisp_time
1516 time_add (struct lisp_time ta
, struct lisp_time tb
)
1518 EMACS_INT hi
= ta
.hi
+ tb
.hi
;
1519 int lo
= ta
.lo
+ tb
.lo
;
1520 int us
= ta
.us
+ tb
.us
;
1521 int ps
= ta
.ps
+ tb
.ps
;
1522 us
+= (1000000 <= ps
);
1523 ps
-= (1000000 <= ps
) * 1000000;
1524 lo
+= (1000000 <= us
);
1525 us
-= (1000000 <= us
) * 1000000;
1526 hi
+= (1 << LO_TIME_BITS
<= lo
);
1527 lo
-= (1 << LO_TIME_BITS
<= lo
) << LO_TIME_BITS
;
1528 return (struct lisp_time
) { hi
, lo
, us
, ps
};
1531 static struct lisp_time
1532 time_subtract (struct lisp_time ta
, struct lisp_time tb
)
1534 EMACS_INT hi
= ta
.hi
- tb
.hi
;
1535 int lo
= ta
.lo
- tb
.lo
;
1536 int us
= ta
.us
- tb
.us
;
1537 int ps
= ta
.ps
- tb
.ps
;
1539 ps
+= (ps
< 0) * 1000000;
1541 us
+= (us
< 0) * 1000000;
1543 lo
+= (lo
< 0) << LO_TIME_BITS
;
1544 return (struct lisp_time
) { hi
, lo
, us
, ps
};
1548 time_arith (Lisp_Object a
, Lisp_Object b
,
1549 struct lisp_time (*op
) (struct lisp_time
, struct lisp_time
))
1552 struct lisp_time ta
= lisp_time_struct (a
, &alen
);
1553 struct lisp_time tb
= lisp_time_struct (b
, &blen
);
1554 struct lisp_time t
= op (ta
, tb
);
1555 if (! (MOST_NEGATIVE_FIXNUM
<= t
.hi
&& t
.hi
<= MOST_POSITIVE_FIXNUM
))
1557 Lisp_Object val
= Qnil
;
1559 switch (max (alen
, blen
))
1562 val
= Fcons (make_number (t
.ps
), val
);
1565 val
= Fcons (make_number (t
.us
), val
);
1568 val
= Fcons (make_number (t
.lo
), val
);
1569 val
= Fcons (make_number (t
.hi
), val
);
1576 DEFUN ("time-add", Ftime_add
, Stime_add
, 2, 2, 0,
1577 doc
: /* Return the sum of two time values A and B, as a time value. */)
1578 (Lisp_Object a
, Lisp_Object b
)
1580 return time_arith (a
, b
, time_add
);
1583 DEFUN ("time-subtract", Ftime_subtract
, Stime_subtract
, 2, 2, 0,
1584 doc
: /* Return the difference between two time values A and B, as a time value. */)
1585 (Lisp_Object a
, Lisp_Object b
)
1587 return time_arith (a
, b
, time_subtract
);
1590 DEFUN ("time-less-p", Ftime_less_p
, Stime_less_p
, 2, 2, 0,
1591 doc
: /* Return non-nil if time value T1 is earlier than time value T2. */)
1592 (Lisp_Object t1
, Lisp_Object t2
)
1595 struct lisp_time a
= lisp_time_struct (t1
, &t1len
);
1596 struct lisp_time b
= lisp_time_struct (t2
, &t2len
);
1597 return ((a
.hi
!= b
.hi
? a
.hi
< b
.hi
1598 : a
.lo
!= b
.lo
? a
.lo
< b
.lo
1599 : a
.us
!= b
.us
? a
.us
< b
.us
1605 DEFUN ("get-internal-run-time", Fget_internal_run_time
, Sget_internal_run_time
,
1607 doc
: /* Return the current run time used by Emacs.
1608 The time is returned as a list (HIGH LOW USEC PSEC), using the same
1609 style as (current-time).
1611 On systems that can't determine the run time, `get-internal-run-time'
1612 does the same thing as `current-time'. */)
1615 #ifdef HAVE_GETRUSAGE
1616 struct rusage usage
;
1620 if (getrusage (RUSAGE_SELF
, &usage
) < 0)
1621 /* This shouldn't happen. What action is appropriate? */
1624 /* Sum up user time and system time. */
1625 secs
= usage
.ru_utime
.tv_sec
+ usage
.ru_stime
.tv_sec
;
1626 usecs
= usage
.ru_utime
.tv_usec
+ usage
.ru_stime
.tv_usec
;
1627 if (usecs
>= 1000000)
1632 return make_lisp_time (make_timespec (secs
, usecs
* 1000));
1633 #else /* ! HAVE_GETRUSAGE */
1635 return w32_get_internal_run_time ();
1636 #else /* ! WINDOWSNT */
1637 return Fcurrent_time ();
1638 #endif /* WINDOWSNT */
1639 #endif /* HAVE_GETRUSAGE */
1643 /* Make a Lisp list that represents the Emacs time T. T may be an
1644 invalid time, with a slightly negative tv_nsec value such as
1645 UNKNOWN_MODTIME_NSECS; in that case, the Lisp list contains a
1646 correspondingly negative picosecond count. */
1648 make_lisp_time (struct timespec t
)
1650 time_t s
= t
.tv_sec
;
1652 return list4i (hi_time (s
), lo_time (s
), ns
/ 1000, ns
% 1000 * 1000);
1655 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1656 Set *PHIGH, *PLOW, *PUSEC, *PPSEC to its parts; do not check their values.
1657 Return 2, 3, or 4 to indicate the effective length of SPECIFIED_TIME
1658 if successful, 0 if unsuccessful. */
1660 disassemble_lisp_time (Lisp_Object specified_time
, Lisp_Object
*phigh
,
1661 Lisp_Object
*plow
, Lisp_Object
*pusec
,
1664 Lisp_Object high
= make_number (0);
1665 Lisp_Object low
= specified_time
;
1666 Lisp_Object usec
= make_number (0);
1667 Lisp_Object psec
= make_number (0);
1670 if (CONSP (specified_time
))
1672 high
= XCAR (specified_time
);
1673 low
= XCDR (specified_time
);
1676 Lisp_Object low_tail
= XCDR (low
);
1678 if (CONSP (low_tail
))
1680 usec
= XCAR (low_tail
);
1681 low_tail
= XCDR (low_tail
);
1682 if (CONSP (low_tail
))
1683 psec
= XCAR (low_tail
);
1687 else if (!NILP (low_tail
))
1698 /* When combining components, require LOW to be an integer,
1699 as otherwise it would be a pain to add up times. */
1700 if (! INTEGERP (low
))
1703 else if (INTEGERP (specified_time
))
1713 /* Convert T into an Emacs time *RESULT, truncating toward minus infinity.
1714 Return true if T is in range, false otherwise. */
1716 decode_float_time (double t
, struct lisp_time
*result
)
1718 double lo_multiplier
= 1 << LO_TIME_BITS
;
1719 double emacs_time_min
= MOST_NEGATIVE_FIXNUM
* lo_multiplier
;
1720 if (! (emacs_time_min
<= t
&& t
< -emacs_time_min
))
1723 double small_t
= t
/ lo_multiplier
;
1724 EMACS_INT hi
= small_t
;
1725 double t_sans_hi
= t
- hi
* lo_multiplier
;
1727 long double fracps
= (t_sans_hi
- lo
) * 1e12L
;
1728 #ifdef INT_FAST64_MAX
1729 int_fast64_t ifracps
= fracps
;
1730 int us
= ifracps
/ 1000000;
1731 int ps
= ifracps
% 1000000;
1733 int us
= fracps
/ 1e6L
;
1734 int ps
= fracps
- us
* 1e6L
;
1737 ps
+= (ps
< 0) * 1000000;
1739 us
+= (us
< 0) * 1000000;
1741 lo
+= (lo
< 0) << LO_TIME_BITS
;
1749 /* From the time components HIGH, LOW, USEC and PSEC taken from a Lisp
1750 list, generate the corresponding time value.
1751 If LOW is floating point, the other components should be zero.
1753 If RESULT is not null, store into *RESULT the converted time.
1754 If *DRESULT is not null, store into *DRESULT the number of
1755 seconds since the start of the POSIX Epoch.
1757 Return 1 if successful, 0 if the components are of the
1758 wrong type, and -1 if the time is out of range. */
1760 decode_time_components (Lisp_Object high
, Lisp_Object low
, Lisp_Object usec
,
1762 struct lisp_time
*result
, double *dresult
)
1764 EMACS_INT hi
, lo
, us
, ps
;
1765 if (! (INTEGERP (high
)
1766 && INTEGERP (usec
) && INTEGERP (psec
)))
1768 if (! INTEGERP (low
))
1772 double t
= XFLOAT_DATA (low
);
1773 if (result
&& ! decode_float_time (t
, result
))
1779 else if (NILP (low
))
1781 struct timespec now
= current_timespec ();
1784 result
->hi
= hi_time (now
.tv_sec
);
1785 result
->lo
= lo_time (now
.tv_sec
);
1786 result
->us
= now
.tv_nsec
/ 1000;
1787 result
->ps
= now
.tv_nsec
% 1000 * 1000;
1790 *dresult
= now
.tv_sec
+ now
.tv_nsec
/ 1e9
;
1802 /* Normalize out-of-range lower-order components by carrying
1803 each overflow into the next higher-order component. */
1804 us
+= ps
/ 1000000 - (ps
% 1000000 < 0);
1805 lo
+= us
/ 1000000 - (us
% 1000000 < 0);
1806 hi
+= lo
>> LO_TIME_BITS
;
1807 ps
= ps
% 1000000 + 1000000 * (ps
% 1000000 < 0);
1808 us
= us
% 1000000 + 1000000 * (us
% 1000000 < 0);
1809 lo
&= (1 << LO_TIME_BITS
) - 1;
1813 if (! (MOST_NEGATIVE_FIXNUM
<= hi
&& hi
<= MOST_POSITIVE_FIXNUM
))
1824 *dresult
= (us
* 1e6
+ ps
) / 1e12
+ lo
+ dhi
* (1 << LO_TIME_BITS
);
1831 lisp_to_timespec (struct lisp_time t
)
1833 if (! ((TYPE_SIGNED (time_t) ? TIME_T_MIN
>> LO_TIME_BITS
<= t
.hi
: 0 <= t
.hi
)
1834 && t
.hi
<= TIME_T_MAX
>> LO_TIME_BITS
))
1835 return invalid_timespec ();
1836 time_t s
= (t
.hi
<< LO_TIME_BITS
) + t
.lo
;
1837 int ns
= t
.us
* 1000 + t
.ps
/ 1000;
1838 return make_timespec (s
, ns
);
1841 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1842 Store its effective length into *PLEN.
1843 If SPECIFIED_TIME is nil, use the current time.
1844 Signal an error if SPECIFIED_TIME does not represent a time. */
1845 static struct lisp_time
1846 lisp_time_struct (Lisp_Object specified_time
, int *plen
)
1848 Lisp_Object high
, low
, usec
, psec
;
1850 int len
= disassemble_lisp_time (specified_time
, &high
, &low
, &usec
, &psec
);
1853 int val
= decode_time_components (high
, low
, usec
, psec
, &t
, 0);
1854 check_time_validity (val
);
1859 /* Like lisp_time_struct, except return a struct timespec.
1860 Discard any low-order digits. */
1862 lisp_time_argument (Lisp_Object specified_time
)
1865 struct lisp_time lt
= lisp_time_struct (specified_time
, &len
);
1866 struct timespec t
= lisp_to_timespec (lt
);
1867 if (! timespec_valid_p (t
))
1872 /* Like lisp_time_argument, except decode only the seconds part,
1873 and do not check the subseconds part. */
1875 lisp_seconds_argument (Lisp_Object specified_time
)
1877 Lisp_Object high
, low
, usec
, psec
;
1880 int val
= disassemble_lisp_time (specified_time
, &high
, &low
, &usec
, &psec
);
1883 val
= decode_time_components (high
, low
, make_number (0),
1884 make_number (0), &t
, 0);
1886 && ! ((TYPE_SIGNED (time_t)
1887 ? TIME_T_MIN
>> LO_TIME_BITS
<= t
.hi
1889 && t
.hi
<= TIME_T_MAX
>> LO_TIME_BITS
))
1892 check_time_validity (val
);
1893 return (t
.hi
<< LO_TIME_BITS
) + t
.lo
;
1896 DEFUN ("float-time", Ffloat_time
, Sfloat_time
, 0, 1, 0,
1897 doc
: /* Return the current time, as a float number of seconds since the epoch.
1898 If SPECIFIED-TIME is given, it is the time to convert to float
1899 instead of the current time. The argument should have the form
1900 \(HIGH LOW) or (HIGH LOW USEC) or (HIGH LOW USEC PSEC). Thus,
1901 you can use times from `current-time' and from `file-attributes'.
1902 SPECIFIED-TIME can also have the form (HIGH . LOW), but this is
1903 considered obsolete.
1905 WARNING: Since the result is floating point, it may not be exact.
1906 If precise time stamps are required, use either `current-time',
1907 or (if you need time as a string) `format-time-string'. */)
1908 (Lisp_Object specified_time
)
1911 Lisp_Object high
, low
, usec
, psec
;
1912 if (! (disassemble_lisp_time (specified_time
, &high
, &low
, &usec
, &psec
)
1913 && decode_time_components (high
, low
, usec
, psec
, 0, &t
)))
1915 return make_float (t
);
1918 /* Write information into buffer S of size MAXSIZE, according to the
1919 FORMAT of length FORMAT_LEN, using time information taken from *TP.
1920 Use the time zone specified by TZ.
1921 Use NS as the number of nanoseconds in the %N directive.
1922 Return the number of bytes written, not including the terminating
1923 '\0'. If S is NULL, nothing will be written anywhere; so to
1924 determine how many bytes would be written, use NULL for S and
1925 ((size_t) -1) for MAXSIZE.
1927 This function behaves like nstrftime, except it allows null
1928 bytes in FORMAT and it does not support nanoseconds. */
1930 emacs_nmemftime (char *s
, size_t maxsize
, const char *format
,
1931 size_t format_len
, const struct tm
*tp
, timezone_t tz
, int ns
)
1935 /* Loop through all the null-terminated strings in the format
1936 argument. Normally there's just one null-terminated string, but
1937 there can be arbitrarily many, concatenated together, if the
1938 format contains '\0' bytes. nstrftime stops at the first
1939 '\0' byte so we must invoke it separately for each such string. */
1948 result
= nstrftime (s
, maxsize
, format
, tp
, tz
, ns
);
1952 if (result
== 0 && s
[0] != '\0')
1957 maxsize
-= result
+ 1;
1959 len
= strlen (format
);
1960 if (len
== format_len
)
1964 format_len
-= len
+ 1;
1968 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 1, 3, 0,
1969 doc
: /* Use FORMAT-STRING to format the time TIME, or now if omitted.
1970 TIME is specified as (HIGH LOW USEC PSEC), as returned by
1971 `current-time' or `file-attributes'. The obsolete form (HIGH . LOW)
1972 is also still accepted.
1973 The optional ZONE is omitted or nil for Emacs local time, t for
1974 Universal Time, `wall' for system wall clock time, or a string as in
1975 `set-time-zone-rule' for a time zone rule.
1976 The value is a copy of FORMAT-STRING, but with certain constructs replaced
1977 by text that describes the specified date and time in TIME:
1979 %Y is the year, %y within the century, %C the century.
1980 %G is the year corresponding to the ISO week, %g within the century.
1981 %m is the numeric month.
1982 %b and %h are the locale's abbreviated month name, %B the full name.
1983 (%h is not supported on MS-Windows.)
1984 %d is the day of the month, zero-padded, %e is blank-padded.
1985 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
1986 %a is the locale's abbreviated name of the day of week, %A the full name.
1987 %U is the week number starting on Sunday, %W starting on Monday,
1988 %V according to ISO 8601.
1989 %j is the day of the year.
1991 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
1992 only blank-padded, %l is like %I blank-padded.
1993 %p is the locale's equivalent of either AM or PM.
1996 %N is the nanosecond, %6N the microsecond, %3N the millisecond, etc.
1997 %Z is the time zone name, %z is the numeric form.
1998 %s is the number of seconds since 1970-01-01 00:00:00 +0000.
2000 %c is the locale's date and time format.
2001 %x is the locale's "preferred" date format.
2002 %D is like "%m/%d/%y".
2003 %F is the ISO 8601 date format (like "%Y-%m-%d").
2005 %R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
2006 %X is the locale's "preferred" time format.
2008 Finally, %n is a newline, %t is a tab, %% is a literal %.
2010 Certain flags and modifiers are available with some format controls.
2011 The flags are `_', `-', `^' and `#'. For certain characters X,
2012 %_X is like %X, but padded with blanks; %-X is like %X,
2013 but without padding. %^X is like %X, but with all textual
2014 characters up-cased; %#X is like %X, but with letter-case of
2015 all textual characters reversed.
2016 %NX (where N stands for an integer) is like %X,
2017 but takes up at least N (a number) positions.
2018 The modifiers are `E' and `O'. For certain characters X,
2019 %EX is a locale's alternative version of %X;
2020 %OX is like %X, but uses the locale's number symbols.
2022 For example, to produce full ISO 8601 format, use "%FT%T%z".
2024 usage: (format-time-string FORMAT-STRING &optional TIME ZONE) */)
2025 (Lisp_Object format_string
, Lisp_Object timeval
, Lisp_Object zone
)
2027 struct timespec t
= lisp_time_argument (timeval
);
2030 CHECK_STRING (format_string
);
2031 format_string
= code_convert_string_norecord (format_string
,
2032 Vlocale_coding_system
, 1);
2033 return format_time_string (SSDATA (format_string
), SBYTES (format_string
),
2038 format_time_string (char const *format
, ptrdiff_t formatlen
,
2039 struct timespec t
, Lisp_Object zone
, struct tm
*tmp
)
2043 ptrdiff_t size
= sizeof buffer
;
2045 Lisp_Object bufstring
;
2049 timezone_t tz
= tzlookup (zone
, false);
2050 tmp
= emacs_localtime_rz (tz
, &t
.tv_sec
, tmp
);
2056 synchronize_system_time_locale ();
2061 len
= emacs_nmemftime (buf
, size
, format
, formatlen
, tmp
, tz
, ns
);
2062 if ((0 < len
&& len
< size
) || (len
== 0 && buf
[0] == '\0'))
2065 /* Buffer was too small, so make it bigger and try again. */
2066 len
= emacs_nmemftime (NULL
, SIZE_MAX
, format
, formatlen
, tmp
, tz
, ns
);
2067 if (STRING_BYTES_BOUND
<= len
)
2073 buf
= SAFE_ALLOCA (size
);
2077 bufstring
= make_unibyte_string (buf
, len
);
2079 return code_convert_string_norecord (bufstring
, Vlocale_coding_system
, 0);
2082 DEFUN ("decode-time", Fdecode_time
, Sdecode_time
, 0, 2, 0,
2083 doc
: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST UTCOFF).
2084 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED),
2085 as from `current-time' and `file-attributes', or nil to use the
2086 current time. The obsolete form (HIGH . LOW) is also still accepted.
2087 The optional ZONE is omitted or nil for Emacs local time, t for
2088 Universal Time, `wall' for system wall clock time, or a string as in
2089 `set-time-zone-rule' for a time zone rule.
2091 The list has the following nine members: SEC is an integer between 0
2092 and 60; SEC is 60 for a leap second, which only some operating systems
2093 support. MINUTE is an integer between 0 and 59. HOUR is an integer
2094 between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
2095 integer between 1 and 12. YEAR is an integer indicating the
2096 four-digit year. DOW is the day of week, an integer between 0 and 6,
2097 where 0 is Sunday. DST is t if daylight saving time is in effect,
2098 otherwise nil. UTCOFF is an integer indicating the UTC offset in
2099 seconds, i.e., the number of seconds east of Greenwich. (Note that
2100 Common Lisp has different meanings for DOW and UTCOFF.)
2102 usage: (decode-time &optional TIME ZONE) */)
2103 (Lisp_Object specified_time
, Lisp_Object zone
)
2105 time_t time_spec
= lisp_seconds_argument (specified_time
);
2106 struct tm local_tm
, gmt_tm
;
2107 timezone_t tz
= tzlookup (zone
, false);
2108 struct tm
*tm
= emacs_localtime_rz (tz
, &time_spec
, &local_tm
);
2112 && MOST_NEGATIVE_FIXNUM
- TM_YEAR_BASE
<= local_tm
.tm_year
2113 && local_tm
.tm_year
<= MOST_POSITIVE_FIXNUM
- TM_YEAR_BASE
))
2116 /* Avoid overflow when INT_MAX < EMACS_INT_MAX. */
2117 EMACS_INT tm_year_base
= TM_YEAR_BASE
;
2119 return CALLN (Flist
,
2120 make_number (local_tm
.tm_sec
),
2121 make_number (local_tm
.tm_min
),
2122 make_number (local_tm
.tm_hour
),
2123 make_number (local_tm
.tm_mday
),
2124 make_number (local_tm
.tm_mon
+ 1),
2125 make_number (local_tm
.tm_year
+ tm_year_base
),
2126 make_number (local_tm
.tm_wday
),
2127 local_tm
.tm_isdst
? Qt
: Qnil
,
2129 ? make_number (tm_gmtoff (&local_tm
))
2130 : gmtime_r (&time_spec
, &gmt_tm
)
2131 ? make_number (tm_diff (&local_tm
, &gmt_tm
))
2135 /* Return OBJ - OFFSET, checking that OBJ is a valid fixnum and that
2136 the result is representable as an int. Assume OFFSET is small and
2139 check_tm_member (Lisp_Object obj
, int offset
)
2144 if (! (INT_MIN
+ offset
<= n
&& n
- offset
<= INT_MAX
))
2149 DEFUN ("encode-time", Fencode_time
, Sencode_time
, 6, MANY
, 0,
2150 doc
: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
2151 This is the reverse operation of `decode-time', which see.
2152 The optional ZONE is omitted or nil for Emacs local time, t for
2153 Universal Time, `wall' for system wall clock time, or a string as in
2154 `set-time-zone-rule' for a time zone rule. It can also be a list (as
2155 from `current-time-zone') or an integer (as from `decode-time')
2156 applied without consideration for daylight saving time.
2158 You can pass more than 7 arguments; then the first six arguments
2159 are used as SECOND through YEAR, and the *last* argument is used as ZONE.
2160 The intervening arguments are ignored.
2161 This feature lets (apply \\='encode-time (decode-time ...)) work.
2163 Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed;
2164 for example, a DAY of 0 means the day preceding the given month.
2165 Year numbers less than 100 are treated just like other year numbers.
2166 If you want them to stand for years in this century, you must do that yourself.
2168 Years before 1970 are not guaranteed to work. On some systems,
2169 year values as low as 1901 do work.
2171 usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
2172 (ptrdiff_t nargs
, Lisp_Object
*args
)
2176 Lisp_Object zone
= (nargs
> 6 ? args
[nargs
- 1] : Qnil
);
2178 tm
.tm_sec
= check_tm_member (args
[0], 0);
2179 tm
.tm_min
= check_tm_member (args
[1], 0);
2180 tm
.tm_hour
= check_tm_member (args
[2], 0);
2181 tm
.tm_mday
= check_tm_member (args
[3], 0);
2182 tm
.tm_mon
= check_tm_member (args
[4], 1);
2183 tm
.tm_year
= check_tm_member (args
[5], TM_YEAR_BASE
);
2188 timezone_t tz
= tzlookup (zone
, false);
2189 value
= emacs_mktime_z (tz
, &tm
);
2192 if (value
== (time_t) -1)
2195 return list2i (hi_time (value
), lo_time (value
));
2198 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
,
2200 doc
: /* Return the current local time, as a human-readable string.
2201 Programs can use this function to decode a time,
2202 since the number of columns in each field is fixed
2203 if the year is in the range 1000-9999.
2204 The format is `Sun Sep 16 01:03:52 1973'.
2205 However, see also the functions `decode-time' and `format-time-string'
2206 which provide a much more powerful and general facility.
2208 If SPECIFIED-TIME is given, it is a time to format instead of the
2209 current time. The argument should have the form (HIGH LOW . IGNORED).
2210 Thus, you can use times obtained from `current-time' and from
2211 `file-attributes'. SPECIFIED-TIME can also have the form (HIGH . LOW),
2212 but this is considered obsolete.
2214 The optional ZONE is omitted or nil for Emacs local time, t for
2215 Universal Time, `wall' for system wall clock time, or a string as in
2216 `set-time-zone-rule' for a time zone rule. */)
2217 (Lisp_Object specified_time
, Lisp_Object zone
)
2219 time_t value
= lisp_seconds_argument (specified_time
);
2220 timezone_t tz
= tzlookup (zone
, false);
2222 /* Convert to a string in ctime format, except without the trailing
2223 newline, and without the 4-digit year limit. Don't use asctime
2224 or ctime, as they might dump core if the year is outside the
2225 range -999 .. 9999. */
2227 struct tm
*tmp
= emacs_localtime_rz (tz
, &value
, &tm
);
2232 static char const wday_name
[][4] =
2233 { "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat" };
2234 static char const mon_name
[][4] =
2235 { "Jan", "Feb", "Mar", "Apr", "May", "Jun",
2236 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" };
2237 printmax_t year_base
= TM_YEAR_BASE
;
2238 char buf
[sizeof "Mon Apr 30 12:49:17 " + INT_STRLEN_BOUND (int) + 1];
2239 int len
= sprintf (buf
, "%s %s%3d %02d:%02d:%02d %"pMd
,
2240 wday_name
[tm
.tm_wday
], mon_name
[tm
.tm_mon
], tm
.tm_mday
,
2241 tm
.tm_hour
, tm
.tm_min
, tm
.tm_sec
,
2242 tm
.tm_year
+ year_base
);
2244 return make_unibyte_string (buf
, len
);
2247 /* Yield A - B, measured in seconds.
2248 This function is copied from the GNU C Library. */
2250 tm_diff (struct tm
*a
, struct tm
*b
)
2252 /* Compute intervening leap days correctly even if year is negative.
2253 Take care to avoid int overflow in leap day calculations,
2254 but it's OK to assume that A and B are close to each other. */
2255 int a4
= (a
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (a
->tm_year
& 3);
2256 int b4
= (b
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (b
->tm_year
& 3);
2257 int a100
= a4
/ 25 - (a4
% 25 < 0);
2258 int b100
= b4
/ 25 - (b4
% 25 < 0);
2259 int a400
= a100
>> 2;
2260 int b400
= b100
>> 2;
2261 int intervening_leap_days
= (a4
- b4
) - (a100
- b100
) + (a400
- b400
);
2262 int years
= a
->tm_year
- b
->tm_year
;
2263 int days
= (365 * years
+ intervening_leap_days
2264 + (a
->tm_yday
- b
->tm_yday
));
2265 return (60 * (60 * (24 * days
+ (a
->tm_hour
- b
->tm_hour
))
2266 + (a
->tm_min
- b
->tm_min
))
2267 + (a
->tm_sec
- b
->tm_sec
));
2270 /* Yield A's UTC offset, or an unspecified value if unknown. */
2272 tm_gmtoff (struct tm
*a
)
2275 return a
->tm_gmtoff
;
2281 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 2, 0,
2282 doc
: /* Return the offset and name for the local time zone.
2283 This returns a list of the form (OFFSET NAME).
2284 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
2285 A negative value means west of Greenwich.
2286 NAME is a string giving the name of the time zone.
2287 If SPECIFIED-TIME is given, the time zone offset is determined from it
2288 instead of using the current time. The argument should have the form
2289 \(HIGH LOW . IGNORED). Thus, you can use times obtained from
2290 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
2291 have the form (HIGH . LOW), but this is considered obsolete.
2292 Optional second arg ZONE is omitted or nil for the local time zone, or
2293 a string as in `set-time-zone-rule'.
2295 Some operating systems cannot provide all this information to Emacs;
2296 in this case, `current-time-zone' returns a list containing nil for
2297 the data it can't find. */)
2298 (Lisp_Object specified_time
, Lisp_Object zone
)
2300 struct timespec value
;
2301 struct tm local_tm
, gmt_tm
;
2302 Lisp_Object zone_offset
, zone_name
;
2305 value
= make_timespec (lisp_seconds_argument (specified_time
), 0);
2306 zone_name
= format_time_string ("%Z", sizeof "%Z" - 1, value
,
2309 if (HAVE_TM_GMTOFF
|| gmtime_r (&value
.tv_sec
, &gmt_tm
))
2311 long int offset
= (HAVE_TM_GMTOFF
2312 ? tm_gmtoff (&local_tm
)
2313 : tm_diff (&local_tm
, &gmt_tm
));
2314 zone_offset
= make_number (offset
);
2315 if (SCHARS (zone_name
) == 0)
2317 /* No local time zone name is available; use "+-NNNN" instead. */
2318 long int m
= offset
/ 60;
2319 long int am
= offset
< 0 ? - m
: m
;
2320 long int hour
= am
/ 60;
2322 char buf
[sizeof "+00" + INT_STRLEN_BOUND (long int)];
2323 zone_name
= make_formatted_string (buf
, "%c%02ld%02d",
2324 (offset
< 0 ? '-' : '+'),
2329 return list2 (zone_offset
, zone_name
);
2332 DEFUN ("set-time-zone-rule", Fset_time_zone_rule
, Sset_time_zone_rule
, 1, 1, 0,
2333 doc
: /* Set the Emacs local time zone using TZ, a string specifying a time zone rule.
2334 If TZ is nil or `wall', use system wall clock time. If TZ is t, use
2335 Universal Time. If TZ is an integer, treat it as in `encode-time'.
2337 Instead of calling this function, you typically want something else.
2338 To temporarily use a different time zone rule for just one invocation
2339 of `decode-time', `encode-time', or `format-time-string', pass the
2340 function a ZONE argument. To change local time consistently
2341 throughout Emacs, call (setenv "TZ" TZ): this changes both the
2342 environment of the Emacs process and the variable
2343 `process-environment', whereas `set-time-zone-rule' affects only the
2347 tzlookup (NILP (tz
) ? Qwall
: tz
, true);
2351 /* A buffer holding a string of the form "TZ=value", intended
2352 to be part of the environment. If TZ is supposed to be unset,
2353 the buffer string is "tZ=". */
2354 static char *tzvalbuf
;
2356 /* Get the local time zone rule. */
2358 emacs_getenv_TZ (void)
2360 return tzvalbuf
[0] == 'T' ? tzvalbuf
+ tzeqlen
: 0;
2363 /* Set the local time zone rule to TZSTRING, which can be null to
2364 denote wall clock time. Do not record the setting in LOCAL_TZ.
2366 This function is not thread-safe, in theory because putenv is not,
2367 but mostly because of the static storage it updates. Other threads
2368 that invoke localtime etc. may be adversely affected while this
2369 function is executing. */
2372 emacs_setenv_TZ (const char *tzstring
)
2374 static ptrdiff_t tzvalbufsize
;
2375 ptrdiff_t tzstringlen
= tzstring
? strlen (tzstring
) : 0;
2376 char *tzval
= tzvalbuf
;
2377 bool new_tzvalbuf
= tzvalbufsize
<= tzeqlen
+ tzstringlen
;
2381 /* Do not attempt to free the old tzvalbuf, since another thread
2382 may be using it. In practice, the first allocation is large
2383 enough and memory does not leak. */
2384 tzval
= xpalloc (NULL
, &tzvalbufsize
,
2385 tzeqlen
+ tzstringlen
- tzvalbufsize
+ 1, -1, 1);
2393 /* Modify TZVAL in place. Although this is dicey in a
2394 multithreaded environment, we know of no portable alternative.
2395 Calling putenv or setenv could crash some other thread. */
2397 strcpy (tzval
+ tzeqlen
, tzstring
);
2401 /* Turn 'TZ=whatever' into an empty environment variable 'tZ='.
2402 Although this is also dicey, calling unsetenv here can crash Emacs.
2410 /* MS-Windows implementation of 'putenv' copies the argument
2411 string into a block it allocates, so modifying tzval string
2412 does not change the environment. OTOH, the other threads run
2413 by Emacs on MS-Windows never call 'xputenv' or 'putenv' or
2414 'unsetenv', so the original cause for the dicey in-place
2415 modification technique doesn't exist there in the first
2421 /* Although this is not thread-safe, in practice this runs only
2422 on startup when there is only one thread. */
2429 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
2430 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
2431 type of object is Lisp_String). INHERIT is passed to
2432 INSERT_FROM_STRING_FUNC as the last argument. */
2435 general_insert_function (void (*insert_func
)
2436 (const char *, ptrdiff_t),
2437 void (*insert_from_string_func
)
2438 (Lisp_Object
, ptrdiff_t, ptrdiff_t,
2439 ptrdiff_t, ptrdiff_t, bool),
2440 bool inherit
, ptrdiff_t nargs
, Lisp_Object
*args
)
2445 for (argnum
= 0; argnum
< nargs
; argnum
++)
2448 if (CHARACTERP (val
))
2450 int c
= XFASTINT (val
);
2451 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2454 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2455 len
= CHAR_STRING (c
, str
);
2458 str
[0] = CHAR_TO_BYTE8 (c
);
2461 (*insert_func
) ((char *) str
, len
);
2463 else if (STRINGP (val
))
2465 (*insert_from_string_func
) (val
, 0, 0,
2471 wrong_type_argument (Qchar_or_string_p
, val
);
2476 insert1 (Lisp_Object arg
)
2482 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
2483 doc
: /* Insert the arguments, either strings or characters, at point.
2484 Point and before-insertion markers move forward to end up
2485 after the inserted text.
2486 Any other markers at the point of insertion remain before the text.
2488 If the current buffer is multibyte, unibyte strings are converted
2489 to multibyte for insertion (see `string-make-multibyte').
2490 If the current buffer is unibyte, multibyte strings are converted
2491 to unibyte for insertion (see `string-make-unibyte').
2493 When operating on binary data, it may be necessary to preserve the
2494 original bytes of a unibyte string when inserting it into a multibyte
2495 buffer; to accomplish this, apply `string-as-multibyte' to the string
2496 and insert the result.
2498 usage: (insert &rest ARGS) */)
2499 (ptrdiff_t nargs
, Lisp_Object
*args
)
2501 general_insert_function (insert
, insert_from_string
, 0, nargs
, args
);
2505 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
2507 doc
: /* Insert the arguments at point, inheriting properties from adjoining text.
2508 Point and before-insertion markers move forward to end up
2509 after the inserted text.
2510 Any other markers at the point of insertion remain before the text.
2512 If the current buffer is multibyte, unibyte strings are converted
2513 to multibyte for insertion (see `unibyte-char-to-multibyte').
2514 If the current buffer is unibyte, multibyte strings are converted
2515 to unibyte for insertion.
2517 usage: (insert-and-inherit &rest ARGS) */)
2518 (ptrdiff_t nargs
, Lisp_Object
*args
)
2520 general_insert_function (insert_and_inherit
, insert_from_string
, 1,
2525 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
2526 doc
: /* Insert strings or characters at point, relocating markers after the text.
2527 Point and markers move forward to end up after the inserted text.
2529 If the current buffer is multibyte, unibyte strings are converted
2530 to multibyte for insertion (see `unibyte-char-to-multibyte').
2531 If the current buffer is unibyte, multibyte strings are converted
2532 to unibyte for insertion.
2534 If an overlay begins at the insertion point, the inserted text falls
2535 outside the overlay; if a nonempty overlay ends at the insertion
2536 point, the inserted text falls inside that overlay.
2538 usage: (insert-before-markers &rest ARGS) */)
2539 (ptrdiff_t nargs
, Lisp_Object
*args
)
2541 general_insert_function (insert_before_markers
,
2542 insert_from_string_before_markers
, 0,
2547 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers
,
2548 Sinsert_and_inherit_before_markers
, 0, MANY
, 0,
2549 doc
: /* Insert text at point, relocating markers and inheriting properties.
2550 Point and markers move forward to end up after the inserted text.
2552 If the current buffer is multibyte, unibyte strings are converted
2553 to multibyte for insertion (see `unibyte-char-to-multibyte').
2554 If the current buffer is unibyte, multibyte strings are converted
2555 to unibyte for insertion.
2557 usage: (insert-before-markers-and-inherit &rest ARGS) */)
2558 (ptrdiff_t nargs
, Lisp_Object
*args
)
2560 general_insert_function (insert_before_markers_and_inherit
,
2561 insert_from_string_before_markers
, 1,
2566 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 1, 3,
2567 "(list (read-char-by-name \"Insert character (Unicode name or hex): \")\
2568 (prefix-numeric-value current-prefix-arg)\
2570 doc
: /* Insert COUNT copies of CHARACTER.
2571 Interactively, prompt for CHARACTER. You can specify CHARACTER in one
2574 - As its Unicode character name, e.g. \"LATIN SMALL LETTER A\".
2575 Completion is available; if you type a substring of the name
2576 preceded by an asterisk `*', Emacs shows all names which include
2577 that substring, not necessarily at the beginning of the name.
2579 - As a hexadecimal code point, e.g. 263A. Note that code points in
2580 Emacs are equivalent to Unicode up to 10FFFF (which is the limit of
2581 the Unicode code space).
2583 - As a code point with a radix specified with #, e.g. #o21430
2584 (octal), #x2318 (hex), or #10r8984 (decimal).
2586 If called interactively, COUNT is given by the prefix argument. If
2587 omitted or nil, it defaults to 1.
2589 Inserting the character(s) relocates point and before-insertion
2590 markers in the same ways as the function `insert'.
2592 The optional third argument INHERIT, if non-nil, says to inherit text
2593 properties from adjoining text, if those properties are sticky. If
2594 called interactively, INHERIT is t. */)
2595 (Lisp_Object character
, Lisp_Object count
, Lisp_Object inherit
)
2598 register ptrdiff_t n
;
2600 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2603 CHECK_CHARACTER (character
);
2605 XSETFASTINT (count
, 1);
2606 CHECK_NUMBER (count
);
2607 c
= XFASTINT (character
);
2609 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2610 len
= CHAR_STRING (c
, str
);
2612 str
[0] = c
, len
= 1;
2613 if (XINT (count
) <= 0)
2615 if (BUF_BYTES_MAX
/ len
< XINT (count
))
2617 n
= XINT (count
) * len
;
2618 stringlen
= min (n
, sizeof string
- sizeof string
% len
);
2619 for (i
= 0; i
< stringlen
; i
++)
2620 string
[i
] = str
[i
% len
];
2621 while (n
> stringlen
)
2624 if (!NILP (inherit
))
2625 insert_and_inherit (string
, stringlen
);
2627 insert (string
, stringlen
);
2630 if (!NILP (inherit
))
2631 insert_and_inherit (string
, n
);
2637 DEFUN ("insert-byte", Finsert_byte
, Sinsert_byte
, 2, 3, 0,
2638 doc
: /* Insert COUNT (second arg) copies of BYTE (first arg).
2639 Both arguments are required.
2640 BYTE is a number of the range 0..255.
2642 If BYTE is 128..255 and the current buffer is multibyte, the
2643 corresponding eight-bit character is inserted.
2645 Point, and before-insertion markers, are relocated as in the function `insert'.
2646 The optional third arg INHERIT, if non-nil, says to inherit text properties
2647 from adjoining text, if those properties are sticky. */)
2648 (Lisp_Object byte
, Lisp_Object count
, Lisp_Object inherit
)
2650 CHECK_NUMBER (byte
);
2651 if (XINT (byte
) < 0 || XINT (byte
) > 255)
2652 args_out_of_range_3 (byte
, make_number (0), make_number (255));
2653 if (XINT (byte
) >= 128
2654 && ! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2655 XSETFASTINT (byte
, BYTE8_TO_CHAR (XINT (byte
)));
2656 return Finsert_char (byte
, count
, inherit
);
2660 /* Making strings from buffer contents. */
2662 /* Return a Lisp_String containing the text of the current buffer from
2663 START to END. If text properties are in use and the current buffer
2664 has properties in the range specified, the resulting string will also
2665 have them, if PROPS is true.
2667 We don't want to use plain old make_string here, because it calls
2668 make_uninit_string, which can cause the buffer arena to be
2669 compacted. make_string has no way of knowing that the data has
2670 been moved, and thus copies the wrong data into the string. This
2671 doesn't effect most of the other users of make_string, so it should
2672 be left as is. But we should use this function when conjuring
2673 buffer substrings. */
2676 make_buffer_string (ptrdiff_t start
, ptrdiff_t end
, bool props
)
2678 ptrdiff_t start_byte
= CHAR_TO_BYTE (start
);
2679 ptrdiff_t end_byte
= CHAR_TO_BYTE (end
);
2681 return make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
);
2684 /* Return a Lisp_String containing the text of the current buffer from
2685 START / START_BYTE to END / END_BYTE.
2687 If text properties are in use and the current buffer
2688 has properties in the range specified, the resulting string will also
2689 have them, if PROPS is true.
2691 We don't want to use plain old make_string here, because it calls
2692 make_uninit_string, which can cause the buffer arena to be
2693 compacted. make_string has no way of knowing that the data has
2694 been moved, and thus copies the wrong data into the string. This
2695 doesn't effect most of the other users of make_string, so it should
2696 be left as is. But we should use this function when conjuring
2697 buffer substrings. */
2700 make_buffer_string_both (ptrdiff_t start
, ptrdiff_t start_byte
,
2701 ptrdiff_t end
, ptrdiff_t end_byte
, bool props
)
2703 Lisp_Object result
, tem
, tem1
;
2704 ptrdiff_t beg0
, end0
, beg1
, end1
, size
;
2706 if (start_byte
< GPT_BYTE
&& GPT_BYTE
< end_byte
)
2708 /* Two regions, before and after the gap. */
2711 beg1
= GPT_BYTE
+ GAP_SIZE
- BEG_BYTE
;
2712 end1
= end_byte
+ GAP_SIZE
- BEG_BYTE
;
2716 /* The only region. */
2723 if (! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2724 result
= make_uninit_multibyte_string (end
- start
, end_byte
- start_byte
);
2726 result
= make_uninit_string (end
- start
);
2729 memcpy (SDATA (result
), BYTE_POS_ADDR (beg0
), size
);
2731 memcpy (SDATA (result
) + size
, BEG_ADDR
+ beg1
, end1
- beg1
);
2733 /* If desired, update and copy the text properties. */
2736 update_buffer_properties (start
, end
);
2738 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
2739 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
2741 if (XINT (tem
) != end
|| !NILP (tem1
))
2742 copy_intervals_to_string (result
, current_buffer
, start
,
2749 /* Call Vbuffer_access_fontify_functions for the range START ... END
2750 in the current buffer, if necessary. */
2753 update_buffer_properties (ptrdiff_t start
, ptrdiff_t end
)
2755 /* If this buffer has some access functions,
2756 call them, specifying the range of the buffer being accessed. */
2757 if (!NILP (Vbuffer_access_fontify_functions
))
2759 /* But don't call them if we can tell that the work
2760 has already been done. */
2761 if (!NILP (Vbuffer_access_fontified_property
))
2764 = Ftext_property_any (make_number (start
), make_number (end
),
2765 Vbuffer_access_fontified_property
,
2771 CALLN (Frun_hook_with_args
, Qbuffer_access_fontify_functions
,
2772 make_number (start
), make_number (end
));
2776 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
2777 doc
: /* Return the contents of part of the current buffer as a string.
2778 The two arguments START and END are character positions;
2779 they can be in either order.
2780 The string returned is multibyte if the buffer is multibyte.
2782 This function copies the text properties of that part of the buffer
2783 into the result string; if you don't want the text properties,
2784 use `buffer-substring-no-properties' instead. */)
2785 (Lisp_Object start
, Lisp_Object end
)
2787 register ptrdiff_t b
, e
;
2789 validate_region (&start
, &end
);
2793 return make_buffer_string (b
, e
, 1);
2796 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties
,
2797 Sbuffer_substring_no_properties
, 2, 2, 0,
2798 doc
: /* Return the characters of part of the buffer, without the text properties.
2799 The two arguments START and END are character positions;
2800 they can be in either order. */)
2801 (Lisp_Object start
, Lisp_Object end
)
2803 register ptrdiff_t b
, e
;
2805 validate_region (&start
, &end
);
2809 return make_buffer_string (b
, e
, 0);
2812 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
2813 doc
: /* Return the contents of the current buffer as a string.
2814 If narrowing is in effect, this function returns only the visible part
2818 return make_buffer_string_both (BEGV
, BEGV_BYTE
, ZV
, ZV_BYTE
, 1);
2821 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
2823 doc
: /* Insert before point a substring of the contents of BUFFER.
2824 BUFFER may be a buffer or a buffer name.
2825 Arguments START and END are character positions specifying the substring.
2826 They default to the values of (point-min) and (point-max) in BUFFER.
2828 Point and before-insertion markers move forward to end up after the
2830 Any other markers at the point of insertion remain before the text.
2832 If the current buffer is multibyte and BUFFER is unibyte, or vice
2833 versa, strings are converted from unibyte to multibyte or vice versa
2834 using `string-make-multibyte' or `string-make-unibyte', which see. */)
2835 (Lisp_Object buffer
, Lisp_Object start
, Lisp_Object end
)
2837 register EMACS_INT b
, e
, temp
;
2838 register struct buffer
*bp
, *obuf
;
2841 buf
= Fget_buffer (buffer
);
2845 if (!BUFFER_LIVE_P (bp
))
2846 error ("Selecting deleted buffer");
2852 CHECK_NUMBER_COERCE_MARKER (start
);
2859 CHECK_NUMBER_COERCE_MARKER (end
);
2864 temp
= b
, b
= e
, e
= temp
;
2866 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
2867 args_out_of_range (start
, end
);
2869 obuf
= current_buffer
;
2870 set_buffer_internal_1 (bp
);
2871 update_buffer_properties (b
, e
);
2872 set_buffer_internal_1 (obuf
);
2874 insert_from_buffer (bp
, b
, e
- b
, 0);
2878 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
2880 doc
: /* Compare two substrings of two buffers; return result as number.
2881 Return -N if first string is less after N-1 chars, +N if first string is
2882 greater after N-1 chars, or 0 if strings match. Each substring is
2883 represented as three arguments: BUFFER, START and END. That makes six
2884 args in all, three for each substring.
2886 The value of `case-fold-search' in the current buffer
2887 determines whether case is significant or ignored. */)
2888 (Lisp_Object buffer1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object buffer2
, Lisp_Object start2
, Lisp_Object end2
)
2890 register EMACS_INT begp1
, endp1
, begp2
, endp2
, temp
;
2891 register struct buffer
*bp1
, *bp2
;
2892 register Lisp_Object trt
2893 = (!NILP (BVAR (current_buffer
, case_fold_search
))
2894 ? BVAR (current_buffer
, case_canon_table
) : Qnil
);
2895 ptrdiff_t chars
= 0;
2896 ptrdiff_t i1
, i2
, i1_byte
, i2_byte
;
2898 /* Find the first buffer and its substring. */
2901 bp1
= current_buffer
;
2905 buf1
= Fget_buffer (buffer1
);
2908 bp1
= XBUFFER (buf1
);
2909 if (!BUFFER_LIVE_P (bp1
))
2910 error ("Selecting deleted buffer");
2914 begp1
= BUF_BEGV (bp1
);
2917 CHECK_NUMBER_COERCE_MARKER (start1
);
2918 begp1
= XINT (start1
);
2921 endp1
= BUF_ZV (bp1
);
2924 CHECK_NUMBER_COERCE_MARKER (end1
);
2925 endp1
= XINT (end1
);
2929 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
2931 if (!(BUF_BEGV (bp1
) <= begp1
2933 && endp1
<= BUF_ZV (bp1
)))
2934 args_out_of_range (start1
, end1
);
2936 /* Likewise for second substring. */
2939 bp2
= current_buffer
;
2943 buf2
= Fget_buffer (buffer2
);
2946 bp2
= XBUFFER (buf2
);
2947 if (!BUFFER_LIVE_P (bp2
))
2948 error ("Selecting deleted buffer");
2952 begp2
= BUF_BEGV (bp2
);
2955 CHECK_NUMBER_COERCE_MARKER (start2
);
2956 begp2
= XINT (start2
);
2959 endp2
= BUF_ZV (bp2
);
2962 CHECK_NUMBER_COERCE_MARKER (end2
);
2963 endp2
= XINT (end2
);
2967 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
2969 if (!(BUF_BEGV (bp2
) <= begp2
2971 && endp2
<= BUF_ZV (bp2
)))
2972 args_out_of_range (start2
, end2
);
2976 i1_byte
= buf_charpos_to_bytepos (bp1
, i1
);
2977 i2_byte
= buf_charpos_to_bytepos (bp2
, i2
);
2979 while (i1
< endp1
&& i2
< endp2
)
2981 /* When we find a mismatch, we must compare the
2982 characters, not just the bytes. */
2987 if (! NILP (BVAR (bp1
, enable_multibyte_characters
)))
2989 c1
= BUF_FETCH_MULTIBYTE_CHAR (bp1
, i1_byte
);
2990 BUF_INC_POS (bp1
, i1_byte
);
2995 c1
= BUF_FETCH_BYTE (bp1
, i1
);
2996 MAKE_CHAR_MULTIBYTE (c1
);
3000 if (! NILP (BVAR (bp2
, enable_multibyte_characters
)))
3002 c2
= BUF_FETCH_MULTIBYTE_CHAR (bp2
, i2_byte
);
3003 BUF_INC_POS (bp2
, i2_byte
);
3008 c2
= BUF_FETCH_BYTE (bp2
, i2
);
3009 MAKE_CHAR_MULTIBYTE (c2
);
3015 c1
= char_table_translate (trt
, c1
);
3016 c2
= char_table_translate (trt
, c2
);
3019 return make_number (- 1 - chars
);
3021 return make_number (chars
+ 1);
3026 /* The strings match as far as they go.
3027 If one is shorter, that one is less. */
3028 if (chars
< endp1
- begp1
)
3029 return make_number (chars
+ 1);
3030 else if (chars
< endp2
- begp2
)
3031 return make_number (- chars
- 1);
3033 /* Same length too => they are equal. */
3034 return make_number (0);
3038 subst_char_in_region_unwind (Lisp_Object arg
)
3040 bset_undo_list (current_buffer
, arg
);
3044 subst_char_in_region_unwind_1 (Lisp_Object arg
)
3046 bset_filename (current_buffer
, arg
);
3049 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
3050 Ssubst_char_in_region
, 4, 5, 0,
3051 doc
: /* From START to END, replace FROMCHAR with TOCHAR each time it occurs.
3052 If optional arg NOUNDO is non-nil, don't record this change for undo
3053 and don't mark the buffer as really changed.
3054 Both characters must have the same length of multi-byte form. */)
3055 (Lisp_Object start
, Lisp_Object end
, Lisp_Object fromchar
, Lisp_Object tochar
, Lisp_Object noundo
)
3057 register ptrdiff_t pos
, pos_byte
, stop
, i
, len
, end_byte
;
3058 /* Keep track of the first change in the buffer:
3059 if 0 we haven't found it yet.
3060 if < 0 we've found it and we've run the before-change-function.
3061 if > 0 we've actually performed it and the value is its position. */
3062 ptrdiff_t changed
= 0;
3063 unsigned char fromstr
[MAX_MULTIBYTE_LENGTH
], tostr
[MAX_MULTIBYTE_LENGTH
];
3065 ptrdiff_t count
= SPECPDL_INDEX ();
3066 #define COMBINING_NO 0
3067 #define COMBINING_BEFORE 1
3068 #define COMBINING_AFTER 2
3069 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
3070 int maybe_byte_combining
= COMBINING_NO
;
3071 ptrdiff_t last_changed
= 0;
3073 = !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3078 validate_region (&start
, &end
);
3079 CHECK_CHARACTER (fromchar
);
3080 CHECK_CHARACTER (tochar
);
3081 fromc
= XFASTINT (fromchar
);
3082 toc
= XFASTINT (tochar
);
3086 len
= CHAR_STRING (fromc
, fromstr
);
3087 if (CHAR_STRING (toc
, tostr
) != len
)
3088 error ("Characters in `subst-char-in-region' have different byte-lengths");
3089 if (!ASCII_CHAR_P (*tostr
))
3091 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
3092 complete multibyte character, it may be combined with the
3093 after bytes. If it is in the range 0xA0..0xFF, it may be
3094 combined with the before and after bytes. */
3095 if (!CHAR_HEAD_P (*tostr
))
3096 maybe_byte_combining
= COMBINING_BOTH
;
3097 else if (BYTES_BY_CHAR_HEAD (*tostr
) > len
)
3098 maybe_byte_combining
= COMBINING_AFTER
;
3109 pos_byte
= CHAR_TO_BYTE (pos
);
3110 stop
= CHAR_TO_BYTE (XINT (end
));
3113 /* If we don't want undo, turn off putting stuff on the list.
3114 That's faster than getting rid of things,
3115 and it prevents even the entry for a first change.
3116 Also inhibit locking the file. */
3117 if (!changed
&& !NILP (noundo
))
3119 record_unwind_protect (subst_char_in_region_unwind
,
3120 BVAR (current_buffer
, undo_list
));
3121 bset_undo_list (current_buffer
, Qt
);
3122 /* Don't do file-locking. */
3123 record_unwind_protect (subst_char_in_region_unwind_1
,
3124 BVAR (current_buffer
, filename
));
3125 bset_filename (current_buffer
, Qnil
);
3128 if (pos_byte
< GPT_BYTE
)
3129 stop
= min (stop
, GPT_BYTE
);
3132 ptrdiff_t pos_byte_next
= pos_byte
;
3134 if (pos_byte
>= stop
)
3136 if (pos_byte
>= end_byte
) break;
3139 p
= BYTE_POS_ADDR (pos_byte
);
3141 INC_POS (pos_byte_next
);
3144 if (pos_byte_next
- pos_byte
== len
3145 && p
[0] == fromstr
[0]
3147 || (p
[1] == fromstr
[1]
3148 && (len
== 2 || (p
[2] == fromstr
[2]
3149 && (len
== 3 || p
[3] == fromstr
[3]))))))
3152 /* We've already seen this and run the before-change-function;
3153 this time we only need to record the actual position. */
3158 modify_text (pos
, XINT (end
));
3160 if (! NILP (noundo
))
3162 if (MODIFF
- 1 == SAVE_MODIFF
)
3164 if (MODIFF
- 1 == BUF_AUTOSAVE_MODIFF (current_buffer
))
3165 BUF_AUTOSAVE_MODIFF (current_buffer
)++;
3168 /* The before-change-function may have moved the gap
3169 or even modified the buffer so we should start over. */
3173 /* Take care of the case where the new character
3174 combines with neighboring bytes. */
3175 if (maybe_byte_combining
3176 && (maybe_byte_combining
== COMBINING_AFTER
3177 ? (pos_byte_next
< Z_BYTE
3178 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
3179 : ((pos_byte_next
< Z_BYTE
3180 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
3181 || (pos_byte
> BEG_BYTE
3182 && ! ASCII_CHAR_P (FETCH_BYTE (pos_byte
- 1))))))
3184 Lisp_Object tem
, string
;
3186 tem
= BVAR (current_buffer
, undo_list
);
3188 /* Make a multibyte string containing this single character. */
3189 string
= make_multibyte_string ((char *) tostr
, 1, len
);
3190 /* replace_range is less efficient, because it moves the gap,
3191 but it handles combining correctly. */
3192 replace_range (pos
, pos
+ 1, string
,
3194 pos_byte_next
= CHAR_TO_BYTE (pos
);
3195 if (pos_byte_next
> pos_byte
)
3196 /* Before combining happened. We should not increment
3197 POS. So, to cancel the later increment of POS,
3201 INC_POS (pos_byte_next
);
3203 if (! NILP (noundo
))
3204 bset_undo_list (current_buffer
, tem
);
3209 record_change (pos
, 1);
3210 for (i
= 0; i
< len
; i
++) *p
++ = tostr
[i
];
3212 last_changed
= pos
+ 1;
3214 pos_byte
= pos_byte_next
;
3220 signal_after_change (changed
,
3221 last_changed
- changed
, last_changed
- changed
);
3222 update_compositions (changed
, last_changed
, CHECK_ALL
);
3225 unbind_to (count
, Qnil
);
3230 static Lisp_Object
check_translation (ptrdiff_t, ptrdiff_t, ptrdiff_t,
3233 /* Helper function for Ftranslate_region_internal.
3235 Check if a character sequence at POS (POS_BYTE) matches an element
3236 of VAL. VAL is a list (([FROM-CHAR ...] . TO) ...). If a matching
3237 element is found, return it. Otherwise return Qnil. */
3240 check_translation (ptrdiff_t pos
, ptrdiff_t pos_byte
, ptrdiff_t end
,
3243 int initial_buf
[16];
3244 int *buf
= initial_buf
;
3245 ptrdiff_t buf_size
= ARRAYELTS (initial_buf
);
3247 ptrdiff_t buf_used
= 0;
3248 Lisp_Object result
= Qnil
;
3250 for (; CONSP (val
); val
= XCDR (val
))
3259 if (! VECTORP (elt
))
3262 if (len
<= end
- pos
)
3264 for (i
= 0; i
< len
; i
++)
3268 unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
3271 if (buf_used
== buf_size
)
3273 bufalloc
= xpalloc (bufalloc
, &buf_size
, 1, -1,
3275 if (buf
== initial_buf
)
3276 memcpy (bufalloc
, buf
, sizeof initial_buf
);
3279 buf
[buf_used
++] = STRING_CHAR_AND_LENGTH (p
, len1
);
3282 if (XINT (AREF (elt
, i
)) != buf
[i
])
3287 result
= XCAR (val
);
3298 DEFUN ("translate-region-internal", Ftranslate_region_internal
,
3299 Stranslate_region_internal
, 3, 3, 0,
3300 doc
: /* Internal use only.
3301 From START to END, translate characters according to TABLE.
3302 TABLE is a string or a char-table; the Nth character in it is the
3303 mapping for the character with code N.
3304 It returns the number of characters changed. */)
3305 (Lisp_Object start
, Lisp_Object end
, register Lisp_Object table
)
3307 register unsigned char *tt
; /* Trans table. */
3308 register int nc
; /* New character. */
3309 int cnt
; /* Number of changes made. */
3310 ptrdiff_t size
; /* Size of translate table. */
3311 ptrdiff_t pos
, pos_byte
, end_pos
;
3312 bool multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3313 bool string_multibyte
IF_LINT (= 0);
3315 validate_region (&start
, &end
);
3316 if (CHAR_TABLE_P (table
))
3318 if (! EQ (XCHAR_TABLE (table
)->purpose
, Qtranslation_table
))
3319 error ("Not a translation table");
3325 CHECK_STRING (table
);
3327 if (! multibyte
&& (SCHARS (table
) < SBYTES (table
)))
3328 table
= string_make_unibyte (table
);
3329 string_multibyte
= SCHARS (table
) < SBYTES (table
);
3330 size
= SBYTES (table
);
3335 pos_byte
= CHAR_TO_BYTE (pos
);
3336 end_pos
= XINT (end
);
3337 modify_text (pos
, end_pos
);
3340 for (; pos
< end_pos
; )
3342 register unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
3343 unsigned char *str
, buf
[MAX_MULTIBYTE_LENGTH
];
3349 oc
= STRING_CHAR_AND_LENGTH (p
, len
);
3356 /* Reload as signal_after_change in last iteration may GC. */
3358 if (string_multibyte
)
3360 str
= tt
+ string_char_to_byte (table
, oc
);
3361 nc
= STRING_CHAR_AND_LENGTH (str
, str_len
);
3366 if (! ASCII_CHAR_P (nc
) && multibyte
)
3368 str_len
= BYTE8_STRING (nc
, buf
);
3381 val
= CHAR_TABLE_REF (table
, oc
);
3382 if (CHARACTERP (val
))
3384 nc
= XFASTINT (val
);
3385 str_len
= CHAR_STRING (nc
, buf
);
3388 else if (VECTORP (val
) || (CONSP (val
)))
3390 /* VAL is [TO_CHAR ...] or (([FROM-CHAR ...] . TO) ...)
3391 where TO is TO-CHAR or [TO-CHAR ...]. */
3396 if (nc
!= oc
&& nc
>= 0)
3398 /* Simple one char to one char translation. */
3403 /* This is less efficient, because it moves the gap,
3404 but it should handle multibyte characters correctly. */
3405 string
= make_multibyte_string ((char *) str
, 1, str_len
);
3406 replace_range (pos
, pos
+ 1, string
, 1, 0, 1);
3411 record_change (pos
, 1);
3412 while (str_len
-- > 0)
3414 signal_after_change (pos
, 1, 1);
3415 update_compositions (pos
, pos
+ 1, CHECK_BORDER
);
3425 val
= check_translation (pos
, pos_byte
, end_pos
, val
);
3432 /* VAL is ([FROM-CHAR ...] . TO). */
3433 len
= ASIZE (XCAR (val
));
3441 string
= Fconcat (1, &val
);
3445 string
= Fmake_string (make_number (1), val
);
3447 replace_range (pos
, pos
+ len
, string
, 1, 0, 1);
3448 pos_byte
+= SBYTES (string
);
3449 pos
+= SCHARS (string
);
3450 cnt
+= SCHARS (string
);
3451 end_pos
+= SCHARS (string
) - len
;
3459 return make_number (cnt
);
3462 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
3463 doc
: /* Delete the text between START and END.
3464 If called interactively, delete the region between point and mark.
3465 This command deletes buffer text without modifying the kill ring. */)
3466 (Lisp_Object start
, Lisp_Object end
)
3468 validate_region (&start
, &end
);
3469 del_range (XINT (start
), XINT (end
));
3473 DEFUN ("delete-and-extract-region", Fdelete_and_extract_region
,
3474 Sdelete_and_extract_region
, 2, 2, 0,
3475 doc
: /* Delete the text between START and END and return it. */)
3476 (Lisp_Object start
, Lisp_Object end
)
3478 validate_region (&start
, &end
);
3479 if (XINT (start
) == XINT (end
))
3480 return empty_unibyte_string
;
3481 return del_range_1 (XINT (start
), XINT (end
), 1, 1);
3484 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
3485 doc
: /* Remove restrictions (narrowing) from current buffer.
3486 This allows the buffer's full text to be seen and edited. */)
3489 if (BEG
!= BEGV
|| Z
!= ZV
)
3490 current_buffer
->clip_changed
= 1;
3492 BEGV_BYTE
= BEG_BYTE
;
3493 SET_BUF_ZV_BOTH (current_buffer
, Z
, Z_BYTE
);
3494 /* Changing the buffer bounds invalidates any recorded current column. */
3495 invalidate_current_column ();
3499 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
3500 doc
: /* Restrict editing in this buffer to the current region.
3501 The rest of the text becomes temporarily invisible and untouchable
3502 but is not deleted; if you save the buffer in a file, the invisible
3503 text is included in the file. \\[widen] makes all visible again.
3504 See also `save-restriction'.
3506 When calling from a program, pass two arguments; positions (integers
3507 or markers) bounding the text that should remain visible. */)
3508 (register Lisp_Object start
, Lisp_Object end
)
3510 CHECK_NUMBER_COERCE_MARKER (start
);
3511 CHECK_NUMBER_COERCE_MARKER (end
);
3513 if (XINT (start
) > XINT (end
))
3516 tem
= start
; start
= end
; end
= tem
;
3519 if (!(BEG
<= XINT (start
) && XINT (start
) <= XINT (end
) && XINT (end
) <= Z
))
3520 args_out_of_range (start
, end
);
3522 if (BEGV
!= XFASTINT (start
) || ZV
!= XFASTINT (end
))
3523 current_buffer
->clip_changed
= 1;
3525 SET_BUF_BEGV (current_buffer
, XFASTINT (start
));
3526 SET_BUF_ZV (current_buffer
, XFASTINT (end
));
3527 if (PT
< XFASTINT (start
))
3528 SET_PT (XFASTINT (start
));
3529 if (PT
> XFASTINT (end
))
3530 SET_PT (XFASTINT (end
));
3531 /* Changing the buffer bounds invalidates any recorded current column. */
3532 invalidate_current_column ();
3537 save_restriction_save (void)
3539 if (BEGV
== BEG
&& ZV
== Z
)
3540 /* The common case that the buffer isn't narrowed.
3541 We return just the buffer object, which save_restriction_restore
3542 recognizes as meaning `no restriction'. */
3543 return Fcurrent_buffer ();
3545 /* We have to save a restriction, so return a pair of markers, one
3546 for the beginning and one for the end. */
3548 Lisp_Object beg
, end
;
3550 beg
= build_marker (current_buffer
, BEGV
, BEGV_BYTE
);
3551 end
= build_marker (current_buffer
, ZV
, ZV_BYTE
);
3553 /* END must move forward if text is inserted at its exact location. */
3554 XMARKER (end
)->insertion_type
= 1;
3556 return Fcons (beg
, end
);
3561 save_restriction_restore (Lisp_Object data
)
3563 struct buffer
*cur
= NULL
;
3564 struct buffer
*buf
= (CONSP (data
)
3565 ? XMARKER (XCAR (data
))->buffer
3568 if (buf
&& buf
!= current_buffer
&& !NILP (BVAR (buf
, pt_marker
)))
3569 { /* If `buf' uses markers to keep track of PT, BEGV, and ZV (as
3570 is the case if it is or has an indirect buffer), then make
3571 sure it is current before we update BEGV, so
3572 set_buffer_internal takes care of managing those markers. */
3573 cur
= current_buffer
;
3574 set_buffer_internal (buf
);
3578 /* A pair of marks bounding a saved restriction. */
3580 struct Lisp_Marker
*beg
= XMARKER (XCAR (data
));
3581 struct Lisp_Marker
*end
= XMARKER (XCDR (data
));
3582 eassert (buf
== end
->buffer
);
3584 if (buf
/* Verify marker still points to a buffer. */
3585 && (beg
->charpos
!= BUF_BEGV (buf
) || end
->charpos
!= BUF_ZV (buf
)))
3586 /* The restriction has changed from the saved one, so restore
3587 the saved restriction. */
3589 ptrdiff_t pt
= BUF_PT (buf
);
3591 SET_BUF_BEGV_BOTH (buf
, beg
->charpos
, beg
->bytepos
);
3592 SET_BUF_ZV_BOTH (buf
, end
->charpos
, end
->bytepos
);
3594 if (pt
< beg
->charpos
|| pt
> end
->charpos
)
3595 /* The point is outside the new visible range, move it inside. */
3596 SET_BUF_PT_BOTH (buf
,
3597 clip_to_bounds (beg
->charpos
, pt
, end
->charpos
),
3598 clip_to_bounds (beg
->bytepos
, BUF_PT_BYTE (buf
),
3601 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3603 /* These aren't needed anymore, so don't wait for GC. */
3604 free_marker (XCAR (data
));
3605 free_marker (XCDR (data
));
3606 free_cons (XCONS (data
));
3609 /* A buffer, which means that there was no old restriction. */
3611 if (buf
/* Verify marker still points to a buffer. */
3612 && (BUF_BEGV (buf
) != BUF_BEG (buf
) || BUF_ZV (buf
) != BUF_Z (buf
)))
3613 /* The buffer has been narrowed, get rid of the narrowing. */
3615 SET_BUF_BEGV_BOTH (buf
, BUF_BEG (buf
), BUF_BEG_BYTE (buf
));
3616 SET_BUF_ZV_BOTH (buf
, BUF_Z (buf
), BUF_Z_BYTE (buf
));
3618 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3622 /* Changing the buffer bounds invalidates any recorded current column. */
3623 invalidate_current_column ();
3626 set_buffer_internal (cur
);
3629 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
3630 doc
: /* Execute BODY, saving and restoring current buffer's restrictions.
3631 The buffer's restrictions make parts of the beginning and end invisible.
3632 \(They are set up with `narrow-to-region' and eliminated with `widen'.)
3633 This special form, `save-restriction', saves the current buffer's restrictions
3634 when it is entered, and restores them when it is exited.
3635 So any `narrow-to-region' within BODY lasts only until the end of the form.
3636 The old restrictions settings are restored
3637 even in case of abnormal exit (throw or error).
3639 The value returned is the value of the last form in BODY.
3641 Note: if you are using both `save-excursion' and `save-restriction',
3642 use `save-excursion' outermost:
3643 (save-excursion (save-restriction ...))
3645 usage: (save-restriction &rest BODY) */)
3648 register Lisp_Object val
;
3649 ptrdiff_t count
= SPECPDL_INDEX ();
3651 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
3652 val
= Fprogn (body
);
3653 return unbind_to (count
, val
);
3656 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
3657 doc
: /* Display a message at the bottom of the screen.
3658 The message also goes into the `*Messages*' buffer, if `message-log-max'
3659 is non-nil. (In keyboard macros, that's all it does.)
3662 In batch mode, the message is printed to the standard error stream,
3663 followed by a newline.
3665 The first argument is a format control string, and the rest are data
3666 to be formatted under control of the string. See `format' for details.
3668 Note: Use (message "%s" VALUE) to print the value of expressions and
3669 variables to avoid accidentally interpreting `%' as format specifiers.
3671 If the first argument is nil or the empty string, the function clears
3672 any existing message; this lets the minibuffer contents show. See
3673 also `current-message'.
3675 usage: (message FORMAT-STRING &rest ARGS) */)
3676 (ptrdiff_t nargs
, Lisp_Object
*args
)
3679 || (STRINGP (args
[0])
3680 && SBYTES (args
[0]) == 0))
3687 Lisp_Object val
= Fformat_message (nargs
, args
);
3693 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
3694 doc
: /* Display a message, in a dialog box if possible.
3695 If a dialog box is not available, use the echo area.
3696 The first argument is a format control string, and the rest are data
3697 to be formatted under control of the string. See `format' for details.
3699 If the first argument is nil or the empty string, clear any existing
3700 message; let the minibuffer contents show.
3702 usage: (message-box FORMAT-STRING &rest ARGS) */)
3703 (ptrdiff_t nargs
, Lisp_Object
*args
)
3712 Lisp_Object val
= Fformat_message (nargs
, args
);
3713 Lisp_Object pane
, menu
;
3715 pane
= list1 (Fcons (build_string ("OK"), Qt
));
3716 menu
= Fcons (val
, pane
);
3717 Fx_popup_dialog (Qt
, menu
, Qt
);
3722 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
3723 doc
: /* Display a message in a dialog box or in the echo area.
3724 If this command was invoked with the mouse, use a dialog box if
3725 `use-dialog-box' is non-nil.
3726 Otherwise, use the echo area.
3727 The first argument is a format control string, and the rest are data
3728 to be formatted under control of the string. See `format' for details.
3730 If the first argument is nil or the empty string, clear any existing
3731 message; let the minibuffer contents show.
3733 usage: (message-or-box FORMAT-STRING &rest ARGS) */)
3734 (ptrdiff_t nargs
, Lisp_Object
*args
)
3736 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3738 return Fmessage_box (nargs
, args
);
3739 return Fmessage (nargs
, args
);
3742 DEFUN ("current-message", Fcurrent_message
, Scurrent_message
, 0, 0, 0,
3743 doc
: /* Return the string currently displayed in the echo area, or nil if none. */)
3746 return current_message ();
3750 DEFUN ("propertize", Fpropertize
, Spropertize
, 1, MANY
, 0,
3751 doc
: /* Return a copy of STRING with text properties added.
3752 First argument is the string to copy.
3753 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
3754 properties to add to the result.
3755 usage: (propertize STRING &rest PROPERTIES) */)
3756 (ptrdiff_t nargs
, Lisp_Object
*args
)
3758 Lisp_Object properties
, string
;
3761 /* Number of args must be odd. */
3762 if ((nargs
& 1) == 0)
3763 error ("Wrong number of arguments");
3765 properties
= string
= Qnil
;
3767 /* First argument must be a string. */
3768 CHECK_STRING (args
[0]);
3769 string
= Fcopy_sequence (args
[0]);
3771 for (i
= 1; i
< nargs
; i
+= 2)
3772 properties
= Fcons (args
[i
], Fcons (args
[i
+ 1], properties
));
3774 Fadd_text_properties (make_number (0),
3775 make_number (SCHARS (string
)),
3776 properties
, string
);
3780 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
3781 doc
: /* Format a string out of a format-string and arguments.
3782 The first argument is a format control string.
3783 The other arguments are substituted into it to make the result, a string.
3785 The format control string may contain %-sequences meaning to substitute
3786 the next available argument:
3788 %s means print a string argument. Actually, prints any object, with `princ'.
3789 %d means print as number in decimal (%o octal, %x hex).
3790 %X is like %x, but uses upper case.
3791 %e means print a number in exponential notation.
3792 %f means print a number in decimal-point notation.
3793 %g means print a number in exponential notation
3794 or decimal-point notation, whichever uses fewer characters.
3795 %c means print a number as a single character.
3796 %S means print any object as an s-expression (using `prin1').
3798 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
3799 Use %% to put a single % into the output.
3801 A %-sequence may contain optional flag, width, and precision
3802 specifiers, as follows:
3804 %<flags><width><precision>character
3806 where flags is [+ #-0]+, width is [0-9]+, and precision is .[0-9]+
3808 The + flag character inserts a + before any positive number, while a
3809 space inserts a space before any positive number; these flags only
3810 affect %d, %e, %f, and %g sequences, and the + flag takes precedence.
3811 The - and 0 flags affect the width specifier, as described below.
3813 The # flag means to use an alternate display form for %o, %x, %X, %e,
3814 %f, and %g sequences: for %o, it ensures that the result begins with
3815 \"0\"; for %x and %X, it prefixes the result with \"0x\" or \"0X\";
3816 for %e, %f, and %g, it causes a decimal point to be included even if
3817 the precision is zero.
3819 The width specifier supplies a lower limit for the length of the
3820 printed representation. The padding, if any, normally goes on the
3821 left, but it goes on the right if the - flag is present. The padding
3822 character is normally a space, but it is 0 if the 0 flag is present.
3823 The 0 flag is ignored if the - flag is present, or the format sequence
3824 is something other than %d, %e, %f, and %g.
3826 For %e, %f, and %g sequences, the number after the "." in the
3827 precision specifier says how many decimal places to show; if zero, the
3828 decimal point itself is omitted. For %s and %S, the precision
3829 specifier truncates the string to the given width.
3831 usage: (format STRING &rest OBJECTS) */)
3832 (ptrdiff_t nargs
, Lisp_Object
*args
)
3834 return styled_format (nargs
, args
, false);
3837 DEFUN ("format-message", Fformat_message
, Sformat_message
, 1, MANY
, 0,
3838 doc
: /* Format a string out of a format-string and arguments.
3839 The first argument is a format control string.
3840 The other arguments are substituted into it to make the result, a string.
3842 This acts like `format', except it also replaces each left single
3843 quotation mark (\\=‘) and grave accent (\\=`) by a left quote, and each
3844 right single quotation mark (\\=’) and apostrophe (\\=') by a right quote.
3845 The left and right quote replacement characters are specified by
3846 `text-quoting-style'.
3848 usage: (format-message STRING &rest OBJECTS) */)
3849 (ptrdiff_t nargs
, Lisp_Object
*args
)
3851 return styled_format (nargs
, args
, true);
3854 /* Implement ‘format-message’ if MESSAGE is true, ‘format’ otherwise. */
3857 styled_format (ptrdiff_t nargs
, Lisp_Object
*args
, bool message
)
3859 ptrdiff_t n
; /* The number of the next arg to substitute. */
3860 char initial_buffer
[4000];
3861 char *buf
= initial_buffer
;
3862 ptrdiff_t bufsize
= sizeof initial_buffer
;
3863 ptrdiff_t max_bufsize
= STRING_BYTES_BOUND
+ 1;
3865 ptrdiff_t buf_save_value_index
IF_LINT (= 0);
3868 /* When we make a multibyte string, we must pay attention to the
3869 byte combining problem, i.e., a byte may be combined with a
3870 multibyte character of the previous string. This flag tells if we
3871 must consider such a situation or not. */
3872 bool maybe_combine_byte
;
3873 bool arg_intervals
= false;
3876 /* Each element records, for one argument,
3877 the start and end bytepos in the output string,
3878 whether the argument has been converted to string (e.g., due to "%S"),
3879 and whether the argument is a string with intervals. */
3882 ptrdiff_t start
, end
;
3883 bool_bf converted_to_string
: 1;
3884 bool_bf intervals
: 1;
3887 CHECK_STRING (args
[0]);
3888 char *format_start
= SSDATA (args
[0]);
3889 ptrdiff_t formatlen
= SBYTES (args
[0]);
3891 /* Allocate the info and discarded tables. */
3892 ptrdiff_t alloca_size
;
3893 if (INT_MULTIPLY_WRAPV (nargs
, sizeof *info
, &alloca_size
)
3894 || INT_ADD_WRAPV (sizeof *info
, alloca_size
, &alloca_size
)
3895 || INT_ADD_WRAPV (formatlen
, alloca_size
, &alloca_size
)
3896 || SIZE_MAX
< alloca_size
)
3897 memory_full (SIZE_MAX
);
3898 /* info[0] is unused. Unused elements have -1 for start. */
3899 info
= SAFE_ALLOCA (alloca_size
);
3900 memset (info
, 0, alloca_size
);
3901 for (ptrdiff_t i
= 0; i
< nargs
+ 1; i
++)
3903 /* discarded[I] is 1 if byte I of the format
3904 string was not copied into the output.
3905 It is 2 if byte I was not the first byte of its character. */
3906 char *discarded
= (char *) &info
[nargs
+ 1];
3908 /* Try to determine whether the result should be multibyte.
3909 This is not always right; sometimes the result needs to be multibyte
3910 because of an object that we will pass through prin1.
3911 or because a grave accent or apostrophe is requoted,
3912 and in that case, we won't know it here. */
3914 /* True if the format is multibyte. */
3915 bool multibyte_format
= STRING_MULTIBYTE (args
[0]);
3916 /* True if the output should be a multibyte string,
3917 which is true if any of the inputs is one. */
3918 bool multibyte
= multibyte_format
;
3919 for (ptrdiff_t i
= 1; !multibyte
&& i
< nargs
; i
++)
3920 if (STRINGP (args
[i
]) && STRING_MULTIBYTE (args
[i
]))
3923 int quoting_style
= message
? text_quoting_style () : -1;
3925 /* If we start out planning a unibyte result,
3926 then discover it has to be multibyte, we jump back to retry. */
3933 /* Scan the format and store result in BUF. */
3934 format
= format_start
;
3935 end
= format
+ formatlen
;
3936 maybe_combine_byte
= false;
3938 while (format
!= end
)
3940 /* The values of N and FORMAT when the loop body is entered. */
3942 char *format0
= format
;
3943 char const *convsrc
= format
;
3944 unsigned char format_char
= *format
++;
3946 /* Bytes needed to represent the output of this conversion. */
3947 ptrdiff_t convbytes
= 1;
3949 if (format_char
== '%')
3951 /* General format specifications look like
3953 '%' [flags] [field-width] [precision] format
3958 field-width ::= [0-9]+
3959 precision ::= '.' [0-9]*
3961 If a field-width is specified, it specifies to which width
3962 the output should be padded with blanks, if the output
3963 string is shorter than field-width.
3965 If precision is specified, it specifies the number of
3966 digits to print after the '.' for floats, or the max.
3967 number of chars to print from a string. */
3969 bool minus_flag
= false;
3970 bool plus_flag
= false;
3971 bool space_flag
= false;
3972 bool sharp_flag
= false;
3973 bool zero_flag
= false;
3979 case '-': minus_flag
= true; continue;
3980 case '+': plus_flag
= true; continue;
3981 case ' ': space_flag
= true; continue;
3982 case '#': sharp_flag
= true; continue;
3983 case '0': zero_flag
= true; continue;
3988 /* Ignore flags when sprintf ignores them. */
3989 space_flag
&= ~ plus_flag
;
3990 zero_flag
&= ~ minus_flag
;
3993 uintmax_t raw_field_width
= strtoumax (format
, &num_end
, 10);
3994 if (max_bufsize
<= raw_field_width
)
3996 ptrdiff_t field_width
= raw_field_width
;
3998 bool precision_given
= *num_end
== '.';
3999 uintmax_t precision
= (precision_given
4000 ? strtoumax (num_end
+ 1, &num_end
, 10)
4005 error ("Format string ends in middle of format specifier");
4007 char conversion
= *format
++;
4008 memset (&discarded
[format0
- format_start
], 1,
4009 format
- format0
- (conversion
== '%'));
4010 if (conversion
== '%')
4015 error ("Not enough arguments for format string");
4017 /* For 'S', prin1 the argument, and then treat like 's'.
4018 For 's', princ any argument that is not a string or
4019 symbol. But don't do this conversion twice, which might
4020 happen after retrying. */
4021 if ((conversion
== 'S'
4022 || (conversion
== 's'
4023 && ! STRINGP (args
[n
]) && ! SYMBOLP (args
[n
]))))
4025 if (! info
[n
].converted_to_string
)
4027 Lisp_Object noescape
= conversion
== 'S' ? Qnil
: Qt
;
4028 args
[n
] = Fprin1_to_string (args
[n
], noescape
);
4029 info
[n
].converted_to_string
= true;
4030 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
4038 else if (conversion
== 'c')
4040 if (FLOATP (args
[n
]))
4042 double d
= XFLOAT_DATA (args
[n
]);
4043 args
[n
] = make_number (FIXNUM_OVERFLOW_P (d
) ? -1 : d
);
4046 if (INTEGERP (args
[n
]) && ! ASCII_CHAR_P (XINT (args
[n
])))
4053 args
[n
] = Fchar_to_string (args
[n
]);
4054 info
[n
].converted_to_string
= true;
4057 if (info
[n
].converted_to_string
)
4062 if (SYMBOLP (args
[n
]))
4064 args
[n
] = SYMBOL_NAME (args
[n
]);
4065 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
4072 if (conversion
== 's')
4074 /* handle case (precision[n] >= 0) */
4076 ptrdiff_t prec
= -1;
4077 if (precision_given
&& precision
<= TYPE_MAXIMUM (ptrdiff_t))
4080 /* lisp_string_width ignores a precision of 0, but GNU
4081 libc functions print 0 characters when the precision
4082 is 0. Imitate libc behavior here. Changing
4083 lisp_string_width is the right thing, and will be
4084 done, but meanwhile we work with it. */
4086 ptrdiff_t width
, nbytes
;
4087 ptrdiff_t nchars_string
;
4089 width
= nchars_string
= nbytes
= 0;
4093 width
= lisp_string_width (args
[n
], prec
, &nch
, &nby
);
4096 nchars_string
= SCHARS (args
[n
]);
4097 nbytes
= SBYTES (args
[n
]);
4101 nchars_string
= nch
;
4107 if (convbytes
&& multibyte
&& ! STRING_MULTIBYTE (args
[n
]))
4108 convbytes
= count_size_as_multibyte (SDATA (args
[n
]), nbytes
);
4111 = width
< field_width
? field_width
- width
: 0;
4113 if (max_bufsize
- padding
<= convbytes
)
4115 convbytes
+= padding
;
4116 if (convbytes
<= buf
+ bufsize
- p
)
4120 memset (p
, ' ', padding
);
4127 && !ASCII_CHAR_P (*((unsigned char *) p
- 1))
4128 && STRING_MULTIBYTE (args
[n
])
4129 && !CHAR_HEAD_P (SREF (args
[n
], 0)))
4130 maybe_combine_byte
= true;
4132 p
+= copy_text (SDATA (args
[n
]), (unsigned char *) p
,
4134 STRING_MULTIBYTE (args
[n
]), multibyte
);
4136 info
[n
].start
= nchars
;
4137 nchars
+= nchars_string
;
4138 info
[n
].end
= nchars
;
4142 memset (p
, ' ', padding
);
4147 /* If this argument has text properties, record where
4148 in the result string it appears. */
4149 if (string_intervals (args
[n
]))
4150 info
[n
].intervals
= arg_intervals
= true;
4155 else if (! (conversion
== 'c' || conversion
== 'd'
4156 || conversion
== 'e' || conversion
== 'f'
4157 || conversion
== 'g' || conversion
== 'i'
4158 || conversion
== 'o' || conversion
== 'x'
4159 || conversion
== 'X'))
4160 error ("Invalid format operation %%%c",
4161 STRING_CHAR ((unsigned char *) format
- 1));
4162 else if (! NUMBERP (args
[n
]))
4163 error ("Format specifier doesn't match argument type");
4168 /* Maximum precision for a %f conversion such that the
4169 trailing output digit might be nonzero. Any precision
4170 larger than this will not yield useful information. */
4171 USEFUL_PRECISION_MAX
=
4173 * (FLT_RADIX
== 2 || FLT_RADIX
== 10 ? 1
4174 : FLT_RADIX
== 16 ? 4
4177 /* Maximum number of bytes generated by any format, if
4178 precision is no more than USEFUL_PRECISION_MAX.
4179 On all practical hosts, %f is the worst case. */
4181 sizeof "-." + (DBL_MAX_10_EXP
+ 1) + USEFUL_PRECISION_MAX
,
4183 /* Length of pM (that is, of pMd without the
4185 pMlen
= sizeof pMd
- 2
4187 verify (USEFUL_PRECISION_MAX
> 0);
4189 /* Avoid undefined behavior in underlying sprintf. */
4190 if (conversion
== 'd' || conversion
== 'i')
4193 /* Create the copy of the conversion specification, with
4194 any width and precision removed, with ".*" inserted,
4195 and with pM inserted for integer formats.
4196 At most three flags F can be specified at once. */
4197 char convspec
[sizeof "%FFF.*d" + pMlen
];
4201 *f
= '-'; f
+= minus_flag
;
4202 *f
= '+'; f
+= plus_flag
;
4203 *f
= ' '; f
+= space_flag
;
4204 *f
= '#'; f
+= sharp_flag
;
4205 *f
= '0'; f
+= zero_flag
;
4208 if (conversion
== 'd' || conversion
== 'i'
4209 || conversion
== 'o' || conversion
== 'x'
4210 || conversion
== 'X')
4212 memcpy (f
, pMd
, pMlen
);
4214 zero_flag
&= ~ precision_given
;
4221 if (precision_given
)
4222 prec
= min (precision
, USEFUL_PRECISION_MAX
);
4224 /* Use sprintf to format this number into sprintf_buf. Omit
4225 padding and excess precision, though, because sprintf limits
4226 output length to INT_MAX.
4228 There are four types of conversion: double, unsigned
4229 char (passed as int), wide signed int, and wide
4230 unsigned int. Treat them separately because the
4231 sprintf ABI is sensitive to which type is passed. Be
4232 careful about integer overflow, NaNs, infinities, and
4233 conversions; for example, the min and max macros are
4234 not suitable here. */
4235 char sprintf_buf
[SPRINTF_BUFSIZE
];
4236 ptrdiff_t sprintf_bytes
;
4237 if (conversion
== 'e' || conversion
== 'f' || conversion
== 'g')
4239 double x
= (INTEGERP (args
[n
])
4241 : XFLOAT_DATA (args
[n
]));
4242 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4244 else if (conversion
== 'c')
4246 /* Don't use sprintf here, as it might mishandle prec. */
4247 sprintf_buf
[0] = XINT (args
[n
]);
4248 sprintf_bytes
= prec
!= 0;
4250 else if (conversion
== 'd')
4252 /* For float, maybe we should use "%1.0f"
4253 instead so it also works for values outside
4254 the integer range. */
4256 if (INTEGERP (args
[n
]))
4260 double d
= XFLOAT_DATA (args
[n
]);
4263 x
= TYPE_MINIMUM (printmax_t
);
4269 x
= TYPE_MAXIMUM (printmax_t
);
4274 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4278 /* Don't sign-extend for octal or hex printing. */
4280 if (INTEGERP (args
[n
]))
4281 x
= XUINT (args
[n
]);
4284 double d
= XFLOAT_DATA (args
[n
]);
4289 x
= TYPE_MAXIMUM (uprintmax_t
);
4294 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4297 /* Now the length of the formatted item is known, except it omits
4298 padding and excess precision. Deal with excess precision
4299 first. This happens only when the format specifies
4300 ridiculously large precision. */
4301 uintmax_t excess_precision
= precision
- prec
;
4302 uintmax_t leading_zeros
= 0, trailing_zeros
= 0;
4303 if (excess_precision
)
4305 if (conversion
== 'e' || conversion
== 'f'
4306 || conversion
== 'g')
4308 if ((conversion
== 'g' && ! sharp_flag
)
4309 || ! ('0' <= sprintf_buf
[sprintf_bytes
- 1]
4310 && sprintf_buf
[sprintf_bytes
- 1] <= '9'))
4311 excess_precision
= 0;
4314 if (conversion
== 'g')
4316 char *dot
= strchr (sprintf_buf
, '.');
4318 excess_precision
= 0;
4321 trailing_zeros
= excess_precision
;
4324 leading_zeros
= excess_precision
;
4327 /* Compute the total bytes needed for this item, including
4328 excess precision and padding. */
4329 uintmax_t numwidth
= sprintf_bytes
+ excess_precision
;
4331 = numwidth
< field_width
? field_width
- numwidth
: 0;
4332 if (max_bufsize
- sprintf_bytes
<= excess_precision
4333 || max_bufsize
- padding
<= numwidth
)
4335 convbytes
= numwidth
+ padding
;
4337 if (convbytes
<= buf
+ bufsize
- p
)
4339 /* Copy the formatted item from sprintf_buf into buf,
4340 inserting padding and excess-precision zeros. */
4342 char *src
= sprintf_buf
;
4344 int exponent_bytes
= 0;
4345 bool signedp
= src0
== '-' || src0
== '+' || src0
== ' ';
4347 && ((src
[signedp
] >= '0' && src
[signedp
] <= '9')
4348 || (src
[signedp
] >= 'a' && src
[signedp
] <= 'f')
4349 || (src
[signedp
] >= 'A' && src
[signedp
] <= 'F')))
4351 leading_zeros
+= padding
;
4355 if (excess_precision
4356 && (conversion
== 'e' || conversion
== 'g'))
4358 char *e
= strchr (src
, 'e');
4360 exponent_bytes
= src
+ sprintf_bytes
- e
;
4365 memset (p
, ' ', padding
);
4373 memset (p
, '0', leading_zeros
);
4375 int significand_bytes
4376 = sprintf_bytes
- signedp
- exponent_bytes
;
4377 memcpy (p
, src
, significand_bytes
);
4378 p
+= significand_bytes
;
4379 src
+= significand_bytes
;
4380 memset (p
, '0', trailing_zeros
);
4381 p
+= trailing_zeros
;
4382 memcpy (p
, src
, exponent_bytes
);
4383 p
+= exponent_bytes
;
4385 info
[n
].start
= nchars
;
4386 nchars
+= leading_zeros
+ sprintf_bytes
+ trailing_zeros
;
4387 info
[n
].end
= nchars
;
4391 memset (p
, ' ', padding
);
4402 /* Named constants for the UTF-8 encodings of U+2018 LEFT SINGLE
4403 QUOTATION MARK and U+2019 RIGHT SINGLE QUOTATION MARK. */
4406 uLSQM0
= 0xE2, uLSQM1
= 0x80, uLSQM2
= 0x98,
4407 /* uRSQM0 = 0xE2, uRSQM1 = 0x80, */ uRSQM2
= 0x99
4410 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
4412 if ((format_char
== '`' || format_char
== '\'')
4413 && quoting_style
== CURVE_QUOTING_STYLE
)
4420 convsrc
= format_char
== '`' ? uLSQM
: uRSQM
;
4423 else if (format_char
== '`' && quoting_style
== STRAIGHT_QUOTING_STYLE
)
4425 else if (format_char
== uLSQM0
&& CURVE_QUOTING_STYLE
< quoting_style
4427 && (unsigned char) format
[0] == uLSQM1
4428 && ((unsigned char) format
[1] == uLSQM2
4429 || (unsigned char) format
[1] == uRSQM2
))
4431 convsrc
= (((unsigned char) format
[1] == uLSQM2
4432 && quoting_style
== GRAVE_QUOTING_STYLE
)
4435 memset (&discarded
[format0
+ 1 - format_start
], 2, 2);
4439 /* Copy a single character from format to buf. */
4440 if (multibyte_format
)
4442 /* Copy a whole multibyte character. */
4444 && !ASCII_CHAR_P (*((unsigned char *) p
- 1))
4445 && !CHAR_HEAD_P (format_char
))
4446 maybe_combine_byte
= true;
4448 while (! CHAR_HEAD_P (*format
))
4451 convbytes
= format
- format0
;
4452 memset (&discarded
[format0
+ 1 - format_start
], 2,
4455 else if (multibyte
&& !ASCII_CHAR_P (format_char
))
4457 int c
= BYTE8_TO_CHAR (format_char
);
4458 convbytes
= CHAR_STRING (c
, str
);
4459 convsrc
= (char *) str
;
4464 if (convbytes
<= buf
+ bufsize
- p
)
4466 memcpy (p
, convsrc
, convbytes
);
4473 /* There wasn't enough room to store this conversion or single
4474 character. CONVBYTES says how much room is needed. Allocate
4475 enough room (and then some) and do it again. */
4477 ptrdiff_t used
= p
- buf
;
4478 if (max_bufsize
- used
< convbytes
)
4480 bufsize
= used
+ convbytes
;
4481 bufsize
= bufsize
< max_bufsize
/ 2 ? bufsize
* 2 : max_bufsize
;
4483 if (buf
== initial_buffer
)
4485 buf
= xmalloc (bufsize
);
4486 sa_must_free
= true;
4487 buf_save_value_index
= SPECPDL_INDEX ();
4488 record_unwind_protect_ptr (xfree
, buf
);
4489 memcpy (buf
, initial_buffer
, used
);
4493 buf
= xrealloc (buf
, bufsize
);
4494 set_unwind_protect_ptr (buf_save_value_index
, xfree
, buf
);
4502 if (bufsize
< p
- buf
)
4505 if (maybe_combine_byte
)
4506 nchars
= multibyte_chars_in_text ((unsigned char *) buf
, p
- buf
);
4507 Lisp_Object val
= make_specified_string (buf
, nchars
, p
- buf
, multibyte
);
4509 /* If the format string has text properties, or any of the string
4510 arguments has text properties, set up text properties of the
4513 if (string_intervals (args
[0]) || arg_intervals
)
4515 /* Add text properties from the format string. */
4516 Lisp_Object len
= make_number (SCHARS (args
[0]));
4517 Lisp_Object props
= text_property_list (args
[0], make_number (0),
4521 ptrdiff_t bytepos
= 0, position
= 0, translated
= 0;
4524 /* Adjust the bounds of each text property
4525 to the proper start and end in the output string. */
4527 /* Put the positions in PROPS in increasing order, so that
4528 we can do (effectively) one scan through the position
4529 space of the format string. */
4530 props
= Fnreverse (props
);
4532 /* BYTEPOS is the byte position in the format string,
4533 POSITION is the untranslated char position in it,
4534 TRANSLATED is the translated char position in BUF,
4535 and ARGN is the number of the next arg we will come to. */
4536 for (Lisp_Object list
= props
; CONSP (list
); list
= XCDR (list
))
4538 Lisp_Object item
= XCAR (list
);
4540 /* First adjust the property start position. */
4541 ptrdiff_t pos
= XINT (XCAR (item
));
4543 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
4544 up to this position. */
4545 for (; position
< pos
; bytepos
++)
4547 if (! discarded
[bytepos
])
4548 position
++, translated
++;
4549 else if (discarded
[bytepos
] == 1)
4552 if (translated
== info
[argn
].start
)
4554 translated
+= info
[argn
].end
- info
[argn
].start
;
4560 XSETCAR (item
, make_number (translated
));
4562 /* Likewise adjust the property end position. */
4563 pos
= XINT (XCAR (XCDR (item
)));
4565 for (; position
< pos
; bytepos
++)
4567 if (! discarded
[bytepos
])
4568 position
++, translated
++;
4569 else if (discarded
[bytepos
] == 1)
4572 if (translated
== info
[argn
].start
)
4574 translated
+= info
[argn
].end
- info
[argn
].start
;
4580 XSETCAR (XCDR (item
), make_number (translated
));
4583 add_text_properties_from_list (val
, props
, make_number (0));
4586 /* Add text properties from arguments. */
4588 for (ptrdiff_t i
= 1; i
< nargs
; i
++)
4589 if (info
[i
].intervals
)
4591 len
= make_number (SCHARS (args
[i
]));
4592 Lisp_Object new_len
= make_number (info
[i
].end
- info
[i
].start
);
4593 props
= text_property_list (args
[i
], make_number (0), len
, Qnil
);
4594 props
= extend_property_ranges (props
, new_len
);
4595 /* If successive arguments have properties, be sure that
4596 the value of `composition' property be the copy. */
4597 if (1 < i
&& info
[i
- 1].end
)
4598 make_composition_value_copy (props
);
4599 add_text_properties_from_list (val
, props
,
4600 make_number (info
[i
].start
));
4604 /* If we allocated BUF or INFO with malloc, free it too. */
4610 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
4611 doc
: /* Return t if two characters match, optionally ignoring case.
4612 Both arguments must be characters (i.e. integers).
4613 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
4614 (register Lisp_Object c1
, Lisp_Object c2
)
4617 /* Check they're chars, not just integers, otherwise we could get array
4618 bounds violations in downcase. */
4619 CHECK_CHARACTER (c1
);
4620 CHECK_CHARACTER (c2
);
4622 if (XINT (c1
) == XINT (c2
))
4624 if (NILP (BVAR (current_buffer
, case_fold_search
)))
4630 /* FIXME: It is possible to compare multibyte characters even when
4631 the current buffer is unibyte. Unfortunately this is ambiguous
4632 for characters between 128 and 255, as they could be either
4633 eight-bit raw bytes or Latin-1 characters. Assume the former for
4634 now. See Bug#17011, and also see casefiddle.c's casify_object,
4635 which has a similar problem. */
4636 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4638 if (SINGLE_BYTE_CHAR_P (i1
))
4639 i1
= UNIBYTE_TO_CHAR (i1
);
4640 if (SINGLE_BYTE_CHAR_P (i2
))
4641 i2
= UNIBYTE_TO_CHAR (i2
);
4644 return (downcase (i1
) == downcase (i2
) ? Qt
: Qnil
);
4647 /* Transpose the markers in two regions of the current buffer, and
4648 adjust the ones between them if necessary (i.e.: if the regions
4651 START1, END1 are the character positions of the first region.
4652 START1_BYTE, END1_BYTE are the byte positions.
4653 START2, END2 are the character positions of the second region.
4654 START2_BYTE, END2_BYTE are the byte positions.
4656 Traverses the entire marker list of the buffer to do so, adding an
4657 appropriate amount to some, subtracting from some, and leaving the
4658 rest untouched. Most of this is copied from adjust_markers in insdel.c.
4660 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
4663 transpose_markers (ptrdiff_t start1
, ptrdiff_t end1
,
4664 ptrdiff_t start2
, ptrdiff_t end2
,
4665 ptrdiff_t start1_byte
, ptrdiff_t end1_byte
,
4666 ptrdiff_t start2_byte
, ptrdiff_t end2_byte
)
4668 register ptrdiff_t amt1
, amt1_byte
, amt2
, amt2_byte
, diff
, diff_byte
, mpos
;
4669 register struct Lisp_Marker
*marker
;
4671 /* Update point as if it were a marker. */
4675 TEMP_SET_PT_BOTH (PT
+ (end2
- end1
),
4676 PT_BYTE
+ (end2_byte
- end1_byte
));
4677 else if (PT
< start2
)
4678 TEMP_SET_PT_BOTH (PT
+ (end2
- start2
) - (end1
- start1
),
4679 (PT_BYTE
+ (end2_byte
- start2_byte
)
4680 - (end1_byte
- start1_byte
)));
4682 TEMP_SET_PT_BOTH (PT
- (start2
- start1
),
4683 PT_BYTE
- (start2_byte
- start1_byte
));
4685 /* We used to adjust the endpoints here to account for the gap, but that
4686 isn't good enough. Even if we assume the caller has tried to move the
4687 gap out of our way, it might still be at start1 exactly, for example;
4688 and that places it `inside' the interval, for our purposes. The amount
4689 of adjustment is nontrivial if there's a `denormalized' marker whose
4690 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
4691 the dirty work to Fmarker_position, below. */
4693 /* The difference between the region's lengths */
4694 diff
= (end2
- start2
) - (end1
- start1
);
4695 diff_byte
= (end2_byte
- start2_byte
) - (end1_byte
- start1_byte
);
4697 /* For shifting each marker in a region by the length of the other
4698 region plus the distance between the regions. */
4699 amt1
= (end2
- start2
) + (start2
- end1
);
4700 amt2
= (end1
- start1
) + (start2
- end1
);
4701 amt1_byte
= (end2_byte
- start2_byte
) + (start2_byte
- end1_byte
);
4702 amt2_byte
= (end1_byte
- start1_byte
) + (start2_byte
- end1_byte
);
4704 for (marker
= BUF_MARKERS (current_buffer
); marker
; marker
= marker
->next
)
4706 mpos
= marker
->bytepos
;
4707 if (mpos
>= start1_byte
&& mpos
< end2_byte
)
4709 if (mpos
< end1_byte
)
4711 else if (mpos
< start2_byte
)
4715 marker
->bytepos
= mpos
;
4717 mpos
= marker
->charpos
;
4718 if (mpos
>= start1
&& mpos
< end2
)
4722 else if (mpos
< start2
)
4727 marker
->charpos
= mpos
;
4731 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
4732 doc
: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
4733 The regions should not be overlapping, because the size of the buffer is
4734 never changed in a transposition.
4736 Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
4737 any markers that happen to be located in the regions.
4739 Transposing beyond buffer boundaries is an error. */)
4740 (Lisp_Object startr1
, Lisp_Object endr1
, Lisp_Object startr2
, Lisp_Object endr2
, Lisp_Object leave_markers
)
4742 register ptrdiff_t start1
, end1
, start2
, end2
;
4743 ptrdiff_t start1_byte
, start2_byte
, len1_byte
, len2_byte
, end2_byte
;
4744 ptrdiff_t gap
, len1
, len_mid
, len2
;
4745 unsigned char *start1_addr
, *start2_addr
, *temp
;
4747 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
, tmp_interval3
;
4750 XSETBUFFER (buf
, current_buffer
);
4751 cur_intv
= buffer_intervals (current_buffer
);
4753 validate_region (&startr1
, &endr1
);
4754 validate_region (&startr2
, &endr2
);
4756 start1
= XFASTINT (startr1
);
4757 end1
= XFASTINT (endr1
);
4758 start2
= XFASTINT (startr2
);
4759 end2
= XFASTINT (endr2
);
4762 /* Swap the regions if they're reversed. */
4765 register ptrdiff_t glumph
= start1
;
4773 len1
= end1
- start1
;
4774 len2
= end2
- start2
;
4777 error ("Transposed regions overlap");
4778 /* Nothing to change for adjacent regions with one being empty */
4779 else if ((start1
== end1
|| start2
== end2
) && end1
== start2
)
4782 /* The possibilities are:
4783 1. Adjacent (contiguous) regions, or separate but equal regions
4784 (no, really equal, in this case!), or
4785 2. Separate regions of unequal size.
4787 The worst case is usually No. 2. It means that (aside from
4788 potential need for getting the gap out of the way), there also
4789 needs to be a shifting of the text between the two regions. So
4790 if they are spread far apart, we are that much slower... sigh. */
4792 /* It must be pointed out that the really studly thing to do would
4793 be not to move the gap at all, but to leave it in place and work
4794 around it if necessary. This would be extremely efficient,
4795 especially considering that people are likely to do
4796 transpositions near where they are working interactively, which
4797 is exactly where the gap would be found. However, such code
4798 would be much harder to write and to read. So, if you are
4799 reading this comment and are feeling squirrely, by all means have
4800 a go! I just didn't feel like doing it, so I will simply move
4801 the gap the minimum distance to get it out of the way, and then
4802 deal with an unbroken array. */
4804 start1_byte
= CHAR_TO_BYTE (start1
);
4805 end2_byte
= CHAR_TO_BYTE (end2
);
4807 /* Make sure the gap won't interfere, by moving it out of the text
4808 we will operate on. */
4809 if (start1
< gap
&& gap
< end2
)
4811 if (gap
- start1
< end2
- gap
)
4812 move_gap_both (start1
, start1_byte
);
4814 move_gap_both (end2
, end2_byte
);
4817 start2_byte
= CHAR_TO_BYTE (start2
);
4818 len1_byte
= CHAR_TO_BYTE (end1
) - start1_byte
;
4819 len2_byte
= end2_byte
- start2_byte
;
4821 #ifdef BYTE_COMBINING_DEBUG
4824 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4825 len2_byte
, start1
, start1_byte
)
4826 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4827 len1_byte
, end2
, start2_byte
+ len2_byte
)
4828 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4829 len1_byte
, end2
, start2_byte
+ len2_byte
))
4834 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4835 len2_byte
, start1
, start1_byte
)
4836 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4837 len1_byte
, start2
, start2_byte
)
4838 || count_combining_after (BYTE_POS_ADDR (start2_byte
),
4839 len2_byte
, end1
, start1_byte
+ len1_byte
)
4840 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4841 len1_byte
, end2
, start2_byte
+ len2_byte
))
4846 /* Hmmm... how about checking to see if the gap is large
4847 enough to use as the temporary storage? That would avoid an
4848 allocation... interesting. Later, don't fool with it now. */
4850 /* Working without memmove, for portability (sigh), so must be
4851 careful of overlapping subsections of the array... */
4853 if (end1
== start2
) /* adjacent regions */
4855 modify_text (start1
, end2
);
4856 record_change (start1
, len1
+ len2
);
4858 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4859 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4860 /* Don't use Fset_text_properties: that can cause GC, which can
4861 clobber objects stored in the tmp_intervals. */
4862 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4864 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4868 /* First region smaller than second. */
4869 if (len1_byte
< len2_byte
)
4871 temp
= SAFE_ALLOCA (len2_byte
);
4873 /* Don't precompute these addresses. We have to compute them
4874 at the last minute, because the relocating allocator might
4875 have moved the buffer around during the xmalloc. */
4876 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4877 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4879 memcpy (temp
, start2_addr
, len2_byte
);
4880 memcpy (start1_addr
+ len2_byte
, start1_addr
, len1_byte
);
4881 memcpy (start1_addr
, temp
, len2_byte
);
4884 /* First region not smaller than second. */
4886 temp
= SAFE_ALLOCA (len1_byte
);
4887 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4888 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4889 memcpy (temp
, start1_addr
, len1_byte
);
4890 memcpy (start1_addr
, start2_addr
, len2_byte
);
4891 memcpy (start1_addr
+ len2_byte
, temp
, len1_byte
);
4895 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
4896 len1
, current_buffer
, 0);
4897 graft_intervals_into_buffer (tmp_interval2
, start1
,
4898 len2
, current_buffer
, 0);
4899 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4900 update_compositions (start1
+ len2
, end2
, CHECK_TAIL
);
4902 /* Non-adjacent regions, because end1 != start2, bleagh... */
4905 len_mid
= start2_byte
- (start1_byte
+ len1_byte
);
4907 if (len1_byte
== len2_byte
)
4908 /* Regions are same size, though, how nice. */
4912 modify_text (start1
, end1
);
4913 modify_text (start2
, end2
);
4914 record_change (start1
, len1
);
4915 record_change (start2
, len2
);
4916 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4917 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4919 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr1
, 0);
4921 set_text_properties_1 (startr1
, endr1
, Qnil
, buf
, tmp_interval3
);
4923 tmp_interval3
= validate_interval_range (buf
, &startr2
, &endr2
, 0);
4925 set_text_properties_1 (startr2
, endr2
, Qnil
, buf
, tmp_interval3
);
4927 temp
= SAFE_ALLOCA (len1_byte
);
4928 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4929 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4930 memcpy (temp
, start1_addr
, len1_byte
);
4931 memcpy (start1_addr
, start2_addr
, len2_byte
);
4932 memcpy (start2_addr
, temp
, len1_byte
);
4935 graft_intervals_into_buffer (tmp_interval1
, start2
,
4936 len1
, current_buffer
, 0);
4937 graft_intervals_into_buffer (tmp_interval2
, start1
,
4938 len2
, current_buffer
, 0);
4941 else if (len1_byte
< len2_byte
) /* Second region larger than first */
4942 /* Non-adjacent & unequal size, area between must also be shifted. */
4946 modify_text (start1
, end2
);
4947 record_change (start1
, (end2
- start1
));
4948 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4949 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4950 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4952 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4954 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4956 /* holds region 2 */
4957 temp
= SAFE_ALLOCA (len2_byte
);
4958 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4959 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4960 memcpy (temp
, start2_addr
, len2_byte
);
4961 memcpy (start1_addr
+ len_mid
+ len2_byte
, start1_addr
, len1_byte
);
4962 memmove (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
4963 memcpy (start1_addr
, temp
, len2_byte
);
4966 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4967 len1
, current_buffer
, 0);
4968 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4969 len_mid
, current_buffer
, 0);
4970 graft_intervals_into_buffer (tmp_interval2
, start1
,
4971 len2
, current_buffer
, 0);
4974 /* Second region smaller than first. */
4978 record_change (start1
, (end2
- start1
));
4979 modify_text (start1
, end2
);
4981 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4982 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4983 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4985 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4987 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4989 /* holds region 1 */
4990 temp
= SAFE_ALLOCA (len1_byte
);
4991 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4992 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4993 memcpy (temp
, start1_addr
, len1_byte
);
4994 memcpy (start1_addr
, start2_addr
, len2_byte
);
4995 memmove (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
4996 memcpy (start1_addr
+ len2_byte
+ len_mid
, temp
, len1_byte
);
4999 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
5000 len1
, current_buffer
, 0);
5001 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
5002 len_mid
, current_buffer
, 0);
5003 graft_intervals_into_buffer (tmp_interval2
, start1
,
5004 len2
, current_buffer
, 0);
5007 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
5008 update_compositions (end2
- len1
, end2
, CHECK_BORDER
);
5011 /* When doing multiple transpositions, it might be nice
5012 to optimize this. Perhaps the markers in any one buffer
5013 should be organized in some sorted data tree. */
5014 if (NILP (leave_markers
))
5016 transpose_markers (start1
, end1
, start2
, end2
,
5017 start1_byte
, start1_byte
+ len1_byte
,
5018 start2_byte
, start2_byte
+ len2_byte
);
5019 fix_start_end_in_overlays (start1
, end2
);
5022 signal_after_change (start1
, end2
- start1
, end2
- start1
);
5028 syms_of_editfns (void)
5030 DEFSYM (Qbuffer_access_fontify_functions
, "buffer-access-fontify-functions");
5031 DEFSYM (Qwall
, "wall");
5033 DEFVAR_LISP ("inhibit-field-text-motion", Vinhibit_field_text_motion
,
5034 doc
: /* Non-nil means text motion commands don't notice fields. */);
5035 Vinhibit_field_text_motion
= Qnil
;
5037 DEFVAR_LISP ("buffer-access-fontify-functions",
5038 Vbuffer_access_fontify_functions
,
5039 doc
: /* List of functions called by `buffer-substring' to fontify if necessary.
5040 Each function is called with two arguments which specify the range
5041 of the buffer being accessed. */);
5042 Vbuffer_access_fontify_functions
= Qnil
;
5046 obuf
= Fcurrent_buffer ();
5047 /* Do this here, because init_buffer_once is too early--it won't work. */
5048 Fset_buffer (Vprin1_to_string_buffer
);
5049 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
5050 Fset (Fmake_local_variable (Qbuffer_access_fontify_functions
), Qnil
);
5054 DEFVAR_LISP ("buffer-access-fontified-property",
5055 Vbuffer_access_fontified_property
,
5056 doc
: /* Property which (if non-nil) indicates text has been fontified.
5057 `buffer-substring' need not call the `buffer-access-fontify-functions'
5058 functions if all the text being accessed has this property. */);
5059 Vbuffer_access_fontified_property
= Qnil
;
5061 DEFVAR_LISP ("system-name", Vsystem_name
,
5062 doc
: /* The host name of the machine Emacs is running on. */);
5063 Vsystem_name
= cached_system_name
= Qnil
;
5065 DEFVAR_LISP ("user-full-name", Vuser_full_name
,
5066 doc
: /* The full name of the user logged in. */);
5068 DEFVAR_LISP ("user-login-name", Vuser_login_name
,
5069 doc
: /* The user's name, taken from environment variables if possible. */);
5070 Vuser_login_name
= Qnil
;
5072 DEFVAR_LISP ("user-real-login-name", Vuser_real_login_name
,
5073 doc
: /* The user's name, based upon the real uid only. */);
5075 DEFVAR_LISP ("operating-system-release", Voperating_system_release
,
5076 doc
: /* The release of the operating system Emacs is running on. */);
5078 defsubr (&Spropertize
);
5079 defsubr (&Schar_equal
);
5080 defsubr (&Sgoto_char
);
5081 defsubr (&Sstring_to_char
);
5082 defsubr (&Schar_to_string
);
5083 defsubr (&Sbyte_to_string
);
5084 defsubr (&Sbuffer_substring
);
5085 defsubr (&Sbuffer_substring_no_properties
);
5086 defsubr (&Sbuffer_string
);
5087 defsubr (&Sget_pos_property
);
5089 defsubr (&Spoint_marker
);
5090 defsubr (&Smark_marker
);
5092 defsubr (&Sregion_beginning
);
5093 defsubr (&Sregion_end
);
5095 /* Symbol for the text property used to mark fields. */
5096 DEFSYM (Qfield
, "field");
5098 /* A special value for Qfield properties. */
5099 DEFSYM (Qboundary
, "boundary");
5101 defsubr (&Sfield_beginning
);
5102 defsubr (&Sfield_end
);
5103 defsubr (&Sfield_string
);
5104 defsubr (&Sfield_string_no_properties
);
5105 defsubr (&Sdelete_field
);
5106 defsubr (&Sconstrain_to_field
);
5108 defsubr (&Sline_beginning_position
);
5109 defsubr (&Sline_end_position
);
5111 defsubr (&Ssave_excursion
);
5112 defsubr (&Ssave_current_buffer
);
5114 defsubr (&Sbuffer_size
);
5115 defsubr (&Spoint_max
);
5116 defsubr (&Spoint_min
);
5117 defsubr (&Spoint_min_marker
);
5118 defsubr (&Spoint_max_marker
);
5119 defsubr (&Sgap_position
);
5120 defsubr (&Sgap_size
);
5121 defsubr (&Sposition_bytes
);
5122 defsubr (&Sbyte_to_position
);
5128 defsubr (&Sfollowing_char
);
5129 defsubr (&Sprevious_char
);
5130 defsubr (&Schar_after
);
5131 defsubr (&Schar_before
);
5133 defsubr (&Sinsert_before_markers
);
5134 defsubr (&Sinsert_and_inherit
);
5135 defsubr (&Sinsert_and_inherit_before_markers
);
5136 defsubr (&Sinsert_char
);
5137 defsubr (&Sinsert_byte
);
5139 defsubr (&Suser_login_name
);
5140 defsubr (&Suser_real_login_name
);
5141 defsubr (&Suser_uid
);
5142 defsubr (&Suser_real_uid
);
5143 defsubr (&Sgroup_gid
);
5144 defsubr (&Sgroup_real_gid
);
5145 defsubr (&Suser_full_name
);
5146 defsubr (&Semacs_pid
);
5147 defsubr (&Scurrent_time
);
5148 defsubr (&Stime_add
);
5149 defsubr (&Stime_subtract
);
5150 defsubr (&Stime_less_p
);
5151 defsubr (&Sget_internal_run_time
);
5152 defsubr (&Sformat_time_string
);
5153 defsubr (&Sfloat_time
);
5154 defsubr (&Sdecode_time
);
5155 defsubr (&Sencode_time
);
5156 defsubr (&Scurrent_time_string
);
5157 defsubr (&Scurrent_time_zone
);
5158 defsubr (&Sset_time_zone_rule
);
5159 defsubr (&Ssystem_name
);
5160 defsubr (&Smessage
);
5161 defsubr (&Smessage_box
);
5162 defsubr (&Smessage_or_box
);
5163 defsubr (&Scurrent_message
);
5165 defsubr (&Sformat_message
);
5167 defsubr (&Sinsert_buffer_substring
);
5168 defsubr (&Scompare_buffer_substrings
);
5169 defsubr (&Ssubst_char_in_region
);
5170 defsubr (&Stranslate_region_internal
);
5171 defsubr (&Sdelete_region
);
5172 defsubr (&Sdelete_and_extract_region
);
5174 defsubr (&Snarrow_to_region
);
5175 defsubr (&Ssave_restriction
);
5176 defsubr (&Stranspose_regions
);