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>
53 #include "intervals.h"
54 #include "character.h"
59 #include "blockinput.h"
61 #define TM_YEAR_BASE 1900
64 extern Lisp_Object
w32_get_internal_run_time (void);
67 static struct lisp_time
lisp_time_struct (Lisp_Object
, int *);
68 static void set_time_zone_rule (char const *);
69 static Lisp_Object
format_time_string (char const *, ptrdiff_t, struct timespec
,
71 static long int tm_gmtoff (struct tm
*);
72 static int tm_diff (struct tm
*, struct tm
*);
73 static void update_buffer_properties (ptrdiff_t, ptrdiff_t);
75 #ifndef HAVE_TM_GMTOFF
76 # define HAVE_TM_GMTOFF false
79 static Lisp_Object Qbuffer_access_fontify_functions
;
81 /* Symbol for the text property used to mark fields. */
85 /* A special value for Qfield properties. */
87 static Lisp_Object Qboundary
;
89 /* The startup value of the TZ environment variable; null if unset. */
90 static char const *initial_tz
;
92 /* A valid but unlikely setting for the TZ environment variable.
93 It is OK (though a bit slower) if the user chooses this value. */
94 static char dump_tz_string
[] = "TZ=UtC0";
96 /* The cached value of Vsystem_name. This is used only to compare it
97 to Vsystem_name, so it need not be visible to the GC. */
98 static Lisp_Object cached_system_name
;
101 init_and_cache_system_name (void)
104 cached_system_name
= Vsystem_name
;
110 const char *user_name
;
112 struct passwd
*pw
; /* password entry for the current user */
115 /* Set up system_name even when dumping. */
116 init_and_cache_system_name ();
119 /* When just dumping out, set the time zone to a known unlikely value
120 and skip the rest of this function. */
124 xputenv (dump_tz_string
);
131 char *tz
= getenv ("TZ");
134 #if !defined CANNOT_DUMP && defined HAVE_TZSET
135 /* If the execution TZ happens to be the same as the dump TZ,
136 change it to some other value and then change it back,
137 to force the underlying implementation to reload the TZ info.
138 This is needed on implementations that load TZ info from files,
139 since the TZ file contents may differ between dump and execution. */
140 if (tz
&& strcmp (tz
, &dump_tz_string
[sizeof "TZ=" - 1]) == 0)
148 /* Call set_time_zone_rule now, so that its call to putenv is done
149 before multiple threads are active. */
150 set_time_zone_rule (tz
);
152 pw
= getpwuid (getuid ());
154 /* We let the real user name default to "root" because that's quite
155 accurate on MS-DOS and because it lets Emacs find the init file.
156 (The DVX libraries override the Djgpp libraries here.) */
157 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "root");
159 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "unknown");
162 /* Get the effective user name, by consulting environment variables,
163 or the effective uid if those are unset. */
164 user_name
= getenv ("LOGNAME");
167 user_name
= getenv ("USERNAME"); /* it's USERNAME on NT */
168 #else /* WINDOWSNT */
169 user_name
= getenv ("USER");
170 #endif /* WINDOWSNT */
173 pw
= getpwuid (geteuid ());
174 user_name
= pw
? pw
->pw_name
: "unknown";
176 Vuser_login_name
= build_string (user_name
);
178 /* If the user name claimed in the environment vars differs from
179 the real uid, use the claimed name to find the full name. */
180 tem
= Fstring_equal (Vuser_login_name
, Vuser_real_login_name
);
182 tem
= Vuser_login_name
;
185 uid_t euid
= geteuid ();
186 tem
= make_fixnum_or_float (euid
);
188 Vuser_full_name
= Fuser_full_name (tem
);
192 Vuser_full_name
= build_string (p
);
193 else if (NILP (Vuser_full_name
))
194 Vuser_full_name
= build_string ("unknown");
196 #ifdef HAVE_SYS_UTSNAME_H
200 Voperating_system_release
= build_string (uts
.release
);
203 Voperating_system_release
= Qnil
;
207 DEFUN ("char-to-string", Fchar_to_string
, Schar_to_string
, 1, 1, 0,
208 doc
: /* Convert arg CHAR to a string containing that character.
209 usage: (char-to-string CHAR) */)
210 (Lisp_Object character
)
213 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
215 CHECK_CHARACTER (character
);
216 c
= XFASTINT (character
);
218 len
= CHAR_STRING (c
, str
);
219 return make_string_from_bytes ((char *) str
, 1, len
);
222 DEFUN ("byte-to-string", Fbyte_to_string
, Sbyte_to_string
, 1, 1, 0,
223 doc
: /* Convert arg BYTE to a unibyte string containing that byte. */)
228 if (XINT (byte
) < 0 || XINT (byte
) > 255)
229 error ("Invalid byte");
231 return make_string_from_bytes ((char *) &b
, 1, 1);
234 DEFUN ("string-to-char", Fstring_to_char
, Sstring_to_char
, 1, 1, 0,
235 doc
: /* Return the first character in STRING. */)
236 (register Lisp_Object string
)
238 register Lisp_Object val
;
239 CHECK_STRING (string
);
242 if (STRING_MULTIBYTE (string
))
243 XSETFASTINT (val
, STRING_CHAR (SDATA (string
)));
245 XSETFASTINT (val
, SREF (string
, 0));
248 XSETFASTINT (val
, 0);
252 DEFUN ("point", Fpoint
, Spoint
, 0, 0, 0,
253 doc
: /* Return value of point, as an integer.
254 Beginning of buffer is position (point-min). */)
258 XSETFASTINT (temp
, PT
);
262 DEFUN ("point-marker", Fpoint_marker
, Spoint_marker
, 0, 0, 0,
263 doc
: /* Return value of point, as a marker object. */)
266 return build_marker (current_buffer
, PT
, PT_BYTE
);
269 DEFUN ("goto-char", Fgoto_char
, Sgoto_char
, 1, 1, "NGoto char: ",
270 doc
: /* Set point to POSITION, a number or marker.
271 Beginning of buffer is position (point-min), end is (point-max).
273 The return value is POSITION. */)
274 (register Lisp_Object position
)
276 if (MARKERP (position
))
277 set_point_from_marker (position
);
278 else if (INTEGERP (position
))
279 SET_PT (clip_to_bounds (BEGV
, XINT (position
), ZV
));
281 wrong_type_argument (Qinteger_or_marker_p
, position
);
286 /* Return the start or end position of the region.
287 BEGINNINGP means return the start.
288 If there is no region active, signal an error. */
291 region_limit (bool beginningp
)
295 if (!NILP (Vtransient_mark_mode
)
296 && NILP (Vmark_even_if_inactive
)
297 && NILP (BVAR (current_buffer
, mark_active
)))
298 xsignal0 (Qmark_inactive
);
300 m
= Fmarker_position (BVAR (current_buffer
, mark
));
302 error ("The mark is not set now, so there is no region");
304 /* Clip to the current narrowing (bug#11770). */
305 return make_number ((PT
< XFASTINT (m
)) == beginningp
307 : clip_to_bounds (BEGV
, XFASTINT (m
), ZV
));
310 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
311 doc
: /* Return the integer value of point or mark, whichever is smaller. */)
314 return region_limit (1);
317 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
318 doc
: /* Return the integer value of point or mark, whichever is larger. */)
321 return region_limit (0);
324 DEFUN ("mark-marker", Fmark_marker
, Smark_marker
, 0, 0, 0,
325 doc
: /* Return this buffer's mark, as a marker object.
326 Watch out! Moving this marker changes the mark position.
327 If you set the marker not to point anywhere, the buffer will have no mark. */)
330 return BVAR (current_buffer
, mark
);
334 /* Find all the overlays in the current buffer that touch position POS.
335 Return the number found, and store them in a vector in VEC
339 overlays_around (EMACS_INT pos
, Lisp_Object
*vec
, ptrdiff_t len
)
341 Lisp_Object overlay
, start
, end
;
342 struct Lisp_Overlay
*tail
;
343 ptrdiff_t startpos
, endpos
;
346 for (tail
= current_buffer
->overlays_before
; tail
; tail
= tail
->next
)
348 XSETMISC (overlay
, tail
);
350 end
= OVERLAY_END (overlay
);
351 endpos
= OVERLAY_POSITION (end
);
354 start
= OVERLAY_START (overlay
);
355 startpos
= OVERLAY_POSITION (start
);
360 /* Keep counting overlays even if we can't return them all. */
365 for (tail
= current_buffer
->overlays_after
; tail
; tail
= tail
->next
)
367 XSETMISC (overlay
, tail
);
369 start
= OVERLAY_START (overlay
);
370 startpos
= OVERLAY_POSITION (start
);
373 end
= OVERLAY_END (overlay
);
374 endpos
= OVERLAY_POSITION (end
);
386 DEFUN ("get-pos-property", Fget_pos_property
, Sget_pos_property
, 2, 3, 0,
387 doc
: /* Return the value of POSITION's property PROP, in OBJECT.
388 Almost identical to `get-char-property' except for the following difference:
389 Whereas `get-char-property' returns the property of the char at (i.e. right
390 after) POSITION, this pays attention to properties's stickiness and overlays's
391 advancement settings, in order to find the property of POSITION itself,
392 i.e. the property that a char would inherit if it were inserted
394 (Lisp_Object position
, register Lisp_Object prop
, Lisp_Object object
)
396 CHECK_NUMBER_COERCE_MARKER (position
);
399 XSETBUFFER (object
, current_buffer
);
400 else if (WINDOWP (object
))
401 object
= XWINDOW (object
)->contents
;
403 if (!BUFFERP (object
))
404 /* pos-property only makes sense in buffers right now, since strings
405 have no overlays and no notion of insertion for which stickiness
407 return Fget_text_property (position
, prop
, object
);
410 EMACS_INT posn
= XINT (position
);
412 Lisp_Object
*overlay_vec
, tem
;
413 struct buffer
*obuf
= current_buffer
;
416 set_buffer_temp (XBUFFER (object
));
418 /* First try with room for 40 overlays. */
419 Lisp_Object overlay_vecbuf
[40];
420 noverlays
= ARRAYELTS (overlay_vecbuf
);
421 overlay_vec
= overlay_vecbuf
;
422 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
424 /* If there are more than 40,
425 make enough space for all, and try again. */
426 if (ARRAYELTS (overlay_vecbuf
) < noverlays
)
428 SAFE_ALLOCA_LISP (overlay_vec
, noverlays
);
429 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
431 noverlays
= sort_overlays (overlay_vec
, noverlays
, NULL
);
433 set_buffer_temp (obuf
);
435 /* Now check the overlays in order of decreasing priority. */
436 while (--noverlays
>= 0)
438 Lisp_Object ol
= overlay_vec
[noverlays
];
439 tem
= Foverlay_get (ol
, prop
);
442 /* Check the overlay is indeed active at point. */
443 Lisp_Object start
= OVERLAY_START (ol
), finish
= OVERLAY_END (ol
);
444 if ((OVERLAY_POSITION (start
) == posn
445 && XMARKER (start
)->insertion_type
== 1)
446 || (OVERLAY_POSITION (finish
) == posn
447 && XMARKER (finish
)->insertion_type
== 0))
448 ; /* The overlay will not cover a char inserted at point. */
458 { /* Now check the text properties. */
459 int stickiness
= text_property_stickiness (prop
, position
, object
);
461 return Fget_text_property (position
, prop
, object
);
462 else if (stickiness
< 0
463 && XINT (position
) > BUF_BEGV (XBUFFER (object
)))
464 return Fget_text_property (make_number (XINT (position
) - 1),
472 /* Find the field surrounding POS in *BEG and *END. If POS is nil,
473 the value of point is used instead. If BEG or END is null,
474 means don't store the beginning or end of the field.
476 BEG_LIMIT and END_LIMIT serve to limit the ranged of the returned
477 results; they do not effect boundary behavior.
479 If MERGE_AT_BOUNDARY is non-nil, then if POS is at the very first
480 position of a field, then the beginning of the previous field is
481 returned instead of the beginning of POS's field (since the end of a
482 field is actually also the beginning of the next input field, this
483 behavior is sometimes useful). Additionally in the MERGE_AT_BOUNDARY
484 non-nil case, if two fields are separated by a field with the special
485 value `boundary', and POS lies within it, then the two separated
486 fields are considered to be adjacent, and POS between them, when
487 finding the beginning and ending of the "merged" field.
489 Either BEG or END may be 0, in which case the corresponding value
493 find_field (Lisp_Object pos
, Lisp_Object merge_at_boundary
,
494 Lisp_Object beg_limit
,
495 ptrdiff_t *beg
, Lisp_Object end_limit
, ptrdiff_t *end
)
497 /* Fields right before and after the point. */
498 Lisp_Object before_field
, after_field
;
499 /* True if POS counts as the start of a field. */
500 bool at_field_start
= 0;
501 /* True if POS counts as the end of a field. */
502 bool at_field_end
= 0;
505 XSETFASTINT (pos
, PT
);
507 CHECK_NUMBER_COERCE_MARKER (pos
);
510 = get_char_property_and_overlay (pos
, Qfield
, Qnil
, NULL
);
512 = (XFASTINT (pos
) > BEGV
513 ? get_char_property_and_overlay (make_number (XINT (pos
) - 1),
515 /* Using nil here would be a more obvious choice, but it would
516 fail when the buffer starts with a non-sticky field. */
519 /* See if we need to handle the case where MERGE_AT_BOUNDARY is nil
520 and POS is at beginning of a field, which can also be interpreted
521 as the end of the previous field. Note that the case where if
522 MERGE_AT_BOUNDARY is non-nil (see function comment) is actually the
523 more natural one; then we avoid treating the beginning of a field
525 if (NILP (merge_at_boundary
))
527 Lisp_Object field
= Fget_pos_property (pos
, Qfield
, Qnil
);
528 if (!EQ (field
, after_field
))
530 if (!EQ (field
, before_field
))
532 if (NILP (field
) && at_field_start
&& at_field_end
)
533 /* If an inserted char would have a nil field while the surrounding
534 text is non-nil, we're probably not looking at a
535 zero-length field, but instead at a non-nil field that's
536 not intended for editing (such as comint's prompts). */
537 at_field_end
= at_field_start
= 0;
540 /* Note about special `boundary' fields:
542 Consider the case where the point (`.') is between the fields `x' and `y':
546 In this situation, if merge_at_boundary is non-nil, consider the
547 `x' and `y' fields as forming one big merged field, and so the end
548 of the field is the end of `y'.
550 However, if `x' and `y' are separated by a special `boundary' field
551 (a field with a `field' char-property of 'boundary), then ignore
552 this special field when merging adjacent fields. Here's the same
553 situation, but with a `boundary' field between the `x' and `y' fields:
557 Here, if point is at the end of `x', the beginning of `y', or
558 anywhere in-between (within the `boundary' field), merge all
559 three fields and consider the beginning as being the beginning of
560 the `x' field, and the end as being the end of the `y' field. */
565 /* POS is at the edge of a field, and we should consider it as
566 the beginning of the following field. */
567 *beg
= XFASTINT (pos
);
569 /* Find the previous field boundary. */
572 if (!NILP (merge_at_boundary
) && EQ (before_field
, Qboundary
))
573 /* Skip a `boundary' field. */
574 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
577 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
579 *beg
= NILP (p
) ? BEGV
: XFASTINT (p
);
586 /* POS is at the edge of a field, and we should consider it as
587 the end of the previous field. */
588 *end
= XFASTINT (pos
);
590 /* Find the next field boundary. */
592 if (!NILP (merge_at_boundary
) && EQ (after_field
, Qboundary
))
593 /* Skip a `boundary' field. */
594 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
597 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
599 *end
= NILP (pos
) ? ZV
: XFASTINT (pos
);
605 DEFUN ("delete-field", Fdelete_field
, Sdelete_field
, 0, 1, 0,
606 doc
: /* Delete the field surrounding POS.
607 A field is a region of text with the same `field' property.
608 If POS is nil, the value of point is used for POS. */)
612 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
614 del_range (beg
, end
);
618 DEFUN ("field-string", Ffield_string
, Sfield_string
, 0, 1, 0,
619 doc
: /* Return the contents of the field surrounding POS as a string.
620 A field is a region of text with the same `field' property.
621 If POS is nil, the value of point is used for POS. */)
625 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
626 return make_buffer_string (beg
, end
, 1);
629 DEFUN ("field-string-no-properties", Ffield_string_no_properties
, Sfield_string_no_properties
, 0, 1, 0,
630 doc
: /* Return the contents of the field around POS, without text properties.
631 A field is a region of text with the same `field' property.
632 If POS is nil, the value of point is used for POS. */)
636 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
637 return make_buffer_string (beg
, end
, 0);
640 DEFUN ("field-beginning", Ffield_beginning
, Sfield_beginning
, 0, 3, 0,
641 doc
: /* Return the beginning of the field surrounding POS.
642 A field is a region of text with the same `field' property.
643 If POS is nil, the value of point is used for POS.
644 If ESCAPE-FROM-EDGE is non-nil and POS is at the beginning of its
645 field, then the beginning of the *previous* field is returned.
646 If LIMIT is non-nil, it is a buffer position; if the beginning of the field
647 is before LIMIT, then LIMIT will be returned instead. */)
648 (Lisp_Object pos
, Lisp_Object escape_from_edge
, Lisp_Object limit
)
651 find_field (pos
, escape_from_edge
, limit
, &beg
, Qnil
, 0);
652 return make_number (beg
);
655 DEFUN ("field-end", Ffield_end
, Sfield_end
, 0, 3, 0,
656 doc
: /* Return the end of the field surrounding POS.
657 A field is a region of text with the same `field' property.
658 If POS is nil, the value of point is used for POS.
659 If ESCAPE-FROM-EDGE is non-nil and POS is at the end of its field,
660 then the end of the *following* field is returned.
661 If LIMIT is non-nil, it is a buffer position; if the end of the field
662 is after LIMIT, then LIMIT will be returned instead. */)
663 (Lisp_Object pos
, Lisp_Object escape_from_edge
, Lisp_Object limit
)
666 find_field (pos
, escape_from_edge
, Qnil
, 0, limit
, &end
);
667 return make_number (end
);
670 DEFUN ("constrain-to-field", Fconstrain_to_field
, Sconstrain_to_field
, 2, 5, 0,
671 doc
: /* Return the position closest to NEW-POS that is in the same field as OLD-POS.
672 A field is a region of text with the same `field' property.
674 If NEW-POS is nil, then use the current point instead, and move point
675 to the resulting constrained position, in addition to returning that
678 If OLD-POS is at the boundary of two fields, then the allowable
679 positions for NEW-POS depends on the value of the optional argument
680 ESCAPE-FROM-EDGE: If ESCAPE-FROM-EDGE is nil, then NEW-POS is
681 constrained to the field that has the same `field' char-property
682 as any new characters inserted at OLD-POS, whereas if ESCAPE-FROM-EDGE
683 is non-nil, NEW-POS is constrained to the union of the two adjacent
684 fields. Additionally, if two fields are separated by another field with
685 the special value `boundary', then any point within this special field is
686 also considered to be `on the boundary'.
688 If the optional argument ONLY-IN-LINE is non-nil and constraining
689 NEW-POS would move it to a different line, NEW-POS is returned
690 unconstrained. This is useful for commands that move by line, like
691 \\[next-line] or \\[beginning-of-line], which should generally respect field boundaries
692 only in the case where they can still move to the right line.
694 If the optional argument INHIBIT-CAPTURE-PROPERTY is non-nil, and OLD-POS has
695 a non-nil property of that name, then any field boundaries are ignored.
697 Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
698 (Lisp_Object new_pos
, Lisp_Object old_pos
, Lisp_Object escape_from_edge
,
699 Lisp_Object only_in_line
, Lisp_Object inhibit_capture_property
)
701 /* If non-zero, then the original point, before re-positioning. */
702 ptrdiff_t orig_point
= 0;
704 Lisp_Object prev_old
, prev_new
;
707 /* Use the current point, and afterwards, set it. */
710 XSETFASTINT (new_pos
, PT
);
713 CHECK_NUMBER_COERCE_MARKER (new_pos
);
714 CHECK_NUMBER_COERCE_MARKER (old_pos
);
716 fwd
= (XINT (new_pos
) > XINT (old_pos
));
718 prev_old
= make_number (XINT (old_pos
) - 1);
719 prev_new
= make_number (XINT (new_pos
) - 1);
721 if (NILP (Vinhibit_field_text_motion
)
722 && !EQ (new_pos
, old_pos
)
723 && (!NILP (Fget_char_property (new_pos
, Qfield
, Qnil
))
724 || !NILP (Fget_char_property (old_pos
, Qfield
, Qnil
))
725 /* To recognize field boundaries, we must also look at the
726 previous positions; we could use `Fget_pos_property'
727 instead, but in itself that would fail inside non-sticky
728 fields (like comint prompts). */
729 || (XFASTINT (new_pos
) > BEGV
730 && !NILP (Fget_char_property (prev_new
, Qfield
, Qnil
)))
731 || (XFASTINT (old_pos
) > BEGV
732 && !NILP (Fget_char_property (prev_old
, Qfield
, Qnil
))))
733 && (NILP (inhibit_capture_property
)
734 /* Field boundaries are again a problem; but now we must
735 decide the case exactly, so we need to call
736 `get_pos_property' as well. */
737 || (NILP (Fget_pos_property (old_pos
, inhibit_capture_property
, Qnil
))
738 && (XFASTINT (old_pos
) <= BEGV
739 || NILP (Fget_char_property
740 (old_pos
, inhibit_capture_property
, Qnil
))
741 || NILP (Fget_char_property
742 (prev_old
, inhibit_capture_property
, Qnil
))))))
743 /* It is possible that NEW_POS is not within the same field as
744 OLD_POS; try to move NEW_POS so that it is. */
747 Lisp_Object field_bound
;
750 field_bound
= Ffield_end (old_pos
, escape_from_edge
, new_pos
);
752 field_bound
= Ffield_beginning (old_pos
, escape_from_edge
, new_pos
);
754 if (/* See if ESCAPE_FROM_EDGE caused FIELD_BOUND to jump to the
755 other side of NEW_POS, which would mean that NEW_POS is
756 already acceptable, and it's not necessary to constrain it
758 ((XFASTINT (field_bound
) < XFASTINT (new_pos
)) ? fwd
: !fwd
)
759 /* NEW_POS should be constrained, but only if either
760 ONLY_IN_LINE is nil (in which case any constraint is OK),
761 or NEW_POS and FIELD_BOUND are on the same line (in which
762 case the constraint is OK even if ONLY_IN_LINE is non-nil). */
763 && (NILP (only_in_line
)
764 /* This is the ONLY_IN_LINE case, check that NEW_POS and
765 FIELD_BOUND are on the same line by seeing whether
766 there's an intervening newline or not. */
767 || (find_newline (XFASTINT (new_pos
), -1,
768 XFASTINT (field_bound
), -1,
769 fwd
? -1 : 1, &shortage
, NULL
, 1),
771 /* Constrain NEW_POS to FIELD_BOUND. */
772 new_pos
= field_bound
;
774 if (orig_point
&& XFASTINT (new_pos
) != orig_point
)
775 /* The NEW_POS argument was originally nil, so automatically set PT. */
776 SET_PT (XFASTINT (new_pos
));
783 DEFUN ("line-beginning-position",
784 Fline_beginning_position
, Sline_beginning_position
, 0, 1, 0,
785 doc
: /* Return the character position of the first character on the current line.
786 With optional argument N, scan forward N - 1 lines first.
787 If the scan reaches the end of the buffer, return that position.
789 This function ignores text display directionality; it returns the
790 position of the first character in logical order, i.e. the smallest
791 character position on the line.
793 This function constrains the returned position to the current field
794 unless that position would be on a different line than the original,
795 unconstrained result. If N is nil or 1, and a front-sticky field
796 starts at point, the scan stops as soon as it starts. To ignore field
797 boundaries, bind `inhibit-field-text-motion' to t.
799 This function does not move point. */)
802 ptrdiff_t charpos
, bytepos
;
809 scan_newline_from_point (XINT (n
) - 1, &charpos
, &bytepos
);
811 /* Return END constrained to the current input field. */
812 return Fconstrain_to_field (make_number (charpos
), make_number (PT
),
813 XINT (n
) != 1 ? Qt
: Qnil
,
817 DEFUN ("line-end-position", Fline_end_position
, Sline_end_position
, 0, 1, 0,
818 doc
: /* Return the character position of the last character on the current line.
819 With argument N not nil or 1, move forward N - 1 lines first.
820 If scan reaches end of buffer, return that position.
822 This function ignores text display directionality; it returns the
823 position of the last character in logical order, i.e. the largest
824 character position on the line.
826 This function constrains the returned position to the current field
827 unless that would be on a different line than the original,
828 unconstrained result. If N is nil or 1, and a rear-sticky field ends
829 at point, the scan stops as soon as it starts. To ignore field
830 boundaries bind `inhibit-field-text-motion' to t.
832 This function does not move point. */)
844 clipped_n
= clip_to_bounds (PTRDIFF_MIN
+ 1, XINT (n
), PTRDIFF_MAX
);
845 end_pos
= find_before_next_newline (orig
, 0, clipped_n
- (clipped_n
<= 0),
848 /* Return END_POS constrained to the current input field. */
849 return Fconstrain_to_field (make_number (end_pos
), make_number (orig
),
853 /* Save current buffer state for `save-excursion' special form.
854 We (ab)use Lisp_Misc_Save_Value to allow explicit free and so
855 offload some work from GC. */
858 save_excursion_save (void)
860 return make_save_obj_obj_obj_obj
862 /* Do not copy the mark if it points to nowhere. */
863 (XMARKER (BVAR (current_buffer
, mark
))->buffer
864 ? Fcopy_marker (BVAR (current_buffer
, mark
), Qnil
)
866 /* Selected window if current buffer is shown in it, nil otherwise. */
867 (EQ (XWINDOW (selected_window
)->contents
, Fcurrent_buffer ())
868 ? selected_window
: Qnil
),
869 BVAR (current_buffer
, mark_active
));
872 /* Restore saved buffer before leaving `save-excursion' special form. */
875 save_excursion_restore (Lisp_Object info
)
877 Lisp_Object tem
, tem1
, omark
, nmark
;
878 struct gcpro gcpro1
, gcpro2
, gcpro3
;
880 tem
= Fmarker_buffer (XSAVE_OBJECT (info
, 0));
881 /* If we're unwinding to top level, saved buffer may be deleted. This
882 means that all of its markers are unchained and so tem is nil. */
886 omark
= nmark
= Qnil
;
887 GCPRO3 (info
, omark
, nmark
);
892 tem
= XSAVE_OBJECT (info
, 0);
894 unchain_marker (XMARKER (tem
));
897 tem
= XSAVE_OBJECT (info
, 1);
898 omark
= Fmarker_position (BVAR (current_buffer
, mark
));
900 unchain_marker (XMARKER (BVAR (current_buffer
, mark
)));
903 Fset_marker (BVAR (current_buffer
, mark
), tem
, Fcurrent_buffer ());
904 nmark
= Fmarker_position (tem
);
905 unchain_marker (XMARKER (tem
));
909 tem
= XSAVE_OBJECT (info
, 3);
910 tem1
= BVAR (current_buffer
, mark_active
);
911 bset_mark_active (current_buffer
, tem
);
913 /* If mark is active now, and either was not active
914 or was at a different place, run the activate hook. */
917 if (! EQ (omark
, nmark
))
919 tem
= intern ("activate-mark-hook");
920 Frun_hooks (1, &tem
);
923 /* If mark has ceased to be active, run deactivate hook. */
924 else if (! NILP (tem1
))
926 tem
= intern ("deactivate-mark-hook");
927 Frun_hooks (1, &tem
);
930 /* If buffer was visible in a window, and a different window was
931 selected, and the old selected window is still showing this
932 buffer, restore point in that window. */
933 tem
= XSAVE_OBJECT (info
, 2);
935 && !EQ (tem
, selected_window
)
936 && (tem1
= XWINDOW (tem
)->contents
,
937 (/* Window is live... */
939 /* ...and it shows the current buffer. */
940 && XBUFFER (tem1
) == current_buffer
)))
941 Fset_window_point (tem
, make_number (PT
));
950 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
951 doc
: /* Save point, mark, and current buffer; execute BODY; restore those things.
952 Executes BODY just like `progn'.
953 The values of point, mark and the current buffer are restored
954 even in case of abnormal exit (throw or error).
955 The state of activation of the mark is also restored.
957 This construct does not save `deactivate-mark', and therefore
958 functions that change the buffer will still cause deactivation
959 of the mark at the end of the command. To prevent that, bind
960 `deactivate-mark' with `let'.
962 If you only want to save the current buffer but not point nor mark,
963 then just use `save-current-buffer', or even `with-current-buffer'.
965 usage: (save-excursion &rest BODY) */)
968 register Lisp_Object val
;
969 ptrdiff_t count
= SPECPDL_INDEX ();
971 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
974 return unbind_to (count
, val
);
977 DEFUN ("save-current-buffer", Fsave_current_buffer
, Ssave_current_buffer
, 0, UNEVALLED
, 0,
978 doc
: /* Record which buffer is current; execute BODY; make that buffer current.
979 BODY is executed just like `progn'.
980 usage: (save-current-buffer &rest BODY) */)
983 ptrdiff_t count
= SPECPDL_INDEX ();
985 record_unwind_current_buffer ();
986 return unbind_to (count
, Fprogn (args
));
989 DEFUN ("buffer-size", Fbuffer_size
, Sbuffer_size
, 0, 1, 0,
990 doc
: /* Return the number of characters in the current buffer.
991 If BUFFER, return the number of characters in that buffer instead. */)
995 return make_number (Z
- BEG
);
998 CHECK_BUFFER (buffer
);
999 return make_number (BUF_Z (XBUFFER (buffer
))
1000 - BUF_BEG (XBUFFER (buffer
)));
1004 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
1005 doc
: /* Return the minimum permissible value of point in the current buffer.
1006 This is 1, unless narrowing (a buffer restriction) is in effect. */)
1010 XSETFASTINT (temp
, BEGV
);
1014 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
1015 doc
: /* Return a marker to the minimum permissible value of point in this buffer.
1016 This is the beginning, unless narrowing (a buffer restriction) is in effect. */)
1019 return build_marker (current_buffer
, BEGV
, BEGV_BYTE
);
1022 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
1023 doc
: /* Return the maximum permissible value of point in the current buffer.
1024 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1025 is in effect, in which case it is less. */)
1029 XSETFASTINT (temp
, ZV
);
1033 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
1034 doc
: /* Return a marker to the maximum permissible value of point in this buffer.
1035 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1036 is in effect, in which case it is less. */)
1039 return build_marker (current_buffer
, ZV
, ZV_BYTE
);
1042 DEFUN ("gap-position", Fgap_position
, Sgap_position
, 0, 0, 0,
1043 doc
: /* Return the position of the gap, in the current buffer.
1044 See also `gap-size'. */)
1048 XSETFASTINT (temp
, GPT
);
1052 DEFUN ("gap-size", Fgap_size
, Sgap_size
, 0, 0, 0,
1053 doc
: /* Return the size of the current buffer's gap.
1054 See also `gap-position'. */)
1058 XSETFASTINT (temp
, GAP_SIZE
);
1062 DEFUN ("position-bytes", Fposition_bytes
, Sposition_bytes
, 1, 1, 0,
1063 doc
: /* Return the byte position for character position POSITION.
1064 If POSITION is out of range, the value is nil. */)
1065 (Lisp_Object position
)
1067 CHECK_NUMBER_COERCE_MARKER (position
);
1068 if (XINT (position
) < BEG
|| XINT (position
) > Z
)
1070 return make_number (CHAR_TO_BYTE (XINT (position
)));
1073 DEFUN ("byte-to-position", Fbyte_to_position
, Sbyte_to_position
, 1, 1, 0,
1074 doc
: /* Return the character position for byte position BYTEPOS.
1075 If BYTEPOS is out of range, the value is nil. */)
1076 (Lisp_Object bytepos
)
1078 CHECK_NUMBER (bytepos
);
1079 if (XINT (bytepos
) < BEG_BYTE
|| XINT (bytepos
) > Z_BYTE
)
1081 return make_number (BYTE_TO_CHAR (XINT (bytepos
)));
1084 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
1085 doc
: /* Return the character following point, as a number.
1086 At the end of the buffer or accessible region, return 0. */)
1091 XSETFASTINT (temp
, 0);
1093 XSETFASTINT (temp
, FETCH_CHAR (PT_BYTE
));
1097 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
1098 doc
: /* Return the character preceding point, as a number.
1099 At the beginning of the buffer or accessible region, return 0. */)
1104 XSETFASTINT (temp
, 0);
1105 else if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1107 ptrdiff_t pos
= PT_BYTE
;
1109 XSETFASTINT (temp
, FETCH_CHAR (pos
));
1112 XSETFASTINT (temp
, FETCH_BYTE (PT_BYTE
- 1));
1116 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
1117 doc
: /* Return t if point is at the beginning of the buffer.
1118 If the buffer is narrowed, this means the beginning of the narrowed part. */)
1126 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
1127 doc
: /* Return t if point is at the end of the buffer.
1128 If the buffer is narrowed, this means the end of the narrowed part. */)
1136 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
1137 doc
: /* Return t if point is at the beginning of a line. */)
1140 if (PT
== BEGV
|| FETCH_BYTE (PT_BYTE
- 1) == '\n')
1145 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
1146 doc
: /* Return t if point is at the end of a line.
1147 `End of a line' includes point being at the end of the buffer. */)
1150 if (PT
== ZV
|| FETCH_BYTE (PT_BYTE
) == '\n')
1155 DEFUN ("char-after", Fchar_after
, Schar_after
, 0, 1, 0,
1156 doc
: /* Return character in current buffer at position POS.
1157 POS is an integer or a marker and defaults to point.
1158 If POS is out of range, the value is nil. */)
1161 register ptrdiff_t pos_byte
;
1166 XSETFASTINT (pos
, PT
);
1171 pos_byte
= marker_byte_position (pos
);
1172 if (pos_byte
< BEGV_BYTE
|| pos_byte
>= ZV_BYTE
)
1177 CHECK_NUMBER_COERCE_MARKER (pos
);
1178 if (XINT (pos
) < BEGV
|| XINT (pos
) >= ZV
)
1181 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1184 return make_number (FETCH_CHAR (pos_byte
));
1187 DEFUN ("char-before", Fchar_before
, Schar_before
, 0, 1, 0,
1188 doc
: /* Return character in current buffer preceding position POS.
1189 POS is an integer or a marker and defaults to point.
1190 If POS is out of range, the value is nil. */)
1193 register Lisp_Object val
;
1194 register ptrdiff_t pos_byte
;
1199 XSETFASTINT (pos
, PT
);
1204 pos_byte
= marker_byte_position (pos
);
1206 if (pos_byte
<= BEGV_BYTE
|| pos_byte
> ZV_BYTE
)
1211 CHECK_NUMBER_COERCE_MARKER (pos
);
1213 if (XINT (pos
) <= BEGV
|| XINT (pos
) > ZV
)
1216 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1219 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1222 XSETFASTINT (val
, FETCH_CHAR (pos_byte
));
1227 XSETFASTINT (val
, FETCH_BYTE (pos_byte
));
1232 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 1, 0,
1233 doc
: /* Return the name under which the user logged in, as a string.
1234 This is based on the effective uid, not the real uid.
1235 Also, if the environment variables LOGNAME or USER are set,
1236 that determines the value of this function.
1238 If optional argument UID is an integer or a float, return the login name
1239 of the user with that uid, or nil if there is no such user. */)
1245 /* Set up the user name info if we didn't do it before.
1246 (That can happen if Emacs is dumpable
1247 but you decide to run `temacs -l loadup' and not dump. */
1248 if (INTEGERP (Vuser_login_name
))
1252 return Vuser_login_name
;
1254 CONS_TO_INTEGER (uid
, uid_t
, id
);
1258 return (pw
? build_string (pw
->pw_name
) : Qnil
);
1261 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
1263 doc
: /* Return the name of the user's real uid, as a string.
1264 This ignores the environment variables LOGNAME and USER, so it differs from
1265 `user-login-name' when running under `su'. */)
1268 /* Set up the user name info if we didn't do it before.
1269 (That can happen if Emacs is dumpable
1270 but you decide to run `temacs -l loadup' and not dump. */
1271 if (INTEGERP (Vuser_login_name
))
1273 return Vuser_real_login_name
;
1276 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
1277 doc
: /* Return the effective uid of Emacs.
1278 Value is an integer or a float, depending on the value. */)
1281 uid_t euid
= geteuid ();
1282 return make_fixnum_or_float (euid
);
1285 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
1286 doc
: /* Return the real uid of Emacs.
1287 Value is an integer or a float, depending on the value. */)
1290 uid_t uid
= getuid ();
1291 return make_fixnum_or_float (uid
);
1294 DEFUN ("group-gid", Fgroup_gid
, Sgroup_gid
, 0, 0, 0,
1295 doc
: /* Return the effective gid of Emacs.
1296 Value is an integer or a float, depending on the value. */)
1299 gid_t egid
= getegid ();
1300 return make_fixnum_or_float (egid
);
1303 DEFUN ("group-real-gid", Fgroup_real_gid
, Sgroup_real_gid
, 0, 0, 0,
1304 doc
: /* Return the real gid of Emacs.
1305 Value is an integer or a float, depending on the value. */)
1308 gid_t gid
= getgid ();
1309 return make_fixnum_or_float (gid
);
1312 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 1, 0,
1313 doc
: /* Return the full name of the user logged in, as a string.
1314 If the full name corresponding to Emacs's userid is not known,
1317 If optional argument UID is an integer or float, return the full name
1318 of the user with that uid, or nil if there is no such user.
1319 If UID is a string, return the full name of the user with that login
1320 name, or nil if there is no such user. */)
1324 register char *p
, *q
;
1328 return Vuser_full_name
;
1329 else if (NUMBERP (uid
))
1332 CONS_TO_INTEGER (uid
, uid_t
, u
);
1337 else if (STRINGP (uid
))
1340 pw
= getpwnam (SSDATA (uid
));
1344 error ("Invalid UID specification");
1350 /* Chop off everything after the first comma. */
1351 q
= strchr (p
, ',');
1352 full
= make_string (p
, q
? q
- p
: strlen (p
));
1354 #ifdef AMPERSAND_FULL_NAME
1356 q
= strchr (p
, '&');
1357 /* Substitute the login name for the &, upcasing the first character. */
1360 Lisp_Object login
= Fuser_login_name (make_number (pw
->pw_uid
));
1362 char *r
= SAFE_ALLOCA (strlen (p
) + SBYTES (login
) + 1);
1363 memcpy (r
, p
, q
- p
);
1364 char *s
= lispstpcpy (&r
[q
- p
], login
);
1365 r
[q
- p
] = upcase ((unsigned char) r
[q
- p
]);
1367 full
= build_string (r
);
1370 #endif /* AMPERSAND_FULL_NAME */
1375 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
1376 doc
: /* Return the host name of the machine you are running on, as a string. */)
1379 if (EQ (Vsystem_name
, cached_system_name
))
1380 init_and_cache_system_name ();
1381 return Vsystem_name
;
1384 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
1385 doc
: /* Return the process ID of Emacs, as a number. */)
1388 pid_t pid
= getpid ();
1389 return make_fixnum_or_float (pid
);
1395 # define TIME_T_MIN TYPE_MINIMUM (time_t)
1398 # define TIME_T_MAX TYPE_MAXIMUM (time_t)
1401 /* Report that a time value is out of range for Emacs. */
1403 time_overflow (void)
1405 error ("Specified time is not representable");
1411 error ("Invalid time specification");
1414 /* A substitute for mktime_z on platforms that lack it. It's not
1415 thread-safe, but should be good enough for Emacs in typical use. */
1416 #ifndef HAVE_TZALLOC
1418 mktime_z (timezone_t tz
, struct tm
*tm
)
1420 char *oldtz
= getenv ("TZ");
1424 size_t oldtzsize
= strlen (oldtz
) + 1;
1425 char *oldtzcopy
= SAFE_ALLOCA (oldtzsize
);
1426 oldtz
= strcpy (oldtzcopy
, oldtz
);
1429 set_time_zone_rule (tz
);
1430 time_t t
= mktime (tm
);
1431 set_time_zone_rule (oldtz
);
1438 /* Return the upper part of the time T (everything but the bottom 16 bits). */
1442 time_t hi
= t
>> LO_TIME_BITS
;
1444 /* Check for overflow, helping the compiler for common cases where
1445 no runtime check is needed, and taking care not to convert
1446 negative numbers to unsigned before comparing them. */
1447 if (! ((! TYPE_SIGNED (time_t)
1448 || MOST_NEGATIVE_FIXNUM
<= TIME_T_MIN
>> LO_TIME_BITS
1449 || MOST_NEGATIVE_FIXNUM
<= hi
)
1450 && (TIME_T_MAX
>> LO_TIME_BITS
<= MOST_POSITIVE_FIXNUM
1451 || hi
<= MOST_POSITIVE_FIXNUM
)))
1457 /* Return the bottom bits of the time T. */
1461 return t
& ((1 << LO_TIME_BITS
) - 1);
1464 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
1465 doc
: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
1466 The time is returned as a list of integers (HIGH LOW USEC PSEC).
1467 HIGH has the most significant bits of the seconds, while LOW has the
1468 least significant 16 bits. USEC and PSEC are the microsecond and
1469 picosecond counts. */)
1472 return make_lisp_time (current_timespec ());
1475 static struct lisp_time
1476 time_add (struct lisp_time ta
, struct lisp_time tb
)
1478 EMACS_INT hi
= ta
.hi
+ tb
.hi
;
1479 int lo
= ta
.lo
+ tb
.lo
;
1480 int us
= ta
.us
+ tb
.us
;
1481 int ps
= ta
.ps
+ tb
.ps
;
1482 us
+= (1000000 <= ps
);
1483 ps
-= (1000000 <= ps
) * 1000000;
1484 lo
+= (1000000 <= us
);
1485 us
-= (1000000 <= us
) * 1000000;
1486 hi
+= (1 << LO_TIME_BITS
<= lo
);
1487 lo
-= (1 << LO_TIME_BITS
<= lo
) << LO_TIME_BITS
;
1488 return (struct lisp_time
) { hi
, lo
, us
, ps
};
1491 static struct lisp_time
1492 time_subtract (struct lisp_time ta
, struct lisp_time tb
)
1494 EMACS_INT hi
= ta
.hi
- tb
.hi
;
1495 int lo
= ta
.lo
- tb
.lo
;
1496 int us
= ta
.us
- tb
.us
;
1497 int ps
= ta
.ps
- tb
.ps
;
1499 ps
+= (ps
< 0) * 1000000;
1501 us
+= (us
< 0) * 1000000;
1503 lo
+= (lo
< 0) << LO_TIME_BITS
;
1504 return (struct lisp_time
) { hi
, lo
, us
, ps
};
1508 time_arith (Lisp_Object a
, Lisp_Object b
,
1509 struct lisp_time (*op
) (struct lisp_time
, struct lisp_time
))
1512 struct lisp_time ta
= lisp_time_struct (a
, &alen
);
1513 struct lisp_time tb
= lisp_time_struct (b
, &blen
);
1514 struct lisp_time t
= op (ta
, tb
);
1515 if (! (MOST_NEGATIVE_FIXNUM
<= t
.hi
&& t
.hi
<= MOST_POSITIVE_FIXNUM
))
1517 Lisp_Object val
= Qnil
;
1519 switch (max (alen
, blen
))
1522 val
= Fcons (make_number (t
.ps
), val
);
1525 val
= Fcons (make_number (t
.us
), val
);
1528 val
= Fcons (make_number (t
.lo
), val
);
1529 val
= Fcons (make_number (t
.hi
), val
);
1536 DEFUN ("time-add", Ftime_add
, Stime_add
, 2, 2, 0,
1537 doc
: /* Return the sum of two time values A and B, as a time value. */)
1538 (Lisp_Object a
, Lisp_Object b
)
1540 return time_arith (a
, b
, time_add
);
1543 DEFUN ("time-subtract", Ftime_subtract
, Stime_subtract
, 2, 2, 0,
1544 doc
: /* Return the difference between two time values A and B, as a time value. */)
1545 (Lisp_Object a
, Lisp_Object b
)
1547 return time_arith (a
, b
, time_subtract
);
1550 DEFUN ("time-less-p", Ftime_less_p
, Stime_less_p
, 2, 2, 0,
1551 doc
: /* Return non-nil if time value T1 is earlier than time value T2. */)
1552 (Lisp_Object t1
, Lisp_Object t2
)
1555 struct lisp_time a
= lisp_time_struct (t1
, &t1len
);
1556 struct lisp_time b
= lisp_time_struct (t2
, &t2len
);
1557 return ((a
.hi
!= b
.hi
? a
.hi
< b
.hi
1558 : a
.lo
!= b
.lo
? a
.lo
< b
.lo
1559 : a
.us
!= b
.us
? a
.us
< b
.us
1565 DEFUN ("get-internal-run-time", Fget_internal_run_time
, Sget_internal_run_time
,
1567 doc
: /* Return the current run time used by Emacs.
1568 The time is returned as a list (HIGH LOW USEC PSEC), using the same
1569 style as (current-time).
1571 On systems that can't determine the run time, `get-internal-run-time'
1572 does the same thing as `current-time'. */)
1575 #ifdef HAVE_GETRUSAGE
1576 struct rusage usage
;
1580 if (getrusage (RUSAGE_SELF
, &usage
) < 0)
1581 /* This shouldn't happen. What action is appropriate? */
1584 /* Sum up user time and system time. */
1585 secs
= usage
.ru_utime
.tv_sec
+ usage
.ru_stime
.tv_sec
;
1586 usecs
= usage
.ru_utime
.tv_usec
+ usage
.ru_stime
.tv_usec
;
1587 if (usecs
>= 1000000)
1592 return make_lisp_time (make_timespec (secs
, usecs
* 1000));
1593 #else /* ! HAVE_GETRUSAGE */
1595 return w32_get_internal_run_time ();
1596 #else /* ! WINDOWSNT */
1597 return Fcurrent_time ();
1598 #endif /* WINDOWSNT */
1599 #endif /* HAVE_GETRUSAGE */
1603 /* Make a Lisp list that represents the Emacs time T. T may be an
1604 invalid time, with a slightly negative tv_nsec value such as
1605 UNKNOWN_MODTIME_NSECS; in that case, the Lisp list contains a
1606 correspondingly negative picosecond count. */
1608 make_lisp_time (struct timespec t
)
1610 time_t s
= t
.tv_sec
;
1612 return list4i (hi_time (s
), lo_time (s
), ns
/ 1000, ns
% 1000 * 1000);
1615 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1616 Set *PHIGH, *PLOW, *PUSEC, *PPSEC to its parts; do not check their values.
1617 Return 2, 3, or 4 to indicate the effective length of SPECIFIED_TIME
1618 if successful, 0 if unsuccessful. */
1620 disassemble_lisp_time (Lisp_Object specified_time
, Lisp_Object
*phigh
,
1621 Lisp_Object
*plow
, Lisp_Object
*pusec
,
1624 Lisp_Object high
= make_number (0);
1625 Lisp_Object low
= specified_time
;
1626 Lisp_Object usec
= make_number (0);
1627 Lisp_Object psec
= make_number (0);
1630 if (CONSP (specified_time
))
1632 high
= XCAR (specified_time
);
1633 low
= XCDR (specified_time
);
1636 Lisp_Object low_tail
= XCDR (low
);
1638 if (CONSP (low_tail
))
1640 usec
= XCAR (low_tail
);
1641 low_tail
= XCDR (low_tail
);
1642 if (CONSP (low_tail
))
1643 psec
= XCAR (low_tail
);
1647 else if (!NILP (low_tail
))
1658 /* When combining components, require LOW to be an integer,
1659 as otherwise it would be a pain to add up times. */
1660 if (! INTEGERP (low
))
1663 else if (INTEGERP (specified_time
))
1673 /* Convert T into an Emacs time *RESULT, truncating toward minus infinity.
1674 Return true if T is in range, false otherwise. */
1676 decode_float_time (double t
, struct lisp_time
*result
)
1678 double lo_multiplier
= 1 << LO_TIME_BITS
;
1679 double emacs_time_min
= MOST_NEGATIVE_FIXNUM
* lo_multiplier
;
1680 if (! (emacs_time_min
<= t
&& t
< -emacs_time_min
))
1683 double small_t
= t
/ lo_multiplier
;
1684 EMACS_INT hi
= small_t
;
1685 double t_sans_hi
= t
- hi
* lo_multiplier
;
1687 long double fracps
= (t_sans_hi
- lo
) * 1e12L
;
1688 #ifdef INT_FAST64_MAX
1689 int_fast64_t ifracps
= fracps
;
1690 int us
= ifracps
/ 1000000;
1691 int ps
= ifracps
% 1000000;
1693 int us
= fracps
/ 1e6L
;
1694 int ps
= fracps
- us
* 1e6L
;
1697 ps
+= (ps
< 0) * 1000000;
1699 us
+= (us
< 0) * 1000000;
1701 lo
+= (lo
< 0) << LO_TIME_BITS
;
1709 /* From the time components HIGH, LOW, USEC and PSEC taken from a Lisp
1710 list, generate the corresponding time value.
1711 If LOW is floating point, the other components should be zero.
1713 If RESULT is not null, store into *RESULT the converted time.
1714 If *DRESULT is not null, store into *DRESULT the number of
1715 seconds since the start of the POSIX Epoch.
1717 Return true if successful, false if the components are of the
1718 wrong type or represent a time out of range. */
1720 decode_time_components (Lisp_Object high
, Lisp_Object low
, Lisp_Object usec
,
1722 struct lisp_time
*result
, double *dresult
)
1724 EMACS_INT hi
, lo
, us
, ps
;
1725 if (! (INTEGERP (high
)
1726 && INTEGERP (usec
) && INTEGERP (psec
)))
1728 if (! INTEGERP (low
))
1732 double t
= XFLOAT_DATA (low
);
1733 if (result
&& ! decode_float_time (t
, result
))
1739 else if (NILP (low
))
1741 struct timespec now
= current_timespec ();
1744 result
->hi
= hi_time (now
.tv_sec
);
1745 result
->lo
= lo_time (now
.tv_sec
);
1746 result
->us
= now
.tv_nsec
/ 1000;
1747 result
->ps
= now
.tv_nsec
% 1000 * 1000;
1750 *dresult
= now
.tv_sec
+ now
.tv_nsec
/ 1e9
;
1762 /* Normalize out-of-range lower-order components by carrying
1763 each overflow into the next higher-order component. */
1764 us
+= ps
/ 1000000 - (ps
% 1000000 < 0);
1765 lo
+= us
/ 1000000 - (us
% 1000000 < 0);
1766 hi
+= lo
>> LO_TIME_BITS
;
1767 ps
= ps
% 1000000 + 1000000 * (ps
% 1000000 < 0);
1768 us
= us
% 1000000 + 1000000 * (us
% 1000000 < 0);
1769 lo
&= (1 << LO_TIME_BITS
) - 1;
1773 if (! (MOST_NEGATIVE_FIXNUM
<= hi
&& hi
<= MOST_POSITIVE_FIXNUM
))
1784 *dresult
= (us
* 1e6
+ ps
) / 1e12
+ lo
+ dhi
* (1 << LO_TIME_BITS
);
1791 lisp_to_timespec (struct lisp_time t
)
1793 if (! ((TYPE_SIGNED (time_t) ? TIME_T_MIN
>> LO_TIME_BITS
<= t
.hi
: 0 <= t
.hi
)
1794 && t
.hi
<= TIME_T_MAX
>> LO_TIME_BITS
))
1795 return invalid_timespec ();
1796 time_t s
= (t
.hi
<< LO_TIME_BITS
) + t
.lo
;
1797 int ns
= t
.us
* 1000 + t
.ps
/ 1000;
1798 return make_timespec (s
, ns
);
1801 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1802 Store its effective length into *PLEN.
1803 If SPECIFIED_TIME is nil, use the current time.
1804 Signal an error if SPECIFIED_TIME does not represent a time. */
1805 static struct lisp_time
1806 lisp_time_struct (Lisp_Object specified_time
, int *plen
)
1808 Lisp_Object high
, low
, usec
, psec
;
1810 int len
= disassemble_lisp_time (specified_time
, &high
, &low
, &usec
, &psec
);
1811 if (! (len
&& decode_time_components (high
, low
, usec
, psec
, &t
, 0)))
1817 /* Like lisp_time_struct, except return a struct timespec.
1818 Discard any low-order digits. */
1820 lisp_time_argument (Lisp_Object specified_time
)
1823 struct lisp_time lt
= lisp_time_struct (specified_time
, &len
);
1824 struct timespec t
= lisp_to_timespec (lt
);
1825 if (! timespec_valid_p (t
))
1830 /* Like lisp_time_argument, except decode only the seconds part,
1831 and do not check the subseconds part. */
1833 lisp_seconds_argument (Lisp_Object specified_time
)
1835 Lisp_Object high
, low
, usec
, psec
;
1837 if (! (disassemble_lisp_time (specified_time
, &high
, &low
, &usec
, &psec
)
1838 && decode_time_components (high
, low
, make_number (0),
1839 make_number (0), &t
, 0)))
1841 if (! ((TYPE_SIGNED (time_t) ? TIME_T_MIN
>> LO_TIME_BITS
<= t
.hi
: 0 <= t
.hi
)
1842 && t
.hi
<= TIME_T_MAX
>> LO_TIME_BITS
))
1844 return (t
.hi
<< LO_TIME_BITS
) + t
.lo
;
1847 DEFUN ("float-time", Ffloat_time
, Sfloat_time
, 0, 1, 0,
1848 doc
: /* Return the current time, as a float number of seconds since the epoch.
1849 If SPECIFIED-TIME is given, it is the time to convert to float
1850 instead of the current time. The argument should have the form
1851 (HIGH LOW) or (HIGH LOW USEC) or (HIGH LOW USEC PSEC). Thus,
1852 you can use times from `current-time' and from `file-attributes'.
1853 SPECIFIED-TIME can also have the form (HIGH . LOW), but this is
1854 considered obsolete.
1856 WARNING: Since the result is floating point, it may not be exact.
1857 If precise time stamps are required, use either `current-time',
1858 or (if you need time as a string) `format-time-string'. */)
1859 (Lisp_Object specified_time
)
1862 Lisp_Object high
, low
, usec
, psec
;
1863 if (! (disassemble_lisp_time (specified_time
, &high
, &low
, &usec
, &psec
)
1864 && decode_time_components (high
, low
, usec
, psec
, 0, &t
)))
1866 return make_float (t
);
1869 /* Write information into buffer S of size MAXSIZE, according to the
1870 FORMAT of length FORMAT_LEN, using time information taken from *TP.
1871 Default to Universal Time if UT, local time otherwise.
1872 Use NS as the number of nanoseconds in the %N directive.
1873 Return the number of bytes written, not including the terminating
1874 '\0'. If S is NULL, nothing will be written anywhere; so to
1875 determine how many bytes would be written, use NULL for S and
1876 ((size_t) -1) for MAXSIZE.
1878 This function behaves like nstrftime, except it allows null
1879 bytes in FORMAT and it does not support nanoseconds. */
1881 emacs_nmemftime (char *s
, size_t maxsize
, const char *format
,
1882 size_t format_len
, const struct tm
*tp
, bool ut
, int ns
)
1886 /* Loop through all the null-terminated strings in the format
1887 argument. Normally there's just one null-terminated string, but
1888 there can be arbitrarily many, concatenated together, if the
1889 format contains '\0' bytes. nstrftime stops at the first
1890 '\0' byte so we must invoke it separately for each such string. */
1899 result
= nstrftime (s
, maxsize
, format
, tp
, ut
, ns
);
1903 if (result
== 0 && s
[0] != '\0')
1908 maxsize
-= result
+ 1;
1910 len
= strlen (format
);
1911 if (len
== format_len
)
1915 format_len
-= len
+ 1;
1919 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 1, 3, 0,
1920 doc
: /* Use FORMAT-STRING to format the time TIME, or now if omitted.
1921 TIME is specified as (HIGH LOW USEC PSEC), as returned by
1922 `current-time' or `file-attributes'. The obsolete form (HIGH . LOW)
1923 is also still accepted.
1924 The third, optional, argument UNIVERSAL, if non-nil, means describe TIME
1925 as Universal Time; nil means describe TIME in the local time zone.
1926 The value is a copy of FORMAT-STRING, but with certain constructs replaced
1927 by text that describes the specified date and time in TIME:
1929 %Y is the year, %y within the century, %C the century.
1930 %G is the year corresponding to the ISO week, %g within the century.
1931 %m is the numeric month.
1932 %b and %h are the locale's abbreviated month name, %B the full name.
1933 (%h is not supported on MS-Windows.)
1934 %d is the day of the month, zero-padded, %e is blank-padded.
1935 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
1936 %a is the locale's abbreviated name of the day of week, %A the full name.
1937 %U is the week number starting on Sunday, %W starting on Monday,
1938 %V according to ISO 8601.
1939 %j is the day of the year.
1941 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
1942 only blank-padded, %l is like %I blank-padded.
1943 %p is the locale's equivalent of either AM or PM.
1946 %N is the nanosecond, %6N the microsecond, %3N the millisecond, etc.
1947 %Z is the time zone name, %z is the numeric form.
1948 %s is the number of seconds since 1970-01-01 00:00:00 +0000.
1950 %c is the locale's date and time format.
1951 %x is the locale's "preferred" date format.
1952 %D is like "%m/%d/%y".
1953 %F is the ISO 8601 date format (like "%Y-%m-%d").
1955 %R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
1956 %X is the locale's "preferred" time format.
1958 Finally, %n is a newline, %t is a tab, %% is a literal %.
1960 Certain flags and modifiers are available with some format controls.
1961 The flags are `_', `-', `^' and `#'. For certain characters X,
1962 %_X is like %X, but padded with blanks; %-X is like %X,
1963 but without padding. %^X is like %X, but with all textual
1964 characters up-cased; %#X is like %X, but with letter-case of
1965 all textual characters reversed.
1966 %NX (where N stands for an integer) is like %X,
1967 but takes up at least N (a number) positions.
1968 The modifiers are `E' and `O'. For certain characters X,
1969 %EX is a locale's alternative version of %X;
1970 %OX is like %X, but uses the locale's number symbols.
1972 For example, to produce full ISO 8601 format, use "%FT%T%z".
1974 usage: (format-time-string FORMAT-STRING &optional TIME UNIVERSAL) */)
1975 (Lisp_Object format_string
, Lisp_Object timeval
, Lisp_Object universal
)
1977 struct timespec t
= lisp_time_argument (timeval
);
1980 CHECK_STRING (format_string
);
1981 format_string
= code_convert_string_norecord (format_string
,
1982 Vlocale_coding_system
, 1);
1983 return format_time_string (SSDATA (format_string
), SBYTES (format_string
),
1984 t
, ! NILP (universal
), &tm
);
1988 format_time_string (char const *format
, ptrdiff_t formatlen
,
1989 struct timespec t
, bool ut
, struct tm
*tmp
)
1993 ptrdiff_t size
= sizeof buffer
;
1995 Lisp_Object bufstring
;
1999 tmp
= ut
? gmtime_r (&t
.tv_sec
, tmp
) : localtime_r (&t
.tv_sec
, tmp
);
2002 synchronize_system_time_locale ();
2007 len
= emacs_nmemftime (buf
, size
, format
, formatlen
, tmp
, ut
, ns
);
2008 if ((0 < len
&& len
< size
) || (len
== 0 && buf
[0] == '\0'))
2011 /* Buffer was too small, so make it bigger and try again. */
2012 len
= emacs_nmemftime (NULL
, SIZE_MAX
, format
, formatlen
, tmp
, ut
, ns
);
2013 if (STRING_BYTES_BOUND
<= len
)
2016 buf
= SAFE_ALLOCA (size
);
2019 bufstring
= make_unibyte_string (buf
, len
);
2021 return code_convert_string_norecord (bufstring
, Vlocale_coding_system
, 0);
2024 DEFUN ("decode-time", Fdecode_time
, Sdecode_time
, 0, 1, 0,
2025 doc
: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST ZONE).
2026 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED),
2027 as from `current-time' and `file-attributes', or nil to use the
2028 current time. The obsolete form (HIGH . LOW) is also still accepted.
2029 The list has the following nine members: SEC is an integer between 0
2030 and 60; SEC is 60 for a leap second, which only some operating systems
2031 support. MINUTE is an integer between 0 and 59. HOUR is an integer
2032 between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
2033 integer between 1 and 12. YEAR is an integer indicating the
2034 four-digit year. DOW is the day of week, an integer between 0 and 6,
2035 where 0 is Sunday. DST is t if daylight saving time is in effect,
2036 otherwise nil. ZONE is an integer indicating the number of seconds
2037 east of Greenwich. (Note that Common Lisp has different meanings for
2039 (Lisp_Object specified_time
)
2041 time_t time_spec
= lisp_seconds_argument (specified_time
);
2042 struct tm local_tm
, gmt_tm
;
2044 if (! (localtime_r (&time_spec
, &local_tm
)
2045 && MOST_NEGATIVE_FIXNUM
- TM_YEAR_BASE
<= local_tm
.tm_year
2046 && local_tm
.tm_year
<= MOST_POSITIVE_FIXNUM
- TM_YEAR_BASE
))
2049 /* Avoid overflow when INT_MAX < EMACS_INT_MAX. */
2050 EMACS_INT tm_year_base
= TM_YEAR_BASE
;
2052 return Flist (9, ((Lisp_Object
[])
2053 {make_number (local_tm
.tm_sec
),
2054 make_number (local_tm
.tm_min
),
2055 make_number (local_tm
.tm_hour
),
2056 make_number (local_tm
.tm_mday
),
2057 make_number (local_tm
.tm_mon
+ 1),
2058 make_number (local_tm
.tm_year
+ tm_year_base
),
2059 make_number (local_tm
.tm_wday
),
2060 local_tm
.tm_isdst
? Qt
: Qnil
,
2062 ? make_number (tm_gmtoff (&local_tm
))
2063 : gmtime_r (&time_spec
, &gmt_tm
)
2064 ? make_number (tm_diff (&local_tm
, &gmt_tm
))
2068 /* Return OBJ - OFFSET, checking that OBJ is a valid fixnum and that
2069 the result is representable as an int. Assume OFFSET is small and
2072 check_tm_member (Lisp_Object obj
, int offset
)
2077 if (! (INT_MIN
+ offset
<= n
&& n
- offset
<= INT_MAX
))
2082 DEFUN ("encode-time", Fencode_time
, Sencode_time
, 6, MANY
, 0,
2083 doc
: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
2084 This is the reverse operation of `decode-time', which see.
2085 ZONE defaults to the current time zone rule. This can
2086 be a string or t (as from `set-time-zone-rule'), or it can be a list
2087 \(as from `current-time-zone') or an integer (as from `decode-time')
2088 applied without consideration for daylight saving time.
2090 You can pass more than 7 arguments; then the first six arguments
2091 are used as SECOND through YEAR, and the *last* argument is used as ZONE.
2092 The intervening arguments are ignored.
2093 This feature lets (apply 'encode-time (decode-time ...)) work.
2095 Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed;
2096 for example, a DAY of 0 means the day preceding the given month.
2097 Year numbers less than 100 are treated just like other year numbers.
2098 If you want them to stand for years in this century, you must do that yourself.
2100 Years before 1970 are not guaranteed to work. On some systems,
2101 year values as low as 1901 do work.
2103 usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
2104 (ptrdiff_t nargs
, Lisp_Object
*args
)
2108 Lisp_Object zone
= (nargs
> 6 ? args
[nargs
- 1] : Qnil
);
2110 tm
.tm_sec
= check_tm_member (args
[0], 0);
2111 tm
.tm_min
= check_tm_member (args
[1], 0);
2112 tm
.tm_hour
= check_tm_member (args
[2], 0);
2113 tm
.tm_mday
= check_tm_member (args
[3], 0);
2114 tm
.tm_mon
= check_tm_member (args
[4], 1);
2115 tm
.tm_year
= check_tm_member (args
[5], TM_YEAR_BASE
);
2121 value
= mktime (&tm
);
2124 static char const tzbuf_format
[] = "XXX%s%"pI
"d:%02d:%02d";
2125 char tzbuf
[sizeof tzbuf_format
+ INT_STRLEN_BOUND (EMACS_INT
)];
2126 const char *tzstring
;
2130 else if (STRINGP (zone
))
2131 tzstring
= SSDATA (zone
);
2132 else if (INTEGERP (zone
))
2134 EMACS_INT abszone
= eabs (XINT (zone
));
2135 EMACS_INT zone_hr
= abszone
/ (60*60);
2136 int zone_min
= (abszone
/60) % 60;
2137 int zone_sec
= abszone
% 60;
2138 sprintf (tzbuf
, tzbuf_format
, &"-"[XINT (zone
) < 0],
2139 zone_hr
, zone_min
, zone_sec
);
2145 timezone_t tz
= tzstring
? tzalloc (tzstring
) : 0;
2147 error ("Invalid time zone specification");
2148 value
= mktime_z (tz
, &tm
);
2152 if (value
== (time_t) -1)
2155 return list2i (hi_time (value
), lo_time (value
));
2158 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
2159 doc
: /* Return the current local time, as a human-readable string.
2160 Programs can use this function to decode a time,
2161 since the number of columns in each field is fixed
2162 if the year is in the range 1000-9999.
2163 The format is `Sun Sep 16 01:03:52 1973'.
2164 However, see also the functions `decode-time' and `format-time-string'
2165 which provide a much more powerful and general facility.
2167 If SPECIFIED-TIME is given, it is a time to format instead of the
2168 current time. The argument should have the form (HIGH LOW . IGNORED).
2169 Thus, you can use times obtained from `current-time' and from
2170 `file-attributes'. SPECIFIED-TIME can also have the form (HIGH . LOW),
2171 but this is considered obsolete. */)
2172 (Lisp_Object specified_time
)
2174 time_t value
= lisp_seconds_argument (specified_time
);
2176 /* Convert to a string in ctime format, except without the trailing
2177 newline, and without the 4-digit year limit. Don't use asctime
2178 or ctime, as they might dump core if the year is outside the
2179 range -999 .. 9999. */
2181 if (! localtime_r (&value
, &tm
))
2184 static char const wday_name
[][4] =
2185 { "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat" };
2186 static char const mon_name
[][4] =
2187 { "Jan", "Feb", "Mar", "Apr", "May", "Jun",
2188 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" };
2189 printmax_t year_base
= TM_YEAR_BASE
;
2190 char buf
[sizeof "Mon Apr 30 12:49:17 " + INT_STRLEN_BOUND (int) + 1];
2191 int len
= sprintf (buf
, "%s %s%3d %02d:%02d:%02d %"pMd
,
2192 wday_name
[tm
.tm_wday
], mon_name
[tm
.tm_mon
], tm
.tm_mday
,
2193 tm
.tm_hour
, tm
.tm_min
, tm
.tm_sec
,
2194 tm
.tm_year
+ year_base
);
2196 return make_unibyte_string (buf
, len
);
2199 /* Yield A - B, measured in seconds.
2200 This function is copied from the GNU C Library. */
2202 tm_diff (struct tm
*a
, struct tm
*b
)
2204 /* Compute intervening leap days correctly even if year is negative.
2205 Take care to avoid int overflow in leap day calculations,
2206 but it's OK to assume that A and B are close to each other. */
2207 int a4
= (a
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (a
->tm_year
& 3);
2208 int b4
= (b
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (b
->tm_year
& 3);
2209 int a100
= a4
/ 25 - (a4
% 25 < 0);
2210 int b100
= b4
/ 25 - (b4
% 25 < 0);
2211 int a400
= a100
>> 2;
2212 int b400
= b100
>> 2;
2213 int intervening_leap_days
= (a4
- b4
) - (a100
- b100
) + (a400
- b400
);
2214 int years
= a
->tm_year
- b
->tm_year
;
2215 int days
= (365 * years
+ intervening_leap_days
2216 + (a
->tm_yday
- b
->tm_yday
));
2217 return (60 * (60 * (24 * days
+ (a
->tm_hour
- b
->tm_hour
))
2218 + (a
->tm_min
- b
->tm_min
))
2219 + (a
->tm_sec
- b
->tm_sec
));
2222 /* Yield A's UTC offset, or an unspecified value if unknown. */
2224 tm_gmtoff (struct tm
*a
)
2227 return a
->tm_gmtoff
;
2233 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
2234 doc
: /* Return the offset and name for the local time zone.
2235 This returns a list of the form (OFFSET NAME).
2236 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
2237 A negative value means west of Greenwich.
2238 NAME is a string giving the name of the time zone.
2239 If SPECIFIED-TIME is given, the time zone offset is determined from it
2240 instead of using the current time. The argument should have the form
2241 (HIGH LOW . IGNORED). Thus, you can use times obtained from
2242 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
2243 have the form (HIGH . LOW), but this is considered obsolete.
2245 Some operating systems cannot provide all this information to Emacs;
2246 in this case, `current-time-zone' returns a list containing nil for
2247 the data it can't find. */)
2248 (Lisp_Object specified_time
)
2250 struct timespec value
;
2251 struct tm local_tm
, gmt_tm
;
2252 Lisp_Object zone_offset
, zone_name
;
2255 value
= make_timespec (lisp_seconds_argument (specified_time
), 0);
2256 zone_name
= format_time_string ("%Z", sizeof "%Z" - 1, value
, 0, &local_tm
);
2258 if (HAVE_TM_GMTOFF
|| gmtime_r (&value
.tv_sec
, &gmt_tm
))
2260 long int offset
= (HAVE_TM_GMTOFF
2261 ? tm_gmtoff (&local_tm
)
2262 : tm_diff (&local_tm
, &gmt_tm
));
2263 zone_offset
= make_number (offset
);
2264 if (SCHARS (zone_name
) == 0)
2266 /* No local time zone name is available; use "+-NNNN" instead. */
2267 long int m
= offset
/ 60;
2268 long int am
= offset
< 0 ? - m
: m
;
2269 long int hour
= am
/ 60;
2271 char buf
[sizeof "+00" + INT_STRLEN_BOUND (long int)];
2272 zone_name
= make_formatted_string (buf
, "%c%02ld%02d",
2273 (offset
< 0 ? '-' : '+'),
2278 return list2 (zone_offset
, zone_name
);
2281 DEFUN ("set-time-zone-rule", Fset_time_zone_rule
, Sset_time_zone_rule
, 1, 1, 0,
2282 doc
: /* Set the local time zone using TZ, a string specifying a time zone rule.
2283 If TZ is nil, use implementation-defined default time zone information.
2284 If TZ is t, use Universal Time.
2286 Instead of calling this function, you typically want (setenv "TZ" TZ).
2287 That changes both the environment of the Emacs process and the
2288 variable `process-environment', whereas `set-time-zone-rule' affects
2289 only the former. */)
2292 const char *tzstring
;
2294 if (! (NILP (tz
) || EQ (tz
, Qt
)))
2298 tzstring
= initial_tz
;
2299 else if (EQ (tz
, Qt
))
2302 tzstring
= SSDATA (tz
);
2305 set_time_zone_rule (tzstring
);
2311 /* Set the local time zone rule to TZSTRING.
2313 This function is not thread-safe, in theory because putenv is not,
2314 but mostly because of the static storage it updates. Other threads
2315 that invoke localtime etc. may be adversely affected while this
2316 function is executing. */
2319 set_time_zone_rule (const char *tzstring
)
2321 /* A buffer holding a string of the form "TZ=value", intended
2322 to be part of the environment. */
2323 static char *tzvalbuf
;
2324 static ptrdiff_t tzvalbufsize
;
2326 int tzeqlen
= sizeof "TZ=" - 1;
2327 ptrdiff_t tzstringlen
= tzstring
? strlen (tzstring
) : 0;
2328 char *tzval
= tzvalbuf
;
2329 bool new_tzvalbuf
= tzvalbufsize
<= tzeqlen
+ tzstringlen
;
2333 /* Do not attempt to free the old tzvalbuf, since another thread
2334 may be using it. In practice, the first allocation is large
2335 enough and memory does not leak. */
2336 tzval
= xpalloc (NULL
, &tzvalbufsize
,
2337 tzeqlen
+ tzstringlen
- tzvalbufsize
+ 1, -1, 1);
2345 /* Modify TZVAL in place. Although this is dicey in a
2346 multithreaded environment, we know of no portable alternative.
2347 Calling putenv or setenv could crash some other thread. */
2349 strcpy (tzval
+ tzeqlen
, tzstring
);
2353 /* Turn 'TZ=whatever' into an empty environment variable 'tZ='.
2354 Although this is also dicey, calling unsetenv here can crash Emacs.
2362 /* Although this is not thread-safe, in practice this runs only
2363 on startup when there is only one thread. */
2372 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
2373 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
2374 type of object is Lisp_String). INHERIT is passed to
2375 INSERT_FROM_STRING_FUNC as the last argument. */
2378 general_insert_function (void (*insert_func
)
2379 (const char *, ptrdiff_t),
2380 void (*insert_from_string_func
)
2381 (Lisp_Object
, ptrdiff_t, ptrdiff_t,
2382 ptrdiff_t, ptrdiff_t, bool),
2383 bool inherit
, ptrdiff_t nargs
, Lisp_Object
*args
)
2388 for (argnum
= 0; argnum
< nargs
; argnum
++)
2391 if (CHARACTERP (val
))
2393 int c
= XFASTINT (val
);
2394 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2397 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2398 len
= CHAR_STRING (c
, str
);
2401 str
[0] = CHAR_TO_BYTE8 (c
);
2404 (*insert_func
) ((char *) str
, len
);
2406 else if (STRINGP (val
))
2408 (*insert_from_string_func
) (val
, 0, 0,
2414 wrong_type_argument (Qchar_or_string_p
, val
);
2419 insert1 (Lisp_Object arg
)
2425 /* Callers passing one argument to Finsert need not gcpro the
2426 argument "array", since the only element of the array will
2427 not be used after calling insert or insert_from_string, so
2428 we don't care if it gets trashed. */
2430 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
2431 doc
: /* Insert the arguments, either strings or characters, at point.
2432 Point and before-insertion markers move forward to end up
2433 after the inserted text.
2434 Any other markers at the point of insertion remain before the text.
2436 If the current buffer is multibyte, unibyte strings are converted
2437 to multibyte for insertion (see `string-make-multibyte').
2438 If the current buffer is unibyte, multibyte strings are converted
2439 to unibyte for insertion (see `string-make-unibyte').
2441 When operating on binary data, it may be necessary to preserve the
2442 original bytes of a unibyte string when inserting it into a multibyte
2443 buffer; to accomplish this, apply `string-as-multibyte' to the string
2444 and insert the result.
2446 usage: (insert &rest ARGS) */)
2447 (ptrdiff_t nargs
, Lisp_Object
*args
)
2449 general_insert_function (insert
, insert_from_string
, 0, nargs
, args
);
2453 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
2455 doc
: /* Insert the arguments at point, inheriting properties from adjoining text.
2456 Point and before-insertion markers move forward to end up
2457 after the inserted text.
2458 Any other markers at the point of insertion remain before the text.
2460 If the current buffer is multibyte, unibyte strings are converted
2461 to multibyte for insertion (see `unibyte-char-to-multibyte').
2462 If the current buffer is unibyte, multibyte strings are converted
2463 to unibyte for insertion.
2465 usage: (insert-and-inherit &rest ARGS) */)
2466 (ptrdiff_t nargs
, Lisp_Object
*args
)
2468 general_insert_function (insert_and_inherit
, insert_from_string
, 1,
2473 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
2474 doc
: /* Insert strings or characters at point, relocating markers after the text.
2475 Point and markers move forward to end up after the inserted text.
2477 If the current buffer is multibyte, unibyte strings are converted
2478 to multibyte for insertion (see `unibyte-char-to-multibyte').
2479 If the current buffer is unibyte, multibyte strings are converted
2480 to unibyte for insertion.
2482 If an overlay begins at the insertion point, the inserted text falls
2483 outside the overlay; if a nonempty overlay ends at the insertion
2484 point, the inserted text falls inside that overlay.
2486 usage: (insert-before-markers &rest ARGS) */)
2487 (ptrdiff_t nargs
, Lisp_Object
*args
)
2489 general_insert_function (insert_before_markers
,
2490 insert_from_string_before_markers
, 0,
2495 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers
,
2496 Sinsert_and_inherit_before_markers
, 0, MANY
, 0,
2497 doc
: /* Insert text at point, relocating markers and inheriting properties.
2498 Point and markers move forward to end up after the inserted text.
2500 If the current buffer is multibyte, unibyte strings are converted
2501 to multibyte for insertion (see `unibyte-char-to-multibyte').
2502 If the current buffer is unibyte, multibyte strings are converted
2503 to unibyte for insertion.
2505 usage: (insert-before-markers-and-inherit &rest ARGS) */)
2506 (ptrdiff_t nargs
, Lisp_Object
*args
)
2508 general_insert_function (insert_before_markers_and_inherit
,
2509 insert_from_string_before_markers
, 1,
2514 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 1, 3,
2515 "(list (read-char-by-name \"Insert character (Unicode name or hex): \")\
2516 (prefix-numeric-value current-prefix-arg)\
2518 doc
: /* Insert COUNT copies of CHARACTER.
2519 Interactively, prompt for CHARACTER. You can specify CHARACTER in one
2522 - As its Unicode character name, e.g. \"LATIN SMALL LETTER A\".
2523 Completion is available; if you type a substring of the name
2524 preceded by an asterisk `*', Emacs shows all names which include
2525 that substring, not necessarily at the beginning of the name.
2527 - As a hexadecimal code point, e.g. 263A. Note that code points in
2528 Emacs are equivalent to Unicode up to 10FFFF (which is the limit of
2529 the Unicode code space).
2531 - As a code point with a radix specified with #, e.g. #o21430
2532 (octal), #x2318 (hex), or #10r8984 (decimal).
2534 If called interactively, COUNT is given by the prefix argument. If
2535 omitted or nil, it defaults to 1.
2537 Inserting the character(s) relocates point and before-insertion
2538 markers in the same ways as the function `insert'.
2540 The optional third argument INHERIT, if non-nil, says to inherit text
2541 properties from adjoining text, if those properties are sticky. If
2542 called interactively, INHERIT is t. */)
2543 (Lisp_Object character
, Lisp_Object count
, Lisp_Object inherit
)
2546 register ptrdiff_t n
;
2548 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2551 CHECK_CHARACTER (character
);
2553 XSETFASTINT (count
, 1);
2554 CHECK_NUMBER (count
);
2555 c
= XFASTINT (character
);
2557 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2558 len
= CHAR_STRING (c
, str
);
2560 str
[0] = c
, len
= 1;
2561 if (XINT (count
) <= 0)
2563 if (BUF_BYTES_MAX
/ len
< XINT (count
))
2565 n
= XINT (count
) * len
;
2566 stringlen
= min (n
, sizeof string
- sizeof string
% len
);
2567 for (i
= 0; i
< stringlen
; i
++)
2568 string
[i
] = str
[i
% len
];
2569 while (n
> stringlen
)
2572 if (!NILP (inherit
))
2573 insert_and_inherit (string
, stringlen
);
2575 insert (string
, stringlen
);
2578 if (!NILP (inherit
))
2579 insert_and_inherit (string
, n
);
2585 DEFUN ("insert-byte", Finsert_byte
, Sinsert_byte
, 2, 3, 0,
2586 doc
: /* Insert COUNT (second arg) copies of BYTE (first arg).
2587 Both arguments are required.
2588 BYTE is a number of the range 0..255.
2590 If BYTE is 128..255 and the current buffer is multibyte, the
2591 corresponding eight-bit character is inserted.
2593 Point, and before-insertion markers, are relocated as in the function `insert'.
2594 The optional third arg INHERIT, if non-nil, says to inherit text properties
2595 from adjoining text, if those properties are sticky. */)
2596 (Lisp_Object byte
, Lisp_Object count
, Lisp_Object inherit
)
2598 CHECK_NUMBER (byte
);
2599 if (XINT (byte
) < 0 || XINT (byte
) > 255)
2600 args_out_of_range_3 (byte
, make_number (0), make_number (255));
2601 if (XINT (byte
) >= 128
2602 && ! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2603 XSETFASTINT (byte
, BYTE8_TO_CHAR (XINT (byte
)));
2604 return Finsert_char (byte
, count
, inherit
);
2608 /* Making strings from buffer contents. */
2610 /* Return a Lisp_String containing the text of the current buffer from
2611 START to END. If text properties are in use and the current buffer
2612 has properties in the range specified, the resulting string will also
2613 have them, if PROPS is true.
2615 We don't want to use plain old make_string here, because it calls
2616 make_uninit_string, which can cause the buffer arena to be
2617 compacted. make_string has no way of knowing that the data has
2618 been moved, and thus copies the wrong data into the string. This
2619 doesn't effect most of the other users of make_string, so it should
2620 be left as is. But we should use this function when conjuring
2621 buffer substrings. */
2624 make_buffer_string (ptrdiff_t start
, ptrdiff_t end
, bool props
)
2626 ptrdiff_t start_byte
= CHAR_TO_BYTE (start
);
2627 ptrdiff_t end_byte
= CHAR_TO_BYTE (end
);
2629 return make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
);
2632 /* Return a Lisp_String containing the text of the current buffer from
2633 START / START_BYTE to END / END_BYTE.
2635 If text properties are in use and the current buffer
2636 has properties in the range specified, the resulting string will also
2637 have them, if PROPS is true.
2639 We don't want to use plain old make_string here, because it calls
2640 make_uninit_string, which can cause the buffer arena to be
2641 compacted. make_string has no way of knowing that the data has
2642 been moved, and thus copies the wrong data into the string. This
2643 doesn't effect most of the other users of make_string, so it should
2644 be left as is. But we should use this function when conjuring
2645 buffer substrings. */
2648 make_buffer_string_both (ptrdiff_t start
, ptrdiff_t start_byte
,
2649 ptrdiff_t end
, ptrdiff_t end_byte
, bool props
)
2651 Lisp_Object result
, tem
, tem1
;
2653 if (start
< GPT
&& GPT
< end
)
2654 move_gap_both (start
, start_byte
);
2656 if (! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2657 result
= make_uninit_multibyte_string (end
- start
, end_byte
- start_byte
);
2659 result
= make_uninit_string (end
- start
);
2660 memcpy (SDATA (result
), BYTE_POS_ADDR (start_byte
), end_byte
- start_byte
);
2662 /* If desired, update and copy the text properties. */
2665 update_buffer_properties (start
, end
);
2667 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
2668 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
2670 if (XINT (tem
) != end
|| !NILP (tem1
))
2671 copy_intervals_to_string (result
, current_buffer
, start
,
2678 /* Call Vbuffer_access_fontify_functions for the range START ... END
2679 in the current buffer, if necessary. */
2682 update_buffer_properties (ptrdiff_t start
, ptrdiff_t end
)
2684 /* If this buffer has some access functions,
2685 call them, specifying the range of the buffer being accessed. */
2686 if (!NILP (Vbuffer_access_fontify_functions
))
2688 Lisp_Object args
[3];
2691 args
[0] = Qbuffer_access_fontify_functions
;
2692 XSETINT (args
[1], start
);
2693 XSETINT (args
[2], end
);
2695 /* But don't call them if we can tell that the work
2696 has already been done. */
2697 if (!NILP (Vbuffer_access_fontified_property
))
2699 tem
= Ftext_property_any (args
[1], args
[2],
2700 Vbuffer_access_fontified_property
,
2703 Frun_hook_with_args (3, args
);
2706 Frun_hook_with_args (3, args
);
2710 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
2711 doc
: /* Return the contents of part of the current buffer as a string.
2712 The two arguments START and END are character positions;
2713 they can be in either order.
2714 The string returned is multibyte if the buffer is multibyte.
2716 This function copies the text properties of that part of the buffer
2717 into the result string; if you don't want the text properties,
2718 use `buffer-substring-no-properties' instead. */)
2719 (Lisp_Object start
, Lisp_Object end
)
2721 register ptrdiff_t b
, e
;
2723 validate_region (&start
, &end
);
2727 return make_buffer_string (b
, e
, 1);
2730 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties
,
2731 Sbuffer_substring_no_properties
, 2, 2, 0,
2732 doc
: /* Return the characters of part of the buffer, without the text properties.
2733 The two arguments START and END are character positions;
2734 they can be in either order. */)
2735 (Lisp_Object start
, Lisp_Object end
)
2737 register ptrdiff_t b
, e
;
2739 validate_region (&start
, &end
);
2743 return make_buffer_string (b
, e
, 0);
2746 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
2747 doc
: /* Return the contents of the current buffer as a string.
2748 If narrowing is in effect, this function returns only the visible part
2752 return make_buffer_string_both (BEGV
, BEGV_BYTE
, ZV
, ZV_BYTE
, 1);
2755 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
2757 doc
: /* Insert before point a substring of the contents of BUFFER.
2758 BUFFER may be a buffer or a buffer name.
2759 Arguments START and END are character positions specifying the substring.
2760 They default to the values of (point-min) and (point-max) in BUFFER. */)
2761 (Lisp_Object buffer
, Lisp_Object start
, Lisp_Object end
)
2763 register EMACS_INT b
, e
, temp
;
2764 register struct buffer
*bp
, *obuf
;
2767 buf
= Fget_buffer (buffer
);
2771 if (!BUFFER_LIVE_P (bp
))
2772 error ("Selecting deleted buffer");
2778 CHECK_NUMBER_COERCE_MARKER (start
);
2785 CHECK_NUMBER_COERCE_MARKER (end
);
2790 temp
= b
, b
= e
, e
= temp
;
2792 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
2793 args_out_of_range (start
, end
);
2795 obuf
= current_buffer
;
2796 set_buffer_internal_1 (bp
);
2797 update_buffer_properties (b
, e
);
2798 set_buffer_internal_1 (obuf
);
2800 insert_from_buffer (bp
, b
, e
- b
, 0);
2804 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
2806 doc
: /* Compare two substrings of two buffers; return result as number.
2807 Return -N if first string is less after N-1 chars, +N if first string is
2808 greater after N-1 chars, or 0 if strings match. Each substring is
2809 represented as three arguments: BUFFER, START and END. That makes six
2810 args in all, three for each substring.
2812 The value of `case-fold-search' in the current buffer
2813 determines whether case is significant or ignored. */)
2814 (Lisp_Object buffer1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object buffer2
, Lisp_Object start2
, Lisp_Object end2
)
2816 register EMACS_INT begp1
, endp1
, begp2
, endp2
, temp
;
2817 register struct buffer
*bp1
, *bp2
;
2818 register Lisp_Object trt
2819 = (!NILP (BVAR (current_buffer
, case_fold_search
))
2820 ? BVAR (current_buffer
, case_canon_table
) : Qnil
);
2821 ptrdiff_t chars
= 0;
2822 ptrdiff_t i1
, i2
, i1_byte
, i2_byte
;
2824 /* Find the first buffer and its substring. */
2827 bp1
= current_buffer
;
2831 buf1
= Fget_buffer (buffer1
);
2834 bp1
= XBUFFER (buf1
);
2835 if (!BUFFER_LIVE_P (bp1
))
2836 error ("Selecting deleted buffer");
2840 begp1
= BUF_BEGV (bp1
);
2843 CHECK_NUMBER_COERCE_MARKER (start1
);
2844 begp1
= XINT (start1
);
2847 endp1
= BUF_ZV (bp1
);
2850 CHECK_NUMBER_COERCE_MARKER (end1
);
2851 endp1
= XINT (end1
);
2855 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
2857 if (!(BUF_BEGV (bp1
) <= begp1
2859 && endp1
<= BUF_ZV (bp1
)))
2860 args_out_of_range (start1
, end1
);
2862 /* Likewise for second substring. */
2865 bp2
= current_buffer
;
2869 buf2
= Fget_buffer (buffer2
);
2872 bp2
= XBUFFER (buf2
);
2873 if (!BUFFER_LIVE_P (bp2
))
2874 error ("Selecting deleted buffer");
2878 begp2
= BUF_BEGV (bp2
);
2881 CHECK_NUMBER_COERCE_MARKER (start2
);
2882 begp2
= XINT (start2
);
2885 endp2
= BUF_ZV (bp2
);
2888 CHECK_NUMBER_COERCE_MARKER (end2
);
2889 endp2
= XINT (end2
);
2893 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
2895 if (!(BUF_BEGV (bp2
) <= begp2
2897 && endp2
<= BUF_ZV (bp2
)))
2898 args_out_of_range (start2
, end2
);
2902 i1_byte
= buf_charpos_to_bytepos (bp1
, i1
);
2903 i2_byte
= buf_charpos_to_bytepos (bp2
, i2
);
2905 while (i1
< endp1
&& i2
< endp2
)
2907 /* When we find a mismatch, we must compare the
2908 characters, not just the bytes. */
2913 if (! NILP (BVAR (bp1
, enable_multibyte_characters
)))
2915 c1
= BUF_FETCH_MULTIBYTE_CHAR (bp1
, i1_byte
);
2916 BUF_INC_POS (bp1
, i1_byte
);
2921 c1
= BUF_FETCH_BYTE (bp1
, i1
);
2922 MAKE_CHAR_MULTIBYTE (c1
);
2926 if (! NILP (BVAR (bp2
, enable_multibyte_characters
)))
2928 c2
= BUF_FETCH_MULTIBYTE_CHAR (bp2
, i2_byte
);
2929 BUF_INC_POS (bp2
, i2_byte
);
2934 c2
= BUF_FETCH_BYTE (bp2
, i2
);
2935 MAKE_CHAR_MULTIBYTE (c2
);
2941 c1
= char_table_translate (trt
, c1
);
2942 c2
= char_table_translate (trt
, c2
);
2945 return make_number (- 1 - chars
);
2947 return make_number (chars
+ 1);
2952 /* The strings match as far as they go.
2953 If one is shorter, that one is less. */
2954 if (chars
< endp1
- begp1
)
2955 return make_number (chars
+ 1);
2956 else if (chars
< endp2
- begp2
)
2957 return make_number (- chars
- 1);
2959 /* Same length too => they are equal. */
2960 return make_number (0);
2964 subst_char_in_region_unwind (Lisp_Object arg
)
2966 bset_undo_list (current_buffer
, arg
);
2970 subst_char_in_region_unwind_1 (Lisp_Object arg
)
2972 bset_filename (current_buffer
, arg
);
2975 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
2976 Ssubst_char_in_region
, 4, 5, 0,
2977 doc
: /* From START to END, replace FROMCHAR with TOCHAR each time it occurs.
2978 If optional arg NOUNDO is non-nil, don't record this change for undo
2979 and don't mark the buffer as really changed.
2980 Both characters must have the same length of multi-byte form. */)
2981 (Lisp_Object start
, Lisp_Object end
, Lisp_Object fromchar
, Lisp_Object tochar
, Lisp_Object noundo
)
2983 register ptrdiff_t pos
, pos_byte
, stop
, i
, len
, end_byte
;
2984 /* Keep track of the first change in the buffer:
2985 if 0 we haven't found it yet.
2986 if < 0 we've found it and we've run the before-change-function.
2987 if > 0 we've actually performed it and the value is its position. */
2988 ptrdiff_t changed
= 0;
2989 unsigned char fromstr
[MAX_MULTIBYTE_LENGTH
], tostr
[MAX_MULTIBYTE_LENGTH
];
2991 ptrdiff_t count
= SPECPDL_INDEX ();
2992 #define COMBINING_NO 0
2993 #define COMBINING_BEFORE 1
2994 #define COMBINING_AFTER 2
2995 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
2996 int maybe_byte_combining
= COMBINING_NO
;
2997 ptrdiff_t last_changed
= 0;
2999 = !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3004 validate_region (&start
, &end
);
3005 CHECK_CHARACTER (fromchar
);
3006 CHECK_CHARACTER (tochar
);
3007 fromc
= XFASTINT (fromchar
);
3008 toc
= XFASTINT (tochar
);
3012 len
= CHAR_STRING (fromc
, fromstr
);
3013 if (CHAR_STRING (toc
, tostr
) != len
)
3014 error ("Characters in `subst-char-in-region' have different byte-lengths");
3015 if (!ASCII_CHAR_P (*tostr
))
3017 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
3018 complete multibyte character, it may be combined with the
3019 after bytes. If it is in the range 0xA0..0xFF, it may be
3020 combined with the before and after bytes. */
3021 if (!CHAR_HEAD_P (*tostr
))
3022 maybe_byte_combining
= COMBINING_BOTH
;
3023 else if (BYTES_BY_CHAR_HEAD (*tostr
) > len
)
3024 maybe_byte_combining
= COMBINING_AFTER
;
3035 pos_byte
= CHAR_TO_BYTE (pos
);
3036 stop
= CHAR_TO_BYTE (XINT (end
));
3039 /* If we don't want undo, turn off putting stuff on the list.
3040 That's faster than getting rid of things,
3041 and it prevents even the entry for a first change.
3042 Also inhibit locking the file. */
3043 if (!changed
&& !NILP (noundo
))
3045 record_unwind_protect (subst_char_in_region_unwind
,
3046 BVAR (current_buffer
, undo_list
));
3047 bset_undo_list (current_buffer
, Qt
);
3048 /* Don't do file-locking. */
3049 record_unwind_protect (subst_char_in_region_unwind_1
,
3050 BVAR (current_buffer
, filename
));
3051 bset_filename (current_buffer
, Qnil
);
3054 if (pos_byte
< GPT_BYTE
)
3055 stop
= min (stop
, GPT_BYTE
);
3058 ptrdiff_t pos_byte_next
= pos_byte
;
3060 if (pos_byte
>= stop
)
3062 if (pos_byte
>= end_byte
) break;
3065 p
= BYTE_POS_ADDR (pos_byte
);
3067 INC_POS (pos_byte_next
);
3070 if (pos_byte_next
- pos_byte
== len
3071 && p
[0] == fromstr
[0]
3073 || (p
[1] == fromstr
[1]
3074 && (len
== 2 || (p
[2] == fromstr
[2]
3075 && (len
== 3 || p
[3] == fromstr
[3]))))))
3078 /* We've already seen this and run the before-change-function;
3079 this time we only need to record the actual position. */
3084 modify_text (pos
, XINT (end
));
3086 if (! NILP (noundo
))
3088 if (MODIFF
- 1 == SAVE_MODIFF
)
3090 if (MODIFF
- 1 == BUF_AUTOSAVE_MODIFF (current_buffer
))
3091 BUF_AUTOSAVE_MODIFF (current_buffer
)++;
3094 /* The before-change-function may have moved the gap
3095 or even modified the buffer so we should start over. */
3099 /* Take care of the case where the new character
3100 combines with neighboring bytes. */
3101 if (maybe_byte_combining
3102 && (maybe_byte_combining
== COMBINING_AFTER
3103 ? (pos_byte_next
< Z_BYTE
3104 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
3105 : ((pos_byte_next
< Z_BYTE
3106 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
3107 || (pos_byte
> BEG_BYTE
3108 && ! ASCII_CHAR_P (FETCH_BYTE (pos_byte
- 1))))))
3110 Lisp_Object tem
, string
;
3112 struct gcpro gcpro1
;
3114 tem
= BVAR (current_buffer
, undo_list
);
3117 /* Make a multibyte string containing this single character. */
3118 string
= make_multibyte_string ((char *) tostr
, 1, len
);
3119 /* replace_range is less efficient, because it moves the gap,
3120 but it handles combining correctly. */
3121 replace_range (pos
, pos
+ 1, string
,
3123 pos_byte_next
= CHAR_TO_BYTE (pos
);
3124 if (pos_byte_next
> pos_byte
)
3125 /* Before combining happened. We should not increment
3126 POS. So, to cancel the later increment of POS,
3130 INC_POS (pos_byte_next
);
3132 if (! NILP (noundo
))
3133 bset_undo_list (current_buffer
, tem
);
3140 record_change (pos
, 1);
3141 for (i
= 0; i
< len
; i
++) *p
++ = tostr
[i
];
3143 last_changed
= pos
+ 1;
3145 pos_byte
= pos_byte_next
;
3151 signal_after_change (changed
,
3152 last_changed
- changed
, last_changed
- changed
);
3153 update_compositions (changed
, last_changed
, CHECK_ALL
);
3156 unbind_to (count
, Qnil
);
3161 static Lisp_Object
check_translation (ptrdiff_t, ptrdiff_t, ptrdiff_t,
3164 /* Helper function for Ftranslate_region_internal.
3166 Check if a character sequence at POS (POS_BYTE) matches an element
3167 of VAL. VAL is a list (([FROM-CHAR ...] . TO) ...). If a matching
3168 element is found, return it. Otherwise return Qnil. */
3171 check_translation (ptrdiff_t pos
, ptrdiff_t pos_byte
, ptrdiff_t end
,
3174 int initial_buf
[16];
3175 int *buf
= initial_buf
;
3176 ptrdiff_t buf_size
= ARRAYELTS (initial_buf
);
3178 ptrdiff_t buf_used
= 0;
3179 Lisp_Object result
= Qnil
;
3181 for (; CONSP (val
); val
= XCDR (val
))
3190 if (! VECTORP (elt
))
3193 if (len
<= end
- pos
)
3195 for (i
= 0; i
< len
; i
++)
3199 unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
3202 if (buf_used
== buf_size
)
3204 bufalloc
= xpalloc (bufalloc
, &buf_size
, 1, -1,
3206 if (buf
== initial_buf
)
3207 memcpy (bufalloc
, buf
, sizeof initial_buf
);
3210 buf
[buf_used
++] = STRING_CHAR_AND_LENGTH (p
, len1
);
3213 if (XINT (AREF (elt
, i
)) != buf
[i
])
3218 result
= XCAR (val
);
3229 DEFUN ("translate-region-internal", Ftranslate_region_internal
,
3230 Stranslate_region_internal
, 3, 3, 0,
3231 doc
: /* Internal use only.
3232 From START to END, translate characters according to TABLE.
3233 TABLE is a string or a char-table; the Nth character in it is the
3234 mapping for the character with code N.
3235 It returns the number of characters changed. */)
3236 (Lisp_Object start
, Lisp_Object end
, register Lisp_Object table
)
3238 register unsigned char *tt
; /* Trans table. */
3239 register int nc
; /* New character. */
3240 int cnt
; /* Number of changes made. */
3241 ptrdiff_t size
; /* Size of translate table. */
3242 ptrdiff_t pos
, pos_byte
, end_pos
;
3243 bool multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3244 bool string_multibyte
IF_LINT (= 0);
3246 validate_region (&start
, &end
);
3247 if (CHAR_TABLE_P (table
))
3249 if (! EQ (XCHAR_TABLE (table
)->purpose
, Qtranslation_table
))
3250 error ("Not a translation table");
3256 CHECK_STRING (table
);
3258 if (! multibyte
&& (SCHARS (table
) < SBYTES (table
)))
3259 table
= string_make_unibyte (table
);
3260 string_multibyte
= SCHARS (table
) < SBYTES (table
);
3261 size
= SBYTES (table
);
3266 pos_byte
= CHAR_TO_BYTE (pos
);
3267 end_pos
= XINT (end
);
3268 modify_text (pos
, end_pos
);
3271 for (; pos
< end_pos
; )
3273 register unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
3274 unsigned char *str
, buf
[MAX_MULTIBYTE_LENGTH
];
3280 oc
= STRING_CHAR_AND_LENGTH (p
, len
);
3287 /* Reload as signal_after_change in last iteration may GC. */
3289 if (string_multibyte
)
3291 str
= tt
+ string_char_to_byte (table
, oc
);
3292 nc
= STRING_CHAR_AND_LENGTH (str
, str_len
);
3297 if (! ASCII_CHAR_P (nc
) && multibyte
)
3299 str_len
= BYTE8_STRING (nc
, buf
);
3312 val
= CHAR_TABLE_REF (table
, oc
);
3313 if (CHARACTERP (val
))
3315 nc
= XFASTINT (val
);
3316 str_len
= CHAR_STRING (nc
, buf
);
3319 else if (VECTORP (val
) || (CONSP (val
)))
3321 /* VAL is [TO_CHAR ...] or (([FROM-CHAR ...] . TO) ...)
3322 where TO is TO-CHAR or [TO-CHAR ...]. */
3327 if (nc
!= oc
&& nc
>= 0)
3329 /* Simple one char to one char translation. */
3334 /* This is less efficient, because it moves the gap,
3335 but it should handle multibyte characters correctly. */
3336 string
= make_multibyte_string ((char *) str
, 1, str_len
);
3337 replace_range (pos
, pos
+ 1, string
, 1, 0, 1);
3342 record_change (pos
, 1);
3343 while (str_len
-- > 0)
3345 signal_after_change (pos
, 1, 1);
3346 update_compositions (pos
, pos
+ 1, CHECK_BORDER
);
3356 val
= check_translation (pos
, pos_byte
, end_pos
, val
);
3363 /* VAL is ([FROM-CHAR ...] . TO). */
3364 len
= ASIZE (XCAR (val
));
3372 string
= Fconcat (1, &val
);
3376 string
= Fmake_string (make_number (1), val
);
3378 replace_range (pos
, pos
+ len
, string
, 1, 0, 1);
3379 pos_byte
+= SBYTES (string
);
3380 pos
+= SCHARS (string
);
3381 cnt
+= SCHARS (string
);
3382 end_pos
+= SCHARS (string
) - len
;
3390 return make_number (cnt
);
3393 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
3394 doc
: /* Delete the text between START and END.
3395 If called interactively, delete the region between point and mark.
3396 This command deletes buffer text without modifying the kill ring. */)
3397 (Lisp_Object start
, Lisp_Object end
)
3399 validate_region (&start
, &end
);
3400 del_range (XINT (start
), XINT (end
));
3404 DEFUN ("delete-and-extract-region", Fdelete_and_extract_region
,
3405 Sdelete_and_extract_region
, 2, 2, 0,
3406 doc
: /* Delete the text between START and END and return it. */)
3407 (Lisp_Object start
, Lisp_Object end
)
3409 validate_region (&start
, &end
);
3410 if (XINT (start
) == XINT (end
))
3411 return empty_unibyte_string
;
3412 return del_range_1 (XINT (start
), XINT (end
), 1, 1);
3415 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
3416 doc
: /* Remove restrictions (narrowing) from current buffer.
3417 This allows the buffer's full text to be seen and edited. */)
3420 if (BEG
!= BEGV
|| Z
!= ZV
)
3421 current_buffer
->clip_changed
= 1;
3423 BEGV_BYTE
= BEG_BYTE
;
3424 SET_BUF_ZV_BOTH (current_buffer
, Z
, Z_BYTE
);
3425 /* Changing the buffer bounds invalidates any recorded current column. */
3426 invalidate_current_column ();
3430 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
3431 doc
: /* Restrict editing in this buffer to the current region.
3432 The rest of the text becomes temporarily invisible and untouchable
3433 but is not deleted; if you save the buffer in a file, the invisible
3434 text is included in the file. \\[widen] makes all visible again.
3435 See also `save-restriction'.
3437 When calling from a program, pass two arguments; positions (integers
3438 or markers) bounding the text that should remain visible. */)
3439 (register Lisp_Object start
, Lisp_Object end
)
3441 CHECK_NUMBER_COERCE_MARKER (start
);
3442 CHECK_NUMBER_COERCE_MARKER (end
);
3444 if (XINT (start
) > XINT (end
))
3447 tem
= start
; start
= end
; end
= tem
;
3450 if (!(BEG
<= XINT (start
) && XINT (start
) <= XINT (end
) && XINT (end
) <= Z
))
3451 args_out_of_range (start
, end
);
3453 if (BEGV
!= XFASTINT (start
) || ZV
!= XFASTINT (end
))
3454 current_buffer
->clip_changed
= 1;
3456 SET_BUF_BEGV (current_buffer
, XFASTINT (start
));
3457 SET_BUF_ZV (current_buffer
, XFASTINT (end
));
3458 if (PT
< XFASTINT (start
))
3459 SET_PT (XFASTINT (start
));
3460 if (PT
> XFASTINT (end
))
3461 SET_PT (XFASTINT (end
));
3462 /* Changing the buffer bounds invalidates any recorded current column. */
3463 invalidate_current_column ();
3468 save_restriction_save (void)
3470 if (BEGV
== BEG
&& ZV
== Z
)
3471 /* The common case that the buffer isn't narrowed.
3472 We return just the buffer object, which save_restriction_restore
3473 recognizes as meaning `no restriction'. */
3474 return Fcurrent_buffer ();
3476 /* We have to save a restriction, so return a pair of markers, one
3477 for the beginning and one for the end. */
3479 Lisp_Object beg
, end
;
3481 beg
= build_marker (current_buffer
, BEGV
, BEGV_BYTE
);
3482 end
= build_marker (current_buffer
, ZV
, ZV_BYTE
);
3484 /* END must move forward if text is inserted at its exact location. */
3485 XMARKER (end
)->insertion_type
= 1;
3487 return Fcons (beg
, end
);
3492 save_restriction_restore (Lisp_Object data
)
3494 struct buffer
*cur
= NULL
;
3495 struct buffer
*buf
= (CONSP (data
)
3496 ? XMARKER (XCAR (data
))->buffer
3499 if (buf
&& buf
!= current_buffer
&& !NILP (BVAR (buf
, pt_marker
)))
3500 { /* If `buf' uses markers to keep track of PT, BEGV, and ZV (as
3501 is the case if it is or has an indirect buffer), then make
3502 sure it is current before we update BEGV, so
3503 set_buffer_internal takes care of managing those markers. */
3504 cur
= current_buffer
;
3505 set_buffer_internal (buf
);
3509 /* A pair of marks bounding a saved restriction. */
3511 struct Lisp_Marker
*beg
= XMARKER (XCAR (data
));
3512 struct Lisp_Marker
*end
= XMARKER (XCDR (data
));
3513 eassert (buf
== end
->buffer
);
3515 if (buf
/* Verify marker still points to a buffer. */
3516 && (beg
->charpos
!= BUF_BEGV (buf
) || end
->charpos
!= BUF_ZV (buf
)))
3517 /* The restriction has changed from the saved one, so restore
3518 the saved restriction. */
3520 ptrdiff_t pt
= BUF_PT (buf
);
3522 SET_BUF_BEGV_BOTH (buf
, beg
->charpos
, beg
->bytepos
);
3523 SET_BUF_ZV_BOTH (buf
, end
->charpos
, end
->bytepos
);
3525 if (pt
< beg
->charpos
|| pt
> end
->charpos
)
3526 /* The point is outside the new visible range, move it inside. */
3527 SET_BUF_PT_BOTH (buf
,
3528 clip_to_bounds (beg
->charpos
, pt
, end
->charpos
),
3529 clip_to_bounds (beg
->bytepos
, BUF_PT_BYTE (buf
),
3532 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3534 /* These aren't needed anymore, so don't wait for GC. */
3535 free_marker (XCAR (data
));
3536 free_marker (XCDR (data
));
3537 free_cons (XCONS (data
));
3540 /* A buffer, which means that there was no old restriction. */
3542 if (buf
/* Verify marker still points to a buffer. */
3543 && (BUF_BEGV (buf
) != BUF_BEG (buf
) || BUF_ZV (buf
) != BUF_Z (buf
)))
3544 /* The buffer has been narrowed, get rid of the narrowing. */
3546 SET_BUF_BEGV_BOTH (buf
, BUF_BEG (buf
), BUF_BEG_BYTE (buf
));
3547 SET_BUF_ZV_BOTH (buf
, BUF_Z (buf
), BUF_Z_BYTE (buf
));
3549 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3553 /* Changing the buffer bounds invalidates any recorded current column. */
3554 invalidate_current_column ();
3557 set_buffer_internal (cur
);
3560 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
3561 doc
: /* Execute BODY, saving and restoring current buffer's restrictions.
3562 The buffer's restrictions make parts of the beginning and end invisible.
3563 \(They are set up with `narrow-to-region' and eliminated with `widen'.)
3564 This special form, `save-restriction', saves the current buffer's restrictions
3565 when it is entered, and restores them when it is exited.
3566 So any `narrow-to-region' within BODY lasts only until the end of the form.
3567 The old restrictions settings are restored
3568 even in case of abnormal exit (throw or error).
3570 The value returned is the value of the last form in BODY.
3572 Note: if you are using both `save-excursion' and `save-restriction',
3573 use `save-excursion' outermost:
3574 (save-excursion (save-restriction ...))
3576 usage: (save-restriction &rest BODY) */)
3579 register Lisp_Object val
;
3580 ptrdiff_t count
= SPECPDL_INDEX ();
3582 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
3583 val
= Fprogn (body
);
3584 return unbind_to (count
, val
);
3587 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
3588 doc
: /* Display a message at the bottom of the screen.
3589 The message also goes into the `*Messages*' buffer, if `message-log-max'
3590 is non-nil. (In keyboard macros, that's all it does.)
3593 In batch mode, the message is printed to the standard error stream,
3594 followed by a newline.
3596 The first argument is a format control string, and the rest are data
3597 to be formatted under control of the string. See `format' for details.
3599 Note: Use (message "%s" VALUE) to print the value of expressions and
3600 variables to avoid accidentally interpreting `%' as format specifiers.
3602 If the first argument is nil or the empty string, the function clears
3603 any existing message; this lets the minibuffer contents show. See
3604 also `current-message'.
3606 usage: (message FORMAT-STRING &rest ARGS) */)
3607 (ptrdiff_t nargs
, Lisp_Object
*args
)
3610 || (STRINGP (args
[0])
3611 && SBYTES (args
[0]) == 0))
3618 register Lisp_Object val
;
3619 val
= Fformat (nargs
, args
);
3625 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
3626 doc
: /* Display a message, in a dialog box if possible.
3627 If a dialog box is not available, use the echo area.
3628 The first argument is a format control string, and the rest are data
3629 to be formatted under control of the string. See `format' for details.
3631 If the first argument is nil or the empty string, clear any existing
3632 message; let the minibuffer contents show.
3634 usage: (message-box FORMAT-STRING &rest ARGS) */)
3635 (ptrdiff_t nargs
, Lisp_Object
*args
)
3644 Lisp_Object val
= Fformat (nargs
, args
);
3645 Lisp_Object pane
, menu
;
3646 struct gcpro gcpro1
;
3648 pane
= list1 (Fcons (build_string ("OK"), Qt
));
3650 menu
= Fcons (val
, pane
);
3651 Fx_popup_dialog (Qt
, menu
, Qt
);
3657 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
3658 doc
: /* Display a message in a dialog box or in the echo area.
3659 If this command was invoked with the mouse, use a dialog box if
3660 `use-dialog-box' is non-nil.
3661 Otherwise, use the echo area.
3662 The first argument is a format control string, and the rest are data
3663 to be formatted under control of the string. See `format' for details.
3665 If the first argument is nil or the empty string, clear any existing
3666 message; let the minibuffer contents show.
3668 usage: (message-or-box FORMAT-STRING &rest ARGS) */)
3669 (ptrdiff_t nargs
, Lisp_Object
*args
)
3671 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3673 return Fmessage_box (nargs
, args
);
3674 return Fmessage (nargs
, args
);
3677 DEFUN ("current-message", Fcurrent_message
, Scurrent_message
, 0, 0, 0,
3678 doc
: /* Return the string currently displayed in the echo area, or nil if none. */)
3681 return current_message ();
3685 DEFUN ("propertize", Fpropertize
, Spropertize
, 1, MANY
, 0,
3686 doc
: /* Return a copy of STRING with text properties added.
3687 First argument is the string to copy.
3688 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
3689 properties to add to the result.
3690 usage: (propertize STRING &rest PROPERTIES) */)
3691 (ptrdiff_t nargs
, Lisp_Object
*args
)
3693 Lisp_Object properties
, string
;
3694 struct gcpro gcpro1
, gcpro2
;
3697 /* Number of args must be odd. */
3698 if ((nargs
& 1) == 0)
3699 error ("Wrong number of arguments");
3701 properties
= string
= Qnil
;
3702 GCPRO2 (properties
, string
);
3704 /* First argument must be a string. */
3705 CHECK_STRING (args
[0]);
3706 string
= Fcopy_sequence (args
[0]);
3708 for (i
= 1; i
< nargs
; i
+= 2)
3709 properties
= Fcons (args
[i
], Fcons (args
[i
+ 1], properties
));
3711 Fadd_text_properties (make_number (0),
3712 make_number (SCHARS (string
)),
3713 properties
, string
);
3714 RETURN_UNGCPRO (string
);
3717 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
3718 doc
: /* Format a string out of a format-string and arguments.
3719 The first argument is a format control string.
3720 The other arguments are substituted into it to make the result, a string.
3722 The format control string may contain %-sequences meaning to substitute
3723 the next available argument:
3725 %s means print a string argument. Actually, prints any object, with `princ'.
3726 %d means print as number in decimal (%o octal, %x hex).
3727 %X is like %x, but uses upper case.
3728 %e means print a number in exponential notation.
3729 %f means print a number in decimal-point notation.
3730 %g means print a number in exponential notation
3731 or decimal-point notation, whichever uses fewer characters.
3732 %c means print a number as a single character.
3733 %S means print any object as an s-expression (using `prin1').
3735 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
3736 Use %% to put a single % into the output.
3738 A %-sequence may contain optional flag, width, and precision
3739 specifiers, as follows:
3741 %<flags><width><precision>character
3743 where flags is [+ #-0]+, width is [0-9]+, and precision is .[0-9]+
3745 The + flag character inserts a + before any positive number, while a
3746 space inserts a space before any positive number; these flags only
3747 affect %d, %e, %f, and %g sequences, and the + flag takes precedence.
3748 The - and 0 flags affect the width specifier, as described below.
3750 The # flag means to use an alternate display form for %o, %x, %X, %e,
3751 %f, and %g sequences: for %o, it ensures that the result begins with
3752 \"0\"; for %x and %X, it prefixes the result with \"0x\" or \"0X\";
3753 for %e, %f, and %g, it causes a decimal point to be included even if
3754 the precision is zero.
3756 The width specifier supplies a lower limit for the length of the
3757 printed representation. The padding, if any, normally goes on the
3758 left, but it goes on the right if the - flag is present. The padding
3759 character is normally a space, but it is 0 if the 0 flag is present.
3760 The 0 flag is ignored if the - flag is present, or the format sequence
3761 is something other than %d, %e, %f, and %g.
3763 For %e, %f, and %g sequences, the number after the "." in the
3764 precision specifier says how many decimal places to show; if zero, the
3765 decimal point itself is omitted. For %s and %S, the precision
3766 specifier truncates the string to the given width.
3768 usage: (format STRING &rest OBJECTS) */)
3769 (ptrdiff_t nargs
, Lisp_Object
*args
)
3771 ptrdiff_t n
; /* The number of the next arg to substitute. */
3772 char initial_buffer
[4000];
3773 char *buf
= initial_buffer
;
3774 ptrdiff_t bufsize
= sizeof initial_buffer
;
3775 ptrdiff_t max_bufsize
= STRING_BYTES_BOUND
+ 1;
3777 ptrdiff_t buf_save_value_index
IF_LINT (= 0);
3778 char *format
, *end
, *format_start
;
3779 ptrdiff_t formatlen
, nchars
;
3780 /* True if the format is multibyte. */
3781 bool multibyte_format
= 0;
3782 /* True if the output should be a multibyte string,
3783 which is true if any of the inputs is one. */
3785 /* When we make a multibyte string, we must pay attention to the
3786 byte combining problem, i.e., a byte may be combined with a
3787 multibyte character of the previous string. This flag tells if we
3788 must consider such a situation or not. */
3789 bool maybe_combine_byte
;
3791 bool arg_intervals
= 0;
3794 /* discarded[I] is 1 if byte I of the format
3795 string was not copied into the output.
3796 It is 2 if byte I was not the first byte of its character. */
3799 /* Each element records, for one argument,
3800 the start and end bytepos in the output string,
3801 whether the argument has been converted to string (e.g., due to "%S"),
3802 and whether the argument is a string with intervals.
3803 info[0] is unused. Unused elements have -1 for start. */
3806 ptrdiff_t start
, end
;
3807 bool_bf converted_to_string
: 1;
3808 bool_bf intervals
: 1;
3811 /* It should not be necessary to GCPRO ARGS, because
3812 the caller in the interpreter should take care of that. */
3814 CHECK_STRING (args
[0]);
3815 format_start
= SSDATA (args
[0]);
3816 formatlen
= SBYTES (args
[0]);
3818 /* Allocate the info and discarded tables. */
3821 if ((SIZE_MAX
- formatlen
) / sizeof (struct info
) <= nargs
)
3822 memory_full (SIZE_MAX
);
3823 info
= SAFE_ALLOCA ((nargs
+ 1) * sizeof *info
+ formatlen
);
3824 discarded
= (char *) &info
[nargs
+ 1];
3825 for (i
= 0; i
< nargs
+ 1; i
++)
3828 info
[i
].intervals
= info
[i
].converted_to_string
= 0;
3830 memset (discarded
, 0, formatlen
);
3833 /* Try to determine whether the result should be multibyte.
3834 This is not always right; sometimes the result needs to be multibyte
3835 because of an object that we will pass through prin1,
3836 and in that case, we won't know it here. */
3837 multibyte_format
= STRING_MULTIBYTE (args
[0]);
3838 multibyte
= multibyte_format
;
3839 for (n
= 1; !multibyte
&& n
< nargs
; n
++)
3840 if (STRINGP (args
[n
]) && STRING_MULTIBYTE (args
[n
]))
3843 /* If we start out planning a unibyte result,
3844 then discover it has to be multibyte, we jump back to retry. */
3851 /* Scan the format and store result in BUF. */
3852 format
= format_start
;
3853 end
= format
+ formatlen
;
3854 maybe_combine_byte
= 0;
3856 while (format
!= end
)
3858 /* The values of N and FORMAT when the loop body is entered. */
3860 char *format0
= format
;
3862 /* Bytes needed to represent the output of this conversion. */
3863 ptrdiff_t convbytes
;
3867 /* General format specifications look like
3869 '%' [flags] [field-width] [precision] format
3874 field-width ::= [0-9]+
3875 precision ::= '.' [0-9]*
3877 If a field-width is specified, it specifies to which width
3878 the output should be padded with blanks, if the output
3879 string is shorter than field-width.
3881 If precision is specified, it specifies the number of
3882 digits to print after the '.' for floats, or the max.
3883 number of chars to print from a string. */
3885 bool minus_flag
= 0;
3887 bool space_flag
= 0;
3888 bool sharp_flag
= 0;
3890 ptrdiff_t field_width
;
3891 bool precision_given
;
3892 uintmax_t precision
= UINTMAX_MAX
;
3900 case '-': minus_flag
= 1; continue;
3901 case '+': plus_flag
= 1; continue;
3902 case ' ': space_flag
= 1; continue;
3903 case '#': sharp_flag
= 1; continue;
3904 case '0': zero_flag
= 1; continue;
3909 /* Ignore flags when sprintf ignores them. */
3910 space_flag
&= ~ plus_flag
;
3911 zero_flag
&= ~ minus_flag
;
3914 uintmax_t w
= strtoumax (format
, &num_end
, 10);
3915 if (max_bufsize
<= w
)
3919 precision_given
= *num_end
== '.';
3920 if (precision_given
)
3921 precision
= strtoumax (num_end
+ 1, &num_end
, 10);
3925 error ("Format string ends in middle of format specifier");
3927 memset (&discarded
[format0
- format_start
], 1, format
- format0
);
3928 conversion
= *format
;
3929 if (conversion
== '%')
3931 discarded
[format
- format_start
] = 1;
3936 error ("Not enough arguments for format string");
3938 /* For 'S', prin1 the argument, and then treat like 's'.
3939 For 's', princ any argument that is not a string or
3940 symbol. But don't do this conversion twice, which might
3941 happen after retrying. */
3942 if ((conversion
== 'S'
3943 || (conversion
== 's'
3944 && ! STRINGP (args
[n
]) && ! SYMBOLP (args
[n
]))))
3946 if (! info
[n
].converted_to_string
)
3948 Lisp_Object noescape
= conversion
== 'S' ? Qnil
: Qt
;
3949 args
[n
] = Fprin1_to_string (args
[n
], noescape
);
3950 info
[n
].converted_to_string
= 1;
3951 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3959 else if (conversion
== 'c')
3961 if (FLOATP (args
[n
]))
3963 double d
= XFLOAT_DATA (args
[n
]);
3964 args
[n
] = make_number (FIXNUM_OVERFLOW_P (d
) ? -1 : d
);
3967 if (INTEGERP (args
[n
]) && ! ASCII_CHAR_P (XINT (args
[n
])))
3974 args
[n
] = Fchar_to_string (args
[n
]);
3975 info
[n
].converted_to_string
= 1;
3978 if (info
[n
].converted_to_string
)
3983 if (SYMBOLP (args
[n
]))
3985 args
[n
] = SYMBOL_NAME (args
[n
]);
3986 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3993 if (conversion
== 's')
3995 /* handle case (precision[n] >= 0) */
3997 ptrdiff_t width
, padding
, nbytes
;
3998 ptrdiff_t nchars_string
;
4000 ptrdiff_t prec
= -1;
4001 if (precision_given
&& precision
<= TYPE_MAXIMUM (ptrdiff_t))
4004 /* lisp_string_width ignores a precision of 0, but GNU
4005 libc functions print 0 characters when the precision
4006 is 0. Imitate libc behavior here. Changing
4007 lisp_string_width is the right thing, and will be
4008 done, but meanwhile we work with it. */
4011 width
= nchars_string
= nbytes
= 0;
4015 width
= lisp_string_width (args
[n
], prec
, &nch
, &nby
);
4018 nchars_string
= SCHARS (args
[n
]);
4019 nbytes
= SBYTES (args
[n
]);
4023 nchars_string
= nch
;
4029 if (convbytes
&& multibyte
&& ! STRING_MULTIBYTE (args
[n
]))
4030 convbytes
= count_size_as_multibyte (SDATA (args
[n
]), nbytes
);
4032 padding
= width
< field_width
? field_width
- width
: 0;
4034 if (max_bufsize
- padding
<= convbytes
)
4036 convbytes
+= padding
;
4037 if (convbytes
<= buf
+ bufsize
- p
)
4041 memset (p
, ' ', padding
);
4048 && !ASCII_CHAR_P (*((unsigned char *) p
- 1))
4049 && STRING_MULTIBYTE (args
[n
])
4050 && !CHAR_HEAD_P (SREF (args
[n
], 0)))
4051 maybe_combine_byte
= 1;
4053 p
+= copy_text (SDATA (args
[n
]), (unsigned char *) p
,
4055 STRING_MULTIBYTE (args
[n
]), multibyte
);
4057 info
[n
].start
= nchars
;
4058 nchars
+= nchars_string
;
4059 info
[n
].end
= nchars
;
4063 memset (p
, ' ', padding
);
4068 /* If this argument has text properties, record where
4069 in the result string it appears. */
4070 if (string_intervals (args
[n
]))
4071 info
[n
].intervals
= arg_intervals
= 1;
4076 else if (! (conversion
== 'c' || conversion
== 'd'
4077 || conversion
== 'e' || conversion
== 'f'
4078 || conversion
== 'g' || conversion
== 'i'
4079 || conversion
== 'o' || conversion
== 'x'
4080 || conversion
== 'X'))
4081 error ("Invalid format operation %%%c",
4082 STRING_CHAR ((unsigned char *) format
- 1));
4083 else if (! (INTEGERP (args
[n
]) || FLOATP (args
[n
])))
4084 error ("Format specifier doesn't match argument type");
4089 /* Maximum precision for a %f conversion such that the
4090 trailing output digit might be nonzero. Any precision
4091 larger than this will not yield useful information. */
4092 USEFUL_PRECISION_MAX
=
4094 * (FLT_RADIX
== 2 || FLT_RADIX
== 10 ? 1
4095 : FLT_RADIX
== 16 ? 4
4098 /* Maximum number of bytes generated by any format, if
4099 precision is no more than USEFUL_PRECISION_MAX.
4100 On all practical hosts, %f is the worst case. */
4102 sizeof "-." + (DBL_MAX_10_EXP
+ 1) + USEFUL_PRECISION_MAX
,
4104 /* Length of pM (that is, of pMd without the
4106 pMlen
= sizeof pMd
- 2
4108 verify (USEFUL_PRECISION_MAX
> 0);
4111 ptrdiff_t padding
, sprintf_bytes
;
4112 uintmax_t excess_precision
, numwidth
;
4113 uintmax_t leading_zeros
= 0, trailing_zeros
= 0;
4115 char sprintf_buf
[SPRINTF_BUFSIZE
];
4117 /* Copy of conversion specification, modified somewhat.
4118 At most three flags F can be specified at once. */
4119 char convspec
[sizeof "%FFF.*d" + pMlen
];
4121 /* Avoid undefined behavior in underlying sprintf. */
4122 if (conversion
== 'd' || conversion
== 'i')
4125 /* Create the copy of the conversion specification, with
4126 any width and precision removed, with ".*" inserted,
4127 and with pM inserted for integer formats. */
4131 *f
= '-'; f
+= minus_flag
;
4132 *f
= '+'; f
+= plus_flag
;
4133 *f
= ' '; f
+= space_flag
;
4134 *f
= '#'; f
+= sharp_flag
;
4135 *f
= '0'; f
+= zero_flag
;
4138 if (conversion
== 'd' || conversion
== 'i'
4139 || conversion
== 'o' || conversion
== 'x'
4140 || conversion
== 'X')
4142 memcpy (f
, pMd
, pMlen
);
4144 zero_flag
&= ~ precision_given
;
4151 if (precision_given
)
4152 prec
= min (precision
, USEFUL_PRECISION_MAX
);
4154 /* Use sprintf to format this number into sprintf_buf. Omit
4155 padding and excess precision, though, because sprintf limits
4156 output length to INT_MAX.
4158 There are four types of conversion: double, unsigned
4159 char (passed as int), wide signed int, and wide
4160 unsigned int. Treat them separately because the
4161 sprintf ABI is sensitive to which type is passed. Be
4162 careful about integer overflow, NaNs, infinities, and
4163 conversions; for example, the min and max macros are
4164 not suitable here. */
4165 if (conversion
== 'e' || conversion
== 'f' || conversion
== 'g')
4167 double x
= (INTEGERP (args
[n
])
4169 : XFLOAT_DATA (args
[n
]));
4170 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4172 else if (conversion
== 'c')
4174 /* Don't use sprintf here, as it might mishandle prec. */
4175 sprintf_buf
[0] = XINT (args
[n
]);
4176 sprintf_bytes
= prec
!= 0;
4178 else if (conversion
== 'd')
4180 /* For float, maybe we should use "%1.0f"
4181 instead so it also works for values outside
4182 the integer range. */
4184 if (INTEGERP (args
[n
]))
4188 double d
= XFLOAT_DATA (args
[n
]);
4191 x
= TYPE_MINIMUM (printmax_t
);
4197 x
= TYPE_MAXIMUM (printmax_t
);
4202 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4206 /* Don't sign-extend for octal or hex printing. */
4208 if (INTEGERP (args
[n
]))
4209 x
= XUINT (args
[n
]);
4212 double d
= XFLOAT_DATA (args
[n
]);
4217 x
= TYPE_MAXIMUM (uprintmax_t
);
4222 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4225 /* Now the length of the formatted item is known, except it omits
4226 padding and excess precision. Deal with excess precision
4227 first. This happens only when the format specifies
4228 ridiculously large precision. */
4229 excess_precision
= precision
- prec
;
4230 if (excess_precision
)
4232 if (conversion
== 'e' || conversion
== 'f'
4233 || conversion
== 'g')
4235 if ((conversion
== 'g' && ! sharp_flag
)
4236 || ! ('0' <= sprintf_buf
[sprintf_bytes
- 1]
4237 && sprintf_buf
[sprintf_bytes
- 1] <= '9'))
4238 excess_precision
= 0;
4241 if (conversion
== 'g')
4243 char *dot
= strchr (sprintf_buf
, '.');
4245 excess_precision
= 0;
4248 trailing_zeros
= excess_precision
;
4251 leading_zeros
= excess_precision
;
4254 /* Compute the total bytes needed for this item, including
4255 excess precision and padding. */
4256 numwidth
= sprintf_bytes
+ excess_precision
;
4257 padding
= numwidth
< field_width
? field_width
- numwidth
: 0;
4258 if (max_bufsize
- sprintf_bytes
<= excess_precision
4259 || max_bufsize
- padding
<= numwidth
)
4261 convbytes
= numwidth
+ padding
;
4263 if (convbytes
<= buf
+ bufsize
- p
)
4265 /* Copy the formatted item from sprintf_buf into buf,
4266 inserting padding and excess-precision zeros. */
4268 char *src
= sprintf_buf
;
4270 int exponent_bytes
= 0;
4271 bool signedp
= src0
== '-' || src0
== '+' || src0
== ' ';
4272 int significand_bytes
;
4274 && ((src
[signedp
] >= '0' && src
[signedp
] <= '9')
4275 || (src
[signedp
] >= 'a' && src
[signedp
] <= 'f')
4276 || (src
[signedp
] >= 'A' && src
[signedp
] <= 'F')))
4278 leading_zeros
+= padding
;
4282 if (excess_precision
4283 && (conversion
== 'e' || conversion
== 'g'))
4285 char *e
= strchr (src
, 'e');
4287 exponent_bytes
= src
+ sprintf_bytes
- e
;
4292 memset (p
, ' ', padding
);
4300 memset (p
, '0', leading_zeros
);
4302 significand_bytes
= sprintf_bytes
- signedp
- exponent_bytes
;
4303 memcpy (p
, src
, significand_bytes
);
4304 p
+= significand_bytes
;
4305 src
+= significand_bytes
;
4306 memset (p
, '0', trailing_zeros
);
4307 p
+= trailing_zeros
;
4308 memcpy (p
, src
, exponent_bytes
);
4309 p
+= exponent_bytes
;
4311 info
[n
].start
= nchars
;
4312 nchars
+= leading_zeros
+ sprintf_bytes
+ trailing_zeros
;
4313 info
[n
].end
= nchars
;
4317 memset (p
, ' ', padding
);
4329 /* Copy a single character from format to buf. */
4332 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
4334 if (multibyte_format
)
4336 /* Copy a whole multibyte character. */
4338 && !ASCII_CHAR_P (*((unsigned char *) p
- 1))
4339 && !CHAR_HEAD_P (*format
))
4340 maybe_combine_byte
= 1;
4344 while (! CHAR_HEAD_P (*format
));
4346 convbytes
= format
- src
;
4347 memset (&discarded
[src
+ 1 - format_start
], 2, convbytes
- 1);
4351 unsigned char uc
= *format
++;
4352 if (! multibyte
|| ASCII_CHAR_P (uc
))
4356 int c
= BYTE8_TO_CHAR (uc
);
4357 convbytes
= CHAR_STRING (c
, str
);
4362 if (convbytes
<= buf
+ bufsize
- p
)
4364 memcpy (p
, src
, convbytes
);
4371 /* There wasn't enough room to store this conversion or single
4372 character. CONVBYTES says how much room is needed. Allocate
4373 enough room (and then some) and do it again. */
4375 ptrdiff_t used
= p
- buf
;
4377 if (max_bufsize
- used
< convbytes
)
4379 bufsize
= used
+ convbytes
;
4380 bufsize
= bufsize
< max_bufsize
/ 2 ? bufsize
* 2 : max_bufsize
;
4382 if (buf
== initial_buffer
)
4384 buf
= xmalloc (bufsize
);
4385 sa_must_free
= true;
4386 buf_save_value_index
= SPECPDL_INDEX ();
4387 record_unwind_protect_ptr (xfree
, buf
);
4388 memcpy (buf
, initial_buffer
, used
);
4392 buf
= xrealloc (buf
, bufsize
);
4393 set_unwind_protect_ptr (buf_save_value_index
, xfree
, buf
);
4403 if (bufsize
< p
- buf
)
4406 if (maybe_combine_byte
)
4407 nchars
= multibyte_chars_in_text ((unsigned char *) buf
, p
- buf
);
4408 val
= make_specified_string (buf
, nchars
, p
- buf
, multibyte
);
4410 /* If we allocated BUF with malloc, free it too. */
4413 /* If the format string has text properties, or any of the string
4414 arguments has text properties, set up text properties of the
4417 if (string_intervals (args
[0]) || arg_intervals
)
4419 Lisp_Object len
, new_len
, props
;
4420 struct gcpro gcpro1
;
4422 /* Add text properties from the format string. */
4423 len
= make_number (SCHARS (args
[0]));
4424 props
= text_property_list (args
[0], make_number (0), len
, Qnil
);
4429 ptrdiff_t bytepos
= 0, position
= 0, translated
= 0;
4433 /* Adjust the bounds of each text property
4434 to the proper start and end in the output string. */
4436 /* Put the positions in PROPS in increasing order, so that
4437 we can do (effectively) one scan through the position
4438 space of the format string. */
4439 props
= Fnreverse (props
);
4441 /* BYTEPOS is the byte position in the format string,
4442 POSITION is the untranslated char position in it,
4443 TRANSLATED is the translated char position in BUF,
4444 and ARGN is the number of the next arg we will come to. */
4445 for (list
= props
; CONSP (list
); list
= XCDR (list
))
4452 /* First adjust the property start position. */
4453 pos
= XINT (XCAR (item
));
4455 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
4456 up to this position. */
4457 for (; position
< pos
; bytepos
++)
4459 if (! discarded
[bytepos
])
4460 position
++, translated
++;
4461 else if (discarded
[bytepos
] == 1)
4464 if (translated
== info
[argn
].start
)
4466 translated
+= info
[argn
].end
- info
[argn
].start
;
4472 XSETCAR (item
, make_number (translated
));
4474 /* Likewise adjust the property end position. */
4475 pos
= XINT (XCAR (XCDR (item
)));
4477 for (; position
< pos
; bytepos
++)
4479 if (! discarded
[bytepos
])
4480 position
++, translated
++;
4481 else if (discarded
[bytepos
] == 1)
4484 if (translated
== info
[argn
].start
)
4486 translated
+= info
[argn
].end
- info
[argn
].start
;
4492 XSETCAR (XCDR (item
), make_number (translated
));
4495 add_text_properties_from_list (val
, props
, make_number (0));
4498 /* Add text properties from arguments. */
4500 for (n
= 1; n
< nargs
; ++n
)
4501 if (info
[n
].intervals
)
4503 len
= make_number (SCHARS (args
[n
]));
4504 new_len
= make_number (info
[n
].end
- info
[n
].start
);
4505 props
= text_property_list (args
[n
], make_number (0), len
, Qnil
);
4506 props
= extend_property_ranges (props
, new_len
);
4507 /* If successive arguments have properties, be sure that
4508 the value of `composition' property be the copy. */
4509 if (n
> 1 && info
[n
- 1].end
)
4510 make_composition_value_copy (props
);
4511 add_text_properties_from_list (val
, props
,
4512 make_number (info
[n
].start
));
4522 format2 (const char *string1
, Lisp_Object arg0
, Lisp_Object arg1
)
4524 AUTO_STRING (format
, string1
);
4525 return Fformat (3, (Lisp_Object
[]) {format
, arg0
, arg1
});
4528 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
4529 doc
: /* Return t if two characters match, optionally ignoring case.
4530 Both arguments must be characters (i.e. integers).
4531 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
4532 (register Lisp_Object c1
, Lisp_Object c2
)
4535 /* Check they're chars, not just integers, otherwise we could get array
4536 bounds violations in downcase. */
4537 CHECK_CHARACTER (c1
);
4538 CHECK_CHARACTER (c2
);
4540 if (XINT (c1
) == XINT (c2
))
4542 if (NILP (BVAR (current_buffer
, case_fold_search
)))
4548 /* FIXME: It is possible to compare multibyte characters even when
4549 the current buffer is unibyte. Unfortunately this is ambiguous
4550 for characters between 128 and 255, as they could be either
4551 eight-bit raw bytes or Latin-1 characters. Assume the former for
4552 now. See Bug#17011, and also see casefiddle.c's casify_object,
4553 which has a similar problem. */
4554 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4556 if (SINGLE_BYTE_CHAR_P (i1
))
4557 i1
= UNIBYTE_TO_CHAR (i1
);
4558 if (SINGLE_BYTE_CHAR_P (i2
))
4559 i2
= UNIBYTE_TO_CHAR (i2
);
4562 return (downcase (i1
) == downcase (i2
) ? Qt
: Qnil
);
4565 /* Transpose the markers in two regions of the current buffer, and
4566 adjust the ones between them if necessary (i.e.: if the regions
4569 START1, END1 are the character positions of the first region.
4570 START1_BYTE, END1_BYTE are the byte positions.
4571 START2, END2 are the character positions of the second region.
4572 START2_BYTE, END2_BYTE are the byte positions.
4574 Traverses the entire marker list of the buffer to do so, adding an
4575 appropriate amount to some, subtracting from some, and leaving the
4576 rest untouched. Most of this is copied from adjust_markers in insdel.c.
4578 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
4581 transpose_markers (ptrdiff_t start1
, ptrdiff_t end1
,
4582 ptrdiff_t start2
, ptrdiff_t end2
,
4583 ptrdiff_t start1_byte
, ptrdiff_t end1_byte
,
4584 ptrdiff_t start2_byte
, ptrdiff_t end2_byte
)
4586 register ptrdiff_t amt1
, amt1_byte
, amt2
, amt2_byte
, diff
, diff_byte
, mpos
;
4587 register struct Lisp_Marker
*marker
;
4589 /* Update point as if it were a marker. */
4593 TEMP_SET_PT_BOTH (PT
+ (end2
- end1
),
4594 PT_BYTE
+ (end2_byte
- end1_byte
));
4595 else if (PT
< start2
)
4596 TEMP_SET_PT_BOTH (PT
+ (end2
- start2
) - (end1
- start1
),
4597 (PT_BYTE
+ (end2_byte
- start2_byte
)
4598 - (end1_byte
- start1_byte
)));
4600 TEMP_SET_PT_BOTH (PT
- (start2
- start1
),
4601 PT_BYTE
- (start2_byte
- start1_byte
));
4603 /* We used to adjust the endpoints here to account for the gap, but that
4604 isn't good enough. Even if we assume the caller has tried to move the
4605 gap out of our way, it might still be at start1 exactly, for example;
4606 and that places it `inside' the interval, for our purposes. The amount
4607 of adjustment is nontrivial if there's a `denormalized' marker whose
4608 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
4609 the dirty work to Fmarker_position, below. */
4611 /* The difference between the region's lengths */
4612 diff
= (end2
- start2
) - (end1
- start1
);
4613 diff_byte
= (end2_byte
- start2_byte
) - (end1_byte
- start1_byte
);
4615 /* For shifting each marker in a region by the length of the other
4616 region plus the distance between the regions. */
4617 amt1
= (end2
- start2
) + (start2
- end1
);
4618 amt2
= (end1
- start1
) + (start2
- end1
);
4619 amt1_byte
= (end2_byte
- start2_byte
) + (start2_byte
- end1_byte
);
4620 amt2_byte
= (end1_byte
- start1_byte
) + (start2_byte
- end1_byte
);
4622 for (marker
= BUF_MARKERS (current_buffer
); marker
; marker
= marker
->next
)
4624 mpos
= marker
->bytepos
;
4625 if (mpos
>= start1_byte
&& mpos
< end2_byte
)
4627 if (mpos
< end1_byte
)
4629 else if (mpos
< start2_byte
)
4633 marker
->bytepos
= mpos
;
4635 mpos
= marker
->charpos
;
4636 if (mpos
>= start1
&& mpos
< end2
)
4640 else if (mpos
< start2
)
4645 marker
->charpos
= mpos
;
4649 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
4650 doc
: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
4651 The regions should not be overlapping, because the size of the buffer is
4652 never changed in a transposition.
4654 Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
4655 any markers that happen to be located in the regions.
4657 Transposing beyond buffer boundaries is an error. */)
4658 (Lisp_Object startr1
, Lisp_Object endr1
, Lisp_Object startr2
, Lisp_Object endr2
, Lisp_Object leave_markers
)
4660 register ptrdiff_t start1
, end1
, start2
, end2
;
4661 ptrdiff_t start1_byte
, start2_byte
, len1_byte
, len2_byte
, end2_byte
;
4662 ptrdiff_t gap
, len1
, len_mid
, len2
;
4663 unsigned char *start1_addr
, *start2_addr
, *temp
;
4665 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
, tmp_interval3
;
4668 XSETBUFFER (buf
, current_buffer
);
4669 cur_intv
= buffer_intervals (current_buffer
);
4671 validate_region (&startr1
, &endr1
);
4672 validate_region (&startr2
, &endr2
);
4674 start1
= XFASTINT (startr1
);
4675 end1
= XFASTINT (endr1
);
4676 start2
= XFASTINT (startr2
);
4677 end2
= XFASTINT (endr2
);
4680 /* Swap the regions if they're reversed. */
4683 register ptrdiff_t glumph
= start1
;
4691 len1
= end1
- start1
;
4692 len2
= end2
- start2
;
4695 error ("Transposed regions overlap");
4696 /* Nothing to change for adjacent regions with one being empty */
4697 else if ((start1
== end1
|| start2
== end2
) && end1
== start2
)
4700 /* The possibilities are:
4701 1. Adjacent (contiguous) regions, or separate but equal regions
4702 (no, really equal, in this case!), or
4703 2. Separate regions of unequal size.
4705 The worst case is usually No. 2. It means that (aside from
4706 potential need for getting the gap out of the way), there also
4707 needs to be a shifting of the text between the two regions. So
4708 if they are spread far apart, we are that much slower... sigh. */
4710 /* It must be pointed out that the really studly thing to do would
4711 be not to move the gap at all, but to leave it in place and work
4712 around it if necessary. This would be extremely efficient,
4713 especially considering that people are likely to do
4714 transpositions near where they are working interactively, which
4715 is exactly where the gap would be found. However, such code
4716 would be much harder to write and to read. So, if you are
4717 reading this comment and are feeling squirrely, by all means have
4718 a go! I just didn't feel like doing it, so I will simply move
4719 the gap the minimum distance to get it out of the way, and then
4720 deal with an unbroken array. */
4722 start1_byte
= CHAR_TO_BYTE (start1
);
4723 end2_byte
= CHAR_TO_BYTE (end2
);
4725 /* Make sure the gap won't interfere, by moving it out of the text
4726 we will operate on. */
4727 if (start1
< gap
&& gap
< end2
)
4729 if (gap
- start1
< end2
- gap
)
4730 move_gap_both (start1
, start1_byte
);
4732 move_gap_both (end2
, end2_byte
);
4735 start2_byte
= CHAR_TO_BYTE (start2
);
4736 len1_byte
= CHAR_TO_BYTE (end1
) - start1_byte
;
4737 len2_byte
= end2_byte
- start2_byte
;
4739 #ifdef BYTE_COMBINING_DEBUG
4742 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4743 len2_byte
, start1
, start1_byte
)
4744 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4745 len1_byte
, end2
, start2_byte
+ len2_byte
)
4746 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4747 len1_byte
, end2
, start2_byte
+ len2_byte
))
4752 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4753 len2_byte
, start1
, start1_byte
)
4754 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4755 len1_byte
, start2
, start2_byte
)
4756 || count_combining_after (BYTE_POS_ADDR (start2_byte
),
4757 len2_byte
, end1
, start1_byte
+ len1_byte
)
4758 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4759 len1_byte
, end2
, start2_byte
+ len2_byte
))
4764 /* Hmmm... how about checking to see if the gap is large
4765 enough to use as the temporary storage? That would avoid an
4766 allocation... interesting. Later, don't fool with it now. */
4768 /* Working without memmove, for portability (sigh), so must be
4769 careful of overlapping subsections of the array... */
4771 if (end1
== start2
) /* adjacent regions */
4773 modify_text (start1
, end2
);
4774 record_change (start1
, len1
+ len2
);
4776 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4777 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4778 /* Don't use Fset_text_properties: that can cause GC, which can
4779 clobber objects stored in the tmp_intervals. */
4780 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4782 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4786 /* First region smaller than second. */
4787 if (len1_byte
< len2_byte
)
4789 temp
= SAFE_ALLOCA (len2_byte
);
4791 /* Don't precompute these addresses. We have to compute them
4792 at the last minute, because the relocating allocator might
4793 have moved the buffer around during the xmalloc. */
4794 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4795 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4797 memcpy (temp
, start2_addr
, len2_byte
);
4798 memcpy (start1_addr
+ len2_byte
, start1_addr
, len1_byte
);
4799 memcpy (start1_addr
, temp
, len2_byte
);
4802 /* First region not smaller than second. */
4804 temp
= SAFE_ALLOCA (len1_byte
);
4805 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4806 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4807 memcpy (temp
, start1_addr
, len1_byte
);
4808 memcpy (start1_addr
, start2_addr
, len2_byte
);
4809 memcpy (start1_addr
+ len2_byte
, temp
, len1_byte
);
4813 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
4814 len1
, current_buffer
, 0);
4815 graft_intervals_into_buffer (tmp_interval2
, start1
,
4816 len2
, current_buffer
, 0);
4817 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4818 update_compositions (start1
+ len2
, end2
, CHECK_TAIL
);
4820 /* Non-adjacent regions, because end1 != start2, bleagh... */
4823 len_mid
= start2_byte
- (start1_byte
+ len1_byte
);
4825 if (len1_byte
== len2_byte
)
4826 /* Regions are same size, though, how nice. */
4830 modify_text (start1
, end1
);
4831 modify_text (start2
, end2
);
4832 record_change (start1
, len1
);
4833 record_change (start2
, len2
);
4834 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4835 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4837 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr1
, 0);
4839 set_text_properties_1 (startr1
, endr1
, Qnil
, buf
, tmp_interval3
);
4841 tmp_interval3
= validate_interval_range (buf
, &startr2
, &endr2
, 0);
4843 set_text_properties_1 (startr2
, endr2
, Qnil
, buf
, tmp_interval3
);
4845 temp
= SAFE_ALLOCA (len1_byte
);
4846 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4847 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4848 memcpy (temp
, start1_addr
, len1_byte
);
4849 memcpy (start1_addr
, start2_addr
, len2_byte
);
4850 memcpy (start2_addr
, temp
, len1_byte
);
4853 graft_intervals_into_buffer (tmp_interval1
, start2
,
4854 len1
, current_buffer
, 0);
4855 graft_intervals_into_buffer (tmp_interval2
, start1
,
4856 len2
, current_buffer
, 0);
4859 else if (len1_byte
< len2_byte
) /* Second region larger than first */
4860 /* Non-adjacent & unequal size, area between must also be shifted. */
4864 modify_text (start1
, end2
);
4865 record_change (start1
, (end2
- start1
));
4866 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4867 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4868 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4870 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4872 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4874 /* holds region 2 */
4875 temp
= SAFE_ALLOCA (len2_byte
);
4876 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4877 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4878 memcpy (temp
, start2_addr
, len2_byte
);
4879 memcpy (start1_addr
+ len_mid
+ len2_byte
, start1_addr
, len1_byte
);
4880 memmove (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
4881 memcpy (start1_addr
, temp
, len2_byte
);
4884 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4885 len1
, current_buffer
, 0);
4886 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4887 len_mid
, current_buffer
, 0);
4888 graft_intervals_into_buffer (tmp_interval2
, start1
,
4889 len2
, current_buffer
, 0);
4892 /* Second region smaller than first. */
4896 record_change (start1
, (end2
- start1
));
4897 modify_text (start1
, end2
);
4899 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4900 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4901 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4903 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4905 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4907 /* holds region 1 */
4908 temp
= SAFE_ALLOCA (len1_byte
);
4909 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4910 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4911 memcpy (temp
, start1_addr
, len1_byte
);
4912 memcpy (start1_addr
, start2_addr
, len2_byte
);
4913 memcpy (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
4914 memcpy (start1_addr
+ len2_byte
+ len_mid
, temp
, len1_byte
);
4917 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4918 len1
, current_buffer
, 0);
4919 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4920 len_mid
, current_buffer
, 0);
4921 graft_intervals_into_buffer (tmp_interval2
, start1
,
4922 len2
, current_buffer
, 0);
4925 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4926 update_compositions (end2
- len1
, end2
, CHECK_BORDER
);
4929 /* When doing multiple transpositions, it might be nice
4930 to optimize this. Perhaps the markers in any one buffer
4931 should be organized in some sorted data tree. */
4932 if (NILP (leave_markers
))
4934 transpose_markers (start1
, end1
, start2
, end2
,
4935 start1_byte
, start1_byte
+ len1_byte
,
4936 start2_byte
, start2_byte
+ len2_byte
);
4937 fix_start_end_in_overlays (start1
, end2
);
4940 signal_after_change (start1
, end2
- start1
, end2
- start1
);
4946 syms_of_editfns (void)
4948 DEFSYM (Qbuffer_access_fontify_functions
, "buffer-access-fontify-functions");
4950 DEFVAR_LISP ("inhibit-field-text-motion", Vinhibit_field_text_motion
,
4951 doc
: /* Non-nil means text motion commands don't notice fields. */);
4952 Vinhibit_field_text_motion
= Qnil
;
4954 DEFVAR_LISP ("buffer-access-fontify-functions",
4955 Vbuffer_access_fontify_functions
,
4956 doc
: /* List of functions called by `buffer-substring' to fontify if necessary.
4957 Each function is called with two arguments which specify the range
4958 of the buffer being accessed. */);
4959 Vbuffer_access_fontify_functions
= Qnil
;
4963 obuf
= Fcurrent_buffer ();
4964 /* Do this here, because init_buffer_once is too early--it won't work. */
4965 Fset_buffer (Vprin1_to_string_buffer
);
4966 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
4967 Fset (Fmake_local_variable (intern_c_string ("buffer-access-fontify-functions")),
4972 DEFVAR_LISP ("buffer-access-fontified-property",
4973 Vbuffer_access_fontified_property
,
4974 doc
: /* Property which (if non-nil) indicates text has been fontified.
4975 `buffer-substring' need not call the `buffer-access-fontify-functions'
4976 functions if all the text being accessed has this property. */);
4977 Vbuffer_access_fontified_property
= Qnil
;
4979 DEFVAR_LISP ("system-name", Vsystem_name
,
4980 doc
: /* The host name of the machine Emacs is running on. */);
4981 Vsystem_name
= cached_system_name
= Qnil
;
4983 DEFVAR_LISP ("user-full-name", Vuser_full_name
,
4984 doc
: /* The full name of the user logged in. */);
4986 DEFVAR_LISP ("user-login-name", Vuser_login_name
,
4987 doc
: /* The user's name, taken from environment variables if possible. */);
4989 DEFVAR_LISP ("user-real-login-name", Vuser_real_login_name
,
4990 doc
: /* The user's name, based upon the real uid only. */);
4992 DEFVAR_LISP ("operating-system-release", Voperating_system_release
,
4993 doc
: /* The release of the operating system Emacs is running on. */);
4995 defsubr (&Spropertize
);
4996 defsubr (&Schar_equal
);
4997 defsubr (&Sgoto_char
);
4998 defsubr (&Sstring_to_char
);
4999 defsubr (&Schar_to_string
);
5000 defsubr (&Sbyte_to_string
);
5001 defsubr (&Sbuffer_substring
);
5002 defsubr (&Sbuffer_substring_no_properties
);
5003 defsubr (&Sbuffer_string
);
5004 defsubr (&Sget_pos_property
);
5006 defsubr (&Spoint_marker
);
5007 defsubr (&Smark_marker
);
5009 defsubr (&Sregion_beginning
);
5010 defsubr (&Sregion_end
);
5012 DEFSYM (Qfield
, "field");
5013 DEFSYM (Qboundary
, "boundary");
5014 defsubr (&Sfield_beginning
);
5015 defsubr (&Sfield_end
);
5016 defsubr (&Sfield_string
);
5017 defsubr (&Sfield_string_no_properties
);
5018 defsubr (&Sdelete_field
);
5019 defsubr (&Sconstrain_to_field
);
5021 defsubr (&Sline_beginning_position
);
5022 defsubr (&Sline_end_position
);
5024 defsubr (&Ssave_excursion
);
5025 defsubr (&Ssave_current_buffer
);
5027 defsubr (&Sbuffer_size
);
5028 defsubr (&Spoint_max
);
5029 defsubr (&Spoint_min
);
5030 defsubr (&Spoint_min_marker
);
5031 defsubr (&Spoint_max_marker
);
5032 defsubr (&Sgap_position
);
5033 defsubr (&Sgap_size
);
5034 defsubr (&Sposition_bytes
);
5035 defsubr (&Sbyte_to_position
);
5041 defsubr (&Sfollowing_char
);
5042 defsubr (&Sprevious_char
);
5043 defsubr (&Schar_after
);
5044 defsubr (&Schar_before
);
5046 defsubr (&Sinsert_before_markers
);
5047 defsubr (&Sinsert_and_inherit
);
5048 defsubr (&Sinsert_and_inherit_before_markers
);
5049 defsubr (&Sinsert_char
);
5050 defsubr (&Sinsert_byte
);
5052 defsubr (&Suser_login_name
);
5053 defsubr (&Suser_real_login_name
);
5054 defsubr (&Suser_uid
);
5055 defsubr (&Suser_real_uid
);
5056 defsubr (&Sgroup_gid
);
5057 defsubr (&Sgroup_real_gid
);
5058 defsubr (&Suser_full_name
);
5059 defsubr (&Semacs_pid
);
5060 defsubr (&Scurrent_time
);
5061 defsubr (&Stime_add
);
5062 defsubr (&Stime_subtract
);
5063 defsubr (&Stime_less_p
);
5064 defsubr (&Sget_internal_run_time
);
5065 defsubr (&Sformat_time_string
);
5066 defsubr (&Sfloat_time
);
5067 defsubr (&Sdecode_time
);
5068 defsubr (&Sencode_time
);
5069 defsubr (&Scurrent_time_string
);
5070 defsubr (&Scurrent_time_zone
);
5071 defsubr (&Sset_time_zone_rule
);
5072 defsubr (&Ssystem_name
);
5073 defsubr (&Smessage
);
5074 defsubr (&Smessage_box
);
5075 defsubr (&Smessage_or_box
);
5076 defsubr (&Scurrent_message
);
5079 defsubr (&Sinsert_buffer_substring
);
5080 defsubr (&Scompare_buffer_substrings
);
5081 defsubr (&Ssubst_char_in_region
);
5082 defsubr (&Stranslate_region_internal
);
5083 defsubr (&Sdelete_region
);
5084 defsubr (&Sdelete_and_extract_region
);
5086 defsubr (&Snarrow_to_region
);
5087 defsubr (&Ssave_restriction
);
5088 defsubr (&Stranspose_regions
);