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 "character.h"
63 #include "blockinput.h"
65 #define TM_YEAR_BASE 1900
68 extern Lisp_Object
w32_get_internal_run_time (void);
71 static struct lisp_time
lisp_time_struct (Lisp_Object
, int *);
72 static Lisp_Object
format_time_string (char const *, ptrdiff_t, struct timespec
,
73 Lisp_Object
, struct tm
*);
74 static long int tm_gmtoff (struct tm
*);
75 static int tm_diff (struct tm
*, struct tm
*);
76 static void update_buffer_properties (ptrdiff_t, ptrdiff_t);
77 static Lisp_Object
styled_format (ptrdiff_t, Lisp_Object
*, bool);
79 #ifndef HAVE_TM_GMTOFF
80 # define HAVE_TM_GMTOFF false
83 enum { tzeqlen
= sizeof "TZ=" - 1 };
85 /* Time zones equivalent to current local time and to UTC, respectively. */
86 static timezone_t local_tz
;
87 static timezone_t
const utc_tz
= 0;
89 /* The cached value of Vsystem_name. This is used only to compare it
90 to Vsystem_name, so it need not be visible to the GC. */
91 static Lisp_Object cached_system_name
;
94 init_and_cache_system_name (void)
97 cached_system_name
= Vsystem_name
;
101 emacs_localtime_rz (timezone_t tz
, time_t const *t
, struct tm
*tm
)
103 tm
= localtime_rz (tz
, t
, tm
);
104 if (!tm
&& errno
== ENOMEM
)
105 memory_full (SIZE_MAX
);
110 emacs_mktime_z (timezone_t tz
, struct tm
*tm
)
113 time_t t
= mktime_z (tz
, tm
);
114 if (t
== (time_t) -1 && errno
== ENOMEM
)
115 memory_full (SIZE_MAX
);
119 /* Allocate a timezone, signaling on failure. */
121 xtzalloc (char const *name
)
123 timezone_t tz
= tzalloc (name
);
125 memory_full (SIZE_MAX
);
129 /* Free a timezone, except do not free the time zone for local time.
130 Freeing utc_tz is also a no-op. */
132 xtzfree (timezone_t tz
)
138 /* Convert the Lisp time zone rule ZONE to a timezone_t object.
139 The returned value either is 0, or is LOCAL_TZ, or is newly allocated.
140 If SETTZ, set Emacs local time to the time zone rule; otherwise,
141 the caller should eventually pass the returned value to xtzfree. */
143 tzlookup (Lisp_Object zone
, bool settz
)
145 static char const tzbuf_format
[] = "<%+.*"pI
"d>%s%"pI
"d:%02d:%02d";
146 char const *trailing_tzbuf_format
= tzbuf_format
+ sizeof "<%+.*"pI
"d" - 1;
147 char tzbuf
[sizeof tzbuf_format
+ 2 * INT_STRLEN_BOUND (EMACS_INT
)];
148 char const *zone_string
;
153 else if (EQ (zone
, Qt
))
155 zone_string
= "UTC0";
160 bool plain_integer
= INTEGERP (zone
);
162 if (EQ (zone
, Qwall
))
164 else if (STRINGP (zone
))
165 zone_string
= SSDATA (ENCODE_SYSTEM (zone
));
166 else if (plain_integer
|| (CONSP (zone
) && INTEGERP (XCAR (zone
))
167 && CONSP (XCDR (zone
))))
172 abbr
= XCAR (XCDR (zone
));
176 EMACS_INT abszone
= eabs (XINT (zone
)), hour
= abszone
/ (60 * 60);
177 int hour_remainder
= abszone
% (60 * 60);
178 int min
= hour_remainder
/ 60, sec
= hour_remainder
% 60;
183 EMACS_INT numzone
= hour
;
184 if (hour_remainder
!= 0)
186 prec
+= 2, numzone
= 100 * numzone
+ min
;
188 prec
+= 2, numzone
= 100 * numzone
+ sec
;
190 sprintf (tzbuf
, tzbuf_format
, prec
,
191 XINT (zone
) < 0 ? -numzone
: numzone
,
192 &"-"[XINT (zone
) < 0], hour
, min
, sec
);
197 AUTO_STRING (leading
, "<");
198 AUTO_STRING_WITH_LEN (trailing
, tzbuf
,
199 sprintf (tzbuf
, trailing_tzbuf_format
,
200 &"-"[XINT (zone
) < 0],
202 zone_string
= SSDATA (concat3 (leading
, ENCODE_SYSTEM (abbr
),
207 xsignal2 (Qerror
, build_string ("Invalid time zone specification"),
209 new_tz
= xtzalloc (zone_string
);
215 emacs_setenv_TZ (zone_string
);
217 timezone_t old_tz
= local_tz
;
227 init_editfns (bool dumping
)
229 #if !defined CANNOT_DUMP
230 /* A valid but unlikely setting for the TZ environment variable.
231 It is OK (though a bit slower) if the user chooses this value. */
232 static char dump_tz_string
[] = "TZ=UtC0";
235 const char *user_name
;
237 struct passwd
*pw
; /* password entry for the current user */
240 /* Set up system_name even when dumping. */
241 init_and_cache_system_name ();
244 /* When just dumping out, set the time zone to a known unlikely value
245 and skip the rest of this function. */
248 xputenv (dump_tz_string
);
254 char *tz
= getenv ("TZ");
256 #if !defined CANNOT_DUMP
257 /* If the execution TZ happens to be the same as the dump TZ,
258 change it to some other value and then change it back,
259 to force the underlying implementation to reload the TZ info.
260 This is needed on implementations that load TZ info from files,
261 since the TZ file contents may differ between dump and execution. */
262 if (tz
&& strcmp (tz
, &dump_tz_string
[tzeqlen
]) == 0)
270 /* Set the time zone rule now, so that the call to putenv is done
271 before multiple threads are active. */
272 tzlookup (tz
? build_string (tz
) : Qwall
, true);
274 pw
= getpwuid (getuid ());
276 /* We let the real user name default to "root" because that's quite
277 accurate on MS-DOS and because it lets Emacs find the init file.
278 (The DVX libraries override the Djgpp libraries here.) */
279 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "root");
281 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "unknown");
284 /* Get the effective user name, by consulting environment variables,
285 or the effective uid if those are unset. */
286 user_name
= getenv ("LOGNAME");
289 user_name
= getenv ("USERNAME"); /* it's USERNAME on NT */
290 #else /* WINDOWSNT */
291 user_name
= getenv ("USER");
292 #endif /* WINDOWSNT */
295 pw
= getpwuid (geteuid ());
296 user_name
= pw
? pw
->pw_name
: "unknown";
298 Vuser_login_name
= build_string (user_name
);
300 /* If the user name claimed in the environment vars differs from
301 the real uid, use the claimed name to find the full name. */
302 tem
= Fstring_equal (Vuser_login_name
, Vuser_real_login_name
);
304 tem
= Vuser_login_name
;
307 uid_t euid
= geteuid ();
308 tem
= make_fixnum_or_float (euid
);
310 Vuser_full_name
= Fuser_full_name (tem
);
314 Vuser_full_name
= build_string (p
);
315 else if (NILP (Vuser_full_name
))
316 Vuser_full_name
= build_string ("unknown");
318 #ifdef HAVE_SYS_UTSNAME_H
322 Voperating_system_release
= build_string (uts
.release
);
325 Voperating_system_release
= Qnil
;
329 DEFUN ("char-to-string", Fchar_to_string
, Schar_to_string
, 1, 1, 0,
330 doc
: /* Convert arg CHAR to a string containing that character.
331 usage: (char-to-string CHAR) */)
332 (Lisp_Object character
)
335 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
337 CHECK_CHARACTER (character
);
338 c
= XFASTINT (character
);
340 len
= CHAR_STRING (c
, str
);
341 return make_string_from_bytes ((char *) str
, 1, len
);
344 DEFUN ("byte-to-string", Fbyte_to_string
, Sbyte_to_string
, 1, 1, 0,
345 doc
: /* Convert arg BYTE to a unibyte string containing that byte. */)
350 if (XINT (byte
) < 0 || XINT (byte
) > 255)
351 error ("Invalid byte");
353 return make_string_from_bytes ((char *) &b
, 1, 1);
356 DEFUN ("string-to-char", Fstring_to_char
, Sstring_to_char
, 1, 1, 0,
357 doc
: /* Return the first character in STRING. */)
358 (register Lisp_Object string
)
360 register Lisp_Object val
;
361 CHECK_STRING (string
);
364 if (STRING_MULTIBYTE (string
))
365 XSETFASTINT (val
, STRING_CHAR (SDATA (string
)));
367 XSETFASTINT (val
, SREF (string
, 0));
370 XSETFASTINT (val
, 0);
374 DEFUN ("point", Fpoint
, Spoint
, 0, 0, 0,
375 doc
: /* Return value of point, as an integer.
376 Beginning of buffer is position (point-min). */)
380 XSETFASTINT (temp
, PT
);
384 DEFUN ("point-marker", Fpoint_marker
, Spoint_marker
, 0, 0, 0,
385 doc
: /* Return value of point, as a marker object. */)
388 return build_marker (current_buffer
, PT
, PT_BYTE
);
391 DEFUN ("goto-char", Fgoto_char
, Sgoto_char
, 1, 1, "NGoto char: ",
392 doc
: /* Set point to POSITION, a number or marker.
393 Beginning of buffer is position (point-min), end is (point-max).
395 The return value is POSITION. */)
396 (register Lisp_Object position
)
398 if (MARKERP (position
))
399 set_point_from_marker (position
);
400 else if (INTEGERP (position
))
401 SET_PT (clip_to_bounds (BEGV
, XINT (position
), ZV
));
403 wrong_type_argument (Qinteger_or_marker_p
, position
);
408 /* Return the start or end position of the region.
409 BEGINNINGP means return the start.
410 If there is no region active, signal an error. */
413 region_limit (bool beginningp
)
417 if (!NILP (Vtransient_mark_mode
)
418 && NILP (Vmark_even_if_inactive
)
419 && NILP (BVAR (current_buffer
, mark_active
)))
420 xsignal0 (Qmark_inactive
);
422 m
= Fmarker_position (BVAR (current_buffer
, mark
));
424 error ("The mark is not set now, so there is no region");
426 /* Clip to the current narrowing (bug#11770). */
427 return make_number ((PT
< XFASTINT (m
)) == beginningp
429 : clip_to_bounds (BEGV
, XFASTINT (m
), ZV
));
432 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
433 doc
: /* Return the integer value of point or mark, whichever is smaller. */)
436 return region_limit (1);
439 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
440 doc
: /* Return the integer value of point or mark, whichever is larger. */)
443 return region_limit (0);
446 DEFUN ("mark-marker", Fmark_marker
, Smark_marker
, 0, 0, 0,
447 doc
: /* Return this buffer's mark, as a marker object.
448 Watch out! Moving this marker changes the mark position.
449 If you set the marker not to point anywhere, the buffer will have no mark. */)
452 return BVAR (current_buffer
, mark
);
456 /* Find all the overlays in the current buffer that touch position POS.
457 Return the number found, and store them in a vector in VEC
461 overlays_around (EMACS_INT pos
, Lisp_Object
*vec
, ptrdiff_t len
)
463 Lisp_Object overlay
, start
, end
;
464 struct Lisp_Overlay
*tail
;
465 ptrdiff_t startpos
, endpos
;
468 for (tail
= current_buffer
->overlays_before
; tail
; tail
= tail
->next
)
470 XSETMISC (overlay
, tail
);
472 end
= OVERLAY_END (overlay
);
473 endpos
= OVERLAY_POSITION (end
);
476 start
= OVERLAY_START (overlay
);
477 startpos
= OVERLAY_POSITION (start
);
482 /* Keep counting overlays even if we can't return them all. */
487 for (tail
= current_buffer
->overlays_after
; tail
; tail
= tail
->next
)
489 XSETMISC (overlay
, tail
);
491 start
= OVERLAY_START (overlay
);
492 startpos
= OVERLAY_POSITION (start
);
495 end
= OVERLAY_END (overlay
);
496 endpos
= OVERLAY_POSITION (end
);
508 DEFUN ("get-pos-property", Fget_pos_property
, Sget_pos_property
, 2, 3, 0,
509 doc
: /* Return the value of POSITION's property PROP, in OBJECT.
510 Almost identical to `get-char-property' except for the following difference:
511 Whereas `get-char-property' returns the property of the char at (i.e. right
512 after) POSITION, this pays attention to properties's stickiness and overlays's
513 advancement settings, in order to find the property of POSITION itself,
514 i.e. the property that a char would inherit if it were inserted
516 (Lisp_Object position
, register Lisp_Object prop
, Lisp_Object object
)
518 CHECK_NUMBER_COERCE_MARKER (position
);
521 XSETBUFFER (object
, current_buffer
);
522 else if (WINDOWP (object
))
523 object
= XWINDOW (object
)->contents
;
525 if (!BUFFERP (object
))
526 /* pos-property only makes sense in buffers right now, since strings
527 have no overlays and no notion of insertion for which stickiness
529 return Fget_text_property (position
, prop
, object
);
532 EMACS_INT posn
= XINT (position
);
534 Lisp_Object
*overlay_vec
, tem
;
535 struct buffer
*obuf
= current_buffer
;
538 set_buffer_temp (XBUFFER (object
));
540 /* First try with room for 40 overlays. */
541 Lisp_Object overlay_vecbuf
[40];
542 noverlays
= ARRAYELTS (overlay_vecbuf
);
543 overlay_vec
= overlay_vecbuf
;
544 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
546 /* If there are more than 40,
547 make enough space for all, and try again. */
548 if (ARRAYELTS (overlay_vecbuf
) < noverlays
)
550 SAFE_ALLOCA_LISP (overlay_vec
, noverlays
);
551 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
553 noverlays
= sort_overlays (overlay_vec
, noverlays
, NULL
);
555 set_buffer_temp (obuf
);
557 /* Now check the overlays in order of decreasing priority. */
558 while (--noverlays
>= 0)
560 Lisp_Object ol
= overlay_vec
[noverlays
];
561 tem
= Foverlay_get (ol
, prop
);
564 /* Check the overlay is indeed active at point. */
565 Lisp_Object start
= OVERLAY_START (ol
), finish
= OVERLAY_END (ol
);
566 if ((OVERLAY_POSITION (start
) == posn
567 && XMARKER (start
)->insertion_type
== 1)
568 || (OVERLAY_POSITION (finish
) == posn
569 && XMARKER (finish
)->insertion_type
== 0))
570 ; /* The overlay will not cover a char inserted at point. */
580 { /* Now check the text properties. */
581 int stickiness
= text_property_stickiness (prop
, position
, object
);
583 return Fget_text_property (position
, prop
, object
);
584 else if (stickiness
< 0
585 && XINT (position
) > BUF_BEGV (XBUFFER (object
)))
586 return Fget_text_property (make_number (XINT (position
) - 1),
594 /* Find the field surrounding POS in *BEG and *END. If POS is nil,
595 the value of point is used instead. If BEG or END is null,
596 means don't store the beginning or end of the field.
598 BEG_LIMIT and END_LIMIT serve to limit the ranged of the returned
599 results; they do not effect boundary behavior.
601 If MERGE_AT_BOUNDARY is non-nil, then if POS is at the very first
602 position of a field, then the beginning of the previous field is
603 returned instead of the beginning of POS's field (since the end of a
604 field is actually also the beginning of the next input field, this
605 behavior is sometimes useful). Additionally in the MERGE_AT_BOUNDARY
606 non-nil case, if two fields are separated by a field with the special
607 value `boundary', and POS lies within it, then the two separated
608 fields are considered to be adjacent, and POS between them, when
609 finding the beginning and ending of the "merged" field.
611 Either BEG or END may be 0, in which case the corresponding value
615 find_field (Lisp_Object pos
, Lisp_Object merge_at_boundary
,
616 Lisp_Object beg_limit
,
617 ptrdiff_t *beg
, Lisp_Object end_limit
, ptrdiff_t *end
)
619 /* Fields right before and after the point. */
620 Lisp_Object before_field
, after_field
;
621 /* True if POS counts as the start of a field. */
622 bool at_field_start
= 0;
623 /* True if POS counts as the end of a field. */
624 bool at_field_end
= 0;
627 XSETFASTINT (pos
, PT
);
629 CHECK_NUMBER_COERCE_MARKER (pos
);
632 = get_char_property_and_overlay (pos
, Qfield
, Qnil
, NULL
);
634 = (XFASTINT (pos
) > BEGV
635 ? get_char_property_and_overlay (make_number (XINT (pos
) - 1),
637 /* Using nil here would be a more obvious choice, but it would
638 fail when the buffer starts with a non-sticky field. */
641 /* See if we need to handle the case where MERGE_AT_BOUNDARY is nil
642 and POS is at beginning of a field, which can also be interpreted
643 as the end of the previous field. Note that the case where if
644 MERGE_AT_BOUNDARY is non-nil (see function comment) is actually the
645 more natural one; then we avoid treating the beginning of a field
647 if (NILP (merge_at_boundary
))
649 Lisp_Object field
= Fget_pos_property (pos
, Qfield
, Qnil
);
650 if (!EQ (field
, after_field
))
652 if (!EQ (field
, before_field
))
654 if (NILP (field
) && at_field_start
&& at_field_end
)
655 /* If an inserted char would have a nil field while the surrounding
656 text is non-nil, we're probably not looking at a
657 zero-length field, but instead at a non-nil field that's
658 not intended for editing (such as comint's prompts). */
659 at_field_end
= at_field_start
= 0;
662 /* Note about special `boundary' fields:
664 Consider the case where the point (`.') is between the fields `x' and `y':
668 In this situation, if merge_at_boundary is non-nil, consider the
669 `x' and `y' fields as forming one big merged field, and so the end
670 of the field is the end of `y'.
672 However, if `x' and `y' are separated by a special `boundary' field
673 (a field with a `field' char-property of 'boundary), then ignore
674 this special field when merging adjacent fields. Here's the same
675 situation, but with a `boundary' field between the `x' and `y' fields:
679 Here, if point is at the end of `x', the beginning of `y', or
680 anywhere in-between (within the `boundary' field), merge all
681 three fields and consider the beginning as being the beginning of
682 the `x' field, and the end as being the end of the `y' field. */
687 /* POS is at the edge of a field, and we should consider it as
688 the beginning of the following field. */
689 *beg
= XFASTINT (pos
);
691 /* Find the previous field boundary. */
694 if (!NILP (merge_at_boundary
) && EQ (before_field
, Qboundary
))
695 /* Skip a `boundary' field. */
696 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
699 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
701 *beg
= NILP (p
) ? BEGV
: XFASTINT (p
);
708 /* POS is at the edge of a field, and we should consider it as
709 the end of the previous field. */
710 *end
= XFASTINT (pos
);
712 /* Find the next field boundary. */
714 if (!NILP (merge_at_boundary
) && EQ (after_field
, Qboundary
))
715 /* Skip a `boundary' field. */
716 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
719 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
721 *end
= NILP (pos
) ? ZV
: XFASTINT (pos
);
727 DEFUN ("delete-field", Fdelete_field
, Sdelete_field
, 0, 1, 0,
728 doc
: /* Delete the field surrounding POS.
729 A field is a region of text with the same `field' property.
730 If POS is nil, the value of point is used for POS. */)
734 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
736 del_range (beg
, end
);
740 DEFUN ("field-string", Ffield_string
, Sfield_string
, 0, 1, 0,
741 doc
: /* Return the contents of the field surrounding POS as a string.
742 A field is a region of text with the same `field' property.
743 If POS is nil, the value of point is used for POS. */)
747 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
748 return make_buffer_string (beg
, end
, 1);
751 DEFUN ("field-string-no-properties", Ffield_string_no_properties
, Sfield_string_no_properties
, 0, 1, 0,
752 doc
: /* Return the contents of the field around POS, without text properties.
753 A field is a region of text with the same `field' property.
754 If POS is nil, the value of point is used for POS. */)
758 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
759 return make_buffer_string (beg
, end
, 0);
762 DEFUN ("field-beginning", Ffield_beginning
, Sfield_beginning
, 0, 3, 0,
763 doc
: /* Return the beginning of the field surrounding POS.
764 A field is a region of text with the same `field' property.
765 If POS is nil, the value of point is used for POS.
766 If ESCAPE-FROM-EDGE is non-nil and POS is at the beginning of its
767 field, then the beginning of the *previous* field is returned.
768 If LIMIT is non-nil, it is a buffer position; if the beginning of the field
769 is before LIMIT, then LIMIT will be returned instead. */)
770 (Lisp_Object pos
, Lisp_Object escape_from_edge
, Lisp_Object limit
)
773 find_field (pos
, escape_from_edge
, limit
, &beg
, Qnil
, 0);
774 return make_number (beg
);
777 DEFUN ("field-end", Ffield_end
, Sfield_end
, 0, 3, 0,
778 doc
: /* Return the end of the field surrounding POS.
779 A field is a region of text with the same `field' property.
780 If POS is nil, the value of point is used for POS.
781 If ESCAPE-FROM-EDGE is non-nil and POS is at the end of its field,
782 then the end of the *following* field is returned.
783 If LIMIT is non-nil, it is a buffer position; if the end of the field
784 is after LIMIT, then LIMIT will be returned instead. */)
785 (Lisp_Object pos
, Lisp_Object escape_from_edge
, Lisp_Object limit
)
788 find_field (pos
, escape_from_edge
, Qnil
, 0, limit
, &end
);
789 return make_number (end
);
792 DEFUN ("constrain-to-field", Fconstrain_to_field
, Sconstrain_to_field
, 2, 5, 0,
793 doc
: /* Return the position closest to NEW-POS that is in the same field as OLD-POS.
794 A field is a region of text with the same `field' property.
796 If NEW-POS is nil, then use the current point instead, and move point
797 to the resulting constrained position, in addition to returning that
800 If OLD-POS is at the boundary of two fields, then the allowable
801 positions for NEW-POS depends on the value of the optional argument
802 ESCAPE-FROM-EDGE: If ESCAPE-FROM-EDGE is nil, then NEW-POS is
803 constrained to the field that has the same `field' char-property
804 as any new characters inserted at OLD-POS, whereas if ESCAPE-FROM-EDGE
805 is non-nil, NEW-POS is constrained to the union of the two adjacent
806 fields. Additionally, if two fields are separated by another field with
807 the special value `boundary', then any point within this special field is
808 also considered to be `on the boundary'.
810 If the optional argument ONLY-IN-LINE is non-nil and constraining
811 NEW-POS would move it to a different line, NEW-POS is returned
812 unconstrained. This is useful for commands that move by line, like
813 \\[next-line] or \\[beginning-of-line], which should generally respect field boundaries
814 only in the case where they can still move to the right line.
816 If the optional argument INHIBIT-CAPTURE-PROPERTY is non-nil, and OLD-POS has
817 a non-nil property of that name, then any field boundaries are ignored.
819 Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
820 (Lisp_Object new_pos
, Lisp_Object old_pos
, Lisp_Object escape_from_edge
,
821 Lisp_Object only_in_line
, Lisp_Object inhibit_capture_property
)
823 /* If non-zero, then the original point, before re-positioning. */
824 ptrdiff_t orig_point
= 0;
826 Lisp_Object prev_old
, prev_new
;
829 /* Use the current point, and afterwards, set it. */
832 XSETFASTINT (new_pos
, PT
);
835 CHECK_NUMBER_COERCE_MARKER (new_pos
);
836 CHECK_NUMBER_COERCE_MARKER (old_pos
);
838 fwd
= (XINT (new_pos
) > XINT (old_pos
));
840 prev_old
= make_number (XINT (old_pos
) - 1);
841 prev_new
= make_number (XINT (new_pos
) - 1);
843 if (NILP (Vinhibit_field_text_motion
)
844 && !EQ (new_pos
, old_pos
)
845 && (!NILP (Fget_char_property (new_pos
, Qfield
, Qnil
))
846 || !NILP (Fget_char_property (old_pos
, Qfield
, Qnil
))
847 /* To recognize field boundaries, we must also look at the
848 previous positions; we could use `Fget_pos_property'
849 instead, but in itself that would fail inside non-sticky
850 fields (like comint prompts). */
851 || (XFASTINT (new_pos
) > BEGV
852 && !NILP (Fget_char_property (prev_new
, Qfield
, Qnil
)))
853 || (XFASTINT (old_pos
) > BEGV
854 && !NILP (Fget_char_property (prev_old
, Qfield
, Qnil
))))
855 && (NILP (inhibit_capture_property
)
856 /* Field boundaries are again a problem; but now we must
857 decide the case exactly, so we need to call
858 `get_pos_property' as well. */
859 || (NILP (Fget_pos_property (old_pos
, inhibit_capture_property
, Qnil
))
860 && (XFASTINT (old_pos
) <= BEGV
861 || NILP (Fget_char_property
862 (old_pos
, inhibit_capture_property
, Qnil
))
863 || NILP (Fget_char_property
864 (prev_old
, inhibit_capture_property
, Qnil
))))))
865 /* It is possible that NEW_POS is not within the same field as
866 OLD_POS; try to move NEW_POS so that it is. */
869 Lisp_Object field_bound
;
872 field_bound
= Ffield_end (old_pos
, escape_from_edge
, new_pos
);
874 field_bound
= Ffield_beginning (old_pos
, escape_from_edge
, new_pos
);
876 if (/* See if ESCAPE_FROM_EDGE caused FIELD_BOUND to jump to the
877 other side of NEW_POS, which would mean that NEW_POS is
878 already acceptable, and it's not necessary to constrain it
880 ((XFASTINT (field_bound
) < XFASTINT (new_pos
)) ? fwd
: !fwd
)
881 /* NEW_POS should be constrained, but only if either
882 ONLY_IN_LINE is nil (in which case any constraint is OK),
883 or NEW_POS and FIELD_BOUND are on the same line (in which
884 case the constraint is OK even if ONLY_IN_LINE is non-nil). */
885 && (NILP (only_in_line
)
886 /* This is the ONLY_IN_LINE case, check that NEW_POS and
887 FIELD_BOUND are on the same line by seeing whether
888 there's an intervening newline or not. */
889 || (find_newline (XFASTINT (new_pos
), -1,
890 XFASTINT (field_bound
), -1,
891 fwd
? -1 : 1, &shortage
, NULL
, 1),
893 /* Constrain NEW_POS to FIELD_BOUND. */
894 new_pos
= field_bound
;
896 if (orig_point
&& XFASTINT (new_pos
) != orig_point
)
897 /* The NEW_POS argument was originally nil, so automatically set PT. */
898 SET_PT (XFASTINT (new_pos
));
905 DEFUN ("line-beginning-position",
906 Fline_beginning_position
, Sline_beginning_position
, 0, 1, 0,
907 doc
: /* Return the character position of the first character on the current line.
908 With optional argument N, scan forward N - 1 lines first.
909 If the scan reaches the end of the buffer, return that position.
911 This function ignores text display directionality; it returns the
912 position of the first character in logical order, i.e. the smallest
913 character position on the line.
915 This function constrains the returned position to the current field
916 unless that position would be on a different line than the original,
917 unconstrained result. If N is nil or 1, and a front-sticky field
918 starts at point, the scan stops as soon as it starts. To ignore field
919 boundaries, bind `inhibit-field-text-motion' to t.
921 This function does not move point. */)
924 ptrdiff_t charpos
, bytepos
;
931 scan_newline_from_point (XINT (n
) - 1, &charpos
, &bytepos
);
933 /* Return END constrained to the current input field. */
934 return Fconstrain_to_field (make_number (charpos
), make_number (PT
),
935 XINT (n
) != 1 ? Qt
: Qnil
,
939 DEFUN ("line-end-position", Fline_end_position
, Sline_end_position
, 0, 1, 0,
940 doc
: /* Return the character position of the last character on the current line.
941 With argument N not nil or 1, move forward N - 1 lines first.
942 If scan reaches end of buffer, return that position.
944 This function ignores text display directionality; it returns the
945 position of the last character in logical order, i.e. the largest
946 character position on the line.
948 This function constrains the returned position to the current field
949 unless that would be on a different line than the original,
950 unconstrained result. If N is nil or 1, and a rear-sticky field ends
951 at point, the scan stops as soon as it starts. To ignore field
952 boundaries bind `inhibit-field-text-motion' to t.
954 This function does not move point. */)
966 clipped_n
= clip_to_bounds (PTRDIFF_MIN
+ 1, XINT (n
), PTRDIFF_MAX
);
967 end_pos
= find_before_next_newline (orig
, 0, clipped_n
- (clipped_n
<= 0),
970 /* Return END_POS constrained to the current input field. */
971 return Fconstrain_to_field (make_number (end_pos
), make_number (orig
),
975 /* Save current buffer state for `save-excursion' special form.
976 We (ab)use Lisp_Misc_Save_Value to allow explicit free and so
977 offload some work from GC. */
980 save_excursion_save (void)
982 return make_save_obj_obj_obj_obj
985 /* Selected window if current buffer is shown in it, nil otherwise. */
986 (EQ (XWINDOW (selected_window
)->contents
, Fcurrent_buffer ())
987 ? selected_window
: Qnil
),
991 /* Restore saved buffer before leaving `save-excursion' special form. */
994 save_excursion_restore (Lisp_Object info
)
996 Lisp_Object tem
, tem1
;
998 tem
= Fmarker_buffer (XSAVE_OBJECT (info
, 0));
999 /* If we're unwinding to top level, saved buffer may be deleted. This
1000 means that all of its markers are unchained and so tem is nil. */
1007 tem
= XSAVE_OBJECT (info
, 0);
1009 unchain_marker (XMARKER (tem
));
1011 /* If buffer was visible in a window, and a different window was
1012 selected, and the old selected window is still showing this
1013 buffer, restore point in that window. */
1014 tem
= XSAVE_OBJECT (info
, 2);
1016 && !EQ (tem
, selected_window
)
1017 && (tem1
= XWINDOW (tem
)->contents
,
1018 (/* Window is live... */
1020 /* ...and it shows the current buffer. */
1021 && XBUFFER (tem1
) == current_buffer
)))
1022 Fset_window_point (tem
, make_number (PT
));
1029 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
1030 doc
: /* Save point, and current buffer; execute BODY; restore those things.
1031 Executes BODY just like `progn'.
1032 The values of point and the current buffer are restored
1033 even in case of abnormal exit (throw or error).
1035 If you only want to save the current buffer but not point,
1036 then just use `save-current-buffer', or even `with-current-buffer'.
1038 Before Emacs 25.1, `save-excursion' used to save the mark state.
1039 To save the marker state as well as the point and buffer, use
1040 `save-mark-and-excursion'.
1042 usage: (save-excursion &rest BODY) */)
1045 register Lisp_Object val
;
1046 ptrdiff_t count
= SPECPDL_INDEX ();
1048 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
1050 val
= Fprogn (args
);
1051 return unbind_to (count
, val
);
1054 DEFUN ("save-current-buffer", Fsave_current_buffer
, Ssave_current_buffer
, 0, UNEVALLED
, 0,
1055 doc
: /* Record which buffer is current; execute BODY; make that buffer current.
1056 BODY is executed just like `progn'.
1057 usage: (save-current-buffer &rest BODY) */)
1060 ptrdiff_t count
= SPECPDL_INDEX ();
1062 record_unwind_current_buffer ();
1063 return unbind_to (count
, Fprogn (args
));
1066 DEFUN ("buffer-size", Fbuffer_size
, Sbuffer_size
, 0, 1, 0,
1067 doc
: /* Return the number of characters in the current buffer.
1068 If BUFFER is not nil, return the number of characters in that buffer
1071 This does not take narrowing into account; to count the number of
1072 characters in the accessible portion of the current buffer, use
1073 `(- (point-max) (point-min))', and to count the number of characters
1074 in some other BUFFER, use
1075 `(with-current-buffer BUFFER (- (point-max) (point-min)))'. */)
1076 (Lisp_Object buffer
)
1079 return make_number (Z
- BEG
);
1082 CHECK_BUFFER (buffer
);
1083 return make_number (BUF_Z (XBUFFER (buffer
))
1084 - BUF_BEG (XBUFFER (buffer
)));
1088 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
1089 doc
: /* Return the minimum permissible value of point in the current buffer.
1090 This is 1, unless narrowing (a buffer restriction) is in effect. */)
1094 XSETFASTINT (temp
, BEGV
);
1098 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
1099 doc
: /* Return a marker to the minimum permissible value of point in this buffer.
1100 This is the beginning, unless narrowing (a buffer restriction) is in effect. */)
1103 return build_marker (current_buffer
, BEGV
, BEGV_BYTE
);
1106 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
1107 doc
: /* Return the maximum permissible value of point in the current buffer.
1108 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1109 is in effect, in which case it is less. */)
1113 XSETFASTINT (temp
, ZV
);
1117 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
1118 doc
: /* Return a marker to the maximum permissible value of point in this buffer.
1119 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1120 is in effect, in which case it is less. */)
1123 return build_marker (current_buffer
, ZV
, ZV_BYTE
);
1126 DEFUN ("gap-position", Fgap_position
, Sgap_position
, 0, 0, 0,
1127 doc
: /* Return the position of the gap, in the current buffer.
1128 See also `gap-size'. */)
1132 XSETFASTINT (temp
, GPT
);
1136 DEFUN ("gap-size", Fgap_size
, Sgap_size
, 0, 0, 0,
1137 doc
: /* Return the size of the current buffer's gap.
1138 See also `gap-position'. */)
1142 XSETFASTINT (temp
, GAP_SIZE
);
1146 DEFUN ("position-bytes", Fposition_bytes
, Sposition_bytes
, 1, 1, 0,
1147 doc
: /* Return the byte position for character position POSITION.
1148 If POSITION is out of range, the value is nil. */)
1149 (Lisp_Object position
)
1151 CHECK_NUMBER_COERCE_MARKER (position
);
1152 if (XINT (position
) < BEG
|| XINT (position
) > Z
)
1154 return make_number (CHAR_TO_BYTE (XINT (position
)));
1157 DEFUN ("byte-to-position", Fbyte_to_position
, Sbyte_to_position
, 1, 1, 0,
1158 doc
: /* Return the character position for byte position BYTEPOS.
1159 If BYTEPOS is out of range, the value is nil. */)
1160 (Lisp_Object bytepos
)
1164 CHECK_NUMBER (bytepos
);
1165 pos_byte
= XINT (bytepos
);
1166 if (pos_byte
< BEG_BYTE
|| pos_byte
> Z_BYTE
)
1169 /* There are multibyte characters in the buffer.
1170 The argument of BYTE_TO_CHAR must be a byte position at
1171 a character boundary, so search for the start of the current
1173 while (!CHAR_HEAD_P (FETCH_BYTE (pos_byte
)))
1175 return make_number (BYTE_TO_CHAR (pos_byte
));
1178 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
1179 doc
: /* Return the character following point, as a number.
1180 At the end of the buffer or accessible region, return 0. */)
1185 XSETFASTINT (temp
, 0);
1187 XSETFASTINT (temp
, FETCH_CHAR (PT_BYTE
));
1191 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
1192 doc
: /* Return the character preceding point, as a number.
1193 At the beginning of the buffer or accessible region, return 0. */)
1198 XSETFASTINT (temp
, 0);
1199 else if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1201 ptrdiff_t pos
= PT_BYTE
;
1203 XSETFASTINT (temp
, FETCH_CHAR (pos
));
1206 XSETFASTINT (temp
, FETCH_BYTE (PT_BYTE
- 1));
1210 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
1211 doc
: /* Return t if point is at the beginning of the buffer.
1212 If the buffer is narrowed, this means the beginning of the narrowed part. */)
1220 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
1221 doc
: /* Return t if point is at the end of the buffer.
1222 If the buffer is narrowed, this means the end of the narrowed part. */)
1230 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
1231 doc
: /* Return t if point is at the beginning of a line. */)
1234 if (PT
== BEGV
|| FETCH_BYTE (PT_BYTE
- 1) == '\n')
1239 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
1240 doc
: /* Return t if point is at the end of a line.
1241 `End of a line' includes point being at the end of the buffer. */)
1244 if (PT
== ZV
|| FETCH_BYTE (PT_BYTE
) == '\n')
1249 DEFUN ("char-after", Fchar_after
, Schar_after
, 0, 1, 0,
1250 doc
: /* Return character in current buffer at position POS.
1251 POS is an integer or a marker and defaults to point.
1252 If POS is out of range, the value is nil. */)
1255 register ptrdiff_t pos_byte
;
1260 XSETFASTINT (pos
, PT
);
1265 pos_byte
= marker_byte_position (pos
);
1266 if (pos_byte
< BEGV_BYTE
|| pos_byte
>= ZV_BYTE
)
1271 CHECK_NUMBER_COERCE_MARKER (pos
);
1272 if (XINT (pos
) < BEGV
|| XINT (pos
) >= ZV
)
1275 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1278 return make_number (FETCH_CHAR (pos_byte
));
1281 DEFUN ("char-before", Fchar_before
, Schar_before
, 0, 1, 0,
1282 doc
: /* Return character in current buffer preceding position POS.
1283 POS is an integer or a marker and defaults to point.
1284 If POS is out of range, the value is nil. */)
1287 register Lisp_Object val
;
1288 register ptrdiff_t pos_byte
;
1293 XSETFASTINT (pos
, PT
);
1298 pos_byte
= marker_byte_position (pos
);
1300 if (pos_byte
<= BEGV_BYTE
|| pos_byte
> ZV_BYTE
)
1305 CHECK_NUMBER_COERCE_MARKER (pos
);
1307 if (XINT (pos
) <= BEGV
|| XINT (pos
) > ZV
)
1310 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1313 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1316 XSETFASTINT (val
, FETCH_CHAR (pos_byte
));
1321 XSETFASTINT (val
, FETCH_BYTE (pos_byte
));
1326 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 1, 0,
1327 doc
: /* Return the name under which the user logged in, as a string.
1328 This is based on the effective uid, not the real uid.
1329 Also, if the environment variables LOGNAME or USER are set,
1330 that determines the value of this function.
1332 If optional argument UID is an integer or a float, return the login name
1333 of the user with that uid, or nil if there is no such user. */)
1339 /* Set up the user name info if we didn't do it before.
1340 (That can happen if Emacs is dumpable
1341 but you decide to run `temacs -l loadup' and not dump. */
1342 if (NILP (Vuser_login_name
))
1343 init_editfns (false);
1346 return Vuser_login_name
;
1348 CONS_TO_INTEGER (uid
, uid_t
, id
);
1352 return (pw
? build_string (pw
->pw_name
) : Qnil
);
1355 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
1357 doc
: /* Return the name of the user's real uid, as a string.
1358 This ignores the environment variables LOGNAME and USER, so it differs from
1359 `user-login-name' when running under `su'. */)
1362 /* Set up the user name info if we didn't do it before.
1363 (That can happen if Emacs is dumpable
1364 but you decide to run `temacs -l loadup' and not dump. */
1365 if (NILP (Vuser_login_name
))
1366 init_editfns (false);
1367 return Vuser_real_login_name
;
1370 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
1371 doc
: /* Return the effective uid of Emacs.
1372 Value is an integer or a float, depending on the value. */)
1375 uid_t euid
= geteuid ();
1376 return make_fixnum_or_float (euid
);
1379 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
1380 doc
: /* Return the real uid of Emacs.
1381 Value is an integer or a float, depending on the value. */)
1384 uid_t uid
= getuid ();
1385 return make_fixnum_or_float (uid
);
1388 DEFUN ("group-gid", Fgroup_gid
, Sgroup_gid
, 0, 0, 0,
1389 doc
: /* Return the effective gid of Emacs.
1390 Value is an integer or a float, depending on the value. */)
1393 gid_t egid
= getegid ();
1394 return make_fixnum_or_float (egid
);
1397 DEFUN ("group-real-gid", Fgroup_real_gid
, Sgroup_real_gid
, 0, 0, 0,
1398 doc
: /* Return the real gid of Emacs.
1399 Value is an integer or a float, depending on the value. */)
1402 gid_t gid
= getgid ();
1403 return make_fixnum_or_float (gid
);
1406 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 1, 0,
1407 doc
: /* Return the full name of the user logged in, as a string.
1408 If the full name corresponding to Emacs's userid is not known,
1411 If optional argument UID is an integer or float, return the full name
1412 of the user with that uid, or nil if there is no such user.
1413 If UID is a string, return the full name of the user with that login
1414 name, or nil if there is no such user. */)
1418 register char *p
, *q
;
1422 return Vuser_full_name
;
1423 else if (NUMBERP (uid
))
1426 CONS_TO_INTEGER (uid
, uid_t
, u
);
1431 else if (STRINGP (uid
))
1434 pw
= getpwnam (SSDATA (uid
));
1438 error ("Invalid UID specification");
1444 /* Chop off everything after the first comma. */
1445 q
= strchr (p
, ',');
1446 full
= make_string (p
, q
? q
- p
: strlen (p
));
1448 #ifdef AMPERSAND_FULL_NAME
1450 q
= strchr (p
, '&');
1451 /* Substitute the login name for the &, upcasing the first character. */
1454 Lisp_Object login
= Fuser_login_name (make_number (pw
->pw_uid
));
1456 char *r
= SAFE_ALLOCA (strlen (p
) + SBYTES (login
) + 1);
1457 memcpy (r
, p
, q
- p
);
1458 char *s
= lispstpcpy (&r
[q
- p
], login
);
1459 r
[q
- p
] = upcase ((unsigned char) r
[q
- p
]);
1461 full
= build_string (r
);
1464 #endif /* AMPERSAND_FULL_NAME */
1469 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
1470 doc
: /* Return the host name of the machine you are running on, as a string. */)
1473 if (EQ (Vsystem_name
, cached_system_name
))
1474 init_and_cache_system_name ();
1475 return Vsystem_name
;
1478 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
1479 doc
: /* Return the process ID of Emacs, as a number. */)
1482 pid_t pid
= getpid ();
1483 return make_fixnum_or_float (pid
);
1489 # define TIME_T_MIN TYPE_MINIMUM (time_t)
1492 # define TIME_T_MAX TYPE_MAXIMUM (time_t)
1495 /* Report that a time value is out of range for Emacs. */
1497 time_overflow (void)
1499 error ("Specified time is not representable");
1502 static _Noreturn
void
1505 error ("Invalid time specification");
1508 /* Check a return value compatible with that of decode_time_components. */
1510 check_time_validity (int validity
)
1521 /* Return the upper part of the time T (everything but the bottom 16 bits). */
1525 time_t hi
= t
>> LO_TIME_BITS
;
1526 if (FIXNUM_OVERFLOW_P (hi
))
1531 /* Return the bottom bits of the time T. */
1535 return t
& ((1 << LO_TIME_BITS
) - 1);
1538 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
1539 doc
: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
1540 The time is returned as a list of integers (HIGH LOW USEC PSEC).
1541 HIGH has the most significant bits of the seconds, while LOW has the
1542 least significant 16 bits. USEC and PSEC are the microsecond and
1543 picosecond counts. */)
1546 return make_lisp_time (current_timespec ());
1549 static struct lisp_time
1550 time_add (struct lisp_time ta
, struct lisp_time tb
)
1552 EMACS_INT hi
= ta
.hi
+ tb
.hi
;
1553 int lo
= ta
.lo
+ tb
.lo
;
1554 int us
= ta
.us
+ tb
.us
;
1555 int ps
= ta
.ps
+ tb
.ps
;
1556 us
+= (1000000 <= ps
);
1557 ps
-= (1000000 <= ps
) * 1000000;
1558 lo
+= (1000000 <= us
);
1559 us
-= (1000000 <= us
) * 1000000;
1560 hi
+= (1 << LO_TIME_BITS
<= lo
);
1561 lo
-= (1 << LO_TIME_BITS
<= lo
) << LO_TIME_BITS
;
1562 return (struct lisp_time
) { hi
, lo
, us
, ps
};
1565 static struct lisp_time
1566 time_subtract (struct lisp_time ta
, struct lisp_time tb
)
1568 EMACS_INT hi
= ta
.hi
- tb
.hi
;
1569 int lo
= ta
.lo
- tb
.lo
;
1570 int us
= ta
.us
- tb
.us
;
1571 int ps
= ta
.ps
- tb
.ps
;
1573 ps
+= (ps
< 0) * 1000000;
1575 us
+= (us
< 0) * 1000000;
1577 lo
+= (lo
< 0) << LO_TIME_BITS
;
1578 return (struct lisp_time
) { hi
, lo
, us
, ps
};
1582 time_arith (Lisp_Object a
, Lisp_Object b
,
1583 struct lisp_time (*op
) (struct lisp_time
, struct lisp_time
))
1586 struct lisp_time ta
= lisp_time_struct (a
, &alen
);
1587 struct lisp_time tb
= lisp_time_struct (b
, &blen
);
1588 struct lisp_time t
= op (ta
, tb
);
1589 if (FIXNUM_OVERFLOW_P (t
.hi
))
1591 Lisp_Object val
= Qnil
;
1593 switch (max (alen
, blen
))
1596 val
= Fcons (make_number (t
.ps
), val
);
1599 val
= Fcons (make_number (t
.us
), val
);
1602 val
= Fcons (make_number (t
.lo
), val
);
1603 val
= Fcons (make_number (t
.hi
), val
);
1610 DEFUN ("time-add", Ftime_add
, Stime_add
, 2, 2, 0,
1611 doc
: /* Return the sum of two time values A and B, as a time value.
1612 A nil value for either argument stands for the current time.
1613 See `current-time-string' for the various forms of a time value. */)
1614 (Lisp_Object a
, Lisp_Object b
)
1616 return time_arith (a
, b
, time_add
);
1619 DEFUN ("time-subtract", Ftime_subtract
, Stime_subtract
, 2, 2, 0,
1620 doc
: /* Return the difference between two time values A and B, as a time value.
1621 Use `float-time' to convert the difference into elapsed seconds.
1622 A nil value for either argument stands for the current time.
1623 See `current-time-string' for the various forms of a time value. */)
1624 (Lisp_Object a
, Lisp_Object b
)
1626 return time_arith (a
, b
, time_subtract
);
1629 DEFUN ("time-less-p", Ftime_less_p
, Stime_less_p
, 2, 2, 0,
1630 doc
: /* Return non-nil if time value T1 is earlier than time value T2.
1631 A nil value for either argument stands for the current time.
1632 See `current-time-string' for the various forms of a time value. */)
1633 (Lisp_Object t1
, Lisp_Object t2
)
1636 struct lisp_time a
= lisp_time_struct (t1
, &t1len
);
1637 struct lisp_time b
= lisp_time_struct (t2
, &t2len
);
1638 return ((a
.hi
!= b
.hi
? a
.hi
< b
.hi
1639 : a
.lo
!= b
.lo
? a
.lo
< b
.lo
1640 : a
.us
!= b
.us
? a
.us
< b
.us
1646 DEFUN ("get-internal-run-time", Fget_internal_run_time
, Sget_internal_run_time
,
1648 doc
: /* Return the current run time used by Emacs.
1649 The time is returned as a list (HIGH LOW USEC PSEC), using the same
1650 style as (current-time).
1652 On systems that can't determine the run time, `get-internal-run-time'
1653 does the same thing as `current-time'. */)
1656 #ifdef HAVE_GETRUSAGE
1657 struct rusage usage
;
1661 if (getrusage (RUSAGE_SELF
, &usage
) < 0)
1662 /* This shouldn't happen. What action is appropriate? */
1665 /* Sum up user time and system time. */
1666 secs
= usage
.ru_utime
.tv_sec
+ usage
.ru_stime
.tv_sec
;
1667 usecs
= usage
.ru_utime
.tv_usec
+ usage
.ru_stime
.tv_usec
;
1668 if (usecs
>= 1000000)
1673 return make_lisp_time (make_timespec (secs
, usecs
* 1000));
1674 #else /* ! HAVE_GETRUSAGE */
1676 return w32_get_internal_run_time ();
1677 #else /* ! WINDOWSNT */
1678 return Fcurrent_time ();
1679 #endif /* WINDOWSNT */
1680 #endif /* HAVE_GETRUSAGE */
1684 /* Make a Lisp list that represents the Emacs time T. T may be an
1685 invalid time, with a slightly negative tv_nsec value such as
1686 UNKNOWN_MODTIME_NSECS; in that case, the Lisp list contains a
1687 correspondingly negative picosecond count. */
1689 make_lisp_time (struct timespec t
)
1691 time_t s
= t
.tv_sec
;
1693 return list4i (hi_time (s
), lo_time (s
), ns
/ 1000, ns
% 1000 * 1000);
1696 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1697 Set *PHIGH, *PLOW, *PUSEC, *PPSEC to its parts; do not check their values.
1698 Return 2, 3, or 4 to indicate the effective length of SPECIFIED_TIME
1699 if successful, 0 if unsuccessful. */
1701 disassemble_lisp_time (Lisp_Object specified_time
, Lisp_Object
*phigh
,
1702 Lisp_Object
*plow
, Lisp_Object
*pusec
,
1705 Lisp_Object high
= make_number (0);
1706 Lisp_Object low
= specified_time
;
1707 Lisp_Object usec
= make_number (0);
1708 Lisp_Object psec
= make_number (0);
1711 if (CONSP (specified_time
))
1713 high
= XCAR (specified_time
);
1714 low
= XCDR (specified_time
);
1717 Lisp_Object low_tail
= XCDR (low
);
1719 if (CONSP (low_tail
))
1721 usec
= XCAR (low_tail
);
1722 low_tail
= XCDR (low_tail
);
1723 if (CONSP (low_tail
))
1724 psec
= XCAR (low_tail
);
1728 else if (!NILP (low_tail
))
1739 /* When combining components, require LOW to be an integer,
1740 as otherwise it would be a pain to add up times. */
1741 if (! INTEGERP (low
))
1744 else if (INTEGERP (specified_time
))
1754 /* Convert T into an Emacs time *RESULT, truncating toward minus infinity.
1755 Return true if T is in range, false otherwise. */
1757 decode_float_time (double t
, struct lisp_time
*result
)
1759 double lo_multiplier
= 1 << LO_TIME_BITS
;
1760 double emacs_time_min
= MOST_NEGATIVE_FIXNUM
* lo_multiplier
;
1761 if (! (emacs_time_min
<= t
&& t
< -emacs_time_min
))
1764 double small_t
= t
/ lo_multiplier
;
1765 EMACS_INT hi
= small_t
;
1766 double t_sans_hi
= t
- hi
* lo_multiplier
;
1768 long double fracps
= (t_sans_hi
- lo
) * 1e12L
;
1769 #ifdef INT_FAST64_MAX
1770 int_fast64_t ifracps
= fracps
;
1771 int us
= ifracps
/ 1000000;
1772 int ps
= ifracps
% 1000000;
1774 int us
= fracps
/ 1e6L
;
1775 int ps
= fracps
- us
* 1e6L
;
1778 ps
+= (ps
< 0) * 1000000;
1780 us
+= (us
< 0) * 1000000;
1782 lo
+= (lo
< 0) << LO_TIME_BITS
;
1790 /* From the time components HIGH, LOW, USEC and PSEC taken from a Lisp
1791 list, generate the corresponding time value.
1792 If LOW is floating point, the other components should be zero.
1794 If RESULT is not null, store into *RESULT the converted time.
1795 If *DRESULT is not null, store into *DRESULT the number of
1796 seconds since the start of the POSIX Epoch.
1798 Return 1 if successful, 0 if the components are of the
1799 wrong type, and -1 if the time is out of range. */
1801 decode_time_components (Lisp_Object high
, Lisp_Object low
, Lisp_Object usec
,
1803 struct lisp_time
*result
, double *dresult
)
1805 EMACS_INT hi
, lo
, us
, ps
;
1806 if (! (INTEGERP (high
)
1807 && INTEGERP (usec
) && INTEGERP (psec
)))
1809 if (! INTEGERP (low
))
1813 double t
= XFLOAT_DATA (low
);
1814 if (result
&& ! decode_float_time (t
, result
))
1820 else if (NILP (low
))
1822 struct timespec now
= current_timespec ();
1825 result
->hi
= hi_time (now
.tv_sec
);
1826 result
->lo
= lo_time (now
.tv_sec
);
1827 result
->us
= now
.tv_nsec
/ 1000;
1828 result
->ps
= now
.tv_nsec
% 1000 * 1000;
1831 *dresult
= now
.tv_sec
+ now
.tv_nsec
/ 1e9
;
1843 /* Normalize out-of-range lower-order components by carrying
1844 each overflow into the next higher-order component. */
1845 us
+= ps
/ 1000000 - (ps
% 1000000 < 0);
1846 lo
+= us
/ 1000000 - (us
% 1000000 < 0);
1847 hi
+= lo
>> LO_TIME_BITS
;
1848 ps
= ps
% 1000000 + 1000000 * (ps
% 1000000 < 0);
1849 us
= us
% 1000000 + 1000000 * (us
% 1000000 < 0);
1850 lo
&= (1 << LO_TIME_BITS
) - 1;
1854 if (FIXNUM_OVERFLOW_P (hi
))
1865 *dresult
= (us
* 1e6
+ ps
) / 1e12
+ lo
+ dhi
* (1 << LO_TIME_BITS
);
1872 lisp_to_timespec (struct lisp_time t
)
1874 if (! ((TYPE_SIGNED (time_t) ? TIME_T_MIN
>> LO_TIME_BITS
<= t
.hi
: 0 <= t
.hi
)
1875 && t
.hi
<= TIME_T_MAX
>> LO_TIME_BITS
))
1876 return invalid_timespec ();
1877 time_t s
= (t
.hi
<< LO_TIME_BITS
) + t
.lo
;
1878 int ns
= t
.us
* 1000 + t
.ps
/ 1000;
1879 return make_timespec (s
, ns
);
1882 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1883 Store its effective length into *PLEN.
1884 If SPECIFIED_TIME is nil, use the current time.
1885 Signal an error if SPECIFIED_TIME does not represent a time. */
1886 static struct lisp_time
1887 lisp_time_struct (Lisp_Object specified_time
, int *plen
)
1889 Lisp_Object high
, low
, usec
, psec
;
1891 int len
= disassemble_lisp_time (specified_time
, &high
, &low
, &usec
, &psec
);
1894 int val
= decode_time_components (high
, low
, usec
, psec
, &t
, 0);
1895 check_time_validity (val
);
1900 /* Like lisp_time_struct, except return a struct timespec.
1901 Discard any low-order digits. */
1903 lisp_time_argument (Lisp_Object specified_time
)
1906 struct lisp_time lt
= lisp_time_struct (specified_time
, &len
);
1907 struct timespec t
= lisp_to_timespec (lt
);
1908 if (! timespec_valid_p (t
))
1913 /* Like lisp_time_argument, except decode only the seconds part,
1914 and do not check the subseconds part. */
1916 lisp_seconds_argument (Lisp_Object specified_time
)
1918 Lisp_Object high
, low
, usec
, psec
;
1921 int val
= disassemble_lisp_time (specified_time
, &high
, &low
, &usec
, &psec
);
1924 val
= decode_time_components (high
, low
, make_number (0),
1925 make_number (0), &t
, 0);
1927 && ! ((TYPE_SIGNED (time_t)
1928 ? TIME_T_MIN
>> LO_TIME_BITS
<= t
.hi
1930 && t
.hi
<= TIME_T_MAX
>> LO_TIME_BITS
))
1933 check_time_validity (val
);
1934 return (t
.hi
<< LO_TIME_BITS
) + t
.lo
;
1937 DEFUN ("float-time", Ffloat_time
, Sfloat_time
, 0, 1, 0,
1938 doc
: /* Return the current time, as a float number of seconds since the epoch.
1939 If SPECIFIED-TIME is given, it is the time to convert to float
1940 instead of the current time. The argument should have the form
1941 \(HIGH LOW) or (HIGH LOW USEC) or (HIGH LOW USEC PSEC). Thus,
1942 you can use times from `current-time' and from `file-attributes'.
1943 SPECIFIED-TIME can also have the form (HIGH . LOW), but this is
1944 considered obsolete.
1946 WARNING: Since the result is floating point, it may not be exact.
1947 If precise time stamps are required, use either `current-time',
1948 or (if you need time as a string) `format-time-string'. */)
1949 (Lisp_Object specified_time
)
1952 Lisp_Object high
, low
, usec
, psec
;
1953 if (! (disassemble_lisp_time (specified_time
, &high
, &low
, &usec
, &psec
)
1954 && decode_time_components (high
, low
, usec
, psec
, 0, &t
)))
1956 return make_float (t
);
1959 /* Write information into buffer S of size MAXSIZE, according to the
1960 FORMAT of length FORMAT_LEN, using time information taken from *TP.
1961 Use the time zone specified by TZ.
1962 Use NS as the number of nanoseconds in the %N directive.
1963 Return the number of bytes written, not including the terminating
1964 '\0'. If S is NULL, nothing will be written anywhere; so to
1965 determine how many bytes would be written, use NULL for S and
1966 ((size_t) -1) for MAXSIZE.
1968 This function behaves like nstrftime, except it allows null
1969 bytes in FORMAT and it does not support nanoseconds. */
1971 emacs_nmemftime (char *s
, size_t maxsize
, const char *format
,
1972 size_t format_len
, const struct tm
*tp
, timezone_t tz
, int ns
)
1976 /* Loop through all the null-terminated strings in the format
1977 argument. Normally there's just one null-terminated string, but
1978 there can be arbitrarily many, concatenated together, if the
1979 format contains '\0' bytes. nstrftime stops at the first
1980 '\0' byte so we must invoke it separately for each such string. */
1989 result
= nstrftime (s
, maxsize
, format
, tp
, tz
, ns
);
1993 if (result
== 0 && s
[0] != '\0')
1998 maxsize
-= result
+ 1;
2000 len
= strlen (format
);
2001 if (len
== format_len
)
2005 format_len
-= len
+ 1;
2009 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 1, 3, 0,
2010 doc
: /* Use FORMAT-STRING to format the time TIME, or now if omitted or nil.
2011 TIME is specified as (HIGH LOW USEC PSEC), as returned by
2012 `current-time' or `file-attributes'. It can also be a single integer
2013 number of seconds since the epoch. The obsolete form (HIGH . LOW) is
2014 also still accepted.
2016 The optional ZONE is omitted or nil for Emacs local time, t for
2017 Universal Time, `wall' for system wall clock time, or a string as in
2018 the TZ environment variable. It can also be a list (as from
2019 `current-time-zone') or an integer (as from `decode-time') applied
2020 without consideration for daylight saving time.
2022 The value is a copy of FORMAT-STRING, but with certain constructs replaced
2023 by text that describes the specified date and time in TIME:
2025 %Y is the year, %y within the century, %C the century.
2026 %G is the year corresponding to the ISO week, %g within the century.
2027 %m is the numeric month.
2028 %b and %h are the locale's abbreviated month name, %B the full name.
2029 (%h is not supported on MS-Windows.)
2030 %d is the day of the month, zero-padded, %e is blank-padded.
2031 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
2032 %a is the locale's abbreviated name of the day of week, %A the full name.
2033 %U is the week number starting on Sunday, %W starting on Monday,
2034 %V according to ISO 8601.
2035 %j is the day of the year.
2037 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
2038 only blank-padded, %l is like %I blank-padded.
2039 %p is the locale's equivalent of either AM or PM.
2040 %q is the calendar quarter (1–4).
2041 %M is the minute (00-59).
2042 %S is the second (00-59; 00-60 on platforms with leap seconds)
2043 %s is the number of seconds since 1970-01-01 00:00:00 +0000.
2044 %N is the nanosecond, %6N the microsecond, %3N the millisecond, etc.
2045 %Z is the time zone abbreviation, %z is the numeric form.
2047 %c is the locale's date and time format.
2048 %x is the locale's "preferred" date format.
2049 %D is like "%m/%d/%y".
2050 %F is the ISO 8601 date format (like "%Y-%m-%d").
2052 %R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
2053 %X is the locale's "preferred" time format.
2055 Finally, %n is a newline, %t is a tab, %% is a literal %, and
2056 unrecognized %-sequences stand for themselves.
2058 Certain flags and modifiers are available with some format controls.
2059 The flags are `_', `-', `^' and `#'. For certain characters X,
2060 %_X is like %X, but padded with blanks; %-X is like %X,
2061 but without padding. %^X is like %X, but with all textual
2062 characters up-cased; %#X is like %X, but with letter-case of
2063 all textual characters reversed.
2064 %NX (where N stands for an integer) is like %X,
2065 but takes up at least N (a number) positions.
2066 The modifiers are `E' and `O'. For certain characters X,
2067 %EX is a locale's alternative version of %X;
2068 %OX is like %X, but uses the locale's number symbols.
2070 For example, to produce full ISO 8601 format, use "%FT%T%z".
2072 usage: (format-time-string FORMAT-STRING &optional TIME ZONE) */)
2073 (Lisp_Object format_string
, Lisp_Object timeval
, Lisp_Object zone
)
2075 struct timespec t
= lisp_time_argument (timeval
);
2078 CHECK_STRING (format_string
);
2079 format_string
= code_convert_string_norecord (format_string
,
2080 Vlocale_coding_system
, 1);
2081 return format_time_string (SSDATA (format_string
), SBYTES (format_string
),
2086 format_time_string (char const *format
, ptrdiff_t formatlen
,
2087 struct timespec t
, Lisp_Object zone
, struct tm
*tmp
)
2091 ptrdiff_t size
= sizeof buffer
;
2096 timezone_t tz
= tzlookup (zone
, false);
2097 /* On some systems, like 32-bit MinGW, tv_sec of struct timespec is
2098 a 64-bit type, but time_t is a 32-bit type. emacs_localtime_rz
2099 expects a pointer to time_t value. */
2100 time_t tsec
= t
.tv_sec
;
2101 tmp
= emacs_localtime_rz (tz
, &tsec
, tmp
);
2107 synchronize_system_time_locale ();
2112 len
= emacs_nmemftime (buf
, size
, format
, formatlen
, tmp
, tz
, ns
);
2113 if ((0 < len
&& len
< size
) || (len
== 0 && buf
[0] == '\0'))
2116 /* Buffer was too small, so make it bigger and try again. */
2117 len
= emacs_nmemftime (NULL
, SIZE_MAX
, format
, formatlen
, tmp
, tz
, ns
);
2118 if (STRING_BYTES_BOUND
<= len
)
2124 buf
= SAFE_ALLOCA (size
);
2128 AUTO_STRING_WITH_LEN (bufstring
, buf
, len
);
2129 Lisp_Object result
= code_convert_string_norecord (bufstring
,
2130 Vlocale_coding_system
, 0);
2135 DEFUN ("decode-time", Fdecode_time
, Sdecode_time
, 0, 2, 0,
2136 doc
: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST UTCOFF).
2137 The optional TIME should be a list of (HIGH LOW . IGNORED),
2138 as from `current-time' and `file-attributes', or nil to use the
2139 current time. It can also be a single integer number of seconds since
2140 the epoch. The obsolete form (HIGH . LOW) is also still accepted.
2142 The optional ZONE is omitted or nil for Emacs local time, t for
2143 Universal Time, `wall' for system wall clock time, or a string as in
2144 the TZ environment variable. It can also be a list (as from
2145 `current-time-zone') or an integer (the UTC offset in seconds) applied
2146 without consideration for daylight saving time.
2148 The list has the following nine members: SEC is an integer between 0
2149 and 60; SEC is 60 for a leap second, which only some operating systems
2150 support. MINUTE is an integer between 0 and 59. HOUR is an integer
2151 between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
2152 integer between 1 and 12. YEAR is an integer indicating the
2153 four-digit year. DOW is the day of week, an integer between 0 and 6,
2154 where 0 is Sunday. DST is t if daylight saving time is in effect,
2155 otherwise nil. UTCOFF is an integer indicating the UTC offset in
2156 seconds, i.e., the number of seconds east of Greenwich. (Note that
2157 Common Lisp has different meanings for DOW and UTCOFF.)
2159 usage: (decode-time &optional TIME ZONE) */)
2160 (Lisp_Object specified_time
, Lisp_Object zone
)
2162 time_t time_spec
= lisp_seconds_argument (specified_time
);
2163 struct tm local_tm
, gmt_tm
;
2164 timezone_t tz
= tzlookup (zone
, false);
2165 struct tm
*tm
= emacs_localtime_rz (tz
, &time_spec
, &local_tm
);
2169 && MOST_NEGATIVE_FIXNUM
- TM_YEAR_BASE
<= local_tm
.tm_year
2170 && local_tm
.tm_year
<= MOST_POSITIVE_FIXNUM
- TM_YEAR_BASE
))
2173 /* Avoid overflow when INT_MAX < EMACS_INT_MAX. */
2174 EMACS_INT tm_year_base
= TM_YEAR_BASE
;
2176 return CALLN (Flist
,
2177 make_number (local_tm
.tm_sec
),
2178 make_number (local_tm
.tm_min
),
2179 make_number (local_tm
.tm_hour
),
2180 make_number (local_tm
.tm_mday
),
2181 make_number (local_tm
.tm_mon
+ 1),
2182 make_number (local_tm
.tm_year
+ tm_year_base
),
2183 make_number (local_tm
.tm_wday
),
2184 local_tm
.tm_isdst
? Qt
: Qnil
,
2186 ? make_number (tm_gmtoff (&local_tm
))
2187 : gmtime_r (&time_spec
, &gmt_tm
)
2188 ? make_number (tm_diff (&local_tm
, &gmt_tm
))
2192 /* Return OBJ - OFFSET, checking that OBJ is a valid fixnum and that
2193 the result is representable as an int. */
2195 check_tm_member (Lisp_Object obj
, int offset
)
2198 EMACS_INT n
= XINT (obj
);
2200 if (INT_SUBTRACT_WRAPV (n
, offset
, &result
))
2205 DEFUN ("encode-time", Fencode_time
, Sencode_time
, 6, MANY
, 0,
2206 doc
: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
2207 This is the reverse operation of `decode-time', which see.
2209 The optional ZONE is omitted or nil for Emacs local time, t for
2210 Universal Time, `wall' for system wall clock time, or a string as in
2211 the TZ environment variable. It can also be a list (as from
2212 `current-time-zone') or an integer (as from `decode-time') applied
2213 without consideration for daylight saving time.
2215 You can pass more than 7 arguments; then the first six arguments
2216 are used as SECOND through YEAR, and the *last* argument is used as ZONE.
2217 The intervening arguments are ignored.
2218 This feature lets (apply \\='encode-time (decode-time ...)) work.
2220 Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed;
2221 for example, a DAY of 0 means the day preceding the given month.
2222 Year numbers less than 100 are treated just like other year numbers.
2223 If you want them to stand for years in this century, you must do that yourself.
2225 Years before 1970 are not guaranteed to work. On some systems,
2226 year values as low as 1901 do work.
2228 usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
2229 (ptrdiff_t nargs
, Lisp_Object
*args
)
2233 Lisp_Object zone
= (nargs
> 6 ? args
[nargs
- 1] : Qnil
);
2235 tm
.tm_sec
= check_tm_member (args
[0], 0);
2236 tm
.tm_min
= check_tm_member (args
[1], 0);
2237 tm
.tm_hour
= check_tm_member (args
[2], 0);
2238 tm
.tm_mday
= check_tm_member (args
[3], 0);
2239 tm
.tm_mon
= check_tm_member (args
[4], 1);
2240 tm
.tm_year
= check_tm_member (args
[5], TM_YEAR_BASE
);
2243 timezone_t tz
= tzlookup (zone
, false);
2244 value
= emacs_mktime_z (tz
, &tm
);
2247 if (value
== (time_t) -1)
2250 return list2i (hi_time (value
), lo_time (value
));
2253 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
,
2255 doc
: /* Return the current local time, as a human-readable string.
2256 Programs can use this function to decode a time,
2257 since the number of columns in each field is fixed
2258 if the year is in the range 1000-9999.
2259 The format is `Sun Sep 16 01:03:52 1973'.
2260 However, see also the functions `decode-time' and `format-time-string'
2261 which provide a much more powerful and general facility.
2263 If SPECIFIED-TIME is given, it is a time to format instead of the
2264 current time. The argument should have the form (HIGH LOW . IGNORED).
2265 Thus, you can use times obtained from `current-time' and from
2266 `file-attributes'. SPECIFIED-TIME can also be a single integer number
2267 of seconds since the epoch. The obsolete form (HIGH . LOW) is also
2270 The optional ZONE is omitted or nil for Emacs local time, t for
2271 Universal Time, `wall' for system wall clock time, or a string as in
2272 the TZ environment variable. It can also be a list (as from
2273 `current-time-zone') or an integer (as from `decode-time') applied
2274 without consideration for daylight saving time. */)
2275 (Lisp_Object specified_time
, Lisp_Object zone
)
2277 time_t value
= lisp_seconds_argument (specified_time
);
2278 timezone_t tz
= tzlookup (zone
, false);
2280 /* Convert to a string in ctime format, except without the trailing
2281 newline, and without the 4-digit year limit. Don't use asctime
2282 or ctime, as they might dump core if the year is outside the
2283 range -999 .. 9999. */
2285 struct tm
*tmp
= emacs_localtime_rz (tz
, &value
, &tm
);
2290 static char const wday_name
[][4] =
2291 { "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat" };
2292 static char const mon_name
[][4] =
2293 { "Jan", "Feb", "Mar", "Apr", "May", "Jun",
2294 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" };
2295 printmax_t year_base
= TM_YEAR_BASE
;
2296 char buf
[sizeof "Mon Apr 30 12:49:17 " + INT_STRLEN_BOUND (int) + 1];
2297 int len
= sprintf (buf
, "%s %s%3d %02d:%02d:%02d %"pMd
,
2298 wday_name
[tm
.tm_wday
], mon_name
[tm
.tm_mon
], tm
.tm_mday
,
2299 tm
.tm_hour
, tm
.tm_min
, tm
.tm_sec
,
2300 tm
.tm_year
+ year_base
);
2302 return make_unibyte_string (buf
, len
);
2305 /* Yield A - B, measured in seconds.
2306 This function is copied from the GNU C Library. */
2308 tm_diff (struct tm
*a
, struct tm
*b
)
2310 /* Compute intervening leap days correctly even if year is negative.
2311 Take care to avoid int overflow in leap day calculations,
2312 but it's OK to assume that A and B are close to each other. */
2313 int a4
= (a
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (a
->tm_year
& 3);
2314 int b4
= (b
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (b
->tm_year
& 3);
2315 int a100
= a4
/ 25 - (a4
% 25 < 0);
2316 int b100
= b4
/ 25 - (b4
% 25 < 0);
2317 int a400
= a100
>> 2;
2318 int b400
= b100
>> 2;
2319 int intervening_leap_days
= (a4
- b4
) - (a100
- b100
) + (a400
- b400
);
2320 int years
= a
->tm_year
- b
->tm_year
;
2321 int days
= (365 * years
+ intervening_leap_days
2322 + (a
->tm_yday
- b
->tm_yday
));
2323 return (60 * (60 * (24 * days
+ (a
->tm_hour
- b
->tm_hour
))
2324 + (a
->tm_min
- b
->tm_min
))
2325 + (a
->tm_sec
- b
->tm_sec
));
2328 /* Yield A's UTC offset, or an unspecified value if unknown. */
2330 tm_gmtoff (struct tm
*a
)
2333 return a
->tm_gmtoff
;
2339 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 2, 0,
2340 doc
: /* Return the offset and name for the local time zone.
2341 This returns a list of the form (OFFSET NAME).
2342 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
2343 A negative value means west of Greenwich.
2344 NAME is a string giving the name of the time zone.
2345 If SPECIFIED-TIME is given, the time zone offset is determined from it
2346 instead of using the current time. The argument should have the form
2347 \(HIGH LOW . IGNORED). Thus, you can use times obtained from
2348 `current-time' and from `file-attributes'. SPECIFIED-TIME can also be
2349 a single integer number of seconds since the epoch. The obsolete form
2350 (HIGH . LOW) is also still accepted.
2352 The optional ZONE is omitted or nil for Emacs local time, t for
2353 Universal Time, `wall' for system wall clock time, or a string as in
2354 the TZ environment variable. It can also be a list (as from
2355 `current-time-zone') or an integer (as from `decode-time') applied
2356 without consideration for daylight saving time.
2358 Some operating systems cannot provide all this information to Emacs;
2359 in this case, `current-time-zone' returns a list containing nil for
2360 the data it can't find. */)
2361 (Lisp_Object specified_time
, Lisp_Object zone
)
2363 struct timespec value
;
2364 struct tm local_tm
, gmt_tm
;
2365 Lisp_Object zone_offset
, zone_name
;
2368 value
= make_timespec (lisp_seconds_argument (specified_time
), 0);
2369 zone_name
= format_time_string ("%Z", sizeof "%Z" - 1, value
,
2372 /* gmtime_r expects a pointer to time_t, but tv_sec of struct
2373 timespec on some systems (MinGW) is a 64-bit field. */
2374 time_t tsec
= value
.tv_sec
;
2375 if (HAVE_TM_GMTOFF
|| gmtime_r (&tsec
, &gmt_tm
))
2377 long int offset
= (HAVE_TM_GMTOFF
2378 ? tm_gmtoff (&local_tm
)
2379 : tm_diff (&local_tm
, &gmt_tm
));
2380 zone_offset
= make_number (offset
);
2381 if (SCHARS (zone_name
) == 0)
2383 /* No local time zone name is available; use numeric zone instead. */
2384 long int hour
= offset
/ 3600;
2385 int min_sec
= offset
% 3600;
2386 int amin_sec
= min_sec
< 0 ? - min_sec
: min_sec
;
2387 int min
= amin_sec
/ 60;
2388 int sec
= amin_sec
% 60;
2389 int min_prec
= min_sec
? 2 : 0;
2390 int sec_prec
= sec
? 2 : 0;
2391 char buf
[sizeof "+0000" + INT_STRLEN_BOUND (long int)];
2392 zone_name
= make_formatted_string (buf
, "%c%.2ld%.*d%.*d",
2393 (offset
< 0 ? '-' : '+'),
2394 hour
, min_prec
, min
, sec_prec
, sec
);
2398 return list2 (zone_offset
, zone_name
);
2401 DEFUN ("set-time-zone-rule", Fset_time_zone_rule
, Sset_time_zone_rule
, 1, 1, 0,
2402 doc
: /* Set the Emacs local time zone using TZ, a string specifying a time zone rule.
2403 If TZ is nil or `wall', use system wall clock time; this differs from
2404 the usual Emacs convention where nil means current local time. If TZ
2405 is t, use Universal Time. If TZ is a list (as from
2406 `current-time-zone') or an integer (as from `decode-time'), use the
2407 specified time zone without consideration for daylight saving time.
2409 Instead of calling this function, you typically want something else.
2410 To temporarily use a different time zone rule for just one invocation
2411 of `decode-time', `encode-time', or `format-time-string', pass the
2412 function a ZONE argument. To change local time consistently
2413 throughout Emacs, call (setenv "TZ" TZ): this changes both the
2414 environment of the Emacs process and the variable
2415 `process-environment', whereas `set-time-zone-rule' affects only the
2419 tzlookup (NILP (tz
) ? Qwall
: tz
, true);
2423 /* A buffer holding a string of the form "TZ=value", intended
2424 to be part of the environment. If TZ is supposed to be unset,
2425 the buffer string is "tZ=". */
2426 static char *tzvalbuf
;
2428 /* Get the local time zone rule. */
2430 emacs_getenv_TZ (void)
2432 return tzvalbuf
[0] == 'T' ? tzvalbuf
+ tzeqlen
: 0;
2435 /* Set the local time zone rule to TZSTRING, which can be null to
2436 denote wall clock time. Do not record the setting in LOCAL_TZ.
2438 This function is not thread-safe, in theory because putenv is not,
2439 but mostly because of the static storage it updates. Other threads
2440 that invoke localtime etc. may be adversely affected while this
2441 function is executing. */
2444 emacs_setenv_TZ (const char *tzstring
)
2446 static ptrdiff_t tzvalbufsize
;
2447 ptrdiff_t tzstringlen
= tzstring
? strlen (tzstring
) : 0;
2448 char *tzval
= tzvalbuf
;
2449 bool new_tzvalbuf
= tzvalbufsize
<= tzeqlen
+ tzstringlen
;
2453 /* Do not attempt to free the old tzvalbuf, since another thread
2454 may be using it. In practice, the first allocation is large
2455 enough and memory does not leak. */
2456 tzval
= xpalloc (NULL
, &tzvalbufsize
,
2457 tzeqlen
+ tzstringlen
- tzvalbufsize
+ 1, -1, 1);
2465 /* Modify TZVAL in place. Although this is dicey in a
2466 multithreaded environment, we know of no portable alternative.
2467 Calling putenv or setenv could crash some other thread. */
2469 strcpy (tzval
+ tzeqlen
, tzstring
);
2473 /* Turn 'TZ=whatever' into an empty environment variable 'tZ='.
2474 Although this is also dicey, calling unsetenv here can crash Emacs.
2482 /* Modifying *TZVAL merely requires calling tzset (which is the
2483 caller's responsibility). However, modifying TZVAL requires
2484 calling putenv; although this is not thread-safe, in practice this
2485 runs only on startup when there is only one thread. */
2486 bool need_putenv
= new_tzvalbuf
;
2488 /* MS-Windows 'putenv' copies the argument string into a block it
2489 allocates, so modifying *TZVAL will not change the environment.
2490 However, the other threads run by Emacs on MS-Windows never call
2491 'xputenv' or 'putenv' or 'unsetenv', so the original cause for the
2492 dicey in-place modification technique doesn't exist there in the
2494 bool need_putenv
= true;
2502 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
2503 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
2504 type of object is Lisp_String). INHERIT is passed to
2505 INSERT_FROM_STRING_FUNC as the last argument. */
2508 general_insert_function (void (*insert_func
)
2509 (const char *, ptrdiff_t),
2510 void (*insert_from_string_func
)
2511 (Lisp_Object
, ptrdiff_t, ptrdiff_t,
2512 ptrdiff_t, ptrdiff_t, bool),
2513 bool inherit
, ptrdiff_t nargs
, Lisp_Object
*args
)
2518 for (argnum
= 0; argnum
< nargs
; argnum
++)
2521 if (CHARACTERP (val
))
2523 int c
= XFASTINT (val
);
2524 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2527 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2528 len
= CHAR_STRING (c
, str
);
2531 str
[0] = CHAR_TO_BYTE8 (c
);
2534 (*insert_func
) ((char *) str
, len
);
2536 else if (STRINGP (val
))
2538 (*insert_from_string_func
) (val
, 0, 0,
2544 wrong_type_argument (Qchar_or_string_p
, val
);
2549 insert1 (Lisp_Object arg
)
2555 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
2556 doc
: /* Insert the arguments, either strings or characters, at point.
2557 Point and after-insertion markers move forward to end up
2558 after the inserted text.
2559 Any other markers at the point of insertion remain before the text.
2561 If the current buffer is multibyte, unibyte strings are converted
2562 to multibyte for insertion (see `string-make-multibyte').
2563 If the current buffer is unibyte, multibyte strings are converted
2564 to unibyte for insertion (see `string-make-unibyte').
2566 When operating on binary data, it may be necessary to preserve the
2567 original bytes of a unibyte string when inserting it into a multibyte
2568 buffer; to accomplish this, apply `string-as-multibyte' to the string
2569 and insert the result.
2571 usage: (insert &rest ARGS) */)
2572 (ptrdiff_t nargs
, Lisp_Object
*args
)
2574 general_insert_function (insert
, insert_from_string
, 0, nargs
, args
);
2578 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
2580 doc
: /* Insert the arguments at point, inheriting properties from adjoining text.
2581 Point and after-insertion markers move forward to end up
2582 after the inserted text.
2583 Any other markers at the point of insertion remain before the text.
2585 If the current buffer is multibyte, unibyte strings are converted
2586 to multibyte for insertion (see `unibyte-char-to-multibyte').
2587 If the current buffer is unibyte, multibyte strings are converted
2588 to unibyte for insertion.
2590 usage: (insert-and-inherit &rest ARGS) */)
2591 (ptrdiff_t nargs
, Lisp_Object
*args
)
2593 general_insert_function (insert_and_inherit
, insert_from_string
, 1,
2598 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
2599 doc
: /* Insert strings or characters at point, relocating markers after the text.
2600 Point and markers move forward to end up after the inserted text.
2602 If the current buffer is multibyte, unibyte strings are converted
2603 to multibyte for insertion (see `unibyte-char-to-multibyte').
2604 If the current buffer is unibyte, multibyte strings are converted
2605 to unibyte for insertion.
2607 If an overlay begins at the insertion point, the inserted text falls
2608 outside the overlay; if a nonempty overlay ends at the insertion
2609 point, the inserted text falls inside that overlay.
2611 usage: (insert-before-markers &rest ARGS) */)
2612 (ptrdiff_t nargs
, Lisp_Object
*args
)
2614 general_insert_function (insert_before_markers
,
2615 insert_from_string_before_markers
, 0,
2620 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers
,
2621 Sinsert_and_inherit_before_markers
, 0, MANY
, 0,
2622 doc
: /* Insert text at point, relocating markers and inheriting properties.
2623 Point and markers move forward to end up after the inserted text.
2625 If the current buffer is multibyte, unibyte strings are converted
2626 to multibyte for insertion (see `unibyte-char-to-multibyte').
2627 If the current buffer is unibyte, multibyte strings are converted
2628 to unibyte for insertion.
2630 usage: (insert-before-markers-and-inherit &rest ARGS) */)
2631 (ptrdiff_t nargs
, Lisp_Object
*args
)
2633 general_insert_function (insert_before_markers_and_inherit
,
2634 insert_from_string_before_markers
, 1,
2639 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 1, 3,
2640 "(list (read-char-by-name \"Insert character (Unicode name or hex): \")\
2641 (prefix-numeric-value current-prefix-arg)\
2643 doc
: /* Insert COUNT copies of CHARACTER.
2644 Interactively, prompt for CHARACTER. You can specify CHARACTER in one
2647 - As its Unicode character name, e.g. \"LATIN SMALL LETTER A\".
2648 Completion is available; if you type a substring of the name
2649 preceded by an asterisk `*', Emacs shows all names which include
2650 that substring, not necessarily at the beginning of the name.
2652 - As a hexadecimal code point, e.g. 263A. Note that code points in
2653 Emacs are equivalent to Unicode up to 10FFFF (which is the limit of
2654 the Unicode code space).
2656 - As a code point with a radix specified with #, e.g. #o21430
2657 (octal), #x2318 (hex), or #10r8984 (decimal).
2659 If called interactively, COUNT is given by the prefix argument. If
2660 omitted or nil, it defaults to 1.
2662 Inserting the character(s) relocates point and before-insertion
2663 markers in the same ways as the function `insert'.
2665 The optional third argument INHERIT, if non-nil, says to inherit text
2666 properties from adjoining text, if those properties are sticky. If
2667 called interactively, INHERIT is t. */)
2668 (Lisp_Object character
, Lisp_Object count
, Lisp_Object inherit
)
2671 register ptrdiff_t n
;
2673 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2676 CHECK_CHARACTER (character
);
2678 XSETFASTINT (count
, 1);
2679 CHECK_NUMBER (count
);
2680 c
= XFASTINT (character
);
2682 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2683 len
= CHAR_STRING (c
, str
);
2685 str
[0] = c
, len
= 1;
2686 if (XINT (count
) <= 0)
2688 if (BUF_BYTES_MAX
/ len
< XINT (count
))
2690 n
= XINT (count
) * len
;
2691 stringlen
= min (n
, sizeof string
- sizeof string
% len
);
2692 for (i
= 0; i
< stringlen
; i
++)
2693 string
[i
] = str
[i
% len
];
2694 while (n
> stringlen
)
2697 if (!NILP (inherit
))
2698 insert_and_inherit (string
, stringlen
);
2700 insert (string
, stringlen
);
2703 if (!NILP (inherit
))
2704 insert_and_inherit (string
, n
);
2710 DEFUN ("insert-byte", Finsert_byte
, Sinsert_byte
, 2, 3, 0,
2711 doc
: /* Insert COUNT (second arg) copies of BYTE (first arg).
2712 Both arguments are required.
2713 BYTE is a number of the range 0..255.
2715 If BYTE is 128..255 and the current buffer is multibyte, the
2716 corresponding eight-bit character is inserted.
2718 Point, and before-insertion markers, are relocated as in the function `insert'.
2719 The optional third arg INHERIT, if non-nil, says to inherit text properties
2720 from adjoining text, if those properties are sticky. */)
2721 (Lisp_Object byte
, Lisp_Object count
, Lisp_Object inherit
)
2723 CHECK_NUMBER (byte
);
2724 if (XINT (byte
) < 0 || XINT (byte
) > 255)
2725 args_out_of_range_3 (byte
, make_number (0), make_number (255));
2726 if (XINT (byte
) >= 128
2727 && ! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2728 XSETFASTINT (byte
, BYTE8_TO_CHAR (XINT (byte
)));
2729 return Finsert_char (byte
, count
, inherit
);
2733 /* Making strings from buffer contents. */
2735 /* Return a Lisp_String containing the text of the current buffer from
2736 START to END. If text properties are in use and the current buffer
2737 has properties in the range specified, the resulting string will also
2738 have them, if PROPS is true.
2740 We don't want to use plain old make_string here, because it calls
2741 make_uninit_string, which can cause the buffer arena to be
2742 compacted. make_string has no way of knowing that the data has
2743 been moved, and thus copies the wrong data into the string. This
2744 doesn't effect most of the other users of make_string, so it should
2745 be left as is. But we should use this function when conjuring
2746 buffer substrings. */
2749 make_buffer_string (ptrdiff_t start
, ptrdiff_t end
, bool props
)
2751 ptrdiff_t start_byte
= CHAR_TO_BYTE (start
);
2752 ptrdiff_t end_byte
= CHAR_TO_BYTE (end
);
2754 return make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
);
2757 /* Return a Lisp_String containing the text of the current buffer from
2758 START / START_BYTE to END / END_BYTE.
2760 If text properties are in use and the current buffer
2761 has properties in the range specified, the resulting string will also
2762 have them, if PROPS is true.
2764 We don't want to use plain old make_string here, because it calls
2765 make_uninit_string, which can cause the buffer arena to be
2766 compacted. make_string has no way of knowing that the data has
2767 been moved, and thus copies the wrong data into the string. This
2768 doesn't effect most of the other users of make_string, so it should
2769 be left as is. But we should use this function when conjuring
2770 buffer substrings. */
2773 make_buffer_string_both (ptrdiff_t start
, ptrdiff_t start_byte
,
2774 ptrdiff_t end
, ptrdiff_t end_byte
, bool props
)
2776 Lisp_Object result
, tem
, tem1
;
2777 ptrdiff_t beg0
, end0
, beg1
, end1
, size
;
2779 if (start_byte
< GPT_BYTE
&& GPT_BYTE
< end_byte
)
2781 /* Two regions, before and after the gap. */
2784 beg1
= GPT_BYTE
+ GAP_SIZE
- BEG_BYTE
;
2785 end1
= end_byte
+ GAP_SIZE
- BEG_BYTE
;
2789 /* The only region. */
2796 if (! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2797 result
= make_uninit_multibyte_string (end
- start
, end_byte
- start_byte
);
2799 result
= make_uninit_string (end
- start
);
2802 memcpy (SDATA (result
), BYTE_POS_ADDR (beg0
), size
);
2804 memcpy (SDATA (result
) + size
, BEG_ADDR
+ beg1
, end1
- beg1
);
2806 /* If desired, update and copy the text properties. */
2809 update_buffer_properties (start
, end
);
2811 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
2812 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
2814 if (XINT (tem
) != end
|| !NILP (tem1
))
2815 copy_intervals_to_string (result
, current_buffer
, start
,
2822 /* Call Vbuffer_access_fontify_functions for the range START ... END
2823 in the current buffer, if necessary. */
2826 update_buffer_properties (ptrdiff_t start
, ptrdiff_t end
)
2828 /* If this buffer has some access functions,
2829 call them, specifying the range of the buffer being accessed. */
2830 if (!NILP (Vbuffer_access_fontify_functions
))
2832 /* But don't call them if we can tell that the work
2833 has already been done. */
2834 if (!NILP (Vbuffer_access_fontified_property
))
2837 = Ftext_property_any (make_number (start
), make_number (end
),
2838 Vbuffer_access_fontified_property
,
2844 CALLN (Frun_hook_with_args
, Qbuffer_access_fontify_functions
,
2845 make_number (start
), make_number (end
));
2849 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
2850 doc
: /* Return the contents of part of the current buffer as a string.
2851 The two arguments START and END are character positions;
2852 they can be in either order.
2853 The string returned is multibyte if the buffer is multibyte.
2855 This function copies the text properties of that part of the buffer
2856 into the result string; if you don't want the text properties,
2857 use `buffer-substring-no-properties' instead. */)
2858 (Lisp_Object start
, Lisp_Object end
)
2860 register ptrdiff_t b
, e
;
2862 validate_region (&start
, &end
);
2866 return make_buffer_string (b
, e
, 1);
2869 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties
,
2870 Sbuffer_substring_no_properties
, 2, 2, 0,
2871 doc
: /* Return the characters of part of the buffer, without the text properties.
2872 The two arguments START and END are character positions;
2873 they can be in either order. */)
2874 (Lisp_Object start
, Lisp_Object end
)
2876 register ptrdiff_t b
, e
;
2878 validate_region (&start
, &end
);
2882 return make_buffer_string (b
, e
, 0);
2885 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
2886 doc
: /* Return the contents of the current buffer as a string.
2887 If narrowing is in effect, this function returns only the visible part
2891 return make_buffer_string_both (BEGV
, BEGV_BYTE
, ZV
, ZV_BYTE
, 1);
2894 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
2896 doc
: /* Insert before point a substring of the contents of BUFFER.
2897 BUFFER may be a buffer or a buffer name.
2898 Arguments START and END are character positions specifying the substring.
2899 They default to the values of (point-min) and (point-max) in BUFFER.
2901 Point and before-insertion markers move forward to end up after the
2903 Any other markers at the point of insertion remain before the text.
2905 If the current buffer is multibyte and BUFFER is unibyte, or vice
2906 versa, strings are converted from unibyte to multibyte or vice versa
2907 using `string-make-multibyte' or `string-make-unibyte', which see. */)
2908 (Lisp_Object buffer
, Lisp_Object start
, Lisp_Object end
)
2910 register EMACS_INT b
, e
, temp
;
2911 register struct buffer
*bp
, *obuf
;
2914 buf
= Fget_buffer (buffer
);
2918 if (!BUFFER_LIVE_P (bp
))
2919 error ("Selecting deleted buffer");
2925 CHECK_NUMBER_COERCE_MARKER (start
);
2932 CHECK_NUMBER_COERCE_MARKER (end
);
2937 temp
= b
, b
= e
, e
= temp
;
2939 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
2940 args_out_of_range (start
, end
);
2942 obuf
= current_buffer
;
2943 set_buffer_internal_1 (bp
);
2944 update_buffer_properties (b
, e
);
2945 set_buffer_internal_1 (obuf
);
2947 insert_from_buffer (bp
, b
, e
- b
, 0);
2951 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
2953 doc
: /* Compare two substrings of two buffers; return result as number.
2954 Return -N if first string is less after N-1 chars, +N if first string is
2955 greater after N-1 chars, or 0 if strings match.
2956 The first substring is in BUFFER1 from START1 to END1 and the second
2957 is in BUFFER2 from START2 to END2.
2958 All arguments may be nil. If BUFFER1 or BUFFER2 is nil, the current
2959 buffer is used. If START1 or START2 is nil, the value of `point-min'
2960 in the respective buffers is used. If END1 or END2 is nil, the value
2961 of `point-max' in the respective buffers is used.
2962 The value of `case-fold-search' in the current buffer
2963 determines whether case is significant or ignored. */)
2964 (Lisp_Object buffer1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object buffer2
, Lisp_Object start2
, Lisp_Object end2
)
2966 register EMACS_INT begp1
, endp1
, begp2
, endp2
, temp
;
2967 register struct buffer
*bp1
, *bp2
;
2968 register Lisp_Object trt
2969 = (!NILP (BVAR (current_buffer
, case_fold_search
))
2970 ? BVAR (current_buffer
, case_canon_table
) : Qnil
);
2971 ptrdiff_t chars
= 0;
2972 ptrdiff_t i1
, i2
, i1_byte
, i2_byte
;
2974 /* Find the first buffer and its substring. */
2977 bp1
= current_buffer
;
2981 buf1
= Fget_buffer (buffer1
);
2984 bp1
= XBUFFER (buf1
);
2985 if (!BUFFER_LIVE_P (bp1
))
2986 error ("Selecting deleted buffer");
2990 begp1
= BUF_BEGV (bp1
);
2993 CHECK_NUMBER_COERCE_MARKER (start1
);
2994 begp1
= XINT (start1
);
2997 endp1
= BUF_ZV (bp1
);
3000 CHECK_NUMBER_COERCE_MARKER (end1
);
3001 endp1
= XINT (end1
);
3005 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
3007 if (!(BUF_BEGV (bp1
) <= begp1
3009 && endp1
<= BUF_ZV (bp1
)))
3010 args_out_of_range (start1
, end1
);
3012 /* Likewise for second substring. */
3015 bp2
= current_buffer
;
3019 buf2
= Fget_buffer (buffer2
);
3022 bp2
= XBUFFER (buf2
);
3023 if (!BUFFER_LIVE_P (bp2
))
3024 error ("Selecting deleted buffer");
3028 begp2
= BUF_BEGV (bp2
);
3031 CHECK_NUMBER_COERCE_MARKER (start2
);
3032 begp2
= XINT (start2
);
3035 endp2
= BUF_ZV (bp2
);
3038 CHECK_NUMBER_COERCE_MARKER (end2
);
3039 endp2
= XINT (end2
);
3043 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
3045 if (!(BUF_BEGV (bp2
) <= begp2
3047 && endp2
<= BUF_ZV (bp2
)))
3048 args_out_of_range (start2
, end2
);
3052 i1_byte
= buf_charpos_to_bytepos (bp1
, i1
);
3053 i2_byte
= buf_charpos_to_bytepos (bp2
, i2
);
3055 while (i1
< endp1
&& i2
< endp2
)
3057 /* When we find a mismatch, we must compare the
3058 characters, not just the bytes. */
3061 if (! NILP (BVAR (bp1
, enable_multibyte_characters
)))
3063 c1
= BUF_FETCH_MULTIBYTE_CHAR (bp1
, i1_byte
);
3064 BUF_INC_POS (bp1
, i1_byte
);
3069 c1
= BUF_FETCH_BYTE (bp1
, i1
);
3070 MAKE_CHAR_MULTIBYTE (c1
);
3074 if (! NILP (BVAR (bp2
, enable_multibyte_characters
)))
3076 c2
= BUF_FETCH_MULTIBYTE_CHAR (bp2
, i2_byte
);
3077 BUF_INC_POS (bp2
, i2_byte
);
3082 c2
= BUF_FETCH_BYTE (bp2
, i2
);
3083 MAKE_CHAR_MULTIBYTE (c2
);
3089 c1
= char_table_translate (trt
, c1
);
3090 c2
= char_table_translate (trt
, c2
);
3094 return make_number (c1
< c2
? -1 - chars
: chars
+ 1);
3097 rarely_quit (chars
);
3100 /* The strings match as far as they go.
3101 If one is shorter, that one is less. */
3102 if (chars
< endp1
- begp1
)
3103 return make_number (chars
+ 1);
3104 else if (chars
< endp2
- begp2
)
3105 return make_number (- chars
- 1);
3107 /* Same length too => they are equal. */
3108 return make_number (0);
3112 /* Set up necessary definitions for diffseq.h; see comments in
3113 diffseq.h for explanation. */
3118 #define XVECREF_YVECREF_EQUAL(ctx, xoff, yoff) \
3119 buffer_chars_equal ((ctx), (xoff), (yoff))
3121 #define OFFSET ptrdiff_t
3123 #define EXTRA_CONTEXT_FIELDS \
3124 /* Buffers to compare. */ \
3125 struct buffer *buffer_a; \
3126 struct buffer *buffer_b; \
3127 /* Bit vectors recording for each character whether it was deleted
3129 unsigned char *deletions; \
3130 unsigned char *insertions;
3132 #define NOTE_DELETE(ctx, xoff) set_bit ((ctx)->deletions, (xoff))
3133 #define NOTE_INSERT(ctx, yoff) set_bit ((ctx)->insertions, (yoff))
3136 static void set_bit (unsigned char *, OFFSET
);
3137 static bool bit_is_set (const unsigned char *, OFFSET
);
3138 static bool buffer_chars_equal (struct context
*, OFFSET
, OFFSET
);
3141 #include "diffseq.h"
3143 DEFUN ("replace-buffer-contents", Freplace_buffer_contents
,
3144 Sreplace_buffer_contents
, 1, 1, "bSource buffer: ",
3145 doc
: /* Replace accessible portion of current buffer with that of SOURCE.
3146 SOURCE can be a buffer or a string that names a buffer.
3147 Interactively, prompt for SOURCE.
3148 As far as possible the replacement is non-destructive, i.e. existing
3149 buffer contents, markers, properties, and overlays in the current
3150 buffer stay intact. */)
3151 (Lisp_Object source
)
3153 struct buffer
*a
= current_buffer
;
3154 Lisp_Object source_buffer
= Fget_buffer (source
);
3155 if (NILP (source_buffer
))
3157 struct buffer
*b
= XBUFFER (source_buffer
);
3158 if (! BUFFER_LIVE_P (b
))
3159 error ("Selecting deleted buffer");
3161 error ("Cannot replace a buffer with itself");
3163 ptrdiff_t min_a
= BEGV
;
3164 ptrdiff_t min_b
= BUF_BEGV (b
);
3165 ptrdiff_t size_a
= ZV
- min_a
;
3166 ptrdiff_t size_b
= BUF_ZV (b
) - min_b
;
3167 eassume (size_a
>= 0);
3168 eassume (size_b
>= 0);
3169 bool a_empty
= size_a
== 0;
3170 bool b_empty
= size_b
== 0;
3172 /* Handle trivial cases where at least one accessible portion is
3175 if (a_empty
&& b_empty
)
3179 return Finsert_buffer_substring (source
, Qnil
, Qnil
);
3183 del_range_both (BEGV
, BEGV_BYTE
, ZV
, ZV_BYTE
, true);
3187 /* FIXME: It is not documented how to initialize the contents of the
3188 context structure. This code cargo-cults from the existing
3189 caller in src/analyze.c of GNU Diffutils, which appears to
3192 ptrdiff_t diags
= size_a
+ size_b
+ 3;
3195 SAFE_NALLOCA (buffer
, 2, diags
);
3196 /* Micro-optimization: Casting to size_t generates much better
3198 ptrdiff_t del_bytes
= (size_t) size_a
/ CHAR_BIT
+ 1;
3199 ptrdiff_t ins_bytes
= (size_t) size_b
/ CHAR_BIT
+ 1;
3200 struct context ctx
= {
3203 .deletions
= SAFE_ALLOCA (del_bytes
),
3204 .insertions
= SAFE_ALLOCA (ins_bytes
),
3205 .fdiag
= buffer
+ size_b
+ 1,
3206 .bdiag
= buffer
+ diags
+ size_b
+ 1,
3207 /* FIXME: Find a good number for .too_expensive. */
3208 .too_expensive
= 1000000,
3210 memclear (ctx
.deletions
, del_bytes
);
3211 memclear (ctx
.insertions
, ins_bytes
);
3212 /* compareseq requires indices to be zero-based. We add BEGV back
3214 bool early_abort
= compareseq (0, size_a
, 0, size_b
, false, &ctx
);
3215 /* Since we didn’t define EARLY_ABORT, we should never abort
3217 eassert (! early_abort
);
3221 ptrdiff_t count
= SPECPDL_INDEX ();
3222 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
3224 ptrdiff_t i
= size_a
;
3225 ptrdiff_t j
= size_b
;
3226 /* Walk backwards through the lists of changes. This was also
3227 cargo-culted from src/analyze.c in GNU Diffutils. Because we
3228 walk backwards, we don’t have to keep the positions in sync. */
3229 while (i
>= 0 || j
>= 0)
3231 /* Check whether there is a change (insertion or deletion)
3232 before the current position. */
3233 if ((i
> 0 && bit_is_set (ctx
.deletions
, i
- 1)) ||
3234 (j
> 0 && bit_is_set (ctx
.insertions
, j
- 1)))
3236 ptrdiff_t end_a
= min_a
+ i
;
3237 ptrdiff_t end_b
= min_b
+ j
;
3238 /* Find the beginning of the current change run. */
3239 while (i
> 0 && bit_is_set (ctx
.deletions
, i
- 1))
3241 while (j
> 0 && bit_is_set (ctx
.insertions
, j
- 1))
3243 ptrdiff_t beg_a
= min_a
+ i
;
3244 ptrdiff_t beg_b
= min_b
+ j
;
3245 eassert (beg_a
>= BEGV
);
3246 eassert (beg_b
>= BUF_BEGV (b
));
3247 eassert (beg_a
<= end_a
);
3248 eassert (beg_b
<= end_b
);
3249 eassert (end_a
<= ZV
);
3250 eassert (end_b
<= BUF_ZV (b
));
3251 eassert (beg_a
< end_a
|| beg_b
< end_b
);
3253 del_range (beg_a
, end_a
);
3257 Finsert_buffer_substring (source
, make_natnum (beg_b
),
3258 make_natnum (end_b
));
3265 return unbind_to (count
, Qnil
);
3269 set_bit (unsigned char *a
, ptrdiff_t i
)
3272 /* Micro-optimization: Casting to size_t generates much better
3275 a
[j
/ CHAR_BIT
] |= (1 << (j
% CHAR_BIT
));
3279 bit_is_set (const unsigned char *a
, ptrdiff_t i
)
3282 /* Micro-optimization: Casting to size_t generates much better
3285 return a
[j
/ CHAR_BIT
] & (1 << (j
% CHAR_BIT
));
3288 /* Return true if the characters at position POS_A of buffer
3289 CTX->buffer_a and at position POS_B of buffer CTX->buffer_b are
3290 equal. POS_A and POS_B are zero-based. Text properties are
3294 buffer_chars_equal (struct context
*ctx
,
3295 ptrdiff_t pos_a
, ptrdiff_t pos_b
)
3297 eassert (pos_a
>= 0);
3298 pos_a
+= BUF_BEGV (ctx
->buffer_a
);
3299 eassert (pos_a
>= BUF_BEGV (ctx
->buffer_a
));
3300 eassert (pos_a
< BUF_ZV (ctx
->buffer_a
));
3302 eassert (pos_b
>= 0);
3303 pos_b
+= BUF_BEGV (ctx
->buffer_b
);
3304 eassert (pos_b
>= BUF_BEGV (ctx
->buffer_b
));
3305 eassert (pos_b
< BUF_ZV (ctx
->buffer_b
));
3307 return BUF_FETCH_CHAR_AS_MULTIBYTE (ctx
->buffer_a
, pos_a
)
3308 == BUF_FETCH_CHAR_AS_MULTIBYTE (ctx
->buffer_b
, pos_b
);
3313 subst_char_in_region_unwind (Lisp_Object arg
)
3315 bset_undo_list (current_buffer
, arg
);
3319 subst_char_in_region_unwind_1 (Lisp_Object arg
)
3321 bset_filename (current_buffer
, arg
);
3324 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
3325 Ssubst_char_in_region
, 4, 5, 0,
3326 doc
: /* From START to END, replace FROMCHAR with TOCHAR each time it occurs.
3327 If optional arg NOUNDO is non-nil, don't record this change for undo
3328 and don't mark the buffer as really changed.
3329 Both characters must have the same length of multi-byte form. */)
3330 (Lisp_Object start
, Lisp_Object end
, Lisp_Object fromchar
, Lisp_Object tochar
, Lisp_Object noundo
)
3332 register ptrdiff_t pos
, pos_byte
, stop
, i
, len
, end_byte
;
3333 /* Keep track of the first change in the buffer:
3334 if 0 we haven't found it yet.
3335 if < 0 we've found it and we've run the before-change-function.
3336 if > 0 we've actually performed it and the value is its position. */
3337 ptrdiff_t changed
= 0;
3338 unsigned char fromstr
[MAX_MULTIBYTE_LENGTH
], tostr
[MAX_MULTIBYTE_LENGTH
];
3340 ptrdiff_t count
= SPECPDL_INDEX ();
3341 #define COMBINING_NO 0
3342 #define COMBINING_BEFORE 1
3343 #define COMBINING_AFTER 2
3344 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
3345 int maybe_byte_combining
= COMBINING_NO
;
3346 ptrdiff_t last_changed
= 0;
3348 = !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3353 validate_region (&start
, &end
);
3354 CHECK_CHARACTER (fromchar
);
3355 CHECK_CHARACTER (tochar
);
3356 fromc
= XFASTINT (fromchar
);
3357 toc
= XFASTINT (tochar
);
3361 len
= CHAR_STRING (fromc
, fromstr
);
3362 if (CHAR_STRING (toc
, tostr
) != len
)
3363 error ("Characters in `subst-char-in-region' have different byte-lengths");
3364 if (!ASCII_CHAR_P (*tostr
))
3366 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
3367 complete multibyte character, it may be combined with the
3368 after bytes. If it is in the range 0xA0..0xFF, it may be
3369 combined with the before and after bytes. */
3370 if (!CHAR_HEAD_P (*tostr
))
3371 maybe_byte_combining
= COMBINING_BOTH
;
3372 else if (BYTES_BY_CHAR_HEAD (*tostr
) > len
)
3373 maybe_byte_combining
= COMBINING_AFTER
;
3384 pos_byte
= CHAR_TO_BYTE (pos
);
3385 stop
= CHAR_TO_BYTE (XINT (end
));
3388 /* If we don't want undo, turn off putting stuff on the list.
3389 That's faster than getting rid of things,
3390 and it prevents even the entry for a first change.
3391 Also inhibit locking the file. */
3392 if (!changed
&& !NILP (noundo
))
3394 record_unwind_protect (subst_char_in_region_unwind
,
3395 BVAR (current_buffer
, undo_list
));
3396 bset_undo_list (current_buffer
, Qt
);
3397 /* Don't do file-locking. */
3398 record_unwind_protect (subst_char_in_region_unwind_1
,
3399 BVAR (current_buffer
, filename
));
3400 bset_filename (current_buffer
, Qnil
);
3403 if (pos_byte
< GPT_BYTE
)
3404 stop
= min (stop
, GPT_BYTE
);
3407 ptrdiff_t pos_byte_next
= pos_byte
;
3409 if (pos_byte
>= stop
)
3411 if (pos_byte
>= end_byte
) break;
3414 p
= BYTE_POS_ADDR (pos_byte
);
3416 INC_POS (pos_byte_next
);
3419 if (pos_byte_next
- pos_byte
== len
3420 && p
[0] == fromstr
[0]
3422 || (p
[1] == fromstr
[1]
3423 && (len
== 2 || (p
[2] == fromstr
[2]
3424 && (len
== 3 || p
[3] == fromstr
[3]))))))
3427 /* We've already seen this and run the before-change-function;
3428 this time we only need to record the actual position. */
3433 modify_text (pos
, XINT (end
));
3435 if (! NILP (noundo
))
3437 if (MODIFF
- 1 == SAVE_MODIFF
)
3439 if (MODIFF
- 1 == BUF_AUTOSAVE_MODIFF (current_buffer
))
3440 BUF_AUTOSAVE_MODIFF (current_buffer
)++;
3443 /* The before-change-function may have moved the gap
3444 or even modified the buffer so we should start over. */
3448 /* Take care of the case where the new character
3449 combines with neighboring bytes. */
3450 if (maybe_byte_combining
3451 && (maybe_byte_combining
== COMBINING_AFTER
3452 ? (pos_byte_next
< Z_BYTE
3453 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
3454 : ((pos_byte_next
< Z_BYTE
3455 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
3456 || (pos_byte
> BEG_BYTE
3457 && ! ASCII_CHAR_P (FETCH_BYTE (pos_byte
- 1))))))
3459 Lisp_Object tem
, string
;
3461 tem
= BVAR (current_buffer
, undo_list
);
3463 /* Make a multibyte string containing this single character. */
3464 string
= make_multibyte_string ((char *) tostr
, 1, len
);
3465 /* replace_range is less efficient, because it moves the gap,
3466 but it handles combining correctly. */
3467 replace_range (pos
, pos
+ 1, string
,
3469 pos_byte_next
= CHAR_TO_BYTE (pos
);
3470 if (pos_byte_next
> pos_byte
)
3471 /* Before combining happened. We should not increment
3472 POS. So, to cancel the later increment of POS,
3476 INC_POS (pos_byte_next
);
3478 if (! NILP (noundo
))
3479 bset_undo_list (current_buffer
, tem
);
3484 record_change (pos
, 1);
3485 for (i
= 0; i
< len
; i
++) *p
++ = tostr
[i
];
3487 last_changed
= pos
+ 1;
3489 pos_byte
= pos_byte_next
;
3495 signal_after_change (changed
,
3496 last_changed
- changed
, last_changed
- changed
);
3497 update_compositions (changed
, last_changed
, CHECK_ALL
);
3500 unbind_to (count
, Qnil
);
3505 static Lisp_Object
check_translation (ptrdiff_t, ptrdiff_t, ptrdiff_t,
3508 /* Helper function for Ftranslate_region_internal.
3510 Check if a character sequence at POS (POS_BYTE) matches an element
3511 of VAL. VAL is a list (([FROM-CHAR ...] . TO) ...). If a matching
3512 element is found, return it. Otherwise return Qnil. */
3515 check_translation (ptrdiff_t pos
, ptrdiff_t pos_byte
, ptrdiff_t end
,
3518 int initial_buf
[16];
3519 int *buf
= initial_buf
;
3520 ptrdiff_t buf_size
= ARRAYELTS (initial_buf
);
3522 ptrdiff_t buf_used
= 0;
3523 Lisp_Object result
= Qnil
;
3525 for (; CONSP (val
); val
= XCDR (val
))
3534 if (! VECTORP (elt
))
3537 if (len
<= end
- pos
)
3539 for (i
= 0; i
< len
; i
++)
3543 unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
3546 if (buf_used
== buf_size
)
3548 bufalloc
= xpalloc (bufalloc
, &buf_size
, 1, -1,
3550 if (buf
== initial_buf
)
3551 memcpy (bufalloc
, buf
, sizeof initial_buf
);
3554 buf
[buf_used
++] = STRING_CHAR_AND_LENGTH (p
, len1
);
3557 if (XINT (AREF (elt
, i
)) != buf
[i
])
3562 result
= XCAR (val
);
3573 DEFUN ("translate-region-internal", Ftranslate_region_internal
,
3574 Stranslate_region_internal
, 3, 3, 0,
3575 doc
: /* Internal use only.
3576 From START to END, translate characters according to TABLE.
3577 TABLE is a string or a char-table; the Nth character in it is the
3578 mapping for the character with code N.
3579 It returns the number of characters changed. */)
3580 (Lisp_Object start
, Lisp_Object end
, register Lisp_Object table
)
3582 register unsigned char *tt
; /* Trans table. */
3583 register int nc
; /* New character. */
3584 int cnt
; /* Number of changes made. */
3585 ptrdiff_t size
; /* Size of translate table. */
3586 ptrdiff_t pos
, pos_byte
, end_pos
;
3587 bool multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3588 bool string_multibyte UNINIT
;
3590 validate_region (&start
, &end
);
3591 if (CHAR_TABLE_P (table
))
3593 if (! EQ (XCHAR_TABLE (table
)->purpose
, Qtranslation_table
))
3594 error ("Not a translation table");
3600 CHECK_STRING (table
);
3602 if (! multibyte
&& (SCHARS (table
) < SBYTES (table
)))
3603 table
= string_make_unibyte (table
);
3604 string_multibyte
= SCHARS (table
) < SBYTES (table
);
3605 size
= SBYTES (table
);
3610 pos_byte
= CHAR_TO_BYTE (pos
);
3611 end_pos
= XINT (end
);
3612 modify_text (pos
, end_pos
);
3615 for (; pos
< end_pos
; )
3617 unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
3618 unsigned char *str UNINIT
;
3619 unsigned char buf
[MAX_MULTIBYTE_LENGTH
];
3625 oc
= STRING_CHAR_AND_LENGTH (p
, len
);
3632 /* Reload as signal_after_change in last iteration may GC. */
3634 if (string_multibyte
)
3636 str
= tt
+ string_char_to_byte (table
, oc
);
3637 nc
= STRING_CHAR_AND_LENGTH (str
, str_len
);
3642 if (! ASCII_CHAR_P (nc
) && multibyte
)
3644 str_len
= BYTE8_STRING (nc
, buf
);
3657 val
= CHAR_TABLE_REF (table
, oc
);
3658 if (CHARACTERP (val
))
3660 nc
= XFASTINT (val
);
3661 str_len
= CHAR_STRING (nc
, buf
);
3664 else if (VECTORP (val
) || (CONSP (val
)))
3666 /* VAL is [TO_CHAR ...] or (([FROM-CHAR ...] . TO) ...)
3667 where TO is TO-CHAR or [TO-CHAR ...]. */
3672 if (nc
!= oc
&& nc
>= 0)
3674 /* Simple one char to one char translation. */
3679 /* This is less efficient, because it moves the gap,
3680 but it should handle multibyte characters correctly. */
3681 string
= make_multibyte_string ((char *) str
, 1, str_len
);
3682 replace_range (pos
, pos
+ 1, string
, 1, 0, 1, 0);
3687 record_change (pos
, 1);
3688 while (str_len
-- > 0)
3690 signal_after_change (pos
, 1, 1);
3691 update_compositions (pos
, pos
+ 1, CHECK_BORDER
);
3701 val
= check_translation (pos
, pos_byte
, end_pos
, val
);
3708 /* VAL is ([FROM-CHAR ...] . TO). */
3709 len
= ASIZE (XCAR (val
));
3717 string
= Fconcat (1, &val
);
3721 string
= Fmake_string (make_number (1), val
);
3723 replace_range (pos
, pos
+ len
, string
, 1, 0, 1, 0);
3724 pos_byte
+= SBYTES (string
);
3725 pos
+= SCHARS (string
);
3726 cnt
+= SCHARS (string
);
3727 end_pos
+= SCHARS (string
) - len
;
3735 return make_number (cnt
);
3738 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
3739 doc
: /* Delete the text between START and END.
3740 If called interactively, delete the region between point and mark.
3741 This command deletes buffer text without modifying the kill ring. */)
3742 (Lisp_Object start
, Lisp_Object end
)
3744 validate_region (&start
, &end
);
3745 del_range (XINT (start
), XINT (end
));
3749 DEFUN ("delete-and-extract-region", Fdelete_and_extract_region
,
3750 Sdelete_and_extract_region
, 2, 2, 0,
3751 doc
: /* Delete the text between START and END and return it. */)
3752 (Lisp_Object start
, Lisp_Object end
)
3754 validate_region (&start
, &end
);
3755 if (XINT (start
) == XINT (end
))
3756 return empty_unibyte_string
;
3757 return del_range_1 (XINT (start
), XINT (end
), 1, 1);
3760 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
3761 doc
: /* Remove restrictions (narrowing) from current buffer.
3762 This allows the buffer's full text to be seen and edited. */)
3765 if (BEG
!= BEGV
|| Z
!= ZV
)
3766 current_buffer
->clip_changed
= 1;
3768 BEGV_BYTE
= BEG_BYTE
;
3769 SET_BUF_ZV_BOTH (current_buffer
, Z
, Z_BYTE
);
3770 /* Changing the buffer bounds invalidates any recorded current column. */
3771 invalidate_current_column ();
3775 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
3776 doc
: /* Restrict editing in this buffer to the current region.
3777 The rest of the text becomes temporarily invisible and untouchable
3778 but is not deleted; if you save the buffer in a file, the invisible
3779 text is included in the file. \\[widen] makes all visible again.
3780 See also `save-restriction'.
3782 When calling from a program, pass two arguments; positions (integers
3783 or markers) bounding the text that should remain visible. */)
3784 (register Lisp_Object start
, Lisp_Object end
)
3786 CHECK_NUMBER_COERCE_MARKER (start
);
3787 CHECK_NUMBER_COERCE_MARKER (end
);
3789 if (XINT (start
) > XINT (end
))
3792 tem
= start
; start
= end
; end
= tem
;
3795 if (!(BEG
<= XINT (start
) && XINT (start
) <= XINT (end
) && XINT (end
) <= Z
))
3796 args_out_of_range (start
, end
);
3798 if (BEGV
!= XFASTINT (start
) || ZV
!= XFASTINT (end
))
3799 current_buffer
->clip_changed
= 1;
3801 SET_BUF_BEGV (current_buffer
, XFASTINT (start
));
3802 SET_BUF_ZV (current_buffer
, XFASTINT (end
));
3803 if (PT
< XFASTINT (start
))
3804 SET_PT (XFASTINT (start
));
3805 if (PT
> XFASTINT (end
))
3806 SET_PT (XFASTINT (end
));
3807 /* Changing the buffer bounds invalidates any recorded current column. */
3808 invalidate_current_column ();
3813 save_restriction_save (void)
3815 if (BEGV
== BEG
&& ZV
== Z
)
3816 /* The common case that the buffer isn't narrowed.
3817 We return just the buffer object, which save_restriction_restore
3818 recognizes as meaning `no restriction'. */
3819 return Fcurrent_buffer ();
3821 /* We have to save a restriction, so return a pair of markers, one
3822 for the beginning and one for the end. */
3824 Lisp_Object beg
, end
;
3826 beg
= build_marker (current_buffer
, BEGV
, BEGV_BYTE
);
3827 end
= build_marker (current_buffer
, ZV
, ZV_BYTE
);
3829 /* END must move forward if text is inserted at its exact location. */
3830 XMARKER (end
)->insertion_type
= 1;
3832 return Fcons (beg
, end
);
3837 save_restriction_restore (Lisp_Object data
)
3839 struct buffer
*cur
= NULL
;
3840 struct buffer
*buf
= (CONSP (data
)
3841 ? XMARKER (XCAR (data
))->buffer
3844 if (buf
&& buf
!= current_buffer
&& !NILP (BVAR (buf
, pt_marker
)))
3845 { /* If `buf' uses markers to keep track of PT, BEGV, and ZV (as
3846 is the case if it is or has an indirect buffer), then make
3847 sure it is current before we update BEGV, so
3848 set_buffer_internal takes care of managing those markers. */
3849 cur
= current_buffer
;
3850 set_buffer_internal (buf
);
3854 /* A pair of marks bounding a saved restriction. */
3856 struct Lisp_Marker
*beg
= XMARKER (XCAR (data
));
3857 struct Lisp_Marker
*end
= XMARKER (XCDR (data
));
3858 eassert (buf
== end
->buffer
);
3860 if (buf
/* Verify marker still points to a buffer. */
3861 && (beg
->charpos
!= BUF_BEGV (buf
) || end
->charpos
!= BUF_ZV (buf
)))
3862 /* The restriction has changed from the saved one, so restore
3863 the saved restriction. */
3865 ptrdiff_t pt
= BUF_PT (buf
);
3867 SET_BUF_BEGV_BOTH (buf
, beg
->charpos
, beg
->bytepos
);
3868 SET_BUF_ZV_BOTH (buf
, end
->charpos
, end
->bytepos
);
3870 if (pt
< beg
->charpos
|| pt
> end
->charpos
)
3871 /* The point is outside the new visible range, move it inside. */
3872 SET_BUF_PT_BOTH (buf
,
3873 clip_to_bounds (beg
->charpos
, pt
, end
->charpos
),
3874 clip_to_bounds (beg
->bytepos
, BUF_PT_BYTE (buf
),
3877 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3879 /* These aren't needed anymore, so don't wait for GC. */
3880 free_marker (XCAR (data
));
3881 free_marker (XCDR (data
));
3882 free_cons (XCONS (data
));
3885 /* A buffer, which means that there was no old restriction. */
3887 if (buf
/* Verify marker still points to a buffer. */
3888 && (BUF_BEGV (buf
) != BUF_BEG (buf
) || BUF_ZV (buf
) != BUF_Z (buf
)))
3889 /* The buffer has been narrowed, get rid of the narrowing. */
3891 SET_BUF_BEGV_BOTH (buf
, BUF_BEG (buf
), BUF_BEG_BYTE (buf
));
3892 SET_BUF_ZV_BOTH (buf
, BUF_Z (buf
), BUF_Z_BYTE (buf
));
3894 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3898 /* Changing the buffer bounds invalidates any recorded current column. */
3899 invalidate_current_column ();
3902 set_buffer_internal (cur
);
3905 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
3906 doc
: /* Execute BODY, saving and restoring current buffer's restrictions.
3907 The buffer's restrictions make parts of the beginning and end invisible.
3908 \(They are set up with `narrow-to-region' and eliminated with `widen'.)
3909 This special form, `save-restriction', saves the current buffer's restrictions
3910 when it is entered, and restores them when it is exited.
3911 So any `narrow-to-region' within BODY lasts only until the end of the form.
3912 The old restrictions settings are restored
3913 even in case of abnormal exit (throw or error).
3915 The value returned is the value of the last form in BODY.
3917 Note: if you are using both `save-excursion' and `save-restriction',
3918 use `save-excursion' outermost:
3919 (save-excursion (save-restriction ...))
3921 usage: (save-restriction &rest BODY) */)
3924 register Lisp_Object val
;
3925 ptrdiff_t count
= SPECPDL_INDEX ();
3927 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
3928 val
= Fprogn (body
);
3929 return unbind_to (count
, val
);
3932 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
3933 doc
: /* Display a message at the bottom of the screen.
3934 The message also goes into the `*Messages*' buffer, if `message-log-max'
3935 is non-nil. (In keyboard macros, that's all it does.)
3938 In batch mode, the message is printed to the standard error stream,
3939 followed by a newline.
3941 The first argument is a format control string, and the rest are data
3942 to be formatted under control of the string. Percent sign (%), grave
3943 accent (\\=`) and apostrophe (\\=') are special in the format; see
3944 `format-message' for details. To display STRING without special
3945 treatment, use (message "%s" STRING).
3947 If the first argument is nil or the empty string, the function clears
3948 any existing message; this lets the minibuffer contents show. See
3949 also `current-message'.
3951 usage: (message FORMAT-STRING &rest ARGS) */)
3952 (ptrdiff_t nargs
, Lisp_Object
*args
)
3955 || (STRINGP (args
[0])
3956 && SBYTES (args
[0]) == 0))
3963 Lisp_Object val
= Fformat_message (nargs
, args
);
3969 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
3970 doc
: /* Display a message, in a dialog box if possible.
3971 If a dialog box is not available, use the echo area.
3972 The first argument is a format control string, and the rest are data
3973 to be formatted under control of the string. See `format-message' for
3976 If the first argument is nil or the empty string, clear any existing
3977 message; let the minibuffer contents show.
3979 usage: (message-box FORMAT-STRING &rest ARGS) */)
3980 (ptrdiff_t nargs
, Lisp_Object
*args
)
3989 Lisp_Object val
= Fformat_message (nargs
, args
);
3990 Lisp_Object pane
, menu
;
3992 pane
= list1 (Fcons (build_string ("OK"), Qt
));
3993 menu
= Fcons (val
, pane
);
3994 Fx_popup_dialog (Qt
, menu
, Qt
);
3999 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
4000 doc
: /* Display a message in a dialog box or in the echo area.
4001 If this command was invoked with the mouse, use a dialog box if
4002 `use-dialog-box' is non-nil.
4003 Otherwise, use the echo area.
4004 The first argument is a format control string, and the rest are data
4005 to be formatted under control of the string. See `format-message' for
4008 If the first argument is nil or the empty string, clear any existing
4009 message; let the minibuffer contents show.
4011 usage: (message-or-box FORMAT-STRING &rest ARGS) */)
4012 (ptrdiff_t nargs
, Lisp_Object
*args
)
4014 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
4016 return Fmessage_box (nargs
, args
);
4017 return Fmessage (nargs
, args
);
4020 DEFUN ("current-message", Fcurrent_message
, Scurrent_message
, 0, 0, 0,
4021 doc
: /* Return the string currently displayed in the echo area, or nil if none. */)
4024 return current_message ();
4028 DEFUN ("propertize", Fpropertize
, Spropertize
, 1, MANY
, 0,
4029 doc
: /* Return a copy of STRING with text properties added.
4030 First argument is the string to copy.
4031 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
4032 properties to add to the result.
4033 usage: (propertize STRING &rest PROPERTIES) */)
4034 (ptrdiff_t nargs
, Lisp_Object
*args
)
4036 Lisp_Object properties
, string
;
4039 /* Number of args must be odd. */
4040 if ((nargs
& 1) == 0)
4041 error ("Wrong number of arguments");
4043 properties
= string
= Qnil
;
4045 /* First argument must be a string. */
4046 CHECK_STRING (args
[0]);
4047 string
= Fcopy_sequence (args
[0]);
4049 for (i
= 1; i
< nargs
; i
+= 2)
4050 properties
= Fcons (args
[i
], Fcons (args
[i
+ 1], properties
));
4052 Fadd_text_properties (make_number (0),
4053 make_number (SCHARS (string
)),
4054 properties
, string
);
4058 /* Convert the prefix of STR from ASCII decimal digits to a number.
4059 Set *STR_END to the address of the first non-digit. Return the
4060 number, or PTRDIFF_MAX on overflow. Return 0 if there is no number.
4061 This is like strtol for ptrdiff_t and base 10 and C locale,
4062 except without negative numbers or errno. */
4065 str2num (char *str
, char **str_end
)
4068 for (; c_isdigit (*str
); str
++)
4069 if (INT_MULTIPLY_WRAPV (n
, 10, &n
) || INT_ADD_WRAPV (n
, *str
- '0', &n
))
4075 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
4076 doc
: /* Format a string out of a format-string and arguments.
4077 The first argument is a format control string.
4078 The other arguments are substituted into it to make the result, a string.
4080 The format control string may contain %-sequences meaning to substitute
4081 the next available argument, or the argument explicitly specified:
4083 %s means print a string argument. Actually, prints any object, with `princ'.
4084 %d means print as signed number in decimal.
4085 %o means print as unsigned number in octal, %x as unsigned number in hex.
4086 %X is like %x, but uses upper case.
4087 %e means print a number in exponential notation.
4088 %f means print a number in decimal-point notation.
4089 %g means print a number in exponential notation if the exponent would be
4090 less than -4 or greater than or equal to the precision (default: 6);
4091 otherwise it prints in decimal-point notation.
4092 %c means print a number as a single character.
4093 %S means print any object as an s-expression (using `prin1').
4095 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
4096 Use %% to put a single % into the output.
4098 A %-sequence other than %% may contain optional field number, flag,
4099 width, and precision specifiers, as follows:
4101 %<field><flags><width><precision>character
4103 where field is [0-9]+ followed by a literal dollar "$", flags is
4104 [+ #-0]+, width is [0-9]+, and precision is a literal period "."
4107 If a %-sequence is numbered with a field with positive value N, the
4108 Nth argument is substituted instead of the next one. A format can
4109 contain either numbered or unnumbered %-sequences but not both, except
4110 that %% can be mixed with numbered %-sequences.
4112 The + flag character inserts a + before any positive number, while a
4113 space inserts a space before any positive number; these flags only
4114 affect %d, %e, %f, and %g sequences, and the + flag takes precedence.
4115 The - and 0 flags affect the width specifier, as described below.
4117 The # flag means to use an alternate display form for %o, %x, %X, %e,
4118 %f, and %g sequences: for %o, it ensures that the result begins with
4119 \"0\"; for %x and %X, it prefixes the result with \"0x\" or \"0X\";
4120 for %e and %f, it causes a decimal point to be included even if the
4121 precision is zero; for %g, it causes a decimal point to be
4122 included even if the precision is zero, and also forces trailing
4123 zeros after the decimal point to be left in place.
4125 The width specifier supplies a lower limit for the length of the
4126 printed representation. The padding, if any, normally goes on the
4127 left, but it goes on the right if the - flag is present. The padding
4128 character is normally a space, but it is 0 if the 0 flag is present.
4129 The 0 flag is ignored if the - flag is present, or the format sequence
4130 is something other than %d, %e, %f, and %g.
4132 For %e and %f sequences, the number after the "." in the precision
4133 specifier says how many decimal places to show; if zero, the decimal
4134 point itself is omitted. For %g, the precision specifies how many
4135 significant digits to print; zero or omitted are treated as 1.
4136 For %s and %S, the precision specifier truncates the string to the
4139 Text properties, if any, are copied from the format-string to the
4142 usage: (format STRING &rest OBJECTS) */)
4143 (ptrdiff_t nargs
, Lisp_Object
*args
)
4145 return styled_format (nargs
, args
, false);
4148 DEFUN ("format-message", Fformat_message
, Sformat_message
, 1, MANY
, 0,
4149 doc
: /* Format a string out of a format-string and arguments.
4150 The first argument is a format control string.
4151 The other arguments are substituted into it to make the result, a string.
4153 This acts like `format', except it also replaces each grave accent (\\=`)
4154 by a left quote, and each apostrophe (\\=') by a right quote. The left
4155 and right quote replacement characters are specified by
4156 `text-quoting-style'.
4158 usage: (format-message STRING &rest OBJECTS) */)
4159 (ptrdiff_t nargs
, Lisp_Object
*args
)
4161 return styled_format (nargs
, args
, true);
4164 /* Implement ‘format-message’ if MESSAGE is true, ‘format’ otherwise. */
4167 styled_format (ptrdiff_t nargs
, Lisp_Object
*args
, bool message
)
4169 ptrdiff_t n
; /* The number of the next arg to substitute. */
4170 char initial_buffer
[4000];
4171 char *buf
= initial_buffer
;
4172 ptrdiff_t bufsize
= sizeof initial_buffer
;
4173 ptrdiff_t max_bufsize
= STRING_BYTES_BOUND
+ 1;
4175 ptrdiff_t buf_save_value_index UNINIT
;
4178 /* When we make a multibyte string, we must pay attention to the
4179 byte combining problem, i.e., a byte may be combined with a
4180 multibyte character of the previous string. This flag tells if we
4181 must consider such a situation or not. */
4182 bool maybe_combine_byte
;
4184 bool arg_intervals
= false;
4186 sa_avail
-= sizeof initial_buffer
;
4188 /* Information recorded for each format spec. */
4191 /* The corresponding argument, converted to string if conversion
4193 Lisp_Object argument
;
4195 /* The start and end bytepos in the output string. */
4196 ptrdiff_t start
, end
;
4198 /* Whether the argument is a string with intervals. */
4199 bool_bf intervals
: 1;
4202 CHECK_STRING (args
[0]);
4203 char *format_start
= SSDATA (args
[0]);
4204 bool multibyte_format
= STRING_MULTIBYTE (args
[0]);
4205 ptrdiff_t formatlen
= SBYTES (args
[0]);
4207 /* Upper bound on number of format specs. Each uses at least 2 chars. */
4208 ptrdiff_t nspec_bound
= SCHARS (args
[0]) >> 1;
4210 /* Allocate the info and discarded tables. */
4211 ptrdiff_t alloca_size
;
4212 if (INT_MULTIPLY_WRAPV (nspec_bound
, sizeof *info
, &alloca_size
)
4213 || INT_ADD_WRAPV (formatlen
, alloca_size
, &alloca_size
)
4214 || SIZE_MAX
< alloca_size
)
4215 memory_full (SIZE_MAX
);
4216 info
= SAFE_ALLOCA (alloca_size
);
4217 /* discarded[I] is 1 if byte I of the format
4218 string was not copied into the output.
4219 It is 2 if byte I was not the first byte of its character. */
4220 char *discarded
= (char *) &info
[nspec_bound
];
4221 memset (discarded
, 0, formatlen
);
4223 /* Try to determine whether the result should be multibyte.
4224 This is not always right; sometimes the result needs to be multibyte
4225 because of an object that we will pass through prin1.
4226 or because a grave accent or apostrophe is requoted,
4227 and in that case, we won't know it here. */
4229 /* True if the output should be a multibyte string,
4230 which is true if any of the inputs is one. */
4231 bool multibyte
= multibyte_format
;
4232 for (ptrdiff_t i
= 1; !multibyte
&& i
< nargs
; i
++)
4233 if (STRINGP (args
[i
]) && STRING_MULTIBYTE (args
[i
]))
4236 int quoting_style
= message
? text_quoting_style () : -1;
4239 ptrdiff_t nspec
= 0;
4241 /* True if a string needs to be allocated to hold the result. */
4242 bool new_result
= false;
4244 /* If we start out planning a unibyte result,
4245 then discover it has to be multibyte, we jump back to retry. */
4251 /* N is the argument index, ISPEC is the specification index. */
4255 /* Scan the format and store result in BUF. */
4256 format
= format_start
;
4257 end
= format
+ formatlen
;
4258 maybe_combine_byte
= false;
4260 while (format
!= end
)
4262 /* The values of N, ISPEC, and FORMAT when the loop body is
4265 ptrdiff_t ispec0
= ispec
;
4266 char *format0
= format
;
4267 char const *convsrc
= format
;
4268 unsigned char format_char
= *format
++;
4270 /* Bytes needed to represent the output of this conversion. */
4271 ptrdiff_t convbytes
= 1;
4273 if (format_char
== '%')
4275 /* General format specifications look like
4277 '%' [field-number] [flags] [field-width] [precision] format
4281 field-number ::= [0-9]+ '$'
4283 field-width ::= [0-9]+
4284 precision ::= '.' [0-9]*
4286 If present, a field-number specifies the argument number
4287 to substitute. Otherwise, the next argument is taken.
4289 If a field-width is specified, it specifies to which width
4290 the output should be padded with blanks, if the output
4291 string is shorter than field-width.
4293 If precision is specified, it specifies the number of
4294 digits to print after the '.' for floats, or the max.
4295 number of chars to print from a string. */
4299 if (c_isdigit (*format
))
4301 num
= str2num (format
, &num_end
);
4302 if (*num_end
== '$')
4305 format
= num_end
+ 1;
4309 bool minus_flag
= false;
4310 bool plus_flag
= false;
4311 bool space_flag
= false;
4312 bool sharp_flag
= false;
4313 bool zero_flag
= false;
4319 case '-': minus_flag
= true; continue;
4320 case '+': plus_flag
= true; continue;
4321 case ' ': space_flag
= true; continue;
4322 case '#': sharp_flag
= true; continue;
4323 case '0': zero_flag
= true; continue;
4328 /* Ignore flags when sprintf ignores them. */
4329 space_flag
&= ! plus_flag
;
4330 zero_flag
&= ! minus_flag
;
4332 num
= str2num (format
, &num_end
);
4333 if (max_bufsize
<= num
)
4335 ptrdiff_t field_width
= num
;
4337 bool precision_given
= *num_end
== '.';
4338 ptrdiff_t precision
= (precision_given
4339 ? str2num (num_end
+ 1, &num_end
)
4344 error ("Format string ends in middle of format specifier");
4346 char conversion
= *format
++;
4347 memset (&discarded
[format0
- format_start
], 1,
4348 format
- format0
- (conversion
== '%'));
4349 if (conversion
== '%')
4357 error ("Not enough arguments for format string");
4359 struct info
*spec
= &info
[ispec
++];
4362 spec
->argument
= args
[n
];
4363 spec
->intervals
= false;
4366 Lisp_Object arg
= spec
->argument
;
4368 /* For 'S', prin1 the argument, and then treat like 's'.
4369 For 's', princ any argument that is not a string or
4370 symbol. But don't do this conversion twice, which might
4371 happen after retrying. */
4372 if ((conversion
== 'S'
4373 || (conversion
== 's'
4374 && ! STRINGP (arg
) && ! SYMBOLP (arg
))))
4376 if (EQ (arg
, args
[n
]))
4378 Lisp_Object noescape
= conversion
== 'S' ? Qnil
: Qt
;
4379 spec
->argument
= arg
= Fprin1_to_string (arg
, noescape
);
4380 if (STRING_MULTIBYTE (arg
) && ! multibyte
)
4388 else if (conversion
== 'c')
4390 if (INTEGERP (arg
) && ! ASCII_CHAR_P (XINT (arg
)))
4397 spec
->argument
= arg
= Fchar_to_string (arg
);
4400 if (!EQ (arg
, args
[n
]))
4407 spec
->argument
= arg
= SYMBOL_NAME (arg
);
4408 if (STRING_MULTIBYTE (arg
) && ! multibyte
)
4415 bool float_conversion
4416 = conversion
== 'e' || conversion
== 'f' || conversion
== 'g';
4418 if (conversion
== 's')
4420 if (format
== end
&& format
- format_start
== 2
4421 && ! string_intervals (args
[0]))
4427 /* handle case (precision[n] >= 0) */
4429 ptrdiff_t prec
= -1;
4430 if (precision_given
)
4433 /* lisp_string_width ignores a precision of 0, but GNU
4434 libc functions print 0 characters when the precision
4435 is 0. Imitate libc behavior here. Changing
4436 lisp_string_width is the right thing, and will be
4437 done, but meanwhile we work with it. */
4439 ptrdiff_t width
, nbytes
;
4440 ptrdiff_t nchars_string
;
4442 width
= nchars_string
= nbytes
= 0;
4446 width
= lisp_string_width (arg
, prec
, &nch
, &nby
);
4449 nchars_string
= SCHARS (arg
);
4450 nbytes
= SBYTES (arg
);
4454 nchars_string
= nch
;
4460 if (convbytes
&& multibyte
&& ! STRING_MULTIBYTE (arg
))
4461 convbytes
= count_size_as_multibyte (SDATA (arg
), nbytes
);
4464 = width
< field_width
? field_width
- width
: 0;
4466 if (max_bufsize
- padding
<= convbytes
)
4468 convbytes
+= padding
;
4469 if (convbytes
<= buf
+ bufsize
- p
)
4473 memset (p
, ' ', padding
);
4477 spec
->start
= nchars
;
4481 && !ASCII_CHAR_P (*((unsigned char *) p
- 1))
4482 && STRING_MULTIBYTE (arg
)
4483 && !CHAR_HEAD_P (SREF (arg
, 0)))
4484 maybe_combine_byte
= true;
4486 p
+= copy_text (SDATA (arg
), (unsigned char *) p
,
4488 STRING_MULTIBYTE (arg
), multibyte
);
4490 nchars
+= nchars_string
;
4494 memset (p
, ' ', padding
);
4500 /* If this argument has text properties, record where
4501 in the result string it appears. */
4502 if (string_intervals (arg
))
4503 spec
->intervals
= arg_intervals
= true;
4509 else if (! (conversion
== 'c' || conversion
== 'd'
4510 || float_conversion
|| conversion
== 'i'
4511 || conversion
== 'o' || conversion
== 'x'
4512 || conversion
== 'X'))
4513 error ("Invalid format operation %%%c",
4514 STRING_CHAR ((unsigned char *) format
- 1));
4515 else if (! (INTEGERP (arg
) || (FLOATP (arg
) && conversion
!= 'c')))
4516 error ("Format specifier doesn't match argument type");
4521 /* Lower bound on the number of bits per
4522 base-FLT_RADIX digit. */
4523 DIG_BITS_LBOUND
= FLT_RADIX
< 16 ? 1 : 4,
4525 /* 1 if integers should be formatted as long doubles,
4526 because they may be so large that there is a rounding
4527 error when converting them to double, and long doubles
4528 are wider than doubles. */
4529 INT_AS_LDBL
= (DIG_BITS_LBOUND
* DBL_MANT_DIG
< FIXNUM_BITS
- 1
4530 && DBL_MANT_DIG
< LDBL_MANT_DIG
),
4532 /* Maximum precision for a %f conversion such that the
4533 trailing output digit might be nonzero. Any precision
4534 larger than this will not yield useful information. */
4535 USEFUL_PRECISION_MAX
=
4537 * (FLT_RADIX
== 2 || FLT_RADIX
== 10 ? 1
4538 : FLT_RADIX
== 16 ? 4
4541 /* Maximum number of bytes generated by any format, if
4542 precision is no more than USEFUL_PRECISION_MAX.
4543 On all practical hosts, %f is the worst case. */
4545 sizeof "-." + (LDBL_MAX_10_EXP
+ 1) + USEFUL_PRECISION_MAX
,
4547 /* Length of pM (that is, of pMd without the
4549 pMlen
= sizeof pMd
- 2
4551 verify (USEFUL_PRECISION_MAX
> 0);
4553 /* Avoid undefined behavior in underlying sprintf. */
4554 if (conversion
== 'd' || conversion
== 'i')
4557 /* Create the copy of the conversion specification, with
4558 any width and precision removed, with ".*" inserted,
4559 with "L" possibly inserted for floating-point formats,
4560 and with pM inserted for integer formats.
4561 At most two flags F can be specified at once. */
4562 char convspec
[sizeof "%FF.*d" + max (INT_AS_LDBL
, pMlen
)];
4566 /* MINUS_FLAG and ZERO_FLAG are dealt with later. */
4567 *f
= '+'; f
+= plus_flag
;
4568 *f
= ' '; f
+= space_flag
;
4569 *f
= '#'; f
+= sharp_flag
;
4572 if (float_conversion
)
4577 f
+= INTEGERP (arg
);
4580 else if (conversion
!= 'c')
4582 memcpy (f
, pMd
, pMlen
);
4584 zero_flag
&= ! precision_given
;
4591 if (precision_given
)
4592 prec
= min (precision
, USEFUL_PRECISION_MAX
);
4594 /* Use sprintf to format this number into sprintf_buf. Omit
4595 padding and excess precision, though, because sprintf limits
4596 output length to INT_MAX.
4598 There are four types of conversion: double, unsigned
4599 char (passed as int), wide signed int, and wide
4600 unsigned int. Treat them separately because the
4601 sprintf ABI is sensitive to which type is passed. Be
4602 careful about integer overflow, NaNs, infinities, and
4603 conversions; for example, the min and max macros are
4604 not suitable here. */
4605 char sprintf_buf
[SPRINTF_BUFSIZE
];
4606 ptrdiff_t sprintf_bytes
;
4607 if (float_conversion
)
4609 if (INT_AS_LDBL
&& INTEGERP (arg
))
4611 /* Although long double may have a rounding error if
4612 DIG_BITS_LBOUND * LDBL_MANT_DIG < FIXNUM_BITS - 1,
4613 it is more accurate than plain 'double'. */
4614 long double x
= XINT (arg
);
4615 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4618 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
,
4621 else if (conversion
== 'c')
4623 /* Don't use sprintf here, as it might mishandle prec. */
4624 sprintf_buf
[0] = XINT (arg
);
4625 sprintf_bytes
= prec
!= 0;
4627 else if (conversion
== 'd' || conversion
== 'i')
4629 /* For float, maybe we should use "%1.0f"
4630 instead so it also works for values outside
4631 the integer range. */
4637 double d
= XFLOAT_DATA (arg
);
4640 x
= TYPE_MINIMUM (printmax_t
);
4646 x
= TYPE_MAXIMUM (printmax_t
);
4651 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4655 /* Don't sign-extend for octal or hex printing. */
4661 double d
= XFLOAT_DATA (arg
);
4666 x
= TYPE_MAXIMUM (uprintmax_t
);
4671 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4674 /* Now the length of the formatted item is known, except it omits
4675 padding and excess precision. Deal with excess precision
4676 first. This happens only when the format specifies
4677 ridiculously large precision. */
4678 ptrdiff_t excess_precision
4679 = precision_given
? precision
- prec
: 0;
4680 ptrdiff_t leading_zeros
= 0, trailing_zeros
= 0;
4681 if (excess_precision
)
4683 if (float_conversion
)
4685 if ((conversion
== 'g' && ! sharp_flag
)
4686 || ! ('0' <= sprintf_buf
[sprintf_bytes
- 1]
4687 && sprintf_buf
[sprintf_bytes
- 1] <= '9'))
4688 excess_precision
= 0;
4691 if (conversion
== 'g')
4693 char *dot
= strchr (sprintf_buf
, '.');
4695 excess_precision
= 0;
4698 trailing_zeros
= excess_precision
;
4701 leading_zeros
= excess_precision
;
4704 /* Compute the total bytes needed for this item, including
4705 excess precision and padding. */
4707 if (INT_ADD_WRAPV (sprintf_bytes
, excess_precision
, &numwidth
))
4708 numwidth
= PTRDIFF_MAX
;
4710 = numwidth
< field_width
? field_width
- numwidth
: 0;
4711 if (max_bufsize
- sprintf_bytes
<= excess_precision
4712 || max_bufsize
- padding
<= numwidth
)
4714 convbytes
= numwidth
+ padding
;
4716 if (convbytes
<= buf
+ bufsize
- p
)
4718 /* Copy the formatted item from sprintf_buf into buf,
4719 inserting padding and excess-precision zeros. */
4721 char *src
= sprintf_buf
;
4723 int exponent_bytes
= 0;
4724 bool signedp
= src0
== '-' || src0
== '+' || src0
== ' ';
4725 unsigned char after_sign
= src
[signedp
];
4726 if (zero_flag
&& 0 <= char_hexdigit (after_sign
))
4728 leading_zeros
+= padding
;
4732 if (excess_precision
4733 && (conversion
== 'e' || conversion
== 'g'))
4735 char *e
= strchr (src
, 'e');
4737 exponent_bytes
= src
+ sprintf_bytes
- e
;
4740 spec
->start
= nchars
;
4743 memset (p
, ' ', padding
);
4751 memset (p
, '0', leading_zeros
);
4753 int significand_bytes
4754 = sprintf_bytes
- signedp
- exponent_bytes
;
4755 memcpy (p
, src
, significand_bytes
);
4756 p
+= significand_bytes
;
4757 src
+= significand_bytes
;
4758 memset (p
, '0', trailing_zeros
);
4759 p
+= trailing_zeros
;
4760 memcpy (p
, src
, exponent_bytes
);
4761 p
+= exponent_bytes
;
4763 nchars
+= leading_zeros
+ sprintf_bytes
+ trailing_zeros
;
4767 memset (p
, ' ', padding
);
4780 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
4782 if ((format_char
== '`' || format_char
== '\'')
4783 && quoting_style
== CURVE_QUOTING_STYLE
)
4790 convsrc
= format_char
== '`' ? uLSQM
: uRSQM
;
4794 else if (format_char
== '`' && quoting_style
== STRAIGHT_QUOTING_STYLE
)
4801 /* Copy a single character from format to buf. */
4802 if (multibyte_format
)
4804 /* Copy a whole multibyte character. */
4806 && !ASCII_CHAR_P (*((unsigned char *) p
- 1))
4807 && !CHAR_HEAD_P (format_char
))
4808 maybe_combine_byte
= true;
4810 while (! CHAR_HEAD_P (*format
))
4813 convbytes
= format
- format0
;
4814 memset (&discarded
[format0
+ 1 - format_start
], 2,
4817 else if (multibyte
&& !ASCII_CHAR_P (format_char
))
4819 int c
= BYTE8_TO_CHAR (format_char
);
4820 convbytes
= CHAR_STRING (c
, str
);
4821 convsrc
= (char *) str
;
4827 if (convbytes
<= buf
+ bufsize
- p
)
4829 memcpy (p
, convsrc
, convbytes
);
4836 /* There wasn't enough room to store this conversion or single
4837 character. CONVBYTES says how much room is needed. Allocate
4838 enough room (and then some) and do it again. */
4840 ptrdiff_t used
= p
- buf
;
4841 if (max_bufsize
- used
< convbytes
)
4843 bufsize
= used
+ convbytes
;
4844 bufsize
= bufsize
< max_bufsize
/ 2 ? bufsize
* 2 : max_bufsize
;
4846 if (buf
== initial_buffer
)
4848 buf
= xmalloc (bufsize
);
4849 sa_must_free
= true;
4850 buf_save_value_index
= SPECPDL_INDEX ();
4851 record_unwind_protect_ptr (xfree
, buf
);
4852 memcpy (buf
, initial_buffer
, used
);
4856 buf
= xrealloc (buf
, bufsize
);
4857 set_unwind_protect_ptr (buf_save_value_index
, xfree
, buf
);
4866 if (bufsize
< p
- buf
)
4875 if (maybe_combine_byte
)
4876 nchars
= multibyte_chars_in_text ((unsigned char *) buf
, p
- buf
);
4877 val
= make_specified_string (buf
, nchars
, p
- buf
, multibyte
);
4879 /* If the format string has text properties, or any of the string
4880 arguments has text properties, set up text properties of the
4883 if (string_intervals (args
[0]) || arg_intervals
)
4885 /* Add text properties from the format string. */
4886 Lisp_Object len
= make_number (SCHARS (args
[0]));
4887 Lisp_Object props
= text_property_list (args
[0], make_number (0),
4891 ptrdiff_t bytepos
= 0, position
= 0, translated
= 0;
4892 ptrdiff_t fieldn
= 0;
4894 /* Adjust the bounds of each text property
4895 to the proper start and end in the output string. */
4897 /* Put the positions in PROPS in increasing order, so that
4898 we can do (effectively) one scan through the position
4899 space of the format string. */
4900 props
= Fnreverse (props
);
4902 /* BYTEPOS is the byte position in the format string,
4903 POSITION is the untranslated char position in it,
4904 TRANSLATED is the translated char position in BUF,
4905 and ARGN is the number of the next arg we will come to. */
4906 for (Lisp_Object list
= props
; CONSP (list
); list
= XCDR (list
))
4908 Lisp_Object item
= XCAR (list
);
4910 /* First adjust the property start position. */
4911 ptrdiff_t pos
= XINT (XCAR (item
));
4913 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
4914 up to this position. */
4915 for (; position
< pos
; bytepos
++)
4917 if (! discarded
[bytepos
])
4918 position
++, translated
++;
4919 else if (discarded
[bytepos
] == 1)
4922 if (fieldn
< nspec
&& translated
== info
[fieldn
].start
)
4924 translated
+= info
[fieldn
].end
- info
[fieldn
].start
;
4930 XSETCAR (item
, make_number (translated
));
4932 /* Likewise adjust the property end position. */
4933 pos
= XINT (XCAR (XCDR (item
)));
4935 for (; position
< pos
; bytepos
++)
4937 if (! discarded
[bytepos
])
4938 position
++, translated
++;
4939 else if (discarded
[bytepos
] == 1)
4942 if (fieldn
< nspec
&& translated
== info
[fieldn
].start
)
4944 translated
+= info
[fieldn
].end
- info
[fieldn
].start
;
4950 XSETCAR (XCDR (item
), make_number (translated
));
4953 add_text_properties_from_list (val
, props
, make_number (0));
4956 /* Add text properties from arguments. */
4958 for (ptrdiff_t i
= 0; i
< nspec
; i
++)
4959 if (info
[i
].intervals
)
4961 len
= make_number (SCHARS (info
[i
].argument
));
4962 Lisp_Object new_len
= make_number (info
[i
].end
- info
[i
].start
);
4963 props
= text_property_list (info
[i
].argument
,
4964 make_number (0), len
, Qnil
);
4965 props
= extend_property_ranges (props
, len
, new_len
);
4966 /* If successive arguments have properties, be sure that
4967 the value of `composition' property be the copy. */
4968 if (1 < i
&& info
[i
- 1].end
)
4969 make_composition_value_copy (props
);
4970 add_text_properties_from_list (val
, props
,
4971 make_number (info
[i
].start
));
4976 /* If we allocated BUF or INFO with malloc, free it too. */
4982 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
4983 doc
: /* Return t if two characters match, optionally ignoring case.
4984 Both arguments must be characters (i.e. integers).
4985 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
4986 (register Lisp_Object c1
, Lisp_Object c2
)
4989 /* Check they're chars, not just integers, otherwise we could get array
4990 bounds violations in downcase. */
4991 CHECK_CHARACTER (c1
);
4992 CHECK_CHARACTER (c2
);
4994 if (XINT (c1
) == XINT (c2
))
4996 if (NILP (BVAR (current_buffer
, case_fold_search
)))
5002 /* FIXME: It is possible to compare multibyte characters even when
5003 the current buffer is unibyte. Unfortunately this is ambiguous
5004 for characters between 128 and 255, as they could be either
5005 eight-bit raw bytes or Latin-1 characters. Assume the former for
5006 now. See Bug#17011, and also see casefiddle.c's casify_object,
5007 which has a similar problem. */
5008 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
5010 if (SINGLE_BYTE_CHAR_P (i1
))
5011 i1
= UNIBYTE_TO_CHAR (i1
);
5012 if (SINGLE_BYTE_CHAR_P (i2
))
5013 i2
= UNIBYTE_TO_CHAR (i2
);
5016 return (downcase (i1
) == downcase (i2
) ? Qt
: Qnil
);
5019 /* Transpose the markers in two regions of the current buffer, and
5020 adjust the ones between them if necessary (i.e.: if the regions
5023 START1, END1 are the character positions of the first region.
5024 START1_BYTE, END1_BYTE are the byte positions.
5025 START2, END2 are the character positions of the second region.
5026 START2_BYTE, END2_BYTE are the byte positions.
5028 Traverses the entire marker list of the buffer to do so, adding an
5029 appropriate amount to some, subtracting from some, and leaving the
5030 rest untouched. Most of this is copied from adjust_markers in insdel.c.
5032 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
5035 transpose_markers (ptrdiff_t start1
, ptrdiff_t end1
,
5036 ptrdiff_t start2
, ptrdiff_t end2
,
5037 ptrdiff_t start1_byte
, ptrdiff_t end1_byte
,
5038 ptrdiff_t start2_byte
, ptrdiff_t end2_byte
)
5040 register ptrdiff_t amt1
, amt1_byte
, amt2
, amt2_byte
, diff
, diff_byte
, mpos
;
5041 register struct Lisp_Marker
*marker
;
5043 /* Update point as if it were a marker. */
5047 TEMP_SET_PT_BOTH (PT
+ (end2
- end1
),
5048 PT_BYTE
+ (end2_byte
- end1_byte
));
5049 else if (PT
< start2
)
5050 TEMP_SET_PT_BOTH (PT
+ (end2
- start2
) - (end1
- start1
),
5051 (PT_BYTE
+ (end2_byte
- start2_byte
)
5052 - (end1_byte
- start1_byte
)));
5054 TEMP_SET_PT_BOTH (PT
- (start2
- start1
),
5055 PT_BYTE
- (start2_byte
- start1_byte
));
5057 /* We used to adjust the endpoints here to account for the gap, but that
5058 isn't good enough. Even if we assume the caller has tried to move the
5059 gap out of our way, it might still be at start1 exactly, for example;
5060 and that places it `inside' the interval, for our purposes. The amount
5061 of adjustment is nontrivial if there's a `denormalized' marker whose
5062 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
5063 the dirty work to Fmarker_position, below. */
5065 /* The difference between the region's lengths */
5066 diff
= (end2
- start2
) - (end1
- start1
);
5067 diff_byte
= (end2_byte
- start2_byte
) - (end1_byte
- start1_byte
);
5069 /* For shifting each marker in a region by the length of the other
5070 region plus the distance between the regions. */
5071 amt1
= (end2
- start2
) + (start2
- end1
);
5072 amt2
= (end1
- start1
) + (start2
- end1
);
5073 amt1_byte
= (end2_byte
- start2_byte
) + (start2_byte
- end1_byte
);
5074 amt2_byte
= (end1_byte
- start1_byte
) + (start2_byte
- end1_byte
);
5076 for (marker
= BUF_MARKERS (current_buffer
); marker
; marker
= marker
->next
)
5078 mpos
= marker
->bytepos
;
5079 if (mpos
>= start1_byte
&& mpos
< end2_byte
)
5081 if (mpos
< end1_byte
)
5083 else if (mpos
< start2_byte
)
5087 marker
->bytepos
= mpos
;
5089 mpos
= marker
->charpos
;
5090 if (mpos
>= start1
&& mpos
< end2
)
5094 else if (mpos
< start2
)
5099 marker
->charpos
= mpos
;
5103 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
5104 doc
: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
5105 The regions should not be overlapping, because the size of the buffer is
5106 never changed in a transposition.
5108 Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
5109 any markers that happen to be located in the regions.
5111 Transposing beyond buffer boundaries is an error. */)
5112 (Lisp_Object startr1
, Lisp_Object endr1
, Lisp_Object startr2
, Lisp_Object endr2
, Lisp_Object leave_markers
)
5114 register ptrdiff_t start1
, end1
, start2
, end2
;
5115 ptrdiff_t start1_byte
, start2_byte
, len1_byte
, len2_byte
, end2_byte
;
5116 ptrdiff_t gap
, len1
, len_mid
, len2
;
5117 unsigned char *start1_addr
, *start2_addr
, *temp
;
5119 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
, tmp_interval3
;
5122 XSETBUFFER (buf
, current_buffer
);
5123 cur_intv
= buffer_intervals (current_buffer
);
5125 validate_region (&startr1
, &endr1
);
5126 validate_region (&startr2
, &endr2
);
5128 start1
= XFASTINT (startr1
);
5129 end1
= XFASTINT (endr1
);
5130 start2
= XFASTINT (startr2
);
5131 end2
= XFASTINT (endr2
);
5134 /* Swap the regions if they're reversed. */
5137 register ptrdiff_t glumph
= start1
;
5145 len1
= end1
- start1
;
5146 len2
= end2
- start2
;
5149 error ("Transposed regions overlap");
5150 /* Nothing to change for adjacent regions with one being empty */
5151 else if ((start1
== end1
|| start2
== end2
) && end1
== start2
)
5154 /* The possibilities are:
5155 1. Adjacent (contiguous) regions, or separate but equal regions
5156 (no, really equal, in this case!), or
5157 2. Separate regions of unequal size.
5159 The worst case is usually No. 2. It means that (aside from
5160 potential need for getting the gap out of the way), there also
5161 needs to be a shifting of the text between the two regions. So
5162 if they are spread far apart, we are that much slower... sigh. */
5164 /* It must be pointed out that the really studly thing to do would
5165 be not to move the gap at all, but to leave it in place and work
5166 around it if necessary. This would be extremely efficient,
5167 especially considering that people are likely to do
5168 transpositions near where they are working interactively, which
5169 is exactly where the gap would be found. However, such code
5170 would be much harder to write and to read. So, if you are
5171 reading this comment and are feeling squirrely, by all means have
5172 a go! I just didn't feel like doing it, so I will simply move
5173 the gap the minimum distance to get it out of the way, and then
5174 deal with an unbroken array. */
5176 start1_byte
= CHAR_TO_BYTE (start1
);
5177 end2_byte
= CHAR_TO_BYTE (end2
);
5179 /* Make sure the gap won't interfere, by moving it out of the text
5180 we will operate on. */
5181 if (start1
< gap
&& gap
< end2
)
5183 if (gap
- start1
< end2
- gap
)
5184 move_gap_both (start1
, start1_byte
);
5186 move_gap_both (end2
, end2_byte
);
5189 start2_byte
= CHAR_TO_BYTE (start2
);
5190 len1_byte
= CHAR_TO_BYTE (end1
) - start1_byte
;
5191 len2_byte
= end2_byte
- start2_byte
;
5193 #ifdef BYTE_COMBINING_DEBUG
5196 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
5197 len2_byte
, start1
, start1_byte
)
5198 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
5199 len1_byte
, end2
, start2_byte
+ len2_byte
)
5200 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
5201 len1_byte
, end2
, start2_byte
+ len2_byte
))
5206 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
5207 len2_byte
, start1
, start1_byte
)
5208 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
5209 len1_byte
, start2
, start2_byte
)
5210 || count_combining_after (BYTE_POS_ADDR (start2_byte
),
5211 len2_byte
, end1
, start1_byte
+ len1_byte
)
5212 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
5213 len1_byte
, end2
, start2_byte
+ len2_byte
))
5218 /* Hmmm... how about checking to see if the gap is large
5219 enough to use as the temporary storage? That would avoid an
5220 allocation... interesting. Later, don't fool with it now. */
5222 /* Working without memmove, for portability (sigh), so must be
5223 careful of overlapping subsections of the array... */
5225 if (end1
== start2
) /* adjacent regions */
5227 modify_text (start1
, end2
);
5228 record_change (start1
, len1
+ len2
);
5230 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
5231 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
5232 /* Don't use Fset_text_properties: that can cause GC, which can
5233 clobber objects stored in the tmp_intervals. */
5234 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
5236 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
5240 /* First region smaller than second. */
5241 if (len1_byte
< len2_byte
)
5243 temp
= SAFE_ALLOCA (len2_byte
);
5245 /* Don't precompute these addresses. We have to compute them
5246 at the last minute, because the relocating allocator might
5247 have moved the buffer around during the xmalloc. */
5248 start1_addr
= BYTE_POS_ADDR (start1_byte
);
5249 start2_addr
= BYTE_POS_ADDR (start2_byte
);
5251 memcpy (temp
, start2_addr
, len2_byte
);
5252 memcpy (start1_addr
+ len2_byte
, start1_addr
, len1_byte
);
5253 memcpy (start1_addr
, temp
, len2_byte
);
5256 /* First region not smaller than second. */
5258 temp
= SAFE_ALLOCA (len1_byte
);
5259 start1_addr
= BYTE_POS_ADDR (start1_byte
);
5260 start2_addr
= BYTE_POS_ADDR (start2_byte
);
5261 memcpy (temp
, start1_addr
, len1_byte
);
5262 memcpy (start1_addr
, start2_addr
, len2_byte
);
5263 memcpy (start1_addr
+ len2_byte
, temp
, len1_byte
);
5267 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
5268 len1
, current_buffer
, 0);
5269 graft_intervals_into_buffer (tmp_interval2
, start1
,
5270 len2
, current_buffer
, 0);
5271 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
5272 update_compositions (start1
+ len2
, end2
, CHECK_TAIL
);
5274 /* Non-adjacent regions, because end1 != start2, bleagh... */
5277 len_mid
= start2_byte
- (start1_byte
+ len1_byte
);
5279 if (len1_byte
== len2_byte
)
5280 /* Regions are same size, though, how nice. */
5284 modify_text (start1
, end1
);
5285 modify_text (start2
, end2
);
5286 record_change (start1
, len1
);
5287 record_change (start2
, len2
);
5288 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
5289 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
5291 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr1
, 0);
5293 set_text_properties_1 (startr1
, endr1
, Qnil
, buf
, tmp_interval3
);
5295 tmp_interval3
= validate_interval_range (buf
, &startr2
, &endr2
, 0);
5297 set_text_properties_1 (startr2
, endr2
, Qnil
, buf
, tmp_interval3
);
5299 temp
= SAFE_ALLOCA (len1_byte
);
5300 start1_addr
= BYTE_POS_ADDR (start1_byte
);
5301 start2_addr
= BYTE_POS_ADDR (start2_byte
);
5302 memcpy (temp
, start1_addr
, len1_byte
);
5303 memcpy (start1_addr
, start2_addr
, len2_byte
);
5304 memcpy (start2_addr
, temp
, len1_byte
);
5307 graft_intervals_into_buffer (tmp_interval1
, start2
,
5308 len1
, current_buffer
, 0);
5309 graft_intervals_into_buffer (tmp_interval2
, start1
,
5310 len2
, current_buffer
, 0);
5313 else if (len1_byte
< len2_byte
) /* Second region larger than first */
5314 /* Non-adjacent & unequal size, area between must also be shifted. */
5318 modify_text (start1
, end2
);
5319 record_change (start1
, (end2
- start1
));
5320 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
5321 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
5322 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
5324 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
5326 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
5328 /* holds region 2 */
5329 temp
= SAFE_ALLOCA (len2_byte
);
5330 start1_addr
= BYTE_POS_ADDR (start1_byte
);
5331 start2_addr
= BYTE_POS_ADDR (start2_byte
);
5332 memcpy (temp
, start2_addr
, len2_byte
);
5333 memcpy (start1_addr
+ len_mid
+ len2_byte
, start1_addr
, len1_byte
);
5334 memmove (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
5335 memcpy (start1_addr
, temp
, len2_byte
);
5338 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
5339 len1
, current_buffer
, 0);
5340 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
5341 len_mid
, current_buffer
, 0);
5342 graft_intervals_into_buffer (tmp_interval2
, start1
,
5343 len2
, current_buffer
, 0);
5346 /* Second region smaller than first. */
5350 record_change (start1
, (end2
- start1
));
5351 modify_text (start1
, end2
);
5353 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
5354 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
5355 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
5357 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
5359 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
5361 /* holds region 1 */
5362 temp
= SAFE_ALLOCA (len1_byte
);
5363 start1_addr
= BYTE_POS_ADDR (start1_byte
);
5364 start2_addr
= BYTE_POS_ADDR (start2_byte
);
5365 memcpy (temp
, start1_addr
, len1_byte
);
5366 memcpy (start1_addr
, start2_addr
, len2_byte
);
5367 memmove (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
5368 memcpy (start1_addr
+ len2_byte
+ len_mid
, temp
, len1_byte
);
5371 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
5372 len1
, current_buffer
, 0);
5373 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
5374 len_mid
, current_buffer
, 0);
5375 graft_intervals_into_buffer (tmp_interval2
, start1
,
5376 len2
, current_buffer
, 0);
5379 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
5380 update_compositions (end2
- len1
, end2
, CHECK_BORDER
);
5383 /* When doing multiple transpositions, it might be nice
5384 to optimize this. Perhaps the markers in any one buffer
5385 should be organized in some sorted data tree. */
5386 if (NILP (leave_markers
))
5388 transpose_markers (start1
, end1
, start2
, end2
,
5389 start1_byte
, start1_byte
+ len1_byte
,
5390 start2_byte
, start2_byte
+ len2_byte
);
5391 fix_start_end_in_overlays (start1
, end2
);
5395 /* The character positions of the markers remain intact, but we
5396 still need to update their byte positions, because the
5397 transposed regions might include multibyte sequences which
5398 make some original byte positions of the markers invalid. */
5399 adjust_markers_bytepos (start1
, start1_byte
, end2
, end2_byte
, 0);
5402 signal_after_change (start1
, end2
- start1
, end2
- start1
);
5408 syms_of_editfns (void)
5410 DEFSYM (Qbuffer_access_fontify_functions
, "buffer-access-fontify-functions");
5411 DEFSYM (Qwall
, "wall");
5413 DEFVAR_LISP ("inhibit-field-text-motion", Vinhibit_field_text_motion
,
5414 doc
: /* Non-nil means text motion commands don't notice fields. */);
5415 Vinhibit_field_text_motion
= Qnil
;
5417 DEFVAR_LISP ("buffer-access-fontify-functions",
5418 Vbuffer_access_fontify_functions
,
5419 doc
: /* List of functions called by `buffer-substring' to fontify if necessary.
5420 Each function is called with two arguments which specify the range
5421 of the buffer being accessed. */);
5422 Vbuffer_access_fontify_functions
= Qnil
;
5426 obuf
= Fcurrent_buffer ();
5427 /* Do this here, because init_buffer_once is too early--it won't work. */
5428 Fset_buffer (Vprin1_to_string_buffer
);
5429 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
5430 Fset (Fmake_local_variable (Qbuffer_access_fontify_functions
), Qnil
);
5434 DEFVAR_LISP ("buffer-access-fontified-property",
5435 Vbuffer_access_fontified_property
,
5436 doc
: /* Property which (if non-nil) indicates text has been fontified.
5437 `buffer-substring' need not call the `buffer-access-fontify-functions'
5438 functions if all the text being accessed has this property. */);
5439 Vbuffer_access_fontified_property
= Qnil
;
5441 DEFVAR_LISP ("system-name", Vsystem_name
,
5442 doc
: /* The host name of the machine Emacs is running on. */);
5443 Vsystem_name
= cached_system_name
= Qnil
;
5445 DEFVAR_LISP ("user-full-name", Vuser_full_name
,
5446 doc
: /* The full name of the user logged in. */);
5448 DEFVAR_LISP ("user-login-name", Vuser_login_name
,
5449 doc
: /* The user's name, taken from environment variables if possible. */);
5450 Vuser_login_name
= Qnil
;
5452 DEFVAR_LISP ("user-real-login-name", Vuser_real_login_name
,
5453 doc
: /* The user's name, based upon the real uid only. */);
5455 DEFVAR_LISP ("operating-system-release", Voperating_system_release
,
5456 doc
: /* The release of the operating system Emacs is running on. */);
5458 defsubr (&Spropertize
);
5459 defsubr (&Schar_equal
);
5460 defsubr (&Sgoto_char
);
5461 defsubr (&Sstring_to_char
);
5462 defsubr (&Schar_to_string
);
5463 defsubr (&Sbyte_to_string
);
5464 defsubr (&Sbuffer_substring
);
5465 defsubr (&Sbuffer_substring_no_properties
);
5466 defsubr (&Sbuffer_string
);
5467 defsubr (&Sget_pos_property
);
5469 defsubr (&Spoint_marker
);
5470 defsubr (&Smark_marker
);
5472 defsubr (&Sregion_beginning
);
5473 defsubr (&Sregion_end
);
5475 /* Symbol for the text property used to mark fields. */
5476 DEFSYM (Qfield
, "field");
5478 /* A special value for Qfield properties. */
5479 DEFSYM (Qboundary
, "boundary");
5481 defsubr (&Sfield_beginning
);
5482 defsubr (&Sfield_end
);
5483 defsubr (&Sfield_string
);
5484 defsubr (&Sfield_string_no_properties
);
5485 defsubr (&Sdelete_field
);
5486 defsubr (&Sconstrain_to_field
);
5488 defsubr (&Sline_beginning_position
);
5489 defsubr (&Sline_end_position
);
5491 defsubr (&Ssave_excursion
);
5492 defsubr (&Ssave_current_buffer
);
5494 defsubr (&Sbuffer_size
);
5495 defsubr (&Spoint_max
);
5496 defsubr (&Spoint_min
);
5497 defsubr (&Spoint_min_marker
);
5498 defsubr (&Spoint_max_marker
);
5499 defsubr (&Sgap_position
);
5500 defsubr (&Sgap_size
);
5501 defsubr (&Sposition_bytes
);
5502 defsubr (&Sbyte_to_position
);
5508 defsubr (&Sfollowing_char
);
5509 defsubr (&Sprevious_char
);
5510 defsubr (&Schar_after
);
5511 defsubr (&Schar_before
);
5513 defsubr (&Sinsert_before_markers
);
5514 defsubr (&Sinsert_and_inherit
);
5515 defsubr (&Sinsert_and_inherit_before_markers
);
5516 defsubr (&Sinsert_char
);
5517 defsubr (&Sinsert_byte
);
5519 defsubr (&Suser_login_name
);
5520 defsubr (&Suser_real_login_name
);
5521 defsubr (&Suser_uid
);
5522 defsubr (&Suser_real_uid
);
5523 defsubr (&Sgroup_gid
);
5524 defsubr (&Sgroup_real_gid
);
5525 defsubr (&Suser_full_name
);
5526 defsubr (&Semacs_pid
);
5527 defsubr (&Scurrent_time
);
5528 defsubr (&Stime_add
);
5529 defsubr (&Stime_subtract
);
5530 defsubr (&Stime_less_p
);
5531 defsubr (&Sget_internal_run_time
);
5532 defsubr (&Sformat_time_string
);
5533 defsubr (&Sfloat_time
);
5534 defsubr (&Sdecode_time
);
5535 defsubr (&Sencode_time
);
5536 defsubr (&Scurrent_time_string
);
5537 defsubr (&Scurrent_time_zone
);
5538 defsubr (&Sset_time_zone_rule
);
5539 defsubr (&Ssystem_name
);
5540 defsubr (&Smessage
);
5541 defsubr (&Smessage_box
);
5542 defsubr (&Smessage_or_box
);
5543 defsubr (&Scurrent_message
);
5545 defsubr (&Sformat_message
);
5547 defsubr (&Sinsert_buffer_substring
);
5548 defsubr (&Scompare_buffer_substrings
);
5549 defsubr (&Sreplace_buffer_contents
);
5550 defsubr (&Ssubst_char_in_region
);
5551 defsubr (&Stranslate_region_internal
);
5552 defsubr (&Sdelete_region
);
5553 defsubr (&Sdelete_and_extract_region
);
5555 defsubr (&Snarrow_to_region
);
5556 defsubr (&Ssave_restriction
);
5557 defsubr (&Stranspose_regions
);