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. The optional ZONE is omitted or nil for Emacs
1973 local time, t for Universal Time, `wall' for system wall clock time,
1974 or a string as in the TZ environment variable.
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 the TZ environment variable.
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 the TZ environment variable. It can also be a list (as from
2155 `current-time-zone') or an integer (as from `decode-time') applied
2156 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 the TZ environment variable. */)
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 the TZ environment variable.
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.
2335 If TZ is nil or `wall', use system wall clock time; this differs from
2336 the usual Emacs convention where nil means current local time. If TZ
2337 is t, use Universal Time. If TZ is an integer, treat it as in
2340 Instead of calling this function, you typically want something else.
2341 To temporarily use a different time zone rule for just one invocation
2342 of `decode-time', `encode-time', or `format-time-string', pass the
2343 function a ZONE argument. To change local time consistently
2344 throughout Emacs, call (setenv "TZ" TZ): this changes both the
2345 environment of the Emacs process and the variable
2346 `process-environment', whereas `set-time-zone-rule' affects only the
2350 tzlookup (NILP (tz
) ? Qwall
: tz
, true);
2354 /* A buffer holding a string of the form "TZ=value", intended
2355 to be part of the environment. If TZ is supposed to be unset,
2356 the buffer string is "tZ=". */
2357 static char *tzvalbuf
;
2359 /* Get the local time zone rule. */
2361 emacs_getenv_TZ (void)
2363 return tzvalbuf
[0] == 'T' ? tzvalbuf
+ tzeqlen
: 0;
2366 /* Set the local time zone rule to TZSTRING, which can be null to
2367 denote wall clock time. Do not record the setting in LOCAL_TZ.
2369 This function is not thread-safe, in theory because putenv is not,
2370 but mostly because of the static storage it updates. Other threads
2371 that invoke localtime etc. may be adversely affected while this
2372 function is executing. */
2375 emacs_setenv_TZ (const char *tzstring
)
2377 static ptrdiff_t tzvalbufsize
;
2378 ptrdiff_t tzstringlen
= tzstring
? strlen (tzstring
) : 0;
2379 char *tzval
= tzvalbuf
;
2380 bool new_tzvalbuf
= tzvalbufsize
<= tzeqlen
+ tzstringlen
;
2384 /* Do not attempt to free the old tzvalbuf, since another thread
2385 may be using it. In practice, the first allocation is large
2386 enough and memory does not leak. */
2387 tzval
= xpalloc (NULL
, &tzvalbufsize
,
2388 tzeqlen
+ tzstringlen
- tzvalbufsize
+ 1, -1, 1);
2396 /* Modify TZVAL in place. Although this is dicey in a
2397 multithreaded environment, we know of no portable alternative.
2398 Calling putenv or setenv could crash some other thread. */
2400 strcpy (tzval
+ tzeqlen
, tzstring
);
2404 /* Turn 'TZ=whatever' into an empty environment variable 'tZ='.
2405 Although this is also dicey, calling unsetenv here can crash Emacs.
2413 /* MS-Windows implementation of 'putenv' copies the argument
2414 string into a block it allocates, so modifying tzval string
2415 does not change the environment. OTOH, the other threads run
2416 by Emacs on MS-Windows never call 'xputenv' or 'putenv' or
2417 'unsetenv', so the original cause for the dicey in-place
2418 modification technique doesn't exist there in the first
2424 /* Although this is not thread-safe, in practice this runs only
2425 on startup when there is only one thread. */
2432 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
2433 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
2434 type of object is Lisp_String). INHERIT is passed to
2435 INSERT_FROM_STRING_FUNC as the last argument. */
2438 general_insert_function (void (*insert_func
)
2439 (const char *, ptrdiff_t),
2440 void (*insert_from_string_func
)
2441 (Lisp_Object
, ptrdiff_t, ptrdiff_t,
2442 ptrdiff_t, ptrdiff_t, bool),
2443 bool inherit
, ptrdiff_t nargs
, Lisp_Object
*args
)
2448 for (argnum
= 0; argnum
< nargs
; argnum
++)
2451 if (CHARACTERP (val
))
2453 int c
= XFASTINT (val
);
2454 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2457 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2458 len
= CHAR_STRING (c
, str
);
2461 str
[0] = CHAR_TO_BYTE8 (c
);
2464 (*insert_func
) ((char *) str
, len
);
2466 else if (STRINGP (val
))
2468 (*insert_from_string_func
) (val
, 0, 0,
2474 wrong_type_argument (Qchar_or_string_p
, val
);
2479 insert1 (Lisp_Object arg
)
2485 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
2486 doc
: /* Insert the arguments, either strings or characters, at point.
2487 Point and after-insertion markers move forward to end up
2488 after the inserted text.
2489 Any other markers at the point of insertion remain before the text.
2491 If the current buffer is multibyte, unibyte strings are converted
2492 to multibyte for insertion (see `string-make-multibyte').
2493 If the current buffer is unibyte, multibyte strings are converted
2494 to unibyte for insertion (see `string-make-unibyte').
2496 When operating on binary data, it may be necessary to preserve the
2497 original bytes of a unibyte string when inserting it into a multibyte
2498 buffer; to accomplish this, apply `string-as-multibyte' to the string
2499 and insert the result.
2501 usage: (insert &rest ARGS) */)
2502 (ptrdiff_t nargs
, Lisp_Object
*args
)
2504 general_insert_function (insert
, insert_from_string
, 0, nargs
, args
);
2508 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
2510 doc
: /* Insert the arguments at point, inheriting properties from adjoining text.
2511 Point and after-insertion markers move forward to end up
2512 after the inserted text.
2513 Any other markers at the point of insertion remain before the text.
2515 If the current buffer is multibyte, unibyte strings are converted
2516 to multibyte for insertion (see `unibyte-char-to-multibyte').
2517 If the current buffer is unibyte, multibyte strings are converted
2518 to unibyte for insertion.
2520 usage: (insert-and-inherit &rest ARGS) */)
2521 (ptrdiff_t nargs
, Lisp_Object
*args
)
2523 general_insert_function (insert_and_inherit
, insert_from_string
, 1,
2528 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
2529 doc
: /* Insert strings or characters at point, relocating markers after the text.
2530 Point and markers move forward to end up after the inserted text.
2532 If the current buffer is multibyte, unibyte strings are converted
2533 to multibyte for insertion (see `unibyte-char-to-multibyte').
2534 If the current buffer is unibyte, multibyte strings are converted
2535 to unibyte for insertion.
2537 If an overlay begins at the insertion point, the inserted text falls
2538 outside the overlay; if a nonempty overlay ends at the insertion
2539 point, the inserted text falls inside that overlay.
2541 usage: (insert-before-markers &rest ARGS) */)
2542 (ptrdiff_t nargs
, Lisp_Object
*args
)
2544 general_insert_function (insert_before_markers
,
2545 insert_from_string_before_markers
, 0,
2550 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers
,
2551 Sinsert_and_inherit_before_markers
, 0, MANY
, 0,
2552 doc
: /* Insert text at point, relocating markers and inheriting properties.
2553 Point and markers move forward to end up after the inserted text.
2555 If the current buffer is multibyte, unibyte strings are converted
2556 to multibyte for insertion (see `unibyte-char-to-multibyte').
2557 If the current buffer is unibyte, multibyte strings are converted
2558 to unibyte for insertion.
2560 usage: (insert-before-markers-and-inherit &rest ARGS) */)
2561 (ptrdiff_t nargs
, Lisp_Object
*args
)
2563 general_insert_function (insert_before_markers_and_inherit
,
2564 insert_from_string_before_markers
, 1,
2569 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 1, 3,
2570 "(list (read-char-by-name \"Insert character (Unicode name or hex): \")\
2571 (prefix-numeric-value current-prefix-arg)\
2573 doc
: /* Insert COUNT copies of CHARACTER.
2574 Interactively, prompt for CHARACTER. You can specify CHARACTER in one
2577 - As its Unicode character name, e.g. \"LATIN SMALL LETTER A\".
2578 Completion is available; if you type a substring of the name
2579 preceded by an asterisk `*', Emacs shows all names which include
2580 that substring, not necessarily at the beginning of the name.
2582 - As a hexadecimal code point, e.g. 263A. Note that code points in
2583 Emacs are equivalent to Unicode up to 10FFFF (which is the limit of
2584 the Unicode code space).
2586 - As a code point with a radix specified with #, e.g. #o21430
2587 (octal), #x2318 (hex), or #10r8984 (decimal).
2589 If called interactively, COUNT is given by the prefix argument. If
2590 omitted or nil, it defaults to 1.
2592 Inserting the character(s) relocates point and before-insertion
2593 markers in the same ways as the function `insert'.
2595 The optional third argument INHERIT, if non-nil, says to inherit text
2596 properties from adjoining text, if those properties are sticky. If
2597 called interactively, INHERIT is t. */)
2598 (Lisp_Object character
, Lisp_Object count
, Lisp_Object inherit
)
2601 register ptrdiff_t n
;
2603 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2606 CHECK_CHARACTER (character
);
2608 XSETFASTINT (count
, 1);
2609 CHECK_NUMBER (count
);
2610 c
= XFASTINT (character
);
2612 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2613 len
= CHAR_STRING (c
, str
);
2615 str
[0] = c
, len
= 1;
2616 if (XINT (count
) <= 0)
2618 if (BUF_BYTES_MAX
/ len
< XINT (count
))
2620 n
= XINT (count
) * len
;
2621 stringlen
= min (n
, sizeof string
- sizeof string
% len
);
2622 for (i
= 0; i
< stringlen
; i
++)
2623 string
[i
] = str
[i
% len
];
2624 while (n
> stringlen
)
2627 if (!NILP (inherit
))
2628 insert_and_inherit (string
, stringlen
);
2630 insert (string
, stringlen
);
2633 if (!NILP (inherit
))
2634 insert_and_inherit (string
, n
);
2640 DEFUN ("insert-byte", Finsert_byte
, Sinsert_byte
, 2, 3, 0,
2641 doc
: /* Insert COUNT (second arg) copies of BYTE (first arg).
2642 Both arguments are required.
2643 BYTE is a number of the range 0..255.
2645 If BYTE is 128..255 and the current buffer is multibyte, the
2646 corresponding eight-bit character is inserted.
2648 Point, and before-insertion markers, are relocated as in the function `insert'.
2649 The optional third arg INHERIT, if non-nil, says to inherit text properties
2650 from adjoining text, if those properties are sticky. */)
2651 (Lisp_Object byte
, Lisp_Object count
, Lisp_Object inherit
)
2653 CHECK_NUMBER (byte
);
2654 if (XINT (byte
) < 0 || XINT (byte
) > 255)
2655 args_out_of_range_3 (byte
, make_number (0), make_number (255));
2656 if (XINT (byte
) >= 128
2657 && ! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2658 XSETFASTINT (byte
, BYTE8_TO_CHAR (XINT (byte
)));
2659 return Finsert_char (byte
, count
, inherit
);
2663 /* Making strings from buffer contents. */
2665 /* Return a Lisp_String containing the text of the current buffer from
2666 START to END. If text properties are in use and the current buffer
2667 has properties in the range specified, the resulting string will also
2668 have them, if PROPS is true.
2670 We don't want to use plain old make_string here, because it calls
2671 make_uninit_string, which can cause the buffer arena to be
2672 compacted. make_string has no way of knowing that the data has
2673 been moved, and thus copies the wrong data into the string. This
2674 doesn't effect most of the other users of make_string, so it should
2675 be left as is. But we should use this function when conjuring
2676 buffer substrings. */
2679 make_buffer_string (ptrdiff_t start
, ptrdiff_t end
, bool props
)
2681 ptrdiff_t start_byte
= CHAR_TO_BYTE (start
);
2682 ptrdiff_t end_byte
= CHAR_TO_BYTE (end
);
2684 return make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
);
2687 /* Return a Lisp_String containing the text of the current buffer from
2688 START / START_BYTE to END / END_BYTE.
2690 If text properties are in use and the current buffer
2691 has properties in the range specified, the resulting string will also
2692 have them, if PROPS is true.
2694 We don't want to use plain old make_string here, because it calls
2695 make_uninit_string, which can cause the buffer arena to be
2696 compacted. make_string has no way of knowing that the data has
2697 been moved, and thus copies the wrong data into the string. This
2698 doesn't effect most of the other users of make_string, so it should
2699 be left as is. But we should use this function when conjuring
2700 buffer substrings. */
2703 make_buffer_string_both (ptrdiff_t start
, ptrdiff_t start_byte
,
2704 ptrdiff_t end
, ptrdiff_t end_byte
, bool props
)
2706 Lisp_Object result
, tem
, tem1
;
2707 ptrdiff_t beg0
, end0
, beg1
, end1
, size
;
2709 if (start_byte
< GPT_BYTE
&& GPT_BYTE
< end_byte
)
2711 /* Two regions, before and after the gap. */
2714 beg1
= GPT_BYTE
+ GAP_SIZE
- BEG_BYTE
;
2715 end1
= end_byte
+ GAP_SIZE
- BEG_BYTE
;
2719 /* The only region. */
2726 if (! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2727 result
= make_uninit_multibyte_string (end
- start
, end_byte
- start_byte
);
2729 result
= make_uninit_string (end
- start
);
2732 memcpy (SDATA (result
), BYTE_POS_ADDR (beg0
), size
);
2734 memcpy (SDATA (result
) + size
, BEG_ADDR
+ beg1
, end1
- beg1
);
2736 /* If desired, update and copy the text properties. */
2739 update_buffer_properties (start
, end
);
2741 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
2742 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
2744 if (XINT (tem
) != end
|| !NILP (tem1
))
2745 copy_intervals_to_string (result
, current_buffer
, start
,
2752 /* Call Vbuffer_access_fontify_functions for the range START ... END
2753 in the current buffer, if necessary. */
2756 update_buffer_properties (ptrdiff_t start
, ptrdiff_t end
)
2758 /* If this buffer has some access functions,
2759 call them, specifying the range of the buffer being accessed. */
2760 if (!NILP (Vbuffer_access_fontify_functions
))
2762 /* But don't call them if we can tell that the work
2763 has already been done. */
2764 if (!NILP (Vbuffer_access_fontified_property
))
2767 = Ftext_property_any (make_number (start
), make_number (end
),
2768 Vbuffer_access_fontified_property
,
2774 CALLN (Frun_hook_with_args
, Qbuffer_access_fontify_functions
,
2775 make_number (start
), make_number (end
));
2779 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
2780 doc
: /* Return the contents of part of the current buffer as a string.
2781 The two arguments START and END are character positions;
2782 they can be in either order.
2783 The string returned is multibyte if the buffer is multibyte.
2785 This function copies the text properties of that part of the buffer
2786 into the result string; if you don't want the text properties,
2787 use `buffer-substring-no-properties' instead. */)
2788 (Lisp_Object start
, Lisp_Object end
)
2790 register ptrdiff_t b
, e
;
2792 validate_region (&start
, &end
);
2796 return make_buffer_string (b
, e
, 1);
2799 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties
,
2800 Sbuffer_substring_no_properties
, 2, 2, 0,
2801 doc
: /* Return the characters of part of the buffer, without the text properties.
2802 The two arguments START and END are character positions;
2803 they can be in either order. */)
2804 (Lisp_Object start
, Lisp_Object end
)
2806 register ptrdiff_t b
, e
;
2808 validate_region (&start
, &end
);
2812 return make_buffer_string (b
, e
, 0);
2815 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
2816 doc
: /* Return the contents of the current buffer as a string.
2817 If narrowing is in effect, this function returns only the visible part
2821 return make_buffer_string_both (BEGV
, BEGV_BYTE
, ZV
, ZV_BYTE
, 1);
2824 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
2826 doc
: /* Insert before point a substring of the contents of BUFFER.
2827 BUFFER may be a buffer or a buffer name.
2828 Arguments START and END are character positions specifying the substring.
2829 They default to the values of (point-min) and (point-max) in BUFFER.
2831 Point and before-insertion markers move forward to end up after the
2833 Any other markers at the point of insertion remain before the text.
2835 If the current buffer is multibyte and BUFFER is unibyte, or vice
2836 versa, strings are converted from unibyte to multibyte or vice versa
2837 using `string-make-multibyte' or `string-make-unibyte', which see. */)
2838 (Lisp_Object buffer
, Lisp_Object start
, Lisp_Object end
)
2840 register EMACS_INT b
, e
, temp
;
2841 register struct buffer
*bp
, *obuf
;
2844 buf
= Fget_buffer (buffer
);
2848 if (!BUFFER_LIVE_P (bp
))
2849 error ("Selecting deleted buffer");
2855 CHECK_NUMBER_COERCE_MARKER (start
);
2862 CHECK_NUMBER_COERCE_MARKER (end
);
2867 temp
= b
, b
= e
, e
= temp
;
2869 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
2870 args_out_of_range (start
, end
);
2872 obuf
= current_buffer
;
2873 set_buffer_internal_1 (bp
);
2874 update_buffer_properties (b
, e
);
2875 set_buffer_internal_1 (obuf
);
2877 insert_from_buffer (bp
, b
, e
- b
, 0);
2881 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
2883 doc
: /* Compare two substrings of two buffers; return result as number.
2884 Return -N if first string is less after N-1 chars, +N if first string is
2885 greater after N-1 chars, or 0 if strings match.
2886 The first substring is in BUFFER1 from START1 to END1 and the second
2887 is in BUFFER2 from START2 to END2.
2888 The value of `case-fold-search' in the current buffer
2889 determines whether case is significant or ignored. */)
2890 (Lisp_Object buffer1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object buffer2
, Lisp_Object start2
, Lisp_Object end2
)
2892 register EMACS_INT begp1
, endp1
, begp2
, endp2
, temp
;
2893 register struct buffer
*bp1
, *bp2
;
2894 register Lisp_Object trt
2895 = (!NILP (BVAR (current_buffer
, case_fold_search
))
2896 ? BVAR (current_buffer
, case_canon_table
) : Qnil
);
2897 ptrdiff_t chars
= 0;
2898 ptrdiff_t i1
, i2
, i1_byte
, i2_byte
;
2900 /* Find the first buffer and its substring. */
2903 bp1
= current_buffer
;
2907 buf1
= Fget_buffer (buffer1
);
2910 bp1
= XBUFFER (buf1
);
2911 if (!BUFFER_LIVE_P (bp1
))
2912 error ("Selecting deleted buffer");
2916 begp1
= BUF_BEGV (bp1
);
2919 CHECK_NUMBER_COERCE_MARKER (start1
);
2920 begp1
= XINT (start1
);
2923 endp1
= BUF_ZV (bp1
);
2926 CHECK_NUMBER_COERCE_MARKER (end1
);
2927 endp1
= XINT (end1
);
2931 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
2933 if (!(BUF_BEGV (bp1
) <= begp1
2935 && endp1
<= BUF_ZV (bp1
)))
2936 args_out_of_range (start1
, end1
);
2938 /* Likewise for second substring. */
2941 bp2
= current_buffer
;
2945 buf2
= Fget_buffer (buffer2
);
2948 bp2
= XBUFFER (buf2
);
2949 if (!BUFFER_LIVE_P (bp2
))
2950 error ("Selecting deleted buffer");
2954 begp2
= BUF_BEGV (bp2
);
2957 CHECK_NUMBER_COERCE_MARKER (start2
);
2958 begp2
= XINT (start2
);
2961 endp2
= BUF_ZV (bp2
);
2964 CHECK_NUMBER_COERCE_MARKER (end2
);
2965 endp2
= XINT (end2
);
2969 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
2971 if (!(BUF_BEGV (bp2
) <= begp2
2973 && endp2
<= BUF_ZV (bp2
)))
2974 args_out_of_range (start2
, end2
);
2978 i1_byte
= buf_charpos_to_bytepos (bp1
, i1
);
2979 i2_byte
= buf_charpos_to_bytepos (bp2
, i2
);
2981 while (i1
< endp1
&& i2
< endp2
)
2983 /* When we find a mismatch, we must compare the
2984 characters, not just the bytes. */
2989 if (! NILP (BVAR (bp1
, enable_multibyte_characters
)))
2991 c1
= BUF_FETCH_MULTIBYTE_CHAR (bp1
, i1_byte
);
2992 BUF_INC_POS (bp1
, i1_byte
);
2997 c1
= BUF_FETCH_BYTE (bp1
, i1
);
2998 MAKE_CHAR_MULTIBYTE (c1
);
3002 if (! NILP (BVAR (bp2
, enable_multibyte_characters
)))
3004 c2
= BUF_FETCH_MULTIBYTE_CHAR (bp2
, i2_byte
);
3005 BUF_INC_POS (bp2
, i2_byte
);
3010 c2
= BUF_FETCH_BYTE (bp2
, i2
);
3011 MAKE_CHAR_MULTIBYTE (c2
);
3017 c1
= char_table_translate (trt
, c1
);
3018 c2
= char_table_translate (trt
, c2
);
3021 return make_number (- 1 - chars
);
3023 return make_number (chars
+ 1);
3028 /* The strings match as far as they go.
3029 If one is shorter, that one is less. */
3030 if (chars
< endp1
- begp1
)
3031 return make_number (chars
+ 1);
3032 else if (chars
< endp2
- begp2
)
3033 return make_number (- chars
- 1);
3035 /* Same length too => they are equal. */
3036 return make_number (0);
3040 subst_char_in_region_unwind (Lisp_Object arg
)
3042 bset_undo_list (current_buffer
, arg
);
3046 subst_char_in_region_unwind_1 (Lisp_Object arg
)
3048 bset_filename (current_buffer
, arg
);
3051 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
3052 Ssubst_char_in_region
, 4, 5, 0,
3053 doc
: /* From START to END, replace FROMCHAR with TOCHAR each time it occurs.
3054 If optional arg NOUNDO is non-nil, don't record this change for undo
3055 and don't mark the buffer as really changed.
3056 Both characters must have the same length of multi-byte form. */)
3057 (Lisp_Object start
, Lisp_Object end
, Lisp_Object fromchar
, Lisp_Object tochar
, Lisp_Object noundo
)
3059 register ptrdiff_t pos
, pos_byte
, stop
, i
, len
, end_byte
;
3060 /* Keep track of the first change in the buffer:
3061 if 0 we haven't found it yet.
3062 if < 0 we've found it and we've run the before-change-function.
3063 if > 0 we've actually performed it and the value is its position. */
3064 ptrdiff_t changed
= 0;
3065 unsigned char fromstr
[MAX_MULTIBYTE_LENGTH
], tostr
[MAX_MULTIBYTE_LENGTH
];
3067 ptrdiff_t count
= SPECPDL_INDEX ();
3068 #define COMBINING_NO 0
3069 #define COMBINING_BEFORE 1
3070 #define COMBINING_AFTER 2
3071 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
3072 int maybe_byte_combining
= COMBINING_NO
;
3073 ptrdiff_t last_changed
= 0;
3075 = !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3080 validate_region (&start
, &end
);
3081 CHECK_CHARACTER (fromchar
);
3082 CHECK_CHARACTER (tochar
);
3083 fromc
= XFASTINT (fromchar
);
3084 toc
= XFASTINT (tochar
);
3088 len
= CHAR_STRING (fromc
, fromstr
);
3089 if (CHAR_STRING (toc
, tostr
) != len
)
3090 error ("Characters in `subst-char-in-region' have different byte-lengths");
3091 if (!ASCII_CHAR_P (*tostr
))
3093 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
3094 complete multibyte character, it may be combined with the
3095 after bytes. If it is in the range 0xA0..0xFF, it may be
3096 combined with the before and after bytes. */
3097 if (!CHAR_HEAD_P (*tostr
))
3098 maybe_byte_combining
= COMBINING_BOTH
;
3099 else if (BYTES_BY_CHAR_HEAD (*tostr
) > len
)
3100 maybe_byte_combining
= COMBINING_AFTER
;
3111 pos_byte
= CHAR_TO_BYTE (pos
);
3112 stop
= CHAR_TO_BYTE (XINT (end
));
3115 /* If we don't want undo, turn off putting stuff on the list.
3116 That's faster than getting rid of things,
3117 and it prevents even the entry for a first change.
3118 Also inhibit locking the file. */
3119 if (!changed
&& !NILP (noundo
))
3121 record_unwind_protect (subst_char_in_region_unwind
,
3122 BVAR (current_buffer
, undo_list
));
3123 bset_undo_list (current_buffer
, Qt
);
3124 /* Don't do file-locking. */
3125 record_unwind_protect (subst_char_in_region_unwind_1
,
3126 BVAR (current_buffer
, filename
));
3127 bset_filename (current_buffer
, Qnil
);
3130 if (pos_byte
< GPT_BYTE
)
3131 stop
= min (stop
, GPT_BYTE
);
3134 ptrdiff_t pos_byte_next
= pos_byte
;
3136 if (pos_byte
>= stop
)
3138 if (pos_byte
>= end_byte
) break;
3141 p
= BYTE_POS_ADDR (pos_byte
);
3143 INC_POS (pos_byte_next
);
3146 if (pos_byte_next
- pos_byte
== len
3147 && p
[0] == fromstr
[0]
3149 || (p
[1] == fromstr
[1]
3150 && (len
== 2 || (p
[2] == fromstr
[2]
3151 && (len
== 3 || p
[3] == fromstr
[3]))))))
3154 /* We've already seen this and run the before-change-function;
3155 this time we only need to record the actual position. */
3160 modify_text (pos
, XINT (end
));
3162 if (! NILP (noundo
))
3164 if (MODIFF
- 1 == SAVE_MODIFF
)
3166 if (MODIFF
- 1 == BUF_AUTOSAVE_MODIFF (current_buffer
))
3167 BUF_AUTOSAVE_MODIFF (current_buffer
)++;
3170 /* The before-change-function may have moved the gap
3171 or even modified the buffer so we should start over. */
3175 /* Take care of the case where the new character
3176 combines with neighboring bytes. */
3177 if (maybe_byte_combining
3178 && (maybe_byte_combining
== COMBINING_AFTER
3179 ? (pos_byte_next
< Z_BYTE
3180 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
3181 : ((pos_byte_next
< Z_BYTE
3182 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
3183 || (pos_byte
> BEG_BYTE
3184 && ! ASCII_CHAR_P (FETCH_BYTE (pos_byte
- 1))))))
3186 Lisp_Object tem
, string
;
3188 tem
= BVAR (current_buffer
, undo_list
);
3190 /* Make a multibyte string containing this single character. */
3191 string
= make_multibyte_string ((char *) tostr
, 1, len
);
3192 /* replace_range is less efficient, because it moves the gap,
3193 but it handles combining correctly. */
3194 replace_range (pos
, pos
+ 1, string
,
3196 pos_byte_next
= CHAR_TO_BYTE (pos
);
3197 if (pos_byte_next
> pos_byte
)
3198 /* Before combining happened. We should not increment
3199 POS. So, to cancel the later increment of POS,
3203 INC_POS (pos_byte_next
);
3205 if (! NILP (noundo
))
3206 bset_undo_list (current_buffer
, tem
);
3211 record_change (pos
, 1);
3212 for (i
= 0; i
< len
; i
++) *p
++ = tostr
[i
];
3214 last_changed
= pos
+ 1;
3216 pos_byte
= pos_byte_next
;
3222 signal_after_change (changed
,
3223 last_changed
- changed
, last_changed
- changed
);
3224 update_compositions (changed
, last_changed
, CHECK_ALL
);
3227 unbind_to (count
, Qnil
);
3232 static Lisp_Object
check_translation (ptrdiff_t, ptrdiff_t, ptrdiff_t,
3235 /* Helper function for Ftranslate_region_internal.
3237 Check if a character sequence at POS (POS_BYTE) matches an element
3238 of VAL. VAL is a list (([FROM-CHAR ...] . TO) ...). If a matching
3239 element is found, return it. Otherwise return Qnil. */
3242 check_translation (ptrdiff_t pos
, ptrdiff_t pos_byte
, ptrdiff_t end
,
3245 int initial_buf
[16];
3246 int *buf
= initial_buf
;
3247 ptrdiff_t buf_size
= ARRAYELTS (initial_buf
);
3249 ptrdiff_t buf_used
= 0;
3250 Lisp_Object result
= Qnil
;
3252 for (; CONSP (val
); val
= XCDR (val
))
3261 if (! VECTORP (elt
))
3264 if (len
<= end
- pos
)
3266 for (i
= 0; i
< len
; i
++)
3270 unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
3273 if (buf_used
== buf_size
)
3275 bufalloc
= xpalloc (bufalloc
, &buf_size
, 1, -1,
3277 if (buf
== initial_buf
)
3278 memcpy (bufalloc
, buf
, sizeof initial_buf
);
3281 buf
[buf_used
++] = STRING_CHAR_AND_LENGTH (p
, len1
);
3284 if (XINT (AREF (elt
, i
)) != buf
[i
])
3289 result
= XCAR (val
);
3300 DEFUN ("translate-region-internal", Ftranslate_region_internal
,
3301 Stranslate_region_internal
, 3, 3, 0,
3302 doc
: /* Internal use only.
3303 From START to END, translate characters according to TABLE.
3304 TABLE is a string or a char-table; the Nth character in it is the
3305 mapping for the character with code N.
3306 It returns the number of characters changed. */)
3307 (Lisp_Object start
, Lisp_Object end
, register Lisp_Object table
)
3309 register unsigned char *tt
; /* Trans table. */
3310 register int nc
; /* New character. */
3311 int cnt
; /* Number of changes made. */
3312 ptrdiff_t size
; /* Size of translate table. */
3313 ptrdiff_t pos
, pos_byte
, end_pos
;
3314 bool multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3315 bool string_multibyte
IF_LINT (= 0);
3317 validate_region (&start
, &end
);
3318 if (CHAR_TABLE_P (table
))
3320 if (! EQ (XCHAR_TABLE (table
)->purpose
, Qtranslation_table
))
3321 error ("Not a translation table");
3327 CHECK_STRING (table
);
3329 if (! multibyte
&& (SCHARS (table
) < SBYTES (table
)))
3330 table
= string_make_unibyte (table
);
3331 string_multibyte
= SCHARS (table
) < SBYTES (table
);
3332 size
= SBYTES (table
);
3337 pos_byte
= CHAR_TO_BYTE (pos
);
3338 end_pos
= XINT (end
);
3339 modify_text (pos
, end_pos
);
3342 for (; pos
< end_pos
; )
3344 register unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
3345 unsigned char *str
, buf
[MAX_MULTIBYTE_LENGTH
];
3351 oc
= STRING_CHAR_AND_LENGTH (p
, len
);
3358 /* Reload as signal_after_change in last iteration may GC. */
3360 if (string_multibyte
)
3362 str
= tt
+ string_char_to_byte (table
, oc
);
3363 nc
= STRING_CHAR_AND_LENGTH (str
, str_len
);
3368 if (! ASCII_CHAR_P (nc
) && multibyte
)
3370 str_len
= BYTE8_STRING (nc
, buf
);
3383 val
= CHAR_TABLE_REF (table
, oc
);
3384 if (CHARACTERP (val
))
3386 nc
= XFASTINT (val
);
3387 str_len
= CHAR_STRING (nc
, buf
);
3390 else if (VECTORP (val
) || (CONSP (val
)))
3392 /* VAL is [TO_CHAR ...] or (([FROM-CHAR ...] . TO) ...)
3393 where TO is TO-CHAR or [TO-CHAR ...]. */
3398 if (nc
!= oc
&& nc
>= 0)
3400 /* Simple one char to one char translation. */
3405 /* This is less efficient, because it moves the gap,
3406 but it should handle multibyte characters correctly. */
3407 string
= make_multibyte_string ((char *) str
, 1, str_len
);
3408 replace_range (pos
, pos
+ 1, string
, 1, 0, 1, 0);
3413 record_change (pos
, 1);
3414 while (str_len
-- > 0)
3416 signal_after_change (pos
, 1, 1);
3417 update_compositions (pos
, pos
+ 1, CHECK_BORDER
);
3427 val
= check_translation (pos
, pos_byte
, end_pos
, val
);
3434 /* VAL is ([FROM-CHAR ...] . TO). */
3435 len
= ASIZE (XCAR (val
));
3443 string
= Fconcat (1, &val
);
3447 string
= Fmake_string (make_number (1), val
);
3449 replace_range (pos
, pos
+ len
, string
, 1, 0, 1, 0);
3450 pos_byte
+= SBYTES (string
);
3451 pos
+= SCHARS (string
);
3452 cnt
+= SCHARS (string
);
3453 end_pos
+= SCHARS (string
) - len
;
3461 return make_number (cnt
);
3464 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
3465 doc
: /* Delete the text between START and END.
3466 If called interactively, delete the region between point and mark.
3467 This command deletes buffer text without modifying the kill ring. */)
3468 (Lisp_Object start
, Lisp_Object end
)
3470 validate_region (&start
, &end
);
3471 del_range (XINT (start
), XINT (end
));
3475 DEFUN ("delete-and-extract-region", Fdelete_and_extract_region
,
3476 Sdelete_and_extract_region
, 2, 2, 0,
3477 doc
: /* Delete the text between START and END and return it. */)
3478 (Lisp_Object start
, Lisp_Object end
)
3480 validate_region (&start
, &end
);
3481 if (XINT (start
) == XINT (end
))
3482 return empty_unibyte_string
;
3483 return del_range_1 (XINT (start
), XINT (end
), 1, 1);
3486 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
3487 doc
: /* Remove restrictions (narrowing) from current buffer.
3488 This allows the buffer's full text to be seen and edited. */)
3491 if (BEG
!= BEGV
|| Z
!= ZV
)
3492 current_buffer
->clip_changed
= 1;
3494 BEGV_BYTE
= BEG_BYTE
;
3495 SET_BUF_ZV_BOTH (current_buffer
, Z
, Z_BYTE
);
3496 /* Changing the buffer bounds invalidates any recorded current column. */
3497 invalidate_current_column ();
3501 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
3502 doc
: /* Restrict editing in this buffer to the current region.
3503 The rest of the text becomes temporarily invisible and untouchable
3504 but is not deleted; if you save the buffer in a file, the invisible
3505 text is included in the file. \\[widen] makes all visible again.
3506 See also `save-restriction'.
3508 When calling from a program, pass two arguments; positions (integers
3509 or markers) bounding the text that should remain visible. */)
3510 (register Lisp_Object start
, Lisp_Object end
)
3512 CHECK_NUMBER_COERCE_MARKER (start
);
3513 CHECK_NUMBER_COERCE_MARKER (end
);
3515 if (XINT (start
) > XINT (end
))
3518 tem
= start
; start
= end
; end
= tem
;
3521 if (!(BEG
<= XINT (start
) && XINT (start
) <= XINT (end
) && XINT (end
) <= Z
))
3522 args_out_of_range (start
, end
);
3524 if (BEGV
!= XFASTINT (start
) || ZV
!= XFASTINT (end
))
3525 current_buffer
->clip_changed
= 1;
3527 SET_BUF_BEGV (current_buffer
, XFASTINT (start
));
3528 SET_BUF_ZV (current_buffer
, XFASTINT (end
));
3529 if (PT
< XFASTINT (start
))
3530 SET_PT (XFASTINT (start
));
3531 if (PT
> XFASTINT (end
))
3532 SET_PT (XFASTINT (end
));
3533 /* Changing the buffer bounds invalidates any recorded current column. */
3534 invalidate_current_column ();
3539 save_restriction_save (void)
3541 if (BEGV
== BEG
&& ZV
== Z
)
3542 /* The common case that the buffer isn't narrowed.
3543 We return just the buffer object, which save_restriction_restore
3544 recognizes as meaning `no restriction'. */
3545 return Fcurrent_buffer ();
3547 /* We have to save a restriction, so return a pair of markers, one
3548 for the beginning and one for the end. */
3550 Lisp_Object beg
, end
;
3552 beg
= build_marker (current_buffer
, BEGV
, BEGV_BYTE
);
3553 end
= build_marker (current_buffer
, ZV
, ZV_BYTE
);
3555 /* END must move forward if text is inserted at its exact location. */
3556 XMARKER (end
)->insertion_type
= 1;
3558 return Fcons (beg
, end
);
3563 save_restriction_restore (Lisp_Object data
)
3565 struct buffer
*cur
= NULL
;
3566 struct buffer
*buf
= (CONSP (data
)
3567 ? XMARKER (XCAR (data
))->buffer
3570 if (buf
&& buf
!= current_buffer
&& !NILP (BVAR (buf
, pt_marker
)))
3571 { /* If `buf' uses markers to keep track of PT, BEGV, and ZV (as
3572 is the case if it is or has an indirect buffer), then make
3573 sure it is current before we update BEGV, so
3574 set_buffer_internal takes care of managing those markers. */
3575 cur
= current_buffer
;
3576 set_buffer_internal (buf
);
3580 /* A pair of marks bounding a saved restriction. */
3582 struct Lisp_Marker
*beg
= XMARKER (XCAR (data
));
3583 struct Lisp_Marker
*end
= XMARKER (XCDR (data
));
3584 eassert (buf
== end
->buffer
);
3586 if (buf
/* Verify marker still points to a buffer. */
3587 && (beg
->charpos
!= BUF_BEGV (buf
) || end
->charpos
!= BUF_ZV (buf
)))
3588 /* The restriction has changed from the saved one, so restore
3589 the saved restriction. */
3591 ptrdiff_t pt
= BUF_PT (buf
);
3593 SET_BUF_BEGV_BOTH (buf
, beg
->charpos
, beg
->bytepos
);
3594 SET_BUF_ZV_BOTH (buf
, end
->charpos
, end
->bytepos
);
3596 if (pt
< beg
->charpos
|| pt
> end
->charpos
)
3597 /* The point is outside the new visible range, move it inside. */
3598 SET_BUF_PT_BOTH (buf
,
3599 clip_to_bounds (beg
->charpos
, pt
, end
->charpos
),
3600 clip_to_bounds (beg
->bytepos
, BUF_PT_BYTE (buf
),
3603 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3605 /* These aren't needed anymore, so don't wait for GC. */
3606 free_marker (XCAR (data
));
3607 free_marker (XCDR (data
));
3608 free_cons (XCONS (data
));
3611 /* A buffer, which means that there was no old restriction. */
3613 if (buf
/* Verify marker still points to a buffer. */
3614 && (BUF_BEGV (buf
) != BUF_BEG (buf
) || BUF_ZV (buf
) != BUF_Z (buf
)))
3615 /* The buffer has been narrowed, get rid of the narrowing. */
3617 SET_BUF_BEGV_BOTH (buf
, BUF_BEG (buf
), BUF_BEG_BYTE (buf
));
3618 SET_BUF_ZV_BOTH (buf
, BUF_Z (buf
), BUF_Z_BYTE (buf
));
3620 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3624 /* Changing the buffer bounds invalidates any recorded current column. */
3625 invalidate_current_column ();
3628 set_buffer_internal (cur
);
3631 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
3632 doc
: /* Execute BODY, saving and restoring current buffer's restrictions.
3633 The buffer's restrictions make parts of the beginning and end invisible.
3634 \(They are set up with `narrow-to-region' and eliminated with `widen'.)
3635 This special form, `save-restriction', saves the current buffer's restrictions
3636 when it is entered, and restores them when it is exited.
3637 So any `narrow-to-region' within BODY lasts only until the end of the form.
3638 The old restrictions settings are restored
3639 even in case of abnormal exit (throw or error).
3641 The value returned is the value of the last form in BODY.
3643 Note: if you are using both `save-excursion' and `save-restriction',
3644 use `save-excursion' outermost:
3645 (save-excursion (save-restriction ...))
3647 usage: (save-restriction &rest BODY) */)
3650 register Lisp_Object val
;
3651 ptrdiff_t count
= SPECPDL_INDEX ();
3653 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
3654 val
= Fprogn (body
);
3655 return unbind_to (count
, val
);
3658 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
3659 doc
: /* Display a message at the bottom of the screen.
3660 The message also goes into the `*Messages*' buffer, if `message-log-max'
3661 is non-nil. (In keyboard macros, that's all it does.)
3664 In batch mode, the message is printed to the standard error stream,
3665 followed by a newline.
3667 The first argument is a format control string, and the rest are data
3668 to be formatted under control of the string. See `format-message' for
3671 Note: (message "%s" VALUE) displays the string VALUE without
3672 interpreting format characters like `%', `\\=`', and `\\=''.
3674 If the first argument is nil or the empty string, the function clears
3675 any existing message; this lets the minibuffer contents show. See
3676 also `current-message'.
3678 usage: (message FORMAT-STRING &rest ARGS) */)
3679 (ptrdiff_t nargs
, Lisp_Object
*args
)
3682 || (STRINGP (args
[0])
3683 && SBYTES (args
[0]) == 0))
3690 Lisp_Object val
= Fformat_message (nargs
, args
);
3696 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
3697 doc
: /* Display a message, in a dialog box if possible.
3698 If a dialog box is not available, use the echo area.
3699 The first argument is a format control string, and the rest are data
3700 to be formatted under control of the string. See `format-message' for
3703 If the first argument is nil or the empty string, clear any existing
3704 message; let the minibuffer contents show.
3706 usage: (message-box FORMAT-STRING &rest ARGS) */)
3707 (ptrdiff_t nargs
, Lisp_Object
*args
)
3716 Lisp_Object val
= Fformat_message (nargs
, args
);
3717 Lisp_Object pane
, menu
;
3719 pane
= list1 (Fcons (build_string ("OK"), Qt
));
3720 menu
= Fcons (val
, pane
);
3721 Fx_popup_dialog (Qt
, menu
, Qt
);
3726 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
3727 doc
: /* Display a message in a dialog box or in the echo area.
3728 If this command was invoked with the mouse, use a dialog box if
3729 `use-dialog-box' is non-nil.
3730 Otherwise, use the echo area.
3731 The first argument is a format control string, and the rest are data
3732 to be formatted under control of the string. See `format-message' for
3735 If the first argument is nil or the empty string, clear any existing
3736 message; let the minibuffer contents show.
3738 usage: (message-or-box FORMAT-STRING &rest ARGS) */)
3739 (ptrdiff_t nargs
, Lisp_Object
*args
)
3741 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3743 return Fmessage_box (nargs
, args
);
3744 return Fmessage (nargs
, args
);
3747 DEFUN ("current-message", Fcurrent_message
, Scurrent_message
, 0, 0, 0,
3748 doc
: /* Return the string currently displayed in the echo area, or nil if none. */)
3751 return current_message ();
3755 DEFUN ("propertize", Fpropertize
, Spropertize
, 1, MANY
, 0,
3756 doc
: /* Return a copy of STRING with text properties added.
3757 First argument is the string to copy.
3758 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
3759 properties to add to the result.
3760 usage: (propertize STRING &rest PROPERTIES) */)
3761 (ptrdiff_t nargs
, Lisp_Object
*args
)
3763 Lisp_Object properties
, string
;
3766 /* Number of args must be odd. */
3767 if ((nargs
& 1) == 0)
3768 error ("Wrong number of arguments");
3770 properties
= string
= Qnil
;
3772 /* First argument must be a string. */
3773 CHECK_STRING (args
[0]);
3774 string
= Fcopy_sequence (args
[0]);
3776 for (i
= 1; i
< nargs
; i
+= 2)
3777 properties
= Fcons (args
[i
], Fcons (args
[i
+ 1], properties
));
3779 Fadd_text_properties (make_number (0),
3780 make_number (SCHARS (string
)),
3781 properties
, string
);
3785 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
3786 doc
: /* Format a string out of a format-string and arguments.
3787 The first argument is a format control string.
3788 The other arguments are substituted into it to make the result, a string.
3790 The format control string may contain %-sequences meaning to substitute
3791 the next available argument:
3793 %s means print a string argument. Actually, prints any object, with `princ'.
3794 %d means print as number in decimal (%o octal, %x hex).
3795 %X is like %x, but uses upper case.
3796 %e means print a number in exponential notation.
3797 %f means print a number in decimal-point notation.
3798 %g means print a number in exponential notation
3799 or decimal-point notation, whichever uses fewer characters.
3800 %c means print a number as a single character.
3801 %S means print any object as an s-expression (using `prin1').
3803 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
3804 Use %% to put a single % into the output.
3806 A %-sequence may contain optional flag, width, and precision
3807 specifiers, as follows:
3809 %<flags><width><precision>character
3811 where flags is [+ #-0]+, width is [0-9]+, and precision is .[0-9]+
3813 The + flag character inserts a + before any positive number, while a
3814 space inserts a space before any positive number; these flags only
3815 affect %d, %e, %f, and %g sequences, and the + flag takes precedence.
3816 The - and 0 flags affect the width specifier, as described below.
3818 The # flag means to use an alternate display form for %o, %x, %X, %e,
3819 %f, and %g sequences: for %o, it ensures that the result begins with
3820 \"0\"; for %x and %X, it prefixes the result with \"0x\" or \"0X\";
3821 for %e, %f, and %g, it causes a decimal point to be included even if
3822 the precision is zero.
3824 The width specifier supplies a lower limit for the length of the
3825 printed representation. The padding, if any, normally goes on the
3826 left, but it goes on the right if the - flag is present. The padding
3827 character is normally a space, but it is 0 if the 0 flag is present.
3828 The 0 flag is ignored if the - flag is present, or the format sequence
3829 is something other than %d, %e, %f, and %g.
3831 For %e, %f, and %g sequences, the number after the "." in the
3832 precision specifier says how many decimal places to show; if zero, the
3833 decimal point itself is omitted. For %s and %S, the precision
3834 specifier truncates the string to the given width.
3836 usage: (format STRING &rest OBJECTS) */)
3837 (ptrdiff_t nargs
, Lisp_Object
*args
)
3839 return styled_format (nargs
, args
, false);
3842 DEFUN ("format-message", Fformat_message
, Sformat_message
, 1, MANY
, 0,
3843 doc
: /* Format a string out of a format-string and arguments.
3844 The first argument is a format control string.
3845 The other arguments are substituted into it to make the result, a string.
3847 This acts like `format', except it also replaces each left single
3848 quotation mark (\\=‘) and grave accent (\\=`) by a left quote, and each
3849 right single quotation mark (\\=’) and apostrophe (\\=') by a right quote.
3850 The left and right quote replacement characters are specified by
3851 `text-quoting-style'.
3853 usage: (format-message STRING &rest OBJECTS) */)
3854 (ptrdiff_t nargs
, Lisp_Object
*args
)
3856 return styled_format (nargs
, args
, true);
3859 /* Implement ‘format-message’ if MESSAGE is true, ‘format’ otherwise. */
3862 styled_format (ptrdiff_t nargs
, Lisp_Object
*args
, bool message
)
3864 ptrdiff_t n
; /* The number of the next arg to substitute. */
3865 char initial_buffer
[4000];
3866 char *buf
= initial_buffer
;
3867 ptrdiff_t bufsize
= sizeof initial_buffer
;
3868 ptrdiff_t max_bufsize
= STRING_BYTES_BOUND
+ 1;
3870 ptrdiff_t buf_save_value_index
IF_LINT (= 0);
3873 /* When we make a multibyte string, we must pay attention to the
3874 byte combining problem, i.e., a byte may be combined with a
3875 multibyte character of the previous string. This flag tells if we
3876 must consider such a situation or not. */
3877 bool maybe_combine_byte
;
3878 bool arg_intervals
= false;
3881 /* Each element records, for one argument,
3882 the start and end bytepos in the output string,
3883 whether the argument has been converted to string (e.g., due to "%S"),
3884 and whether the argument is a string with intervals. */
3887 ptrdiff_t start
, end
;
3888 bool_bf converted_to_string
: 1;
3889 bool_bf intervals
: 1;
3892 CHECK_STRING (args
[0]);
3893 char *format_start
= SSDATA (args
[0]);
3894 ptrdiff_t formatlen
= SBYTES (args
[0]);
3896 /* Allocate the info and discarded tables. */
3897 ptrdiff_t alloca_size
;
3898 if (INT_MULTIPLY_WRAPV (nargs
, sizeof *info
, &alloca_size
)
3899 || INT_ADD_WRAPV (sizeof *info
, alloca_size
, &alloca_size
)
3900 || INT_ADD_WRAPV (formatlen
, alloca_size
, &alloca_size
)
3901 || SIZE_MAX
< alloca_size
)
3902 memory_full (SIZE_MAX
);
3903 /* info[0] is unused. Unused elements have -1 for start. */
3904 info
= SAFE_ALLOCA (alloca_size
);
3905 memset (info
, 0, alloca_size
);
3906 for (ptrdiff_t i
= 0; i
< nargs
+ 1; i
++)
3908 /* discarded[I] is 1 if byte I of the format
3909 string was not copied into the output.
3910 It is 2 if byte I was not the first byte of its character. */
3911 char *discarded
= (char *) &info
[nargs
+ 1];
3913 /* Try to determine whether the result should be multibyte.
3914 This is not always right; sometimes the result needs to be multibyte
3915 because of an object that we will pass through prin1.
3916 or because a grave accent or apostrophe is requoted,
3917 and in that case, we won't know it here. */
3919 /* True if the format is multibyte. */
3920 bool multibyte_format
= STRING_MULTIBYTE (args
[0]);
3921 /* True if the output should be a multibyte string,
3922 which is true if any of the inputs is one. */
3923 bool multibyte
= multibyte_format
;
3924 for (ptrdiff_t i
= 1; !multibyte
&& i
< nargs
; i
++)
3925 if (STRINGP (args
[i
]) && STRING_MULTIBYTE (args
[i
]))
3928 int quoting_style
= message
? text_quoting_style () : -1;
3930 /* If we start out planning a unibyte result,
3931 then discover it has to be multibyte, we jump back to retry. */
3938 /* Scan the format and store result in BUF. */
3939 format
= format_start
;
3940 end
= format
+ formatlen
;
3941 maybe_combine_byte
= false;
3943 while (format
!= end
)
3945 /* The values of N and FORMAT when the loop body is entered. */
3947 char *format0
= format
;
3948 char const *convsrc
= format
;
3949 unsigned char format_char
= *format
++;
3951 /* Bytes needed to represent the output of this conversion. */
3952 ptrdiff_t convbytes
= 1;
3954 if (format_char
== '%')
3956 /* General format specifications look like
3958 '%' [flags] [field-width] [precision] format
3963 field-width ::= [0-9]+
3964 precision ::= '.' [0-9]*
3966 If a field-width is specified, it specifies to which width
3967 the output should be padded with blanks, if the output
3968 string is shorter than field-width.
3970 If precision is specified, it specifies the number of
3971 digits to print after the '.' for floats, or the max.
3972 number of chars to print from a string. */
3974 bool minus_flag
= false;
3975 bool plus_flag
= false;
3976 bool space_flag
= false;
3977 bool sharp_flag
= false;
3978 bool zero_flag
= false;
3984 case '-': minus_flag
= true; continue;
3985 case '+': plus_flag
= true; continue;
3986 case ' ': space_flag
= true; continue;
3987 case '#': sharp_flag
= true; continue;
3988 case '0': zero_flag
= true; continue;
3993 /* Ignore flags when sprintf ignores them. */
3994 space_flag
&= ~ plus_flag
;
3995 zero_flag
&= ~ minus_flag
;
3998 uintmax_t raw_field_width
= strtoumax (format
, &num_end
, 10);
3999 if (max_bufsize
<= raw_field_width
)
4001 ptrdiff_t field_width
= raw_field_width
;
4003 bool precision_given
= *num_end
== '.';
4004 uintmax_t precision
= (precision_given
4005 ? strtoumax (num_end
+ 1, &num_end
, 10)
4010 error ("Format string ends in middle of format specifier");
4012 char conversion
= *format
++;
4013 memset (&discarded
[format0
- format_start
], 1,
4014 format
- format0
- (conversion
== '%'));
4015 if (conversion
== '%')
4020 error ("Not enough arguments for format string");
4022 /* For 'S', prin1 the argument, and then treat like 's'.
4023 For 's', princ any argument that is not a string or
4024 symbol. But don't do this conversion twice, which might
4025 happen after retrying. */
4026 if ((conversion
== 'S'
4027 || (conversion
== 's'
4028 && ! STRINGP (args
[n
]) && ! SYMBOLP (args
[n
]))))
4030 if (! info
[n
].converted_to_string
)
4032 Lisp_Object noescape
= conversion
== 'S' ? Qnil
: Qt
;
4033 args
[n
] = Fprin1_to_string (args
[n
], noescape
);
4034 info
[n
].converted_to_string
= true;
4035 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
4043 else if (conversion
== 'c')
4045 if (FLOATP (args
[n
]))
4047 double d
= XFLOAT_DATA (args
[n
]);
4048 args
[n
] = make_number (FIXNUM_OVERFLOW_P (d
) ? -1 : d
);
4051 if (INTEGERP (args
[n
]) && ! ASCII_CHAR_P (XINT (args
[n
])))
4058 args
[n
] = Fchar_to_string (args
[n
]);
4059 info
[n
].converted_to_string
= true;
4062 if (info
[n
].converted_to_string
)
4067 if (SYMBOLP (args
[n
]))
4069 args
[n
] = SYMBOL_NAME (args
[n
]);
4070 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
4077 if (conversion
== 's')
4079 /* handle case (precision[n] >= 0) */
4081 ptrdiff_t prec
= -1;
4082 if (precision_given
&& precision
<= TYPE_MAXIMUM (ptrdiff_t))
4085 /* lisp_string_width ignores a precision of 0, but GNU
4086 libc functions print 0 characters when the precision
4087 is 0. Imitate libc behavior here. Changing
4088 lisp_string_width is the right thing, and will be
4089 done, but meanwhile we work with it. */
4091 ptrdiff_t width
, nbytes
;
4092 ptrdiff_t nchars_string
;
4094 width
= nchars_string
= nbytes
= 0;
4098 width
= lisp_string_width (args
[n
], prec
, &nch
, &nby
);
4101 nchars_string
= SCHARS (args
[n
]);
4102 nbytes
= SBYTES (args
[n
]);
4106 nchars_string
= nch
;
4112 if (convbytes
&& multibyte
&& ! STRING_MULTIBYTE (args
[n
]))
4113 convbytes
= count_size_as_multibyte (SDATA (args
[n
]), nbytes
);
4116 = width
< field_width
? field_width
- width
: 0;
4118 if (max_bufsize
- padding
<= convbytes
)
4120 convbytes
+= padding
;
4121 if (convbytes
<= buf
+ bufsize
- p
)
4125 memset (p
, ' ', padding
);
4132 && !ASCII_CHAR_P (*((unsigned char *) p
- 1))
4133 && STRING_MULTIBYTE (args
[n
])
4134 && !CHAR_HEAD_P (SREF (args
[n
], 0)))
4135 maybe_combine_byte
= true;
4137 p
+= copy_text (SDATA (args
[n
]), (unsigned char *) p
,
4139 STRING_MULTIBYTE (args
[n
]), multibyte
);
4141 info
[n
].start
= nchars
;
4142 nchars
+= nchars_string
;
4143 info
[n
].end
= nchars
;
4147 memset (p
, ' ', padding
);
4152 /* If this argument has text properties, record where
4153 in the result string it appears. */
4154 if (string_intervals (args
[n
]))
4155 info
[n
].intervals
= arg_intervals
= true;
4160 else if (! (conversion
== 'c' || conversion
== 'd'
4161 || conversion
== 'e' || conversion
== 'f'
4162 || conversion
== 'g' || conversion
== 'i'
4163 || conversion
== 'o' || conversion
== 'x'
4164 || conversion
== 'X'))
4165 error ("Invalid format operation %%%c",
4166 STRING_CHAR ((unsigned char *) format
- 1));
4167 else if (! NUMBERP (args
[n
]))
4168 error ("Format specifier doesn't match argument type");
4173 /* Maximum precision for a %f conversion such that the
4174 trailing output digit might be nonzero. Any precision
4175 larger than this will not yield useful information. */
4176 USEFUL_PRECISION_MAX
=
4178 * (FLT_RADIX
== 2 || FLT_RADIX
== 10 ? 1
4179 : FLT_RADIX
== 16 ? 4
4182 /* Maximum number of bytes generated by any format, if
4183 precision is no more than USEFUL_PRECISION_MAX.
4184 On all practical hosts, %f is the worst case. */
4186 sizeof "-." + (DBL_MAX_10_EXP
+ 1) + USEFUL_PRECISION_MAX
,
4188 /* Length of pM (that is, of pMd without the
4190 pMlen
= sizeof pMd
- 2
4192 verify (USEFUL_PRECISION_MAX
> 0);
4194 /* Avoid undefined behavior in underlying sprintf. */
4195 if (conversion
== 'd' || conversion
== 'i')
4198 /* Create the copy of the conversion specification, with
4199 any width and precision removed, with ".*" inserted,
4200 and with pM inserted for integer formats.
4201 At most three flags F can be specified at once. */
4202 char convspec
[sizeof "%FFF.*d" + pMlen
];
4206 *f
= '-'; f
+= minus_flag
;
4207 *f
= '+'; f
+= plus_flag
;
4208 *f
= ' '; f
+= space_flag
;
4209 *f
= '#'; f
+= sharp_flag
;
4210 *f
= '0'; f
+= zero_flag
;
4213 if (conversion
== 'd' || conversion
== 'i'
4214 || conversion
== 'o' || conversion
== 'x'
4215 || conversion
== 'X')
4217 memcpy (f
, pMd
, pMlen
);
4219 zero_flag
&= ~ precision_given
;
4226 if (precision_given
)
4227 prec
= min (precision
, USEFUL_PRECISION_MAX
);
4229 /* Use sprintf to format this number into sprintf_buf. Omit
4230 padding and excess precision, though, because sprintf limits
4231 output length to INT_MAX.
4233 There are four types of conversion: double, unsigned
4234 char (passed as int), wide signed int, and wide
4235 unsigned int. Treat them separately because the
4236 sprintf ABI is sensitive to which type is passed. Be
4237 careful about integer overflow, NaNs, infinities, and
4238 conversions; for example, the min and max macros are
4239 not suitable here. */
4240 char sprintf_buf
[SPRINTF_BUFSIZE
];
4241 ptrdiff_t sprintf_bytes
;
4242 if (conversion
== 'e' || conversion
== 'f' || conversion
== 'g')
4244 double x
= (INTEGERP (args
[n
])
4246 : XFLOAT_DATA (args
[n
]));
4247 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4249 else if (conversion
== 'c')
4251 /* Don't use sprintf here, as it might mishandle prec. */
4252 sprintf_buf
[0] = XINT (args
[n
]);
4253 sprintf_bytes
= prec
!= 0;
4255 else if (conversion
== 'd')
4257 /* For float, maybe we should use "%1.0f"
4258 instead so it also works for values outside
4259 the integer range. */
4261 if (INTEGERP (args
[n
]))
4265 double d
= XFLOAT_DATA (args
[n
]);
4268 x
= TYPE_MINIMUM (printmax_t
);
4274 x
= TYPE_MAXIMUM (printmax_t
);
4279 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4283 /* Don't sign-extend for octal or hex printing. */
4285 if (INTEGERP (args
[n
]))
4286 x
= XUINT (args
[n
]);
4289 double d
= XFLOAT_DATA (args
[n
]);
4294 x
= TYPE_MAXIMUM (uprintmax_t
);
4299 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4302 /* Now the length of the formatted item is known, except it omits
4303 padding and excess precision. Deal with excess precision
4304 first. This happens only when the format specifies
4305 ridiculously large precision. */
4306 uintmax_t excess_precision
= precision
- prec
;
4307 uintmax_t leading_zeros
= 0, trailing_zeros
= 0;
4308 if (excess_precision
)
4310 if (conversion
== 'e' || conversion
== 'f'
4311 || conversion
== 'g')
4313 if ((conversion
== 'g' && ! sharp_flag
)
4314 || ! ('0' <= sprintf_buf
[sprintf_bytes
- 1]
4315 && sprintf_buf
[sprintf_bytes
- 1] <= '9'))
4316 excess_precision
= 0;
4319 if (conversion
== 'g')
4321 char *dot
= strchr (sprintf_buf
, '.');
4323 excess_precision
= 0;
4326 trailing_zeros
= excess_precision
;
4329 leading_zeros
= excess_precision
;
4332 /* Compute the total bytes needed for this item, including
4333 excess precision and padding. */
4334 uintmax_t numwidth
= sprintf_bytes
+ excess_precision
;
4336 = numwidth
< field_width
? field_width
- numwidth
: 0;
4337 if (max_bufsize
- sprintf_bytes
<= excess_precision
4338 || max_bufsize
- padding
<= numwidth
)
4340 convbytes
= numwidth
+ padding
;
4342 if (convbytes
<= buf
+ bufsize
- p
)
4344 /* Copy the formatted item from sprintf_buf into buf,
4345 inserting padding and excess-precision zeros. */
4347 char *src
= sprintf_buf
;
4349 int exponent_bytes
= 0;
4350 bool signedp
= src0
== '-' || src0
== '+' || src0
== ' ';
4352 && ((src
[signedp
] >= '0' && src
[signedp
] <= '9')
4353 || (src
[signedp
] >= 'a' && src
[signedp
] <= 'f')
4354 || (src
[signedp
] >= 'A' && src
[signedp
] <= 'F')))
4356 leading_zeros
+= padding
;
4360 if (excess_precision
4361 && (conversion
== 'e' || conversion
== 'g'))
4363 char *e
= strchr (src
, 'e');
4365 exponent_bytes
= src
+ sprintf_bytes
- e
;
4370 memset (p
, ' ', padding
);
4378 memset (p
, '0', leading_zeros
);
4380 int significand_bytes
4381 = sprintf_bytes
- signedp
- exponent_bytes
;
4382 memcpy (p
, src
, significand_bytes
);
4383 p
+= significand_bytes
;
4384 src
+= significand_bytes
;
4385 memset (p
, '0', trailing_zeros
);
4386 p
+= trailing_zeros
;
4387 memcpy (p
, src
, exponent_bytes
);
4388 p
+= exponent_bytes
;
4390 info
[n
].start
= nchars
;
4391 nchars
+= leading_zeros
+ sprintf_bytes
+ trailing_zeros
;
4392 info
[n
].end
= nchars
;
4396 memset (p
, ' ', padding
);
4407 /* Named constants for the UTF-8 encodings of U+2018 LEFT SINGLE
4408 QUOTATION MARK and U+2019 RIGHT SINGLE QUOTATION MARK. */
4411 uLSQM0
= 0xE2, uLSQM1
= 0x80, uLSQM2
= 0x98,
4412 /* uRSQM0 = 0xE2, uRSQM1 = 0x80, */ uRSQM2
= 0x99
4415 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
4417 if ((format_char
== '`' || format_char
== '\'')
4418 && quoting_style
== CURVE_QUOTING_STYLE
)
4425 convsrc
= format_char
== '`' ? uLSQM
: uRSQM
;
4428 else if (format_char
== '`' && quoting_style
== STRAIGHT_QUOTING_STYLE
)
4430 else if (format_char
== uLSQM0
&& CURVE_QUOTING_STYLE
< quoting_style
4432 && (unsigned char) format
[0] == uLSQM1
4433 && ((unsigned char) format
[1] == uLSQM2
4434 || (unsigned char) format
[1] == uRSQM2
))
4436 convsrc
= (((unsigned char) format
[1] == uLSQM2
4437 && quoting_style
== GRAVE_QUOTING_STYLE
)
4440 memset (&discarded
[format0
+ 1 - format_start
], 2, 2);
4444 /* Copy a single character from format to buf. */
4445 if (multibyte_format
)
4447 /* Copy a whole multibyte character. */
4449 && !ASCII_CHAR_P (*((unsigned char *) p
- 1))
4450 && !CHAR_HEAD_P (format_char
))
4451 maybe_combine_byte
= true;
4453 while (! CHAR_HEAD_P (*format
))
4456 convbytes
= format
- format0
;
4457 memset (&discarded
[format0
+ 1 - format_start
], 2,
4460 else if (multibyte
&& !ASCII_CHAR_P (format_char
))
4462 int c
= BYTE8_TO_CHAR (format_char
);
4463 convbytes
= CHAR_STRING (c
, str
);
4464 convsrc
= (char *) str
;
4469 if (convbytes
<= buf
+ bufsize
- p
)
4471 memcpy (p
, convsrc
, convbytes
);
4478 /* There wasn't enough room to store this conversion or single
4479 character. CONVBYTES says how much room is needed. Allocate
4480 enough room (and then some) and do it again. */
4482 ptrdiff_t used
= p
- buf
;
4483 if (max_bufsize
- used
< convbytes
)
4485 bufsize
= used
+ convbytes
;
4486 bufsize
= bufsize
< max_bufsize
/ 2 ? bufsize
* 2 : max_bufsize
;
4488 if (buf
== initial_buffer
)
4490 buf
= xmalloc (bufsize
);
4491 sa_must_free
= true;
4492 buf_save_value_index
= SPECPDL_INDEX ();
4493 record_unwind_protect_ptr (xfree
, buf
);
4494 memcpy (buf
, initial_buffer
, used
);
4498 buf
= xrealloc (buf
, bufsize
);
4499 set_unwind_protect_ptr (buf_save_value_index
, xfree
, buf
);
4507 if (bufsize
< p
- buf
)
4510 if (maybe_combine_byte
)
4511 nchars
= multibyte_chars_in_text ((unsigned char *) buf
, p
- buf
);
4512 Lisp_Object val
= make_specified_string (buf
, nchars
, p
- buf
, multibyte
);
4514 /* If the format string has text properties, or any of the string
4515 arguments has text properties, set up text properties of the
4518 if (string_intervals (args
[0]) || arg_intervals
)
4520 /* Add text properties from the format string. */
4521 Lisp_Object len
= make_number (SCHARS (args
[0]));
4522 Lisp_Object props
= text_property_list (args
[0], make_number (0),
4526 ptrdiff_t bytepos
= 0, position
= 0, translated
= 0;
4529 /* Adjust the bounds of each text property
4530 to the proper start and end in the output string. */
4532 /* Put the positions in PROPS in increasing order, so that
4533 we can do (effectively) one scan through the position
4534 space of the format string. */
4535 props
= Fnreverse (props
);
4537 /* BYTEPOS is the byte position in the format string,
4538 POSITION is the untranslated char position in it,
4539 TRANSLATED is the translated char position in BUF,
4540 and ARGN is the number of the next arg we will come to. */
4541 for (Lisp_Object list
= props
; CONSP (list
); list
= XCDR (list
))
4543 Lisp_Object item
= XCAR (list
);
4545 /* First adjust the property start position. */
4546 ptrdiff_t pos
= XINT (XCAR (item
));
4548 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
4549 up to this position. */
4550 for (; position
< pos
; bytepos
++)
4552 if (! discarded
[bytepos
])
4553 position
++, translated
++;
4554 else if (discarded
[bytepos
] == 1)
4557 if (translated
== info
[argn
].start
)
4559 translated
+= info
[argn
].end
- info
[argn
].start
;
4565 XSETCAR (item
, make_number (translated
));
4567 /* Likewise adjust the property end position. */
4568 pos
= XINT (XCAR (XCDR (item
)));
4570 for (; position
< pos
; bytepos
++)
4572 if (! discarded
[bytepos
])
4573 position
++, translated
++;
4574 else if (discarded
[bytepos
] == 1)
4577 if (translated
== info
[argn
].start
)
4579 translated
+= info
[argn
].end
- info
[argn
].start
;
4585 XSETCAR (XCDR (item
), make_number (translated
));
4588 add_text_properties_from_list (val
, props
, make_number (0));
4591 /* Add text properties from arguments. */
4593 for (ptrdiff_t i
= 1; i
< nargs
; i
++)
4594 if (info
[i
].intervals
)
4596 len
= make_number (SCHARS (args
[i
]));
4597 Lisp_Object new_len
= make_number (info
[i
].end
- info
[i
].start
);
4598 props
= text_property_list (args
[i
], make_number (0), len
, Qnil
);
4599 props
= extend_property_ranges (props
, new_len
);
4600 /* If successive arguments have properties, be sure that
4601 the value of `composition' property be the copy. */
4602 if (1 < i
&& info
[i
- 1].end
)
4603 make_composition_value_copy (props
);
4604 add_text_properties_from_list (val
, props
,
4605 make_number (info
[i
].start
));
4609 /* If we allocated BUF or INFO with malloc, free it too. */
4615 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
4616 doc
: /* Return t if two characters match, optionally ignoring case.
4617 Both arguments must be characters (i.e. integers).
4618 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
4619 (register Lisp_Object c1
, Lisp_Object c2
)
4622 /* Check they're chars, not just integers, otherwise we could get array
4623 bounds violations in downcase. */
4624 CHECK_CHARACTER (c1
);
4625 CHECK_CHARACTER (c2
);
4627 if (XINT (c1
) == XINT (c2
))
4629 if (NILP (BVAR (current_buffer
, case_fold_search
)))
4635 /* FIXME: It is possible to compare multibyte characters even when
4636 the current buffer is unibyte. Unfortunately this is ambiguous
4637 for characters between 128 and 255, as they could be either
4638 eight-bit raw bytes or Latin-1 characters. Assume the former for
4639 now. See Bug#17011, and also see casefiddle.c's casify_object,
4640 which has a similar problem. */
4641 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4643 if (SINGLE_BYTE_CHAR_P (i1
))
4644 i1
= UNIBYTE_TO_CHAR (i1
);
4645 if (SINGLE_BYTE_CHAR_P (i2
))
4646 i2
= UNIBYTE_TO_CHAR (i2
);
4649 return (downcase (i1
) == downcase (i2
) ? Qt
: Qnil
);
4652 /* Transpose the markers in two regions of the current buffer, and
4653 adjust the ones between them if necessary (i.e.: if the regions
4656 START1, END1 are the character positions of the first region.
4657 START1_BYTE, END1_BYTE are the byte positions.
4658 START2, END2 are the character positions of the second region.
4659 START2_BYTE, END2_BYTE are the byte positions.
4661 Traverses the entire marker list of the buffer to do so, adding an
4662 appropriate amount to some, subtracting from some, and leaving the
4663 rest untouched. Most of this is copied from adjust_markers in insdel.c.
4665 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
4668 transpose_markers (ptrdiff_t start1
, ptrdiff_t end1
,
4669 ptrdiff_t start2
, ptrdiff_t end2
,
4670 ptrdiff_t start1_byte
, ptrdiff_t end1_byte
,
4671 ptrdiff_t start2_byte
, ptrdiff_t end2_byte
)
4673 register ptrdiff_t amt1
, amt1_byte
, amt2
, amt2_byte
, diff
, diff_byte
, mpos
;
4674 register struct Lisp_Marker
*marker
;
4676 /* Update point as if it were a marker. */
4680 TEMP_SET_PT_BOTH (PT
+ (end2
- end1
),
4681 PT_BYTE
+ (end2_byte
- end1_byte
));
4682 else if (PT
< start2
)
4683 TEMP_SET_PT_BOTH (PT
+ (end2
- start2
) - (end1
- start1
),
4684 (PT_BYTE
+ (end2_byte
- start2_byte
)
4685 - (end1_byte
- start1_byte
)));
4687 TEMP_SET_PT_BOTH (PT
- (start2
- start1
),
4688 PT_BYTE
- (start2_byte
- start1_byte
));
4690 /* We used to adjust the endpoints here to account for the gap, but that
4691 isn't good enough. Even if we assume the caller has tried to move the
4692 gap out of our way, it might still be at start1 exactly, for example;
4693 and that places it `inside' the interval, for our purposes. The amount
4694 of adjustment is nontrivial if there's a `denormalized' marker whose
4695 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
4696 the dirty work to Fmarker_position, below. */
4698 /* The difference between the region's lengths */
4699 diff
= (end2
- start2
) - (end1
- start1
);
4700 diff_byte
= (end2_byte
- start2_byte
) - (end1_byte
- start1_byte
);
4702 /* For shifting each marker in a region by the length of the other
4703 region plus the distance between the regions. */
4704 amt1
= (end2
- start2
) + (start2
- end1
);
4705 amt2
= (end1
- start1
) + (start2
- end1
);
4706 amt1_byte
= (end2_byte
- start2_byte
) + (start2_byte
- end1_byte
);
4707 amt2_byte
= (end1_byte
- start1_byte
) + (start2_byte
- end1_byte
);
4709 for (marker
= BUF_MARKERS (current_buffer
); marker
; marker
= marker
->next
)
4711 mpos
= marker
->bytepos
;
4712 if (mpos
>= start1_byte
&& mpos
< end2_byte
)
4714 if (mpos
< end1_byte
)
4716 else if (mpos
< start2_byte
)
4720 marker
->bytepos
= mpos
;
4722 mpos
= marker
->charpos
;
4723 if (mpos
>= start1
&& mpos
< end2
)
4727 else if (mpos
< start2
)
4732 marker
->charpos
= mpos
;
4736 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
4737 doc
: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
4738 The regions should not be overlapping, because the size of the buffer is
4739 never changed in a transposition.
4741 Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
4742 any markers that happen to be located in the regions.
4744 Transposing beyond buffer boundaries is an error. */)
4745 (Lisp_Object startr1
, Lisp_Object endr1
, Lisp_Object startr2
, Lisp_Object endr2
, Lisp_Object leave_markers
)
4747 register ptrdiff_t start1
, end1
, start2
, end2
;
4748 ptrdiff_t start1_byte
, start2_byte
, len1_byte
, len2_byte
, end2_byte
;
4749 ptrdiff_t gap
, len1
, len_mid
, len2
;
4750 unsigned char *start1_addr
, *start2_addr
, *temp
;
4752 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
, tmp_interval3
;
4755 XSETBUFFER (buf
, current_buffer
);
4756 cur_intv
= buffer_intervals (current_buffer
);
4758 validate_region (&startr1
, &endr1
);
4759 validate_region (&startr2
, &endr2
);
4761 start1
= XFASTINT (startr1
);
4762 end1
= XFASTINT (endr1
);
4763 start2
= XFASTINT (startr2
);
4764 end2
= XFASTINT (endr2
);
4767 /* Swap the regions if they're reversed. */
4770 register ptrdiff_t glumph
= start1
;
4778 len1
= end1
- start1
;
4779 len2
= end2
- start2
;
4782 error ("Transposed regions overlap");
4783 /* Nothing to change for adjacent regions with one being empty */
4784 else if ((start1
== end1
|| start2
== end2
) && end1
== start2
)
4787 /* The possibilities are:
4788 1. Adjacent (contiguous) regions, or separate but equal regions
4789 (no, really equal, in this case!), or
4790 2. Separate regions of unequal size.
4792 The worst case is usually No. 2. It means that (aside from
4793 potential need for getting the gap out of the way), there also
4794 needs to be a shifting of the text between the two regions. So
4795 if they are spread far apart, we are that much slower... sigh. */
4797 /* It must be pointed out that the really studly thing to do would
4798 be not to move the gap at all, but to leave it in place and work
4799 around it if necessary. This would be extremely efficient,
4800 especially considering that people are likely to do
4801 transpositions near where they are working interactively, which
4802 is exactly where the gap would be found. However, such code
4803 would be much harder to write and to read. So, if you are
4804 reading this comment and are feeling squirrely, by all means have
4805 a go! I just didn't feel like doing it, so I will simply move
4806 the gap the minimum distance to get it out of the way, and then
4807 deal with an unbroken array. */
4809 start1_byte
= CHAR_TO_BYTE (start1
);
4810 end2_byte
= CHAR_TO_BYTE (end2
);
4812 /* Make sure the gap won't interfere, by moving it out of the text
4813 we will operate on. */
4814 if (start1
< gap
&& gap
< end2
)
4816 if (gap
- start1
< end2
- gap
)
4817 move_gap_both (start1
, start1_byte
);
4819 move_gap_both (end2
, end2_byte
);
4822 start2_byte
= CHAR_TO_BYTE (start2
);
4823 len1_byte
= CHAR_TO_BYTE (end1
) - start1_byte
;
4824 len2_byte
= end2_byte
- start2_byte
;
4826 #ifdef BYTE_COMBINING_DEBUG
4829 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4830 len2_byte
, start1
, start1_byte
)
4831 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4832 len1_byte
, end2
, start2_byte
+ len2_byte
)
4833 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4834 len1_byte
, end2
, start2_byte
+ len2_byte
))
4839 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4840 len2_byte
, start1
, start1_byte
)
4841 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4842 len1_byte
, start2
, start2_byte
)
4843 || count_combining_after (BYTE_POS_ADDR (start2_byte
),
4844 len2_byte
, end1
, start1_byte
+ len1_byte
)
4845 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4846 len1_byte
, end2
, start2_byte
+ len2_byte
))
4851 /* Hmmm... how about checking to see if the gap is large
4852 enough to use as the temporary storage? That would avoid an
4853 allocation... interesting. Later, don't fool with it now. */
4855 /* Working without memmove, for portability (sigh), so must be
4856 careful of overlapping subsections of the array... */
4858 if (end1
== start2
) /* adjacent regions */
4860 modify_text (start1
, end2
);
4861 record_change (start1
, len1
+ len2
);
4863 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4864 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4865 /* Don't use Fset_text_properties: that can cause GC, which can
4866 clobber objects stored in the tmp_intervals. */
4867 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4869 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4873 /* First region smaller than second. */
4874 if (len1_byte
< len2_byte
)
4876 temp
= SAFE_ALLOCA (len2_byte
);
4878 /* Don't precompute these addresses. We have to compute them
4879 at the last minute, because the relocating allocator might
4880 have moved the buffer around during the xmalloc. */
4881 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4882 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4884 memcpy (temp
, start2_addr
, len2_byte
);
4885 memcpy (start1_addr
+ len2_byte
, start1_addr
, len1_byte
);
4886 memcpy (start1_addr
, temp
, len2_byte
);
4889 /* First region not smaller than second. */
4891 temp
= SAFE_ALLOCA (len1_byte
);
4892 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4893 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4894 memcpy (temp
, start1_addr
, len1_byte
);
4895 memcpy (start1_addr
, start2_addr
, len2_byte
);
4896 memcpy (start1_addr
+ len2_byte
, temp
, len1_byte
);
4900 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
4901 len1
, current_buffer
, 0);
4902 graft_intervals_into_buffer (tmp_interval2
, start1
,
4903 len2
, current_buffer
, 0);
4904 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4905 update_compositions (start1
+ len2
, end2
, CHECK_TAIL
);
4907 /* Non-adjacent regions, because end1 != start2, bleagh... */
4910 len_mid
= start2_byte
- (start1_byte
+ len1_byte
);
4912 if (len1_byte
== len2_byte
)
4913 /* Regions are same size, though, how nice. */
4917 modify_text (start1
, end1
);
4918 modify_text (start2
, end2
);
4919 record_change (start1
, len1
);
4920 record_change (start2
, len2
);
4921 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4922 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4924 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr1
, 0);
4926 set_text_properties_1 (startr1
, endr1
, Qnil
, buf
, tmp_interval3
);
4928 tmp_interval3
= validate_interval_range (buf
, &startr2
, &endr2
, 0);
4930 set_text_properties_1 (startr2
, endr2
, Qnil
, buf
, tmp_interval3
);
4932 temp
= SAFE_ALLOCA (len1_byte
);
4933 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4934 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4935 memcpy (temp
, start1_addr
, len1_byte
);
4936 memcpy (start1_addr
, start2_addr
, len2_byte
);
4937 memcpy (start2_addr
, temp
, len1_byte
);
4940 graft_intervals_into_buffer (tmp_interval1
, start2
,
4941 len1
, current_buffer
, 0);
4942 graft_intervals_into_buffer (tmp_interval2
, start1
,
4943 len2
, current_buffer
, 0);
4946 else if (len1_byte
< len2_byte
) /* Second region larger than first */
4947 /* Non-adjacent & unequal size, area between must also be shifted. */
4951 modify_text (start1
, end2
);
4952 record_change (start1
, (end2
- start1
));
4953 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4954 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4955 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4957 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4959 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4961 /* holds region 2 */
4962 temp
= SAFE_ALLOCA (len2_byte
);
4963 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4964 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4965 memcpy (temp
, start2_addr
, len2_byte
);
4966 memcpy (start1_addr
+ len_mid
+ len2_byte
, start1_addr
, len1_byte
);
4967 memmove (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
4968 memcpy (start1_addr
, temp
, len2_byte
);
4971 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4972 len1
, current_buffer
, 0);
4973 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4974 len_mid
, current_buffer
, 0);
4975 graft_intervals_into_buffer (tmp_interval2
, start1
,
4976 len2
, current_buffer
, 0);
4979 /* Second region smaller than first. */
4983 record_change (start1
, (end2
- start1
));
4984 modify_text (start1
, end2
);
4986 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4987 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4988 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4990 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4992 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4994 /* holds region 1 */
4995 temp
= SAFE_ALLOCA (len1_byte
);
4996 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4997 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4998 memcpy (temp
, start1_addr
, len1_byte
);
4999 memcpy (start1_addr
, start2_addr
, len2_byte
);
5000 memmove (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
5001 memcpy (start1_addr
+ len2_byte
+ len_mid
, temp
, len1_byte
);
5004 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
5005 len1
, current_buffer
, 0);
5006 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
5007 len_mid
, current_buffer
, 0);
5008 graft_intervals_into_buffer (tmp_interval2
, start1
,
5009 len2
, current_buffer
, 0);
5012 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
5013 update_compositions (end2
- len1
, end2
, CHECK_BORDER
);
5016 /* When doing multiple transpositions, it might be nice
5017 to optimize this. Perhaps the markers in any one buffer
5018 should be organized in some sorted data tree. */
5019 if (NILP (leave_markers
))
5021 transpose_markers (start1
, end1
, start2
, end2
,
5022 start1_byte
, start1_byte
+ len1_byte
,
5023 start2_byte
, start2_byte
+ len2_byte
);
5024 fix_start_end_in_overlays (start1
, end2
);
5027 signal_after_change (start1
, end2
- start1
, end2
- start1
);
5033 syms_of_editfns (void)
5035 DEFSYM (Qbuffer_access_fontify_functions
, "buffer-access-fontify-functions");
5036 DEFSYM (Qwall
, "wall");
5038 DEFVAR_LISP ("inhibit-field-text-motion", Vinhibit_field_text_motion
,
5039 doc
: /* Non-nil means text motion commands don't notice fields. */);
5040 Vinhibit_field_text_motion
= Qnil
;
5042 DEFVAR_LISP ("buffer-access-fontify-functions",
5043 Vbuffer_access_fontify_functions
,
5044 doc
: /* List of functions called by `buffer-substring' to fontify if necessary.
5045 Each function is called with two arguments which specify the range
5046 of the buffer being accessed. */);
5047 Vbuffer_access_fontify_functions
= Qnil
;
5051 obuf
= Fcurrent_buffer ();
5052 /* Do this here, because init_buffer_once is too early--it won't work. */
5053 Fset_buffer (Vprin1_to_string_buffer
);
5054 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
5055 Fset (Fmake_local_variable (Qbuffer_access_fontify_functions
), Qnil
);
5059 DEFVAR_LISP ("buffer-access-fontified-property",
5060 Vbuffer_access_fontified_property
,
5061 doc
: /* Property which (if non-nil) indicates text has been fontified.
5062 `buffer-substring' need not call the `buffer-access-fontify-functions'
5063 functions if all the text being accessed has this property. */);
5064 Vbuffer_access_fontified_property
= Qnil
;
5066 DEFVAR_LISP ("system-name", Vsystem_name
,
5067 doc
: /* The host name of the machine Emacs is running on. */);
5068 Vsystem_name
= cached_system_name
= Qnil
;
5070 DEFVAR_LISP ("user-full-name", Vuser_full_name
,
5071 doc
: /* The full name of the user logged in. */);
5073 DEFVAR_LISP ("user-login-name", Vuser_login_name
,
5074 doc
: /* The user's name, taken from environment variables if possible. */);
5075 Vuser_login_name
= Qnil
;
5077 DEFVAR_LISP ("user-real-login-name", Vuser_real_login_name
,
5078 doc
: /* The user's name, based upon the real uid only. */);
5080 DEFVAR_LISP ("operating-system-release", Voperating_system_release
,
5081 doc
: /* The release of the operating system Emacs is running on. */);
5083 defsubr (&Spropertize
);
5084 defsubr (&Schar_equal
);
5085 defsubr (&Sgoto_char
);
5086 defsubr (&Sstring_to_char
);
5087 defsubr (&Schar_to_string
);
5088 defsubr (&Sbyte_to_string
);
5089 defsubr (&Sbuffer_substring
);
5090 defsubr (&Sbuffer_substring_no_properties
);
5091 defsubr (&Sbuffer_string
);
5092 defsubr (&Sget_pos_property
);
5094 defsubr (&Spoint_marker
);
5095 defsubr (&Smark_marker
);
5097 defsubr (&Sregion_beginning
);
5098 defsubr (&Sregion_end
);
5100 /* Symbol for the text property used to mark fields. */
5101 DEFSYM (Qfield
, "field");
5103 /* A special value for Qfield properties. */
5104 DEFSYM (Qboundary
, "boundary");
5106 defsubr (&Sfield_beginning
);
5107 defsubr (&Sfield_end
);
5108 defsubr (&Sfield_string
);
5109 defsubr (&Sfield_string_no_properties
);
5110 defsubr (&Sdelete_field
);
5111 defsubr (&Sconstrain_to_field
);
5113 defsubr (&Sline_beginning_position
);
5114 defsubr (&Sline_end_position
);
5116 defsubr (&Ssave_excursion
);
5117 defsubr (&Ssave_current_buffer
);
5119 defsubr (&Sbuffer_size
);
5120 defsubr (&Spoint_max
);
5121 defsubr (&Spoint_min
);
5122 defsubr (&Spoint_min_marker
);
5123 defsubr (&Spoint_max_marker
);
5124 defsubr (&Sgap_position
);
5125 defsubr (&Sgap_size
);
5126 defsubr (&Sposition_bytes
);
5127 defsubr (&Sbyte_to_position
);
5133 defsubr (&Sfollowing_char
);
5134 defsubr (&Sprevious_char
);
5135 defsubr (&Schar_after
);
5136 defsubr (&Schar_before
);
5138 defsubr (&Sinsert_before_markers
);
5139 defsubr (&Sinsert_and_inherit
);
5140 defsubr (&Sinsert_and_inherit_before_markers
);
5141 defsubr (&Sinsert_char
);
5142 defsubr (&Sinsert_byte
);
5144 defsubr (&Suser_login_name
);
5145 defsubr (&Suser_real_login_name
);
5146 defsubr (&Suser_uid
);
5147 defsubr (&Suser_real_uid
);
5148 defsubr (&Sgroup_gid
);
5149 defsubr (&Sgroup_real_gid
);
5150 defsubr (&Suser_full_name
);
5151 defsubr (&Semacs_pid
);
5152 defsubr (&Scurrent_time
);
5153 defsubr (&Stime_add
);
5154 defsubr (&Stime_subtract
);
5155 defsubr (&Stime_less_p
);
5156 defsubr (&Sget_internal_run_time
);
5157 defsubr (&Sformat_time_string
);
5158 defsubr (&Sfloat_time
);
5159 defsubr (&Sdecode_time
);
5160 defsubr (&Sencode_time
);
5161 defsubr (&Scurrent_time_string
);
5162 defsubr (&Scurrent_time_zone
);
5163 defsubr (&Sset_time_zone_rule
);
5164 defsubr (&Ssystem_name
);
5165 defsubr (&Smessage
);
5166 defsubr (&Smessage_box
);
5167 defsubr (&Smessage_or_box
);
5168 defsubr (&Scurrent_message
);
5170 defsubr (&Sformat_message
);
5172 defsubr (&Sinsert_buffer_substring
);
5173 defsubr (&Scompare_buffer_substrings
);
5174 defsubr (&Ssubst_char_in_region
);
5175 defsubr (&Stranslate_region_internal
);
5176 defsubr (&Sdelete_region
);
5177 defsubr (&Sdelete_and_extract_region
);
5179 defsubr (&Snarrow_to_region
);
5180 defsubr (&Ssave_restriction
);
5181 defsubr (&Stranspose_regions
);