1 /* Lisp functions pertaining to editing.
3 Copyright (C) 1985-1987, 1989, 1993-2013 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 Lisp_Object
format_time_string (char const *, ptrdiff_t, struct timespec
,
69 static int tm_diff (struct tm
*, struct tm
*);
70 static void update_buffer_properties (ptrdiff_t, ptrdiff_t);
72 static Lisp_Object Qbuffer_access_fontify_functions
;
74 /* Symbol for the text property used to mark fields. */
78 /* A special value for Qfield properties. */
80 static Lisp_Object Qboundary
;
82 /* The startup value of the TZ environment variable so it can be
83 restored if the user calls set-time-zone-rule with a nil
84 argument. If null, the TZ environment variable was unset. */
85 static char const *initial_tz
;
87 /* True if the static variable tzvalbuf (defined in
88 set_time_zone_rule) is part of 'environ'. */
89 static bool tzvalbuf_in_environ
;
95 const char *user_name
;
97 struct passwd
*pw
; /* password entry for the current user */
100 /* Set up system_name even when dumping. */
104 /* Don't bother with this on initial start when just dumping out */
107 #endif /* not CANNOT_DUMP */
109 initial_tz
= getenv ("TZ");
110 tzvalbuf_in_environ
= 0;
112 pw
= getpwuid (getuid ());
114 /* We let the real user name default to "root" because that's quite
115 accurate on MSDOG and because it lets Emacs find the init file.
116 (The DVX libraries override the Djgpp libraries here.) */
117 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "root");
119 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "unknown");
122 /* Get the effective user name, by consulting environment variables,
123 or the effective uid if those are unset. */
124 user_name
= getenv ("LOGNAME");
127 user_name
= getenv ("USERNAME"); /* it's USERNAME on NT */
128 #else /* WINDOWSNT */
129 user_name
= getenv ("USER");
130 #endif /* WINDOWSNT */
133 pw
= getpwuid (geteuid ());
134 user_name
= pw
? pw
->pw_name
: "unknown";
136 Vuser_login_name
= build_string (user_name
);
138 /* If the user name claimed in the environment vars differs from
139 the real uid, use the claimed name to find the full name. */
140 tem
= Fstring_equal (Vuser_login_name
, Vuser_real_login_name
);
142 tem
= Vuser_login_name
;
145 uid_t euid
= geteuid ();
146 tem
= make_fixnum_or_float (euid
);
148 Vuser_full_name
= Fuser_full_name (tem
);
152 Vuser_full_name
= build_string (p
);
153 else if (NILP (Vuser_full_name
))
154 Vuser_full_name
= build_string ("unknown");
156 #ifdef HAVE_SYS_UTSNAME_H
160 Voperating_system_release
= build_string (uts
.release
);
163 Voperating_system_release
= Qnil
;
167 DEFUN ("char-to-string", Fchar_to_string
, Schar_to_string
, 1, 1, 0,
168 doc
: /* Convert arg CHAR to a string containing that character.
169 usage: (char-to-string CHAR) */)
170 (Lisp_Object character
)
173 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
175 CHECK_CHARACTER (character
);
176 c
= XFASTINT (character
);
178 len
= CHAR_STRING (c
, str
);
179 return make_string_from_bytes ((char *) str
, 1, len
);
182 DEFUN ("byte-to-string", Fbyte_to_string
, Sbyte_to_string
, 1, 1, 0,
183 doc
: /* Convert arg BYTE to a unibyte string containing that byte. */)
188 if (XINT (byte
) < 0 || XINT (byte
) > 255)
189 error ("Invalid byte");
191 return make_string_from_bytes ((char *) &b
, 1, 1);
194 DEFUN ("string-to-char", Fstring_to_char
, Sstring_to_char
, 1, 1, 0,
195 doc
: /* Return the first character in STRING. */)
196 (register Lisp_Object string
)
198 register Lisp_Object val
;
199 CHECK_STRING (string
);
202 if (STRING_MULTIBYTE (string
))
203 XSETFASTINT (val
, STRING_CHAR (SDATA (string
)));
205 XSETFASTINT (val
, SREF (string
, 0));
208 XSETFASTINT (val
, 0);
212 DEFUN ("point", Fpoint
, Spoint
, 0, 0, 0,
213 doc
: /* Return value of point, as an integer.
214 Beginning of buffer is position (point-min). */)
218 XSETFASTINT (temp
, PT
);
222 DEFUN ("point-marker", Fpoint_marker
, Spoint_marker
, 0, 0, 0,
223 doc
: /* Return value of point, as a marker object. */)
226 return build_marker (current_buffer
, PT
, PT_BYTE
);
229 DEFUN ("goto-char", Fgoto_char
, Sgoto_char
, 1, 1, "NGoto char: ",
230 doc
: /* Set point to POSITION, a number or marker.
231 Beginning of buffer is position (point-min), end is (point-max).
233 The return value is POSITION. */)
234 (register Lisp_Object position
)
236 if (MARKERP (position
))
237 set_point_from_marker (position
);
238 else if (INTEGERP (position
))
239 SET_PT (clip_to_bounds (BEGV
, XINT (position
), ZV
));
241 wrong_type_argument (Qinteger_or_marker_p
, position
);
246 /* Return the start or end position of the region.
247 BEGINNINGP means return the start.
248 If there is no region active, signal an error. */
251 region_limit (bool beginningp
)
255 if (!NILP (Vtransient_mark_mode
)
256 && NILP (Vmark_even_if_inactive
)
257 && NILP (BVAR (current_buffer
, mark_active
)))
258 xsignal0 (Qmark_inactive
);
260 m
= Fmarker_position (BVAR (current_buffer
, mark
));
262 error ("The mark is not set now, so there is no region");
264 /* Clip to the current narrowing (bug#11770). */
265 return make_number ((PT
< XFASTINT (m
)) == beginningp
267 : clip_to_bounds (BEGV
, XFASTINT (m
), ZV
));
270 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
271 doc
: /* Return the integer value of point or mark, whichever is smaller. */)
274 return region_limit (1);
277 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
278 doc
: /* Return the integer value of point or mark, whichever is larger. */)
281 return region_limit (0);
284 DEFUN ("mark-marker", Fmark_marker
, Smark_marker
, 0, 0, 0,
285 doc
: /* Return this buffer's mark, as a marker object.
286 Watch out! Moving this marker changes the mark position.
287 If you set the marker not to point anywhere, the buffer will have no mark. */)
290 return BVAR (current_buffer
, mark
);
294 /* Find all the overlays in the current buffer that touch position POS.
295 Return the number found, and store them in a vector in VEC
299 overlays_around (EMACS_INT pos
, Lisp_Object
*vec
, ptrdiff_t len
)
301 Lisp_Object overlay
, start
, end
;
302 struct Lisp_Overlay
*tail
;
303 ptrdiff_t startpos
, endpos
;
306 for (tail
= current_buffer
->overlays_before
; tail
; tail
= tail
->next
)
308 XSETMISC (overlay
, tail
);
310 end
= OVERLAY_END (overlay
);
311 endpos
= OVERLAY_POSITION (end
);
314 start
= OVERLAY_START (overlay
);
315 startpos
= OVERLAY_POSITION (start
);
320 /* Keep counting overlays even if we can't return them all. */
325 for (tail
= current_buffer
->overlays_after
; tail
; tail
= tail
->next
)
327 XSETMISC (overlay
, tail
);
329 start
= OVERLAY_START (overlay
);
330 startpos
= OVERLAY_POSITION (start
);
333 end
= OVERLAY_END (overlay
);
334 endpos
= OVERLAY_POSITION (end
);
346 /* Return the value of property PROP, in OBJECT at POSITION.
347 It's the value of PROP that a char inserted at POSITION would get.
348 OBJECT is optional and defaults to the current buffer.
349 If OBJECT is a buffer, then overlay properties are considered as well as
351 If OBJECT is a window, then that window's buffer is used, but
352 window-specific overlays are considered only if they are associated
355 get_pos_property (Lisp_Object position
, register Lisp_Object prop
, Lisp_Object object
)
357 CHECK_NUMBER_COERCE_MARKER (position
);
360 XSETBUFFER (object
, current_buffer
);
361 else if (WINDOWP (object
))
362 object
= XWINDOW (object
)->contents
;
364 if (!BUFFERP (object
))
365 /* pos-property only makes sense in buffers right now, since strings
366 have no overlays and no notion of insertion for which stickiness
368 return Fget_text_property (position
, prop
, object
);
371 EMACS_INT posn
= XINT (position
);
373 Lisp_Object
*overlay_vec
, tem
;
374 struct buffer
*obuf
= current_buffer
;
377 set_buffer_temp (XBUFFER (object
));
379 /* First try with room for 40 overlays. */
381 overlay_vec
= alloca (noverlays
* sizeof *overlay_vec
);
382 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
384 /* If there are more than 40,
385 make enough space for all, and try again. */
388 SAFE_ALLOCA_LISP (overlay_vec
, noverlays
);
389 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
391 noverlays
= sort_overlays (overlay_vec
, noverlays
, NULL
);
393 set_buffer_temp (obuf
);
395 /* Now check the overlays in order of decreasing priority. */
396 while (--noverlays
>= 0)
398 Lisp_Object ol
= overlay_vec
[noverlays
];
399 tem
= Foverlay_get (ol
, prop
);
402 /* Check the overlay is indeed active at point. */
403 Lisp_Object start
= OVERLAY_START (ol
), finish
= OVERLAY_END (ol
);
404 if ((OVERLAY_POSITION (start
) == posn
405 && XMARKER (start
)->insertion_type
== 1)
406 || (OVERLAY_POSITION (finish
) == posn
407 && XMARKER (finish
)->insertion_type
== 0))
408 ; /* The overlay will not cover a char inserted at point. */
418 { /* Now check the text properties. */
419 int stickiness
= text_property_stickiness (prop
, position
, object
);
421 return Fget_text_property (position
, prop
, object
);
422 else if (stickiness
< 0
423 && XINT (position
) > BUF_BEGV (XBUFFER (object
)))
424 return Fget_text_property (make_number (XINT (position
) - 1),
432 /* Find the field surrounding POS in *BEG and *END. If POS is nil,
433 the value of point is used instead. If BEG or END is null,
434 means don't store the beginning or end of the field.
436 BEG_LIMIT and END_LIMIT serve to limit the ranged of the returned
437 results; they do not effect boundary behavior.
439 If MERGE_AT_BOUNDARY is non-nil, then if POS is at the very first
440 position of a field, then the beginning of the previous field is
441 returned instead of the beginning of POS's field (since the end of a
442 field is actually also the beginning of the next input field, this
443 behavior is sometimes useful). Additionally in the MERGE_AT_BOUNDARY
444 non-nil case, if two fields are separated by a field with the special
445 value `boundary', and POS lies within it, then the two separated
446 fields are considered to be adjacent, and POS between them, when
447 finding the beginning and ending of the "merged" field.
449 Either BEG or END may be 0, in which case the corresponding value
453 find_field (Lisp_Object pos
, Lisp_Object merge_at_boundary
,
454 Lisp_Object beg_limit
,
455 ptrdiff_t *beg
, Lisp_Object end_limit
, ptrdiff_t *end
)
457 /* Fields right before and after the point. */
458 Lisp_Object before_field
, after_field
;
459 /* True if POS counts as the start of a field. */
460 bool at_field_start
= 0;
461 /* True if POS counts as the end of a field. */
462 bool at_field_end
= 0;
465 XSETFASTINT (pos
, PT
);
467 CHECK_NUMBER_COERCE_MARKER (pos
);
470 = get_char_property_and_overlay (pos
, Qfield
, Qnil
, NULL
);
472 = (XFASTINT (pos
) > BEGV
473 ? get_char_property_and_overlay (make_number (XINT (pos
) - 1),
475 /* Using nil here would be a more obvious choice, but it would
476 fail when the buffer starts with a non-sticky field. */
479 /* See if we need to handle the case where MERGE_AT_BOUNDARY is nil
480 and POS is at beginning of a field, which can also be interpreted
481 as the end of the previous field. Note that the case where if
482 MERGE_AT_BOUNDARY is non-nil (see function comment) is actually the
483 more natural one; then we avoid treating the beginning of a field
485 if (NILP (merge_at_boundary
))
487 Lisp_Object field
= get_pos_property (pos
, Qfield
, Qnil
);
488 if (!EQ (field
, after_field
))
490 if (!EQ (field
, before_field
))
492 if (NILP (field
) && at_field_start
&& at_field_end
)
493 /* If an inserted char would have a nil field while the surrounding
494 text is non-nil, we're probably not looking at a
495 zero-length field, but instead at a non-nil field that's
496 not intended for editing (such as comint's prompts). */
497 at_field_end
= at_field_start
= 0;
500 /* Note about special `boundary' fields:
502 Consider the case where the point (`.') is between the fields `x' and `y':
506 In this situation, if merge_at_boundary is non-nil, consider the
507 `x' and `y' fields as forming one big merged field, and so the end
508 of the field is the end of `y'.
510 However, if `x' and `y' are separated by a special `boundary' field
511 (a field with a `field' char-property of 'boundary), then ignore
512 this special field when merging adjacent fields. Here's the same
513 situation, but with a `boundary' field between the `x' and `y' fields:
517 Here, if point is at the end of `x', the beginning of `y', or
518 anywhere in-between (within the `boundary' field), merge all
519 three fields and consider the beginning as being the beginning of
520 the `x' field, and the end as being the end of the `y' field. */
525 /* POS is at the edge of a field, and we should consider it as
526 the beginning of the following field. */
527 *beg
= XFASTINT (pos
);
529 /* Find the previous field boundary. */
532 if (!NILP (merge_at_boundary
) && EQ (before_field
, Qboundary
))
533 /* Skip a `boundary' field. */
534 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
537 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
539 *beg
= NILP (p
) ? BEGV
: XFASTINT (p
);
546 /* POS is at the edge of a field, and we should consider it as
547 the end of the previous field. */
548 *end
= XFASTINT (pos
);
550 /* Find the next field boundary. */
552 if (!NILP (merge_at_boundary
) && EQ (after_field
, Qboundary
))
553 /* Skip a `boundary' field. */
554 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
557 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
559 *end
= NILP (pos
) ? ZV
: XFASTINT (pos
);
565 DEFUN ("delete-field", Fdelete_field
, Sdelete_field
, 0, 1, 0,
566 doc
: /* Delete the field surrounding POS.
567 A field is a region of text with the same `field' property.
568 If POS is nil, the value of point is used for POS. */)
572 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
574 del_range (beg
, end
);
578 DEFUN ("field-string", Ffield_string
, Sfield_string
, 0, 1, 0,
579 doc
: /* Return the contents of the field surrounding POS as a string.
580 A field is a region of text with the same `field' property.
581 If POS is nil, the value of point is used for POS. */)
585 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
586 return make_buffer_string (beg
, end
, 1);
589 DEFUN ("field-string-no-properties", Ffield_string_no_properties
, Sfield_string_no_properties
, 0, 1, 0,
590 doc
: /* Return the contents of the field around POS, without text properties.
591 A field is a region of text with the same `field' property.
592 If POS is nil, the value of point is used for POS. */)
596 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
597 return make_buffer_string (beg
, end
, 0);
600 DEFUN ("field-beginning", Ffield_beginning
, Sfield_beginning
, 0, 3, 0,
601 doc
: /* Return the beginning of the field surrounding POS.
602 A field is a region of text with the same `field' property.
603 If POS is nil, the value of point is used for POS.
604 If ESCAPE-FROM-EDGE is non-nil and POS is at the beginning of its
605 field, then the beginning of the *previous* field is returned.
606 If LIMIT is non-nil, it is a buffer position; if the beginning of the field
607 is before LIMIT, then LIMIT will be returned instead. */)
608 (Lisp_Object pos
, Lisp_Object escape_from_edge
, Lisp_Object limit
)
611 find_field (pos
, escape_from_edge
, limit
, &beg
, Qnil
, 0);
612 return make_number (beg
);
615 DEFUN ("field-end", Ffield_end
, Sfield_end
, 0, 3, 0,
616 doc
: /* Return the end of the field surrounding POS.
617 A field is a region of text with the same `field' property.
618 If POS is nil, the value of point is used for POS.
619 If ESCAPE-FROM-EDGE is non-nil and POS is at the end of its field,
620 then the end of the *following* field is returned.
621 If LIMIT is non-nil, it is a buffer position; if the end of the field
622 is after LIMIT, then LIMIT will be returned instead. */)
623 (Lisp_Object pos
, Lisp_Object escape_from_edge
, Lisp_Object limit
)
626 find_field (pos
, escape_from_edge
, Qnil
, 0, limit
, &end
);
627 return make_number (end
);
630 DEFUN ("constrain-to-field", Fconstrain_to_field
, Sconstrain_to_field
, 2, 5, 0,
631 doc
: /* Return the position closest to NEW-POS that is in the same field as OLD-POS.
632 A field is a region of text with the same `field' property.
634 If NEW-POS is nil, then use the current point instead, and move point
635 to the resulting constrained position, in addition to returning that
638 If OLD-POS is at the boundary of two fields, then the allowable
639 positions for NEW-POS depends on the value of the optional argument
640 ESCAPE-FROM-EDGE: If ESCAPE-FROM-EDGE is nil, then NEW-POS is
641 constrained to the field that has the same `field' char-property
642 as any new characters inserted at OLD-POS, whereas if ESCAPE-FROM-EDGE
643 is non-nil, NEW-POS is constrained to the union of the two adjacent
644 fields. Additionally, if two fields are separated by another field with
645 the special value `boundary', then any point within this special field is
646 also considered to be `on the boundary'.
648 If the optional argument ONLY-IN-LINE is non-nil and constraining
649 NEW-POS would move it to a different line, NEW-POS is returned
650 unconstrained. This useful for commands that move by line, like
651 \\[next-line] or \\[beginning-of-line], which should generally respect field boundaries
652 only in the case where they can still move to the right line.
654 If the optional argument INHIBIT-CAPTURE-PROPERTY is non-nil, and OLD-POS has
655 a non-nil property of that name, then any field boundaries are ignored.
657 Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
658 (Lisp_Object new_pos
, Lisp_Object old_pos
, Lisp_Object escape_from_edge
,
659 Lisp_Object only_in_line
, Lisp_Object inhibit_capture_property
)
661 /* If non-zero, then the original point, before re-positioning. */
662 ptrdiff_t orig_point
= 0;
664 Lisp_Object prev_old
, prev_new
;
667 /* Use the current point, and afterwards, set it. */
670 XSETFASTINT (new_pos
, PT
);
673 CHECK_NUMBER_COERCE_MARKER (new_pos
);
674 CHECK_NUMBER_COERCE_MARKER (old_pos
);
676 fwd
= (XINT (new_pos
) > XINT (old_pos
));
678 prev_old
= make_number (XINT (old_pos
) - 1);
679 prev_new
= make_number (XINT (new_pos
) - 1);
681 if (NILP (Vinhibit_field_text_motion
)
682 && !EQ (new_pos
, old_pos
)
683 && (!NILP (Fget_char_property (new_pos
, Qfield
, Qnil
))
684 || !NILP (Fget_char_property (old_pos
, Qfield
, Qnil
))
685 /* To recognize field boundaries, we must also look at the
686 previous positions; we could use `get_pos_property'
687 instead, but in itself that would fail inside non-sticky
688 fields (like comint prompts). */
689 || (XFASTINT (new_pos
) > BEGV
690 && !NILP (Fget_char_property (prev_new
, Qfield
, Qnil
)))
691 || (XFASTINT (old_pos
) > BEGV
692 && !NILP (Fget_char_property (prev_old
, Qfield
, Qnil
))))
693 && (NILP (inhibit_capture_property
)
694 /* Field boundaries are again a problem; but now we must
695 decide the case exactly, so we need to call
696 `get_pos_property' as well. */
697 || (NILP (get_pos_property (old_pos
, inhibit_capture_property
, Qnil
))
698 && (XFASTINT (old_pos
) <= BEGV
699 || NILP (Fget_char_property (old_pos
, inhibit_capture_property
, Qnil
))
700 || NILP (Fget_char_property (prev_old
, inhibit_capture_property
, Qnil
))))))
701 /* It is possible that NEW_POS is not within the same field as
702 OLD_POS; try to move NEW_POS so that it is. */
705 Lisp_Object field_bound
;
708 field_bound
= Ffield_end (old_pos
, escape_from_edge
, new_pos
);
710 field_bound
= Ffield_beginning (old_pos
, escape_from_edge
, new_pos
);
712 if (/* See if ESCAPE_FROM_EDGE caused FIELD_BOUND to jump to the
713 other side of NEW_POS, which would mean that NEW_POS is
714 already acceptable, and it's not necessary to constrain it
716 ((XFASTINT (field_bound
) < XFASTINT (new_pos
)) ? fwd
: !fwd
)
717 /* NEW_POS should be constrained, but only if either
718 ONLY_IN_LINE is nil (in which case any constraint is OK),
719 or NEW_POS and FIELD_BOUND are on the same line (in which
720 case the constraint is OK even if ONLY_IN_LINE is non-nil). */
721 && (NILP (only_in_line
)
722 /* This is the ONLY_IN_LINE case, check that NEW_POS and
723 FIELD_BOUND are on the same line by seeing whether
724 there's an intervening newline or not. */
725 || (find_newline (XFASTINT (new_pos
), -1,
726 XFASTINT (field_bound
), -1,
727 fwd
? -1 : 1, &shortage
, NULL
, 1),
729 /* Constrain NEW_POS to FIELD_BOUND. */
730 new_pos
= field_bound
;
732 if (orig_point
&& XFASTINT (new_pos
) != orig_point
)
733 /* The NEW_POS argument was originally nil, so automatically set PT. */
734 SET_PT (XFASTINT (new_pos
));
741 DEFUN ("line-beginning-position",
742 Fline_beginning_position
, Sline_beginning_position
, 0, 1, 0,
743 doc
: /* Return the character position of the first character on the current line.
744 With optional argument N, scan forward N - 1 lines first.
745 If the scan reaches the end of the buffer, return that position.
747 This function ignores text display directionality; it returns the
748 position of the first character in logical order, i.e. the smallest
749 character position on the line.
751 This function constrains the returned position to the current field
752 unless that position would be on a different line than the original,
753 unconstrained result. If N is nil or 1, and a front-sticky field
754 starts at point, the scan stops as soon as it starts. To ignore field
755 boundaries, bind `inhibit-field-text-motion' to t.
757 This function does not move point. */)
760 ptrdiff_t orig
, orig_byte
, end
;
761 ptrdiff_t count
= SPECPDL_INDEX ();
762 specbind (Qinhibit_point_motion_hooks
, Qt
);
771 Fforward_line (make_number (XINT (n
) - 1));
774 SET_PT_BOTH (orig
, orig_byte
);
776 unbind_to (count
, Qnil
);
778 /* Return END constrained to the current input field. */
779 return Fconstrain_to_field (make_number (end
), make_number (orig
),
780 XINT (n
) != 1 ? Qt
: Qnil
,
784 DEFUN ("line-end-position", Fline_end_position
, Sline_end_position
, 0, 1, 0,
785 doc
: /* Return the character position of the last character on the current line.
786 With argument N not nil or 1, move forward N - 1 lines first.
787 If scan reaches end of buffer, return that position.
789 This function ignores text display directionality; it returns the
790 position of the last character in logical order, i.e. the largest
791 character position on the line.
793 This function constrains the returned position to the current field
794 unless that would be on a different line than the original,
795 unconstrained result. If N is nil or 1, and a rear-sticky field ends
796 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. */)
811 clipped_n
= clip_to_bounds (PTRDIFF_MIN
+ 1, XINT (n
), PTRDIFF_MAX
);
812 end_pos
= find_before_next_newline (orig
, 0, clipped_n
- (clipped_n
<= 0),
815 /* Return END_POS constrained to the current input field. */
816 return Fconstrain_to_field (make_number (end_pos
), make_number (orig
),
820 /* Save current buffer state for `save-excursion' special form.
821 We (ab)use Lisp_Misc_Save_Value to allow explicit free and so
822 offload some work from GC. */
825 save_excursion_save (void)
827 return make_save_obj_obj_obj_obj
829 /* Do not copy the mark if it points to nowhere. */
830 (XMARKER (BVAR (current_buffer
, mark
))->buffer
831 ? Fcopy_marker (BVAR (current_buffer
, mark
), Qnil
)
833 /* Selected window if current buffer is shown in it, nil otherwise. */
834 (EQ (XWINDOW (selected_window
)->contents
, Fcurrent_buffer ())
835 ? selected_window
: Qnil
),
836 BVAR (current_buffer
, mark_active
));
839 /* Restore saved buffer before leaving `save-excursion' special form. */
842 save_excursion_restore (Lisp_Object info
)
844 Lisp_Object tem
, tem1
, omark
, nmark
;
845 struct gcpro gcpro1
, gcpro2
, gcpro3
;
847 tem
= Fmarker_buffer (XSAVE_OBJECT (info
, 0));
848 /* If we're unwinding to top level, saved buffer may be deleted. This
849 means that all of its markers are unchained and so tem is nil. */
853 omark
= nmark
= Qnil
;
854 GCPRO3 (info
, omark
, nmark
);
859 tem
= XSAVE_OBJECT (info
, 0);
861 unchain_marker (XMARKER (tem
));
864 tem
= XSAVE_OBJECT (info
, 1);
865 omark
= Fmarker_position (BVAR (current_buffer
, mark
));
867 unchain_marker (XMARKER (BVAR (current_buffer
, mark
)));
870 Fset_marker (BVAR (current_buffer
, mark
), tem
, Fcurrent_buffer ());
871 nmark
= Fmarker_position (tem
);
872 unchain_marker (XMARKER (tem
));
876 tem
= XSAVE_OBJECT (info
, 3);
877 tem1
= BVAR (current_buffer
, mark_active
);
878 bset_mark_active (current_buffer
, tem
);
880 /* If mark is active now, and either was not active
881 or was at a different place, run the activate hook. */
884 if (! EQ (omark
, nmark
))
886 tem
= intern ("activate-mark-hook");
887 Frun_hooks (1, &tem
);
890 /* If mark has ceased to be active, run deactivate hook. */
891 else if (! NILP (tem1
))
893 tem
= intern ("deactivate-mark-hook");
894 Frun_hooks (1, &tem
);
897 /* If buffer was visible in a window, and a different window was
898 selected, and the old selected window is still showing this
899 buffer, restore point in that window. */
900 tem
= XSAVE_OBJECT (info
, 2);
902 && !EQ (tem
, selected_window
)
903 && (tem1
= XWINDOW (tem
)->contents
,
904 (/* Window is live... */
906 /* ...and it shows the current buffer. */
907 && XBUFFER (tem1
) == current_buffer
)))
908 Fset_window_point (tem
, make_number (PT
));
917 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
918 doc
: /* Save point, mark, and current buffer; execute BODY; restore those things.
919 Executes BODY just like `progn'.
920 The values of point, mark and the current buffer are restored
921 even in case of abnormal exit (throw or error).
922 The state of activation of the mark is also restored.
924 This construct does not save `deactivate-mark', and therefore
925 functions that change the buffer will still cause deactivation
926 of the mark at the end of the command. To prevent that, bind
927 `deactivate-mark' with `let'.
929 If you only want to save the current buffer but not point nor mark,
930 then just use `save-current-buffer', or even `with-current-buffer'.
932 usage: (save-excursion &rest BODY) */)
935 register Lisp_Object val
;
936 ptrdiff_t count
= SPECPDL_INDEX ();
938 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
941 return unbind_to (count
, val
);
944 DEFUN ("save-current-buffer", Fsave_current_buffer
, Ssave_current_buffer
, 0, UNEVALLED
, 0,
945 doc
: /* Record which buffer is current; execute BODY; make that buffer current.
946 BODY is executed just like `progn'.
947 usage: (save-current-buffer &rest BODY) */)
950 ptrdiff_t count
= SPECPDL_INDEX ();
952 record_unwind_current_buffer ();
953 return unbind_to (count
, Fprogn (args
));
956 DEFUN ("buffer-size", Fbuffer_size
, Sbuffer_size
, 0, 1, 0,
957 doc
: /* Return the number of characters in the current buffer.
958 If BUFFER, return the number of characters in that buffer instead. */)
962 return make_number (Z
- BEG
);
965 CHECK_BUFFER (buffer
);
966 return make_number (BUF_Z (XBUFFER (buffer
))
967 - BUF_BEG (XBUFFER (buffer
)));
971 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
972 doc
: /* Return the minimum permissible value of point in the current buffer.
973 This is 1, unless narrowing (a buffer restriction) is in effect. */)
977 XSETFASTINT (temp
, BEGV
);
981 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
982 doc
: /* Return a marker to the minimum permissible value of point in this buffer.
983 This is the beginning, unless narrowing (a buffer restriction) is in effect. */)
986 return build_marker (current_buffer
, BEGV
, BEGV_BYTE
);
989 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
990 doc
: /* Return the maximum permissible value of point in the current buffer.
991 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
992 is in effect, in which case it is less. */)
996 XSETFASTINT (temp
, ZV
);
1000 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
1001 doc
: /* Return a marker to the maximum permissible value of point in this buffer.
1002 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1003 is in effect, in which case it is less. */)
1006 return build_marker (current_buffer
, ZV
, ZV_BYTE
);
1009 DEFUN ("gap-position", Fgap_position
, Sgap_position
, 0, 0, 0,
1010 doc
: /* Return the position of the gap, in the current buffer.
1011 See also `gap-size'. */)
1015 XSETFASTINT (temp
, GPT
);
1019 DEFUN ("gap-size", Fgap_size
, Sgap_size
, 0, 0, 0,
1020 doc
: /* Return the size of the current buffer's gap.
1021 See also `gap-position'. */)
1025 XSETFASTINT (temp
, GAP_SIZE
);
1029 DEFUN ("position-bytes", Fposition_bytes
, Sposition_bytes
, 1, 1, 0,
1030 doc
: /* Return the byte position for character position POSITION.
1031 If POSITION is out of range, the value is nil. */)
1032 (Lisp_Object position
)
1034 CHECK_NUMBER_COERCE_MARKER (position
);
1035 if (XINT (position
) < BEG
|| XINT (position
) > Z
)
1037 return make_number (CHAR_TO_BYTE (XINT (position
)));
1040 DEFUN ("byte-to-position", Fbyte_to_position
, Sbyte_to_position
, 1, 1, 0,
1041 doc
: /* Return the character position for byte position BYTEPOS.
1042 If BYTEPOS is out of range, the value is nil. */)
1043 (Lisp_Object bytepos
)
1045 CHECK_NUMBER (bytepos
);
1046 if (XINT (bytepos
) < BEG_BYTE
|| XINT (bytepos
) > Z_BYTE
)
1048 return make_number (BYTE_TO_CHAR (XINT (bytepos
)));
1051 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
1052 doc
: /* Return the character following point, as a number.
1053 At the end of the buffer or accessible region, return 0. */)
1058 XSETFASTINT (temp
, 0);
1060 XSETFASTINT (temp
, FETCH_CHAR (PT_BYTE
));
1064 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
1065 doc
: /* Return the character preceding point, as a number.
1066 At the beginning of the buffer or accessible region, return 0. */)
1071 XSETFASTINT (temp
, 0);
1072 else if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1074 ptrdiff_t pos
= PT_BYTE
;
1076 XSETFASTINT (temp
, FETCH_CHAR (pos
));
1079 XSETFASTINT (temp
, FETCH_BYTE (PT_BYTE
- 1));
1083 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
1084 doc
: /* Return t if point is at the beginning of the buffer.
1085 If the buffer is narrowed, this means the beginning of the narrowed part. */)
1093 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
1094 doc
: /* Return t if point is at the end of the buffer.
1095 If the buffer is narrowed, this means the end of the narrowed part. */)
1103 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
1104 doc
: /* Return t if point is at the beginning of a line. */)
1107 if (PT
== BEGV
|| FETCH_BYTE (PT_BYTE
- 1) == '\n')
1112 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
1113 doc
: /* Return t if point is at the end of a line.
1114 `End of a line' includes point being at the end of the buffer. */)
1117 if (PT
== ZV
|| FETCH_BYTE (PT_BYTE
) == '\n')
1122 DEFUN ("char-after", Fchar_after
, Schar_after
, 0, 1, 0,
1123 doc
: /* Return character in current buffer at position POS.
1124 POS is an integer or a marker and defaults to point.
1125 If POS is out of range, the value is nil. */)
1128 register ptrdiff_t pos_byte
;
1133 XSETFASTINT (pos
, PT
);
1138 pos_byte
= marker_byte_position (pos
);
1139 if (pos_byte
< BEGV_BYTE
|| pos_byte
>= ZV_BYTE
)
1144 CHECK_NUMBER_COERCE_MARKER (pos
);
1145 if (XINT (pos
) < BEGV
|| XINT (pos
) >= ZV
)
1148 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1151 return make_number (FETCH_CHAR (pos_byte
));
1154 DEFUN ("char-before", Fchar_before
, Schar_before
, 0, 1, 0,
1155 doc
: /* Return character in current buffer preceding position POS.
1156 POS is an integer or a marker and defaults to point.
1157 If POS is out of range, the value is nil. */)
1160 register Lisp_Object val
;
1161 register ptrdiff_t pos_byte
;
1166 XSETFASTINT (pos
, PT
);
1171 pos_byte
= marker_byte_position (pos
);
1173 if (pos_byte
<= BEGV_BYTE
|| pos_byte
> ZV_BYTE
)
1178 CHECK_NUMBER_COERCE_MARKER (pos
);
1180 if (XINT (pos
) <= BEGV
|| XINT (pos
) > ZV
)
1183 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1186 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1189 XSETFASTINT (val
, FETCH_CHAR (pos_byte
));
1194 XSETFASTINT (val
, FETCH_BYTE (pos_byte
));
1199 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 1, 0,
1200 doc
: /* Return the name under which the user logged in, as a string.
1201 This is based on the effective uid, not the real uid.
1202 Also, if the environment variables LOGNAME or USER are set,
1203 that determines the value of this function.
1205 If optional argument UID is an integer or a float, return the login name
1206 of the user with that uid, or nil if there is no such user. */)
1212 /* Set up the user name info if we didn't do it before.
1213 (That can happen if Emacs is dumpable
1214 but you decide to run `temacs -l loadup' and not dump. */
1215 if (INTEGERP (Vuser_login_name
))
1219 return Vuser_login_name
;
1221 CONS_TO_INTEGER (uid
, uid_t
, id
);
1225 return (pw
? build_string (pw
->pw_name
) : Qnil
);
1228 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
1230 doc
: /* Return the name of the user's real uid, as a string.
1231 This ignores the environment variables LOGNAME and USER, so it differs from
1232 `user-login-name' when running under `su'. */)
1235 /* Set up the user name info if we didn't do it before.
1236 (That can happen if Emacs is dumpable
1237 but you decide to run `temacs -l loadup' and not dump. */
1238 if (INTEGERP (Vuser_login_name
))
1240 return Vuser_real_login_name
;
1243 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
1244 doc
: /* Return the effective uid of Emacs.
1245 Value is an integer or a float, depending on the value. */)
1248 uid_t euid
= geteuid ();
1249 return make_fixnum_or_float (euid
);
1252 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
1253 doc
: /* Return the real uid of Emacs.
1254 Value is an integer or a float, depending on the value. */)
1257 uid_t uid
= getuid ();
1258 return make_fixnum_or_float (uid
);
1261 DEFUN ("group-gid", Fgroup_gid
, Sgroup_gid
, 0, 0, 0,
1262 doc
: /* Return the effective gid of Emacs.
1263 Value is an integer or a float, depending on the value. */)
1266 gid_t egid
= getegid ();
1267 return make_fixnum_or_float (egid
);
1270 DEFUN ("group-real-gid", Fgroup_real_gid
, Sgroup_real_gid
, 0, 0, 0,
1271 doc
: /* Return the real gid of Emacs.
1272 Value is an integer or a float, depending on the value. */)
1275 gid_t gid
= getgid ();
1276 return make_fixnum_or_float (gid
);
1279 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 1, 0,
1280 doc
: /* Return the full name of the user logged in, as a string.
1281 If the full name corresponding to Emacs's userid is not known,
1284 If optional argument UID is an integer or float, return the full name
1285 of the user with that uid, or nil if there is no such user.
1286 If UID is a string, return the full name of the user with that login
1287 name, or nil if there is no such user. */)
1291 register char *p
, *q
;
1295 return Vuser_full_name
;
1296 else if (NUMBERP (uid
))
1299 CONS_TO_INTEGER (uid
, uid_t
, u
);
1304 else if (STRINGP (uid
))
1307 pw
= getpwnam (SSDATA (uid
));
1311 error ("Invalid UID specification");
1317 /* Chop off everything after the first comma. */
1318 q
= strchr (p
, ',');
1319 full
= make_string (p
, q
? q
- p
: strlen (p
));
1321 #ifdef AMPERSAND_FULL_NAME
1323 q
= strchr (p
, '&');
1324 /* Substitute the login name for the &, upcasing the first character. */
1330 login
= Fuser_login_name (make_number (pw
->pw_uid
));
1331 r
= alloca (strlen (p
) + SCHARS (login
) + 1);
1332 memcpy (r
, p
, q
- p
);
1334 strcat (r
, SSDATA (login
));
1335 r
[q
- p
] = upcase ((unsigned char) r
[q
- p
]);
1337 full
= build_string (r
);
1339 #endif /* AMPERSAND_FULL_NAME */
1344 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
1345 doc
: /* Return the host name of the machine you are running on, as a string. */)
1348 return Vsystem_name
;
1351 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
1352 doc
: /* Return the process ID of Emacs, as a number. */)
1355 pid_t pid
= getpid ();
1356 return make_fixnum_or_float (pid
);
1362 # define TIME_T_MIN TYPE_MINIMUM (time_t)
1365 # define TIME_T_MAX TYPE_MAXIMUM (time_t)
1368 /* Report that a time value is out of range for Emacs. */
1370 time_overflow (void)
1372 error ("Specified time is not representable");
1375 /* Return the upper part of the time T (everything but the bottom 16 bits). */
1379 time_t hi
= t
>> 16;
1381 /* Check for overflow, helping the compiler for common cases where
1382 no runtime check is needed, and taking care not to convert
1383 negative numbers to unsigned before comparing them. */
1384 if (! ((! TYPE_SIGNED (time_t)
1385 || MOST_NEGATIVE_FIXNUM
<= TIME_T_MIN
>> 16
1386 || MOST_NEGATIVE_FIXNUM
<= hi
)
1387 && (TIME_T_MAX
>> 16 <= MOST_POSITIVE_FIXNUM
1388 || hi
<= MOST_POSITIVE_FIXNUM
)))
1394 /* Return the bottom 16 bits of the time T. */
1398 return t
& ((1 << 16) - 1);
1401 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
1402 doc
: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
1403 The time is returned as a list of integers (HIGH LOW USEC PSEC).
1404 HIGH has the most significant bits of the seconds, while LOW has the
1405 least significant 16 bits. USEC and PSEC are the microsecond and
1406 picosecond counts. */)
1409 return make_lisp_time (current_timespec ());
1412 DEFUN ("get-internal-run-time", Fget_internal_run_time
, Sget_internal_run_time
,
1414 doc
: /* Return the current run time used by Emacs.
1415 The time is returned as a list (HIGH LOW USEC PSEC), using the same
1416 style as (current-time).
1418 On systems that can't determine the run time, `get-internal-run-time'
1419 does the same thing as `current-time'. */)
1422 #ifdef HAVE_GETRUSAGE
1423 struct rusage usage
;
1427 if (getrusage (RUSAGE_SELF
, &usage
) < 0)
1428 /* This shouldn't happen. What action is appropriate? */
1431 /* Sum up user time and system time. */
1432 secs
= usage
.ru_utime
.tv_sec
+ usage
.ru_stime
.tv_sec
;
1433 usecs
= usage
.ru_utime
.tv_usec
+ usage
.ru_stime
.tv_usec
;
1434 if (usecs
>= 1000000)
1439 return make_lisp_time (make_timespec (secs
, usecs
* 1000));
1440 #else /* ! HAVE_GETRUSAGE */
1442 return w32_get_internal_run_time ();
1443 #else /* ! WINDOWSNT */
1444 return Fcurrent_time ();
1445 #endif /* WINDOWSNT */
1446 #endif /* HAVE_GETRUSAGE */
1450 /* Make a Lisp list that represents the time T with fraction TAIL. */
1452 make_time_tail (time_t t
, Lisp_Object tail
)
1454 return Fcons (make_number (hi_time (t
)),
1455 Fcons (make_number (lo_time (t
)), tail
));
1458 /* Make a Lisp list that represents the system time T. */
1460 make_time (time_t t
)
1462 return make_time_tail (t
, Qnil
);
1465 /* Make a Lisp list that represents the Emacs time T. T may be an
1466 invalid time, with a slightly negative tv_nsec value such as
1467 UNKNOWN_MODTIME_NSECS; in that case, the Lisp list contains a
1468 correspondingly negative picosecond count. */
1470 make_lisp_time (struct timespec t
)
1473 return make_time_tail (t
.tv_sec
, list2i (ns
/ 1000, ns
% 1000 * 1000));
1476 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1477 Set *PHIGH, *PLOW, *PUSEC, *PPSEC to its parts; do not check their values.
1478 Return true if successful. */
1480 disassemble_lisp_time (Lisp_Object specified_time
, Lisp_Object
*phigh
,
1481 Lisp_Object
*plow
, Lisp_Object
*pusec
,
1484 if (CONSP (specified_time
))
1486 Lisp_Object low
= XCDR (specified_time
);
1487 Lisp_Object usec
= make_number (0);
1488 Lisp_Object psec
= make_number (0);
1491 Lisp_Object low_tail
= XCDR (low
);
1493 if (CONSP (low_tail
))
1495 usec
= XCAR (low_tail
);
1496 low_tail
= XCDR (low_tail
);
1497 if (CONSP (low_tail
))
1498 psec
= XCAR (low_tail
);
1500 else if (!NILP (low_tail
))
1504 *phigh
= XCAR (specified_time
);
1514 /* From the time components HIGH, LOW, USEC and PSEC taken from a Lisp
1515 list, generate the corresponding time value.
1517 If RESULT is not null, store into *RESULT the converted time;
1518 this can fail if the converted time does not fit into struct timespec.
1519 If *DRESULT is not null, store into *DRESULT the number of
1520 seconds since the start of the POSIX Epoch.
1522 Return true if successful. */
1524 decode_time_components (Lisp_Object high
, Lisp_Object low
, Lisp_Object usec
,
1526 struct timespec
*result
, double *dresult
)
1528 EMACS_INT hi
, lo
, us
, ps
;
1529 if (! (INTEGERP (high
) && INTEGERP (low
)
1530 && INTEGERP (usec
) && INTEGERP (psec
)))
1537 /* Normalize out-of-range lower-order components by carrying
1538 each overflow into the next higher-order component. */
1539 us
+= ps
/ 1000000 - (ps
% 1000000 < 0);
1540 lo
+= us
/ 1000000 - (us
% 1000000 < 0);
1542 ps
= ps
% 1000000 + 1000000 * (ps
% 1000000 < 0);
1543 us
= us
% 1000000 + 1000000 * (us
% 1000000 < 0);
1544 lo
&= (1 << 16) - 1;
1548 if ((TYPE_SIGNED (time_t) ? TIME_T_MIN
>> 16 <= hi
: 0 <= hi
)
1549 && hi
<= TIME_T_MAX
>> 16)
1551 /* Return the greatest representable time that is not greater
1552 than the requested time. */
1554 *result
= make_timespec ((sec
<< 16) + lo
, us
* 1000 + ps
/ 1000);
1558 /* Overflow in the highest-order component. */
1564 *dresult
= (us
* 1e6
+ ps
) / 1e12
+ lo
+ hi
* 65536.0;
1569 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1570 If SPECIFIED_TIME is nil, use the current time.
1572 Round the time down to the nearest struct timespec value.
1573 Return seconds since the Epoch.
1574 Signal an error if unsuccessful. */
1576 lisp_time_argument (Lisp_Object specified_time
)
1579 if (NILP (specified_time
))
1580 t
= current_timespec ();
1583 Lisp_Object high
, low
, usec
, psec
;
1584 if (! (disassemble_lisp_time (specified_time
, &high
, &low
, &usec
, &psec
)
1585 && decode_time_components (high
, low
, usec
, psec
, &t
, 0)))
1586 error ("Invalid time specification");
1591 /* Like lisp_time_argument, except decode only the seconds part,
1592 do not allow out-of-range time stamps, do not check the subseconds part,
1593 and always round down. */
1595 lisp_seconds_argument (Lisp_Object specified_time
)
1597 if (NILP (specified_time
))
1601 Lisp_Object high
, low
, usec
, psec
;
1603 if (! (disassemble_lisp_time (specified_time
, &high
, &low
, &usec
, &psec
)
1604 && decode_time_components (high
, low
, make_number (0),
1605 make_number (0), &t
, 0)))
1606 error ("Invalid time specification");
1611 DEFUN ("float-time", Ffloat_time
, Sfloat_time
, 0, 1, 0,
1612 doc
: /* Return the current time, as a float number of seconds since the epoch.
1613 If SPECIFIED-TIME is given, it is the time to convert to float
1614 instead of the current time. The argument should have the form
1615 (HIGH LOW) or (HIGH LOW USEC) or (HIGH LOW USEC PSEC). Thus,
1616 you can use times from `current-time' and from `file-attributes'.
1617 SPECIFIED-TIME can also have the form (HIGH . LOW), but this is
1618 considered obsolete.
1620 WARNING: Since the result is floating point, it may not be exact.
1621 If precise time stamps are required, use either `current-time',
1622 or (if you need time as a string) `format-time-string'. */)
1623 (Lisp_Object specified_time
)
1626 if (NILP (specified_time
))
1628 struct timespec now
= current_timespec ();
1629 t
= now
.tv_sec
+ now
.tv_nsec
/ 1e9
;
1633 Lisp_Object high
, low
, usec
, psec
;
1634 if (! (disassemble_lisp_time (specified_time
, &high
, &low
, &usec
, &psec
)
1635 && decode_time_components (high
, low
, usec
, psec
, 0, &t
)))
1636 error ("Invalid time specification");
1638 return make_float (t
);
1641 /* Write information into buffer S of size MAXSIZE, according to the
1642 FORMAT of length FORMAT_LEN, using time information taken from *TP.
1643 Default to Universal Time if UT, local time otherwise.
1644 Use NS as the number of nanoseconds in the %N directive.
1645 Return the number of bytes written, not including the terminating
1646 '\0'. If S is NULL, nothing will be written anywhere; so to
1647 determine how many bytes would be written, use NULL for S and
1648 ((size_t) -1) for MAXSIZE.
1650 This function behaves like nstrftime, except it allows null
1651 bytes in FORMAT and it does not support nanoseconds. */
1653 emacs_nmemftime (char *s
, size_t maxsize
, const char *format
,
1654 size_t format_len
, const struct tm
*tp
, bool ut
, int ns
)
1658 /* Loop through all the null-terminated strings in the format
1659 argument. Normally there's just one null-terminated string, but
1660 there can be arbitrarily many, concatenated together, if the
1661 format contains '\0' bytes. nstrftime stops at the first
1662 '\0' byte so we must invoke it separately for each such string. */
1671 result
= nstrftime (s
, maxsize
, format
, tp
, ut
, ns
);
1675 if (result
== 0 && s
[0] != '\0')
1680 maxsize
-= result
+ 1;
1682 len
= strlen (format
);
1683 if (len
== format_len
)
1687 format_len
-= len
+ 1;
1691 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 1, 3, 0,
1692 doc
: /* Use FORMAT-STRING to format the time TIME, or now if omitted.
1693 TIME is specified as (HIGH LOW USEC PSEC), as returned by
1694 `current-time' or `file-attributes'. The obsolete form (HIGH . LOW)
1695 is also still accepted.
1696 The third, optional, argument UNIVERSAL, if non-nil, means describe TIME
1697 as Universal Time; nil means describe TIME in the local time zone.
1698 The value is a copy of FORMAT-STRING, but with certain constructs replaced
1699 by text that describes the specified date and time in TIME:
1701 %Y is the year, %y within the century, %C the century.
1702 %G is the year corresponding to the ISO week, %g within the century.
1703 %m is the numeric month.
1704 %b and %h are the locale's abbreviated month name, %B the full name.
1705 (%h is not supported on MS-Windows.)
1706 %d is the day of the month, zero-padded, %e is blank-padded.
1707 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
1708 %a is the locale's abbreviated name of the day of week, %A the full name.
1709 %U is the week number starting on Sunday, %W starting on Monday,
1710 %V according to ISO 8601.
1711 %j is the day of the year.
1713 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
1714 only blank-padded, %l is like %I blank-padded.
1715 %p is the locale's equivalent of either AM or PM.
1718 %N is the nanosecond, %6N the microsecond, %3N the millisecond, etc.
1719 %Z is the time zone name, %z is the numeric form.
1720 %s is the number of seconds since 1970-01-01 00:00:00 +0000.
1722 %c is the locale's date and time format.
1723 %x is the locale's "preferred" date format.
1724 %D is like "%m/%d/%y".
1726 %R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
1727 %X is the locale's "preferred" time format.
1729 Finally, %n is a newline, %t is a tab, %% is a literal %.
1731 Certain flags and modifiers are available with some format controls.
1732 The flags are `_', `-', `^' and `#'. For certain characters X,
1733 %_X is like %X, but padded with blanks; %-X is like %X,
1734 but without padding. %^X is like %X, but with all textual
1735 characters up-cased; %#X is like %X, but with letter-case of
1736 all textual characters reversed.
1737 %NX (where N stands for an integer) is like %X,
1738 but takes up at least N (a number) positions.
1739 The modifiers are `E' and `O'. For certain characters X,
1740 %EX is a locale's alternative version of %X;
1741 %OX is like %X, but uses the locale's number symbols.
1743 For example, to produce full ISO 8601 format, use "%Y-%m-%dT%T%z".
1745 usage: (format-time-string FORMAT-STRING &optional TIME UNIVERSAL) */)
1746 (Lisp_Object format_string
, Lisp_Object timeval
, Lisp_Object universal
)
1748 struct timespec t
= lisp_time_argument (timeval
);
1751 CHECK_STRING (format_string
);
1752 format_string
= code_convert_string_norecord (format_string
,
1753 Vlocale_coding_system
, 1);
1754 return format_time_string (SSDATA (format_string
), SBYTES (format_string
),
1755 t
, ! NILP (universal
), &tm
);
1759 format_time_string (char const *format
, ptrdiff_t formatlen
,
1760 struct timespec t
, bool ut
, struct tm
*tmp
)
1764 ptrdiff_t size
= sizeof buffer
;
1766 Lisp_Object bufstring
;
1773 time_t *taddr
= &t
.tv_sec
;
1776 synchronize_system_time_locale ();
1778 tm
= ut
? gmtime (taddr
) : localtime (taddr
);
1787 len
= emacs_nmemftime (buf
, size
, format
, formatlen
, tm
, ut
, ns
);
1788 if ((0 < len
&& len
< size
) || (len
== 0 && buf
[0] == '\0'))
1791 /* Buffer was too small, so make it bigger and try again. */
1792 len
= emacs_nmemftime (NULL
, SIZE_MAX
, format
, formatlen
, tm
, ut
, ns
);
1794 if (STRING_BYTES_BOUND
<= len
)
1797 buf
= SAFE_ALLOCA (size
);
1801 bufstring
= make_unibyte_string (buf
, len
);
1803 return code_convert_string_norecord (bufstring
, Vlocale_coding_system
, 0);
1806 DEFUN ("decode-time", Fdecode_time
, Sdecode_time
, 0, 1, 0,
1807 doc
: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST ZONE).
1808 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED),
1809 as from `current-time' and `file-attributes', or nil to use the
1810 current time. The obsolete form (HIGH . LOW) is also still accepted.
1811 The list has the following nine members: SEC is an integer between 0
1812 and 60; SEC is 60 for a leap second, which only some operating systems
1813 support. MINUTE is an integer between 0 and 59. HOUR is an integer
1814 between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
1815 integer between 1 and 12. YEAR is an integer indicating the
1816 four-digit year. DOW is the day of week, an integer between 0 and 6,
1817 where 0 is Sunday. DST is t if daylight saving time is in effect,
1818 otherwise nil. ZONE is an integer indicating the number of seconds
1819 east of Greenwich. (Note that Common Lisp has different meanings for
1821 (Lisp_Object specified_time
)
1823 time_t time_spec
= lisp_seconds_argument (specified_time
);
1825 struct tm
*decoded_time
;
1826 Lisp_Object list_args
[9];
1829 decoded_time
= localtime (&time_spec
);
1831 save_tm
= *decoded_time
;
1834 && MOST_NEGATIVE_FIXNUM
- TM_YEAR_BASE
<= save_tm
.tm_year
1835 && save_tm
.tm_year
<= MOST_POSITIVE_FIXNUM
- TM_YEAR_BASE
))
1837 XSETFASTINT (list_args
[0], save_tm
.tm_sec
);
1838 XSETFASTINT (list_args
[1], save_tm
.tm_min
);
1839 XSETFASTINT (list_args
[2], save_tm
.tm_hour
);
1840 XSETFASTINT (list_args
[3], save_tm
.tm_mday
);
1841 XSETFASTINT (list_args
[4], save_tm
.tm_mon
+ 1);
1842 /* On 64-bit machines an int is narrower than EMACS_INT, thus the
1843 cast below avoids overflow in int arithmetics. */
1844 XSETINT (list_args
[5], TM_YEAR_BASE
+ (EMACS_INT
) save_tm
.tm_year
);
1845 XSETFASTINT (list_args
[6], save_tm
.tm_wday
);
1846 list_args
[7] = save_tm
.tm_isdst
? Qt
: Qnil
;
1849 decoded_time
= gmtime (&time_spec
);
1850 if (decoded_time
== 0)
1851 list_args
[8] = Qnil
;
1853 XSETINT (list_args
[8], tm_diff (&save_tm
, decoded_time
));
1855 return Flist (9, list_args
);
1858 /* Return OBJ - OFFSET, checking that OBJ is a valid fixnum and that
1859 the result is representable as an int. Assume OFFSET is small and
1862 check_tm_member (Lisp_Object obj
, int offset
)
1867 if (! (INT_MIN
+ offset
<= n
&& n
- offset
<= INT_MAX
))
1872 DEFUN ("encode-time", Fencode_time
, Sencode_time
, 6, MANY
, 0,
1873 doc
: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
1874 This is the reverse operation of `decode-time', which see.
1875 ZONE defaults to the current time zone rule. This can
1876 be a string or t (as from `set-time-zone-rule'), or it can be a list
1877 \(as from `current-time-zone') or an integer (as from `decode-time')
1878 applied without consideration for daylight saving time.
1880 You can pass more than 7 arguments; then the first six arguments
1881 are used as SECOND through YEAR, and the *last* argument is used as ZONE.
1882 The intervening arguments are ignored.
1883 This feature lets (apply 'encode-time (decode-time ...)) work.
1885 Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed;
1886 for example, a DAY of 0 means the day preceding the given month.
1887 Year numbers less than 100 are treated just like other year numbers.
1888 If you want them to stand for years in this century, you must do that yourself.
1890 Years before 1970 are not guaranteed to work. On some systems,
1891 year values as low as 1901 do work.
1893 usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
1894 (ptrdiff_t nargs
, Lisp_Object
*args
)
1898 Lisp_Object zone
= (nargs
> 6 ? args
[nargs
- 1] : Qnil
);
1900 tm
.tm_sec
= check_tm_member (args
[0], 0);
1901 tm
.tm_min
= check_tm_member (args
[1], 0);
1902 tm
.tm_hour
= check_tm_member (args
[2], 0);
1903 tm
.tm_mday
= check_tm_member (args
[3], 0);
1904 tm
.tm_mon
= check_tm_member (args
[4], 1);
1905 tm
.tm_year
= check_tm_member (args
[5], TM_YEAR_BASE
);
1913 value
= mktime (&tm
);
1918 static char const tzbuf_format
[] = "XXX%s%"pI
"d:%02d:%02d";
1919 char tzbuf
[sizeof tzbuf_format
+ INT_STRLEN_BOUND (EMACS_INT
)];
1921 const char *tzstring
;
1926 else if (STRINGP (zone
))
1927 tzstring
= SSDATA (zone
);
1928 else if (INTEGERP (zone
))
1930 EMACS_INT abszone
= eabs (XINT (zone
));
1931 EMACS_INT zone_hr
= abszone
/ (60*60);
1932 int zone_min
= (abszone
/60) % 60;
1933 int zone_sec
= abszone
% 60;
1934 sprintf (tzbuf
, tzbuf_format
, &"-"[XINT (zone
) < 0],
1935 zone_hr
, zone_min
, zone_sec
);
1939 error ("Invalid time zone specification");
1941 old_tzstring
= getenv ("TZ");
1944 char *buf
= SAFE_ALLOCA (strlen (old_tzstring
) + 1);
1945 old_tzstring
= strcpy (buf
, old_tzstring
);
1950 /* Set TZ before calling mktime; merely adjusting mktime's returned
1951 value doesn't suffice, since that would mishandle leap seconds. */
1952 set_time_zone_rule (tzstring
);
1954 value
= mktime (&tm
);
1956 set_time_zone_rule (old_tzstring
);
1957 #ifdef LOCALTIME_CACHE
1964 if (value
== (time_t) -1)
1967 return make_time (value
);
1970 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
1971 doc
: /* Return the current local time, as a human-readable string.
1972 Programs can use this function to decode a time,
1973 since the number of columns in each field is fixed
1974 if the year is in the range 1000-9999.
1975 The format is `Sun Sep 16 01:03:52 1973'.
1976 However, see also the functions `decode-time' and `format-time-string'
1977 which provide a much more powerful and general facility.
1979 If SPECIFIED-TIME is given, it is a time to format instead of the
1980 current time. The argument should have the form (HIGH LOW . IGNORED).
1981 Thus, you can use times obtained from `current-time' and from
1982 `file-attributes'. SPECIFIED-TIME can also have the form (HIGH . LOW),
1983 but this is considered obsolete. */)
1984 (Lisp_Object specified_time
)
1986 time_t value
= lisp_seconds_argument (specified_time
);
1988 char buf
[sizeof "Mon Apr 30 12:49:17 " + INT_STRLEN_BOUND (int) + 1];
1989 int len
IF_LINT (= 0);
1991 /* Convert to a string in ctime format, except without the trailing
1992 newline, and without the 4-digit year limit. Don't use asctime
1993 or ctime, as they might dump core if the year is outside the
1994 range -999 .. 9999. */
1996 tm
= localtime (&value
);
1999 static char const wday_name
[][4] =
2000 { "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat" };
2001 static char const mon_name
[][4] =
2002 { "Jan", "Feb", "Mar", "Apr", "May", "Jun",
2003 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" };
2004 printmax_t year_base
= TM_YEAR_BASE
;
2006 len
= sprintf (buf
, "%s %s%3d %02d:%02d:%02d %"pMd
,
2007 wday_name
[tm
->tm_wday
], mon_name
[tm
->tm_mon
], tm
->tm_mday
,
2008 tm
->tm_hour
, tm
->tm_min
, tm
->tm_sec
,
2009 tm
->tm_year
+ year_base
);
2015 return make_unibyte_string (buf
, len
);
2018 /* Yield A - B, measured in seconds.
2019 This function is copied from the GNU C Library. */
2021 tm_diff (struct tm
*a
, struct tm
*b
)
2023 /* Compute intervening leap days correctly even if year is negative.
2024 Take care to avoid int overflow in leap day calculations,
2025 but it's OK to assume that A and B are close to each other. */
2026 int a4
= (a
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (a
->tm_year
& 3);
2027 int b4
= (b
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (b
->tm_year
& 3);
2028 int a100
= a4
/ 25 - (a4
% 25 < 0);
2029 int b100
= b4
/ 25 - (b4
% 25 < 0);
2030 int a400
= a100
>> 2;
2031 int b400
= b100
>> 2;
2032 int intervening_leap_days
= (a4
- b4
) - (a100
- b100
) + (a400
- b400
);
2033 int years
= a
->tm_year
- b
->tm_year
;
2034 int days
= (365 * years
+ intervening_leap_days
2035 + (a
->tm_yday
- b
->tm_yday
));
2036 return (60 * (60 * (24 * days
+ (a
->tm_hour
- b
->tm_hour
))
2037 + (a
->tm_min
- b
->tm_min
))
2038 + (a
->tm_sec
- b
->tm_sec
));
2041 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
2042 doc
: /* Return the offset and name for the local time zone.
2043 This returns a list of the form (OFFSET NAME).
2044 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
2045 A negative value means west of Greenwich.
2046 NAME is a string giving the name of the time zone.
2047 If SPECIFIED-TIME is given, the time zone offset is determined from it
2048 instead of using the current time. The argument should have the form
2049 (HIGH LOW . IGNORED). Thus, you can use times obtained from
2050 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
2051 have the form (HIGH . LOW), but this is considered obsolete.
2053 Some operating systems cannot provide all this information to Emacs;
2054 in this case, `current-time-zone' returns a list containing nil for
2055 the data it can't find. */)
2056 (Lisp_Object specified_time
)
2058 struct timespec value
;
2062 Lisp_Object zone_offset
, zone_name
;
2065 value
= make_timespec (lisp_seconds_argument (specified_time
), 0);
2066 zone_name
= format_time_string ("%Z", sizeof "%Z" - 1, value
, 0, &localtm
);
2068 t
= gmtime (&value
.tv_sec
);
2070 offset
= tm_diff (&localtm
, t
);
2075 zone_offset
= make_number (offset
);
2076 if (SCHARS (zone_name
) == 0)
2078 /* No local time zone name is available; use "+-NNNN" instead. */
2079 int m
= offset
/ 60;
2080 int am
= offset
< 0 ? - m
: m
;
2081 char buf
[sizeof "+00" + INT_STRLEN_BOUND (int)];
2082 zone_name
= make_formatted_string (buf
, "%c%02d%02d",
2083 (offset
< 0 ? '-' : '+'),
2088 return list2 (zone_offset
, zone_name
);
2091 DEFUN ("set-time-zone-rule", Fset_time_zone_rule
, Sset_time_zone_rule
, 1, 1, 0,
2092 doc
: /* Set the local time zone using TZ, a string specifying a time zone rule.
2093 If TZ is nil, use implementation-defined default time zone information.
2094 If TZ is t, use Universal Time.
2096 Instead of calling this function, you typically want (setenv "TZ" TZ).
2097 That changes both the environment of the Emacs process and the
2098 variable `process-environment', whereas `set-time-zone-rule' affects
2099 only the former. */)
2102 const char *tzstring
;
2104 if (! (NILP (tz
) || EQ (tz
, Qt
)))
2108 tzstring
= initial_tz
;
2109 else if (EQ (tz
, Qt
))
2112 tzstring
= SSDATA (tz
);
2115 set_time_zone_rule (tzstring
);
2121 /* Set the local time zone rule to TZSTRING.
2123 This function is not thread-safe, partly because putenv, unsetenv
2124 and tzset are not, and partly because of the static storage it
2125 updates. Other threads that invoke localtime etc. may be adversely
2126 affected while this function is executing. */
2129 set_time_zone_rule (const char *tzstring
)
2131 /* A buffer holding a string of the form "TZ=value", intended
2132 to be part of the environment. */
2133 static char *tzvalbuf
;
2134 static ptrdiff_t tzvalbufsize
;
2136 int tzeqlen
= sizeof "TZ=" - 1;
2138 #ifdef LOCALTIME_CACHE
2139 /* These two values are known to load tz files in buggy implementations,
2140 i.e., Solaris 1 executables running under either Solaris 1 or Solaris 2.
2141 Their values shouldn't matter in non-buggy implementations.
2142 We don't use string literals for these strings,
2143 since if a string in the environment is in readonly
2144 storage, it runs afoul of bugs in SVR4 and Solaris 2.3.
2145 See Sun bugs 1113095 and 1114114, ``Timezone routines
2146 improperly modify environment''. */
2148 static char set_time_zone_rule_tz
[][sizeof "TZ=GMT+0"]
2149 = { "TZ=GMT+0", "TZ=GMT+1" };
2151 /* In SunOS 4.1.3_U1 and 4.1.4, if TZ has a value like
2152 "US/Pacific" that loads a tz file, then changes to a value like
2153 "XXX0" that does not load a tz file, and then changes back to
2154 its original value, the last change is (incorrectly) ignored.
2155 Also, if TZ changes twice in succession to values that do
2156 not load a tz file, tzset can dump core (see Sun bug#1225179).
2157 The following code works around these bugs. */
2161 /* Temporarily set TZ to a value that loads a tz file
2162 and that differs from tzstring. */
2163 bool eq0
= strcmp (tzstring
, set_time_zone_rule_tz
[0] + tzeqlen
) == 0;
2164 xputenv (set_time_zone_rule_tz
[eq0
]);
2168 /* The implied tzstring is unknown, so temporarily set TZ to
2169 two different values that each load a tz file. */
2170 xputenv (set_time_zone_rule_tz
[0]);
2172 xputenv (set_time_zone_rule_tz
[1]);
2175 tzvalbuf_in_environ
= 0;
2181 tzvalbuf_in_environ
= 0;
2185 ptrdiff_t tzstringlen
= strlen (tzstring
);
2187 if (tzvalbufsize
<= tzeqlen
+ tzstringlen
)
2190 tzvalbuf_in_environ
= 0;
2191 tzvalbuf
= xpalloc (tzvalbuf
, &tzvalbufsize
,
2192 tzeqlen
+ tzstringlen
- tzvalbufsize
+ 1, -1, 1);
2193 memcpy (tzvalbuf
, "TZ=", tzeqlen
);
2196 strcpy (tzvalbuf
+ tzeqlen
, tzstring
);
2198 if (!tzvalbuf_in_environ
)
2201 tzvalbuf_in_environ
= 1;
2205 #ifdef LOCALTIME_CACHE
2210 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
2211 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
2212 type of object is Lisp_String). INHERIT is passed to
2213 INSERT_FROM_STRING_FUNC as the last argument. */
2216 general_insert_function (void (*insert_func
)
2217 (const char *, ptrdiff_t),
2218 void (*insert_from_string_func
)
2219 (Lisp_Object
, ptrdiff_t, ptrdiff_t,
2220 ptrdiff_t, ptrdiff_t, bool),
2221 bool inherit
, ptrdiff_t nargs
, Lisp_Object
*args
)
2226 for (argnum
= 0; argnum
< nargs
; argnum
++)
2229 if (CHARACTERP (val
))
2231 int c
= XFASTINT (val
);
2232 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2235 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2236 len
= CHAR_STRING (c
, str
);
2239 str
[0] = ASCII_CHAR_P (c
) ? c
: multibyte_char_to_unibyte (c
);
2242 (*insert_func
) ((char *) str
, len
);
2244 else if (STRINGP (val
))
2246 (*insert_from_string_func
) (val
, 0, 0,
2252 wrong_type_argument (Qchar_or_string_p
, val
);
2257 insert1 (Lisp_Object arg
)
2263 /* Callers passing one argument to Finsert need not gcpro the
2264 argument "array", since the only element of the array will
2265 not be used after calling insert or insert_from_string, so
2266 we don't care if it gets trashed. */
2268 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
2269 doc
: /* Insert the arguments, either strings or characters, at point.
2270 Point and before-insertion markers move forward to end up
2271 after the inserted text.
2272 Any other markers at the point of insertion remain before the text.
2274 If the current buffer is multibyte, unibyte strings are converted
2275 to multibyte for insertion (see `string-make-multibyte').
2276 If the current buffer is unibyte, multibyte strings are converted
2277 to unibyte for insertion (see `string-make-unibyte').
2279 When operating on binary data, it may be necessary to preserve the
2280 original bytes of a unibyte string when inserting it into a multibyte
2281 buffer; to accomplish this, apply `string-as-multibyte' to the string
2282 and insert the result.
2284 usage: (insert &rest ARGS) */)
2285 (ptrdiff_t nargs
, Lisp_Object
*args
)
2287 general_insert_function (insert
, insert_from_string
, 0, nargs
, args
);
2291 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
2293 doc
: /* Insert the arguments at point, inheriting properties from adjoining text.
2294 Point and before-insertion markers move forward to end up
2295 after the inserted text.
2296 Any other markers at the point of insertion remain before the text.
2298 If the current buffer is multibyte, unibyte strings are converted
2299 to multibyte for insertion (see `unibyte-char-to-multibyte').
2300 If the current buffer is unibyte, multibyte strings are converted
2301 to unibyte for insertion.
2303 usage: (insert-and-inherit &rest ARGS) */)
2304 (ptrdiff_t nargs
, Lisp_Object
*args
)
2306 general_insert_function (insert_and_inherit
, insert_from_string
, 1,
2311 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
2312 doc
: /* Insert strings or characters at point, relocating markers after the text.
2313 Point and markers move forward to end up after the inserted text.
2315 If the current buffer is multibyte, unibyte strings are converted
2316 to multibyte for insertion (see `unibyte-char-to-multibyte').
2317 If the current buffer is unibyte, multibyte strings are converted
2318 to unibyte for insertion.
2320 If an overlay begins at the insertion point, the inserted text falls
2321 outside the overlay; if a nonempty overlay ends at the insertion
2322 point, the inserted text falls inside that overlay.
2324 usage: (insert-before-markers &rest ARGS) */)
2325 (ptrdiff_t nargs
, Lisp_Object
*args
)
2327 general_insert_function (insert_before_markers
,
2328 insert_from_string_before_markers
, 0,
2333 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers
,
2334 Sinsert_and_inherit_before_markers
, 0, MANY
, 0,
2335 doc
: /* Insert text at point, relocating markers and inheriting properties.
2336 Point and markers move forward to end up after the inserted text.
2338 If the current buffer is multibyte, unibyte strings are converted
2339 to multibyte for insertion (see `unibyte-char-to-multibyte').
2340 If the current buffer is unibyte, multibyte strings are converted
2341 to unibyte for insertion.
2343 usage: (insert-before-markers-and-inherit &rest ARGS) */)
2344 (ptrdiff_t nargs
, Lisp_Object
*args
)
2346 general_insert_function (insert_before_markers_and_inherit
,
2347 insert_from_string_before_markers
, 1,
2352 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 1, 3,
2353 "(list (read-char-by-name \"Insert character (Unicode name or hex): \")\
2354 (prefix-numeric-value current-prefix-arg)\
2356 doc
: /* Insert COUNT copies of CHARACTER.
2357 Interactively, prompt for CHARACTER. You can specify CHARACTER in one
2360 - As its Unicode character name, e.g. \"LATIN SMALL LETTER A\".
2361 Completion is available; if you type a substring of the name
2362 preceded by an asterisk `*', Emacs shows all names which include
2363 that substring, not necessarily at the beginning of the name.
2365 - As a hexadecimal code point, e.g. 263A. Note that code points in
2366 Emacs are equivalent to Unicode up to 10FFFF (which is the limit of
2367 the Unicode code space).
2369 - As a code point with a radix specified with #, e.g. #o21430
2370 (octal), #x2318 (hex), or #10r8984 (decimal).
2372 If called interactively, COUNT is given by the prefix argument. If
2373 omitted or nil, it defaults to 1.
2375 Inserting the character(s) relocates point and before-insertion
2376 markers in the same ways as the function `insert'.
2378 The optional third argument INHERIT, if non-nil, says to inherit text
2379 properties from adjoining text, if those properties are sticky. If
2380 called interactively, INHERIT is t. */)
2381 (Lisp_Object character
, Lisp_Object count
, Lisp_Object inherit
)
2384 register ptrdiff_t n
;
2386 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2389 CHECK_CHARACTER (character
);
2391 XSETFASTINT (count
, 1);
2392 CHECK_NUMBER (count
);
2393 c
= XFASTINT (character
);
2395 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2396 len
= CHAR_STRING (c
, str
);
2398 str
[0] = c
, len
= 1;
2399 if (XINT (count
) <= 0)
2401 if (BUF_BYTES_MAX
/ len
< XINT (count
))
2403 n
= XINT (count
) * len
;
2404 stringlen
= min (n
, sizeof string
- sizeof string
% len
);
2405 for (i
= 0; i
< stringlen
; i
++)
2406 string
[i
] = str
[i
% len
];
2407 while (n
> stringlen
)
2410 if (!NILP (inherit
))
2411 insert_and_inherit (string
, stringlen
);
2413 insert (string
, stringlen
);
2416 if (!NILP (inherit
))
2417 insert_and_inherit (string
, n
);
2423 DEFUN ("insert-byte", Finsert_byte
, Sinsert_byte
, 2, 3, 0,
2424 doc
: /* Insert COUNT (second arg) copies of BYTE (first arg).
2425 Both arguments are required.
2426 BYTE is a number of the range 0..255.
2428 If BYTE is 128..255 and the current buffer is multibyte, the
2429 corresponding eight-bit character is inserted.
2431 Point, and before-insertion markers, are relocated as in the function `insert'.
2432 The optional third arg INHERIT, if non-nil, says to inherit text properties
2433 from adjoining text, if those properties are sticky. */)
2434 (Lisp_Object byte
, Lisp_Object count
, Lisp_Object inherit
)
2436 CHECK_NUMBER (byte
);
2437 if (XINT (byte
) < 0 || XINT (byte
) > 255)
2438 args_out_of_range_3 (byte
, make_number (0), make_number (255));
2439 if (XINT (byte
) >= 128
2440 && ! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2441 XSETFASTINT (byte
, BYTE8_TO_CHAR (XINT (byte
)));
2442 return Finsert_char (byte
, count
, inherit
);
2446 /* Making strings from buffer contents. */
2448 /* Return a Lisp_String containing the text of the current buffer from
2449 START to END. If text properties are in use and the current buffer
2450 has properties in the range specified, the resulting string will also
2451 have them, if PROPS is true.
2453 We don't want to use plain old make_string here, because it calls
2454 make_uninit_string, which can cause the buffer arena to be
2455 compacted. make_string has no way of knowing that the data has
2456 been moved, and thus copies the wrong data into the string. This
2457 doesn't effect most of the other users of make_string, so it should
2458 be left as is. But we should use this function when conjuring
2459 buffer substrings. */
2462 make_buffer_string (ptrdiff_t start
, ptrdiff_t end
, bool props
)
2464 ptrdiff_t start_byte
= CHAR_TO_BYTE (start
);
2465 ptrdiff_t end_byte
= CHAR_TO_BYTE (end
);
2467 return make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
);
2470 /* Return a Lisp_String containing the text of the current buffer from
2471 START / START_BYTE to END / END_BYTE.
2473 If text properties are in use and the current buffer
2474 has properties in the range specified, the resulting string will also
2475 have them, if PROPS is true.
2477 We don't want to use plain old make_string here, because it calls
2478 make_uninit_string, which can cause the buffer arena to be
2479 compacted. make_string has no way of knowing that the data has
2480 been moved, and thus copies the wrong data into the string. This
2481 doesn't effect most of the other users of make_string, so it should
2482 be left as is. But we should use this function when conjuring
2483 buffer substrings. */
2486 make_buffer_string_both (ptrdiff_t start
, ptrdiff_t start_byte
,
2487 ptrdiff_t end
, ptrdiff_t end_byte
, bool props
)
2489 Lisp_Object result
, tem
, tem1
;
2491 if (start
< GPT
&& GPT
< end
)
2492 move_gap_both (start
, start_byte
);
2494 if (! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2495 result
= make_uninit_multibyte_string (end
- start
, end_byte
- start_byte
);
2497 result
= make_uninit_string (end
- start
);
2498 memcpy (SDATA (result
), BYTE_POS_ADDR (start_byte
), end_byte
- start_byte
);
2500 /* If desired, update and copy the text properties. */
2503 update_buffer_properties (start
, end
);
2505 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
2506 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
2508 if (XINT (tem
) != end
|| !NILP (tem1
))
2509 copy_intervals_to_string (result
, current_buffer
, start
,
2516 /* Call Vbuffer_access_fontify_functions for the range START ... END
2517 in the current buffer, if necessary. */
2520 update_buffer_properties (ptrdiff_t start
, ptrdiff_t end
)
2522 /* If this buffer has some access functions,
2523 call them, specifying the range of the buffer being accessed. */
2524 if (!NILP (Vbuffer_access_fontify_functions
))
2526 Lisp_Object args
[3];
2529 args
[0] = Qbuffer_access_fontify_functions
;
2530 XSETINT (args
[1], start
);
2531 XSETINT (args
[2], end
);
2533 /* But don't call them if we can tell that the work
2534 has already been done. */
2535 if (!NILP (Vbuffer_access_fontified_property
))
2537 tem
= Ftext_property_any (args
[1], args
[2],
2538 Vbuffer_access_fontified_property
,
2541 Frun_hook_with_args (3, args
);
2544 Frun_hook_with_args (3, args
);
2548 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
2549 doc
: /* Return the contents of part of the current buffer as a string.
2550 The two arguments START and END are character positions;
2551 they can be in either order.
2552 The string returned is multibyte if the buffer is multibyte.
2554 This function copies the text properties of that part of the buffer
2555 into the result string; if you don't want the text properties,
2556 use `buffer-substring-no-properties' instead. */)
2557 (Lisp_Object start
, Lisp_Object end
)
2559 register ptrdiff_t b
, e
;
2561 validate_region (&start
, &end
);
2565 return make_buffer_string (b
, e
, 1);
2568 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties
,
2569 Sbuffer_substring_no_properties
, 2, 2, 0,
2570 doc
: /* Return the characters of part of the buffer, without the text properties.
2571 The two arguments START and END are character positions;
2572 they can be in either order. */)
2573 (Lisp_Object start
, Lisp_Object end
)
2575 register ptrdiff_t b
, e
;
2577 validate_region (&start
, &end
);
2581 return make_buffer_string (b
, e
, 0);
2584 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
2585 doc
: /* Return the contents of the current buffer as a string.
2586 If narrowing is in effect, this function returns only the visible part
2590 return make_buffer_string_both (BEGV
, BEGV_BYTE
, ZV
, ZV_BYTE
, 1);
2593 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
2595 doc
: /* Insert before point a substring of the contents of BUFFER.
2596 BUFFER may be a buffer or a buffer name.
2597 Arguments START and END are character positions specifying the substring.
2598 They default to the values of (point-min) and (point-max) in BUFFER. */)
2599 (Lisp_Object buffer
, Lisp_Object start
, Lisp_Object end
)
2601 register EMACS_INT b
, e
, temp
;
2602 register struct buffer
*bp
, *obuf
;
2605 buf
= Fget_buffer (buffer
);
2609 if (!BUFFER_LIVE_P (bp
))
2610 error ("Selecting deleted buffer");
2616 CHECK_NUMBER_COERCE_MARKER (start
);
2623 CHECK_NUMBER_COERCE_MARKER (end
);
2628 temp
= b
, b
= e
, e
= temp
;
2630 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
2631 args_out_of_range (start
, end
);
2633 obuf
= current_buffer
;
2634 set_buffer_internal_1 (bp
);
2635 update_buffer_properties (b
, e
);
2636 set_buffer_internal_1 (obuf
);
2638 insert_from_buffer (bp
, b
, e
- b
, 0);
2642 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
2644 doc
: /* Compare two substrings of two buffers; return result as number.
2645 Return -N if first string is less after N-1 chars, +N if first string is
2646 greater after N-1 chars, or 0 if strings match. Each substring is
2647 represented as three arguments: BUFFER, START and END. That makes six
2648 args in all, three for each substring.
2650 The value of `case-fold-search' in the current buffer
2651 determines whether case is significant or ignored. */)
2652 (Lisp_Object buffer1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object buffer2
, Lisp_Object start2
, Lisp_Object end2
)
2654 register EMACS_INT begp1
, endp1
, begp2
, endp2
, temp
;
2655 register struct buffer
*bp1
, *bp2
;
2656 register Lisp_Object trt
2657 = (!NILP (BVAR (current_buffer
, case_fold_search
))
2658 ? BVAR (current_buffer
, case_canon_table
) : Qnil
);
2659 ptrdiff_t chars
= 0;
2660 ptrdiff_t i1
, i2
, i1_byte
, i2_byte
;
2662 /* Find the first buffer and its substring. */
2665 bp1
= current_buffer
;
2669 buf1
= Fget_buffer (buffer1
);
2672 bp1
= XBUFFER (buf1
);
2673 if (!BUFFER_LIVE_P (bp1
))
2674 error ("Selecting deleted buffer");
2678 begp1
= BUF_BEGV (bp1
);
2681 CHECK_NUMBER_COERCE_MARKER (start1
);
2682 begp1
= XINT (start1
);
2685 endp1
= BUF_ZV (bp1
);
2688 CHECK_NUMBER_COERCE_MARKER (end1
);
2689 endp1
= XINT (end1
);
2693 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
2695 if (!(BUF_BEGV (bp1
) <= begp1
2697 && endp1
<= BUF_ZV (bp1
)))
2698 args_out_of_range (start1
, end1
);
2700 /* Likewise for second substring. */
2703 bp2
= current_buffer
;
2707 buf2
= Fget_buffer (buffer2
);
2710 bp2
= XBUFFER (buf2
);
2711 if (!BUFFER_LIVE_P (bp2
))
2712 error ("Selecting deleted buffer");
2716 begp2
= BUF_BEGV (bp2
);
2719 CHECK_NUMBER_COERCE_MARKER (start2
);
2720 begp2
= XINT (start2
);
2723 endp2
= BUF_ZV (bp2
);
2726 CHECK_NUMBER_COERCE_MARKER (end2
);
2727 endp2
= XINT (end2
);
2731 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
2733 if (!(BUF_BEGV (bp2
) <= begp2
2735 && endp2
<= BUF_ZV (bp2
)))
2736 args_out_of_range (start2
, end2
);
2740 i1_byte
= buf_charpos_to_bytepos (bp1
, i1
);
2741 i2_byte
= buf_charpos_to_bytepos (bp2
, i2
);
2743 while (i1
< endp1
&& i2
< endp2
)
2745 /* When we find a mismatch, we must compare the
2746 characters, not just the bytes. */
2751 if (! NILP (BVAR (bp1
, enable_multibyte_characters
)))
2753 c1
= BUF_FETCH_MULTIBYTE_CHAR (bp1
, i1_byte
);
2754 BUF_INC_POS (bp1
, i1_byte
);
2759 c1
= BUF_FETCH_BYTE (bp1
, i1
);
2760 MAKE_CHAR_MULTIBYTE (c1
);
2764 if (! NILP (BVAR (bp2
, enable_multibyte_characters
)))
2766 c2
= BUF_FETCH_MULTIBYTE_CHAR (bp2
, i2_byte
);
2767 BUF_INC_POS (bp2
, i2_byte
);
2772 c2
= BUF_FETCH_BYTE (bp2
, i2
);
2773 MAKE_CHAR_MULTIBYTE (c2
);
2779 c1
= char_table_translate (trt
, c1
);
2780 c2
= char_table_translate (trt
, c2
);
2783 return make_number (- 1 - chars
);
2785 return make_number (chars
+ 1);
2790 /* The strings match as far as they go.
2791 If one is shorter, that one is less. */
2792 if (chars
< endp1
- begp1
)
2793 return make_number (chars
+ 1);
2794 else if (chars
< endp2
- begp2
)
2795 return make_number (- chars
- 1);
2797 /* Same length too => they are equal. */
2798 return make_number (0);
2802 subst_char_in_region_unwind (Lisp_Object arg
)
2804 bset_undo_list (current_buffer
, arg
);
2808 subst_char_in_region_unwind_1 (Lisp_Object arg
)
2810 bset_filename (current_buffer
, arg
);
2813 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
2814 Ssubst_char_in_region
, 4, 5, 0,
2815 doc
: /* From START to END, replace FROMCHAR with TOCHAR each time it occurs.
2816 If optional arg NOUNDO is non-nil, don't record this change for undo
2817 and don't mark the buffer as really changed.
2818 Both characters must have the same length of multi-byte form. */)
2819 (Lisp_Object start
, Lisp_Object end
, Lisp_Object fromchar
, Lisp_Object tochar
, Lisp_Object noundo
)
2821 register ptrdiff_t pos
, pos_byte
, stop
, i
, len
, end_byte
;
2822 /* Keep track of the first change in the buffer:
2823 if 0 we haven't found it yet.
2824 if < 0 we've found it and we've run the before-change-function.
2825 if > 0 we've actually performed it and the value is its position. */
2826 ptrdiff_t changed
= 0;
2827 unsigned char fromstr
[MAX_MULTIBYTE_LENGTH
], tostr
[MAX_MULTIBYTE_LENGTH
];
2829 ptrdiff_t count
= SPECPDL_INDEX ();
2830 #define COMBINING_NO 0
2831 #define COMBINING_BEFORE 1
2832 #define COMBINING_AFTER 2
2833 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
2834 int maybe_byte_combining
= COMBINING_NO
;
2835 ptrdiff_t last_changed
= 0;
2837 = !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
2842 validate_region (&start
, &end
);
2843 CHECK_CHARACTER (fromchar
);
2844 CHECK_CHARACTER (tochar
);
2845 fromc
= XFASTINT (fromchar
);
2846 toc
= XFASTINT (tochar
);
2850 len
= CHAR_STRING (fromc
, fromstr
);
2851 if (CHAR_STRING (toc
, tostr
) != len
)
2852 error ("Characters in `subst-char-in-region' have different byte-lengths");
2853 if (!ASCII_BYTE_P (*tostr
))
2855 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
2856 complete multibyte character, it may be combined with the
2857 after bytes. If it is in the range 0xA0..0xFF, it may be
2858 combined with the before and after bytes. */
2859 if (!CHAR_HEAD_P (*tostr
))
2860 maybe_byte_combining
= COMBINING_BOTH
;
2861 else if (BYTES_BY_CHAR_HEAD (*tostr
) > len
)
2862 maybe_byte_combining
= COMBINING_AFTER
;
2873 pos_byte
= CHAR_TO_BYTE (pos
);
2874 stop
= CHAR_TO_BYTE (XINT (end
));
2877 /* If we don't want undo, turn off putting stuff on the list.
2878 That's faster than getting rid of things,
2879 and it prevents even the entry for a first change.
2880 Also inhibit locking the file. */
2881 if (!changed
&& !NILP (noundo
))
2883 record_unwind_protect (subst_char_in_region_unwind
,
2884 BVAR (current_buffer
, undo_list
));
2885 bset_undo_list (current_buffer
, Qt
);
2886 /* Don't do file-locking. */
2887 record_unwind_protect (subst_char_in_region_unwind_1
,
2888 BVAR (current_buffer
, filename
));
2889 bset_filename (current_buffer
, Qnil
);
2892 if (pos_byte
< GPT_BYTE
)
2893 stop
= min (stop
, GPT_BYTE
);
2896 ptrdiff_t pos_byte_next
= pos_byte
;
2898 if (pos_byte
>= stop
)
2900 if (pos_byte
>= end_byte
) break;
2903 p
= BYTE_POS_ADDR (pos_byte
);
2905 INC_POS (pos_byte_next
);
2908 if (pos_byte_next
- pos_byte
== len
2909 && p
[0] == fromstr
[0]
2911 || (p
[1] == fromstr
[1]
2912 && (len
== 2 || (p
[2] == fromstr
[2]
2913 && (len
== 3 || p
[3] == fromstr
[3]))))))
2916 /* We've already seen this and run the before-change-function;
2917 this time we only need to record the actual position. */
2922 modify_text (pos
, XINT (end
));
2924 if (! NILP (noundo
))
2926 if (MODIFF
- 1 == SAVE_MODIFF
)
2928 if (MODIFF
- 1 == BUF_AUTOSAVE_MODIFF (current_buffer
))
2929 BUF_AUTOSAVE_MODIFF (current_buffer
)++;
2932 /* The before-change-function may have moved the gap
2933 or even modified the buffer so we should start over. */
2937 /* Take care of the case where the new character
2938 combines with neighboring bytes. */
2939 if (maybe_byte_combining
2940 && (maybe_byte_combining
== COMBINING_AFTER
2941 ? (pos_byte_next
< Z_BYTE
2942 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2943 : ((pos_byte_next
< Z_BYTE
2944 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2945 || (pos_byte
> BEG_BYTE
2946 && ! ASCII_BYTE_P (FETCH_BYTE (pos_byte
- 1))))))
2948 Lisp_Object tem
, string
;
2950 struct gcpro gcpro1
;
2952 tem
= BVAR (current_buffer
, undo_list
);
2955 /* Make a multibyte string containing this single character. */
2956 string
= make_multibyte_string ((char *) tostr
, 1, len
);
2957 /* replace_range is less efficient, because it moves the gap,
2958 but it handles combining correctly. */
2959 replace_range (pos
, pos
+ 1, string
,
2961 pos_byte_next
= CHAR_TO_BYTE (pos
);
2962 if (pos_byte_next
> pos_byte
)
2963 /* Before combining happened. We should not increment
2964 POS. So, to cancel the later increment of POS,
2968 INC_POS (pos_byte_next
);
2970 if (! NILP (noundo
))
2971 bset_undo_list (current_buffer
, tem
);
2978 record_change (pos
, 1);
2979 for (i
= 0; i
< len
; i
++) *p
++ = tostr
[i
];
2981 last_changed
= pos
+ 1;
2983 pos_byte
= pos_byte_next
;
2989 signal_after_change (changed
,
2990 last_changed
- changed
, last_changed
- changed
);
2991 update_compositions (changed
, last_changed
, CHECK_ALL
);
2994 unbind_to (count
, Qnil
);
2999 static Lisp_Object
check_translation (ptrdiff_t, ptrdiff_t, ptrdiff_t,
3002 /* Helper function for Ftranslate_region_internal.
3004 Check if a character sequence at POS (POS_BYTE) matches an element
3005 of VAL. VAL is a list (([FROM-CHAR ...] . TO) ...). If a matching
3006 element is found, return it. Otherwise return Qnil. */
3009 check_translation (ptrdiff_t pos
, ptrdiff_t pos_byte
, ptrdiff_t end
,
3012 int buf_size
= 16, buf_used
= 0;
3013 int *buf
= alloca (sizeof (int) * buf_size
);
3015 for (; CONSP (val
); val
= XCDR (val
))
3024 if (! VECTORP (elt
))
3027 if (len
<= end
- pos
)
3029 for (i
= 0; i
< len
; i
++)
3033 unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
3036 if (buf_used
== buf_size
)
3041 newbuf
= alloca (sizeof (int) * buf_size
);
3042 memcpy (newbuf
, buf
, sizeof (int) * buf_used
);
3045 buf
[buf_used
++] = STRING_CHAR_AND_LENGTH (p
, len1
);
3048 if (XINT (AREF (elt
, i
)) != buf
[i
])
3059 DEFUN ("translate-region-internal", Ftranslate_region_internal
,
3060 Stranslate_region_internal
, 3, 3, 0,
3061 doc
: /* Internal use only.
3062 From START to END, translate characters according to TABLE.
3063 TABLE is a string or a char-table; the Nth character in it is the
3064 mapping for the character with code N.
3065 It returns the number of characters changed. */)
3066 (Lisp_Object start
, Lisp_Object end
, register Lisp_Object table
)
3068 register unsigned char *tt
; /* Trans table. */
3069 register int nc
; /* New character. */
3070 int cnt
; /* Number of changes made. */
3071 ptrdiff_t size
; /* Size of translate table. */
3072 ptrdiff_t pos
, pos_byte
, end_pos
;
3073 bool multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3074 bool string_multibyte
IF_LINT (= 0);
3076 validate_region (&start
, &end
);
3077 if (CHAR_TABLE_P (table
))
3079 if (! EQ (XCHAR_TABLE (table
)->purpose
, Qtranslation_table
))
3080 error ("Not a translation table");
3086 CHECK_STRING (table
);
3088 if (! multibyte
&& (SCHARS (table
) < SBYTES (table
)))
3089 table
= string_make_unibyte (table
);
3090 string_multibyte
= SCHARS (table
) < SBYTES (table
);
3091 size
= SBYTES (table
);
3096 pos_byte
= CHAR_TO_BYTE (pos
);
3097 end_pos
= XINT (end
);
3098 modify_text (pos
, end_pos
);
3101 for (; pos
< end_pos
; )
3103 register unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
3104 unsigned char *str
, buf
[MAX_MULTIBYTE_LENGTH
];
3110 oc
= STRING_CHAR_AND_LENGTH (p
, len
);
3117 /* Reload as signal_after_change in last iteration may GC. */
3119 if (string_multibyte
)
3121 str
= tt
+ string_char_to_byte (table
, oc
);
3122 nc
= STRING_CHAR_AND_LENGTH (str
, str_len
);
3127 if (! ASCII_BYTE_P (nc
) && multibyte
)
3129 str_len
= BYTE8_STRING (nc
, buf
);
3142 val
= CHAR_TABLE_REF (table
, oc
);
3143 if (CHARACTERP (val
))
3145 nc
= XFASTINT (val
);
3146 str_len
= CHAR_STRING (nc
, buf
);
3149 else if (VECTORP (val
) || (CONSP (val
)))
3151 /* VAL is [TO_CHAR ...] or (([FROM-CHAR ...] . TO) ...)
3152 where TO is TO-CHAR or [TO-CHAR ...]. */
3157 if (nc
!= oc
&& nc
>= 0)
3159 /* Simple one char to one char translation. */
3164 /* This is less efficient, because it moves the gap,
3165 but it should handle multibyte characters correctly. */
3166 string
= make_multibyte_string ((char *) str
, 1, str_len
);
3167 replace_range (pos
, pos
+ 1, string
, 1, 0, 1);
3172 record_change (pos
, 1);
3173 while (str_len
-- > 0)
3175 signal_after_change (pos
, 1, 1);
3176 update_compositions (pos
, pos
+ 1, CHECK_BORDER
);
3186 val
= check_translation (pos
, pos_byte
, end_pos
, val
);
3193 /* VAL is ([FROM-CHAR ...] . TO). */
3194 len
= ASIZE (XCAR (val
));
3202 string
= Fconcat (1, &val
);
3206 string
= Fmake_string (make_number (1), val
);
3208 replace_range (pos
, pos
+ len
, string
, 1, 0, 1);
3209 pos_byte
+= SBYTES (string
);
3210 pos
+= SCHARS (string
);
3211 cnt
+= SCHARS (string
);
3212 end_pos
+= SCHARS (string
) - len
;
3220 return make_number (cnt
);
3223 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
3224 doc
: /* Delete the text between START and END.
3225 If called interactively, delete the region between point and mark.
3226 This command deletes buffer text without modifying the kill ring. */)
3227 (Lisp_Object start
, Lisp_Object end
)
3229 validate_region (&start
, &end
);
3230 del_range (XINT (start
), XINT (end
));
3234 DEFUN ("delete-and-extract-region", Fdelete_and_extract_region
,
3235 Sdelete_and_extract_region
, 2, 2, 0,
3236 doc
: /* Delete the text between START and END and return it. */)
3237 (Lisp_Object start
, Lisp_Object end
)
3239 validate_region (&start
, &end
);
3240 if (XINT (start
) == XINT (end
))
3241 return empty_unibyte_string
;
3242 return del_range_1 (XINT (start
), XINT (end
), 1, 1);
3245 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
3246 doc
: /* Remove restrictions (narrowing) from current buffer.
3247 This allows the buffer's full text to be seen and edited. */)
3250 if (BEG
!= BEGV
|| Z
!= ZV
)
3251 current_buffer
->clip_changed
= 1;
3253 BEGV_BYTE
= BEG_BYTE
;
3254 SET_BUF_ZV_BOTH (current_buffer
, Z
, Z_BYTE
);
3255 /* Changing the buffer bounds invalidates any recorded current column. */
3256 invalidate_current_column ();
3260 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
3261 doc
: /* Restrict editing in this buffer to the current region.
3262 The rest of the text becomes temporarily invisible and untouchable
3263 but is not deleted; if you save the buffer in a file, the invisible
3264 text is included in the file. \\[widen] makes all visible again.
3265 See also `save-restriction'.
3267 When calling from a program, pass two arguments; positions (integers
3268 or markers) bounding the text that should remain visible. */)
3269 (register Lisp_Object start
, Lisp_Object end
)
3271 CHECK_NUMBER_COERCE_MARKER (start
);
3272 CHECK_NUMBER_COERCE_MARKER (end
);
3274 if (XINT (start
) > XINT (end
))
3277 tem
= start
; start
= end
; end
= tem
;
3280 if (!(BEG
<= XINT (start
) && XINT (start
) <= XINT (end
) && XINT (end
) <= Z
))
3281 args_out_of_range (start
, end
);
3283 if (BEGV
!= XFASTINT (start
) || ZV
!= XFASTINT (end
))
3284 current_buffer
->clip_changed
= 1;
3286 SET_BUF_BEGV (current_buffer
, XFASTINT (start
));
3287 SET_BUF_ZV (current_buffer
, XFASTINT (end
));
3288 if (PT
< XFASTINT (start
))
3289 SET_PT (XFASTINT (start
));
3290 if (PT
> XFASTINT (end
))
3291 SET_PT (XFASTINT (end
));
3292 /* Changing the buffer bounds invalidates any recorded current column. */
3293 invalidate_current_column ();
3298 save_restriction_save (void)
3300 if (BEGV
== BEG
&& ZV
== Z
)
3301 /* The common case that the buffer isn't narrowed.
3302 We return just the buffer object, which save_restriction_restore
3303 recognizes as meaning `no restriction'. */
3304 return Fcurrent_buffer ();
3306 /* We have to save a restriction, so return a pair of markers, one
3307 for the beginning and one for the end. */
3309 Lisp_Object beg
, end
;
3311 beg
= build_marker (current_buffer
, BEGV
, BEGV_BYTE
);
3312 end
= build_marker (current_buffer
, ZV
, ZV_BYTE
);
3314 /* END must move forward if text is inserted at its exact location. */
3315 XMARKER (end
)->insertion_type
= 1;
3317 return Fcons (beg
, end
);
3322 save_restriction_restore (Lisp_Object data
)
3324 struct buffer
*cur
= NULL
;
3325 struct buffer
*buf
= (CONSP (data
)
3326 ? XMARKER (XCAR (data
))->buffer
3329 if (buf
&& buf
!= current_buffer
&& !NILP (BVAR (buf
, pt_marker
)))
3330 { /* If `buf' uses markers to keep track of PT, BEGV, and ZV (as
3331 is the case if it is or has an indirect buffer), then make
3332 sure it is current before we update BEGV, so
3333 set_buffer_internal takes care of managing those markers. */
3334 cur
= current_buffer
;
3335 set_buffer_internal (buf
);
3339 /* A pair of marks bounding a saved restriction. */
3341 struct Lisp_Marker
*beg
= XMARKER (XCAR (data
));
3342 struct Lisp_Marker
*end
= XMARKER (XCDR (data
));
3343 eassert (buf
== end
->buffer
);
3345 if (buf
/* Verify marker still points to a buffer. */
3346 && (beg
->charpos
!= BUF_BEGV (buf
) || end
->charpos
!= BUF_ZV (buf
)))
3347 /* The restriction has changed from the saved one, so restore
3348 the saved restriction. */
3350 ptrdiff_t pt
= BUF_PT (buf
);
3352 SET_BUF_BEGV_BOTH (buf
, beg
->charpos
, beg
->bytepos
);
3353 SET_BUF_ZV_BOTH (buf
, end
->charpos
, end
->bytepos
);
3355 if (pt
< beg
->charpos
|| pt
> end
->charpos
)
3356 /* The point is outside the new visible range, move it inside. */
3357 SET_BUF_PT_BOTH (buf
,
3358 clip_to_bounds (beg
->charpos
, pt
, end
->charpos
),
3359 clip_to_bounds (beg
->bytepos
, BUF_PT_BYTE (buf
),
3362 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3364 /* These aren't needed anymore, so don't wait for GC. */
3365 free_marker (XCAR (data
));
3366 free_marker (XCDR (data
));
3367 free_cons (XCONS (data
));
3370 /* A buffer, which means that there was no old restriction. */
3372 if (buf
/* Verify marker still points to a buffer. */
3373 && (BUF_BEGV (buf
) != BUF_BEG (buf
) || BUF_ZV (buf
) != BUF_Z (buf
)))
3374 /* The buffer has been narrowed, get rid of the narrowing. */
3376 SET_BUF_BEGV_BOTH (buf
, BUF_BEG (buf
), BUF_BEG_BYTE (buf
));
3377 SET_BUF_ZV_BOTH (buf
, BUF_Z (buf
), BUF_Z_BYTE (buf
));
3379 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3383 /* Changing the buffer bounds invalidates any recorded current column. */
3384 invalidate_current_column ();
3387 set_buffer_internal (cur
);
3390 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
3391 doc
: /* Execute BODY, saving and restoring current buffer's restrictions.
3392 The buffer's restrictions make parts of the beginning and end invisible.
3393 \(They are set up with `narrow-to-region' and eliminated with `widen'.)
3394 This special form, `save-restriction', saves the current buffer's restrictions
3395 when it is entered, and restores them when it is exited.
3396 So any `narrow-to-region' within BODY lasts only until the end of the form.
3397 The old restrictions settings are restored
3398 even in case of abnormal exit (throw or error).
3400 The value returned is the value of the last form in BODY.
3402 Note: if you are using both `save-excursion' and `save-restriction',
3403 use `save-excursion' outermost:
3404 (save-excursion (save-restriction ...))
3406 usage: (save-restriction &rest BODY) */)
3409 register Lisp_Object val
;
3410 ptrdiff_t count
= SPECPDL_INDEX ();
3412 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
3413 val
= Fprogn (body
);
3414 return unbind_to (count
, val
);
3417 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
3418 doc
: /* Display a message at the bottom of the screen.
3419 The message also goes into the `*Messages*' buffer, if `message-log-max'
3420 is non-nil. (In keyboard macros, that's all it does.)
3423 In batch mode, the message is printed to the standard error stream,
3424 followed by a newline.
3426 The first argument is a format control string, and the rest are data
3427 to be formatted under control of the string. See `format' for details.
3429 Note: Use (message "%s" VALUE) to print the value of expressions and
3430 variables to avoid accidentally interpreting `%' as format specifiers.
3432 If the first argument is nil or the empty string, the function clears
3433 any existing message; this lets the minibuffer contents show. See
3434 also `current-message'.
3436 usage: (message FORMAT-STRING &rest ARGS) */)
3437 (ptrdiff_t nargs
, Lisp_Object
*args
)
3440 || (STRINGP (args
[0])
3441 && SBYTES (args
[0]) == 0))
3448 register Lisp_Object val
;
3449 val
= Fformat (nargs
, args
);
3455 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
3456 doc
: /* Display a message, in a dialog box if possible.
3457 If a dialog box is not available, use the echo area.
3458 The first argument is a format control string, and the rest are data
3459 to be formatted under control of the string. See `format' for details.
3461 If the first argument is nil or the empty string, clear any existing
3462 message; let the minibuffer contents show.
3464 usage: (message-box FORMAT-STRING &rest ARGS) */)
3465 (ptrdiff_t nargs
, Lisp_Object
*args
)
3474 Lisp_Object val
= Fformat (nargs
, args
);
3476 Lisp_Object pane
, menu
;
3477 struct gcpro gcpro1
;
3479 pane
= list1 (Fcons (build_string ("OK"), Qt
));
3481 menu
= Fcons (val
, pane
);
3482 Fx_popup_dialog (Qt
, menu
, Qt
);
3484 #else /* !HAVE_MENUS */
3491 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
3492 doc
: /* Display a message in a dialog box or in the echo area.
3493 If this command was invoked with the mouse, use a dialog box if
3494 `use-dialog-box' is non-nil.
3495 Otherwise, use the echo area.
3496 The first argument is a format control string, and the rest are data
3497 to be formatted under control of the string. See `format' for details.
3499 If the first argument is nil or the empty string, clear any existing
3500 message; let the minibuffer contents show.
3502 usage: (message-or-box FORMAT-STRING &rest ARGS) */)
3503 (ptrdiff_t nargs
, Lisp_Object
*args
)
3506 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3508 return Fmessage_box (nargs
, args
);
3510 return Fmessage (nargs
, args
);
3513 DEFUN ("current-message", Fcurrent_message
, Scurrent_message
, 0, 0, 0,
3514 doc
: /* Return the string currently displayed in the echo area, or nil if none. */)
3517 return current_message ();
3521 DEFUN ("propertize", Fpropertize
, Spropertize
, 1, MANY
, 0,
3522 doc
: /* Return a copy of STRING with text properties added.
3523 First argument is the string to copy.
3524 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
3525 properties to add to the result.
3526 usage: (propertize STRING &rest PROPERTIES) */)
3527 (ptrdiff_t nargs
, Lisp_Object
*args
)
3529 Lisp_Object properties
, string
;
3530 struct gcpro gcpro1
, gcpro2
;
3533 /* Number of args must be odd. */
3534 if ((nargs
& 1) == 0)
3535 error ("Wrong number of arguments");
3537 properties
= string
= Qnil
;
3538 GCPRO2 (properties
, string
);
3540 /* First argument must be a string. */
3541 CHECK_STRING (args
[0]);
3542 string
= Fcopy_sequence (args
[0]);
3544 for (i
= 1; i
< nargs
; i
+= 2)
3545 properties
= Fcons (args
[i
], Fcons (args
[i
+ 1], properties
));
3547 Fadd_text_properties (make_number (0),
3548 make_number (SCHARS (string
)),
3549 properties
, string
);
3550 RETURN_UNGCPRO (string
);
3553 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
3554 doc
: /* Format a string out of a format-string and arguments.
3555 The first argument is a format control string.
3556 The other arguments are substituted into it to make the result, a string.
3558 The format control string may contain %-sequences meaning to substitute
3559 the next available argument:
3561 %s means print a string argument. Actually, prints any object, with `princ'.
3562 %d means print as number in decimal (%o octal, %x hex).
3563 %X is like %x, but uses upper case.
3564 %e means print a number in exponential notation.
3565 %f means print a number in decimal-point notation.
3566 %g means print a number in exponential notation
3567 or decimal-point notation, whichever uses fewer characters.
3568 %c means print a number as a single character.
3569 %S means print any object as an s-expression (using `prin1').
3571 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
3572 Use %% to put a single % into the output.
3574 A %-sequence may contain optional flag, width, and precision
3575 specifiers, as follows:
3577 %<flags><width><precision>character
3579 where flags is [+ #-0]+, width is [0-9]+, and precision is .[0-9]+
3581 The + flag character inserts a + before any positive number, while a
3582 space inserts a space before any positive number; these flags only
3583 affect %d, %e, %f, and %g sequences, and the + flag takes precedence.
3584 The - and 0 flags affect the width specifier, as described below.
3586 The # flag means to use an alternate display form for %o, %x, %X, %e,
3587 %f, and %g sequences: for %o, it ensures that the result begins with
3588 \"0\"; for %x and %X, it prefixes the result with \"0x\" or \"0X\";
3589 for %e, %f, and %g, it causes a decimal point to be included even if
3590 the precision is zero.
3592 The width specifier supplies a lower limit for the length of the
3593 printed representation. The padding, if any, normally goes on the
3594 left, but it goes on the right if the - flag is present. The padding
3595 character is normally a space, but it is 0 if the 0 flag is present.
3596 The 0 flag is ignored if the - flag is present, or the format sequence
3597 is something other than %d, %e, %f, and %g.
3599 For %e, %f, and %g sequences, the number after the "." in the
3600 precision specifier says how many decimal places to show; if zero, the
3601 decimal point itself is omitted. For %s and %S, the precision
3602 specifier truncates the string to the given width.
3604 usage: (format STRING &rest OBJECTS) */)
3605 (ptrdiff_t nargs
, Lisp_Object
*args
)
3607 ptrdiff_t n
; /* The number of the next arg to substitute */
3608 char initial_buffer
[4000];
3609 char *buf
= initial_buffer
;
3610 ptrdiff_t bufsize
= sizeof initial_buffer
;
3611 ptrdiff_t max_bufsize
= STRING_BYTES_BOUND
+ 1;
3613 ptrdiff_t buf_save_value_index
IF_LINT (= 0);
3614 char *format
, *end
, *format_start
;
3615 ptrdiff_t formatlen
, nchars
;
3616 /* True if the format is multibyte. */
3617 bool multibyte_format
= 0;
3618 /* True if the output should be a multibyte string,
3619 which is true if any of the inputs is one. */
3621 /* When we make a multibyte string, we must pay attention to the
3622 byte combining problem, i.e., a byte may be combined with a
3623 multibyte character of the previous string. This flag tells if we
3624 must consider such a situation or not. */
3625 bool maybe_combine_byte
;
3627 bool arg_intervals
= 0;
3630 /* discarded[I] is 1 if byte I of the format
3631 string was not copied into the output.
3632 It is 2 if byte I was not the first byte of its character. */
3635 /* Each element records, for one argument,
3636 the start and end bytepos in the output string,
3637 whether the argument has been converted to string (e.g., due to "%S"),
3638 and whether the argument is a string with intervals.
3639 info[0] is unused. Unused elements have -1 for start. */
3642 ptrdiff_t start
, end
;
3643 unsigned converted_to_string
: 1;
3644 unsigned intervals
: 1;
3647 /* It should not be necessary to GCPRO ARGS, because
3648 the caller in the interpreter should take care of that. */
3650 CHECK_STRING (args
[0]);
3651 format_start
= SSDATA (args
[0]);
3652 formatlen
= SBYTES (args
[0]);
3654 /* Allocate the info and discarded tables. */
3657 if ((SIZE_MAX
- formatlen
) / sizeof (struct info
) <= nargs
)
3658 memory_full (SIZE_MAX
);
3659 info
= SAFE_ALLOCA ((nargs
+ 1) * sizeof *info
+ formatlen
);
3660 discarded
= (char *) &info
[nargs
+ 1];
3661 for (i
= 0; i
< nargs
+ 1; i
++)
3664 info
[i
].intervals
= info
[i
].converted_to_string
= 0;
3666 memset (discarded
, 0, formatlen
);
3669 /* Try to determine whether the result should be multibyte.
3670 This is not always right; sometimes the result needs to be multibyte
3671 because of an object that we will pass through prin1,
3672 and in that case, we won't know it here. */
3673 multibyte_format
= STRING_MULTIBYTE (args
[0]);
3674 multibyte
= multibyte_format
;
3675 for (n
= 1; !multibyte
&& n
< nargs
; n
++)
3676 if (STRINGP (args
[n
]) && STRING_MULTIBYTE (args
[n
]))
3679 /* If we start out planning a unibyte result,
3680 then discover it has to be multibyte, we jump back to retry. */
3687 /* Scan the format and store result in BUF. */
3688 format
= format_start
;
3689 end
= format
+ formatlen
;
3690 maybe_combine_byte
= 0;
3692 while (format
!= end
)
3694 /* The values of N and FORMAT when the loop body is entered. */
3696 char *format0
= format
;
3698 /* Bytes needed to represent the output of this conversion. */
3699 ptrdiff_t convbytes
;
3703 /* General format specifications look like
3705 '%' [flags] [field-width] [precision] format
3710 field-width ::= [0-9]+
3711 precision ::= '.' [0-9]*
3713 If a field-width is specified, it specifies to which width
3714 the output should be padded with blanks, if the output
3715 string is shorter than field-width.
3717 If precision is specified, it specifies the number of
3718 digits to print after the '.' for floats, or the max.
3719 number of chars to print from a string. */
3721 bool minus_flag
= 0;
3723 bool space_flag
= 0;
3724 bool sharp_flag
= 0;
3726 ptrdiff_t field_width
;
3727 bool precision_given
;
3728 uintmax_t precision
= UINTMAX_MAX
;
3736 case '-': minus_flag
= 1; continue;
3737 case '+': plus_flag
= 1; continue;
3738 case ' ': space_flag
= 1; continue;
3739 case '#': sharp_flag
= 1; continue;
3740 case '0': zero_flag
= 1; continue;
3745 /* Ignore flags when sprintf ignores them. */
3746 space_flag
&= ~ plus_flag
;
3747 zero_flag
&= ~ minus_flag
;
3750 uintmax_t w
= strtoumax (format
, &num_end
, 10);
3751 if (max_bufsize
<= w
)
3755 precision_given
= *num_end
== '.';
3756 if (precision_given
)
3757 precision
= strtoumax (num_end
+ 1, &num_end
, 10);
3761 error ("Format string ends in middle of format specifier");
3763 memset (&discarded
[format0
- format_start
], 1, format
- format0
);
3764 conversion
= *format
;
3765 if (conversion
== '%')
3767 discarded
[format
- format_start
] = 1;
3772 error ("Not enough arguments for format string");
3774 /* For 'S', prin1 the argument, and then treat like 's'.
3775 For 's', princ any argument that is not a string or
3776 symbol. But don't do this conversion twice, which might
3777 happen after retrying. */
3778 if ((conversion
== 'S'
3779 || (conversion
== 's'
3780 && ! STRINGP (args
[n
]) && ! SYMBOLP (args
[n
]))))
3782 if (! info
[n
].converted_to_string
)
3784 Lisp_Object noescape
= conversion
== 'S' ? Qnil
: Qt
;
3785 args
[n
] = Fprin1_to_string (args
[n
], noescape
);
3786 info
[n
].converted_to_string
= 1;
3787 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3795 else if (conversion
== 'c')
3797 if (FLOATP (args
[n
]))
3799 double d
= XFLOAT_DATA (args
[n
]);
3800 args
[n
] = make_number (FIXNUM_OVERFLOW_P (d
) ? -1 : d
);
3803 if (INTEGERP (args
[n
]) && ! ASCII_CHAR_P (XINT (args
[n
])))
3810 args
[n
] = Fchar_to_string (args
[n
]);
3811 info
[n
].converted_to_string
= 1;
3814 if (info
[n
].converted_to_string
)
3819 if (SYMBOLP (args
[n
]))
3821 args
[n
] = SYMBOL_NAME (args
[n
]);
3822 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3829 if (conversion
== 's')
3831 /* handle case (precision[n] >= 0) */
3833 ptrdiff_t width
, padding
, nbytes
;
3834 ptrdiff_t nchars_string
;
3836 ptrdiff_t prec
= -1;
3837 if (precision_given
&& precision
<= TYPE_MAXIMUM (ptrdiff_t))
3840 /* lisp_string_width ignores a precision of 0, but GNU
3841 libc functions print 0 characters when the precision
3842 is 0. Imitate libc behavior here. Changing
3843 lisp_string_width is the right thing, and will be
3844 done, but meanwhile we work with it. */
3847 width
= nchars_string
= nbytes
= 0;
3851 width
= lisp_string_width (args
[n
], prec
, &nch
, &nby
);
3854 nchars_string
= SCHARS (args
[n
]);
3855 nbytes
= SBYTES (args
[n
]);
3859 nchars_string
= nch
;
3865 if (convbytes
&& multibyte
&& ! STRING_MULTIBYTE (args
[n
]))
3866 convbytes
= count_size_as_multibyte (SDATA (args
[n
]), nbytes
);
3868 padding
= width
< field_width
? field_width
- width
: 0;
3870 if (max_bufsize
- padding
<= convbytes
)
3872 convbytes
+= padding
;
3873 if (convbytes
<= buf
+ bufsize
- p
)
3877 memset (p
, ' ', padding
);
3884 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3885 && STRING_MULTIBYTE (args
[n
])
3886 && !CHAR_HEAD_P (SREF (args
[n
], 0)))
3887 maybe_combine_byte
= 1;
3889 p
+= copy_text (SDATA (args
[n
]), (unsigned char *) p
,
3891 STRING_MULTIBYTE (args
[n
]), multibyte
);
3893 info
[n
].start
= nchars
;
3894 nchars
+= nchars_string
;
3895 info
[n
].end
= nchars
;
3899 memset (p
, ' ', padding
);
3904 /* If this argument has text properties, record where
3905 in the result string it appears. */
3906 if (string_intervals (args
[n
]))
3907 info
[n
].intervals
= arg_intervals
= 1;
3912 else if (! (conversion
== 'c' || conversion
== 'd'
3913 || conversion
== 'e' || conversion
== 'f'
3914 || conversion
== 'g' || conversion
== 'i'
3915 || conversion
== 'o' || conversion
== 'x'
3916 || conversion
== 'X'))
3917 error ("Invalid format operation %%%c",
3918 STRING_CHAR ((unsigned char *) format
- 1));
3919 else if (! (INTEGERP (args
[n
]) || FLOATP (args
[n
])))
3920 error ("Format specifier doesn't match argument type");
3925 /* Maximum precision for a %f conversion such that the
3926 trailing output digit might be nonzero. Any precision
3927 larger than this will not yield useful information. */
3928 USEFUL_PRECISION_MAX
=
3930 * (FLT_RADIX
== 2 || FLT_RADIX
== 10 ? 1
3931 : FLT_RADIX
== 16 ? 4
3934 /* Maximum number of bytes generated by any format, if
3935 precision is no more than USEFUL_PRECISION_MAX.
3936 On all practical hosts, %f is the worst case. */
3938 sizeof "-." + (DBL_MAX_10_EXP
+ 1) + USEFUL_PRECISION_MAX
,
3940 /* Length of pM (that is, of pMd without the
3942 pMlen
= sizeof pMd
- 2
3944 verify (USEFUL_PRECISION_MAX
> 0);
3947 ptrdiff_t padding
, sprintf_bytes
;
3948 uintmax_t excess_precision
, numwidth
;
3949 uintmax_t leading_zeros
= 0, trailing_zeros
= 0;
3951 char sprintf_buf
[SPRINTF_BUFSIZE
];
3953 /* Copy of conversion specification, modified somewhat.
3954 At most three flags F can be specified at once. */
3955 char convspec
[sizeof "%FFF.*d" + pMlen
];
3957 /* Avoid undefined behavior in underlying sprintf. */
3958 if (conversion
== 'd' || conversion
== 'i')
3961 /* Create the copy of the conversion specification, with
3962 any width and precision removed, with ".*" inserted,
3963 and with pM inserted for integer formats. */
3967 *f
= '-'; f
+= minus_flag
;
3968 *f
= '+'; f
+= plus_flag
;
3969 *f
= ' '; f
+= space_flag
;
3970 *f
= '#'; f
+= sharp_flag
;
3971 *f
= '0'; f
+= zero_flag
;
3974 if (conversion
== 'd' || conversion
== 'i'
3975 || conversion
== 'o' || conversion
== 'x'
3976 || conversion
== 'X')
3978 memcpy (f
, pMd
, pMlen
);
3980 zero_flag
&= ~ precision_given
;
3987 if (precision_given
)
3988 prec
= min (precision
, USEFUL_PRECISION_MAX
);
3990 /* Use sprintf to format this number into sprintf_buf. Omit
3991 padding and excess precision, though, because sprintf limits
3992 output length to INT_MAX.
3994 There are four types of conversion: double, unsigned
3995 char (passed as int), wide signed int, and wide
3996 unsigned int. Treat them separately because the
3997 sprintf ABI is sensitive to which type is passed. Be
3998 careful about integer overflow, NaNs, infinities, and
3999 conversions; for example, the min and max macros are
4000 not suitable here. */
4001 if (conversion
== 'e' || conversion
== 'f' || conversion
== 'g')
4003 double x
= (INTEGERP (args
[n
])
4005 : XFLOAT_DATA (args
[n
]));
4006 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4008 else if (conversion
== 'c')
4010 /* Don't use sprintf here, as it might mishandle prec. */
4011 sprintf_buf
[0] = XINT (args
[n
]);
4012 sprintf_bytes
= prec
!= 0;
4014 else if (conversion
== 'd')
4016 /* For float, maybe we should use "%1.0f"
4017 instead so it also works for values outside
4018 the integer range. */
4020 if (INTEGERP (args
[n
]))
4024 double d
= XFLOAT_DATA (args
[n
]);
4027 x
= TYPE_MINIMUM (printmax_t
);
4033 x
= TYPE_MAXIMUM (printmax_t
);
4038 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4042 /* Don't sign-extend for octal or hex printing. */
4044 if (INTEGERP (args
[n
]))
4045 x
= XUINT (args
[n
]);
4048 double d
= XFLOAT_DATA (args
[n
]);
4053 x
= TYPE_MAXIMUM (uprintmax_t
);
4058 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4061 /* Now the length of the formatted item is known, except it omits
4062 padding and excess precision. Deal with excess precision
4063 first. This happens only when the format specifies
4064 ridiculously large precision. */
4065 excess_precision
= precision
- prec
;
4066 if (excess_precision
)
4068 if (conversion
== 'e' || conversion
== 'f'
4069 || conversion
== 'g')
4071 if ((conversion
== 'g' && ! sharp_flag
)
4072 || ! ('0' <= sprintf_buf
[sprintf_bytes
- 1]
4073 && sprintf_buf
[sprintf_bytes
- 1] <= '9'))
4074 excess_precision
= 0;
4077 if (conversion
== 'g')
4079 char *dot
= strchr (sprintf_buf
, '.');
4081 excess_precision
= 0;
4084 trailing_zeros
= excess_precision
;
4087 leading_zeros
= excess_precision
;
4090 /* Compute the total bytes needed for this item, including
4091 excess precision and padding. */
4092 numwidth
= sprintf_bytes
+ excess_precision
;
4093 padding
= numwidth
< field_width
? field_width
- numwidth
: 0;
4094 if (max_bufsize
- sprintf_bytes
<= excess_precision
4095 || max_bufsize
- padding
<= numwidth
)
4097 convbytes
= numwidth
+ padding
;
4099 if (convbytes
<= buf
+ bufsize
- p
)
4101 /* Copy the formatted item from sprintf_buf into buf,
4102 inserting padding and excess-precision zeros. */
4104 char *src
= sprintf_buf
;
4106 int exponent_bytes
= 0;
4107 bool signedp
= src0
== '-' || src0
== '+' || src0
== ' ';
4108 int significand_bytes
;
4110 && ((src
[signedp
] >= '0' && src
[signedp
] <= '9')
4111 || (src
[signedp
] >= 'a' && src
[signedp
] <= 'f')
4112 || (src
[signedp
] >= 'A' && src
[signedp
] <= 'F')))
4114 leading_zeros
+= padding
;
4118 if (excess_precision
4119 && (conversion
== 'e' || conversion
== 'g'))
4121 char *e
= strchr (src
, 'e');
4123 exponent_bytes
= src
+ sprintf_bytes
- e
;
4128 memset (p
, ' ', padding
);
4136 memset (p
, '0', leading_zeros
);
4138 significand_bytes
= sprintf_bytes
- signedp
- exponent_bytes
;
4139 memcpy (p
, src
, significand_bytes
);
4140 p
+= significand_bytes
;
4141 src
+= significand_bytes
;
4142 memset (p
, '0', trailing_zeros
);
4143 p
+= trailing_zeros
;
4144 memcpy (p
, src
, exponent_bytes
);
4145 p
+= exponent_bytes
;
4147 info
[n
].start
= nchars
;
4148 nchars
+= leading_zeros
+ sprintf_bytes
+ trailing_zeros
;
4149 info
[n
].end
= nchars
;
4153 memset (p
, ' ', padding
);
4165 /* Copy a single character from format to buf. */
4168 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
4170 if (multibyte_format
)
4172 /* Copy a whole multibyte character. */
4174 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
4175 && !CHAR_HEAD_P (*format
))
4176 maybe_combine_byte
= 1;
4180 while (! CHAR_HEAD_P (*format
));
4182 convbytes
= format
- src
;
4183 memset (&discarded
[src
+ 1 - format_start
], 2, convbytes
- 1);
4187 unsigned char uc
= *format
++;
4188 if (! multibyte
|| ASCII_BYTE_P (uc
))
4192 int c
= BYTE8_TO_CHAR (uc
);
4193 convbytes
= CHAR_STRING (c
, str
);
4198 if (convbytes
<= buf
+ bufsize
- p
)
4200 memcpy (p
, src
, convbytes
);
4207 /* There wasn't enough room to store this conversion or single
4208 character. CONVBYTES says how much room is needed. Allocate
4209 enough room (and then some) and do it again. */
4211 ptrdiff_t used
= p
- buf
;
4213 if (max_bufsize
- used
< convbytes
)
4215 bufsize
= used
+ convbytes
;
4216 bufsize
= bufsize
< max_bufsize
/ 2 ? bufsize
* 2 : max_bufsize
;
4218 if (buf
== initial_buffer
)
4220 buf
= xmalloc (bufsize
);
4222 buf_save_value_index
= SPECPDL_INDEX ();
4223 record_unwind_protect_ptr (xfree
, buf
);
4224 memcpy (buf
, initial_buffer
, used
);
4228 buf
= xrealloc (buf
, bufsize
);
4229 set_unwind_protect_ptr (buf_save_value_index
, xfree
, buf
);
4239 if (bufsize
< p
- buf
)
4242 if (maybe_combine_byte
)
4243 nchars
= multibyte_chars_in_text ((unsigned char *) buf
, p
- buf
);
4244 val
= make_specified_string (buf
, nchars
, p
- buf
, multibyte
);
4246 /* If we allocated BUF with malloc, free it too. */
4249 /* If the format string has text properties, or any of the string
4250 arguments has text properties, set up text properties of the
4253 if (string_intervals (args
[0]) || arg_intervals
)
4255 Lisp_Object len
, new_len
, props
;
4256 struct gcpro gcpro1
;
4258 /* Add text properties from the format string. */
4259 len
= make_number (SCHARS (args
[0]));
4260 props
= text_property_list (args
[0], make_number (0), len
, Qnil
);
4265 ptrdiff_t bytepos
= 0, position
= 0, translated
= 0;
4269 /* Adjust the bounds of each text property
4270 to the proper start and end in the output string. */
4272 /* Put the positions in PROPS in increasing order, so that
4273 we can do (effectively) one scan through the position
4274 space of the format string. */
4275 props
= Fnreverse (props
);
4277 /* BYTEPOS is the byte position in the format string,
4278 POSITION is the untranslated char position in it,
4279 TRANSLATED is the translated char position in BUF,
4280 and ARGN is the number of the next arg we will come to. */
4281 for (list
= props
; CONSP (list
); list
= XCDR (list
))
4288 /* First adjust the property start position. */
4289 pos
= XINT (XCAR (item
));
4291 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
4292 up to this position. */
4293 for (; position
< pos
; bytepos
++)
4295 if (! discarded
[bytepos
])
4296 position
++, translated
++;
4297 else if (discarded
[bytepos
] == 1)
4300 if (translated
== info
[argn
].start
)
4302 translated
+= info
[argn
].end
- info
[argn
].start
;
4308 XSETCAR (item
, make_number (translated
));
4310 /* Likewise adjust the property end position. */
4311 pos
= XINT (XCAR (XCDR (item
)));
4313 for (; position
< pos
; bytepos
++)
4315 if (! discarded
[bytepos
])
4316 position
++, translated
++;
4317 else if (discarded
[bytepos
] == 1)
4320 if (translated
== info
[argn
].start
)
4322 translated
+= info
[argn
].end
- info
[argn
].start
;
4328 XSETCAR (XCDR (item
), make_number (translated
));
4331 add_text_properties_from_list (val
, props
, make_number (0));
4334 /* Add text properties from arguments. */
4336 for (n
= 1; n
< nargs
; ++n
)
4337 if (info
[n
].intervals
)
4339 len
= make_number (SCHARS (args
[n
]));
4340 new_len
= make_number (info
[n
].end
- info
[n
].start
);
4341 props
= text_property_list (args
[n
], make_number (0), len
, Qnil
);
4342 props
= extend_property_ranges (props
, new_len
);
4343 /* If successive arguments have properties, be sure that
4344 the value of `composition' property be the copy. */
4345 if (n
> 1 && info
[n
- 1].end
)
4346 make_composition_value_copy (props
);
4347 add_text_properties_from_list (val
, props
,
4348 make_number (info
[n
].start
));
4358 format2 (const char *string1
, Lisp_Object arg0
, Lisp_Object arg1
)
4360 Lisp_Object args
[3];
4361 args
[0] = build_string (string1
);
4364 return Fformat (3, args
);
4367 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
4368 doc
: /* Return t if two characters match, optionally ignoring case.
4369 Both arguments must be characters (i.e. integers).
4370 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
4371 (register Lisp_Object c1
, Lisp_Object c2
)
4374 /* Check they're chars, not just integers, otherwise we could get array
4375 bounds violations in downcase. */
4376 CHECK_CHARACTER (c1
);
4377 CHECK_CHARACTER (c2
);
4379 if (XINT (c1
) == XINT (c2
))
4381 if (NILP (BVAR (current_buffer
, case_fold_search
)))
4385 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
))
4386 && ! ASCII_CHAR_P (i1
))
4388 MAKE_CHAR_MULTIBYTE (i1
);
4391 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
))
4392 && ! ASCII_CHAR_P (i2
))
4394 MAKE_CHAR_MULTIBYTE (i2
);
4396 return (downcase (i1
) == downcase (i2
) ? Qt
: Qnil
);
4399 /* Transpose the markers in two regions of the current buffer, and
4400 adjust the ones between them if necessary (i.e.: if the regions
4403 START1, END1 are the character positions of the first region.
4404 START1_BYTE, END1_BYTE are the byte positions.
4405 START2, END2 are the character positions of the second region.
4406 START2_BYTE, END2_BYTE are the byte positions.
4408 Traverses the entire marker list of the buffer to do so, adding an
4409 appropriate amount to some, subtracting from some, and leaving the
4410 rest untouched. Most of this is copied from adjust_markers in insdel.c.
4412 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
4415 transpose_markers (ptrdiff_t start1
, ptrdiff_t end1
,
4416 ptrdiff_t start2
, ptrdiff_t end2
,
4417 ptrdiff_t start1_byte
, ptrdiff_t end1_byte
,
4418 ptrdiff_t start2_byte
, ptrdiff_t end2_byte
)
4420 register ptrdiff_t amt1
, amt1_byte
, amt2
, amt2_byte
, diff
, diff_byte
, mpos
;
4421 register struct Lisp_Marker
*marker
;
4423 /* Update point as if it were a marker. */
4427 TEMP_SET_PT_BOTH (PT
+ (end2
- end1
),
4428 PT_BYTE
+ (end2_byte
- end1_byte
));
4429 else if (PT
< start2
)
4430 TEMP_SET_PT_BOTH (PT
+ (end2
- start2
) - (end1
- start1
),
4431 (PT_BYTE
+ (end2_byte
- start2_byte
)
4432 - (end1_byte
- start1_byte
)));
4434 TEMP_SET_PT_BOTH (PT
- (start2
- start1
),
4435 PT_BYTE
- (start2_byte
- start1_byte
));
4437 /* We used to adjust the endpoints here to account for the gap, but that
4438 isn't good enough. Even if we assume the caller has tried to move the
4439 gap out of our way, it might still be at start1 exactly, for example;
4440 and that places it `inside' the interval, for our purposes. The amount
4441 of adjustment is nontrivial if there's a `denormalized' marker whose
4442 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
4443 the dirty work to Fmarker_position, below. */
4445 /* The difference between the region's lengths */
4446 diff
= (end2
- start2
) - (end1
- start1
);
4447 diff_byte
= (end2_byte
- start2_byte
) - (end1_byte
- start1_byte
);
4449 /* For shifting each marker in a region by the length of the other
4450 region plus the distance between the regions. */
4451 amt1
= (end2
- start2
) + (start2
- end1
);
4452 amt2
= (end1
- start1
) + (start2
- end1
);
4453 amt1_byte
= (end2_byte
- start2_byte
) + (start2_byte
- end1_byte
);
4454 amt2_byte
= (end1_byte
- start1_byte
) + (start2_byte
- end1_byte
);
4456 for (marker
= BUF_MARKERS (current_buffer
); marker
; marker
= marker
->next
)
4458 mpos
= marker
->bytepos
;
4459 if (mpos
>= start1_byte
&& mpos
< end2_byte
)
4461 if (mpos
< end1_byte
)
4463 else if (mpos
< start2_byte
)
4467 marker
->bytepos
= mpos
;
4469 mpos
= marker
->charpos
;
4470 if (mpos
>= start1
&& mpos
< end2
)
4474 else if (mpos
< start2
)
4479 marker
->charpos
= mpos
;
4483 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
4484 doc
: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
4485 The regions should not be overlapping, because the size of the buffer is
4486 never changed in a transposition.
4488 Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
4489 any markers that happen to be located in the regions.
4491 Transposing beyond buffer boundaries is an error. */)
4492 (Lisp_Object startr1
, Lisp_Object endr1
, Lisp_Object startr2
, Lisp_Object endr2
, Lisp_Object leave_markers
)
4494 register ptrdiff_t start1
, end1
, start2
, end2
;
4495 ptrdiff_t start1_byte
, start2_byte
, len1_byte
, len2_byte
, end2_byte
;
4496 ptrdiff_t gap
, len1
, len_mid
, len2
;
4497 unsigned char *start1_addr
, *start2_addr
, *temp
;
4499 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
, tmp_interval3
;
4502 XSETBUFFER (buf
, current_buffer
);
4503 cur_intv
= buffer_intervals (current_buffer
);
4505 validate_region (&startr1
, &endr1
);
4506 validate_region (&startr2
, &endr2
);
4508 start1
= XFASTINT (startr1
);
4509 end1
= XFASTINT (endr1
);
4510 start2
= XFASTINT (startr2
);
4511 end2
= XFASTINT (endr2
);
4514 /* Swap the regions if they're reversed. */
4517 register ptrdiff_t glumph
= start1
;
4525 len1
= end1
- start1
;
4526 len2
= end2
- start2
;
4529 error ("Transposed regions overlap");
4530 /* Nothing to change for adjacent regions with one being empty */
4531 else if ((start1
== end1
|| start2
== end2
) && end1
== start2
)
4534 /* The possibilities are:
4535 1. Adjacent (contiguous) regions, or separate but equal regions
4536 (no, really equal, in this case!), or
4537 2. Separate regions of unequal size.
4539 The worst case is usually No. 2. It means that (aside from
4540 potential need for getting the gap out of the way), there also
4541 needs to be a shifting of the text between the two regions. So
4542 if they are spread far apart, we are that much slower... sigh. */
4544 /* It must be pointed out that the really studly thing to do would
4545 be not to move the gap at all, but to leave it in place and work
4546 around it if necessary. This would be extremely efficient,
4547 especially considering that people are likely to do
4548 transpositions near where they are working interactively, which
4549 is exactly where the gap would be found. However, such code
4550 would be much harder to write and to read. So, if you are
4551 reading this comment and are feeling squirrely, by all means have
4552 a go! I just didn't feel like doing it, so I will simply move
4553 the gap the minimum distance to get it out of the way, and then
4554 deal with an unbroken array. */
4556 start1_byte
= CHAR_TO_BYTE (start1
);
4557 end2_byte
= CHAR_TO_BYTE (end2
);
4559 /* Make sure the gap won't interfere, by moving it out of the text
4560 we will operate on. */
4561 if (start1
< gap
&& gap
< end2
)
4563 if (gap
- start1
< end2
- gap
)
4564 move_gap_both (start1
, start1_byte
);
4566 move_gap_both (end2
, end2_byte
);
4569 start2_byte
= CHAR_TO_BYTE (start2
);
4570 len1_byte
= CHAR_TO_BYTE (end1
) - start1_byte
;
4571 len2_byte
= end2_byte
- start2_byte
;
4573 #ifdef BYTE_COMBINING_DEBUG
4576 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4577 len2_byte
, start1
, start1_byte
)
4578 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4579 len1_byte
, end2
, start2_byte
+ len2_byte
)
4580 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4581 len1_byte
, end2
, start2_byte
+ len2_byte
))
4586 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4587 len2_byte
, start1
, start1_byte
)
4588 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4589 len1_byte
, start2
, start2_byte
)
4590 || count_combining_after (BYTE_POS_ADDR (start2_byte
),
4591 len2_byte
, end1
, start1_byte
+ len1_byte
)
4592 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4593 len1_byte
, end2
, start2_byte
+ len2_byte
))
4598 /* Hmmm... how about checking to see if the gap is large
4599 enough to use as the temporary storage? That would avoid an
4600 allocation... interesting. Later, don't fool with it now. */
4602 /* Working without memmove, for portability (sigh), so must be
4603 careful of overlapping subsections of the array... */
4605 if (end1
== start2
) /* adjacent regions */
4607 modify_text (start1
, end2
);
4608 record_change (start1
, len1
+ len2
);
4610 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4611 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4612 /* Don't use Fset_text_properties: that can cause GC, which can
4613 clobber objects stored in the tmp_intervals. */
4614 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4616 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4618 /* First region smaller than second. */
4619 if (len1_byte
< len2_byte
)
4623 temp
= SAFE_ALLOCA (len2_byte
);
4625 /* Don't precompute these addresses. We have to compute them
4626 at the last minute, because the relocating allocator might
4627 have moved the buffer around during the xmalloc. */
4628 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4629 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4631 memcpy (temp
, start2_addr
, len2_byte
);
4632 memcpy (start1_addr
+ len2_byte
, start1_addr
, len1_byte
);
4633 memcpy (start1_addr
, temp
, len2_byte
);
4637 /* First region not smaller than second. */
4641 temp
= SAFE_ALLOCA (len1_byte
);
4642 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4643 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4644 memcpy (temp
, start1_addr
, len1_byte
);
4645 memcpy (start1_addr
, start2_addr
, len2_byte
);
4646 memcpy (start1_addr
+ len2_byte
, temp
, len1_byte
);
4649 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
4650 len1
, current_buffer
, 0);
4651 graft_intervals_into_buffer (tmp_interval2
, start1
,
4652 len2
, current_buffer
, 0);
4653 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4654 update_compositions (start1
+ len2
, end2
, CHECK_TAIL
);
4656 /* Non-adjacent regions, because end1 != start2, bleagh... */
4659 len_mid
= start2_byte
- (start1_byte
+ len1_byte
);
4661 if (len1_byte
== len2_byte
)
4662 /* Regions are same size, though, how nice. */
4666 modify_text (start1
, end1
);
4667 modify_text (start2
, end2
);
4668 record_change (start1
, len1
);
4669 record_change (start2
, len2
);
4670 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4671 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4673 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr1
, 0);
4675 set_text_properties_1 (startr1
, endr1
, Qnil
, buf
, tmp_interval3
);
4677 tmp_interval3
= validate_interval_range (buf
, &startr2
, &endr2
, 0);
4679 set_text_properties_1 (startr2
, endr2
, Qnil
, buf
, tmp_interval3
);
4681 temp
= SAFE_ALLOCA (len1_byte
);
4682 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4683 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4684 memcpy (temp
, start1_addr
, len1_byte
);
4685 memcpy (start1_addr
, start2_addr
, len2_byte
);
4686 memcpy (start2_addr
, temp
, len1_byte
);
4689 graft_intervals_into_buffer (tmp_interval1
, start2
,
4690 len1
, current_buffer
, 0);
4691 graft_intervals_into_buffer (tmp_interval2
, start1
,
4692 len2
, current_buffer
, 0);
4695 else if (len1_byte
< len2_byte
) /* Second region larger than first */
4696 /* Non-adjacent & unequal size, area between must also be shifted. */
4700 modify_text (start1
, end2
);
4701 record_change (start1
, (end2
- start1
));
4702 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4703 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4704 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4706 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4708 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4710 /* holds region 2 */
4711 temp
= SAFE_ALLOCA (len2_byte
);
4712 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4713 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4714 memcpy (temp
, start2_addr
, len2_byte
);
4715 memcpy (start1_addr
+ len_mid
+ len2_byte
, start1_addr
, len1_byte
);
4716 memmove (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
4717 memcpy (start1_addr
, temp
, len2_byte
);
4720 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4721 len1
, current_buffer
, 0);
4722 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4723 len_mid
, current_buffer
, 0);
4724 graft_intervals_into_buffer (tmp_interval2
, start1
,
4725 len2
, current_buffer
, 0);
4728 /* Second region smaller than first. */
4732 record_change (start1
, (end2
- start1
));
4733 modify_text (start1
, end2
);
4735 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4736 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4737 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4739 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4741 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4743 /* holds region 1 */
4744 temp
= SAFE_ALLOCA (len1_byte
);
4745 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4746 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4747 memcpy (temp
, start1_addr
, len1_byte
);
4748 memcpy (start1_addr
, start2_addr
, len2_byte
);
4749 memcpy (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
4750 memcpy (start1_addr
+ len2_byte
+ len_mid
, temp
, len1_byte
);
4753 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4754 len1
, current_buffer
, 0);
4755 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4756 len_mid
, current_buffer
, 0);
4757 graft_intervals_into_buffer (tmp_interval2
, start1
,
4758 len2
, current_buffer
, 0);
4761 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4762 update_compositions (end2
- len1
, end2
, CHECK_BORDER
);
4765 /* When doing multiple transpositions, it might be nice
4766 to optimize this. Perhaps the markers in any one buffer
4767 should be organized in some sorted data tree. */
4768 if (NILP (leave_markers
))
4770 transpose_markers (start1
, end1
, start2
, end2
,
4771 start1_byte
, start1_byte
+ len1_byte
,
4772 start2_byte
, start2_byte
+ len2_byte
);
4773 fix_start_end_in_overlays (start1
, end2
);
4776 signal_after_change (start1
, end2
- start1
, end2
- start1
);
4782 syms_of_editfns (void)
4784 DEFSYM (Qbuffer_access_fontify_functions
, "buffer-access-fontify-functions");
4786 DEFVAR_LISP ("inhibit-field-text-motion", Vinhibit_field_text_motion
,
4787 doc
: /* Non-nil means text motion commands don't notice fields. */);
4788 Vinhibit_field_text_motion
= Qnil
;
4790 DEFVAR_LISP ("buffer-access-fontify-functions",
4791 Vbuffer_access_fontify_functions
,
4792 doc
: /* List of functions called by `buffer-substring' to fontify if necessary.
4793 Each function is called with two arguments which specify the range
4794 of the buffer being accessed. */);
4795 Vbuffer_access_fontify_functions
= Qnil
;
4799 obuf
= Fcurrent_buffer ();
4800 /* Do this here, because init_buffer_once is too early--it won't work. */
4801 Fset_buffer (Vprin1_to_string_buffer
);
4802 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
4803 Fset (Fmake_local_variable (intern_c_string ("buffer-access-fontify-functions")),
4808 DEFVAR_LISP ("buffer-access-fontified-property",
4809 Vbuffer_access_fontified_property
,
4810 doc
: /* Property which (if non-nil) indicates text has been fontified.
4811 `buffer-substring' need not call the `buffer-access-fontify-functions'
4812 functions if all the text being accessed has this property. */);
4813 Vbuffer_access_fontified_property
= Qnil
;
4815 DEFVAR_LISP ("system-name", Vsystem_name
,
4816 doc
: /* The host name of the machine Emacs is running on. */);
4818 DEFVAR_LISP ("user-full-name", Vuser_full_name
,
4819 doc
: /* The full name of the user logged in. */);
4821 DEFVAR_LISP ("user-login-name", Vuser_login_name
,
4822 doc
: /* The user's name, taken from environment variables if possible. */);
4824 DEFVAR_LISP ("user-real-login-name", Vuser_real_login_name
,
4825 doc
: /* The user's name, based upon the real uid only. */);
4827 DEFVAR_LISP ("operating-system-release", Voperating_system_release
,
4828 doc
: /* The release of the operating system Emacs is running on. */);
4830 defsubr (&Spropertize
);
4831 defsubr (&Schar_equal
);
4832 defsubr (&Sgoto_char
);
4833 defsubr (&Sstring_to_char
);
4834 defsubr (&Schar_to_string
);
4835 defsubr (&Sbyte_to_string
);
4836 defsubr (&Sbuffer_substring
);
4837 defsubr (&Sbuffer_substring_no_properties
);
4838 defsubr (&Sbuffer_string
);
4840 defsubr (&Spoint_marker
);
4841 defsubr (&Smark_marker
);
4843 defsubr (&Sregion_beginning
);
4844 defsubr (&Sregion_end
);
4846 DEFSYM (Qfield
, "field");
4847 DEFSYM (Qboundary
, "boundary");
4848 defsubr (&Sfield_beginning
);
4849 defsubr (&Sfield_end
);
4850 defsubr (&Sfield_string
);
4851 defsubr (&Sfield_string_no_properties
);
4852 defsubr (&Sdelete_field
);
4853 defsubr (&Sconstrain_to_field
);
4855 defsubr (&Sline_beginning_position
);
4856 defsubr (&Sline_end_position
);
4858 defsubr (&Ssave_excursion
);
4859 defsubr (&Ssave_current_buffer
);
4861 defsubr (&Sbuffer_size
);
4862 defsubr (&Spoint_max
);
4863 defsubr (&Spoint_min
);
4864 defsubr (&Spoint_min_marker
);
4865 defsubr (&Spoint_max_marker
);
4866 defsubr (&Sgap_position
);
4867 defsubr (&Sgap_size
);
4868 defsubr (&Sposition_bytes
);
4869 defsubr (&Sbyte_to_position
);
4875 defsubr (&Sfollowing_char
);
4876 defsubr (&Sprevious_char
);
4877 defsubr (&Schar_after
);
4878 defsubr (&Schar_before
);
4880 defsubr (&Sinsert_before_markers
);
4881 defsubr (&Sinsert_and_inherit
);
4882 defsubr (&Sinsert_and_inherit_before_markers
);
4883 defsubr (&Sinsert_char
);
4884 defsubr (&Sinsert_byte
);
4886 defsubr (&Suser_login_name
);
4887 defsubr (&Suser_real_login_name
);
4888 defsubr (&Suser_uid
);
4889 defsubr (&Suser_real_uid
);
4890 defsubr (&Sgroup_gid
);
4891 defsubr (&Sgroup_real_gid
);
4892 defsubr (&Suser_full_name
);
4893 defsubr (&Semacs_pid
);
4894 defsubr (&Scurrent_time
);
4895 defsubr (&Sget_internal_run_time
);
4896 defsubr (&Sformat_time_string
);
4897 defsubr (&Sfloat_time
);
4898 defsubr (&Sdecode_time
);
4899 defsubr (&Sencode_time
);
4900 defsubr (&Scurrent_time_string
);
4901 defsubr (&Scurrent_time_zone
);
4902 defsubr (&Sset_time_zone_rule
);
4903 defsubr (&Ssystem_name
);
4904 defsubr (&Smessage
);
4905 defsubr (&Smessage_box
);
4906 defsubr (&Smessage_or_box
);
4907 defsubr (&Scurrent_message
);
4910 defsubr (&Sinsert_buffer_substring
);
4911 defsubr (&Scompare_buffer_substrings
);
4912 defsubr (&Ssubst_char_in_region
);
4913 defsubr (&Stranslate_region_internal
);
4914 defsubr (&Sdelete_region
);
4915 defsubr (&Sdelete_and_extract_region
);
4917 defsubr (&Snarrow_to_region
);
4918 defsubr (&Ssave_restriction
);
4919 defsubr (&Stranspose_regions
);