1 /* Lisp functions pertaining to editing.
3 Copyright (C) 1985-1987, 1989, 1993-2012 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>
31 #ifdef HAVE_SYS_UTSNAME_H
32 #include <sys/utsname.h>
37 /* systime.h includes <sys/time.h> which, on some systems, is required
38 for <sys/resource.h>; thus systime.h must be included before
42 #if defined HAVE_SYS_RESOURCE_H
43 #include <sys/resource.h>
52 #include "intervals.h"
53 #include "character.h"
58 #include "blockinput.h"
60 #define TM_YEAR_BASE 1900
63 extern Lisp_Object
w32_get_internal_run_time (void);
66 static Lisp_Object
format_time_string (char const *, ptrdiff_t, EMACS_TIME
,
68 static int tm_diff (struct tm
*, struct tm
*);
69 static void update_buffer_properties (ptrdiff_t, ptrdiff_t);
71 static Lisp_Object Qbuffer_access_fontify_functions
;
73 /* Symbol for the text property used to mark fields. */
77 /* A special value for Qfield properties. */
79 static Lisp_Object Qboundary
;
85 const char *user_name
;
87 struct passwd
*pw
; /* password entry for the current user */
90 /* Set up system_name even when dumping. */
94 /* Don't bother with this on initial start when just dumping out */
97 #endif /* not CANNOT_DUMP */
99 pw
= getpwuid (getuid ());
101 /* We let the real user name default to "root" because that's quite
102 accurate on MSDOG and because it lets Emacs find the init file.
103 (The DVX libraries override the Djgpp libraries here.) */
104 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "root");
106 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "unknown");
109 /* Get the effective user name, by consulting environment variables,
110 or the effective uid if those are unset. */
111 user_name
= getenv ("LOGNAME");
114 user_name
= getenv ("USERNAME"); /* it's USERNAME on NT */
115 #else /* WINDOWSNT */
116 user_name
= getenv ("USER");
117 #endif /* WINDOWSNT */
120 pw
= getpwuid (geteuid ());
121 user_name
= pw
? pw
->pw_name
: "unknown";
123 Vuser_login_name
= build_string (user_name
);
125 /* If the user name claimed in the environment vars differs from
126 the real uid, use the claimed name to find the full name. */
127 tem
= Fstring_equal (Vuser_login_name
, Vuser_real_login_name
);
129 tem
= Vuser_login_name
;
132 uid_t euid
= geteuid ();
133 tem
= make_fixnum_or_float (euid
);
135 Vuser_full_name
= Fuser_full_name (tem
);
139 Vuser_full_name
= build_string (p
);
140 else if (NILP (Vuser_full_name
))
141 Vuser_full_name
= build_string ("unknown");
143 #ifdef HAVE_SYS_UTSNAME_H
147 Voperating_system_release
= build_string (uts
.release
);
150 Voperating_system_release
= Qnil
;
154 DEFUN ("char-to-string", Fchar_to_string
, Schar_to_string
, 1, 1, 0,
155 doc
: /* Convert arg CHAR to a string containing that character.
156 usage: (char-to-string CHAR) */)
157 (Lisp_Object character
)
160 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
162 CHECK_CHARACTER (character
);
163 c
= XFASTINT (character
);
165 len
= CHAR_STRING (c
, str
);
166 return make_string_from_bytes ((char *) str
, 1, len
);
169 DEFUN ("byte-to-string", Fbyte_to_string
, Sbyte_to_string
, 1, 1, 0,
170 doc
: /* Convert arg BYTE to a unibyte string containing that byte. */)
175 if (XINT (byte
) < 0 || XINT (byte
) > 255)
176 error ("Invalid byte");
178 return make_string_from_bytes ((char *) &b
, 1, 1);
181 DEFUN ("string-to-char", Fstring_to_char
, Sstring_to_char
, 1, 1, 0,
182 doc
: /* Return the first character in STRING. */)
183 (register Lisp_Object string
)
185 register Lisp_Object val
;
186 CHECK_STRING (string
);
189 if (STRING_MULTIBYTE (string
))
190 XSETFASTINT (val
, STRING_CHAR (SDATA (string
)));
192 XSETFASTINT (val
, SREF (string
, 0));
195 XSETFASTINT (val
, 0);
199 DEFUN ("point", Fpoint
, Spoint
, 0, 0, 0,
200 doc
: /* Return value of point, as an integer.
201 Beginning of buffer is position (point-min). */)
205 XSETFASTINT (temp
, PT
);
209 DEFUN ("point-marker", Fpoint_marker
, Spoint_marker
, 0, 0, 0,
210 doc
: /* Return value of point, as a marker object. */)
213 return build_marker (current_buffer
, PT
, PT_BYTE
);
216 DEFUN ("goto-char", Fgoto_char
, Sgoto_char
, 1, 1, "NGoto char: ",
217 doc
: /* Set point to POSITION, a number or marker.
218 Beginning of buffer is position (point-min), end is (point-max).
220 The return value is POSITION. */)
221 (register Lisp_Object position
)
225 if (MARKERP (position
)
226 && current_buffer
== XMARKER (position
)->buffer
)
228 pos
= marker_position (position
);
230 SET_PT_BOTH (BEGV
, BEGV_BYTE
);
232 SET_PT_BOTH (ZV
, ZV_BYTE
);
234 SET_PT_BOTH (pos
, marker_byte_position (position
));
239 CHECK_NUMBER_COERCE_MARKER (position
);
241 pos
= clip_to_bounds (BEGV
, XINT (position
), ZV
);
247 /* Return the start or end position of the region.
248 BEGINNINGP means return the start.
249 If there is no region active, signal an error. */
252 region_limit (bool beginningp
)
256 if (!NILP (Vtransient_mark_mode
)
257 && NILP (Vmark_even_if_inactive
)
258 && NILP (BVAR (current_buffer
, mark_active
)))
259 xsignal0 (Qmark_inactive
);
261 m
= Fmarker_position (BVAR (current_buffer
, mark
));
263 error ("The mark is not set now, so there is no region");
265 /* Clip to the current narrowing (bug#11770). */
266 return make_number ((PT
< XFASTINT (m
)) == beginningp
268 : clip_to_bounds (BEGV
, XFASTINT (m
), ZV
));
271 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
272 doc
: /* Return the integer value of point or mark, whichever is smaller. */)
275 return region_limit (1);
278 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
279 doc
: /* Return the integer value of point or mark, whichever is larger. */)
282 return region_limit (0);
285 DEFUN ("mark-marker", Fmark_marker
, Smark_marker
, 0, 0, 0,
286 doc
: /* Return this buffer's mark, as a marker object.
287 Watch out! Moving this marker changes the mark position.
288 If you set the marker not to point anywhere, the buffer will have no mark. */)
291 return BVAR (current_buffer
, mark
);
295 /* Find all the overlays in the current buffer that touch position POS.
296 Return the number found, and store them in a vector in VEC
300 overlays_around (EMACS_INT pos
, Lisp_Object
*vec
, ptrdiff_t len
)
302 Lisp_Object overlay
, start
, end
;
303 struct Lisp_Overlay
*tail
;
304 ptrdiff_t startpos
, endpos
;
307 for (tail
= current_buffer
->overlays_before
; tail
; tail
= tail
->next
)
309 XSETMISC (overlay
, tail
);
311 end
= OVERLAY_END (overlay
);
312 endpos
= OVERLAY_POSITION (end
);
315 start
= OVERLAY_START (overlay
);
316 startpos
= OVERLAY_POSITION (start
);
321 /* Keep counting overlays even if we can't return them all. */
326 for (tail
= current_buffer
->overlays_after
; tail
; tail
= tail
->next
)
328 XSETMISC (overlay
, tail
);
330 start
= OVERLAY_START (overlay
);
331 startpos
= OVERLAY_POSITION (start
);
334 end
= OVERLAY_END (overlay
);
335 endpos
= OVERLAY_POSITION (end
);
347 /* Return the value of property PROP, in OBJECT at POSITION.
348 It's the value of PROP that a char inserted at POSITION would get.
349 OBJECT is optional and defaults to the current buffer.
350 If OBJECT is a buffer, then overlay properties are considered as well as
352 If OBJECT is a window, then that window's buffer is used, but
353 window-specific overlays are considered only if they are associated
356 get_pos_property (Lisp_Object position
, register Lisp_Object prop
, Lisp_Object object
)
358 CHECK_NUMBER_COERCE_MARKER (position
);
361 XSETBUFFER (object
, current_buffer
);
362 else if (WINDOWP (object
))
363 object
= XWINDOW (object
)->buffer
;
365 if (!BUFFERP (object
))
366 /* pos-property only makes sense in buffers right now, since strings
367 have no overlays and no notion of insertion for which stickiness
369 return Fget_text_property (position
, prop
, object
);
372 EMACS_INT posn
= XINT (position
);
374 Lisp_Object
*overlay_vec
, tem
;
375 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 overlay_vec
= alloca (noverlays
* sizeof *overlay_vec
);
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. */
416 { /* Now check the text properties. */
417 int stickiness
= text_property_stickiness (prop
, position
, object
);
419 return Fget_text_property (position
, prop
, object
);
420 else if (stickiness
< 0
421 && XINT (position
) > BUF_BEGV (XBUFFER (object
)))
422 return Fget_text_property (make_number (XINT (position
) - 1),
430 /* Find the field surrounding POS in *BEG and *END. If POS is nil,
431 the value of point is used instead. If BEG or END is null,
432 means don't store the beginning or end of the field.
434 BEG_LIMIT and END_LIMIT serve to limit the ranged of the returned
435 results; they do not effect boundary behavior.
437 If MERGE_AT_BOUNDARY is non-nil, then if POS is at the very first
438 position of a field, then the beginning of the previous field is
439 returned instead of the beginning of POS's field (since the end of a
440 field is actually also the beginning of the next input field, this
441 behavior is sometimes useful). Additionally in the MERGE_AT_BOUNDARY
442 non-nil case, if two fields are separated by a field with the special
443 value `boundary', and POS lies within it, then the two separated
444 fields are considered to be adjacent, and POS between them, when
445 finding the beginning and ending of the "merged" field.
447 Either BEG or END may be 0, in which case the corresponding value
451 find_field (Lisp_Object pos
, Lisp_Object merge_at_boundary
,
452 Lisp_Object beg_limit
,
453 ptrdiff_t *beg
, Lisp_Object end_limit
, ptrdiff_t *end
)
455 /* Fields right before and after the point. */
456 Lisp_Object before_field
, after_field
;
457 /* True if POS counts as the start of a field. */
458 bool at_field_start
= 0;
459 /* True if POS counts as the end of a field. */
460 bool at_field_end
= 0;
463 XSETFASTINT (pos
, PT
);
465 CHECK_NUMBER_COERCE_MARKER (pos
);
468 = get_char_property_and_overlay (pos
, Qfield
, Qnil
, NULL
);
470 = (XFASTINT (pos
) > BEGV
471 ? get_char_property_and_overlay (make_number (XINT (pos
) - 1),
473 /* Using nil here would be a more obvious choice, but it would
474 fail when the buffer starts with a non-sticky field. */
477 /* See if we need to handle the case where MERGE_AT_BOUNDARY is nil
478 and POS is at beginning of a field, which can also be interpreted
479 as the end of the previous field. Note that the case where if
480 MERGE_AT_BOUNDARY is non-nil (see function comment) is actually the
481 more natural one; then we avoid treating the beginning of a field
483 if (NILP (merge_at_boundary
))
485 Lisp_Object field
= get_pos_property (pos
, Qfield
, Qnil
);
486 if (!EQ (field
, after_field
))
488 if (!EQ (field
, before_field
))
490 if (NILP (field
) && at_field_start
&& at_field_end
)
491 /* If an inserted char would have a nil field while the surrounding
492 text is non-nil, we're probably not looking at a
493 zero-length field, but instead at a non-nil field that's
494 not intended for editing (such as comint's prompts). */
495 at_field_end
= at_field_start
= 0;
498 /* Note about special `boundary' fields:
500 Consider the case where the point (`.') is between the fields `x' and `y':
504 In this situation, if merge_at_boundary is non-nil, consider the
505 `x' and `y' fields as forming one big merged field, and so the end
506 of the field is the end of `y'.
508 However, if `x' and `y' are separated by a special `boundary' field
509 (a field with a `field' char-property of 'boundary), then ignore
510 this special field when merging adjacent fields. Here's the same
511 situation, but with a `boundary' field between the `x' and `y' fields:
515 Here, if point is at the end of `x', the beginning of `y', or
516 anywhere in-between (within the `boundary' field), merge all
517 three fields and consider the beginning as being the beginning of
518 the `x' field, and the end as being the end of the `y' field. */
523 /* POS is at the edge of a field, and we should consider it as
524 the beginning of the following field. */
525 *beg
= XFASTINT (pos
);
527 /* Find the previous field boundary. */
530 if (!NILP (merge_at_boundary
) && EQ (before_field
, Qboundary
))
531 /* Skip a `boundary' field. */
532 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
535 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
537 *beg
= NILP (p
) ? BEGV
: XFASTINT (p
);
544 /* POS is at the edge of a field, and we should consider it as
545 the end of the previous field. */
546 *end
= XFASTINT (pos
);
548 /* Find the next field boundary. */
550 if (!NILP (merge_at_boundary
) && EQ (after_field
, Qboundary
))
551 /* Skip a `boundary' field. */
552 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
555 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
557 *end
= NILP (pos
) ? ZV
: XFASTINT (pos
);
563 DEFUN ("delete-field", Fdelete_field
, Sdelete_field
, 0, 1, 0,
564 doc
: /* Delete the field surrounding POS.
565 A field is a region of text with the same `field' property.
566 If POS is nil, the value of point is used for POS. */)
570 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
572 del_range (beg
, end
);
576 DEFUN ("field-string", Ffield_string
, Sfield_string
, 0, 1, 0,
577 doc
: /* Return the contents of the field surrounding POS as a string.
578 A field is a region of text with the same `field' property.
579 If POS is nil, the value of point is used for POS. */)
583 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
584 return make_buffer_string (beg
, end
, 1);
587 DEFUN ("field-string-no-properties", Ffield_string_no_properties
, Sfield_string_no_properties
, 0, 1, 0,
588 doc
: /* Return the contents of the field around POS, without text properties.
589 A field is a region of text with the same `field' property.
590 If POS is nil, the value of point is used for POS. */)
594 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
595 return make_buffer_string (beg
, end
, 0);
598 DEFUN ("field-beginning", Ffield_beginning
, Sfield_beginning
, 0, 3, 0,
599 doc
: /* Return the beginning of the field surrounding POS.
600 A field is a region of text with the same `field' property.
601 If POS is nil, the value of point is used for POS.
602 If ESCAPE-FROM-EDGE is non-nil and POS is at the beginning of its
603 field, then the beginning of the *previous* field is returned.
604 If LIMIT is non-nil, it is a buffer position; if the beginning of the field
605 is before LIMIT, then LIMIT will be returned instead. */)
606 (Lisp_Object pos
, Lisp_Object escape_from_edge
, Lisp_Object limit
)
609 find_field (pos
, escape_from_edge
, limit
, &beg
, Qnil
, 0);
610 return make_number (beg
);
613 DEFUN ("field-end", Ffield_end
, Sfield_end
, 0, 3, 0,
614 doc
: /* Return the end of the field surrounding POS.
615 A field is a region of text with the same `field' property.
616 If POS is nil, the value of point is used for POS.
617 If ESCAPE-FROM-EDGE is non-nil and POS is at the end of its field,
618 then the end of the *following* field is returned.
619 If LIMIT is non-nil, it is a buffer position; if the end of the field
620 is after LIMIT, then LIMIT will be returned instead. */)
621 (Lisp_Object pos
, Lisp_Object escape_from_edge
, Lisp_Object limit
)
624 find_field (pos
, escape_from_edge
, Qnil
, 0, limit
, &end
);
625 return make_number (end
);
628 DEFUN ("constrain-to-field", Fconstrain_to_field
, Sconstrain_to_field
, 2, 5, 0,
629 doc
: /* Return the position closest to NEW-POS that is in the same field as OLD-POS.
630 A field is a region of text with the same `field' property.
632 If NEW-POS is nil, then use the current point instead, and move point
633 to the resulting constrained position, in addition to returning that
636 If OLD-POS is at the boundary of two fields, then the allowable
637 positions for NEW-POS depends on the value of the optional argument
638 ESCAPE-FROM-EDGE: If ESCAPE-FROM-EDGE is nil, then NEW-POS is
639 constrained to the field that has the same `field' char-property
640 as any new characters inserted at OLD-POS, whereas if ESCAPE-FROM-EDGE
641 is non-nil, NEW-POS is constrained to the union of the two adjacent
642 fields. Additionally, if two fields are separated by another field with
643 the special value `boundary', then any point within this special field is
644 also considered to be `on the boundary'.
646 If the optional argument ONLY-IN-LINE is non-nil and constraining
647 NEW-POS would move it to a different line, NEW-POS is returned
648 unconstrained. This useful for commands that move by line, like
649 \\[next-line] or \\[beginning-of-line], which should generally respect field boundaries
650 only in the case where they can still move to the right line.
652 If the optional argument INHIBIT-CAPTURE-PROPERTY is non-nil, and OLD-POS has
653 a non-nil property of that name, then any field boundaries are ignored.
655 Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
656 (Lisp_Object new_pos
, Lisp_Object old_pos
, Lisp_Object escape_from_edge
, Lisp_Object only_in_line
, Lisp_Object inhibit_capture_property
)
658 /* If non-zero, then the original point, before re-positioning. */
659 ptrdiff_t orig_point
= 0;
661 Lisp_Object prev_old
, prev_new
;
664 /* Use the current point, and afterwards, set it. */
667 XSETFASTINT (new_pos
, PT
);
670 CHECK_NUMBER_COERCE_MARKER (new_pos
);
671 CHECK_NUMBER_COERCE_MARKER (old_pos
);
673 fwd
= (XINT (new_pos
) > XINT (old_pos
));
675 prev_old
= make_number (XINT (old_pos
) - 1);
676 prev_new
= make_number (XINT (new_pos
) - 1);
678 if (NILP (Vinhibit_field_text_motion
)
679 && !EQ (new_pos
, old_pos
)
680 && (!NILP (Fget_char_property (new_pos
, Qfield
, Qnil
))
681 || !NILP (Fget_char_property (old_pos
, Qfield
, Qnil
))
682 /* To recognize field boundaries, we must also look at the
683 previous positions; we could use `get_pos_property'
684 instead, but in itself that would fail inside non-sticky
685 fields (like comint prompts). */
686 || (XFASTINT (new_pos
) > BEGV
687 && !NILP (Fget_char_property (prev_new
, Qfield
, Qnil
)))
688 || (XFASTINT (old_pos
) > BEGV
689 && !NILP (Fget_char_property (prev_old
, Qfield
, Qnil
))))
690 && (NILP (inhibit_capture_property
)
691 /* Field boundaries are again a problem; but now we must
692 decide the case exactly, so we need to call
693 `get_pos_property' as well. */
694 || (NILP (get_pos_property (old_pos
, inhibit_capture_property
, Qnil
))
695 && (XFASTINT (old_pos
) <= BEGV
696 || NILP (Fget_char_property (old_pos
, inhibit_capture_property
, Qnil
))
697 || NILP (Fget_char_property (prev_old
, inhibit_capture_property
, Qnil
))))))
698 /* It is possible that NEW_POS is not within the same field as
699 OLD_POS; try to move NEW_POS so that it is. */
702 Lisp_Object field_bound
;
705 field_bound
= Ffield_end (old_pos
, escape_from_edge
, new_pos
);
707 field_bound
= Ffield_beginning (old_pos
, escape_from_edge
, new_pos
);
709 if (/* See if ESCAPE_FROM_EDGE caused FIELD_BOUND to jump to the
710 other side of NEW_POS, which would mean that NEW_POS is
711 already acceptable, and it's not necessary to constrain it
713 ((XFASTINT (field_bound
) < XFASTINT (new_pos
)) ? fwd
: !fwd
)
714 /* NEW_POS should be constrained, but only if either
715 ONLY_IN_LINE is nil (in which case any constraint is OK),
716 or NEW_POS and FIELD_BOUND are on the same line (in which
717 case the constraint is OK even if ONLY_IN_LINE is non-nil). */
718 && (NILP (only_in_line
)
719 /* This is the ONLY_IN_LINE case, check that NEW_POS and
720 FIELD_BOUND are on the same line by seeing whether
721 there's an intervening newline or not. */
722 || (scan_buffer ('\n',
723 XFASTINT (new_pos
), XFASTINT (field_bound
),
724 fwd
? -1 : 1, &shortage
, 1),
726 /* Constrain NEW_POS to FIELD_BOUND. */
727 new_pos
= field_bound
;
729 if (orig_point
&& XFASTINT (new_pos
) != orig_point
)
730 /* The NEW_POS argument was originally nil, so automatically set PT. */
731 SET_PT (XFASTINT (new_pos
));
738 DEFUN ("line-beginning-position",
739 Fline_beginning_position
, Sline_beginning_position
, 0, 1, 0,
740 doc
: /* Return the character position of the first character on the current line.
741 With optional argument N, scan forward N - 1 lines first.
742 If the scan reaches the end of the buffer, return that position.
744 This function ignores text display directionality; it returns the
745 position of the first character in logical order, i.e. the smallest
746 character position on the line.
748 This function constrains the returned position to the current field
749 unless that position would be on a different line than the original,
750 unconstrained result. If N is nil or 1, and a front-sticky field
751 starts at point, the scan stops as soon as it starts. To ignore field
752 boundaries, bind `inhibit-field-text-motion' to t.
754 This function does not move point. */)
757 ptrdiff_t orig
, orig_byte
, end
;
758 ptrdiff_t count
= SPECPDL_INDEX ();
759 specbind (Qinhibit_point_motion_hooks
, Qt
);
768 Fforward_line (make_number (XINT (n
) - 1));
771 SET_PT_BOTH (orig
, orig_byte
);
773 unbind_to (count
, Qnil
);
775 /* Return END constrained to the current input field. */
776 return Fconstrain_to_field (make_number (end
), make_number (orig
),
777 XINT (n
) != 1 ? Qt
: Qnil
,
781 DEFUN ("line-end-position", Fline_end_position
, Sline_end_position
, 0, 1, 0,
782 doc
: /* Return the character position of the last character on the current line.
783 With argument N not nil or 1, move forward N - 1 lines first.
784 If scan reaches end of buffer, return that position.
786 This function ignores text display directionality; it returns the
787 position of the last character in logical order, i.e. the largest
788 character position on the line.
790 This function constrains the returned position to the current field
791 unless that would be on a different line than the original,
792 unconstrained result. If N is nil or 1, and a rear-sticky field ends
793 at point, the scan stops as soon as it starts. To ignore field
794 boundaries bind `inhibit-field-text-motion' to t.
796 This function does not move point. */)
808 clipped_n
= clip_to_bounds (PTRDIFF_MIN
+ 1, XINT (n
), PTRDIFF_MAX
);
809 end_pos
= find_before_next_newline (orig
, 0, clipped_n
- (clipped_n
<= 0));
811 /* Return END_POS constrained to the current input field. */
812 return Fconstrain_to_field (make_number (end_pos
), make_number (orig
),
818 save_excursion_save (void)
820 bool visible
= (XBUFFER (XWINDOW (selected_window
)->buffer
)
822 /* Do not copy the mark if it points to nowhere. */
823 Lisp_Object mark
= (XMARKER (BVAR (current_buffer
, mark
))->buffer
824 ? Fcopy_marker (BVAR (current_buffer
, mark
), Qnil
)
827 return Fcons (Fpoint_marker (),
829 Fcons (visible
? Qt
: Qnil
,
830 Fcons (BVAR (current_buffer
, mark_active
),
835 save_excursion_restore (Lisp_Object info
)
837 Lisp_Object tem
, tem1
, omark
, nmark
;
838 struct gcpro gcpro1
, gcpro2
, gcpro3
;
841 tem
= Fmarker_buffer (XCAR (info
));
842 /* If buffer being returned to is now deleted, avoid error */
843 /* Otherwise could get error here while unwinding to top level
845 /* In that case, Fmarker_buffer returns nil now. */
849 omark
= nmark
= Qnil
;
850 GCPRO3 (info
, omark
, nmark
);
857 unchain_marker (XMARKER (tem
));
862 omark
= Fmarker_position (BVAR (current_buffer
, mark
));
864 unchain_marker (XMARKER (BVAR (current_buffer
, mark
)));
867 Fset_marker (BVAR (current_buffer
, mark
), tem
, Fcurrent_buffer ());
868 nmark
= Fmarker_position (tem
);
869 unchain_marker (XMARKER (tem
));
874 visible_p
= !NILP (XCAR (info
));
876 #if 0 /* We used to make the current buffer visible in the selected window
877 if that was true previously. That avoids some anomalies.
878 But it creates others, and it wasn't documented, and it is simpler
879 and cleaner never to alter the window/buffer connections. */
882 && current_buffer
!= XBUFFER (XWINDOW (selected_window
)->buffer
))
883 Fswitch_to_buffer (Fcurrent_buffer (), Qnil
);
889 tem1
= BVAR (current_buffer
, mark_active
);
890 bset_mark_active (current_buffer
, tem
);
892 /* If mark is active now, and either was not active
893 or was at a different place, run the activate hook. */
896 if (! EQ (omark
, nmark
))
898 tem
= intern ("activate-mark-hook");
899 Frun_hooks (1, &tem
);
902 /* If mark has ceased to be active, run deactivate hook. */
903 else if (! NILP (tem1
))
905 tem
= intern ("deactivate-mark-hook");
906 Frun_hooks (1, &tem
);
909 /* If buffer was visible in a window, and a different window was
910 selected, and the old selected window is still showing this
911 buffer, restore point in that window. */
914 && !EQ (tem
, selected_window
)
915 && (tem1
= XWINDOW (tem
)->buffer
,
916 (/* Window is live... */
918 /* ...and it shows the current buffer. */
919 && XBUFFER (tem1
) == current_buffer
)))
920 Fset_window_point (tem
, make_number (PT
));
926 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
927 doc
: /* Save point, mark, and current buffer; execute BODY; restore those things.
928 Executes BODY just like `progn'.
929 The values of point, mark and the current buffer are restored
930 even in case of abnormal exit (throw or error).
931 The state of activation of the mark is also restored.
933 This construct does not save `deactivate-mark', and therefore
934 functions that change the buffer will still cause deactivation
935 of the mark at the end of the command. To prevent that, bind
936 `deactivate-mark' with `let'.
938 If you only want to save the current buffer but not point nor mark,
939 then just use `save-current-buffer', or even `with-current-buffer'.
941 usage: (save-excursion &rest BODY) */)
944 register Lisp_Object val
;
945 ptrdiff_t count
= SPECPDL_INDEX ();
947 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
950 return unbind_to (count
, val
);
953 DEFUN ("save-current-buffer", Fsave_current_buffer
, Ssave_current_buffer
, 0, UNEVALLED
, 0,
954 doc
: /* Record which buffer is current; execute BODY; make that buffer current.
955 BODY is executed just like `progn'.
956 usage: (save-current-buffer &rest BODY) */)
959 ptrdiff_t count
= SPECPDL_INDEX ();
961 record_unwind_current_buffer ();
962 return unbind_to (count
, Fprogn (args
));
965 DEFUN ("buffer-size", Fbufsize
, Sbufsize
, 0, 1, 0,
966 doc
: /* Return the number of characters in the current buffer.
967 If BUFFER, return the number of characters in that buffer instead. */)
971 return make_number (Z
- BEG
);
974 CHECK_BUFFER (buffer
);
975 return make_number (BUF_Z (XBUFFER (buffer
))
976 - BUF_BEG (XBUFFER (buffer
)));
980 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
981 doc
: /* Return the minimum permissible value of point in the current buffer.
982 This is 1, unless narrowing (a buffer restriction) is in effect. */)
986 XSETFASTINT (temp
, BEGV
);
990 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
991 doc
: /* Return a marker to the minimum permissible value of point in this buffer.
992 This is the beginning, unless narrowing (a buffer restriction) is in effect. */)
995 return build_marker (current_buffer
, BEGV
, BEGV_BYTE
);
998 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
999 doc
: /* Return the maximum permissible value of point in the current buffer.
1000 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1001 is in effect, in which case it is less. */)
1005 XSETFASTINT (temp
, ZV
);
1009 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
1010 doc
: /* Return a marker to the maximum permissible value of point in this buffer.
1011 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1012 is in effect, in which case it is less. */)
1015 return build_marker (current_buffer
, ZV
, ZV_BYTE
);
1018 DEFUN ("gap-position", Fgap_position
, Sgap_position
, 0, 0, 0,
1019 doc
: /* Return the position of the gap, in the current buffer.
1020 See also `gap-size'. */)
1024 XSETFASTINT (temp
, GPT
);
1028 DEFUN ("gap-size", Fgap_size
, Sgap_size
, 0, 0, 0,
1029 doc
: /* Return the size of the current buffer's gap.
1030 See also `gap-position'. */)
1034 XSETFASTINT (temp
, GAP_SIZE
);
1038 DEFUN ("position-bytes", Fposition_bytes
, Sposition_bytes
, 1, 1, 0,
1039 doc
: /* Return the byte position for character position POSITION.
1040 If POSITION is out of range, the value is nil. */)
1041 (Lisp_Object position
)
1043 CHECK_NUMBER_COERCE_MARKER (position
);
1044 if (XINT (position
) < BEG
|| XINT (position
) > Z
)
1046 return make_number (CHAR_TO_BYTE (XINT (position
)));
1049 DEFUN ("byte-to-position", Fbyte_to_position
, Sbyte_to_position
, 1, 1, 0,
1050 doc
: /* Return the character position for byte position BYTEPOS.
1051 If BYTEPOS is out of range, the value is nil. */)
1052 (Lisp_Object bytepos
)
1054 CHECK_NUMBER (bytepos
);
1055 if (XINT (bytepos
) < BEG_BYTE
|| XINT (bytepos
) > Z_BYTE
)
1057 return make_number (BYTE_TO_CHAR (XINT (bytepos
)));
1060 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
1061 doc
: /* Return the character following point, as a number.
1062 At the end of the buffer or accessible region, return 0. */)
1067 XSETFASTINT (temp
, 0);
1069 XSETFASTINT (temp
, FETCH_CHAR (PT_BYTE
));
1073 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
1074 doc
: /* Return the character preceding point, as a number.
1075 At the beginning of the buffer or accessible region, return 0. */)
1080 XSETFASTINT (temp
, 0);
1081 else if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1083 ptrdiff_t pos
= PT_BYTE
;
1085 XSETFASTINT (temp
, FETCH_CHAR (pos
));
1088 XSETFASTINT (temp
, FETCH_BYTE (PT_BYTE
- 1));
1092 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
1093 doc
: /* Return t if point is at the beginning of the buffer.
1094 If the buffer is narrowed, this means the beginning of the narrowed part. */)
1102 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
1103 doc
: /* Return t if point is at the end of the buffer.
1104 If the buffer is narrowed, this means the end of the narrowed part. */)
1112 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
1113 doc
: /* Return t if point is at the beginning of a line. */)
1116 if (PT
== BEGV
|| FETCH_BYTE (PT_BYTE
- 1) == '\n')
1121 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
1122 doc
: /* Return t if point is at the end of a line.
1123 `End of a line' includes point being at the end of the buffer. */)
1126 if (PT
== ZV
|| FETCH_BYTE (PT_BYTE
) == '\n')
1131 DEFUN ("char-after", Fchar_after
, Schar_after
, 0, 1, 0,
1132 doc
: /* Return character in current buffer at position POS.
1133 POS is an integer or a marker and defaults to point.
1134 If POS is out of range, the value is nil. */)
1137 register ptrdiff_t pos_byte
;
1142 XSETFASTINT (pos
, PT
);
1147 pos_byte
= marker_byte_position (pos
);
1148 if (pos_byte
< BEGV_BYTE
|| pos_byte
>= ZV_BYTE
)
1153 CHECK_NUMBER_COERCE_MARKER (pos
);
1154 if (XINT (pos
) < BEGV
|| XINT (pos
) >= ZV
)
1157 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1160 return make_number (FETCH_CHAR (pos_byte
));
1163 DEFUN ("char-before", Fchar_before
, Schar_before
, 0, 1, 0,
1164 doc
: /* Return character in current buffer preceding position POS.
1165 POS is an integer or a marker and defaults to point.
1166 If POS is out of range, the value is nil. */)
1169 register Lisp_Object val
;
1170 register ptrdiff_t pos_byte
;
1175 XSETFASTINT (pos
, PT
);
1180 pos_byte
= marker_byte_position (pos
);
1182 if (pos_byte
<= BEGV_BYTE
|| pos_byte
> ZV_BYTE
)
1187 CHECK_NUMBER_COERCE_MARKER (pos
);
1189 if (XINT (pos
) <= BEGV
|| XINT (pos
) > ZV
)
1192 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1195 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1198 XSETFASTINT (val
, FETCH_CHAR (pos_byte
));
1203 XSETFASTINT (val
, FETCH_BYTE (pos_byte
));
1208 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 1, 0,
1209 doc
: /* Return the name under which the user logged in, as a string.
1210 This is based on the effective uid, not the real uid.
1211 Also, if the environment variables LOGNAME or USER are set,
1212 that determines the value of this function.
1214 If optional argument UID is an integer or a float, return the login name
1215 of the user with that uid, or nil if there is no such user. */)
1221 /* Set up the user name info if we didn't do it before.
1222 (That can happen if Emacs is dumpable
1223 but you decide to run `temacs -l loadup' and not dump. */
1224 if (INTEGERP (Vuser_login_name
))
1228 return Vuser_login_name
;
1230 CONS_TO_INTEGER (uid
, uid_t
, id
);
1234 return (pw
? build_string (pw
->pw_name
) : Qnil
);
1237 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
1239 doc
: /* Return the name of the user's real uid, as a string.
1240 This ignores the environment variables LOGNAME and USER, so it differs from
1241 `user-login-name' when running under `su'. */)
1244 /* Set up the user name info if we didn't do it before.
1245 (That can happen if Emacs is dumpable
1246 but you decide to run `temacs -l loadup' and not dump. */
1247 if (INTEGERP (Vuser_login_name
))
1249 return Vuser_real_login_name
;
1252 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
1253 doc
: /* Return the effective uid of Emacs.
1254 Value is an integer or a float, depending on the value. */)
1257 uid_t euid
= geteuid ();
1258 return make_fixnum_or_float (euid
);
1261 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
1262 doc
: /* Return the real uid of Emacs.
1263 Value is an integer or a float, depending on the value. */)
1266 uid_t uid
= getuid ();
1267 return make_fixnum_or_float (uid
);
1270 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 1, 0,
1271 doc
: /* Return the full name of the user logged in, as a string.
1272 If the full name corresponding to Emacs's userid is not known,
1275 If optional argument UID is an integer or float, return the full name
1276 of the user with that uid, or nil if there is no such user.
1277 If UID is a string, return the full name of the user with that login
1278 name, or nil if there is no such user. */)
1282 register char *p
, *q
;
1286 return Vuser_full_name
;
1287 else if (NUMBERP (uid
))
1290 CONS_TO_INTEGER (uid
, uid_t
, u
);
1295 else if (STRINGP (uid
))
1298 pw
= getpwnam (SSDATA (uid
));
1302 error ("Invalid UID specification");
1308 /* Chop off everything after the first comma. */
1309 q
= strchr (p
, ',');
1310 full
= make_string (p
, q
? q
- p
: strlen (p
));
1312 #ifdef AMPERSAND_FULL_NAME
1314 q
= strchr (p
, '&');
1315 /* Substitute the login name for the &, upcasing the first character. */
1321 login
= Fuser_login_name (make_number (pw
->pw_uid
));
1322 r
= alloca (strlen (p
) + SCHARS (login
) + 1);
1323 memcpy (r
, p
, q
- p
);
1325 strcat (r
, SSDATA (login
));
1326 r
[q
- p
] = upcase ((unsigned char) r
[q
- p
]);
1328 full
= build_string (r
);
1330 #endif /* AMPERSAND_FULL_NAME */
1335 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
1336 doc
: /* Return the host name of the machine you are running on, as a string. */)
1339 return Vsystem_name
;
1343 get_system_name (void)
1345 if (STRINGP (Vsystem_name
))
1346 return SSDATA (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_emacs_time ());
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_emacs_time (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 (EMACS_TIME t
)
1472 int ns
= EMACS_NSECS (t
);
1473 return make_time_tail (EMACS_SECS (t
),
1474 list2 (make_number (ns
/ 1000),
1475 make_number (ns
% 1000 * 1000)));
1478 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1479 Set *PHIGH, *PLOW, *PUSEC, *PPSEC to its parts; do not check their values.
1480 Return true if successful. */
1482 disassemble_lisp_time (Lisp_Object specified_time
, Lisp_Object
*phigh
,
1483 Lisp_Object
*plow
, Lisp_Object
*pusec
,
1486 if (CONSP (specified_time
))
1488 Lisp_Object low
= XCDR (specified_time
);
1489 Lisp_Object usec
= make_number (0);
1490 Lisp_Object psec
= make_number (0);
1493 Lisp_Object low_tail
= XCDR (low
);
1495 if (CONSP (low_tail
))
1497 usec
= XCAR (low_tail
);
1498 low_tail
= XCDR (low_tail
);
1499 if (CONSP (low_tail
))
1500 psec
= XCAR (low_tail
);
1502 else if (!NILP (low_tail
))
1506 *phigh
= XCAR (specified_time
);
1516 /* From the time components HIGH, LOW, USEC and PSEC taken from a Lisp
1517 list, generate the corresponding time value.
1519 If RESULT is not null, store into *RESULT the converted time;
1520 this can fail if the converted time does not fit into EMACS_TIME.
1521 If *DRESULT is not null, store into *DRESULT the number of
1522 seconds since the start of the POSIX Epoch.
1524 Return true if successful. */
1526 decode_time_components (Lisp_Object high
, Lisp_Object low
, Lisp_Object usec
,
1528 EMACS_TIME
*result
, double *dresult
)
1530 EMACS_INT hi
, lo
, us
, ps
;
1531 if (! (INTEGERP (high
) && INTEGERP (low
)
1532 && INTEGERP (usec
) && INTEGERP (psec
)))
1539 /* Normalize out-of-range lower-order components by carrying
1540 each overflow into the next higher-order component. */
1541 us
+= ps
/ 1000000 - (ps
% 1000000 < 0);
1542 lo
+= us
/ 1000000 - (us
% 1000000 < 0);
1544 ps
= ps
% 1000000 + 1000000 * (ps
% 1000000 < 0);
1545 us
= us
% 1000000 + 1000000 * (us
% 1000000 < 0);
1546 lo
&= (1 << 16) - 1;
1550 if ((TYPE_SIGNED (time_t) ? TIME_T_MIN
>> 16 <= hi
: 0 <= hi
)
1551 && hi
<= TIME_T_MAX
>> 16)
1553 /* Return the greatest representable time that is not greater
1554 than the requested time. */
1556 *result
= make_emacs_time ((sec
<< 16) + lo
, us
* 1000 + ps
/ 1000);
1560 /* Overflow in the highest-order component. */
1566 *dresult
= (us
* 1e6
+ ps
) / 1e12
+ lo
+ hi
* 65536.0;
1571 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1572 If SPECIFIED_TIME is nil, use the current time.
1574 Round the time down to the nearest EMACS_TIME value.
1575 Return seconds since the Epoch.
1576 Signal an error if unsuccessful. */
1578 lisp_time_argument (Lisp_Object specified_time
)
1581 if (NILP (specified_time
))
1582 t
= current_emacs_time ();
1585 Lisp_Object high
, low
, usec
, psec
;
1586 if (! (disassemble_lisp_time (specified_time
, &high
, &low
, &usec
, &psec
)
1587 && decode_time_components (high
, low
, usec
, psec
, &t
, 0)))
1588 error ("Invalid time specification");
1593 /* Like lisp_time_argument, except decode only the seconds part,
1594 do not allow out-of-range time stamps, do not check the subseconds part,
1595 and always round down. */
1597 lisp_seconds_argument (Lisp_Object specified_time
)
1599 if (NILP (specified_time
))
1603 Lisp_Object high
, low
, usec
, psec
;
1605 if (! (disassemble_lisp_time (specified_time
, &high
, &low
, &usec
, &psec
)
1606 && decode_time_components (high
, low
, make_number (0),
1607 make_number (0), &t
, 0)))
1608 error ("Invalid time specification");
1609 return EMACS_SECS (t
);
1613 DEFUN ("float-time", Ffloat_time
, Sfloat_time
, 0, 1, 0,
1614 doc
: /* Return the current time, as a float number of seconds since the epoch.
1615 If SPECIFIED-TIME is given, it is the time to convert to float
1616 instead of the current time. The argument should have the form
1617 (HIGH LOW) or (HIGH LOW USEC) or (HIGH LOW USEC PSEC). Thus,
1618 you can use times from `current-time' and from `file-attributes'.
1619 SPECIFIED-TIME can also have the form (HIGH . LOW), but this is
1620 considered obsolete.
1622 WARNING: Since the result is floating point, it may not be exact.
1623 If precise time stamps are required, use either `current-time',
1624 or (if you need time as a string) `format-time-string'. */)
1625 (Lisp_Object specified_time
)
1628 if (NILP (specified_time
))
1630 EMACS_TIME now
= current_emacs_time ();
1631 t
= EMACS_SECS (now
) + EMACS_NSECS (now
) / 1e9
;
1635 Lisp_Object high
, low
, usec
, psec
;
1636 if (! (disassemble_lisp_time (specified_time
, &high
, &low
, &usec
, &psec
)
1637 && decode_time_components (high
, low
, usec
, psec
, 0, &t
)))
1638 error ("Invalid time specification");
1640 return make_float (t
);
1643 /* Write information into buffer S of size MAXSIZE, according to the
1644 FORMAT of length FORMAT_LEN, using time information taken from *TP.
1645 Default to Universal Time if UT, local time otherwise.
1646 Use NS as the number of nanoseconds in the %N directive.
1647 Return the number of bytes written, not including the terminating
1648 '\0'. If S is NULL, nothing will be written anywhere; so to
1649 determine how many bytes would be written, use NULL for S and
1650 ((size_t) -1) for MAXSIZE.
1652 This function behaves like nstrftime, except it allows null
1653 bytes in FORMAT and it does not support nanoseconds. */
1655 emacs_nmemftime (char *s
, size_t maxsize
, const char *format
,
1656 size_t format_len
, const struct tm
*tp
, bool ut
, int ns
)
1660 /* Loop through all the null-terminated strings in the format
1661 argument. Normally there's just one null-terminated string, but
1662 there can be arbitrarily many, concatenated together, if the
1663 format contains '\0' bytes. nstrftime stops at the first
1664 '\0' byte so we must invoke it separately for each such string. */
1673 result
= nstrftime (s
, maxsize
, format
, tp
, ut
, ns
);
1677 if (result
== 0 && s
[0] != '\0')
1682 maxsize
-= result
+ 1;
1684 len
= strlen (format
);
1685 if (len
== format_len
)
1689 format_len
-= len
+ 1;
1693 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 1, 3, 0,
1694 doc
: /* Use FORMAT-STRING to format the time TIME, or now if omitted.
1695 TIME is specified as (HIGH LOW USEC PSEC), as returned by
1696 `current-time' or `file-attributes'. The obsolete form (HIGH . LOW)
1697 is also still accepted.
1698 The third, optional, argument UNIVERSAL, if non-nil, means describe TIME
1699 as Universal Time; nil means describe TIME in the local time zone.
1700 The value is a copy of FORMAT-STRING, but with certain constructs replaced
1701 by text that describes the specified date and time in TIME:
1703 %Y is the year, %y within the century, %C the century.
1704 %G is the year corresponding to the ISO week, %g within the century.
1705 %m is the numeric month.
1706 %b and %h are the locale's abbreviated month name, %B the full name.
1707 %d is the day of the month, zero-padded, %e is blank-padded.
1708 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
1709 %a is the locale's abbreviated name of the day of week, %A the full name.
1710 %U is the week number starting on Sunday, %W starting on Monday,
1711 %V according to ISO 8601.
1712 %j is the day of the year.
1714 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
1715 only blank-padded, %l is like %I blank-padded.
1716 %p is the locale's equivalent of either AM or PM.
1719 %N is the nanosecond, %6N the microsecond, %3N the millisecond, etc.
1720 %Z is the time zone name, %z is the numeric form.
1721 %s is the number of seconds since 1970-01-01 00:00:00 +0000.
1723 %c is the locale's date and time format.
1724 %x is the locale's "preferred" date format.
1725 %D is like "%m/%d/%y".
1727 %R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
1728 %X is the locale's "preferred" time format.
1730 Finally, %n is a newline, %t is a tab, %% is a literal %.
1732 Certain flags and modifiers are available with some format controls.
1733 The flags are `_', `-', `^' and `#'. For certain characters X,
1734 %_X is like %X, but padded with blanks; %-X is like %X,
1735 but without padding. %^X is like %X, but with all textual
1736 characters up-cased; %#X is like %X, but with letter-case of
1737 all textual characters reversed.
1738 %NX (where N stands for an integer) is like %X,
1739 but takes up at least N (a number) positions.
1740 The modifiers are `E' and `O'. For certain characters X,
1741 %EX is a locale's alternative version of %X;
1742 %OX is like %X, but uses the locale's number symbols.
1744 For example, to produce full ISO 8601 format, use "%Y-%m-%dT%T%z".
1746 usage: (format-time-string FORMAT-STRING &optional TIME UNIVERSAL) */)
1747 (Lisp_Object format_string
, Lisp_Object timeval
, Lisp_Object universal
)
1749 EMACS_TIME t
= lisp_time_argument (timeval
);
1752 CHECK_STRING (format_string
);
1753 format_string
= code_convert_string_norecord (format_string
,
1754 Vlocale_coding_system
, 1);
1755 return format_time_string (SSDATA (format_string
), SBYTES (format_string
),
1756 t
, ! NILP (universal
), &tm
);
1760 format_time_string (char const *format
, ptrdiff_t formatlen
,
1761 EMACS_TIME t
, bool ut
, struct tm
*tmp
)
1765 ptrdiff_t size
= sizeof buffer
;
1767 Lisp_Object bufstring
;
1768 int ns
= EMACS_NSECS (t
);
1774 time_t *taddr
= emacs_secs_addr (&t
);
1777 synchronize_system_time_locale ();
1779 tm
= ut
? gmtime (taddr
) : localtime (taddr
);
1788 len
= emacs_nmemftime (buf
, size
, format
, formatlen
, tm
, ut
, ns
);
1789 if ((0 < len
&& len
< size
) || (len
== 0 && buf
[0] == '\0'))
1792 /* Buffer was too small, so make it bigger and try again. */
1793 len
= emacs_nmemftime (NULL
, SIZE_MAX
, format
, formatlen
, tm
, ut
, ns
);
1795 if (STRING_BYTES_BOUND
<= len
)
1798 buf
= SAFE_ALLOCA (size
);
1802 bufstring
= make_unibyte_string (buf
, len
);
1804 return code_convert_string_norecord (bufstring
, Vlocale_coding_system
, 0);
1807 DEFUN ("decode-time", Fdecode_time
, Sdecode_time
, 0, 1, 0,
1808 doc
: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST ZONE).
1809 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED),
1810 as from `current-time' and `file-attributes', or nil to use the
1811 current time. The obsolete form (HIGH . LOW) is also still accepted.
1812 The list has the following nine members: SEC is an integer between 0
1813 and 60; SEC is 60 for a leap second, which only some operating systems
1814 support. MINUTE is an integer between 0 and 59. HOUR is an integer
1815 between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
1816 integer between 1 and 12. YEAR is an integer indicating the
1817 four-digit year. DOW is the day of week, an integer between 0 and 6,
1818 where 0 is Sunday. DST is t if daylight saving time is in effect,
1819 otherwise nil. ZONE is an integer indicating the number of seconds
1820 east of Greenwich. (Note that Common Lisp has different meanings for
1822 (Lisp_Object specified_time
)
1824 time_t time_spec
= lisp_seconds_argument (specified_time
);
1826 struct tm
*decoded_time
;
1827 Lisp_Object list_args
[9];
1830 decoded_time
= localtime (&time_spec
);
1832 save_tm
= *decoded_time
;
1835 && MOST_NEGATIVE_FIXNUM
- TM_YEAR_BASE
<= save_tm
.tm_year
1836 && save_tm
.tm_year
<= MOST_POSITIVE_FIXNUM
- TM_YEAR_BASE
))
1838 XSETFASTINT (list_args
[0], save_tm
.tm_sec
);
1839 XSETFASTINT (list_args
[1], save_tm
.tm_min
);
1840 XSETFASTINT (list_args
[2], save_tm
.tm_hour
);
1841 XSETFASTINT (list_args
[3], save_tm
.tm_mday
);
1842 XSETFASTINT (list_args
[4], save_tm
.tm_mon
+ 1);
1843 /* On 64-bit machines an int is narrower than EMACS_INT, thus the
1844 cast below avoids overflow in int arithmetics. */
1845 XSETINT (list_args
[5], TM_YEAR_BASE
+ (EMACS_INT
) save_tm
.tm_year
);
1846 XSETFASTINT (list_args
[6], save_tm
.tm_wday
);
1847 list_args
[7] = save_tm
.tm_isdst
? Qt
: Qnil
;
1850 decoded_time
= gmtime (&time_spec
);
1851 if (decoded_time
== 0)
1852 list_args
[8] = Qnil
;
1854 XSETINT (list_args
[8], tm_diff (&save_tm
, decoded_time
));
1856 return Flist (9, list_args
);
1859 /* Return OBJ - OFFSET, checking that OBJ is a valid fixnum and that
1860 the result is representable as an int. Assume OFFSET is small and
1863 check_tm_member (Lisp_Object obj
, int offset
)
1868 if (! (INT_MIN
+ offset
<= n
&& n
- offset
<= INT_MAX
))
1873 DEFUN ("encode-time", Fencode_time
, Sencode_time
, 6, MANY
, 0,
1874 doc
: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
1875 This is the reverse operation of `decode-time', which see.
1876 ZONE defaults to the current time zone rule. This can
1877 be a string or t (as from `set-time-zone-rule'), or it can be a list
1878 \(as from `current-time-zone') or an integer (as from `decode-time')
1879 applied without consideration for daylight saving time.
1881 You can pass more than 7 arguments; then the first six arguments
1882 are used as SECOND through YEAR, and the *last* argument is used as ZONE.
1883 The intervening arguments are ignored.
1884 This feature lets (apply 'encode-time (decode-time ...)) work.
1886 Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed;
1887 for example, a DAY of 0 means the day preceding the given month.
1888 Year numbers less than 100 are treated just like other year numbers.
1889 If you want them to stand for years in this century, you must do that yourself.
1891 Years before 1970 are not guaranteed to work. On some systems,
1892 year values as low as 1901 do work.
1894 usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
1895 (ptrdiff_t nargs
, Lisp_Object
*args
)
1899 Lisp_Object zone
= (nargs
> 6 ? args
[nargs
- 1] : Qnil
);
1901 tm
.tm_sec
= check_tm_member (args
[0], 0);
1902 tm
.tm_min
= check_tm_member (args
[1], 0);
1903 tm
.tm_hour
= check_tm_member (args
[2], 0);
1904 tm
.tm_mday
= check_tm_member (args
[3], 0);
1905 tm
.tm_mon
= check_tm_member (args
[4], 1);
1906 tm
.tm_year
= check_tm_member (args
[5], TM_YEAR_BASE
);
1914 value
= mktime (&tm
);
1920 const char *tzstring
;
1921 char **oldenv
= environ
, **newenv
;
1925 else if (STRINGP (zone
))
1926 tzstring
= SSDATA (zone
);
1927 else if (INTEGERP (zone
))
1929 EMACS_INT abszone
= eabs (XINT (zone
));
1930 EMACS_INT zone_hr
= abszone
/ (60*60);
1931 int zone_min
= (abszone
/60) % 60;
1932 int zone_sec
= abszone
% 60;
1933 sprintf (tzbuf
, "XXX%s%"pI
"d:%02d:%02d", "-" + (XINT (zone
) < 0),
1934 zone_hr
, zone_min
, zone_sec
);
1938 error ("Invalid time zone specification");
1942 /* Set TZ before calling mktime; merely adjusting mktime's returned
1943 value doesn't suffice, since that would mishandle leap seconds. */
1944 set_time_zone_rule (tzstring
);
1946 value
= mktime (&tm
);
1948 /* Restore TZ to previous value. */
1951 #ifdef LOCALTIME_CACHE
1959 if (value
== (time_t) -1)
1962 return make_time (value
);
1965 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
1966 doc
: /* Return the current local time, as a human-readable string.
1967 Programs can use this function to decode a time,
1968 since the number of columns in each field is fixed
1969 if the year is in the range 1000-9999.
1970 The format is `Sun Sep 16 01:03:52 1973'.
1971 However, see also the functions `decode-time' and `format-time-string'
1972 which provide a much more powerful and general facility.
1974 If SPECIFIED-TIME is given, it is a time to format instead of the
1975 current time. The argument should have the form (HIGH LOW . IGNORED).
1976 Thus, you can use times obtained from `current-time' and from
1977 `file-attributes'. SPECIFIED-TIME can also have the form (HIGH . LOW),
1978 but this is considered obsolete. */)
1979 (Lisp_Object specified_time
)
1981 time_t value
= lisp_seconds_argument (specified_time
);
1983 char buf
[sizeof "Mon Apr 30 12:49:17 " + INT_STRLEN_BOUND (int) + 1];
1984 int len
IF_LINT (= 0);
1986 /* Convert to a string in ctime format, except without the trailing
1987 newline, and without the 4-digit year limit. Don't use asctime
1988 or ctime, as they might dump core if the year is outside the
1989 range -999 .. 9999. */
1991 tm
= localtime (&value
);
1994 static char const wday_name
[][4] =
1995 { "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat" };
1996 static char const mon_name
[][4] =
1997 { "Jan", "Feb", "Mar", "Apr", "May", "Jun",
1998 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" };
1999 printmax_t year_base
= TM_YEAR_BASE
;
2001 len
= sprintf (buf
, "%s %s%3d %02d:%02d:%02d %"pMd
,
2002 wday_name
[tm
->tm_wday
], mon_name
[tm
->tm_mon
], tm
->tm_mday
,
2003 tm
->tm_hour
, tm
->tm_min
, tm
->tm_sec
,
2004 tm
->tm_year
+ year_base
);
2010 return make_unibyte_string (buf
, len
);
2013 /* Yield A - B, measured in seconds.
2014 This function is copied from the GNU C Library. */
2016 tm_diff (struct tm
*a
, struct tm
*b
)
2018 /* Compute intervening leap days correctly even if year is negative.
2019 Take care to avoid int overflow in leap day calculations,
2020 but it's OK to assume that A and B are close to each other. */
2021 int a4
= (a
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (a
->tm_year
& 3);
2022 int b4
= (b
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (b
->tm_year
& 3);
2023 int a100
= a4
/ 25 - (a4
% 25 < 0);
2024 int b100
= b4
/ 25 - (b4
% 25 < 0);
2025 int a400
= a100
>> 2;
2026 int b400
= b100
>> 2;
2027 int intervening_leap_days
= (a4
- b4
) - (a100
- b100
) + (a400
- b400
);
2028 int years
= a
->tm_year
- b
->tm_year
;
2029 int days
= (365 * years
+ intervening_leap_days
2030 + (a
->tm_yday
- b
->tm_yday
));
2031 return (60 * (60 * (24 * days
+ (a
->tm_hour
- b
->tm_hour
))
2032 + (a
->tm_min
- b
->tm_min
))
2033 + (a
->tm_sec
- b
->tm_sec
));
2036 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
2037 doc
: /* Return the offset and name for the local time zone.
2038 This returns a list of the form (OFFSET NAME).
2039 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
2040 A negative value means west of Greenwich.
2041 NAME is a string giving the name of the time zone.
2042 If SPECIFIED-TIME is given, the time zone offset is determined from it
2043 instead of using the current time. The argument should have the form
2044 (HIGH LOW . IGNORED). Thus, you can use times obtained from
2045 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
2046 have the form (HIGH . LOW), but this is considered obsolete.
2048 Some operating systems cannot provide all this information to Emacs;
2049 in this case, `current-time-zone' returns a list containing nil for
2050 the data it can't find. */)
2051 (Lisp_Object specified_time
)
2057 Lisp_Object zone_offset
, zone_name
;
2060 value
= make_emacs_time (lisp_seconds_argument (specified_time
), 0);
2061 zone_name
= format_time_string ("%Z", sizeof "%Z" - 1, value
, 0, &localtm
);
2063 t
= gmtime (emacs_secs_addr (&value
));
2065 offset
= tm_diff (&localtm
, t
);
2070 zone_offset
= make_number (offset
);
2071 if (SCHARS (zone_name
) == 0)
2073 /* No local time zone name is available; use "+-NNNN" instead. */
2074 int m
= offset
/ 60;
2075 int am
= offset
< 0 ? - m
: m
;
2076 char buf
[sizeof "+00" + INT_STRLEN_BOUND (int)];
2077 zone_name
= make_formatted_string (buf
, "%c%02d%02d",
2078 (offset
< 0 ? '-' : '+'),
2083 return list2 (zone_offset
, zone_name
);
2086 /* This holds the value of `environ' produced by the previous
2087 call to Fset_time_zone_rule, or 0 if Fset_time_zone_rule
2088 has never been called. */
2089 static char **environbuf
;
2091 /* This holds the startup value of the TZ environment variable so it
2092 can be restored if the user calls set-time-zone-rule with a nil
2094 static char *initial_tz
;
2096 DEFUN ("set-time-zone-rule", Fset_time_zone_rule
, Sset_time_zone_rule
, 1, 1, 0,
2097 doc
: /* Set the local time zone using TZ, a string specifying a time zone rule.
2098 If TZ is nil, use implementation-defined default time zone information.
2099 If TZ is t, use Universal Time.
2101 Instead of calling this function, you typically want (setenv "TZ" TZ).
2102 That changes both the environment of the Emacs process and the
2103 variable `process-environment', whereas `set-time-zone-rule' affects
2104 only the former. */)
2107 const char *tzstring
;
2108 char **old_environbuf
;
2110 if (! (NILP (tz
) || EQ (tz
, Qt
)))
2115 /* When called for the first time, save the original TZ. */
2116 old_environbuf
= environbuf
;
2117 if (!old_environbuf
)
2118 initial_tz
= (char *) getenv ("TZ");
2121 tzstring
= initial_tz
;
2122 else if (EQ (tz
, Qt
))
2125 tzstring
= SSDATA (tz
);
2127 set_time_zone_rule (tzstring
);
2128 environbuf
= environ
;
2132 xfree (old_environbuf
);
2136 #ifdef LOCALTIME_CACHE
2138 /* These two values are known to load tz files in buggy implementations,
2139 i.e. Solaris 1 executables running under either Solaris 1 or Solaris 2.
2140 Their values shouldn't matter in non-buggy implementations.
2141 We don't use string literals for these strings,
2142 since if a string in the environment is in readonly
2143 storage, it runs afoul of bugs in SVR4 and Solaris 2.3.
2144 See Sun bugs 1113095 and 1114114, ``Timezone routines
2145 improperly modify environment''. */
2147 static char set_time_zone_rule_tz1
[] = "TZ=GMT+0";
2148 static char set_time_zone_rule_tz2
[] = "TZ=GMT+1";
2152 /* Set the local time zone rule to TZSTRING.
2153 This allocates memory into `environ', which it is the caller's
2154 responsibility to free. */
2157 set_time_zone_rule (const char *tzstring
)
2160 char **from
, **to
, **newenv
;
2162 /* Make the ENVIRON vector longer with room for TZSTRING. */
2163 for (from
= environ
; *from
; from
++)
2165 envptrs
= from
- environ
+ 2;
2166 newenv
= to
= xmalloc (envptrs
* sizeof *newenv
2167 + (tzstring
? strlen (tzstring
) + 4 : 0));
2169 /* Add TZSTRING to the end of environ, as a value for TZ. */
2172 char *t
= (char *) (to
+ envptrs
);
2174 strcat (t
, tzstring
);
2178 /* Copy the old environ vector elements into NEWENV,
2179 but don't copy the TZ variable.
2180 So we have only one definition of TZ, which came from TZSTRING. */
2181 for (from
= environ
; *from
; from
++)
2182 if (strncmp (*from
, "TZ=", 3) != 0)
2188 /* If we do have a TZSTRING, NEWENV points to the vector slot where
2189 the TZ variable is stored. If we do not have a TZSTRING,
2190 TO points to the vector slot which has the terminating null. */
2192 #ifdef LOCALTIME_CACHE
2194 /* In SunOS 4.1.3_U1 and 4.1.4, if TZ has a value like
2195 "US/Pacific" that loads a tz file, then changes to a value like
2196 "XXX0" that does not load a tz file, and then changes back to
2197 its original value, the last change is (incorrectly) ignored.
2198 Also, if TZ changes twice in succession to values that do
2199 not load a tz file, tzset can dump core (see Sun bug#1225179).
2200 The following code works around these bugs. */
2204 /* Temporarily set TZ to a value that loads a tz file
2205 and that differs from tzstring. */
2207 *newenv
= (strcmp (tzstring
, set_time_zone_rule_tz1
+ 3) == 0
2208 ? set_time_zone_rule_tz2
: set_time_zone_rule_tz1
);
2214 /* The implied tzstring is unknown, so temporarily set TZ to
2215 two different values that each load a tz file. */
2216 *to
= set_time_zone_rule_tz1
;
2219 *to
= set_time_zone_rule_tz2
;
2224 /* Now TZ has the desired value, and tzset can be invoked safely. */
2231 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
2232 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
2233 type of object is Lisp_String). INHERIT is passed to
2234 INSERT_FROM_STRING_FUNC as the last argument. */
2237 general_insert_function (void (*insert_func
)
2238 (const char *, ptrdiff_t),
2239 void (*insert_from_string_func
)
2240 (Lisp_Object
, ptrdiff_t, ptrdiff_t,
2241 ptrdiff_t, ptrdiff_t, bool),
2242 bool inherit
, ptrdiff_t nargs
, Lisp_Object
*args
)
2247 for (argnum
= 0; argnum
< nargs
; argnum
++)
2250 if (CHARACTERP (val
))
2252 int c
= XFASTINT (val
);
2253 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2256 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2257 len
= CHAR_STRING (c
, str
);
2260 str
[0] = ASCII_CHAR_P (c
) ? c
: multibyte_char_to_unibyte (c
);
2263 (*insert_func
) ((char *) str
, len
);
2265 else if (STRINGP (val
))
2267 (*insert_from_string_func
) (val
, 0, 0,
2273 wrong_type_argument (Qchar_or_string_p
, val
);
2278 insert1 (Lisp_Object arg
)
2284 /* Callers passing one argument to Finsert need not gcpro the
2285 argument "array", since the only element of the array will
2286 not be used after calling insert or insert_from_string, so
2287 we don't care if it gets trashed. */
2289 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
2290 doc
: /* Insert the arguments, either strings or characters, at point.
2291 Point and before-insertion markers move forward to end up
2292 after the inserted text.
2293 Any other markers at the point of insertion remain before the text.
2295 If the current buffer is multibyte, unibyte strings are converted
2296 to multibyte for insertion (see `string-make-multibyte').
2297 If the current buffer is unibyte, multibyte strings are converted
2298 to unibyte for insertion (see `string-make-unibyte').
2300 When operating on binary data, it may be necessary to preserve the
2301 original bytes of a unibyte string when inserting it into a multibyte
2302 buffer; to accomplish this, apply `string-as-multibyte' to the string
2303 and insert the result.
2305 usage: (insert &rest ARGS) */)
2306 (ptrdiff_t nargs
, Lisp_Object
*args
)
2308 general_insert_function (insert
, insert_from_string
, 0, nargs
, args
);
2312 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
2314 doc
: /* Insert the arguments at point, inheriting properties from adjoining text.
2315 Point and before-insertion markers move forward to end up
2316 after the inserted text.
2317 Any other markers at the point of insertion remain before the text.
2319 If the current buffer is multibyte, unibyte strings are converted
2320 to multibyte for insertion (see `unibyte-char-to-multibyte').
2321 If the current buffer is unibyte, multibyte strings are converted
2322 to unibyte for insertion.
2324 usage: (insert-and-inherit &rest ARGS) */)
2325 (ptrdiff_t nargs
, Lisp_Object
*args
)
2327 general_insert_function (insert_and_inherit
, insert_from_string
, 1,
2332 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
2333 doc
: /* Insert strings or characters at point, relocating markers after the text.
2334 Point and markers move forward to end up after the inserted text.
2336 If the current buffer is multibyte, unibyte strings are converted
2337 to multibyte for insertion (see `unibyte-char-to-multibyte').
2338 If the current buffer is unibyte, multibyte strings are converted
2339 to unibyte for insertion.
2341 usage: (insert-before-markers &rest ARGS) */)
2342 (ptrdiff_t nargs
, Lisp_Object
*args
)
2344 general_insert_function (insert_before_markers
,
2345 insert_from_string_before_markers
, 0,
2350 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers
,
2351 Sinsert_and_inherit_before_markers
, 0, MANY
, 0,
2352 doc
: /* Insert text at point, relocating markers and inheriting properties.
2353 Point and markers move forward to end up after the inserted text.
2355 If the current buffer is multibyte, unibyte strings are converted
2356 to multibyte for insertion (see `unibyte-char-to-multibyte').
2357 If the current buffer is unibyte, multibyte strings are converted
2358 to unibyte for insertion.
2360 usage: (insert-before-markers-and-inherit &rest ARGS) */)
2361 (ptrdiff_t nargs
, Lisp_Object
*args
)
2363 general_insert_function (insert_before_markers_and_inherit
,
2364 insert_from_string_before_markers
, 1,
2369 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 1, 3,
2370 "(list (read-char-by-name \"Insert character (Unicode name or hex): \")\
2371 (prefix-numeric-value current-prefix-arg)\
2373 doc
: /* Insert COUNT copies of CHARACTER.
2374 Interactively, prompt for CHARACTER. You can specify CHARACTER in one
2377 - As its Unicode character name, e.g. \"LATIN SMALL LETTER A\".
2378 Completion is available; if you type a substring of the name
2379 preceded by an asterisk `*', Emacs shows all names which include
2380 that substring, not necessarily at the beginning of the name.
2382 - As a hexadecimal code point, e.g. 263A. Note that code points in
2383 Emacs are equivalent to Unicode up to 10FFFF (which is the limit of
2384 the Unicode code space).
2386 - As a code point with a radix specified with #, e.g. #o21430
2387 (octal), #x2318 (hex), or #10r8984 (decimal).
2389 If called interactively, COUNT is given by the prefix argument. If
2390 omitted or nil, it defaults to 1.
2392 Inserting the character(s) relocates point and before-insertion
2393 markers in the same ways as the function `insert'.
2395 The optional third argument INHERIT, if non-nil, says to inherit text
2396 properties from adjoining text, if those properties are sticky. If
2397 called interactively, INHERIT is t. */)
2398 (Lisp_Object character
, Lisp_Object count
, Lisp_Object inherit
)
2401 register ptrdiff_t n
;
2403 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2406 CHECK_CHARACTER (character
);
2408 XSETFASTINT (count
, 1);
2409 CHECK_NUMBER (count
);
2410 c
= XFASTINT (character
);
2412 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2413 len
= CHAR_STRING (c
, str
);
2415 str
[0] = c
, len
= 1;
2416 if (XINT (count
) <= 0)
2418 if (BUF_BYTES_MAX
/ len
< XINT (count
))
2420 n
= XINT (count
) * len
;
2421 stringlen
= min (n
, sizeof string
- sizeof string
% len
);
2422 for (i
= 0; i
< stringlen
; i
++)
2423 string
[i
] = str
[i
% len
];
2424 while (n
> stringlen
)
2427 if (!NILP (inherit
))
2428 insert_and_inherit (string
, stringlen
);
2430 insert (string
, stringlen
);
2433 if (!NILP (inherit
))
2434 insert_and_inherit (string
, n
);
2440 DEFUN ("insert-byte", Finsert_byte
, Sinsert_byte
, 2, 3, 0,
2441 doc
: /* Insert COUNT (second arg) copies of BYTE (first arg).
2442 Both arguments are required.
2443 BYTE is a number of the range 0..255.
2445 If BYTE is 128..255 and the current buffer is multibyte, the
2446 corresponding eight-bit character is inserted.
2448 Point, and before-insertion markers, are relocated as in the function `insert'.
2449 The optional third arg INHERIT, if non-nil, says to inherit text properties
2450 from adjoining text, if those properties are sticky. */)
2451 (Lisp_Object byte
, Lisp_Object count
, Lisp_Object inherit
)
2453 CHECK_NUMBER (byte
);
2454 if (XINT (byte
) < 0 || XINT (byte
) > 255)
2455 args_out_of_range_3 (byte
, make_number (0), make_number (255));
2456 if (XINT (byte
) >= 128
2457 && ! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2458 XSETFASTINT (byte
, BYTE8_TO_CHAR (XINT (byte
)));
2459 return Finsert_char (byte
, count
, inherit
);
2463 /* Making strings from buffer contents. */
2465 /* Return a Lisp_String containing the text of the current buffer from
2466 START to END. If text properties are in use and the current buffer
2467 has properties in the range specified, the resulting string will also
2468 have them, if PROPS is true.
2470 We don't want to use plain old make_string here, because it calls
2471 make_uninit_string, which can cause the buffer arena to be
2472 compacted. make_string has no way of knowing that the data has
2473 been moved, and thus copies the wrong data into the string. This
2474 doesn't effect most of the other users of make_string, so it should
2475 be left as is. But we should use this function when conjuring
2476 buffer substrings. */
2479 make_buffer_string (ptrdiff_t start
, ptrdiff_t end
, bool props
)
2481 ptrdiff_t start_byte
= CHAR_TO_BYTE (start
);
2482 ptrdiff_t end_byte
= CHAR_TO_BYTE (end
);
2484 return make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
);
2487 /* Return a Lisp_String containing the text of the current buffer from
2488 START / START_BYTE to END / END_BYTE.
2490 If text properties are in use and the current buffer
2491 has properties in the range specified, the resulting string will also
2492 have them, if PROPS is true.
2494 We don't want to use plain old make_string here, because it calls
2495 make_uninit_string, which can cause the buffer arena to be
2496 compacted. make_string has no way of knowing that the data has
2497 been moved, and thus copies the wrong data into the string. This
2498 doesn't effect most of the other users of make_string, so it should
2499 be left as is. But we should use this function when conjuring
2500 buffer substrings. */
2503 make_buffer_string_both (ptrdiff_t start
, ptrdiff_t start_byte
,
2504 ptrdiff_t end
, ptrdiff_t end_byte
, bool props
)
2506 Lisp_Object result
, tem
, tem1
;
2508 if (start
< GPT
&& GPT
< end
)
2511 if (! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2512 result
= make_uninit_multibyte_string (end
- start
, end_byte
- start_byte
);
2514 result
= make_uninit_string (end
- start
);
2515 memcpy (SDATA (result
), BYTE_POS_ADDR (start_byte
), end_byte
- start_byte
);
2517 /* If desired, update and copy the text properties. */
2520 update_buffer_properties (start
, end
);
2522 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
2523 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
2525 if (XINT (tem
) != end
|| !NILP (tem1
))
2526 copy_intervals_to_string (result
, current_buffer
, start
,
2533 /* Call Vbuffer_access_fontify_functions for the range START ... END
2534 in the current buffer, if necessary. */
2537 update_buffer_properties (ptrdiff_t start
, ptrdiff_t end
)
2539 /* If this buffer has some access functions,
2540 call them, specifying the range of the buffer being accessed. */
2541 if (!NILP (Vbuffer_access_fontify_functions
))
2543 Lisp_Object args
[3];
2546 args
[0] = Qbuffer_access_fontify_functions
;
2547 XSETINT (args
[1], start
);
2548 XSETINT (args
[2], end
);
2550 /* But don't call them if we can tell that the work
2551 has already been done. */
2552 if (!NILP (Vbuffer_access_fontified_property
))
2554 tem
= Ftext_property_any (args
[1], args
[2],
2555 Vbuffer_access_fontified_property
,
2558 Frun_hook_with_args (3, args
);
2561 Frun_hook_with_args (3, args
);
2565 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
2566 doc
: /* Return the contents of part of the current buffer as a string.
2567 The two arguments START and END are character positions;
2568 they can be in either order.
2569 The string returned is multibyte if the buffer is multibyte.
2571 This function copies the text properties of that part of the buffer
2572 into the result string; if you don't want the text properties,
2573 use `buffer-substring-no-properties' instead. */)
2574 (Lisp_Object start
, Lisp_Object end
)
2576 register ptrdiff_t b
, e
;
2578 validate_region (&start
, &end
);
2582 return make_buffer_string (b
, e
, 1);
2585 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties
,
2586 Sbuffer_substring_no_properties
, 2, 2, 0,
2587 doc
: /* Return the characters of part of the buffer, without the text properties.
2588 The two arguments START and END are character positions;
2589 they can be in either order. */)
2590 (Lisp_Object start
, Lisp_Object end
)
2592 register ptrdiff_t b
, e
;
2594 validate_region (&start
, &end
);
2598 return make_buffer_string (b
, e
, 0);
2601 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
2602 doc
: /* Return the contents of the current buffer as a string.
2603 If narrowing is in effect, this function returns only the visible part
2607 return make_buffer_string (BEGV
, ZV
, 1);
2610 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
2612 doc
: /* Insert before point a substring of the contents of BUFFER.
2613 BUFFER may be a buffer or a buffer name.
2614 Arguments START and END are character positions specifying the substring.
2615 They default to the values of (point-min) and (point-max) in BUFFER. */)
2616 (Lisp_Object buffer
, Lisp_Object start
, Lisp_Object end
)
2618 register EMACS_INT b
, e
, temp
;
2619 register struct buffer
*bp
, *obuf
;
2622 buf
= Fget_buffer (buffer
);
2626 if (!BUFFER_LIVE_P (bp
))
2627 error ("Selecting deleted buffer");
2633 CHECK_NUMBER_COERCE_MARKER (start
);
2640 CHECK_NUMBER_COERCE_MARKER (end
);
2645 temp
= b
, b
= e
, e
= temp
;
2647 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
2648 args_out_of_range (start
, end
);
2650 obuf
= current_buffer
;
2651 set_buffer_internal_1 (bp
);
2652 update_buffer_properties (b
, e
);
2653 set_buffer_internal_1 (obuf
);
2655 insert_from_buffer (bp
, b
, e
- b
, 0);
2659 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
2661 doc
: /* Compare two substrings of two buffers; return result as number.
2662 the value is -N if first string is less after N-1 chars,
2663 +N if first string is greater after N-1 chars, or 0 if strings match.
2664 Each substring is represented as three arguments: BUFFER, START and END.
2665 That makes six args in all, three for each substring.
2667 The value of `case-fold-search' in the current buffer
2668 determines whether case is significant or ignored. */)
2669 (Lisp_Object buffer1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object buffer2
, Lisp_Object start2
, Lisp_Object end2
)
2671 register EMACS_INT begp1
, endp1
, begp2
, endp2
, temp
;
2672 register struct buffer
*bp1
, *bp2
;
2673 register Lisp_Object trt
2674 = (!NILP (BVAR (current_buffer
, case_fold_search
))
2675 ? BVAR (current_buffer
, case_canon_table
) : Qnil
);
2676 ptrdiff_t chars
= 0;
2677 ptrdiff_t i1
, i2
, i1_byte
, i2_byte
;
2679 /* Find the first buffer and its substring. */
2682 bp1
= current_buffer
;
2686 buf1
= Fget_buffer (buffer1
);
2689 bp1
= XBUFFER (buf1
);
2690 if (!BUFFER_LIVE_P (bp1
))
2691 error ("Selecting deleted buffer");
2695 begp1
= BUF_BEGV (bp1
);
2698 CHECK_NUMBER_COERCE_MARKER (start1
);
2699 begp1
= XINT (start1
);
2702 endp1
= BUF_ZV (bp1
);
2705 CHECK_NUMBER_COERCE_MARKER (end1
);
2706 endp1
= XINT (end1
);
2710 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
2712 if (!(BUF_BEGV (bp1
) <= begp1
2714 && endp1
<= BUF_ZV (bp1
)))
2715 args_out_of_range (start1
, end1
);
2717 /* Likewise for second substring. */
2720 bp2
= current_buffer
;
2724 buf2
= Fget_buffer (buffer2
);
2727 bp2
= XBUFFER (buf2
);
2728 if (!BUFFER_LIVE_P (bp2
))
2729 error ("Selecting deleted buffer");
2733 begp2
= BUF_BEGV (bp2
);
2736 CHECK_NUMBER_COERCE_MARKER (start2
);
2737 begp2
= XINT (start2
);
2740 endp2
= BUF_ZV (bp2
);
2743 CHECK_NUMBER_COERCE_MARKER (end2
);
2744 endp2
= XINT (end2
);
2748 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
2750 if (!(BUF_BEGV (bp2
) <= begp2
2752 && endp2
<= BUF_ZV (bp2
)))
2753 args_out_of_range (start2
, end2
);
2757 i1_byte
= buf_charpos_to_bytepos (bp1
, i1
);
2758 i2_byte
= buf_charpos_to_bytepos (bp2
, i2
);
2760 while (i1
< endp1
&& i2
< endp2
)
2762 /* When we find a mismatch, we must compare the
2763 characters, not just the bytes. */
2768 if (! NILP (BVAR (bp1
, enable_multibyte_characters
)))
2770 c1
= BUF_FETCH_MULTIBYTE_CHAR (bp1
, i1_byte
);
2771 BUF_INC_POS (bp1
, i1_byte
);
2776 c1
= BUF_FETCH_BYTE (bp1
, i1
);
2777 MAKE_CHAR_MULTIBYTE (c1
);
2781 if (! NILP (BVAR (bp2
, enable_multibyte_characters
)))
2783 c2
= BUF_FETCH_MULTIBYTE_CHAR (bp2
, i2_byte
);
2784 BUF_INC_POS (bp2
, i2_byte
);
2789 c2
= BUF_FETCH_BYTE (bp2
, i2
);
2790 MAKE_CHAR_MULTIBYTE (c2
);
2796 c1
= char_table_translate (trt
, c1
);
2797 c2
= char_table_translate (trt
, c2
);
2800 return make_number (- 1 - chars
);
2802 return make_number (chars
+ 1);
2807 /* The strings match as far as they go.
2808 If one is shorter, that one is less. */
2809 if (chars
< endp1
- begp1
)
2810 return make_number (chars
+ 1);
2811 else if (chars
< endp2
- begp2
)
2812 return make_number (- chars
- 1);
2814 /* Same length too => they are equal. */
2815 return make_number (0);
2819 subst_char_in_region_unwind (Lisp_Object arg
)
2821 bset_undo_list (current_buffer
, arg
);
2826 subst_char_in_region_unwind_1 (Lisp_Object arg
)
2828 bset_filename (current_buffer
, arg
);
2832 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
2833 Ssubst_char_in_region
, 4, 5, 0,
2834 doc
: /* From START to END, replace FROMCHAR with TOCHAR each time it occurs.
2835 If optional arg NOUNDO is non-nil, don't record this change for undo
2836 and don't mark the buffer as really changed.
2837 Both characters must have the same length of multi-byte form. */)
2838 (Lisp_Object start
, Lisp_Object end
, Lisp_Object fromchar
, Lisp_Object tochar
, Lisp_Object noundo
)
2840 register ptrdiff_t pos
, pos_byte
, stop
, i
, len
, end_byte
;
2841 /* Keep track of the first change in the buffer:
2842 if 0 we haven't found it yet.
2843 if < 0 we've found it and we've run the before-change-function.
2844 if > 0 we've actually performed it and the value is its position. */
2845 ptrdiff_t changed
= 0;
2846 unsigned char fromstr
[MAX_MULTIBYTE_LENGTH
], tostr
[MAX_MULTIBYTE_LENGTH
];
2848 ptrdiff_t count
= SPECPDL_INDEX ();
2849 #define COMBINING_NO 0
2850 #define COMBINING_BEFORE 1
2851 #define COMBINING_AFTER 2
2852 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
2853 int maybe_byte_combining
= COMBINING_NO
;
2854 ptrdiff_t last_changed
= 0;
2856 = !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
2861 validate_region (&start
, &end
);
2862 CHECK_CHARACTER (fromchar
);
2863 CHECK_CHARACTER (tochar
);
2864 fromc
= XFASTINT (fromchar
);
2865 toc
= XFASTINT (tochar
);
2869 len
= CHAR_STRING (fromc
, fromstr
);
2870 if (CHAR_STRING (toc
, tostr
) != len
)
2871 error ("Characters in `subst-char-in-region' have different byte-lengths");
2872 if (!ASCII_BYTE_P (*tostr
))
2874 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
2875 complete multibyte character, it may be combined with the
2876 after bytes. If it is in the range 0xA0..0xFF, it may be
2877 combined with the before and after bytes. */
2878 if (!CHAR_HEAD_P (*tostr
))
2879 maybe_byte_combining
= COMBINING_BOTH
;
2880 else if (BYTES_BY_CHAR_HEAD (*tostr
) > len
)
2881 maybe_byte_combining
= COMBINING_AFTER
;
2892 pos_byte
= CHAR_TO_BYTE (pos
);
2893 stop
= CHAR_TO_BYTE (XINT (end
));
2896 /* If we don't want undo, turn off putting stuff on the list.
2897 That's faster than getting rid of things,
2898 and it prevents even the entry for a first change.
2899 Also inhibit locking the file. */
2900 if (!changed
&& !NILP (noundo
))
2902 record_unwind_protect (subst_char_in_region_unwind
,
2903 BVAR (current_buffer
, undo_list
));
2904 bset_undo_list (current_buffer
, Qt
);
2905 /* Don't do file-locking. */
2906 record_unwind_protect (subst_char_in_region_unwind_1
,
2907 BVAR (current_buffer
, filename
));
2908 bset_filename (current_buffer
, Qnil
);
2911 if (pos_byte
< GPT_BYTE
)
2912 stop
= min (stop
, GPT_BYTE
);
2915 ptrdiff_t pos_byte_next
= pos_byte
;
2917 if (pos_byte
>= stop
)
2919 if (pos_byte
>= end_byte
) break;
2922 p
= BYTE_POS_ADDR (pos_byte
);
2924 INC_POS (pos_byte_next
);
2927 if (pos_byte_next
- pos_byte
== len
2928 && p
[0] == fromstr
[0]
2930 || (p
[1] == fromstr
[1]
2931 && (len
== 2 || (p
[2] == fromstr
[2]
2932 && (len
== 3 || p
[3] == fromstr
[3]))))))
2935 /* We've already seen this and run the before-change-function;
2936 this time we only need to record the actual position. */
2941 modify_region (current_buffer
, pos
, XINT (end
), 0);
2943 if (! NILP (noundo
))
2945 if (MODIFF
- 1 == SAVE_MODIFF
)
2947 if (MODIFF
- 1 == BUF_AUTOSAVE_MODIFF (current_buffer
))
2948 BUF_AUTOSAVE_MODIFF (current_buffer
)++;
2951 /* The before-change-function may have moved the gap
2952 or even modified the buffer so we should start over. */
2956 /* Take care of the case where the new character
2957 combines with neighboring bytes. */
2958 if (maybe_byte_combining
2959 && (maybe_byte_combining
== COMBINING_AFTER
2960 ? (pos_byte_next
< Z_BYTE
2961 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2962 : ((pos_byte_next
< Z_BYTE
2963 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2964 || (pos_byte
> BEG_BYTE
2965 && ! ASCII_BYTE_P (FETCH_BYTE (pos_byte
- 1))))))
2967 Lisp_Object tem
, string
;
2969 struct gcpro gcpro1
;
2971 tem
= BVAR (current_buffer
, undo_list
);
2974 /* Make a multibyte string containing this single character. */
2975 string
= make_multibyte_string ((char *) tostr
, 1, len
);
2976 /* replace_range is less efficient, because it moves the gap,
2977 but it handles combining correctly. */
2978 replace_range (pos
, pos
+ 1, string
,
2980 pos_byte_next
= CHAR_TO_BYTE (pos
);
2981 if (pos_byte_next
> pos_byte
)
2982 /* Before combining happened. We should not increment
2983 POS. So, to cancel the later increment of POS,
2987 INC_POS (pos_byte_next
);
2989 if (! NILP (noundo
))
2990 bset_undo_list (current_buffer
, tem
);
2997 record_change (pos
, 1);
2998 for (i
= 0; i
< len
; i
++) *p
++ = tostr
[i
];
3000 last_changed
= pos
+ 1;
3002 pos_byte
= pos_byte_next
;
3008 signal_after_change (changed
,
3009 last_changed
- changed
, last_changed
- changed
);
3010 update_compositions (changed
, last_changed
, CHECK_ALL
);
3013 unbind_to (count
, Qnil
);
3018 static Lisp_Object
check_translation (ptrdiff_t, ptrdiff_t, ptrdiff_t,
3021 /* Helper function for Ftranslate_region_internal.
3023 Check if a character sequence at POS (POS_BYTE) matches an element
3024 of VAL. VAL is a list (([FROM-CHAR ...] . TO) ...). If a matching
3025 element is found, return it. Otherwise return Qnil. */
3028 check_translation (ptrdiff_t pos
, ptrdiff_t pos_byte
, ptrdiff_t end
,
3031 int buf_size
= 16, buf_used
= 0;
3032 int *buf
= alloca (sizeof (int) * buf_size
);
3034 for (; CONSP (val
); val
= XCDR (val
))
3043 if (! VECTORP (elt
))
3046 if (len
<= end
- pos
)
3048 for (i
= 0; i
< len
; i
++)
3052 unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
3055 if (buf_used
== buf_size
)
3060 newbuf
= alloca (sizeof (int) * buf_size
);
3061 memcpy (newbuf
, buf
, sizeof (int) * buf_used
);
3064 buf
[buf_used
++] = STRING_CHAR_AND_LENGTH (p
, len1
);
3067 if (XINT (AREF (elt
, i
)) != buf
[i
])
3078 DEFUN ("translate-region-internal", Ftranslate_region_internal
,
3079 Stranslate_region_internal
, 3, 3, 0,
3080 doc
: /* Internal use only.
3081 From START to END, translate characters according to TABLE.
3082 TABLE is a string or a char-table; the Nth character in it is the
3083 mapping for the character with code N.
3084 It returns the number of characters changed. */)
3085 (Lisp_Object start
, Lisp_Object end
, register Lisp_Object table
)
3087 register unsigned char *tt
; /* Trans table. */
3088 register int nc
; /* New character. */
3089 int cnt
; /* Number of changes made. */
3090 ptrdiff_t size
; /* Size of translate table. */
3091 ptrdiff_t pos
, pos_byte
, end_pos
;
3092 bool multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3093 bool string_multibyte
IF_LINT (= 0);
3095 validate_region (&start
, &end
);
3096 if (CHAR_TABLE_P (table
))
3098 if (! EQ (XCHAR_TABLE (table
)->purpose
, Qtranslation_table
))
3099 error ("Not a translation table");
3105 CHECK_STRING (table
);
3107 if (! multibyte
&& (SCHARS (table
) < SBYTES (table
)))
3108 table
= string_make_unibyte (table
);
3109 string_multibyte
= SCHARS (table
) < SBYTES (table
);
3110 size
= SBYTES (table
);
3115 pos_byte
= CHAR_TO_BYTE (pos
);
3116 end_pos
= XINT (end
);
3117 modify_region (current_buffer
, pos
, end_pos
, 0);
3120 for (; pos
< end_pos
; )
3122 register unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
3123 unsigned char *str
, buf
[MAX_MULTIBYTE_LENGTH
];
3129 oc
= STRING_CHAR_AND_LENGTH (p
, len
);
3136 /* Reload as signal_after_change in last iteration may GC. */
3138 if (string_multibyte
)
3140 str
= tt
+ string_char_to_byte (table
, oc
);
3141 nc
= STRING_CHAR_AND_LENGTH (str
, str_len
);
3146 if (! ASCII_BYTE_P (nc
) && multibyte
)
3148 str_len
= BYTE8_STRING (nc
, buf
);
3161 val
= CHAR_TABLE_REF (table
, oc
);
3162 if (CHARACTERP (val
))
3164 nc
= XFASTINT (val
);
3165 str_len
= CHAR_STRING (nc
, buf
);
3168 else if (VECTORP (val
) || (CONSP (val
)))
3170 /* VAL is [TO_CHAR ...] or (([FROM-CHAR ...] . TO) ...)
3171 where TO is TO-CHAR or [TO-CHAR ...]. */
3176 if (nc
!= oc
&& nc
>= 0)
3178 /* Simple one char to one char translation. */
3183 /* This is less efficient, because it moves the gap,
3184 but it should handle multibyte characters correctly. */
3185 string
= make_multibyte_string ((char *) str
, 1, str_len
);
3186 replace_range (pos
, pos
+ 1, string
, 1, 0, 1);
3191 record_change (pos
, 1);
3192 while (str_len
-- > 0)
3194 signal_after_change (pos
, 1, 1);
3195 update_compositions (pos
, pos
+ 1, CHECK_BORDER
);
3205 val
= check_translation (pos
, pos_byte
, end_pos
, val
);
3212 /* VAL is ([FROM-CHAR ...] . TO). */
3213 len
= ASIZE (XCAR (val
));
3221 string
= Fconcat (1, &val
);
3225 string
= Fmake_string (make_number (1), val
);
3227 replace_range (pos
, pos
+ len
, string
, 1, 0, 1);
3228 pos_byte
+= SBYTES (string
);
3229 pos
+= SCHARS (string
);
3230 cnt
+= SCHARS (string
);
3231 end_pos
+= SCHARS (string
) - len
;
3239 return make_number (cnt
);
3242 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
3243 doc
: /* Delete the text between START and END.
3244 If called interactively, delete the region between point and mark.
3245 This command deletes buffer text without modifying the kill ring. */)
3246 (Lisp_Object start
, Lisp_Object end
)
3248 validate_region (&start
, &end
);
3249 del_range (XINT (start
), XINT (end
));
3253 DEFUN ("delete-and-extract-region", Fdelete_and_extract_region
,
3254 Sdelete_and_extract_region
, 2, 2, 0,
3255 doc
: /* Delete the text between START and END and return it. */)
3256 (Lisp_Object start
, Lisp_Object end
)
3258 validate_region (&start
, &end
);
3259 if (XINT (start
) == XINT (end
))
3260 return empty_unibyte_string
;
3261 return del_range_1 (XINT (start
), XINT (end
), 1, 1);
3264 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
3265 doc
: /* Remove restrictions (narrowing) from current buffer.
3266 This allows the buffer's full text to be seen and edited. */)
3269 if (BEG
!= BEGV
|| Z
!= ZV
)
3270 current_buffer
->clip_changed
= 1;
3272 BEGV_BYTE
= BEG_BYTE
;
3273 SET_BUF_ZV_BOTH (current_buffer
, Z
, Z_BYTE
);
3274 /* Changing the buffer bounds invalidates any recorded current column. */
3275 invalidate_current_column ();
3279 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
3280 doc
: /* Restrict editing in this buffer to the current region.
3281 The rest of the text becomes temporarily invisible and untouchable
3282 but is not deleted; if you save the buffer in a file, the invisible
3283 text is included in the file. \\[widen] makes all visible again.
3284 See also `save-restriction'.
3286 When calling from a program, pass two arguments; positions (integers
3287 or markers) bounding the text that should remain visible. */)
3288 (register Lisp_Object start
, Lisp_Object end
)
3290 CHECK_NUMBER_COERCE_MARKER (start
);
3291 CHECK_NUMBER_COERCE_MARKER (end
);
3293 if (XINT (start
) > XINT (end
))
3296 tem
= start
; start
= end
; end
= tem
;
3299 if (!(BEG
<= XINT (start
) && XINT (start
) <= XINT (end
) && XINT (end
) <= Z
))
3300 args_out_of_range (start
, end
);
3302 if (BEGV
!= XFASTINT (start
) || ZV
!= XFASTINT (end
))
3303 current_buffer
->clip_changed
= 1;
3305 SET_BUF_BEGV (current_buffer
, XFASTINT (start
));
3306 SET_BUF_ZV (current_buffer
, XFASTINT (end
));
3307 if (PT
< XFASTINT (start
))
3308 SET_PT (XFASTINT (start
));
3309 if (PT
> XFASTINT (end
))
3310 SET_PT (XFASTINT (end
));
3311 /* Changing the buffer bounds invalidates any recorded current column. */
3312 invalidate_current_column ();
3317 save_restriction_save (void)
3319 if (BEGV
== BEG
&& ZV
== Z
)
3320 /* The common case that the buffer isn't narrowed.
3321 We return just the buffer object, which save_restriction_restore
3322 recognizes as meaning `no restriction'. */
3323 return Fcurrent_buffer ();
3325 /* We have to save a restriction, so return a pair of markers, one
3326 for the beginning and one for the end. */
3328 Lisp_Object beg
, end
;
3330 beg
= build_marker (current_buffer
, BEGV
, BEGV_BYTE
);
3331 end
= build_marker (current_buffer
, ZV
, ZV_BYTE
);
3333 /* END must move forward if text is inserted at its exact location. */
3334 XMARKER (end
)->insertion_type
= 1;
3336 return Fcons (beg
, end
);
3341 save_restriction_restore (Lisp_Object data
)
3343 struct buffer
*cur
= NULL
;
3344 struct buffer
*buf
= (CONSP (data
)
3345 ? XMARKER (XCAR (data
))->buffer
3348 if (buf
&& buf
!= current_buffer
&& !NILP (BVAR (buf
, pt_marker
)))
3349 { /* If `buf' uses markers to keep track of PT, BEGV, and ZV (as
3350 is the case if it is or has an indirect buffer), then make
3351 sure it is current before we update BEGV, so
3352 set_buffer_internal takes care of managing those markers. */
3353 cur
= current_buffer
;
3354 set_buffer_internal (buf
);
3358 /* A pair of marks bounding a saved restriction. */
3360 struct Lisp_Marker
*beg
= XMARKER (XCAR (data
));
3361 struct Lisp_Marker
*end
= XMARKER (XCDR (data
));
3362 eassert (buf
== end
->buffer
);
3364 if (buf
/* Verify marker still points to a buffer. */
3365 && (beg
->charpos
!= BUF_BEGV (buf
) || end
->charpos
!= BUF_ZV (buf
)))
3366 /* The restriction has changed from the saved one, so restore
3367 the saved restriction. */
3369 ptrdiff_t pt
= BUF_PT (buf
);
3371 SET_BUF_BEGV_BOTH (buf
, beg
->charpos
, beg
->bytepos
);
3372 SET_BUF_ZV_BOTH (buf
, end
->charpos
, end
->bytepos
);
3374 if (pt
< beg
->charpos
|| pt
> end
->charpos
)
3375 /* The point is outside the new visible range, move it inside. */
3376 SET_BUF_PT_BOTH (buf
,
3377 clip_to_bounds (beg
->charpos
, pt
, end
->charpos
),
3378 clip_to_bounds (beg
->bytepos
, BUF_PT_BYTE (buf
),
3381 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3383 /* These aren't needed anymore, so don't wait for GC. */
3384 free_marker (XCAR (data
));
3385 free_marker (XCDR (data
));
3386 free_cons (XCONS (data
));
3389 /* A buffer, which means that there was no old restriction. */
3391 if (buf
/* Verify marker still points to a buffer. */
3392 && (BUF_BEGV (buf
) != BUF_BEG (buf
) || BUF_ZV (buf
) != BUF_Z (buf
)))
3393 /* The buffer has been narrowed, get rid of the narrowing. */
3395 SET_BUF_BEGV_BOTH (buf
, BUF_BEG (buf
), BUF_BEG_BYTE (buf
));
3396 SET_BUF_ZV_BOTH (buf
, BUF_Z (buf
), BUF_Z_BYTE (buf
));
3398 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3402 /* Changing the buffer bounds invalidates any recorded current column. */
3403 invalidate_current_column ();
3406 set_buffer_internal (cur
);
3411 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
3412 doc
: /* Execute BODY, saving and restoring current buffer's restrictions.
3413 The buffer's restrictions make parts of the beginning and end invisible.
3414 \(They are set up with `narrow-to-region' and eliminated with `widen'.)
3415 This special form, `save-restriction', saves the current buffer's restrictions
3416 when it is entered, and restores them when it is exited.
3417 So any `narrow-to-region' within BODY lasts only until the end of the form.
3418 The old restrictions settings are restored
3419 even in case of abnormal exit (throw or error).
3421 The value returned is the value of the last form in BODY.
3423 Note: if you are using both `save-excursion' and `save-restriction',
3424 use `save-excursion' outermost:
3425 (save-excursion (save-restriction ...))
3427 usage: (save-restriction &rest BODY) */)
3430 register Lisp_Object val
;
3431 ptrdiff_t count
= SPECPDL_INDEX ();
3433 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
3434 val
= Fprogn (body
);
3435 return unbind_to (count
, val
);
3438 /* Buffer for the most recent text displayed by Fmessage_box. */
3439 static char *message_text
;
3441 /* Allocated length of that buffer. */
3442 static ptrdiff_t message_length
;
3444 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
3445 doc
: /* Display a message at the bottom of the screen.
3446 The message also goes into the `*Messages*' buffer.
3447 \(In keyboard macros, that's all it does.)
3450 The first argument is a format control string, and the rest are data
3451 to be formatted under control of the string. See `format' for details.
3453 Note: Use (message "%s" VALUE) to print the value of expressions and
3454 variables to avoid accidentally interpreting `%' as format specifiers.
3456 If the first argument is nil or the empty string, the function clears
3457 any existing message; this lets the minibuffer contents show. See
3458 also `current-message'.
3460 usage: (message FORMAT-STRING &rest ARGS) */)
3461 (ptrdiff_t nargs
, Lisp_Object
*args
)
3464 || (STRINGP (args
[0])
3465 && SBYTES (args
[0]) == 0))
3472 register Lisp_Object val
;
3473 val
= Fformat (nargs
, args
);
3474 message3 (val
, SBYTES (val
), STRING_MULTIBYTE (val
));
3479 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
3480 doc
: /* Display a message, in a dialog box if possible.
3481 If a dialog box is not available, use the echo area.
3482 The first argument is a format control string, and the rest are data
3483 to be formatted under control of the string. See `format' for details.
3485 If the first argument is nil or the empty string, clear any existing
3486 message; let the minibuffer contents show.
3488 usage: (message-box FORMAT-STRING &rest ARGS) */)
3489 (ptrdiff_t nargs
, Lisp_Object
*args
)
3498 register Lisp_Object val
;
3499 val
= Fformat (nargs
, args
);
3501 /* The MS-DOS frames support popup menus even though they are
3502 not FRAME_WINDOW_P. */
3503 if (FRAME_WINDOW_P (XFRAME (selected_frame
))
3504 || FRAME_MSDOS_P (XFRAME (selected_frame
)))
3506 Lisp_Object pane
, menu
;
3507 struct gcpro gcpro1
;
3508 pane
= Fcons (Fcons (build_string ("OK"), Qt
), Qnil
);
3510 menu
= Fcons (val
, pane
);
3511 Fx_popup_dialog (Qt
, menu
, Qt
);
3515 #endif /* HAVE_MENUS */
3516 /* Copy the data so that it won't move when we GC. */
3517 if (SBYTES (val
) > message_length
)
3519 ptrdiff_t new_length
= SBYTES (val
) + 80;
3520 message_text
= xrealloc (message_text
, new_length
);
3521 message_length
= new_length
;
3523 memcpy (message_text
, SDATA (val
), SBYTES (val
));
3524 message2 (message_text
, SBYTES (val
),
3525 STRING_MULTIBYTE (val
));
3530 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
3531 doc
: /* Display a message in a dialog box or in the echo area.
3532 If this command was invoked with the mouse, use a dialog box if
3533 `use-dialog-box' is non-nil.
3534 Otherwise, use the echo area.
3535 The first argument is a format control string, and the rest are data
3536 to be formatted under control of the string. See `format' for details.
3538 If the first argument is nil or the empty string, clear any existing
3539 message; let the minibuffer contents show.
3541 usage: (message-or-box FORMAT-STRING &rest ARGS) */)
3542 (ptrdiff_t nargs
, Lisp_Object
*args
)
3545 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3547 return Fmessage_box (nargs
, args
);
3549 return Fmessage (nargs
, args
);
3552 DEFUN ("current-message", Fcurrent_message
, Scurrent_message
, 0, 0, 0,
3553 doc
: /* Return the string currently displayed in the echo area, or nil if none. */)
3556 return current_message ();
3560 DEFUN ("propertize", Fpropertize
, Spropertize
, 1, MANY
, 0,
3561 doc
: /* Return a copy of STRING with text properties added.
3562 First argument is the string to copy.
3563 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
3564 properties to add to the result.
3565 usage: (propertize STRING &rest PROPERTIES) */)
3566 (ptrdiff_t nargs
, Lisp_Object
*args
)
3568 Lisp_Object properties
, string
;
3569 struct gcpro gcpro1
, gcpro2
;
3572 /* Number of args must be odd. */
3573 if ((nargs
& 1) == 0)
3574 error ("Wrong number of arguments");
3576 properties
= string
= Qnil
;
3577 GCPRO2 (properties
, string
);
3579 /* First argument must be a string. */
3580 CHECK_STRING (args
[0]);
3581 string
= Fcopy_sequence (args
[0]);
3583 for (i
= 1; i
< nargs
; i
+= 2)
3584 properties
= Fcons (args
[i
], Fcons (args
[i
+ 1], properties
));
3586 Fadd_text_properties (make_number (0),
3587 make_number (SCHARS (string
)),
3588 properties
, string
);
3589 RETURN_UNGCPRO (string
);
3592 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
3593 doc
: /* Format a string out of a format-string and arguments.
3594 The first argument is a format control string.
3595 The other arguments are substituted into it to make the result, a string.
3597 The format control string may contain %-sequences meaning to substitute
3598 the next available argument:
3600 %s means print a string argument. Actually, prints any object, with `princ'.
3601 %d means print as number in decimal (%o octal, %x hex).
3602 %X is like %x, but uses upper case.
3603 %e means print a number in exponential notation.
3604 %f means print a number in decimal-point notation.
3605 %g means print a number in exponential notation
3606 or decimal-point notation, whichever uses fewer characters.
3607 %c means print a number as a single character.
3608 %S means print any object as an s-expression (using `prin1').
3610 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
3611 Use %% to put a single % into the output.
3613 A %-sequence may contain optional flag, width, and precision
3614 specifiers, as follows:
3616 %<flags><width><precision>character
3618 where flags is [+ #-0]+, width is [0-9]+, and precision is .[0-9]+
3620 The + flag character inserts a + before any positive number, while a
3621 space inserts a space before any positive number; these flags only
3622 affect %d, %e, %f, and %g sequences, and the + flag takes precedence.
3623 The - and 0 flags affect the width specifier, as described below.
3625 The # flag means to use an alternate display form for %o, %x, %X, %e,
3626 %f, and %g sequences: for %o, it ensures that the result begins with
3627 \"0\"; for %x and %X, it prefixes the result with \"0x\" or \"0X\";
3628 for %e, %f, and %g, it causes a decimal point to be included even if
3629 the precision is zero.
3631 The width specifier supplies a lower limit for the length of the
3632 printed representation. The padding, if any, normally goes on the
3633 left, but it goes on the right if the - flag is present. The padding
3634 character is normally a space, but it is 0 if the 0 flag is present.
3635 The 0 flag is ignored if the - flag is present, or the format sequence
3636 is something other than %d, %e, %f, and %g.
3638 For %e, %f, and %g sequences, the number after the "." in the
3639 precision specifier says how many decimal places to show; if zero, the
3640 decimal point itself is omitted. For %s and %S, the precision
3641 specifier truncates the string to the given width.
3643 usage: (format STRING &rest OBJECTS) */)
3644 (ptrdiff_t nargs
, Lisp_Object
*args
)
3646 ptrdiff_t n
; /* The number of the next arg to substitute */
3647 char initial_buffer
[4000];
3648 char *buf
= initial_buffer
;
3649 ptrdiff_t bufsize
= sizeof initial_buffer
;
3650 ptrdiff_t max_bufsize
= STRING_BYTES_BOUND
+ 1;
3652 Lisp_Object buf_save_value
IF_LINT (= {0});
3653 char *format
, *end
, *format_start
;
3654 ptrdiff_t formatlen
, nchars
;
3655 /* True if the format is multibyte. */
3656 bool multibyte_format
= 0;
3657 /* True if the output should be a multibyte string,
3658 which is true if any of the inputs is one. */
3660 /* When we make a multibyte string, we must pay attention to the
3661 byte combining problem, i.e., a byte may be combined with a
3662 multibyte character of the previous string. This flag tells if we
3663 must consider such a situation or not. */
3664 bool maybe_combine_byte
;
3666 bool arg_intervals
= 0;
3669 /* discarded[I] is 1 if byte I of the format
3670 string was not copied into the output.
3671 It is 2 if byte I was not the first byte of its character. */
3674 /* Each element records, for one argument,
3675 the start and end bytepos in the output string,
3676 whether the argument has been converted to string (e.g., due to "%S"),
3677 and whether the argument is a string with intervals.
3678 info[0] is unused. Unused elements have -1 for start. */
3681 ptrdiff_t start
, end
;
3682 unsigned converted_to_string
: 1;
3683 unsigned intervals
: 1;
3686 /* It should not be necessary to GCPRO ARGS, because
3687 the caller in the interpreter should take care of that. */
3689 CHECK_STRING (args
[0]);
3690 format_start
= SSDATA (args
[0]);
3691 formatlen
= SBYTES (args
[0]);
3693 /* Allocate the info and discarded tables. */
3696 if ((SIZE_MAX
- formatlen
) / sizeof (struct info
) <= nargs
)
3697 memory_full (SIZE_MAX
);
3698 info
= SAFE_ALLOCA ((nargs
+ 1) * sizeof *info
+ formatlen
);
3699 discarded
= (char *) &info
[nargs
+ 1];
3700 for (i
= 0; i
< nargs
+ 1; i
++)
3703 info
[i
].intervals
= info
[i
].converted_to_string
= 0;
3705 memset (discarded
, 0, formatlen
);
3708 /* Try to determine whether the result should be multibyte.
3709 This is not always right; sometimes the result needs to be multibyte
3710 because of an object that we will pass through prin1,
3711 and in that case, we won't know it here. */
3712 multibyte_format
= STRING_MULTIBYTE (args
[0]);
3713 multibyte
= multibyte_format
;
3714 for (n
= 1; !multibyte
&& n
< nargs
; n
++)
3715 if (STRINGP (args
[n
]) && STRING_MULTIBYTE (args
[n
]))
3718 /* If we start out planning a unibyte result,
3719 then discover it has to be multibyte, we jump back to retry. */
3726 /* Scan the format and store result in BUF. */
3727 format
= format_start
;
3728 end
= format
+ formatlen
;
3729 maybe_combine_byte
= 0;
3731 while (format
!= end
)
3733 /* The values of N and FORMAT when the loop body is entered. */
3735 char *format0
= format
;
3737 /* Bytes needed to represent the output of this conversion. */
3738 ptrdiff_t convbytes
;
3742 /* General format specifications look like
3744 '%' [flags] [field-width] [precision] format
3749 field-width ::= [0-9]+
3750 precision ::= '.' [0-9]*
3752 If a field-width is specified, it specifies to which width
3753 the output should be padded with blanks, if the output
3754 string is shorter than field-width.
3756 If precision is specified, it specifies the number of
3757 digits to print after the '.' for floats, or the max.
3758 number of chars to print from a string. */
3760 bool minus_flag
= 0;
3762 bool space_flag
= 0;
3763 bool sharp_flag
= 0;
3765 ptrdiff_t field_width
;
3766 bool precision_given
;
3767 uintmax_t precision
= UINTMAX_MAX
;
3775 case '-': minus_flag
= 1; continue;
3776 case '+': plus_flag
= 1; continue;
3777 case ' ': space_flag
= 1; continue;
3778 case '#': sharp_flag
= 1; continue;
3779 case '0': zero_flag
= 1; continue;
3784 /* Ignore flags when sprintf ignores them. */
3785 space_flag
&= ~ plus_flag
;
3786 zero_flag
&= ~ minus_flag
;
3789 uintmax_t w
= strtoumax (format
, &num_end
, 10);
3790 if (max_bufsize
<= w
)
3794 precision_given
= *num_end
== '.';
3795 if (precision_given
)
3796 precision
= strtoumax (num_end
+ 1, &num_end
, 10);
3800 error ("Format string ends in middle of format specifier");
3802 memset (&discarded
[format0
- format_start
], 1, format
- format0
);
3803 conversion
= *format
;
3804 if (conversion
== '%')
3806 discarded
[format
- format_start
] = 1;
3811 error ("Not enough arguments for format string");
3813 /* For 'S', prin1 the argument, and then treat like 's'.
3814 For 's', princ any argument that is not a string or
3815 symbol. But don't do this conversion twice, which might
3816 happen after retrying. */
3817 if ((conversion
== 'S'
3818 || (conversion
== 's'
3819 && ! STRINGP (args
[n
]) && ! SYMBOLP (args
[n
]))))
3821 if (! info
[n
].converted_to_string
)
3823 Lisp_Object noescape
= conversion
== 'S' ? Qnil
: Qt
;
3824 args
[n
] = Fprin1_to_string (args
[n
], noescape
);
3825 info
[n
].converted_to_string
= 1;
3826 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3834 else if (conversion
== 'c')
3836 if (FLOATP (args
[n
]))
3838 double d
= XFLOAT_DATA (args
[n
]);
3839 args
[n
] = make_number (FIXNUM_OVERFLOW_P (d
) ? -1 : d
);
3842 if (INTEGERP (args
[n
]) && ! ASCII_CHAR_P (XINT (args
[n
])))
3849 args
[n
] = Fchar_to_string (args
[n
]);
3850 info
[n
].converted_to_string
= 1;
3853 if (info
[n
].converted_to_string
)
3858 if (SYMBOLP (args
[n
]))
3860 args
[n
] = SYMBOL_NAME (args
[n
]);
3861 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3868 if (conversion
== 's')
3870 /* handle case (precision[n] >= 0) */
3872 ptrdiff_t width
, padding
, nbytes
;
3873 ptrdiff_t nchars_string
;
3875 ptrdiff_t prec
= -1;
3876 if (precision_given
&& precision
<= TYPE_MAXIMUM (ptrdiff_t))
3879 /* lisp_string_width ignores a precision of 0, but GNU
3880 libc functions print 0 characters when the precision
3881 is 0. Imitate libc behavior here. Changing
3882 lisp_string_width is the right thing, and will be
3883 done, but meanwhile we work with it. */
3886 width
= nchars_string
= nbytes
= 0;
3890 width
= lisp_string_width (args
[n
], prec
, &nch
, &nby
);
3893 nchars_string
= SCHARS (args
[n
]);
3894 nbytes
= SBYTES (args
[n
]);
3898 nchars_string
= nch
;
3904 if (convbytes
&& multibyte
&& ! STRING_MULTIBYTE (args
[n
]))
3905 convbytes
= count_size_as_multibyte (SDATA (args
[n
]), nbytes
);
3907 padding
= width
< field_width
? field_width
- width
: 0;
3909 if (max_bufsize
- padding
<= convbytes
)
3911 convbytes
+= padding
;
3912 if (convbytes
<= buf
+ bufsize
- p
)
3916 memset (p
, ' ', padding
);
3923 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3924 && STRING_MULTIBYTE (args
[n
])
3925 && !CHAR_HEAD_P (SREF (args
[n
], 0)))
3926 maybe_combine_byte
= 1;
3928 p
+= copy_text (SDATA (args
[n
]), (unsigned char *) p
,
3930 STRING_MULTIBYTE (args
[n
]), multibyte
);
3932 info
[n
].start
= nchars
;
3933 nchars
+= nchars_string
;
3934 info
[n
].end
= nchars
;
3938 memset (p
, ' ', padding
);
3943 /* If this argument has text properties, record where
3944 in the result string it appears. */
3945 if (string_intervals (args
[n
]))
3946 info
[n
].intervals
= arg_intervals
= 1;
3951 else if (! (conversion
== 'c' || conversion
== 'd'
3952 || conversion
== 'e' || conversion
== 'f'
3953 || conversion
== 'g' || conversion
== 'i'
3954 || conversion
== 'o' || conversion
== 'x'
3955 || conversion
== 'X'))
3956 error ("Invalid format operation %%%c",
3957 STRING_CHAR ((unsigned char *) format
- 1));
3958 else if (! (INTEGERP (args
[n
]) || FLOATP (args
[n
])))
3959 error ("Format specifier doesn't match argument type");
3964 /* Maximum precision for a %f conversion such that the
3965 trailing output digit might be nonzero. Any precision
3966 larger than this will not yield useful information. */
3967 USEFUL_PRECISION_MAX
=
3969 * (FLT_RADIX
== 2 || FLT_RADIX
== 10 ? 1
3970 : FLT_RADIX
== 16 ? 4
3973 /* Maximum number of bytes generated by any format, if
3974 precision is no more than USEFUL_PRECISION_MAX.
3975 On all practical hosts, %f is the worst case. */
3977 sizeof "-." + (DBL_MAX_10_EXP
+ 1) + USEFUL_PRECISION_MAX
,
3979 /* Length of pM (that is, of pMd without the
3981 pMlen
= sizeof pMd
- 2
3983 verify (0 < USEFUL_PRECISION_MAX
);
3986 ptrdiff_t padding
, sprintf_bytes
;
3987 uintmax_t excess_precision
, numwidth
;
3988 uintmax_t leading_zeros
= 0, trailing_zeros
= 0;
3990 char sprintf_buf
[SPRINTF_BUFSIZE
];
3992 /* Copy of conversion specification, modified somewhat.
3993 At most three flags F can be specified at once. */
3994 char convspec
[sizeof "%FFF.*d" + pMlen
];
3996 /* Avoid undefined behavior in underlying sprintf. */
3997 if (conversion
== 'd' || conversion
== 'i')
4000 /* Create the copy of the conversion specification, with
4001 any width and precision removed, with ".*" inserted,
4002 and with pM inserted for integer formats. */
4006 *f
= '-'; f
+= minus_flag
;
4007 *f
= '+'; f
+= plus_flag
;
4008 *f
= ' '; f
+= space_flag
;
4009 *f
= '#'; f
+= sharp_flag
;
4010 *f
= '0'; f
+= zero_flag
;
4013 if (conversion
== 'd' || conversion
== 'i'
4014 || conversion
== 'o' || conversion
== 'x'
4015 || conversion
== 'X')
4017 memcpy (f
, pMd
, pMlen
);
4019 zero_flag
&= ~ precision_given
;
4026 if (precision_given
)
4027 prec
= min (precision
, USEFUL_PRECISION_MAX
);
4029 /* Use sprintf to format this number into sprintf_buf. Omit
4030 padding and excess precision, though, because sprintf limits
4031 output length to INT_MAX.
4033 There are four types of conversion: double, unsigned
4034 char (passed as int), wide signed int, and wide
4035 unsigned int. Treat them separately because the
4036 sprintf ABI is sensitive to which type is passed. Be
4037 careful about integer overflow, NaNs, infinities, and
4038 conversions; for example, the min and max macros are
4039 not suitable here. */
4040 if (conversion
== 'e' || conversion
== 'f' || conversion
== 'g')
4042 double x
= (INTEGERP (args
[n
])
4044 : XFLOAT_DATA (args
[n
]));
4045 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4047 else if (conversion
== 'c')
4049 /* Don't use sprintf here, as it might mishandle prec. */
4050 sprintf_buf
[0] = XINT (args
[n
]);
4051 sprintf_bytes
= prec
!= 0;
4053 else if (conversion
== 'd')
4055 /* For float, maybe we should use "%1.0f"
4056 instead so it also works for values outside
4057 the integer range. */
4059 if (INTEGERP (args
[n
]))
4063 double d
= XFLOAT_DATA (args
[n
]);
4066 x
= TYPE_MINIMUM (printmax_t
);
4072 x
= TYPE_MAXIMUM (printmax_t
);
4077 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4081 /* Don't sign-extend for octal or hex printing. */
4083 if (INTEGERP (args
[n
]))
4084 x
= XUINT (args
[n
]);
4087 double d
= XFLOAT_DATA (args
[n
]);
4092 x
= TYPE_MAXIMUM (uprintmax_t
);
4097 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4100 /* Now the length of the formatted item is known, except it omits
4101 padding and excess precision. Deal with excess precision
4102 first. This happens only when the format specifies
4103 ridiculously large precision. */
4104 excess_precision
= precision
- prec
;
4105 if (excess_precision
)
4107 if (conversion
== 'e' || conversion
== 'f'
4108 || conversion
== 'g')
4110 if ((conversion
== 'g' && ! sharp_flag
)
4111 || ! ('0' <= sprintf_buf
[sprintf_bytes
- 1]
4112 && sprintf_buf
[sprintf_bytes
- 1] <= '9'))
4113 excess_precision
= 0;
4116 if (conversion
== 'g')
4118 char *dot
= strchr (sprintf_buf
, '.');
4120 excess_precision
= 0;
4123 trailing_zeros
= excess_precision
;
4126 leading_zeros
= excess_precision
;
4129 /* Compute the total bytes needed for this item, including
4130 excess precision and padding. */
4131 numwidth
= sprintf_bytes
+ excess_precision
;
4132 padding
= numwidth
< field_width
? field_width
- numwidth
: 0;
4133 if (max_bufsize
- sprintf_bytes
<= excess_precision
4134 || max_bufsize
- padding
<= numwidth
)
4136 convbytes
= numwidth
+ padding
;
4138 if (convbytes
<= buf
+ bufsize
- p
)
4140 /* Copy the formatted item from sprintf_buf into buf,
4141 inserting padding and excess-precision zeros. */
4143 char *src
= sprintf_buf
;
4145 int exponent_bytes
= 0;
4146 bool signedp
= src0
== '-' || src0
== '+' || src0
== ' ';
4147 int significand_bytes
;
4149 && ((src
[signedp
] >= '0' && src
[signedp
] <= '9')
4150 || (src
[signedp
] >= 'a' && src
[signedp
] <= 'f')
4151 || (src
[signedp
] >= 'A' && src
[signedp
] <= 'F')))
4153 leading_zeros
+= padding
;
4157 if (excess_precision
4158 && (conversion
== 'e' || conversion
== 'g'))
4160 char *e
= strchr (src
, 'e');
4162 exponent_bytes
= src
+ sprintf_bytes
- e
;
4167 memset (p
, ' ', padding
);
4175 memset (p
, '0', leading_zeros
);
4177 significand_bytes
= sprintf_bytes
- signedp
- exponent_bytes
;
4178 memcpy (p
, src
, significand_bytes
);
4179 p
+= significand_bytes
;
4180 src
+= significand_bytes
;
4181 memset (p
, '0', trailing_zeros
);
4182 p
+= trailing_zeros
;
4183 memcpy (p
, src
, exponent_bytes
);
4184 p
+= exponent_bytes
;
4186 info
[n
].start
= nchars
;
4187 nchars
+= leading_zeros
+ sprintf_bytes
+ trailing_zeros
;
4188 info
[n
].end
= nchars
;
4192 memset (p
, ' ', padding
);
4204 /* Copy a single character from format to buf. */
4207 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
4209 if (multibyte_format
)
4211 /* Copy a whole multibyte character. */
4213 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
4214 && !CHAR_HEAD_P (*format
))
4215 maybe_combine_byte
= 1;
4219 while (! CHAR_HEAD_P (*format
));
4221 convbytes
= format
- src
;
4222 memset (&discarded
[src
+ 1 - format_start
], 2, convbytes
- 1);
4226 unsigned char uc
= *format
++;
4227 if (! multibyte
|| ASCII_BYTE_P (uc
))
4231 int c
= BYTE8_TO_CHAR (uc
);
4232 convbytes
= CHAR_STRING (c
, str
);
4237 if (convbytes
<= buf
+ bufsize
- p
)
4239 memcpy (p
, src
, convbytes
);
4246 /* There wasn't enough room to store this conversion or single
4247 character. CONVBYTES says how much room is needed. Allocate
4248 enough room (and then some) and do it again. */
4250 ptrdiff_t used
= p
- buf
;
4252 if (max_bufsize
- used
< convbytes
)
4254 bufsize
= used
+ convbytes
;
4255 bufsize
= bufsize
< max_bufsize
/ 2 ? bufsize
* 2 : max_bufsize
;
4257 if (buf
== initial_buffer
)
4259 buf
= xmalloc (bufsize
);
4261 buf_save_value
= make_save_value (buf
, 0);
4262 record_unwind_protect (safe_alloca_unwind
, buf_save_value
);
4263 memcpy (buf
, initial_buffer
, used
);
4266 XSAVE_VALUE (buf_save_value
)->pointer
= buf
= xrealloc (buf
, bufsize
);
4275 if (bufsize
< p
- buf
)
4278 if (maybe_combine_byte
)
4279 nchars
= multibyte_chars_in_text ((unsigned char *) buf
, p
- buf
);
4280 val
= make_specified_string (buf
, nchars
, p
- buf
, multibyte
);
4282 /* If we allocated BUF with malloc, free it too. */
4285 /* If the format string has text properties, or any of the string
4286 arguments has text properties, set up text properties of the
4289 if (string_intervals (args
[0]) || arg_intervals
)
4291 Lisp_Object len
, new_len
, props
;
4292 struct gcpro gcpro1
;
4294 /* Add text properties from the format string. */
4295 len
= make_number (SCHARS (args
[0]));
4296 props
= text_property_list (args
[0], make_number (0), len
, Qnil
);
4301 ptrdiff_t bytepos
= 0, position
= 0, translated
= 0;
4305 /* Adjust the bounds of each text property
4306 to the proper start and end in the output string. */
4308 /* Put the positions in PROPS in increasing order, so that
4309 we can do (effectively) one scan through the position
4310 space of the format string. */
4311 props
= Fnreverse (props
);
4313 /* BYTEPOS is the byte position in the format string,
4314 POSITION is the untranslated char position in it,
4315 TRANSLATED is the translated char position in BUF,
4316 and ARGN is the number of the next arg we will come to. */
4317 for (list
= props
; CONSP (list
); list
= XCDR (list
))
4324 /* First adjust the property start position. */
4325 pos
= XINT (XCAR (item
));
4327 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
4328 up to this position. */
4329 for (; position
< pos
; bytepos
++)
4331 if (! discarded
[bytepos
])
4332 position
++, translated
++;
4333 else if (discarded
[bytepos
] == 1)
4336 if (translated
== info
[argn
].start
)
4338 translated
+= info
[argn
].end
- info
[argn
].start
;
4344 XSETCAR (item
, make_number (translated
));
4346 /* Likewise adjust the property end position. */
4347 pos
= XINT (XCAR (XCDR (item
)));
4349 for (; position
< pos
; bytepos
++)
4351 if (! discarded
[bytepos
])
4352 position
++, translated
++;
4353 else if (discarded
[bytepos
] == 1)
4356 if (translated
== info
[argn
].start
)
4358 translated
+= info
[argn
].end
- info
[argn
].start
;
4364 XSETCAR (XCDR (item
), make_number (translated
));
4367 add_text_properties_from_list (val
, props
, make_number (0));
4370 /* Add text properties from arguments. */
4372 for (n
= 1; n
< nargs
; ++n
)
4373 if (info
[n
].intervals
)
4375 len
= make_number (SCHARS (args
[n
]));
4376 new_len
= make_number (info
[n
].end
- info
[n
].start
);
4377 props
= text_property_list (args
[n
], make_number (0), len
, Qnil
);
4378 props
= extend_property_ranges (props
, new_len
);
4379 /* If successive arguments have properties, be sure that
4380 the value of `composition' property be the copy. */
4381 if (n
> 1 && info
[n
- 1].end
)
4382 make_composition_value_copy (props
);
4383 add_text_properties_from_list (val
, props
,
4384 make_number (info
[n
].start
));
4394 format2 (const char *string1
, Lisp_Object arg0
, Lisp_Object arg1
)
4396 Lisp_Object args
[3];
4397 args
[0] = build_string (string1
);
4400 return Fformat (3, args
);
4403 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
4404 doc
: /* Return t if two characters match, optionally ignoring case.
4405 Both arguments must be characters (i.e. integers).
4406 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
4407 (register Lisp_Object c1
, Lisp_Object c2
)
4410 /* Check they're chars, not just integers, otherwise we could get array
4411 bounds violations in downcase. */
4412 CHECK_CHARACTER (c1
);
4413 CHECK_CHARACTER (c2
);
4415 if (XINT (c1
) == XINT (c2
))
4417 if (NILP (BVAR (current_buffer
, case_fold_search
)))
4421 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
))
4422 && ! ASCII_CHAR_P (i1
))
4424 MAKE_CHAR_MULTIBYTE (i1
);
4427 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
))
4428 && ! ASCII_CHAR_P (i2
))
4430 MAKE_CHAR_MULTIBYTE (i2
);
4432 return (downcase (i1
) == downcase (i2
) ? Qt
: Qnil
);
4435 /* Transpose the markers in two regions of the current buffer, and
4436 adjust the ones between them if necessary (i.e.: if the regions
4439 START1, END1 are the character positions of the first region.
4440 START1_BYTE, END1_BYTE are the byte positions.
4441 START2, END2 are the character positions of the second region.
4442 START2_BYTE, END2_BYTE are the byte positions.
4444 Traverses the entire marker list of the buffer to do so, adding an
4445 appropriate amount to some, subtracting from some, and leaving the
4446 rest untouched. Most of this is copied from adjust_markers in insdel.c.
4448 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
4451 transpose_markers (ptrdiff_t start1
, ptrdiff_t end1
,
4452 ptrdiff_t start2
, ptrdiff_t end2
,
4453 ptrdiff_t start1_byte
, ptrdiff_t end1_byte
,
4454 ptrdiff_t start2_byte
, ptrdiff_t end2_byte
)
4456 register ptrdiff_t amt1
, amt1_byte
, amt2
, amt2_byte
, diff
, diff_byte
, mpos
;
4457 register struct Lisp_Marker
*marker
;
4459 /* Update point as if it were a marker. */
4463 TEMP_SET_PT_BOTH (PT
+ (end2
- end1
),
4464 PT_BYTE
+ (end2_byte
- end1_byte
));
4465 else if (PT
< start2
)
4466 TEMP_SET_PT_BOTH (PT
+ (end2
- start2
) - (end1
- start1
),
4467 (PT_BYTE
+ (end2_byte
- start2_byte
)
4468 - (end1_byte
- start1_byte
)));
4470 TEMP_SET_PT_BOTH (PT
- (start2
- start1
),
4471 PT_BYTE
- (start2_byte
- start1_byte
));
4473 /* We used to adjust the endpoints here to account for the gap, but that
4474 isn't good enough. Even if we assume the caller has tried to move the
4475 gap out of our way, it might still be at start1 exactly, for example;
4476 and that places it `inside' the interval, for our purposes. The amount
4477 of adjustment is nontrivial if there's a `denormalized' marker whose
4478 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
4479 the dirty work to Fmarker_position, below. */
4481 /* The difference between the region's lengths */
4482 diff
= (end2
- start2
) - (end1
- start1
);
4483 diff_byte
= (end2_byte
- start2_byte
) - (end1_byte
- start1_byte
);
4485 /* For shifting each marker in a region by the length of the other
4486 region plus the distance between the regions. */
4487 amt1
= (end2
- start2
) + (start2
- end1
);
4488 amt2
= (end1
- start1
) + (start2
- end1
);
4489 amt1_byte
= (end2_byte
- start2_byte
) + (start2_byte
- end1_byte
);
4490 amt2_byte
= (end1_byte
- start1_byte
) + (start2_byte
- end1_byte
);
4492 for (marker
= BUF_MARKERS (current_buffer
); marker
; marker
= marker
->next
)
4494 mpos
= marker
->bytepos
;
4495 if (mpos
>= start1_byte
&& mpos
< end2_byte
)
4497 if (mpos
< end1_byte
)
4499 else if (mpos
< start2_byte
)
4503 marker
->bytepos
= mpos
;
4505 mpos
= marker
->charpos
;
4506 if (mpos
>= start1
&& mpos
< end2
)
4510 else if (mpos
< start2
)
4515 marker
->charpos
= mpos
;
4519 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
4520 doc
: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
4521 The regions should not be overlapping, because the size of the buffer is
4522 never changed in a transposition.
4524 Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
4525 any markers that happen to be located in the regions.
4527 Transposing beyond buffer boundaries is an error. */)
4528 (Lisp_Object startr1
, Lisp_Object endr1
, Lisp_Object startr2
, Lisp_Object endr2
, Lisp_Object leave_markers
)
4530 register ptrdiff_t start1
, end1
, start2
, end2
;
4531 ptrdiff_t start1_byte
, start2_byte
, len1_byte
, len2_byte
;
4532 ptrdiff_t gap
, len1
, len_mid
, len2
;
4533 unsigned char *start1_addr
, *start2_addr
, *temp
;
4535 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
, tmp_interval3
;
4538 XSETBUFFER (buf
, current_buffer
);
4539 cur_intv
= buffer_intervals (current_buffer
);
4541 validate_region (&startr1
, &endr1
);
4542 validate_region (&startr2
, &endr2
);
4544 start1
= XFASTINT (startr1
);
4545 end1
= XFASTINT (endr1
);
4546 start2
= XFASTINT (startr2
);
4547 end2
= XFASTINT (endr2
);
4550 /* Swap the regions if they're reversed. */
4553 register ptrdiff_t glumph
= start1
;
4561 len1
= end1
- start1
;
4562 len2
= end2
- start2
;
4565 error ("Transposed regions overlap");
4566 /* Nothing to change for adjacent regions with one being empty */
4567 else if ((start1
== end1
|| start2
== end2
) && end1
== start2
)
4570 /* The possibilities are:
4571 1. Adjacent (contiguous) regions, or separate but equal regions
4572 (no, really equal, in this case!), or
4573 2. Separate regions of unequal size.
4575 The worst case is usually No. 2. It means that (aside from
4576 potential need for getting the gap out of the way), there also
4577 needs to be a shifting of the text between the two regions. So
4578 if they are spread far apart, we are that much slower... sigh. */
4580 /* It must be pointed out that the really studly thing to do would
4581 be not to move the gap at all, but to leave it in place and work
4582 around it if necessary. This would be extremely efficient,
4583 especially considering that people are likely to do
4584 transpositions near where they are working interactively, which
4585 is exactly where the gap would be found. However, such code
4586 would be much harder to write and to read. So, if you are
4587 reading this comment and are feeling squirrely, by all means have
4588 a go! I just didn't feel like doing it, so I will simply move
4589 the gap the minimum distance to get it out of the way, and then
4590 deal with an unbroken array. */
4592 /* Make sure the gap won't interfere, by moving it out of the text
4593 we will operate on. */
4594 if (start1
< gap
&& gap
< end2
)
4596 if (gap
- start1
< end2
- gap
)
4602 start1_byte
= CHAR_TO_BYTE (start1
);
4603 start2_byte
= CHAR_TO_BYTE (start2
);
4604 len1_byte
= CHAR_TO_BYTE (end1
) - start1_byte
;
4605 len2_byte
= CHAR_TO_BYTE (end2
) - start2_byte
;
4607 #ifdef BYTE_COMBINING_DEBUG
4610 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4611 len2_byte
, start1
, start1_byte
)
4612 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4613 len1_byte
, end2
, start2_byte
+ len2_byte
)
4614 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4615 len1_byte
, end2
, start2_byte
+ len2_byte
))
4620 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4621 len2_byte
, start1
, start1_byte
)
4622 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4623 len1_byte
, start2
, start2_byte
)
4624 || count_combining_after (BYTE_POS_ADDR (start2_byte
),
4625 len2_byte
, end1
, start1_byte
+ len1_byte
)
4626 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4627 len1_byte
, end2
, start2_byte
+ len2_byte
))
4632 /* Hmmm... how about checking to see if the gap is large
4633 enough to use as the temporary storage? That would avoid an
4634 allocation... interesting. Later, don't fool with it now. */
4636 /* Working without memmove, for portability (sigh), so must be
4637 careful of overlapping subsections of the array... */
4639 if (end1
== start2
) /* adjacent regions */
4641 modify_region (current_buffer
, start1
, end2
, 0);
4642 record_change (start1
, len1
+ len2
);
4644 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4645 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4646 /* Don't use Fset_text_properties: that can cause GC, which can
4647 clobber objects stored in the tmp_intervals. */
4648 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4650 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4652 /* First region smaller than second. */
4653 if (len1_byte
< len2_byte
)
4657 temp
= SAFE_ALLOCA (len2_byte
);
4659 /* Don't precompute these addresses. We have to compute them
4660 at the last minute, because the relocating allocator might
4661 have moved the buffer around during the xmalloc. */
4662 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4663 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4665 memcpy (temp
, start2_addr
, len2_byte
);
4666 memcpy (start1_addr
+ len2_byte
, start1_addr
, len1_byte
);
4667 memcpy (start1_addr
, temp
, len2_byte
);
4671 /* First region not smaller than second. */
4675 temp
= SAFE_ALLOCA (len1_byte
);
4676 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4677 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4678 memcpy (temp
, start1_addr
, len1_byte
);
4679 memcpy (start1_addr
, start2_addr
, len2_byte
);
4680 memcpy (start1_addr
+ len2_byte
, temp
, len1_byte
);
4683 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
4684 len1
, current_buffer
, 0);
4685 graft_intervals_into_buffer (tmp_interval2
, start1
,
4686 len2
, current_buffer
, 0);
4687 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4688 update_compositions (start1
+ len2
, end2
, CHECK_TAIL
);
4690 /* Non-adjacent regions, because end1 != start2, bleagh... */
4693 len_mid
= start2_byte
- (start1_byte
+ len1_byte
);
4695 if (len1_byte
== len2_byte
)
4696 /* Regions are same size, though, how nice. */
4700 modify_region (current_buffer
, start1
, end1
, 0);
4701 modify_region (current_buffer
, start2
, end2
, 0);
4702 record_change (start1
, len1
);
4703 record_change (start2
, len2
);
4704 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4705 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4707 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr1
, 0);
4709 set_text_properties_1 (startr1
, endr1
, Qnil
, buf
, tmp_interval3
);
4711 tmp_interval3
= validate_interval_range (buf
, &startr2
, &endr2
, 0);
4713 set_text_properties_1 (startr2
, endr2
, Qnil
, buf
, tmp_interval3
);
4715 temp
= SAFE_ALLOCA (len1_byte
);
4716 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4717 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4718 memcpy (temp
, start1_addr
, len1_byte
);
4719 memcpy (start1_addr
, start2_addr
, len2_byte
);
4720 memcpy (start2_addr
, temp
, len1_byte
);
4723 graft_intervals_into_buffer (tmp_interval1
, start2
,
4724 len1
, current_buffer
, 0);
4725 graft_intervals_into_buffer (tmp_interval2
, start1
,
4726 len2
, current_buffer
, 0);
4729 else if (len1_byte
< len2_byte
) /* Second region larger than first */
4730 /* Non-adjacent & unequal size, area between must also be shifted. */
4734 modify_region (current_buffer
, start1
, end2
, 0);
4735 record_change (start1
, (end2
- start1
));
4736 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4737 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4738 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4740 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4742 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4744 /* holds region 2 */
4745 temp
= SAFE_ALLOCA (len2_byte
);
4746 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4747 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4748 memcpy (temp
, start2_addr
, len2_byte
);
4749 memcpy (start1_addr
+ len_mid
+ len2_byte
, start1_addr
, len1_byte
);
4750 memmove (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
4751 memcpy (start1_addr
, temp
, len2_byte
);
4754 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4755 len1
, current_buffer
, 0);
4756 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4757 len_mid
, current_buffer
, 0);
4758 graft_intervals_into_buffer (tmp_interval2
, start1
,
4759 len2
, current_buffer
, 0);
4762 /* Second region smaller than first. */
4766 record_change (start1
, (end2
- start1
));
4767 modify_region (current_buffer
, start1
, end2
, 0);
4769 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4770 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4771 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4773 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4775 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4777 /* holds region 1 */
4778 temp
= SAFE_ALLOCA (len1_byte
);
4779 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4780 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4781 memcpy (temp
, start1_addr
, len1_byte
);
4782 memcpy (start1_addr
, start2_addr
, len2_byte
);
4783 memcpy (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
4784 memcpy (start1_addr
+ len2_byte
+ len_mid
, temp
, len1_byte
);
4787 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4788 len1
, current_buffer
, 0);
4789 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4790 len_mid
, current_buffer
, 0);
4791 graft_intervals_into_buffer (tmp_interval2
, start1
,
4792 len2
, current_buffer
, 0);
4795 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4796 update_compositions (end2
- len1
, end2
, CHECK_BORDER
);
4799 /* When doing multiple transpositions, it might be nice
4800 to optimize this. Perhaps the markers in any one buffer
4801 should be organized in some sorted data tree. */
4802 if (NILP (leave_markers
))
4804 transpose_markers (start1
, end1
, start2
, end2
,
4805 start1_byte
, start1_byte
+ len1_byte
,
4806 start2_byte
, start2_byte
+ len2_byte
);
4807 fix_start_end_in_overlays (start1
, end2
);
4810 signal_after_change (start1
, end2
- start1
, end2
- start1
);
4816 syms_of_editfns (void)
4821 DEFSYM (Qbuffer_access_fontify_functions
, "buffer-access-fontify-functions");
4823 DEFVAR_LISP ("inhibit-field-text-motion", Vinhibit_field_text_motion
,
4824 doc
: /* Non-nil means text motion commands don't notice fields. */);
4825 Vinhibit_field_text_motion
= Qnil
;
4827 DEFVAR_LISP ("buffer-access-fontify-functions",
4828 Vbuffer_access_fontify_functions
,
4829 doc
: /* List of functions called by `buffer-substring' to fontify if necessary.
4830 Each function is called with two arguments which specify the range
4831 of the buffer being accessed. */);
4832 Vbuffer_access_fontify_functions
= Qnil
;
4836 obuf
= Fcurrent_buffer ();
4837 /* Do this here, because init_buffer_once is too early--it won't work. */
4838 Fset_buffer (Vprin1_to_string_buffer
);
4839 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
4840 Fset (Fmake_local_variable (intern_c_string ("buffer-access-fontify-functions")),
4845 DEFVAR_LISP ("buffer-access-fontified-property",
4846 Vbuffer_access_fontified_property
,
4847 doc
: /* Property which (if non-nil) indicates text has been fontified.
4848 `buffer-substring' need not call the `buffer-access-fontify-functions'
4849 functions if all the text being accessed has this property. */);
4850 Vbuffer_access_fontified_property
= Qnil
;
4852 DEFVAR_LISP ("system-name", Vsystem_name
,
4853 doc
: /* The host name of the machine Emacs is running on. */);
4855 DEFVAR_LISP ("user-full-name", Vuser_full_name
,
4856 doc
: /* The full name of the user logged in. */);
4858 DEFVAR_LISP ("user-login-name", Vuser_login_name
,
4859 doc
: /* The user's name, taken from environment variables if possible. */);
4861 DEFVAR_LISP ("user-real-login-name", Vuser_real_login_name
,
4862 doc
: /* The user's name, based upon the real uid only. */);
4864 DEFVAR_LISP ("operating-system-release", Voperating_system_release
,
4865 doc
: /* The release of the operating system Emacs is running on. */);
4867 defsubr (&Spropertize
);
4868 defsubr (&Schar_equal
);
4869 defsubr (&Sgoto_char
);
4870 defsubr (&Sstring_to_char
);
4871 defsubr (&Schar_to_string
);
4872 defsubr (&Sbyte_to_string
);
4873 defsubr (&Sbuffer_substring
);
4874 defsubr (&Sbuffer_substring_no_properties
);
4875 defsubr (&Sbuffer_string
);
4877 defsubr (&Spoint_marker
);
4878 defsubr (&Smark_marker
);
4880 defsubr (&Sregion_beginning
);
4881 defsubr (&Sregion_end
);
4883 DEFSYM (Qfield
, "field");
4884 DEFSYM (Qboundary
, "boundary");
4885 defsubr (&Sfield_beginning
);
4886 defsubr (&Sfield_end
);
4887 defsubr (&Sfield_string
);
4888 defsubr (&Sfield_string_no_properties
);
4889 defsubr (&Sdelete_field
);
4890 defsubr (&Sconstrain_to_field
);
4892 defsubr (&Sline_beginning_position
);
4893 defsubr (&Sline_end_position
);
4895 /* defsubr (&Smark); */
4896 /* defsubr (&Sset_mark); */
4897 defsubr (&Ssave_excursion
);
4898 defsubr (&Ssave_current_buffer
);
4900 defsubr (&Sbufsize
);
4901 defsubr (&Spoint_max
);
4902 defsubr (&Spoint_min
);
4903 defsubr (&Spoint_min_marker
);
4904 defsubr (&Spoint_max_marker
);
4905 defsubr (&Sgap_position
);
4906 defsubr (&Sgap_size
);
4907 defsubr (&Sposition_bytes
);
4908 defsubr (&Sbyte_to_position
);
4914 defsubr (&Sfollowing_char
);
4915 defsubr (&Sprevious_char
);
4916 defsubr (&Schar_after
);
4917 defsubr (&Schar_before
);
4919 defsubr (&Sinsert_before_markers
);
4920 defsubr (&Sinsert_and_inherit
);
4921 defsubr (&Sinsert_and_inherit_before_markers
);
4922 defsubr (&Sinsert_char
);
4923 defsubr (&Sinsert_byte
);
4925 defsubr (&Suser_login_name
);
4926 defsubr (&Suser_real_login_name
);
4927 defsubr (&Suser_uid
);
4928 defsubr (&Suser_real_uid
);
4929 defsubr (&Suser_full_name
);
4930 defsubr (&Semacs_pid
);
4931 defsubr (&Scurrent_time
);
4932 defsubr (&Sget_internal_run_time
);
4933 defsubr (&Sformat_time_string
);
4934 defsubr (&Sfloat_time
);
4935 defsubr (&Sdecode_time
);
4936 defsubr (&Sencode_time
);
4937 defsubr (&Scurrent_time_string
);
4938 defsubr (&Scurrent_time_zone
);
4939 defsubr (&Sset_time_zone_rule
);
4940 defsubr (&Ssystem_name
);
4941 defsubr (&Smessage
);
4942 defsubr (&Smessage_box
);
4943 defsubr (&Smessage_or_box
);
4944 defsubr (&Scurrent_message
);
4947 defsubr (&Sinsert_buffer_substring
);
4948 defsubr (&Scompare_buffer_substrings
);
4949 defsubr (&Ssubst_char_in_region
);
4950 defsubr (&Stranslate_region_internal
);
4951 defsubr (&Sdelete_region
);
4952 defsubr (&Sdelete_and_extract_region
);
4954 defsubr (&Snarrow_to_region
);
4955 defsubr (&Ssave_restriction
);
4956 defsubr (&Stranspose_regions
);