1 /* Lisp functions pertaining to editing. -*- coding: utf-8 -*-
3 Copyright (C) 1985-1987, 1989, 1993-2018 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 <https://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>
57 #include "composite.h"
58 #include "intervals.h"
59 #include "ptr-bounds.h"
60 #include "character.h"
64 #include "blockinput.h"
66 #define TM_YEAR_BASE 1900
69 extern Lisp_Object
w32_get_internal_run_time (void);
72 static struct lisp_time
lisp_time_struct (Lisp_Object
, int *);
73 static Lisp_Object
format_time_string (char const *, ptrdiff_t, struct timespec
,
74 Lisp_Object
, struct tm
*);
75 static long int tm_gmtoff (struct tm
*);
76 static int tm_diff (struct tm
*, struct tm
*);
77 static void update_buffer_properties (ptrdiff_t, ptrdiff_t);
78 static Lisp_Object
styled_format (ptrdiff_t, Lisp_Object
*, bool);
80 #ifndef HAVE_TM_GMTOFF
81 # define HAVE_TM_GMTOFF false
84 enum { tzeqlen
= sizeof "TZ=" - 1 };
86 /* Time zones equivalent to current local time and to UTC, respectively. */
87 static timezone_t local_tz
;
88 static timezone_t
const utc_tz
= 0;
90 /* The cached value of Vsystem_name. This is used only to compare it
91 to Vsystem_name, so it need not be visible to the GC. */
92 static Lisp_Object cached_system_name
;
95 init_and_cache_system_name (void)
98 cached_system_name
= Vsystem_name
;
102 emacs_localtime_rz (timezone_t tz
, time_t const *t
, struct tm
*tm
)
104 tm
= localtime_rz (tz
, t
, tm
);
105 if (!tm
&& errno
== ENOMEM
)
106 memory_full (SIZE_MAX
);
111 emacs_mktime_z (timezone_t tz
, struct tm
*tm
)
114 time_t t
= mktime_z (tz
, tm
);
115 if (t
== (time_t) -1 && errno
== ENOMEM
)
116 memory_full (SIZE_MAX
);
120 /* Allocate a timezone, signaling on failure. */
122 xtzalloc (char const *name
)
124 timezone_t tz
= tzalloc (name
);
126 memory_full (SIZE_MAX
);
130 /* Free a timezone, except do not free the time zone for local time.
131 Freeing utc_tz is also a no-op. */
133 xtzfree (timezone_t tz
)
139 /* Convert the Lisp time zone rule ZONE to a timezone_t object.
140 The returned value either is 0, or is LOCAL_TZ, or is newly allocated.
141 If SETTZ, set Emacs local time to the time zone rule; otherwise,
142 the caller should eventually pass the returned value to xtzfree. */
144 tzlookup (Lisp_Object zone
, bool settz
)
146 static char const tzbuf_format
[] = "<%+.*"pI
"d>%s%"pI
"d:%02d:%02d";
147 char const *trailing_tzbuf_format
= tzbuf_format
+ sizeof "<%+.*"pI
"d" - 1;
148 char tzbuf
[sizeof tzbuf_format
+ 2 * INT_STRLEN_BOUND (EMACS_INT
)];
149 char const *zone_string
;
154 else if (EQ (zone
, Qt
))
156 zone_string
= "UTC0";
161 bool plain_integer
= INTEGERP (zone
);
163 if (EQ (zone
, Qwall
))
165 else if (STRINGP (zone
))
166 zone_string
= SSDATA (ENCODE_SYSTEM (zone
));
167 else if (plain_integer
|| (CONSP (zone
) && INTEGERP (XCAR (zone
))
168 && CONSP (XCDR (zone
))))
173 abbr
= XCAR (XCDR (zone
));
177 EMACS_INT abszone
= eabs (XINT (zone
)), hour
= abszone
/ (60 * 60);
178 int hour_remainder
= abszone
% (60 * 60);
179 int min
= hour_remainder
/ 60, sec
= hour_remainder
% 60;
184 EMACS_INT numzone
= hour
;
185 if (hour_remainder
!= 0)
187 prec
+= 2, numzone
= 100 * numzone
+ min
;
189 prec
+= 2, numzone
= 100 * numzone
+ sec
;
191 sprintf (tzbuf
, tzbuf_format
, prec
,
192 XINT (zone
) < 0 ? -numzone
: numzone
,
193 &"-"[XINT (zone
) < 0], hour
, min
, sec
);
198 AUTO_STRING (leading
, "<");
199 AUTO_STRING_WITH_LEN (trailing
, tzbuf
,
200 sprintf (tzbuf
, trailing_tzbuf_format
,
201 &"-"[XINT (zone
) < 0],
203 zone_string
= SSDATA (concat3 (leading
, ENCODE_SYSTEM (abbr
),
208 xsignal2 (Qerror
, build_string ("Invalid time zone specification"),
210 new_tz
= xtzalloc (zone_string
);
216 emacs_setenv_TZ (zone_string
);
218 timezone_t old_tz
= local_tz
;
228 init_editfns (bool dumping
)
230 #if !defined CANNOT_DUMP
231 /* A valid but unlikely setting for the TZ environment variable.
232 It is OK (though a bit slower) if the user chooses this value. */
233 static char dump_tz_string
[] = "TZ=UtC0";
236 const char *user_name
;
238 struct passwd
*pw
; /* password entry for the current user */
241 /* Set up system_name even when dumping. */
242 init_and_cache_system_name ();
245 /* When just dumping out, set the time zone to a known unlikely value
246 and skip the rest of this function. */
249 xputenv (dump_tz_string
);
255 char *tz
= getenv ("TZ");
257 #if !defined CANNOT_DUMP
258 /* If the execution TZ happens to be the same as the dump TZ,
259 change it to some other value and then change it back,
260 to force the underlying implementation to reload the TZ info.
261 This is needed on implementations that load TZ info from files,
262 since the TZ file contents may differ between dump and execution. */
263 if (tz
&& strcmp (tz
, &dump_tz_string
[tzeqlen
]) == 0)
271 /* Set the time zone rule now, so that the call to putenv is done
272 before multiple threads are active. */
273 tzlookup (tz
? build_string (tz
) : Qwall
, true);
275 pw
= getpwuid (getuid ());
277 /* We let the real user name default to "root" because that's quite
278 accurate on MS-DOS and because it lets Emacs find the init file.
279 (The DVX libraries override the Djgpp libraries here.) */
280 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "root");
282 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "unknown");
285 /* Get the effective user name, by consulting environment variables,
286 or the effective uid if those are unset. */
287 user_name
= getenv ("LOGNAME");
290 user_name
= getenv ("USERNAME"); /* it's USERNAME on NT */
291 #else /* WINDOWSNT */
292 user_name
= getenv ("USER");
293 #endif /* WINDOWSNT */
296 pw
= getpwuid (geteuid ());
297 user_name
= pw
? pw
->pw_name
: "unknown";
299 Vuser_login_name
= build_string (user_name
);
301 /* If the user name claimed in the environment vars differs from
302 the real uid, use the claimed name to find the full name. */
303 tem
= Fstring_equal (Vuser_login_name
, Vuser_real_login_name
);
305 tem
= Vuser_login_name
;
308 uid_t euid
= geteuid ();
309 tem
= make_fixnum_or_float (euid
);
311 Vuser_full_name
= Fuser_full_name (tem
);
315 Vuser_full_name
= build_string (p
);
316 else if (NILP (Vuser_full_name
))
317 Vuser_full_name
= build_string ("unknown");
319 #ifdef HAVE_SYS_UTSNAME_H
323 Voperating_system_release
= build_string (uts
.release
);
326 Voperating_system_release
= Qnil
;
330 DEFUN ("char-to-string", Fchar_to_string
, Schar_to_string
, 1, 1, 0,
331 doc
: /* Convert arg CHAR to a string containing that character.
332 usage: (char-to-string CHAR) */)
333 (Lisp_Object character
)
336 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
338 CHECK_CHARACTER (character
);
339 c
= XFASTINT (character
);
341 len
= CHAR_STRING (c
, str
);
342 return make_string_from_bytes ((char *) str
, 1, len
);
345 DEFUN ("byte-to-string", Fbyte_to_string
, Sbyte_to_string
, 1, 1, 0,
346 doc
: /* Convert arg BYTE to a unibyte string containing that byte. */)
351 if (XINT (byte
) < 0 || XINT (byte
) > 255)
352 error ("Invalid byte");
354 return make_string_from_bytes ((char *) &b
, 1, 1);
357 DEFUN ("string-to-char", Fstring_to_char
, Sstring_to_char
, 1, 1, 0,
358 doc
: /* Return the first character in STRING. */)
359 (register Lisp_Object string
)
361 register Lisp_Object val
;
362 CHECK_STRING (string
);
365 if (STRING_MULTIBYTE (string
))
366 XSETFASTINT (val
, STRING_CHAR (SDATA (string
)));
368 XSETFASTINT (val
, SREF (string
, 0));
371 XSETFASTINT (val
, 0);
375 DEFUN ("point", Fpoint
, Spoint
, 0, 0, 0,
376 doc
: /* Return value of point, as an integer.
377 Beginning of buffer is position (point-min). */)
381 XSETFASTINT (temp
, PT
);
385 DEFUN ("point-marker", Fpoint_marker
, Spoint_marker
, 0, 0, 0,
386 doc
: /* Return value of point, as a marker object. */)
389 return build_marker (current_buffer
, PT
, PT_BYTE
);
392 DEFUN ("goto-char", Fgoto_char
, Sgoto_char
, 1, 1, "NGoto char: ",
393 doc
: /* Set point to POSITION, a number or marker.
394 Beginning of buffer is position (point-min), end is (point-max).
396 The return value is POSITION. */)
397 (register Lisp_Object position
)
399 if (MARKERP (position
))
400 set_point_from_marker (position
);
401 else if (INTEGERP (position
))
402 SET_PT (clip_to_bounds (BEGV
, XINT (position
), ZV
));
404 wrong_type_argument (Qinteger_or_marker_p
, position
);
409 /* Return the start or end position of the region.
410 BEGINNINGP means return the start.
411 If there is no region active, signal an error. */
414 region_limit (bool beginningp
)
418 if (!NILP (Vtransient_mark_mode
)
419 && NILP (Vmark_even_if_inactive
)
420 && NILP (BVAR (current_buffer
, mark_active
)))
421 xsignal0 (Qmark_inactive
);
423 m
= Fmarker_position (BVAR (current_buffer
, mark
));
425 error ("The mark is not set now, so there is no region");
427 /* Clip to the current narrowing (bug#11770). */
428 return make_number ((PT
< XFASTINT (m
)) == beginningp
430 : clip_to_bounds (BEGV
, XFASTINT (m
), ZV
));
433 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
434 doc
: /* Return the integer value of point or mark, whichever is smaller. */)
437 return region_limit (1);
440 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
441 doc
: /* Return the integer value of point or mark, whichever is larger. */)
444 return region_limit (0);
447 DEFUN ("mark-marker", Fmark_marker
, Smark_marker
, 0, 0, 0,
448 doc
: /* Return this buffer's mark, as a marker object.
449 Watch out! Moving this marker changes the mark position.
450 If you set the marker not to point anywhere, the buffer will have no mark. */)
453 return BVAR (current_buffer
, mark
);
457 /* Find all the overlays in the current buffer that touch position POS.
458 Return the number found, and store them in a vector in VEC
462 overlays_around (EMACS_INT pos
, Lisp_Object
*vec
, ptrdiff_t len
)
464 Lisp_Object overlay
, start
, end
;
465 struct Lisp_Overlay
*tail
;
466 ptrdiff_t startpos
, endpos
;
469 for (tail
= current_buffer
->overlays_before
; tail
; tail
= tail
->next
)
471 XSETMISC (overlay
, tail
);
473 end
= OVERLAY_END (overlay
);
474 endpos
= OVERLAY_POSITION (end
);
477 start
= OVERLAY_START (overlay
);
478 startpos
= OVERLAY_POSITION (start
);
483 /* Keep counting overlays even if we can't return them all. */
488 for (tail
= current_buffer
->overlays_after
; tail
; tail
= tail
->next
)
490 XSETMISC (overlay
, tail
);
492 start
= OVERLAY_START (overlay
);
493 startpos
= OVERLAY_POSITION (start
);
496 end
= OVERLAY_END (overlay
);
497 endpos
= OVERLAY_POSITION (end
);
509 DEFUN ("get-pos-property", Fget_pos_property
, Sget_pos_property
, 2, 3, 0,
510 doc
: /* Return the value of POSITION's property PROP, in OBJECT.
511 Almost identical to `get-char-property' except for the following difference:
512 Whereas `get-char-property' returns the property of the char at (i.e. right
513 after) POSITION, this pays attention to properties's stickiness and overlays's
514 advancement settings, in order to find the property of POSITION itself,
515 i.e. the property that a char would inherit if it were inserted
517 (Lisp_Object position
, register Lisp_Object prop
, Lisp_Object object
)
519 CHECK_NUMBER_COERCE_MARKER (position
);
522 XSETBUFFER (object
, current_buffer
);
523 else if (WINDOWP (object
))
524 object
= XWINDOW (object
)->contents
;
526 if (!BUFFERP (object
))
527 /* pos-property only makes sense in buffers right now, since strings
528 have no overlays and no notion of insertion for which stickiness
530 return Fget_text_property (position
, prop
, object
);
533 EMACS_INT posn
= XINT (position
);
535 Lisp_Object
*overlay_vec
, tem
;
536 struct buffer
*obuf
= current_buffer
;
539 set_buffer_temp (XBUFFER (object
));
541 /* First try with room for 40 overlays. */
542 Lisp_Object overlay_vecbuf
[40];
543 noverlays
= ARRAYELTS (overlay_vecbuf
);
544 overlay_vec
= overlay_vecbuf
;
545 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
547 /* If there are more than 40,
548 make enough space for all, and try again. */
549 if (ARRAYELTS (overlay_vecbuf
) < noverlays
)
551 SAFE_ALLOCA_LISP (overlay_vec
, noverlays
);
552 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
554 noverlays
= sort_overlays (overlay_vec
, noverlays
, NULL
);
556 set_buffer_temp (obuf
);
558 /* Now check the overlays in order of decreasing priority. */
559 while (--noverlays
>= 0)
561 Lisp_Object ol
= overlay_vec
[noverlays
];
562 tem
= Foverlay_get (ol
, prop
);
565 /* Check the overlay is indeed active at point. */
566 Lisp_Object start
= OVERLAY_START (ol
), finish
= OVERLAY_END (ol
);
567 if ((OVERLAY_POSITION (start
) == posn
568 && XMARKER (start
)->insertion_type
== 1)
569 || (OVERLAY_POSITION (finish
) == posn
570 && XMARKER (finish
)->insertion_type
== 0))
571 ; /* The overlay will not cover a char inserted at point. */
581 { /* Now check the text properties. */
582 int stickiness
= text_property_stickiness (prop
, position
, object
);
584 return Fget_text_property (position
, prop
, object
);
585 else if (stickiness
< 0
586 && XINT (position
) > BUF_BEGV (XBUFFER (object
)))
587 return Fget_text_property (make_number (XINT (position
) - 1),
595 /* Find the field surrounding POS in *BEG and *END. If POS is nil,
596 the value of point is used instead. If BEG or END is null,
597 means don't store the beginning or end of the field.
599 BEG_LIMIT and END_LIMIT serve to limit the ranged of the returned
600 results; they do not effect boundary behavior.
602 If MERGE_AT_BOUNDARY is non-nil, then if POS is at the very first
603 position of a field, then the beginning of the previous field is
604 returned instead of the beginning of POS's field (since the end of a
605 field is actually also the beginning of the next input field, this
606 behavior is sometimes useful). Additionally in the MERGE_AT_BOUNDARY
607 non-nil case, if two fields are separated by a field with the special
608 value `boundary', and POS lies within it, then the two separated
609 fields are considered to be adjacent, and POS between them, when
610 finding the beginning and ending of the "merged" field.
612 Either BEG or END may be 0, in which case the corresponding value
616 find_field (Lisp_Object pos
, Lisp_Object merge_at_boundary
,
617 Lisp_Object beg_limit
,
618 ptrdiff_t *beg
, Lisp_Object end_limit
, ptrdiff_t *end
)
620 /* Fields right before and after the point. */
621 Lisp_Object before_field
, after_field
;
622 /* True if POS counts as the start of a field. */
623 bool at_field_start
= 0;
624 /* True if POS counts as the end of a field. */
625 bool at_field_end
= 0;
628 XSETFASTINT (pos
, PT
);
630 CHECK_NUMBER_COERCE_MARKER (pos
);
633 = get_char_property_and_overlay (pos
, Qfield
, Qnil
, NULL
);
635 = (XFASTINT (pos
) > BEGV
636 ? get_char_property_and_overlay (make_number (XINT (pos
) - 1),
638 /* Using nil here would be a more obvious choice, but it would
639 fail when the buffer starts with a non-sticky field. */
642 /* See if we need to handle the case where MERGE_AT_BOUNDARY is nil
643 and POS is at beginning of a field, which can also be interpreted
644 as the end of the previous field. Note that the case where if
645 MERGE_AT_BOUNDARY is non-nil (see function comment) is actually the
646 more natural one; then we avoid treating the beginning of a field
648 if (NILP (merge_at_boundary
))
650 Lisp_Object field
= Fget_pos_property (pos
, Qfield
, Qnil
);
651 if (!EQ (field
, after_field
))
653 if (!EQ (field
, before_field
))
655 if (NILP (field
) && at_field_start
&& at_field_end
)
656 /* If an inserted char would have a nil field while the surrounding
657 text is non-nil, we're probably not looking at a
658 zero-length field, but instead at a non-nil field that's
659 not intended for editing (such as comint's prompts). */
660 at_field_end
= at_field_start
= 0;
663 /* Note about special `boundary' fields:
665 Consider the case where the point (`.') is between the fields `x' and `y':
669 In this situation, if merge_at_boundary is non-nil, consider the
670 `x' and `y' fields as forming one big merged field, and so the end
671 of the field is the end of `y'.
673 However, if `x' and `y' are separated by a special `boundary' field
674 (a field with a `field' char-property of 'boundary), then ignore
675 this special field when merging adjacent fields. Here's the same
676 situation, but with a `boundary' field between the `x' and `y' fields:
680 Here, if point is at the end of `x', the beginning of `y', or
681 anywhere in-between (within the `boundary' field), merge all
682 three fields and consider the beginning as being the beginning of
683 the `x' field, and the end as being the end of the `y' field. */
688 /* POS is at the edge of a field, and we should consider it as
689 the beginning of the following field. */
690 *beg
= XFASTINT (pos
);
692 /* Find the previous field boundary. */
695 if (!NILP (merge_at_boundary
) && EQ (before_field
, Qboundary
))
696 /* Skip a `boundary' field. */
697 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
700 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
702 *beg
= NILP (p
) ? BEGV
: XFASTINT (p
);
709 /* POS is at the edge of a field, and we should consider it as
710 the end of the previous field. */
711 *end
= XFASTINT (pos
);
713 /* Find the next field boundary. */
715 if (!NILP (merge_at_boundary
) && EQ (after_field
, Qboundary
))
716 /* Skip a `boundary' field. */
717 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
720 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
722 *end
= NILP (pos
) ? ZV
: XFASTINT (pos
);
728 DEFUN ("delete-field", Fdelete_field
, Sdelete_field
, 0, 1, 0,
729 doc
: /* Delete the field surrounding POS.
730 A field is a region of text with the same `field' property.
731 If POS is nil, the value of point is used for POS. */)
735 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
737 del_range (beg
, end
);
741 DEFUN ("field-string", Ffield_string
, Sfield_string
, 0, 1, 0,
742 doc
: /* Return the contents of the field surrounding POS as a string.
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. */)
748 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
749 return make_buffer_string (beg
, end
, 1);
752 DEFUN ("field-string-no-properties", Ffield_string_no_properties
, Sfield_string_no_properties
, 0, 1, 0,
753 doc
: /* Return the contents of the field around POS, without text properties.
754 A field is a region of text with the same `field' property.
755 If POS is nil, the value of point is used for POS. */)
759 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
760 return make_buffer_string (beg
, end
, 0);
763 DEFUN ("field-beginning", Ffield_beginning
, Sfield_beginning
, 0, 3, 0,
764 doc
: /* Return the beginning of the field surrounding POS.
765 A field is a region of text with the same `field' property.
766 If POS is nil, the value of point is used for POS.
767 If ESCAPE-FROM-EDGE is non-nil and POS is at the beginning of its
768 field, then the beginning of the *previous* field is returned.
769 If LIMIT is non-nil, it is a buffer position; if the beginning of the field
770 is before LIMIT, then LIMIT will be returned instead. */)
771 (Lisp_Object pos
, Lisp_Object escape_from_edge
, Lisp_Object limit
)
774 find_field (pos
, escape_from_edge
, limit
, &beg
, Qnil
, 0);
775 return make_number (beg
);
778 DEFUN ("field-end", Ffield_end
, Sfield_end
, 0, 3, 0,
779 doc
: /* Return the end of the field surrounding POS.
780 A field is a region of text with the same `field' property.
781 If POS is nil, the value of point is used for POS.
782 If ESCAPE-FROM-EDGE is non-nil and POS is at the end of its field,
783 then the end of the *following* field is returned.
784 If LIMIT is non-nil, it is a buffer position; if the end of the field
785 is after LIMIT, then LIMIT will be returned instead. */)
786 (Lisp_Object pos
, Lisp_Object escape_from_edge
, Lisp_Object limit
)
789 find_field (pos
, escape_from_edge
, Qnil
, 0, limit
, &end
);
790 return make_number (end
);
793 DEFUN ("constrain-to-field", Fconstrain_to_field
, Sconstrain_to_field
, 2, 5, 0,
794 doc
: /* Return the position closest to NEW-POS that is in the same field as OLD-POS.
795 A field is a region of text with the same `field' property.
797 If NEW-POS is nil, then use the current point instead, and move point
798 to the resulting constrained position, in addition to returning that
801 If OLD-POS is at the boundary of two fields, then the allowable
802 positions for NEW-POS depends on the value of the optional argument
803 ESCAPE-FROM-EDGE: If ESCAPE-FROM-EDGE is nil, then NEW-POS is
804 constrained to the field that has the same `field' char-property
805 as any new characters inserted at OLD-POS, whereas if ESCAPE-FROM-EDGE
806 is non-nil, NEW-POS is constrained to the union of the two adjacent
807 fields. Additionally, if two fields are separated by another field with
808 the special value `boundary', then any point within this special field is
809 also considered to be `on the boundary'.
811 If the optional argument ONLY-IN-LINE is non-nil and constraining
812 NEW-POS would move it to a different line, NEW-POS is returned
813 unconstrained. This is useful for commands that move by line, like
814 \\[next-line] or \\[beginning-of-line], which should generally respect field boundaries
815 only in the case where they can still move to the right line.
817 If the optional argument INHIBIT-CAPTURE-PROPERTY is non-nil, and OLD-POS has
818 a non-nil property of that name, then any field boundaries are ignored.
820 Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
821 (Lisp_Object new_pos
, Lisp_Object old_pos
, Lisp_Object escape_from_edge
,
822 Lisp_Object only_in_line
, Lisp_Object inhibit_capture_property
)
824 /* If non-zero, then the original point, before re-positioning. */
825 ptrdiff_t orig_point
= 0;
827 Lisp_Object prev_old
, prev_new
;
830 /* Use the current point, and afterwards, set it. */
833 XSETFASTINT (new_pos
, PT
);
836 CHECK_NUMBER_COERCE_MARKER (new_pos
);
837 CHECK_NUMBER_COERCE_MARKER (old_pos
);
839 fwd
= (XINT (new_pos
) > XINT (old_pos
));
841 prev_old
= make_number (XINT (old_pos
) - 1);
842 prev_new
= make_number (XINT (new_pos
) - 1);
844 if (NILP (Vinhibit_field_text_motion
)
845 && !EQ (new_pos
, old_pos
)
846 && (!NILP (Fget_char_property (new_pos
, Qfield
, Qnil
))
847 || !NILP (Fget_char_property (old_pos
, Qfield
, Qnil
))
848 /* To recognize field boundaries, we must also look at the
849 previous positions; we could use `Fget_pos_property'
850 instead, but in itself that would fail inside non-sticky
851 fields (like comint prompts). */
852 || (XFASTINT (new_pos
) > BEGV
853 && !NILP (Fget_char_property (prev_new
, Qfield
, Qnil
)))
854 || (XFASTINT (old_pos
) > BEGV
855 && !NILP (Fget_char_property (prev_old
, Qfield
, Qnil
))))
856 && (NILP (inhibit_capture_property
)
857 /* Field boundaries are again a problem; but now we must
858 decide the case exactly, so we need to call
859 `get_pos_property' as well. */
860 || (NILP (Fget_pos_property (old_pos
, inhibit_capture_property
, Qnil
))
861 && (XFASTINT (old_pos
) <= BEGV
862 || NILP (Fget_char_property
863 (old_pos
, inhibit_capture_property
, Qnil
))
864 || NILP (Fget_char_property
865 (prev_old
, inhibit_capture_property
, Qnil
))))))
866 /* It is possible that NEW_POS is not within the same field as
867 OLD_POS; try to move NEW_POS so that it is. */
870 Lisp_Object field_bound
;
873 field_bound
= Ffield_end (old_pos
, escape_from_edge
, new_pos
);
875 field_bound
= Ffield_beginning (old_pos
, escape_from_edge
, new_pos
);
877 if (/* See if ESCAPE_FROM_EDGE caused FIELD_BOUND to jump to the
878 other side of NEW_POS, which would mean that NEW_POS is
879 already acceptable, and it's not necessary to constrain it
881 ((XFASTINT (field_bound
) < XFASTINT (new_pos
)) ? fwd
: !fwd
)
882 /* NEW_POS should be constrained, but only if either
883 ONLY_IN_LINE is nil (in which case any constraint is OK),
884 or NEW_POS and FIELD_BOUND are on the same line (in which
885 case the constraint is OK even if ONLY_IN_LINE is non-nil). */
886 && (NILP (only_in_line
)
887 /* This is the ONLY_IN_LINE case, check that NEW_POS and
888 FIELD_BOUND are on the same line by seeing whether
889 there's an intervening newline or not. */
890 || (find_newline (XFASTINT (new_pos
), -1,
891 XFASTINT (field_bound
), -1,
892 fwd
? -1 : 1, &shortage
, NULL
, 1),
894 /* Constrain NEW_POS to FIELD_BOUND. */
895 new_pos
= field_bound
;
897 if (orig_point
&& XFASTINT (new_pos
) != orig_point
)
898 /* The NEW_POS argument was originally nil, so automatically set PT. */
899 SET_PT (XFASTINT (new_pos
));
906 DEFUN ("line-beginning-position",
907 Fline_beginning_position
, Sline_beginning_position
, 0, 1, 0,
908 doc
: /* Return the character position of the first character on the current line.
909 With optional argument N, scan forward N - 1 lines first.
910 If the scan reaches the end of the buffer, return that position.
912 This function ignores text display directionality; it returns the
913 position of the first character in logical order, i.e. the smallest
914 character position on the line.
916 This function constrains the returned position to the current field
917 unless that position would be on a different line than the original,
918 unconstrained result. If N is nil or 1, and a front-sticky field
919 starts at point, the scan stops as soon as it starts. To ignore field
920 boundaries, bind `inhibit-field-text-motion' to t.
922 This function does not move point. */)
925 ptrdiff_t charpos
, bytepos
;
932 scan_newline_from_point (XINT (n
) - 1, &charpos
, &bytepos
);
934 /* Return END constrained to the current input field. */
935 return Fconstrain_to_field (make_number (charpos
), make_number (PT
),
936 XINT (n
) != 1 ? Qt
: Qnil
,
940 DEFUN ("line-end-position", Fline_end_position
, Sline_end_position
, 0, 1, 0,
941 doc
: /* Return the character position of the last character on the current line.
942 With argument N not nil or 1, move forward N - 1 lines first.
943 If scan reaches end of buffer, return that position.
945 This function ignores text display directionality; it returns the
946 position of the last character in logical order, i.e. the largest
947 character position on the line.
949 This function constrains the returned position to the current field
950 unless that would be on a different line than the original,
951 unconstrained result. If N is nil or 1, and a rear-sticky field ends
952 at point, the scan stops as soon as it starts. To ignore field
953 boundaries bind `inhibit-field-text-motion' to t.
955 This function does not move point. */)
967 clipped_n
= clip_to_bounds (PTRDIFF_MIN
+ 1, XINT (n
), PTRDIFF_MAX
);
968 end_pos
= find_before_next_newline (orig
, 0, clipped_n
- (clipped_n
<= 0),
971 /* Return END_POS constrained to the current input field. */
972 return Fconstrain_to_field (make_number (end_pos
), make_number (orig
),
976 /* Save current buffer state for `save-excursion' special form.
977 We (ab)use Lisp_Misc_Save_Value to allow explicit free and so
978 offload some work from GC. */
981 save_excursion_save (void)
983 return make_save_obj_obj_obj_obj
986 /* Selected window if current buffer is shown in it, nil otherwise. */
987 (EQ (XWINDOW (selected_window
)->contents
, Fcurrent_buffer ())
988 ? selected_window
: Qnil
),
992 /* Restore saved buffer before leaving `save-excursion' special form. */
995 save_excursion_restore (Lisp_Object info
)
997 Lisp_Object tem
, tem1
;
999 tem
= Fmarker_buffer (XSAVE_OBJECT (info
, 0));
1000 /* If we're unwinding to top level, saved buffer may be deleted. This
1001 means that all of its markers are unchained and so tem is nil. */
1008 tem
= XSAVE_OBJECT (info
, 0);
1010 unchain_marker (XMARKER (tem
));
1012 /* If buffer was visible in a window, and a different window was
1013 selected, and the old selected window is still showing this
1014 buffer, restore point in that window. */
1015 tem
= XSAVE_OBJECT (info
, 2);
1017 && !EQ (tem
, selected_window
)
1018 && (tem1
= XWINDOW (tem
)->contents
,
1019 (/* Window is live... */
1021 /* ...and it shows the current buffer. */
1022 && XBUFFER (tem1
) == current_buffer
)))
1023 Fset_window_point (tem
, make_number (PT
));
1030 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
1031 doc
: /* Save point, and current buffer; execute BODY; restore those things.
1032 Executes BODY just like `progn'.
1033 The values of point and the current buffer are restored
1034 even in case of abnormal exit (throw or error).
1036 If you only want to save the current buffer but not point,
1037 then just use `save-current-buffer', or even `with-current-buffer'.
1039 Before Emacs 25.1, `save-excursion' used to save the mark state.
1040 To save the mark state as well as point and the current buffer, use
1041 `save-mark-and-excursion'.
1043 usage: (save-excursion &rest BODY) */)
1046 register Lisp_Object val
;
1047 ptrdiff_t count
= SPECPDL_INDEX ();
1049 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
1051 val
= Fprogn (args
);
1052 return unbind_to (count
, val
);
1055 DEFUN ("save-current-buffer", Fsave_current_buffer
, Ssave_current_buffer
, 0, UNEVALLED
, 0,
1056 doc
: /* Record which buffer is current; execute BODY; make that buffer current.
1057 BODY is executed just like `progn'.
1058 usage: (save-current-buffer &rest BODY) */)
1061 ptrdiff_t count
= SPECPDL_INDEX ();
1063 record_unwind_current_buffer ();
1064 return unbind_to (count
, Fprogn (args
));
1067 DEFUN ("buffer-size", Fbuffer_size
, Sbuffer_size
, 0, 1, 0,
1068 doc
: /* Return the number of characters in the current buffer.
1069 If BUFFER is not nil, return the number of characters in that buffer
1072 This does not take narrowing into account; to count the number of
1073 characters in the accessible portion of the current buffer, use
1074 `(- (point-max) (point-min))', and to count the number of characters
1075 in some other BUFFER, use
1076 `(with-current-buffer BUFFER (- (point-max) (point-min)))'. */)
1077 (Lisp_Object buffer
)
1080 return make_number (Z
- BEG
);
1083 CHECK_BUFFER (buffer
);
1084 return make_number (BUF_Z (XBUFFER (buffer
))
1085 - BUF_BEG (XBUFFER (buffer
)));
1089 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
1090 doc
: /* Return the minimum permissible value of point in the current buffer.
1091 This is 1, unless narrowing (a buffer restriction) is in effect. */)
1095 XSETFASTINT (temp
, BEGV
);
1099 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
1100 doc
: /* Return a marker to the minimum permissible value of point in this buffer.
1101 This is the beginning, unless narrowing (a buffer restriction) is in effect. */)
1104 return build_marker (current_buffer
, BEGV
, BEGV_BYTE
);
1107 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
1108 doc
: /* Return the maximum permissible value of point in the current buffer.
1109 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1110 is in effect, in which case it is less. */)
1114 XSETFASTINT (temp
, ZV
);
1118 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
1119 doc
: /* Return a marker to the maximum permissible value of point in this buffer.
1120 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1121 is in effect, in which case it is less. */)
1124 return build_marker (current_buffer
, ZV
, ZV_BYTE
);
1127 DEFUN ("gap-position", Fgap_position
, Sgap_position
, 0, 0, 0,
1128 doc
: /* Return the position of the gap, in the current buffer.
1129 See also `gap-size'. */)
1133 XSETFASTINT (temp
, GPT
);
1137 DEFUN ("gap-size", Fgap_size
, Sgap_size
, 0, 0, 0,
1138 doc
: /* Return the size of the current buffer's gap.
1139 See also `gap-position'. */)
1143 XSETFASTINT (temp
, GAP_SIZE
);
1147 DEFUN ("position-bytes", Fposition_bytes
, Sposition_bytes
, 1, 1, 0,
1148 doc
: /* Return the byte position for character position POSITION.
1149 If POSITION is out of range, the value is nil. */)
1150 (Lisp_Object position
)
1152 CHECK_NUMBER_COERCE_MARKER (position
);
1153 if (XINT (position
) < BEG
|| XINT (position
) > Z
)
1155 return make_number (CHAR_TO_BYTE (XINT (position
)));
1158 DEFUN ("byte-to-position", Fbyte_to_position
, Sbyte_to_position
, 1, 1, 0,
1159 doc
: /* Return the character position for byte position BYTEPOS.
1160 If BYTEPOS is out of range, the value is nil. */)
1161 (Lisp_Object bytepos
)
1165 CHECK_NUMBER (bytepos
);
1166 pos_byte
= XINT (bytepos
);
1167 if (pos_byte
< BEG_BYTE
|| pos_byte
> Z_BYTE
)
1170 /* There are multibyte characters in the buffer.
1171 The argument of BYTE_TO_CHAR must be a byte position at
1172 a character boundary, so search for the start of the current
1174 while (!CHAR_HEAD_P (FETCH_BYTE (pos_byte
)))
1176 return make_number (BYTE_TO_CHAR (pos_byte
));
1179 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
1180 doc
: /* Return the character following point, as a number.
1181 At the end of the buffer or accessible region, return 0. */)
1186 XSETFASTINT (temp
, 0);
1188 XSETFASTINT (temp
, FETCH_CHAR (PT_BYTE
));
1192 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
1193 doc
: /* Return the character preceding point, as a number.
1194 At the beginning of the buffer or accessible region, return 0. */)
1199 XSETFASTINT (temp
, 0);
1200 else if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1202 ptrdiff_t pos
= PT_BYTE
;
1204 XSETFASTINT (temp
, FETCH_CHAR (pos
));
1207 XSETFASTINT (temp
, FETCH_BYTE (PT_BYTE
- 1));
1211 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
1212 doc
: /* Return t if point is at the beginning of the buffer.
1213 If the buffer is narrowed, this means the beginning of the narrowed part. */)
1221 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
1222 doc
: /* Return t if point is at the end of the buffer.
1223 If the buffer is narrowed, this means the end of the narrowed part. */)
1231 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
1232 doc
: /* Return t if point is at the beginning of a line. */)
1235 if (PT
== BEGV
|| FETCH_BYTE (PT_BYTE
- 1) == '\n')
1240 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
1241 doc
: /* Return t if point is at the end of a line.
1242 `End of a line' includes point being at the end of the buffer. */)
1245 if (PT
== ZV
|| FETCH_BYTE (PT_BYTE
) == '\n')
1250 DEFUN ("char-after", Fchar_after
, Schar_after
, 0, 1, 0,
1251 doc
: /* Return character in current buffer at position POS.
1252 POS is an integer or a marker and defaults to point.
1253 If POS is out of range, the value is nil. */)
1256 register ptrdiff_t pos_byte
;
1261 if (pos_byte
< BEGV_BYTE
|| pos_byte
>= ZV_BYTE
)
1264 else if (MARKERP (pos
))
1266 pos_byte
= marker_byte_position (pos
);
1267 if (pos_byte
< BEGV_BYTE
|| pos_byte
>= ZV_BYTE
)
1272 CHECK_NUMBER_COERCE_MARKER (pos
);
1273 if (XINT (pos
) < BEGV
|| XINT (pos
) >= ZV
)
1276 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1279 return make_number (FETCH_CHAR (pos_byte
));
1282 DEFUN ("char-before", Fchar_before
, Schar_before
, 0, 1, 0,
1283 doc
: /* Return character in current buffer preceding position POS.
1284 POS is an integer or a marker and defaults to point.
1285 If POS is out of range, the value is nil. */)
1288 register Lisp_Object val
;
1289 register ptrdiff_t pos_byte
;
1294 XSETFASTINT (pos
, PT
);
1299 pos_byte
= marker_byte_position (pos
);
1301 if (pos_byte
<= BEGV_BYTE
|| pos_byte
> ZV_BYTE
)
1306 CHECK_NUMBER_COERCE_MARKER (pos
);
1308 if (XINT (pos
) <= BEGV
|| XINT (pos
) > ZV
)
1311 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1314 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1317 XSETFASTINT (val
, FETCH_CHAR (pos_byte
));
1322 XSETFASTINT (val
, FETCH_BYTE (pos_byte
));
1327 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 1, 0,
1328 doc
: /* Return the name under which the user logged in, as a string.
1329 This is based on the effective uid, not the real uid.
1330 Also, if the environment variables LOGNAME or USER are set,
1331 that determines the value of this function.
1333 If optional argument UID is an integer or a float, return the login name
1334 of the user with that uid, or nil if there is no such user. */)
1340 /* Set up the user name info if we didn't do it before.
1341 (That can happen if Emacs is dumpable
1342 but you decide to run `temacs -l loadup' and not dump. */
1343 if (NILP (Vuser_login_name
))
1344 init_editfns (false);
1347 return Vuser_login_name
;
1349 CONS_TO_INTEGER (uid
, uid_t
, id
);
1353 return (pw
? build_string (pw
->pw_name
) : Qnil
);
1356 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
1358 doc
: /* Return the name of the user's real uid, as a string.
1359 This ignores the environment variables LOGNAME and USER, so it differs from
1360 `user-login-name' when running under `su'. */)
1363 /* Set up the user name info if we didn't do it before.
1364 (That can happen if Emacs is dumpable
1365 but you decide to run `temacs -l loadup' and not dump. */
1366 if (NILP (Vuser_login_name
))
1367 init_editfns (false);
1368 return Vuser_real_login_name
;
1371 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
1372 doc
: /* Return the effective uid of Emacs.
1373 Value is an integer or a float, depending on the value. */)
1376 uid_t euid
= geteuid ();
1377 return make_fixnum_or_float (euid
);
1380 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
1381 doc
: /* Return the real uid of Emacs.
1382 Value is an integer or a float, depending on the value. */)
1385 uid_t uid
= getuid ();
1386 return make_fixnum_or_float (uid
);
1389 DEFUN ("group-gid", Fgroup_gid
, Sgroup_gid
, 0, 0, 0,
1390 doc
: /* Return the effective gid of Emacs.
1391 Value is an integer or a float, depending on the value. */)
1394 gid_t egid
= getegid ();
1395 return make_fixnum_or_float (egid
);
1398 DEFUN ("group-real-gid", Fgroup_real_gid
, Sgroup_real_gid
, 0, 0, 0,
1399 doc
: /* Return the real gid of Emacs.
1400 Value is an integer or a float, depending on the value. */)
1403 gid_t gid
= getgid ();
1404 return make_fixnum_or_float (gid
);
1407 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 1, 0,
1408 doc
: /* Return the full name of the user logged in, as a string.
1409 If the full name corresponding to Emacs's userid is not known,
1412 If optional argument UID is an integer or float, return the full name
1413 of the user with that uid, or nil if there is no such user.
1414 If UID is a string, return the full name of the user with that login
1415 name, or nil if there is no such user. */)
1419 register char *p
, *q
;
1423 return Vuser_full_name
;
1424 else if (NUMBERP (uid
))
1427 CONS_TO_INTEGER (uid
, uid_t
, u
);
1432 else if (STRINGP (uid
))
1435 pw
= getpwnam (SSDATA (uid
));
1439 error ("Invalid UID specification");
1445 /* Chop off everything after the first comma. */
1446 q
= strchr (p
, ',');
1447 full
= make_string (p
, q
? q
- p
: strlen (p
));
1449 #ifdef AMPERSAND_FULL_NAME
1451 q
= strchr (p
, '&');
1452 /* Substitute the login name for the &, upcasing the first character. */
1455 Lisp_Object login
= Fuser_login_name (make_number (pw
->pw_uid
));
1457 char *r
= SAFE_ALLOCA (strlen (p
) + SBYTES (login
) + 1);
1458 memcpy (r
, p
, q
- p
);
1459 char *s
= lispstpcpy (&r
[q
- p
], login
);
1460 r
[q
- p
] = upcase ((unsigned char) r
[q
- p
]);
1462 full
= build_string (r
);
1465 #endif /* AMPERSAND_FULL_NAME */
1470 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
1471 doc
: /* Return the host name of the machine you are running on, as a string. */)
1474 if (EQ (Vsystem_name
, cached_system_name
))
1475 init_and_cache_system_name ();
1476 return Vsystem_name
;
1479 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
1480 doc
: /* Return the process ID of Emacs, as a number. */)
1483 pid_t pid
= getpid ();
1484 return make_fixnum_or_float (pid
);
1490 # define TIME_T_MIN TYPE_MINIMUM (time_t)
1493 # define TIME_T_MAX TYPE_MAXIMUM (time_t)
1496 /* Report that a time value is out of range for Emacs. */
1498 time_overflow (void)
1500 error ("Specified time is not representable");
1503 static _Noreturn
void
1506 error ("Invalid time specification");
1509 /* Check a return value compatible with that of decode_time_components. */
1511 check_time_validity (int validity
)
1522 /* Return the upper part of the time T (everything but the bottom 16 bits). */
1526 time_t hi
= t
>> LO_TIME_BITS
;
1527 if (FIXNUM_OVERFLOW_P (hi
))
1532 /* Return the bottom bits of the time T. */
1536 return t
& ((1 << LO_TIME_BITS
) - 1);
1539 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
1540 doc
: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
1541 The time is returned as a list of integers (HIGH LOW USEC PSEC).
1542 HIGH has the most significant bits of the seconds, while LOW has the
1543 least significant 16 bits. USEC and PSEC are the microsecond and
1544 picosecond counts. */)
1547 return make_lisp_time (current_timespec ());
1550 static struct lisp_time
1551 time_add (struct lisp_time ta
, struct lisp_time tb
)
1553 EMACS_INT hi
= ta
.hi
+ tb
.hi
;
1554 int lo
= ta
.lo
+ tb
.lo
;
1555 int us
= ta
.us
+ tb
.us
;
1556 int ps
= ta
.ps
+ tb
.ps
;
1557 us
+= (1000000 <= ps
);
1558 ps
-= (1000000 <= ps
) * 1000000;
1559 lo
+= (1000000 <= us
);
1560 us
-= (1000000 <= us
) * 1000000;
1561 hi
+= (1 << LO_TIME_BITS
<= lo
);
1562 lo
-= (1 << LO_TIME_BITS
<= lo
) << LO_TIME_BITS
;
1563 return (struct lisp_time
) { hi
, lo
, us
, ps
};
1566 static struct lisp_time
1567 time_subtract (struct lisp_time ta
, struct lisp_time tb
)
1569 EMACS_INT hi
= ta
.hi
- tb
.hi
;
1570 int lo
= ta
.lo
- tb
.lo
;
1571 int us
= ta
.us
- tb
.us
;
1572 int ps
= ta
.ps
- tb
.ps
;
1574 ps
+= (ps
< 0) * 1000000;
1576 us
+= (us
< 0) * 1000000;
1578 lo
+= (lo
< 0) << LO_TIME_BITS
;
1579 return (struct lisp_time
) { hi
, lo
, us
, ps
};
1583 time_arith (Lisp_Object a
, Lisp_Object b
,
1584 struct lisp_time (*op
) (struct lisp_time
, struct lisp_time
))
1587 struct lisp_time ta
= lisp_time_struct (a
, &alen
);
1588 struct lisp_time tb
= lisp_time_struct (b
, &blen
);
1589 struct lisp_time t
= op (ta
, tb
);
1590 if (FIXNUM_OVERFLOW_P (t
.hi
))
1592 Lisp_Object val
= Qnil
;
1594 switch (max (alen
, blen
))
1597 val
= Fcons (make_number (t
.ps
), val
);
1600 val
= Fcons (make_number (t
.us
), val
);
1603 val
= Fcons (make_number (t
.lo
), val
);
1604 val
= Fcons (make_number (t
.hi
), val
);
1611 DEFUN ("time-add", Ftime_add
, Stime_add
, 2, 2, 0,
1612 doc
: /* Return the sum of two time values A and B, as a time value.
1613 A nil value for either argument stands for the current time.
1614 See `current-time-string' for the various forms of a time value. */)
1615 (Lisp_Object a
, Lisp_Object b
)
1617 return time_arith (a
, b
, time_add
);
1620 DEFUN ("time-subtract", Ftime_subtract
, Stime_subtract
, 2, 2, 0,
1621 doc
: /* Return the difference between two time values A and B, as a time value.
1622 Use `float-time' to convert the difference into elapsed seconds.
1623 A nil value for either argument stands for the current time.
1624 See `current-time-string' for the various forms of a time value. */)
1625 (Lisp_Object a
, Lisp_Object b
)
1627 return time_arith (a
, b
, time_subtract
);
1630 DEFUN ("time-less-p", Ftime_less_p
, Stime_less_p
, 2, 2, 0,
1631 doc
: /* Return non-nil if time value T1 is earlier than time value T2.
1632 A nil value for either argument stands for the current time.
1633 See `current-time-string' for the various forms of a time value. */)
1634 (Lisp_Object t1
, Lisp_Object t2
)
1637 struct lisp_time a
= lisp_time_struct (t1
, &t1len
);
1638 struct lisp_time b
= lisp_time_struct (t2
, &t2len
);
1639 return ((a
.hi
!= b
.hi
? a
.hi
< b
.hi
1640 : a
.lo
!= b
.lo
? a
.lo
< b
.lo
1641 : a
.us
!= b
.us
? a
.us
< b
.us
1647 DEFUN ("get-internal-run-time", Fget_internal_run_time
, Sget_internal_run_time
,
1649 doc
: /* Return the current run time used by Emacs.
1650 The time is returned as a list (HIGH LOW USEC PSEC), using the same
1651 style as (current-time).
1653 On systems that can't determine the run time, `get-internal-run-time'
1654 does the same thing as `current-time'. */)
1657 #ifdef HAVE_GETRUSAGE
1658 struct rusage usage
;
1662 if (getrusage (RUSAGE_SELF
, &usage
) < 0)
1663 /* This shouldn't happen. What action is appropriate? */
1666 /* Sum up user time and system time. */
1667 secs
= usage
.ru_utime
.tv_sec
+ usage
.ru_stime
.tv_sec
;
1668 usecs
= usage
.ru_utime
.tv_usec
+ usage
.ru_stime
.tv_usec
;
1669 if (usecs
>= 1000000)
1674 return make_lisp_time (make_timespec (secs
, usecs
* 1000));
1675 #else /* ! HAVE_GETRUSAGE */
1677 return w32_get_internal_run_time ();
1678 #else /* ! WINDOWSNT */
1679 return Fcurrent_time ();
1680 #endif /* WINDOWSNT */
1681 #endif /* HAVE_GETRUSAGE */
1685 /* Make a Lisp list that represents the Emacs time T. T may be an
1686 invalid time, with a slightly negative tv_nsec value such as
1687 UNKNOWN_MODTIME_NSECS; in that case, the Lisp list contains a
1688 correspondingly negative picosecond count. */
1690 make_lisp_time (struct timespec t
)
1692 time_t s
= t
.tv_sec
;
1694 return list4i (hi_time (s
), lo_time (s
), ns
/ 1000, ns
% 1000 * 1000);
1697 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1698 Set *PHIGH, *PLOW, *PUSEC, *PPSEC to its parts; do not check their values.
1699 Return 2, 3, or 4 to indicate the effective length of SPECIFIED_TIME
1700 if successful, 0 if unsuccessful. */
1702 disassemble_lisp_time (Lisp_Object specified_time
, Lisp_Object
*phigh
,
1703 Lisp_Object
*plow
, Lisp_Object
*pusec
,
1706 Lisp_Object high
= make_number (0);
1707 Lisp_Object low
= specified_time
;
1708 Lisp_Object usec
= make_number (0);
1709 Lisp_Object psec
= make_number (0);
1712 if (CONSP (specified_time
))
1714 high
= XCAR (specified_time
);
1715 low
= XCDR (specified_time
);
1718 Lisp_Object low_tail
= XCDR (low
);
1720 if (CONSP (low_tail
))
1722 usec
= XCAR (low_tail
);
1723 low_tail
= XCDR (low_tail
);
1724 if (CONSP (low_tail
))
1725 psec
= XCAR (low_tail
);
1729 else if (!NILP (low_tail
))
1740 /* When combining components, require LOW to be an integer,
1741 as otherwise it would be a pain to add up times. */
1742 if (! INTEGERP (low
))
1745 else if (INTEGERP (specified_time
))
1755 /* Convert T into an Emacs time *RESULT, truncating toward minus infinity.
1756 Return true if T is in range, false otherwise. */
1758 decode_float_time (double t
, struct lisp_time
*result
)
1760 double lo_multiplier
= 1 << LO_TIME_BITS
;
1761 double emacs_time_min
= MOST_NEGATIVE_FIXNUM
* lo_multiplier
;
1762 if (! (emacs_time_min
<= t
&& t
< -emacs_time_min
))
1765 double small_t
= t
/ lo_multiplier
;
1766 EMACS_INT hi
= small_t
;
1767 double t_sans_hi
= t
- hi
* lo_multiplier
;
1769 long double fracps
= (t_sans_hi
- lo
) * 1e12L
;
1770 #ifdef INT_FAST64_MAX
1771 int_fast64_t ifracps
= fracps
;
1772 int us
= ifracps
/ 1000000;
1773 int ps
= ifracps
% 1000000;
1775 int us
= fracps
/ 1e6L
;
1776 int ps
= fracps
- us
* 1e6L
;
1779 ps
+= (ps
< 0) * 1000000;
1781 us
+= (us
< 0) * 1000000;
1783 lo
+= (lo
< 0) << LO_TIME_BITS
;
1791 /* From the time components HIGH, LOW, USEC and PSEC taken from a Lisp
1792 list, generate the corresponding time value.
1793 If LOW is floating point, the other components should be zero.
1795 If RESULT is not null, store into *RESULT the converted time.
1796 If *DRESULT is not null, store into *DRESULT the number of
1797 seconds since the start of the POSIX Epoch.
1799 Return 1 if successful, 0 if the components are of the
1800 wrong type, and -1 if the time is out of range. */
1802 decode_time_components (Lisp_Object high
, Lisp_Object low
, Lisp_Object usec
,
1804 struct lisp_time
*result
, double *dresult
)
1806 EMACS_INT hi
, lo
, us
, ps
;
1807 if (! (INTEGERP (high
)
1808 && INTEGERP (usec
) && INTEGERP (psec
)))
1810 if (! INTEGERP (low
))
1814 double t
= XFLOAT_DATA (low
);
1815 if (result
&& ! decode_float_time (t
, result
))
1821 else if (NILP (low
))
1823 struct timespec now
= current_timespec ();
1826 result
->hi
= hi_time (now
.tv_sec
);
1827 result
->lo
= lo_time (now
.tv_sec
);
1828 result
->us
= now
.tv_nsec
/ 1000;
1829 result
->ps
= now
.tv_nsec
% 1000 * 1000;
1832 *dresult
= now
.tv_sec
+ now
.tv_nsec
/ 1e9
;
1844 /* Normalize out-of-range lower-order components by carrying
1845 each overflow into the next higher-order component. */
1846 us
+= ps
/ 1000000 - (ps
% 1000000 < 0);
1847 lo
+= us
/ 1000000 - (us
% 1000000 < 0);
1848 hi
+= lo
>> LO_TIME_BITS
;
1849 ps
= ps
% 1000000 + 1000000 * (ps
% 1000000 < 0);
1850 us
= us
% 1000000 + 1000000 * (us
% 1000000 < 0);
1851 lo
&= (1 << LO_TIME_BITS
) - 1;
1855 if (FIXNUM_OVERFLOW_P (hi
))
1866 *dresult
= (us
* 1e6
+ ps
) / 1e12
+ lo
+ dhi
* (1 << LO_TIME_BITS
);
1873 lisp_to_timespec (struct lisp_time t
)
1875 if (! ((TYPE_SIGNED (time_t) ? TIME_T_MIN
>> LO_TIME_BITS
<= t
.hi
: 0 <= t
.hi
)
1876 && t
.hi
<= TIME_T_MAX
>> LO_TIME_BITS
))
1877 return invalid_timespec ();
1878 time_t s
= (t
.hi
<< LO_TIME_BITS
) + t
.lo
;
1879 int ns
= t
.us
* 1000 + t
.ps
/ 1000;
1880 return make_timespec (s
, ns
);
1883 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1884 Store its effective length into *PLEN.
1885 If SPECIFIED_TIME is nil, use the current time.
1886 Signal an error if SPECIFIED_TIME does not represent a time. */
1887 static struct lisp_time
1888 lisp_time_struct (Lisp_Object specified_time
, int *plen
)
1890 Lisp_Object high
, low
, usec
, psec
;
1892 int len
= disassemble_lisp_time (specified_time
, &high
, &low
, &usec
, &psec
);
1895 int val
= decode_time_components (high
, low
, usec
, psec
, &t
, 0);
1896 check_time_validity (val
);
1901 /* Like lisp_time_struct, except return a struct timespec.
1902 Discard any low-order digits. */
1904 lisp_time_argument (Lisp_Object specified_time
)
1907 struct lisp_time lt
= lisp_time_struct (specified_time
, &len
);
1908 struct timespec t
= lisp_to_timespec (lt
);
1909 if (! timespec_valid_p (t
))
1914 /* Like lisp_time_argument, except decode only the seconds part,
1915 and do not check the subseconds part. */
1917 lisp_seconds_argument (Lisp_Object specified_time
)
1919 Lisp_Object high
, low
, usec
, psec
;
1922 int val
= disassemble_lisp_time (specified_time
, &high
, &low
, &usec
, &psec
);
1925 val
= decode_time_components (high
, low
, make_number (0),
1926 make_number (0), &t
, 0);
1928 && ! ((TYPE_SIGNED (time_t)
1929 ? TIME_T_MIN
>> LO_TIME_BITS
<= t
.hi
1931 && t
.hi
<= TIME_T_MAX
>> LO_TIME_BITS
))
1934 check_time_validity (val
);
1935 return (t
.hi
<< LO_TIME_BITS
) + t
.lo
;
1938 DEFUN ("float-time", Ffloat_time
, Sfloat_time
, 0, 1, 0,
1939 doc
: /* Return the current time, as a float number of seconds since the epoch.
1940 If SPECIFIED-TIME is given, it is the time to convert to float
1941 instead of the current time. The argument should have the form
1942 \(HIGH LOW) or (HIGH LOW USEC) or (HIGH LOW USEC PSEC). Thus,
1943 you can use times from `current-time' and from `file-attributes'.
1944 SPECIFIED-TIME can also have the form (HIGH . LOW), but this is
1945 considered obsolete.
1947 WARNING: Since the result is floating point, it may not be exact.
1948 If precise time stamps are required, use either `current-time',
1949 or (if you need time as a string) `format-time-string'. */)
1950 (Lisp_Object specified_time
)
1953 Lisp_Object high
, low
, usec
, psec
;
1954 if (! (disassemble_lisp_time (specified_time
, &high
, &low
, &usec
, &psec
)
1955 && decode_time_components (high
, low
, usec
, psec
, 0, &t
)))
1957 return make_float (t
);
1960 /* Write information into buffer S of size MAXSIZE, according to the
1961 FORMAT of length FORMAT_LEN, using time information taken from *TP.
1962 Use the time zone specified by TZ.
1963 Use NS as the number of nanoseconds in the %N directive.
1964 Return the number of bytes written, not including the terminating
1965 '\0'. If S is NULL, nothing will be written anywhere; so to
1966 determine how many bytes would be written, use NULL for S and
1967 ((size_t) -1) for MAXSIZE.
1969 This function behaves like nstrftime, except it allows null
1970 bytes in FORMAT and it does not support nanoseconds. */
1972 emacs_nmemftime (char *s
, size_t maxsize
, const char *format
,
1973 size_t format_len
, const struct tm
*tp
, timezone_t tz
, int ns
)
1977 /* Loop through all the null-terminated strings in the format
1978 argument. Normally there's just one null-terminated string, but
1979 there can be arbitrarily many, concatenated together, if the
1980 format contains '\0' bytes. nstrftime stops at the first
1981 '\0' byte so we must invoke it separately for each such string. */
1990 result
= nstrftime (s
, maxsize
, format
, tp
, tz
, ns
);
1994 if (result
== 0 && s
[0] != '\0')
1999 maxsize
-= result
+ 1;
2001 len
= strlen (format
);
2002 if (len
== format_len
)
2006 format_len
-= len
+ 1;
2010 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 1, 3, 0,
2011 doc
: /* Use FORMAT-STRING to format the time TIME, or now if omitted or nil.
2012 TIME is specified as (HIGH LOW USEC PSEC), as returned by
2013 `current-time' or `file-attributes'. It can also be a single integer
2014 number of seconds since the epoch. The obsolete form (HIGH . LOW) is
2015 also still accepted.
2017 The optional ZONE is omitted or nil for Emacs local time, t for
2018 Universal Time, `wall' for system wall clock time, or a string as in
2019 the TZ environment variable. It can also be a list (as from
2020 `current-time-zone') or an integer (as from `decode-time') applied
2021 without consideration for daylight saving time.
2023 The value is a copy of FORMAT-STRING, but with certain constructs replaced
2024 by text that describes the specified date and time in TIME:
2026 %Y is the year, %y within the century, %C the century.
2027 %G is the year corresponding to the ISO week, %g within the century.
2028 %m is the numeric month.
2029 %b and %h are the locale's abbreviated month name, %B the full name.
2030 (%h is not supported on MS-Windows.)
2031 %d is the day of the month, zero-padded, %e is blank-padded.
2032 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
2033 %a is the locale's abbreviated name of the day of week, %A the full name.
2034 %U is the week number starting on Sunday, %W starting on Monday,
2035 %V according to ISO 8601.
2036 %j is the day of the year.
2038 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
2039 only blank-padded, %l is like %I blank-padded.
2040 %p is the locale's equivalent of either AM or PM.
2041 %q is the calendar quarter (1–4).
2042 %M is the minute (00-59).
2043 %S is the second (00-59; 00-60 on platforms with leap seconds)
2044 %s is the number of seconds since 1970-01-01 00:00:00 +0000.
2045 %N is the nanosecond, %6N the microsecond, %3N the millisecond, etc.
2046 %Z is the time zone abbreviation, %z is the numeric form.
2048 %c is the locale's date and time format.
2049 %x is the locale's "preferred" date format.
2050 %D is like "%m/%d/%y".
2051 %F is the ISO 8601 date format (like "%Y-%m-%d").
2053 %R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
2054 %X is the locale's "preferred" time format.
2056 Finally, %n is a newline, %t is a tab, %% is a literal %, and
2057 unrecognized %-sequences stand for themselves.
2059 Certain flags and modifiers are available with some format controls.
2060 The flags are `_', `-', `^' and `#'. For certain characters X,
2061 %_X is like %X, but padded with blanks; %-X is like %X,
2062 but without padding. %^X is like %X, but with all textual
2063 characters up-cased; %#X is like %X, but with letter-case of
2064 all textual characters reversed.
2065 %NX (where N stands for an integer) is like %X,
2066 but takes up at least N (a number) positions.
2067 The modifiers are `E' and `O'. For certain characters X,
2068 %EX is a locale's alternative version of %X;
2069 %OX is like %X, but uses the locale's number symbols.
2071 For example, to produce full ISO 8601 format, use "%FT%T%z".
2073 usage: (format-time-string FORMAT-STRING &optional TIME ZONE) */)
2074 (Lisp_Object format_string
, Lisp_Object timeval
, Lisp_Object zone
)
2076 struct timespec t
= lisp_time_argument (timeval
);
2079 CHECK_STRING (format_string
);
2080 format_string
= code_convert_string_norecord (format_string
,
2081 Vlocale_coding_system
, 1);
2082 return format_time_string (SSDATA (format_string
), SBYTES (format_string
),
2087 format_time_string (char const *format
, ptrdiff_t formatlen
,
2088 struct timespec t
, Lisp_Object zone
, struct tm
*tmp
)
2092 ptrdiff_t size
= sizeof buffer
;
2097 timezone_t tz
= tzlookup (zone
, false);
2098 /* On some systems, like 32-bit MinGW, tv_sec of struct timespec is
2099 a 64-bit type, but time_t is a 32-bit type. emacs_localtime_rz
2100 expects a pointer to time_t value. */
2101 time_t tsec
= t
.tv_sec
;
2102 tmp
= emacs_localtime_rz (tz
, &tsec
, tmp
);
2108 synchronize_system_time_locale ();
2113 len
= emacs_nmemftime (buf
, size
, format
, formatlen
, tmp
, tz
, ns
);
2114 if ((0 < len
&& len
< size
) || (len
== 0 && buf
[0] == '\0'))
2117 /* Buffer was too small, so make it bigger and try again. */
2118 len
= emacs_nmemftime (NULL
, SIZE_MAX
, format
, formatlen
, tmp
, tz
, ns
);
2119 if (STRING_BYTES_BOUND
<= len
)
2125 buf
= SAFE_ALLOCA (size
);
2129 AUTO_STRING_WITH_LEN (bufstring
, buf
, len
);
2130 Lisp_Object result
= code_convert_string_norecord (bufstring
,
2131 Vlocale_coding_system
, 0);
2136 DEFUN ("decode-time", Fdecode_time
, Sdecode_time
, 0, 2, 0,
2137 doc
: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST UTCOFF).
2138 The optional TIME should be a list of (HIGH LOW . IGNORED),
2139 as from `current-time' and `file-attributes', or nil to use the
2140 current time. It can also be a single integer number of seconds since
2141 the epoch. The obsolete form (HIGH . LOW) is also still accepted.
2143 The optional ZONE is omitted or nil for Emacs local time, t for
2144 Universal Time, `wall' for system wall clock time, or a string as in
2145 the TZ environment variable. It can also be a list (as from
2146 `current-time-zone') or an integer (the UTC offset in seconds) applied
2147 without consideration for daylight saving time.
2149 The list has the following nine members: SEC is an integer between 0
2150 and 60; SEC is 60 for a leap second, which only some operating systems
2151 support. MINUTE is an integer between 0 and 59. HOUR is an integer
2152 between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
2153 integer between 1 and 12. YEAR is an integer indicating the
2154 four-digit year. DOW is the day of week, an integer between 0 and 6,
2155 where 0 is Sunday. DST is t if daylight saving time is in effect,
2156 otherwise nil. UTCOFF is an integer indicating the UTC offset in
2157 seconds, i.e., the number of seconds east of Greenwich. (Note that
2158 Common Lisp has different meanings for DOW and UTCOFF.)
2160 usage: (decode-time &optional TIME ZONE) */)
2161 (Lisp_Object specified_time
, Lisp_Object zone
)
2163 time_t time_spec
= lisp_seconds_argument (specified_time
);
2164 struct tm local_tm
, gmt_tm
;
2165 timezone_t tz
= tzlookup (zone
, false);
2166 struct tm
*tm
= emacs_localtime_rz (tz
, &time_spec
, &local_tm
);
2170 && MOST_NEGATIVE_FIXNUM
- TM_YEAR_BASE
<= local_tm
.tm_year
2171 && local_tm
.tm_year
<= MOST_POSITIVE_FIXNUM
- TM_YEAR_BASE
))
2174 /* Avoid overflow when INT_MAX < EMACS_INT_MAX. */
2175 EMACS_INT tm_year_base
= TM_YEAR_BASE
;
2177 return CALLN (Flist
,
2178 make_number (local_tm
.tm_sec
),
2179 make_number (local_tm
.tm_min
),
2180 make_number (local_tm
.tm_hour
),
2181 make_number (local_tm
.tm_mday
),
2182 make_number (local_tm
.tm_mon
+ 1),
2183 make_number (local_tm
.tm_year
+ tm_year_base
),
2184 make_number (local_tm
.tm_wday
),
2185 local_tm
.tm_isdst
? Qt
: Qnil
,
2187 ? make_number (tm_gmtoff (&local_tm
))
2188 : gmtime_r (&time_spec
, &gmt_tm
)
2189 ? make_number (tm_diff (&local_tm
, &gmt_tm
))
2193 /* Return OBJ - OFFSET, checking that OBJ is a valid fixnum and that
2194 the result is representable as an int. */
2196 check_tm_member (Lisp_Object obj
, int offset
)
2199 EMACS_INT n
= XINT (obj
);
2201 if (INT_SUBTRACT_WRAPV (n
, offset
, &result
))
2206 DEFUN ("encode-time", Fencode_time
, Sencode_time
, 6, MANY
, 0,
2207 doc
: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
2208 This is the reverse operation of `decode-time', which see.
2210 The optional ZONE is omitted or nil for Emacs local time, t for
2211 Universal Time, `wall' for system wall clock time, or a string as in
2212 the TZ environment variable. It can also be a list (as from
2213 `current-time-zone') or an integer (as from `decode-time') applied
2214 without consideration for daylight saving time.
2216 You can pass more than 7 arguments; then the first six arguments
2217 are used as SECOND through YEAR, and the *last* argument is used as ZONE.
2218 The intervening arguments are ignored.
2219 This feature lets (apply \\='encode-time (decode-time ...)) work.
2221 Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed;
2222 for example, a DAY of 0 means the day preceding the given month.
2223 Year numbers less than 100 are treated just like other year numbers.
2224 If you want them to stand for years in this century, you must do that yourself.
2226 Years before 1970 are not guaranteed to work. On some systems,
2227 year values as low as 1901 do work.
2229 usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
2230 (ptrdiff_t nargs
, Lisp_Object
*args
)
2234 Lisp_Object zone
= (nargs
> 6 ? args
[nargs
- 1] : Qnil
);
2236 tm
.tm_sec
= check_tm_member (args
[0], 0);
2237 tm
.tm_min
= check_tm_member (args
[1], 0);
2238 tm
.tm_hour
= check_tm_member (args
[2], 0);
2239 tm
.tm_mday
= check_tm_member (args
[3], 0);
2240 tm
.tm_mon
= check_tm_member (args
[4], 1);
2241 tm
.tm_year
= check_tm_member (args
[5], TM_YEAR_BASE
);
2244 timezone_t tz
= tzlookup (zone
, false);
2245 value
= emacs_mktime_z (tz
, &tm
);
2248 if (value
== (time_t) -1)
2251 return list2i (hi_time (value
), lo_time (value
));
2254 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
,
2256 doc
: /* Return the current local time, as a human-readable string.
2257 Programs can use this function to decode a time,
2258 since the number of columns in each field is fixed
2259 if the year is in the range 1000-9999.
2260 The format is `Sun Sep 16 01:03:52 1973'.
2261 However, see also the functions `decode-time' and `format-time-string'
2262 which provide a much more powerful and general facility.
2264 If SPECIFIED-TIME is given, it is a time to format instead of the
2265 current time. The argument should have the form (HIGH LOW . IGNORED).
2266 Thus, you can use times obtained from `current-time' and from
2267 `file-attributes'. SPECIFIED-TIME can also be a single integer number
2268 of seconds since the epoch. The obsolete form (HIGH . LOW) is also
2271 The optional ZONE is omitted or nil for Emacs local time, t for
2272 Universal Time, `wall' for system wall clock time, or a string as in
2273 the TZ environment variable. It can also be a list (as from
2274 `current-time-zone') or an integer (as from `decode-time') applied
2275 without consideration for daylight saving time. */)
2276 (Lisp_Object specified_time
, Lisp_Object zone
)
2278 time_t value
= lisp_seconds_argument (specified_time
);
2279 timezone_t tz
= tzlookup (zone
, false);
2281 /* Convert to a string in ctime format, except without the trailing
2282 newline, and without the 4-digit year limit. Don't use asctime
2283 or ctime, as they might dump core if the year is outside the
2284 range -999 .. 9999. */
2286 struct tm
*tmp
= emacs_localtime_rz (tz
, &value
, &tm
);
2291 static char const wday_name
[][4] =
2292 { "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat" };
2293 static char const mon_name
[][4] =
2294 { "Jan", "Feb", "Mar", "Apr", "May", "Jun",
2295 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" };
2296 printmax_t year_base
= TM_YEAR_BASE
;
2297 char buf
[sizeof "Mon Apr 30 12:49:17 " + INT_STRLEN_BOUND (int) + 1];
2298 int len
= sprintf (buf
, "%s %s%3d %02d:%02d:%02d %"pMd
,
2299 wday_name
[tm
.tm_wday
], mon_name
[tm
.tm_mon
], tm
.tm_mday
,
2300 tm
.tm_hour
, tm
.tm_min
, tm
.tm_sec
,
2301 tm
.tm_year
+ year_base
);
2303 return make_unibyte_string (buf
, len
);
2306 /* Yield A - B, measured in seconds.
2307 This function is copied from the GNU C Library. */
2309 tm_diff (struct tm
*a
, struct tm
*b
)
2311 /* Compute intervening leap days correctly even if year is negative.
2312 Take care to avoid int overflow in leap day calculations,
2313 but it's OK to assume that A and B are close to each other. */
2314 int a4
= (a
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (a
->tm_year
& 3);
2315 int b4
= (b
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (b
->tm_year
& 3);
2316 int a100
= a4
/ 25 - (a4
% 25 < 0);
2317 int b100
= b4
/ 25 - (b4
% 25 < 0);
2318 int a400
= a100
>> 2;
2319 int b400
= b100
>> 2;
2320 int intervening_leap_days
= (a4
- b4
) - (a100
- b100
) + (a400
- b400
);
2321 int years
= a
->tm_year
- b
->tm_year
;
2322 int days
= (365 * years
+ intervening_leap_days
2323 + (a
->tm_yday
- b
->tm_yday
));
2324 return (60 * (60 * (24 * days
+ (a
->tm_hour
- b
->tm_hour
))
2325 + (a
->tm_min
- b
->tm_min
))
2326 + (a
->tm_sec
- b
->tm_sec
));
2329 /* Yield A's UTC offset, or an unspecified value if unknown. */
2331 tm_gmtoff (struct tm
*a
)
2334 return a
->tm_gmtoff
;
2340 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 2, 0,
2341 doc
: /* Return the offset and name for the local time zone.
2342 This returns a list of the form (OFFSET NAME).
2343 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
2344 A negative value means west of Greenwich.
2345 NAME is a string giving the name of the time zone.
2346 If SPECIFIED-TIME is given, the time zone offset is determined from it
2347 instead of using the current time. The argument should have the form
2348 \(HIGH LOW . IGNORED). Thus, you can use times obtained from
2349 `current-time' and from `file-attributes'. SPECIFIED-TIME can also be
2350 a single integer number of seconds since the epoch. The obsolete form
2351 (HIGH . LOW) is also still accepted.
2353 The optional ZONE is omitted or nil for Emacs local time, t for
2354 Universal Time, `wall' for system wall clock time, or a string as in
2355 the TZ environment variable. It can also be a list (as from
2356 `current-time-zone') or an integer (as from `decode-time') applied
2357 without consideration for daylight saving time.
2359 Some operating systems cannot provide all this information to Emacs;
2360 in this case, `current-time-zone' returns a list containing nil for
2361 the data it can't find. */)
2362 (Lisp_Object specified_time
, Lisp_Object zone
)
2364 struct timespec value
;
2365 struct tm local_tm
, gmt_tm
;
2366 Lisp_Object zone_offset
, zone_name
;
2369 value
= make_timespec (lisp_seconds_argument (specified_time
), 0);
2370 zone_name
= format_time_string ("%Z", sizeof "%Z" - 1, value
,
2373 /* gmtime_r expects a pointer to time_t, but tv_sec of struct
2374 timespec on some systems (MinGW) is a 64-bit field. */
2375 time_t tsec
= value
.tv_sec
;
2376 if (HAVE_TM_GMTOFF
|| gmtime_r (&tsec
, &gmt_tm
))
2378 long int offset
= (HAVE_TM_GMTOFF
2379 ? tm_gmtoff (&local_tm
)
2380 : tm_diff (&local_tm
, &gmt_tm
));
2381 zone_offset
= make_number (offset
);
2382 if (SCHARS (zone_name
) == 0)
2384 /* No local time zone name is available; use numeric zone instead. */
2385 long int hour
= offset
/ 3600;
2386 int min_sec
= offset
% 3600;
2387 int amin_sec
= min_sec
< 0 ? - min_sec
: min_sec
;
2388 int min
= amin_sec
/ 60;
2389 int sec
= amin_sec
% 60;
2390 int min_prec
= min_sec
? 2 : 0;
2391 int sec_prec
= sec
? 2 : 0;
2392 char buf
[sizeof "+0000" + INT_STRLEN_BOUND (long int)];
2393 zone_name
= make_formatted_string (buf
, "%c%.2ld%.*d%.*d",
2394 (offset
< 0 ? '-' : '+'),
2395 hour
, min_prec
, min
, sec_prec
, sec
);
2399 return list2 (zone_offset
, zone_name
);
2402 DEFUN ("set-time-zone-rule", Fset_time_zone_rule
, Sset_time_zone_rule
, 1, 1, 0,
2403 doc
: /* Set the Emacs local time zone using TZ, a string specifying a time zone rule.
2404 If TZ is nil or `wall', use system wall clock time; this differs from
2405 the usual Emacs convention where nil means current local time. If TZ
2406 is t, use Universal Time. If TZ is a list (as from
2407 `current-time-zone') or an integer (as from `decode-time'), use the
2408 specified time zone without consideration for daylight saving time.
2410 Instead of calling this function, you typically want something else.
2411 To temporarily use a different time zone rule for just one invocation
2412 of `decode-time', `encode-time', or `format-time-string', pass the
2413 function a ZONE argument. To change local time consistently
2414 throughout Emacs, call (setenv "TZ" TZ): this changes both the
2415 environment of the Emacs process and the variable
2416 `process-environment', whereas `set-time-zone-rule' affects only the
2420 tzlookup (NILP (tz
) ? Qwall
: tz
, true);
2424 /* A buffer holding a string of the form "TZ=value", intended
2425 to be part of the environment. If TZ is supposed to be unset,
2426 the buffer string is "tZ=". */
2427 static char *tzvalbuf
;
2429 /* Get the local time zone rule. */
2431 emacs_getenv_TZ (void)
2433 return tzvalbuf
[0] == 'T' ? tzvalbuf
+ tzeqlen
: 0;
2436 /* Set the local time zone rule to TZSTRING, which can be null to
2437 denote wall clock time. Do not record the setting in LOCAL_TZ.
2439 This function is not thread-safe, in theory because putenv is not,
2440 but mostly because of the static storage it updates. Other threads
2441 that invoke localtime etc. may be adversely affected while this
2442 function is executing. */
2445 emacs_setenv_TZ (const char *tzstring
)
2447 static ptrdiff_t tzvalbufsize
;
2448 ptrdiff_t tzstringlen
= tzstring
? strlen (tzstring
) : 0;
2449 char *tzval
= tzvalbuf
;
2450 bool new_tzvalbuf
= tzvalbufsize
<= tzeqlen
+ tzstringlen
;
2454 /* Do not attempt to free the old tzvalbuf, since another thread
2455 may be using it. In practice, the first allocation is large
2456 enough and memory does not leak. */
2457 tzval
= xpalloc (NULL
, &tzvalbufsize
,
2458 tzeqlen
+ tzstringlen
- tzvalbufsize
+ 1, -1, 1);
2466 /* Modify TZVAL in place. Although this is dicey in a
2467 multithreaded environment, we know of no portable alternative.
2468 Calling putenv or setenv could crash some other thread. */
2470 strcpy (tzval
+ tzeqlen
, tzstring
);
2474 /* Turn 'TZ=whatever' into an empty environment variable 'tZ='.
2475 Although this is also dicey, calling unsetenv here can crash Emacs.
2483 /* Modifying *TZVAL merely requires calling tzset (which is the
2484 caller's responsibility). However, modifying TZVAL requires
2485 calling putenv; although this is not thread-safe, in practice this
2486 runs only on startup when there is only one thread. */
2487 bool need_putenv
= new_tzvalbuf
;
2489 /* MS-Windows 'putenv' copies the argument string into a block it
2490 allocates, so modifying *TZVAL will not change the environment.
2491 However, the other threads run by Emacs on MS-Windows never call
2492 'xputenv' or 'putenv' or 'unsetenv', so the original cause for the
2493 dicey in-place modification technique doesn't exist there in the
2495 bool need_putenv
= true;
2503 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
2504 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
2505 type of object is Lisp_String). INHERIT is passed to
2506 INSERT_FROM_STRING_FUNC as the last argument. */
2509 general_insert_function (void (*insert_func
)
2510 (const char *, ptrdiff_t),
2511 void (*insert_from_string_func
)
2512 (Lisp_Object
, ptrdiff_t, ptrdiff_t,
2513 ptrdiff_t, ptrdiff_t, bool),
2514 bool inherit
, ptrdiff_t nargs
, Lisp_Object
*args
)
2519 for (argnum
= 0; argnum
< nargs
; argnum
++)
2522 if (CHARACTERP (val
))
2524 int c
= XFASTINT (val
);
2525 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2528 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2529 len
= CHAR_STRING (c
, str
);
2532 str
[0] = CHAR_TO_BYTE8 (c
);
2535 (*insert_func
) ((char *) str
, len
);
2537 else if (STRINGP (val
))
2539 (*insert_from_string_func
) (val
, 0, 0,
2545 wrong_type_argument (Qchar_or_string_p
, val
);
2550 insert1 (Lisp_Object arg
)
2556 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
2557 doc
: /* Insert the arguments, either strings or characters, at point.
2558 Point and after-insertion markers move forward to end up
2559 after the inserted text.
2560 Any other markers at the point of insertion remain before the text.
2562 If the current buffer is multibyte, unibyte strings are converted
2563 to multibyte for insertion (see `string-make-multibyte').
2564 If the current buffer is unibyte, multibyte strings are converted
2565 to unibyte for insertion (see `string-make-unibyte').
2567 When operating on binary data, it may be necessary to preserve the
2568 original bytes of a unibyte string when inserting it into a multibyte
2569 buffer; to accomplish this, apply `string-as-multibyte' to the string
2570 and insert the result.
2572 usage: (insert &rest ARGS) */)
2573 (ptrdiff_t nargs
, Lisp_Object
*args
)
2575 general_insert_function (insert
, insert_from_string
, 0, nargs
, args
);
2579 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
2581 doc
: /* Insert the arguments at point, inheriting properties from adjoining text.
2582 Point and after-insertion markers move forward to end up
2583 after the inserted text.
2584 Any other markers at the point of insertion remain before the text.
2586 If the current buffer is multibyte, unibyte strings are converted
2587 to multibyte for insertion (see `unibyte-char-to-multibyte').
2588 If the current buffer is unibyte, multibyte strings are converted
2589 to unibyte for insertion.
2591 usage: (insert-and-inherit &rest ARGS) */)
2592 (ptrdiff_t nargs
, Lisp_Object
*args
)
2594 general_insert_function (insert_and_inherit
, insert_from_string
, 1,
2599 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
2600 doc
: /* Insert strings or characters at point, relocating markers after the text.
2601 Point and markers move forward to end up after the inserted text.
2603 If the current buffer is multibyte, unibyte strings are converted
2604 to multibyte for insertion (see `unibyte-char-to-multibyte').
2605 If the current buffer is unibyte, multibyte strings are converted
2606 to unibyte for insertion.
2608 If an overlay begins at the insertion point, the inserted text falls
2609 outside the overlay; if a nonempty overlay ends at the insertion
2610 point, the inserted text falls inside that overlay.
2612 usage: (insert-before-markers &rest ARGS) */)
2613 (ptrdiff_t nargs
, Lisp_Object
*args
)
2615 general_insert_function (insert_before_markers
,
2616 insert_from_string_before_markers
, 0,
2621 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers
,
2622 Sinsert_and_inherit_before_markers
, 0, MANY
, 0,
2623 doc
: /* Insert text at point, relocating markers and inheriting properties.
2624 Point and markers move forward to end up after the inserted text.
2626 If the current buffer is multibyte, unibyte strings are converted
2627 to multibyte for insertion (see `unibyte-char-to-multibyte').
2628 If the current buffer is unibyte, multibyte strings are converted
2629 to unibyte for insertion.
2631 usage: (insert-before-markers-and-inherit &rest ARGS) */)
2632 (ptrdiff_t nargs
, Lisp_Object
*args
)
2634 general_insert_function (insert_before_markers_and_inherit
,
2635 insert_from_string_before_markers
, 1,
2640 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 1, 3,
2641 "(list (read-char-by-name \"Insert character (Unicode name or hex): \")\
2642 (prefix-numeric-value current-prefix-arg)\
2644 doc
: /* Insert COUNT copies of CHARACTER.
2645 Interactively, prompt for CHARACTER. You can specify CHARACTER in one
2648 - As its Unicode character name, e.g. \"LATIN SMALL LETTER A\".
2649 Completion is available; if you type a substring of the name
2650 preceded by an asterisk `*', Emacs shows all names which include
2651 that substring, not necessarily at the beginning of the name.
2653 - As a hexadecimal code point, e.g. 263A. Note that code points in
2654 Emacs are equivalent to Unicode up to 10FFFF (which is the limit of
2655 the Unicode code space).
2657 - As a code point with a radix specified with #, e.g. #o21430
2658 (octal), #x2318 (hex), or #10r8984 (decimal).
2660 If called interactively, COUNT is given by the prefix argument. If
2661 omitted or nil, it defaults to 1.
2663 Inserting the character(s) relocates point and before-insertion
2664 markers in the same ways as the function `insert'.
2666 The optional third argument INHERIT, if non-nil, says to inherit text
2667 properties from adjoining text, if those properties are sticky. If
2668 called interactively, INHERIT is t. */)
2669 (Lisp_Object character
, Lisp_Object count
, Lisp_Object inherit
)
2672 register ptrdiff_t n
;
2674 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2677 CHECK_CHARACTER (character
);
2679 XSETFASTINT (count
, 1);
2680 CHECK_NUMBER (count
);
2681 c
= XFASTINT (character
);
2683 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2684 len
= CHAR_STRING (c
, str
);
2686 str
[0] = c
, len
= 1;
2687 if (XINT (count
) <= 0)
2689 if (BUF_BYTES_MAX
/ len
< XINT (count
))
2691 n
= XINT (count
) * len
;
2692 stringlen
= min (n
, sizeof string
- sizeof string
% len
);
2693 for (i
= 0; i
< stringlen
; i
++)
2694 string
[i
] = str
[i
% len
];
2695 while (n
> stringlen
)
2698 if (!NILP (inherit
))
2699 insert_and_inherit (string
, stringlen
);
2701 insert (string
, stringlen
);
2704 if (!NILP (inherit
))
2705 insert_and_inherit (string
, n
);
2711 DEFUN ("insert-byte", Finsert_byte
, Sinsert_byte
, 2, 3, 0,
2712 doc
: /* Insert COUNT (second arg) copies of BYTE (first arg).
2713 Both arguments are required.
2714 BYTE is a number of the range 0..255.
2716 If BYTE is 128..255 and the current buffer is multibyte, the
2717 corresponding eight-bit character is inserted.
2719 Point, and before-insertion markers, are relocated as in the function `insert'.
2720 The optional third arg INHERIT, if non-nil, says to inherit text properties
2721 from adjoining text, if those properties are sticky. */)
2722 (Lisp_Object byte
, Lisp_Object count
, Lisp_Object inherit
)
2724 CHECK_NUMBER (byte
);
2725 if (XINT (byte
) < 0 || XINT (byte
) > 255)
2726 args_out_of_range_3 (byte
, make_number (0), make_number (255));
2727 if (XINT (byte
) >= 128
2728 && ! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2729 XSETFASTINT (byte
, BYTE8_TO_CHAR (XINT (byte
)));
2730 return Finsert_char (byte
, count
, inherit
);
2734 /* Making strings from buffer contents. */
2736 /* Return a Lisp_String containing the text of the current buffer from
2737 START to END. If text properties are in use and the current buffer
2738 has properties in the range specified, the resulting string will also
2739 have them, if PROPS is true.
2741 We don't want to use plain old make_string here, because it calls
2742 make_uninit_string, which can cause the buffer arena to be
2743 compacted. make_string has no way of knowing that the data has
2744 been moved, and thus copies the wrong data into the string. This
2745 doesn't effect most of the other users of make_string, so it should
2746 be left as is. But we should use this function when conjuring
2747 buffer substrings. */
2750 make_buffer_string (ptrdiff_t start
, ptrdiff_t end
, bool props
)
2752 ptrdiff_t start_byte
= CHAR_TO_BYTE (start
);
2753 ptrdiff_t end_byte
= CHAR_TO_BYTE (end
);
2755 return make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
);
2758 /* Return a Lisp_String containing the text of the current buffer from
2759 START / START_BYTE to END / END_BYTE.
2761 If text properties are in use and the current buffer
2762 has properties in the range specified, the resulting string will also
2763 have them, if PROPS is true.
2765 We don't want to use plain old make_string here, because it calls
2766 make_uninit_string, which can cause the buffer arena to be
2767 compacted. make_string has no way of knowing that the data has
2768 been moved, and thus copies the wrong data into the string. This
2769 doesn't effect most of the other users of make_string, so it should
2770 be left as is. But we should use this function when conjuring
2771 buffer substrings. */
2774 make_buffer_string_both (ptrdiff_t start
, ptrdiff_t start_byte
,
2775 ptrdiff_t end
, ptrdiff_t end_byte
, bool props
)
2777 Lisp_Object result
, tem
, tem1
;
2778 ptrdiff_t beg0
, end0
, beg1
, end1
, size
;
2780 if (start_byte
< GPT_BYTE
&& GPT_BYTE
< end_byte
)
2782 /* Two regions, before and after the gap. */
2785 beg1
= GPT_BYTE
+ GAP_SIZE
- BEG_BYTE
;
2786 end1
= end_byte
+ GAP_SIZE
- BEG_BYTE
;
2790 /* The only region. */
2797 if (! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2798 result
= make_uninit_multibyte_string (end
- start
, end_byte
- start_byte
);
2800 result
= make_uninit_string (end
- start
);
2803 memcpy (SDATA (result
), BYTE_POS_ADDR (beg0
), size
);
2805 memcpy (SDATA (result
) + size
, BEG_ADDR
+ beg1
, end1
- beg1
);
2807 /* If desired, update and copy the text properties. */
2810 update_buffer_properties (start
, end
);
2812 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
2813 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
2815 if (XINT (tem
) != end
|| !NILP (tem1
))
2816 copy_intervals_to_string (result
, current_buffer
, start
,
2823 /* Call Vbuffer_access_fontify_functions for the range START ... END
2824 in the current buffer, if necessary. */
2827 update_buffer_properties (ptrdiff_t start
, ptrdiff_t end
)
2829 /* If this buffer has some access functions,
2830 call them, specifying the range of the buffer being accessed. */
2831 if (!NILP (Vbuffer_access_fontify_functions
))
2833 /* But don't call them if we can tell that the work
2834 has already been done. */
2835 if (!NILP (Vbuffer_access_fontified_property
))
2838 = Ftext_property_any (make_number (start
), make_number (end
),
2839 Vbuffer_access_fontified_property
,
2845 CALLN (Frun_hook_with_args
, Qbuffer_access_fontify_functions
,
2846 make_number (start
), make_number (end
));
2850 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
2851 doc
: /* Return the contents of part of the current buffer as a string.
2852 The two arguments START and END are character positions;
2853 they can be in either order.
2854 The string returned is multibyte if the buffer is multibyte.
2856 This function copies the text properties of that part of the buffer
2857 into the result string; if you don't want the text properties,
2858 use `buffer-substring-no-properties' instead. */)
2859 (Lisp_Object start
, Lisp_Object end
)
2861 register ptrdiff_t b
, e
;
2863 validate_region (&start
, &end
);
2867 return make_buffer_string (b
, e
, 1);
2870 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties
,
2871 Sbuffer_substring_no_properties
, 2, 2, 0,
2872 doc
: /* Return the characters of part of the buffer, without the text properties.
2873 The two arguments START and END are character positions;
2874 they can be in either order. */)
2875 (Lisp_Object start
, Lisp_Object end
)
2877 register ptrdiff_t b
, e
;
2879 validate_region (&start
, &end
);
2883 return make_buffer_string (b
, e
, 0);
2886 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
2887 doc
: /* Return the contents of the current buffer as a string.
2888 If narrowing is in effect, this function returns only the visible part
2892 return make_buffer_string_both (BEGV
, BEGV_BYTE
, ZV
, ZV_BYTE
, 1);
2895 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
2897 doc
: /* Insert before point a substring of the contents of BUFFER.
2898 BUFFER may be a buffer or a buffer name.
2899 Arguments START and END are character positions specifying the substring.
2900 They default to the values of (point-min) and (point-max) in BUFFER.
2902 Point and before-insertion markers move forward to end up after the
2904 Any other markers at the point of insertion remain before the text.
2906 If the current buffer is multibyte and BUFFER is unibyte, or vice
2907 versa, strings are converted from unibyte to multibyte or vice versa
2908 using `string-make-multibyte' or `string-make-unibyte', which see. */)
2909 (Lisp_Object buffer
, Lisp_Object start
, Lisp_Object end
)
2911 register EMACS_INT b
, e
, temp
;
2912 register struct buffer
*bp
, *obuf
;
2915 buf
= Fget_buffer (buffer
);
2919 if (!BUFFER_LIVE_P (bp
))
2920 error ("Selecting deleted buffer");
2926 CHECK_NUMBER_COERCE_MARKER (start
);
2933 CHECK_NUMBER_COERCE_MARKER (end
);
2938 temp
= b
, b
= e
, e
= temp
;
2940 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
2941 args_out_of_range (start
, end
);
2943 obuf
= current_buffer
;
2944 set_buffer_internal_1 (bp
);
2945 update_buffer_properties (b
, e
);
2946 set_buffer_internal_1 (obuf
);
2948 insert_from_buffer (bp
, b
, e
- b
, 0);
2952 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
2954 doc
: /* Compare two substrings of two buffers; return result as number.
2955 Return -N if first string is less after N-1 chars, +N if first string is
2956 greater after N-1 chars, or 0 if strings match.
2957 The first substring is in BUFFER1 from START1 to END1 and the second
2958 is in BUFFER2 from START2 to END2.
2959 All arguments may be nil. If BUFFER1 or BUFFER2 is nil, the current
2960 buffer is used. If START1 or START2 is nil, the value of `point-min'
2961 in the respective buffers is used. If END1 or END2 is nil, the value
2962 of `point-max' in the respective buffers is used.
2963 The value of `case-fold-search' in the current buffer
2964 determines whether case is significant or ignored. */)
2965 (Lisp_Object buffer1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object buffer2
, Lisp_Object start2
, Lisp_Object end2
)
2967 register EMACS_INT begp1
, endp1
, begp2
, endp2
, temp
;
2968 register struct buffer
*bp1
, *bp2
;
2969 register Lisp_Object trt
2970 = (!NILP (BVAR (current_buffer
, case_fold_search
))
2971 ? BVAR (current_buffer
, case_canon_table
) : Qnil
);
2972 ptrdiff_t chars
= 0;
2973 ptrdiff_t i1
, i2
, i1_byte
, i2_byte
;
2975 /* Find the first buffer and its substring. */
2978 bp1
= current_buffer
;
2982 buf1
= Fget_buffer (buffer1
);
2985 bp1
= XBUFFER (buf1
);
2986 if (!BUFFER_LIVE_P (bp1
))
2987 error ("Selecting deleted buffer");
2991 begp1
= BUF_BEGV (bp1
);
2994 CHECK_NUMBER_COERCE_MARKER (start1
);
2995 begp1
= XINT (start1
);
2998 endp1
= BUF_ZV (bp1
);
3001 CHECK_NUMBER_COERCE_MARKER (end1
);
3002 endp1
= XINT (end1
);
3006 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
3008 if (!(BUF_BEGV (bp1
) <= begp1
3010 && endp1
<= BUF_ZV (bp1
)))
3011 args_out_of_range (start1
, end1
);
3013 /* Likewise for second substring. */
3016 bp2
= current_buffer
;
3020 buf2
= Fget_buffer (buffer2
);
3023 bp2
= XBUFFER (buf2
);
3024 if (!BUFFER_LIVE_P (bp2
))
3025 error ("Selecting deleted buffer");
3029 begp2
= BUF_BEGV (bp2
);
3032 CHECK_NUMBER_COERCE_MARKER (start2
);
3033 begp2
= XINT (start2
);
3036 endp2
= BUF_ZV (bp2
);
3039 CHECK_NUMBER_COERCE_MARKER (end2
);
3040 endp2
= XINT (end2
);
3044 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
3046 if (!(BUF_BEGV (bp2
) <= begp2
3048 && endp2
<= BUF_ZV (bp2
)))
3049 args_out_of_range (start2
, end2
);
3053 i1_byte
= buf_charpos_to_bytepos (bp1
, i1
);
3054 i2_byte
= buf_charpos_to_bytepos (bp2
, i2
);
3056 while (i1
< endp1
&& i2
< endp2
)
3058 /* When we find a mismatch, we must compare the
3059 characters, not just the bytes. */
3062 if (! NILP (BVAR (bp1
, enable_multibyte_characters
)))
3064 c1
= BUF_FETCH_MULTIBYTE_CHAR (bp1
, i1_byte
);
3065 BUF_INC_POS (bp1
, i1_byte
);
3070 c1
= BUF_FETCH_BYTE (bp1
, i1
);
3071 MAKE_CHAR_MULTIBYTE (c1
);
3075 if (! NILP (BVAR (bp2
, enable_multibyte_characters
)))
3077 c2
= BUF_FETCH_MULTIBYTE_CHAR (bp2
, i2_byte
);
3078 BUF_INC_POS (bp2
, i2_byte
);
3083 c2
= BUF_FETCH_BYTE (bp2
, i2
);
3084 MAKE_CHAR_MULTIBYTE (c2
);
3090 c1
= char_table_translate (trt
, c1
);
3091 c2
= char_table_translate (trt
, c2
);
3095 return make_number (c1
< c2
? -1 - chars
: chars
+ 1);
3098 rarely_quit (chars
);
3101 /* The strings match as far as they go.
3102 If one is shorter, that one is less. */
3103 if (chars
< endp1
- begp1
)
3104 return make_number (chars
+ 1);
3105 else if (chars
< endp2
- begp2
)
3106 return make_number (- chars
- 1);
3108 /* Same length too => they are equal. */
3109 return make_number (0);
3113 /* Set up necessary definitions for diffseq.h; see comments in
3114 diffseq.h for explanation. */
3119 #define XVECREF_YVECREF_EQUAL(ctx, xoff, yoff) \
3120 buffer_chars_equal ((ctx), (xoff), (yoff))
3122 #define OFFSET ptrdiff_t
3124 #define EXTRA_CONTEXT_FIELDS \
3125 /* Buffers to compare. */ \
3126 struct buffer *buffer_a; \
3127 struct buffer *buffer_b; \
3128 /* Bit vectors recording for each character whether it was deleted
3130 unsigned char *deletions; \
3131 unsigned char *insertions;
3133 #define NOTE_DELETE(ctx, xoff) set_bit ((ctx)->deletions, (xoff))
3134 #define NOTE_INSERT(ctx, yoff) set_bit ((ctx)->insertions, (yoff))
3137 static void set_bit (unsigned char *, OFFSET
);
3138 static bool bit_is_set (const unsigned char *, OFFSET
);
3139 static bool buffer_chars_equal (struct context
*, OFFSET
, OFFSET
);
3142 #include "diffseq.h"
3144 DEFUN ("replace-buffer-contents", Freplace_buffer_contents
,
3145 Sreplace_buffer_contents
, 1, 1, "bSource buffer: ",
3146 doc
: /* Replace accessible portion of current buffer with that of SOURCE.
3147 SOURCE can be a buffer or a string that names a buffer.
3148 Interactively, prompt for SOURCE.
3149 As far as possible the replacement is non-destructive, i.e. existing
3150 buffer contents, markers, properties, and overlays in the current
3151 buffer stay intact. */)
3152 (Lisp_Object source
)
3154 struct buffer
*a
= current_buffer
;
3155 Lisp_Object source_buffer
= Fget_buffer (source
);
3156 if (NILP (source_buffer
))
3158 struct buffer
*b
= XBUFFER (source_buffer
);
3159 if (! BUFFER_LIVE_P (b
))
3160 error ("Selecting deleted buffer");
3162 error ("Cannot replace a buffer with itself");
3164 ptrdiff_t min_a
= BEGV
;
3165 ptrdiff_t min_b
= BUF_BEGV (b
);
3166 ptrdiff_t size_a
= ZV
- min_a
;
3167 ptrdiff_t size_b
= BUF_ZV (b
) - min_b
;
3168 eassume (size_a
>= 0);
3169 eassume (size_b
>= 0);
3170 bool a_empty
= size_a
== 0;
3171 bool b_empty
= size_b
== 0;
3173 /* Handle trivial cases where at least one accessible portion is
3176 if (a_empty
&& b_empty
)
3180 return Finsert_buffer_substring (source
, Qnil
, Qnil
);
3184 del_range_both (BEGV
, BEGV_BYTE
, ZV
, ZV_BYTE
, true);
3188 /* FIXME: It is not documented how to initialize the contents of the
3189 context structure. This code cargo-cults from the existing
3190 caller in src/analyze.c of GNU Diffutils, which appears to
3193 ptrdiff_t diags
= size_a
+ size_b
+ 3;
3196 SAFE_NALLOCA (buffer
, 2, diags
);
3197 /* Micro-optimization: Casting to size_t generates much better
3199 ptrdiff_t del_bytes
= (size_t) size_a
/ CHAR_BIT
+ 1;
3200 ptrdiff_t ins_bytes
= (size_t) size_b
/ CHAR_BIT
+ 1;
3201 struct context ctx
= {
3204 .deletions
= SAFE_ALLOCA (del_bytes
),
3205 .insertions
= SAFE_ALLOCA (ins_bytes
),
3206 .fdiag
= buffer
+ size_b
+ 1,
3207 .bdiag
= buffer
+ diags
+ size_b
+ 1,
3208 /* FIXME: Find a good number for .too_expensive. */
3209 .too_expensive
= 1000000,
3211 memclear (ctx
.deletions
, del_bytes
);
3212 memclear (ctx
.insertions
, ins_bytes
);
3213 /* compareseq requires indices to be zero-based. We add BEGV back
3215 bool early_abort
= compareseq (0, size_a
, 0, size_b
, false, &ctx
);
3216 /* Since we didn’t define EARLY_ABORT, we should never abort
3218 eassert (! early_abort
);
3222 ptrdiff_t count
= SPECPDL_INDEX ();
3223 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
3225 ptrdiff_t i
= size_a
;
3226 ptrdiff_t j
= size_b
;
3227 /* Walk backwards through the lists of changes. This was also
3228 cargo-culted from src/analyze.c in GNU Diffutils. Because we
3229 walk backwards, we don’t have to keep the positions in sync. */
3230 while (i
>= 0 || j
>= 0)
3232 /* Check whether there is a change (insertion or deletion)
3233 before the current position. */
3234 if ((i
> 0 && bit_is_set (ctx
.deletions
, i
- 1)) ||
3235 (j
> 0 && bit_is_set (ctx
.insertions
, j
- 1)))
3237 ptrdiff_t end_a
= min_a
+ i
;
3238 ptrdiff_t end_b
= min_b
+ j
;
3239 /* Find the beginning of the current change run. */
3240 while (i
> 0 && bit_is_set (ctx
.deletions
, i
- 1))
3242 while (j
> 0 && bit_is_set (ctx
.insertions
, j
- 1))
3244 ptrdiff_t beg_a
= min_a
+ i
;
3245 ptrdiff_t beg_b
= min_b
+ j
;
3246 eassert (beg_a
>= BEGV
);
3247 eassert (beg_b
>= BUF_BEGV (b
));
3248 eassert (beg_a
<= end_a
);
3249 eassert (beg_b
<= end_b
);
3250 eassert (end_a
<= ZV
);
3251 eassert (end_b
<= BUF_ZV (b
));
3252 eassert (beg_a
< end_a
|| beg_b
< end_b
);
3254 del_range (beg_a
, end_a
);
3258 Finsert_buffer_substring (source
, make_natnum (beg_b
),
3259 make_natnum (end_b
));
3266 return unbind_to (count
, Qnil
);
3270 set_bit (unsigned char *a
, ptrdiff_t i
)
3273 /* Micro-optimization: Casting to size_t generates much better
3276 a
[j
/ CHAR_BIT
] |= (1 << (j
% CHAR_BIT
));
3280 bit_is_set (const unsigned char *a
, ptrdiff_t i
)
3283 /* Micro-optimization: Casting to size_t generates much better
3286 return a
[j
/ CHAR_BIT
] & (1 << (j
% CHAR_BIT
));
3289 /* Return true if the characters at position POS_A of buffer
3290 CTX->buffer_a and at position POS_B of buffer CTX->buffer_b are
3291 equal. POS_A and POS_B are zero-based. Text properties are
3295 buffer_chars_equal (struct context
*ctx
,
3296 ptrdiff_t pos_a
, ptrdiff_t pos_b
)
3298 eassert (pos_a
>= 0);
3299 pos_a
+= BUF_BEGV (ctx
->buffer_a
);
3300 eassert (pos_a
>= BUF_BEGV (ctx
->buffer_a
));
3301 eassert (pos_a
< BUF_ZV (ctx
->buffer_a
));
3303 eassert (pos_b
>= 0);
3304 pos_b
+= BUF_BEGV (ctx
->buffer_b
);
3305 eassert (pos_b
>= BUF_BEGV (ctx
->buffer_b
));
3306 eassert (pos_b
< BUF_ZV (ctx
->buffer_b
));
3308 return BUF_FETCH_CHAR_AS_MULTIBYTE (ctx
->buffer_a
, pos_a
)
3309 == BUF_FETCH_CHAR_AS_MULTIBYTE (ctx
->buffer_b
, pos_b
);
3314 subst_char_in_region_unwind (Lisp_Object arg
)
3316 bset_undo_list (current_buffer
, arg
);
3320 subst_char_in_region_unwind_1 (Lisp_Object arg
)
3322 bset_filename (current_buffer
, arg
);
3325 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
3326 Ssubst_char_in_region
, 4, 5, 0,
3327 doc
: /* From START to END, replace FROMCHAR with TOCHAR each time it occurs.
3328 If optional arg NOUNDO is non-nil, don't record this change for undo
3329 and don't mark the buffer as really changed.
3330 Both characters must have the same length of multi-byte form. */)
3331 (Lisp_Object start
, Lisp_Object end
, Lisp_Object fromchar
, Lisp_Object tochar
, Lisp_Object noundo
)
3333 register ptrdiff_t pos
, pos_byte
, stop
, i
, len
, end_byte
;
3334 /* Keep track of the first change in the buffer:
3335 if 0 we haven't found it yet.
3336 if < 0 we've found it and we've run the before-change-function.
3337 if > 0 we've actually performed it and the value is its position. */
3338 ptrdiff_t changed
= 0;
3339 unsigned char fromstr
[MAX_MULTIBYTE_LENGTH
], tostr
[MAX_MULTIBYTE_LENGTH
];
3341 ptrdiff_t count
= SPECPDL_INDEX ();
3342 #define COMBINING_NO 0
3343 #define COMBINING_BEFORE 1
3344 #define COMBINING_AFTER 2
3345 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
3346 int maybe_byte_combining
= COMBINING_NO
;
3347 ptrdiff_t last_changed
= 0;
3349 = !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3354 validate_region (&start
, &end
);
3355 CHECK_CHARACTER (fromchar
);
3356 CHECK_CHARACTER (tochar
);
3357 fromc
= XFASTINT (fromchar
);
3358 toc
= XFASTINT (tochar
);
3362 len
= CHAR_STRING (fromc
, fromstr
);
3363 if (CHAR_STRING (toc
, tostr
) != len
)
3364 error ("Characters in `subst-char-in-region' have different byte-lengths");
3365 if (!ASCII_CHAR_P (*tostr
))
3367 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
3368 complete multibyte character, it may be combined with the
3369 after bytes. If it is in the range 0xA0..0xFF, it may be
3370 combined with the before and after bytes. */
3371 if (!CHAR_HEAD_P (*tostr
))
3372 maybe_byte_combining
= COMBINING_BOTH
;
3373 else if (BYTES_BY_CHAR_HEAD (*tostr
) > len
)
3374 maybe_byte_combining
= COMBINING_AFTER
;
3385 pos_byte
= CHAR_TO_BYTE (pos
);
3386 stop
= CHAR_TO_BYTE (XINT (end
));
3389 /* If we don't want undo, turn off putting stuff on the list.
3390 That's faster than getting rid of things,
3391 and it prevents even the entry for a first change.
3392 Also inhibit locking the file. */
3393 if (!changed
&& !NILP (noundo
))
3395 record_unwind_protect (subst_char_in_region_unwind
,
3396 BVAR (current_buffer
, undo_list
));
3397 bset_undo_list (current_buffer
, Qt
);
3398 /* Don't do file-locking. */
3399 record_unwind_protect (subst_char_in_region_unwind_1
,
3400 BVAR (current_buffer
, filename
));
3401 bset_filename (current_buffer
, Qnil
);
3404 if (pos_byte
< GPT_BYTE
)
3405 stop
= min (stop
, GPT_BYTE
);
3408 ptrdiff_t pos_byte_next
= pos_byte
;
3410 if (pos_byte
>= stop
)
3412 if (pos_byte
>= end_byte
) break;
3415 p
= BYTE_POS_ADDR (pos_byte
);
3417 INC_POS (pos_byte_next
);
3420 if (pos_byte_next
- pos_byte
== len
3421 && p
[0] == fromstr
[0]
3423 || (p
[1] == fromstr
[1]
3424 && (len
== 2 || (p
[2] == fromstr
[2]
3425 && (len
== 3 || p
[3] == fromstr
[3]))))))
3428 /* We've already seen this and run the before-change-function;
3429 this time we only need to record the actual position. */
3434 modify_text (pos
, XINT (end
));
3436 if (! NILP (noundo
))
3438 if (MODIFF
- 1 == SAVE_MODIFF
)
3440 if (MODIFF
- 1 == BUF_AUTOSAVE_MODIFF (current_buffer
))
3441 BUF_AUTOSAVE_MODIFF (current_buffer
)++;
3444 /* The before-change-function may have moved the gap
3445 or even modified the buffer so we should start over. */
3449 /* Take care of the case where the new character
3450 combines with neighboring bytes. */
3451 if (maybe_byte_combining
3452 && (maybe_byte_combining
== COMBINING_AFTER
3453 ? (pos_byte_next
< Z_BYTE
3454 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
3455 : ((pos_byte_next
< Z_BYTE
3456 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
3457 || (pos_byte
> BEG_BYTE
3458 && ! ASCII_CHAR_P (FETCH_BYTE (pos_byte
- 1))))))
3460 Lisp_Object tem
, string
;
3462 tem
= BVAR (current_buffer
, undo_list
);
3464 /* Make a multibyte string containing this single character. */
3465 string
= make_multibyte_string ((char *) tostr
, 1, len
);
3466 /* replace_range is less efficient, because it moves the gap,
3467 but it handles combining correctly. */
3468 replace_range (pos
, pos
+ 1, string
,
3470 pos_byte_next
= CHAR_TO_BYTE (pos
);
3471 if (pos_byte_next
> pos_byte
)
3472 /* Before combining happened. We should not increment
3473 POS. So, to cancel the later increment of POS,
3477 INC_POS (pos_byte_next
);
3479 if (! NILP (noundo
))
3480 bset_undo_list (current_buffer
, tem
);
3485 record_change (pos
, 1);
3486 for (i
= 0; i
< len
; i
++) *p
++ = tostr
[i
];
3488 last_changed
= pos
+ 1;
3490 pos_byte
= pos_byte_next
;
3496 signal_after_change (changed
,
3497 last_changed
- changed
, last_changed
- changed
);
3498 update_compositions (changed
, last_changed
, CHECK_ALL
);
3501 unbind_to (count
, Qnil
);
3506 static Lisp_Object
check_translation (ptrdiff_t, ptrdiff_t, ptrdiff_t,
3509 /* Helper function for Ftranslate_region_internal.
3511 Check if a character sequence at POS (POS_BYTE) matches an element
3512 of VAL. VAL is a list (([FROM-CHAR ...] . TO) ...). If a matching
3513 element is found, return it. Otherwise return Qnil. */
3516 check_translation (ptrdiff_t pos
, ptrdiff_t pos_byte
, ptrdiff_t end
,
3519 int initial_buf
[16];
3520 int *buf
= initial_buf
;
3521 ptrdiff_t buf_size
= ARRAYELTS (initial_buf
);
3523 ptrdiff_t buf_used
= 0;
3524 Lisp_Object result
= Qnil
;
3526 for (; CONSP (val
); val
= XCDR (val
))
3535 if (! VECTORP (elt
))
3538 if (len
<= end
- pos
)
3540 for (i
= 0; i
< len
; i
++)
3544 unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
3547 if (buf_used
== buf_size
)
3549 bufalloc
= xpalloc (bufalloc
, &buf_size
, 1, -1,
3551 if (buf
== initial_buf
)
3552 memcpy (bufalloc
, buf
, sizeof initial_buf
);
3555 buf
[buf_used
++] = STRING_CHAR_AND_LENGTH (p
, len1
);
3558 if (XINT (AREF (elt
, i
)) != buf
[i
])
3563 result
= XCAR (val
);
3574 DEFUN ("translate-region-internal", Ftranslate_region_internal
,
3575 Stranslate_region_internal
, 3, 3, 0,
3576 doc
: /* Internal use only.
3577 From START to END, translate characters according to TABLE.
3578 TABLE is a string or a char-table; the Nth character in it is the
3579 mapping for the character with code N.
3580 It returns the number of characters changed. */)
3581 (Lisp_Object start
, Lisp_Object end
, register Lisp_Object table
)
3583 register unsigned char *tt
; /* Trans table. */
3584 register int nc
; /* New character. */
3585 int cnt
; /* Number of changes made. */
3586 ptrdiff_t size
; /* Size of translate table. */
3587 ptrdiff_t pos
, pos_byte
, end_pos
;
3588 bool multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3589 bool string_multibyte UNINIT
;
3591 validate_region (&start
, &end
);
3592 if (CHAR_TABLE_P (table
))
3594 if (! EQ (XCHAR_TABLE (table
)->purpose
, Qtranslation_table
))
3595 error ("Not a translation table");
3601 CHECK_STRING (table
);
3603 if (! multibyte
&& (SCHARS (table
) < SBYTES (table
)))
3604 table
= string_make_unibyte (table
);
3605 string_multibyte
= SCHARS (table
) < SBYTES (table
);
3606 size
= SBYTES (table
);
3611 pos_byte
= CHAR_TO_BYTE (pos
);
3612 end_pos
= XINT (end
);
3613 modify_text (pos
, end_pos
);
3616 for (; pos
< end_pos
; )
3618 unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
3619 unsigned char *str UNINIT
;
3620 unsigned char buf
[MAX_MULTIBYTE_LENGTH
];
3626 oc
= STRING_CHAR_AND_LENGTH (p
, len
);
3633 /* Reload as signal_after_change in last iteration may GC. */
3635 if (string_multibyte
)
3637 str
= tt
+ string_char_to_byte (table
, oc
);
3638 nc
= STRING_CHAR_AND_LENGTH (str
, str_len
);
3643 if (! ASCII_CHAR_P (nc
) && multibyte
)
3645 str_len
= BYTE8_STRING (nc
, buf
);
3658 val
= CHAR_TABLE_REF (table
, oc
);
3659 if (CHARACTERP (val
))
3661 nc
= XFASTINT (val
);
3662 str_len
= CHAR_STRING (nc
, buf
);
3665 else if (VECTORP (val
) || (CONSP (val
)))
3667 /* VAL is [TO_CHAR ...] or (([FROM-CHAR ...] . TO) ...)
3668 where TO is TO-CHAR or [TO-CHAR ...]. */
3673 if (nc
!= oc
&& nc
>= 0)
3675 /* Simple one char to one char translation. */
3680 /* This is less efficient, because it moves the gap,
3681 but it should handle multibyte characters correctly. */
3682 string
= make_multibyte_string ((char *) str
, 1, str_len
);
3683 replace_range (pos
, pos
+ 1, string
, 1, 0, 1, 0);
3688 record_change (pos
, 1);
3689 while (str_len
-- > 0)
3691 signal_after_change (pos
, 1, 1);
3692 update_compositions (pos
, pos
+ 1, CHECK_BORDER
);
3702 val
= check_translation (pos
, pos_byte
, end_pos
, val
);
3709 /* VAL is ([FROM-CHAR ...] . TO). */
3710 len
= ASIZE (XCAR (val
));
3718 string
= Fconcat (1, &val
);
3722 string
= Fmake_string (make_number (1), val
, Qnil
);
3724 replace_range (pos
, pos
+ len
, string
, 1, 0, 1, 0);
3725 pos_byte
+= SBYTES (string
);
3726 pos
+= SCHARS (string
);
3727 cnt
+= SCHARS (string
);
3728 end_pos
+= SCHARS (string
) - len
;
3736 return make_number (cnt
);
3739 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
3740 doc
: /* Delete the text between START and END.
3741 If called interactively, delete the region between point and mark.
3742 This command deletes buffer text without modifying the kill ring. */)
3743 (Lisp_Object start
, Lisp_Object end
)
3745 validate_region (&start
, &end
);
3746 del_range (XINT (start
), XINT (end
));
3750 DEFUN ("delete-and-extract-region", Fdelete_and_extract_region
,
3751 Sdelete_and_extract_region
, 2, 2, 0,
3752 doc
: /* Delete the text between START and END and return it. */)
3753 (Lisp_Object start
, Lisp_Object end
)
3755 validate_region (&start
, &end
);
3756 if (XINT (start
) == XINT (end
))
3757 return empty_unibyte_string
;
3758 return del_range_1 (XINT (start
), XINT (end
), 1, 1);
3761 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
3762 doc
: /* Remove restrictions (narrowing) from current buffer.
3763 This allows the buffer's full text to be seen and edited. */)
3766 if (BEG
!= BEGV
|| Z
!= ZV
)
3767 current_buffer
->clip_changed
= 1;
3769 BEGV_BYTE
= BEG_BYTE
;
3770 SET_BUF_ZV_BOTH (current_buffer
, Z
, Z_BYTE
);
3771 /* Changing the buffer bounds invalidates any recorded current column. */
3772 invalidate_current_column ();
3776 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
3777 doc
: /* Restrict editing in this buffer to the current region.
3778 The rest of the text becomes temporarily invisible and untouchable
3779 but is not deleted; if you save the buffer in a file, the invisible
3780 text is included in the file. \\[widen] makes all visible again.
3781 See also `save-restriction'.
3783 When calling from a program, pass two arguments; positions (integers
3784 or markers) bounding the text that should remain visible. */)
3785 (register Lisp_Object start
, Lisp_Object end
)
3787 CHECK_NUMBER_COERCE_MARKER (start
);
3788 CHECK_NUMBER_COERCE_MARKER (end
);
3790 if (XINT (start
) > XINT (end
))
3793 tem
= start
; start
= end
; end
= tem
;
3796 if (!(BEG
<= XINT (start
) && XINT (start
) <= XINT (end
) && XINT (end
) <= Z
))
3797 args_out_of_range (start
, end
);
3799 if (BEGV
!= XFASTINT (start
) || ZV
!= XFASTINT (end
))
3800 current_buffer
->clip_changed
= 1;
3802 SET_BUF_BEGV (current_buffer
, XFASTINT (start
));
3803 SET_BUF_ZV (current_buffer
, XFASTINT (end
));
3804 if (PT
< XFASTINT (start
))
3805 SET_PT (XFASTINT (start
));
3806 if (PT
> XFASTINT (end
))
3807 SET_PT (XFASTINT (end
));
3808 /* Changing the buffer bounds invalidates any recorded current column. */
3809 invalidate_current_column ();
3814 save_restriction_save (void)
3816 if (BEGV
== BEG
&& ZV
== Z
)
3817 /* The common case that the buffer isn't narrowed.
3818 We return just the buffer object, which save_restriction_restore
3819 recognizes as meaning `no restriction'. */
3820 return Fcurrent_buffer ();
3822 /* We have to save a restriction, so return a pair of markers, one
3823 for the beginning and one for the end. */
3825 Lisp_Object beg
, end
;
3827 beg
= build_marker (current_buffer
, BEGV
, BEGV_BYTE
);
3828 end
= build_marker (current_buffer
, ZV
, ZV_BYTE
);
3830 /* END must move forward if text is inserted at its exact location. */
3831 XMARKER (end
)->insertion_type
= 1;
3833 return Fcons (beg
, end
);
3838 save_restriction_restore (Lisp_Object data
)
3840 struct buffer
*cur
= NULL
;
3841 struct buffer
*buf
= (CONSP (data
)
3842 ? XMARKER (XCAR (data
))->buffer
3845 if (buf
&& buf
!= current_buffer
&& !NILP (BVAR (buf
, pt_marker
)))
3846 { /* If `buf' uses markers to keep track of PT, BEGV, and ZV (as
3847 is the case if it is or has an indirect buffer), then make
3848 sure it is current before we update BEGV, so
3849 set_buffer_internal takes care of managing those markers. */
3850 cur
= current_buffer
;
3851 set_buffer_internal (buf
);
3855 /* A pair of marks bounding a saved restriction. */
3857 struct Lisp_Marker
*beg
= XMARKER (XCAR (data
));
3858 struct Lisp_Marker
*end
= XMARKER (XCDR (data
));
3859 eassert (buf
== end
->buffer
);
3861 if (buf
/* Verify marker still points to a buffer. */
3862 && (beg
->charpos
!= BUF_BEGV (buf
) || end
->charpos
!= BUF_ZV (buf
)))
3863 /* The restriction has changed from the saved one, so restore
3864 the saved restriction. */
3866 ptrdiff_t pt
= BUF_PT (buf
);
3868 SET_BUF_BEGV_BOTH (buf
, beg
->charpos
, beg
->bytepos
);
3869 SET_BUF_ZV_BOTH (buf
, end
->charpos
, end
->bytepos
);
3871 if (pt
< beg
->charpos
|| pt
> end
->charpos
)
3872 /* The point is outside the new visible range, move it inside. */
3873 SET_BUF_PT_BOTH (buf
,
3874 clip_to_bounds (beg
->charpos
, pt
, end
->charpos
),
3875 clip_to_bounds (beg
->bytepos
, BUF_PT_BYTE (buf
),
3878 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3880 /* These aren't needed anymore, so don't wait for GC. */
3881 free_marker (XCAR (data
));
3882 free_marker (XCDR (data
));
3883 free_cons (XCONS (data
));
3886 /* A buffer, which means that there was no old restriction. */
3888 if (buf
/* Verify marker still points to a buffer. */
3889 && (BUF_BEGV (buf
) != BUF_BEG (buf
) || BUF_ZV (buf
) != BUF_Z (buf
)))
3890 /* The buffer has been narrowed, get rid of the narrowing. */
3892 SET_BUF_BEGV_BOTH (buf
, BUF_BEG (buf
), BUF_BEG_BYTE (buf
));
3893 SET_BUF_ZV_BOTH (buf
, BUF_Z (buf
), BUF_Z_BYTE (buf
));
3895 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3899 /* Changing the buffer bounds invalidates any recorded current column. */
3900 invalidate_current_column ();
3903 set_buffer_internal (cur
);
3906 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
3907 doc
: /* Execute BODY, saving and restoring current buffer's restrictions.
3908 The buffer's restrictions make parts of the beginning and end invisible.
3909 \(They are set up with `narrow-to-region' and eliminated with `widen'.)
3910 This special form, `save-restriction', saves the current buffer's restrictions
3911 when it is entered, and restores them when it is exited.
3912 So any `narrow-to-region' within BODY lasts only until the end of the form.
3913 The old restrictions settings are restored
3914 even in case of abnormal exit (throw or error).
3916 The value returned is the value of the last form in BODY.
3918 Note: if you are using both `save-excursion' and `save-restriction',
3919 use `save-excursion' outermost:
3920 (save-excursion (save-restriction ...))
3922 usage: (save-restriction &rest BODY) */)
3925 register Lisp_Object val
;
3926 ptrdiff_t count
= SPECPDL_INDEX ();
3928 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
3929 val
= Fprogn (body
);
3930 return unbind_to (count
, val
);
3933 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
3934 doc
: /* Display a message at the bottom of the screen.
3935 The message also goes into the `*Messages*' buffer, if `message-log-max'
3936 is non-nil. (In keyboard macros, that's all it does.)
3939 In batch mode, the message is printed to the standard error stream,
3940 followed by a newline.
3942 The first argument is a format control string, and the rest are data
3943 to be formatted under control of the string. Percent sign (%), grave
3944 accent (\\=`) and apostrophe (\\=') are special in the format; see
3945 `format-message' for details. To display STRING without special
3946 treatment, use (message "%s" STRING).
3948 If the first argument is nil or the empty string, the function clears
3949 any existing message; this lets the minibuffer contents show. See
3950 also `current-message'.
3952 usage: (message FORMAT-STRING &rest ARGS) */)
3953 (ptrdiff_t nargs
, Lisp_Object
*args
)
3956 || (STRINGP (args
[0])
3957 && SBYTES (args
[0]) == 0))
3964 Lisp_Object val
= Fformat_message (nargs
, args
);
3970 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
3971 doc
: /* Display a message, in a dialog box if possible.
3972 If a dialog box is not available, use the echo area.
3973 The first argument is a format control string, and the rest are data
3974 to be formatted under control of the string. See `format-message' for
3977 If the first argument is nil or the empty string, clear any existing
3978 message; let the minibuffer contents show.
3980 usage: (message-box FORMAT-STRING &rest ARGS) */)
3981 (ptrdiff_t nargs
, Lisp_Object
*args
)
3990 Lisp_Object val
= Fformat_message (nargs
, args
);
3991 Lisp_Object pane
, menu
;
3993 pane
= list1 (Fcons (build_string ("OK"), Qt
));
3994 menu
= Fcons (val
, pane
);
3995 Fx_popup_dialog (Qt
, menu
, Qt
);
4000 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
4001 doc
: /* Display a message in a dialog box or in the echo area.
4002 If this command was invoked with the mouse, use a dialog box if
4003 `use-dialog-box' is non-nil.
4004 Otherwise, use the echo area.
4005 The first argument is a format control string, and the rest are data
4006 to be formatted under control of the string. See `format-message' for
4009 If the first argument is nil or the empty string, clear any existing
4010 message; let the minibuffer contents show.
4012 usage: (message-or-box FORMAT-STRING &rest ARGS) */)
4013 (ptrdiff_t nargs
, Lisp_Object
*args
)
4015 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
4017 return Fmessage_box (nargs
, args
);
4018 return Fmessage (nargs
, args
);
4021 DEFUN ("current-message", Fcurrent_message
, Scurrent_message
, 0, 0, 0,
4022 doc
: /* Return the string currently displayed in the echo area, or nil if none. */)
4025 return current_message ();
4029 DEFUN ("propertize", Fpropertize
, Spropertize
, 1, MANY
, 0,
4030 doc
: /* Return a copy of STRING with text properties added.
4031 First argument is the string to copy.
4032 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
4033 properties to add to the result.
4034 usage: (propertize STRING &rest PROPERTIES) */)
4035 (ptrdiff_t nargs
, Lisp_Object
*args
)
4037 Lisp_Object properties
, string
;
4040 /* Number of args must be odd. */
4041 if ((nargs
& 1) == 0)
4042 error ("Wrong number of arguments");
4044 properties
= string
= Qnil
;
4046 /* First argument must be a string. */
4047 CHECK_STRING (args
[0]);
4048 string
= Fcopy_sequence (args
[0]);
4050 for (i
= 1; i
< nargs
; i
+= 2)
4051 properties
= Fcons (args
[i
], Fcons (args
[i
+ 1], properties
));
4053 Fadd_text_properties (make_number (0),
4054 make_number (SCHARS (string
)),
4055 properties
, string
);
4059 /* Convert the prefix of STR from ASCII decimal digits to a number.
4060 Set *STR_END to the address of the first non-digit. Return the
4061 number, or PTRDIFF_MAX on overflow. Return 0 if there is no number.
4062 This is like strtol for ptrdiff_t and base 10 and C locale,
4063 except without negative numbers or errno. */
4066 str2num (char *str
, char **str_end
)
4069 for (; c_isdigit (*str
); str
++)
4070 if (INT_MULTIPLY_WRAPV (n
, 10, &n
) || INT_ADD_WRAPV (n
, *str
- '0', &n
))
4076 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
4077 doc
: /* Format a string out of a format-string and arguments.
4078 The first argument is a format control string.
4079 The other arguments are substituted into it to make the result, a string.
4081 The format control string may contain %-sequences meaning to substitute
4082 the next available argument, or the argument explicitly specified:
4084 %s means print a string argument. Actually, prints any object, with `princ'.
4085 %d means print as signed number in decimal.
4086 %o means print as unsigned number in octal, %x as unsigned number in hex.
4087 %X is like %x, but uses upper case.
4088 %e means print a number in exponential notation.
4089 %f means print a number in decimal-point notation.
4090 %g means print a number in exponential notation if the exponent would be
4091 less than -4 or greater than or equal to the precision (default: 6);
4092 otherwise it prints in decimal-point notation.
4093 %c means print a number as a single character.
4094 %S means print any object as an s-expression (using `prin1').
4096 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
4097 Use %% to put a single % into the output.
4099 A %-sequence other than %% may contain optional field number, flag,
4100 width, and precision specifiers, as follows:
4102 %<field><flags><width><precision>character
4104 where field is [0-9]+ followed by a literal dollar "$", flags is
4105 [+ #-0]+, width is [0-9]+, and precision is a literal period "."
4108 If a %-sequence is numbered with a field with positive value N, the
4109 Nth argument is substituted instead of the next one. A format can
4110 contain either numbered or unnumbered %-sequences but not both, except
4111 that %% can be mixed with numbered %-sequences.
4113 The + flag character inserts a + before any positive number, while a
4114 space inserts a space before any positive number; these flags only
4115 affect %d, %e, %f, and %g sequences, and the + flag takes precedence.
4116 The - and 0 flags affect the width specifier, as described below.
4118 The # flag means to use an alternate display form for %o, %x, %X, %e,
4119 %f, and %g sequences: for %o, it ensures that the result begins with
4120 \"0\"; for %x and %X, it prefixes the result with \"0x\" or \"0X\";
4121 for %e and %f, it causes a decimal point to be included even if the
4122 precision is zero; for %g, it causes a decimal point to be
4123 included even if the precision is zero, and also forces trailing
4124 zeros after the decimal point to be left in place.
4126 The width specifier supplies a lower limit for the length of the
4127 printed representation. The padding, if any, normally goes on the
4128 left, but it goes on the right if the - flag is present. The padding
4129 character is normally a space, but it is 0 if the 0 flag is present.
4130 The 0 flag is ignored if the - flag is present, or the format sequence
4131 is something other than %d, %e, %f, and %g.
4133 For %e and %f sequences, the number after the "." in the precision
4134 specifier says how many decimal places to show; if zero, the decimal
4135 point itself is omitted. For %g, the precision specifies how many
4136 significant digits to print; zero or omitted are treated as 1.
4137 For %s and %S, the precision specifier truncates the string to the
4140 Text properties, if any, are copied from the format-string to the
4143 usage: (format STRING &rest OBJECTS) */)
4144 (ptrdiff_t nargs
, Lisp_Object
*args
)
4146 return styled_format (nargs
, args
, false);
4149 DEFUN ("format-message", Fformat_message
, Sformat_message
, 1, MANY
, 0,
4150 doc
: /* Format a string out of a format-string and arguments.
4151 The first argument is a format control string.
4152 The other arguments are substituted into it to make the result, a string.
4154 This acts like `format', except it also replaces each grave accent (\\=`)
4155 by a left quote, and each apostrophe (\\=') by a right quote. The left
4156 and right quote replacement characters are specified by
4157 `text-quoting-style'.
4159 usage: (format-message STRING &rest OBJECTS) */)
4160 (ptrdiff_t nargs
, Lisp_Object
*args
)
4162 return styled_format (nargs
, args
, true);
4165 /* Implement ‘format-message’ if MESSAGE is true, ‘format’ otherwise. */
4168 styled_format (ptrdiff_t nargs
, Lisp_Object
*args
, bool message
)
4170 ptrdiff_t n
; /* The number of the next arg to substitute. */
4171 char initial_buffer
[4000];
4172 char *buf
= initial_buffer
;
4173 ptrdiff_t bufsize
= sizeof initial_buffer
;
4174 ptrdiff_t max_bufsize
= STRING_BYTES_BOUND
+ 1;
4176 ptrdiff_t buf_save_value_index UNINIT
;
4179 /* When we make a multibyte string, we must pay attention to the
4180 byte combining problem, i.e., a byte may be combined with a
4181 multibyte character of the previous string. This flag tells if we
4182 must consider such a situation or not. */
4183 bool maybe_combine_byte
;
4185 bool arg_intervals
= false;
4187 sa_avail
-= sizeof initial_buffer
;
4189 /* Information recorded for each format spec. */
4192 /* The corresponding argument, converted to string if conversion
4194 Lisp_Object argument
;
4196 /* The start and end bytepos in the output string. */
4197 ptrdiff_t start
, end
;
4199 /* Whether the argument is a string with intervals. */
4200 bool_bf intervals
: 1;
4203 CHECK_STRING (args
[0]);
4204 char *format_start
= SSDATA (args
[0]);
4205 bool multibyte_format
= STRING_MULTIBYTE (args
[0]);
4206 ptrdiff_t formatlen
= SBYTES (args
[0]);
4208 /* Upper bound on number of format specs. Each uses at least 2 chars. */
4209 ptrdiff_t nspec_bound
= SCHARS (args
[0]) >> 1;
4211 /* Allocate the info and discarded tables. */
4212 ptrdiff_t info_size
, alloca_size
;
4213 if (INT_MULTIPLY_WRAPV (nspec_bound
, sizeof *info
, &info_size
)
4214 || INT_ADD_WRAPV (formatlen
, info_size
, &alloca_size
)
4215 || SIZE_MAX
< alloca_size
)
4216 memory_full (SIZE_MAX
);
4217 info
= SAFE_ALLOCA (alloca_size
);
4218 /* discarded[I] is 1 if byte I of the format
4219 string was not copied into the output.
4220 It is 2 if byte I was not the first byte of its character. */
4221 char *discarded
= (char *) &info
[nspec_bound
];
4222 info
= ptr_bounds_clip (info
, info_size
);
4223 discarded
= ptr_bounds_clip (discarded
, formatlen
);
4224 memset (discarded
, 0, formatlen
);
4226 /* Try to determine whether the result should be multibyte.
4227 This is not always right; sometimes the result needs to be multibyte
4228 because of an object that we will pass through prin1.
4229 or because a grave accent or apostrophe is requoted,
4230 and in that case, we won't know it here. */
4232 /* True if the output should be a multibyte string,
4233 which is true if any of the inputs is one. */
4234 bool multibyte
= multibyte_format
;
4235 for (ptrdiff_t i
= 1; !multibyte
&& i
< nargs
; i
++)
4236 if (STRINGP (args
[i
]) && STRING_MULTIBYTE (args
[i
]))
4239 int quoting_style
= message
? text_quoting_style () : -1;
4242 ptrdiff_t nspec
= 0;
4244 /* True if a string needs to be allocated to hold the result. */
4245 bool new_result
= false;
4247 /* If we start out planning a unibyte result,
4248 then discover it has to be multibyte, we jump back to retry. */
4254 /* N is the argument index, ISPEC is the specification index. */
4258 /* Scan the format and store result in BUF. */
4259 format
= format_start
;
4260 end
= format
+ formatlen
;
4261 maybe_combine_byte
= false;
4263 while (format
!= end
)
4265 /* The values of N, ISPEC, and FORMAT when the loop body is
4268 ptrdiff_t ispec0
= ispec
;
4269 char *format0
= format
;
4270 char const *convsrc
= format
;
4271 unsigned char format_char
= *format
++;
4273 /* Bytes needed to represent the output of this conversion. */
4274 ptrdiff_t convbytes
= 1;
4276 if (format_char
== '%')
4278 /* General format specifications look like
4280 '%' [field-number] [flags] [field-width] [precision] format
4284 field-number ::= [0-9]+ '$'
4286 field-width ::= [0-9]+
4287 precision ::= '.' [0-9]*
4289 If present, a field-number specifies the argument number
4290 to substitute. Otherwise, the next argument is taken.
4292 If a field-width is specified, it specifies to which width
4293 the output should be padded with blanks, if the output
4294 string is shorter than field-width.
4296 If precision is specified, it specifies the number of
4297 digits to print after the '.' for floats, or the max.
4298 number of chars to print from a string. */
4302 if (c_isdigit (*format
))
4304 num
= str2num (format
, &num_end
);
4305 if (*num_end
== '$')
4308 format
= num_end
+ 1;
4312 bool minus_flag
= false;
4313 bool plus_flag
= false;
4314 bool space_flag
= false;
4315 bool sharp_flag
= false;
4316 bool zero_flag
= false;
4322 case '-': minus_flag
= true; continue;
4323 case '+': plus_flag
= true; continue;
4324 case ' ': space_flag
= true; continue;
4325 case '#': sharp_flag
= true; continue;
4326 case '0': zero_flag
= true; continue;
4331 /* Ignore flags when sprintf ignores them. */
4332 space_flag
&= ! plus_flag
;
4333 zero_flag
&= ! minus_flag
;
4335 num
= str2num (format
, &num_end
);
4336 if (max_bufsize
<= num
)
4338 ptrdiff_t field_width
= num
;
4340 bool precision_given
= *num_end
== '.';
4341 ptrdiff_t precision
= (precision_given
4342 ? str2num (num_end
+ 1, &num_end
)
4347 error ("Format string ends in middle of format specifier");
4349 char conversion
= *format
++;
4350 memset (&discarded
[format0
- format_start
], 1,
4351 format
- format0
- (conversion
== '%'));
4352 if (conversion
== '%')
4360 error ("Not enough arguments for format string");
4362 struct info
*spec
= &info
[ispec
++];
4365 spec
->argument
= args
[n
];
4366 spec
->intervals
= false;
4369 Lisp_Object arg
= spec
->argument
;
4371 /* For 'S', prin1 the argument, and then treat like 's'.
4372 For 's', princ any argument that is not a string or
4373 symbol. But don't do this conversion twice, which might
4374 happen after retrying. */
4375 if ((conversion
== 'S'
4376 || (conversion
== 's'
4377 && ! STRINGP (arg
) && ! SYMBOLP (arg
))))
4379 if (EQ (arg
, args
[n
]))
4381 Lisp_Object noescape
= conversion
== 'S' ? Qnil
: Qt
;
4382 spec
->argument
= arg
= Fprin1_to_string (arg
, noescape
);
4383 if (STRING_MULTIBYTE (arg
) && ! multibyte
)
4391 else if (conversion
== 'c')
4393 if (INTEGERP (arg
) && ! ASCII_CHAR_P (XINT (arg
)))
4400 spec
->argument
= arg
= Fchar_to_string (arg
);
4403 if (!EQ (arg
, args
[n
]))
4410 spec
->argument
= arg
= SYMBOL_NAME (arg
);
4411 if (STRING_MULTIBYTE (arg
) && ! multibyte
)
4418 bool float_conversion
4419 = conversion
== 'e' || conversion
== 'f' || conversion
== 'g';
4421 if (conversion
== 's')
4423 if (format
== end
&& format
- format_start
== 2
4424 && ! string_intervals (args
[0]))
4430 /* handle case (precision[n] >= 0) */
4432 ptrdiff_t prec
= -1;
4433 if (precision_given
)
4436 /* lisp_string_width ignores a precision of 0, but GNU
4437 libc functions print 0 characters when the precision
4438 is 0. Imitate libc behavior here. Changing
4439 lisp_string_width is the right thing, and will be
4440 done, but meanwhile we work with it. */
4442 ptrdiff_t width
, nbytes
;
4443 ptrdiff_t nchars_string
;
4445 width
= nchars_string
= nbytes
= 0;
4449 width
= lisp_string_width (arg
, prec
, &nch
, &nby
);
4452 nchars_string
= SCHARS (arg
);
4453 nbytes
= SBYTES (arg
);
4457 nchars_string
= nch
;
4463 if (convbytes
&& multibyte
&& ! STRING_MULTIBYTE (arg
))
4464 convbytes
= count_size_as_multibyte (SDATA (arg
), nbytes
);
4467 = width
< field_width
? field_width
- width
: 0;
4469 if (max_bufsize
- padding
<= convbytes
)
4471 convbytes
+= padding
;
4472 if (convbytes
<= buf
+ bufsize
- p
)
4476 memset (p
, ' ', padding
);
4480 spec
->start
= nchars
;
4484 && !ASCII_CHAR_P (*((unsigned char *) p
- 1))
4485 && STRING_MULTIBYTE (arg
)
4486 && !CHAR_HEAD_P (SREF (arg
, 0)))
4487 maybe_combine_byte
= true;
4489 p
+= copy_text (SDATA (arg
), (unsigned char *) p
,
4491 STRING_MULTIBYTE (arg
), multibyte
);
4493 nchars
+= nchars_string
;
4497 memset (p
, ' ', padding
);
4503 /* If this argument has text properties, record where
4504 in the result string it appears. */
4505 if (string_intervals (arg
))
4506 spec
->intervals
= arg_intervals
= true;
4512 else if (! (conversion
== 'c' || conversion
== 'd'
4513 || float_conversion
|| conversion
== 'i'
4514 || conversion
== 'o' || conversion
== 'x'
4515 || conversion
== 'X'))
4516 error ("Invalid format operation %%%c",
4517 STRING_CHAR ((unsigned char *) format
- 1));
4518 else if (! (INTEGERP (arg
) || (FLOATP (arg
) && conversion
!= 'c')))
4519 error ("Format specifier doesn't match argument type");
4524 /* Lower bound on the number of bits per
4525 base-FLT_RADIX digit. */
4526 DIG_BITS_LBOUND
= FLT_RADIX
< 16 ? 1 : 4,
4528 /* 1 if integers should be formatted as long doubles,
4529 because they may be so large that there is a rounding
4530 error when converting them to double, and long doubles
4531 are wider than doubles. */
4532 INT_AS_LDBL
= (DIG_BITS_LBOUND
* DBL_MANT_DIG
< FIXNUM_BITS
- 1
4533 && DBL_MANT_DIG
< LDBL_MANT_DIG
),
4535 /* Maximum precision for a %f conversion such that the
4536 trailing output digit might be nonzero. Any precision
4537 larger than this will not yield useful information. */
4538 USEFUL_PRECISION_MAX
=
4540 * (FLT_RADIX
== 2 || FLT_RADIX
== 10 ? 1
4541 : FLT_RADIX
== 16 ? 4
4544 /* Maximum number of bytes generated by any format, if
4545 precision is no more than USEFUL_PRECISION_MAX.
4546 On all practical hosts, %f is the worst case. */
4548 sizeof "-." + (LDBL_MAX_10_EXP
+ 1) + USEFUL_PRECISION_MAX
,
4550 /* Length of pM (that is, of pMd without the
4552 pMlen
= sizeof pMd
- 2
4554 verify (USEFUL_PRECISION_MAX
> 0);
4556 /* Avoid undefined behavior in underlying sprintf. */
4557 if (conversion
== 'd' || conversion
== 'i')
4560 /* Create the copy of the conversion specification, with
4561 any width and precision removed, with ".*" inserted,
4562 with "L" possibly inserted for floating-point formats,
4563 and with pM inserted for integer formats.
4564 At most two flags F can be specified at once. */
4565 char convspec
[sizeof "%FF.*d" + max (INT_AS_LDBL
, pMlen
)];
4569 /* MINUS_FLAG and ZERO_FLAG are dealt with later. */
4570 *f
= '+'; f
+= plus_flag
;
4571 *f
= ' '; f
+= space_flag
;
4572 *f
= '#'; f
+= sharp_flag
;
4575 if (float_conversion
)
4580 f
+= INTEGERP (arg
);
4583 else if (conversion
!= 'c')
4585 memcpy (f
, pMd
, pMlen
);
4587 zero_flag
&= ! precision_given
;
4594 if (precision_given
)
4595 prec
= min (precision
, USEFUL_PRECISION_MAX
);
4597 /* Use sprintf to format this number into sprintf_buf. Omit
4598 padding and excess precision, though, because sprintf limits
4599 output length to INT_MAX.
4601 There are four types of conversion: double, unsigned
4602 char (passed as int), wide signed int, and wide
4603 unsigned int. Treat them separately because the
4604 sprintf ABI is sensitive to which type is passed. Be
4605 careful about integer overflow, NaNs, infinities, and
4606 conversions; for example, the min and max macros are
4607 not suitable here. */
4608 char sprintf_buf
[SPRINTF_BUFSIZE
];
4609 ptrdiff_t sprintf_bytes
;
4610 if (float_conversion
)
4612 if (INT_AS_LDBL
&& INTEGERP (arg
))
4614 /* Although long double may have a rounding error if
4615 DIG_BITS_LBOUND * LDBL_MANT_DIG < FIXNUM_BITS - 1,
4616 it is more accurate than plain 'double'. */
4617 long double x
= XINT (arg
);
4618 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4621 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
,
4624 else if (conversion
== 'c')
4626 /* Don't use sprintf here, as it might mishandle prec. */
4627 sprintf_buf
[0] = XINT (arg
);
4628 sprintf_bytes
= prec
!= 0;
4629 sprintf_buf
[sprintf_bytes
] = '\0';
4631 else if (conversion
== 'd' || conversion
== 'i')
4633 /* For float, maybe we should use "%1.0f"
4634 instead so it also works for values outside
4635 the integer range. */
4641 double d
= XFLOAT_DATA (arg
);
4644 x
= TYPE_MINIMUM (printmax_t
);
4650 x
= TYPE_MAXIMUM (printmax_t
);
4655 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4659 /* Don't sign-extend for octal or hex printing. */
4665 double d
= XFLOAT_DATA (arg
);
4670 x
= TYPE_MAXIMUM (uprintmax_t
);
4675 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4678 /* Now the length of the formatted item is known, except it omits
4679 padding and excess precision. Deal with excess precision
4680 first. This happens only when the format specifies
4681 ridiculously large precision. */
4682 ptrdiff_t excess_precision
4683 = precision_given
? precision
- prec
: 0;
4684 ptrdiff_t leading_zeros
= 0, trailing_zeros
= 0;
4685 if (excess_precision
)
4687 if (float_conversion
)
4689 if ((conversion
== 'g' && ! sharp_flag
)
4690 || ! ('0' <= sprintf_buf
[sprintf_bytes
- 1]
4691 && sprintf_buf
[sprintf_bytes
- 1] <= '9'))
4692 excess_precision
= 0;
4695 if (conversion
== 'g')
4697 char *dot
= strchr (sprintf_buf
, '.');
4699 excess_precision
= 0;
4702 trailing_zeros
= excess_precision
;
4705 leading_zeros
= excess_precision
;
4708 /* Compute the total bytes needed for this item, including
4709 excess precision and padding. */
4711 if (INT_ADD_WRAPV (sprintf_bytes
, excess_precision
, &numwidth
))
4712 numwidth
= PTRDIFF_MAX
;
4714 = numwidth
< field_width
? field_width
- numwidth
: 0;
4715 if (max_bufsize
- sprintf_bytes
<= excess_precision
4716 || max_bufsize
- padding
<= numwidth
)
4718 convbytes
= numwidth
+ padding
;
4720 if (convbytes
<= buf
+ bufsize
- p
)
4722 /* Copy the formatted item from sprintf_buf into buf,
4723 inserting padding and excess-precision zeros. */
4725 char *src
= sprintf_buf
;
4727 int exponent_bytes
= 0;
4728 bool signedp
= src0
== '-' || src0
== '+' || src0
== ' ';
4729 int prefix_bytes
= (signedp
4730 + ((src
[signedp
] == '0'
4731 && (src
[signedp
+ 1] == 'x'
4732 || src
[signedp
+ 1] == 'X'))
4736 unsigned char after_prefix
= src
[prefix_bytes
];
4737 if (0 <= char_hexdigit (after_prefix
))
4739 leading_zeros
+= padding
;
4744 if (excess_precision
4745 && (conversion
== 'e' || conversion
== 'g'))
4747 char *e
= strchr (src
, 'e');
4749 exponent_bytes
= src
+ sprintf_bytes
- e
;
4752 spec
->start
= nchars
;
4755 memset (p
, ' ', padding
);
4760 memcpy (p
, src
, prefix_bytes
);
4762 src
+= prefix_bytes
;
4763 memset (p
, '0', leading_zeros
);
4765 int significand_bytes
4766 = sprintf_bytes
- prefix_bytes
- exponent_bytes
;
4767 memcpy (p
, src
, significand_bytes
);
4768 p
+= significand_bytes
;
4769 src
+= significand_bytes
;
4770 memset (p
, '0', trailing_zeros
);
4771 p
+= trailing_zeros
;
4772 memcpy (p
, src
, exponent_bytes
);
4773 p
+= exponent_bytes
;
4775 nchars
+= leading_zeros
+ sprintf_bytes
+ trailing_zeros
;
4779 memset (p
, ' ', padding
);
4792 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
4794 if ((format_char
== '`' || format_char
== '\'')
4795 && quoting_style
== CURVE_QUOTING_STYLE
)
4802 convsrc
= format_char
== '`' ? uLSQM
: uRSQM
;
4806 else if (format_char
== '`' && quoting_style
== STRAIGHT_QUOTING_STYLE
)
4813 /* Copy a single character from format to buf. */
4814 if (multibyte_format
)
4816 /* Copy a whole multibyte character. */
4818 && !ASCII_CHAR_P (*((unsigned char *) p
- 1))
4819 && !CHAR_HEAD_P (format_char
))
4820 maybe_combine_byte
= true;
4822 while (! CHAR_HEAD_P (*format
))
4825 convbytes
= format
- format0
;
4826 memset (&discarded
[format0
+ 1 - format_start
], 2,
4829 else if (multibyte
&& !ASCII_CHAR_P (format_char
))
4831 int c
= BYTE8_TO_CHAR (format_char
);
4832 convbytes
= CHAR_STRING (c
, str
);
4833 convsrc
= (char *) str
;
4839 if (convbytes
<= buf
+ bufsize
- p
)
4841 memcpy (p
, convsrc
, convbytes
);
4848 /* There wasn't enough room to store this conversion or single
4849 character. CONVBYTES says how much room is needed. Allocate
4850 enough room (and then some) and do it again. */
4852 ptrdiff_t used
= p
- buf
;
4853 if (max_bufsize
- used
< convbytes
)
4855 bufsize
= used
+ convbytes
;
4856 bufsize
= bufsize
< max_bufsize
/ 2 ? bufsize
* 2 : max_bufsize
;
4858 if (buf
== initial_buffer
)
4860 buf
= xmalloc (bufsize
);
4861 sa_must_free
= true;
4862 buf_save_value_index
= SPECPDL_INDEX ();
4863 record_unwind_protect_ptr (xfree
, buf
);
4864 memcpy (buf
, initial_buffer
, used
);
4868 buf
= xrealloc (buf
, bufsize
);
4869 set_unwind_protect_ptr (buf_save_value_index
, xfree
, buf
);
4878 if (bufsize
< p
- buf
)
4887 if (maybe_combine_byte
)
4888 nchars
= multibyte_chars_in_text ((unsigned char *) buf
, p
- buf
);
4889 val
= make_specified_string (buf
, nchars
, p
- buf
, multibyte
);
4891 /* If the format string has text properties, or any of the string
4892 arguments has text properties, set up text properties of the
4895 if (string_intervals (args
[0]) || arg_intervals
)
4897 /* Add text properties from the format string. */
4898 Lisp_Object len
= make_number (SCHARS (args
[0]));
4899 Lisp_Object props
= text_property_list (args
[0], make_number (0),
4903 ptrdiff_t bytepos
= 0, position
= 0, translated
= 0;
4904 ptrdiff_t fieldn
= 0;
4906 /* Adjust the bounds of each text property
4907 to the proper start and end in the output string. */
4909 /* Put the positions in PROPS in increasing order, so that
4910 we can do (effectively) one scan through the position
4911 space of the format string. */
4912 props
= Fnreverse (props
);
4914 /* BYTEPOS is the byte position in the format string,
4915 POSITION is the untranslated char position in it,
4916 TRANSLATED is the translated char position in BUF,
4917 and ARGN is the number of the next arg we will come to. */
4918 for (Lisp_Object list
= props
; CONSP (list
); list
= XCDR (list
))
4920 Lisp_Object item
= XCAR (list
);
4922 /* First adjust the property start position. */
4923 ptrdiff_t pos
= XINT (XCAR (item
));
4925 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
4926 up to this position. */
4927 for (; position
< pos
; bytepos
++)
4929 if (! discarded
[bytepos
])
4930 position
++, translated
++;
4931 else if (discarded
[bytepos
] == 1)
4934 if (fieldn
< nspec
&& translated
== info
[fieldn
].start
)
4936 translated
+= info
[fieldn
].end
- info
[fieldn
].start
;
4942 XSETCAR (item
, make_number (translated
));
4944 /* Likewise adjust the property end position. */
4945 pos
= XINT (XCAR (XCDR (item
)));
4947 for (; position
< pos
; bytepos
++)
4949 if (! discarded
[bytepos
])
4950 position
++, translated
++;
4951 else if (discarded
[bytepos
] == 1)
4954 if (fieldn
< nspec
&& translated
== info
[fieldn
].start
)
4956 translated
+= info
[fieldn
].end
- info
[fieldn
].start
;
4962 XSETCAR (XCDR (item
), make_number (translated
));
4965 add_text_properties_from_list (val
, props
, make_number (0));
4968 /* Add text properties from arguments. */
4970 for (ptrdiff_t i
= 0; i
< nspec
; i
++)
4971 if (info
[i
].intervals
)
4973 len
= make_number (SCHARS (info
[i
].argument
));
4974 Lisp_Object new_len
= make_number (info
[i
].end
- info
[i
].start
);
4975 props
= text_property_list (info
[i
].argument
,
4976 make_number (0), len
, Qnil
);
4977 props
= extend_property_ranges (props
, len
, new_len
);
4978 /* If successive arguments have properties, be sure that
4979 the value of `composition' property be the copy. */
4980 if (1 < i
&& info
[i
- 1].end
)
4981 make_composition_value_copy (props
);
4982 add_text_properties_from_list (val
, props
,
4983 make_number (info
[i
].start
));
4988 /* If we allocated BUF or INFO with malloc, free it too. */
4994 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
4995 doc
: /* Return t if two characters match, optionally ignoring case.
4996 Both arguments must be characters (i.e. integers).
4997 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
4998 (register Lisp_Object c1
, Lisp_Object c2
)
5001 /* Check they're chars, not just integers, otherwise we could get array
5002 bounds violations in downcase. */
5003 CHECK_CHARACTER (c1
);
5004 CHECK_CHARACTER (c2
);
5006 if (XINT (c1
) == XINT (c2
))
5008 if (NILP (BVAR (current_buffer
, case_fold_search
)))
5014 /* FIXME: It is possible to compare multibyte characters even when
5015 the current buffer is unibyte. Unfortunately this is ambiguous
5016 for characters between 128 and 255, as they could be either
5017 eight-bit raw bytes or Latin-1 characters. Assume the former for
5018 now. See Bug#17011, and also see casefiddle.c's casify_object,
5019 which has a similar problem. */
5020 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
5022 if (SINGLE_BYTE_CHAR_P (i1
))
5023 i1
= UNIBYTE_TO_CHAR (i1
);
5024 if (SINGLE_BYTE_CHAR_P (i2
))
5025 i2
= UNIBYTE_TO_CHAR (i2
);
5028 return (downcase (i1
) == downcase (i2
) ? Qt
: Qnil
);
5031 /* Transpose the markers in two regions of the current buffer, and
5032 adjust the ones between them if necessary (i.e.: if the regions
5035 START1, END1 are the character positions of the first region.
5036 START1_BYTE, END1_BYTE are the byte positions.
5037 START2, END2 are the character positions of the second region.
5038 START2_BYTE, END2_BYTE are the byte positions.
5040 Traverses the entire marker list of the buffer to do so, adding an
5041 appropriate amount to some, subtracting from some, and leaving the
5042 rest untouched. Most of this is copied from adjust_markers in insdel.c.
5044 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
5047 transpose_markers (ptrdiff_t start1
, ptrdiff_t end1
,
5048 ptrdiff_t start2
, ptrdiff_t end2
,
5049 ptrdiff_t start1_byte
, ptrdiff_t end1_byte
,
5050 ptrdiff_t start2_byte
, ptrdiff_t end2_byte
)
5052 register ptrdiff_t amt1
, amt1_byte
, amt2
, amt2_byte
, diff
, diff_byte
, mpos
;
5053 register struct Lisp_Marker
*marker
;
5055 /* Update point as if it were a marker. */
5059 TEMP_SET_PT_BOTH (PT
+ (end2
- end1
),
5060 PT_BYTE
+ (end2_byte
- end1_byte
));
5061 else if (PT
< start2
)
5062 TEMP_SET_PT_BOTH (PT
+ (end2
- start2
) - (end1
- start1
),
5063 (PT_BYTE
+ (end2_byte
- start2_byte
)
5064 - (end1_byte
- start1_byte
)));
5066 TEMP_SET_PT_BOTH (PT
- (start2
- start1
),
5067 PT_BYTE
- (start2_byte
- start1_byte
));
5069 /* We used to adjust the endpoints here to account for the gap, but that
5070 isn't good enough. Even if we assume the caller has tried to move the
5071 gap out of our way, it might still be at start1 exactly, for example;
5072 and that places it `inside' the interval, for our purposes. The amount
5073 of adjustment is nontrivial if there's a `denormalized' marker whose
5074 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
5075 the dirty work to Fmarker_position, below. */
5077 /* The difference between the region's lengths */
5078 diff
= (end2
- start2
) - (end1
- start1
);
5079 diff_byte
= (end2_byte
- start2_byte
) - (end1_byte
- start1_byte
);
5081 /* For shifting each marker in a region by the length of the other
5082 region plus the distance between the regions. */
5083 amt1
= (end2
- start2
) + (start2
- end1
);
5084 amt2
= (end1
- start1
) + (start2
- end1
);
5085 amt1_byte
= (end2_byte
- start2_byte
) + (start2_byte
- end1_byte
);
5086 amt2_byte
= (end1_byte
- start1_byte
) + (start2_byte
- end1_byte
);
5088 for (marker
= BUF_MARKERS (current_buffer
); marker
; marker
= marker
->next
)
5090 mpos
= marker
->bytepos
;
5091 if (mpos
>= start1_byte
&& mpos
< end2_byte
)
5093 if (mpos
< end1_byte
)
5095 else if (mpos
< start2_byte
)
5099 marker
->bytepos
= mpos
;
5101 mpos
= marker
->charpos
;
5102 if (mpos
>= start1
&& mpos
< end2
)
5106 else if (mpos
< start2
)
5111 marker
->charpos
= mpos
;
5115 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
5116 doc
: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
5117 The regions should not be overlapping, because the size of the buffer is
5118 never changed in a transposition.
5120 Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
5121 any markers that happen to be located in the regions.
5123 Transposing beyond buffer boundaries is an error. */)
5124 (Lisp_Object startr1
, Lisp_Object endr1
, Lisp_Object startr2
, Lisp_Object endr2
, Lisp_Object leave_markers
)
5126 register ptrdiff_t start1
, end1
, start2
, end2
;
5127 ptrdiff_t start1_byte
, start2_byte
, len1_byte
, len2_byte
, end2_byte
;
5128 ptrdiff_t gap
, len1
, len_mid
, len2
;
5129 unsigned char *start1_addr
, *start2_addr
, *temp
;
5131 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
, tmp_interval3
;
5134 XSETBUFFER (buf
, current_buffer
);
5135 cur_intv
= buffer_intervals (current_buffer
);
5137 validate_region (&startr1
, &endr1
);
5138 validate_region (&startr2
, &endr2
);
5140 start1
= XFASTINT (startr1
);
5141 end1
= XFASTINT (endr1
);
5142 start2
= XFASTINT (startr2
);
5143 end2
= XFASTINT (endr2
);
5146 /* Swap the regions if they're reversed. */
5149 register ptrdiff_t glumph
= start1
;
5157 len1
= end1
- start1
;
5158 len2
= end2
- start2
;
5161 error ("Transposed regions overlap");
5162 /* Nothing to change for adjacent regions with one being empty */
5163 else if ((start1
== end1
|| start2
== end2
) && end1
== start2
)
5166 /* The possibilities are:
5167 1. Adjacent (contiguous) regions, or separate but equal regions
5168 (no, really equal, in this case!), or
5169 2. Separate regions of unequal size.
5171 The worst case is usually No. 2. It means that (aside from
5172 potential need for getting the gap out of the way), there also
5173 needs to be a shifting of the text between the two regions. So
5174 if they are spread far apart, we are that much slower... sigh. */
5176 /* It must be pointed out that the really studly thing to do would
5177 be not to move the gap at all, but to leave it in place and work
5178 around it if necessary. This would be extremely efficient,
5179 especially considering that people are likely to do
5180 transpositions near where they are working interactively, which
5181 is exactly where the gap would be found. However, such code
5182 would be much harder to write and to read. So, if you are
5183 reading this comment and are feeling squirrely, by all means have
5184 a go! I just didn't feel like doing it, so I will simply move
5185 the gap the minimum distance to get it out of the way, and then
5186 deal with an unbroken array. */
5188 start1_byte
= CHAR_TO_BYTE (start1
);
5189 end2_byte
= CHAR_TO_BYTE (end2
);
5191 /* Make sure the gap won't interfere, by moving it out of the text
5192 we will operate on. */
5193 if (start1
< gap
&& gap
< end2
)
5195 if (gap
- start1
< end2
- gap
)
5196 move_gap_both (start1
, start1_byte
);
5198 move_gap_both (end2
, end2_byte
);
5201 start2_byte
= CHAR_TO_BYTE (start2
);
5202 len1_byte
= CHAR_TO_BYTE (end1
) - start1_byte
;
5203 len2_byte
= end2_byte
- start2_byte
;
5205 #ifdef BYTE_COMBINING_DEBUG
5208 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
5209 len2_byte
, start1
, start1_byte
)
5210 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
5211 len1_byte
, end2
, start2_byte
+ len2_byte
)
5212 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
5213 len1_byte
, end2
, start2_byte
+ len2_byte
))
5218 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
5219 len2_byte
, start1
, start1_byte
)
5220 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
5221 len1_byte
, start2
, start2_byte
)
5222 || count_combining_after (BYTE_POS_ADDR (start2_byte
),
5223 len2_byte
, end1
, start1_byte
+ len1_byte
)
5224 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
5225 len1_byte
, end2
, start2_byte
+ len2_byte
))
5230 /* Hmmm... how about checking to see if the gap is large
5231 enough to use as the temporary storage? That would avoid an
5232 allocation... interesting. Later, don't fool with it now. */
5234 /* Working without memmove, for portability (sigh), so must be
5235 careful of overlapping subsections of the array... */
5237 if (end1
== start2
) /* adjacent regions */
5239 modify_text (start1
, end2
);
5240 record_change (start1
, len1
+ len2
);
5242 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
5243 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
5244 /* Don't use Fset_text_properties: that can cause GC, which can
5245 clobber objects stored in the tmp_intervals. */
5246 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
5248 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
5252 /* First region smaller than second. */
5253 if (len1_byte
< len2_byte
)
5255 temp
= SAFE_ALLOCA (len2_byte
);
5257 /* Don't precompute these addresses. We have to compute them
5258 at the last minute, because the relocating allocator might
5259 have moved the buffer around during the xmalloc. */
5260 start1_addr
= BYTE_POS_ADDR (start1_byte
);
5261 start2_addr
= BYTE_POS_ADDR (start2_byte
);
5263 memcpy (temp
, start2_addr
, len2_byte
);
5264 memcpy (start1_addr
+ len2_byte
, start1_addr
, len1_byte
);
5265 memcpy (start1_addr
, temp
, len2_byte
);
5268 /* First region not smaller than second. */
5270 temp
= SAFE_ALLOCA (len1_byte
);
5271 start1_addr
= BYTE_POS_ADDR (start1_byte
);
5272 start2_addr
= BYTE_POS_ADDR (start2_byte
);
5273 memcpy (temp
, start1_addr
, len1_byte
);
5274 memcpy (start1_addr
, start2_addr
, len2_byte
);
5275 memcpy (start1_addr
+ len2_byte
, temp
, len1_byte
);
5279 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
5280 len1
, current_buffer
, 0);
5281 graft_intervals_into_buffer (tmp_interval2
, start1
,
5282 len2
, current_buffer
, 0);
5283 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
5284 update_compositions (start1
+ len2
, end2
, CHECK_TAIL
);
5286 /* Non-adjacent regions, because end1 != start2, bleagh... */
5289 len_mid
= start2_byte
- (start1_byte
+ len1_byte
);
5291 if (len1_byte
== len2_byte
)
5292 /* Regions are same size, though, how nice. */
5296 modify_text (start1
, end2
);
5297 record_change (start1
, len1
);
5298 record_change (start2
, len2
);
5299 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
5300 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
5302 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr1
, 0);
5304 set_text_properties_1 (startr1
, endr1
, Qnil
, buf
, tmp_interval3
);
5306 tmp_interval3
= validate_interval_range (buf
, &startr2
, &endr2
, 0);
5308 set_text_properties_1 (startr2
, endr2
, Qnil
, buf
, tmp_interval3
);
5310 temp
= SAFE_ALLOCA (len1_byte
);
5311 start1_addr
= BYTE_POS_ADDR (start1_byte
);
5312 start2_addr
= BYTE_POS_ADDR (start2_byte
);
5313 memcpy (temp
, start1_addr
, len1_byte
);
5314 memcpy (start1_addr
, start2_addr
, len2_byte
);
5315 memcpy (start2_addr
, temp
, len1_byte
);
5318 graft_intervals_into_buffer (tmp_interval1
, start2
,
5319 len1
, current_buffer
, 0);
5320 graft_intervals_into_buffer (tmp_interval2
, start1
,
5321 len2
, current_buffer
, 0);
5324 else if (len1_byte
< len2_byte
) /* Second region larger than first */
5325 /* Non-adjacent & unequal size, area between must also be shifted. */
5329 modify_text (start1
, end2
);
5330 record_change (start1
, (end2
- start1
));
5331 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
5332 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
5333 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
5335 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
5337 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
5339 /* holds region 2 */
5340 temp
= SAFE_ALLOCA (len2_byte
);
5341 start1_addr
= BYTE_POS_ADDR (start1_byte
);
5342 start2_addr
= BYTE_POS_ADDR (start2_byte
);
5343 memcpy (temp
, start2_addr
, len2_byte
);
5344 memcpy (start1_addr
+ len_mid
+ len2_byte
, start1_addr
, len1_byte
);
5345 memmove (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
5346 memcpy (start1_addr
, temp
, len2_byte
);
5349 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
5350 len1
, current_buffer
, 0);
5351 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
5352 len_mid
, current_buffer
, 0);
5353 graft_intervals_into_buffer (tmp_interval2
, start1
,
5354 len2
, current_buffer
, 0);
5357 /* Second region smaller than first. */
5361 record_change (start1
, (end2
- start1
));
5362 modify_text (start1
, end2
);
5364 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
5365 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
5366 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
5368 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
5370 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
5372 /* holds region 1 */
5373 temp
= SAFE_ALLOCA (len1_byte
);
5374 start1_addr
= BYTE_POS_ADDR (start1_byte
);
5375 start2_addr
= BYTE_POS_ADDR (start2_byte
);
5376 memcpy (temp
, start1_addr
, len1_byte
);
5377 memcpy (start1_addr
, start2_addr
, len2_byte
);
5378 memmove (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
5379 memcpy (start1_addr
+ len2_byte
+ len_mid
, temp
, len1_byte
);
5382 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
5383 len1
, current_buffer
, 0);
5384 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
5385 len_mid
, current_buffer
, 0);
5386 graft_intervals_into_buffer (tmp_interval2
, start1
,
5387 len2
, current_buffer
, 0);
5390 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
5391 update_compositions (end2
- len1
, end2
, CHECK_BORDER
);
5394 /* When doing multiple transpositions, it might be nice
5395 to optimize this. Perhaps the markers in any one buffer
5396 should be organized in some sorted data tree. */
5397 if (NILP (leave_markers
))
5399 transpose_markers (start1
, end1
, start2
, end2
,
5400 start1_byte
, start1_byte
+ len1_byte
,
5401 start2_byte
, start2_byte
+ len2_byte
);
5402 fix_start_end_in_overlays (start1
, end2
);
5406 /* The character positions of the markers remain intact, but we
5407 still need to update their byte positions, because the
5408 transposed regions might include multibyte sequences which
5409 make some original byte positions of the markers invalid. */
5410 adjust_markers_bytepos (start1
, start1_byte
, end2
, end2_byte
, 0);
5413 signal_after_change (start1
, end2
- start1
, end2
- start1
);
5419 syms_of_editfns (void)
5421 DEFSYM (Qbuffer_access_fontify_functions
, "buffer-access-fontify-functions");
5422 DEFSYM (Qwall
, "wall");
5424 DEFVAR_LISP ("inhibit-field-text-motion", Vinhibit_field_text_motion
,
5425 doc
: /* Non-nil means text motion commands don't notice fields. */);
5426 Vinhibit_field_text_motion
= Qnil
;
5428 DEFVAR_LISP ("buffer-access-fontify-functions",
5429 Vbuffer_access_fontify_functions
,
5430 doc
: /* List of functions called by `buffer-substring' to fontify if necessary.
5431 Each function is called with two arguments which specify the range
5432 of the buffer being accessed. */);
5433 Vbuffer_access_fontify_functions
= Qnil
;
5437 obuf
= Fcurrent_buffer ();
5438 /* Do this here, because init_buffer_once is too early--it won't work. */
5439 Fset_buffer (Vprin1_to_string_buffer
);
5440 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
5441 Fset (Fmake_local_variable (Qbuffer_access_fontify_functions
), Qnil
);
5445 DEFVAR_LISP ("buffer-access-fontified-property",
5446 Vbuffer_access_fontified_property
,
5447 doc
: /* Property which (if non-nil) indicates text has been fontified.
5448 `buffer-substring' need not call the `buffer-access-fontify-functions'
5449 functions if all the text being accessed has this property. */);
5450 Vbuffer_access_fontified_property
= Qnil
;
5452 DEFVAR_LISP ("system-name", Vsystem_name
,
5453 doc
: /* The host name of the machine Emacs is running on. */);
5454 Vsystem_name
= cached_system_name
= Qnil
;
5456 DEFVAR_LISP ("user-full-name", Vuser_full_name
,
5457 doc
: /* The full name of the user logged in. */);
5459 DEFVAR_LISP ("user-login-name", Vuser_login_name
,
5460 doc
: /* The user's name, taken from environment variables if possible. */);
5461 Vuser_login_name
= Qnil
;
5463 DEFVAR_LISP ("user-real-login-name", Vuser_real_login_name
,
5464 doc
: /* The user's name, based upon the real uid only. */);
5466 DEFVAR_LISP ("operating-system-release", Voperating_system_release
,
5467 doc
: /* The release of the operating system Emacs is running on. */);
5469 defsubr (&Spropertize
);
5470 defsubr (&Schar_equal
);
5471 defsubr (&Sgoto_char
);
5472 defsubr (&Sstring_to_char
);
5473 defsubr (&Schar_to_string
);
5474 defsubr (&Sbyte_to_string
);
5475 defsubr (&Sbuffer_substring
);
5476 defsubr (&Sbuffer_substring_no_properties
);
5477 defsubr (&Sbuffer_string
);
5478 defsubr (&Sget_pos_property
);
5480 defsubr (&Spoint_marker
);
5481 defsubr (&Smark_marker
);
5483 defsubr (&Sregion_beginning
);
5484 defsubr (&Sregion_end
);
5486 /* Symbol for the text property used to mark fields. */
5487 DEFSYM (Qfield
, "field");
5489 /* A special value for Qfield properties. */
5490 DEFSYM (Qboundary
, "boundary");
5492 defsubr (&Sfield_beginning
);
5493 defsubr (&Sfield_end
);
5494 defsubr (&Sfield_string
);
5495 defsubr (&Sfield_string_no_properties
);
5496 defsubr (&Sdelete_field
);
5497 defsubr (&Sconstrain_to_field
);
5499 defsubr (&Sline_beginning_position
);
5500 defsubr (&Sline_end_position
);
5502 defsubr (&Ssave_excursion
);
5503 defsubr (&Ssave_current_buffer
);
5505 defsubr (&Sbuffer_size
);
5506 defsubr (&Spoint_max
);
5507 defsubr (&Spoint_min
);
5508 defsubr (&Spoint_min_marker
);
5509 defsubr (&Spoint_max_marker
);
5510 defsubr (&Sgap_position
);
5511 defsubr (&Sgap_size
);
5512 defsubr (&Sposition_bytes
);
5513 defsubr (&Sbyte_to_position
);
5519 defsubr (&Sfollowing_char
);
5520 defsubr (&Sprevious_char
);
5521 defsubr (&Schar_after
);
5522 defsubr (&Schar_before
);
5524 defsubr (&Sinsert_before_markers
);
5525 defsubr (&Sinsert_and_inherit
);
5526 defsubr (&Sinsert_and_inherit_before_markers
);
5527 defsubr (&Sinsert_char
);
5528 defsubr (&Sinsert_byte
);
5530 defsubr (&Suser_login_name
);
5531 defsubr (&Suser_real_login_name
);
5532 defsubr (&Suser_uid
);
5533 defsubr (&Suser_real_uid
);
5534 defsubr (&Sgroup_gid
);
5535 defsubr (&Sgroup_real_gid
);
5536 defsubr (&Suser_full_name
);
5537 defsubr (&Semacs_pid
);
5538 defsubr (&Scurrent_time
);
5539 defsubr (&Stime_add
);
5540 defsubr (&Stime_subtract
);
5541 defsubr (&Stime_less_p
);
5542 defsubr (&Sget_internal_run_time
);
5543 defsubr (&Sformat_time_string
);
5544 defsubr (&Sfloat_time
);
5545 defsubr (&Sdecode_time
);
5546 defsubr (&Sencode_time
);
5547 defsubr (&Scurrent_time_string
);
5548 defsubr (&Scurrent_time_zone
);
5549 defsubr (&Sset_time_zone_rule
);
5550 defsubr (&Ssystem_name
);
5551 defsubr (&Smessage
);
5552 defsubr (&Smessage_box
);
5553 defsubr (&Smessage_or_box
);
5554 defsubr (&Scurrent_message
);
5556 defsubr (&Sformat_message
);
5558 defsubr (&Sinsert_buffer_substring
);
5559 defsubr (&Scompare_buffer_substrings
);
5560 defsubr (&Sreplace_buffer_contents
);
5561 defsubr (&Ssubst_char_in_region
);
5562 defsubr (&Stranslate_region_internal
);
5563 defsubr (&Sdelete_region
);
5564 defsubr (&Sdelete_and_extract_region
);
5566 defsubr (&Snarrow_to_region
);
5567 defsubr (&Ssave_restriction
);
5568 defsubr (&Stranspose_regions
);