1 /* Lisp functions pertaining to editing. -*- coding: utf-8 -*-
3 Copyright (C) 1985-1987, 1989, 1993-2016 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software: you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation, either version 3 of the License, or (at
10 your option) any later version.
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
22 #include <sys/types.h>
32 #ifdef HAVE_SYS_UTSNAME_H
33 #include <sys/utsname.h>
38 /* systime.h includes <sys/time.h> which, on some systems, is required
39 for <sys/resource.h>; thus systime.h must be included before
43 #if defined HAVE_SYS_RESOURCE_H
44 #include <sys/resource.h>
56 #include "composite.h"
57 #include "intervals.h"
58 #include "character.h"
62 #include "blockinput.h"
64 #define TM_YEAR_BASE 1900
67 extern Lisp_Object
w32_get_internal_run_time (void);
70 static struct lisp_time
lisp_time_struct (Lisp_Object
, int *);
71 static Lisp_Object
format_time_string (char const *, ptrdiff_t, struct timespec
,
72 Lisp_Object
, struct tm
*);
73 static long int tm_gmtoff (struct tm
*);
74 static int tm_diff (struct tm
*, struct tm
*);
75 static void update_buffer_properties (ptrdiff_t, ptrdiff_t);
76 static Lisp_Object
styled_format (ptrdiff_t, Lisp_Object
*, bool);
78 #ifndef HAVE_TM_GMTOFF
79 # define HAVE_TM_GMTOFF false
82 enum { tzeqlen
= sizeof "TZ=" - 1 };
84 /* Time zones equivalent to current local time, to wall clock time,
85 and to UTC, respectively. */
86 static timezone_t local_tz
;
87 static timezone_t wall_clock_tz
;
88 static timezone_t
const utc_tz
= 0;
90 /* A valid but unlikely setting for the TZ environment variable.
91 It is OK (though a bit slower) if the user chooses this value. */
92 static char dump_tz_string
[] = "TZ=UtC0";
94 /* The cached value of Vsystem_name. This is used only to compare it
95 to Vsystem_name, so it need not be visible to the GC. */
96 static Lisp_Object cached_system_name
;
99 init_and_cache_system_name (void)
102 cached_system_name
= Vsystem_name
;
106 emacs_localtime_rz (timezone_t tz
, time_t const *t
, struct tm
*tm
)
108 tm
= localtime_rz (tz
, t
, tm
);
109 if (!tm
&& errno
== ENOMEM
)
110 memory_full (SIZE_MAX
);
115 emacs_mktime_z (timezone_t tz
, struct tm
*tm
)
118 time_t t
= mktime_z (tz
, tm
);
119 if (t
== (time_t) -1 && errno
== ENOMEM
)
120 memory_full (SIZE_MAX
);
124 /* Allocate a timezone, signaling on failure. */
126 xtzalloc (char const *name
)
128 timezone_t tz
= tzalloc (name
);
130 memory_full (SIZE_MAX
);
134 /* Free a timezone, except do not free the time zone for local time.
135 Freeing utc_tz is also a no-op. */
137 xtzfree (timezone_t tz
)
143 /* Convert the Lisp time zone rule ZONE to a timezone_t object.
144 The returned value either is 0, or is LOCAL_TZ, or is newly allocated.
145 If SETTZ, set Emacs local time to the time zone rule; otherwise,
146 the caller should eventually pass the returned value to xtzfree. */
148 tzlookup (Lisp_Object zone
, bool settz
)
150 static char const tzbuf_format
[] = "<%+.*"pI
"d>%s%"pI
"d:%02d:%02d";
151 char const *trailing_tzbuf_format
= tzbuf_format
+ sizeof "<%+.*"pI
"d" - 1;
152 char tzbuf
[sizeof tzbuf_format
+ 2 * INT_STRLEN_BOUND (EMACS_INT
)];
153 char const *zone_string
;
158 else if (EQ (zone
, Qt
))
160 zone_string
= "UTC0";
165 bool plain_integer
= INTEGERP (zone
);
167 if (EQ (zone
, Qwall
))
169 else if (STRINGP (zone
))
170 zone_string
= SSDATA (ENCODE_SYSTEM (zone
));
171 else if (plain_integer
|| (CONSP (zone
) && INTEGERP (XCAR (zone
))
172 && CONSP (XCDR (zone
))))
177 abbr
= XCAR (XCDR (zone
));
181 EMACS_INT abszone
= eabs (XINT (zone
)), hour
= abszone
/ (60 * 60);
182 int hour_remainder
= abszone
% (60 * 60);
183 int min
= hour_remainder
/ 60, sec
= hour_remainder
% 60;
188 EMACS_INT numzone
= hour
;
189 if (hour_remainder
!= 0)
191 prec
+= 2, numzone
= 100 * numzone
+ min
;
193 prec
+= 2, numzone
= 100 * numzone
+ sec
;
195 sprintf (tzbuf
, tzbuf_format
, prec
, numzone
,
196 &"-"[XINT (zone
) < 0], hour
, min
, sec
);
201 AUTO_STRING (leading
, "<");
202 AUTO_STRING_WITH_LEN (trailing
, tzbuf
,
203 sprintf (tzbuf
, trailing_tzbuf_format
,
204 &"-"[XINT (zone
) < 0],
206 zone_string
= SSDATA (concat3 (leading
, ENCODE_SYSTEM (abbr
),
211 xsignal2 (Qerror
, build_string ("Invalid time zone specification"),
213 new_tz
= xtzalloc (zone_string
);
219 emacs_setenv_TZ (zone_string
);
221 timezone_t old_tz
= local_tz
;
231 init_editfns (bool dumping
)
233 const char *user_name
;
235 struct passwd
*pw
; /* password entry for the current user */
238 /* Set up system_name even when dumping. */
239 init_and_cache_system_name ();
242 /* When just dumping out, set the time zone to a known unlikely value
243 and skip the rest of this function. */
247 xputenv (dump_tz_string
);
254 char *tz
= getenv ("TZ");
256 #if !defined CANNOT_DUMP && defined HAVE_TZSET
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 wall_clock_tz
= xtzalloc (0);
273 tzlookup (tz
? build_string (tz
) : Qwall
, true);
275 pw
= getpwuid (getuid ());
277 /* We let the real user name default to "root" because that's quite
278 accurate on MS-DOS and because it lets Emacs find the init file.
279 (The DVX libraries override the Djgpp libraries here.) */
280 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "root");
282 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "unknown");
285 /* Get the effective user name, by consulting environment variables,
286 or the effective uid if those are unset. */
287 user_name
= getenv ("LOGNAME");
290 user_name
= getenv ("USERNAME"); /* it's USERNAME on NT */
291 #else /* WINDOWSNT */
292 user_name
= getenv ("USER");
293 #endif /* WINDOWSNT */
296 pw
= getpwuid (geteuid ());
297 user_name
= pw
? pw
->pw_name
: "unknown";
299 Vuser_login_name
= build_string (user_name
);
301 /* If the user name claimed in the environment vars differs from
302 the real uid, use the claimed name to find the full name. */
303 tem
= Fstring_equal (Vuser_login_name
, Vuser_real_login_name
);
305 tem
= Vuser_login_name
;
308 uid_t euid
= geteuid ();
309 tem
= make_fixnum_or_float (euid
);
311 Vuser_full_name
= Fuser_full_name (tem
);
315 Vuser_full_name
= build_string (p
);
316 else if (NILP (Vuser_full_name
))
317 Vuser_full_name
= build_string ("unknown");
319 #ifdef HAVE_SYS_UTSNAME_H
323 Voperating_system_release
= build_string (uts
.release
);
326 Voperating_system_release
= Qnil
;
330 DEFUN ("char-to-string", Fchar_to_string
, Schar_to_string
, 1, 1, 0,
331 doc
: /* Convert arg CHAR to a string containing that character.
332 usage: (char-to-string CHAR) */)
333 (Lisp_Object character
)
336 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
338 CHECK_CHARACTER (character
);
339 c
= XFASTINT (character
);
341 len
= CHAR_STRING (c
, str
);
342 return make_string_from_bytes ((char *) str
, 1, len
);
345 DEFUN ("byte-to-string", Fbyte_to_string
, Sbyte_to_string
, 1, 1, 0,
346 doc
: /* Convert arg BYTE to a unibyte string containing that byte. */)
351 if (XINT (byte
) < 0 || XINT (byte
) > 255)
352 error ("Invalid byte");
354 return make_string_from_bytes ((char *) &b
, 1, 1);
357 DEFUN ("string-to-char", Fstring_to_char
, Sstring_to_char
, 1, 1, 0,
358 doc
: /* Return the first character in STRING. */)
359 (register Lisp_Object string
)
361 register Lisp_Object val
;
362 CHECK_STRING (string
);
365 if (STRING_MULTIBYTE (string
))
366 XSETFASTINT (val
, STRING_CHAR (SDATA (string
)));
368 XSETFASTINT (val
, SREF (string
, 0));
371 XSETFASTINT (val
, 0);
375 DEFUN ("point", Fpoint
, Spoint
, 0, 0, 0,
376 doc
: /* Return value of point, as an integer.
377 Beginning of buffer is position (point-min). */)
381 XSETFASTINT (temp
, PT
);
385 DEFUN ("point-marker", Fpoint_marker
, Spoint_marker
, 0, 0, 0,
386 doc
: /* Return value of point, as a marker object. */)
389 return build_marker (current_buffer
, PT
, PT_BYTE
);
392 DEFUN ("goto-char", Fgoto_char
, Sgoto_char
, 1, 1, "NGoto char: ",
393 doc
: /* Set point to POSITION, a number or marker.
394 Beginning of buffer is position (point-min), end is (point-max).
396 The return value is POSITION. */)
397 (register Lisp_Object position
)
399 if (MARKERP (position
))
400 set_point_from_marker (position
);
401 else if (INTEGERP (position
))
402 SET_PT (clip_to_bounds (BEGV
, XINT (position
), ZV
));
404 wrong_type_argument (Qinteger_or_marker_p
, position
);
409 /* Return the start or end position of the region.
410 BEGINNINGP means return the start.
411 If there is no region active, signal an error. */
414 region_limit (bool beginningp
)
418 if (!NILP (Vtransient_mark_mode
)
419 && NILP (Vmark_even_if_inactive
)
420 && NILP (BVAR (current_buffer
, mark_active
)))
421 xsignal0 (Qmark_inactive
);
423 m
= Fmarker_position (BVAR (current_buffer
, mark
));
425 error ("The mark is not set now, so there is no region");
427 /* Clip to the current narrowing (bug#11770). */
428 return make_number ((PT
< XFASTINT (m
)) == beginningp
430 : clip_to_bounds (BEGV
, XFASTINT (m
), ZV
));
433 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
434 doc
: /* Return the integer value of point or mark, whichever is smaller. */)
437 return region_limit (1);
440 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
441 doc
: /* Return the integer value of point or mark, whichever is larger. */)
444 return region_limit (0);
447 DEFUN ("mark-marker", Fmark_marker
, Smark_marker
, 0, 0, 0,
448 doc
: /* Return this buffer's mark, as a marker object.
449 Watch out! Moving this marker changes the mark position.
450 If you set the marker not to point anywhere, the buffer will have no mark. */)
453 return BVAR (current_buffer
, mark
);
457 /* Find all the overlays in the current buffer that touch position POS.
458 Return the number found, and store them in a vector in VEC
462 overlays_around (EMACS_INT pos
, Lisp_Object
*vec
, ptrdiff_t len
)
464 Lisp_Object overlay
, start
, end
;
465 struct Lisp_Overlay
*tail
;
466 ptrdiff_t startpos
, endpos
;
469 for (tail
= current_buffer
->overlays_before
; tail
; tail
= tail
->next
)
471 XSETMISC (overlay
, tail
);
473 end
= OVERLAY_END (overlay
);
474 endpos
= OVERLAY_POSITION (end
);
477 start
= OVERLAY_START (overlay
);
478 startpos
= OVERLAY_POSITION (start
);
483 /* Keep counting overlays even if we can't return them all. */
488 for (tail
= current_buffer
->overlays_after
; tail
; tail
= tail
->next
)
490 XSETMISC (overlay
, tail
);
492 start
= OVERLAY_START (overlay
);
493 startpos
= OVERLAY_POSITION (start
);
496 end
= OVERLAY_END (overlay
);
497 endpos
= OVERLAY_POSITION (end
);
509 DEFUN ("get-pos-property", Fget_pos_property
, Sget_pos_property
, 2, 3, 0,
510 doc
: /* Return the value of POSITION's property PROP, in OBJECT.
511 Almost identical to `get-char-property' except for the following difference:
512 Whereas `get-char-property' returns the property of the char at (i.e. right
513 after) POSITION, this pays attention to properties's stickiness and overlays's
514 advancement settings, in order to find the property of POSITION itself,
515 i.e. the property that a char would inherit if it were inserted
517 (Lisp_Object position
, register Lisp_Object prop
, Lisp_Object object
)
519 CHECK_NUMBER_COERCE_MARKER (position
);
522 XSETBUFFER (object
, current_buffer
);
523 else if (WINDOWP (object
))
524 object
= XWINDOW (object
)->contents
;
526 if (!BUFFERP (object
))
527 /* pos-property only makes sense in buffers right now, since strings
528 have no overlays and no notion of insertion for which stickiness
530 return Fget_text_property (position
, prop
, object
);
533 EMACS_INT posn
= XINT (position
);
535 Lisp_Object
*overlay_vec
, tem
;
536 struct buffer
*obuf
= current_buffer
;
539 set_buffer_temp (XBUFFER (object
));
541 /* First try with room for 40 overlays. */
542 Lisp_Object overlay_vecbuf
[40];
543 noverlays
= ARRAYELTS (overlay_vecbuf
);
544 overlay_vec
= overlay_vecbuf
;
545 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
547 /* If there are more than 40,
548 make enough space for all, and try again. */
549 if (ARRAYELTS (overlay_vecbuf
) < noverlays
)
551 SAFE_ALLOCA_LISP (overlay_vec
, noverlays
);
552 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
554 noverlays
= sort_overlays (overlay_vec
, noverlays
, NULL
);
556 set_buffer_temp (obuf
);
558 /* Now check the overlays in order of decreasing priority. */
559 while (--noverlays
>= 0)
561 Lisp_Object ol
= overlay_vec
[noverlays
];
562 tem
= Foverlay_get (ol
, prop
);
565 /* Check the overlay is indeed active at point. */
566 Lisp_Object start
= OVERLAY_START (ol
), finish
= OVERLAY_END (ol
);
567 if ((OVERLAY_POSITION (start
) == posn
568 && XMARKER (start
)->insertion_type
== 1)
569 || (OVERLAY_POSITION (finish
) == posn
570 && XMARKER (finish
)->insertion_type
== 0))
571 ; /* The overlay will not cover a char inserted at point. */
581 { /* Now check the text properties. */
582 int stickiness
= text_property_stickiness (prop
, position
, object
);
584 return Fget_text_property (position
, prop
, object
);
585 else if (stickiness
< 0
586 && XINT (position
) > BUF_BEGV (XBUFFER (object
)))
587 return Fget_text_property (make_number (XINT (position
) - 1),
595 /* Find the field surrounding POS in *BEG and *END. If POS is nil,
596 the value of point is used instead. If BEG or END is null,
597 means don't store the beginning or end of the field.
599 BEG_LIMIT and END_LIMIT serve to limit the ranged of the returned
600 results; they do not effect boundary behavior.
602 If MERGE_AT_BOUNDARY is non-nil, then if POS is at the very first
603 position of a field, then the beginning of the previous field is
604 returned instead of the beginning of POS's field (since the end of a
605 field is actually also the beginning of the next input field, this
606 behavior is sometimes useful). Additionally in the MERGE_AT_BOUNDARY
607 non-nil case, if two fields are separated by a field with the special
608 value `boundary', and POS lies within it, then the two separated
609 fields are considered to be adjacent, and POS between them, when
610 finding the beginning and ending of the "merged" field.
612 Either BEG or END may be 0, in which case the corresponding value
616 find_field (Lisp_Object pos
, Lisp_Object merge_at_boundary
,
617 Lisp_Object beg_limit
,
618 ptrdiff_t *beg
, Lisp_Object end_limit
, ptrdiff_t *end
)
620 /* Fields right before and after the point. */
621 Lisp_Object before_field
, after_field
;
622 /* True if POS counts as the start of a field. */
623 bool at_field_start
= 0;
624 /* True if POS counts as the end of a field. */
625 bool at_field_end
= 0;
628 XSETFASTINT (pos
, PT
);
630 CHECK_NUMBER_COERCE_MARKER (pos
);
633 = get_char_property_and_overlay (pos
, Qfield
, Qnil
, NULL
);
635 = (XFASTINT (pos
) > BEGV
636 ? get_char_property_and_overlay (make_number (XINT (pos
) - 1),
638 /* Using nil here would be a more obvious choice, but it would
639 fail when the buffer starts with a non-sticky field. */
642 /* See if we need to handle the case where MERGE_AT_BOUNDARY is nil
643 and POS is at beginning of a field, which can also be interpreted
644 as the end of the previous field. Note that the case where if
645 MERGE_AT_BOUNDARY is non-nil (see function comment) is actually the
646 more natural one; then we avoid treating the beginning of a field
648 if (NILP (merge_at_boundary
))
650 Lisp_Object field
= Fget_pos_property (pos
, Qfield
, Qnil
);
651 if (!EQ (field
, after_field
))
653 if (!EQ (field
, before_field
))
655 if (NILP (field
) && at_field_start
&& at_field_end
)
656 /* If an inserted char would have a nil field while the surrounding
657 text is non-nil, we're probably not looking at a
658 zero-length field, but instead at a non-nil field that's
659 not intended for editing (such as comint's prompts). */
660 at_field_end
= at_field_start
= 0;
663 /* Note about special `boundary' fields:
665 Consider the case where the point (`.') is between the fields `x' and `y':
669 In this situation, if merge_at_boundary is non-nil, consider the
670 `x' and `y' fields as forming one big merged field, and so the end
671 of the field is the end of `y'.
673 However, if `x' and `y' are separated by a special `boundary' field
674 (a field with a `field' char-property of 'boundary), then ignore
675 this special field when merging adjacent fields. Here's the same
676 situation, but with a `boundary' field between the `x' and `y' fields:
680 Here, if point is at the end of `x', the beginning of `y', or
681 anywhere in-between (within the `boundary' field), merge all
682 three fields and consider the beginning as being the beginning of
683 the `x' field, and the end as being the end of the `y' field. */
688 /* POS is at the edge of a field, and we should consider it as
689 the beginning of the following field. */
690 *beg
= XFASTINT (pos
);
692 /* Find the previous field boundary. */
695 if (!NILP (merge_at_boundary
) && EQ (before_field
, Qboundary
))
696 /* Skip a `boundary' field. */
697 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
700 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
702 *beg
= NILP (p
) ? BEGV
: XFASTINT (p
);
709 /* POS is at the edge of a field, and we should consider it as
710 the end of the previous field. */
711 *end
= XFASTINT (pos
);
713 /* Find the next field boundary. */
715 if (!NILP (merge_at_boundary
) && EQ (after_field
, Qboundary
))
716 /* Skip a `boundary' field. */
717 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
720 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
722 *end
= NILP (pos
) ? ZV
: XFASTINT (pos
);
728 DEFUN ("delete-field", Fdelete_field
, Sdelete_field
, 0, 1, 0,
729 doc
: /* Delete the field surrounding POS.
730 A field is a region of text with the same `field' property.
731 If POS is nil, the value of point is used for POS. */)
735 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
737 del_range (beg
, end
);
741 DEFUN ("field-string", Ffield_string
, Sfield_string
, 0, 1, 0,
742 doc
: /* Return the contents of the field surrounding POS as a string.
743 A field is a region of text with the same `field' property.
744 If POS is nil, the value of point is used for POS. */)
748 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
749 return make_buffer_string (beg
, end
, 1);
752 DEFUN ("field-string-no-properties", Ffield_string_no_properties
, Sfield_string_no_properties
, 0, 1, 0,
753 doc
: /* Return the contents of the field around POS, without text properties.
754 A field is a region of text with the same `field' property.
755 If POS is nil, the value of point is used for POS. */)
759 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
760 return make_buffer_string (beg
, end
, 0);
763 DEFUN ("field-beginning", Ffield_beginning
, Sfield_beginning
, 0, 3, 0,
764 doc
: /* Return the beginning of the field surrounding POS.
765 A field is a region of text with the same `field' property.
766 If POS is nil, the value of point is used for POS.
767 If ESCAPE-FROM-EDGE is non-nil and POS is at the beginning of its
768 field, then the beginning of the *previous* field is returned.
769 If LIMIT is non-nil, it is a buffer position; if the beginning of the field
770 is before LIMIT, then LIMIT will be returned instead. */)
771 (Lisp_Object pos
, Lisp_Object escape_from_edge
, Lisp_Object limit
)
774 find_field (pos
, escape_from_edge
, limit
, &beg
, Qnil
, 0);
775 return make_number (beg
);
778 DEFUN ("field-end", Ffield_end
, Sfield_end
, 0, 3, 0,
779 doc
: /* Return the end of the field surrounding POS.
780 A field is a region of text with the same `field' property.
781 If POS is nil, the value of point is used for POS.
782 If ESCAPE-FROM-EDGE is non-nil and POS is at the end of its field,
783 then the end of the *following* field is returned.
784 If LIMIT is non-nil, it is a buffer position; if the end of the field
785 is after LIMIT, then LIMIT will be returned instead. */)
786 (Lisp_Object pos
, Lisp_Object escape_from_edge
, Lisp_Object limit
)
789 find_field (pos
, escape_from_edge
, Qnil
, 0, limit
, &end
);
790 return make_number (end
);
793 DEFUN ("constrain-to-field", Fconstrain_to_field
, Sconstrain_to_field
, 2, 5, 0,
794 doc
: /* Return the position closest to NEW-POS that is in the same field as OLD-POS.
795 A field is a region of text with the same `field' property.
797 If NEW-POS is nil, then use the current point instead, and move point
798 to the resulting constrained position, in addition to returning that
801 If OLD-POS is at the boundary of two fields, then the allowable
802 positions for NEW-POS depends on the value of the optional argument
803 ESCAPE-FROM-EDGE: If ESCAPE-FROM-EDGE is nil, then NEW-POS is
804 constrained to the field that has the same `field' char-property
805 as any new characters inserted at OLD-POS, whereas if ESCAPE-FROM-EDGE
806 is non-nil, NEW-POS is constrained to the union of the two adjacent
807 fields. Additionally, if two fields are separated by another field with
808 the special value `boundary', then any point within this special field is
809 also considered to be `on the boundary'.
811 If the optional argument ONLY-IN-LINE is non-nil and constraining
812 NEW-POS would move it to a different line, NEW-POS is returned
813 unconstrained. This is useful for commands that move by line, like
814 \\[next-line] or \\[beginning-of-line], which should generally respect field boundaries
815 only in the case where they can still move to the right line.
817 If the optional argument INHIBIT-CAPTURE-PROPERTY is non-nil, and OLD-POS has
818 a non-nil property of that name, then any field boundaries are ignored.
820 Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
821 (Lisp_Object new_pos
, Lisp_Object old_pos
, Lisp_Object escape_from_edge
,
822 Lisp_Object only_in_line
, Lisp_Object inhibit_capture_property
)
824 /* If non-zero, then the original point, before re-positioning. */
825 ptrdiff_t orig_point
= 0;
827 Lisp_Object prev_old
, prev_new
;
830 /* Use the current point, and afterwards, set it. */
833 XSETFASTINT (new_pos
, PT
);
836 CHECK_NUMBER_COERCE_MARKER (new_pos
);
837 CHECK_NUMBER_COERCE_MARKER (old_pos
);
839 fwd
= (XINT (new_pos
) > XINT (old_pos
));
841 prev_old
= make_number (XINT (old_pos
) - 1);
842 prev_new
= make_number (XINT (new_pos
) - 1);
844 if (NILP (Vinhibit_field_text_motion
)
845 && !EQ (new_pos
, old_pos
)
846 && (!NILP (Fget_char_property (new_pos
, Qfield
, Qnil
))
847 || !NILP (Fget_char_property (old_pos
, Qfield
, Qnil
))
848 /* To recognize field boundaries, we must also look at the
849 previous positions; we could use `Fget_pos_property'
850 instead, but in itself that would fail inside non-sticky
851 fields (like comint prompts). */
852 || (XFASTINT (new_pos
) > BEGV
853 && !NILP (Fget_char_property (prev_new
, Qfield
, Qnil
)))
854 || (XFASTINT (old_pos
) > BEGV
855 && !NILP (Fget_char_property (prev_old
, Qfield
, Qnil
))))
856 && (NILP (inhibit_capture_property
)
857 /* Field boundaries are again a problem; but now we must
858 decide the case exactly, so we need to call
859 `get_pos_property' as well. */
860 || (NILP (Fget_pos_property (old_pos
, inhibit_capture_property
, Qnil
))
861 && (XFASTINT (old_pos
) <= BEGV
862 || NILP (Fget_char_property
863 (old_pos
, inhibit_capture_property
, Qnil
))
864 || NILP (Fget_char_property
865 (prev_old
, inhibit_capture_property
, Qnil
))))))
866 /* It is possible that NEW_POS is not within the same field as
867 OLD_POS; try to move NEW_POS so that it is. */
870 Lisp_Object field_bound
;
873 field_bound
= Ffield_end (old_pos
, escape_from_edge
, new_pos
);
875 field_bound
= Ffield_beginning (old_pos
, escape_from_edge
, new_pos
);
877 if (/* See if ESCAPE_FROM_EDGE caused FIELD_BOUND to jump to the
878 other side of NEW_POS, which would mean that NEW_POS is
879 already acceptable, and it's not necessary to constrain it
881 ((XFASTINT (field_bound
) < XFASTINT (new_pos
)) ? fwd
: !fwd
)
882 /* NEW_POS should be constrained, but only if either
883 ONLY_IN_LINE is nil (in which case any constraint is OK),
884 or NEW_POS and FIELD_BOUND are on the same line (in which
885 case the constraint is OK even if ONLY_IN_LINE is non-nil). */
886 && (NILP (only_in_line
)
887 /* This is the ONLY_IN_LINE case, check that NEW_POS and
888 FIELD_BOUND are on the same line by seeing whether
889 there's an intervening newline or not. */
890 || (find_newline (XFASTINT (new_pos
), -1,
891 XFASTINT (field_bound
), -1,
892 fwd
? -1 : 1, &shortage
, NULL
, 1),
894 /* Constrain NEW_POS to FIELD_BOUND. */
895 new_pos
= field_bound
;
897 if (orig_point
&& XFASTINT (new_pos
) != orig_point
)
898 /* The NEW_POS argument was originally nil, so automatically set PT. */
899 SET_PT (XFASTINT (new_pos
));
906 DEFUN ("line-beginning-position",
907 Fline_beginning_position
, Sline_beginning_position
, 0, 1, 0,
908 doc
: /* Return the character position of the first character on the current line.
909 With optional argument N, scan forward N - 1 lines first.
910 If the scan reaches the end of the buffer, return that position.
912 This function ignores text display directionality; it returns the
913 position of the first character in logical order, i.e. the smallest
914 character position on the line.
916 This function constrains the returned position to the current field
917 unless that position would be on a different line than the original,
918 unconstrained result. If N is nil or 1, and a front-sticky field
919 starts at point, the scan stops as soon as it starts. To ignore field
920 boundaries, bind `inhibit-field-text-motion' to t.
922 This function does not move point. */)
925 ptrdiff_t charpos
, bytepos
;
932 scan_newline_from_point (XINT (n
) - 1, &charpos
, &bytepos
);
934 /* Return END constrained to the current input field. */
935 return Fconstrain_to_field (make_number (charpos
), make_number (PT
),
936 XINT (n
) != 1 ? Qt
: Qnil
,
940 DEFUN ("line-end-position", Fline_end_position
, Sline_end_position
, 0, 1, 0,
941 doc
: /* Return the character position of the last character on the current line.
942 With argument N not nil or 1, move forward N - 1 lines first.
943 If scan reaches end of buffer, return that position.
945 This function ignores text display directionality; it returns the
946 position of the last character in logical order, i.e. the largest
947 character position on the line.
949 This function constrains the returned position to the current field
950 unless that would be on a different line than the original,
951 unconstrained result. If N is nil or 1, and a rear-sticky field ends
952 at point, the scan stops as soon as it starts. To ignore field
953 boundaries bind `inhibit-field-text-motion' to t.
955 This function does not move point. */)
967 clipped_n
= clip_to_bounds (PTRDIFF_MIN
+ 1, XINT (n
), PTRDIFF_MAX
);
968 end_pos
= find_before_next_newline (orig
, 0, clipped_n
- (clipped_n
<= 0),
971 /* Return END_POS constrained to the current input field. */
972 return Fconstrain_to_field (make_number (end_pos
), make_number (orig
),
976 /* Save current buffer state for `save-excursion' special form.
977 We (ab)use Lisp_Misc_Save_Value to allow explicit free and so
978 offload some work from GC. */
981 save_excursion_save (void)
983 return make_save_obj_obj_obj_obj
986 /* Selected window if current buffer is shown in it, nil otherwise. */
987 (EQ (XWINDOW (selected_window
)->contents
, Fcurrent_buffer ())
988 ? selected_window
: Qnil
),
992 /* Restore saved buffer before leaving `save-excursion' special form. */
995 save_excursion_restore (Lisp_Object info
)
997 Lisp_Object tem
, tem1
;
999 tem
= Fmarker_buffer (XSAVE_OBJECT (info
, 0));
1000 /* If we're unwinding to top level, saved buffer may be deleted. This
1001 means that all of its markers are unchained and so tem is nil. */
1008 tem
= XSAVE_OBJECT (info
, 0);
1010 unchain_marker (XMARKER (tem
));
1012 /* If buffer was visible in a window, and a different window was
1013 selected, and the old selected window is still showing this
1014 buffer, restore point in that window. */
1015 tem
= XSAVE_OBJECT (info
, 2);
1017 && !EQ (tem
, selected_window
)
1018 && (tem1
= XWINDOW (tem
)->contents
,
1019 (/* Window is live... */
1021 /* ...and it shows the current buffer. */
1022 && XBUFFER (tem1
) == current_buffer
)))
1023 Fset_window_point (tem
, make_number (PT
));
1030 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
1031 doc
: /* Save point, and current buffer; execute BODY; restore those things.
1032 Executes BODY just like `progn'.
1033 The values of point and the current buffer are restored
1034 even in case of abnormal exit (throw or error).
1036 If you only want to save the current buffer but not point,
1037 then just use `save-current-buffer', or even `with-current-buffer'.
1039 Before Emacs 25.1, `save-excursion' used to save the mark state.
1040 To save the marker state as well as the point and buffer, use
1041 `save-mark-and-excursion'.
1043 usage: (save-excursion &rest BODY) */)
1046 register Lisp_Object val
;
1047 ptrdiff_t count
= SPECPDL_INDEX ();
1049 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
1051 val
= Fprogn (args
);
1052 return unbind_to (count
, val
);
1055 DEFUN ("save-current-buffer", Fsave_current_buffer
, Ssave_current_buffer
, 0, UNEVALLED
, 0,
1056 doc
: /* Record which buffer is current; execute BODY; make that buffer current.
1057 BODY is executed just like `progn'.
1058 usage: (save-current-buffer &rest BODY) */)
1061 ptrdiff_t count
= SPECPDL_INDEX ();
1063 record_unwind_current_buffer ();
1064 return unbind_to (count
, Fprogn (args
));
1067 DEFUN ("buffer-size", Fbuffer_size
, Sbuffer_size
, 0, 1, 0,
1068 doc
: /* Return the number of characters in the current buffer.
1069 If BUFFER is not nil, return the number of characters in that buffer
1072 This does not take narrowing into account; to count the number of
1073 characters in the accessible portion of the current buffer, use
1074 `(- (point-max) (point-min))', and to count the number of characters
1075 in some other BUFFER, use
1076 `(with-current-buffer BUFFER (- (point-max) (point-min)))'. */)
1077 (Lisp_Object buffer
)
1080 return make_number (Z
- BEG
);
1083 CHECK_BUFFER (buffer
);
1084 return make_number (BUF_Z (XBUFFER (buffer
))
1085 - BUF_BEG (XBUFFER (buffer
)));
1089 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
1090 doc
: /* Return the minimum permissible value of point in the current buffer.
1091 This is 1, unless narrowing (a buffer restriction) is in effect. */)
1095 XSETFASTINT (temp
, BEGV
);
1099 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
1100 doc
: /* Return a marker to the minimum permissible value of point in this buffer.
1101 This is the beginning, unless narrowing (a buffer restriction) is in effect. */)
1104 return build_marker (current_buffer
, BEGV
, BEGV_BYTE
);
1107 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
1108 doc
: /* Return the maximum permissible value of point in the current buffer.
1109 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1110 is in effect, in which case it is less. */)
1114 XSETFASTINT (temp
, ZV
);
1118 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
1119 doc
: /* Return a marker to the maximum permissible value of point in this buffer.
1120 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1121 is in effect, in which case it is less. */)
1124 return build_marker (current_buffer
, ZV
, ZV_BYTE
);
1127 DEFUN ("gap-position", Fgap_position
, Sgap_position
, 0, 0, 0,
1128 doc
: /* Return the position of the gap, in the current buffer.
1129 See also `gap-size'. */)
1133 XSETFASTINT (temp
, GPT
);
1137 DEFUN ("gap-size", Fgap_size
, Sgap_size
, 0, 0, 0,
1138 doc
: /* Return the size of the current buffer's gap.
1139 See also `gap-position'. */)
1143 XSETFASTINT (temp
, GAP_SIZE
);
1147 DEFUN ("position-bytes", Fposition_bytes
, Sposition_bytes
, 1, 1, 0,
1148 doc
: /* Return the byte position for character position POSITION.
1149 If POSITION is out of range, the value is nil. */)
1150 (Lisp_Object position
)
1152 CHECK_NUMBER_COERCE_MARKER (position
);
1153 if (XINT (position
) < BEG
|| XINT (position
) > Z
)
1155 return make_number (CHAR_TO_BYTE (XINT (position
)));
1158 DEFUN ("byte-to-position", Fbyte_to_position
, Sbyte_to_position
, 1, 1, 0,
1159 doc
: /* Return the character position for byte position BYTEPOS.
1160 If BYTEPOS is out of range, the value is nil. */)
1161 (Lisp_Object bytepos
)
1165 CHECK_NUMBER (bytepos
);
1166 pos_byte
= XINT (bytepos
);
1167 if (pos_byte
< BEG_BYTE
|| pos_byte
> Z_BYTE
)
1170 /* There are multibyte characters in the buffer.
1171 The argument of BYTE_TO_CHAR must be a byte position at
1172 a character boundary, so search for the start of the current
1174 while (!CHAR_HEAD_P (FETCH_BYTE (pos_byte
)))
1176 return make_number (BYTE_TO_CHAR (pos_byte
));
1179 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
1180 doc
: /* Return the character following point, as a number.
1181 At the end of the buffer or accessible region, return 0. */)
1186 XSETFASTINT (temp
, 0);
1188 XSETFASTINT (temp
, FETCH_CHAR (PT_BYTE
));
1192 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
1193 doc
: /* Return the character preceding point, as a number.
1194 At the beginning of the buffer or accessible region, return 0. */)
1199 XSETFASTINT (temp
, 0);
1200 else if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1202 ptrdiff_t pos
= PT_BYTE
;
1204 XSETFASTINT (temp
, FETCH_CHAR (pos
));
1207 XSETFASTINT (temp
, FETCH_BYTE (PT_BYTE
- 1));
1211 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
1212 doc
: /* Return t if point is at the beginning of the buffer.
1213 If the buffer is narrowed, this means the beginning of the narrowed part. */)
1221 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
1222 doc
: /* Return t if point is at the end of the buffer.
1223 If the buffer is narrowed, this means the end of the narrowed part. */)
1231 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
1232 doc
: /* Return t if point is at the beginning of a line. */)
1235 if (PT
== BEGV
|| FETCH_BYTE (PT_BYTE
- 1) == '\n')
1240 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
1241 doc
: /* Return t if point is at the end of a line.
1242 `End of a line' includes point being at the end of the buffer. */)
1245 if (PT
== ZV
|| FETCH_BYTE (PT_BYTE
) == '\n')
1250 DEFUN ("char-after", Fchar_after
, Schar_after
, 0, 1, 0,
1251 doc
: /* Return character in current buffer at position POS.
1252 POS is an integer or a marker and defaults to point.
1253 If POS is out of range, the value is nil. */)
1256 register ptrdiff_t pos_byte
;
1261 XSETFASTINT (pos
, PT
);
1266 pos_byte
= marker_byte_position (pos
);
1267 if (pos_byte
< BEGV_BYTE
|| pos_byte
>= ZV_BYTE
)
1272 CHECK_NUMBER_COERCE_MARKER (pos
);
1273 if (XINT (pos
) < BEGV
|| XINT (pos
) >= ZV
)
1276 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1279 return make_number (FETCH_CHAR (pos_byte
));
1282 DEFUN ("char-before", Fchar_before
, Schar_before
, 0, 1, 0,
1283 doc
: /* Return character in current buffer preceding position POS.
1284 POS is an integer or a marker and defaults to point.
1285 If POS is out of range, the value is nil. */)
1288 register Lisp_Object val
;
1289 register ptrdiff_t pos_byte
;
1294 XSETFASTINT (pos
, PT
);
1299 pos_byte
= marker_byte_position (pos
);
1301 if (pos_byte
<= BEGV_BYTE
|| pos_byte
> ZV_BYTE
)
1306 CHECK_NUMBER_COERCE_MARKER (pos
);
1308 if (XINT (pos
) <= BEGV
|| XINT (pos
) > ZV
)
1311 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1314 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1317 XSETFASTINT (val
, FETCH_CHAR (pos_byte
));
1322 XSETFASTINT (val
, FETCH_BYTE (pos_byte
));
1327 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 1, 0,
1328 doc
: /* Return the name under which the user logged in, as a string.
1329 This is based on the effective uid, not the real uid.
1330 Also, if the environment variables LOGNAME or USER are set,
1331 that determines the value of this function.
1333 If optional argument UID is an integer or a float, return the login name
1334 of the user with that uid, or nil if there is no such user. */)
1340 /* Set up the user name info if we didn't do it before.
1341 (That can happen if Emacs is dumpable
1342 but you decide to run `temacs -l loadup' and not dump. */
1343 if (NILP (Vuser_login_name
))
1344 init_editfns (false);
1347 return Vuser_login_name
;
1349 CONS_TO_INTEGER (uid
, uid_t
, id
);
1353 return (pw
? build_string (pw
->pw_name
) : Qnil
);
1356 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
1358 doc
: /* Return the name of the user's real uid, as a string.
1359 This ignores the environment variables LOGNAME and USER, so it differs from
1360 `user-login-name' when running under `su'. */)
1363 /* Set up the user name info if we didn't do it before.
1364 (That can happen if Emacs is dumpable
1365 but you decide to run `temacs -l loadup' and not dump. */
1366 if (NILP (Vuser_login_name
))
1367 init_editfns (false);
1368 return Vuser_real_login_name
;
1371 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
1372 doc
: /* Return the effective uid of Emacs.
1373 Value is an integer or a float, depending on the value. */)
1376 uid_t euid
= geteuid ();
1377 return make_fixnum_or_float (euid
);
1380 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
1381 doc
: /* Return the real uid of Emacs.
1382 Value is an integer or a float, depending on the value. */)
1385 uid_t uid
= getuid ();
1386 return make_fixnum_or_float (uid
);
1389 DEFUN ("group-gid", Fgroup_gid
, Sgroup_gid
, 0, 0, 0,
1390 doc
: /* Return the effective gid of Emacs.
1391 Value is an integer or a float, depending on the value. */)
1394 gid_t egid
= getegid ();
1395 return make_fixnum_or_float (egid
);
1398 DEFUN ("group-real-gid", Fgroup_real_gid
, Sgroup_real_gid
, 0, 0, 0,
1399 doc
: /* Return the real gid of Emacs.
1400 Value is an integer or a float, depending on the value. */)
1403 gid_t gid
= getgid ();
1404 return make_fixnum_or_float (gid
);
1407 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 1, 0,
1408 doc
: /* Return the full name of the user logged in, as a string.
1409 If the full name corresponding to Emacs's userid is not known,
1412 If optional argument UID is an integer or float, return the full name
1413 of the user with that uid, or nil if there is no such user.
1414 If UID is a string, return the full name of the user with that login
1415 name, or nil if there is no such user. */)
1419 register char *p
, *q
;
1423 return Vuser_full_name
;
1424 else if (NUMBERP (uid
))
1427 CONS_TO_INTEGER (uid
, uid_t
, u
);
1432 else if (STRINGP (uid
))
1435 pw
= getpwnam (SSDATA (uid
));
1439 error ("Invalid UID specification");
1445 /* Chop off everything after the first comma. */
1446 q
= strchr (p
, ',');
1447 full
= make_string (p
, q
? q
- p
: strlen (p
));
1449 #ifdef AMPERSAND_FULL_NAME
1451 q
= strchr (p
, '&');
1452 /* Substitute the login name for the &, upcasing the first character. */
1455 Lisp_Object login
= Fuser_login_name (make_number (pw
->pw_uid
));
1457 char *r
= SAFE_ALLOCA (strlen (p
) + SBYTES (login
) + 1);
1458 memcpy (r
, p
, q
- p
);
1459 char *s
= lispstpcpy (&r
[q
- p
], login
);
1460 r
[q
- p
] = upcase ((unsigned char) r
[q
- p
]);
1462 full
= build_string (r
);
1465 #endif /* AMPERSAND_FULL_NAME */
1470 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
1471 doc
: /* Return the host name of the machine you are running on, as a string. */)
1474 if (EQ (Vsystem_name
, cached_system_name
))
1475 init_and_cache_system_name ();
1476 return Vsystem_name
;
1479 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
1480 doc
: /* Return the process ID of Emacs, as a number. */)
1483 pid_t pid
= getpid ();
1484 return make_fixnum_or_float (pid
);
1490 # define TIME_T_MIN TYPE_MINIMUM (time_t)
1493 # define TIME_T_MAX TYPE_MAXIMUM (time_t)
1496 /* Report that a time value is out of range for Emacs. */
1498 time_overflow (void)
1500 error ("Specified time is not representable");
1503 static _Noreturn
void
1506 error ("Invalid time specification");
1509 /* Check a return value compatible with that of decode_time_components. */
1511 check_time_validity (int validity
)
1522 /* Return the upper part of the time T (everything but the bottom 16 bits). */
1526 time_t hi
= t
>> LO_TIME_BITS
;
1527 if (FIXNUM_OVERFLOW_P (hi
))
1532 /* Return the bottom bits of the time T. */
1536 return t
& ((1 << LO_TIME_BITS
) - 1);
1539 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
1540 doc
: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
1541 The time is returned as a list of integers (HIGH LOW USEC PSEC).
1542 HIGH has the most significant bits of the seconds, while LOW has the
1543 least significant 16 bits. USEC and PSEC are the microsecond and
1544 picosecond counts. */)
1547 return make_lisp_time (current_timespec ());
1550 static struct lisp_time
1551 time_add (struct lisp_time ta
, struct lisp_time tb
)
1553 EMACS_INT hi
= ta
.hi
+ tb
.hi
;
1554 int lo
= ta
.lo
+ tb
.lo
;
1555 int us
= ta
.us
+ tb
.us
;
1556 int ps
= ta
.ps
+ tb
.ps
;
1557 us
+= (1000000 <= ps
);
1558 ps
-= (1000000 <= ps
) * 1000000;
1559 lo
+= (1000000 <= us
);
1560 us
-= (1000000 <= us
) * 1000000;
1561 hi
+= (1 << LO_TIME_BITS
<= lo
);
1562 lo
-= (1 << LO_TIME_BITS
<= lo
) << LO_TIME_BITS
;
1563 return (struct lisp_time
) { hi
, lo
, us
, ps
};
1566 static struct lisp_time
1567 time_subtract (struct lisp_time ta
, struct lisp_time tb
)
1569 EMACS_INT hi
= ta
.hi
- tb
.hi
;
1570 int lo
= ta
.lo
- tb
.lo
;
1571 int us
= ta
.us
- tb
.us
;
1572 int ps
= ta
.ps
- tb
.ps
;
1574 ps
+= (ps
< 0) * 1000000;
1576 us
+= (us
< 0) * 1000000;
1578 lo
+= (lo
< 0) << LO_TIME_BITS
;
1579 return (struct lisp_time
) { hi
, lo
, us
, ps
};
1583 time_arith (Lisp_Object a
, Lisp_Object b
,
1584 struct lisp_time (*op
) (struct lisp_time
, struct lisp_time
))
1587 struct lisp_time ta
= lisp_time_struct (a
, &alen
);
1588 struct lisp_time tb
= lisp_time_struct (b
, &blen
);
1589 struct lisp_time t
= op (ta
, tb
);
1590 if (FIXNUM_OVERFLOW_P (t
.hi
))
1592 Lisp_Object val
= Qnil
;
1594 switch (max (alen
, blen
))
1597 val
= Fcons (make_number (t
.ps
), val
);
1600 val
= Fcons (make_number (t
.us
), val
);
1603 val
= Fcons (make_number (t
.lo
), val
);
1604 val
= Fcons (make_number (t
.hi
), val
);
1611 DEFUN ("time-add", Ftime_add
, Stime_add
, 2, 2, 0,
1612 doc
: /* Return the sum of two time values A and B, as a time value. */)
1613 (Lisp_Object a
, Lisp_Object b
)
1615 return time_arith (a
, b
, time_add
);
1618 DEFUN ("time-subtract", Ftime_subtract
, Stime_subtract
, 2, 2, 0,
1619 doc
: /* Return the difference between two time values A and B, as a time value. */)
1620 (Lisp_Object a
, Lisp_Object b
)
1622 return time_arith (a
, b
, time_subtract
);
1625 DEFUN ("time-less-p", Ftime_less_p
, Stime_less_p
, 2, 2, 0,
1626 doc
: /* Return non-nil if time value T1 is earlier than time value T2. */)
1627 (Lisp_Object t1
, Lisp_Object t2
)
1630 struct lisp_time a
= lisp_time_struct (t1
, &t1len
);
1631 struct lisp_time b
= lisp_time_struct (t2
, &t2len
);
1632 return ((a
.hi
!= b
.hi
? a
.hi
< b
.hi
1633 : a
.lo
!= b
.lo
? a
.lo
< b
.lo
1634 : a
.us
!= b
.us
? a
.us
< b
.us
1640 DEFUN ("get-internal-run-time", Fget_internal_run_time
, Sget_internal_run_time
,
1642 doc
: /* Return the current run time used by Emacs.
1643 The time is returned as a list (HIGH LOW USEC PSEC), using the same
1644 style as (current-time).
1646 On systems that can't determine the run time, `get-internal-run-time'
1647 does the same thing as `current-time'. */)
1650 #ifdef HAVE_GETRUSAGE
1651 struct rusage usage
;
1655 if (getrusage (RUSAGE_SELF
, &usage
) < 0)
1656 /* This shouldn't happen. What action is appropriate? */
1659 /* Sum up user time and system time. */
1660 secs
= usage
.ru_utime
.tv_sec
+ usage
.ru_stime
.tv_sec
;
1661 usecs
= usage
.ru_utime
.tv_usec
+ usage
.ru_stime
.tv_usec
;
1662 if (usecs
>= 1000000)
1667 return make_lisp_time (make_timespec (secs
, usecs
* 1000));
1668 #else /* ! HAVE_GETRUSAGE */
1670 return w32_get_internal_run_time ();
1671 #else /* ! WINDOWSNT */
1672 return Fcurrent_time ();
1673 #endif /* WINDOWSNT */
1674 #endif /* HAVE_GETRUSAGE */
1678 /* Make a Lisp list that represents the Emacs time T. T may be an
1679 invalid time, with a slightly negative tv_nsec value such as
1680 UNKNOWN_MODTIME_NSECS; in that case, the Lisp list contains a
1681 correspondingly negative picosecond count. */
1683 make_lisp_time (struct timespec t
)
1685 time_t s
= t
.tv_sec
;
1687 return list4i (hi_time (s
), lo_time (s
), ns
/ 1000, ns
% 1000 * 1000);
1690 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1691 Set *PHIGH, *PLOW, *PUSEC, *PPSEC to its parts; do not check their values.
1692 Return 2, 3, or 4 to indicate the effective length of SPECIFIED_TIME
1693 if successful, 0 if unsuccessful. */
1695 disassemble_lisp_time (Lisp_Object specified_time
, Lisp_Object
*phigh
,
1696 Lisp_Object
*plow
, Lisp_Object
*pusec
,
1699 Lisp_Object high
= make_number (0);
1700 Lisp_Object low
= specified_time
;
1701 Lisp_Object usec
= make_number (0);
1702 Lisp_Object psec
= make_number (0);
1705 if (CONSP (specified_time
))
1707 high
= XCAR (specified_time
);
1708 low
= XCDR (specified_time
);
1711 Lisp_Object low_tail
= XCDR (low
);
1713 if (CONSP (low_tail
))
1715 usec
= XCAR (low_tail
);
1716 low_tail
= XCDR (low_tail
);
1717 if (CONSP (low_tail
))
1718 psec
= XCAR (low_tail
);
1722 else if (!NILP (low_tail
))
1733 /* When combining components, require LOW to be an integer,
1734 as otherwise it would be a pain to add up times. */
1735 if (! INTEGERP (low
))
1738 else if (INTEGERP (specified_time
))
1748 /* Convert T into an Emacs time *RESULT, truncating toward minus infinity.
1749 Return true if T is in range, false otherwise. */
1751 decode_float_time (double t
, struct lisp_time
*result
)
1753 double lo_multiplier
= 1 << LO_TIME_BITS
;
1754 double emacs_time_min
= MOST_NEGATIVE_FIXNUM
* lo_multiplier
;
1755 if (! (emacs_time_min
<= t
&& t
< -emacs_time_min
))
1758 double small_t
= t
/ lo_multiplier
;
1759 EMACS_INT hi
= small_t
;
1760 double t_sans_hi
= t
- hi
* lo_multiplier
;
1762 long double fracps
= (t_sans_hi
- lo
) * 1e12L
;
1763 #ifdef INT_FAST64_MAX
1764 int_fast64_t ifracps
= fracps
;
1765 int us
= ifracps
/ 1000000;
1766 int ps
= ifracps
% 1000000;
1768 int us
= fracps
/ 1e6L
;
1769 int ps
= fracps
- us
* 1e6L
;
1772 ps
+= (ps
< 0) * 1000000;
1774 us
+= (us
< 0) * 1000000;
1776 lo
+= (lo
< 0) << LO_TIME_BITS
;
1784 /* From the time components HIGH, LOW, USEC and PSEC taken from a Lisp
1785 list, generate the corresponding time value.
1786 If LOW is floating point, the other components should be zero.
1788 If RESULT is not null, store into *RESULT the converted time.
1789 If *DRESULT is not null, store into *DRESULT the number of
1790 seconds since the start of the POSIX Epoch.
1792 Return 1 if successful, 0 if the components are of the
1793 wrong type, and -1 if the time is out of range. */
1795 decode_time_components (Lisp_Object high
, Lisp_Object low
, Lisp_Object usec
,
1797 struct lisp_time
*result
, double *dresult
)
1799 EMACS_INT hi
, lo
, us
, ps
;
1800 if (! (INTEGERP (high
)
1801 && INTEGERP (usec
) && INTEGERP (psec
)))
1803 if (! INTEGERP (low
))
1807 double t
= XFLOAT_DATA (low
);
1808 if (result
&& ! decode_float_time (t
, result
))
1814 else if (NILP (low
))
1816 struct timespec now
= current_timespec ();
1819 result
->hi
= hi_time (now
.tv_sec
);
1820 result
->lo
= lo_time (now
.tv_sec
);
1821 result
->us
= now
.tv_nsec
/ 1000;
1822 result
->ps
= now
.tv_nsec
% 1000 * 1000;
1825 *dresult
= now
.tv_sec
+ now
.tv_nsec
/ 1e9
;
1837 /* Normalize out-of-range lower-order components by carrying
1838 each overflow into the next higher-order component. */
1839 us
+= ps
/ 1000000 - (ps
% 1000000 < 0);
1840 lo
+= us
/ 1000000 - (us
% 1000000 < 0);
1841 hi
+= lo
>> LO_TIME_BITS
;
1842 ps
= ps
% 1000000 + 1000000 * (ps
% 1000000 < 0);
1843 us
= us
% 1000000 + 1000000 * (us
% 1000000 < 0);
1844 lo
&= (1 << LO_TIME_BITS
) - 1;
1848 if (FIXNUM_OVERFLOW_P (hi
))
1859 *dresult
= (us
* 1e6
+ ps
) / 1e12
+ lo
+ dhi
* (1 << LO_TIME_BITS
);
1866 lisp_to_timespec (struct lisp_time t
)
1868 if (! ((TYPE_SIGNED (time_t) ? TIME_T_MIN
>> LO_TIME_BITS
<= t
.hi
: 0 <= t
.hi
)
1869 && t
.hi
<= TIME_T_MAX
>> LO_TIME_BITS
))
1870 return invalid_timespec ();
1871 time_t s
= (t
.hi
<< LO_TIME_BITS
) + t
.lo
;
1872 int ns
= t
.us
* 1000 + t
.ps
/ 1000;
1873 return make_timespec (s
, ns
);
1876 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1877 Store its effective length into *PLEN.
1878 If SPECIFIED_TIME is nil, use the current time.
1879 Signal an error if SPECIFIED_TIME does not represent a time. */
1880 static struct lisp_time
1881 lisp_time_struct (Lisp_Object specified_time
, int *plen
)
1883 Lisp_Object high
, low
, usec
, psec
;
1885 int len
= disassemble_lisp_time (specified_time
, &high
, &low
, &usec
, &psec
);
1888 int val
= decode_time_components (high
, low
, usec
, psec
, &t
, 0);
1889 check_time_validity (val
);
1894 /* Like lisp_time_struct, except return a struct timespec.
1895 Discard any low-order digits. */
1897 lisp_time_argument (Lisp_Object specified_time
)
1900 struct lisp_time lt
= lisp_time_struct (specified_time
, &len
);
1901 struct timespec t
= lisp_to_timespec (lt
);
1902 if (! timespec_valid_p (t
))
1907 /* Like lisp_time_argument, except decode only the seconds part,
1908 and do not check the subseconds part. */
1910 lisp_seconds_argument (Lisp_Object specified_time
)
1912 Lisp_Object high
, low
, usec
, psec
;
1915 int val
= disassemble_lisp_time (specified_time
, &high
, &low
, &usec
, &psec
);
1918 val
= decode_time_components (high
, low
, make_number (0),
1919 make_number (0), &t
, 0);
1921 && ! ((TYPE_SIGNED (time_t)
1922 ? TIME_T_MIN
>> LO_TIME_BITS
<= t
.hi
1924 && t
.hi
<= TIME_T_MAX
>> LO_TIME_BITS
))
1927 check_time_validity (val
);
1928 return (t
.hi
<< LO_TIME_BITS
) + t
.lo
;
1931 DEFUN ("float-time", Ffloat_time
, Sfloat_time
, 0, 1, 0,
1932 doc
: /* Return the current time, as a float number of seconds since the epoch.
1933 If SPECIFIED-TIME is given, it is the time to convert to float
1934 instead of the current time. The argument should have the form
1935 \(HIGH LOW) or (HIGH LOW USEC) or (HIGH LOW USEC PSEC). Thus,
1936 you can use times from `current-time' and from `file-attributes'.
1937 SPECIFIED-TIME can also have the form (HIGH . LOW), but this is
1938 considered obsolete.
1940 WARNING: Since the result is floating point, it may not be exact.
1941 If precise time stamps are required, use either `current-time',
1942 or (if you need time as a string) `format-time-string'. */)
1943 (Lisp_Object specified_time
)
1946 Lisp_Object high
, low
, usec
, psec
;
1947 if (! (disassemble_lisp_time (specified_time
, &high
, &low
, &usec
, &psec
)
1948 && decode_time_components (high
, low
, usec
, psec
, 0, &t
)))
1950 return make_float (t
);
1953 /* Write information into buffer S of size MAXSIZE, according to the
1954 FORMAT of length FORMAT_LEN, using time information taken from *TP.
1955 Use the time zone specified by TZ.
1956 Use NS as the number of nanoseconds in the %N directive.
1957 Return the number of bytes written, not including the terminating
1958 '\0'. If S is NULL, nothing will be written anywhere; so to
1959 determine how many bytes would be written, use NULL for S and
1960 ((size_t) -1) for MAXSIZE.
1962 This function behaves like nstrftime, except it allows null
1963 bytes in FORMAT and it does not support nanoseconds. */
1965 emacs_nmemftime (char *s
, size_t maxsize
, const char *format
,
1966 size_t format_len
, const struct tm
*tp
, timezone_t tz
, int ns
)
1970 /* Loop through all the null-terminated strings in the format
1971 argument. Normally there's just one null-terminated string, but
1972 there can be arbitrarily many, concatenated together, if the
1973 format contains '\0' bytes. nstrftime stops at the first
1974 '\0' byte so we must invoke it separately for each such string. */
1983 result
= nstrftime (s
, maxsize
, format
, tp
, tz
, ns
);
1987 if (result
== 0 && s
[0] != '\0')
1992 maxsize
-= result
+ 1;
1994 len
= strlen (format
);
1995 if (len
== format_len
)
1999 format_len
-= len
+ 1;
2003 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 1, 3, 0,
2004 doc
: /* Use FORMAT-STRING to format the time TIME, or now if omitted.
2005 TIME is specified as (HIGH LOW USEC PSEC), as returned by
2006 `current-time' or `file-attributes'. The obsolete form (HIGH . LOW)
2007 is also still accepted.
2009 The optional ZONE is omitted or nil for Emacs local time, t for
2010 Universal Time, `wall' for system wall clock time, or a string as in
2011 the TZ environment variable. It can also be a list (as from
2012 `current-time-zone') or an integer (as from `decode-time') applied
2013 without consideration for daylight saving time.
2015 The value is a copy of FORMAT-STRING, but with certain constructs replaced
2016 by text that describes the specified date and time in TIME:
2018 %Y is the year, %y within the century, %C the century.
2019 %G is the year corresponding to the ISO week, %g within the century.
2020 %m is the numeric month.
2021 %b and %h are the locale's abbreviated month name, %B the full name.
2022 (%h is not supported on MS-Windows.)
2023 %d is the day of the month, zero-padded, %e is blank-padded.
2024 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
2025 %a is the locale's abbreviated name of the day of week, %A the full name.
2026 %U is the week number starting on Sunday, %W starting on Monday,
2027 %V according to ISO 8601.
2028 %j is the day of the year.
2030 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
2031 only blank-padded, %l is like %I blank-padded.
2032 %p is the locale's equivalent of either AM or PM.
2035 %N is the nanosecond, %6N the microsecond, %3N the millisecond, etc.
2036 %Z is the time zone name, %z is the numeric form.
2037 %s is the number of seconds since 1970-01-01 00:00:00 +0000.
2039 %c is the locale's date and time format.
2040 %x is the locale's "preferred" date format.
2041 %D is like "%m/%d/%y".
2042 %F is the ISO 8601 date format (like "%Y-%m-%d").
2044 %R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
2045 %X is the locale's "preferred" time format.
2047 Finally, %n is a newline, %t is a tab, %% is a literal %.
2049 Certain flags and modifiers are available with some format controls.
2050 The flags are `_', `-', `^' and `#'. For certain characters X,
2051 %_X is like %X, but padded with blanks; %-X is like %X,
2052 but without padding. %^X is like %X, but with all textual
2053 characters up-cased; %#X is like %X, but with letter-case of
2054 all textual characters reversed.
2055 %NX (where N stands for an integer) is like %X,
2056 but takes up at least N (a number) positions.
2057 The modifiers are `E' and `O'. For certain characters X,
2058 %EX is a locale's alternative version of %X;
2059 %OX is like %X, but uses the locale's number symbols.
2061 For example, to produce full ISO 8601 format, use "%FT%T%z".
2063 usage: (format-time-string FORMAT-STRING &optional TIME ZONE) */)
2064 (Lisp_Object format_string
, Lisp_Object timeval
, Lisp_Object zone
)
2066 struct timespec t
= lisp_time_argument (timeval
);
2069 CHECK_STRING (format_string
);
2070 format_string
= code_convert_string_norecord (format_string
,
2071 Vlocale_coding_system
, 1);
2072 return format_time_string (SSDATA (format_string
), SBYTES (format_string
),
2077 format_time_string (char const *format
, ptrdiff_t formatlen
,
2078 struct timespec t
, Lisp_Object zone
, struct tm
*tmp
)
2082 ptrdiff_t size
= sizeof buffer
;
2087 timezone_t tz
= tzlookup (zone
, false);
2088 tmp
= emacs_localtime_rz (tz
, &t
.tv_sec
, tmp
);
2094 synchronize_system_time_locale ();
2099 len
= emacs_nmemftime (buf
, size
, format
, formatlen
, tmp
, tz
, ns
);
2100 if ((0 < len
&& len
< size
) || (len
== 0 && buf
[0] == '\0'))
2103 /* Buffer was too small, so make it bigger and try again. */
2104 len
= emacs_nmemftime (NULL
, SIZE_MAX
, format
, formatlen
, tmp
, tz
, ns
);
2105 if (STRING_BYTES_BOUND
<= len
)
2111 buf
= SAFE_ALLOCA (size
);
2115 AUTO_STRING_WITH_LEN (bufstring
, buf
, len
);
2116 Lisp_Object result
= code_convert_string_norecord (bufstring
,
2117 Vlocale_coding_system
, 0);
2122 DEFUN ("decode-time", Fdecode_time
, Sdecode_time
, 0, 2, 0,
2123 doc
: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST UTCOFF).
2124 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED),
2125 as from `current-time' and `file-attributes', or nil to use the
2126 current time. The obsolete form (HIGH . LOW) is also still accepted.
2128 The optional ZONE is omitted or nil for Emacs local time, t for
2129 Universal Time, `wall' for system wall clock time, or a string as in
2130 the TZ environment variable. It can also be a list (as from
2131 `current-time-zone') or an integer (as from `decode-time') applied
2132 without consideration for daylight saving time.
2134 The list has the following nine members: SEC is an integer between 0
2135 and 60; SEC is 60 for a leap second, which only some operating systems
2136 support. MINUTE is an integer between 0 and 59. HOUR is an integer
2137 between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
2138 integer between 1 and 12. YEAR is an integer indicating the
2139 four-digit year. DOW is the day of week, an integer between 0 and 6,
2140 where 0 is Sunday. DST is t if daylight saving time is in effect,
2141 otherwise nil. UTCOFF is an integer indicating the UTC offset in
2142 seconds, i.e., the number of seconds east of Greenwich. (Note that
2143 Common Lisp has different meanings for DOW and UTCOFF.)
2145 usage: (decode-time &optional TIME ZONE) */)
2146 (Lisp_Object specified_time
, Lisp_Object zone
)
2148 time_t time_spec
= lisp_seconds_argument (specified_time
);
2149 struct tm local_tm
, gmt_tm
;
2150 timezone_t tz
= tzlookup (zone
, false);
2151 struct tm
*tm
= emacs_localtime_rz (tz
, &time_spec
, &local_tm
);
2155 && MOST_NEGATIVE_FIXNUM
- TM_YEAR_BASE
<= local_tm
.tm_year
2156 && local_tm
.tm_year
<= MOST_POSITIVE_FIXNUM
- TM_YEAR_BASE
))
2159 /* Avoid overflow when INT_MAX < EMACS_INT_MAX. */
2160 EMACS_INT tm_year_base
= TM_YEAR_BASE
;
2162 return CALLN (Flist
,
2163 make_number (local_tm
.tm_sec
),
2164 make_number (local_tm
.tm_min
),
2165 make_number (local_tm
.tm_hour
),
2166 make_number (local_tm
.tm_mday
),
2167 make_number (local_tm
.tm_mon
+ 1),
2168 make_number (local_tm
.tm_year
+ tm_year_base
),
2169 make_number (local_tm
.tm_wday
),
2170 local_tm
.tm_isdst
? Qt
: Qnil
,
2172 ? make_number (tm_gmtoff (&local_tm
))
2173 : gmtime_r (&time_spec
, &gmt_tm
)
2174 ? make_number (tm_diff (&local_tm
, &gmt_tm
))
2178 /* Return OBJ - OFFSET, checking that OBJ is a valid fixnum and that
2179 the result is representable as an int. */
2181 check_tm_member (Lisp_Object obj
, int offset
)
2184 EMACS_INT n
= XINT (obj
);
2186 if (INT_SUBTRACT_WRAPV (n
, offset
, &result
))
2191 DEFUN ("encode-time", Fencode_time
, Sencode_time
, 6, MANY
, 0,
2192 doc
: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
2193 This is the reverse operation of `decode-time', which see.
2195 The optional ZONE is omitted or nil for Emacs local time, t for
2196 Universal Time, `wall' for system wall clock time, or a string as in
2197 the TZ environment variable. It can also be a list (as from
2198 `current-time-zone') or an integer (as from `decode-time') applied
2199 without consideration for daylight saving time.
2201 You can pass more than 7 arguments; then the first six arguments
2202 are used as SECOND through YEAR, and the *last* argument is used as ZONE.
2203 The intervening arguments are ignored.
2204 This feature lets (apply \\='encode-time (decode-time ...)) work.
2206 Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed;
2207 for example, a DAY of 0 means the day preceding the given month.
2208 Year numbers less than 100 are treated just like other year numbers.
2209 If you want them to stand for years in this century, you must do that yourself.
2211 Years before 1970 are not guaranteed to work. On some systems,
2212 year values as low as 1901 do work.
2214 usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
2215 (ptrdiff_t nargs
, Lisp_Object
*args
)
2219 Lisp_Object zone
= (nargs
> 6 ? args
[nargs
- 1] : Qnil
);
2221 tm
.tm_sec
= check_tm_member (args
[0], 0);
2222 tm
.tm_min
= check_tm_member (args
[1], 0);
2223 tm
.tm_hour
= check_tm_member (args
[2], 0);
2224 tm
.tm_mday
= check_tm_member (args
[3], 0);
2225 tm
.tm_mon
= check_tm_member (args
[4], 1);
2226 tm
.tm_year
= check_tm_member (args
[5], TM_YEAR_BASE
);
2229 timezone_t tz
= tzlookup (zone
, false);
2230 value
= emacs_mktime_z (tz
, &tm
);
2233 if (value
== (time_t) -1)
2236 return list2i (hi_time (value
), lo_time (value
));
2239 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
,
2241 doc
: /* Return the current local time, as a human-readable string.
2242 Programs can use this function to decode a time,
2243 since the number of columns in each field is fixed
2244 if the year is in the range 1000-9999.
2245 The format is `Sun Sep 16 01:03:52 1973'.
2246 However, see also the functions `decode-time' and `format-time-string'
2247 which provide a much more powerful and general facility.
2249 If SPECIFIED-TIME is given, it is a time to format instead of the
2250 current time. The argument should have the form (HIGH LOW . IGNORED).
2251 Thus, you can use times obtained from `current-time' and from
2252 `file-attributes'. SPECIFIED-TIME can also have the form (HIGH . LOW),
2253 but this is considered obsolete.
2255 The optional ZONE is omitted or nil for Emacs local time, t for
2256 Universal Time, `wall' for system wall clock time, or a string as in
2257 the TZ environment variable. It can also be a list (as from
2258 `current-time-zone') or an integer (as from `decode-time') applied
2259 without consideration for daylight saving time. */)
2260 (Lisp_Object specified_time
, Lisp_Object zone
)
2262 time_t value
= lisp_seconds_argument (specified_time
);
2263 timezone_t tz
= tzlookup (zone
, false);
2265 /* Convert to a string in ctime format, except without the trailing
2266 newline, and without the 4-digit year limit. Don't use asctime
2267 or ctime, as they might dump core if the year is outside the
2268 range -999 .. 9999. */
2270 struct tm
*tmp
= emacs_localtime_rz (tz
, &value
, &tm
);
2275 static char const wday_name
[][4] =
2276 { "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat" };
2277 static char const mon_name
[][4] =
2278 { "Jan", "Feb", "Mar", "Apr", "May", "Jun",
2279 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" };
2280 printmax_t year_base
= TM_YEAR_BASE
;
2281 char buf
[sizeof "Mon Apr 30 12:49:17 " + INT_STRLEN_BOUND (int) + 1];
2282 int len
= sprintf (buf
, "%s %s%3d %02d:%02d:%02d %"pMd
,
2283 wday_name
[tm
.tm_wday
], mon_name
[tm
.tm_mon
], tm
.tm_mday
,
2284 tm
.tm_hour
, tm
.tm_min
, tm
.tm_sec
,
2285 tm
.tm_year
+ year_base
);
2287 return make_unibyte_string (buf
, len
);
2290 /* Yield A - B, measured in seconds.
2291 This function is copied from the GNU C Library. */
2293 tm_diff (struct tm
*a
, struct tm
*b
)
2295 /* Compute intervening leap days correctly even if year is negative.
2296 Take care to avoid int overflow in leap day calculations,
2297 but it's OK to assume that A and B are close to each other. */
2298 int a4
= (a
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (a
->tm_year
& 3);
2299 int b4
= (b
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (b
->tm_year
& 3);
2300 int a100
= a4
/ 25 - (a4
% 25 < 0);
2301 int b100
= b4
/ 25 - (b4
% 25 < 0);
2302 int a400
= a100
>> 2;
2303 int b400
= b100
>> 2;
2304 int intervening_leap_days
= (a4
- b4
) - (a100
- b100
) + (a400
- b400
);
2305 int years
= a
->tm_year
- b
->tm_year
;
2306 int days
= (365 * years
+ intervening_leap_days
2307 + (a
->tm_yday
- b
->tm_yday
));
2308 return (60 * (60 * (24 * days
+ (a
->tm_hour
- b
->tm_hour
))
2309 + (a
->tm_min
- b
->tm_min
))
2310 + (a
->tm_sec
- b
->tm_sec
));
2313 /* Yield A's UTC offset, or an unspecified value if unknown. */
2315 tm_gmtoff (struct tm
*a
)
2318 return a
->tm_gmtoff
;
2324 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 2, 0,
2325 doc
: /* Return the offset and name for the local time zone.
2326 This returns a list of the form (OFFSET NAME).
2327 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
2328 A negative value means west of Greenwich.
2329 NAME is a string giving the name of the time zone.
2330 If SPECIFIED-TIME is given, the time zone offset is determined from it
2331 instead of using the current time. The argument should have the form
2332 \(HIGH LOW . IGNORED). Thus, you can use times obtained from
2333 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
2334 have the form (HIGH . LOW), but this is considered obsolete.
2336 The optional ZONE is omitted or nil for Emacs local time, t for
2337 Universal Time, `wall' for system wall clock time, or a string as in
2338 the TZ environment variable. It can also be a list (as from
2339 `current-time-zone') or an integer (as from `decode-time') applied
2340 without consideration for daylight saving time.
2342 Some operating systems cannot provide all this information to Emacs;
2343 in this case, `current-time-zone' returns a list containing nil for
2344 the data it can't find. */)
2345 (Lisp_Object specified_time
, Lisp_Object zone
)
2347 struct timespec value
;
2348 struct tm local_tm
, gmt_tm
;
2349 Lisp_Object zone_offset
, zone_name
;
2352 value
= make_timespec (lisp_seconds_argument (specified_time
), 0);
2353 zone_name
= format_time_string ("%Z", sizeof "%Z" - 1, value
,
2356 if (HAVE_TM_GMTOFF
|| gmtime_r (&value
.tv_sec
, &gmt_tm
))
2358 long int offset
= (HAVE_TM_GMTOFF
2359 ? tm_gmtoff (&local_tm
)
2360 : tm_diff (&local_tm
, &gmt_tm
));
2361 zone_offset
= make_number (offset
);
2362 if (SCHARS (zone_name
) == 0)
2364 /* No local time zone name is available; use numeric zone instead. */
2365 long int hour
= offset
/ 3600;
2366 int min_sec
= offset
% 3600;
2367 int amin_sec
= min_sec
< 0 ? - min_sec
: min_sec
;
2368 int min
= amin_sec
/ 60;
2369 int sec
= amin_sec
% 60;
2370 int min_prec
= min_sec
? 2 : 0;
2371 int sec_prec
= sec
? 2 : 0;
2372 char buf
[sizeof "+0000" + INT_STRLEN_BOUND (long int)];
2373 zone_name
= make_formatted_string (buf
, "%c%.2ld%.*d%.*d",
2374 (offset
< 0 ? '-' : '+'),
2375 hour
, min_prec
, min
, sec_prec
, sec
);
2379 return list2 (zone_offset
, zone_name
);
2382 DEFUN ("set-time-zone-rule", Fset_time_zone_rule
, Sset_time_zone_rule
, 1, 1, 0,
2383 doc
: /* Set the Emacs local time zone using TZ, a string specifying a time zone rule.
2384 If TZ is nil or `wall', use system wall clock time; this differs from
2385 the usual Emacs convention where nil means current local time. If TZ
2386 is t, use Universal Time. If TZ is a list (as from
2387 `current-time-zone') or an integer (as from `decode-time'), use the
2388 specified time zone without consideration for daylight saving time.
2390 Instead of calling this function, you typically want something else.
2391 To temporarily use a different time zone rule for just one invocation
2392 of `decode-time', `encode-time', or `format-time-string', pass the
2393 function a ZONE argument. To change local time consistently
2394 throughout Emacs, call (setenv "TZ" TZ): this changes both the
2395 environment of the Emacs process and the variable
2396 `process-environment', whereas `set-time-zone-rule' affects only the
2400 tzlookup (NILP (tz
) ? Qwall
: tz
, true);
2404 /* A buffer holding a string of the form "TZ=value", intended
2405 to be part of the environment. If TZ is supposed to be unset,
2406 the buffer string is "tZ=". */
2407 static char *tzvalbuf
;
2409 /* Get the local time zone rule. */
2411 emacs_getenv_TZ (void)
2413 return tzvalbuf
[0] == 'T' ? tzvalbuf
+ tzeqlen
: 0;
2416 /* Set the local time zone rule to TZSTRING, which can be null to
2417 denote wall clock time. Do not record the setting in LOCAL_TZ.
2419 This function is not thread-safe, in theory because putenv is not,
2420 but mostly because of the static storage it updates. Other threads
2421 that invoke localtime etc. may be adversely affected while this
2422 function is executing. */
2425 emacs_setenv_TZ (const char *tzstring
)
2427 static ptrdiff_t tzvalbufsize
;
2428 ptrdiff_t tzstringlen
= tzstring
? strlen (tzstring
) : 0;
2429 char *tzval
= tzvalbuf
;
2430 bool new_tzvalbuf
= tzvalbufsize
<= tzeqlen
+ tzstringlen
;
2434 /* Do not attempt to free the old tzvalbuf, since another thread
2435 may be using it. In practice, the first allocation is large
2436 enough and memory does not leak. */
2437 tzval
= xpalloc (NULL
, &tzvalbufsize
,
2438 tzeqlen
+ tzstringlen
- tzvalbufsize
+ 1, -1, 1);
2446 /* Modify TZVAL in place. Although this is dicey in a
2447 multithreaded environment, we know of no portable alternative.
2448 Calling putenv or setenv could crash some other thread. */
2450 strcpy (tzval
+ tzeqlen
, tzstring
);
2454 /* Turn 'TZ=whatever' into an empty environment variable 'tZ='.
2455 Although this is also dicey, calling unsetenv here can crash Emacs.
2463 /* Modifying *TZVAL merely requires calling tzset (which is the
2464 caller's responsibility). However, modifying TZVAL requires
2465 calling putenv; although this is not thread-safe, in practice this
2466 runs only on startup when there is only one thread. */
2467 bool need_putenv
= new_tzvalbuf
;
2469 /* MS-Windows 'putenv' copies the argument string into a block it
2470 allocates, so modifying *TZVAL will not change the environment.
2471 However, the other threads run by Emacs on MS-Windows never call
2472 'xputenv' or 'putenv' or 'unsetenv', so the original cause for the
2473 dicey in-place modification technique doesn't exist there in the
2475 bool need_putenv
= true;
2483 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
2484 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
2485 type of object is Lisp_String). INHERIT is passed to
2486 INSERT_FROM_STRING_FUNC as the last argument. */
2489 general_insert_function (void (*insert_func
)
2490 (const char *, ptrdiff_t),
2491 void (*insert_from_string_func
)
2492 (Lisp_Object
, ptrdiff_t, ptrdiff_t,
2493 ptrdiff_t, ptrdiff_t, bool),
2494 bool inherit
, ptrdiff_t nargs
, Lisp_Object
*args
)
2499 for (argnum
= 0; argnum
< nargs
; argnum
++)
2502 if (CHARACTERP (val
))
2504 int c
= XFASTINT (val
);
2505 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2508 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2509 len
= CHAR_STRING (c
, str
);
2512 str
[0] = CHAR_TO_BYTE8 (c
);
2515 (*insert_func
) ((char *) str
, len
);
2517 else if (STRINGP (val
))
2519 (*insert_from_string_func
) (val
, 0, 0,
2525 wrong_type_argument (Qchar_or_string_p
, val
);
2530 insert1 (Lisp_Object arg
)
2536 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
2537 doc
: /* Insert the arguments, either strings or characters, at point.
2538 Point and after-insertion markers move forward to end up
2539 after the inserted text.
2540 Any other markers at the point of insertion remain before the text.
2542 If the current buffer is multibyte, unibyte strings are converted
2543 to multibyte for insertion (see `string-make-multibyte').
2544 If the current buffer is unibyte, multibyte strings are converted
2545 to unibyte for insertion (see `string-make-unibyte').
2547 When operating on binary data, it may be necessary to preserve the
2548 original bytes of a unibyte string when inserting it into a multibyte
2549 buffer; to accomplish this, apply `string-as-multibyte' to the string
2550 and insert the result.
2552 usage: (insert &rest ARGS) */)
2553 (ptrdiff_t nargs
, Lisp_Object
*args
)
2555 general_insert_function (insert
, insert_from_string
, 0, nargs
, args
);
2559 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
2561 doc
: /* Insert the arguments at point, inheriting properties from adjoining text.
2562 Point and after-insertion markers move forward to end up
2563 after the inserted text.
2564 Any other markers at the point of insertion remain before the text.
2566 If the current buffer is multibyte, unibyte strings are converted
2567 to multibyte for insertion (see `unibyte-char-to-multibyte').
2568 If the current buffer is unibyte, multibyte strings are converted
2569 to unibyte for insertion.
2571 usage: (insert-and-inherit &rest ARGS) */)
2572 (ptrdiff_t nargs
, Lisp_Object
*args
)
2574 general_insert_function (insert_and_inherit
, insert_from_string
, 1,
2579 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
2580 doc
: /* Insert strings or characters at point, relocating markers after the text.
2581 Point and markers move forward to end up after the inserted text.
2583 If the current buffer is multibyte, unibyte strings are converted
2584 to multibyte for insertion (see `unibyte-char-to-multibyte').
2585 If the current buffer is unibyte, multibyte strings are converted
2586 to unibyte for insertion.
2588 If an overlay begins at the insertion point, the inserted text falls
2589 outside the overlay; if a nonempty overlay ends at the insertion
2590 point, the inserted text falls inside that overlay.
2592 usage: (insert-before-markers &rest ARGS) */)
2593 (ptrdiff_t nargs
, Lisp_Object
*args
)
2595 general_insert_function (insert_before_markers
,
2596 insert_from_string_before_markers
, 0,
2601 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers
,
2602 Sinsert_and_inherit_before_markers
, 0, MANY
, 0,
2603 doc
: /* Insert text at point, relocating markers and inheriting properties.
2604 Point and markers move forward to end up after the inserted text.
2606 If the current buffer is multibyte, unibyte strings are converted
2607 to multibyte for insertion (see `unibyte-char-to-multibyte').
2608 If the current buffer is unibyte, multibyte strings are converted
2609 to unibyte for insertion.
2611 usage: (insert-before-markers-and-inherit &rest ARGS) */)
2612 (ptrdiff_t nargs
, Lisp_Object
*args
)
2614 general_insert_function (insert_before_markers_and_inherit
,
2615 insert_from_string_before_markers
, 1,
2620 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 1, 3,
2621 "(list (read-char-by-name \"Insert character (Unicode name or hex): \")\
2622 (prefix-numeric-value current-prefix-arg)\
2624 doc
: /* Insert COUNT copies of CHARACTER.
2625 Interactively, prompt for CHARACTER. You can specify CHARACTER in one
2628 - As its Unicode character name, e.g. \"LATIN SMALL LETTER A\".
2629 Completion is available; if you type a substring of the name
2630 preceded by an asterisk `*', Emacs shows all names which include
2631 that substring, not necessarily at the beginning of the name.
2633 - As a hexadecimal code point, e.g. 263A. Note that code points in
2634 Emacs are equivalent to Unicode up to 10FFFF (which is the limit of
2635 the Unicode code space).
2637 - As a code point with a radix specified with #, e.g. #o21430
2638 (octal), #x2318 (hex), or #10r8984 (decimal).
2640 If called interactively, COUNT is given by the prefix argument. If
2641 omitted or nil, it defaults to 1.
2643 Inserting the character(s) relocates point and before-insertion
2644 markers in the same ways as the function `insert'.
2646 The optional third argument INHERIT, if non-nil, says to inherit text
2647 properties from adjoining text, if those properties are sticky. If
2648 called interactively, INHERIT is t. */)
2649 (Lisp_Object character
, Lisp_Object count
, Lisp_Object inherit
)
2652 register ptrdiff_t n
;
2654 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2657 CHECK_CHARACTER (character
);
2659 XSETFASTINT (count
, 1);
2660 CHECK_NUMBER (count
);
2661 c
= XFASTINT (character
);
2663 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2664 len
= CHAR_STRING (c
, str
);
2666 str
[0] = c
, len
= 1;
2667 if (XINT (count
) <= 0)
2669 if (BUF_BYTES_MAX
/ len
< XINT (count
))
2671 n
= XINT (count
) * len
;
2672 stringlen
= min (n
, sizeof string
- sizeof string
% len
);
2673 for (i
= 0; i
< stringlen
; i
++)
2674 string
[i
] = str
[i
% len
];
2675 while (n
> stringlen
)
2678 if (!NILP (inherit
))
2679 insert_and_inherit (string
, stringlen
);
2681 insert (string
, stringlen
);
2684 if (!NILP (inherit
))
2685 insert_and_inherit (string
, n
);
2691 DEFUN ("insert-byte", Finsert_byte
, Sinsert_byte
, 2, 3, 0,
2692 doc
: /* Insert COUNT (second arg) copies of BYTE (first arg).
2693 Both arguments are required.
2694 BYTE is a number of the range 0..255.
2696 If BYTE is 128..255 and the current buffer is multibyte, the
2697 corresponding eight-bit character is inserted.
2699 Point, and before-insertion markers, are relocated as in the function `insert'.
2700 The optional third arg INHERIT, if non-nil, says to inherit text properties
2701 from adjoining text, if those properties are sticky. */)
2702 (Lisp_Object byte
, Lisp_Object count
, Lisp_Object inherit
)
2704 CHECK_NUMBER (byte
);
2705 if (XINT (byte
) < 0 || XINT (byte
) > 255)
2706 args_out_of_range_3 (byte
, make_number (0), make_number (255));
2707 if (XINT (byte
) >= 128
2708 && ! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2709 XSETFASTINT (byte
, BYTE8_TO_CHAR (XINT (byte
)));
2710 return Finsert_char (byte
, count
, inherit
);
2714 /* Making strings from buffer contents. */
2716 /* Return a Lisp_String containing the text of the current buffer from
2717 START to END. If text properties are in use and the current buffer
2718 has properties in the range specified, the resulting string will also
2719 have them, if PROPS is true.
2721 We don't want to use plain old make_string here, because it calls
2722 make_uninit_string, which can cause the buffer arena to be
2723 compacted. make_string has no way of knowing that the data has
2724 been moved, and thus copies the wrong data into the string. This
2725 doesn't effect most of the other users of make_string, so it should
2726 be left as is. But we should use this function when conjuring
2727 buffer substrings. */
2730 make_buffer_string (ptrdiff_t start
, ptrdiff_t end
, bool props
)
2732 ptrdiff_t start_byte
= CHAR_TO_BYTE (start
);
2733 ptrdiff_t end_byte
= CHAR_TO_BYTE (end
);
2735 return make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
);
2738 /* Return a Lisp_String containing the text of the current buffer from
2739 START / START_BYTE to END / END_BYTE.
2741 If text properties are in use and the current buffer
2742 has properties in the range specified, the resulting string will also
2743 have them, if PROPS is true.
2745 We don't want to use plain old make_string here, because it calls
2746 make_uninit_string, which can cause the buffer arena to be
2747 compacted. make_string has no way of knowing that the data has
2748 been moved, and thus copies the wrong data into the string. This
2749 doesn't effect most of the other users of make_string, so it should
2750 be left as is. But we should use this function when conjuring
2751 buffer substrings. */
2754 make_buffer_string_both (ptrdiff_t start
, ptrdiff_t start_byte
,
2755 ptrdiff_t end
, ptrdiff_t end_byte
, bool props
)
2757 Lisp_Object result
, tem
, tem1
;
2758 ptrdiff_t beg0
, end0
, beg1
, end1
, size
;
2760 if (start_byte
< GPT_BYTE
&& GPT_BYTE
< end_byte
)
2762 /* Two regions, before and after the gap. */
2765 beg1
= GPT_BYTE
+ GAP_SIZE
- BEG_BYTE
;
2766 end1
= end_byte
+ GAP_SIZE
- BEG_BYTE
;
2770 /* The only region. */
2777 if (! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2778 result
= make_uninit_multibyte_string (end
- start
, end_byte
- start_byte
);
2780 result
= make_uninit_string (end
- start
);
2783 memcpy (SDATA (result
), BYTE_POS_ADDR (beg0
), size
);
2785 memcpy (SDATA (result
) + size
, BEG_ADDR
+ beg1
, end1
- beg1
);
2787 /* If desired, update and copy the text properties. */
2790 update_buffer_properties (start
, end
);
2792 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
2793 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
2795 if (XINT (tem
) != end
|| !NILP (tem1
))
2796 copy_intervals_to_string (result
, current_buffer
, start
,
2803 /* Call Vbuffer_access_fontify_functions for the range START ... END
2804 in the current buffer, if necessary. */
2807 update_buffer_properties (ptrdiff_t start
, ptrdiff_t end
)
2809 /* If this buffer has some access functions,
2810 call them, specifying the range of the buffer being accessed. */
2811 if (!NILP (Vbuffer_access_fontify_functions
))
2813 /* But don't call them if we can tell that the work
2814 has already been done. */
2815 if (!NILP (Vbuffer_access_fontified_property
))
2818 = Ftext_property_any (make_number (start
), make_number (end
),
2819 Vbuffer_access_fontified_property
,
2825 CALLN (Frun_hook_with_args
, Qbuffer_access_fontify_functions
,
2826 make_number (start
), make_number (end
));
2830 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
2831 doc
: /* Return the contents of part of the current buffer as a string.
2832 The two arguments START and END are character positions;
2833 they can be in either order.
2834 The string returned is multibyte if the buffer is multibyte.
2836 This function copies the text properties of that part of the buffer
2837 into the result string; if you don't want the text properties,
2838 use `buffer-substring-no-properties' instead. */)
2839 (Lisp_Object start
, Lisp_Object end
)
2841 register ptrdiff_t b
, e
;
2843 validate_region (&start
, &end
);
2847 return make_buffer_string (b
, e
, 1);
2850 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties
,
2851 Sbuffer_substring_no_properties
, 2, 2, 0,
2852 doc
: /* Return the characters of part of the buffer, without the text properties.
2853 The two arguments START and END are character positions;
2854 they can be in either order. */)
2855 (Lisp_Object start
, Lisp_Object end
)
2857 register ptrdiff_t b
, e
;
2859 validate_region (&start
, &end
);
2863 return make_buffer_string (b
, e
, 0);
2866 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
2867 doc
: /* Return the contents of the current buffer as a string.
2868 If narrowing is in effect, this function returns only the visible part
2872 return make_buffer_string_both (BEGV
, BEGV_BYTE
, ZV
, ZV_BYTE
, 1);
2875 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
2877 doc
: /* Insert before point a substring of the contents of BUFFER.
2878 BUFFER may be a buffer or a buffer name.
2879 Arguments START and END are character positions specifying the substring.
2880 They default to the values of (point-min) and (point-max) in BUFFER.
2882 Point and before-insertion markers move forward to end up after the
2884 Any other markers at the point of insertion remain before the text.
2886 If the current buffer is multibyte and BUFFER is unibyte, or vice
2887 versa, strings are converted from unibyte to multibyte or vice versa
2888 using `string-make-multibyte' or `string-make-unibyte', which see. */)
2889 (Lisp_Object buffer
, Lisp_Object start
, Lisp_Object end
)
2891 register EMACS_INT b
, e
, temp
;
2892 register struct buffer
*bp
, *obuf
;
2895 buf
= Fget_buffer (buffer
);
2899 if (!BUFFER_LIVE_P (bp
))
2900 error ("Selecting deleted buffer");
2906 CHECK_NUMBER_COERCE_MARKER (start
);
2913 CHECK_NUMBER_COERCE_MARKER (end
);
2918 temp
= b
, b
= e
, e
= temp
;
2920 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
2921 args_out_of_range (start
, end
);
2923 obuf
= current_buffer
;
2924 set_buffer_internal_1 (bp
);
2925 update_buffer_properties (b
, e
);
2926 set_buffer_internal_1 (obuf
);
2928 insert_from_buffer (bp
, b
, e
- b
, 0);
2932 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
2934 doc
: /* Compare two substrings of two buffers; return result as number.
2935 Return -N if first string is less after N-1 chars, +N if first string is
2936 greater after N-1 chars, or 0 if strings match.
2937 The first substring is in BUFFER1 from START1 to END1 and the second
2938 is in BUFFER2 from START2 to END2.
2939 The value of `case-fold-search' in the current buffer
2940 determines whether case is significant or ignored. */)
2941 (Lisp_Object buffer1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object buffer2
, Lisp_Object start2
, Lisp_Object end2
)
2943 register EMACS_INT begp1
, endp1
, begp2
, endp2
, temp
;
2944 register struct buffer
*bp1
, *bp2
;
2945 register Lisp_Object trt
2946 = (!NILP (BVAR (current_buffer
, case_fold_search
))
2947 ? BVAR (current_buffer
, case_canon_table
) : Qnil
);
2948 ptrdiff_t chars
= 0;
2949 ptrdiff_t i1
, i2
, i1_byte
, i2_byte
;
2951 /* Find the first buffer and its substring. */
2954 bp1
= current_buffer
;
2958 buf1
= Fget_buffer (buffer1
);
2961 bp1
= XBUFFER (buf1
);
2962 if (!BUFFER_LIVE_P (bp1
))
2963 error ("Selecting deleted buffer");
2967 begp1
= BUF_BEGV (bp1
);
2970 CHECK_NUMBER_COERCE_MARKER (start1
);
2971 begp1
= XINT (start1
);
2974 endp1
= BUF_ZV (bp1
);
2977 CHECK_NUMBER_COERCE_MARKER (end1
);
2978 endp1
= XINT (end1
);
2982 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
2984 if (!(BUF_BEGV (bp1
) <= begp1
2986 && endp1
<= BUF_ZV (bp1
)))
2987 args_out_of_range (start1
, end1
);
2989 /* Likewise for second substring. */
2992 bp2
= current_buffer
;
2996 buf2
= Fget_buffer (buffer2
);
2999 bp2
= XBUFFER (buf2
);
3000 if (!BUFFER_LIVE_P (bp2
))
3001 error ("Selecting deleted buffer");
3005 begp2
= BUF_BEGV (bp2
);
3008 CHECK_NUMBER_COERCE_MARKER (start2
);
3009 begp2
= XINT (start2
);
3012 endp2
= BUF_ZV (bp2
);
3015 CHECK_NUMBER_COERCE_MARKER (end2
);
3016 endp2
= XINT (end2
);
3020 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
3022 if (!(BUF_BEGV (bp2
) <= begp2
3024 && endp2
<= BUF_ZV (bp2
)))
3025 args_out_of_range (start2
, end2
);
3029 i1_byte
= buf_charpos_to_bytepos (bp1
, i1
);
3030 i2_byte
= buf_charpos_to_bytepos (bp2
, i2
);
3032 while (i1
< endp1
&& i2
< endp2
)
3034 /* When we find a mismatch, we must compare the
3035 characters, not just the bytes. */
3040 if (! NILP (BVAR (bp1
, enable_multibyte_characters
)))
3042 c1
= BUF_FETCH_MULTIBYTE_CHAR (bp1
, i1_byte
);
3043 BUF_INC_POS (bp1
, i1_byte
);
3048 c1
= BUF_FETCH_BYTE (bp1
, i1
);
3049 MAKE_CHAR_MULTIBYTE (c1
);
3053 if (! NILP (BVAR (bp2
, enable_multibyte_characters
)))
3055 c2
= BUF_FETCH_MULTIBYTE_CHAR (bp2
, i2_byte
);
3056 BUF_INC_POS (bp2
, i2_byte
);
3061 c2
= BUF_FETCH_BYTE (bp2
, i2
);
3062 MAKE_CHAR_MULTIBYTE (c2
);
3068 c1
= char_table_translate (trt
, c1
);
3069 c2
= char_table_translate (trt
, c2
);
3072 return make_number (- 1 - chars
);
3074 return make_number (chars
+ 1);
3079 /* The strings match as far as they go.
3080 If one is shorter, that one is less. */
3081 if (chars
< endp1
- begp1
)
3082 return make_number (chars
+ 1);
3083 else if (chars
< endp2
- begp2
)
3084 return make_number (- chars
- 1);
3086 /* Same length too => they are equal. */
3087 return make_number (0);
3091 subst_char_in_region_unwind (Lisp_Object arg
)
3093 bset_undo_list (current_buffer
, arg
);
3097 subst_char_in_region_unwind_1 (Lisp_Object arg
)
3099 bset_filename (current_buffer
, arg
);
3102 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
3103 Ssubst_char_in_region
, 4, 5, 0,
3104 doc
: /* From START to END, replace FROMCHAR with TOCHAR each time it occurs.
3105 If optional arg NOUNDO is non-nil, don't record this change for undo
3106 and don't mark the buffer as really changed.
3107 Both characters must have the same length of multi-byte form. */)
3108 (Lisp_Object start
, Lisp_Object end
, Lisp_Object fromchar
, Lisp_Object tochar
, Lisp_Object noundo
)
3110 register ptrdiff_t pos
, pos_byte
, stop
, i
, len
, end_byte
;
3111 /* Keep track of the first change in the buffer:
3112 if 0 we haven't found it yet.
3113 if < 0 we've found it and we've run the before-change-function.
3114 if > 0 we've actually performed it and the value is its position. */
3115 ptrdiff_t changed
= 0;
3116 unsigned char fromstr
[MAX_MULTIBYTE_LENGTH
], tostr
[MAX_MULTIBYTE_LENGTH
];
3118 ptrdiff_t count
= SPECPDL_INDEX ();
3119 #define COMBINING_NO 0
3120 #define COMBINING_BEFORE 1
3121 #define COMBINING_AFTER 2
3122 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
3123 int maybe_byte_combining
= COMBINING_NO
;
3124 ptrdiff_t last_changed
= 0;
3126 = !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3131 validate_region (&start
, &end
);
3132 CHECK_CHARACTER (fromchar
);
3133 CHECK_CHARACTER (tochar
);
3134 fromc
= XFASTINT (fromchar
);
3135 toc
= XFASTINT (tochar
);
3139 len
= CHAR_STRING (fromc
, fromstr
);
3140 if (CHAR_STRING (toc
, tostr
) != len
)
3141 error ("Characters in `subst-char-in-region' have different byte-lengths");
3142 if (!ASCII_CHAR_P (*tostr
))
3144 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
3145 complete multibyte character, it may be combined with the
3146 after bytes. If it is in the range 0xA0..0xFF, it may be
3147 combined with the before and after bytes. */
3148 if (!CHAR_HEAD_P (*tostr
))
3149 maybe_byte_combining
= COMBINING_BOTH
;
3150 else if (BYTES_BY_CHAR_HEAD (*tostr
) > len
)
3151 maybe_byte_combining
= COMBINING_AFTER
;
3162 pos_byte
= CHAR_TO_BYTE (pos
);
3163 stop
= CHAR_TO_BYTE (XINT (end
));
3166 /* If we don't want undo, turn off putting stuff on the list.
3167 That's faster than getting rid of things,
3168 and it prevents even the entry for a first change.
3169 Also inhibit locking the file. */
3170 if (!changed
&& !NILP (noundo
))
3172 record_unwind_protect (subst_char_in_region_unwind
,
3173 BVAR (current_buffer
, undo_list
));
3174 bset_undo_list (current_buffer
, Qt
);
3175 /* Don't do file-locking. */
3176 record_unwind_protect (subst_char_in_region_unwind_1
,
3177 BVAR (current_buffer
, filename
));
3178 bset_filename (current_buffer
, Qnil
);
3181 if (pos_byte
< GPT_BYTE
)
3182 stop
= min (stop
, GPT_BYTE
);
3185 ptrdiff_t pos_byte_next
= pos_byte
;
3187 if (pos_byte
>= stop
)
3189 if (pos_byte
>= end_byte
) break;
3192 p
= BYTE_POS_ADDR (pos_byte
);
3194 INC_POS (pos_byte_next
);
3197 if (pos_byte_next
- pos_byte
== len
3198 && p
[0] == fromstr
[0]
3200 || (p
[1] == fromstr
[1]
3201 && (len
== 2 || (p
[2] == fromstr
[2]
3202 && (len
== 3 || p
[3] == fromstr
[3]))))))
3205 /* We've already seen this and run the before-change-function;
3206 this time we only need to record the actual position. */
3211 modify_text (pos
, XINT (end
));
3213 if (! NILP (noundo
))
3215 if (MODIFF
- 1 == SAVE_MODIFF
)
3217 if (MODIFF
- 1 == BUF_AUTOSAVE_MODIFF (current_buffer
))
3218 BUF_AUTOSAVE_MODIFF (current_buffer
)++;
3221 /* The before-change-function may have moved the gap
3222 or even modified the buffer so we should start over. */
3226 /* Take care of the case where the new character
3227 combines with neighboring bytes. */
3228 if (maybe_byte_combining
3229 && (maybe_byte_combining
== COMBINING_AFTER
3230 ? (pos_byte_next
< Z_BYTE
3231 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
3232 : ((pos_byte_next
< Z_BYTE
3233 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
3234 || (pos_byte
> BEG_BYTE
3235 && ! ASCII_CHAR_P (FETCH_BYTE (pos_byte
- 1))))))
3237 Lisp_Object tem
, string
;
3239 tem
= BVAR (current_buffer
, undo_list
);
3241 /* Make a multibyte string containing this single character. */
3242 string
= make_multibyte_string ((char *) tostr
, 1, len
);
3243 /* replace_range is less efficient, because it moves the gap,
3244 but it handles combining correctly. */
3245 replace_range (pos
, pos
+ 1, string
,
3247 pos_byte_next
= CHAR_TO_BYTE (pos
);
3248 if (pos_byte_next
> pos_byte
)
3249 /* Before combining happened. We should not increment
3250 POS. So, to cancel the later increment of POS,
3254 INC_POS (pos_byte_next
);
3256 if (! NILP (noundo
))
3257 bset_undo_list (current_buffer
, tem
);
3262 record_change (pos
, 1);
3263 for (i
= 0; i
< len
; i
++) *p
++ = tostr
[i
];
3265 last_changed
= pos
+ 1;
3267 pos_byte
= pos_byte_next
;
3273 signal_after_change (changed
,
3274 last_changed
- changed
, last_changed
- changed
);
3275 update_compositions (changed
, last_changed
, CHECK_ALL
);
3278 unbind_to (count
, Qnil
);
3283 static Lisp_Object
check_translation (ptrdiff_t, ptrdiff_t, ptrdiff_t,
3286 /* Helper function for Ftranslate_region_internal.
3288 Check if a character sequence at POS (POS_BYTE) matches an element
3289 of VAL. VAL is a list (([FROM-CHAR ...] . TO) ...). If a matching
3290 element is found, return it. Otherwise return Qnil. */
3293 check_translation (ptrdiff_t pos
, ptrdiff_t pos_byte
, ptrdiff_t end
,
3296 int initial_buf
[16];
3297 int *buf
= initial_buf
;
3298 ptrdiff_t buf_size
= ARRAYELTS (initial_buf
);
3300 ptrdiff_t buf_used
= 0;
3301 Lisp_Object result
= Qnil
;
3303 for (; CONSP (val
); val
= XCDR (val
))
3312 if (! VECTORP (elt
))
3315 if (len
<= end
- pos
)
3317 for (i
= 0; i
< len
; i
++)
3321 unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
3324 if (buf_used
== buf_size
)
3326 bufalloc
= xpalloc (bufalloc
, &buf_size
, 1, -1,
3328 if (buf
== initial_buf
)
3329 memcpy (bufalloc
, buf
, sizeof initial_buf
);
3332 buf
[buf_used
++] = STRING_CHAR_AND_LENGTH (p
, len1
);
3335 if (XINT (AREF (elt
, i
)) != buf
[i
])
3340 result
= XCAR (val
);
3351 DEFUN ("translate-region-internal", Ftranslate_region_internal
,
3352 Stranslate_region_internal
, 3, 3, 0,
3353 doc
: /* Internal use only.
3354 From START to END, translate characters according to TABLE.
3355 TABLE is a string or a char-table; the Nth character in it is the
3356 mapping for the character with code N.
3357 It returns the number of characters changed. */)
3358 (Lisp_Object start
, Lisp_Object end
, register Lisp_Object table
)
3360 register unsigned char *tt
; /* Trans table. */
3361 register int nc
; /* New character. */
3362 int cnt
; /* Number of changes made. */
3363 ptrdiff_t size
; /* Size of translate table. */
3364 ptrdiff_t pos
, pos_byte
, end_pos
;
3365 bool multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3366 bool string_multibyte UNINIT
;
3368 validate_region (&start
, &end
);
3369 if (CHAR_TABLE_P (table
))
3371 if (! EQ (XCHAR_TABLE (table
)->purpose
, Qtranslation_table
))
3372 error ("Not a translation table");
3378 CHECK_STRING (table
);
3380 if (! multibyte
&& (SCHARS (table
) < SBYTES (table
)))
3381 table
= string_make_unibyte (table
);
3382 string_multibyte
= SCHARS (table
) < SBYTES (table
);
3383 size
= SBYTES (table
);
3388 pos_byte
= CHAR_TO_BYTE (pos
);
3389 end_pos
= XINT (end
);
3390 modify_text (pos
, end_pos
);
3393 for (; pos
< end_pos
; )
3395 register unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
3396 unsigned char *str
, buf
[MAX_MULTIBYTE_LENGTH
];
3402 oc
= STRING_CHAR_AND_LENGTH (p
, len
);
3409 /* Reload as signal_after_change in last iteration may GC. */
3411 if (string_multibyte
)
3413 str
= tt
+ string_char_to_byte (table
, oc
);
3414 nc
= STRING_CHAR_AND_LENGTH (str
, str_len
);
3419 if (! ASCII_CHAR_P (nc
) && multibyte
)
3421 str_len
= BYTE8_STRING (nc
, buf
);
3434 val
= CHAR_TABLE_REF (table
, oc
);
3435 if (CHARACTERP (val
))
3437 nc
= XFASTINT (val
);
3438 str_len
= CHAR_STRING (nc
, buf
);
3441 else if (VECTORP (val
) || (CONSP (val
)))
3443 /* VAL is [TO_CHAR ...] or (([FROM-CHAR ...] . TO) ...)
3444 where TO is TO-CHAR or [TO-CHAR ...]. */
3449 if (nc
!= oc
&& nc
>= 0)
3451 /* Simple one char to one char translation. */
3456 /* This is less efficient, because it moves the gap,
3457 but it should handle multibyte characters correctly. */
3458 string
= make_multibyte_string ((char *) str
, 1, str_len
);
3459 replace_range (pos
, pos
+ 1, string
, 1, 0, 1, 0);
3464 record_change (pos
, 1);
3465 while (str_len
-- > 0)
3467 signal_after_change (pos
, 1, 1);
3468 update_compositions (pos
, pos
+ 1, CHECK_BORDER
);
3478 val
= check_translation (pos
, pos_byte
, end_pos
, val
);
3485 /* VAL is ([FROM-CHAR ...] . TO). */
3486 len
= ASIZE (XCAR (val
));
3494 string
= Fconcat (1, &val
);
3498 string
= Fmake_string (make_number (1), val
);
3500 replace_range (pos
, pos
+ len
, string
, 1, 0, 1, 0);
3501 pos_byte
+= SBYTES (string
);
3502 pos
+= SCHARS (string
);
3503 cnt
+= SCHARS (string
);
3504 end_pos
+= SCHARS (string
) - len
;
3512 return make_number (cnt
);
3515 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
3516 doc
: /* Delete the text between START and END.
3517 If called interactively, delete the region between point and mark.
3518 This command deletes buffer text without modifying the kill ring. */)
3519 (Lisp_Object start
, Lisp_Object end
)
3521 validate_region (&start
, &end
);
3522 del_range (XINT (start
), XINT (end
));
3526 DEFUN ("delete-and-extract-region", Fdelete_and_extract_region
,
3527 Sdelete_and_extract_region
, 2, 2, 0,
3528 doc
: /* Delete the text between START and END and return it. */)
3529 (Lisp_Object start
, Lisp_Object end
)
3531 validate_region (&start
, &end
);
3532 if (XINT (start
) == XINT (end
))
3533 return empty_unibyte_string
;
3534 return del_range_1 (XINT (start
), XINT (end
), 1, 1);
3537 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
3538 doc
: /* Remove restrictions (narrowing) from current buffer.
3539 This allows the buffer's full text to be seen and edited. */)
3542 if (BEG
!= BEGV
|| Z
!= ZV
)
3543 current_buffer
->clip_changed
= 1;
3545 BEGV_BYTE
= BEG_BYTE
;
3546 SET_BUF_ZV_BOTH (current_buffer
, Z
, Z_BYTE
);
3547 /* Changing the buffer bounds invalidates any recorded current column. */
3548 invalidate_current_column ();
3552 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
3553 doc
: /* Restrict editing in this buffer to the current region.
3554 The rest of the text becomes temporarily invisible and untouchable
3555 but is not deleted; if you save the buffer in a file, the invisible
3556 text is included in the file. \\[widen] makes all visible again.
3557 See also `save-restriction'.
3559 When calling from a program, pass two arguments; positions (integers
3560 or markers) bounding the text that should remain visible. */)
3561 (register Lisp_Object start
, Lisp_Object end
)
3563 CHECK_NUMBER_COERCE_MARKER (start
);
3564 CHECK_NUMBER_COERCE_MARKER (end
);
3566 if (XINT (start
) > XINT (end
))
3569 tem
= start
; start
= end
; end
= tem
;
3572 if (!(BEG
<= XINT (start
) && XINT (start
) <= XINT (end
) && XINT (end
) <= Z
))
3573 args_out_of_range (start
, end
);
3575 if (BEGV
!= XFASTINT (start
) || ZV
!= XFASTINT (end
))
3576 current_buffer
->clip_changed
= 1;
3578 SET_BUF_BEGV (current_buffer
, XFASTINT (start
));
3579 SET_BUF_ZV (current_buffer
, XFASTINT (end
));
3580 if (PT
< XFASTINT (start
))
3581 SET_PT (XFASTINT (start
));
3582 if (PT
> XFASTINT (end
))
3583 SET_PT (XFASTINT (end
));
3584 /* Changing the buffer bounds invalidates any recorded current column. */
3585 invalidate_current_column ();
3590 save_restriction_save (void)
3592 if (BEGV
== BEG
&& ZV
== Z
)
3593 /* The common case that the buffer isn't narrowed.
3594 We return just the buffer object, which save_restriction_restore
3595 recognizes as meaning `no restriction'. */
3596 return Fcurrent_buffer ();
3598 /* We have to save a restriction, so return a pair of markers, one
3599 for the beginning and one for the end. */
3601 Lisp_Object beg
, end
;
3603 beg
= build_marker (current_buffer
, BEGV
, BEGV_BYTE
);
3604 end
= build_marker (current_buffer
, ZV
, ZV_BYTE
);
3606 /* END must move forward if text is inserted at its exact location. */
3607 XMARKER (end
)->insertion_type
= 1;
3609 return Fcons (beg
, end
);
3614 save_restriction_restore (Lisp_Object data
)
3616 struct buffer
*cur
= NULL
;
3617 struct buffer
*buf
= (CONSP (data
)
3618 ? XMARKER (XCAR (data
))->buffer
3621 if (buf
&& buf
!= current_buffer
&& !NILP (BVAR (buf
, pt_marker
)))
3622 { /* If `buf' uses markers to keep track of PT, BEGV, and ZV (as
3623 is the case if it is or has an indirect buffer), then make
3624 sure it is current before we update BEGV, so
3625 set_buffer_internal takes care of managing those markers. */
3626 cur
= current_buffer
;
3627 set_buffer_internal (buf
);
3631 /* A pair of marks bounding a saved restriction. */
3633 struct Lisp_Marker
*beg
= XMARKER (XCAR (data
));
3634 struct Lisp_Marker
*end
= XMARKER (XCDR (data
));
3635 eassert (buf
== end
->buffer
);
3637 if (buf
/* Verify marker still points to a buffer. */
3638 && (beg
->charpos
!= BUF_BEGV (buf
) || end
->charpos
!= BUF_ZV (buf
)))
3639 /* The restriction has changed from the saved one, so restore
3640 the saved restriction. */
3642 ptrdiff_t pt
= BUF_PT (buf
);
3644 SET_BUF_BEGV_BOTH (buf
, beg
->charpos
, beg
->bytepos
);
3645 SET_BUF_ZV_BOTH (buf
, end
->charpos
, end
->bytepos
);
3647 if (pt
< beg
->charpos
|| pt
> end
->charpos
)
3648 /* The point is outside the new visible range, move it inside. */
3649 SET_BUF_PT_BOTH (buf
,
3650 clip_to_bounds (beg
->charpos
, pt
, end
->charpos
),
3651 clip_to_bounds (beg
->bytepos
, BUF_PT_BYTE (buf
),
3654 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3656 /* These aren't needed anymore, so don't wait for GC. */
3657 free_marker (XCAR (data
));
3658 free_marker (XCDR (data
));
3659 free_cons (XCONS (data
));
3662 /* A buffer, which means that there was no old restriction. */
3664 if (buf
/* Verify marker still points to a buffer. */
3665 && (BUF_BEGV (buf
) != BUF_BEG (buf
) || BUF_ZV (buf
) != BUF_Z (buf
)))
3666 /* The buffer has been narrowed, get rid of the narrowing. */
3668 SET_BUF_BEGV_BOTH (buf
, BUF_BEG (buf
), BUF_BEG_BYTE (buf
));
3669 SET_BUF_ZV_BOTH (buf
, BUF_Z (buf
), BUF_Z_BYTE (buf
));
3671 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3675 /* Changing the buffer bounds invalidates any recorded current column. */
3676 invalidate_current_column ();
3679 set_buffer_internal (cur
);
3682 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
3683 doc
: /* Execute BODY, saving and restoring current buffer's restrictions.
3684 The buffer's restrictions make parts of the beginning and end invisible.
3685 \(They are set up with `narrow-to-region' and eliminated with `widen'.)
3686 This special form, `save-restriction', saves the current buffer's restrictions
3687 when it is entered, and restores them when it is exited.
3688 So any `narrow-to-region' within BODY lasts only until the end of the form.
3689 The old restrictions settings are restored
3690 even in case of abnormal exit (throw or error).
3692 The value returned is the value of the last form in BODY.
3694 Note: if you are using both `save-excursion' and `save-restriction',
3695 use `save-excursion' outermost:
3696 (save-excursion (save-restriction ...))
3698 usage: (save-restriction &rest BODY) */)
3701 register Lisp_Object val
;
3702 ptrdiff_t count
= SPECPDL_INDEX ();
3704 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
3705 val
= Fprogn (body
);
3706 return unbind_to (count
, val
);
3709 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
3710 doc
: /* Display a message at the bottom of the screen.
3711 The message also goes into the `*Messages*' buffer, if `message-log-max'
3712 is non-nil. (In keyboard macros, that's all it does.)
3715 In batch mode, the message is printed to the standard error stream,
3716 followed by a newline.
3718 The first argument is a format control string, and the rest are data
3719 to be formatted under control of the string. See `format-message' for
3722 Note: (message "%s" VALUE) displays the string VALUE without
3723 interpreting format characters like `%', `\\=`', and `\\=''.
3725 If the first argument is nil or the empty string, the function clears
3726 any existing message; this lets the minibuffer contents show. See
3727 also `current-message'.
3729 usage: (message FORMAT-STRING &rest ARGS) */)
3730 (ptrdiff_t nargs
, Lisp_Object
*args
)
3733 || (STRINGP (args
[0])
3734 && SBYTES (args
[0]) == 0))
3741 Lisp_Object val
= Fformat_message (nargs
, args
);
3747 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
3748 doc
: /* Display a message, in a dialog box if possible.
3749 If a dialog box is not available, use the echo area.
3750 The first argument is a format control string, and the rest are data
3751 to be formatted under control of the string. See `format-message' for
3754 If the first argument is nil or the empty string, clear any existing
3755 message; let the minibuffer contents show.
3757 usage: (message-box FORMAT-STRING &rest ARGS) */)
3758 (ptrdiff_t nargs
, Lisp_Object
*args
)
3767 Lisp_Object val
= Fformat_message (nargs
, args
);
3768 Lisp_Object pane
, menu
;
3770 pane
= list1 (Fcons (build_string ("OK"), Qt
));
3771 menu
= Fcons (val
, pane
);
3772 Fx_popup_dialog (Qt
, menu
, Qt
);
3777 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
3778 doc
: /* Display a message in a dialog box or in the echo area.
3779 If this command was invoked with the mouse, use a dialog box if
3780 `use-dialog-box' is non-nil.
3781 Otherwise, use the echo area.
3782 The first argument is a format control string, and the rest are data
3783 to be formatted under control of the string. See `format-message' for
3786 If the first argument is nil or the empty string, clear any existing
3787 message; let the minibuffer contents show.
3789 usage: (message-or-box FORMAT-STRING &rest ARGS) */)
3790 (ptrdiff_t nargs
, Lisp_Object
*args
)
3792 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3794 return Fmessage_box (nargs
, args
);
3795 return Fmessage (nargs
, args
);
3798 DEFUN ("current-message", Fcurrent_message
, Scurrent_message
, 0, 0, 0,
3799 doc
: /* Return the string currently displayed in the echo area, or nil if none. */)
3802 return current_message ();
3806 DEFUN ("propertize", Fpropertize
, Spropertize
, 1, MANY
, 0,
3807 doc
: /* Return a copy of STRING with text properties added.
3808 First argument is the string to copy.
3809 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
3810 properties to add to the result.
3811 usage: (propertize STRING &rest PROPERTIES) */)
3812 (ptrdiff_t nargs
, Lisp_Object
*args
)
3814 Lisp_Object properties
, string
;
3817 /* Number of args must be odd. */
3818 if ((nargs
& 1) == 0)
3819 error ("Wrong number of arguments");
3821 properties
= string
= Qnil
;
3823 /* First argument must be a string. */
3824 CHECK_STRING (args
[0]);
3825 string
= Fcopy_sequence (args
[0]);
3827 for (i
= 1; i
< nargs
; i
+= 2)
3828 properties
= Fcons (args
[i
], Fcons (args
[i
+ 1], properties
));
3830 Fadd_text_properties (make_number (0),
3831 make_number (SCHARS (string
)),
3832 properties
, string
);
3836 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
3837 doc
: /* Format a string out of a format-string and arguments.
3838 The first argument is a format control string.
3839 The other arguments are substituted into it to make the result, a string.
3841 The format control string may contain %-sequences meaning to substitute
3842 the next available argument:
3844 %s means print a string argument. Actually, prints any object, with `princ'.
3845 %d means print as number in decimal (%o octal, %x hex).
3846 %X is like %x, but uses upper case.
3847 %e means print a number in exponential notation.
3848 %f means print a number in decimal-point notation.
3849 %g means print a number in exponential notation
3850 or decimal-point notation, whichever uses fewer characters.
3851 %c means print a number as a single character.
3852 %S means print any object as an s-expression (using `prin1').
3854 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
3855 Use %% to put a single % into the output.
3857 A %-sequence may contain optional flag, width, and precision
3858 specifiers, as follows:
3860 %<flags><width><precision>character
3862 where flags is [+ #-0]+, width is [0-9]+, and precision is a literal
3863 period "." followed by [0-9]+
3865 The + flag character inserts a + before any positive number, while a
3866 space inserts a space before any positive number; these flags only
3867 affect %d, %e, %f, and %g sequences, and the + flag takes precedence.
3868 The - and 0 flags affect the width specifier, as described below.
3870 The # flag means to use an alternate display form for %o, %x, %X, %e,
3871 %f, and %g sequences: for %o, it ensures that the result begins with
3872 \"0\"; for %x and %X, it prefixes the result with \"0x\" or \"0X\";
3873 for %e, %f, and %g, it causes a decimal point to be included even if
3874 the precision is zero.
3876 The width specifier supplies a lower limit for the length of the
3877 printed representation. The padding, if any, normally goes on the
3878 left, but it goes on the right if the - flag is present. The padding
3879 character is normally a space, but it is 0 if the 0 flag is present.
3880 The 0 flag is ignored if the - flag is present, or the format sequence
3881 is something other than %d, %e, %f, and %g.
3883 For %e, %f, and %g sequences, the number after the "." in the
3884 precision specifier says how many decimal places to show; if zero, the
3885 decimal point itself is omitted. For %s and %S, the precision
3886 specifier truncates the string to the given width.
3888 Text properties, if any, are copied from the format-string to the
3891 usage: (format STRING &rest OBJECTS) */)
3892 (ptrdiff_t nargs
, Lisp_Object
*args
)
3894 return styled_format (nargs
, args
, false);
3897 DEFUN ("format-message", Fformat_message
, Sformat_message
, 1, MANY
, 0,
3898 doc
: /* Format a string out of a format-string and arguments.
3899 The first argument is a format control string.
3900 The other arguments are substituted into it to make the result, a string.
3902 This acts like `format', except it also replaces each grave accent (\\=`)
3903 by a left quote, and each apostrophe (\\=') by a right quote. The left
3904 and right quote replacement characters are specified by
3905 `text-quoting-style'.
3907 usage: (format-message STRING &rest OBJECTS) */)
3908 (ptrdiff_t nargs
, Lisp_Object
*args
)
3910 return styled_format (nargs
, args
, true);
3913 /* Implement ‘format-message’ if MESSAGE is true, ‘format’ otherwise. */
3916 styled_format (ptrdiff_t nargs
, Lisp_Object
*args
, bool message
)
3918 ptrdiff_t n
; /* The number of the next arg to substitute. */
3919 char initial_buffer
[4000];
3920 char *buf
= initial_buffer
;
3921 ptrdiff_t bufsize
= sizeof initial_buffer
;
3922 ptrdiff_t max_bufsize
= STRING_BYTES_BOUND
+ 1;
3924 ptrdiff_t buf_save_value_index UNINIT
;
3927 /* When we make a multibyte string, we must pay attention to the
3928 byte combining problem, i.e., a byte may be combined with a
3929 multibyte character of the previous string. This flag tells if we
3930 must consider such a situation or not. */
3931 bool maybe_combine_byte
;
3932 bool arg_intervals
= false;
3935 /* Each element records, for one argument,
3936 the start and end bytepos in the output string,
3937 whether the argument has been converted to string (e.g., due to "%S"),
3938 and whether the argument is a string with intervals. */
3941 ptrdiff_t start
, end
;
3942 bool_bf converted_to_string
: 1;
3943 bool_bf intervals
: 1;
3946 CHECK_STRING (args
[0]);
3947 char *format_start
= SSDATA (args
[0]);
3948 ptrdiff_t formatlen
= SBYTES (args
[0]);
3950 /* Allocate the info and discarded tables. */
3951 ptrdiff_t alloca_size
;
3952 if (INT_MULTIPLY_WRAPV (nargs
, sizeof *info
, &alloca_size
)
3953 || INT_ADD_WRAPV (sizeof *info
, alloca_size
, &alloca_size
)
3954 || INT_ADD_WRAPV (formatlen
, alloca_size
, &alloca_size
)
3955 || SIZE_MAX
< alloca_size
)
3956 memory_full (SIZE_MAX
);
3957 /* info[0] is unused. Unused elements have -1 for start. */
3958 info
= SAFE_ALLOCA (alloca_size
);
3959 memset (info
, 0, alloca_size
);
3960 for (ptrdiff_t i
= 0; i
< nargs
+ 1; i
++)
3962 /* discarded[I] is 1 if byte I of the format
3963 string was not copied into the output.
3964 It is 2 if byte I was not the first byte of its character. */
3965 char *discarded
= (char *) &info
[nargs
+ 1];
3967 /* Try to determine whether the result should be multibyte.
3968 This is not always right; sometimes the result needs to be multibyte
3969 because of an object that we will pass through prin1.
3970 or because a grave accent or apostrophe is requoted,
3971 and in that case, we won't know it here. */
3973 /* True if the format is multibyte. */
3974 bool multibyte_format
= STRING_MULTIBYTE (args
[0]);
3975 /* True if the output should be a multibyte string,
3976 which is true if any of the inputs is one. */
3977 bool multibyte
= multibyte_format
;
3978 for (ptrdiff_t i
= 1; !multibyte
&& i
< nargs
; i
++)
3979 if (STRINGP (args
[i
]) && STRING_MULTIBYTE (args
[i
]))
3982 int quoting_style
= message
? text_quoting_style () : -1;
3984 /* If we start out planning a unibyte result,
3985 then discover it has to be multibyte, we jump back to retry. */
3992 /* Scan the format and store result in BUF. */
3993 format
= format_start
;
3994 end
= format
+ formatlen
;
3995 maybe_combine_byte
= false;
3997 while (format
!= end
)
3999 /* The values of N and FORMAT when the loop body is entered. */
4001 char *format0
= format
;
4002 char const *convsrc
= format
;
4003 unsigned char format_char
= *format
++;
4005 /* Bytes needed to represent the output of this conversion. */
4006 ptrdiff_t convbytes
= 1;
4008 if (format_char
== '%')
4010 /* General format specifications look like
4012 '%' [flags] [field-width] [precision] format
4017 field-width ::= [0-9]+
4018 precision ::= '.' [0-9]*
4020 If a field-width is specified, it specifies to which width
4021 the output should be padded with blanks, if the output
4022 string is shorter than field-width.
4024 If precision is specified, it specifies the number of
4025 digits to print after the '.' for floats, or the max.
4026 number of chars to print from a string. */
4028 bool minus_flag
= false;
4029 bool plus_flag
= false;
4030 bool space_flag
= false;
4031 bool sharp_flag
= false;
4032 bool zero_flag
= false;
4038 case '-': minus_flag
= true; continue;
4039 case '+': plus_flag
= true; continue;
4040 case ' ': space_flag
= true; continue;
4041 case '#': sharp_flag
= true; continue;
4042 case '0': zero_flag
= true; continue;
4047 /* Ignore flags when sprintf ignores them. */
4048 space_flag
&= ~ plus_flag
;
4049 zero_flag
&= ~ minus_flag
;
4052 uintmax_t raw_field_width
= strtoumax (format
, &num_end
, 10);
4053 if (max_bufsize
<= raw_field_width
)
4055 ptrdiff_t field_width
= raw_field_width
;
4057 bool precision_given
= *num_end
== '.';
4058 uintmax_t precision
= (precision_given
4059 ? strtoumax (num_end
+ 1, &num_end
, 10)
4064 error ("Format string ends in middle of format specifier");
4066 char conversion
= *format
++;
4067 memset (&discarded
[format0
- format_start
], 1,
4068 format
- format0
- (conversion
== '%'));
4069 if (conversion
== '%')
4074 error ("Not enough arguments for format string");
4076 /* For 'S', prin1 the argument, and then treat like 's'.
4077 For 's', princ any argument that is not a string or
4078 symbol. But don't do this conversion twice, which might
4079 happen after retrying. */
4080 if ((conversion
== 'S'
4081 || (conversion
== 's'
4082 && ! STRINGP (args
[n
]) && ! SYMBOLP (args
[n
]))))
4084 if (! info
[n
].converted_to_string
)
4086 Lisp_Object noescape
= conversion
== 'S' ? Qnil
: Qt
;
4087 args
[n
] = Fprin1_to_string (args
[n
], noescape
);
4088 info
[n
].converted_to_string
= true;
4089 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
4097 else if (conversion
== 'c')
4099 if (FLOATP (args
[n
]))
4101 double d
= XFLOAT_DATA (args
[n
]);
4102 args
[n
] = make_number (FIXNUM_OVERFLOW_P (d
) ? -1 : d
);
4105 if (INTEGERP (args
[n
]) && ! ASCII_CHAR_P (XINT (args
[n
])))
4112 args
[n
] = Fchar_to_string (args
[n
]);
4113 info
[n
].converted_to_string
= true;
4116 if (info
[n
].converted_to_string
)
4121 if (SYMBOLP (args
[n
]))
4123 args
[n
] = SYMBOL_NAME (args
[n
]);
4124 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
4131 if (conversion
== 's')
4133 /* handle case (precision[n] >= 0) */
4135 ptrdiff_t prec
= -1;
4136 if (precision_given
&& precision
<= TYPE_MAXIMUM (ptrdiff_t))
4139 /* lisp_string_width ignores a precision of 0, but GNU
4140 libc functions print 0 characters when the precision
4141 is 0. Imitate libc behavior here. Changing
4142 lisp_string_width is the right thing, and will be
4143 done, but meanwhile we work with it. */
4145 ptrdiff_t width
, nbytes
;
4146 ptrdiff_t nchars_string
;
4148 width
= nchars_string
= nbytes
= 0;
4152 width
= lisp_string_width (args
[n
], prec
, &nch
, &nby
);
4155 nchars_string
= SCHARS (args
[n
]);
4156 nbytes
= SBYTES (args
[n
]);
4160 nchars_string
= nch
;
4166 if (convbytes
&& multibyte
&& ! STRING_MULTIBYTE (args
[n
]))
4167 convbytes
= count_size_as_multibyte (SDATA (args
[n
]), nbytes
);
4170 = width
< field_width
? field_width
- width
: 0;
4172 if (max_bufsize
- padding
<= convbytes
)
4174 convbytes
+= padding
;
4175 if (convbytes
<= buf
+ bufsize
- p
)
4179 memset (p
, ' ', padding
);
4183 info
[n
].start
= nchars
;
4187 && !ASCII_CHAR_P (*((unsigned char *) p
- 1))
4188 && STRING_MULTIBYTE (args
[n
])
4189 && !CHAR_HEAD_P (SREF (args
[n
], 0)))
4190 maybe_combine_byte
= true;
4192 p
+= copy_text (SDATA (args
[n
]), (unsigned char *) p
,
4194 STRING_MULTIBYTE (args
[n
]), multibyte
);
4196 nchars
+= nchars_string
;
4200 memset (p
, ' ', padding
);
4204 info
[n
].end
= nchars
;
4206 /* If this argument has text properties, record where
4207 in the result string it appears. */
4208 if (string_intervals (args
[n
]))
4209 info
[n
].intervals
= arg_intervals
= true;
4214 else if (! (conversion
== 'c' || conversion
== 'd'
4215 || conversion
== 'e' || conversion
== 'f'
4216 || conversion
== 'g' || conversion
== 'i'
4217 || conversion
== 'o' || conversion
== 'x'
4218 || conversion
== 'X'))
4219 error ("Invalid format operation %%%c",
4220 STRING_CHAR ((unsigned char *) format
- 1));
4221 else if (! NUMBERP (args
[n
]))
4222 error ("Format specifier doesn't match argument type");
4227 /* Maximum precision for a %f conversion such that the
4228 trailing output digit might be nonzero. Any precision
4229 larger than this will not yield useful information. */
4230 USEFUL_PRECISION_MAX
=
4232 * (FLT_RADIX
== 2 || FLT_RADIX
== 10 ? 1
4233 : FLT_RADIX
== 16 ? 4
4236 /* Maximum number of bytes generated by any format, if
4237 precision is no more than USEFUL_PRECISION_MAX.
4238 On all practical hosts, %f is the worst case. */
4240 sizeof "-." + (DBL_MAX_10_EXP
+ 1) + USEFUL_PRECISION_MAX
,
4242 /* Length of pM (that is, of pMd without the
4244 pMlen
= sizeof pMd
- 2
4246 verify (USEFUL_PRECISION_MAX
> 0);
4248 /* Avoid undefined behavior in underlying sprintf. */
4249 if (conversion
== 'd' || conversion
== 'i')
4252 /* Create the copy of the conversion specification, with
4253 any width and precision removed, with ".*" inserted,
4254 and with pM inserted for integer formats.
4255 At most three flags F can be specified at once. */
4256 char convspec
[sizeof "%FFF.*d" + pMlen
];
4260 *f
= '-'; f
+= minus_flag
;
4261 *f
= '+'; f
+= plus_flag
;
4262 *f
= ' '; f
+= space_flag
;
4263 *f
= '#'; f
+= sharp_flag
;
4264 *f
= '0'; f
+= zero_flag
;
4267 if (conversion
== 'd' || conversion
== 'i'
4268 || conversion
== 'o' || conversion
== 'x'
4269 || conversion
== 'X')
4271 memcpy (f
, pMd
, pMlen
);
4273 zero_flag
&= ~ precision_given
;
4280 if (precision_given
)
4281 prec
= min (precision
, USEFUL_PRECISION_MAX
);
4283 /* Use sprintf to format this number into sprintf_buf. Omit
4284 padding and excess precision, though, because sprintf limits
4285 output length to INT_MAX.
4287 There are four types of conversion: double, unsigned
4288 char (passed as int), wide signed int, and wide
4289 unsigned int. Treat them separately because the
4290 sprintf ABI is sensitive to which type is passed. Be
4291 careful about integer overflow, NaNs, infinities, and
4292 conversions; for example, the min and max macros are
4293 not suitable here. */
4294 char sprintf_buf
[SPRINTF_BUFSIZE
];
4295 ptrdiff_t sprintf_bytes
;
4296 if (conversion
== 'e' || conversion
== 'f' || conversion
== 'g')
4298 double x
= (INTEGERP (args
[n
])
4300 : XFLOAT_DATA (args
[n
]));
4301 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4303 else if (conversion
== 'c')
4305 /* Don't use sprintf here, as it might mishandle prec. */
4306 sprintf_buf
[0] = XINT (args
[n
]);
4307 sprintf_bytes
= prec
!= 0;
4309 else if (conversion
== 'd')
4311 /* For float, maybe we should use "%1.0f"
4312 instead so it also works for values outside
4313 the integer range. */
4315 if (INTEGERP (args
[n
]))
4319 double d
= XFLOAT_DATA (args
[n
]);
4322 x
= TYPE_MINIMUM (printmax_t
);
4328 x
= TYPE_MAXIMUM (printmax_t
);
4333 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4337 /* Don't sign-extend for octal or hex printing. */
4339 if (INTEGERP (args
[n
]))
4340 x
= XUINT (args
[n
]);
4343 double d
= XFLOAT_DATA (args
[n
]);
4348 x
= TYPE_MAXIMUM (uprintmax_t
);
4353 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4356 /* Now the length of the formatted item is known, except it omits
4357 padding and excess precision. Deal with excess precision
4358 first. This happens only when the format specifies
4359 ridiculously large precision. */
4360 uintmax_t excess_precision
= precision
- prec
;
4361 uintmax_t leading_zeros
= 0, trailing_zeros
= 0;
4362 if (excess_precision
)
4364 if (conversion
== 'e' || conversion
== 'f'
4365 || conversion
== 'g')
4367 if ((conversion
== 'g' && ! sharp_flag
)
4368 || ! ('0' <= sprintf_buf
[sprintf_bytes
- 1]
4369 && sprintf_buf
[sprintf_bytes
- 1] <= '9'))
4370 excess_precision
= 0;
4373 if (conversion
== 'g')
4375 char *dot
= strchr (sprintf_buf
, '.');
4377 excess_precision
= 0;
4380 trailing_zeros
= excess_precision
;
4383 leading_zeros
= excess_precision
;
4386 /* Compute the total bytes needed for this item, including
4387 excess precision and padding. */
4388 uintmax_t numwidth
= sprintf_bytes
+ excess_precision
;
4390 = numwidth
< field_width
? field_width
- numwidth
: 0;
4391 if (max_bufsize
- sprintf_bytes
<= excess_precision
4392 || max_bufsize
- padding
<= numwidth
)
4394 convbytes
= numwidth
+ padding
;
4396 if (convbytes
<= buf
+ bufsize
- p
)
4398 /* Copy the formatted item from sprintf_buf into buf,
4399 inserting padding and excess-precision zeros. */
4401 char *src
= sprintf_buf
;
4403 int exponent_bytes
= 0;
4404 bool signedp
= src0
== '-' || src0
== '+' || src0
== ' ';
4406 && ((src
[signedp
] >= '0' && src
[signedp
] <= '9')
4407 || (src
[signedp
] >= 'a' && src
[signedp
] <= 'f')
4408 || (src
[signedp
] >= 'A' && src
[signedp
] <= 'F')))
4410 leading_zeros
+= padding
;
4414 if (excess_precision
4415 && (conversion
== 'e' || conversion
== 'g'))
4417 char *e
= strchr (src
, 'e');
4419 exponent_bytes
= src
+ sprintf_bytes
- e
;
4422 info
[n
].start
= nchars
;
4425 memset (p
, ' ', padding
);
4433 memset (p
, '0', leading_zeros
);
4435 int significand_bytes
4436 = sprintf_bytes
- signedp
- exponent_bytes
;
4437 memcpy (p
, src
, significand_bytes
);
4438 p
+= significand_bytes
;
4439 src
+= significand_bytes
;
4440 memset (p
, '0', trailing_zeros
);
4441 p
+= trailing_zeros
;
4442 memcpy (p
, src
, exponent_bytes
);
4443 p
+= exponent_bytes
;
4445 nchars
+= leading_zeros
+ sprintf_bytes
+ trailing_zeros
;
4449 memset (p
, ' ', padding
);
4453 info
[n
].end
= nchars
;
4461 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
4463 if ((format_char
== '`' || format_char
== '\'')
4464 && quoting_style
== CURVE_QUOTING_STYLE
)
4471 convsrc
= format_char
== '`' ? uLSQM
: uRSQM
;
4474 else if (format_char
== '`' && quoting_style
== STRAIGHT_QUOTING_STYLE
)
4478 /* Copy a single character from format to buf. */
4479 if (multibyte_format
)
4481 /* Copy a whole multibyte character. */
4483 && !ASCII_CHAR_P (*((unsigned char *) p
- 1))
4484 && !CHAR_HEAD_P (format_char
))
4485 maybe_combine_byte
= true;
4487 while (! CHAR_HEAD_P (*format
))
4490 convbytes
= format
- format0
;
4491 memset (&discarded
[format0
+ 1 - format_start
], 2,
4494 else if (multibyte
&& !ASCII_CHAR_P (format_char
))
4496 int c
= BYTE8_TO_CHAR (format_char
);
4497 convbytes
= CHAR_STRING (c
, str
);
4498 convsrc
= (char *) str
;
4503 if (convbytes
<= buf
+ bufsize
- p
)
4505 memcpy (p
, convsrc
, convbytes
);
4512 /* There wasn't enough room to store this conversion or single
4513 character. CONVBYTES says how much room is needed. Allocate
4514 enough room (and then some) and do it again. */
4516 ptrdiff_t used
= p
- buf
;
4517 if (max_bufsize
- used
< convbytes
)
4519 bufsize
= used
+ convbytes
;
4520 bufsize
= bufsize
< max_bufsize
/ 2 ? bufsize
* 2 : max_bufsize
;
4522 if (buf
== initial_buffer
)
4524 buf
= xmalloc (bufsize
);
4525 sa_must_free
= true;
4526 buf_save_value_index
= SPECPDL_INDEX ();
4527 record_unwind_protect_ptr (xfree
, buf
);
4528 memcpy (buf
, initial_buffer
, used
);
4532 buf
= xrealloc (buf
, bufsize
);
4533 set_unwind_protect_ptr (buf_save_value_index
, xfree
, buf
);
4541 if (bufsize
< p
- buf
)
4544 if (maybe_combine_byte
)
4545 nchars
= multibyte_chars_in_text ((unsigned char *) buf
, p
- buf
);
4546 Lisp_Object val
= make_specified_string (buf
, nchars
, p
- buf
, multibyte
);
4548 /* If the format string has text properties, or any of the string
4549 arguments has text properties, set up text properties of the
4552 if (string_intervals (args
[0]) || arg_intervals
)
4554 /* Add text properties from the format string. */
4555 Lisp_Object len
= make_number (SCHARS (args
[0]));
4556 Lisp_Object props
= text_property_list (args
[0], make_number (0),
4560 ptrdiff_t bytepos
= 0, position
= 0, translated
= 0;
4563 /* Adjust the bounds of each text property
4564 to the proper start and end in the output string. */
4566 /* Put the positions in PROPS in increasing order, so that
4567 we can do (effectively) one scan through the position
4568 space of the format string. */
4569 props
= Fnreverse (props
);
4571 /* BYTEPOS is the byte position in the format string,
4572 POSITION is the untranslated char position in it,
4573 TRANSLATED is the translated char position in BUF,
4574 and ARGN is the number of the next arg we will come to. */
4575 for (Lisp_Object list
= props
; CONSP (list
); list
= XCDR (list
))
4577 Lisp_Object item
= XCAR (list
);
4579 /* First adjust the property start position. */
4580 ptrdiff_t pos
= XINT (XCAR (item
));
4582 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
4583 up to this position. */
4584 for (; position
< pos
; bytepos
++)
4586 if (! discarded
[bytepos
])
4587 position
++, translated
++;
4588 else if (discarded
[bytepos
] == 1)
4591 if (translated
== info
[argn
].start
)
4593 translated
+= info
[argn
].end
- info
[argn
].start
;
4599 XSETCAR (item
, make_number (translated
));
4601 /* Likewise adjust the property end position. */
4602 pos
= XINT (XCAR (XCDR (item
)));
4604 for (; position
< pos
; bytepos
++)
4606 if (! discarded
[bytepos
])
4607 position
++, translated
++;
4608 else if (discarded
[bytepos
] == 1)
4611 if (translated
== info
[argn
].start
)
4613 translated
+= info
[argn
].end
- info
[argn
].start
;
4619 XSETCAR (XCDR (item
), make_number (translated
));
4622 add_text_properties_from_list (val
, props
, make_number (0));
4625 /* Add text properties from arguments. */
4627 for (ptrdiff_t i
= 1; i
< nargs
; i
++)
4628 if (info
[i
].intervals
)
4630 len
= make_number (SCHARS (args
[i
]));
4631 Lisp_Object new_len
= make_number (info
[i
].end
- info
[i
].start
);
4632 props
= text_property_list (args
[i
], make_number (0), len
, Qnil
);
4633 props
= extend_property_ranges (props
, len
, new_len
);
4634 /* If successive arguments have properties, be sure that
4635 the value of `composition' property be the copy. */
4636 if (1 < i
&& info
[i
- 1].end
)
4637 make_composition_value_copy (props
);
4638 add_text_properties_from_list (val
, props
,
4639 make_number (info
[i
].start
));
4643 /* If we allocated BUF or INFO with malloc, free it too. */
4649 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
4650 doc
: /* Return t if two characters match, optionally ignoring case.
4651 Both arguments must be characters (i.e. integers).
4652 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
4653 (register Lisp_Object c1
, Lisp_Object c2
)
4656 /* Check they're chars, not just integers, otherwise we could get array
4657 bounds violations in downcase. */
4658 CHECK_CHARACTER (c1
);
4659 CHECK_CHARACTER (c2
);
4661 if (XINT (c1
) == XINT (c2
))
4663 if (NILP (BVAR (current_buffer
, case_fold_search
)))
4669 /* FIXME: It is possible to compare multibyte characters even when
4670 the current buffer is unibyte. Unfortunately this is ambiguous
4671 for characters between 128 and 255, as they could be either
4672 eight-bit raw bytes or Latin-1 characters. Assume the former for
4673 now. See Bug#17011, and also see casefiddle.c's casify_object,
4674 which has a similar problem. */
4675 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4677 if (SINGLE_BYTE_CHAR_P (i1
))
4678 i1
= UNIBYTE_TO_CHAR (i1
);
4679 if (SINGLE_BYTE_CHAR_P (i2
))
4680 i2
= UNIBYTE_TO_CHAR (i2
);
4683 return (downcase (i1
) == downcase (i2
) ? Qt
: Qnil
);
4686 /* Transpose the markers in two regions of the current buffer, and
4687 adjust the ones between them if necessary (i.e.: if the regions
4690 START1, END1 are the character positions of the first region.
4691 START1_BYTE, END1_BYTE are the byte positions.
4692 START2, END2 are the character positions of the second region.
4693 START2_BYTE, END2_BYTE are the byte positions.
4695 Traverses the entire marker list of the buffer to do so, adding an
4696 appropriate amount to some, subtracting from some, and leaving the
4697 rest untouched. Most of this is copied from adjust_markers in insdel.c.
4699 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
4702 transpose_markers (ptrdiff_t start1
, ptrdiff_t end1
,
4703 ptrdiff_t start2
, ptrdiff_t end2
,
4704 ptrdiff_t start1_byte
, ptrdiff_t end1_byte
,
4705 ptrdiff_t start2_byte
, ptrdiff_t end2_byte
)
4707 register ptrdiff_t amt1
, amt1_byte
, amt2
, amt2_byte
, diff
, diff_byte
, mpos
;
4708 register struct Lisp_Marker
*marker
;
4710 /* Update point as if it were a marker. */
4714 TEMP_SET_PT_BOTH (PT
+ (end2
- end1
),
4715 PT_BYTE
+ (end2_byte
- end1_byte
));
4716 else if (PT
< start2
)
4717 TEMP_SET_PT_BOTH (PT
+ (end2
- start2
) - (end1
- start1
),
4718 (PT_BYTE
+ (end2_byte
- start2_byte
)
4719 - (end1_byte
- start1_byte
)));
4721 TEMP_SET_PT_BOTH (PT
- (start2
- start1
),
4722 PT_BYTE
- (start2_byte
- start1_byte
));
4724 /* We used to adjust the endpoints here to account for the gap, but that
4725 isn't good enough. Even if we assume the caller has tried to move the
4726 gap out of our way, it might still be at start1 exactly, for example;
4727 and that places it `inside' the interval, for our purposes. The amount
4728 of adjustment is nontrivial if there's a `denormalized' marker whose
4729 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
4730 the dirty work to Fmarker_position, below. */
4732 /* The difference between the region's lengths */
4733 diff
= (end2
- start2
) - (end1
- start1
);
4734 diff_byte
= (end2_byte
- start2_byte
) - (end1_byte
- start1_byte
);
4736 /* For shifting each marker in a region by the length of the other
4737 region plus the distance between the regions. */
4738 amt1
= (end2
- start2
) + (start2
- end1
);
4739 amt2
= (end1
- start1
) + (start2
- end1
);
4740 amt1_byte
= (end2_byte
- start2_byte
) + (start2_byte
- end1_byte
);
4741 amt2_byte
= (end1_byte
- start1_byte
) + (start2_byte
- end1_byte
);
4743 for (marker
= BUF_MARKERS (current_buffer
); marker
; marker
= marker
->next
)
4745 mpos
= marker
->bytepos
;
4746 if (mpos
>= start1_byte
&& mpos
< end2_byte
)
4748 if (mpos
< end1_byte
)
4750 else if (mpos
< start2_byte
)
4754 marker
->bytepos
= mpos
;
4756 mpos
= marker
->charpos
;
4757 if (mpos
>= start1
&& mpos
< end2
)
4761 else if (mpos
< start2
)
4766 marker
->charpos
= mpos
;
4770 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
4771 doc
: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
4772 The regions should not be overlapping, because the size of the buffer is
4773 never changed in a transposition.
4775 Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
4776 any markers that happen to be located in the regions.
4778 Transposing beyond buffer boundaries is an error. */)
4779 (Lisp_Object startr1
, Lisp_Object endr1
, Lisp_Object startr2
, Lisp_Object endr2
, Lisp_Object leave_markers
)
4781 register ptrdiff_t start1
, end1
, start2
, end2
;
4782 ptrdiff_t start1_byte
, start2_byte
, len1_byte
, len2_byte
, end2_byte
;
4783 ptrdiff_t gap
, len1
, len_mid
, len2
;
4784 unsigned char *start1_addr
, *start2_addr
, *temp
;
4786 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
, tmp_interval3
;
4789 XSETBUFFER (buf
, current_buffer
);
4790 cur_intv
= buffer_intervals (current_buffer
);
4792 validate_region (&startr1
, &endr1
);
4793 validate_region (&startr2
, &endr2
);
4795 start1
= XFASTINT (startr1
);
4796 end1
= XFASTINT (endr1
);
4797 start2
= XFASTINT (startr2
);
4798 end2
= XFASTINT (endr2
);
4801 /* Swap the regions if they're reversed. */
4804 register ptrdiff_t glumph
= start1
;
4812 len1
= end1
- start1
;
4813 len2
= end2
- start2
;
4816 error ("Transposed regions overlap");
4817 /* Nothing to change for adjacent regions with one being empty */
4818 else if ((start1
== end1
|| start2
== end2
) && end1
== start2
)
4821 /* The possibilities are:
4822 1. Adjacent (contiguous) regions, or separate but equal regions
4823 (no, really equal, in this case!), or
4824 2. Separate regions of unequal size.
4826 The worst case is usually No. 2. It means that (aside from
4827 potential need for getting the gap out of the way), there also
4828 needs to be a shifting of the text between the two regions. So
4829 if they are spread far apart, we are that much slower... sigh. */
4831 /* It must be pointed out that the really studly thing to do would
4832 be not to move the gap at all, but to leave it in place and work
4833 around it if necessary. This would be extremely efficient,
4834 especially considering that people are likely to do
4835 transpositions near where they are working interactively, which
4836 is exactly where the gap would be found. However, such code
4837 would be much harder to write and to read. So, if you are
4838 reading this comment and are feeling squirrely, by all means have
4839 a go! I just didn't feel like doing it, so I will simply move
4840 the gap the minimum distance to get it out of the way, and then
4841 deal with an unbroken array. */
4843 start1_byte
= CHAR_TO_BYTE (start1
);
4844 end2_byte
= CHAR_TO_BYTE (end2
);
4846 /* Make sure the gap won't interfere, by moving it out of the text
4847 we will operate on. */
4848 if (start1
< gap
&& gap
< end2
)
4850 if (gap
- start1
< end2
- gap
)
4851 move_gap_both (start1
, start1_byte
);
4853 move_gap_both (end2
, end2_byte
);
4856 start2_byte
= CHAR_TO_BYTE (start2
);
4857 len1_byte
= CHAR_TO_BYTE (end1
) - start1_byte
;
4858 len2_byte
= end2_byte
- start2_byte
;
4860 #ifdef BYTE_COMBINING_DEBUG
4863 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4864 len2_byte
, start1
, start1_byte
)
4865 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4866 len1_byte
, end2
, start2_byte
+ len2_byte
)
4867 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4868 len1_byte
, end2
, start2_byte
+ len2_byte
))
4873 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4874 len2_byte
, start1
, start1_byte
)
4875 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4876 len1_byte
, start2
, start2_byte
)
4877 || count_combining_after (BYTE_POS_ADDR (start2_byte
),
4878 len2_byte
, end1
, start1_byte
+ len1_byte
)
4879 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4880 len1_byte
, end2
, start2_byte
+ len2_byte
))
4885 /* Hmmm... how about checking to see if the gap is large
4886 enough to use as the temporary storage? That would avoid an
4887 allocation... interesting. Later, don't fool with it now. */
4889 /* Working without memmove, for portability (sigh), so must be
4890 careful of overlapping subsections of the array... */
4892 if (end1
== start2
) /* adjacent regions */
4894 modify_text (start1
, end2
);
4895 record_change (start1
, len1
+ len2
);
4897 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4898 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4899 /* Don't use Fset_text_properties: that can cause GC, which can
4900 clobber objects stored in the tmp_intervals. */
4901 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4903 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4907 /* First region smaller than second. */
4908 if (len1_byte
< len2_byte
)
4910 temp
= SAFE_ALLOCA (len2_byte
);
4912 /* Don't precompute these addresses. We have to compute them
4913 at the last minute, because the relocating allocator might
4914 have moved the buffer around during the xmalloc. */
4915 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4916 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4918 memcpy (temp
, start2_addr
, len2_byte
);
4919 memcpy (start1_addr
+ len2_byte
, start1_addr
, len1_byte
);
4920 memcpy (start1_addr
, temp
, len2_byte
);
4923 /* First region not smaller than second. */
4925 temp
= SAFE_ALLOCA (len1_byte
);
4926 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4927 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4928 memcpy (temp
, start1_addr
, len1_byte
);
4929 memcpy (start1_addr
, start2_addr
, len2_byte
);
4930 memcpy (start1_addr
+ len2_byte
, temp
, len1_byte
);
4934 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
4935 len1
, current_buffer
, 0);
4936 graft_intervals_into_buffer (tmp_interval2
, start1
,
4937 len2
, current_buffer
, 0);
4938 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4939 update_compositions (start1
+ len2
, end2
, CHECK_TAIL
);
4941 /* Non-adjacent regions, because end1 != start2, bleagh... */
4944 len_mid
= start2_byte
- (start1_byte
+ len1_byte
);
4946 if (len1_byte
== len2_byte
)
4947 /* Regions are same size, though, how nice. */
4951 modify_text (start1
, end1
);
4952 modify_text (start2
, end2
);
4953 record_change (start1
, len1
);
4954 record_change (start2
, len2
);
4955 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4956 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4958 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr1
, 0);
4960 set_text_properties_1 (startr1
, endr1
, Qnil
, buf
, tmp_interval3
);
4962 tmp_interval3
= validate_interval_range (buf
, &startr2
, &endr2
, 0);
4964 set_text_properties_1 (startr2
, endr2
, Qnil
, buf
, tmp_interval3
);
4966 temp
= SAFE_ALLOCA (len1_byte
);
4967 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4968 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4969 memcpy (temp
, start1_addr
, len1_byte
);
4970 memcpy (start1_addr
, start2_addr
, len2_byte
);
4971 memcpy (start2_addr
, temp
, len1_byte
);
4974 graft_intervals_into_buffer (tmp_interval1
, start2
,
4975 len1
, current_buffer
, 0);
4976 graft_intervals_into_buffer (tmp_interval2
, start1
,
4977 len2
, current_buffer
, 0);
4980 else if (len1_byte
< len2_byte
) /* Second region larger than first */
4981 /* Non-adjacent & unequal size, area between must also be shifted. */
4985 modify_text (start1
, end2
);
4986 record_change (start1
, (end2
- start1
));
4987 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4988 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4989 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4991 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4993 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4995 /* holds region 2 */
4996 temp
= SAFE_ALLOCA (len2_byte
);
4997 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4998 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4999 memcpy (temp
, start2_addr
, len2_byte
);
5000 memcpy (start1_addr
+ len_mid
+ len2_byte
, start1_addr
, len1_byte
);
5001 memmove (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
5002 memcpy (start1_addr
, temp
, len2_byte
);
5005 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
5006 len1
, current_buffer
, 0);
5007 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
5008 len_mid
, current_buffer
, 0);
5009 graft_intervals_into_buffer (tmp_interval2
, start1
,
5010 len2
, current_buffer
, 0);
5013 /* Second region smaller than first. */
5017 record_change (start1
, (end2
- start1
));
5018 modify_text (start1
, end2
);
5020 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
5021 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
5022 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
5024 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
5026 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
5028 /* holds region 1 */
5029 temp
= SAFE_ALLOCA (len1_byte
);
5030 start1_addr
= BYTE_POS_ADDR (start1_byte
);
5031 start2_addr
= BYTE_POS_ADDR (start2_byte
);
5032 memcpy (temp
, start1_addr
, len1_byte
);
5033 memcpy (start1_addr
, start2_addr
, len2_byte
);
5034 memmove (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
5035 memcpy (start1_addr
+ len2_byte
+ len_mid
, temp
, len1_byte
);
5038 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
5039 len1
, current_buffer
, 0);
5040 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
5041 len_mid
, current_buffer
, 0);
5042 graft_intervals_into_buffer (tmp_interval2
, start1
,
5043 len2
, current_buffer
, 0);
5046 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
5047 update_compositions (end2
- len1
, end2
, CHECK_BORDER
);
5050 /* When doing multiple transpositions, it might be nice
5051 to optimize this. Perhaps the markers in any one buffer
5052 should be organized in some sorted data tree. */
5053 if (NILP (leave_markers
))
5055 transpose_markers (start1
, end1
, start2
, end2
,
5056 start1_byte
, start1_byte
+ len1_byte
,
5057 start2_byte
, start2_byte
+ len2_byte
);
5058 fix_start_end_in_overlays (start1
, end2
);
5062 /* The character positions of the markers remain intact, but we
5063 still need to update their byte positions, because the
5064 transposed regions might include multibyte sequences which
5065 make some original byte positions of the markers invalid. */
5066 adjust_markers_bytepos (start1
, start1_byte
, end2
, end2_byte
, 0);
5069 signal_after_change (start1
, end2
- start1
, end2
- start1
);
5075 syms_of_editfns (void)
5077 DEFSYM (Qbuffer_access_fontify_functions
, "buffer-access-fontify-functions");
5078 DEFSYM (Qwall
, "wall");
5080 DEFVAR_LISP ("inhibit-field-text-motion", Vinhibit_field_text_motion
,
5081 doc
: /* Non-nil means text motion commands don't notice fields. */);
5082 Vinhibit_field_text_motion
= Qnil
;
5084 DEFVAR_LISP ("buffer-access-fontify-functions",
5085 Vbuffer_access_fontify_functions
,
5086 doc
: /* List of functions called by `buffer-substring' to fontify if necessary.
5087 Each function is called with two arguments which specify the range
5088 of the buffer being accessed. */);
5089 Vbuffer_access_fontify_functions
= Qnil
;
5093 obuf
= Fcurrent_buffer ();
5094 /* Do this here, because init_buffer_once is too early--it won't work. */
5095 Fset_buffer (Vprin1_to_string_buffer
);
5096 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
5097 Fset (Fmake_local_variable (Qbuffer_access_fontify_functions
), Qnil
);
5101 DEFVAR_LISP ("buffer-access-fontified-property",
5102 Vbuffer_access_fontified_property
,
5103 doc
: /* Property which (if non-nil) indicates text has been fontified.
5104 `buffer-substring' need not call the `buffer-access-fontify-functions'
5105 functions if all the text being accessed has this property. */);
5106 Vbuffer_access_fontified_property
= Qnil
;
5108 DEFVAR_LISP ("system-name", Vsystem_name
,
5109 doc
: /* The host name of the machine Emacs is running on. */);
5110 Vsystem_name
= cached_system_name
= Qnil
;
5112 DEFVAR_LISP ("user-full-name", Vuser_full_name
,
5113 doc
: /* The full name of the user logged in. */);
5115 DEFVAR_LISP ("user-login-name", Vuser_login_name
,
5116 doc
: /* The user's name, taken from environment variables if possible. */);
5117 Vuser_login_name
= Qnil
;
5119 DEFVAR_LISP ("user-real-login-name", Vuser_real_login_name
,
5120 doc
: /* The user's name, based upon the real uid only. */);
5122 DEFVAR_LISP ("operating-system-release", Voperating_system_release
,
5123 doc
: /* The release of the operating system Emacs is running on. */);
5125 defsubr (&Spropertize
);
5126 defsubr (&Schar_equal
);
5127 defsubr (&Sgoto_char
);
5128 defsubr (&Sstring_to_char
);
5129 defsubr (&Schar_to_string
);
5130 defsubr (&Sbyte_to_string
);
5131 defsubr (&Sbuffer_substring
);
5132 defsubr (&Sbuffer_substring_no_properties
);
5133 defsubr (&Sbuffer_string
);
5134 defsubr (&Sget_pos_property
);
5136 defsubr (&Spoint_marker
);
5137 defsubr (&Smark_marker
);
5139 defsubr (&Sregion_beginning
);
5140 defsubr (&Sregion_end
);
5142 /* Symbol for the text property used to mark fields. */
5143 DEFSYM (Qfield
, "field");
5145 /* A special value for Qfield properties. */
5146 DEFSYM (Qboundary
, "boundary");
5148 defsubr (&Sfield_beginning
);
5149 defsubr (&Sfield_end
);
5150 defsubr (&Sfield_string
);
5151 defsubr (&Sfield_string_no_properties
);
5152 defsubr (&Sdelete_field
);
5153 defsubr (&Sconstrain_to_field
);
5155 defsubr (&Sline_beginning_position
);
5156 defsubr (&Sline_end_position
);
5158 defsubr (&Ssave_excursion
);
5159 defsubr (&Ssave_current_buffer
);
5161 defsubr (&Sbuffer_size
);
5162 defsubr (&Spoint_max
);
5163 defsubr (&Spoint_min
);
5164 defsubr (&Spoint_min_marker
);
5165 defsubr (&Spoint_max_marker
);
5166 defsubr (&Sgap_position
);
5167 defsubr (&Sgap_size
);
5168 defsubr (&Sposition_bytes
);
5169 defsubr (&Sbyte_to_position
);
5175 defsubr (&Sfollowing_char
);
5176 defsubr (&Sprevious_char
);
5177 defsubr (&Schar_after
);
5178 defsubr (&Schar_before
);
5180 defsubr (&Sinsert_before_markers
);
5181 defsubr (&Sinsert_and_inherit
);
5182 defsubr (&Sinsert_and_inherit_before_markers
);
5183 defsubr (&Sinsert_char
);
5184 defsubr (&Sinsert_byte
);
5186 defsubr (&Suser_login_name
);
5187 defsubr (&Suser_real_login_name
);
5188 defsubr (&Suser_uid
);
5189 defsubr (&Suser_real_uid
);
5190 defsubr (&Sgroup_gid
);
5191 defsubr (&Sgroup_real_gid
);
5192 defsubr (&Suser_full_name
);
5193 defsubr (&Semacs_pid
);
5194 defsubr (&Scurrent_time
);
5195 defsubr (&Stime_add
);
5196 defsubr (&Stime_subtract
);
5197 defsubr (&Stime_less_p
);
5198 defsubr (&Sget_internal_run_time
);
5199 defsubr (&Sformat_time_string
);
5200 defsubr (&Sfloat_time
);
5201 defsubr (&Sdecode_time
);
5202 defsubr (&Sencode_time
);
5203 defsubr (&Scurrent_time_string
);
5204 defsubr (&Scurrent_time_zone
);
5205 defsubr (&Sset_time_zone_rule
);
5206 defsubr (&Ssystem_name
);
5207 defsubr (&Smessage
);
5208 defsubr (&Smessage_box
);
5209 defsubr (&Smessage_or_box
);
5210 defsubr (&Scurrent_message
);
5212 defsubr (&Sformat_message
);
5214 defsubr (&Sinsert_buffer_substring
);
5215 defsubr (&Scompare_buffer_substrings
);
5216 defsubr (&Ssubst_char_in_region
);
5217 defsubr (&Stranslate_region_internal
);
5218 defsubr (&Sdelete_region
);
5219 defsubr (&Sdelete_and_extract_region
);
5221 defsubr (&Snarrow_to_region
);
5222 defsubr (&Ssave_restriction
);
5223 defsubr (&Stranspose_regions
);