1 /* Lisp functions pertaining to editing.
3 Copyright (C) 1985-1987, 1989, 1993-2011 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software: you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation, either version 3 of the License, or
10 (at your option) any later version.
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
22 #include <sys/types.h>
32 #ifdef HAVE_SYS_UTSNAME_H
33 #include <sys/utsname.h>
38 /* systime.h includes <sys/time.h> which, on some systems, is required
39 for <sys/resource.h>; thus systime.h must be included before
43 #if defined HAVE_SYS_RESOURCE_H
44 #include <sys/resource.h>
54 #include "intervals.h"
56 #include "character.h"
60 #include "blockinput.h"
66 #ifndef USER_FULL_NAME
67 #define USER_FULL_NAME pw->pw_gecos
71 extern char **environ
;
74 #define TM_YEAR_BASE 1900
76 /* Nonzero if TM_YEAR is a struct tm's tm_year value that causes
77 asctime to have well-defined behavior. */
78 #ifndef TM_YEAR_IN_ASCTIME_RANGE
79 # define TM_YEAR_IN_ASCTIME_RANGE(tm_year) \
80 (1000 - TM_YEAR_BASE <= (tm_year) && (tm_year) <= 9999 - TM_YEAR_BASE)
84 extern Lisp_Object
w32_get_internal_run_time (void);
87 static void time_overflow (void) NO_RETURN
;
88 static int tm_diff (struct tm
*, struct tm
*);
89 static void find_field (Lisp_Object
, Lisp_Object
, Lisp_Object
,
90 EMACS_INT
*, Lisp_Object
, EMACS_INT
*);
91 static void update_buffer_properties (EMACS_INT
, EMACS_INT
);
92 static Lisp_Object
region_limit (int);
93 static size_t emacs_nmemftime (char *, size_t, const char *,
94 size_t, const struct tm
*, int, int);
95 static void general_insert_function (void (*) (const char *, EMACS_INT
),
96 void (*) (Lisp_Object
, EMACS_INT
,
99 int, size_t, Lisp_Object
*);
100 static Lisp_Object
subst_char_in_region_unwind (Lisp_Object
);
101 static Lisp_Object
subst_char_in_region_unwind_1 (Lisp_Object
);
102 static void transpose_markers (EMACS_INT
, EMACS_INT
, EMACS_INT
, EMACS_INT
,
103 EMACS_INT
, EMACS_INT
, EMACS_INT
, EMACS_INT
);
105 static Lisp_Object Qbuffer_access_fontify_functions
;
106 static Lisp_Object
Fuser_full_name (Lisp_Object
);
108 /* Symbol for the text property used to mark fields. */
112 /* A special value for Qfield properties. */
114 static Lisp_Object Qboundary
;
120 const char *user_name
;
122 struct passwd
*pw
; /* password entry for the current user */
125 /* Set up system_name even when dumping. */
129 /* Don't bother with this on initial start when just dumping out */
132 #endif /* not CANNOT_DUMP */
134 pw
= getpwuid (getuid ());
136 /* We let the real user name default to "root" because that's quite
137 accurate on MSDOG and because it lets Emacs find the init file.
138 (The DVX libraries override the Djgpp libraries here.) */
139 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "root");
141 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "unknown");
144 /* Get the effective user name, by consulting environment variables,
145 or the effective uid if those are unset. */
146 user_name
= getenv ("LOGNAME");
149 user_name
= getenv ("USERNAME"); /* it's USERNAME on NT */
150 #else /* WINDOWSNT */
151 user_name
= getenv ("USER");
152 #endif /* WINDOWSNT */
155 pw
= getpwuid (geteuid ());
156 user_name
= pw
? pw
->pw_name
: "unknown";
158 Vuser_login_name
= build_string (user_name
);
160 /* If the user name claimed in the environment vars differs from
161 the real uid, use the claimed name to find the full name. */
162 tem
= Fstring_equal (Vuser_login_name
, Vuser_real_login_name
);
163 Vuser_full_name
= Fuser_full_name (NILP (tem
)? make_number (geteuid())
168 Vuser_full_name
= build_string (p
);
169 else if (NILP (Vuser_full_name
))
170 Vuser_full_name
= build_string ("unknown");
172 #ifdef HAVE_SYS_UTSNAME_H
176 Voperating_system_release
= build_string (uts
.release
);
179 Voperating_system_release
= Qnil
;
183 DEFUN ("char-to-string", Fchar_to_string
, Schar_to_string
, 1, 1, 0,
184 doc
: /* Convert arg CHAR to a string containing that character.
185 usage: (char-to-string CHAR) */)
186 (Lisp_Object character
)
189 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
191 CHECK_CHARACTER (character
);
192 c
= XFASTINT (character
);
194 len
= CHAR_STRING (c
, str
);
195 return make_string_from_bytes ((char *) str
, 1, len
);
198 DEFUN ("byte-to-string", Fbyte_to_string
, Sbyte_to_string
, 1, 1, 0,
199 doc
: /* Convert arg BYTE to a unibyte string containing that byte. */)
204 if (XINT (byte
) < 0 || XINT (byte
) > 255)
205 error ("Invalid byte");
207 return make_string_from_bytes ((char *) &b
, 1, 1);
210 DEFUN ("string-to-char", Fstring_to_char
, Sstring_to_char
, 1, 1, 0,
211 doc
: /* Convert arg STRING to a character, the first character of that string.
212 A multibyte character is handled correctly. */)
213 (register Lisp_Object string
)
215 register Lisp_Object val
;
216 CHECK_STRING (string
);
219 if (STRING_MULTIBYTE (string
))
220 XSETFASTINT (val
, STRING_CHAR (SDATA (string
)));
222 XSETFASTINT (val
, SREF (string
, 0));
225 XSETFASTINT (val
, 0);
230 buildmark (EMACS_INT charpos
, EMACS_INT bytepos
)
232 register Lisp_Object mark
;
233 mark
= Fmake_marker ();
234 set_marker_both (mark
, Qnil
, charpos
, bytepos
);
238 DEFUN ("point", Fpoint
, Spoint
, 0, 0, 0,
239 doc
: /* Return value of point, as an integer.
240 Beginning of buffer is position (point-min). */)
244 XSETFASTINT (temp
, PT
);
248 DEFUN ("point-marker", Fpoint_marker
, Spoint_marker
, 0, 0, 0,
249 doc
: /* Return value of point, as a marker object. */)
252 return buildmark (PT
, PT_BYTE
);
256 clip_to_bounds (EMACS_INT lower
, EMACS_INT num
, EMACS_INT upper
)
260 else if (num
> upper
)
266 DEFUN ("goto-char", Fgoto_char
, Sgoto_char
, 1, 1, "NGoto char: ",
267 doc
: /* Set point to POSITION, a number or marker.
268 Beginning of buffer is position (point-min), end is (point-max).
270 The return value is POSITION. */)
271 (register Lisp_Object position
)
275 if (MARKERP (position
)
276 && current_buffer
== XMARKER (position
)->buffer
)
278 pos
= marker_position (position
);
280 SET_PT_BOTH (BEGV
, BEGV_BYTE
);
282 SET_PT_BOTH (ZV
, ZV_BYTE
);
284 SET_PT_BOTH (pos
, marker_byte_position (position
));
289 CHECK_NUMBER_COERCE_MARKER (position
);
291 pos
= clip_to_bounds (BEGV
, XINT (position
), ZV
);
297 /* Return the start or end position of the region.
298 BEGINNINGP non-zero means return the start.
299 If there is no region active, signal an error. */
302 region_limit (int beginningp
)
306 if (!NILP (Vtransient_mark_mode
)
307 && NILP (Vmark_even_if_inactive
)
308 && NILP (BVAR (current_buffer
, mark_active
)))
309 xsignal0 (Qmark_inactive
);
311 m
= Fmarker_position (BVAR (current_buffer
, mark
));
313 error ("The mark is not set now, so there is no region");
315 if ((PT
< XFASTINT (m
)) == (beginningp
!= 0))
316 m
= make_number (PT
);
320 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
321 doc
: /* Return the integer value of point or mark, whichever is smaller. */)
324 return region_limit (1);
327 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
328 doc
: /* Return the integer value of point or mark, whichever is larger. */)
331 return region_limit (0);
334 DEFUN ("mark-marker", Fmark_marker
, Smark_marker
, 0, 0, 0,
335 doc
: /* Return this buffer's mark, as a marker object.
336 Watch out! Moving this marker changes the mark position.
337 If you set the marker not to point anywhere, the buffer will have no mark. */)
340 return BVAR (current_buffer
, mark
);
344 /* Find all the overlays in the current buffer that touch position POS.
345 Return the number found, and store them in a vector in VEC
349 overlays_around (EMACS_INT pos
, Lisp_Object
*vec
, int len
)
351 Lisp_Object overlay
, start
, end
;
352 struct Lisp_Overlay
*tail
;
353 EMACS_INT startpos
, endpos
;
356 for (tail
= current_buffer
->overlays_before
; tail
; tail
= tail
->next
)
358 XSETMISC (overlay
, tail
);
360 end
= OVERLAY_END (overlay
);
361 endpos
= OVERLAY_POSITION (end
);
364 start
= OVERLAY_START (overlay
);
365 startpos
= OVERLAY_POSITION (start
);
370 /* Keep counting overlays even if we can't return them all. */
375 for (tail
= current_buffer
->overlays_after
; tail
; tail
= tail
->next
)
377 XSETMISC (overlay
, tail
);
379 start
= OVERLAY_START (overlay
);
380 startpos
= OVERLAY_POSITION (start
);
383 end
= OVERLAY_END (overlay
);
384 endpos
= OVERLAY_POSITION (end
);
396 /* Return the value of property PROP, in OBJECT at POSITION.
397 It's the value of PROP that a char inserted at POSITION would get.
398 OBJECT is optional and defaults to the current buffer.
399 If OBJECT is a buffer, then overlay properties are considered as well as
401 If OBJECT is a window, then that window's buffer is used, but
402 window-specific overlays are considered only if they are associated
405 get_pos_property (Lisp_Object position
, register Lisp_Object prop
, Lisp_Object object
)
407 CHECK_NUMBER_COERCE_MARKER (position
);
410 XSETBUFFER (object
, current_buffer
);
411 else if (WINDOWP (object
))
412 object
= XWINDOW (object
)->buffer
;
414 if (!BUFFERP (object
))
415 /* pos-property only makes sense in buffers right now, since strings
416 have no overlays and no notion of insertion for which stickiness
418 return Fget_text_property (position
, prop
, object
);
421 EMACS_INT posn
= XINT (position
);
423 Lisp_Object
*overlay_vec
, tem
;
424 struct buffer
*obuf
= current_buffer
;
426 set_buffer_temp (XBUFFER (object
));
428 /* First try with room for 40 overlays. */
430 overlay_vec
= (Lisp_Object
*) alloca (noverlays
* sizeof (Lisp_Object
));
431 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
433 /* If there are more than 40,
434 make enough space for all, and try again. */
437 overlay_vec
= (Lisp_Object
*) alloca (noverlays
* sizeof (Lisp_Object
));
438 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
440 noverlays
= sort_overlays (overlay_vec
, noverlays
, NULL
);
442 set_buffer_temp (obuf
);
444 /* Now check the overlays in order of decreasing priority. */
445 while (--noverlays
>= 0)
447 Lisp_Object ol
= overlay_vec
[noverlays
];
448 tem
= Foverlay_get (ol
, prop
);
451 /* Check the overlay is indeed active at point. */
452 Lisp_Object start
= OVERLAY_START (ol
), finish
= OVERLAY_END (ol
);
453 if ((OVERLAY_POSITION (start
) == posn
454 && XMARKER (start
)->insertion_type
== 1)
455 || (OVERLAY_POSITION (finish
) == posn
456 && XMARKER (finish
)->insertion_type
== 0))
457 ; /* The overlay will not cover a char inserted at point. */
465 { /* Now check the text properties. */
466 int stickiness
= text_property_stickiness (prop
, position
, object
);
468 return Fget_text_property (position
, prop
, object
);
469 else if (stickiness
< 0
470 && XINT (position
) > BUF_BEGV (XBUFFER (object
)))
471 return Fget_text_property (make_number (XINT (position
) - 1),
479 /* Find the field surrounding POS in *BEG and *END. If POS is nil,
480 the value of point is used instead. If BEG or END is null,
481 means don't store the beginning or end of the field.
483 BEG_LIMIT and END_LIMIT serve to limit the ranged of the returned
484 results; they do not effect boundary behavior.
486 If MERGE_AT_BOUNDARY is nonzero, then if POS is at the very first
487 position of a field, then the beginning of the previous field is
488 returned instead of the beginning of POS's field (since the end of a
489 field is actually also the beginning of the next input field, this
490 behavior is sometimes useful). Additionally in the MERGE_AT_BOUNDARY
491 true case, if two fields are separated by a field with the special
492 value `boundary', and POS lies within it, then the two separated
493 fields are considered to be adjacent, and POS between them, when
494 finding the beginning and ending of the "merged" field.
496 Either BEG or END may be 0, in which case the corresponding value
500 find_field (Lisp_Object pos
, Lisp_Object merge_at_boundary
,
501 Lisp_Object beg_limit
,
502 EMACS_INT
*beg
, Lisp_Object end_limit
, EMACS_INT
*end
)
504 /* Fields right before and after the point. */
505 Lisp_Object before_field
, after_field
;
506 /* 1 if POS counts as the start of a field. */
507 int at_field_start
= 0;
508 /* 1 if POS counts as the end of a field. */
509 int at_field_end
= 0;
512 XSETFASTINT (pos
, PT
);
514 CHECK_NUMBER_COERCE_MARKER (pos
);
517 = get_char_property_and_overlay (pos
, Qfield
, Qnil
, NULL
);
519 = (XFASTINT (pos
) > BEGV
520 ? get_char_property_and_overlay (make_number (XINT (pos
) - 1),
522 /* Using nil here would be a more obvious choice, but it would
523 fail when the buffer starts with a non-sticky field. */
526 /* See if we need to handle the case where MERGE_AT_BOUNDARY is nil
527 and POS is at beginning of a field, which can also be interpreted
528 as the end of the previous field. Note that the case where if
529 MERGE_AT_BOUNDARY is non-nil (see function comment) is actually the
530 more natural one; then we avoid treating the beginning of a field
532 if (NILP (merge_at_boundary
))
534 Lisp_Object field
= get_pos_property (pos
, Qfield
, Qnil
);
535 if (!EQ (field
, after_field
))
537 if (!EQ (field
, before_field
))
539 if (NILP (field
) && at_field_start
&& at_field_end
)
540 /* If an inserted char would have a nil field while the surrounding
541 text is non-nil, we're probably not looking at a
542 zero-length field, but instead at a non-nil field that's
543 not intended for editing (such as comint's prompts). */
544 at_field_end
= at_field_start
= 0;
547 /* Note about special `boundary' fields:
549 Consider the case where the point (`.') is between the fields `x' and `y':
553 In this situation, if merge_at_boundary is true, we consider the
554 `x' and `y' fields as forming one big merged field, and so the end
555 of the field is the end of `y'.
557 However, if `x' and `y' are separated by a special `boundary' field
558 (a field with a `field' char-property of 'boundary), then we ignore
559 this special field when merging adjacent fields. Here's the same
560 situation, but with a `boundary' field between the `x' and `y' fields:
564 Here, if point is at the end of `x', the beginning of `y', or
565 anywhere in-between (within the `boundary' field), we merge all
566 three fields and consider the beginning as being the beginning of
567 the `x' field, and the end as being the end of the `y' field. */
572 /* POS is at the edge of a field, and we should consider it as
573 the beginning of the following field. */
574 *beg
= XFASTINT (pos
);
576 /* Find the previous field boundary. */
579 if (!NILP (merge_at_boundary
) && EQ (before_field
, Qboundary
))
580 /* Skip a `boundary' field. */
581 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
584 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
586 *beg
= NILP (p
) ? BEGV
: XFASTINT (p
);
593 /* POS is at the edge of a field, and we should consider it as
594 the end of the previous field. */
595 *end
= XFASTINT (pos
);
597 /* Find the next field boundary. */
599 if (!NILP (merge_at_boundary
) && EQ (after_field
, Qboundary
))
600 /* Skip a `boundary' field. */
601 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
604 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
606 *end
= NILP (pos
) ? ZV
: XFASTINT (pos
);
612 DEFUN ("delete-field", Fdelete_field
, Sdelete_field
, 0, 1, 0,
613 doc
: /* Delete the field surrounding POS.
614 A field is a region of text with the same `field' property.
615 If POS is nil, the value of point is used for POS. */)
619 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
621 del_range (beg
, end
);
625 DEFUN ("field-string", Ffield_string
, Sfield_string
, 0, 1, 0,
626 doc
: /* Return the contents of the field surrounding POS as a string.
627 A field is a region of text with the same `field' property.
628 If POS is nil, the value of point is used for POS. */)
632 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
633 return make_buffer_string (beg
, end
, 1);
636 DEFUN ("field-string-no-properties", Ffield_string_no_properties
, Sfield_string_no_properties
, 0, 1, 0,
637 doc
: /* Return the contents of the field around POS, without text properties.
638 A field is a region of text with the same `field' property.
639 If POS is nil, the value of point is used for POS. */)
643 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
644 return make_buffer_string (beg
, end
, 0);
647 DEFUN ("field-beginning", Ffield_beginning
, Sfield_beginning
, 0, 3, 0,
648 doc
: /* Return the beginning of the field surrounding POS.
649 A field is a region of text with the same `field' property.
650 If POS is nil, the value of point is used for POS.
651 If ESCAPE-FROM-EDGE is non-nil and POS is at the beginning of its
652 field, then the beginning of the *previous* field is returned.
653 If LIMIT is non-nil, it is a buffer position; if the beginning of the field
654 is before LIMIT, then LIMIT will be returned instead. */)
655 (Lisp_Object pos
, Lisp_Object escape_from_edge
, Lisp_Object limit
)
658 find_field (pos
, escape_from_edge
, limit
, &beg
, Qnil
, 0);
659 return make_number (beg
);
662 DEFUN ("field-end", Ffield_end
, Sfield_end
, 0, 3, 0,
663 doc
: /* Return the end of the field surrounding POS.
664 A field is a region of text with the same `field' property.
665 If POS is nil, the value of point is used for POS.
666 If ESCAPE-FROM-EDGE is non-nil and POS is at the end of its field,
667 then the end of the *following* field is returned.
668 If LIMIT is non-nil, it is a buffer position; if the end of the field
669 is after LIMIT, then LIMIT will be returned instead. */)
670 (Lisp_Object pos
, Lisp_Object escape_from_edge
, Lisp_Object limit
)
673 find_field (pos
, escape_from_edge
, Qnil
, 0, limit
, &end
);
674 return make_number (end
);
677 DEFUN ("constrain-to-field", Fconstrain_to_field
, Sconstrain_to_field
, 2, 5, 0,
678 doc
: /* Return the position closest to NEW-POS that is in the same field as OLD-POS.
680 A field is a region of text with the same `field' property.
681 If NEW-POS is nil, then the current point is used instead, and set to the
682 constrained position if that is different.
684 If OLD-POS is at the boundary of two fields, then the allowable
685 positions for NEW-POS depends on the value of the optional argument
686 ESCAPE-FROM-EDGE: If ESCAPE-FROM-EDGE is nil, then NEW-POS is
687 constrained to the field that has the same `field' char-property
688 as any new characters inserted at OLD-POS, whereas if ESCAPE-FROM-EDGE
689 is non-nil, NEW-POS is constrained to the union of the two adjacent
690 fields. Additionally, if two fields are separated by another field with
691 the special value `boundary', then any point within this special field is
692 also considered to be `on the boundary'.
694 If the optional argument ONLY-IN-LINE is non-nil and constraining
695 NEW-POS would move it to a different line, NEW-POS is returned
696 unconstrained. This useful for commands that move by line, like
697 \\[next-line] or \\[beginning-of-line], which should generally respect field boundaries
698 only in the case where they can still move to the right line.
700 If the optional argument INHIBIT-CAPTURE-PROPERTY is non-nil, and OLD-POS has
701 a non-nil property of that name, then any field boundaries are ignored.
703 Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
704 (Lisp_Object new_pos
, Lisp_Object old_pos
, Lisp_Object escape_from_edge
, Lisp_Object only_in_line
, Lisp_Object inhibit_capture_property
)
706 /* If non-zero, then the original point, before re-positioning. */
707 EMACS_INT orig_point
= 0;
709 Lisp_Object prev_old
, prev_new
;
712 /* Use the current point, and afterwards, set it. */
715 XSETFASTINT (new_pos
, PT
);
718 CHECK_NUMBER_COERCE_MARKER (new_pos
);
719 CHECK_NUMBER_COERCE_MARKER (old_pos
);
721 fwd
= (XFASTINT (new_pos
) > XFASTINT (old_pos
));
723 prev_old
= make_number (XFASTINT (old_pos
) - 1);
724 prev_new
= make_number (XFASTINT (new_pos
) - 1);
726 if (NILP (Vinhibit_field_text_motion
)
727 && !EQ (new_pos
, old_pos
)
728 && (!NILP (Fget_char_property (new_pos
, Qfield
, Qnil
))
729 || !NILP (Fget_char_property (old_pos
, Qfield
, Qnil
))
730 /* To recognize field boundaries, we must also look at the
731 previous positions; we could use `get_pos_property'
732 instead, but in itself that would fail inside non-sticky
733 fields (like comint prompts). */
734 || (XFASTINT (new_pos
) > BEGV
735 && !NILP (Fget_char_property (prev_new
, Qfield
, Qnil
)))
736 || (XFASTINT (old_pos
) > BEGV
737 && !NILP (Fget_char_property (prev_old
, Qfield
, Qnil
))))
738 && (NILP (inhibit_capture_property
)
739 /* Field boundaries are again a problem; but now we must
740 decide the case exactly, so we need to call
741 `get_pos_property' as well. */
742 || (NILP (get_pos_property (old_pos
, inhibit_capture_property
, Qnil
))
743 && (XFASTINT (old_pos
) <= BEGV
744 || NILP (Fget_char_property (old_pos
, inhibit_capture_property
, Qnil
))
745 || NILP (Fget_char_property (prev_old
, inhibit_capture_property
, Qnil
))))))
746 /* It is possible that NEW_POS is not within the same field as
747 OLD_POS; try to move NEW_POS so that it is. */
750 Lisp_Object field_bound
;
753 field_bound
= Ffield_end (old_pos
, escape_from_edge
, new_pos
);
755 field_bound
= Ffield_beginning (old_pos
, escape_from_edge
, new_pos
);
757 if (/* See if ESCAPE_FROM_EDGE caused FIELD_BOUND to jump to the
758 other side of NEW_POS, which would mean that NEW_POS is
759 already acceptable, and it's not necessary to constrain it
761 ((XFASTINT (field_bound
) < XFASTINT (new_pos
)) ? fwd
: !fwd
)
762 /* NEW_POS should be constrained, but only if either
763 ONLY_IN_LINE is nil (in which case any constraint is OK),
764 or NEW_POS and FIELD_BOUND are on the same line (in which
765 case the constraint is OK even if ONLY_IN_LINE is non-nil). */
766 && (NILP (only_in_line
)
767 /* This is the ONLY_IN_LINE case, check that NEW_POS and
768 FIELD_BOUND are on the same line by seeing whether
769 there's an intervening newline or not. */
770 || (scan_buffer ('\n',
771 XFASTINT (new_pos
), XFASTINT (field_bound
),
772 fwd
? -1 : 1, &shortage
, 1),
774 /* Constrain NEW_POS to FIELD_BOUND. */
775 new_pos
= field_bound
;
777 if (orig_point
&& XFASTINT (new_pos
) != orig_point
)
778 /* The NEW_POS argument was originally nil, so automatically set PT. */
779 SET_PT (XFASTINT (new_pos
));
786 DEFUN ("line-beginning-position",
787 Fline_beginning_position
, Sline_beginning_position
, 0, 1, 0,
788 doc
: /* Return the character position of the first character on the current line.
789 With argument N not nil or 1, move forward N - 1 lines first.
790 If scan reaches end of buffer, return that position.
792 The returned position is of the first character in the logical order,
793 i.e. the one that has the smallest character position.
795 This function constrains the returned position to the current field
796 unless that would be on a different line than the original,
797 unconstrained result. If N is nil or 1, and a front-sticky field
798 starts at point, the scan stops as soon as it starts. To ignore field
799 boundaries bind `inhibit-field-text-motion' to t.
801 This function does not move point. */)
804 EMACS_INT orig
, orig_byte
, end
;
805 int count
= SPECPDL_INDEX ();
806 specbind (Qinhibit_point_motion_hooks
, Qt
);
815 Fforward_line (make_number (XINT (n
) - 1));
818 SET_PT_BOTH (orig
, orig_byte
);
820 unbind_to (count
, Qnil
);
822 /* Return END constrained to the current input field. */
823 return Fconstrain_to_field (make_number (end
), make_number (orig
),
824 XINT (n
) != 1 ? Qt
: Qnil
,
828 DEFUN ("line-end-position", Fline_end_position
, Sline_end_position
, 0, 1, 0,
829 doc
: /* Return the character position of the last character on the current line.
830 With argument N not nil or 1, move forward N - 1 lines first.
831 If scan reaches end of buffer, return that position.
833 The returned position is of the last character in the logical order,
834 i.e. the character whose buffer position is the largest one.
836 This function constrains the returned position to the current field
837 unless that would be on a different line than the original,
838 unconstrained result. If N is nil or 1, and a rear-sticky field ends
839 at point, the scan stops as soon as it starts. To ignore field
840 boundaries bind `inhibit-field-text-motion' to t.
842 This function does not move point. */)
853 end_pos
= find_before_next_newline (orig
, 0, XINT (n
) - (XINT (n
) <= 0));
855 /* Return END_POS constrained to the current input field. */
856 return Fconstrain_to_field (make_number (end_pos
), make_number (orig
),
862 save_excursion_save (void)
864 int visible
= (XBUFFER (XWINDOW (selected_window
)->buffer
)
867 return Fcons (Fpoint_marker (),
868 Fcons (Fcopy_marker (BVAR (current_buffer
, mark
), Qnil
),
869 Fcons (visible
? Qt
: Qnil
,
870 Fcons (BVAR (current_buffer
, mark_active
),
875 save_excursion_restore (Lisp_Object info
)
877 Lisp_Object tem
, tem1
, omark
, nmark
;
878 struct gcpro gcpro1
, gcpro2
, gcpro3
;
881 tem
= Fmarker_buffer (XCAR (info
));
882 /* If buffer being returned to is now deleted, avoid error */
883 /* Otherwise could get error here while unwinding to top level
885 /* In that case, Fmarker_buffer returns nil now. */
889 omark
= nmark
= Qnil
;
890 GCPRO3 (info
, omark
, nmark
);
897 unchain_marker (XMARKER (tem
));
902 omark
= Fmarker_position (BVAR (current_buffer
, mark
));
903 Fset_marker (BVAR (current_buffer
, mark
), tem
, Fcurrent_buffer ());
904 nmark
= Fmarker_position (tem
);
905 unchain_marker (XMARKER (tem
));
909 visible_p
= !NILP (XCAR (info
));
911 #if 0 /* We used to make the current buffer visible in the selected window
912 if that was true previously. That avoids some anomalies.
913 But it creates others, and it wasn't documented, and it is simpler
914 and cleaner never to alter the window/buffer connections. */
917 && current_buffer
!= XBUFFER (XWINDOW (selected_window
)->buffer
))
918 Fswitch_to_buffer (Fcurrent_buffer (), Qnil
);
924 tem1
= BVAR (current_buffer
, mark_active
);
925 BVAR (current_buffer
, mark_active
) = tem
;
927 /* If mark is active now, and either was not active
928 or was at a different place, run the activate hook. */
931 if (! EQ (omark
, nmark
))
933 tem
= intern ("activate-mark-hook");
934 Frun_hooks (1, &tem
);
937 /* If mark has ceased to be active, run deactivate hook. */
938 else if (! NILP (tem1
))
940 tem
= intern ("deactivate-mark-hook");
941 Frun_hooks (1, &tem
);
944 /* If buffer was visible in a window, and a different window was
945 selected, and the old selected window is still showing this
946 buffer, restore point in that window. */
949 && !EQ (tem
, selected_window
)
950 && (tem1
= XWINDOW (tem
)->buffer
,
951 (/* Window is live... */
953 /* ...and it shows the current buffer. */
954 && XBUFFER (tem1
) == current_buffer
)))
955 Fset_window_point (tem
, make_number (PT
));
961 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
962 doc
: /* Save point, mark, and current buffer; execute BODY; restore those things.
963 Executes BODY just like `progn'.
964 The values of point, mark and the current buffer are restored
965 even in case of abnormal exit (throw or error).
966 The state of activation of the mark is also restored.
968 This construct does not save `deactivate-mark', and therefore
969 functions that change the buffer will still cause deactivation
970 of the mark at the end of the command. To prevent that, bind
971 `deactivate-mark' with `let'.
973 If you only want to save the current buffer but not point nor mark,
974 then just use `save-current-buffer', or even `with-current-buffer'.
976 usage: (save-excursion &rest BODY) */)
979 register Lisp_Object val
;
980 int count
= SPECPDL_INDEX ();
982 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
985 return unbind_to (count
, val
);
988 DEFUN ("save-current-buffer", Fsave_current_buffer
, Ssave_current_buffer
, 0, UNEVALLED
, 0,
989 doc
: /* Save the current buffer; execute BODY; restore the current buffer.
990 Executes BODY just like `progn'.
991 usage: (save-current-buffer &rest BODY) */)
995 int count
= SPECPDL_INDEX ();
997 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
1000 return unbind_to (count
, val
);
1003 DEFUN ("buffer-size", Fbufsize
, Sbufsize
, 0, 1, 0,
1004 doc
: /* Return the number of characters in the current buffer.
1005 If BUFFER, return the number of characters in that buffer instead. */)
1006 (Lisp_Object buffer
)
1009 return make_number (Z
- BEG
);
1012 CHECK_BUFFER (buffer
);
1013 return make_number (BUF_Z (XBUFFER (buffer
))
1014 - BUF_BEG (XBUFFER (buffer
)));
1018 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
1019 doc
: /* Return the minimum permissible value of point in the current buffer.
1020 This is 1, unless narrowing (a buffer restriction) is in effect. */)
1024 XSETFASTINT (temp
, BEGV
);
1028 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
1029 doc
: /* Return a marker to the minimum permissible value of point in this buffer.
1030 This is the beginning, unless narrowing (a buffer restriction) is in effect. */)
1033 return buildmark (BEGV
, BEGV_BYTE
);
1036 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
1037 doc
: /* Return the maximum permissible value of point in the current buffer.
1038 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1039 is in effect, in which case it is less. */)
1043 XSETFASTINT (temp
, ZV
);
1047 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
1048 doc
: /* Return a marker to the maximum permissible value of point in this buffer.
1049 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1050 is in effect, in which case it is less. */)
1053 return buildmark (ZV
, ZV_BYTE
);
1056 DEFUN ("gap-position", Fgap_position
, Sgap_position
, 0, 0, 0,
1057 doc
: /* Return the position of the gap, in the current buffer.
1058 See also `gap-size'. */)
1062 XSETFASTINT (temp
, GPT
);
1066 DEFUN ("gap-size", Fgap_size
, Sgap_size
, 0, 0, 0,
1067 doc
: /* Return the size of the current buffer's gap.
1068 See also `gap-position'. */)
1072 XSETFASTINT (temp
, GAP_SIZE
);
1076 DEFUN ("position-bytes", Fposition_bytes
, Sposition_bytes
, 1, 1, 0,
1077 doc
: /* Return the byte position for character position POSITION.
1078 If POSITION is out of range, the value is nil. */)
1079 (Lisp_Object position
)
1081 CHECK_NUMBER_COERCE_MARKER (position
);
1082 if (XINT (position
) < BEG
|| XINT (position
) > Z
)
1084 return make_number (CHAR_TO_BYTE (XINT (position
)));
1087 DEFUN ("byte-to-position", Fbyte_to_position
, Sbyte_to_position
, 1, 1, 0,
1088 doc
: /* Return the character position for byte position BYTEPOS.
1089 If BYTEPOS is out of range, the value is nil. */)
1090 (Lisp_Object bytepos
)
1092 CHECK_NUMBER (bytepos
);
1093 if (XINT (bytepos
) < BEG_BYTE
|| XINT (bytepos
) > Z_BYTE
)
1095 return make_number (BYTE_TO_CHAR (XINT (bytepos
)));
1098 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
1099 doc
: /* Return the character following point, as a number.
1100 At the end of the buffer or accessible region, return 0. */)
1105 XSETFASTINT (temp
, 0);
1107 XSETFASTINT (temp
, FETCH_CHAR (PT_BYTE
));
1111 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
1112 doc
: /* Return the character preceding point, as a number.
1113 At the beginning of the buffer or accessible region, return 0. */)
1118 XSETFASTINT (temp
, 0);
1119 else if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1121 EMACS_INT pos
= PT_BYTE
;
1123 XSETFASTINT (temp
, FETCH_CHAR (pos
));
1126 XSETFASTINT (temp
, FETCH_BYTE (PT_BYTE
- 1));
1130 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
1131 doc
: /* Return t if point is at the beginning of the buffer.
1132 If the buffer is narrowed, this means the beginning of the narrowed part. */)
1140 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
1141 doc
: /* Return t if point is at the end of the buffer.
1142 If the buffer is narrowed, this means the end of the narrowed part. */)
1150 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
1151 doc
: /* Return t if point is at the beginning of a line. */)
1154 if (PT
== BEGV
|| FETCH_BYTE (PT_BYTE
- 1) == '\n')
1159 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
1160 doc
: /* Return t if point is at the end of a line.
1161 `End of a line' includes point being at the end of the buffer. */)
1164 if (PT
== ZV
|| FETCH_BYTE (PT_BYTE
) == '\n')
1169 DEFUN ("char-after", Fchar_after
, Schar_after
, 0, 1, 0,
1170 doc
: /* Return character in current buffer at position POS.
1171 POS is an integer or a marker and defaults to point.
1172 If POS is out of range, the value is nil. */)
1175 register EMACS_INT pos_byte
;
1180 XSETFASTINT (pos
, PT
);
1185 pos_byte
= marker_byte_position (pos
);
1186 if (pos_byte
< BEGV_BYTE
|| pos_byte
>= ZV_BYTE
)
1191 CHECK_NUMBER_COERCE_MARKER (pos
);
1192 if (XINT (pos
) < BEGV
|| XINT (pos
) >= ZV
)
1195 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1198 return make_number (FETCH_CHAR (pos_byte
));
1201 DEFUN ("char-before", Fchar_before
, Schar_before
, 0, 1, 0,
1202 doc
: /* Return character in current buffer preceding position POS.
1203 POS is an integer or a marker and defaults to point.
1204 If POS is out of range, the value is nil. */)
1207 register Lisp_Object val
;
1208 register EMACS_INT pos_byte
;
1213 XSETFASTINT (pos
, PT
);
1218 pos_byte
= marker_byte_position (pos
);
1220 if (pos_byte
<= BEGV_BYTE
|| pos_byte
> ZV_BYTE
)
1225 CHECK_NUMBER_COERCE_MARKER (pos
);
1227 if (XINT (pos
) <= BEGV
|| XINT (pos
) > ZV
)
1230 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1233 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1236 XSETFASTINT (val
, FETCH_CHAR (pos_byte
));
1241 XSETFASTINT (val
, FETCH_BYTE (pos_byte
));
1246 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 1, 0,
1247 doc
: /* Return the name under which the user logged in, as a string.
1248 This is based on the effective uid, not the real uid.
1249 Also, if the environment variables LOGNAME or USER are set,
1250 that determines the value of this function.
1252 If optional argument UID is an integer or a float, return the login name
1253 of the user with that uid, or nil if there is no such user. */)
1259 /* Set up the user name info if we didn't do it before.
1260 (That can happen if Emacs is dumpable
1261 but you decide to run `temacs -l loadup' and not dump. */
1262 if (INTEGERP (Vuser_login_name
))
1266 return Vuser_login_name
;
1268 id
= XFLOATINT (uid
);
1272 return (pw
? build_string (pw
->pw_name
) : Qnil
);
1275 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
1277 doc
: /* Return the name of the user's real uid, as a string.
1278 This ignores the environment variables LOGNAME and USER, so it differs from
1279 `user-login-name' when running under `su'. */)
1282 /* Set up the user name info if we didn't do it before.
1283 (That can happen if Emacs is dumpable
1284 but you decide to run `temacs -l loadup' and not dump. */
1285 if (INTEGERP (Vuser_login_name
))
1287 return Vuser_real_login_name
;
1290 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
1291 doc
: /* Return the effective uid of Emacs.
1292 Value is an integer or a float, depending on the value. */)
1295 /* Assignment to EMACS_INT stops GCC whining about limited range of
1297 EMACS_INT euid
= geteuid ();
1299 /* Make sure we don't produce a negative UID due to signed integer
1302 return make_float (geteuid ());
1303 return make_fixnum_or_float (euid
);
1306 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
1307 doc
: /* Return the real uid of Emacs.
1308 Value is an integer or a float, depending on the value. */)
1311 /* Assignment to EMACS_INT stops GCC whining about limited range of
1313 EMACS_INT uid
= getuid ();
1315 /* Make sure we don't produce a negative UID due to signed integer
1318 return make_float (getuid ());
1319 return make_fixnum_or_float (uid
);
1322 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 1, 0,
1323 doc
: /* Return the full name of the user logged in, as a string.
1324 If the full name corresponding to Emacs's userid is not known,
1327 If optional argument UID is an integer or float, return the full name
1328 of the user with that uid, or nil if there is no such user.
1329 If UID is a string, return the full name of the user with that login
1330 name, or nil if there is no such user. */)
1334 register char *p
, *q
;
1338 return Vuser_full_name
;
1339 else if (NUMBERP (uid
))
1341 uid_t u
= XFLOATINT (uid
);
1346 else if (STRINGP (uid
))
1349 pw
= getpwnam (SSDATA (uid
));
1353 error ("Invalid UID specification");
1359 /* Chop off everything after the first comma. */
1360 q
= strchr (p
, ',');
1361 full
= make_string (p
, q
? q
- p
: strlen (p
));
1363 #ifdef AMPERSAND_FULL_NAME
1365 q
= strchr (p
, '&');
1366 /* Substitute the login name for the &, upcasing the first character. */
1372 login
= Fuser_login_name (make_number (pw
->pw_uid
));
1373 r
= (char *) alloca (strlen (p
) + SCHARS (login
) + 1);
1374 memcpy (r
, p
, q
- p
);
1376 strcat (r
, SSDATA (login
));
1377 r
[q
- p
] = upcase ((unsigned char) r
[q
- p
]);
1379 full
= build_string (r
);
1381 #endif /* AMPERSAND_FULL_NAME */
1386 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
1387 doc
: /* Return the host name of the machine you are running on, as a string. */)
1390 return Vsystem_name
;
1394 get_system_name (void)
1396 if (STRINGP (Vsystem_name
))
1397 return SSDATA (Vsystem_name
);
1402 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
1403 doc
: /* Return the process ID of Emacs, as an integer. */)
1406 return make_number (getpid ());
1412 # define TIME_T_MIN TYPE_MINIMUM (time_t)
1415 # define TIME_T_MAX TYPE_MAXIMUM (time_t)
1418 /* Report that a time value is out of range for Emacs. */
1420 time_overflow (void)
1422 error ("Specified time is not representable");
1425 /* Return the upper part of the time T (everything but the bottom 16 bits),
1426 making sure that it is representable. */
1430 time_t hi
= t
>> 16;
1432 /* Check for overflow, helping the compiler for common cases where
1433 no runtime check is needed, and taking care not to convert
1434 negative numbers to unsigned before comparing them. */
1435 if (! ((! TYPE_SIGNED (time_t)
1436 || MOST_NEGATIVE_FIXNUM
<= TIME_T_MIN
>> 16
1437 || MOST_NEGATIVE_FIXNUM
<= hi
)
1438 && (TIME_T_MAX
>> 16 <= MOST_POSITIVE_FIXNUM
1439 || hi
<= MOST_POSITIVE_FIXNUM
)))
1445 /* Return the bottom 16 bits of the time T. */
1449 return t
& ((1 << 16) - 1);
1452 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
1453 doc
: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
1454 The time is returned as a list of three integers. The first has the
1455 most significant 16 bits of the seconds, while the second has the
1456 least significant 16 bits. The third integer gives the microsecond
1459 The microsecond count is zero on systems that do not provide
1460 resolution finer than a second. */)
1466 return list3 (make_number (hi_time (EMACS_SECS (t
))),
1467 make_number (lo_time (EMACS_SECS (t
))),
1468 make_number (EMACS_USECS (t
)));
1471 DEFUN ("get-internal-run-time", Fget_internal_run_time
, Sget_internal_run_time
,
1473 doc
: /* Return the current run time used by Emacs.
1474 The time is returned as a list of three integers. The first has the
1475 most significant 16 bits of the seconds, while the second has the
1476 least significant 16 bits. The third integer gives the microsecond
1479 On systems that can't determine the run time, `get-internal-run-time'
1480 does the same thing as `current-time'. The microsecond count is zero
1481 on systems that do not provide resolution finer than a second. */)
1484 #ifdef HAVE_GETRUSAGE
1485 struct rusage usage
;
1489 if (getrusage (RUSAGE_SELF
, &usage
) < 0)
1490 /* This shouldn't happen. What action is appropriate? */
1493 /* Sum up user time and system time. */
1494 secs
= usage
.ru_utime
.tv_sec
+ usage
.ru_stime
.tv_sec
;
1495 usecs
= usage
.ru_utime
.tv_usec
+ usage
.ru_stime
.tv_usec
;
1496 if (usecs
>= 1000000)
1502 return list3 (make_number (hi_time (secs
)),
1503 make_number (lo_time (secs
)),
1504 make_number (usecs
));
1505 #else /* ! HAVE_GETRUSAGE */
1507 return w32_get_internal_run_time ();
1508 #else /* ! WINDOWSNT */
1509 return Fcurrent_time ();
1510 #endif /* WINDOWSNT */
1511 #endif /* HAVE_GETRUSAGE */
1515 /* Make a Lisp list that represents the time T. */
1517 make_time (time_t t
)
1519 return list2 (make_number (hi_time (t
)),
1520 make_number (lo_time (t
)));
1523 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1524 If SPECIFIED_TIME is nil, use the current time.
1525 Set *RESULT to seconds since the Epoch.
1526 If USEC is not null, set *USEC to the microseconds component.
1527 Return nonzero if successful. */
1529 lisp_time_argument (Lisp_Object specified_time
, time_t *result
, int *usec
)
1531 if (NILP (specified_time
))
1538 *usec
= EMACS_USECS (t
);
1539 *result
= EMACS_SECS (t
);
1543 return time (result
) != -1;
1547 Lisp_Object high
, low
;
1549 high
= Fcar (specified_time
);
1550 CHECK_NUMBER (high
);
1551 low
= Fcdr (specified_time
);
1556 Lisp_Object usec_l
= Fcdr (low
);
1558 usec_l
= Fcar (usec_l
);
1563 CHECK_NUMBER (usec_l
);
1564 *usec
= XINT (usec_l
);
1574 /* Check for overflow, helping the compiler for common cases
1575 where no runtime check is needed, and taking care not to
1576 convert negative numbers to unsigned before comparing them. */
1577 if (! ((TYPE_SIGNED (time_t)
1578 ? (TIME_T_MIN
>> 16 <= MOST_NEGATIVE_FIXNUM
1579 || TIME_T_MIN
>> 16 <= hi
)
1581 && (MOST_POSITIVE_FIXNUM
<= TIME_T_MAX
>> 16
1582 || hi
<= TIME_T_MAX
>> 16)))
1585 *result
= (hi
<< 16) + (XINT (low
) & 0xffff);
1590 DEFUN ("float-time", Ffloat_time
, Sfloat_time
, 0, 1, 0,
1591 doc
: /* Return the current time, as a float number of seconds since the epoch.
1592 If SPECIFIED-TIME is given, it is the time to convert to float
1593 instead of the current time. The argument should have the form
1594 (HIGH LOW) or (HIGH LOW USEC). Thus, you can use times obtained from
1595 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
1596 have the form (HIGH . LOW), but this is considered obsolete.
1598 WARNING: Since the result is floating point, it may not be exact.
1599 If precise time stamps are required, use either `current-time',
1600 or (if you need time as a string) `format-time-string'. */)
1601 (Lisp_Object specified_time
)
1606 if (! lisp_time_argument (specified_time
, &sec
, &usec
))
1607 error ("Invalid time specification");
1609 return make_float ((sec
* 1e6
+ usec
) / 1e6
);
1612 /* Write information into buffer S of size MAXSIZE, according to the
1613 FORMAT of length FORMAT_LEN, using time information taken from *TP.
1614 Default to Universal Time if UT is nonzero, local time otherwise.
1615 Use NS as the number of nanoseconds in the %N directive.
1616 Return the number of bytes written, not including the terminating
1617 '\0'. If S is NULL, nothing will be written anywhere; so to
1618 determine how many bytes would be written, use NULL for S and
1619 ((size_t) -1) for MAXSIZE.
1621 This function behaves like nstrftime, except it allows null
1622 bytes in FORMAT and it does not support nanoseconds. */
1624 emacs_nmemftime (char *s
, size_t maxsize
, const char *format
,
1625 size_t format_len
, const struct tm
*tp
, int ut
, int ns
)
1629 /* Loop through all the null-terminated strings in the format
1630 argument. Normally there's just one null-terminated string, but
1631 there can be arbitrarily many, concatenated together, if the
1632 format contains '\0' bytes. nstrftime stops at the first
1633 '\0' byte so we must invoke it separately for each such string. */
1642 result
= nstrftime (s
, maxsize
, format
, tp
, ut
, ns
);
1646 if (result
== 0 && s
[0] != '\0')
1651 maxsize
-= result
+ 1;
1653 len
= strlen (format
);
1654 if (len
== format_len
)
1658 format_len
-= len
+ 1;
1662 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 1, 3, 0,
1663 doc
: /* Use FORMAT-STRING to format the time TIME, or now if omitted.
1664 TIME is specified as (HIGH LOW . IGNORED), as returned by
1665 `current-time' or `file-attributes'. The obsolete form (HIGH . LOW)
1666 is also still accepted.
1667 The third, optional, argument UNIVERSAL, if non-nil, means describe TIME
1668 as Universal Time; nil means describe TIME in the local time zone.
1669 The value is a copy of FORMAT-STRING, but with certain constructs replaced
1670 by text that describes the specified date and time in TIME:
1672 %Y is the year, %y within the century, %C the century.
1673 %G is the year corresponding to the ISO week, %g within the century.
1674 %m is the numeric month.
1675 %b and %h are the locale's abbreviated month name, %B the full name.
1676 %d is the day of the month, zero-padded, %e is blank-padded.
1677 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
1678 %a is the locale's abbreviated name of the day of week, %A the full name.
1679 %U is the week number starting on Sunday, %W starting on Monday,
1680 %V according to ISO 8601.
1681 %j is the day of the year.
1683 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
1684 only blank-padded, %l is like %I blank-padded.
1685 %p is the locale's equivalent of either AM or PM.
1688 %N is the nanosecond, %6N the microsecond, %3N the millisecond, etc.
1689 %Z is the time zone name, %z is the numeric form.
1690 %s is the number of seconds since 1970-01-01 00:00:00 +0000.
1692 %c is the locale's date and time format.
1693 %x is the locale's "preferred" date format.
1694 %D is like "%m/%d/%y".
1696 %R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
1697 %X is the locale's "preferred" time format.
1699 Finally, %n is a newline, %t is a tab, %% is a literal %.
1701 Certain flags and modifiers are available with some format controls.
1702 The flags are `_', `-', `^' and `#'. For certain characters X,
1703 %_X is like %X, but padded with blanks; %-X is like %X,
1704 but without padding. %^X is like %X, but with all textual
1705 characters up-cased; %#X is like %X, but with letter-case of
1706 all textual characters reversed.
1707 %NX (where N stands for an integer) is like %X,
1708 but takes up at least N (a number) positions.
1709 The modifiers are `E' and `O'. For certain characters X,
1710 %EX is a locale's alternative version of %X;
1711 %OX is like %X, but uses the locale's number symbols.
1713 For example, to produce full ISO 8601 format, use "%Y-%m-%dT%T%z". */)
1714 (Lisp_Object format_string
, Lisp_Object timeval
, Lisp_Object universal
)
1721 int ut
= ! NILP (universal
);
1723 CHECK_STRING (format_string
);
1725 if (! (lisp_time_argument (timeval
, &value
, &usec
)
1726 && 0 <= usec
&& usec
< 1000000))
1727 error ("Invalid time specification");
1730 format_string
= code_convert_string_norecord (format_string
,
1731 Vlocale_coding_system
, 1);
1733 /* This is probably enough. */
1734 size
= SBYTES (format_string
) * 6 + 50;
1737 tm
= ut
? gmtime (&value
) : localtime (&value
);
1742 synchronize_system_time_locale ();
1746 char *buf
= (char *) alloca (size
+ 1);
1751 result
= emacs_nmemftime (buf
, size
, SSDATA (format_string
),
1752 SBYTES (format_string
),
1755 if ((result
> 0 && result
< size
) || (result
== 0 && buf
[0] == '\0'))
1756 return code_convert_string_norecord (make_unibyte_string (buf
, result
),
1757 Vlocale_coding_system
, 0);
1759 /* If buffer was too small, make it bigger and try again. */
1761 result
= emacs_nmemftime (NULL
, (size_t) -1,
1762 SSDATA (format_string
),
1763 SBYTES (format_string
),
1770 DEFUN ("decode-time", Fdecode_time
, Sdecode_time
, 0, 1, 0,
1771 doc
: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST ZONE).
1772 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED),
1773 as from `current-time' and `file-attributes', or nil to use the
1774 current time. The obsolete form (HIGH . LOW) is also still accepted.
1775 The list has the following nine members: SEC is an integer between 0
1776 and 60; SEC is 60 for a leap second, which only some operating systems
1777 support. MINUTE is an integer between 0 and 59. HOUR is an integer
1778 between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
1779 integer between 1 and 12. YEAR is an integer indicating the
1780 four-digit year. DOW is the day of week, an integer between 0 and 6,
1781 where 0 is Sunday. DST is t if daylight saving time is in effect,
1782 otherwise nil. ZONE is an integer indicating the number of seconds
1783 east of Greenwich. (Note that Common Lisp has different meanings for
1785 (Lisp_Object specified_time
)
1789 struct tm
*decoded_time
;
1790 Lisp_Object list_args
[9];
1792 if (! lisp_time_argument (specified_time
, &time_spec
, NULL
))
1793 error ("Invalid time specification");
1796 decoded_time
= localtime (&time_spec
);
1799 && MOST_NEGATIVE_FIXNUM
- TM_YEAR_BASE
<= decoded_time
->tm_year
1800 && decoded_time
->tm_year
<= MOST_POSITIVE_FIXNUM
- TM_YEAR_BASE
))
1802 XSETFASTINT (list_args
[0], decoded_time
->tm_sec
);
1803 XSETFASTINT (list_args
[1], decoded_time
->tm_min
);
1804 XSETFASTINT (list_args
[2], decoded_time
->tm_hour
);
1805 XSETFASTINT (list_args
[3], decoded_time
->tm_mday
);
1806 XSETFASTINT (list_args
[4], decoded_time
->tm_mon
+ 1);
1807 /* On 64-bit machines an int is narrower than EMACS_INT, thus the
1808 cast below avoids overflow in int arithmetics. */
1809 XSETINT (list_args
[5], TM_YEAR_BASE
+ (EMACS_INT
) decoded_time
->tm_year
);
1810 XSETFASTINT (list_args
[6], decoded_time
->tm_wday
);
1811 list_args
[7] = (decoded_time
->tm_isdst
)? Qt
: Qnil
;
1813 /* Make a copy, in case gmtime modifies the struct. */
1814 save_tm
= *decoded_time
;
1816 decoded_time
= gmtime (&time_spec
);
1818 if (decoded_time
== 0)
1819 list_args
[8] = Qnil
;
1821 XSETINT (list_args
[8], tm_diff (&save_tm
, decoded_time
));
1822 return Flist (9, list_args
);
1825 /* Return OBJ - OFFSET, checking that OBJ is a valid fixnum and that
1826 the result is representable as an int. Assume OFFSET is small and
1829 check_tm_member (Lisp_Object obj
, int offset
)
1834 if (! (INT_MIN
+ offset
<= n
&& n
- offset
<= INT_MAX
))
1839 DEFUN ("encode-time", Fencode_time
, Sencode_time
, 6, MANY
, 0,
1840 doc
: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
1841 This is the reverse operation of `decode-time', which see.
1842 ZONE defaults to the current time zone rule. This can
1843 be a string or t (as from `set-time-zone-rule'), or it can be a list
1844 \(as from `current-time-zone') or an integer (as from `decode-time')
1845 applied without consideration for daylight saving time.
1847 You can pass more than 7 arguments; then the first six arguments
1848 are used as SECOND through YEAR, and the *last* argument is used as ZONE.
1849 The intervening arguments are ignored.
1850 This feature lets (apply 'encode-time (decode-time ...)) work.
1852 Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed;
1853 for example, a DAY of 0 means the day preceding the given month.
1854 Year numbers less than 100 are treated just like other year numbers.
1855 If you want them to stand for years in this century, you must do that yourself.
1857 Years before 1970 are not guaranteed to work. On some systems,
1858 year values as low as 1901 do work.
1860 usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
1861 (size_t nargs
, register Lisp_Object
*args
)
1865 Lisp_Object zone
= (nargs
> 6 ? args
[nargs
- 1] : Qnil
);
1867 tm
.tm_sec
= check_tm_member (args
[0], 0);
1868 tm
.tm_min
= check_tm_member (args
[1], 0);
1869 tm
.tm_hour
= check_tm_member (args
[2], 0);
1870 tm
.tm_mday
= check_tm_member (args
[3], 0);
1871 tm
.tm_mon
= check_tm_member (args
[4], 1);
1872 tm
.tm_year
= check_tm_member (args
[5], TM_YEAR_BASE
);
1880 value
= mktime (&tm
);
1886 const char *tzstring
;
1887 char **oldenv
= environ
, **newenv
;
1891 else if (STRINGP (zone
))
1892 tzstring
= SSDATA (zone
);
1893 else if (INTEGERP (zone
))
1895 int abszone
= eabs (XINT (zone
));
1896 sprintf (tzbuf
, "XXX%s%d:%02d:%02d", "-" + (XINT (zone
) < 0),
1897 abszone
/ (60*60), (abszone
/60) % 60, abszone
% 60);
1901 error ("Invalid time zone specification");
1903 /* Set TZ before calling mktime; merely adjusting mktime's returned
1904 value doesn't suffice, since that would mishandle leap seconds. */
1905 set_time_zone_rule (tzstring
);
1908 value
= mktime (&tm
);
1911 /* Restore TZ to previous value. */
1915 #ifdef LOCALTIME_CACHE
1920 if (value
== (time_t) -1)
1923 return make_time (value
);
1926 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
1927 doc
: /* Return the current local time, as a human-readable string.
1928 Programs can use this function to decode a time,
1929 since the number of columns in each field is fixed
1930 if the year is in the range 1000-9999.
1931 The format is `Sun Sep 16 01:03:52 1973'.
1932 However, see also the functions `decode-time' and `format-time-string'
1933 which provide a much more powerful and general facility.
1935 If SPECIFIED-TIME is given, it is a time to format instead of the
1936 current time. The argument should have the form (HIGH LOW . IGNORED).
1937 Thus, you can use times obtained from `current-time' and from
1938 `file-attributes'. SPECIFIED-TIME can also have the form (HIGH . LOW),
1939 but this is considered obsolete. */)
1940 (Lisp_Object specified_time
)
1946 if (! lisp_time_argument (specified_time
, &value
, NULL
))
1947 error ("Invalid time specification");
1949 /* Convert to a string, checking for out-of-range time stamps.
1950 Don't use 'ctime', as that might dump core if VALUE is out of
1953 tm
= localtime (&value
);
1955 if (! (tm
&& TM_YEAR_IN_ASCTIME_RANGE (tm
->tm_year
) && (tem
= asctime (tm
))))
1958 /* Remove the trailing newline. */
1959 tem
[strlen (tem
) - 1] = '\0';
1961 return build_string (tem
);
1964 /* Yield A - B, measured in seconds.
1965 This function is copied from the GNU C Library. */
1967 tm_diff (struct tm
*a
, struct tm
*b
)
1969 /* Compute intervening leap days correctly even if year is negative.
1970 Take care to avoid int overflow in leap day calculations,
1971 but it's OK to assume that A and B are close to each other. */
1972 int a4
= (a
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (a
->tm_year
& 3);
1973 int b4
= (b
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (b
->tm_year
& 3);
1974 int a100
= a4
/ 25 - (a4
% 25 < 0);
1975 int b100
= b4
/ 25 - (b4
% 25 < 0);
1976 int a400
= a100
>> 2;
1977 int b400
= b100
>> 2;
1978 int intervening_leap_days
= (a4
- b4
) - (a100
- b100
) + (a400
- b400
);
1979 int years
= a
->tm_year
- b
->tm_year
;
1980 int days
= (365 * years
+ intervening_leap_days
1981 + (a
->tm_yday
- b
->tm_yday
));
1982 return (60 * (60 * (24 * days
+ (a
->tm_hour
- b
->tm_hour
))
1983 + (a
->tm_min
- b
->tm_min
))
1984 + (a
->tm_sec
- b
->tm_sec
));
1987 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
1988 doc
: /* Return the offset and name for the local time zone.
1989 This returns a list of the form (OFFSET NAME).
1990 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
1991 A negative value means west of Greenwich.
1992 NAME is a string giving the name of the time zone.
1993 If SPECIFIED-TIME is given, the time zone offset is determined from it
1994 instead of using the current time. The argument should have the form
1995 (HIGH LOW . IGNORED). Thus, you can use times obtained from
1996 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
1997 have the form (HIGH . LOW), but this is considered obsolete.
1999 Some operating systems cannot provide all this information to Emacs;
2000 in this case, `current-time-zone' returns a list containing nil for
2001 the data it can't find. */)
2002 (Lisp_Object specified_time
)
2008 if (!lisp_time_argument (specified_time
, &value
, NULL
))
2013 t
= gmtime (&value
);
2017 t
= localtime (&value
);
2024 int offset
= tm_diff (t
, &gmt
);
2030 s
= (char *)t
->tm_zone
;
2031 #else /* not HAVE_TM_ZONE */
2033 if (t
->tm_isdst
== 0 || t
->tm_isdst
== 1)
2034 s
= tzname
[t
->tm_isdst
];
2036 #endif /* not HAVE_TM_ZONE */
2040 /* No local time zone name is available; use "+-NNNN" instead. */
2041 int am
= (offset
< 0 ? -offset
: offset
) / 60;
2042 sprintf (buf
, "%c%02d%02d", (offset
< 0 ? '-' : '+'), am
/60, am
%60);
2046 return Fcons (make_number (offset
), Fcons (build_string (s
), Qnil
));
2049 return Fmake_list (make_number (2), Qnil
);
2052 /* This holds the value of `environ' produced by the previous
2053 call to Fset_time_zone_rule, or 0 if Fset_time_zone_rule
2054 has never been called. */
2055 static char **environbuf
;
2057 /* This holds the startup value of the TZ environment variable so it
2058 can be restored if the user calls set-time-zone-rule with a nil
2060 static char *initial_tz
;
2062 DEFUN ("set-time-zone-rule", Fset_time_zone_rule
, Sset_time_zone_rule
, 1, 1, 0,
2063 doc
: /* Set the local time zone using TZ, a string specifying a time zone rule.
2064 If TZ is nil, use implementation-defined default time zone information.
2065 If TZ is t, use Universal Time. */)
2068 const char *tzstring
;
2070 /* When called for the first time, save the original TZ. */
2072 initial_tz
= (char *) getenv ("TZ");
2075 tzstring
= initial_tz
;
2076 else if (EQ (tz
, Qt
))
2081 tzstring
= SSDATA (tz
);
2084 set_time_zone_rule (tzstring
);
2086 environbuf
= environ
;
2091 #ifdef LOCALTIME_CACHE
2093 /* These two values are known to load tz files in buggy implementations,
2094 i.e. Solaris 1 executables running under either Solaris 1 or Solaris 2.
2095 Their values shouldn't matter in non-buggy implementations.
2096 We don't use string literals for these strings,
2097 since if a string in the environment is in readonly
2098 storage, it runs afoul of bugs in SVR4 and Solaris 2.3.
2099 See Sun bugs 1113095 and 1114114, ``Timezone routines
2100 improperly modify environment''. */
2102 static char set_time_zone_rule_tz1
[] = "TZ=GMT+0";
2103 static char set_time_zone_rule_tz2
[] = "TZ=GMT+1";
2107 /* Set the local time zone rule to TZSTRING.
2108 This allocates memory into `environ', which it is the caller's
2109 responsibility to free. */
2112 set_time_zone_rule (const char *tzstring
)
2115 char **from
, **to
, **newenv
;
2117 /* Make the ENVIRON vector longer with room for TZSTRING. */
2118 for (from
= environ
; *from
; from
++)
2120 envptrs
= from
- environ
+ 2;
2121 newenv
= to
= (char **) xmalloc (envptrs
* sizeof (char *)
2122 + (tzstring
? strlen (tzstring
) + 4 : 0));
2124 /* Add TZSTRING to the end of environ, as a value for TZ. */
2127 char *t
= (char *) (to
+ envptrs
);
2129 strcat (t
, tzstring
);
2133 /* Copy the old environ vector elements into NEWENV,
2134 but don't copy the TZ variable.
2135 So we have only one definition of TZ, which came from TZSTRING. */
2136 for (from
= environ
; *from
; from
++)
2137 if (strncmp (*from
, "TZ=", 3) != 0)
2143 /* If we do have a TZSTRING, NEWENV points to the vector slot where
2144 the TZ variable is stored. If we do not have a TZSTRING,
2145 TO points to the vector slot which has the terminating null. */
2147 #ifdef LOCALTIME_CACHE
2149 /* In SunOS 4.1.3_U1 and 4.1.4, if TZ has a value like
2150 "US/Pacific" that loads a tz file, then changes to a value like
2151 "XXX0" that does not load a tz file, and then changes back to
2152 its original value, the last change is (incorrectly) ignored.
2153 Also, if TZ changes twice in succession to values that do
2154 not load a tz file, tzset can dump core (see Sun bug#1225179).
2155 The following code works around these bugs. */
2159 /* Temporarily set TZ to a value that loads a tz file
2160 and that differs from tzstring. */
2162 *newenv
= (strcmp (tzstring
, set_time_zone_rule_tz1
+ 3) == 0
2163 ? set_time_zone_rule_tz2
: set_time_zone_rule_tz1
);
2169 /* The implied tzstring is unknown, so temporarily set TZ to
2170 two different values that each load a tz file. */
2171 *to
= set_time_zone_rule_tz1
;
2174 *to
= set_time_zone_rule_tz2
;
2179 /* Now TZ has the desired value, and tzset can be invoked safely. */
2186 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
2187 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
2188 type of object is Lisp_String). INHERIT is passed to
2189 INSERT_FROM_STRING_FUNC as the last argument. */
2192 general_insert_function (void (*insert_func
)
2193 (const char *, EMACS_INT
),
2194 void (*insert_from_string_func
)
2195 (Lisp_Object
, EMACS_INT
, EMACS_INT
,
2196 EMACS_INT
, EMACS_INT
, int),
2197 int inherit
, size_t nargs
, Lisp_Object
*args
)
2199 register size_t argnum
;
2200 register Lisp_Object val
;
2202 for (argnum
= 0; argnum
< nargs
; argnum
++)
2205 if (CHARACTERP (val
))
2207 int c
= XFASTINT (val
);
2208 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2211 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2212 len
= CHAR_STRING (c
, str
);
2215 str
[0] = ASCII_CHAR_P (c
) ? c
: multibyte_char_to_unibyte (c
);
2218 (*insert_func
) ((char *) str
, len
);
2220 else if (STRINGP (val
))
2222 (*insert_from_string_func
) (val
, 0, 0,
2228 wrong_type_argument (Qchar_or_string_p
, val
);
2233 insert1 (Lisp_Object arg
)
2239 /* Callers passing one argument to Finsert need not gcpro the
2240 argument "array", since the only element of the array will
2241 not be used after calling insert or insert_from_string, so
2242 we don't care if it gets trashed. */
2244 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
2245 doc
: /* Insert the arguments, either strings or characters, at point.
2246 Point and before-insertion markers move forward to end up
2247 after the inserted text.
2248 Any other markers at the point of insertion remain before the text.
2250 If the current buffer is multibyte, unibyte strings are converted
2251 to multibyte for insertion (see `string-make-multibyte').
2252 If the current buffer is unibyte, multibyte strings are converted
2253 to unibyte for insertion (see `string-make-unibyte').
2255 When operating on binary data, it may be necessary to preserve the
2256 original bytes of a unibyte string when inserting it into a multibyte
2257 buffer; to accomplish this, apply `string-as-multibyte' to the string
2258 and insert the result.
2260 usage: (insert &rest ARGS) */)
2261 (size_t nargs
, register Lisp_Object
*args
)
2263 general_insert_function (insert
, insert_from_string
, 0, nargs
, args
);
2267 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
2269 doc
: /* Insert the arguments at point, inheriting properties from adjoining text.
2270 Point and before-insertion markers move forward to end up
2271 after the inserted text.
2272 Any other markers at the point of insertion remain before the text.
2274 If the current buffer is multibyte, unibyte strings are converted
2275 to multibyte for insertion (see `unibyte-char-to-multibyte').
2276 If the current buffer is unibyte, multibyte strings are converted
2277 to unibyte for insertion.
2279 usage: (insert-and-inherit &rest ARGS) */)
2280 (size_t nargs
, register Lisp_Object
*args
)
2282 general_insert_function (insert_and_inherit
, insert_from_string
, 1,
2287 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
2288 doc
: /* Insert strings or characters at point, relocating markers after the text.
2289 Point and markers move forward to end up after the inserted text.
2291 If the current buffer is multibyte, unibyte strings are converted
2292 to multibyte for insertion (see `unibyte-char-to-multibyte').
2293 If the current buffer is unibyte, multibyte strings are converted
2294 to unibyte for insertion.
2296 usage: (insert-before-markers &rest ARGS) */)
2297 (size_t nargs
, register Lisp_Object
*args
)
2299 general_insert_function (insert_before_markers
,
2300 insert_from_string_before_markers
, 0,
2305 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers
,
2306 Sinsert_and_inherit_before_markers
, 0, MANY
, 0,
2307 doc
: /* Insert text at point, relocating markers and inheriting properties.
2308 Point and markers move forward to end up after the inserted text.
2310 If the current buffer is multibyte, unibyte strings are converted
2311 to multibyte for insertion (see `unibyte-char-to-multibyte').
2312 If the current buffer is unibyte, multibyte strings are converted
2313 to unibyte for insertion.
2315 usage: (insert-before-markers-and-inherit &rest ARGS) */)
2316 (size_t nargs
, register Lisp_Object
*args
)
2318 general_insert_function (insert_before_markers_and_inherit
,
2319 insert_from_string_before_markers
, 1,
2324 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 2, 3, 0,
2325 doc
: /* Insert COUNT copies of CHARACTER.
2326 Point, and before-insertion markers, are relocated as in the function `insert'.
2327 The optional third arg INHERIT, if non-nil, says to inherit text properties
2328 from adjoining text, if those properties are sticky. */)
2329 (Lisp_Object character
, Lisp_Object count
, Lisp_Object inherit
)
2331 register char *string
;
2332 register EMACS_INT stringlen
;
2334 register EMACS_INT n
;
2336 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2338 CHECK_CHARACTER (character
);
2339 CHECK_NUMBER (count
);
2340 c
= XFASTINT (character
);
2342 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2343 len
= CHAR_STRING (c
, str
);
2345 str
[0] = c
, len
= 1;
2346 if (BUF_BYTES_MAX
/ len
< XINT (count
))
2347 error ("Maximum buffer size would be exceeded");
2348 n
= XINT (count
) * len
;
2351 stringlen
= min (n
, 256 * len
);
2352 string
= (char *) alloca (stringlen
);
2353 for (i
= 0; i
< stringlen
; i
++)
2354 string
[i
] = str
[i
% len
];
2355 while (n
>= stringlen
)
2358 if (!NILP (inherit
))
2359 insert_and_inherit (string
, stringlen
);
2361 insert (string
, stringlen
);
2366 if (!NILP (inherit
))
2367 insert_and_inherit (string
, n
);
2374 DEFUN ("insert-byte", Finsert_byte
, Sinsert_byte
, 2, 3, 0,
2375 doc
: /* Insert COUNT (second arg) copies of BYTE (first arg).
2376 Both arguments are required.
2377 BYTE is a number of the range 0..255.
2379 If BYTE is 128..255 and the current buffer is multibyte, the
2380 corresponding eight-bit character is inserted.
2382 Point, and before-insertion markers, are relocated as in the function `insert'.
2383 The optional third arg INHERIT, if non-nil, says to inherit text properties
2384 from adjoining text, if those properties are sticky. */)
2385 (Lisp_Object byte
, Lisp_Object count
, Lisp_Object inherit
)
2387 CHECK_NUMBER (byte
);
2388 if (XINT (byte
) < 0 || XINT (byte
) > 255)
2389 args_out_of_range_3 (byte
, make_number (0), make_number (255));
2390 if (XINT (byte
) >= 128
2391 && ! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2392 XSETFASTINT (byte
, BYTE8_TO_CHAR (XINT (byte
)));
2393 return Finsert_char (byte
, count
, inherit
);
2397 /* Making strings from buffer contents. */
2399 /* Return a Lisp_String containing the text of the current buffer from
2400 START to END. If text properties are in use and the current buffer
2401 has properties in the range specified, the resulting string will also
2402 have them, if PROPS is nonzero.
2404 We don't want to use plain old make_string here, because it calls
2405 make_uninit_string, which can cause the buffer arena to be
2406 compacted. make_string has no way of knowing that the data has
2407 been moved, and thus copies the wrong data into the string. This
2408 doesn't effect most of the other users of make_string, so it should
2409 be left as is. But we should use this function when conjuring
2410 buffer substrings. */
2413 make_buffer_string (EMACS_INT start
, EMACS_INT end
, int props
)
2415 EMACS_INT start_byte
= CHAR_TO_BYTE (start
);
2416 EMACS_INT end_byte
= CHAR_TO_BYTE (end
);
2418 return make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
);
2421 /* Return a Lisp_String containing the text of the current buffer from
2422 START / START_BYTE to END / END_BYTE.
2424 If text properties are in use and the current buffer
2425 has properties in the range specified, the resulting string will also
2426 have them, if PROPS is nonzero.
2428 We don't want to use plain old make_string here, because it calls
2429 make_uninit_string, which can cause the buffer arena to be
2430 compacted. make_string has no way of knowing that the data has
2431 been moved, and thus copies the wrong data into the string. This
2432 doesn't effect most of the other users of make_string, so it should
2433 be left as is. But we should use this function when conjuring
2434 buffer substrings. */
2437 make_buffer_string_both (EMACS_INT start
, EMACS_INT start_byte
,
2438 EMACS_INT end
, EMACS_INT end_byte
, int props
)
2440 Lisp_Object result
, tem
, tem1
;
2442 if (start
< GPT
&& GPT
< end
)
2445 if (! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2446 result
= make_uninit_multibyte_string (end
- start
, end_byte
- start_byte
);
2448 result
= make_uninit_string (end
- start
);
2449 memcpy (SDATA (result
), BYTE_POS_ADDR (start_byte
), end_byte
- start_byte
);
2451 /* If desired, update and copy the text properties. */
2454 update_buffer_properties (start
, end
);
2456 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
2457 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
2459 if (XINT (tem
) != end
|| !NILP (tem1
))
2460 copy_intervals_to_string (result
, current_buffer
, start
,
2467 /* Call Vbuffer_access_fontify_functions for the range START ... END
2468 in the current buffer, if necessary. */
2471 update_buffer_properties (EMACS_INT start
, EMACS_INT end
)
2473 /* If this buffer has some access functions,
2474 call them, specifying the range of the buffer being accessed. */
2475 if (!NILP (Vbuffer_access_fontify_functions
))
2477 Lisp_Object args
[3];
2480 args
[0] = Qbuffer_access_fontify_functions
;
2481 XSETINT (args
[1], start
);
2482 XSETINT (args
[2], end
);
2484 /* But don't call them if we can tell that the work
2485 has already been done. */
2486 if (!NILP (Vbuffer_access_fontified_property
))
2488 tem
= Ftext_property_any (args
[1], args
[2],
2489 Vbuffer_access_fontified_property
,
2492 Frun_hook_with_args (3, args
);
2495 Frun_hook_with_args (3, args
);
2499 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
2500 doc
: /* Return the contents of part of the current buffer as a string.
2501 The two arguments START and END are character positions;
2502 they can be in either order.
2503 The string returned is multibyte if the buffer is multibyte.
2505 This function copies the text properties of that part of the buffer
2506 into the result string; if you don't want the text properties,
2507 use `buffer-substring-no-properties' instead. */)
2508 (Lisp_Object start
, Lisp_Object end
)
2510 register EMACS_INT b
, e
;
2512 validate_region (&start
, &end
);
2516 return make_buffer_string (b
, e
, 1);
2519 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties
,
2520 Sbuffer_substring_no_properties
, 2, 2, 0,
2521 doc
: /* Return the characters of part of the buffer, without the text properties.
2522 The two arguments START and END are character positions;
2523 they can be in either order. */)
2524 (Lisp_Object start
, Lisp_Object end
)
2526 register EMACS_INT b
, e
;
2528 validate_region (&start
, &end
);
2532 return make_buffer_string (b
, e
, 0);
2535 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
2536 doc
: /* Return the contents of the current buffer as a string.
2537 If narrowing is in effect, this function returns only the visible part
2541 return make_buffer_string (BEGV
, ZV
, 1);
2544 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
2546 doc
: /* Insert before point a substring of the contents of BUFFER.
2547 BUFFER may be a buffer or a buffer name.
2548 Arguments START and END are character positions specifying the substring.
2549 They default to the values of (point-min) and (point-max) in BUFFER. */)
2550 (Lisp_Object buffer
, Lisp_Object start
, Lisp_Object end
)
2552 register EMACS_INT b
, e
, temp
;
2553 register struct buffer
*bp
, *obuf
;
2556 buf
= Fget_buffer (buffer
);
2560 if (NILP (BVAR (bp
, name
)))
2561 error ("Selecting deleted buffer");
2567 CHECK_NUMBER_COERCE_MARKER (start
);
2574 CHECK_NUMBER_COERCE_MARKER (end
);
2579 temp
= b
, b
= e
, e
= temp
;
2581 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
2582 args_out_of_range (start
, end
);
2584 obuf
= current_buffer
;
2585 set_buffer_internal_1 (bp
);
2586 update_buffer_properties (b
, e
);
2587 set_buffer_internal_1 (obuf
);
2589 insert_from_buffer (bp
, b
, e
- b
, 0);
2593 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
2595 doc
: /* Compare two substrings of two buffers; return result as number.
2596 the value is -N if first string is less after N-1 chars,
2597 +N if first string is greater after N-1 chars, or 0 if strings match.
2598 Each substring is represented as three arguments: BUFFER, START and END.
2599 That makes six args in all, three for each substring.
2601 The value of `case-fold-search' in the current buffer
2602 determines whether case is significant or ignored. */)
2603 (Lisp_Object buffer1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object buffer2
, Lisp_Object start2
, Lisp_Object end2
)
2605 register EMACS_INT begp1
, endp1
, begp2
, endp2
, temp
;
2606 register struct buffer
*bp1
, *bp2
;
2607 register Lisp_Object trt
2608 = (!NILP (BVAR (current_buffer
, case_fold_search
))
2609 ? BVAR (current_buffer
, case_canon_table
) : Qnil
);
2610 EMACS_INT chars
= 0;
2611 EMACS_INT i1
, i2
, i1_byte
, i2_byte
;
2613 /* Find the first buffer and its substring. */
2616 bp1
= current_buffer
;
2620 buf1
= Fget_buffer (buffer1
);
2623 bp1
= XBUFFER (buf1
);
2624 if (NILP (BVAR (bp1
, name
)))
2625 error ("Selecting deleted buffer");
2629 begp1
= BUF_BEGV (bp1
);
2632 CHECK_NUMBER_COERCE_MARKER (start1
);
2633 begp1
= XINT (start1
);
2636 endp1
= BUF_ZV (bp1
);
2639 CHECK_NUMBER_COERCE_MARKER (end1
);
2640 endp1
= XINT (end1
);
2644 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
2646 if (!(BUF_BEGV (bp1
) <= begp1
2648 && endp1
<= BUF_ZV (bp1
)))
2649 args_out_of_range (start1
, end1
);
2651 /* Likewise for second substring. */
2654 bp2
= current_buffer
;
2658 buf2
= Fget_buffer (buffer2
);
2661 bp2
= XBUFFER (buf2
);
2662 if (NILP (BVAR (bp2
, name
)))
2663 error ("Selecting deleted buffer");
2667 begp2
= BUF_BEGV (bp2
);
2670 CHECK_NUMBER_COERCE_MARKER (start2
);
2671 begp2
= XINT (start2
);
2674 endp2
= BUF_ZV (bp2
);
2677 CHECK_NUMBER_COERCE_MARKER (end2
);
2678 endp2
= XINT (end2
);
2682 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
2684 if (!(BUF_BEGV (bp2
) <= begp2
2686 && endp2
<= BUF_ZV (bp2
)))
2687 args_out_of_range (start2
, end2
);
2691 i1_byte
= buf_charpos_to_bytepos (bp1
, i1
);
2692 i2_byte
= buf_charpos_to_bytepos (bp2
, i2
);
2694 while (i1
< endp1
&& i2
< endp2
)
2696 /* When we find a mismatch, we must compare the
2697 characters, not just the bytes. */
2702 if (! NILP (BVAR (bp1
, enable_multibyte_characters
)))
2704 c1
= BUF_FETCH_MULTIBYTE_CHAR (bp1
, i1_byte
);
2705 BUF_INC_POS (bp1
, i1_byte
);
2710 c1
= BUF_FETCH_BYTE (bp1
, i1
);
2711 MAKE_CHAR_MULTIBYTE (c1
);
2715 if (! NILP (BVAR (bp2
, enable_multibyte_characters
)))
2717 c2
= BUF_FETCH_MULTIBYTE_CHAR (bp2
, i2_byte
);
2718 BUF_INC_POS (bp2
, i2_byte
);
2723 c2
= BUF_FETCH_BYTE (bp2
, i2
);
2724 MAKE_CHAR_MULTIBYTE (c2
);
2730 c1
= CHAR_TABLE_TRANSLATE (trt
, c1
);
2731 c2
= CHAR_TABLE_TRANSLATE (trt
, c2
);
2734 return make_number (- 1 - chars
);
2736 return make_number (chars
+ 1);
2741 /* The strings match as far as they go.
2742 If one is shorter, that one is less. */
2743 if (chars
< endp1
- begp1
)
2744 return make_number (chars
+ 1);
2745 else if (chars
< endp2
- begp2
)
2746 return make_number (- chars
- 1);
2748 /* Same length too => they are equal. */
2749 return make_number (0);
2753 subst_char_in_region_unwind (Lisp_Object arg
)
2755 return BVAR (current_buffer
, undo_list
) = arg
;
2759 subst_char_in_region_unwind_1 (Lisp_Object arg
)
2761 return BVAR (current_buffer
, filename
) = arg
;
2764 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
2765 Ssubst_char_in_region
, 4, 5, 0,
2766 doc
: /* From START to END, replace FROMCHAR with TOCHAR each time it occurs.
2767 If optional arg NOUNDO is non-nil, don't record this change for undo
2768 and don't mark the buffer as really changed.
2769 Both characters must have the same length of multi-byte form. */)
2770 (Lisp_Object start
, Lisp_Object end
, Lisp_Object fromchar
, Lisp_Object tochar
, Lisp_Object noundo
)
2772 register EMACS_INT pos
, pos_byte
, stop
, i
, len
, end_byte
;
2773 /* Keep track of the first change in the buffer:
2774 if 0 we haven't found it yet.
2775 if < 0 we've found it and we've run the before-change-function.
2776 if > 0 we've actually performed it and the value is its position. */
2777 EMACS_INT changed
= 0;
2778 unsigned char fromstr
[MAX_MULTIBYTE_LENGTH
], tostr
[MAX_MULTIBYTE_LENGTH
];
2780 int count
= SPECPDL_INDEX ();
2781 #define COMBINING_NO 0
2782 #define COMBINING_BEFORE 1
2783 #define COMBINING_AFTER 2
2784 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
2785 int maybe_byte_combining
= COMBINING_NO
;
2786 EMACS_INT last_changed
= 0;
2787 int multibyte_p
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
2792 validate_region (&start
, &end
);
2793 CHECK_CHARACTER (fromchar
);
2794 CHECK_CHARACTER (tochar
);
2795 fromc
= XFASTINT (fromchar
);
2796 toc
= XFASTINT (tochar
);
2800 len
= CHAR_STRING (fromc
, fromstr
);
2801 if (CHAR_STRING (toc
, tostr
) != len
)
2802 error ("Characters in `subst-char-in-region' have different byte-lengths");
2803 if (!ASCII_BYTE_P (*tostr
))
2805 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
2806 complete multibyte character, it may be combined with the
2807 after bytes. If it is in the range 0xA0..0xFF, it may be
2808 combined with the before and after bytes. */
2809 if (!CHAR_HEAD_P (*tostr
))
2810 maybe_byte_combining
= COMBINING_BOTH
;
2811 else if (BYTES_BY_CHAR_HEAD (*tostr
) > len
)
2812 maybe_byte_combining
= COMBINING_AFTER
;
2823 pos_byte
= CHAR_TO_BYTE (pos
);
2824 stop
= CHAR_TO_BYTE (XINT (end
));
2827 /* If we don't want undo, turn off putting stuff on the list.
2828 That's faster than getting rid of things,
2829 and it prevents even the entry for a first change.
2830 Also inhibit locking the file. */
2831 if (!changed
&& !NILP (noundo
))
2833 record_unwind_protect (subst_char_in_region_unwind
,
2834 BVAR (current_buffer
, undo_list
));
2835 BVAR (current_buffer
, undo_list
) = Qt
;
2836 /* Don't do file-locking. */
2837 record_unwind_protect (subst_char_in_region_unwind_1
,
2838 BVAR (current_buffer
, filename
));
2839 BVAR (current_buffer
, filename
) = Qnil
;
2842 if (pos_byte
< GPT_BYTE
)
2843 stop
= min (stop
, GPT_BYTE
);
2846 EMACS_INT pos_byte_next
= pos_byte
;
2848 if (pos_byte
>= stop
)
2850 if (pos_byte
>= end_byte
) break;
2853 p
= BYTE_POS_ADDR (pos_byte
);
2855 INC_POS (pos_byte_next
);
2858 if (pos_byte_next
- pos_byte
== len
2859 && p
[0] == fromstr
[0]
2861 || (p
[1] == fromstr
[1]
2862 && (len
== 2 || (p
[2] == fromstr
[2]
2863 && (len
== 3 || p
[3] == fromstr
[3]))))))
2866 /* We've already seen this and run the before-change-function;
2867 this time we only need to record the actual position. */
2872 modify_region (current_buffer
, pos
, XINT (end
), 0);
2874 if (! NILP (noundo
))
2876 if (MODIFF
- 1 == SAVE_MODIFF
)
2878 if (MODIFF
- 1 == BUF_AUTOSAVE_MODIFF (current_buffer
))
2879 BUF_AUTOSAVE_MODIFF (current_buffer
)++;
2882 /* The before-change-function may have moved the gap
2883 or even modified the buffer so we should start over. */
2887 /* Take care of the case where the new character
2888 combines with neighboring bytes. */
2889 if (maybe_byte_combining
2890 && (maybe_byte_combining
== COMBINING_AFTER
2891 ? (pos_byte_next
< Z_BYTE
2892 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2893 : ((pos_byte_next
< Z_BYTE
2894 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2895 || (pos_byte
> BEG_BYTE
2896 && ! ASCII_BYTE_P (FETCH_BYTE (pos_byte
- 1))))))
2898 Lisp_Object tem
, string
;
2900 struct gcpro gcpro1
;
2902 tem
= BVAR (current_buffer
, undo_list
);
2905 /* Make a multibyte string containing this single character. */
2906 string
= make_multibyte_string ((char *) tostr
, 1, len
);
2907 /* replace_range is less efficient, because it moves the gap,
2908 but it handles combining correctly. */
2909 replace_range (pos
, pos
+ 1, string
,
2911 pos_byte_next
= CHAR_TO_BYTE (pos
);
2912 if (pos_byte_next
> pos_byte
)
2913 /* Before combining happened. We should not increment
2914 POS. So, to cancel the later increment of POS,
2918 INC_POS (pos_byte_next
);
2920 if (! NILP (noundo
))
2921 BVAR (current_buffer
, undo_list
) = tem
;
2928 record_change (pos
, 1);
2929 for (i
= 0; i
< len
; i
++) *p
++ = tostr
[i
];
2931 last_changed
= pos
+ 1;
2933 pos_byte
= pos_byte_next
;
2939 signal_after_change (changed
,
2940 last_changed
- changed
, last_changed
- changed
);
2941 update_compositions (changed
, last_changed
, CHECK_ALL
);
2944 unbind_to (count
, Qnil
);
2949 static Lisp_Object
check_translation (EMACS_INT
, EMACS_INT
, EMACS_INT
,
2952 /* Helper function for Ftranslate_region_internal.
2954 Check if a character sequence at POS (POS_BYTE) matches an element
2955 of VAL. VAL is a list (([FROM-CHAR ...] . TO) ...). If a matching
2956 element is found, return it. Otherwise return Qnil. */
2959 check_translation (EMACS_INT pos
, EMACS_INT pos_byte
, EMACS_INT end
,
2962 int buf_size
= 16, buf_used
= 0;
2963 int *buf
= alloca (sizeof (int) * buf_size
);
2965 for (; CONSP (val
); val
= XCDR (val
))
2974 if (! VECTORP (elt
))
2977 if (len
<= end
- pos
)
2979 for (i
= 0; i
< len
; i
++)
2983 unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
2986 if (buf_used
== buf_size
)
2991 newbuf
= alloca (sizeof (int) * buf_size
);
2992 memcpy (newbuf
, buf
, sizeof (int) * buf_used
);
2995 buf
[buf_used
++] = STRING_CHAR_AND_LENGTH (p
, len1
);
2998 if (XINT (AREF (elt
, i
)) != buf
[i
])
3009 DEFUN ("translate-region-internal", Ftranslate_region_internal
,
3010 Stranslate_region_internal
, 3, 3, 0,
3011 doc
: /* Internal use only.
3012 From START to END, translate characters according to TABLE.
3013 TABLE is a string or a char-table; the Nth character in it is the
3014 mapping for the character with code N.
3015 It returns the number of characters changed. */)
3016 (Lisp_Object start
, Lisp_Object end
, register Lisp_Object table
)
3018 register unsigned char *tt
; /* Trans table. */
3019 register int nc
; /* New character. */
3020 int cnt
; /* Number of changes made. */
3021 EMACS_INT size
; /* Size of translate table. */
3022 EMACS_INT pos
, pos_byte
, end_pos
;
3023 int multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3024 int string_multibyte
IF_LINT (= 0);
3026 validate_region (&start
, &end
);
3027 if (CHAR_TABLE_P (table
))
3029 if (! EQ (XCHAR_TABLE (table
)->purpose
, Qtranslation_table
))
3030 error ("Not a translation table");
3036 CHECK_STRING (table
);
3038 if (! multibyte
&& (SCHARS (table
) < SBYTES (table
)))
3039 table
= string_make_unibyte (table
);
3040 string_multibyte
= SCHARS (table
) < SBYTES (table
);
3041 size
= SBYTES (table
);
3046 pos_byte
= CHAR_TO_BYTE (pos
);
3047 end_pos
= XINT (end
);
3048 modify_region (current_buffer
, pos
, end_pos
, 0);
3051 for (; pos
< end_pos
; )
3053 register unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
3054 unsigned char *str
, buf
[MAX_MULTIBYTE_LENGTH
];
3060 oc
= STRING_CHAR_AND_LENGTH (p
, len
);
3067 /* Reload as signal_after_change in last iteration may GC. */
3069 if (string_multibyte
)
3071 str
= tt
+ string_char_to_byte (table
, oc
);
3072 nc
= STRING_CHAR_AND_LENGTH (str
, str_len
);
3077 if (! ASCII_BYTE_P (nc
) && multibyte
)
3079 str_len
= BYTE8_STRING (nc
, buf
);
3094 val
= CHAR_TABLE_REF (table
, oc
);
3095 if (CHARACTERP (val
)
3096 && (c
= XFASTINT (val
), CHAR_VALID_P (c
, 0)))
3099 str_len
= CHAR_STRING (nc
, buf
);
3102 else if (VECTORP (val
) || (CONSP (val
)))
3104 /* VAL is [TO_CHAR ...] or (([FROM-CHAR ...] . TO) ...)
3105 where TO is TO-CHAR or [TO-CHAR ...]. */
3110 if (nc
!= oc
&& nc
>= 0)
3112 /* Simple one char to one char translation. */
3117 /* This is less efficient, because it moves the gap,
3118 but it should handle multibyte characters correctly. */
3119 string
= make_multibyte_string ((char *) str
, 1, str_len
);
3120 replace_range (pos
, pos
+ 1, string
, 1, 0, 1);
3125 record_change (pos
, 1);
3126 while (str_len
-- > 0)
3128 signal_after_change (pos
, 1, 1);
3129 update_compositions (pos
, pos
+ 1, CHECK_BORDER
);
3139 val
= check_translation (pos
, pos_byte
, end_pos
, val
);
3146 /* VAL is ([FROM-CHAR ...] . TO). */
3147 len
= ASIZE (XCAR (val
));
3155 string
= Fconcat (1, &val
);
3159 string
= Fmake_string (make_number (1), val
);
3161 replace_range (pos
, pos
+ len
, string
, 1, 0, 1);
3162 pos_byte
+= SBYTES (string
);
3163 pos
+= SCHARS (string
);
3164 cnt
+= SCHARS (string
);
3165 end_pos
+= SCHARS (string
) - len
;
3173 return make_number (cnt
);
3176 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
3177 doc
: /* Delete the text between point and mark.
3179 When called from a program, expects two arguments,
3180 positions (integers or markers) specifying the stretch to be deleted. */)
3181 (Lisp_Object start
, Lisp_Object end
)
3183 validate_region (&start
, &end
);
3184 del_range (XINT (start
), XINT (end
));
3188 DEFUN ("delete-and-extract-region", Fdelete_and_extract_region
,
3189 Sdelete_and_extract_region
, 2, 2, 0,
3190 doc
: /* Delete the text between START and END and return it. */)
3191 (Lisp_Object start
, Lisp_Object end
)
3193 validate_region (&start
, &end
);
3194 if (XINT (start
) == XINT (end
))
3195 return empty_unibyte_string
;
3196 return del_range_1 (XINT (start
), XINT (end
), 1, 1);
3199 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
3200 doc
: /* Remove restrictions (narrowing) from current buffer.
3201 This allows the buffer's full text to be seen and edited. */)
3204 if (BEG
!= BEGV
|| Z
!= ZV
)
3205 current_buffer
->clip_changed
= 1;
3207 BEGV_BYTE
= BEG_BYTE
;
3208 SET_BUF_ZV_BOTH (current_buffer
, Z
, Z_BYTE
);
3209 /* Changing the buffer bounds invalidates any recorded current column. */
3210 invalidate_current_column ();
3214 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
3215 doc
: /* Restrict editing in this buffer to the current region.
3216 The rest of the text becomes temporarily invisible and untouchable
3217 but is not deleted; if you save the buffer in a file, the invisible
3218 text is included in the file. \\[widen] makes all visible again.
3219 See also `save-restriction'.
3221 When calling from a program, pass two arguments; positions (integers
3222 or markers) bounding the text that should remain visible. */)
3223 (register Lisp_Object start
, Lisp_Object end
)
3225 CHECK_NUMBER_COERCE_MARKER (start
);
3226 CHECK_NUMBER_COERCE_MARKER (end
);
3228 if (XINT (start
) > XINT (end
))
3231 tem
= start
; start
= end
; end
= tem
;
3234 if (!(BEG
<= XINT (start
) && XINT (start
) <= XINT (end
) && XINT (end
) <= Z
))
3235 args_out_of_range (start
, end
);
3237 if (BEGV
!= XFASTINT (start
) || ZV
!= XFASTINT (end
))
3238 current_buffer
->clip_changed
= 1;
3240 SET_BUF_BEGV (current_buffer
, XFASTINT (start
));
3241 SET_BUF_ZV (current_buffer
, XFASTINT (end
));
3242 if (PT
< XFASTINT (start
))
3243 SET_PT (XFASTINT (start
));
3244 if (PT
> XFASTINT (end
))
3245 SET_PT (XFASTINT (end
));
3246 /* Changing the buffer bounds invalidates any recorded current column. */
3247 invalidate_current_column ();
3252 save_restriction_save (void)
3254 if (BEGV
== BEG
&& ZV
== Z
)
3255 /* The common case that the buffer isn't narrowed.
3256 We return just the buffer object, which save_restriction_restore
3257 recognizes as meaning `no restriction'. */
3258 return Fcurrent_buffer ();
3260 /* We have to save a restriction, so return a pair of markers, one
3261 for the beginning and one for the end. */
3263 Lisp_Object beg
, end
;
3265 beg
= buildmark (BEGV
, BEGV_BYTE
);
3266 end
= buildmark (ZV
, ZV_BYTE
);
3268 /* END must move forward if text is inserted at its exact location. */
3269 XMARKER(end
)->insertion_type
= 1;
3271 return Fcons (beg
, end
);
3276 save_restriction_restore (Lisp_Object data
)
3278 struct buffer
*cur
= NULL
;
3279 struct buffer
*buf
= (CONSP (data
)
3280 ? XMARKER (XCAR (data
))->buffer
3283 if (buf
&& buf
!= current_buffer
&& !NILP (BVAR (buf
, pt_marker
)))
3284 { /* If `buf' uses markers to keep track of PT, BEGV, and ZV (as
3285 is the case if it is or has an indirect buffer), then make
3286 sure it is current before we update BEGV, so
3287 set_buffer_internal takes care of managing those markers. */
3288 cur
= current_buffer
;
3289 set_buffer_internal (buf
);
3293 /* A pair of marks bounding a saved restriction. */
3295 struct Lisp_Marker
*beg
= XMARKER (XCAR (data
));
3296 struct Lisp_Marker
*end
= XMARKER (XCDR (data
));
3297 eassert (buf
== end
->buffer
);
3299 if (buf
/* Verify marker still points to a buffer. */
3300 && (beg
->charpos
!= BUF_BEGV (buf
) || end
->charpos
!= BUF_ZV (buf
)))
3301 /* The restriction has changed from the saved one, so restore
3302 the saved restriction. */
3304 EMACS_INT pt
= BUF_PT (buf
);
3306 SET_BUF_BEGV_BOTH (buf
, beg
->charpos
, beg
->bytepos
);
3307 SET_BUF_ZV_BOTH (buf
, end
->charpos
, end
->bytepos
);
3309 if (pt
< beg
->charpos
|| pt
> end
->charpos
)
3310 /* The point is outside the new visible range, move it inside. */
3311 SET_BUF_PT_BOTH (buf
,
3312 clip_to_bounds (beg
->charpos
, pt
, end
->charpos
),
3313 clip_to_bounds (beg
->bytepos
, BUF_PT_BYTE (buf
),
3316 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3320 /* A buffer, which means that there was no old restriction. */
3322 if (buf
/* Verify marker still points to a buffer. */
3323 && (BUF_BEGV (buf
) != BUF_BEG (buf
) || BUF_ZV (buf
) != BUF_Z (buf
)))
3324 /* The buffer has been narrowed, get rid of the narrowing. */
3326 SET_BUF_BEGV_BOTH (buf
, BUF_BEG (buf
), BUF_BEG_BYTE (buf
));
3327 SET_BUF_ZV_BOTH (buf
, BUF_Z (buf
), BUF_Z_BYTE (buf
));
3329 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3333 /* Changing the buffer bounds invalidates any recorded current column. */
3334 invalidate_current_column ();
3337 set_buffer_internal (cur
);
3342 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
3343 doc
: /* Execute BODY, saving and restoring current buffer's restrictions.
3344 The buffer's restrictions make parts of the beginning and end invisible.
3345 \(They are set up with `narrow-to-region' and eliminated with `widen'.)
3346 This special form, `save-restriction', saves the current buffer's restrictions
3347 when it is entered, and restores them when it is exited.
3348 So any `narrow-to-region' within BODY lasts only until the end of the form.
3349 The old restrictions settings are restored
3350 even in case of abnormal exit (throw or error).
3352 The value returned is the value of the last form in BODY.
3354 Note: if you are using both `save-excursion' and `save-restriction',
3355 use `save-excursion' outermost:
3356 (save-excursion (save-restriction ...))
3358 usage: (save-restriction &rest BODY) */)
3361 register Lisp_Object val
;
3362 int count
= SPECPDL_INDEX ();
3364 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
3365 val
= Fprogn (body
);
3366 return unbind_to (count
, val
);
3369 /* Buffer for the most recent text displayed by Fmessage_box. */
3370 static char *message_text
;
3372 /* Allocated length of that buffer. */
3373 static int message_length
;
3375 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
3376 doc
: /* Display a message at the bottom of the screen.
3377 The message also goes into the `*Messages*' buffer.
3378 \(In keyboard macros, that's all it does.)
3381 The first argument is a format control string, and the rest are data
3382 to be formatted under control of the string. See `format' for details.
3384 Note: Use (message "%s" VALUE) to print the value of expressions and
3385 variables to avoid accidentally interpreting `%' as format specifiers.
3387 If the first argument is nil or the empty string, the function clears
3388 any existing message; this lets the minibuffer contents show. See
3389 also `current-message'.
3391 usage: (message FORMAT-STRING &rest ARGS) */)
3392 (size_t nargs
, Lisp_Object
*args
)
3395 || (STRINGP (args
[0])
3396 && SBYTES (args
[0]) == 0))
3403 register Lisp_Object val
;
3404 val
= Fformat (nargs
, args
);
3405 message3 (val
, SBYTES (val
), STRING_MULTIBYTE (val
));
3410 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
3411 doc
: /* Display a message, in a dialog box if possible.
3412 If a dialog box is not available, use the echo area.
3413 The first argument is a format control string, and the rest are data
3414 to be formatted under control of the string. See `format' for details.
3416 If the first argument is nil or the empty string, clear any existing
3417 message; let the minibuffer contents show.
3419 usage: (message-box FORMAT-STRING &rest ARGS) */)
3420 (size_t nargs
, Lisp_Object
*args
)
3429 register Lisp_Object val
;
3430 val
= Fformat (nargs
, args
);
3432 /* The MS-DOS frames support popup menus even though they are
3433 not FRAME_WINDOW_P. */
3434 if (FRAME_WINDOW_P (XFRAME (selected_frame
))
3435 || FRAME_MSDOS_P (XFRAME (selected_frame
)))
3437 Lisp_Object pane
, menu
;
3438 struct gcpro gcpro1
;
3439 pane
= Fcons (Fcons (build_string ("OK"), Qt
), Qnil
);
3441 menu
= Fcons (val
, pane
);
3442 Fx_popup_dialog (Qt
, menu
, Qt
);
3446 #endif /* HAVE_MENUS */
3447 /* Copy the data so that it won't move when we GC. */
3450 message_text
= (char *)xmalloc (80);
3451 message_length
= 80;
3453 if (SBYTES (val
) > message_length
)
3455 message_length
= SBYTES (val
);
3456 message_text
= (char *)xrealloc (message_text
, message_length
);
3458 memcpy (message_text
, SDATA (val
), SBYTES (val
));
3459 message2 (message_text
, SBYTES (val
),
3460 STRING_MULTIBYTE (val
));
3465 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
3466 doc
: /* Display a message in a dialog box or in the echo area.
3467 If this command was invoked with the mouse, use a dialog box if
3468 `use-dialog-box' is non-nil.
3469 Otherwise, use the echo area.
3470 The first argument is a format control string, and the rest are data
3471 to be formatted under control of the string. See `format' for details.
3473 If the first argument is nil or the empty string, clear any existing
3474 message; let the minibuffer contents show.
3476 usage: (message-or-box FORMAT-STRING &rest ARGS) */)
3477 (size_t nargs
, Lisp_Object
*args
)
3480 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3482 return Fmessage_box (nargs
, args
);
3484 return Fmessage (nargs
, args
);
3487 DEFUN ("current-message", Fcurrent_message
, Scurrent_message
, 0, 0, 0,
3488 doc
: /* Return the string currently displayed in the echo area, or nil if none. */)
3491 return current_message ();
3495 DEFUN ("propertize", Fpropertize
, Spropertize
, 1, MANY
, 0,
3496 doc
: /* Return a copy of STRING with text properties added.
3497 First argument is the string to copy.
3498 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
3499 properties to add to the result.
3500 usage: (propertize STRING &rest PROPERTIES) */)
3501 (size_t nargs
, Lisp_Object
*args
)
3503 Lisp_Object properties
, string
;
3504 struct gcpro gcpro1
, gcpro2
;
3507 /* Number of args must be odd. */
3508 if ((nargs
& 1) == 0)
3509 error ("Wrong number of arguments");
3511 properties
= string
= Qnil
;
3512 GCPRO2 (properties
, string
);
3514 /* First argument must be a string. */
3515 CHECK_STRING (args
[0]);
3516 string
= Fcopy_sequence (args
[0]);
3518 for (i
= 1; i
< nargs
; i
+= 2)
3519 properties
= Fcons (args
[i
], Fcons (args
[i
+ 1], properties
));
3521 Fadd_text_properties (make_number (0),
3522 make_number (SCHARS (string
)),
3523 properties
, string
);
3524 RETURN_UNGCPRO (string
);
3527 /* pWIDE is a conversion for printing large decimal integers (possibly with a
3528 trailing "d" that is ignored). pWIDElen is its length. signed_wide and
3529 unsigned_wide are signed and unsigned types for printing them. Use widest
3530 integers if available so that more floating point values can be converted. */
3532 # define pWIDE PRIdMAX
3533 enum { pWIDElen
= sizeof PRIdMAX
- 2 }; /* Don't count trailing "d". */
3534 typedef intmax_t signed_wide
;
3535 typedef uintmax_t unsigned_wide
;
3538 enum { pWIDElen
= sizeof pI
- 1 };
3539 typedef EMACS_INT signed_wide
;
3540 typedef EMACS_UINT unsigned_wide
;
3543 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
3544 doc
: /* Format a string out of a format-string and arguments.
3545 The first argument is a format control string.
3546 The other arguments are substituted into it to make the result, a string.
3548 The format control string may contain %-sequences meaning to substitute
3549 the next available argument:
3551 %s means print a string argument. Actually, prints any object, with `princ'.
3552 %d means print as number in decimal (%o octal, %x hex).
3553 %X is like %x, but uses upper case.
3554 %e means print a number in exponential notation.
3555 %f means print a number in decimal-point notation.
3556 %g means print a number in exponential notation
3557 or decimal-point notation, whichever uses fewer characters.
3558 %c means print a number as a single character.
3559 %S means print any object as an s-expression (using `prin1').
3561 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
3562 Use %% to put a single % into the output.
3564 A %-sequence may contain optional flag, width, and precision
3565 specifiers, as follows:
3567 %<flags><width><precision>character
3569 where flags is [+ #-0]+, width is [0-9]+, and precision is .[0-9]+
3571 The + flag character inserts a + before any positive number, while a
3572 space inserts a space before any positive number; these flags only
3573 affect %d, %e, %f, and %g sequences, and the + flag takes precedence.
3574 The # flag means to use an alternate display form for %o, %x, %X, %e,
3575 %f, and %g sequences. The - and 0 flags affect the width specifier,
3578 The width specifier supplies a lower limit for the length of the
3579 printed representation. The padding, if any, normally goes on the
3580 left, but it goes on the right if the - flag is present. The padding
3581 character is normally a space, but it is 0 if the 0 flag is present.
3582 The - flag takes precedence over the 0 flag.
3584 For %e, %f, and %g sequences, the number after the "." in the
3585 precision specifier says how many decimal places to show; if zero, the
3586 decimal point itself is omitted. For %s and %S, the precision
3587 specifier truncates the string to the given width.
3589 usage: (format STRING &rest OBJECTS) */)
3590 (size_t nargs
, register Lisp_Object
*args
)
3592 EMACS_INT n
; /* The number of the next arg to substitute */
3593 char initial_buffer
[4000];
3594 char *buf
= initial_buffer
;
3595 EMACS_INT bufsize
= sizeof initial_buffer
;
3596 EMACS_INT max_bufsize
= STRING_BYTES_BOUND
+ 1;
3598 Lisp_Object buf_save_value
IF_LINT (= {0});
3599 register char *format
, *end
, *format_start
;
3600 EMACS_INT formatlen
, nchars
;
3601 /* Nonzero if the format is multibyte. */
3602 int multibyte_format
= 0;
3603 /* Nonzero if the output should be a multibyte string,
3604 which is true if any of the inputs is one. */
3606 /* When we make a multibyte string, we must pay attention to the
3607 byte combining problem, i.e., a byte may be combined with a
3608 multibyte character of the previous string. This flag tells if we
3609 must consider such a situation or not. */
3610 int maybe_combine_byte
;
3612 int arg_intervals
= 0;
3615 /* discarded[I] is 1 if byte I of the format
3616 string was not copied into the output.
3617 It is 2 if byte I was not the first byte of its character. */
3620 /* Each element records, for one argument,
3621 the start and end bytepos in the output string,
3622 whether the argument has been converted to string (e.g., due to "%S"),
3623 and whether the argument is a string with intervals.
3624 info[0] is unused. Unused elements have -1 for start. */
3627 EMACS_INT start
, end
;
3628 int converted_to_string
;
3632 /* It should not be necessary to GCPRO ARGS, because
3633 the caller in the interpreter should take care of that. */
3635 CHECK_STRING (args
[0]);
3636 format_start
= SSDATA (args
[0]);
3637 formatlen
= SBYTES (args
[0]);
3639 /* Allocate the info and discarded tables. */
3642 if ((SIZE_MAX
- formatlen
) / sizeof (struct info
) <= nargs
)
3643 memory_full (SIZE_MAX
);
3644 SAFE_ALLOCA (info
, struct info
*, (nargs
+ 1) * sizeof *info
+ formatlen
);
3645 discarded
= (char *) &info
[nargs
+ 1];
3646 for (i
= 0; i
< nargs
+ 1; i
++)
3649 info
[i
].intervals
= info
[i
].converted_to_string
= 0;
3651 memset (discarded
, 0, formatlen
);
3654 /* Try to determine whether the result should be multibyte.
3655 This is not always right; sometimes the result needs to be multibyte
3656 because of an object that we will pass through prin1,
3657 and in that case, we won't know it here. */
3658 multibyte_format
= STRING_MULTIBYTE (args
[0]);
3659 multibyte
= multibyte_format
;
3660 for (n
= 1; !multibyte
&& n
< nargs
; n
++)
3661 if (STRINGP (args
[n
]) && STRING_MULTIBYTE (args
[n
]))
3664 /* If we start out planning a unibyte result,
3665 then discover it has to be multibyte, we jump back to retry. */
3672 /* Scan the format and store result in BUF. */
3673 format
= format_start
;
3674 end
= format
+ formatlen
;
3675 maybe_combine_byte
= 0;
3677 while (format
!= end
)
3679 /* The values of N and FORMAT when the loop body is entered. */
3681 char *format0
= format
;
3683 /* Bytes needed to represent the output of this conversion. */
3684 EMACS_INT convbytes
;
3688 /* General format specifications look like
3690 '%' [flags] [field-width] [precision] format
3695 field-width ::= [0-9]+
3696 precision ::= '.' [0-9]*
3698 If a field-width is specified, it specifies to which width
3699 the output should be padded with blanks, if the output
3700 string is shorter than field-width.
3702 If precision is specified, it specifies the number of
3703 digits to print after the '.' for floats, or the max.
3704 number of chars to print from a string. */
3711 EMACS_INT field_width
;
3712 int precision_given
;
3713 uintmax_t precision
= UINTMAX_MAX
;
3721 case '-': minus_flag
= 1; continue;
3722 case '+': plus_flag
= 1; continue;
3723 case ' ': space_flag
= 1; continue;
3724 case '#': sharp_flag
= 1; continue;
3725 case '0': zero_flag
= 1; continue;
3730 /* Ignore flags when sprintf ignores them. */
3731 space_flag
&= ~ plus_flag
;
3732 zero_flag
&= ~ minus_flag
;
3735 uintmax_t w
= strtoumax (format
, &num_end
, 10);
3736 if (max_bufsize
<= w
)
3740 precision_given
= *num_end
== '.';
3741 if (precision_given
)
3742 precision
= strtoumax (num_end
+ 1, &num_end
, 10);
3746 error ("Format string ends in middle of format specifier");
3748 memset (&discarded
[format0
- format_start
], 1, format
- format0
);
3749 conversion
= *format
;
3750 if (conversion
== '%')
3752 discarded
[format
- format_start
] = 1;
3757 error ("Not enough arguments for format string");
3759 /* For 'S', prin1 the argument, and then treat like 's'.
3760 For 's', princ any argument that is not a string or
3761 symbol. But don't do this conversion twice, which might
3762 happen after retrying. */
3763 if ((conversion
== 'S'
3764 || (conversion
== 's'
3765 && ! STRINGP (args
[n
]) && ! SYMBOLP (args
[n
]))))
3767 if (! info
[n
].converted_to_string
)
3769 Lisp_Object noescape
= conversion
== 'S' ? Qnil
: Qt
;
3770 args
[n
] = Fprin1_to_string (args
[n
], noescape
);
3771 info
[n
].converted_to_string
= 1;
3772 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3780 else if (conversion
== 'c')
3782 if (FLOATP (args
[n
]))
3784 double d
= XFLOAT_DATA (args
[n
]);
3785 args
[n
] = make_number (FIXNUM_OVERFLOW_P (d
) ? -1 : d
);
3788 if (INTEGERP (args
[n
]) && ! ASCII_CHAR_P (XINT (args
[n
])))
3795 args
[n
] = Fchar_to_string (args
[n
]);
3796 info
[n
].converted_to_string
= 1;
3799 if (info
[n
].converted_to_string
)
3804 if (SYMBOLP (args
[n
]))
3806 args
[n
] = SYMBOL_NAME (args
[n
]);
3807 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3814 if (conversion
== 's')
3816 /* handle case (precision[n] >= 0) */
3818 EMACS_INT width
, padding
, nbytes
;
3819 EMACS_INT nchars_string
;
3821 EMACS_INT prec
= -1;
3822 if (precision_given
&& precision
<= TYPE_MAXIMUM (EMACS_INT
))
3825 /* lisp_string_width ignores a precision of 0, but GNU
3826 libc functions print 0 characters when the precision
3827 is 0. Imitate libc behavior here. Changing
3828 lisp_string_width is the right thing, and will be
3829 done, but meanwhile we work with it. */
3832 width
= nchars_string
= nbytes
= 0;
3836 width
= lisp_string_width (args
[n
], prec
, &nch
, &nby
);
3839 nchars_string
= SCHARS (args
[n
]);
3840 nbytes
= SBYTES (args
[n
]);
3844 nchars_string
= nch
;
3850 if (convbytes
&& multibyte
&& ! STRING_MULTIBYTE (args
[n
]))
3851 convbytes
= count_size_as_multibyte (SDATA (args
[n
]), nbytes
);
3853 padding
= width
< field_width
? field_width
- width
: 0;
3855 if (max_bufsize
- padding
<= convbytes
)
3857 convbytes
+= padding
;
3858 if (convbytes
<= buf
+ bufsize
- p
)
3862 memset (p
, ' ', padding
);
3869 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3870 && STRING_MULTIBYTE (args
[n
])
3871 && !CHAR_HEAD_P (SREF (args
[n
], 0)))
3872 maybe_combine_byte
= 1;
3874 p
+= copy_text (SDATA (args
[n
]), (unsigned char *) p
,
3876 STRING_MULTIBYTE (args
[n
]), multibyte
);
3878 info
[n
].start
= nchars
;
3879 nchars
+= nchars_string
;
3880 info
[n
].end
= nchars
;
3884 memset (p
, ' ', padding
);
3889 /* If this argument has text properties, record where
3890 in the result string it appears. */
3891 if (STRING_INTERVALS (args
[n
]))
3892 info
[n
].intervals
= arg_intervals
= 1;
3897 else if (! (conversion
== 'c' || conversion
== 'd'
3898 || conversion
== 'e' || conversion
== 'f'
3899 || conversion
== 'g' || conversion
== 'i'
3900 || conversion
== 'o' || conversion
== 'x'
3901 || conversion
== 'X'))
3902 error ("Invalid format operation %%%c",
3903 STRING_CHAR ((unsigned char *) format
- 1));
3904 else if (! (INTEGERP (args
[n
]) || FLOATP (args
[n
])))
3905 error ("Format specifier doesn't match argument type");
3910 /* Maximum precision for a %f conversion such that the
3911 trailing output digit might be nonzero. Any precisions
3912 larger than this will not yield useful information. */
3913 USEFUL_PRECISION_MAX
=
3915 * (FLT_RADIX
== 2 || FLT_RADIX
== 10 ? 1
3916 : FLT_RADIX
== 16 ? 4
3919 /* Maximum number of bytes generated by any format, if
3920 precision is no more than DBL_USEFUL_PRECISION_MAX.
3921 On all practical hosts, %f is the worst case. */
3923 sizeof "-." + (DBL_MAX_10_EXP
+ 1) + USEFUL_PRECISION_MAX
3925 verify (0 < USEFUL_PRECISION_MAX
);
3928 EMACS_INT padding
, sprintf_bytes
;
3929 uintmax_t excess_precision
, numwidth
;
3930 uintmax_t leading_zeros
= 0, trailing_zeros
= 0;
3932 char sprintf_buf
[SPRINTF_BUFSIZE
];
3934 /* Copy of conversion specification, modified somewhat.
3935 At most three flags F can be specified at once. */
3936 char convspec
[sizeof "%FFF.*d" + pWIDElen
];
3938 /* Avoid undefined behavior in underlying sprintf. */
3939 if (conversion
== 'd' || conversion
== 'i')
3942 /* Create the copy of the conversion specification, with
3943 any width and precision removed, with ".*" inserted,
3944 and with pWIDE inserted for integer formats. */
3948 *f
= '-'; f
+= minus_flag
;
3949 *f
= '+'; f
+= plus_flag
;
3950 *f
= ' '; f
+= space_flag
;
3951 *f
= '#'; f
+= sharp_flag
;
3952 *f
= '0'; f
+= zero_flag
;
3955 if (conversion
== 'd' || conversion
== 'i'
3956 || conversion
== 'o' || conversion
== 'x'
3957 || conversion
== 'X')
3959 memcpy (f
, pWIDE
, pWIDElen
);
3961 zero_flag
&= ~ precision_given
;
3968 if (precision_given
)
3969 prec
= min (precision
, USEFUL_PRECISION_MAX
);
3971 /* Use sprintf to format this number into sprintf_buf. Omit
3972 padding and excess precision, though, because sprintf limits
3973 output length to INT_MAX.
3975 There are four types of conversion: double, unsigned
3976 char (passed as int), wide signed int, and wide
3977 unsigned int. Treat them separately because the
3978 sprintf ABI is sensitive to which type is passed. Be
3979 careful about integer overflow, NaNs, infinities, and
3980 conversions; for example, the min and max macros are
3981 not suitable here. */
3982 if (conversion
== 'e' || conversion
== 'f' || conversion
== 'g')
3984 double x
= (INTEGERP (args
[n
])
3986 : XFLOAT_DATA (args
[n
]));
3987 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
3989 else if (conversion
== 'c')
3991 /* Don't use sprintf here, as it might mishandle prec. */
3992 sprintf_buf
[0] = XINT (args
[n
]);
3993 sprintf_bytes
= prec
!= 0;
3995 else if (conversion
== 'd')
3997 /* For float, maybe we should use "%1.0f"
3998 instead so it also works for values outside
3999 the integer range. */
4001 if (INTEGERP (args
[n
]))
4005 double d
= XFLOAT_DATA (args
[n
]);
4008 x
= TYPE_MINIMUM (signed_wide
);
4014 x
= TYPE_MAXIMUM (signed_wide
);
4019 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4023 /* Don't sign-extend for octal or hex printing. */
4025 if (INTEGERP (args
[n
]))
4026 x
= XUINT (args
[n
]);
4029 double d
= XFLOAT_DATA (args
[n
]);
4034 x
= TYPE_MAXIMUM (unsigned_wide
);
4039 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4042 /* Now the length of the formatted item is known, except it omits
4043 padding and excess precision. Deal with excess precision
4044 first. This happens only when the format specifies
4045 ridiculously large precision. */
4046 excess_precision
= precision
- prec
;
4047 if (excess_precision
)
4049 if (conversion
== 'e' || conversion
== 'f'
4050 || conversion
== 'g')
4052 if ((conversion
== 'g' && ! sharp_flag
)
4053 || ! ('0' <= sprintf_buf
[sprintf_bytes
- 1]
4054 && sprintf_buf
[sprintf_bytes
- 1] <= '9'))
4055 excess_precision
= 0;
4058 if (conversion
== 'g')
4060 char *dot
= strchr (sprintf_buf
, '.');
4062 excess_precision
= 0;
4065 trailing_zeros
= excess_precision
;
4068 leading_zeros
= excess_precision
;
4071 /* Compute the total bytes needed for this item, including
4072 excess precision and padding. */
4073 numwidth
= sprintf_bytes
+ excess_precision
;
4074 padding
= numwidth
< field_width
? field_width
- numwidth
: 0;
4075 if (max_bufsize
- sprintf_bytes
<= excess_precision
4076 || max_bufsize
- padding
<= numwidth
)
4078 convbytes
= numwidth
+ padding
;
4080 if (convbytes
<= buf
+ bufsize
- p
)
4082 /* Copy the formatted item from sprintf_buf into buf,
4083 inserting padding and excess-precision zeros. */
4085 char *src
= sprintf_buf
;
4087 int exponent_bytes
= 0;
4088 int signedp
= src0
== '-' || src0
== '+' || src0
== ' ';
4089 int significand_bytes
;
4091 && ((src
[signedp
] >= '0' && src
[signedp
] <= '9')
4092 || (src
[signedp
] >= 'a' && src
[signedp
] <= 'f')
4093 || (src
[signedp
] >= 'A' && src
[signedp
] <= 'F')))
4095 leading_zeros
+= padding
;
4099 if (excess_precision
4100 && (conversion
== 'e' || conversion
== 'g'))
4102 char *e
= strchr (src
, 'e');
4104 exponent_bytes
= src
+ sprintf_bytes
- e
;
4109 memset (p
, ' ', padding
);
4117 memset (p
, '0', leading_zeros
);
4119 significand_bytes
= sprintf_bytes
- signedp
- exponent_bytes
;
4120 memcpy (p
, src
, significand_bytes
);
4121 p
+= significand_bytes
;
4122 src
+= significand_bytes
;
4123 memset (p
, '0', trailing_zeros
);
4124 p
+= trailing_zeros
;
4125 memcpy (p
, src
, exponent_bytes
);
4126 p
+= exponent_bytes
;
4128 info
[n
].start
= nchars
;
4129 nchars
+= leading_zeros
+ sprintf_bytes
+ trailing_zeros
;
4130 info
[n
].end
= nchars
;
4134 memset (p
, ' ', padding
);
4146 /* Copy a single character from format to buf. */
4149 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
4151 if (multibyte_format
)
4153 /* Copy a whole multibyte character. */
4155 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
4156 && !CHAR_HEAD_P (*format
))
4157 maybe_combine_byte
= 1;
4161 while (! CHAR_HEAD_P (*format
));
4163 convbytes
= format
- format0
;
4164 memset (&discarded
[format0
+ 1 - format_start
], 2, convbytes
- 1);
4168 unsigned char uc
= *format
++;
4169 if (! multibyte
|| ASCII_BYTE_P (uc
))
4173 int c
= BYTE8_TO_CHAR (uc
);
4174 convbytes
= CHAR_STRING (c
, str
);
4179 if (convbytes
<= buf
+ bufsize
- p
)
4181 memcpy (p
, src
, convbytes
);
4188 /* There wasn't enough room to store this conversion or single
4189 character. CONVBYTES says how much room is needed. Allocate
4190 enough room (and then some) and do it again. */
4192 EMACS_INT used
= p
- buf
;
4194 if (max_bufsize
- used
< convbytes
)
4196 bufsize
= used
+ convbytes
;
4197 bufsize
= bufsize
< max_bufsize
/ 2 ? bufsize
* 2 : max_bufsize
;
4199 if (buf
== initial_buffer
)
4201 buf
= xmalloc (bufsize
);
4203 buf_save_value
= make_save_value (buf
, 0);
4204 record_unwind_protect (safe_alloca_unwind
, buf_save_value
);
4205 memcpy (buf
, initial_buffer
, used
);
4208 XSAVE_VALUE (buf_save_value
)->pointer
= buf
= xrealloc (buf
, bufsize
);
4217 if (bufsize
< p
- buf
)
4220 if (maybe_combine_byte
)
4221 nchars
= multibyte_chars_in_text ((unsigned char *) buf
, p
- buf
);
4222 val
= make_specified_string (buf
, nchars
, p
- buf
, multibyte
);
4224 /* If we allocated BUF with malloc, free it too. */
4227 /* If the format string has text properties, or any of the string
4228 arguments has text properties, set up text properties of the
4231 if (STRING_INTERVALS (args
[0]) || arg_intervals
)
4233 Lisp_Object len
, new_len
, props
;
4234 struct gcpro gcpro1
;
4236 /* Add text properties from the format string. */
4237 len
= make_number (SCHARS (args
[0]));
4238 props
= text_property_list (args
[0], make_number (0), len
, Qnil
);
4243 EMACS_INT bytepos
= 0, position
= 0, translated
= 0;
4247 /* Adjust the bounds of each text property
4248 to the proper start and end in the output string. */
4250 /* Put the positions in PROPS in increasing order, so that
4251 we can do (effectively) one scan through the position
4252 space of the format string. */
4253 props
= Fnreverse (props
);
4255 /* BYTEPOS is the byte position in the format string,
4256 POSITION is the untranslated char position in it,
4257 TRANSLATED is the translated char position in BUF,
4258 and ARGN is the number of the next arg we will come to. */
4259 for (list
= props
; CONSP (list
); list
= XCDR (list
))
4266 /* First adjust the property start position. */
4267 pos
= XINT (XCAR (item
));
4269 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
4270 up to this position. */
4271 for (; position
< pos
; bytepos
++)
4273 if (! discarded
[bytepos
])
4274 position
++, translated
++;
4275 else if (discarded
[bytepos
] == 1)
4278 if (translated
== info
[argn
].start
)
4280 translated
+= info
[argn
].end
- info
[argn
].start
;
4286 XSETCAR (item
, make_number (translated
));
4288 /* Likewise adjust the property end position. */
4289 pos
= XINT (XCAR (XCDR (item
)));
4291 for (; position
< pos
; bytepos
++)
4293 if (! discarded
[bytepos
])
4294 position
++, translated
++;
4295 else if (discarded
[bytepos
] == 1)
4298 if (translated
== info
[argn
].start
)
4300 translated
+= info
[argn
].end
- info
[argn
].start
;
4306 XSETCAR (XCDR (item
), make_number (translated
));
4309 add_text_properties_from_list (val
, props
, make_number (0));
4312 /* Add text properties from arguments. */
4314 for (n
= 1; n
< nargs
; ++n
)
4315 if (info
[n
].intervals
)
4317 len
= make_number (SCHARS (args
[n
]));
4318 new_len
= make_number (info
[n
].end
- info
[n
].start
);
4319 props
= text_property_list (args
[n
], make_number (0), len
, Qnil
);
4320 props
= extend_property_ranges (props
, new_len
);
4321 /* If successive arguments have properties, be sure that
4322 the value of `composition' property be the copy. */
4323 if (n
> 1 && info
[n
- 1].end
)
4324 make_composition_value_copy (props
);
4325 add_text_properties_from_list (val
, props
,
4326 make_number (info
[n
].start
));
4336 format2 (const char *string1
, Lisp_Object arg0
, Lisp_Object arg1
)
4338 Lisp_Object args
[3];
4339 args
[0] = build_string (string1
);
4342 return Fformat (3, args
);
4345 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
4346 doc
: /* Return t if two characters match, optionally ignoring case.
4347 Both arguments must be characters (i.e. integers).
4348 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
4349 (register Lisp_Object c1
, Lisp_Object c2
)
4352 /* Check they're chars, not just integers, otherwise we could get array
4353 bounds violations in downcase. */
4354 CHECK_CHARACTER (c1
);
4355 CHECK_CHARACTER (c2
);
4357 if (XINT (c1
) == XINT (c2
))
4359 if (NILP (BVAR (current_buffer
, case_fold_search
)))
4363 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
))
4364 && ! ASCII_CHAR_P (i1
))
4366 MAKE_CHAR_MULTIBYTE (i1
);
4369 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
))
4370 && ! ASCII_CHAR_P (i2
))
4372 MAKE_CHAR_MULTIBYTE (i2
);
4374 return (downcase (i1
) == downcase (i2
) ? Qt
: Qnil
);
4377 /* Transpose the markers in two regions of the current buffer, and
4378 adjust the ones between them if necessary (i.e.: if the regions
4381 START1, END1 are the character positions of the first region.
4382 START1_BYTE, END1_BYTE are the byte positions.
4383 START2, END2 are the character positions of the second region.
4384 START2_BYTE, END2_BYTE are the byte positions.
4386 Traverses the entire marker list of the buffer to do so, adding an
4387 appropriate amount to some, subtracting from some, and leaving the
4388 rest untouched. Most of this is copied from adjust_markers in insdel.c.
4390 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
4393 transpose_markers (EMACS_INT start1
, EMACS_INT end1
,
4394 EMACS_INT start2
, EMACS_INT end2
,
4395 EMACS_INT start1_byte
, EMACS_INT end1_byte
,
4396 EMACS_INT start2_byte
, EMACS_INT end2_byte
)
4398 register EMACS_INT amt1
, amt1_byte
, amt2
, amt2_byte
, diff
, diff_byte
, mpos
;
4399 register struct Lisp_Marker
*marker
;
4401 /* Update point as if it were a marker. */
4405 TEMP_SET_PT_BOTH (PT
+ (end2
- end1
),
4406 PT_BYTE
+ (end2_byte
- end1_byte
));
4407 else if (PT
< start2
)
4408 TEMP_SET_PT_BOTH (PT
+ (end2
- start2
) - (end1
- start1
),
4409 (PT_BYTE
+ (end2_byte
- start2_byte
)
4410 - (end1_byte
- start1_byte
)));
4412 TEMP_SET_PT_BOTH (PT
- (start2
- start1
),
4413 PT_BYTE
- (start2_byte
- start1_byte
));
4415 /* We used to adjust the endpoints here to account for the gap, but that
4416 isn't good enough. Even if we assume the caller has tried to move the
4417 gap out of our way, it might still be at start1 exactly, for example;
4418 and that places it `inside' the interval, for our purposes. The amount
4419 of adjustment is nontrivial if there's a `denormalized' marker whose
4420 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
4421 the dirty work to Fmarker_position, below. */
4423 /* The difference between the region's lengths */
4424 diff
= (end2
- start2
) - (end1
- start1
);
4425 diff_byte
= (end2_byte
- start2_byte
) - (end1_byte
- start1_byte
);
4427 /* For shifting each marker in a region by the length of the other
4428 region plus the distance between the regions. */
4429 amt1
= (end2
- start2
) + (start2
- end1
);
4430 amt2
= (end1
- start1
) + (start2
- end1
);
4431 amt1_byte
= (end2_byte
- start2_byte
) + (start2_byte
- end1_byte
);
4432 amt2_byte
= (end1_byte
- start1_byte
) + (start2_byte
- end1_byte
);
4434 for (marker
= BUF_MARKERS (current_buffer
); marker
; marker
= marker
->next
)
4436 mpos
= marker
->bytepos
;
4437 if (mpos
>= start1_byte
&& mpos
< end2_byte
)
4439 if (mpos
< end1_byte
)
4441 else if (mpos
< start2_byte
)
4445 marker
->bytepos
= mpos
;
4447 mpos
= marker
->charpos
;
4448 if (mpos
>= start1
&& mpos
< end2
)
4452 else if (mpos
< start2
)
4457 marker
->charpos
= mpos
;
4461 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
4462 doc
: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
4463 The regions should not be overlapping, because the size of the buffer is
4464 never changed in a transposition.
4466 Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
4467 any markers that happen to be located in the regions.
4469 Transposing beyond buffer boundaries is an error. */)
4470 (Lisp_Object startr1
, Lisp_Object endr1
, Lisp_Object startr2
, Lisp_Object endr2
, Lisp_Object leave_markers
)
4472 register EMACS_INT start1
, end1
, start2
, end2
;
4473 EMACS_INT start1_byte
, start2_byte
, len1_byte
, len2_byte
;
4474 EMACS_INT gap
, len1
, len_mid
, len2
;
4475 unsigned char *start1_addr
, *start2_addr
, *temp
;
4477 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
, tmp_interval3
;
4480 XSETBUFFER (buf
, current_buffer
);
4481 cur_intv
= BUF_INTERVALS (current_buffer
);
4483 validate_region (&startr1
, &endr1
);
4484 validate_region (&startr2
, &endr2
);
4486 start1
= XFASTINT (startr1
);
4487 end1
= XFASTINT (endr1
);
4488 start2
= XFASTINT (startr2
);
4489 end2
= XFASTINT (endr2
);
4492 /* Swap the regions if they're reversed. */
4495 register EMACS_INT glumph
= start1
;
4503 len1
= end1
- start1
;
4504 len2
= end2
- start2
;
4507 error ("Transposed regions overlap");
4508 /* Nothing to change for adjacent regions with one being empty */
4509 else if ((start1
== end1
|| start2
== end2
) && end1
== start2
)
4512 /* The possibilities are:
4513 1. Adjacent (contiguous) regions, or separate but equal regions
4514 (no, really equal, in this case!), or
4515 2. Separate regions of unequal size.
4517 The worst case is usually No. 2. It means that (aside from
4518 potential need for getting the gap out of the way), there also
4519 needs to be a shifting of the text between the two regions. So
4520 if they are spread far apart, we are that much slower... sigh. */
4522 /* It must be pointed out that the really studly thing to do would
4523 be not to move the gap at all, but to leave it in place and work
4524 around it if necessary. This would be extremely efficient,
4525 especially considering that people are likely to do
4526 transpositions near where they are working interactively, which
4527 is exactly where the gap would be found. However, such code
4528 would be much harder to write and to read. So, if you are
4529 reading this comment and are feeling squirrely, by all means have
4530 a go! I just didn't feel like doing it, so I will simply move
4531 the gap the minimum distance to get it out of the way, and then
4532 deal with an unbroken array. */
4534 /* Make sure the gap won't interfere, by moving it out of the text
4535 we will operate on. */
4536 if (start1
< gap
&& gap
< end2
)
4538 if (gap
- start1
< end2
- gap
)
4544 start1_byte
= CHAR_TO_BYTE (start1
);
4545 start2_byte
= CHAR_TO_BYTE (start2
);
4546 len1_byte
= CHAR_TO_BYTE (end1
) - start1_byte
;
4547 len2_byte
= CHAR_TO_BYTE (end2
) - start2_byte
;
4549 #ifdef BYTE_COMBINING_DEBUG
4552 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4553 len2_byte
, start1
, start1_byte
)
4554 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4555 len1_byte
, end2
, start2_byte
+ len2_byte
)
4556 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4557 len1_byte
, end2
, start2_byte
+ len2_byte
))
4562 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4563 len2_byte
, start1
, start1_byte
)
4564 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4565 len1_byte
, start2
, start2_byte
)
4566 || count_combining_after (BYTE_POS_ADDR (start2_byte
),
4567 len2_byte
, end1
, start1_byte
+ len1_byte
)
4568 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4569 len1_byte
, end2
, start2_byte
+ len2_byte
))
4574 /* Hmmm... how about checking to see if the gap is large
4575 enough to use as the temporary storage? That would avoid an
4576 allocation... interesting. Later, don't fool with it now. */
4578 /* Working without memmove, for portability (sigh), so must be
4579 careful of overlapping subsections of the array... */
4581 if (end1
== start2
) /* adjacent regions */
4583 modify_region (current_buffer
, start1
, end2
, 0);
4584 record_change (start1
, len1
+ len2
);
4586 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4587 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4588 /* Don't use Fset_text_properties: that can cause GC, which can
4589 clobber objects stored in the tmp_intervals. */
4590 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4591 if (!NULL_INTERVAL_P (tmp_interval3
))
4592 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4594 /* First region smaller than second. */
4595 if (len1_byte
< len2_byte
)
4599 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4601 /* Don't precompute these addresses. We have to compute them
4602 at the last minute, because the relocating allocator might
4603 have moved the buffer around during the xmalloc. */
4604 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4605 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4607 memcpy (temp
, start2_addr
, len2_byte
);
4608 memcpy (start1_addr
+ len2_byte
, start1_addr
, len1_byte
);
4609 memcpy (start1_addr
, temp
, len2_byte
);
4613 /* First region not smaller than second. */
4617 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4618 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4619 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4620 memcpy (temp
, start1_addr
, len1_byte
);
4621 memcpy (start1_addr
, start2_addr
, len2_byte
);
4622 memcpy (start1_addr
+ len2_byte
, temp
, len1_byte
);
4625 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
4626 len1
, current_buffer
, 0);
4627 graft_intervals_into_buffer (tmp_interval2
, start1
,
4628 len2
, current_buffer
, 0);
4629 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4630 update_compositions (start1
+ len2
, end2
, CHECK_TAIL
);
4632 /* Non-adjacent regions, because end1 != start2, bleagh... */
4635 len_mid
= start2_byte
- (start1_byte
+ len1_byte
);
4637 if (len1_byte
== len2_byte
)
4638 /* Regions are same size, though, how nice. */
4642 modify_region (current_buffer
, start1
, end1
, 0);
4643 modify_region (current_buffer
, start2
, end2
, 0);
4644 record_change (start1
, len1
);
4645 record_change (start2
, len2
);
4646 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4647 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4649 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr1
, 0);
4650 if (!NULL_INTERVAL_P (tmp_interval3
))
4651 set_text_properties_1 (startr1
, endr1
, Qnil
, buf
, tmp_interval3
);
4653 tmp_interval3
= validate_interval_range (buf
, &startr2
, &endr2
, 0);
4654 if (!NULL_INTERVAL_P (tmp_interval3
))
4655 set_text_properties_1 (startr2
, endr2
, Qnil
, buf
, tmp_interval3
);
4657 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4658 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4659 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4660 memcpy (temp
, start1_addr
, len1_byte
);
4661 memcpy (start1_addr
, start2_addr
, len2_byte
);
4662 memcpy (start2_addr
, temp
, len1_byte
);
4665 graft_intervals_into_buffer (tmp_interval1
, start2
,
4666 len1
, current_buffer
, 0);
4667 graft_intervals_into_buffer (tmp_interval2
, start1
,
4668 len2
, current_buffer
, 0);
4671 else if (len1_byte
< len2_byte
) /* Second region larger than first */
4672 /* Non-adjacent & unequal size, area between must also be shifted. */
4676 modify_region (current_buffer
, start1
, end2
, 0);
4677 record_change (start1
, (end2
- start1
));
4678 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4679 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4680 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4682 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4683 if (!NULL_INTERVAL_P (tmp_interval3
))
4684 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4686 /* holds region 2 */
4687 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4688 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4689 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4690 memcpy (temp
, start2_addr
, len2_byte
);
4691 memcpy (start1_addr
+ len_mid
+ len2_byte
, start1_addr
, len1_byte
);
4692 memmove (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
4693 memcpy (start1_addr
, temp
, len2_byte
);
4696 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4697 len1
, current_buffer
, 0);
4698 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4699 len_mid
, current_buffer
, 0);
4700 graft_intervals_into_buffer (tmp_interval2
, start1
,
4701 len2
, current_buffer
, 0);
4704 /* Second region smaller than first. */
4708 record_change (start1
, (end2
- start1
));
4709 modify_region (current_buffer
, start1
, end2
, 0);
4711 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4712 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4713 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4715 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4716 if (!NULL_INTERVAL_P (tmp_interval3
))
4717 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4719 /* holds region 1 */
4720 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4721 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4722 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4723 memcpy (temp
, start1_addr
, len1_byte
);
4724 memcpy (start1_addr
, start2_addr
, len2_byte
);
4725 memcpy (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
4726 memcpy (start1_addr
+ len2_byte
+ len_mid
, temp
, len1_byte
);
4729 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4730 len1
, current_buffer
, 0);
4731 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4732 len_mid
, current_buffer
, 0);
4733 graft_intervals_into_buffer (tmp_interval2
, start1
,
4734 len2
, current_buffer
, 0);
4737 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4738 update_compositions (end2
- len1
, end2
, CHECK_BORDER
);
4741 /* When doing multiple transpositions, it might be nice
4742 to optimize this. Perhaps the markers in any one buffer
4743 should be organized in some sorted data tree. */
4744 if (NILP (leave_markers
))
4746 transpose_markers (start1
, end1
, start2
, end2
,
4747 start1_byte
, start1_byte
+ len1_byte
,
4748 start2_byte
, start2_byte
+ len2_byte
);
4749 fix_start_end_in_overlays (start1
, end2
);
4752 signal_after_change (start1
, end2
- start1
, end2
- start1
);
4758 syms_of_editfns (void)
4763 Qbuffer_access_fontify_functions
4764 = intern_c_string ("buffer-access-fontify-functions");
4765 staticpro (&Qbuffer_access_fontify_functions
);
4767 DEFVAR_LISP ("inhibit-field-text-motion", Vinhibit_field_text_motion
,
4768 doc
: /* Non-nil means text motion commands don't notice fields. */);
4769 Vinhibit_field_text_motion
= Qnil
;
4771 DEFVAR_LISP ("buffer-access-fontify-functions",
4772 Vbuffer_access_fontify_functions
,
4773 doc
: /* List of functions called by `buffer-substring' to fontify if necessary.
4774 Each function is called with two arguments which specify the range
4775 of the buffer being accessed. */);
4776 Vbuffer_access_fontify_functions
= Qnil
;
4780 obuf
= Fcurrent_buffer ();
4781 /* Do this here, because init_buffer_once is too early--it won't work. */
4782 Fset_buffer (Vprin1_to_string_buffer
);
4783 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
4784 Fset (Fmake_local_variable (intern_c_string ("buffer-access-fontify-functions")),
4789 DEFVAR_LISP ("buffer-access-fontified-property",
4790 Vbuffer_access_fontified_property
,
4791 doc
: /* Property which (if non-nil) indicates text has been fontified.
4792 `buffer-substring' need not call the `buffer-access-fontify-functions'
4793 functions if all the text being accessed has this property. */);
4794 Vbuffer_access_fontified_property
= Qnil
;
4796 DEFVAR_LISP ("system-name", Vsystem_name
,
4797 doc
: /* The host name of the machine Emacs is running on. */);
4799 DEFVAR_LISP ("user-full-name", Vuser_full_name
,
4800 doc
: /* The full name of the user logged in. */);
4802 DEFVAR_LISP ("user-login-name", Vuser_login_name
,
4803 doc
: /* The user's name, taken from environment variables if possible. */);
4805 DEFVAR_LISP ("user-real-login-name", Vuser_real_login_name
,
4806 doc
: /* The user's name, based upon the real uid only. */);
4808 DEFVAR_LISP ("operating-system-release", Voperating_system_release
,
4809 doc
: /* The release of the operating system Emacs is running on. */);
4811 defsubr (&Spropertize
);
4812 defsubr (&Schar_equal
);
4813 defsubr (&Sgoto_char
);
4814 defsubr (&Sstring_to_char
);
4815 defsubr (&Schar_to_string
);
4816 defsubr (&Sbyte_to_string
);
4817 defsubr (&Sbuffer_substring
);
4818 defsubr (&Sbuffer_substring_no_properties
);
4819 defsubr (&Sbuffer_string
);
4821 defsubr (&Spoint_marker
);
4822 defsubr (&Smark_marker
);
4824 defsubr (&Sregion_beginning
);
4825 defsubr (&Sregion_end
);
4827 staticpro (&Qfield
);
4828 Qfield
= intern_c_string ("field");
4829 staticpro (&Qboundary
);
4830 Qboundary
= intern_c_string ("boundary");
4831 defsubr (&Sfield_beginning
);
4832 defsubr (&Sfield_end
);
4833 defsubr (&Sfield_string
);
4834 defsubr (&Sfield_string_no_properties
);
4835 defsubr (&Sdelete_field
);
4836 defsubr (&Sconstrain_to_field
);
4838 defsubr (&Sline_beginning_position
);
4839 defsubr (&Sline_end_position
);
4841 /* defsubr (&Smark); */
4842 /* defsubr (&Sset_mark); */
4843 defsubr (&Ssave_excursion
);
4844 defsubr (&Ssave_current_buffer
);
4846 defsubr (&Sbufsize
);
4847 defsubr (&Spoint_max
);
4848 defsubr (&Spoint_min
);
4849 defsubr (&Spoint_min_marker
);
4850 defsubr (&Spoint_max_marker
);
4851 defsubr (&Sgap_position
);
4852 defsubr (&Sgap_size
);
4853 defsubr (&Sposition_bytes
);
4854 defsubr (&Sbyte_to_position
);
4860 defsubr (&Sfollowing_char
);
4861 defsubr (&Sprevious_char
);
4862 defsubr (&Schar_after
);
4863 defsubr (&Schar_before
);
4865 defsubr (&Sinsert_before_markers
);
4866 defsubr (&Sinsert_and_inherit
);
4867 defsubr (&Sinsert_and_inherit_before_markers
);
4868 defsubr (&Sinsert_char
);
4869 defsubr (&Sinsert_byte
);
4871 defsubr (&Suser_login_name
);
4872 defsubr (&Suser_real_login_name
);
4873 defsubr (&Suser_uid
);
4874 defsubr (&Suser_real_uid
);
4875 defsubr (&Suser_full_name
);
4876 defsubr (&Semacs_pid
);
4877 defsubr (&Scurrent_time
);
4878 defsubr (&Sget_internal_run_time
);
4879 defsubr (&Sformat_time_string
);
4880 defsubr (&Sfloat_time
);
4881 defsubr (&Sdecode_time
);
4882 defsubr (&Sencode_time
);
4883 defsubr (&Scurrent_time_string
);
4884 defsubr (&Scurrent_time_zone
);
4885 defsubr (&Sset_time_zone_rule
);
4886 defsubr (&Ssystem_name
);
4887 defsubr (&Smessage
);
4888 defsubr (&Smessage_box
);
4889 defsubr (&Smessage_or_box
);
4890 defsubr (&Scurrent_message
);
4893 defsubr (&Sinsert_buffer_substring
);
4894 defsubr (&Scompare_buffer_substrings
);
4895 defsubr (&Ssubst_char_in_region
);
4896 defsubr (&Stranslate_region_internal
);
4897 defsubr (&Sdelete_region
);
4898 defsubr (&Sdelete_and_extract_region
);
4900 defsubr (&Snarrow_to_region
);
4901 defsubr (&Ssave_restriction
);
4902 defsubr (&Stranspose_regions
);