1 /* Lisp functions pertaining to editing.
3 Copyright (C) 1985-1987, 1989, 1993-2015 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
10 (at your option) any later version.
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
22 #include <sys/types.h>
32 #ifdef HAVE_SYS_UTSNAME_H
33 #include <sys/utsname.h>
38 /* systime.h includes <sys/time.h> which, on some systems, is required
39 for <sys/resource.h>; thus systime.h must be included before
43 #if defined HAVE_SYS_RESOURCE_H
44 #include <sys/resource.h>
55 #include "intervals.h"
56 #include "character.h"
61 #include "blockinput.h"
63 #define TM_YEAR_BASE 1900
66 extern Lisp_Object
w32_get_internal_run_time (void);
69 static struct lisp_time
lisp_time_struct (Lisp_Object
, int *);
70 static Lisp_Object
format_time_string (char const *, ptrdiff_t, struct timespec
,
71 Lisp_Object
, struct tm
*);
72 static long int tm_gmtoff (struct tm
*);
73 static int tm_diff (struct tm
*, struct tm
*);
74 static void update_buffer_properties (ptrdiff_t, ptrdiff_t);
76 #ifndef HAVE_TM_GMTOFF
77 # define HAVE_TM_GMTOFF false
80 enum { tzeqlen
= sizeof "TZ=" - 1 };
82 /* Time zones equivalent to current local time, to wall clock time,
83 and to UTC, respectively. */
84 static timezone_t local_tz
;
85 static timezone_t wall_clock_tz
;
86 static timezone_t
const utc_tz
= 0;
88 /* A valid but unlikely setting for the TZ environment variable.
89 It is OK (though a bit slower) if the user chooses this value. */
90 static char dump_tz_string
[] = "TZ=UtC0";
92 /* The cached value of Vsystem_name. This is used only to compare it
93 to Vsystem_name, so it need not be visible to the GC. */
94 static Lisp_Object cached_system_name
;
97 init_and_cache_system_name (void)
100 cached_system_name
= Vsystem_name
;
104 emacs_localtime_rz (timezone_t tz
, time_t const *t
, struct tm
*tm
)
106 tm
= localtime_rz (tz
, t
, tm
);
107 if (!tm
&& errno
== ENOMEM
)
108 memory_full (SIZE_MAX
);
113 emacs_mktime_z (timezone_t tz
, struct tm
*tm
)
116 time_t t
= mktime_z (tz
, tm
);
117 if (t
== (time_t) -1 && errno
== ENOMEM
)
118 memory_full (SIZE_MAX
);
122 /* Allocate a timezone, signaling on failure. */
124 xtzalloc (char const *name
)
126 timezone_t tz
= tzalloc (name
);
128 memory_full (SIZE_MAX
);
132 /* Free a timezone, except do not free the time zone for local time.
133 Freeing utc_tz is also a no-op. */
135 xtzfree (timezone_t tz
)
141 /* Convert the Lisp time zone rule ZONE to a timezone_t object.
142 The returned value either is 0, or is LOCAL_TZ, or is newly allocated.
143 If SETTZ, set Emacs local time to the time zone rule; otherwise,
144 the caller should eventually pass the returned value to xtzfree. */
146 tzlookup (Lisp_Object zone
, bool settz
)
148 static char const tzbuf_format
[] = "XXX%s%"pI
"d:%02d:%02d";
149 char tzbuf
[sizeof tzbuf_format
+ INT_STRLEN_BOUND (EMACS_INT
)];
150 char const *zone_string
;
155 else if (EQ (zone
, Qt
))
157 zone_string
= "UTC0";
162 if (EQ (zone
, Qwall
))
164 else if (STRINGP (zone
))
165 zone_string
= SSDATA (zone
);
166 else if (INTEGERP (zone
))
168 EMACS_INT abszone
= eabs (XINT (zone
)), hour
= abszone
/ (60 * 60);
169 int min
= (abszone
/ 60) % 60, sec
= abszone
% 60;
170 sprintf (tzbuf
, tzbuf_format
, &"-"[XINT (zone
) < 0], hour
, min
, sec
);
174 xsignal2 (Qerror
, build_string ("Invalid time zone specification"),
176 new_tz
= xtzalloc (zone_string
);
182 emacs_setenv_TZ (zone_string
);
183 timezone_t old_tz
= local_tz
;
193 init_editfns (bool dumping
)
195 const char *user_name
;
197 struct passwd
*pw
; /* password entry for the current user */
200 /* Set up system_name even when dumping. */
201 init_and_cache_system_name ();
204 /* When just dumping out, set the time zone to a known unlikely value
205 and skip the rest of this function. */
209 xputenv (dump_tz_string
);
216 char *tz
= getenv ("TZ");
218 #if !defined CANNOT_DUMP && defined HAVE_TZSET
219 /* If the execution TZ happens to be the same as the dump TZ,
220 change it to some other value and then change it back,
221 to force the underlying implementation to reload the TZ info.
222 This is needed on implementations that load TZ info from files,
223 since the TZ file contents may differ between dump and execution. */
224 if (tz
&& strcmp (tz
, &dump_tz_string
[tzeqlen
]) == 0)
232 /* Set the time zone rule now, so that the call to putenv is done
233 before multiple threads are active. */
234 wall_clock_tz
= xtzalloc (0);
235 tzlookup (tz
? build_string (tz
) : Qwall
, true);
237 pw
= getpwuid (getuid ());
239 /* We let the real user name default to "root" because that's quite
240 accurate on MS-DOS and because it lets Emacs find the init file.
241 (The DVX libraries override the Djgpp libraries here.) */
242 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "root");
244 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "unknown");
247 /* Get the effective user name, by consulting environment variables,
248 or the effective uid if those are unset. */
249 user_name
= getenv ("LOGNAME");
252 user_name
= getenv ("USERNAME"); /* it's USERNAME on NT */
253 #else /* WINDOWSNT */
254 user_name
= getenv ("USER");
255 #endif /* WINDOWSNT */
258 pw
= getpwuid (geteuid ());
259 user_name
= pw
? pw
->pw_name
: "unknown";
261 Vuser_login_name
= build_string (user_name
);
263 /* If the user name claimed in the environment vars differs from
264 the real uid, use the claimed name to find the full name. */
265 tem
= Fstring_equal (Vuser_login_name
, Vuser_real_login_name
);
267 tem
= Vuser_login_name
;
270 uid_t euid
= geteuid ();
271 tem
= make_fixnum_or_float (euid
);
273 Vuser_full_name
= Fuser_full_name (tem
);
277 Vuser_full_name
= build_string (p
);
278 else if (NILP (Vuser_full_name
))
279 Vuser_full_name
= build_string ("unknown");
281 #ifdef HAVE_SYS_UTSNAME_H
285 Voperating_system_release
= build_string (uts
.release
);
288 Voperating_system_release
= Qnil
;
292 DEFUN ("char-to-string", Fchar_to_string
, Schar_to_string
, 1, 1, 0,
293 doc
: /* Convert arg CHAR to a string containing that character.
294 usage: (char-to-string CHAR) */)
295 (Lisp_Object character
)
298 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
300 CHECK_CHARACTER (character
);
301 c
= XFASTINT (character
);
303 len
= CHAR_STRING (c
, str
);
304 return make_string_from_bytes ((char *) str
, 1, len
);
307 DEFUN ("byte-to-string", Fbyte_to_string
, Sbyte_to_string
, 1, 1, 0,
308 doc
: /* Convert arg BYTE to a unibyte string containing that byte. */)
313 if (XINT (byte
) < 0 || XINT (byte
) > 255)
314 error ("Invalid byte");
316 return make_string_from_bytes ((char *) &b
, 1, 1);
319 DEFUN ("string-to-char", Fstring_to_char
, Sstring_to_char
, 1, 1, 0,
320 doc
: /* Return the first character in STRING. */)
321 (register Lisp_Object string
)
323 register Lisp_Object val
;
324 CHECK_STRING (string
);
327 if (STRING_MULTIBYTE (string
))
328 XSETFASTINT (val
, STRING_CHAR (SDATA (string
)));
330 XSETFASTINT (val
, SREF (string
, 0));
333 XSETFASTINT (val
, 0);
337 DEFUN ("point", Fpoint
, Spoint
, 0, 0, 0,
338 doc
: /* Return value of point, as an integer.
339 Beginning of buffer is position (point-min). */)
343 XSETFASTINT (temp
, PT
);
347 DEFUN ("point-marker", Fpoint_marker
, Spoint_marker
, 0, 0, 0,
348 doc
: /* Return value of point, as a marker object. */)
351 return build_marker (current_buffer
, PT
, PT_BYTE
);
354 DEFUN ("goto-char", Fgoto_char
, Sgoto_char
, 1, 1, "NGoto char: ",
355 doc
: /* Set point to POSITION, a number or marker.
356 Beginning of buffer is position (point-min), end is (point-max).
358 The return value is POSITION. */)
359 (register Lisp_Object position
)
361 if (MARKERP (position
))
362 set_point_from_marker (position
);
363 else if (INTEGERP (position
))
364 SET_PT (clip_to_bounds (BEGV
, XINT (position
), ZV
));
366 wrong_type_argument (Qinteger_or_marker_p
, position
);
371 /* Return the start or end position of the region.
372 BEGINNINGP means return the start.
373 If there is no region active, signal an error. */
376 region_limit (bool beginningp
)
380 if (!NILP (Vtransient_mark_mode
)
381 && NILP (Vmark_even_if_inactive
)
382 && NILP (BVAR (current_buffer
, mark_active
)))
383 xsignal0 (Qmark_inactive
);
385 m
= Fmarker_position (BVAR (current_buffer
, mark
));
387 error ("The mark is not set now, so there is no region");
389 /* Clip to the current narrowing (bug#11770). */
390 return make_number ((PT
< XFASTINT (m
)) == beginningp
392 : clip_to_bounds (BEGV
, XFASTINT (m
), ZV
));
395 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
396 doc
: /* Return the integer value of point or mark, whichever is smaller. */)
399 return region_limit (1);
402 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
403 doc
: /* Return the integer value of point or mark, whichever is larger. */)
406 return region_limit (0);
409 DEFUN ("mark-marker", Fmark_marker
, Smark_marker
, 0, 0, 0,
410 doc
: /* Return this buffer's mark, as a marker object.
411 Watch out! Moving this marker changes the mark position.
412 If you set the marker not to point anywhere, the buffer will have no mark. */)
415 return BVAR (current_buffer
, mark
);
419 /* Find all the overlays in the current buffer that touch position POS.
420 Return the number found, and store them in a vector in VEC
424 overlays_around (EMACS_INT pos
, Lisp_Object
*vec
, ptrdiff_t len
)
426 Lisp_Object overlay
, start
, end
;
427 struct Lisp_Overlay
*tail
;
428 ptrdiff_t startpos
, endpos
;
431 for (tail
= current_buffer
->overlays_before
; tail
; tail
= tail
->next
)
433 XSETMISC (overlay
, tail
);
435 end
= OVERLAY_END (overlay
);
436 endpos
= OVERLAY_POSITION (end
);
439 start
= OVERLAY_START (overlay
);
440 startpos
= OVERLAY_POSITION (start
);
445 /* Keep counting overlays even if we can't return them all. */
450 for (tail
= current_buffer
->overlays_after
; tail
; tail
= tail
->next
)
452 XSETMISC (overlay
, tail
);
454 start
= OVERLAY_START (overlay
);
455 startpos
= OVERLAY_POSITION (start
);
458 end
= OVERLAY_END (overlay
);
459 endpos
= OVERLAY_POSITION (end
);
471 DEFUN ("get-pos-property", Fget_pos_property
, Sget_pos_property
, 2, 3, 0,
472 doc
: /* Return the value of POSITION's property PROP, in OBJECT.
473 Almost identical to `get-char-property' except for the following difference:
474 Whereas `get-char-property' returns the property of the char at (i.e. right
475 after) POSITION, this pays attention to properties's stickiness and overlays's
476 advancement settings, in order to find the property of POSITION itself,
477 i.e. the property that a char would inherit if it were inserted
479 (Lisp_Object position
, register Lisp_Object prop
, Lisp_Object object
)
481 CHECK_NUMBER_COERCE_MARKER (position
);
484 XSETBUFFER (object
, current_buffer
);
485 else if (WINDOWP (object
))
486 object
= XWINDOW (object
)->contents
;
488 if (!BUFFERP (object
))
489 /* pos-property only makes sense in buffers right now, since strings
490 have no overlays and no notion of insertion for which stickiness
492 return Fget_text_property (position
, prop
, object
);
495 EMACS_INT posn
= XINT (position
);
497 Lisp_Object
*overlay_vec
, tem
;
498 struct buffer
*obuf
= current_buffer
;
501 set_buffer_temp (XBUFFER (object
));
503 /* First try with room for 40 overlays. */
504 Lisp_Object overlay_vecbuf
[40];
505 noverlays
= ARRAYELTS (overlay_vecbuf
);
506 overlay_vec
= overlay_vecbuf
;
507 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
509 /* If there are more than 40,
510 make enough space for all, and try again. */
511 if (ARRAYELTS (overlay_vecbuf
) < noverlays
)
513 SAFE_ALLOCA_LISP (overlay_vec
, noverlays
);
514 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
516 noverlays
= sort_overlays (overlay_vec
, noverlays
, NULL
);
518 set_buffer_temp (obuf
);
520 /* Now check the overlays in order of decreasing priority. */
521 while (--noverlays
>= 0)
523 Lisp_Object ol
= overlay_vec
[noverlays
];
524 tem
= Foverlay_get (ol
, prop
);
527 /* Check the overlay is indeed active at point. */
528 Lisp_Object start
= OVERLAY_START (ol
), finish
= OVERLAY_END (ol
);
529 if ((OVERLAY_POSITION (start
) == posn
530 && XMARKER (start
)->insertion_type
== 1)
531 || (OVERLAY_POSITION (finish
) == posn
532 && XMARKER (finish
)->insertion_type
== 0))
533 ; /* The overlay will not cover a char inserted at point. */
543 { /* Now check the text properties. */
544 int stickiness
= text_property_stickiness (prop
, position
, object
);
546 return Fget_text_property (position
, prop
, object
);
547 else if (stickiness
< 0
548 && XINT (position
) > BUF_BEGV (XBUFFER (object
)))
549 return Fget_text_property (make_number (XINT (position
) - 1),
557 /* Find the field surrounding POS in *BEG and *END. If POS is nil,
558 the value of point is used instead. If BEG or END is null,
559 means don't store the beginning or end of the field.
561 BEG_LIMIT and END_LIMIT serve to limit the ranged of the returned
562 results; they do not effect boundary behavior.
564 If MERGE_AT_BOUNDARY is non-nil, then if POS is at the very first
565 position of a field, then the beginning of the previous field is
566 returned instead of the beginning of POS's field (since the end of a
567 field is actually also the beginning of the next input field, this
568 behavior is sometimes useful). Additionally in the MERGE_AT_BOUNDARY
569 non-nil case, if two fields are separated by a field with the special
570 value `boundary', and POS lies within it, then the two separated
571 fields are considered to be adjacent, and POS between them, when
572 finding the beginning and ending of the "merged" field.
574 Either BEG or END may be 0, in which case the corresponding value
578 find_field (Lisp_Object pos
, Lisp_Object merge_at_boundary
,
579 Lisp_Object beg_limit
,
580 ptrdiff_t *beg
, Lisp_Object end_limit
, ptrdiff_t *end
)
582 /* Fields right before and after the point. */
583 Lisp_Object before_field
, after_field
;
584 /* True if POS counts as the start of a field. */
585 bool at_field_start
= 0;
586 /* True if POS counts as the end of a field. */
587 bool at_field_end
= 0;
590 XSETFASTINT (pos
, PT
);
592 CHECK_NUMBER_COERCE_MARKER (pos
);
595 = get_char_property_and_overlay (pos
, Qfield
, Qnil
, NULL
);
597 = (XFASTINT (pos
) > BEGV
598 ? get_char_property_and_overlay (make_number (XINT (pos
) - 1),
600 /* Using nil here would be a more obvious choice, but it would
601 fail when the buffer starts with a non-sticky field. */
604 /* See if we need to handle the case where MERGE_AT_BOUNDARY is nil
605 and POS is at beginning of a field, which can also be interpreted
606 as the end of the previous field. Note that the case where if
607 MERGE_AT_BOUNDARY is non-nil (see function comment) is actually the
608 more natural one; then we avoid treating the beginning of a field
610 if (NILP (merge_at_boundary
))
612 Lisp_Object field
= Fget_pos_property (pos
, Qfield
, Qnil
);
613 if (!EQ (field
, after_field
))
615 if (!EQ (field
, before_field
))
617 if (NILP (field
) && at_field_start
&& at_field_end
)
618 /* If an inserted char would have a nil field while the surrounding
619 text is non-nil, we're probably not looking at a
620 zero-length field, but instead at a non-nil field that's
621 not intended for editing (such as comint's prompts). */
622 at_field_end
= at_field_start
= 0;
625 /* Note about special `boundary' fields:
627 Consider the case where the point (`.') is between the fields `x' and `y':
631 In this situation, if merge_at_boundary is non-nil, consider the
632 `x' and `y' fields as forming one big merged field, and so the end
633 of the field is the end of `y'.
635 However, if `x' and `y' are separated by a special `boundary' field
636 (a field with a `field' char-property of 'boundary), then ignore
637 this special field when merging adjacent fields. Here's the same
638 situation, but with a `boundary' field between the `x' and `y' fields:
642 Here, if point is at the end of `x', the beginning of `y', or
643 anywhere in-between (within the `boundary' field), merge all
644 three fields and consider the beginning as being the beginning of
645 the `x' field, and the end as being the end of the `y' field. */
650 /* POS is at the edge of a field, and we should consider it as
651 the beginning of the following field. */
652 *beg
= XFASTINT (pos
);
654 /* Find the previous field boundary. */
657 if (!NILP (merge_at_boundary
) && EQ (before_field
, Qboundary
))
658 /* Skip a `boundary' field. */
659 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
662 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
664 *beg
= NILP (p
) ? BEGV
: XFASTINT (p
);
671 /* POS is at the edge of a field, and we should consider it as
672 the end of the previous field. */
673 *end
= XFASTINT (pos
);
675 /* Find the next field boundary. */
677 if (!NILP (merge_at_boundary
) && EQ (after_field
, Qboundary
))
678 /* Skip a `boundary' field. */
679 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
682 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
684 *end
= NILP (pos
) ? ZV
: XFASTINT (pos
);
690 DEFUN ("delete-field", Fdelete_field
, Sdelete_field
, 0, 1, 0,
691 doc
: /* Delete the field surrounding POS.
692 A field is a region of text with the same `field' property.
693 If POS is nil, the value of point is used for POS. */)
697 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
699 del_range (beg
, end
);
703 DEFUN ("field-string", Ffield_string
, Sfield_string
, 0, 1, 0,
704 doc
: /* Return the contents of the field surrounding POS as a string.
705 A field is a region of text with the same `field' property.
706 If POS is nil, the value of point is used for POS. */)
710 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
711 return make_buffer_string (beg
, end
, 1);
714 DEFUN ("field-string-no-properties", Ffield_string_no_properties
, Sfield_string_no_properties
, 0, 1, 0,
715 doc
: /* Return the contents of the field around POS, without text properties.
716 A field is a region of text with the same `field' property.
717 If POS is nil, the value of point is used for POS. */)
721 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
722 return make_buffer_string (beg
, end
, 0);
725 DEFUN ("field-beginning", Ffield_beginning
, Sfield_beginning
, 0, 3, 0,
726 doc
: /* Return the beginning of the field surrounding POS.
727 A field is a region of text with the same `field' property.
728 If POS is nil, the value of point is used for POS.
729 If ESCAPE-FROM-EDGE is non-nil and POS is at the beginning of its
730 field, then the beginning of the *previous* field is returned.
731 If LIMIT is non-nil, it is a buffer position; if the beginning of the field
732 is before LIMIT, then LIMIT will be returned instead. */)
733 (Lisp_Object pos
, Lisp_Object escape_from_edge
, Lisp_Object limit
)
736 find_field (pos
, escape_from_edge
, limit
, &beg
, Qnil
, 0);
737 return make_number (beg
);
740 DEFUN ("field-end", Ffield_end
, Sfield_end
, 0, 3, 0,
741 doc
: /* Return the end of the field surrounding POS.
742 A field is a region of text with the same `field' property.
743 If POS is nil, the value of point is used for POS.
744 If ESCAPE-FROM-EDGE is non-nil and POS is at the end of its field,
745 then the end of the *following* field is returned.
746 If LIMIT is non-nil, it is a buffer position; if the end of the field
747 is after LIMIT, then LIMIT will be returned instead. */)
748 (Lisp_Object pos
, Lisp_Object escape_from_edge
, Lisp_Object limit
)
751 find_field (pos
, escape_from_edge
, Qnil
, 0, limit
, &end
);
752 return make_number (end
);
755 DEFUN ("constrain-to-field", Fconstrain_to_field
, Sconstrain_to_field
, 2, 5, 0,
756 doc
: /* Return the position closest to NEW-POS that is in the same field as OLD-POS.
757 A field is a region of text with the same `field' property.
759 If NEW-POS is nil, then use the current point instead, and move point
760 to the resulting constrained position, in addition to returning that
763 If OLD-POS is at the boundary of two fields, then the allowable
764 positions for NEW-POS depends on the value of the optional argument
765 ESCAPE-FROM-EDGE: If ESCAPE-FROM-EDGE is nil, then NEW-POS is
766 constrained to the field that has the same `field' char-property
767 as any new characters inserted at OLD-POS, whereas if ESCAPE-FROM-EDGE
768 is non-nil, NEW-POS is constrained to the union of the two adjacent
769 fields. Additionally, if two fields are separated by another field with
770 the special value `boundary', then any point within this special field is
771 also considered to be `on the boundary'.
773 If the optional argument ONLY-IN-LINE is non-nil and constraining
774 NEW-POS would move it to a different line, NEW-POS is returned
775 unconstrained. This is useful for commands that move by line, like
776 \\[next-line] or \\[beginning-of-line], which should generally respect field boundaries
777 only in the case where they can still move to the right line.
779 If the optional argument INHIBIT-CAPTURE-PROPERTY is non-nil, and OLD-POS has
780 a non-nil property of that name, then any field boundaries are ignored.
782 Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
783 (Lisp_Object new_pos
, Lisp_Object old_pos
, Lisp_Object escape_from_edge
,
784 Lisp_Object only_in_line
, Lisp_Object inhibit_capture_property
)
786 /* If non-zero, then the original point, before re-positioning. */
787 ptrdiff_t orig_point
= 0;
789 Lisp_Object prev_old
, prev_new
;
792 /* Use the current point, and afterwards, set it. */
795 XSETFASTINT (new_pos
, PT
);
798 CHECK_NUMBER_COERCE_MARKER (new_pos
);
799 CHECK_NUMBER_COERCE_MARKER (old_pos
);
801 fwd
= (XINT (new_pos
) > XINT (old_pos
));
803 prev_old
= make_number (XINT (old_pos
) - 1);
804 prev_new
= make_number (XINT (new_pos
) - 1);
806 if (NILP (Vinhibit_field_text_motion
)
807 && !EQ (new_pos
, old_pos
)
808 && (!NILP (Fget_char_property (new_pos
, Qfield
, Qnil
))
809 || !NILP (Fget_char_property (old_pos
, Qfield
, Qnil
))
810 /* To recognize field boundaries, we must also look at the
811 previous positions; we could use `Fget_pos_property'
812 instead, but in itself that would fail inside non-sticky
813 fields (like comint prompts). */
814 || (XFASTINT (new_pos
) > BEGV
815 && !NILP (Fget_char_property (prev_new
, Qfield
, Qnil
)))
816 || (XFASTINT (old_pos
) > BEGV
817 && !NILP (Fget_char_property (prev_old
, Qfield
, Qnil
))))
818 && (NILP (inhibit_capture_property
)
819 /* Field boundaries are again a problem; but now we must
820 decide the case exactly, so we need to call
821 `get_pos_property' as well. */
822 || (NILP (Fget_pos_property (old_pos
, inhibit_capture_property
, Qnil
))
823 && (XFASTINT (old_pos
) <= BEGV
824 || NILP (Fget_char_property
825 (old_pos
, inhibit_capture_property
, Qnil
))
826 || NILP (Fget_char_property
827 (prev_old
, inhibit_capture_property
, Qnil
))))))
828 /* It is possible that NEW_POS is not within the same field as
829 OLD_POS; try to move NEW_POS so that it is. */
832 Lisp_Object field_bound
;
835 field_bound
= Ffield_end (old_pos
, escape_from_edge
, new_pos
);
837 field_bound
= Ffield_beginning (old_pos
, escape_from_edge
, new_pos
);
839 if (/* See if ESCAPE_FROM_EDGE caused FIELD_BOUND to jump to the
840 other side of NEW_POS, which would mean that NEW_POS is
841 already acceptable, and it's not necessary to constrain it
843 ((XFASTINT (field_bound
) < XFASTINT (new_pos
)) ? fwd
: !fwd
)
844 /* NEW_POS should be constrained, but only if either
845 ONLY_IN_LINE is nil (in which case any constraint is OK),
846 or NEW_POS and FIELD_BOUND are on the same line (in which
847 case the constraint is OK even if ONLY_IN_LINE is non-nil). */
848 && (NILP (only_in_line
)
849 /* This is the ONLY_IN_LINE case, check that NEW_POS and
850 FIELD_BOUND are on the same line by seeing whether
851 there's an intervening newline or not. */
852 || (find_newline (XFASTINT (new_pos
), -1,
853 XFASTINT (field_bound
), -1,
854 fwd
? -1 : 1, &shortage
, NULL
, 1),
856 /* Constrain NEW_POS to FIELD_BOUND. */
857 new_pos
= field_bound
;
859 if (orig_point
&& XFASTINT (new_pos
) != orig_point
)
860 /* The NEW_POS argument was originally nil, so automatically set PT. */
861 SET_PT (XFASTINT (new_pos
));
868 DEFUN ("line-beginning-position",
869 Fline_beginning_position
, Sline_beginning_position
, 0, 1, 0,
870 doc
: /* Return the character position of the first character on the current line.
871 With optional argument N, scan forward N - 1 lines first.
872 If the scan reaches the end of the buffer, return that position.
874 This function ignores text display directionality; it returns the
875 position of the first character in logical order, i.e. the smallest
876 character position on the line.
878 This function constrains the returned position to the current field
879 unless that position would be on a different line than the original,
880 unconstrained result. If N is nil or 1, and a front-sticky field
881 starts at point, the scan stops as soon as it starts. To ignore field
882 boundaries, bind `inhibit-field-text-motion' to t.
884 This function does not move point. */)
887 ptrdiff_t charpos
, bytepos
;
894 scan_newline_from_point (XINT (n
) - 1, &charpos
, &bytepos
);
896 /* Return END constrained to the current input field. */
897 return Fconstrain_to_field (make_number (charpos
), make_number (PT
),
898 XINT (n
) != 1 ? Qt
: Qnil
,
902 DEFUN ("line-end-position", Fline_end_position
, Sline_end_position
, 0, 1, 0,
903 doc
: /* Return the character position of the last character on the current line.
904 With argument N not nil or 1, move forward N - 1 lines first.
905 If scan reaches end of buffer, return that position.
907 This function ignores text display directionality; it returns the
908 position of the last character in logical order, i.e. the largest
909 character position on the line.
911 This function constrains the returned position to the current field
912 unless that would be on a different line than the original,
913 unconstrained result. If N is nil or 1, and a rear-sticky field ends
914 at point, the scan stops as soon as it starts. To ignore field
915 boundaries bind `inhibit-field-text-motion' to t.
917 This function does not move point. */)
929 clipped_n
= clip_to_bounds (PTRDIFF_MIN
+ 1, XINT (n
), PTRDIFF_MAX
);
930 end_pos
= find_before_next_newline (orig
, 0, clipped_n
- (clipped_n
<= 0),
933 /* Return END_POS constrained to the current input field. */
934 return Fconstrain_to_field (make_number (end_pos
), make_number (orig
),
938 /* Save current buffer state for `save-excursion' special form.
939 We (ab)use Lisp_Misc_Save_Value to allow explicit free and so
940 offload some work from GC. */
943 save_excursion_save (void)
945 return make_save_obj_obj_obj_obj
948 /* Selected window if current buffer is shown in it, nil otherwise. */
949 (EQ (XWINDOW (selected_window
)->contents
, Fcurrent_buffer ())
950 ? selected_window
: Qnil
),
954 /* Restore saved buffer before leaving `save-excursion' special form. */
957 save_excursion_restore (Lisp_Object info
)
959 Lisp_Object tem
, tem1
;
962 tem
= Fmarker_buffer (XSAVE_OBJECT (info
, 0));
963 /* If we're unwinding to top level, saved buffer may be deleted. This
964 means that all of its markers are unchained and so tem is nil. */
973 tem
= XSAVE_OBJECT (info
, 0);
975 unchain_marker (XMARKER (tem
));
977 /* If buffer was visible in a window, and a different window was
978 selected, and the old selected window is still showing this
979 buffer, restore point in that window. */
980 tem
= XSAVE_OBJECT (info
, 2);
982 && !EQ (tem
, selected_window
)
983 && (tem1
= XWINDOW (tem
)->contents
,
984 (/* Window is live... */
986 /* ...and it shows the current buffer. */
987 && XBUFFER (tem1
) == current_buffer
)))
988 Fset_window_point (tem
, make_number (PT
));
997 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
998 doc
: /* Save point, and current buffer; execute BODY; restore those things.
999 Executes BODY just like `progn'.
1000 The values of point and the current buffer are restored
1001 even in case of abnormal exit (throw or error).
1003 If you only want to save the current buffer but not point,
1004 then just use `save-current-buffer', or even `with-current-buffer'.
1006 Before Emacs 25.1, `save-excursion' used to save the mark state.
1007 To save the marker state as well as the point and buffer, use
1008 `save-mark-and-excursion'.
1010 usage: (save-excursion &rest BODY) */)
1013 register Lisp_Object val
;
1014 ptrdiff_t count
= SPECPDL_INDEX ();
1016 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
1018 val
= Fprogn (args
);
1019 return unbind_to (count
, val
);
1022 DEFUN ("save-current-buffer", Fsave_current_buffer
, Ssave_current_buffer
, 0, UNEVALLED
, 0,
1023 doc
: /* Record which buffer is current; execute BODY; make that buffer current.
1024 BODY is executed just like `progn'.
1025 usage: (save-current-buffer &rest BODY) */)
1028 ptrdiff_t count
= SPECPDL_INDEX ();
1030 record_unwind_current_buffer ();
1031 return unbind_to (count
, Fprogn (args
));
1034 DEFUN ("buffer-size", Fbuffer_size
, Sbuffer_size
, 0, 1, 0,
1035 doc
: /* Return the number of characters in the current buffer.
1036 If BUFFER, return the number of characters in that buffer instead. */)
1037 (Lisp_Object buffer
)
1040 return make_number (Z
- BEG
);
1043 CHECK_BUFFER (buffer
);
1044 return make_number (BUF_Z (XBUFFER (buffer
))
1045 - BUF_BEG (XBUFFER (buffer
)));
1049 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
1050 doc
: /* Return the minimum permissible value of point in the current buffer.
1051 This is 1, unless narrowing (a buffer restriction) is in effect. */)
1055 XSETFASTINT (temp
, BEGV
);
1059 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
1060 doc
: /* Return a marker to the minimum permissible value of point in this buffer.
1061 This is the beginning, unless narrowing (a buffer restriction) is in effect. */)
1064 return build_marker (current_buffer
, BEGV
, BEGV_BYTE
);
1067 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
1068 doc
: /* Return the maximum permissible value of point in the current buffer.
1069 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1070 is in effect, in which case it is less. */)
1074 XSETFASTINT (temp
, ZV
);
1078 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
1079 doc
: /* Return a marker to the maximum permissible value of point in this buffer.
1080 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1081 is in effect, in which case it is less. */)
1084 return build_marker (current_buffer
, ZV
, ZV_BYTE
);
1087 DEFUN ("gap-position", Fgap_position
, Sgap_position
, 0, 0, 0,
1088 doc
: /* Return the position of the gap, in the current buffer.
1089 See also `gap-size'. */)
1093 XSETFASTINT (temp
, GPT
);
1097 DEFUN ("gap-size", Fgap_size
, Sgap_size
, 0, 0, 0,
1098 doc
: /* Return the size of the current buffer's gap.
1099 See also `gap-position'. */)
1103 XSETFASTINT (temp
, GAP_SIZE
);
1107 DEFUN ("position-bytes", Fposition_bytes
, Sposition_bytes
, 1, 1, 0,
1108 doc
: /* Return the byte position for character position POSITION.
1109 If POSITION is out of range, the value is nil. */)
1110 (Lisp_Object position
)
1112 CHECK_NUMBER_COERCE_MARKER (position
);
1113 if (XINT (position
) < BEG
|| XINT (position
) > Z
)
1115 return make_number (CHAR_TO_BYTE (XINT (position
)));
1118 DEFUN ("byte-to-position", Fbyte_to_position
, Sbyte_to_position
, 1, 1, 0,
1119 doc
: /* Return the character position for byte position BYTEPOS.
1120 If BYTEPOS is out of range, the value is nil. */)
1121 (Lisp_Object bytepos
)
1125 CHECK_NUMBER (bytepos
);
1126 pos_byte
= XINT (bytepos
);
1127 if (pos_byte
< BEG_BYTE
|| pos_byte
> Z_BYTE
)
1130 /* There are multibyte characters in the buffer.
1131 The argument of BYTE_TO_CHAR must be a byte position at
1132 a character boundary, so search for the start of the current
1134 while (!CHAR_HEAD_P (FETCH_BYTE (pos_byte
)))
1136 return make_number (BYTE_TO_CHAR (pos_byte
));
1139 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
1140 doc
: /* Return the character following point, as a number.
1141 At the end of the buffer or accessible region, return 0. */)
1146 XSETFASTINT (temp
, 0);
1148 XSETFASTINT (temp
, FETCH_CHAR (PT_BYTE
));
1152 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
1153 doc
: /* Return the character preceding point, as a number.
1154 At the beginning of the buffer or accessible region, return 0. */)
1159 XSETFASTINT (temp
, 0);
1160 else if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1162 ptrdiff_t pos
= PT_BYTE
;
1164 XSETFASTINT (temp
, FETCH_CHAR (pos
));
1167 XSETFASTINT (temp
, FETCH_BYTE (PT_BYTE
- 1));
1171 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
1172 doc
: /* Return t if point is at the beginning of the buffer.
1173 If the buffer is narrowed, this means the beginning of the narrowed part. */)
1181 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
1182 doc
: /* Return t if point is at the end of the buffer.
1183 If the buffer is narrowed, this means the end of the narrowed part. */)
1191 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
1192 doc
: /* Return t if point is at the beginning of a line. */)
1195 if (PT
== BEGV
|| FETCH_BYTE (PT_BYTE
- 1) == '\n')
1200 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
1201 doc
: /* Return t if point is at the end of a line.
1202 `End of a line' includes point being at the end of the buffer. */)
1205 if (PT
== ZV
|| FETCH_BYTE (PT_BYTE
) == '\n')
1210 DEFUN ("char-after", Fchar_after
, Schar_after
, 0, 1, 0,
1211 doc
: /* Return character in current buffer at position POS.
1212 POS is an integer or a marker and defaults to point.
1213 If POS is out of range, the value is nil. */)
1216 register ptrdiff_t pos_byte
;
1221 XSETFASTINT (pos
, PT
);
1226 pos_byte
= marker_byte_position (pos
);
1227 if (pos_byte
< BEGV_BYTE
|| pos_byte
>= ZV_BYTE
)
1232 CHECK_NUMBER_COERCE_MARKER (pos
);
1233 if (XINT (pos
) < BEGV
|| XINT (pos
) >= ZV
)
1236 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1239 return make_number (FETCH_CHAR (pos_byte
));
1242 DEFUN ("char-before", Fchar_before
, Schar_before
, 0, 1, 0,
1243 doc
: /* Return character in current buffer preceding position POS.
1244 POS is an integer or a marker and defaults to point.
1245 If POS is out of range, the value is nil. */)
1248 register Lisp_Object val
;
1249 register ptrdiff_t pos_byte
;
1254 XSETFASTINT (pos
, PT
);
1259 pos_byte
= marker_byte_position (pos
);
1261 if (pos_byte
<= BEGV_BYTE
|| pos_byte
> ZV_BYTE
)
1266 CHECK_NUMBER_COERCE_MARKER (pos
);
1268 if (XINT (pos
) <= BEGV
|| XINT (pos
) > ZV
)
1271 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1274 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1277 XSETFASTINT (val
, FETCH_CHAR (pos_byte
));
1282 XSETFASTINT (val
, FETCH_BYTE (pos_byte
));
1287 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 1, 0,
1288 doc
: /* Return the name under which the user logged in, as a string.
1289 This is based on the effective uid, not the real uid.
1290 Also, if the environment variables LOGNAME or USER are set,
1291 that determines the value of this function.
1293 If optional argument UID is an integer or a float, return the login name
1294 of the user with that uid, or nil if there is no such user. */)
1300 /* Set up the user name info if we didn't do it before.
1301 (That can happen if Emacs is dumpable
1302 but you decide to run `temacs -l loadup' and not dump. */
1303 if (NILP (Vuser_login_name
))
1304 init_editfns (false);
1307 return Vuser_login_name
;
1309 CONS_TO_INTEGER (uid
, uid_t
, id
);
1313 return (pw
? build_string (pw
->pw_name
) : Qnil
);
1316 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
1318 doc
: /* Return the name of the user's real uid, as a string.
1319 This ignores the environment variables LOGNAME and USER, so it differs from
1320 `user-login-name' when running under `su'. */)
1323 /* Set up the user name info if we didn't do it before.
1324 (That can happen if Emacs is dumpable
1325 but you decide to run `temacs -l loadup' and not dump. */
1326 if (NILP (Vuser_login_name
))
1327 init_editfns (false);
1328 return Vuser_real_login_name
;
1331 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
1332 doc
: /* Return the effective uid of Emacs.
1333 Value is an integer or a float, depending on the value. */)
1336 uid_t euid
= geteuid ();
1337 return make_fixnum_or_float (euid
);
1340 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
1341 doc
: /* Return the real uid of Emacs.
1342 Value is an integer or a float, depending on the value. */)
1345 uid_t uid
= getuid ();
1346 return make_fixnum_or_float (uid
);
1349 DEFUN ("group-gid", Fgroup_gid
, Sgroup_gid
, 0, 0, 0,
1350 doc
: /* Return the effective gid of Emacs.
1351 Value is an integer or a float, depending on the value. */)
1354 gid_t egid
= getegid ();
1355 return make_fixnum_or_float (egid
);
1358 DEFUN ("group-real-gid", Fgroup_real_gid
, Sgroup_real_gid
, 0, 0, 0,
1359 doc
: /* Return the real gid of Emacs.
1360 Value is an integer or a float, depending on the value. */)
1363 gid_t gid
= getgid ();
1364 return make_fixnum_or_float (gid
);
1367 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 1, 0,
1368 doc
: /* Return the full name of the user logged in, as a string.
1369 If the full name corresponding to Emacs's userid is not known,
1372 If optional argument UID is an integer or float, return the full name
1373 of the user with that uid, or nil if there is no such user.
1374 If UID is a string, return the full name of the user with that login
1375 name, or nil if there is no such user. */)
1379 register char *p
, *q
;
1383 return Vuser_full_name
;
1384 else if (NUMBERP (uid
))
1387 CONS_TO_INTEGER (uid
, uid_t
, u
);
1392 else if (STRINGP (uid
))
1395 pw
= getpwnam (SSDATA (uid
));
1399 error ("Invalid UID specification");
1405 /* Chop off everything after the first comma. */
1406 q
= strchr (p
, ',');
1407 full
= make_string (p
, q
? q
- p
: strlen (p
));
1409 #ifdef AMPERSAND_FULL_NAME
1411 q
= strchr (p
, '&');
1412 /* Substitute the login name for the &, upcasing the first character. */
1415 Lisp_Object login
= Fuser_login_name (make_number (pw
->pw_uid
));
1417 char *r
= SAFE_ALLOCA (strlen (p
) + SBYTES (login
) + 1);
1418 memcpy (r
, p
, q
- p
);
1419 char *s
= lispstpcpy (&r
[q
- p
], login
);
1420 r
[q
- p
] = upcase ((unsigned char) r
[q
- p
]);
1422 full
= build_string (r
);
1425 #endif /* AMPERSAND_FULL_NAME */
1430 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
1431 doc
: /* Return the host name of the machine you are running on, as a string. */)
1434 if (EQ (Vsystem_name
, cached_system_name
))
1435 init_and_cache_system_name ();
1436 return Vsystem_name
;
1439 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
1440 doc
: /* Return the process ID of Emacs, as a number. */)
1443 pid_t pid
= getpid ();
1444 return make_fixnum_or_float (pid
);
1450 # define TIME_T_MIN TYPE_MINIMUM (time_t)
1453 # define TIME_T_MAX TYPE_MAXIMUM (time_t)
1456 /* Report that a time value is out of range for Emacs. */
1458 time_overflow (void)
1460 error ("Specified time is not representable");
1466 error ("Invalid time specification");
1469 /* Check a return value compatible with that of decode_time_components. */
1471 check_time_validity (int validity
)
1482 /* Return the upper part of the time T (everything but the bottom 16 bits). */
1486 time_t hi
= t
>> LO_TIME_BITS
;
1488 /* Check for overflow, helping the compiler for common cases where
1489 no runtime check is needed, and taking care not to convert
1490 negative numbers to unsigned before comparing them. */
1491 if (! ((! TYPE_SIGNED (time_t)
1492 || MOST_NEGATIVE_FIXNUM
<= TIME_T_MIN
>> LO_TIME_BITS
1493 || MOST_NEGATIVE_FIXNUM
<= hi
)
1494 && (TIME_T_MAX
>> LO_TIME_BITS
<= MOST_POSITIVE_FIXNUM
1495 || hi
<= MOST_POSITIVE_FIXNUM
)))
1501 /* Return the bottom bits of the time T. */
1505 return t
& ((1 << LO_TIME_BITS
) - 1);
1508 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
1509 doc
: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
1510 The time is returned as a list of integers (HIGH LOW USEC PSEC).
1511 HIGH has the most significant bits of the seconds, while LOW has the
1512 least significant 16 bits. USEC and PSEC are the microsecond and
1513 picosecond counts. */)
1516 return make_lisp_time (current_timespec ());
1519 static struct lisp_time
1520 time_add (struct lisp_time ta
, struct lisp_time tb
)
1522 EMACS_INT hi
= ta
.hi
+ tb
.hi
;
1523 int lo
= ta
.lo
+ tb
.lo
;
1524 int us
= ta
.us
+ tb
.us
;
1525 int ps
= ta
.ps
+ tb
.ps
;
1526 us
+= (1000000 <= ps
);
1527 ps
-= (1000000 <= ps
) * 1000000;
1528 lo
+= (1000000 <= us
);
1529 us
-= (1000000 <= us
) * 1000000;
1530 hi
+= (1 << LO_TIME_BITS
<= lo
);
1531 lo
-= (1 << LO_TIME_BITS
<= lo
) << LO_TIME_BITS
;
1532 return (struct lisp_time
) { hi
, lo
, us
, ps
};
1535 static struct lisp_time
1536 time_subtract (struct lisp_time ta
, struct lisp_time tb
)
1538 EMACS_INT hi
= ta
.hi
- tb
.hi
;
1539 int lo
= ta
.lo
- tb
.lo
;
1540 int us
= ta
.us
- tb
.us
;
1541 int ps
= ta
.ps
- tb
.ps
;
1543 ps
+= (ps
< 0) * 1000000;
1545 us
+= (us
< 0) * 1000000;
1547 lo
+= (lo
< 0) << LO_TIME_BITS
;
1548 return (struct lisp_time
) { hi
, lo
, us
, ps
};
1552 time_arith (Lisp_Object a
, Lisp_Object b
,
1553 struct lisp_time (*op
) (struct lisp_time
, struct lisp_time
))
1556 struct lisp_time ta
= lisp_time_struct (a
, &alen
);
1557 struct lisp_time tb
= lisp_time_struct (b
, &blen
);
1558 struct lisp_time t
= op (ta
, tb
);
1559 if (! (MOST_NEGATIVE_FIXNUM
<= t
.hi
&& t
.hi
<= MOST_POSITIVE_FIXNUM
))
1561 Lisp_Object val
= Qnil
;
1563 switch (max (alen
, blen
))
1566 val
= Fcons (make_number (t
.ps
), val
);
1569 val
= Fcons (make_number (t
.us
), val
);
1572 val
= Fcons (make_number (t
.lo
), val
);
1573 val
= Fcons (make_number (t
.hi
), val
);
1580 DEFUN ("time-add", Ftime_add
, Stime_add
, 2, 2, 0,
1581 doc
: /* Return the sum of two time values A and B, as a time value. */)
1582 (Lisp_Object a
, Lisp_Object b
)
1584 return time_arith (a
, b
, time_add
);
1587 DEFUN ("time-subtract", Ftime_subtract
, Stime_subtract
, 2, 2, 0,
1588 doc
: /* Return the difference between two time values A and B, as a time value. */)
1589 (Lisp_Object a
, Lisp_Object b
)
1591 return time_arith (a
, b
, time_subtract
);
1594 DEFUN ("time-less-p", Ftime_less_p
, Stime_less_p
, 2, 2, 0,
1595 doc
: /* Return non-nil if time value T1 is earlier than time value T2. */)
1596 (Lisp_Object t1
, Lisp_Object t2
)
1599 struct lisp_time a
= lisp_time_struct (t1
, &t1len
);
1600 struct lisp_time b
= lisp_time_struct (t2
, &t2len
);
1601 return ((a
.hi
!= b
.hi
? a
.hi
< b
.hi
1602 : a
.lo
!= b
.lo
? a
.lo
< b
.lo
1603 : a
.us
!= b
.us
? a
.us
< b
.us
1609 DEFUN ("get-internal-run-time", Fget_internal_run_time
, Sget_internal_run_time
,
1611 doc
: /* Return the current run time used by Emacs.
1612 The time is returned as a list (HIGH LOW USEC PSEC), using the same
1613 style as (current-time).
1615 On systems that can't determine the run time, `get-internal-run-time'
1616 does the same thing as `current-time'. */)
1619 #ifdef HAVE_GETRUSAGE
1620 struct rusage usage
;
1624 if (getrusage (RUSAGE_SELF
, &usage
) < 0)
1625 /* This shouldn't happen. What action is appropriate? */
1628 /* Sum up user time and system time. */
1629 secs
= usage
.ru_utime
.tv_sec
+ usage
.ru_stime
.tv_sec
;
1630 usecs
= usage
.ru_utime
.tv_usec
+ usage
.ru_stime
.tv_usec
;
1631 if (usecs
>= 1000000)
1636 return make_lisp_time (make_timespec (secs
, usecs
* 1000));
1637 #else /* ! HAVE_GETRUSAGE */
1639 return w32_get_internal_run_time ();
1640 #else /* ! WINDOWSNT */
1641 return Fcurrent_time ();
1642 #endif /* WINDOWSNT */
1643 #endif /* HAVE_GETRUSAGE */
1647 /* Make a Lisp list that represents the Emacs time T. T may be an
1648 invalid time, with a slightly negative tv_nsec value such as
1649 UNKNOWN_MODTIME_NSECS; in that case, the Lisp list contains a
1650 correspondingly negative picosecond count. */
1652 make_lisp_time (struct timespec t
)
1654 time_t s
= t
.tv_sec
;
1656 return list4i (hi_time (s
), lo_time (s
), ns
/ 1000, ns
% 1000 * 1000);
1659 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1660 Set *PHIGH, *PLOW, *PUSEC, *PPSEC to its parts; do not check their values.
1661 Return 2, 3, or 4 to indicate the effective length of SPECIFIED_TIME
1662 if successful, 0 if unsuccessful. */
1664 disassemble_lisp_time (Lisp_Object specified_time
, Lisp_Object
*phigh
,
1665 Lisp_Object
*plow
, Lisp_Object
*pusec
,
1668 Lisp_Object high
= make_number (0);
1669 Lisp_Object low
= specified_time
;
1670 Lisp_Object usec
= make_number (0);
1671 Lisp_Object psec
= make_number (0);
1674 if (CONSP (specified_time
))
1676 high
= XCAR (specified_time
);
1677 low
= XCDR (specified_time
);
1680 Lisp_Object low_tail
= XCDR (low
);
1682 if (CONSP (low_tail
))
1684 usec
= XCAR (low_tail
);
1685 low_tail
= XCDR (low_tail
);
1686 if (CONSP (low_tail
))
1687 psec
= XCAR (low_tail
);
1691 else if (!NILP (low_tail
))
1702 /* When combining components, require LOW to be an integer,
1703 as otherwise it would be a pain to add up times. */
1704 if (! INTEGERP (low
))
1707 else if (INTEGERP (specified_time
))
1717 /* Convert T into an Emacs time *RESULT, truncating toward minus infinity.
1718 Return true if T is in range, false otherwise. */
1720 decode_float_time (double t
, struct lisp_time
*result
)
1722 double lo_multiplier
= 1 << LO_TIME_BITS
;
1723 double emacs_time_min
= MOST_NEGATIVE_FIXNUM
* lo_multiplier
;
1724 if (! (emacs_time_min
<= t
&& t
< -emacs_time_min
))
1727 double small_t
= t
/ lo_multiplier
;
1728 EMACS_INT hi
= small_t
;
1729 double t_sans_hi
= t
- hi
* lo_multiplier
;
1731 long double fracps
= (t_sans_hi
- lo
) * 1e12L
;
1732 #ifdef INT_FAST64_MAX
1733 int_fast64_t ifracps
= fracps
;
1734 int us
= ifracps
/ 1000000;
1735 int ps
= ifracps
% 1000000;
1737 int us
= fracps
/ 1e6L
;
1738 int ps
= fracps
- us
* 1e6L
;
1741 ps
+= (ps
< 0) * 1000000;
1743 us
+= (us
< 0) * 1000000;
1745 lo
+= (lo
< 0) << LO_TIME_BITS
;
1753 /* From the time components HIGH, LOW, USEC and PSEC taken from a Lisp
1754 list, generate the corresponding time value.
1755 If LOW is floating point, the other components should be zero.
1757 If RESULT is not null, store into *RESULT the converted time.
1758 If *DRESULT is not null, store into *DRESULT the number of
1759 seconds since the start of the POSIX Epoch.
1761 Return 1 if successful, 0 if the components are of the
1762 wrong type, and -1 if the time is out of range. */
1764 decode_time_components (Lisp_Object high
, Lisp_Object low
, Lisp_Object usec
,
1766 struct lisp_time
*result
, double *dresult
)
1768 EMACS_INT hi
, lo
, us
, ps
;
1769 if (! (INTEGERP (high
)
1770 && INTEGERP (usec
) && INTEGERP (psec
)))
1772 if (! INTEGERP (low
))
1776 double t
= XFLOAT_DATA (low
);
1777 if (result
&& ! decode_float_time (t
, result
))
1783 else if (NILP (low
))
1785 struct timespec now
= current_timespec ();
1788 result
->hi
= hi_time (now
.tv_sec
);
1789 result
->lo
= lo_time (now
.tv_sec
);
1790 result
->us
= now
.tv_nsec
/ 1000;
1791 result
->ps
= now
.tv_nsec
% 1000 * 1000;
1794 *dresult
= now
.tv_sec
+ now
.tv_nsec
/ 1e9
;
1806 /* Normalize out-of-range lower-order components by carrying
1807 each overflow into the next higher-order component. */
1808 us
+= ps
/ 1000000 - (ps
% 1000000 < 0);
1809 lo
+= us
/ 1000000 - (us
% 1000000 < 0);
1810 hi
+= lo
>> LO_TIME_BITS
;
1811 ps
= ps
% 1000000 + 1000000 * (ps
% 1000000 < 0);
1812 us
= us
% 1000000 + 1000000 * (us
% 1000000 < 0);
1813 lo
&= (1 << LO_TIME_BITS
) - 1;
1817 if (! (MOST_NEGATIVE_FIXNUM
<= hi
&& hi
<= MOST_POSITIVE_FIXNUM
))
1828 *dresult
= (us
* 1e6
+ ps
) / 1e12
+ lo
+ dhi
* (1 << LO_TIME_BITS
);
1835 lisp_to_timespec (struct lisp_time t
)
1837 if (! ((TYPE_SIGNED (time_t) ? TIME_T_MIN
>> LO_TIME_BITS
<= t
.hi
: 0 <= t
.hi
)
1838 && t
.hi
<= TIME_T_MAX
>> LO_TIME_BITS
))
1839 return invalid_timespec ();
1840 time_t s
= (t
.hi
<< LO_TIME_BITS
) + t
.lo
;
1841 int ns
= t
.us
* 1000 + t
.ps
/ 1000;
1842 return make_timespec (s
, ns
);
1845 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1846 Store its effective length into *PLEN.
1847 If SPECIFIED_TIME is nil, use the current time.
1848 Signal an error if SPECIFIED_TIME does not represent a time. */
1849 static struct lisp_time
1850 lisp_time_struct (Lisp_Object specified_time
, int *plen
)
1852 Lisp_Object high
, low
, usec
, psec
;
1854 int len
= disassemble_lisp_time (specified_time
, &high
, &low
, &usec
, &psec
);
1855 int val
= len
? decode_time_components (high
, low
, usec
, psec
, &t
, 0) : 0;
1856 check_time_validity (val
);
1861 /* Like lisp_time_struct, except return a struct timespec.
1862 Discard any low-order digits. */
1864 lisp_time_argument (Lisp_Object specified_time
)
1867 struct lisp_time lt
= lisp_time_struct (specified_time
, &len
);
1868 struct timespec t
= lisp_to_timespec (lt
);
1869 if (! timespec_valid_p (t
))
1874 /* Like lisp_time_argument, except decode only the seconds part,
1875 and do not check the subseconds part. */
1877 lisp_seconds_argument (Lisp_Object specified_time
)
1879 Lisp_Object high
, low
, usec
, psec
;
1882 int val
= disassemble_lisp_time (specified_time
, &high
, &low
, &usec
, &psec
);
1885 val
= decode_time_components (high
, low
, make_number (0),
1886 make_number (0), &t
, 0);
1888 && ! ((TYPE_SIGNED (time_t)
1889 ? TIME_T_MIN
>> LO_TIME_BITS
<= t
.hi
1891 && t
.hi
<= TIME_T_MAX
>> LO_TIME_BITS
))
1894 check_time_validity (val
);
1895 return (t
.hi
<< LO_TIME_BITS
) + t
.lo
;
1898 DEFUN ("float-time", Ffloat_time
, Sfloat_time
, 0, 1, 0,
1899 doc
: /* Return the current time, as a float number of seconds since the epoch.
1900 If SPECIFIED-TIME is given, it is the time to convert to float
1901 instead of the current time. The argument should have the form
1902 (HIGH LOW) or (HIGH LOW USEC) or (HIGH LOW USEC PSEC). Thus,
1903 you can use times from `current-time' and from `file-attributes'.
1904 SPECIFIED-TIME can also have the form (HIGH . LOW), but this is
1905 considered obsolete.
1907 WARNING: Since the result is floating point, it may not be exact.
1908 If precise time stamps are required, use either `current-time',
1909 or (if you need time as a string) `format-time-string'. */)
1910 (Lisp_Object specified_time
)
1913 Lisp_Object high
, low
, usec
, psec
;
1914 if (! (disassemble_lisp_time (specified_time
, &high
, &low
, &usec
, &psec
)
1915 && decode_time_components (high
, low
, usec
, psec
, 0, &t
)))
1917 return make_float (t
);
1920 /* Write information into buffer S of size MAXSIZE, according to the
1921 FORMAT of length FORMAT_LEN, using time information taken from *TP.
1922 Use the time zone specified by TZ.
1923 Use NS as the number of nanoseconds in the %N directive.
1924 Return the number of bytes written, not including the terminating
1925 '\0'. If S is NULL, nothing will be written anywhere; so to
1926 determine how many bytes would be written, use NULL for S and
1927 ((size_t) -1) for MAXSIZE.
1929 This function behaves like nstrftime, except it allows null
1930 bytes in FORMAT and it does not support nanoseconds. */
1932 emacs_nmemftime (char *s
, size_t maxsize
, const char *format
,
1933 size_t format_len
, const struct tm
*tp
, timezone_t tz
, int ns
)
1937 /* Loop through all the null-terminated strings in the format
1938 argument. Normally there's just one null-terminated string, but
1939 there can be arbitrarily many, concatenated together, if the
1940 format contains '\0' bytes. nstrftime stops at the first
1941 '\0' byte so we must invoke it separately for each such string. */
1950 result
= nstrftime (s
, maxsize
, format
, tp
, tz
, ns
);
1954 if (result
== 0 && s
[0] != '\0')
1959 maxsize
-= result
+ 1;
1961 len
= strlen (format
);
1962 if (len
== format_len
)
1966 format_len
-= len
+ 1;
1970 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 1, 3, 0,
1971 doc
: /* Use FORMAT-STRING to format the time TIME, or now if omitted.
1972 TIME is specified as (HIGH LOW USEC PSEC), as returned by
1973 `current-time' or `file-attributes'. The obsolete form (HIGH . LOW)
1974 is also still accepted.
1975 The optional ZONE is omitted or nil for Emacs local time, t for
1976 Universal Time, `wall' for system wall clock time, or a string as in
1977 `set-time-zone-rule' for a time zone rule.
1978 The value is a copy of FORMAT-STRING, but with certain constructs replaced
1979 by text that describes the specified date and time in TIME:
1981 %Y is the year, %y within the century, %C the century.
1982 %G is the year corresponding to the ISO week, %g within the century.
1983 %m is the numeric month.
1984 %b and %h are the locale's abbreviated month name, %B the full name.
1985 (%h is not supported on MS-Windows.)
1986 %d is the day of the month, zero-padded, %e is blank-padded.
1987 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
1988 %a is the locale's abbreviated name of the day of week, %A the full name.
1989 %U is the week number starting on Sunday, %W starting on Monday,
1990 %V according to ISO 8601.
1991 %j is the day of the year.
1993 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
1994 only blank-padded, %l is like %I blank-padded.
1995 %p is the locale's equivalent of either AM or PM.
1998 %N is the nanosecond, %6N the microsecond, %3N the millisecond, etc.
1999 %Z is the time zone name, %z is the numeric form.
2000 %s is the number of seconds since 1970-01-01 00:00:00 +0000.
2002 %c is the locale's date and time format.
2003 %x is the locale's "preferred" date format.
2004 %D is like "%m/%d/%y".
2005 %F is the ISO 8601 date format (like "%Y-%m-%d").
2007 %R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
2008 %X is the locale's "preferred" time format.
2010 Finally, %n is a newline, %t is a tab, %% is a literal %.
2012 Certain flags and modifiers are available with some format controls.
2013 The flags are `_', `-', `^' and `#'. For certain characters X,
2014 %_X is like %X, but padded with blanks; %-X is like %X,
2015 but without padding. %^X is like %X, but with all textual
2016 characters up-cased; %#X is like %X, but with letter-case of
2017 all textual characters reversed.
2018 %NX (where N stands for an integer) is like %X,
2019 but takes up at least N (a number) positions.
2020 The modifiers are `E' and `O'. For certain characters X,
2021 %EX is a locale's alternative version of %X;
2022 %OX is like %X, but uses the locale's number symbols.
2024 For example, to produce full ISO 8601 format, use "%FT%T%z".
2026 usage: (format-time-string FORMAT-STRING &optional TIME ZONE) */)
2027 (Lisp_Object format_string
, Lisp_Object timeval
, Lisp_Object zone
)
2029 struct timespec t
= lisp_time_argument (timeval
);
2032 CHECK_STRING (format_string
);
2033 format_string
= code_convert_string_norecord (format_string
,
2034 Vlocale_coding_system
, 1);
2035 return format_time_string (SSDATA (format_string
), SBYTES (format_string
),
2040 format_time_string (char const *format
, ptrdiff_t formatlen
,
2041 struct timespec t
, Lisp_Object zone
, struct tm
*tmp
)
2045 ptrdiff_t size
= sizeof buffer
;
2047 Lisp_Object bufstring
;
2051 timezone_t tz
= tzlookup (zone
, false);
2052 tmp
= emacs_localtime_rz (tz
, &t
.tv_sec
, tmp
);
2058 synchronize_system_time_locale ();
2063 len
= emacs_nmemftime (buf
, size
, format
, formatlen
, tmp
, tz
, ns
);
2064 if ((0 < len
&& len
< size
) || (len
== 0 && buf
[0] == '\0'))
2067 /* Buffer was too small, so make it bigger and try again. */
2068 len
= emacs_nmemftime (NULL
, SIZE_MAX
, format
, formatlen
, tmp
, tz
, ns
);
2069 if (STRING_BYTES_BOUND
<= len
)
2075 buf
= SAFE_ALLOCA (size
);
2079 bufstring
= make_unibyte_string (buf
, len
);
2081 return code_convert_string_norecord (bufstring
, Vlocale_coding_system
, 0);
2084 DEFUN ("decode-time", Fdecode_time
, Sdecode_time
, 0, 2, 0,
2085 doc
: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST UTCOFF).
2086 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED),
2087 as from `current-time' and `file-attributes', or nil to use the
2088 current time. The obsolete form (HIGH . LOW) is also still accepted.
2089 The optional ZONE is omitted or nil for Emacs local time, t for
2090 Universal Time, `wall' for system wall clock time, or a string as in
2091 `set-time-zone-rule' for a time zone rule.
2093 The list has the following nine members: SEC is an integer between 0
2094 and 60; SEC is 60 for a leap second, which only some operating systems
2095 support. MINUTE is an integer between 0 and 59. HOUR is an integer
2096 between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
2097 integer between 1 and 12. YEAR is an integer indicating the
2098 four-digit year. DOW is the day of week, an integer between 0 and 6,
2099 where 0 is Sunday. DST is t if daylight saving time is in effect,
2100 otherwise nil. UTCOFF is an integer indicating the UTC offset in
2101 seconds, i.e., the number of seconds east of Greenwich. (Note that
2102 Common Lisp has different meanings for DOW and UTCOFF.)
2104 usage: (decode-time &optional TIME ZONE) */)
2105 (Lisp_Object specified_time
, Lisp_Object zone
)
2107 time_t time_spec
= lisp_seconds_argument (specified_time
);
2108 struct tm local_tm
, gmt_tm
;
2109 timezone_t tz
= tzlookup (zone
, false);
2110 struct tm
*tm
= emacs_localtime_rz (tz
, &time_spec
, &local_tm
);
2114 && MOST_NEGATIVE_FIXNUM
- TM_YEAR_BASE
<= local_tm
.tm_year
2115 && local_tm
.tm_year
<= MOST_POSITIVE_FIXNUM
- TM_YEAR_BASE
))
2118 /* Avoid overflow when INT_MAX < EMACS_INT_MAX. */
2119 EMACS_INT tm_year_base
= TM_YEAR_BASE
;
2121 return CALLN (Flist
,
2122 make_number (local_tm
.tm_sec
),
2123 make_number (local_tm
.tm_min
),
2124 make_number (local_tm
.tm_hour
),
2125 make_number (local_tm
.tm_mday
),
2126 make_number (local_tm
.tm_mon
+ 1),
2127 make_number (local_tm
.tm_year
+ tm_year_base
),
2128 make_number (local_tm
.tm_wday
),
2129 local_tm
.tm_isdst
? Qt
: Qnil
,
2131 ? make_number (tm_gmtoff (&local_tm
))
2132 : gmtime_r (&time_spec
, &gmt_tm
)
2133 ? make_number (tm_diff (&local_tm
, &gmt_tm
))
2137 /* Return OBJ - OFFSET, checking that OBJ is a valid fixnum and that
2138 the result is representable as an int. Assume OFFSET is small and
2141 check_tm_member (Lisp_Object obj
, int offset
)
2146 if (! (INT_MIN
+ offset
<= n
&& n
- offset
<= INT_MAX
))
2151 DEFUN ("encode-time", Fencode_time
, Sencode_time
, 6, MANY
, 0,
2152 doc
: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
2153 This is the reverse operation of `decode-time', which see.
2154 The optional ZONE is omitted or nil for Emacs local time, t for
2155 Universal Time, `wall' for system wall clock time, or a string as in
2156 `set-time-zone-rule' for a time zone rule. It can also be a list (as
2157 from `current-time-zone') or an integer (as from `decode-time')
2158 applied without consideration for daylight saving time.
2160 You can pass more than 7 arguments; then the first six arguments
2161 are used as SECOND through YEAR, and the *last* argument is used as ZONE.
2162 The intervening arguments are ignored.
2163 This feature lets (apply 'encode-time (decode-time ...)) work.
2165 Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed;
2166 for example, a DAY of 0 means the day preceding the given month.
2167 Year numbers less than 100 are treated just like other year numbers.
2168 If you want them to stand for years in this century, you must do that yourself.
2170 Years before 1970 are not guaranteed to work. On some systems,
2171 year values as low as 1901 do work.
2173 usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
2174 (ptrdiff_t nargs
, Lisp_Object
*args
)
2178 Lisp_Object zone
= (nargs
> 6 ? args
[nargs
- 1] : Qnil
);
2180 tm
.tm_sec
= check_tm_member (args
[0], 0);
2181 tm
.tm_min
= check_tm_member (args
[1], 0);
2182 tm
.tm_hour
= check_tm_member (args
[2], 0);
2183 tm
.tm_mday
= check_tm_member (args
[3], 0);
2184 tm
.tm_mon
= check_tm_member (args
[4], 1);
2185 tm
.tm_year
= check_tm_member (args
[5], TM_YEAR_BASE
);
2190 timezone_t tz
= tzlookup (zone
, false);
2191 value
= emacs_mktime_z (tz
, &tm
);
2194 if (value
== (time_t) -1)
2197 return list2i (hi_time (value
), lo_time (value
));
2200 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
,
2202 doc
: /* Return the current local time, as a human-readable string.
2203 Programs can use this function to decode a time,
2204 since the number of columns in each field is fixed
2205 if the year is in the range 1000-9999.
2206 The format is `Sun Sep 16 01:03:52 1973'.
2207 However, see also the functions `decode-time' and `format-time-string'
2208 which provide a much more powerful and general facility.
2210 If SPECIFIED-TIME is given, it is a time to format instead of the
2211 current time. The argument should have the form (HIGH LOW . IGNORED).
2212 Thus, you can use times obtained from `current-time' and from
2213 `file-attributes'. SPECIFIED-TIME can also have the form (HIGH . LOW),
2214 but this is considered obsolete.
2216 The optional ZONE is omitted or nil for Emacs local time, t for
2217 Universal Time, `wall' for system wall clock time, or a string as in
2218 `set-time-zone-rule' for a time zone rule. */)
2219 (Lisp_Object specified_time
, Lisp_Object zone
)
2221 time_t value
= lisp_seconds_argument (specified_time
);
2222 timezone_t tz
= tzlookup (zone
, false);
2224 /* Convert to a string in ctime format, except without the trailing
2225 newline, and without the 4-digit year limit. Don't use asctime
2226 or ctime, as they might dump core if the year is outside the
2227 range -999 .. 9999. */
2229 struct tm
*tmp
= emacs_localtime_rz (tz
, &value
, &tm
);
2234 static char const wday_name
[][4] =
2235 { "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat" };
2236 static char const mon_name
[][4] =
2237 { "Jan", "Feb", "Mar", "Apr", "May", "Jun",
2238 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" };
2239 printmax_t year_base
= TM_YEAR_BASE
;
2240 char buf
[sizeof "Mon Apr 30 12:49:17 " + INT_STRLEN_BOUND (int) + 1];
2241 int len
= sprintf (buf
, "%s %s%3d %02d:%02d:%02d %"pMd
,
2242 wday_name
[tm
.tm_wday
], mon_name
[tm
.tm_mon
], tm
.tm_mday
,
2243 tm
.tm_hour
, tm
.tm_min
, tm
.tm_sec
,
2244 tm
.tm_year
+ year_base
);
2246 return make_unibyte_string (buf
, len
);
2249 /* Yield A - B, measured in seconds.
2250 This function is copied from the GNU C Library. */
2252 tm_diff (struct tm
*a
, struct tm
*b
)
2254 /* Compute intervening leap days correctly even if year is negative.
2255 Take care to avoid int overflow in leap day calculations,
2256 but it's OK to assume that A and B are close to each other. */
2257 int a4
= (a
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (a
->tm_year
& 3);
2258 int b4
= (b
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (b
->tm_year
& 3);
2259 int a100
= a4
/ 25 - (a4
% 25 < 0);
2260 int b100
= b4
/ 25 - (b4
% 25 < 0);
2261 int a400
= a100
>> 2;
2262 int b400
= b100
>> 2;
2263 int intervening_leap_days
= (a4
- b4
) - (a100
- b100
) + (a400
- b400
);
2264 int years
= a
->tm_year
- b
->tm_year
;
2265 int days
= (365 * years
+ intervening_leap_days
2266 + (a
->tm_yday
- b
->tm_yday
));
2267 return (60 * (60 * (24 * days
+ (a
->tm_hour
- b
->tm_hour
))
2268 + (a
->tm_min
- b
->tm_min
))
2269 + (a
->tm_sec
- b
->tm_sec
));
2272 /* Yield A's UTC offset, or an unspecified value if unknown. */
2274 tm_gmtoff (struct tm
*a
)
2277 return a
->tm_gmtoff
;
2283 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 2, 0,
2284 doc
: /* Return the offset and name for the local time zone.
2285 This returns a list of the form (OFFSET NAME).
2286 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
2287 A negative value means west of Greenwich.
2288 NAME is a string giving the name of the time zone.
2289 If SPECIFIED-TIME is given, the time zone offset is determined from it
2290 instead of using the current time. The argument should have the form
2291 (HIGH LOW . IGNORED). Thus, you can use times obtained from
2292 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
2293 have the form (HIGH . LOW), but this is considered obsolete.
2294 Optional second arg ZONE is omitted or nil for the local time zone, or
2295 a string as in `set-time-zone-rule'.
2297 Some operating systems cannot provide all this information to Emacs;
2298 in this case, `current-time-zone' returns a list containing nil for
2299 the data it can't find. */)
2300 (Lisp_Object specified_time
, Lisp_Object zone
)
2302 struct timespec value
;
2303 struct tm local_tm
, gmt_tm
;
2304 Lisp_Object zone_offset
, zone_name
;
2307 value
= make_timespec (lisp_seconds_argument (specified_time
), 0);
2308 zone_name
= format_time_string ("%Z", sizeof "%Z" - 1, value
,
2311 if (HAVE_TM_GMTOFF
|| gmtime_r (&value
.tv_sec
, &gmt_tm
))
2313 long int offset
= (HAVE_TM_GMTOFF
2314 ? tm_gmtoff (&local_tm
)
2315 : tm_diff (&local_tm
, &gmt_tm
));
2316 zone_offset
= make_number (offset
);
2317 if (SCHARS (zone_name
) == 0)
2319 /* No local time zone name is available; use "+-NNNN" instead. */
2320 long int m
= offset
/ 60;
2321 long int am
= offset
< 0 ? - m
: m
;
2322 long int hour
= am
/ 60;
2324 char buf
[sizeof "+00" + INT_STRLEN_BOUND (long int)];
2325 zone_name
= make_formatted_string (buf
, "%c%02ld%02d",
2326 (offset
< 0 ? '-' : '+'),
2331 return list2 (zone_offset
, zone_name
);
2334 DEFUN ("set-time-zone-rule", Fset_time_zone_rule
, Sset_time_zone_rule
, 1, 1, 0,
2335 doc
: /* Set the Emacs local time zone using TZ, a string specifying a time zone rule.
2336 If TZ is nil or `wall', use system wall clock time. If TZ is t, use
2337 Universal Time. If TZ is an integer, treat it as in `encode-time'.
2339 Instead of calling this function, you typically want something else.
2340 To temporarily use a different time zone rule for just one invocation
2341 of `decode-time', `encode-time', or `format-time-string', pass the
2342 function a ZONE argument. To change local time consistently
2343 throughout Emacs, call (setenv "TZ" TZ): this changes both the
2344 environment of the Emacs process and the variable
2345 `process-environment', whereas `set-time-zone-rule' affects only the
2349 tzlookup (NILP (tz
) ? Qwall
: tz
, true);
2353 /* A buffer holding a string of the form "TZ=value", intended
2354 to be part of the environment. If TZ is supposed to be unset,
2355 the buffer string is "tZ=". */
2356 static char *tzvalbuf
;
2358 /* Get the local time zone rule. */
2360 emacs_getenv_TZ (void)
2362 return tzvalbuf
[0] == 'T' ? tzvalbuf
+ tzeqlen
: 0;
2365 /* Set the local time zone rule to TZSTRING, which can be null to
2366 denote wall clock time. Do not record the setting in LOCAL_TZ.
2368 This function is not thread-safe, in theory because putenv is not,
2369 but mostly because of the static storage it updates. Other threads
2370 that invoke localtime etc. may be adversely affected while this
2371 function is executing. */
2374 emacs_setenv_TZ (const char *tzstring
)
2376 static ptrdiff_t tzvalbufsize
;
2377 ptrdiff_t tzstringlen
= tzstring
? strlen (tzstring
) : 0;
2378 char *tzval
= tzvalbuf
;
2379 bool new_tzvalbuf
= tzvalbufsize
<= tzeqlen
+ tzstringlen
;
2383 /* Do not attempt to free the old tzvalbuf, since another thread
2384 may be using it. In practice, the first allocation is large
2385 enough and memory does not leak. */
2386 tzval
= xpalloc (NULL
, &tzvalbufsize
,
2387 tzeqlen
+ tzstringlen
- tzvalbufsize
+ 1, -1, 1);
2395 /* Modify TZVAL in place. Although this is dicey in a
2396 multithreaded environment, we know of no portable alternative.
2397 Calling putenv or setenv could crash some other thread. */
2399 strcpy (tzval
+ tzeqlen
, tzstring
);
2403 /* Turn 'TZ=whatever' into an empty environment variable 'tZ='.
2404 Although this is also dicey, calling unsetenv here can crash Emacs.
2412 /* MS-Windows implementation of 'putenv' copies the argument
2413 string into a block it allocates, so modifying tzval string
2414 does not change the environment. OTOH, the other threads run
2415 by Emacs on MS-Windows never call 'xputenv' or 'putenv' or
2416 'unsetenv', so the original cause for the dicey in-place
2417 modification technique doesn't exist there in the first
2423 /* Although this is not thread-safe, in practice this runs only
2424 on startup when there is only one thread. */
2431 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
2432 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
2433 type of object is Lisp_String). INHERIT is passed to
2434 INSERT_FROM_STRING_FUNC as the last argument. */
2437 general_insert_function (void (*insert_func
)
2438 (const char *, ptrdiff_t),
2439 void (*insert_from_string_func
)
2440 (Lisp_Object
, ptrdiff_t, ptrdiff_t,
2441 ptrdiff_t, ptrdiff_t, bool),
2442 bool inherit
, ptrdiff_t nargs
, Lisp_Object
*args
)
2447 for (argnum
= 0; argnum
< nargs
; argnum
++)
2450 if (CHARACTERP (val
))
2452 int c
= XFASTINT (val
);
2453 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2456 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2457 len
= CHAR_STRING (c
, str
);
2460 str
[0] = CHAR_TO_BYTE8 (c
);
2463 (*insert_func
) ((char *) str
, len
);
2465 else if (STRINGP (val
))
2467 (*insert_from_string_func
) (val
, 0, 0,
2473 wrong_type_argument (Qchar_or_string_p
, val
);
2478 insert1 (Lisp_Object arg
)
2484 /* Callers passing one argument to Finsert need not gcpro the
2485 argument "array", since the only element of the array will
2486 not be used after calling insert or insert_from_string, so
2487 we don't care if it gets trashed. */
2489 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
2490 doc
: /* Insert the arguments, either strings or characters, at point.
2491 Point and before-insertion markers move forward to end up
2492 after the inserted text.
2493 Any other markers at the point of insertion remain before the text.
2495 If the current buffer is multibyte, unibyte strings are converted
2496 to multibyte for insertion (see `string-make-multibyte').
2497 If the current buffer is unibyte, multibyte strings are converted
2498 to unibyte for insertion (see `string-make-unibyte').
2500 When operating on binary data, it may be necessary to preserve the
2501 original bytes of a unibyte string when inserting it into a multibyte
2502 buffer; to accomplish this, apply `string-as-multibyte' to the string
2503 and insert the result.
2505 usage: (insert &rest ARGS) */)
2506 (ptrdiff_t nargs
, Lisp_Object
*args
)
2508 general_insert_function (insert
, insert_from_string
, 0, nargs
, args
);
2512 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
2514 doc
: /* Insert the arguments at point, inheriting properties from adjoining text.
2515 Point and before-insertion markers move forward to end up
2516 after the inserted text.
2517 Any other markers at the point of insertion remain before the text.
2519 If the current buffer is multibyte, unibyte strings are converted
2520 to multibyte for insertion (see `unibyte-char-to-multibyte').
2521 If the current buffer is unibyte, multibyte strings are converted
2522 to unibyte for insertion.
2524 usage: (insert-and-inherit &rest ARGS) */)
2525 (ptrdiff_t nargs
, Lisp_Object
*args
)
2527 general_insert_function (insert_and_inherit
, insert_from_string
, 1,
2532 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
2533 doc
: /* Insert strings or characters at point, relocating markers after the text.
2534 Point and markers move forward to end up after the inserted text.
2536 If the current buffer is multibyte, unibyte strings are converted
2537 to multibyte for insertion (see `unibyte-char-to-multibyte').
2538 If the current buffer is unibyte, multibyte strings are converted
2539 to unibyte for insertion.
2541 If an overlay begins at the insertion point, the inserted text falls
2542 outside the overlay; if a nonempty overlay ends at the insertion
2543 point, the inserted text falls inside that overlay.
2545 usage: (insert-before-markers &rest ARGS) */)
2546 (ptrdiff_t nargs
, Lisp_Object
*args
)
2548 general_insert_function (insert_before_markers
,
2549 insert_from_string_before_markers
, 0,
2554 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers
,
2555 Sinsert_and_inherit_before_markers
, 0, MANY
, 0,
2556 doc
: /* Insert text at point, relocating markers and inheriting properties.
2557 Point and markers move forward to end up after the inserted text.
2559 If the current buffer is multibyte, unibyte strings are converted
2560 to multibyte for insertion (see `unibyte-char-to-multibyte').
2561 If the current buffer is unibyte, multibyte strings are converted
2562 to unibyte for insertion.
2564 usage: (insert-before-markers-and-inherit &rest ARGS) */)
2565 (ptrdiff_t nargs
, Lisp_Object
*args
)
2567 general_insert_function (insert_before_markers_and_inherit
,
2568 insert_from_string_before_markers
, 1,
2573 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 1, 3,
2574 "(list (read-char-by-name \"Insert character (Unicode name or hex): \")\
2575 (prefix-numeric-value current-prefix-arg)\
2577 doc
: /* Insert COUNT copies of CHARACTER.
2578 Interactively, prompt for CHARACTER. You can specify CHARACTER in one
2581 - As its Unicode character name, e.g. \"LATIN SMALL LETTER A\".
2582 Completion is available; if you type a substring of the name
2583 preceded by an asterisk `*', Emacs shows all names which include
2584 that substring, not necessarily at the beginning of the name.
2586 - As a hexadecimal code point, e.g. 263A. Note that code points in
2587 Emacs are equivalent to Unicode up to 10FFFF (which is the limit of
2588 the Unicode code space).
2590 - As a code point with a radix specified with #, e.g. #o21430
2591 (octal), #x2318 (hex), or #10r8984 (decimal).
2593 If called interactively, COUNT is given by the prefix argument. If
2594 omitted or nil, it defaults to 1.
2596 Inserting the character(s) relocates point and before-insertion
2597 markers in the same ways as the function `insert'.
2599 The optional third argument INHERIT, if non-nil, says to inherit text
2600 properties from adjoining text, if those properties are sticky. If
2601 called interactively, INHERIT is t. */)
2602 (Lisp_Object character
, Lisp_Object count
, Lisp_Object inherit
)
2605 register ptrdiff_t n
;
2607 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2610 CHECK_CHARACTER (character
);
2612 XSETFASTINT (count
, 1);
2613 CHECK_NUMBER (count
);
2614 c
= XFASTINT (character
);
2616 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2617 len
= CHAR_STRING (c
, str
);
2619 str
[0] = c
, len
= 1;
2620 if (XINT (count
) <= 0)
2622 if (BUF_BYTES_MAX
/ len
< XINT (count
))
2624 n
= XINT (count
) * len
;
2625 stringlen
= min (n
, sizeof string
- sizeof string
% len
);
2626 for (i
= 0; i
< stringlen
; i
++)
2627 string
[i
] = str
[i
% len
];
2628 while (n
> stringlen
)
2631 if (!NILP (inherit
))
2632 insert_and_inherit (string
, stringlen
);
2634 insert (string
, stringlen
);
2637 if (!NILP (inherit
))
2638 insert_and_inherit (string
, n
);
2644 DEFUN ("insert-byte", Finsert_byte
, Sinsert_byte
, 2, 3, 0,
2645 doc
: /* Insert COUNT (second arg) copies of BYTE (first arg).
2646 Both arguments are required.
2647 BYTE is a number of the range 0..255.
2649 If BYTE is 128..255 and the current buffer is multibyte, the
2650 corresponding eight-bit character is inserted.
2652 Point, and before-insertion markers, are relocated as in the function `insert'.
2653 The optional third arg INHERIT, if non-nil, says to inherit text properties
2654 from adjoining text, if those properties are sticky. */)
2655 (Lisp_Object byte
, Lisp_Object count
, Lisp_Object inherit
)
2657 CHECK_NUMBER (byte
);
2658 if (XINT (byte
) < 0 || XINT (byte
) > 255)
2659 args_out_of_range_3 (byte
, make_number (0), make_number (255));
2660 if (XINT (byte
) >= 128
2661 && ! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2662 XSETFASTINT (byte
, BYTE8_TO_CHAR (XINT (byte
)));
2663 return Finsert_char (byte
, count
, inherit
);
2667 /* Making strings from buffer contents. */
2669 /* Return a Lisp_String containing the text of the current buffer from
2670 START to END. If text properties are in use and the current buffer
2671 has properties in the range specified, the resulting string will also
2672 have them, if PROPS is true.
2674 We don't want to use plain old make_string here, because it calls
2675 make_uninit_string, which can cause the buffer arena to be
2676 compacted. make_string has no way of knowing that the data has
2677 been moved, and thus copies the wrong data into the string. This
2678 doesn't effect most of the other users of make_string, so it should
2679 be left as is. But we should use this function when conjuring
2680 buffer substrings. */
2683 make_buffer_string (ptrdiff_t start
, ptrdiff_t end
, bool props
)
2685 ptrdiff_t start_byte
= CHAR_TO_BYTE (start
);
2686 ptrdiff_t end_byte
= CHAR_TO_BYTE (end
);
2688 return make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
);
2691 /* Return a Lisp_String containing the text of the current buffer from
2692 START / START_BYTE to END / END_BYTE.
2694 If text properties are in use and the current buffer
2695 has properties in the range specified, the resulting string will also
2696 have them, if PROPS is true.
2698 We don't want to use plain old make_string here, because it calls
2699 make_uninit_string, which can cause the buffer arena to be
2700 compacted. make_string has no way of knowing that the data has
2701 been moved, and thus copies the wrong data into the string. This
2702 doesn't effect most of the other users of make_string, so it should
2703 be left as is. But we should use this function when conjuring
2704 buffer substrings. */
2707 make_buffer_string_both (ptrdiff_t start
, ptrdiff_t start_byte
,
2708 ptrdiff_t end
, ptrdiff_t end_byte
, bool props
)
2710 Lisp_Object result
, tem
, tem1
;
2711 ptrdiff_t beg0
, end0
, beg1
, end1
, size
;
2713 if (start_byte
< GPT_BYTE
&& GPT_BYTE
< end_byte
)
2715 /* Two regions, before and after the gap. */
2718 beg1
= GPT_BYTE
+ GAP_SIZE
- BEG_BYTE
;
2719 end1
= end_byte
+ GAP_SIZE
- BEG_BYTE
;
2723 /* The only region. */
2730 if (! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2731 result
= make_uninit_multibyte_string (end
- start
, end_byte
- start_byte
);
2733 result
= make_uninit_string (end
- start
);
2736 memcpy (SDATA (result
), BYTE_POS_ADDR (beg0
), size
);
2738 memcpy (SDATA (result
) + size
, BEG_ADDR
+ beg1
, end1
- beg1
);
2740 /* If desired, update and copy the text properties. */
2743 update_buffer_properties (start
, end
);
2745 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
2746 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
2748 if (XINT (tem
) != end
|| !NILP (tem1
))
2749 copy_intervals_to_string (result
, current_buffer
, start
,
2756 /* Call Vbuffer_access_fontify_functions for the range START ... END
2757 in the current buffer, if necessary. */
2760 update_buffer_properties (ptrdiff_t start
, ptrdiff_t end
)
2762 /* If this buffer has some access functions,
2763 call them, specifying the range of the buffer being accessed. */
2764 if (!NILP (Vbuffer_access_fontify_functions
))
2766 /* But don't call them if we can tell that the work
2767 has already been done. */
2768 if (!NILP (Vbuffer_access_fontified_property
))
2771 = Ftext_property_any (make_number (start
), make_number (end
),
2772 Vbuffer_access_fontified_property
,
2778 CALLN (Frun_hook_with_args
, Qbuffer_access_fontify_functions
,
2779 make_number (start
), make_number (end
));
2783 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
2784 doc
: /* Return the contents of part of the current buffer as a string.
2785 The two arguments START and END are character positions;
2786 they can be in either order.
2787 The string returned is multibyte if the buffer is multibyte.
2789 This function copies the text properties of that part of the buffer
2790 into the result string; if you don't want the text properties,
2791 use `buffer-substring-no-properties' instead. */)
2792 (Lisp_Object start
, Lisp_Object end
)
2794 register ptrdiff_t b
, e
;
2796 validate_region (&start
, &end
);
2800 return make_buffer_string (b
, e
, 1);
2803 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties
,
2804 Sbuffer_substring_no_properties
, 2, 2, 0,
2805 doc
: /* Return the characters of part of the buffer, without the text properties.
2806 The two arguments START and END are character positions;
2807 they can be in either order. */)
2808 (Lisp_Object start
, Lisp_Object end
)
2810 register ptrdiff_t b
, e
;
2812 validate_region (&start
, &end
);
2816 return make_buffer_string (b
, e
, 0);
2819 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
2820 doc
: /* Return the contents of the current buffer as a string.
2821 If narrowing is in effect, this function returns only the visible part
2825 return make_buffer_string_both (BEGV
, BEGV_BYTE
, ZV
, ZV_BYTE
, 1);
2828 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
2830 doc
: /* Insert before point a substring of the contents of BUFFER.
2831 BUFFER may be a buffer or a buffer name.
2832 Arguments START and END are character positions specifying the substring.
2833 They default to the values of (point-min) and (point-max) in BUFFER.
2835 Point and before-insertion markers move forward to end up after the
2837 Any other markers at the point of insertion remain before the text.
2839 If the current buffer is multibyte and BUFFER is unibyte, or vice
2840 versa, strings are converted from unibyte to multibyte or vice versa
2841 using `string-make-multibyte' or `string-make-unibyte', which see. */)
2842 (Lisp_Object buffer
, Lisp_Object start
, Lisp_Object end
)
2844 register EMACS_INT b
, e
, temp
;
2845 register struct buffer
*bp
, *obuf
;
2848 buf
= Fget_buffer (buffer
);
2852 if (!BUFFER_LIVE_P (bp
))
2853 error ("Selecting deleted buffer");
2859 CHECK_NUMBER_COERCE_MARKER (start
);
2866 CHECK_NUMBER_COERCE_MARKER (end
);
2871 temp
= b
, b
= e
, e
= temp
;
2873 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
2874 args_out_of_range (start
, end
);
2876 obuf
= current_buffer
;
2877 set_buffer_internal_1 (bp
);
2878 update_buffer_properties (b
, e
);
2879 set_buffer_internal_1 (obuf
);
2881 insert_from_buffer (bp
, b
, e
- b
, 0);
2885 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
2887 doc
: /* Compare two substrings of two buffers; return result as number.
2888 Return -N if first string is less after N-1 chars, +N if first string is
2889 greater after N-1 chars, or 0 if strings match. Each substring is
2890 represented as three arguments: BUFFER, START and END. That makes six
2891 args in all, three for each substring.
2893 The value of `case-fold-search' in the current buffer
2894 determines whether case is significant or ignored. */)
2895 (Lisp_Object buffer1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object buffer2
, Lisp_Object start2
, Lisp_Object end2
)
2897 register EMACS_INT begp1
, endp1
, begp2
, endp2
, temp
;
2898 register struct buffer
*bp1
, *bp2
;
2899 register Lisp_Object trt
2900 = (!NILP (BVAR (current_buffer
, case_fold_search
))
2901 ? BVAR (current_buffer
, case_canon_table
) : Qnil
);
2902 ptrdiff_t chars
= 0;
2903 ptrdiff_t i1
, i2
, i1_byte
, i2_byte
;
2905 /* Find the first buffer and its substring. */
2908 bp1
= current_buffer
;
2912 buf1
= Fget_buffer (buffer1
);
2915 bp1
= XBUFFER (buf1
);
2916 if (!BUFFER_LIVE_P (bp1
))
2917 error ("Selecting deleted buffer");
2921 begp1
= BUF_BEGV (bp1
);
2924 CHECK_NUMBER_COERCE_MARKER (start1
);
2925 begp1
= XINT (start1
);
2928 endp1
= BUF_ZV (bp1
);
2931 CHECK_NUMBER_COERCE_MARKER (end1
);
2932 endp1
= XINT (end1
);
2936 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
2938 if (!(BUF_BEGV (bp1
) <= begp1
2940 && endp1
<= BUF_ZV (bp1
)))
2941 args_out_of_range (start1
, end1
);
2943 /* Likewise for second substring. */
2946 bp2
= current_buffer
;
2950 buf2
= Fget_buffer (buffer2
);
2953 bp2
= XBUFFER (buf2
);
2954 if (!BUFFER_LIVE_P (bp2
))
2955 error ("Selecting deleted buffer");
2959 begp2
= BUF_BEGV (bp2
);
2962 CHECK_NUMBER_COERCE_MARKER (start2
);
2963 begp2
= XINT (start2
);
2966 endp2
= BUF_ZV (bp2
);
2969 CHECK_NUMBER_COERCE_MARKER (end2
);
2970 endp2
= XINT (end2
);
2974 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
2976 if (!(BUF_BEGV (bp2
) <= begp2
2978 && endp2
<= BUF_ZV (bp2
)))
2979 args_out_of_range (start2
, end2
);
2983 i1_byte
= buf_charpos_to_bytepos (bp1
, i1
);
2984 i2_byte
= buf_charpos_to_bytepos (bp2
, i2
);
2986 while (i1
< endp1
&& i2
< endp2
)
2988 /* When we find a mismatch, we must compare the
2989 characters, not just the bytes. */
2994 if (! NILP (BVAR (bp1
, enable_multibyte_characters
)))
2996 c1
= BUF_FETCH_MULTIBYTE_CHAR (bp1
, i1_byte
);
2997 BUF_INC_POS (bp1
, i1_byte
);
3002 c1
= BUF_FETCH_BYTE (bp1
, i1
);
3003 MAKE_CHAR_MULTIBYTE (c1
);
3007 if (! NILP (BVAR (bp2
, enable_multibyte_characters
)))
3009 c2
= BUF_FETCH_MULTIBYTE_CHAR (bp2
, i2_byte
);
3010 BUF_INC_POS (bp2
, i2_byte
);
3015 c2
= BUF_FETCH_BYTE (bp2
, i2
);
3016 MAKE_CHAR_MULTIBYTE (c2
);
3022 c1
= char_table_translate (trt
, c1
);
3023 c2
= char_table_translate (trt
, c2
);
3026 return make_number (- 1 - chars
);
3028 return make_number (chars
+ 1);
3033 /* The strings match as far as they go.
3034 If one is shorter, that one is less. */
3035 if (chars
< endp1
- begp1
)
3036 return make_number (chars
+ 1);
3037 else if (chars
< endp2
- begp2
)
3038 return make_number (- chars
- 1);
3040 /* Same length too => they are equal. */
3041 return make_number (0);
3045 subst_char_in_region_unwind (Lisp_Object arg
)
3047 bset_undo_list (current_buffer
, arg
);
3051 subst_char_in_region_unwind_1 (Lisp_Object arg
)
3053 bset_filename (current_buffer
, arg
);
3056 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
3057 Ssubst_char_in_region
, 4, 5, 0,
3058 doc
: /* From START to END, replace FROMCHAR with TOCHAR each time it occurs.
3059 If optional arg NOUNDO is non-nil, don't record this change for undo
3060 and don't mark the buffer as really changed.
3061 Both characters must have the same length of multi-byte form. */)
3062 (Lisp_Object start
, Lisp_Object end
, Lisp_Object fromchar
, Lisp_Object tochar
, Lisp_Object noundo
)
3064 register ptrdiff_t pos
, pos_byte
, stop
, i
, len
, end_byte
;
3065 /* Keep track of the first change in the buffer:
3066 if 0 we haven't found it yet.
3067 if < 0 we've found it and we've run the before-change-function.
3068 if > 0 we've actually performed it and the value is its position. */
3069 ptrdiff_t changed
= 0;
3070 unsigned char fromstr
[MAX_MULTIBYTE_LENGTH
], tostr
[MAX_MULTIBYTE_LENGTH
];
3072 ptrdiff_t count
= SPECPDL_INDEX ();
3073 #define COMBINING_NO 0
3074 #define COMBINING_BEFORE 1
3075 #define COMBINING_AFTER 2
3076 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
3077 int maybe_byte_combining
= COMBINING_NO
;
3078 ptrdiff_t last_changed
= 0;
3080 = !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3085 validate_region (&start
, &end
);
3086 CHECK_CHARACTER (fromchar
);
3087 CHECK_CHARACTER (tochar
);
3088 fromc
= XFASTINT (fromchar
);
3089 toc
= XFASTINT (tochar
);
3093 len
= CHAR_STRING (fromc
, fromstr
);
3094 if (CHAR_STRING (toc
, tostr
) != len
)
3095 error ("Characters in `subst-char-in-region' have different byte-lengths");
3096 if (!ASCII_CHAR_P (*tostr
))
3098 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
3099 complete multibyte character, it may be combined with the
3100 after bytes. If it is in the range 0xA0..0xFF, it may be
3101 combined with the before and after bytes. */
3102 if (!CHAR_HEAD_P (*tostr
))
3103 maybe_byte_combining
= COMBINING_BOTH
;
3104 else if (BYTES_BY_CHAR_HEAD (*tostr
) > len
)
3105 maybe_byte_combining
= COMBINING_AFTER
;
3116 pos_byte
= CHAR_TO_BYTE (pos
);
3117 stop
= CHAR_TO_BYTE (XINT (end
));
3120 /* If we don't want undo, turn off putting stuff on the list.
3121 That's faster than getting rid of things,
3122 and it prevents even the entry for a first change.
3123 Also inhibit locking the file. */
3124 if (!changed
&& !NILP (noundo
))
3126 record_unwind_protect (subst_char_in_region_unwind
,
3127 BVAR (current_buffer
, undo_list
));
3128 bset_undo_list (current_buffer
, Qt
);
3129 /* Don't do file-locking. */
3130 record_unwind_protect (subst_char_in_region_unwind_1
,
3131 BVAR (current_buffer
, filename
));
3132 bset_filename (current_buffer
, Qnil
);
3135 if (pos_byte
< GPT_BYTE
)
3136 stop
= min (stop
, GPT_BYTE
);
3139 ptrdiff_t pos_byte_next
= pos_byte
;
3141 if (pos_byte
>= stop
)
3143 if (pos_byte
>= end_byte
) break;
3146 p
= BYTE_POS_ADDR (pos_byte
);
3148 INC_POS (pos_byte_next
);
3151 if (pos_byte_next
- pos_byte
== len
3152 && p
[0] == fromstr
[0]
3154 || (p
[1] == fromstr
[1]
3155 && (len
== 2 || (p
[2] == fromstr
[2]
3156 && (len
== 3 || p
[3] == fromstr
[3]))))))
3159 /* We've already seen this and run the before-change-function;
3160 this time we only need to record the actual position. */
3165 modify_text (pos
, XINT (end
));
3167 if (! NILP (noundo
))
3169 if (MODIFF
- 1 == SAVE_MODIFF
)
3171 if (MODIFF
- 1 == BUF_AUTOSAVE_MODIFF (current_buffer
))
3172 BUF_AUTOSAVE_MODIFF (current_buffer
)++;
3175 /* The before-change-function may have moved the gap
3176 or even modified the buffer so we should start over. */
3180 /* Take care of the case where the new character
3181 combines with neighboring bytes. */
3182 if (maybe_byte_combining
3183 && (maybe_byte_combining
== COMBINING_AFTER
3184 ? (pos_byte_next
< Z_BYTE
3185 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
3186 : ((pos_byte_next
< Z_BYTE
3187 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
3188 || (pos_byte
> BEG_BYTE
3189 && ! ASCII_CHAR_P (FETCH_BYTE (pos_byte
- 1))))))
3191 Lisp_Object tem
, string
;
3193 struct gcpro gcpro1
;
3195 tem
= BVAR (current_buffer
, undo_list
);
3198 /* Make a multibyte string containing this single character. */
3199 string
= make_multibyte_string ((char *) tostr
, 1, len
);
3200 /* replace_range is less efficient, because it moves the gap,
3201 but it handles combining correctly. */
3202 replace_range (pos
, pos
+ 1, string
,
3204 pos_byte_next
= CHAR_TO_BYTE (pos
);
3205 if (pos_byte_next
> pos_byte
)
3206 /* Before combining happened. We should not increment
3207 POS. So, to cancel the later increment of POS,
3211 INC_POS (pos_byte_next
);
3213 if (! NILP (noundo
))
3214 bset_undo_list (current_buffer
, tem
);
3221 record_change (pos
, 1);
3222 for (i
= 0; i
< len
; i
++) *p
++ = tostr
[i
];
3224 last_changed
= pos
+ 1;
3226 pos_byte
= pos_byte_next
;
3232 signal_after_change (changed
,
3233 last_changed
- changed
, last_changed
- changed
);
3234 update_compositions (changed
, last_changed
, CHECK_ALL
);
3237 unbind_to (count
, Qnil
);
3242 static Lisp_Object
check_translation (ptrdiff_t, ptrdiff_t, ptrdiff_t,
3245 /* Helper function for Ftranslate_region_internal.
3247 Check if a character sequence at POS (POS_BYTE) matches an element
3248 of VAL. VAL is a list (([FROM-CHAR ...] . TO) ...). If a matching
3249 element is found, return it. Otherwise return Qnil. */
3252 check_translation (ptrdiff_t pos
, ptrdiff_t pos_byte
, ptrdiff_t end
,
3255 int initial_buf
[16];
3256 int *buf
= initial_buf
;
3257 ptrdiff_t buf_size
= ARRAYELTS (initial_buf
);
3259 ptrdiff_t buf_used
= 0;
3260 Lisp_Object result
= Qnil
;
3262 for (; CONSP (val
); val
= XCDR (val
))
3271 if (! VECTORP (elt
))
3274 if (len
<= end
- pos
)
3276 for (i
= 0; i
< len
; i
++)
3280 unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
3283 if (buf_used
== buf_size
)
3285 bufalloc
= xpalloc (bufalloc
, &buf_size
, 1, -1,
3287 if (buf
== initial_buf
)
3288 memcpy (bufalloc
, buf
, sizeof initial_buf
);
3291 buf
[buf_used
++] = STRING_CHAR_AND_LENGTH (p
, len1
);
3294 if (XINT (AREF (elt
, i
)) != buf
[i
])
3299 result
= XCAR (val
);
3310 DEFUN ("translate-region-internal", Ftranslate_region_internal
,
3311 Stranslate_region_internal
, 3, 3, 0,
3312 doc
: /* Internal use only.
3313 From START to END, translate characters according to TABLE.
3314 TABLE is a string or a char-table; the Nth character in it is the
3315 mapping for the character with code N.
3316 It returns the number of characters changed. */)
3317 (Lisp_Object start
, Lisp_Object end
, register Lisp_Object table
)
3319 register unsigned char *tt
; /* Trans table. */
3320 register int nc
; /* New character. */
3321 int cnt
; /* Number of changes made. */
3322 ptrdiff_t size
; /* Size of translate table. */
3323 ptrdiff_t pos
, pos_byte
, end_pos
;
3324 bool multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3325 bool string_multibyte
IF_LINT (= 0);
3327 validate_region (&start
, &end
);
3328 if (CHAR_TABLE_P (table
))
3330 if (! EQ (XCHAR_TABLE (table
)->purpose
, Qtranslation_table
))
3331 error ("Not a translation table");
3337 CHECK_STRING (table
);
3339 if (! multibyte
&& (SCHARS (table
) < SBYTES (table
)))
3340 table
= string_make_unibyte (table
);
3341 string_multibyte
= SCHARS (table
) < SBYTES (table
);
3342 size
= SBYTES (table
);
3347 pos_byte
= CHAR_TO_BYTE (pos
);
3348 end_pos
= XINT (end
);
3349 modify_text (pos
, end_pos
);
3352 for (; pos
< end_pos
; )
3354 register unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
3355 unsigned char *str
, buf
[MAX_MULTIBYTE_LENGTH
];
3361 oc
= STRING_CHAR_AND_LENGTH (p
, len
);
3368 /* Reload as signal_after_change in last iteration may GC. */
3370 if (string_multibyte
)
3372 str
= tt
+ string_char_to_byte (table
, oc
);
3373 nc
= STRING_CHAR_AND_LENGTH (str
, str_len
);
3378 if (! ASCII_CHAR_P (nc
) && multibyte
)
3380 str_len
= BYTE8_STRING (nc
, buf
);
3393 val
= CHAR_TABLE_REF (table
, oc
);
3394 if (CHARACTERP (val
))
3396 nc
= XFASTINT (val
);
3397 str_len
= CHAR_STRING (nc
, buf
);
3400 else if (VECTORP (val
) || (CONSP (val
)))
3402 /* VAL is [TO_CHAR ...] or (([FROM-CHAR ...] . TO) ...)
3403 where TO is TO-CHAR or [TO-CHAR ...]. */
3408 if (nc
!= oc
&& nc
>= 0)
3410 /* Simple one char to one char translation. */
3415 /* This is less efficient, because it moves the gap,
3416 but it should handle multibyte characters correctly. */
3417 string
= make_multibyte_string ((char *) str
, 1, str_len
);
3418 replace_range (pos
, pos
+ 1, string
, 1, 0, 1);
3423 record_change (pos
, 1);
3424 while (str_len
-- > 0)
3426 signal_after_change (pos
, 1, 1);
3427 update_compositions (pos
, pos
+ 1, CHECK_BORDER
);
3437 val
= check_translation (pos
, pos_byte
, end_pos
, val
);
3444 /* VAL is ([FROM-CHAR ...] . TO). */
3445 len
= ASIZE (XCAR (val
));
3453 string
= Fconcat (1, &val
);
3457 string
= Fmake_string (make_number (1), val
);
3459 replace_range (pos
, pos
+ len
, string
, 1, 0, 1);
3460 pos_byte
+= SBYTES (string
);
3461 pos
+= SCHARS (string
);
3462 cnt
+= SCHARS (string
);
3463 end_pos
+= SCHARS (string
) - len
;
3471 return make_number (cnt
);
3474 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
3475 doc
: /* Delete the text between START and END.
3476 If called interactively, delete the region between point and mark.
3477 This command deletes buffer text without modifying the kill ring. */)
3478 (Lisp_Object start
, Lisp_Object end
)
3480 validate_region (&start
, &end
);
3481 del_range (XINT (start
), XINT (end
));
3485 DEFUN ("delete-and-extract-region", Fdelete_and_extract_region
,
3486 Sdelete_and_extract_region
, 2, 2, 0,
3487 doc
: /* Delete the text between START and END and return it. */)
3488 (Lisp_Object start
, Lisp_Object end
)
3490 validate_region (&start
, &end
);
3491 if (XINT (start
) == XINT (end
))
3492 return empty_unibyte_string
;
3493 return del_range_1 (XINT (start
), XINT (end
), 1, 1);
3496 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
3497 doc
: /* Remove restrictions (narrowing) from current buffer.
3498 This allows the buffer's full text to be seen and edited. */)
3501 if (BEG
!= BEGV
|| Z
!= ZV
)
3502 current_buffer
->clip_changed
= 1;
3504 BEGV_BYTE
= BEG_BYTE
;
3505 SET_BUF_ZV_BOTH (current_buffer
, Z
, Z_BYTE
);
3506 /* Changing the buffer bounds invalidates any recorded current column. */
3507 invalidate_current_column ();
3511 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
3512 doc
: /* Restrict editing in this buffer to the current region.
3513 The rest of the text becomes temporarily invisible and untouchable
3514 but is not deleted; if you save the buffer in a file, the invisible
3515 text is included in the file. \\[widen] makes all visible again.
3516 See also `save-restriction'.
3518 When calling from a program, pass two arguments; positions (integers
3519 or markers) bounding the text that should remain visible. */)
3520 (register Lisp_Object start
, Lisp_Object end
)
3522 CHECK_NUMBER_COERCE_MARKER (start
);
3523 CHECK_NUMBER_COERCE_MARKER (end
);
3525 if (XINT (start
) > XINT (end
))
3528 tem
= start
; start
= end
; end
= tem
;
3531 if (!(BEG
<= XINT (start
) && XINT (start
) <= XINT (end
) && XINT (end
) <= Z
))
3532 args_out_of_range (start
, end
);
3534 if (BEGV
!= XFASTINT (start
) || ZV
!= XFASTINT (end
))
3535 current_buffer
->clip_changed
= 1;
3537 SET_BUF_BEGV (current_buffer
, XFASTINT (start
));
3538 SET_BUF_ZV (current_buffer
, XFASTINT (end
));
3539 if (PT
< XFASTINT (start
))
3540 SET_PT (XFASTINT (start
));
3541 if (PT
> XFASTINT (end
))
3542 SET_PT (XFASTINT (end
));
3543 /* Changing the buffer bounds invalidates any recorded current column. */
3544 invalidate_current_column ();
3549 save_restriction_save (void)
3551 if (BEGV
== BEG
&& ZV
== Z
)
3552 /* The common case that the buffer isn't narrowed.
3553 We return just the buffer object, which save_restriction_restore
3554 recognizes as meaning `no restriction'. */
3555 return Fcurrent_buffer ();
3557 /* We have to save a restriction, so return a pair of markers, one
3558 for the beginning and one for the end. */
3560 Lisp_Object beg
, end
;
3562 beg
= build_marker (current_buffer
, BEGV
, BEGV_BYTE
);
3563 end
= build_marker (current_buffer
, ZV
, ZV_BYTE
);
3565 /* END must move forward if text is inserted at its exact location. */
3566 XMARKER (end
)->insertion_type
= 1;
3568 return Fcons (beg
, end
);
3573 save_restriction_restore (Lisp_Object data
)
3575 struct buffer
*cur
= NULL
;
3576 struct buffer
*buf
= (CONSP (data
)
3577 ? XMARKER (XCAR (data
))->buffer
3580 if (buf
&& buf
!= current_buffer
&& !NILP (BVAR (buf
, pt_marker
)))
3581 { /* If `buf' uses markers to keep track of PT, BEGV, and ZV (as
3582 is the case if it is or has an indirect buffer), then make
3583 sure it is current before we update BEGV, so
3584 set_buffer_internal takes care of managing those markers. */
3585 cur
= current_buffer
;
3586 set_buffer_internal (buf
);
3590 /* A pair of marks bounding a saved restriction. */
3592 struct Lisp_Marker
*beg
= XMARKER (XCAR (data
));
3593 struct Lisp_Marker
*end
= XMARKER (XCDR (data
));
3594 eassert (buf
== end
->buffer
);
3596 if (buf
/* Verify marker still points to a buffer. */
3597 && (beg
->charpos
!= BUF_BEGV (buf
) || end
->charpos
!= BUF_ZV (buf
)))
3598 /* The restriction has changed from the saved one, so restore
3599 the saved restriction. */
3601 ptrdiff_t pt
= BUF_PT (buf
);
3603 SET_BUF_BEGV_BOTH (buf
, beg
->charpos
, beg
->bytepos
);
3604 SET_BUF_ZV_BOTH (buf
, end
->charpos
, end
->bytepos
);
3606 if (pt
< beg
->charpos
|| pt
> end
->charpos
)
3607 /* The point is outside the new visible range, move it inside. */
3608 SET_BUF_PT_BOTH (buf
,
3609 clip_to_bounds (beg
->charpos
, pt
, end
->charpos
),
3610 clip_to_bounds (beg
->bytepos
, BUF_PT_BYTE (buf
),
3613 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3615 /* These aren't needed anymore, so don't wait for GC. */
3616 free_marker (XCAR (data
));
3617 free_marker (XCDR (data
));
3618 free_cons (XCONS (data
));
3621 /* A buffer, which means that there was no old restriction. */
3623 if (buf
/* Verify marker still points to a buffer. */
3624 && (BUF_BEGV (buf
) != BUF_BEG (buf
) || BUF_ZV (buf
) != BUF_Z (buf
)))
3625 /* The buffer has been narrowed, get rid of the narrowing. */
3627 SET_BUF_BEGV_BOTH (buf
, BUF_BEG (buf
), BUF_BEG_BYTE (buf
));
3628 SET_BUF_ZV_BOTH (buf
, BUF_Z (buf
), BUF_Z_BYTE (buf
));
3630 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3634 /* Changing the buffer bounds invalidates any recorded current column. */
3635 invalidate_current_column ();
3638 set_buffer_internal (cur
);
3641 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
3642 doc
: /* Execute BODY, saving and restoring current buffer's restrictions.
3643 The buffer's restrictions make parts of the beginning and end invisible.
3644 \(They are set up with `narrow-to-region' and eliminated with `widen'.)
3645 This special form, `save-restriction', saves the current buffer's restrictions
3646 when it is entered, and restores them when it is exited.
3647 So any `narrow-to-region' within BODY lasts only until the end of the form.
3648 The old restrictions settings are restored
3649 even in case of abnormal exit (throw or error).
3651 The value returned is the value of the last form in BODY.
3653 Note: if you are using both `save-excursion' and `save-restriction',
3654 use `save-excursion' outermost:
3655 (save-excursion (save-restriction ...))
3657 usage: (save-restriction &rest BODY) */)
3660 register Lisp_Object val
;
3661 ptrdiff_t count
= SPECPDL_INDEX ();
3663 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
3664 val
= Fprogn (body
);
3665 return unbind_to (count
, val
);
3668 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
3669 doc
: /* Display a message at the bottom of the screen.
3670 The message also goes into the `*Messages*' buffer, if `message-log-max'
3671 is non-nil. (In keyboard macros, that's all it does.)
3674 In batch mode, the message is printed to the standard error stream,
3675 followed by a newline.
3677 The first argument is a format control string, and the rest are data
3678 to be formatted under control of the string. See `format' for details.
3680 Note: Use (message "%s" VALUE) to print the value of expressions and
3681 variables to avoid accidentally interpreting `%' as format specifiers.
3683 If the first argument is nil or the empty string, the function clears
3684 any existing message; this lets the minibuffer contents show. See
3685 also `current-message'.
3687 usage: (message FORMAT-STRING &rest ARGS) */)
3688 (ptrdiff_t nargs
, Lisp_Object
*args
)
3691 || (STRINGP (args
[0])
3692 && SBYTES (args
[0]) == 0))
3699 register Lisp_Object val
;
3700 val
= Fformat (nargs
, args
);
3706 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
3707 doc
: /* Display a message, in a dialog box if possible.
3708 If a dialog box is not available, use the echo area.
3709 The first argument is a format control string, and the rest are data
3710 to be formatted under control of the string. See `format' for details.
3712 If the first argument is nil or the empty string, clear any existing
3713 message; let the minibuffer contents show.
3715 usage: (message-box FORMAT-STRING &rest ARGS) */)
3716 (ptrdiff_t nargs
, Lisp_Object
*args
)
3725 Lisp_Object val
= Fformat (nargs
, args
);
3726 Lisp_Object pane
, menu
;
3727 struct gcpro gcpro1
;
3729 pane
= list1 (Fcons (build_string ("OK"), Qt
));
3731 menu
= Fcons (val
, pane
);
3732 Fx_popup_dialog (Qt
, menu
, Qt
);
3738 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
3739 doc
: /* Display a message in a dialog box or in the echo area.
3740 If this command was invoked with the mouse, use a dialog box if
3741 `use-dialog-box' is non-nil.
3742 Otherwise, use the echo area.
3743 The first argument is a format control string, and the rest are data
3744 to be formatted under control of the string. See `format' for details.
3746 If the first argument is nil or the empty string, clear any existing
3747 message; let the minibuffer contents show.
3749 usage: (message-or-box FORMAT-STRING &rest ARGS) */)
3750 (ptrdiff_t nargs
, Lisp_Object
*args
)
3752 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3754 return Fmessage_box (nargs
, args
);
3755 return Fmessage (nargs
, args
);
3758 DEFUN ("current-message", Fcurrent_message
, Scurrent_message
, 0, 0, 0,
3759 doc
: /* Return the string currently displayed in the echo area, or nil if none. */)
3762 return current_message ();
3766 DEFUN ("propertize", Fpropertize
, Spropertize
, 1, MANY
, 0,
3767 doc
: /* Return a copy of STRING with text properties added.
3768 First argument is the string to copy.
3769 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
3770 properties to add to the result.
3771 usage: (propertize STRING &rest PROPERTIES) */)
3772 (ptrdiff_t nargs
, Lisp_Object
*args
)
3774 Lisp_Object properties
, string
;
3775 struct gcpro gcpro1
, gcpro2
;
3778 /* Number of args must be odd. */
3779 if ((nargs
& 1) == 0)
3780 error ("Wrong number of arguments");
3782 properties
= string
= Qnil
;
3783 GCPRO2 (properties
, string
);
3785 /* First argument must be a string. */
3786 CHECK_STRING (args
[0]);
3787 string
= Fcopy_sequence (args
[0]);
3789 for (i
= 1; i
< nargs
; i
+= 2)
3790 properties
= Fcons (args
[i
], Fcons (args
[i
+ 1], properties
));
3792 Fadd_text_properties (make_number (0),
3793 make_number (SCHARS (string
)),
3794 properties
, string
);
3795 RETURN_UNGCPRO (string
);
3798 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
3799 doc
: /* Format a string out of a format-string and arguments.
3800 The first argument is a format control string.
3801 The other arguments are substituted into it to make the result, a string.
3803 The format control string may contain ordinary characters,
3804 %-sequences meaning to substitute the next available argument,
3805 and curved single quotation marks meaning to substitute quotes.
3807 %s means print a string argument. Actually, prints any object, with `princ'.
3808 %d means print as number in decimal (%o octal, %x hex).
3809 %X is like %x, but uses upper case.
3810 %e means print a number in exponential notation.
3811 %f means print a number in decimal-point notation.
3812 %g means print a number in exponential notation
3813 or decimal-point notation, whichever uses fewer characters.
3814 %c means print a number as a single character.
3815 %S means print any object as an s-expression (using `prin1').
3817 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
3818 Use %% to put a single % into the output.
3820 A %-sequence may contain optional flag, width, and precision
3821 specifiers, as follows:
3823 %<flags><width><precision>character
3825 where flags is [+ #-0]+, width is [0-9]+, and precision is .[0-9]+
3827 The + flag character inserts a + before any positive number, while a
3828 space inserts a space before any positive number; these flags only
3829 affect %d, %e, %f, and %g sequences, and the + flag takes precedence.
3830 The - and 0 flags affect the width specifier, as described below.
3832 The # flag means to use an alternate display form for %o, %x, %X, %e,
3833 %f, and %g sequences: for %o, it ensures that the result begins with
3834 \"0\"; for %x and %X, it prefixes the result with \"0x\" or \"0X\";
3835 for %e, %f, and %g, it causes a decimal point to be included even if
3836 the precision is zero.
3838 The width specifier supplies a lower limit for the length of the
3839 printed representation. The padding, if any, normally goes on the
3840 left, but it goes on the right if the - flag is present. The padding
3841 character is normally a space, but it is 0 if the 0 flag is present.
3842 The 0 flag is ignored if the - flag is present, or the format sequence
3843 is something other than %d, %e, %f, and %g.
3845 For %e, %f, and %g sequences, the number after the "." in the
3846 precision specifier says how many decimal places to show; if zero, the
3847 decimal point itself is omitted. For %s and %S, the precision
3848 specifier truncates the string to the given width.
3850 \\=‘ and \\=’ means print left and right quotes as per
3851 ‘text-quoting-style’.
3853 Return the first argument if it contains no format directives.
3854 Otherwise, return a new string.
3856 usage: (format STRING &rest OBJECTS) */)
3857 (ptrdiff_t nargs
, Lisp_Object
*args
)
3859 ptrdiff_t n
; /* The number of the next arg to substitute. */
3860 char initial_buffer
[4000];
3861 char *buf
= initial_buffer
;
3862 ptrdiff_t bufsize
= sizeof initial_buffer
;
3863 ptrdiff_t max_bufsize
= STRING_BYTES_BOUND
+ 1;
3865 ptrdiff_t buf_save_value_index
IF_LINT (= 0);
3866 char *format
, *end
, *format_start
;
3867 ptrdiff_t formatlen
, nchars
;
3868 bool changed
= false;
3869 /* True if the format is multibyte. */
3870 bool multibyte_format
= 0;
3871 /* True if the output should be a multibyte string,
3872 which is true if any of the inputs is one. */
3874 /* When we make a multibyte string, we must pay attention to the
3875 byte combining problem, i.e., a byte may be combined with a
3876 multibyte character of the previous string. This flag tells if we
3877 must consider such a situation or not. */
3878 bool maybe_combine_byte
;
3880 bool arg_intervals
= 0;
3883 /* discarded[I] is 1 if byte I of the format
3884 string was not copied into the output.
3885 It is 2 if byte I was not the first byte of its character. */
3888 /* Each element records, for one argument,
3889 the start and end bytepos in the output string,
3890 whether the argument has been converted to string (e.g., due to "%S"),
3891 and whether the argument is a string with intervals.
3892 info[0] is unused. Unused elements have -1 for start. */
3895 ptrdiff_t start
, end
;
3896 bool_bf converted_to_string
: 1;
3897 bool_bf intervals
: 1;
3900 /* It should not be necessary to GCPRO ARGS, because
3901 the caller in the interpreter should take care of that. */
3903 CHECK_STRING (args
[0]);
3904 format_start
= SSDATA (args
[0]);
3905 formatlen
= SBYTES (args
[0]);
3907 /* Allocate the info and discarded tables. */
3910 if ((SIZE_MAX
- formatlen
) / sizeof (struct info
) <= nargs
)
3911 memory_full (SIZE_MAX
);
3912 info
= SAFE_ALLOCA ((nargs
+ 1) * sizeof *info
+ formatlen
);
3913 discarded
= (char *) &info
[nargs
+ 1];
3914 for (i
= 0; i
< nargs
+ 1; i
++)
3917 info
[i
].intervals
= info
[i
].converted_to_string
= 0;
3919 memset (discarded
, 0, formatlen
);
3922 /* Try to determine whether the result should be multibyte.
3923 This is not always right; sometimes the result needs to be multibyte
3924 because of an object that we will pass through prin1,
3925 and in that case, we won't know it here. */
3926 multibyte_format
= STRING_MULTIBYTE (args
[0]);
3927 multibyte
= multibyte_format
;
3928 for (n
= 1; !multibyte
&& n
< nargs
; n
++)
3929 if (STRINGP (args
[n
]) && STRING_MULTIBYTE (args
[n
]))
3932 enum text_quoting_style quoting_style
= text_quoting_style ();
3934 /* If we start out planning a unibyte result,
3935 then discover it has to be multibyte, we jump back to retry. */
3942 /* Scan the format and store result in BUF. */
3943 format
= format_start
;
3944 end
= format
+ formatlen
;
3945 maybe_combine_byte
= 0;
3947 while (format
!= end
)
3949 /* The values of N and FORMAT when the loop body is entered. */
3951 char *format0
= format
;
3953 /* Bytes needed to represent the output of this conversion. */
3954 ptrdiff_t convbytes
;
3958 /* General format specifications look like
3960 '%' [flags] [field-width] [precision] format
3965 field-width ::= [0-9]+
3966 precision ::= '.' [0-9]*
3968 If a field-width is specified, it specifies to which width
3969 the output should be padded with blanks, if the output
3970 string is shorter than field-width.
3972 If precision is specified, it specifies the number of
3973 digits to print after the '.' for floats, or the max.
3974 number of chars to print from a string. */
3976 bool minus_flag
= 0;
3978 bool space_flag
= 0;
3979 bool sharp_flag
= 0;
3981 ptrdiff_t field_width
;
3982 bool precision_given
;
3983 uintmax_t precision
= UINTMAX_MAX
;
3991 case '-': minus_flag
= 1; continue;
3992 case '+': plus_flag
= 1; continue;
3993 case ' ': space_flag
= 1; continue;
3994 case '#': sharp_flag
= 1; continue;
3995 case '0': zero_flag
= 1; continue;
4000 /* Ignore flags when sprintf ignores them. */
4001 space_flag
&= ~ plus_flag
;
4002 zero_flag
&= ~ minus_flag
;
4005 uintmax_t w
= strtoumax (format
, &num_end
, 10);
4006 if (max_bufsize
<= w
)
4010 precision_given
= *num_end
== '.';
4011 if (precision_given
)
4012 precision
= strtoumax (num_end
+ 1, &num_end
, 10);
4016 error ("Format string ends in middle of format specifier");
4019 memset (&discarded
[format0
- format_start
], 1, format
- format0
);
4020 conversion
= *format
;
4021 if (conversion
== '%')
4023 discarded
[format
- format_start
] = 1;
4028 error ("Not enough arguments for format string");
4030 /* For 'S', prin1 the argument, and then treat like 's'.
4031 For 's', princ any argument that is not a string or
4032 symbol. But don't do this conversion twice, which might
4033 happen after retrying. */
4034 if ((conversion
== 'S'
4035 || (conversion
== 's'
4036 && ! STRINGP (args
[n
]) && ! SYMBOLP (args
[n
]))))
4038 if (! info
[n
].converted_to_string
)
4040 Lisp_Object noescape
= conversion
== 'S' ? Qnil
: Qt
;
4041 args
[n
] = Fprin1_to_string (args
[n
], noescape
);
4042 info
[n
].converted_to_string
= 1;
4043 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
4051 else if (conversion
== 'c')
4053 if (FLOATP (args
[n
]))
4055 double d
= XFLOAT_DATA (args
[n
]);
4056 args
[n
] = make_number (FIXNUM_OVERFLOW_P (d
) ? -1 : d
);
4059 if (INTEGERP (args
[n
]) && ! ASCII_CHAR_P (XINT (args
[n
])))
4066 args
[n
] = Fchar_to_string (args
[n
]);
4067 info
[n
].converted_to_string
= 1;
4070 if (info
[n
].converted_to_string
)
4075 if (SYMBOLP (args
[n
]))
4077 args
[n
] = SYMBOL_NAME (args
[n
]);
4078 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
4085 if (conversion
== 's')
4087 /* handle case (precision[n] >= 0) */
4089 ptrdiff_t width
, padding
, nbytes
;
4090 ptrdiff_t nchars_string
;
4092 ptrdiff_t prec
= -1;
4093 if (precision_given
&& precision
<= TYPE_MAXIMUM (ptrdiff_t))
4096 /* lisp_string_width ignores a precision of 0, but GNU
4097 libc functions print 0 characters when the precision
4098 is 0. Imitate libc behavior here. Changing
4099 lisp_string_width is the right thing, and will be
4100 done, but meanwhile we work with it. */
4103 width
= nchars_string
= nbytes
= 0;
4107 width
= lisp_string_width (args
[n
], prec
, &nch
, &nby
);
4110 nchars_string
= SCHARS (args
[n
]);
4111 nbytes
= SBYTES (args
[n
]);
4115 nchars_string
= nch
;
4121 if (convbytes
&& multibyte
&& ! STRING_MULTIBYTE (args
[n
]))
4122 convbytes
= count_size_as_multibyte (SDATA (args
[n
]), nbytes
);
4124 padding
= width
< field_width
? field_width
- width
: 0;
4126 if (max_bufsize
- padding
<= convbytes
)
4128 convbytes
+= padding
;
4129 if (convbytes
<= buf
+ bufsize
- p
)
4133 memset (p
, ' ', padding
);
4140 && !ASCII_CHAR_P (*((unsigned char *) p
- 1))
4141 && STRING_MULTIBYTE (args
[n
])
4142 && !CHAR_HEAD_P (SREF (args
[n
], 0)))
4143 maybe_combine_byte
= 1;
4145 p
+= copy_text (SDATA (args
[n
]), (unsigned char *) p
,
4147 STRING_MULTIBYTE (args
[n
]), multibyte
);
4149 info
[n
].start
= nchars
;
4150 nchars
+= nchars_string
;
4151 info
[n
].end
= nchars
;
4155 memset (p
, ' ', padding
);
4160 /* If this argument has text properties, record where
4161 in the result string it appears. */
4162 if (string_intervals (args
[n
]))
4163 info
[n
].intervals
= arg_intervals
= 1;
4168 else if (! (conversion
== 'c' || conversion
== 'd'
4169 || conversion
== 'e' || conversion
== 'f'
4170 || conversion
== 'g' || conversion
== 'i'
4171 || conversion
== 'o' || conversion
== 'x'
4172 || conversion
== 'X'))
4173 error ("Invalid format operation %%%c",
4174 STRING_CHAR ((unsigned char *) format
- 1));
4175 else if (! (INTEGERP (args
[n
]) || FLOATP (args
[n
])))
4176 error ("Format specifier doesn't match argument type");
4181 /* Maximum precision for a %f conversion such that the
4182 trailing output digit might be nonzero. Any precision
4183 larger than this will not yield useful information. */
4184 USEFUL_PRECISION_MAX
=
4186 * (FLT_RADIX
== 2 || FLT_RADIX
== 10 ? 1
4187 : FLT_RADIX
== 16 ? 4
4190 /* Maximum number of bytes generated by any format, if
4191 precision is no more than USEFUL_PRECISION_MAX.
4192 On all practical hosts, %f is the worst case. */
4194 sizeof "-." + (DBL_MAX_10_EXP
+ 1) + USEFUL_PRECISION_MAX
,
4196 /* Length of pM (that is, of pMd without the
4198 pMlen
= sizeof pMd
- 2
4200 verify (USEFUL_PRECISION_MAX
> 0);
4203 ptrdiff_t padding
, sprintf_bytes
;
4204 uintmax_t excess_precision
, numwidth
;
4205 uintmax_t leading_zeros
= 0, trailing_zeros
= 0;
4207 char sprintf_buf
[SPRINTF_BUFSIZE
];
4209 /* Copy of conversion specification, modified somewhat.
4210 At most three flags F can be specified at once. */
4211 char convspec
[sizeof "%FFF.*d" + pMlen
];
4213 /* Avoid undefined behavior in underlying sprintf. */
4214 if (conversion
== 'd' || conversion
== 'i')
4217 /* Create the copy of the conversion specification, with
4218 any width and precision removed, with ".*" inserted,
4219 and with pM inserted for integer formats. */
4223 *f
= '-'; f
+= minus_flag
;
4224 *f
= '+'; f
+= plus_flag
;
4225 *f
= ' '; f
+= space_flag
;
4226 *f
= '#'; f
+= sharp_flag
;
4227 *f
= '0'; f
+= zero_flag
;
4230 if (conversion
== 'd' || conversion
== 'i'
4231 || conversion
== 'o' || conversion
== 'x'
4232 || conversion
== 'X')
4234 memcpy (f
, pMd
, pMlen
);
4236 zero_flag
&= ~ precision_given
;
4243 if (precision_given
)
4244 prec
= min (precision
, USEFUL_PRECISION_MAX
);
4246 /* Use sprintf to format this number into sprintf_buf. Omit
4247 padding and excess precision, though, because sprintf limits
4248 output length to INT_MAX.
4250 There are four types of conversion: double, unsigned
4251 char (passed as int), wide signed int, and wide
4252 unsigned int. Treat them separately because the
4253 sprintf ABI is sensitive to which type is passed. Be
4254 careful about integer overflow, NaNs, infinities, and
4255 conversions; for example, the min and max macros are
4256 not suitable here. */
4257 if (conversion
== 'e' || conversion
== 'f' || conversion
== 'g')
4259 double x
= (INTEGERP (args
[n
])
4261 : XFLOAT_DATA (args
[n
]));
4262 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4264 else if (conversion
== 'c')
4266 /* Don't use sprintf here, as it might mishandle prec. */
4267 sprintf_buf
[0] = XINT (args
[n
]);
4268 sprintf_bytes
= prec
!= 0;
4270 else if (conversion
== 'd')
4272 /* For float, maybe we should use "%1.0f"
4273 instead so it also works for values outside
4274 the integer range. */
4276 if (INTEGERP (args
[n
]))
4280 double d
= XFLOAT_DATA (args
[n
]);
4283 x
= TYPE_MINIMUM (printmax_t
);
4289 x
= TYPE_MAXIMUM (printmax_t
);
4294 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4298 /* Don't sign-extend for octal or hex printing. */
4300 if (INTEGERP (args
[n
]))
4301 x
= XUINT (args
[n
]);
4304 double d
= XFLOAT_DATA (args
[n
]);
4309 x
= TYPE_MAXIMUM (uprintmax_t
);
4314 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4317 /* Now the length of the formatted item is known, except it omits
4318 padding and excess precision. Deal with excess precision
4319 first. This happens only when the format specifies
4320 ridiculously large precision. */
4321 excess_precision
= precision
- prec
;
4322 if (excess_precision
)
4324 if (conversion
== 'e' || conversion
== 'f'
4325 || conversion
== 'g')
4327 if ((conversion
== 'g' && ! sharp_flag
)
4328 || ! ('0' <= sprintf_buf
[sprintf_bytes
- 1]
4329 && sprintf_buf
[sprintf_bytes
- 1] <= '9'))
4330 excess_precision
= 0;
4333 if (conversion
== 'g')
4335 char *dot
= strchr (sprintf_buf
, '.');
4337 excess_precision
= 0;
4340 trailing_zeros
= excess_precision
;
4343 leading_zeros
= excess_precision
;
4346 /* Compute the total bytes needed for this item, including
4347 excess precision and padding. */
4348 numwidth
= sprintf_bytes
+ excess_precision
;
4349 padding
= numwidth
< field_width
? field_width
- numwidth
: 0;
4350 if (max_bufsize
- sprintf_bytes
<= excess_precision
4351 || max_bufsize
- padding
<= numwidth
)
4353 convbytes
= numwidth
+ padding
;
4355 if (convbytes
<= buf
+ bufsize
- p
)
4357 /* Copy the formatted item from sprintf_buf into buf,
4358 inserting padding and excess-precision zeros. */
4360 char *src
= sprintf_buf
;
4362 int exponent_bytes
= 0;
4363 bool signedp
= src0
== '-' || src0
== '+' || src0
== ' ';
4364 int significand_bytes
;
4366 && ((src
[signedp
] >= '0' && src
[signedp
] <= '9')
4367 || (src
[signedp
] >= 'a' && src
[signedp
] <= 'f')
4368 || (src
[signedp
] >= 'A' && src
[signedp
] <= 'F')))
4370 leading_zeros
+= padding
;
4374 if (excess_precision
4375 && (conversion
== 'e' || conversion
== 'g'))
4377 char *e
= strchr (src
, 'e');
4379 exponent_bytes
= src
+ sprintf_bytes
- e
;
4384 memset (p
, ' ', padding
);
4392 memset (p
, '0', leading_zeros
);
4394 significand_bytes
= sprintf_bytes
- signedp
- exponent_bytes
;
4395 memcpy (p
, src
, significand_bytes
);
4396 p
+= significand_bytes
;
4397 src
+= significand_bytes
;
4398 memset (p
, '0', trailing_zeros
);
4399 p
+= trailing_zeros
;
4400 memcpy (p
, src
, exponent_bytes
);
4401 p
+= exponent_bytes
;
4403 info
[n
].start
= nchars
;
4404 nchars
+= leading_zeros
+ sprintf_bytes
+ trailing_zeros
;
4405 info
[n
].end
= nchars
;
4409 memset (p
, ' ', padding
);
4421 /* Copy a single character from format to buf. */
4424 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
4426 if (multibyte_format
)
4428 /* Copy a whole multibyte character. */
4430 && !ASCII_CHAR_P (*((unsigned char *) p
- 1))
4431 && !CHAR_HEAD_P (*format
))
4432 maybe_combine_byte
= 1;
4436 while (! CHAR_HEAD_P (*format
));
4438 convbytes
= format
- src
;
4439 memset (&discarded
[src
+ 1 - format_start
], 2, convbytes
- 1);
4441 if (quoting_style
!= CURVE_QUOTING_STYLE
&& convbytes
== 3
4442 && (unsigned char) src
[0] == uLSQM0
4443 && (unsigned char) src
[1] == uLSQM1
4444 && ((unsigned char) src
[2] == uLSQM2
4445 || (unsigned char) src
[2] == uRSQM2
))
4448 str
[0] = (((unsigned char) src
[2] == uLSQM2
4449 && quoting_style
== GRAVE_QUOTING_STYLE
)
4457 unsigned char uc
= *format
++;
4458 if (! multibyte
|| ASCII_CHAR_P (uc
))
4462 int c
= BYTE8_TO_CHAR (uc
);
4463 convbytes
= CHAR_STRING (c
, str
);
4469 if (convbytes
<= buf
+ bufsize
- p
)
4471 memcpy (p
, src
, convbytes
);
4478 /* There wasn't enough room to store this conversion or single
4479 character. CONVBYTES says how much room is needed. Allocate
4480 enough room (and then some) and do it again. */
4482 ptrdiff_t used
= p
- buf
;
4484 if (max_bufsize
- used
< convbytes
)
4486 bufsize
= used
+ convbytes
;
4487 bufsize
= bufsize
< max_bufsize
/ 2 ? bufsize
* 2 : max_bufsize
;
4489 if (buf
== initial_buffer
)
4491 buf
= xmalloc (bufsize
);
4492 sa_must_free
= true;
4493 buf_save_value_index
= SPECPDL_INDEX ();
4494 record_unwind_protect_ptr (xfree
, buf
);
4495 memcpy (buf
, initial_buffer
, used
);
4499 buf
= xrealloc (buf
, bufsize
);
4500 set_unwind_protect_ptr (buf_save_value_index
, xfree
, buf
);
4510 if (bufsize
< p
- buf
)
4517 if (maybe_combine_byte
)
4518 nchars
= multibyte_chars_in_text ((unsigned char *) buf
, p
- buf
);
4519 val
= make_specified_string (buf
, nchars
, p
- buf
, multibyte
);
4521 /* If the format string has text properties, or any of the string
4522 arguments has text properties, set up text properties of the
4525 if (string_intervals (args
[0]) || arg_intervals
)
4527 Lisp_Object len
, new_len
, props
;
4528 struct gcpro gcpro1
;
4530 /* Add text properties from the format string. */
4531 len
= make_number (SCHARS (args
[0]));
4532 props
= text_property_list (args
[0], make_number (0), len
, Qnil
);
4537 ptrdiff_t bytepos
= 0, position
= 0, translated
= 0;
4541 /* Adjust the bounds of each text property
4542 to the proper start and end in the output string. */
4544 /* Put the positions in PROPS in increasing order, so that
4545 we can do (effectively) one scan through the position
4546 space of the format string. */
4547 props
= Fnreverse (props
);
4549 /* BYTEPOS is the byte position in the format string,
4550 POSITION is the untranslated char position in it,
4551 TRANSLATED is the translated char position in BUF,
4552 and ARGN is the number of the next arg we will come to. */
4553 for (list
= props
; CONSP (list
); list
= XCDR (list
))
4560 /* First adjust the property start position. */
4561 pos
= XINT (XCAR (item
));
4563 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
4564 up to this position. */
4565 for (; position
< pos
; bytepos
++)
4567 if (! discarded
[bytepos
])
4568 position
++, translated
++;
4569 else if (discarded
[bytepos
] == 1)
4572 if (translated
== info
[argn
].start
)
4574 translated
+= info
[argn
].end
- info
[argn
].start
;
4580 XSETCAR (item
, make_number (translated
));
4582 /* Likewise adjust the property end position. */
4583 pos
= XINT (XCAR (XCDR (item
)));
4585 for (; position
< pos
; bytepos
++)
4587 if (! discarded
[bytepos
])
4588 position
++, translated
++;
4589 else if (discarded
[bytepos
] == 1)
4592 if (translated
== info
[argn
].start
)
4594 translated
+= info
[argn
].end
- info
[argn
].start
;
4600 XSETCAR (XCDR (item
), make_number (translated
));
4603 add_text_properties_from_list (val
, props
, make_number (0));
4606 /* Add text properties from arguments. */
4608 for (n
= 1; n
< nargs
; ++n
)
4609 if (info
[n
].intervals
)
4611 len
= make_number (SCHARS (args
[n
]));
4612 new_len
= make_number (info
[n
].end
- info
[n
].start
);
4613 props
= text_property_list (args
[n
], make_number (0),
4615 props
= extend_property_ranges (props
, new_len
);
4616 /* If successive arguments have properties, be sure that
4617 the value of `composition' property be the copy. */
4618 if (n
> 1 && info
[n
- 1].end
)
4619 make_composition_value_copy (props
);
4620 add_text_properties_from_list (val
, props
,
4621 make_number (info
[n
].start
));
4628 /* If we allocated BUF or INFO with malloc, free it too. */
4634 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
4635 doc
: /* Return t if two characters match, optionally ignoring case.
4636 Both arguments must be characters (i.e. integers).
4637 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
4638 (register Lisp_Object c1
, Lisp_Object c2
)
4641 /* Check they're chars, not just integers, otherwise we could get array
4642 bounds violations in downcase. */
4643 CHECK_CHARACTER (c1
);
4644 CHECK_CHARACTER (c2
);
4646 if (XINT (c1
) == XINT (c2
))
4648 if (NILP (BVAR (current_buffer
, case_fold_search
)))
4654 /* FIXME: It is possible to compare multibyte characters even when
4655 the current buffer is unibyte. Unfortunately this is ambiguous
4656 for characters between 128 and 255, as they could be either
4657 eight-bit raw bytes or Latin-1 characters. Assume the former for
4658 now. See Bug#17011, and also see casefiddle.c's casify_object,
4659 which has a similar problem. */
4660 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4662 if (SINGLE_BYTE_CHAR_P (i1
))
4663 i1
= UNIBYTE_TO_CHAR (i1
);
4664 if (SINGLE_BYTE_CHAR_P (i2
))
4665 i2
= UNIBYTE_TO_CHAR (i2
);
4668 return (downcase (i1
) == downcase (i2
) ? Qt
: Qnil
);
4671 /* Transpose the markers in two regions of the current buffer, and
4672 adjust the ones between them if necessary (i.e.: if the regions
4675 START1, END1 are the character positions of the first region.
4676 START1_BYTE, END1_BYTE are the byte positions.
4677 START2, END2 are the character positions of the second region.
4678 START2_BYTE, END2_BYTE are the byte positions.
4680 Traverses the entire marker list of the buffer to do so, adding an
4681 appropriate amount to some, subtracting from some, and leaving the
4682 rest untouched. Most of this is copied from adjust_markers in insdel.c.
4684 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
4687 transpose_markers (ptrdiff_t start1
, ptrdiff_t end1
,
4688 ptrdiff_t start2
, ptrdiff_t end2
,
4689 ptrdiff_t start1_byte
, ptrdiff_t end1_byte
,
4690 ptrdiff_t start2_byte
, ptrdiff_t end2_byte
)
4692 register ptrdiff_t amt1
, amt1_byte
, amt2
, amt2_byte
, diff
, diff_byte
, mpos
;
4693 register struct Lisp_Marker
*marker
;
4695 /* Update point as if it were a marker. */
4699 TEMP_SET_PT_BOTH (PT
+ (end2
- end1
),
4700 PT_BYTE
+ (end2_byte
- end1_byte
));
4701 else if (PT
< start2
)
4702 TEMP_SET_PT_BOTH (PT
+ (end2
- start2
) - (end1
- start1
),
4703 (PT_BYTE
+ (end2_byte
- start2_byte
)
4704 - (end1_byte
- start1_byte
)));
4706 TEMP_SET_PT_BOTH (PT
- (start2
- start1
),
4707 PT_BYTE
- (start2_byte
- start1_byte
));
4709 /* We used to adjust the endpoints here to account for the gap, but that
4710 isn't good enough. Even if we assume the caller has tried to move the
4711 gap out of our way, it might still be at start1 exactly, for example;
4712 and that places it `inside' the interval, for our purposes. The amount
4713 of adjustment is nontrivial if there's a `denormalized' marker whose
4714 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
4715 the dirty work to Fmarker_position, below. */
4717 /* The difference between the region's lengths */
4718 diff
= (end2
- start2
) - (end1
- start1
);
4719 diff_byte
= (end2_byte
- start2_byte
) - (end1_byte
- start1_byte
);
4721 /* For shifting each marker in a region by the length of the other
4722 region plus the distance between the regions. */
4723 amt1
= (end2
- start2
) + (start2
- end1
);
4724 amt2
= (end1
- start1
) + (start2
- end1
);
4725 amt1_byte
= (end2_byte
- start2_byte
) + (start2_byte
- end1_byte
);
4726 amt2_byte
= (end1_byte
- start1_byte
) + (start2_byte
- end1_byte
);
4728 for (marker
= BUF_MARKERS (current_buffer
); marker
; marker
= marker
->next
)
4730 mpos
= marker
->bytepos
;
4731 if (mpos
>= start1_byte
&& mpos
< end2_byte
)
4733 if (mpos
< end1_byte
)
4735 else if (mpos
< start2_byte
)
4739 marker
->bytepos
= mpos
;
4741 mpos
= marker
->charpos
;
4742 if (mpos
>= start1
&& mpos
< end2
)
4746 else if (mpos
< start2
)
4751 marker
->charpos
= mpos
;
4755 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
4756 doc
: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
4757 The regions should not be overlapping, because the size of the buffer is
4758 never changed in a transposition.
4760 Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
4761 any markers that happen to be located in the regions.
4763 Transposing beyond buffer boundaries is an error. */)
4764 (Lisp_Object startr1
, Lisp_Object endr1
, Lisp_Object startr2
, Lisp_Object endr2
, Lisp_Object leave_markers
)
4766 register ptrdiff_t start1
, end1
, start2
, end2
;
4767 ptrdiff_t start1_byte
, start2_byte
, len1_byte
, len2_byte
, end2_byte
;
4768 ptrdiff_t gap
, len1
, len_mid
, len2
;
4769 unsigned char *start1_addr
, *start2_addr
, *temp
;
4771 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
, tmp_interval3
;
4774 XSETBUFFER (buf
, current_buffer
);
4775 cur_intv
= buffer_intervals (current_buffer
);
4777 validate_region (&startr1
, &endr1
);
4778 validate_region (&startr2
, &endr2
);
4780 start1
= XFASTINT (startr1
);
4781 end1
= XFASTINT (endr1
);
4782 start2
= XFASTINT (startr2
);
4783 end2
= XFASTINT (endr2
);
4786 /* Swap the regions if they're reversed. */
4789 register ptrdiff_t glumph
= start1
;
4797 len1
= end1
- start1
;
4798 len2
= end2
- start2
;
4801 error ("Transposed regions overlap");
4802 /* Nothing to change for adjacent regions with one being empty */
4803 else if ((start1
== end1
|| start2
== end2
) && end1
== start2
)
4806 /* The possibilities are:
4807 1. Adjacent (contiguous) regions, or separate but equal regions
4808 (no, really equal, in this case!), or
4809 2. Separate regions of unequal size.
4811 The worst case is usually No. 2. It means that (aside from
4812 potential need for getting the gap out of the way), there also
4813 needs to be a shifting of the text between the two regions. So
4814 if they are spread far apart, we are that much slower... sigh. */
4816 /* It must be pointed out that the really studly thing to do would
4817 be not to move the gap at all, but to leave it in place and work
4818 around it if necessary. This would be extremely efficient,
4819 especially considering that people are likely to do
4820 transpositions near where they are working interactively, which
4821 is exactly where the gap would be found. However, such code
4822 would be much harder to write and to read. So, if you are
4823 reading this comment and are feeling squirrely, by all means have
4824 a go! I just didn't feel like doing it, so I will simply move
4825 the gap the minimum distance to get it out of the way, and then
4826 deal with an unbroken array. */
4828 start1_byte
= CHAR_TO_BYTE (start1
);
4829 end2_byte
= CHAR_TO_BYTE (end2
);
4831 /* Make sure the gap won't interfere, by moving it out of the text
4832 we will operate on. */
4833 if (start1
< gap
&& gap
< end2
)
4835 if (gap
- start1
< end2
- gap
)
4836 move_gap_both (start1
, start1_byte
);
4838 move_gap_both (end2
, end2_byte
);
4841 start2_byte
= CHAR_TO_BYTE (start2
);
4842 len1_byte
= CHAR_TO_BYTE (end1
) - start1_byte
;
4843 len2_byte
= end2_byte
- start2_byte
;
4845 #ifdef BYTE_COMBINING_DEBUG
4848 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4849 len2_byte
, start1
, start1_byte
)
4850 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4851 len1_byte
, end2
, start2_byte
+ len2_byte
)
4852 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4853 len1_byte
, end2
, start2_byte
+ len2_byte
))
4858 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4859 len2_byte
, start1
, start1_byte
)
4860 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4861 len1_byte
, start2
, start2_byte
)
4862 || count_combining_after (BYTE_POS_ADDR (start2_byte
),
4863 len2_byte
, end1
, start1_byte
+ len1_byte
)
4864 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4865 len1_byte
, end2
, start2_byte
+ len2_byte
))
4870 /* Hmmm... how about checking to see if the gap is large
4871 enough to use as the temporary storage? That would avoid an
4872 allocation... interesting. Later, don't fool with it now. */
4874 /* Working without memmove, for portability (sigh), so must be
4875 careful of overlapping subsections of the array... */
4877 if (end1
== start2
) /* adjacent regions */
4879 modify_text (start1
, end2
);
4880 record_change (start1
, len1
+ len2
);
4882 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4883 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4884 /* Don't use Fset_text_properties: that can cause GC, which can
4885 clobber objects stored in the tmp_intervals. */
4886 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4888 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4892 /* First region smaller than second. */
4893 if (len1_byte
< len2_byte
)
4895 temp
= SAFE_ALLOCA (len2_byte
);
4897 /* Don't precompute these addresses. We have to compute them
4898 at the last minute, because the relocating allocator might
4899 have moved the buffer around during the xmalloc. */
4900 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4901 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4903 memcpy (temp
, start2_addr
, len2_byte
);
4904 memcpy (start1_addr
+ len2_byte
, start1_addr
, len1_byte
);
4905 memcpy (start1_addr
, temp
, len2_byte
);
4908 /* First region not smaller than second. */
4910 temp
= SAFE_ALLOCA (len1_byte
);
4911 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4912 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4913 memcpy (temp
, start1_addr
, len1_byte
);
4914 memcpy (start1_addr
, start2_addr
, len2_byte
);
4915 memcpy (start1_addr
+ len2_byte
, temp
, len1_byte
);
4919 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
4920 len1
, current_buffer
, 0);
4921 graft_intervals_into_buffer (tmp_interval2
, start1
,
4922 len2
, current_buffer
, 0);
4923 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4924 update_compositions (start1
+ len2
, end2
, CHECK_TAIL
);
4926 /* Non-adjacent regions, because end1 != start2, bleagh... */
4929 len_mid
= start2_byte
- (start1_byte
+ len1_byte
);
4931 if (len1_byte
== len2_byte
)
4932 /* Regions are same size, though, how nice. */
4936 modify_text (start1
, end1
);
4937 modify_text (start2
, end2
);
4938 record_change (start1
, len1
);
4939 record_change (start2
, len2
);
4940 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4941 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4943 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr1
, 0);
4945 set_text_properties_1 (startr1
, endr1
, Qnil
, buf
, tmp_interval3
);
4947 tmp_interval3
= validate_interval_range (buf
, &startr2
, &endr2
, 0);
4949 set_text_properties_1 (startr2
, endr2
, Qnil
, buf
, tmp_interval3
);
4951 temp
= SAFE_ALLOCA (len1_byte
);
4952 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4953 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4954 memcpy (temp
, start1_addr
, len1_byte
);
4955 memcpy (start1_addr
, start2_addr
, len2_byte
);
4956 memcpy (start2_addr
, temp
, len1_byte
);
4959 graft_intervals_into_buffer (tmp_interval1
, start2
,
4960 len1
, current_buffer
, 0);
4961 graft_intervals_into_buffer (tmp_interval2
, start1
,
4962 len2
, current_buffer
, 0);
4965 else if (len1_byte
< len2_byte
) /* Second region larger than first */
4966 /* Non-adjacent & unequal size, area between must also be shifted. */
4970 modify_text (start1
, end2
);
4971 record_change (start1
, (end2
- start1
));
4972 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4973 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4974 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4976 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4978 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4980 /* holds region 2 */
4981 temp
= SAFE_ALLOCA (len2_byte
);
4982 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4983 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4984 memcpy (temp
, start2_addr
, len2_byte
);
4985 memcpy (start1_addr
+ len_mid
+ len2_byte
, start1_addr
, len1_byte
);
4986 memmove (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
4987 memcpy (start1_addr
, temp
, len2_byte
);
4990 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4991 len1
, current_buffer
, 0);
4992 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4993 len_mid
, current_buffer
, 0);
4994 graft_intervals_into_buffer (tmp_interval2
, start1
,
4995 len2
, current_buffer
, 0);
4998 /* Second region smaller than first. */
5002 record_change (start1
, (end2
- start1
));
5003 modify_text (start1
, end2
);
5005 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
5006 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
5007 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
5009 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
5011 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
5013 /* holds region 1 */
5014 temp
= SAFE_ALLOCA (len1_byte
);
5015 start1_addr
= BYTE_POS_ADDR (start1_byte
);
5016 start2_addr
= BYTE_POS_ADDR (start2_byte
);
5017 memcpy (temp
, start1_addr
, len1_byte
);
5018 memcpy (start1_addr
, start2_addr
, len2_byte
);
5019 memcpy (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
5020 memcpy (start1_addr
+ len2_byte
+ len_mid
, temp
, len1_byte
);
5023 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
5024 len1
, current_buffer
, 0);
5025 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
5026 len_mid
, current_buffer
, 0);
5027 graft_intervals_into_buffer (tmp_interval2
, start1
,
5028 len2
, current_buffer
, 0);
5031 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
5032 update_compositions (end2
- len1
, end2
, CHECK_BORDER
);
5035 /* When doing multiple transpositions, it might be nice
5036 to optimize this. Perhaps the markers in any one buffer
5037 should be organized in some sorted data tree. */
5038 if (NILP (leave_markers
))
5040 transpose_markers (start1
, end1
, start2
, end2
,
5041 start1_byte
, start1_byte
+ len1_byte
,
5042 start2_byte
, start2_byte
+ len2_byte
);
5043 fix_start_end_in_overlays (start1
, end2
);
5046 signal_after_change (start1
, end2
- start1
, end2
- start1
);
5052 syms_of_editfns (void)
5054 DEFSYM (Qbuffer_access_fontify_functions
, "buffer-access-fontify-functions");
5055 DEFSYM (Qwall
, "wall");
5057 DEFVAR_LISP ("inhibit-field-text-motion", Vinhibit_field_text_motion
,
5058 doc
: /* Non-nil means text motion commands don't notice fields. */);
5059 Vinhibit_field_text_motion
= Qnil
;
5061 DEFVAR_LISP ("buffer-access-fontify-functions",
5062 Vbuffer_access_fontify_functions
,
5063 doc
: /* List of functions called by `buffer-substring' to fontify if necessary.
5064 Each function is called with two arguments which specify the range
5065 of the buffer being accessed. */);
5066 Vbuffer_access_fontify_functions
= Qnil
;
5070 obuf
= Fcurrent_buffer ();
5071 /* Do this here, because init_buffer_once is too early--it won't work. */
5072 Fset_buffer (Vprin1_to_string_buffer
);
5073 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
5074 Fset (Fmake_local_variable (Qbuffer_access_fontify_functions
), Qnil
);
5078 DEFVAR_LISP ("buffer-access-fontified-property",
5079 Vbuffer_access_fontified_property
,
5080 doc
: /* Property which (if non-nil) indicates text has been fontified.
5081 `buffer-substring' need not call the `buffer-access-fontify-functions'
5082 functions if all the text being accessed has this property. */);
5083 Vbuffer_access_fontified_property
= Qnil
;
5085 DEFVAR_LISP ("system-name", Vsystem_name
,
5086 doc
: /* The host name of the machine Emacs is running on. */);
5087 Vsystem_name
= cached_system_name
= Qnil
;
5089 DEFVAR_LISP ("user-full-name", Vuser_full_name
,
5090 doc
: /* The full name of the user logged in. */);
5092 DEFVAR_LISP ("user-login-name", Vuser_login_name
,
5093 doc
: /* The user's name, taken from environment variables if possible. */);
5094 Vuser_login_name
= Qnil
;
5096 DEFVAR_LISP ("user-real-login-name", Vuser_real_login_name
,
5097 doc
: /* The user's name, based upon the real uid only. */);
5099 DEFVAR_LISP ("operating-system-release", Voperating_system_release
,
5100 doc
: /* The release of the operating system Emacs is running on. */);
5102 defsubr (&Spropertize
);
5103 defsubr (&Schar_equal
);
5104 defsubr (&Sgoto_char
);
5105 defsubr (&Sstring_to_char
);
5106 defsubr (&Schar_to_string
);
5107 defsubr (&Sbyte_to_string
);
5108 defsubr (&Sbuffer_substring
);
5109 defsubr (&Sbuffer_substring_no_properties
);
5110 defsubr (&Sbuffer_string
);
5111 defsubr (&Sget_pos_property
);
5113 defsubr (&Spoint_marker
);
5114 defsubr (&Smark_marker
);
5116 defsubr (&Sregion_beginning
);
5117 defsubr (&Sregion_end
);
5119 /* Symbol for the text property used to mark fields. */
5120 DEFSYM (Qfield
, "field");
5122 /* A special value for Qfield properties. */
5123 DEFSYM (Qboundary
, "boundary");
5125 defsubr (&Sfield_beginning
);
5126 defsubr (&Sfield_end
);
5127 defsubr (&Sfield_string
);
5128 defsubr (&Sfield_string_no_properties
);
5129 defsubr (&Sdelete_field
);
5130 defsubr (&Sconstrain_to_field
);
5132 defsubr (&Sline_beginning_position
);
5133 defsubr (&Sline_end_position
);
5135 defsubr (&Ssave_excursion
);
5136 defsubr (&Ssave_current_buffer
);
5138 defsubr (&Sbuffer_size
);
5139 defsubr (&Spoint_max
);
5140 defsubr (&Spoint_min
);
5141 defsubr (&Spoint_min_marker
);
5142 defsubr (&Spoint_max_marker
);
5143 defsubr (&Sgap_position
);
5144 defsubr (&Sgap_size
);
5145 defsubr (&Sposition_bytes
);
5146 defsubr (&Sbyte_to_position
);
5152 defsubr (&Sfollowing_char
);
5153 defsubr (&Sprevious_char
);
5154 defsubr (&Schar_after
);
5155 defsubr (&Schar_before
);
5157 defsubr (&Sinsert_before_markers
);
5158 defsubr (&Sinsert_and_inherit
);
5159 defsubr (&Sinsert_and_inherit_before_markers
);
5160 defsubr (&Sinsert_char
);
5161 defsubr (&Sinsert_byte
);
5163 defsubr (&Suser_login_name
);
5164 defsubr (&Suser_real_login_name
);
5165 defsubr (&Suser_uid
);
5166 defsubr (&Suser_real_uid
);
5167 defsubr (&Sgroup_gid
);
5168 defsubr (&Sgroup_real_gid
);
5169 defsubr (&Suser_full_name
);
5170 defsubr (&Semacs_pid
);
5171 defsubr (&Scurrent_time
);
5172 defsubr (&Stime_add
);
5173 defsubr (&Stime_subtract
);
5174 defsubr (&Stime_less_p
);
5175 defsubr (&Sget_internal_run_time
);
5176 defsubr (&Sformat_time_string
);
5177 defsubr (&Sfloat_time
);
5178 defsubr (&Sdecode_time
);
5179 defsubr (&Sencode_time
);
5180 defsubr (&Scurrent_time_string
);
5181 defsubr (&Scurrent_time_zone
);
5182 defsubr (&Sset_time_zone_rule
);
5183 defsubr (&Ssystem_name
);
5184 defsubr (&Smessage
);
5185 defsubr (&Smessage_box
);
5186 defsubr (&Smessage_or_box
);
5187 defsubr (&Scurrent_message
);
5190 defsubr (&Sinsert_buffer_substring
);
5191 defsubr (&Scompare_buffer_substrings
);
5192 defsubr (&Ssubst_char_in_region
);
5193 defsubr (&Stranslate_region_internal
);
5194 defsubr (&Sdelete_region
);
5195 defsubr (&Sdelete_and_extract_region
);
5197 defsubr (&Snarrow_to_region
);
5198 defsubr (&Ssave_restriction
);
5199 defsubr (&Stranspose_regions
);