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>
53 #include "intervals.h"
55 #include "character.h"
59 #include "blockinput.h"
65 #ifndef USER_FULL_NAME
66 #define USER_FULL_NAME pw->pw_gecos
70 extern char **environ
;
73 #define TM_YEAR_BASE 1900
75 /* Nonzero if TM_YEAR is a struct tm's tm_year value that causes
76 asctime to have well-defined behavior. */
77 #ifndef TM_YEAR_IN_ASCTIME_RANGE
78 # define TM_YEAR_IN_ASCTIME_RANGE(tm_year) \
79 (1000 - TM_YEAR_BASE <= (tm_year) && (tm_year) <= 9999 - TM_YEAR_BASE)
83 extern Lisp_Object
w32_get_internal_run_time (void);
86 static void time_overflow (void) NO_RETURN
;
87 static int tm_diff (struct tm
*, struct tm
*);
88 static void find_field (Lisp_Object
, Lisp_Object
, Lisp_Object
,
89 EMACS_INT
*, Lisp_Object
, EMACS_INT
*);
90 static void update_buffer_properties (EMACS_INT
, EMACS_INT
);
91 static Lisp_Object
region_limit (int);
92 static size_t emacs_nmemftime (char *, size_t, const char *,
93 size_t, const struct tm
*, int, int);
94 static void general_insert_function (void (*) (const char *, EMACS_INT
),
95 void (*) (Lisp_Object
, EMACS_INT
,
98 int, size_t, Lisp_Object
*);
99 static Lisp_Object
subst_char_in_region_unwind (Lisp_Object
);
100 static Lisp_Object
subst_char_in_region_unwind_1 (Lisp_Object
);
101 static void transpose_markers (EMACS_INT
, EMACS_INT
, EMACS_INT
, EMACS_INT
,
102 EMACS_INT
, EMACS_INT
, EMACS_INT
, EMACS_INT
);
104 static Lisp_Object Qbuffer_access_fontify_functions
;
105 static Lisp_Object
Fuser_full_name (Lisp_Object
);
107 /* Symbol for the text property used to mark fields. */
111 /* A special value for Qfield properties. */
113 static Lisp_Object Qboundary
;
119 const char *user_name
;
121 struct passwd
*pw
; /* password entry for the current user */
124 /* Set up system_name even when dumping. */
128 /* Don't bother with this on initial start when just dumping out */
131 #endif /* not CANNOT_DUMP */
133 pw
= getpwuid (getuid ());
135 /* We let the real user name default to "root" because that's quite
136 accurate on MSDOG and because it lets Emacs find the init file.
137 (The DVX libraries override the Djgpp libraries here.) */
138 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "root");
140 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "unknown");
143 /* Get the effective user name, by consulting environment variables,
144 or the effective uid if those are unset. */
145 user_name
= getenv ("LOGNAME");
148 user_name
= getenv ("USERNAME"); /* it's USERNAME on NT */
149 #else /* WINDOWSNT */
150 user_name
= getenv ("USER");
151 #endif /* WINDOWSNT */
154 pw
= getpwuid (geteuid ());
155 user_name
= pw
? pw
->pw_name
: "unknown";
157 Vuser_login_name
= build_string (user_name
);
159 /* If the user name claimed in the environment vars differs from
160 the real uid, use the claimed name to find the full name. */
161 tem
= Fstring_equal (Vuser_login_name
, Vuser_real_login_name
);
162 Vuser_full_name
= Fuser_full_name (NILP (tem
)? make_number (geteuid())
167 Vuser_full_name
= build_string (p
);
168 else if (NILP (Vuser_full_name
))
169 Vuser_full_name
= build_string ("unknown");
171 #ifdef HAVE_SYS_UTSNAME_H
175 Voperating_system_release
= build_string (uts
.release
);
178 Voperating_system_release
= Qnil
;
182 DEFUN ("char-to-string", Fchar_to_string
, Schar_to_string
, 1, 1, 0,
183 doc
: /* Convert arg CHAR to a string containing that character.
184 usage: (char-to-string CHAR) */)
185 (Lisp_Object character
)
188 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
190 CHECK_CHARACTER (character
);
192 len
= CHAR_STRING (XFASTINT (character
), str
);
193 return make_string_from_bytes ((char *) str
, 1, len
);
196 DEFUN ("byte-to-string", Fbyte_to_string
, Sbyte_to_string
, 1, 1, 0,
197 doc
: /* Convert arg BYTE to a unibyte string containing that byte. */)
202 if (XINT (byte
) < 0 || XINT (byte
) > 255)
203 error ("Invalid byte");
205 return make_string_from_bytes ((char *) &b
, 1, 1);
208 DEFUN ("string-to-char", Fstring_to_char
, Sstring_to_char
, 1, 1, 0,
209 doc
: /* Convert arg STRING to a character, the first character of that string.
210 A multibyte character is handled correctly. */)
211 (register Lisp_Object string
)
213 register Lisp_Object val
;
214 CHECK_STRING (string
);
217 if (STRING_MULTIBYTE (string
))
218 XSETFASTINT (val
, STRING_CHAR (SDATA (string
)));
220 XSETFASTINT (val
, SREF (string
, 0));
223 XSETFASTINT (val
, 0);
228 buildmark (EMACS_INT charpos
, EMACS_INT bytepos
)
230 register Lisp_Object mark
;
231 mark
= Fmake_marker ();
232 set_marker_both (mark
, Qnil
, charpos
, bytepos
);
236 DEFUN ("point", Fpoint
, Spoint
, 0, 0, 0,
237 doc
: /* Return value of point, as an integer.
238 Beginning of buffer is position (point-min). */)
242 XSETFASTINT (temp
, PT
);
246 DEFUN ("point-marker", Fpoint_marker
, Spoint_marker
, 0, 0, 0,
247 doc
: /* Return value of point, as a marker object. */)
250 return buildmark (PT
, PT_BYTE
);
254 clip_to_bounds (EMACS_INT lower
, EMACS_INT num
, EMACS_INT upper
)
258 else if (num
> upper
)
264 DEFUN ("goto-char", Fgoto_char
, Sgoto_char
, 1, 1, "NGoto char: ",
265 doc
: /* Set point to POSITION, a number or marker.
266 Beginning of buffer is position (point-min), end is (point-max).
268 The return value is POSITION. */)
269 (register Lisp_Object position
)
273 if (MARKERP (position
)
274 && current_buffer
== XMARKER (position
)->buffer
)
276 pos
= marker_position (position
);
278 SET_PT_BOTH (BEGV
, BEGV_BYTE
);
280 SET_PT_BOTH (ZV
, ZV_BYTE
);
282 SET_PT_BOTH (pos
, marker_byte_position (position
));
287 CHECK_NUMBER_COERCE_MARKER (position
);
289 pos
= clip_to_bounds (BEGV
, XINT (position
), ZV
);
295 /* Return the start or end position of the region.
296 BEGINNINGP non-zero means return the start.
297 If there is no region active, signal an error. */
300 region_limit (int beginningp
)
304 if (!NILP (Vtransient_mark_mode
)
305 && NILP (Vmark_even_if_inactive
)
306 && NILP (BVAR (current_buffer
, mark_active
)))
307 xsignal0 (Qmark_inactive
);
309 m
= Fmarker_position (BVAR (current_buffer
, mark
));
311 error ("The mark is not set now, so there is no region");
313 if ((PT
< XFASTINT (m
)) == (beginningp
!= 0))
314 m
= make_number (PT
);
318 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
319 doc
: /* Return the integer value of point or mark, whichever is smaller. */)
322 return region_limit (1);
325 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
326 doc
: /* Return the integer value of point or mark, whichever is larger. */)
329 return region_limit (0);
332 DEFUN ("mark-marker", Fmark_marker
, Smark_marker
, 0, 0, 0,
333 doc
: /* Return this buffer's mark, as a marker object.
334 Watch out! Moving this marker changes the mark position.
335 If you set the marker not to point anywhere, the buffer will have no mark. */)
338 return BVAR (current_buffer
, mark
);
342 /* Find all the overlays in the current buffer that touch position POS.
343 Return the number found, and store them in a vector in VEC
347 overlays_around (EMACS_INT pos
, Lisp_Object
*vec
, int len
)
349 Lisp_Object overlay
, start
, end
;
350 struct Lisp_Overlay
*tail
;
351 EMACS_INT startpos
, endpos
;
354 for (tail
= current_buffer
->overlays_before
; tail
; tail
= tail
->next
)
356 XSETMISC (overlay
, tail
);
358 end
= OVERLAY_END (overlay
);
359 endpos
= OVERLAY_POSITION (end
);
362 start
= OVERLAY_START (overlay
);
363 startpos
= OVERLAY_POSITION (start
);
368 /* Keep counting overlays even if we can't return them all. */
373 for (tail
= current_buffer
->overlays_after
; tail
; tail
= tail
->next
)
375 XSETMISC (overlay
, tail
);
377 start
= OVERLAY_START (overlay
);
378 startpos
= OVERLAY_POSITION (start
);
381 end
= OVERLAY_END (overlay
);
382 endpos
= OVERLAY_POSITION (end
);
394 /* Return the value of property PROP, in OBJECT at POSITION.
395 It's the value of PROP that a char inserted at POSITION would get.
396 OBJECT is optional and defaults to the current buffer.
397 If OBJECT is a buffer, then overlay properties are considered as well as
399 If OBJECT is a window, then that window's buffer is used, but
400 window-specific overlays are considered only if they are associated
403 get_pos_property (Lisp_Object position
, register Lisp_Object prop
, Lisp_Object object
)
405 CHECK_NUMBER_COERCE_MARKER (position
);
408 XSETBUFFER (object
, current_buffer
);
409 else if (WINDOWP (object
))
410 object
= XWINDOW (object
)->buffer
;
412 if (!BUFFERP (object
))
413 /* pos-property only makes sense in buffers right now, since strings
414 have no overlays and no notion of insertion for which stickiness
416 return Fget_text_property (position
, prop
, object
);
419 EMACS_INT posn
= XINT (position
);
421 Lisp_Object
*overlay_vec
, tem
;
422 struct buffer
*obuf
= current_buffer
;
424 set_buffer_temp (XBUFFER (object
));
426 /* First try with room for 40 overlays. */
428 overlay_vec
= (Lisp_Object
*) alloca (noverlays
* sizeof (Lisp_Object
));
429 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
431 /* If there are more than 40,
432 make enough space for all, and try again. */
435 overlay_vec
= (Lisp_Object
*) alloca (noverlays
* sizeof (Lisp_Object
));
436 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
438 noverlays
= sort_overlays (overlay_vec
, noverlays
, NULL
);
440 set_buffer_temp (obuf
);
442 /* Now check the overlays in order of decreasing priority. */
443 while (--noverlays
>= 0)
445 Lisp_Object ol
= overlay_vec
[noverlays
];
446 tem
= Foverlay_get (ol
, prop
);
449 /* Check the overlay is indeed active at point. */
450 Lisp_Object start
= OVERLAY_START (ol
), finish
= OVERLAY_END (ol
);
451 if ((OVERLAY_POSITION (start
) == posn
452 && XMARKER (start
)->insertion_type
== 1)
453 || (OVERLAY_POSITION (finish
) == posn
454 && XMARKER (finish
)->insertion_type
== 0))
455 ; /* The overlay will not cover a char inserted at point. */
463 { /* Now check the text properties. */
464 int stickiness
= text_property_stickiness (prop
, position
, object
);
466 return Fget_text_property (position
, prop
, object
);
467 else if (stickiness
< 0
468 && XINT (position
) > BUF_BEGV (XBUFFER (object
)))
469 return Fget_text_property (make_number (XINT (position
) - 1),
477 /* Find the field surrounding POS in *BEG and *END. If POS is nil,
478 the value of point is used instead. If BEG or END is null,
479 means don't store the beginning or end of the field.
481 BEG_LIMIT and END_LIMIT serve to limit the ranged of the returned
482 results; they do not effect boundary behavior.
484 If MERGE_AT_BOUNDARY is nonzero, then if POS is at the very first
485 position of a field, then the beginning of the previous field is
486 returned instead of the beginning of POS's field (since the end of a
487 field is actually also the beginning of the next input field, this
488 behavior is sometimes useful). Additionally in the MERGE_AT_BOUNDARY
489 true case, if two fields are separated by a field with the special
490 value `boundary', and POS lies within it, then the two separated
491 fields are considered to be adjacent, and POS between them, when
492 finding the beginning and ending of the "merged" field.
494 Either BEG or END may be 0, in which case the corresponding value
498 find_field (Lisp_Object pos
, Lisp_Object merge_at_boundary
,
499 Lisp_Object beg_limit
,
500 EMACS_INT
*beg
, Lisp_Object end_limit
, EMACS_INT
*end
)
502 /* Fields right before and after the point. */
503 Lisp_Object before_field
, after_field
;
504 /* 1 if POS counts as the start of a field. */
505 int at_field_start
= 0;
506 /* 1 if POS counts as the end of a field. */
507 int at_field_end
= 0;
510 XSETFASTINT (pos
, PT
);
512 CHECK_NUMBER_COERCE_MARKER (pos
);
515 = get_char_property_and_overlay (pos
, Qfield
, Qnil
, NULL
);
517 = (XFASTINT (pos
) > BEGV
518 ? get_char_property_and_overlay (make_number (XINT (pos
) - 1),
520 /* Using nil here would be a more obvious choice, but it would
521 fail when the buffer starts with a non-sticky field. */
524 /* See if we need to handle the case where MERGE_AT_BOUNDARY is nil
525 and POS is at beginning of a field, which can also be interpreted
526 as the end of the previous field. Note that the case where if
527 MERGE_AT_BOUNDARY is non-nil (see function comment) is actually the
528 more natural one; then we avoid treating the beginning of a field
530 if (NILP (merge_at_boundary
))
532 Lisp_Object field
= get_pos_property (pos
, Qfield
, Qnil
);
533 if (!EQ (field
, after_field
))
535 if (!EQ (field
, before_field
))
537 if (NILP (field
) && at_field_start
&& at_field_end
)
538 /* If an inserted char would have a nil field while the surrounding
539 text is non-nil, we're probably not looking at a
540 zero-length field, but instead at a non-nil field that's
541 not intended for editing (such as comint's prompts). */
542 at_field_end
= at_field_start
= 0;
545 /* Note about special `boundary' fields:
547 Consider the case where the point (`.') is between the fields `x' and `y':
551 In this situation, if merge_at_boundary is true, we consider the
552 `x' and `y' fields as forming one big merged field, and so the end
553 of the field is the end of `y'.
555 However, if `x' and `y' are separated by a special `boundary' field
556 (a field with a `field' char-property of 'boundary), then we ignore
557 this special field when merging adjacent fields. Here's the same
558 situation, but with a `boundary' field between the `x' and `y' fields:
562 Here, if point is at the end of `x', the beginning of `y', or
563 anywhere in-between (within the `boundary' field), we merge all
564 three fields and consider the beginning as being the beginning of
565 the `x' field, and the end as being the end of the `y' field. */
570 /* POS is at the edge of a field, and we should consider it as
571 the beginning of the following field. */
572 *beg
= XFASTINT (pos
);
574 /* Find the previous field boundary. */
577 if (!NILP (merge_at_boundary
) && EQ (before_field
, Qboundary
))
578 /* Skip a `boundary' field. */
579 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
582 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
584 *beg
= NILP (p
) ? BEGV
: XFASTINT (p
);
591 /* POS is at the edge of a field, and we should consider it as
592 the end of the previous field. */
593 *end
= XFASTINT (pos
);
595 /* Find the next field boundary. */
597 if (!NILP (merge_at_boundary
) && EQ (after_field
, Qboundary
))
598 /* Skip a `boundary' field. */
599 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
602 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
604 *end
= NILP (pos
) ? ZV
: XFASTINT (pos
);
610 DEFUN ("delete-field", Fdelete_field
, Sdelete_field
, 0, 1, 0,
611 doc
: /* Delete the field surrounding POS.
612 A field is a region of text with the same `field' property.
613 If POS is nil, the value of point is used for POS. */)
617 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
619 del_range (beg
, end
);
623 DEFUN ("field-string", Ffield_string
, Sfield_string
, 0, 1, 0,
624 doc
: /* Return the contents of the field surrounding POS as a string.
625 A field is a region of text with the same `field' property.
626 If POS is nil, the value of point is used for POS. */)
630 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
631 return make_buffer_string (beg
, end
, 1);
634 DEFUN ("field-string-no-properties", Ffield_string_no_properties
, Sfield_string_no_properties
, 0, 1, 0,
635 doc
: /* Return the contents of the field around POS, without text properties.
636 A field is a region of text with the same `field' property.
637 If POS is nil, the value of point is used for POS. */)
641 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
642 return make_buffer_string (beg
, end
, 0);
645 DEFUN ("field-beginning", Ffield_beginning
, Sfield_beginning
, 0, 3, 0,
646 doc
: /* Return the beginning of the field surrounding POS.
647 A field is a region of text with the same `field' property.
648 If POS is nil, the value of point is used for POS.
649 If ESCAPE-FROM-EDGE is non-nil and POS is at the beginning of its
650 field, then the beginning of the *previous* field is returned.
651 If LIMIT is non-nil, it is a buffer position; if the beginning of the field
652 is before LIMIT, then LIMIT will be returned instead. */)
653 (Lisp_Object pos
, Lisp_Object escape_from_edge
, Lisp_Object limit
)
656 find_field (pos
, escape_from_edge
, limit
, &beg
, Qnil
, 0);
657 return make_number (beg
);
660 DEFUN ("field-end", Ffield_end
, Sfield_end
, 0, 3, 0,
661 doc
: /* Return the end of the field surrounding POS.
662 A field is a region of text with the same `field' property.
663 If POS is nil, the value of point is used for POS.
664 If ESCAPE-FROM-EDGE is non-nil and POS is at the end of its field,
665 then the end of the *following* field is returned.
666 If LIMIT is non-nil, it is a buffer position; if the end of the field
667 is after LIMIT, then LIMIT will be returned instead. */)
668 (Lisp_Object pos
, Lisp_Object escape_from_edge
, Lisp_Object limit
)
671 find_field (pos
, escape_from_edge
, Qnil
, 0, limit
, &end
);
672 return make_number (end
);
675 DEFUN ("constrain-to-field", Fconstrain_to_field
, Sconstrain_to_field
, 2, 5, 0,
676 doc
: /* Return the position closest to NEW-POS that is in the same field as OLD-POS.
678 A field is a region of text with the same `field' property.
679 If NEW-POS is nil, then the current point is used instead, and set to the
680 constrained position if that is different.
682 If OLD-POS is at the boundary of two fields, then the allowable
683 positions for NEW-POS depends on the value of the optional argument
684 ESCAPE-FROM-EDGE: If ESCAPE-FROM-EDGE is nil, then NEW-POS is
685 constrained to the field that has the same `field' char-property
686 as any new characters inserted at OLD-POS, whereas if ESCAPE-FROM-EDGE
687 is non-nil, NEW-POS is constrained to the union of the two adjacent
688 fields. Additionally, if two fields are separated by another field with
689 the special value `boundary', then any point within this special field is
690 also considered to be `on the boundary'.
692 If the optional argument ONLY-IN-LINE is non-nil and constraining
693 NEW-POS would move it to a different line, NEW-POS is returned
694 unconstrained. This useful for commands that move by line, like
695 \\[next-line] or \\[beginning-of-line], which should generally respect field boundaries
696 only in the case where they can still move to the right line.
698 If the optional argument INHIBIT-CAPTURE-PROPERTY is non-nil, and OLD-POS has
699 a non-nil property of that name, then any field boundaries are ignored.
701 Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
702 (Lisp_Object new_pos
, Lisp_Object old_pos
, Lisp_Object escape_from_edge
, Lisp_Object only_in_line
, Lisp_Object inhibit_capture_property
)
704 /* If non-zero, then the original point, before re-positioning. */
705 EMACS_INT orig_point
= 0;
707 Lisp_Object prev_old
, prev_new
;
710 /* Use the current point, and afterwards, set it. */
713 XSETFASTINT (new_pos
, PT
);
716 CHECK_NUMBER_COERCE_MARKER (new_pos
);
717 CHECK_NUMBER_COERCE_MARKER (old_pos
);
719 fwd
= (XFASTINT (new_pos
) > XFASTINT (old_pos
));
721 prev_old
= make_number (XFASTINT (old_pos
) - 1);
722 prev_new
= make_number (XFASTINT (new_pos
) - 1);
724 if (NILP (Vinhibit_field_text_motion
)
725 && !EQ (new_pos
, old_pos
)
726 && (!NILP (Fget_char_property (new_pos
, Qfield
, Qnil
))
727 || !NILP (Fget_char_property (old_pos
, Qfield
, Qnil
))
728 /* To recognize field boundaries, we must also look at the
729 previous positions; we could use `get_pos_property'
730 instead, but in itself that would fail inside non-sticky
731 fields (like comint prompts). */
732 || (XFASTINT (new_pos
) > BEGV
733 && !NILP (Fget_char_property (prev_new
, Qfield
, Qnil
)))
734 || (XFASTINT (old_pos
) > BEGV
735 && !NILP (Fget_char_property (prev_old
, Qfield
, Qnil
))))
736 && (NILP (inhibit_capture_property
)
737 /* Field boundaries are again a problem; but now we must
738 decide the case exactly, so we need to call
739 `get_pos_property' as well. */
740 || (NILP (get_pos_property (old_pos
, inhibit_capture_property
, Qnil
))
741 && (XFASTINT (old_pos
) <= BEGV
742 || NILP (Fget_char_property (old_pos
, inhibit_capture_property
, Qnil
))
743 || NILP (Fget_char_property (prev_old
, inhibit_capture_property
, Qnil
))))))
744 /* It is possible that NEW_POS is not within the same field as
745 OLD_POS; try to move NEW_POS so that it is. */
748 Lisp_Object field_bound
;
751 field_bound
= Ffield_end (old_pos
, escape_from_edge
, new_pos
);
753 field_bound
= Ffield_beginning (old_pos
, escape_from_edge
, new_pos
);
755 if (/* See if ESCAPE_FROM_EDGE caused FIELD_BOUND to jump to the
756 other side of NEW_POS, which would mean that NEW_POS is
757 already acceptable, and it's not necessary to constrain it
759 ((XFASTINT (field_bound
) < XFASTINT (new_pos
)) ? fwd
: !fwd
)
760 /* NEW_POS should be constrained, but only if either
761 ONLY_IN_LINE is nil (in which case any constraint is OK),
762 or NEW_POS and FIELD_BOUND are on the same line (in which
763 case the constraint is OK even if ONLY_IN_LINE is non-nil). */
764 && (NILP (only_in_line
)
765 /* This is the ONLY_IN_LINE case, check that NEW_POS and
766 FIELD_BOUND are on the same line by seeing whether
767 there's an intervening newline or not. */
768 || (scan_buffer ('\n',
769 XFASTINT (new_pos
), XFASTINT (field_bound
),
770 fwd
? -1 : 1, &shortage
, 1),
772 /* Constrain NEW_POS to FIELD_BOUND. */
773 new_pos
= field_bound
;
775 if (orig_point
&& XFASTINT (new_pos
) != orig_point
)
776 /* The NEW_POS argument was originally nil, so automatically set PT. */
777 SET_PT (XFASTINT (new_pos
));
784 DEFUN ("line-beginning-position",
785 Fline_beginning_position
, Sline_beginning_position
, 0, 1, 0,
786 doc
: /* Return the character position of the first character on the current line.
787 With argument N not nil or 1, move forward N - 1 lines first.
788 If scan reaches end of buffer, return that position.
790 The returned position is of the first character in the logical order,
791 i.e. the one that has the smallest character position.
793 This function constrains the returned position to the current field
794 unless that would be on a different line than the original,
795 unconstrained result. If N is nil or 1, and a front-sticky field
796 starts at point, the scan stops as soon as it starts. To ignore field
797 boundaries bind `inhibit-field-text-motion' to t.
799 This function does not move point. */)
802 EMACS_INT orig
, orig_byte
, end
;
803 int count
= SPECPDL_INDEX ();
804 specbind (Qinhibit_point_motion_hooks
, Qt
);
813 Fforward_line (make_number (XINT (n
) - 1));
816 SET_PT_BOTH (orig
, orig_byte
);
818 unbind_to (count
, Qnil
);
820 /* Return END constrained to the current input field. */
821 return Fconstrain_to_field (make_number (end
), make_number (orig
),
822 XINT (n
) != 1 ? Qt
: Qnil
,
826 DEFUN ("line-end-position", Fline_end_position
, Sline_end_position
, 0, 1, 0,
827 doc
: /* Return the character position of the last character on the current line.
828 With argument N not nil or 1, move forward N - 1 lines first.
829 If scan reaches end of buffer, return that position.
831 The returned position is of the last character in the logical order,
832 i.e. the character whose buffer position is the largest one.
834 This function constrains the returned position to the current field
835 unless that would be on a different line than the original,
836 unconstrained result. If N is nil or 1, and a rear-sticky field ends
837 at point, the scan stops as soon as it starts. To ignore field
838 boundaries bind `inhibit-field-text-motion' to t.
840 This function does not move point. */)
851 end_pos
= find_before_next_newline (orig
, 0, XINT (n
) - (XINT (n
) <= 0));
853 /* Return END_POS constrained to the current input field. */
854 return Fconstrain_to_field (make_number (end_pos
), make_number (orig
),
860 save_excursion_save (void)
862 int visible
= (XBUFFER (XWINDOW (selected_window
)->buffer
)
865 return Fcons (Fpoint_marker (),
866 Fcons (Fcopy_marker (BVAR (current_buffer
, mark
), Qnil
),
867 Fcons (visible
? Qt
: Qnil
,
868 Fcons (BVAR (current_buffer
, mark_active
),
873 save_excursion_restore (Lisp_Object info
)
875 Lisp_Object tem
, tem1
, omark
, nmark
;
876 struct gcpro gcpro1
, gcpro2
, gcpro3
;
879 tem
= Fmarker_buffer (XCAR (info
));
880 /* If buffer being returned to is now deleted, avoid error */
881 /* Otherwise could get error here while unwinding to top level
883 /* In that case, Fmarker_buffer returns nil now. */
887 omark
= nmark
= Qnil
;
888 GCPRO3 (info
, omark
, nmark
);
895 unchain_marker (XMARKER (tem
));
900 omark
= Fmarker_position (BVAR (current_buffer
, mark
));
901 Fset_marker (BVAR (current_buffer
, mark
), tem
, Fcurrent_buffer ());
902 nmark
= Fmarker_position (tem
);
903 unchain_marker (XMARKER (tem
));
907 visible_p
= !NILP (XCAR (info
));
909 #if 0 /* We used to make the current buffer visible in the selected window
910 if that was true previously. That avoids some anomalies.
911 But it creates others, and it wasn't documented, and it is simpler
912 and cleaner never to alter the window/buffer connections. */
915 && current_buffer
!= XBUFFER (XWINDOW (selected_window
)->buffer
))
916 Fswitch_to_buffer (Fcurrent_buffer (), Qnil
);
922 tem1
= BVAR (current_buffer
, mark_active
);
923 BVAR (current_buffer
, mark_active
) = tem
;
925 /* If mark is active now, and either was not active
926 or was at a different place, run the activate hook. */
929 if (! EQ (omark
, nmark
))
931 tem
= intern ("activate-mark-hook");
932 Frun_hooks (1, &tem
);
935 /* If mark has ceased to be active, run deactivate hook. */
936 else if (! NILP (tem1
))
938 tem
= intern ("deactivate-mark-hook");
939 Frun_hooks (1, &tem
);
942 /* If buffer was visible in a window, and a different window was
943 selected, and the old selected window is still showing this
944 buffer, restore point in that window. */
947 && !EQ (tem
, selected_window
)
948 && (tem1
= XWINDOW (tem
)->buffer
,
949 (/* Window is live... */
951 /* ...and it shows the current buffer. */
952 && XBUFFER (tem1
) == current_buffer
)))
953 Fset_window_point (tem
, make_number (PT
));
959 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
960 doc
: /* Save point, mark, and current buffer; execute BODY; restore those things.
961 Executes BODY just like `progn'.
962 The values of point, mark and the current buffer are restored
963 even in case of abnormal exit (throw or error).
964 The state of activation of the mark is also restored.
966 This construct does not save `deactivate-mark', and therefore
967 functions that change the buffer will still cause deactivation
968 of the mark at the end of the command. To prevent that, bind
969 `deactivate-mark' with `let'.
971 If you only want to save the current buffer but not point nor mark,
972 then just use `save-current-buffer', or even `with-current-buffer'.
974 usage: (save-excursion &rest BODY) */)
977 register Lisp_Object val
;
978 int count
= SPECPDL_INDEX ();
980 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
983 return unbind_to (count
, val
);
986 DEFUN ("save-current-buffer", Fsave_current_buffer
, Ssave_current_buffer
, 0, UNEVALLED
, 0,
987 doc
: /* Save the current buffer; execute BODY; restore the current buffer.
988 Executes BODY just like `progn'.
989 usage: (save-current-buffer &rest BODY) */)
993 int count
= SPECPDL_INDEX ();
995 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
998 return unbind_to (count
, val
);
1001 DEFUN ("buffer-size", Fbufsize
, Sbufsize
, 0, 1, 0,
1002 doc
: /* Return the number of characters in the current buffer.
1003 If BUFFER, return the number of characters in that buffer instead. */)
1004 (Lisp_Object buffer
)
1007 return make_number (Z
- BEG
);
1010 CHECK_BUFFER (buffer
);
1011 return make_number (BUF_Z (XBUFFER (buffer
))
1012 - BUF_BEG (XBUFFER (buffer
)));
1016 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
1017 doc
: /* Return the minimum permissible value of point in the current buffer.
1018 This is 1, unless narrowing (a buffer restriction) is in effect. */)
1022 XSETFASTINT (temp
, BEGV
);
1026 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
1027 doc
: /* Return a marker to the minimum permissible value of point in this buffer.
1028 This is the beginning, unless narrowing (a buffer restriction) is in effect. */)
1031 return buildmark (BEGV
, BEGV_BYTE
);
1034 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
1035 doc
: /* Return the maximum permissible value of point in the current buffer.
1036 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1037 is in effect, in which case it is less. */)
1041 XSETFASTINT (temp
, ZV
);
1045 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
1046 doc
: /* Return a marker to the maximum permissible value of point in this buffer.
1047 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1048 is in effect, in which case it is less. */)
1051 return buildmark (ZV
, ZV_BYTE
);
1054 DEFUN ("gap-position", Fgap_position
, Sgap_position
, 0, 0, 0,
1055 doc
: /* Return the position of the gap, in the current buffer.
1056 See also `gap-size'. */)
1060 XSETFASTINT (temp
, GPT
);
1064 DEFUN ("gap-size", Fgap_size
, Sgap_size
, 0, 0, 0,
1065 doc
: /* Return the size of the current buffer's gap.
1066 See also `gap-position'. */)
1070 XSETFASTINT (temp
, GAP_SIZE
);
1074 DEFUN ("position-bytes", Fposition_bytes
, Sposition_bytes
, 1, 1, 0,
1075 doc
: /* Return the byte position for character position POSITION.
1076 If POSITION is out of range, the value is nil. */)
1077 (Lisp_Object position
)
1079 CHECK_NUMBER_COERCE_MARKER (position
);
1080 if (XINT (position
) < BEG
|| XINT (position
) > Z
)
1082 return make_number (CHAR_TO_BYTE (XINT (position
)));
1085 DEFUN ("byte-to-position", Fbyte_to_position
, Sbyte_to_position
, 1, 1, 0,
1086 doc
: /* Return the character position for byte position BYTEPOS.
1087 If BYTEPOS is out of range, the value is nil. */)
1088 (Lisp_Object bytepos
)
1090 CHECK_NUMBER (bytepos
);
1091 if (XINT (bytepos
) < BEG_BYTE
|| XINT (bytepos
) > Z_BYTE
)
1093 return make_number (BYTE_TO_CHAR (XINT (bytepos
)));
1096 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
1097 doc
: /* Return the character following point, as a number.
1098 At the end of the buffer or accessible region, return 0. */)
1103 XSETFASTINT (temp
, 0);
1105 XSETFASTINT (temp
, FETCH_CHAR (PT_BYTE
));
1109 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
1110 doc
: /* Return the character preceding point, as a number.
1111 At the beginning of the buffer or accessible region, return 0. */)
1116 XSETFASTINT (temp
, 0);
1117 else if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1119 EMACS_INT pos
= PT_BYTE
;
1121 XSETFASTINT (temp
, FETCH_CHAR (pos
));
1124 XSETFASTINT (temp
, FETCH_BYTE (PT_BYTE
- 1));
1128 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
1129 doc
: /* Return t if point is at the beginning of the buffer.
1130 If the buffer is narrowed, this means the beginning of the narrowed part. */)
1138 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
1139 doc
: /* Return t if point is at the end of the buffer.
1140 If the buffer is narrowed, this means the end of the narrowed part. */)
1148 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
1149 doc
: /* Return t if point is at the beginning of a line. */)
1152 if (PT
== BEGV
|| FETCH_BYTE (PT_BYTE
- 1) == '\n')
1157 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
1158 doc
: /* Return t if point is at the end of a line.
1159 `End of a line' includes point being at the end of the buffer. */)
1162 if (PT
== ZV
|| FETCH_BYTE (PT_BYTE
) == '\n')
1167 DEFUN ("char-after", Fchar_after
, Schar_after
, 0, 1, 0,
1168 doc
: /* Return character in current buffer at position POS.
1169 POS is an integer or a marker and defaults to point.
1170 If POS is out of range, the value is nil. */)
1173 register EMACS_INT pos_byte
;
1178 XSETFASTINT (pos
, PT
);
1183 pos_byte
= marker_byte_position (pos
);
1184 if (pos_byte
< BEGV_BYTE
|| pos_byte
>= ZV_BYTE
)
1189 CHECK_NUMBER_COERCE_MARKER (pos
);
1190 if (XINT (pos
) < BEGV
|| XINT (pos
) >= ZV
)
1193 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1196 return make_number (FETCH_CHAR (pos_byte
));
1199 DEFUN ("char-before", Fchar_before
, Schar_before
, 0, 1, 0,
1200 doc
: /* Return character in current buffer preceding position POS.
1201 POS is an integer or a marker and defaults to point.
1202 If POS is out of range, the value is nil. */)
1205 register Lisp_Object val
;
1206 register EMACS_INT pos_byte
;
1211 XSETFASTINT (pos
, PT
);
1216 pos_byte
= marker_byte_position (pos
);
1218 if (pos_byte
<= BEGV_BYTE
|| pos_byte
> ZV_BYTE
)
1223 CHECK_NUMBER_COERCE_MARKER (pos
);
1225 if (XINT (pos
) <= BEGV
|| XINT (pos
) > ZV
)
1228 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1231 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1234 XSETFASTINT (val
, FETCH_CHAR (pos_byte
));
1239 XSETFASTINT (val
, FETCH_BYTE (pos_byte
));
1244 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 1, 0,
1245 doc
: /* Return the name under which the user logged in, as a string.
1246 This is based on the effective uid, not the real uid.
1247 Also, if the environment variables LOGNAME or USER are set,
1248 that determines the value of this function.
1250 If optional argument UID is an integer or a float, return the login name
1251 of the user with that uid, or nil if there is no such user. */)
1257 /* Set up the user name info if we didn't do it before.
1258 (That can happen if Emacs is dumpable
1259 but you decide to run `temacs -l loadup' and not dump. */
1260 if (INTEGERP (Vuser_login_name
))
1264 return Vuser_login_name
;
1266 id
= XFLOATINT (uid
);
1270 return (pw
? build_string (pw
->pw_name
) : Qnil
);
1273 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
1275 doc
: /* Return the name of the user's real uid, as a string.
1276 This ignores the environment variables LOGNAME and USER, so it differs from
1277 `user-login-name' when running under `su'. */)
1280 /* Set up the user name info if we didn't do it before.
1281 (That can happen if Emacs is dumpable
1282 but you decide to run `temacs -l loadup' and not dump. */
1283 if (INTEGERP (Vuser_login_name
))
1285 return Vuser_real_login_name
;
1288 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
1289 doc
: /* Return the effective uid of Emacs.
1290 Value is an integer or a float, depending on the value. */)
1293 /* Assignment to EMACS_INT stops GCC whining about limited range of
1295 EMACS_INT euid
= geteuid ();
1297 /* Make sure we don't produce a negative UID due to signed integer
1300 return make_float (geteuid ());
1301 return make_fixnum_or_float (euid
);
1304 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
1305 doc
: /* Return the real uid of Emacs.
1306 Value is an integer or a float, depending on the value. */)
1309 /* Assignment to EMACS_INT stops GCC whining about limited range of
1311 EMACS_INT uid
= getuid ();
1313 /* Make sure we don't produce a negative UID due to signed integer
1316 return make_float (getuid ());
1317 return make_fixnum_or_float (uid
);
1320 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 1, 0,
1321 doc
: /* Return the full name of the user logged in, as a string.
1322 If the full name corresponding to Emacs's userid is not known,
1325 If optional argument UID is an integer or float, return the full name
1326 of the user with that uid, or nil if there is no such user.
1327 If UID is a string, return the full name of the user with that login
1328 name, or nil if there is no such user. */)
1332 register char *p
, *q
;
1336 return Vuser_full_name
;
1337 else if (NUMBERP (uid
))
1339 uid_t u
= XFLOATINT (uid
);
1344 else if (STRINGP (uid
))
1347 pw
= getpwnam (SSDATA (uid
));
1351 error ("Invalid UID specification");
1357 /* Chop off everything after the first comma. */
1358 q
= strchr (p
, ',');
1359 full
= make_string (p
, q
? q
- p
: strlen (p
));
1361 #ifdef AMPERSAND_FULL_NAME
1363 q
= strchr (p
, '&');
1364 /* Substitute the login name for the &, upcasing the first character. */
1370 login
= Fuser_login_name (make_number (pw
->pw_uid
));
1371 r
= (char *) alloca (strlen (p
) + SCHARS (login
) + 1);
1372 memcpy (r
, p
, q
- p
);
1374 strcat (r
, SSDATA (login
));
1375 r
[q
- p
] = upcase ((unsigned char) r
[q
- p
]);
1377 full
= build_string (r
);
1379 #endif /* AMPERSAND_FULL_NAME */
1384 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
1385 doc
: /* Return the host name of the machine you are running on, as a string. */)
1388 return Vsystem_name
;
1392 get_system_name (void)
1394 if (STRINGP (Vsystem_name
))
1395 return SSDATA (Vsystem_name
);
1400 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
1401 doc
: /* Return the process ID of Emacs, as an integer. */)
1404 return make_number (getpid ());
1410 # define TIME_T_MIN TYPE_MINIMUM (time_t)
1413 # define TIME_T_MAX TYPE_MAXIMUM (time_t)
1416 /* Report that a time value is out of range for Emacs. */
1418 time_overflow (void)
1420 error ("Specified time is not representable");
1423 /* Return the upper part of the time T (everything but the bottom 16 bits),
1424 making sure that it is representable. */
1428 time_t hi
= t
>> 16;
1430 /* Check for overflow, helping the compiler for common cases where
1431 no runtime check is needed, and taking care not to convert
1432 negative numbers to unsigned before comparing them. */
1433 if (! ((! TYPE_SIGNED (time_t)
1434 || MOST_NEGATIVE_FIXNUM
<= TIME_T_MIN
>> 16
1435 || MOST_NEGATIVE_FIXNUM
<= hi
)
1436 && (TIME_T_MAX
>> 16 <= MOST_POSITIVE_FIXNUM
1437 || hi
<= MOST_POSITIVE_FIXNUM
)))
1443 /* Return the bottom 16 bits of the time T. */
1447 return t
& ((1 << 16) - 1);
1450 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
1451 doc
: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
1452 The time is returned as a list of three integers. The first has the
1453 most significant 16 bits of the seconds, while the second has the
1454 least significant 16 bits. The third integer gives the microsecond
1457 The microsecond count is zero on systems that do not provide
1458 resolution finer than a second. */)
1464 return list3 (make_number (hi_time (EMACS_SECS (t
))),
1465 make_number (lo_time (EMACS_SECS (t
))),
1466 make_number (EMACS_USECS (t
)));
1469 DEFUN ("get-internal-run-time", Fget_internal_run_time
, Sget_internal_run_time
,
1471 doc
: /* Return the current run time used by Emacs.
1472 The time is returned as a list of three integers. The first has the
1473 most significant 16 bits of the seconds, while the second has the
1474 least significant 16 bits. The third integer gives the microsecond
1477 On systems that can't determine the run time, `get-internal-run-time'
1478 does the same thing as `current-time'. The microsecond count is zero
1479 on systems that do not provide resolution finer than a second. */)
1482 #ifdef HAVE_GETRUSAGE
1483 struct rusage usage
;
1487 if (getrusage (RUSAGE_SELF
, &usage
) < 0)
1488 /* This shouldn't happen. What action is appropriate? */
1491 /* Sum up user time and system time. */
1492 secs
= usage
.ru_utime
.tv_sec
+ usage
.ru_stime
.tv_sec
;
1493 usecs
= usage
.ru_utime
.tv_usec
+ usage
.ru_stime
.tv_usec
;
1494 if (usecs
>= 1000000)
1500 return list3 (make_number (hi_time (secs
)),
1501 make_number (lo_time (secs
)),
1502 make_number (usecs
));
1503 #else /* ! HAVE_GETRUSAGE */
1505 return w32_get_internal_run_time ();
1506 #else /* ! WINDOWSNT */
1507 return Fcurrent_time ();
1508 #endif /* WINDOWSNT */
1509 #endif /* HAVE_GETRUSAGE */
1513 /* Make a Lisp list that represents the time T. */
1515 make_time (time_t t
)
1517 return list2 (make_number (hi_time (t
)),
1518 make_number (lo_time (t
)));
1521 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1522 If SPECIFIED_TIME is nil, use the current time.
1523 Set *RESULT to seconds since the Epoch.
1524 If USEC is not null, set *USEC to the microseconds component.
1525 Return nonzero if successful. */
1527 lisp_time_argument (Lisp_Object specified_time
, time_t *result
, int *usec
)
1529 if (NILP (specified_time
))
1536 *usec
= EMACS_USECS (t
);
1537 *result
= EMACS_SECS (t
);
1541 return time (result
) != -1;
1545 Lisp_Object high
, low
;
1547 high
= Fcar (specified_time
);
1548 CHECK_NUMBER (high
);
1549 low
= Fcdr (specified_time
);
1554 Lisp_Object usec_l
= Fcdr (low
);
1556 usec_l
= Fcar (usec_l
);
1561 CHECK_NUMBER (usec_l
);
1562 *usec
= XINT (usec_l
);
1572 /* Check for overflow, helping the compiler for common cases
1573 where no runtime check is needed, and taking care not to
1574 convert negative numbers to unsigned before comparing them. */
1575 if (! ((TYPE_SIGNED (time_t)
1576 ? (TIME_T_MIN
>> 16 <= MOST_NEGATIVE_FIXNUM
1577 || TIME_T_MIN
>> 16 <= hi
)
1579 && (MOST_POSITIVE_FIXNUM
<= TIME_T_MAX
>> 16
1580 || hi
<= TIME_T_MAX
>> 16)))
1583 *result
= (hi
<< 16) + (XINT (low
) & 0xffff);
1588 DEFUN ("float-time", Ffloat_time
, Sfloat_time
, 0, 1, 0,
1589 doc
: /* Return the current time, as a float number of seconds since the epoch.
1590 If SPECIFIED-TIME is given, it is the time to convert to float
1591 instead of the current time. The argument should have the form
1592 (HIGH LOW) or (HIGH LOW USEC). Thus, you can use times obtained from
1593 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
1594 have the form (HIGH . LOW), but this is considered obsolete.
1596 WARNING: Since the result is floating point, it may not be exact.
1597 If precise time stamps are required, use either `current-time',
1598 or (if you need time as a string) `format-time-string'. */)
1599 (Lisp_Object specified_time
)
1604 if (! lisp_time_argument (specified_time
, &sec
, &usec
))
1605 error ("Invalid time specification");
1607 return make_float ((sec
* 1e6
+ usec
) / 1e6
);
1610 /* Write information into buffer S of size MAXSIZE, according to the
1611 FORMAT of length FORMAT_LEN, using time information taken from *TP.
1612 Default to Universal Time if UT is nonzero, local time otherwise.
1613 Use NS as the number of nanoseconds in the %N directive.
1614 Return the number of bytes written, not including the terminating
1615 '\0'. If S is NULL, nothing will be written anywhere; so to
1616 determine how many bytes would be written, use NULL for S and
1617 ((size_t) -1) for MAXSIZE.
1619 This function behaves like nstrftime, except it allows null
1620 bytes in FORMAT and it does not support nanoseconds. */
1622 emacs_nmemftime (char *s
, size_t maxsize
, const char *format
,
1623 size_t format_len
, const struct tm
*tp
, int ut
, int ns
)
1627 /* Loop through all the null-terminated strings in the format
1628 argument. Normally there's just one null-terminated string, but
1629 there can be arbitrarily many, concatenated together, if the
1630 format contains '\0' bytes. nstrftime stops at the first
1631 '\0' byte so we must invoke it separately for each such string. */
1640 result
= nstrftime (s
, maxsize
, format
, tp
, ut
, ns
);
1644 if (result
== 0 && s
[0] != '\0')
1649 maxsize
-= result
+ 1;
1651 len
= strlen (format
);
1652 if (len
== format_len
)
1656 format_len
-= len
+ 1;
1660 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 1, 3, 0,
1661 doc
: /* Use FORMAT-STRING to format the time TIME, or now if omitted.
1662 TIME is specified as (HIGH LOW . IGNORED), as returned by
1663 `current-time' or `file-attributes'. The obsolete form (HIGH . LOW)
1664 is also still accepted.
1665 The third, optional, argument UNIVERSAL, if non-nil, means describe TIME
1666 as Universal Time; nil means describe TIME in the local time zone.
1667 The value is a copy of FORMAT-STRING, but with certain constructs replaced
1668 by text that describes the specified date and time in TIME:
1670 %Y is the year, %y within the century, %C the century.
1671 %G is the year corresponding to the ISO week, %g within the century.
1672 %m is the numeric month.
1673 %b and %h are the locale's abbreviated month name, %B the full name.
1674 %d is the day of the month, zero-padded, %e is blank-padded.
1675 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
1676 %a is the locale's abbreviated name of the day of week, %A the full name.
1677 %U is the week number starting on Sunday, %W starting on Monday,
1678 %V according to ISO 8601.
1679 %j is the day of the year.
1681 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
1682 only blank-padded, %l is like %I blank-padded.
1683 %p is the locale's equivalent of either AM or PM.
1686 %N is the nanosecond, %6N the microsecond, %3N the millisecond, etc.
1687 %Z is the time zone name, %z is the numeric form.
1688 %s is the number of seconds since 1970-01-01 00:00:00 +0000.
1690 %c is the locale's date and time format.
1691 %x is the locale's "preferred" date format.
1692 %D is like "%m/%d/%y".
1694 %R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
1695 %X is the locale's "preferred" time format.
1697 Finally, %n is a newline, %t is a tab, %% is a literal %.
1699 Certain flags and modifiers are available with some format controls.
1700 The flags are `_', `-', `^' and `#'. For certain characters X,
1701 %_X is like %X, but padded with blanks; %-X is like %X,
1702 but without padding. %^X is like %X, but with all textual
1703 characters up-cased; %#X is like %X, but with letter-case of
1704 all textual characters reversed.
1705 %NX (where N stands for an integer) is like %X,
1706 but takes up at least N (a number) positions.
1707 The modifiers are `E' and `O'. For certain characters X,
1708 %EX is a locale's alternative version of %X;
1709 %OX is like %X, but uses the locale's number symbols.
1711 For example, to produce full ISO 8601 format, use "%Y-%m-%dT%T%z". */)
1712 (Lisp_Object format_string
, Lisp_Object timeval
, Lisp_Object universal
)
1719 int ut
= ! NILP (universal
);
1721 CHECK_STRING (format_string
);
1723 if (! (lisp_time_argument (timeval
, &value
, &usec
)
1724 && 0 <= usec
&& usec
< 1000000))
1725 error ("Invalid time specification");
1728 format_string
= code_convert_string_norecord (format_string
,
1729 Vlocale_coding_system
, 1);
1731 /* This is probably enough. */
1732 size
= SBYTES (format_string
) * 6 + 50;
1735 tm
= ut
? gmtime (&value
) : localtime (&value
);
1740 synchronize_system_time_locale ();
1744 char *buf
= (char *) alloca (size
+ 1);
1749 result
= emacs_nmemftime (buf
, size
, SSDATA (format_string
),
1750 SBYTES (format_string
),
1753 if ((result
> 0 && result
< size
) || (result
== 0 && buf
[0] == '\0'))
1754 return code_convert_string_norecord (make_unibyte_string (buf
, result
),
1755 Vlocale_coding_system
, 0);
1757 /* If buffer was too small, make it bigger and try again. */
1759 result
= emacs_nmemftime (NULL
, (size_t) -1,
1760 SSDATA (format_string
),
1761 SBYTES (format_string
),
1768 DEFUN ("decode-time", Fdecode_time
, Sdecode_time
, 0, 1, 0,
1769 doc
: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST ZONE).
1770 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED),
1771 as from `current-time' and `file-attributes', or nil to use the
1772 current time. The obsolete form (HIGH . LOW) is also still accepted.
1773 The list has the following nine members: SEC is an integer between 0
1774 and 60; SEC is 60 for a leap second, which only some operating systems
1775 support. MINUTE is an integer between 0 and 59. HOUR is an integer
1776 between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
1777 integer between 1 and 12. YEAR is an integer indicating the
1778 four-digit year. DOW is the day of week, an integer between 0 and 6,
1779 where 0 is Sunday. DST is t if daylight saving time is in effect,
1780 otherwise nil. ZONE is an integer indicating the number of seconds
1781 east of Greenwich. (Note that Common Lisp has different meanings for
1783 (Lisp_Object specified_time
)
1787 struct tm
*decoded_time
;
1788 Lisp_Object list_args
[9];
1790 if (! lisp_time_argument (specified_time
, &time_spec
, NULL
))
1791 error ("Invalid time specification");
1794 decoded_time
= localtime (&time_spec
);
1797 && MOST_NEGATIVE_FIXNUM
- TM_YEAR_BASE
<= decoded_time
->tm_year
1798 && decoded_time
->tm_year
<= MOST_POSITIVE_FIXNUM
- TM_YEAR_BASE
))
1800 XSETFASTINT (list_args
[0], decoded_time
->tm_sec
);
1801 XSETFASTINT (list_args
[1], decoded_time
->tm_min
);
1802 XSETFASTINT (list_args
[2], decoded_time
->tm_hour
);
1803 XSETFASTINT (list_args
[3], decoded_time
->tm_mday
);
1804 XSETFASTINT (list_args
[4], decoded_time
->tm_mon
+ 1);
1805 /* On 64-bit machines an int is narrower than EMACS_INT, thus the
1806 cast below avoids overflow in int arithmetics. */
1807 XSETINT (list_args
[5], TM_YEAR_BASE
+ (EMACS_INT
) decoded_time
->tm_year
);
1808 XSETFASTINT (list_args
[6], decoded_time
->tm_wday
);
1809 list_args
[7] = (decoded_time
->tm_isdst
)? Qt
: Qnil
;
1811 /* Make a copy, in case gmtime modifies the struct. */
1812 save_tm
= *decoded_time
;
1814 decoded_time
= gmtime (&time_spec
);
1816 if (decoded_time
== 0)
1817 list_args
[8] = Qnil
;
1819 XSETINT (list_args
[8], tm_diff (&save_tm
, decoded_time
));
1820 return Flist (9, list_args
);
1823 /* Return OBJ - OFFSET, checking that OBJ is a valid fixnum and that
1824 the result is representable as an int. Assume OFFSET is small and
1827 check_tm_member (Lisp_Object obj
, int offset
)
1832 if (! (INT_MIN
+ offset
<= n
&& n
- offset
<= INT_MAX
))
1837 DEFUN ("encode-time", Fencode_time
, Sencode_time
, 6, MANY
, 0,
1838 doc
: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
1839 This is the reverse operation of `decode-time', which see.
1840 ZONE defaults to the current time zone rule. This can
1841 be a string or t (as from `set-time-zone-rule'), or it can be a list
1842 \(as from `current-time-zone') or an integer (as from `decode-time')
1843 applied without consideration for daylight saving time.
1845 You can pass more than 7 arguments; then the first six arguments
1846 are used as SECOND through YEAR, and the *last* argument is used as ZONE.
1847 The intervening arguments are ignored.
1848 This feature lets (apply 'encode-time (decode-time ...)) work.
1850 Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed;
1851 for example, a DAY of 0 means the day preceding the given month.
1852 Year numbers less than 100 are treated just like other year numbers.
1853 If you want them to stand for years in this century, you must do that yourself.
1855 Years before 1970 are not guaranteed to work. On some systems,
1856 year values as low as 1901 do work.
1858 usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
1859 (size_t nargs
, register Lisp_Object
*args
)
1863 Lisp_Object zone
= (nargs
> 6 ? args
[nargs
- 1] : Qnil
);
1865 tm
.tm_sec
= check_tm_member (args
[0], 0);
1866 tm
.tm_min
= check_tm_member (args
[1], 0);
1867 tm
.tm_hour
= check_tm_member (args
[2], 0);
1868 tm
.tm_mday
= check_tm_member (args
[3], 0);
1869 tm
.tm_mon
= check_tm_member (args
[4], 1);
1870 tm
.tm_year
= check_tm_member (args
[5], TM_YEAR_BASE
);
1878 value
= mktime (&tm
);
1884 const char *tzstring
;
1885 char **oldenv
= environ
, **newenv
;
1889 else if (STRINGP (zone
))
1890 tzstring
= SSDATA (zone
);
1891 else if (INTEGERP (zone
))
1893 int abszone
= eabs (XINT (zone
));
1894 sprintf (tzbuf
, "XXX%s%d:%02d:%02d", "-" + (XINT (zone
) < 0),
1895 abszone
/ (60*60), (abszone
/60) % 60, abszone
% 60);
1899 error ("Invalid time zone specification");
1901 /* Set TZ before calling mktime; merely adjusting mktime's returned
1902 value doesn't suffice, since that would mishandle leap seconds. */
1903 set_time_zone_rule (tzstring
);
1906 value
= mktime (&tm
);
1909 /* Restore TZ to previous value. */
1913 #ifdef LOCALTIME_CACHE
1918 if (value
== (time_t) -1)
1921 return make_time (value
);
1924 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
1925 doc
: /* Return the current local time, as a human-readable string.
1926 Programs can use this function to decode a time,
1927 since the number of columns in each field is fixed
1928 if the year is in the range 1000-9999.
1929 The format is `Sun Sep 16 01:03:52 1973'.
1930 However, see also the functions `decode-time' and `format-time-string'
1931 which provide a much more powerful and general facility.
1933 If SPECIFIED-TIME is given, it is a time to format instead of the
1934 current time. The argument should have the form (HIGH LOW . IGNORED).
1935 Thus, you can use times obtained from `current-time' and from
1936 `file-attributes'. SPECIFIED-TIME can also have the form (HIGH . LOW),
1937 but this is considered obsolete. */)
1938 (Lisp_Object specified_time
)
1944 if (! lisp_time_argument (specified_time
, &value
, NULL
))
1945 error ("Invalid time specification");
1947 /* Convert to a string, checking for out-of-range time stamps.
1948 Don't use 'ctime', as that might dump core if VALUE is out of
1951 tm
= localtime (&value
);
1953 if (! (tm
&& TM_YEAR_IN_ASCTIME_RANGE (tm
->tm_year
) && (tem
= asctime (tm
))))
1956 /* Remove the trailing newline. */
1957 tem
[strlen (tem
) - 1] = '\0';
1959 return build_string (tem
);
1962 /* Yield A - B, measured in seconds.
1963 This function is copied from the GNU C Library. */
1965 tm_diff (struct tm
*a
, struct tm
*b
)
1967 /* Compute intervening leap days correctly even if year is negative.
1968 Take care to avoid int overflow in leap day calculations,
1969 but it's OK to assume that A and B are close to each other. */
1970 int a4
= (a
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (a
->tm_year
& 3);
1971 int b4
= (b
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (b
->tm_year
& 3);
1972 int a100
= a4
/ 25 - (a4
% 25 < 0);
1973 int b100
= b4
/ 25 - (b4
% 25 < 0);
1974 int a400
= a100
>> 2;
1975 int b400
= b100
>> 2;
1976 int intervening_leap_days
= (a4
- b4
) - (a100
- b100
) + (a400
- b400
);
1977 int years
= a
->tm_year
- b
->tm_year
;
1978 int days
= (365 * years
+ intervening_leap_days
1979 + (a
->tm_yday
- b
->tm_yday
));
1980 return (60 * (60 * (24 * days
+ (a
->tm_hour
- b
->tm_hour
))
1981 + (a
->tm_min
- b
->tm_min
))
1982 + (a
->tm_sec
- b
->tm_sec
));
1985 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
1986 doc
: /* Return the offset and name for the local time zone.
1987 This returns a list of the form (OFFSET NAME).
1988 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
1989 A negative value means west of Greenwich.
1990 NAME is a string giving the name of the time zone.
1991 If SPECIFIED-TIME is given, the time zone offset is determined from it
1992 instead of using the current time. The argument should have the form
1993 (HIGH LOW . IGNORED). Thus, you can use times obtained from
1994 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
1995 have the form (HIGH . LOW), but this is considered obsolete.
1997 Some operating systems cannot provide all this information to Emacs;
1998 in this case, `current-time-zone' returns a list containing nil for
1999 the data it can't find. */)
2000 (Lisp_Object specified_time
)
2006 if (!lisp_time_argument (specified_time
, &value
, NULL
))
2011 t
= gmtime (&value
);
2015 t
= localtime (&value
);
2022 int offset
= tm_diff (t
, &gmt
);
2028 s
= (char *)t
->tm_zone
;
2029 #else /* not HAVE_TM_ZONE */
2031 if (t
->tm_isdst
== 0 || t
->tm_isdst
== 1)
2032 s
= tzname
[t
->tm_isdst
];
2034 #endif /* not HAVE_TM_ZONE */
2038 /* No local time zone name is available; use "+-NNNN" instead. */
2039 int am
= (offset
< 0 ? -offset
: offset
) / 60;
2040 sprintf (buf
, "%c%02d%02d", (offset
< 0 ? '-' : '+'), am
/60, am
%60);
2044 return Fcons (make_number (offset
), Fcons (build_string (s
), Qnil
));
2047 return Fmake_list (make_number (2), Qnil
);
2050 /* This holds the value of `environ' produced by the previous
2051 call to Fset_time_zone_rule, or 0 if Fset_time_zone_rule
2052 has never been called. */
2053 static char **environbuf
;
2055 /* This holds the startup value of the TZ environment variable so it
2056 can be restored if the user calls set-time-zone-rule with a nil
2058 static char *initial_tz
;
2060 DEFUN ("set-time-zone-rule", Fset_time_zone_rule
, Sset_time_zone_rule
, 1, 1, 0,
2061 doc
: /* Set the local time zone using TZ, a string specifying a time zone rule.
2062 If TZ is nil, use implementation-defined default time zone information.
2063 If TZ is t, use Universal Time. */)
2066 const char *tzstring
;
2068 /* When called for the first time, save the original TZ. */
2070 initial_tz
= (char *) getenv ("TZ");
2073 tzstring
= initial_tz
;
2074 else if (EQ (tz
, Qt
))
2079 tzstring
= SSDATA (tz
);
2082 set_time_zone_rule (tzstring
);
2084 environbuf
= environ
;
2089 #ifdef LOCALTIME_CACHE
2091 /* These two values are known to load tz files in buggy implementations,
2092 i.e. Solaris 1 executables running under either Solaris 1 or Solaris 2.
2093 Their values shouldn't matter in non-buggy implementations.
2094 We don't use string literals for these strings,
2095 since if a string in the environment is in readonly
2096 storage, it runs afoul of bugs in SVR4 and Solaris 2.3.
2097 See Sun bugs 1113095 and 1114114, ``Timezone routines
2098 improperly modify environment''. */
2100 static char set_time_zone_rule_tz1
[] = "TZ=GMT+0";
2101 static char set_time_zone_rule_tz2
[] = "TZ=GMT+1";
2105 /* Set the local time zone rule to TZSTRING.
2106 This allocates memory into `environ', which it is the caller's
2107 responsibility to free. */
2110 set_time_zone_rule (const char *tzstring
)
2113 char **from
, **to
, **newenv
;
2115 /* Make the ENVIRON vector longer with room for TZSTRING. */
2116 for (from
= environ
; *from
; from
++)
2118 envptrs
= from
- environ
+ 2;
2119 newenv
= to
= (char **) xmalloc (envptrs
* sizeof (char *)
2120 + (tzstring
? strlen (tzstring
) + 4 : 0));
2122 /* Add TZSTRING to the end of environ, as a value for TZ. */
2125 char *t
= (char *) (to
+ envptrs
);
2127 strcat (t
, tzstring
);
2131 /* Copy the old environ vector elements into NEWENV,
2132 but don't copy the TZ variable.
2133 So we have only one definition of TZ, which came from TZSTRING. */
2134 for (from
= environ
; *from
; from
++)
2135 if (strncmp (*from
, "TZ=", 3) != 0)
2141 /* If we do have a TZSTRING, NEWENV points to the vector slot where
2142 the TZ variable is stored. If we do not have a TZSTRING,
2143 TO points to the vector slot which has the terminating null. */
2145 #ifdef LOCALTIME_CACHE
2147 /* In SunOS 4.1.3_U1 and 4.1.4, if TZ has a value like
2148 "US/Pacific" that loads a tz file, then changes to a value like
2149 "XXX0" that does not load a tz file, and then changes back to
2150 its original value, the last change is (incorrectly) ignored.
2151 Also, if TZ changes twice in succession to values that do
2152 not load a tz file, tzset can dump core (see Sun bug#1225179).
2153 The following code works around these bugs. */
2157 /* Temporarily set TZ to a value that loads a tz file
2158 and that differs from tzstring. */
2160 *newenv
= (strcmp (tzstring
, set_time_zone_rule_tz1
+ 3) == 0
2161 ? set_time_zone_rule_tz2
: set_time_zone_rule_tz1
);
2167 /* The implied tzstring is unknown, so temporarily set TZ to
2168 two different values that each load a tz file. */
2169 *to
= set_time_zone_rule_tz1
;
2172 *to
= set_time_zone_rule_tz2
;
2177 /* Now TZ has the desired value, and tzset can be invoked safely. */
2184 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
2185 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
2186 type of object is Lisp_String). INHERIT is passed to
2187 INSERT_FROM_STRING_FUNC as the last argument. */
2190 general_insert_function (void (*insert_func
)
2191 (const char *, EMACS_INT
),
2192 void (*insert_from_string_func
)
2193 (Lisp_Object
, EMACS_INT
, EMACS_INT
,
2194 EMACS_INT
, EMACS_INT
, int),
2195 int inherit
, size_t nargs
, Lisp_Object
*args
)
2197 register size_t argnum
;
2198 register Lisp_Object val
;
2200 for (argnum
= 0; argnum
< nargs
; argnum
++)
2203 if (CHARACTERP (val
))
2205 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2208 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2209 len
= CHAR_STRING (XFASTINT (val
), str
);
2212 str
[0] = (ASCII_CHAR_P (XINT (val
))
2214 : multibyte_char_to_unibyte (XINT (val
)));
2217 (*insert_func
) ((char *) str
, len
);
2219 else if (STRINGP (val
))
2221 (*insert_from_string_func
) (val
, 0, 0,
2227 wrong_type_argument (Qchar_or_string_p
, val
);
2232 insert1 (Lisp_Object arg
)
2238 /* Callers passing one argument to Finsert need not gcpro the
2239 argument "array", since the only element of the array will
2240 not be used after calling insert or insert_from_string, so
2241 we don't care if it gets trashed. */
2243 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
2244 doc
: /* Insert the arguments, either strings or characters, at point.
2245 Point and before-insertion markers move forward to end up
2246 after the inserted text.
2247 Any other markers at the point of insertion remain before the text.
2249 If the current buffer is multibyte, unibyte strings are converted
2250 to multibyte for insertion (see `string-make-multibyte').
2251 If the current buffer is unibyte, multibyte strings are converted
2252 to unibyte for insertion (see `string-make-unibyte').
2254 When operating on binary data, it may be necessary to preserve the
2255 original bytes of a unibyte string when inserting it into a multibyte
2256 buffer; to accomplish this, apply `string-as-multibyte' to the string
2257 and insert the result.
2259 usage: (insert &rest ARGS) */)
2260 (size_t nargs
, register Lisp_Object
*args
)
2262 general_insert_function (insert
, insert_from_string
, 0, nargs
, args
);
2266 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
2268 doc
: /* Insert the arguments at point, inheriting properties from adjoining text.
2269 Point and before-insertion markers move forward to end up
2270 after the inserted text.
2271 Any other markers at the point of insertion remain before the text.
2273 If the current buffer is multibyte, unibyte strings are converted
2274 to multibyte for insertion (see `unibyte-char-to-multibyte').
2275 If the current buffer is unibyte, multibyte strings are converted
2276 to unibyte for insertion.
2278 usage: (insert-and-inherit &rest ARGS) */)
2279 (size_t nargs
, register Lisp_Object
*args
)
2281 general_insert_function (insert_and_inherit
, insert_from_string
, 1,
2286 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
2287 doc
: /* Insert strings or characters at point, relocating markers after the text.
2288 Point and markers move forward to end up after the inserted text.
2290 If the current buffer is multibyte, unibyte strings are converted
2291 to multibyte for insertion (see `unibyte-char-to-multibyte').
2292 If the current buffer is unibyte, multibyte strings are converted
2293 to unibyte for insertion.
2295 usage: (insert-before-markers &rest ARGS) */)
2296 (size_t nargs
, register Lisp_Object
*args
)
2298 general_insert_function (insert_before_markers
,
2299 insert_from_string_before_markers
, 0,
2304 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers
,
2305 Sinsert_and_inherit_before_markers
, 0, MANY
, 0,
2306 doc
: /* Insert text at point, relocating markers and inheriting properties.
2307 Point and markers move forward to end up after the inserted text.
2309 If the current buffer is multibyte, unibyte strings are converted
2310 to multibyte for insertion (see `unibyte-char-to-multibyte').
2311 If the current buffer is unibyte, multibyte strings are converted
2312 to unibyte for insertion.
2314 usage: (insert-before-markers-and-inherit &rest ARGS) */)
2315 (size_t nargs
, register Lisp_Object
*args
)
2317 general_insert_function (insert_before_markers_and_inherit
,
2318 insert_from_string_before_markers
, 1,
2323 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 2, 3, 0,
2324 doc
: /* Insert COUNT copies of CHARACTER.
2325 Point, and before-insertion markers, are relocated as in the function `insert'.
2326 The optional third arg INHERIT, if non-nil, says to inherit text properties
2327 from adjoining text, if those properties are sticky. */)
2328 (Lisp_Object character
, Lisp_Object count
, Lisp_Object inherit
)
2330 register char *string
;
2331 register EMACS_INT stringlen
;
2333 register EMACS_INT n
;
2335 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2337 CHECK_NUMBER (character
);
2338 CHECK_NUMBER (count
);
2340 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2341 len
= CHAR_STRING (XFASTINT (character
), str
);
2343 str
[0] = XFASTINT (character
), len
= 1;
2344 if (MOST_POSITIVE_FIXNUM
/ len
< XINT (count
))
2345 error ("Maximum buffer size would be exceeded");
2346 n
= XINT (count
) * len
;
2349 stringlen
= min (n
, 256 * len
);
2350 string
= (char *) alloca (stringlen
);
2351 for (i
= 0; i
< stringlen
; i
++)
2352 string
[i
] = str
[i
% len
];
2353 while (n
>= stringlen
)
2356 if (!NILP (inherit
))
2357 insert_and_inherit (string
, stringlen
);
2359 insert (string
, stringlen
);
2364 if (!NILP (inherit
))
2365 insert_and_inherit (string
, n
);
2372 DEFUN ("insert-byte", Finsert_byte
, Sinsert_byte
, 2, 3, 0,
2373 doc
: /* Insert COUNT (second arg) copies of BYTE (first arg).
2374 Both arguments are required.
2375 BYTE is a number of the range 0..255.
2377 If BYTE is 128..255 and the current buffer is multibyte, the
2378 corresponding eight-bit character is inserted.
2380 Point, and before-insertion markers, are relocated as in the function `insert'.
2381 The optional third arg INHERIT, if non-nil, says to inherit text properties
2382 from adjoining text, if those properties are sticky. */)
2383 (Lisp_Object byte
, Lisp_Object count
, Lisp_Object inherit
)
2385 CHECK_NUMBER (byte
);
2386 if (XINT (byte
) < 0 || XINT (byte
) > 255)
2387 args_out_of_range_3 (byte
, make_number (0), make_number (255));
2388 if (XINT (byte
) >= 128
2389 && ! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2390 XSETFASTINT (byte
, BYTE8_TO_CHAR (XINT (byte
)));
2391 return Finsert_char (byte
, count
, inherit
);
2395 /* Making strings from buffer contents. */
2397 /* Return a Lisp_String containing the text of the current buffer from
2398 START to END. If text properties are in use and the current buffer
2399 has properties in the range specified, the resulting string will also
2400 have them, if PROPS is nonzero.
2402 We don't want to use plain old make_string here, because it calls
2403 make_uninit_string, which can cause the buffer arena to be
2404 compacted. make_string has no way of knowing that the data has
2405 been moved, and thus copies the wrong data into the string. This
2406 doesn't effect most of the other users of make_string, so it should
2407 be left as is. But we should use this function when conjuring
2408 buffer substrings. */
2411 make_buffer_string (EMACS_INT start
, EMACS_INT end
, int props
)
2413 EMACS_INT start_byte
= CHAR_TO_BYTE (start
);
2414 EMACS_INT end_byte
= CHAR_TO_BYTE (end
);
2416 return make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
);
2419 /* Return a Lisp_String containing the text of the current buffer from
2420 START / START_BYTE to END / END_BYTE.
2422 If text properties are in use and the current buffer
2423 has properties in the range specified, the resulting string will also
2424 have them, if PROPS is nonzero.
2426 We don't want to use plain old make_string here, because it calls
2427 make_uninit_string, which can cause the buffer arena to be
2428 compacted. make_string has no way of knowing that the data has
2429 been moved, and thus copies the wrong data into the string. This
2430 doesn't effect most of the other users of make_string, so it should
2431 be left as is. But we should use this function when conjuring
2432 buffer substrings. */
2435 make_buffer_string_both (EMACS_INT start
, EMACS_INT start_byte
,
2436 EMACS_INT end
, EMACS_INT end_byte
, int props
)
2438 Lisp_Object result
, tem
, tem1
;
2440 if (start
< GPT
&& GPT
< end
)
2443 if (! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2444 result
= make_uninit_multibyte_string (end
- start
, end_byte
- start_byte
);
2446 result
= make_uninit_string (end
- start
);
2447 memcpy (SDATA (result
), BYTE_POS_ADDR (start_byte
), end_byte
- start_byte
);
2449 /* If desired, update and copy the text properties. */
2452 update_buffer_properties (start
, end
);
2454 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
2455 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
2457 if (XINT (tem
) != end
|| !NILP (tem1
))
2458 copy_intervals_to_string (result
, current_buffer
, start
,
2465 /* Call Vbuffer_access_fontify_functions for the range START ... END
2466 in the current buffer, if necessary. */
2469 update_buffer_properties (EMACS_INT start
, EMACS_INT end
)
2471 /* If this buffer has some access functions,
2472 call them, specifying the range of the buffer being accessed. */
2473 if (!NILP (Vbuffer_access_fontify_functions
))
2475 Lisp_Object args
[3];
2478 args
[0] = Qbuffer_access_fontify_functions
;
2479 XSETINT (args
[1], start
);
2480 XSETINT (args
[2], end
);
2482 /* But don't call them if we can tell that the work
2483 has already been done. */
2484 if (!NILP (Vbuffer_access_fontified_property
))
2486 tem
= Ftext_property_any (args
[1], args
[2],
2487 Vbuffer_access_fontified_property
,
2490 Frun_hook_with_args (3, args
);
2493 Frun_hook_with_args (3, args
);
2497 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
2498 doc
: /* Return the contents of part of the current buffer as a string.
2499 The two arguments START and END are character positions;
2500 they can be in either order.
2501 The string returned is multibyte if the buffer is multibyte.
2503 This function copies the text properties of that part of the buffer
2504 into the result string; if you don't want the text properties,
2505 use `buffer-substring-no-properties' instead. */)
2506 (Lisp_Object start
, Lisp_Object end
)
2508 register EMACS_INT b
, e
;
2510 validate_region (&start
, &end
);
2514 return make_buffer_string (b
, e
, 1);
2517 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties
,
2518 Sbuffer_substring_no_properties
, 2, 2, 0,
2519 doc
: /* Return the characters of part of the buffer, without the text properties.
2520 The two arguments START and END are character positions;
2521 they can be in either order. */)
2522 (Lisp_Object start
, Lisp_Object end
)
2524 register EMACS_INT b
, e
;
2526 validate_region (&start
, &end
);
2530 return make_buffer_string (b
, e
, 0);
2533 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
2534 doc
: /* Return the contents of the current buffer as a string.
2535 If narrowing is in effect, this function returns only the visible part
2539 return make_buffer_string (BEGV
, ZV
, 1);
2542 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
2544 doc
: /* Insert before point a substring of the contents of BUFFER.
2545 BUFFER may be a buffer or a buffer name.
2546 Arguments START and END are character positions specifying the substring.
2547 They default to the values of (point-min) and (point-max) in BUFFER. */)
2548 (Lisp_Object buffer
, Lisp_Object start
, Lisp_Object end
)
2550 register EMACS_INT b
, e
, temp
;
2551 register struct buffer
*bp
, *obuf
;
2554 buf
= Fget_buffer (buffer
);
2558 if (NILP (BVAR (bp
, name
)))
2559 error ("Selecting deleted buffer");
2565 CHECK_NUMBER_COERCE_MARKER (start
);
2572 CHECK_NUMBER_COERCE_MARKER (end
);
2577 temp
= b
, b
= e
, e
= temp
;
2579 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
2580 args_out_of_range (start
, end
);
2582 obuf
= current_buffer
;
2583 set_buffer_internal_1 (bp
);
2584 update_buffer_properties (b
, e
);
2585 set_buffer_internal_1 (obuf
);
2587 insert_from_buffer (bp
, b
, e
- b
, 0);
2591 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
2593 doc
: /* Compare two substrings of two buffers; return result as number.
2594 the value is -N if first string is less after N-1 chars,
2595 +N if first string is greater after N-1 chars, or 0 if strings match.
2596 Each substring is represented as three arguments: BUFFER, START and END.
2597 That makes six args in all, three for each substring.
2599 The value of `case-fold-search' in the current buffer
2600 determines whether case is significant or ignored. */)
2601 (Lisp_Object buffer1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object buffer2
, Lisp_Object start2
, Lisp_Object end2
)
2603 register EMACS_INT begp1
, endp1
, begp2
, endp2
, temp
;
2604 register struct buffer
*bp1
, *bp2
;
2605 register Lisp_Object trt
2606 = (!NILP (BVAR (current_buffer
, case_fold_search
))
2607 ? BVAR (current_buffer
, case_canon_table
) : Qnil
);
2608 EMACS_INT chars
= 0;
2609 EMACS_INT i1
, i2
, i1_byte
, i2_byte
;
2611 /* Find the first buffer and its substring. */
2614 bp1
= current_buffer
;
2618 buf1
= Fget_buffer (buffer1
);
2621 bp1
= XBUFFER (buf1
);
2622 if (NILP (BVAR (bp1
, name
)))
2623 error ("Selecting deleted buffer");
2627 begp1
= BUF_BEGV (bp1
);
2630 CHECK_NUMBER_COERCE_MARKER (start1
);
2631 begp1
= XINT (start1
);
2634 endp1
= BUF_ZV (bp1
);
2637 CHECK_NUMBER_COERCE_MARKER (end1
);
2638 endp1
= XINT (end1
);
2642 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
2644 if (!(BUF_BEGV (bp1
) <= begp1
2646 && endp1
<= BUF_ZV (bp1
)))
2647 args_out_of_range (start1
, end1
);
2649 /* Likewise for second substring. */
2652 bp2
= current_buffer
;
2656 buf2
= Fget_buffer (buffer2
);
2659 bp2
= XBUFFER (buf2
);
2660 if (NILP (BVAR (bp2
, name
)))
2661 error ("Selecting deleted buffer");
2665 begp2
= BUF_BEGV (bp2
);
2668 CHECK_NUMBER_COERCE_MARKER (start2
);
2669 begp2
= XINT (start2
);
2672 endp2
= BUF_ZV (bp2
);
2675 CHECK_NUMBER_COERCE_MARKER (end2
);
2676 endp2
= XINT (end2
);
2680 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
2682 if (!(BUF_BEGV (bp2
) <= begp2
2684 && endp2
<= BUF_ZV (bp2
)))
2685 args_out_of_range (start2
, end2
);
2689 i1_byte
= buf_charpos_to_bytepos (bp1
, i1
);
2690 i2_byte
= buf_charpos_to_bytepos (bp2
, i2
);
2692 while (i1
< endp1
&& i2
< endp2
)
2694 /* When we find a mismatch, we must compare the
2695 characters, not just the bytes. */
2700 if (! NILP (BVAR (bp1
, enable_multibyte_characters
)))
2702 c1
= BUF_FETCH_MULTIBYTE_CHAR (bp1
, i1_byte
);
2703 BUF_INC_POS (bp1
, i1_byte
);
2708 c1
= BUF_FETCH_BYTE (bp1
, i1
);
2709 MAKE_CHAR_MULTIBYTE (c1
);
2713 if (! NILP (BVAR (bp2
, enable_multibyte_characters
)))
2715 c2
= BUF_FETCH_MULTIBYTE_CHAR (bp2
, i2_byte
);
2716 BUF_INC_POS (bp2
, i2_byte
);
2721 c2
= BUF_FETCH_BYTE (bp2
, i2
);
2722 MAKE_CHAR_MULTIBYTE (c2
);
2728 c1
= CHAR_TABLE_TRANSLATE (trt
, c1
);
2729 c2
= CHAR_TABLE_TRANSLATE (trt
, c2
);
2732 return make_number (- 1 - chars
);
2734 return make_number (chars
+ 1);
2739 /* The strings match as far as they go.
2740 If one is shorter, that one is less. */
2741 if (chars
< endp1
- begp1
)
2742 return make_number (chars
+ 1);
2743 else if (chars
< endp2
- begp2
)
2744 return make_number (- chars
- 1);
2746 /* Same length too => they are equal. */
2747 return make_number (0);
2751 subst_char_in_region_unwind (Lisp_Object arg
)
2753 return BVAR (current_buffer
, undo_list
) = arg
;
2757 subst_char_in_region_unwind_1 (Lisp_Object arg
)
2759 return BVAR (current_buffer
, filename
) = arg
;
2762 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
2763 Ssubst_char_in_region
, 4, 5, 0,
2764 doc
: /* From START to END, replace FROMCHAR with TOCHAR each time it occurs.
2765 If optional arg NOUNDO is non-nil, don't record this change for undo
2766 and don't mark the buffer as really changed.
2767 Both characters must have the same length of multi-byte form. */)
2768 (Lisp_Object start
, Lisp_Object end
, Lisp_Object fromchar
, Lisp_Object tochar
, Lisp_Object noundo
)
2770 register EMACS_INT pos
, pos_byte
, stop
, i
, len
, end_byte
;
2771 /* Keep track of the first change in the buffer:
2772 if 0 we haven't found it yet.
2773 if < 0 we've found it and we've run the before-change-function.
2774 if > 0 we've actually performed it and the value is its position. */
2775 EMACS_INT changed
= 0;
2776 unsigned char fromstr
[MAX_MULTIBYTE_LENGTH
], tostr
[MAX_MULTIBYTE_LENGTH
];
2778 int count
= SPECPDL_INDEX ();
2779 #define COMBINING_NO 0
2780 #define COMBINING_BEFORE 1
2781 #define COMBINING_AFTER 2
2782 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
2783 int maybe_byte_combining
= COMBINING_NO
;
2784 EMACS_INT last_changed
= 0;
2785 int multibyte_p
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
2789 validate_region (&start
, &end
);
2790 CHECK_NUMBER (fromchar
);
2791 CHECK_NUMBER (tochar
);
2795 len
= CHAR_STRING (XFASTINT (fromchar
), fromstr
);
2796 if (CHAR_STRING (XFASTINT (tochar
), tostr
) != len
)
2797 error ("Characters in `subst-char-in-region' have different byte-lengths");
2798 if (!ASCII_BYTE_P (*tostr
))
2800 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
2801 complete multibyte character, it may be combined with the
2802 after bytes. If it is in the range 0xA0..0xFF, it may be
2803 combined with the before and after bytes. */
2804 if (!CHAR_HEAD_P (*tostr
))
2805 maybe_byte_combining
= COMBINING_BOTH
;
2806 else if (BYTES_BY_CHAR_HEAD (*tostr
) > len
)
2807 maybe_byte_combining
= COMBINING_AFTER
;
2813 fromstr
[0] = XFASTINT (fromchar
);
2814 tostr
[0] = XFASTINT (tochar
);
2818 pos_byte
= CHAR_TO_BYTE (pos
);
2819 stop
= CHAR_TO_BYTE (XINT (end
));
2822 /* If we don't want undo, turn off putting stuff on the list.
2823 That's faster than getting rid of things,
2824 and it prevents even the entry for a first change.
2825 Also inhibit locking the file. */
2826 if (!changed
&& !NILP (noundo
))
2828 record_unwind_protect (subst_char_in_region_unwind
,
2829 BVAR (current_buffer
, undo_list
));
2830 BVAR (current_buffer
, undo_list
) = Qt
;
2831 /* Don't do file-locking. */
2832 record_unwind_protect (subst_char_in_region_unwind_1
,
2833 BVAR (current_buffer
, filename
));
2834 BVAR (current_buffer
, filename
) = Qnil
;
2837 if (pos_byte
< GPT_BYTE
)
2838 stop
= min (stop
, GPT_BYTE
);
2841 EMACS_INT pos_byte_next
= pos_byte
;
2843 if (pos_byte
>= stop
)
2845 if (pos_byte
>= end_byte
) break;
2848 p
= BYTE_POS_ADDR (pos_byte
);
2850 INC_POS (pos_byte_next
);
2853 if (pos_byte_next
- pos_byte
== len
2854 && p
[0] == fromstr
[0]
2856 || (p
[1] == fromstr
[1]
2857 && (len
== 2 || (p
[2] == fromstr
[2]
2858 && (len
== 3 || p
[3] == fromstr
[3]))))))
2861 /* We've already seen this and run the before-change-function;
2862 this time we only need to record the actual position. */
2867 modify_region (current_buffer
, pos
, XINT (end
), 0);
2869 if (! NILP (noundo
))
2871 if (MODIFF
- 1 == SAVE_MODIFF
)
2873 if (MODIFF
- 1 == BUF_AUTOSAVE_MODIFF (current_buffer
))
2874 BUF_AUTOSAVE_MODIFF (current_buffer
)++;
2877 /* The before-change-function may have moved the gap
2878 or even modified the buffer so we should start over. */
2882 /* Take care of the case where the new character
2883 combines with neighboring bytes. */
2884 if (maybe_byte_combining
2885 && (maybe_byte_combining
== COMBINING_AFTER
2886 ? (pos_byte_next
< Z_BYTE
2887 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2888 : ((pos_byte_next
< Z_BYTE
2889 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2890 || (pos_byte
> BEG_BYTE
2891 && ! ASCII_BYTE_P (FETCH_BYTE (pos_byte
- 1))))))
2893 Lisp_Object tem
, string
;
2895 struct gcpro gcpro1
;
2897 tem
= BVAR (current_buffer
, undo_list
);
2900 /* Make a multibyte string containing this single character. */
2901 string
= make_multibyte_string ((char *) tostr
, 1, len
);
2902 /* replace_range is less efficient, because it moves the gap,
2903 but it handles combining correctly. */
2904 replace_range (pos
, pos
+ 1, string
,
2906 pos_byte_next
= CHAR_TO_BYTE (pos
);
2907 if (pos_byte_next
> pos_byte
)
2908 /* Before combining happened. We should not increment
2909 POS. So, to cancel the later increment of POS,
2913 INC_POS (pos_byte_next
);
2915 if (! NILP (noundo
))
2916 BVAR (current_buffer
, undo_list
) = tem
;
2923 record_change (pos
, 1);
2924 for (i
= 0; i
< len
; i
++) *p
++ = tostr
[i
];
2926 last_changed
= pos
+ 1;
2928 pos_byte
= pos_byte_next
;
2934 signal_after_change (changed
,
2935 last_changed
- changed
, last_changed
- changed
);
2936 update_compositions (changed
, last_changed
, CHECK_ALL
);
2939 unbind_to (count
, Qnil
);
2944 static Lisp_Object
check_translation (EMACS_INT
, EMACS_INT
, EMACS_INT
,
2947 /* Helper function for Ftranslate_region_internal.
2949 Check if a character sequence at POS (POS_BYTE) matches an element
2950 of VAL. VAL is a list (([FROM-CHAR ...] . TO) ...). If a matching
2951 element is found, return it. Otherwise return Qnil. */
2954 check_translation (EMACS_INT pos
, EMACS_INT pos_byte
, EMACS_INT end
,
2957 int buf_size
= 16, buf_used
= 0;
2958 int *buf
= alloca (sizeof (int) * buf_size
);
2960 for (; CONSP (val
); val
= XCDR (val
))
2969 if (! VECTORP (elt
))
2972 if (len
<= end
- pos
)
2974 for (i
= 0; i
< len
; i
++)
2978 unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
2981 if (buf_used
== buf_size
)
2986 newbuf
= alloca (sizeof (int) * buf_size
);
2987 memcpy (newbuf
, buf
, sizeof (int) * buf_used
);
2990 buf
[buf_used
++] = STRING_CHAR_AND_LENGTH (p
, len1
);
2993 if (XINT (AREF (elt
, i
)) != buf
[i
])
3004 DEFUN ("translate-region-internal", Ftranslate_region_internal
,
3005 Stranslate_region_internal
, 3, 3, 0,
3006 doc
: /* Internal use only.
3007 From START to END, translate characters according to TABLE.
3008 TABLE is a string or a char-table; the Nth character in it is the
3009 mapping for the character with code N.
3010 It returns the number of characters changed. */)
3011 (Lisp_Object start
, Lisp_Object end
, register Lisp_Object table
)
3013 register unsigned char *tt
; /* Trans table. */
3014 register int nc
; /* New character. */
3015 int cnt
; /* Number of changes made. */
3016 EMACS_INT size
; /* Size of translate table. */
3017 EMACS_INT pos
, pos_byte
, end_pos
;
3018 int multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3019 int string_multibyte
IF_LINT (= 0);
3021 validate_region (&start
, &end
);
3022 if (CHAR_TABLE_P (table
))
3024 if (! EQ (XCHAR_TABLE (table
)->purpose
, Qtranslation_table
))
3025 error ("Not a translation table");
3031 CHECK_STRING (table
);
3033 if (! multibyte
&& (SCHARS (table
) < SBYTES (table
)))
3034 table
= string_make_unibyte (table
);
3035 string_multibyte
= SCHARS (table
) < SBYTES (table
);
3036 size
= SBYTES (table
);
3041 pos_byte
= CHAR_TO_BYTE (pos
);
3042 end_pos
= XINT (end
);
3043 modify_region (current_buffer
, pos
, end_pos
, 0);
3046 for (; pos
< end_pos
; )
3048 register unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
3049 unsigned char *str
, buf
[MAX_MULTIBYTE_LENGTH
];
3055 oc
= STRING_CHAR_AND_LENGTH (p
, len
);
3062 /* Reload as signal_after_change in last iteration may GC. */
3064 if (string_multibyte
)
3066 str
= tt
+ string_char_to_byte (table
, oc
);
3067 nc
= STRING_CHAR_AND_LENGTH (str
, str_len
);
3072 if (! ASCII_BYTE_P (nc
) && multibyte
)
3074 str_len
= BYTE8_STRING (nc
, buf
);
3089 val
= CHAR_TABLE_REF (table
, oc
);
3090 if (CHARACTERP (val
)
3091 && (c
= XINT (val
), CHAR_VALID_P (c
, 0)))
3094 str_len
= CHAR_STRING (nc
, buf
);
3097 else if (VECTORP (val
) || (CONSP (val
)))
3099 /* VAL is [TO_CHAR ...] or (([FROM-CHAR ...] . TO) ...)
3100 where TO is TO-CHAR or [TO-CHAR ...]. */
3105 if (nc
!= oc
&& nc
>= 0)
3107 /* Simple one char to one char translation. */
3112 /* This is less efficient, because it moves the gap,
3113 but it should handle multibyte characters correctly. */
3114 string
= make_multibyte_string ((char *) str
, 1, str_len
);
3115 replace_range (pos
, pos
+ 1, string
, 1, 0, 1);
3120 record_change (pos
, 1);
3121 while (str_len
-- > 0)
3123 signal_after_change (pos
, 1, 1);
3124 update_compositions (pos
, pos
+ 1, CHECK_BORDER
);
3134 val
= check_translation (pos
, pos_byte
, end_pos
, val
);
3141 /* VAL is ([FROM-CHAR ...] . TO). */
3142 len
= ASIZE (XCAR (val
));
3150 string
= Fconcat (1, &val
);
3154 string
= Fmake_string (make_number (1), val
);
3156 replace_range (pos
, pos
+ len
, string
, 1, 0, 1);
3157 pos_byte
+= SBYTES (string
);
3158 pos
+= SCHARS (string
);
3159 cnt
+= SCHARS (string
);
3160 end_pos
+= SCHARS (string
) - len
;
3168 return make_number (cnt
);
3171 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
3172 doc
: /* Delete the text between point and mark.
3174 When called from a program, expects two arguments,
3175 positions (integers or markers) specifying the stretch to be deleted. */)
3176 (Lisp_Object start
, Lisp_Object end
)
3178 validate_region (&start
, &end
);
3179 del_range (XINT (start
), XINT (end
));
3183 DEFUN ("delete-and-extract-region", Fdelete_and_extract_region
,
3184 Sdelete_and_extract_region
, 2, 2, 0,
3185 doc
: /* Delete the text between START and END and return it. */)
3186 (Lisp_Object start
, Lisp_Object end
)
3188 validate_region (&start
, &end
);
3189 if (XINT (start
) == XINT (end
))
3190 return empty_unibyte_string
;
3191 return del_range_1 (XINT (start
), XINT (end
), 1, 1);
3194 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
3195 doc
: /* Remove restrictions (narrowing) from current buffer.
3196 This allows the buffer's full text to be seen and edited. */)
3199 if (BEG
!= BEGV
|| Z
!= ZV
)
3200 current_buffer
->clip_changed
= 1;
3202 BEGV_BYTE
= BEG_BYTE
;
3203 SET_BUF_ZV_BOTH (current_buffer
, Z
, Z_BYTE
);
3204 /* Changing the buffer bounds invalidates any recorded current column. */
3205 invalidate_current_column ();
3209 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
3210 doc
: /* Restrict editing in this buffer to the current region.
3211 The rest of the text becomes temporarily invisible and untouchable
3212 but is not deleted; if you save the buffer in a file, the invisible
3213 text is included in the file. \\[widen] makes all visible again.
3214 See also `save-restriction'.
3216 When calling from a program, pass two arguments; positions (integers
3217 or markers) bounding the text that should remain visible. */)
3218 (register Lisp_Object start
, Lisp_Object end
)
3220 CHECK_NUMBER_COERCE_MARKER (start
);
3221 CHECK_NUMBER_COERCE_MARKER (end
);
3223 if (XINT (start
) > XINT (end
))
3226 tem
= start
; start
= end
; end
= tem
;
3229 if (!(BEG
<= XINT (start
) && XINT (start
) <= XINT (end
) && XINT (end
) <= Z
))
3230 args_out_of_range (start
, end
);
3232 if (BEGV
!= XFASTINT (start
) || ZV
!= XFASTINT (end
))
3233 current_buffer
->clip_changed
= 1;
3235 SET_BUF_BEGV (current_buffer
, XFASTINT (start
));
3236 SET_BUF_ZV (current_buffer
, XFASTINT (end
));
3237 if (PT
< XFASTINT (start
))
3238 SET_PT (XFASTINT (start
));
3239 if (PT
> XFASTINT (end
))
3240 SET_PT (XFASTINT (end
));
3241 /* Changing the buffer bounds invalidates any recorded current column. */
3242 invalidate_current_column ();
3247 save_restriction_save (void)
3249 if (BEGV
== BEG
&& ZV
== Z
)
3250 /* The common case that the buffer isn't narrowed.
3251 We return just the buffer object, which save_restriction_restore
3252 recognizes as meaning `no restriction'. */
3253 return Fcurrent_buffer ();
3255 /* We have to save a restriction, so return a pair of markers, one
3256 for the beginning and one for the end. */
3258 Lisp_Object beg
, end
;
3260 beg
= buildmark (BEGV
, BEGV_BYTE
);
3261 end
= buildmark (ZV
, ZV_BYTE
);
3263 /* END must move forward if text is inserted at its exact location. */
3264 XMARKER(end
)->insertion_type
= 1;
3266 return Fcons (beg
, end
);
3271 save_restriction_restore (Lisp_Object data
)
3273 struct buffer
*cur
= NULL
;
3274 struct buffer
*buf
= (CONSP (data
)
3275 ? XMARKER (XCAR (data
))->buffer
3278 if (buf
&& buf
!= current_buffer
&& !NILP (BVAR (buf
, pt_marker
)))
3279 { /* If `buf' uses markers to keep track of PT, BEGV, and ZV (as
3280 is the case if it is or has an indirect buffer), then make
3281 sure it is current before we update BEGV, so
3282 set_buffer_internal takes care of managing those markers. */
3283 cur
= current_buffer
;
3284 set_buffer_internal (buf
);
3288 /* A pair of marks bounding a saved restriction. */
3290 struct Lisp_Marker
*beg
= XMARKER (XCAR (data
));
3291 struct Lisp_Marker
*end
= XMARKER (XCDR (data
));
3292 eassert (buf
== end
->buffer
);
3294 if (buf
/* Verify marker still points to a buffer. */
3295 && (beg
->charpos
!= BUF_BEGV (buf
) || end
->charpos
!= BUF_ZV (buf
)))
3296 /* The restriction has changed from the saved one, so restore
3297 the saved restriction. */
3299 EMACS_INT pt
= BUF_PT (buf
);
3301 SET_BUF_BEGV_BOTH (buf
, beg
->charpos
, beg
->bytepos
);
3302 SET_BUF_ZV_BOTH (buf
, end
->charpos
, end
->bytepos
);
3304 if (pt
< beg
->charpos
|| pt
> end
->charpos
)
3305 /* The point is outside the new visible range, move it inside. */
3306 SET_BUF_PT_BOTH (buf
,
3307 clip_to_bounds (beg
->charpos
, pt
, end
->charpos
),
3308 clip_to_bounds (beg
->bytepos
, BUF_PT_BYTE (buf
),
3311 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3315 /* A buffer, which means that there was no old restriction. */
3317 if (buf
/* Verify marker still points to a buffer. */
3318 && (BUF_BEGV (buf
) != BUF_BEG (buf
) || BUF_ZV (buf
) != BUF_Z (buf
)))
3319 /* The buffer has been narrowed, get rid of the narrowing. */
3321 SET_BUF_BEGV_BOTH (buf
, BUF_BEG (buf
), BUF_BEG_BYTE (buf
));
3322 SET_BUF_ZV_BOTH (buf
, BUF_Z (buf
), BUF_Z_BYTE (buf
));
3324 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3328 /* Changing the buffer bounds invalidates any recorded current column. */
3329 invalidate_current_column ();
3332 set_buffer_internal (cur
);
3337 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
3338 doc
: /* Execute BODY, saving and restoring current buffer's restrictions.
3339 The buffer's restrictions make parts of the beginning and end invisible.
3340 \(They are set up with `narrow-to-region' and eliminated with `widen'.)
3341 This special form, `save-restriction', saves the current buffer's restrictions
3342 when it is entered, and restores them when it is exited.
3343 So any `narrow-to-region' within BODY lasts only until the end of the form.
3344 The old restrictions settings are restored
3345 even in case of abnormal exit (throw or error).
3347 The value returned is the value of the last form in BODY.
3349 Note: if you are using both `save-excursion' and `save-restriction',
3350 use `save-excursion' outermost:
3351 (save-excursion (save-restriction ...))
3353 usage: (save-restriction &rest BODY) */)
3356 register Lisp_Object val
;
3357 int count
= SPECPDL_INDEX ();
3359 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
3360 val
= Fprogn (body
);
3361 return unbind_to (count
, val
);
3364 /* Buffer for the most recent text displayed by Fmessage_box. */
3365 static char *message_text
;
3367 /* Allocated length of that buffer. */
3368 static int message_length
;
3370 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
3371 doc
: /* Display a message at the bottom of the screen.
3372 The message also goes into the `*Messages*' buffer.
3373 \(In keyboard macros, that's all it does.)
3376 The first argument is a format control string, and the rest are data
3377 to be formatted under control of the string. See `format' for details.
3379 Note: Use (message "%s" VALUE) to print the value of expressions and
3380 variables to avoid accidentally interpreting `%' as format specifiers.
3382 If the first argument is nil or the empty string, the function clears
3383 any existing message; this lets the minibuffer contents show. See
3384 also `current-message'.
3386 usage: (message FORMAT-STRING &rest ARGS) */)
3387 (size_t nargs
, Lisp_Object
*args
)
3390 || (STRINGP (args
[0])
3391 && SBYTES (args
[0]) == 0))
3398 register Lisp_Object val
;
3399 val
= Fformat (nargs
, args
);
3400 message3 (val
, SBYTES (val
), STRING_MULTIBYTE (val
));
3405 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
3406 doc
: /* Display a message, in a dialog box if possible.
3407 If a dialog box is not available, use the echo area.
3408 The first argument is a format control string, and the rest are data
3409 to be formatted under control of the string. See `format' for details.
3411 If the first argument is nil or the empty string, clear any existing
3412 message; let the minibuffer contents show.
3414 usage: (message-box FORMAT-STRING &rest ARGS) */)
3415 (size_t nargs
, Lisp_Object
*args
)
3424 register Lisp_Object val
;
3425 val
= Fformat (nargs
, args
);
3427 /* The MS-DOS frames support popup menus even though they are
3428 not FRAME_WINDOW_P. */
3429 if (FRAME_WINDOW_P (XFRAME (selected_frame
))
3430 || FRAME_MSDOS_P (XFRAME (selected_frame
)))
3432 Lisp_Object pane
, menu
;
3433 struct gcpro gcpro1
;
3434 pane
= Fcons (Fcons (build_string ("OK"), Qt
), Qnil
);
3436 menu
= Fcons (val
, pane
);
3437 Fx_popup_dialog (Qt
, menu
, Qt
);
3441 #endif /* HAVE_MENUS */
3442 /* Copy the data so that it won't move when we GC. */
3445 message_text
= (char *)xmalloc (80);
3446 message_length
= 80;
3448 if (SBYTES (val
) > message_length
)
3450 message_length
= SBYTES (val
);
3451 message_text
= (char *)xrealloc (message_text
, message_length
);
3453 memcpy (message_text
, SDATA (val
), SBYTES (val
));
3454 message2 (message_text
, SBYTES (val
),
3455 STRING_MULTIBYTE (val
));
3460 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
3461 doc
: /* Display a message in a dialog box or in the echo area.
3462 If this command was invoked with the mouse, use a dialog box if
3463 `use-dialog-box' is non-nil.
3464 Otherwise, use the echo area.
3465 The first argument is a format control string, and the rest are data
3466 to be formatted under control of the string. See `format' for details.
3468 If the first argument is nil or the empty string, clear any existing
3469 message; let the minibuffer contents show.
3471 usage: (message-or-box FORMAT-STRING &rest ARGS) */)
3472 (size_t nargs
, Lisp_Object
*args
)
3475 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3477 return Fmessage_box (nargs
, args
);
3479 return Fmessage (nargs
, args
);
3482 DEFUN ("current-message", Fcurrent_message
, Scurrent_message
, 0, 0, 0,
3483 doc
: /* Return the string currently displayed in the echo area, or nil if none. */)
3486 return current_message ();
3490 DEFUN ("propertize", Fpropertize
, Spropertize
, 1, MANY
, 0,
3491 doc
: /* Return a copy of STRING with text properties added.
3492 First argument is the string to copy.
3493 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
3494 properties to add to the result.
3495 usage: (propertize STRING &rest PROPERTIES) */)
3496 (size_t nargs
, Lisp_Object
*args
)
3498 Lisp_Object properties
, string
;
3499 struct gcpro gcpro1
, gcpro2
;
3502 /* Number of args must be odd. */
3503 if ((nargs
& 1) == 0)
3504 error ("Wrong number of arguments");
3506 properties
= string
= Qnil
;
3507 GCPRO2 (properties
, string
);
3509 /* First argument must be a string. */
3510 CHECK_STRING (args
[0]);
3511 string
= Fcopy_sequence (args
[0]);
3513 for (i
= 1; i
< nargs
; i
+= 2)
3514 properties
= Fcons (args
[i
], Fcons (args
[i
+ 1], properties
));
3516 Fadd_text_properties (make_number (0),
3517 make_number (SCHARS (string
)),
3518 properties
, string
);
3519 RETURN_UNGCPRO (string
);
3522 /* pWIDE is a conversion for printing large decimal integers (possibly with a
3523 trailing "d" that is ignored). pWIDElen is its length. signed_wide and
3524 unsigned_wide are signed and unsigned types for printing them. Use widest
3525 integers if available so that more floating point values can be converted. */
3527 # define pWIDE PRIdMAX
3528 enum { pWIDElen
= sizeof PRIdMAX
- 2 }; /* Don't count trailing "d". */
3529 typedef intmax_t signed_wide
;
3530 typedef uintmax_t unsigned_wide
;
3533 enum { pWIDElen
= sizeof pI
- 1 };
3534 typedef EMACS_INT signed_wide
;
3535 typedef EMACS_UINT unsigned_wide
;
3538 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
3539 doc
: /* Format a string out of a format-string and arguments.
3540 The first argument is a format control string.
3541 The other arguments are substituted into it to make the result, a string.
3543 The format control string may contain %-sequences meaning to substitute
3544 the next available argument:
3546 %s means print a string argument. Actually, prints any object, with `princ'.
3547 %d means print as number in decimal (%o octal, %x hex).
3548 %X is like %x, but uses upper case.
3549 %e means print a number in exponential notation.
3550 %f means print a number in decimal-point notation.
3551 %g means print a number in exponential notation
3552 or decimal-point notation, whichever uses fewer characters.
3553 %c means print a number as a single character.
3554 %S means print any object as an s-expression (using `prin1').
3556 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
3557 Use %% to put a single % into the output.
3559 A %-sequence may contain optional flag, width, and precision
3560 specifiers, as follows:
3562 %<flags><width><precision>character
3564 where flags is [+ #-0]+, width is [0-9]+, and precision is .[0-9]+
3566 The + flag character inserts a + before any positive number, while a
3567 space inserts a space before any positive number; these flags only
3568 affect %d, %e, %f, and %g sequences, and the + flag takes precedence.
3569 The # flag means to use an alternate display form for %o, %x, %X, %e,
3570 %f, and %g sequences. The - and 0 flags affect the width specifier,
3573 The width specifier supplies a lower limit for the length of the
3574 printed representation. The padding, if any, normally goes on the
3575 left, but it goes on the right if the - flag is present. The padding
3576 character is normally a space, but it is 0 if the 0 flag is present.
3577 The - flag takes precedence over the 0 flag.
3579 For %e, %f, and %g sequences, the number after the "." in the
3580 precision specifier says how many decimal places to show; if zero, the
3581 decimal point itself is omitted. For %s and %S, the precision
3582 specifier truncates the string to the given width.
3584 usage: (format STRING &rest OBJECTS) */)
3585 (size_t nargs
, register Lisp_Object
*args
)
3587 EMACS_INT n
; /* The number of the next arg to substitute */
3588 char initial_buffer
[4000];
3589 char *buf
= initial_buffer
;
3590 EMACS_INT bufsize
= sizeof initial_buffer
;
3591 EMACS_INT max_bufsize
= min (MOST_POSITIVE_FIXNUM
+ 1, SIZE_MAX
);
3593 Lisp_Object buf_save_value
IF_LINT (= {0});
3594 register char *format
, *end
, *format_start
;
3595 EMACS_INT formatlen
, nchars
;
3596 /* Nonzero if the format is multibyte. */
3597 int multibyte_format
= 0;
3598 /* Nonzero if the output should be a multibyte string,
3599 which is true if any of the inputs is one. */
3601 /* When we make a multibyte string, we must pay attention to the
3602 byte combining problem, i.e., a byte may be combined with a
3603 multibyte character of the previous string. This flag tells if we
3604 must consider such a situation or not. */
3605 int maybe_combine_byte
;
3607 int arg_intervals
= 0;
3610 /* discarded[I] is 1 if byte I of the format
3611 string was not copied into the output.
3612 It is 2 if byte I was not the first byte of its character. */
3615 /* Each element records, for one argument,
3616 the start and end bytepos in the output string,
3617 whether the argument has been converted to string (e.g., due to "%S"),
3618 and whether the argument is a string with intervals.
3619 info[0] is unused. Unused elements have -1 for start. */
3622 EMACS_INT start
, end
;
3623 int converted_to_string
;
3627 /* It should not be necessary to GCPRO ARGS, because
3628 the caller in the interpreter should take care of that. */
3630 CHECK_STRING (args
[0]);
3631 format_start
= SSDATA (args
[0]);
3632 formatlen
= SBYTES (args
[0]);
3634 /* Allocate the info and discarded tables. */
3637 if ((SIZE_MAX
- formatlen
) / sizeof (struct info
) <= nargs
)
3638 memory_full (SIZE_MAX
);
3639 SAFE_ALLOCA (info
, struct info
*, (nargs
+ 1) * sizeof *info
+ formatlen
);
3640 discarded
= (char *) &info
[nargs
+ 1];
3641 for (i
= 0; i
< nargs
+ 1; i
++)
3644 info
[i
].intervals
= info
[i
].converted_to_string
= 0;
3646 memset (discarded
, 0, formatlen
);
3649 /* Try to determine whether the result should be multibyte.
3650 This is not always right; sometimes the result needs to be multibyte
3651 because of an object that we will pass through prin1,
3652 and in that case, we won't know it here. */
3653 multibyte_format
= STRING_MULTIBYTE (args
[0]);
3654 multibyte
= multibyte_format
;
3655 for (n
= 1; !multibyte
&& n
< nargs
; n
++)
3656 if (STRINGP (args
[n
]) && STRING_MULTIBYTE (args
[n
]))
3659 /* If we start out planning a unibyte result,
3660 then discover it has to be multibyte, we jump back to retry. */
3667 /* Scan the format and store result in BUF. */
3668 format
= format_start
;
3669 end
= format
+ formatlen
;
3670 maybe_combine_byte
= 0;
3672 while (format
!= end
)
3674 /* The values of N and FORMAT when the loop body is entered. */
3676 char *format0
= format
;
3678 /* Bytes needed to represent the output of this conversion. */
3679 EMACS_INT convbytes
;
3683 /* General format specifications look like
3685 '%' [flags] [field-width] [precision] format
3690 field-width ::= [0-9]+
3691 precision ::= '.' [0-9]*
3693 If a field-width is specified, it specifies to which width
3694 the output should be padded with blanks, if the output
3695 string is shorter than field-width.
3697 If precision is specified, it specifies the number of
3698 digits to print after the '.' for floats, or the max.
3699 number of chars to print from a string. */
3706 EMACS_INT field_width
;
3707 int precision_given
;
3708 uintmax_t precision
= UINTMAX_MAX
;
3716 case '-': minus_flag
= 1; continue;
3717 case '+': plus_flag
= 1; continue;
3718 case ' ': space_flag
= 1; continue;
3719 case '#': sharp_flag
= 1; continue;
3720 case '0': zero_flag
= 1; continue;
3725 /* Ignore flags when sprintf ignores them. */
3726 space_flag
&= ~ plus_flag
;
3727 zero_flag
&= ~ minus_flag
;
3730 uintmax_t w
= strtoumax (format
, &num_end
, 10);
3731 if (max_bufsize
<= w
)
3735 precision_given
= *num_end
== '.';
3736 if (precision_given
)
3737 precision
= strtoumax (num_end
+ 1, &num_end
, 10);
3741 error ("Format string ends in middle of format specifier");
3743 memset (&discarded
[format0
- format_start
], 1, format
- format0
);
3744 conversion
= *format
;
3745 if (conversion
== '%')
3747 discarded
[format
- format_start
] = 1;
3752 error ("Not enough arguments for format string");
3754 /* For 'S', prin1 the argument, and then treat like 's'.
3755 For 's', princ any argument that is not a string or
3756 symbol. But don't do this conversion twice, which might
3757 happen after retrying. */
3758 if ((conversion
== 'S'
3759 || (conversion
== 's'
3760 && ! STRINGP (args
[n
]) && ! SYMBOLP (args
[n
]))))
3762 if (! info
[n
].converted_to_string
)
3764 Lisp_Object noescape
= conversion
== 'S' ? Qnil
: Qt
;
3765 args
[n
] = Fprin1_to_string (args
[n
], noescape
);
3766 info
[n
].converted_to_string
= 1;
3767 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3775 else if (conversion
== 'c')
3777 if (FLOATP (args
[n
]))
3779 double d
= XFLOAT_DATA (args
[n
]);
3780 args
[n
] = make_number (FIXNUM_OVERFLOW_P (d
) ? -1 : d
);
3783 if (INTEGERP (args
[n
]) && ! ASCII_CHAR_P (XINT (args
[n
])))
3790 args
[n
] = Fchar_to_string (args
[n
]);
3791 info
[n
].converted_to_string
= 1;
3794 if (info
[n
].converted_to_string
)
3799 if (SYMBOLP (args
[n
]))
3801 args
[n
] = SYMBOL_NAME (args
[n
]);
3802 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3809 if (conversion
== 's')
3811 /* handle case (precision[n] >= 0) */
3813 EMACS_INT width
, padding
, nbytes
;
3814 EMACS_INT nchars_string
;
3816 EMACS_INT prec
= -1;
3817 if (precision_given
&& precision
<= TYPE_MAXIMUM (EMACS_INT
))
3820 /* lisp_string_width ignores a precision of 0, but GNU
3821 libc functions print 0 characters when the precision
3822 is 0. Imitate libc behavior here. Changing
3823 lisp_string_width is the right thing, and will be
3824 done, but meanwhile we work with it. */
3827 width
= nchars_string
= nbytes
= 0;
3831 width
= lisp_string_width (args
[n
], prec
, &nch
, &nby
);
3834 nchars_string
= SCHARS (args
[n
]);
3835 nbytes
= SBYTES (args
[n
]);
3839 nchars_string
= nch
;
3845 if (convbytes
&& multibyte
&& ! STRING_MULTIBYTE (args
[n
]))
3846 convbytes
= count_size_as_multibyte (SDATA (args
[n
]), nbytes
);
3848 padding
= width
< field_width
? field_width
- width
: 0;
3850 if (max_bufsize
- padding
<= convbytes
)
3852 convbytes
+= padding
;
3853 if (convbytes
<= buf
+ bufsize
- p
)
3857 memset (p
, ' ', padding
);
3864 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3865 && STRING_MULTIBYTE (args
[n
])
3866 && !CHAR_HEAD_P (SREF (args
[n
], 0)))
3867 maybe_combine_byte
= 1;
3869 p
+= copy_text (SDATA (args
[n
]), (unsigned char *) p
,
3871 STRING_MULTIBYTE (args
[n
]), multibyte
);
3873 info
[n
].start
= nchars
;
3874 nchars
+= nchars_string
;
3875 info
[n
].end
= nchars
;
3879 memset (p
, ' ', padding
);
3884 /* If this argument has text properties, record where
3885 in the result string it appears. */
3886 if (STRING_INTERVALS (args
[n
]))
3887 info
[n
].intervals
= arg_intervals
= 1;
3892 else if (! (conversion
== 'c' || conversion
== 'd'
3893 || conversion
== 'e' || conversion
== 'f'
3894 || conversion
== 'g' || conversion
== 'i'
3895 || conversion
== 'o' || conversion
== 'x'
3896 || conversion
== 'X'))
3897 error ("Invalid format operation %%%c",
3898 STRING_CHAR ((unsigned char *) format
- 1));
3899 else if (! (INTEGERP (args
[n
]) || FLOATP (args
[n
])))
3900 error ("Format specifier doesn't match argument type");
3905 /* Maximum precision for a %f conversion such that the
3906 trailing output digit might be nonzero. Any precisions
3907 larger than this will not yield useful information. */
3908 USEFUL_PRECISION_MAX
=
3910 * (FLT_RADIX
== 2 || FLT_RADIX
== 10 ? 1
3911 : FLT_RADIX
== 16 ? 4
3914 /* Maximum number of bytes generated by any format, if
3915 precision is no more than DBL_USEFUL_PRECISION_MAX.
3916 On all practical hosts, %f is the worst case. */
3918 sizeof "-." + (DBL_MAX_10_EXP
+ 1) + USEFUL_PRECISION_MAX
3920 verify (0 < USEFUL_PRECISION_MAX
);
3923 EMACS_INT padding
, sprintf_bytes
;
3924 uintmax_t excess_precision
, numwidth
;
3925 uintmax_t leading_zeros
= 0, trailing_zeros
= 0;
3927 char sprintf_buf
[SPRINTF_BUFSIZE
];
3929 /* Copy of conversion specification, modified somewhat.
3930 At most three flags F can be specified at once. */
3931 char convspec
[sizeof "%FFF.*d" + pWIDElen
];
3933 /* Avoid undefined behavior in underlying sprintf. */
3934 if (conversion
== 'd' || conversion
== 'i')
3937 /* Create the copy of the conversion specification, with
3938 any width and precision removed, with ".*" inserted,
3939 and with pWIDE inserted for integer formats. */
3943 *f
= '-'; f
+= minus_flag
;
3944 *f
= '+'; f
+= plus_flag
;
3945 *f
= ' '; f
+= space_flag
;
3946 *f
= '#'; f
+= sharp_flag
;
3947 *f
= '0'; f
+= zero_flag
;
3950 if (conversion
== 'd' || conversion
== 'i'
3951 || conversion
== 'o' || conversion
== 'x'
3952 || conversion
== 'X')
3954 memcpy (f
, pWIDE
, pWIDElen
);
3956 zero_flag
&= ~ precision_given
;
3963 if (precision_given
)
3964 prec
= min (precision
, USEFUL_PRECISION_MAX
);
3966 /* Use sprintf to format this number into sprintf_buf. Omit
3967 padding and excess precision, though, because sprintf limits
3968 output length to INT_MAX.
3970 There are four types of conversion: double, unsigned
3971 char (passed as int), wide signed int, and wide
3972 unsigned int. Treat them separately because the
3973 sprintf ABI is sensitive to which type is passed. Be
3974 careful about integer overflow, NaNs, infinities, and
3975 conversions; for example, the min and max macros are
3976 not suitable here. */
3977 if (conversion
== 'e' || conversion
== 'f' || conversion
== 'g')
3979 double x
= (INTEGERP (args
[n
])
3981 : XFLOAT_DATA (args
[n
]));
3982 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
3984 else if (conversion
== 'c')
3986 /* Don't use sprintf here, as it might mishandle prec. */
3987 sprintf_buf
[0] = XINT (args
[n
]);
3988 sprintf_bytes
= prec
!= 0;
3990 else if (conversion
== 'd')
3992 /* For float, maybe we should use "%1.0f"
3993 instead so it also works for values outside
3994 the integer range. */
3996 if (INTEGERP (args
[n
]))
4000 double d
= XFLOAT_DATA (args
[n
]);
4003 x
= TYPE_MINIMUM (signed_wide
);
4009 x
= TYPE_MAXIMUM (signed_wide
);
4014 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4018 /* Don't sign-extend for octal or hex printing. */
4020 if (INTEGERP (args
[n
]))
4021 x
= XUINT (args
[n
]);
4024 double d
= XFLOAT_DATA (args
[n
]);
4029 x
= TYPE_MAXIMUM (unsigned_wide
);
4034 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4037 /* Now the length of the formatted item is known, except it omits
4038 padding and excess precision. Deal with excess precision
4039 first. This happens only when the format specifies
4040 ridiculously large precision. */
4041 excess_precision
= precision
- prec
;
4042 if (excess_precision
)
4044 if (conversion
== 'e' || conversion
== 'f'
4045 || conversion
== 'g')
4047 if ((conversion
== 'g' && ! sharp_flag
)
4048 || ! ('0' <= sprintf_buf
[sprintf_bytes
- 1]
4049 && sprintf_buf
[sprintf_bytes
- 1] <= '9'))
4050 excess_precision
= 0;
4053 if (conversion
== 'g')
4055 char *dot
= strchr (sprintf_buf
, '.');
4057 excess_precision
= 0;
4060 trailing_zeros
= excess_precision
;
4063 leading_zeros
= excess_precision
;
4066 /* Compute the total bytes needed for this item, including
4067 excess precision and padding. */
4068 numwidth
= sprintf_bytes
+ excess_precision
;
4069 padding
= numwidth
< field_width
? field_width
- numwidth
: 0;
4070 if (max_bufsize
- sprintf_bytes
<= excess_precision
4071 || max_bufsize
- padding
<= numwidth
)
4073 convbytes
= numwidth
+ padding
;
4075 if (convbytes
<= buf
+ bufsize
- p
)
4077 /* Copy the formatted item from sprintf_buf into buf,
4078 inserting padding and excess-precision zeros. */
4080 char *src
= sprintf_buf
;
4082 int exponent_bytes
= 0;
4083 int signedp
= src0
== '-' || src0
== '+' || src0
== ' ';
4084 int significand_bytes
;
4085 if (zero_flag
&& '0' <= src
[signedp
] && src
[signedp
] <= '9')
4087 leading_zeros
+= padding
;
4091 if (excess_precision
4092 && (conversion
== 'e' || conversion
== 'g'))
4094 char *e
= strchr (src
, 'e');
4096 exponent_bytes
= src
+ sprintf_bytes
- e
;
4101 memset (p
, ' ', padding
);
4109 memset (p
, '0', leading_zeros
);
4111 significand_bytes
= sprintf_bytes
- signedp
- exponent_bytes
;
4112 memcpy (p
, src
, significand_bytes
);
4113 p
+= significand_bytes
;
4114 src
+= significand_bytes
;
4115 memset (p
, '0', trailing_zeros
);
4116 p
+= trailing_zeros
;
4117 memcpy (p
, src
, exponent_bytes
);
4118 p
+= exponent_bytes
;
4120 info
[n
].start
= nchars
;
4121 nchars
+= leading_zeros
+ sprintf_bytes
+ trailing_zeros
;
4122 info
[n
].end
= nchars
;
4126 memset (p
, ' ', padding
);
4138 /* Copy a single character from format to buf. */
4141 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
4143 if (multibyte_format
)
4145 /* Copy a whole multibyte character. */
4147 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
4148 && !CHAR_HEAD_P (*format
))
4149 maybe_combine_byte
= 1;
4153 while (! CHAR_HEAD_P (*format
));
4155 convbytes
= format
- format0
;
4156 memset (&discarded
[format0
+ 1 - format_start
], 2, convbytes
- 1);
4160 unsigned char uc
= *format
++;
4161 if (! multibyte
|| ASCII_BYTE_P (uc
))
4165 int c
= BYTE8_TO_CHAR (uc
);
4166 convbytes
= CHAR_STRING (c
, str
);
4171 if (convbytes
<= buf
+ bufsize
- p
)
4173 memcpy (p
, src
, convbytes
);
4180 /* There wasn't enough room to store this conversion or single
4181 character. CONVBYTES says how much room is needed. Allocate
4182 enough room (and then some) and do it again. */
4184 EMACS_INT used
= p
- buf
;
4186 if (max_bufsize
- used
< convbytes
)
4188 bufsize
= used
+ convbytes
;
4189 bufsize
= bufsize
< max_bufsize
/ 2 ? bufsize
* 2 : max_bufsize
;
4191 if (buf
== initial_buffer
)
4193 buf
= xmalloc (bufsize
);
4195 buf_save_value
= make_save_value (buf
, 0);
4196 record_unwind_protect (safe_alloca_unwind
, buf_save_value
);
4197 memcpy (buf
, initial_buffer
, used
);
4200 XSAVE_VALUE (buf_save_value
)->pointer
= buf
= xrealloc (buf
, bufsize
);
4209 if (bufsize
< p
- buf
)
4212 if (maybe_combine_byte
)
4213 nchars
= multibyte_chars_in_text ((unsigned char *) buf
, p
- buf
);
4214 val
= make_specified_string (buf
, nchars
, p
- buf
, multibyte
);
4216 /* If we allocated BUF with malloc, free it too. */
4219 /* If the format string has text properties, or any of the string
4220 arguments has text properties, set up text properties of the
4223 if (STRING_INTERVALS (args
[0]) || arg_intervals
)
4225 Lisp_Object len
, new_len
, props
;
4226 struct gcpro gcpro1
;
4228 /* Add text properties from the format string. */
4229 len
= make_number (SCHARS (args
[0]));
4230 props
= text_property_list (args
[0], make_number (0), len
, Qnil
);
4235 EMACS_INT bytepos
= 0, position
= 0, translated
= 0;
4239 /* Adjust the bounds of each text property
4240 to the proper start and end in the output string. */
4242 /* Put the positions in PROPS in increasing order, so that
4243 we can do (effectively) one scan through the position
4244 space of the format string. */
4245 props
= Fnreverse (props
);
4247 /* BYTEPOS is the byte position in the format string,
4248 POSITION is the untranslated char position in it,
4249 TRANSLATED is the translated char position in BUF,
4250 and ARGN is the number of the next arg we will come to. */
4251 for (list
= props
; CONSP (list
); list
= XCDR (list
))
4258 /* First adjust the property start position. */
4259 pos
= XINT (XCAR (item
));
4261 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
4262 up to this position. */
4263 for (; position
< pos
; bytepos
++)
4265 if (! discarded
[bytepos
])
4266 position
++, translated
++;
4267 else if (discarded
[bytepos
] == 1)
4270 if (translated
== info
[argn
].start
)
4272 translated
+= info
[argn
].end
- info
[argn
].start
;
4278 XSETCAR (item
, make_number (translated
));
4280 /* Likewise adjust the property end position. */
4281 pos
= XINT (XCAR (XCDR (item
)));
4283 for (; position
< pos
; bytepos
++)
4285 if (! discarded
[bytepos
])
4286 position
++, translated
++;
4287 else if (discarded
[bytepos
] == 1)
4290 if (translated
== info
[argn
].start
)
4292 translated
+= info
[argn
].end
- info
[argn
].start
;
4298 XSETCAR (XCDR (item
), make_number (translated
));
4301 add_text_properties_from_list (val
, props
, make_number (0));
4304 /* Add text properties from arguments. */
4306 for (n
= 1; n
< nargs
; ++n
)
4307 if (info
[n
].intervals
)
4309 len
= make_number (SCHARS (args
[n
]));
4310 new_len
= make_number (info
[n
].end
- info
[n
].start
);
4311 props
= text_property_list (args
[n
], make_number (0), len
, Qnil
);
4312 props
= extend_property_ranges (props
, new_len
);
4313 /* If successive arguments have properties, be sure that
4314 the value of `composition' property be the copy. */
4315 if (n
> 1 && info
[n
- 1].end
)
4316 make_composition_value_copy (props
);
4317 add_text_properties_from_list (val
, props
,
4318 make_number (info
[n
].start
));
4328 format2 (const char *string1
, Lisp_Object arg0
, Lisp_Object arg1
)
4330 Lisp_Object args
[3];
4331 args
[0] = build_string (string1
);
4334 return Fformat (3, args
);
4337 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
4338 doc
: /* Return t if two characters match, optionally ignoring case.
4339 Both arguments must be characters (i.e. integers).
4340 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
4341 (register Lisp_Object c1
, Lisp_Object c2
)
4344 /* Check they're chars, not just integers, otherwise we could get array
4345 bounds violations in downcase. */
4346 CHECK_CHARACTER (c1
);
4347 CHECK_CHARACTER (c2
);
4349 if (XINT (c1
) == XINT (c2
))
4351 if (NILP (BVAR (current_buffer
, case_fold_search
)))
4355 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
))
4356 && ! ASCII_CHAR_P (i1
))
4358 MAKE_CHAR_MULTIBYTE (i1
);
4361 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
))
4362 && ! ASCII_CHAR_P (i2
))
4364 MAKE_CHAR_MULTIBYTE (i2
);
4366 return (downcase (i1
) == downcase (i2
) ? Qt
: Qnil
);
4369 /* Transpose the markers in two regions of the current buffer, and
4370 adjust the ones between them if necessary (i.e.: if the regions
4373 START1, END1 are the character positions of the first region.
4374 START1_BYTE, END1_BYTE are the byte positions.
4375 START2, END2 are the character positions of the second region.
4376 START2_BYTE, END2_BYTE are the byte positions.
4378 Traverses the entire marker list of the buffer to do so, adding an
4379 appropriate amount to some, subtracting from some, and leaving the
4380 rest untouched. Most of this is copied from adjust_markers in insdel.c.
4382 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
4385 transpose_markers (EMACS_INT start1
, EMACS_INT end1
,
4386 EMACS_INT start2
, EMACS_INT end2
,
4387 EMACS_INT start1_byte
, EMACS_INT end1_byte
,
4388 EMACS_INT start2_byte
, EMACS_INT end2_byte
)
4390 register EMACS_INT amt1
, amt1_byte
, amt2
, amt2_byte
, diff
, diff_byte
, mpos
;
4391 register struct Lisp_Marker
*marker
;
4393 /* Update point as if it were a marker. */
4397 TEMP_SET_PT_BOTH (PT
+ (end2
- end1
),
4398 PT_BYTE
+ (end2_byte
- end1_byte
));
4399 else if (PT
< start2
)
4400 TEMP_SET_PT_BOTH (PT
+ (end2
- start2
) - (end1
- start1
),
4401 (PT_BYTE
+ (end2_byte
- start2_byte
)
4402 - (end1_byte
- start1_byte
)));
4404 TEMP_SET_PT_BOTH (PT
- (start2
- start1
),
4405 PT_BYTE
- (start2_byte
- start1_byte
));
4407 /* We used to adjust the endpoints here to account for the gap, but that
4408 isn't good enough. Even if we assume the caller has tried to move the
4409 gap out of our way, it might still be at start1 exactly, for example;
4410 and that places it `inside' the interval, for our purposes. The amount
4411 of adjustment is nontrivial if there's a `denormalized' marker whose
4412 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
4413 the dirty work to Fmarker_position, below. */
4415 /* The difference between the region's lengths */
4416 diff
= (end2
- start2
) - (end1
- start1
);
4417 diff_byte
= (end2_byte
- start2_byte
) - (end1_byte
- start1_byte
);
4419 /* For shifting each marker in a region by the length of the other
4420 region plus the distance between the regions. */
4421 amt1
= (end2
- start2
) + (start2
- end1
);
4422 amt2
= (end1
- start1
) + (start2
- end1
);
4423 amt1_byte
= (end2_byte
- start2_byte
) + (start2_byte
- end1_byte
);
4424 amt2_byte
= (end1_byte
- start1_byte
) + (start2_byte
- end1_byte
);
4426 for (marker
= BUF_MARKERS (current_buffer
); marker
; marker
= marker
->next
)
4428 mpos
= marker
->bytepos
;
4429 if (mpos
>= start1_byte
&& mpos
< end2_byte
)
4431 if (mpos
< end1_byte
)
4433 else if (mpos
< start2_byte
)
4437 marker
->bytepos
= mpos
;
4439 mpos
= marker
->charpos
;
4440 if (mpos
>= start1
&& mpos
< end2
)
4444 else if (mpos
< start2
)
4449 marker
->charpos
= mpos
;
4453 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
4454 doc
: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
4455 The regions should not be overlapping, because the size of the buffer is
4456 never changed in a transposition.
4458 Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
4459 any markers that happen to be located in the regions.
4461 Transposing beyond buffer boundaries is an error. */)
4462 (Lisp_Object startr1
, Lisp_Object endr1
, Lisp_Object startr2
, Lisp_Object endr2
, Lisp_Object leave_markers
)
4464 register EMACS_INT start1
, end1
, start2
, end2
;
4465 EMACS_INT start1_byte
, start2_byte
, len1_byte
, len2_byte
;
4466 EMACS_INT gap
, len1
, len_mid
, len2
;
4467 unsigned char *start1_addr
, *start2_addr
, *temp
;
4469 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
, tmp_interval3
;
4472 XSETBUFFER (buf
, current_buffer
);
4473 cur_intv
= BUF_INTERVALS (current_buffer
);
4475 validate_region (&startr1
, &endr1
);
4476 validate_region (&startr2
, &endr2
);
4478 start1
= XFASTINT (startr1
);
4479 end1
= XFASTINT (endr1
);
4480 start2
= XFASTINT (startr2
);
4481 end2
= XFASTINT (endr2
);
4484 /* Swap the regions if they're reversed. */
4487 register EMACS_INT glumph
= start1
;
4495 len1
= end1
- start1
;
4496 len2
= end2
- start2
;
4499 error ("Transposed regions overlap");
4500 /* Nothing to change for adjacent regions with one being empty */
4501 else if ((start1
== end1
|| start2
== end2
) && end1
== start2
)
4504 /* The possibilities are:
4505 1. Adjacent (contiguous) regions, or separate but equal regions
4506 (no, really equal, in this case!), or
4507 2. Separate regions of unequal size.
4509 The worst case is usually No. 2. It means that (aside from
4510 potential need for getting the gap out of the way), there also
4511 needs to be a shifting of the text between the two regions. So
4512 if they are spread far apart, we are that much slower... sigh. */
4514 /* It must be pointed out that the really studly thing to do would
4515 be not to move the gap at all, but to leave it in place and work
4516 around it if necessary. This would be extremely efficient,
4517 especially considering that people are likely to do
4518 transpositions near where they are working interactively, which
4519 is exactly where the gap would be found. However, such code
4520 would be much harder to write and to read. So, if you are
4521 reading this comment and are feeling squirrely, by all means have
4522 a go! I just didn't feel like doing it, so I will simply move
4523 the gap the minimum distance to get it out of the way, and then
4524 deal with an unbroken array. */
4526 /* Make sure the gap won't interfere, by moving it out of the text
4527 we will operate on. */
4528 if (start1
< gap
&& gap
< end2
)
4530 if (gap
- start1
< end2
- gap
)
4536 start1_byte
= CHAR_TO_BYTE (start1
);
4537 start2_byte
= CHAR_TO_BYTE (start2
);
4538 len1_byte
= CHAR_TO_BYTE (end1
) - start1_byte
;
4539 len2_byte
= CHAR_TO_BYTE (end2
) - start2_byte
;
4541 #ifdef BYTE_COMBINING_DEBUG
4544 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4545 len2_byte
, start1
, start1_byte
)
4546 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4547 len1_byte
, end2
, start2_byte
+ len2_byte
)
4548 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4549 len1_byte
, end2
, start2_byte
+ len2_byte
))
4554 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4555 len2_byte
, start1
, start1_byte
)
4556 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4557 len1_byte
, start2
, start2_byte
)
4558 || count_combining_after (BYTE_POS_ADDR (start2_byte
),
4559 len2_byte
, end1
, start1_byte
+ len1_byte
)
4560 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4561 len1_byte
, end2
, start2_byte
+ len2_byte
))
4566 /* Hmmm... how about checking to see if the gap is large
4567 enough to use as the temporary storage? That would avoid an
4568 allocation... interesting. Later, don't fool with it now. */
4570 /* Working without memmove, for portability (sigh), so must be
4571 careful of overlapping subsections of the array... */
4573 if (end1
== start2
) /* adjacent regions */
4575 modify_region (current_buffer
, start1
, end2
, 0);
4576 record_change (start1
, len1
+ len2
);
4578 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4579 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4580 /* Don't use Fset_text_properties: that can cause GC, which can
4581 clobber objects stored in the tmp_intervals. */
4582 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4583 if (!NULL_INTERVAL_P (tmp_interval3
))
4584 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4586 /* First region smaller than second. */
4587 if (len1_byte
< len2_byte
)
4591 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4593 /* Don't precompute these addresses. We have to compute them
4594 at the last minute, because the relocating allocator might
4595 have moved the buffer around during the xmalloc. */
4596 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4597 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4599 memcpy (temp
, start2_addr
, len2_byte
);
4600 memcpy (start1_addr
+ len2_byte
, start1_addr
, len1_byte
);
4601 memcpy (start1_addr
, temp
, len2_byte
);
4605 /* First region not smaller than second. */
4609 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4610 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4611 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4612 memcpy (temp
, start1_addr
, len1_byte
);
4613 memcpy (start1_addr
, start2_addr
, len2_byte
);
4614 memcpy (start1_addr
+ len2_byte
, temp
, len1_byte
);
4617 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
4618 len1
, current_buffer
, 0);
4619 graft_intervals_into_buffer (tmp_interval2
, start1
,
4620 len2
, current_buffer
, 0);
4621 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4622 update_compositions (start1
+ len2
, end2
, CHECK_TAIL
);
4624 /* Non-adjacent regions, because end1 != start2, bleagh... */
4627 len_mid
= start2_byte
- (start1_byte
+ len1_byte
);
4629 if (len1_byte
== len2_byte
)
4630 /* Regions are same size, though, how nice. */
4634 modify_region (current_buffer
, start1
, end1
, 0);
4635 modify_region (current_buffer
, start2
, end2
, 0);
4636 record_change (start1
, len1
);
4637 record_change (start2
, len2
);
4638 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4639 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4641 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr1
, 0);
4642 if (!NULL_INTERVAL_P (tmp_interval3
))
4643 set_text_properties_1 (startr1
, endr1
, Qnil
, buf
, tmp_interval3
);
4645 tmp_interval3
= validate_interval_range (buf
, &startr2
, &endr2
, 0);
4646 if (!NULL_INTERVAL_P (tmp_interval3
))
4647 set_text_properties_1 (startr2
, endr2
, Qnil
, buf
, tmp_interval3
);
4649 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4650 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4651 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4652 memcpy (temp
, start1_addr
, len1_byte
);
4653 memcpy (start1_addr
, start2_addr
, len2_byte
);
4654 memcpy (start2_addr
, temp
, len1_byte
);
4657 graft_intervals_into_buffer (tmp_interval1
, start2
,
4658 len1
, current_buffer
, 0);
4659 graft_intervals_into_buffer (tmp_interval2
, start1
,
4660 len2
, current_buffer
, 0);
4663 else if (len1_byte
< len2_byte
) /* Second region larger than first */
4664 /* Non-adjacent & unequal size, area between must also be shifted. */
4668 modify_region (current_buffer
, start1
, end2
, 0);
4669 record_change (start1
, (end2
- start1
));
4670 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4671 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4672 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4674 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4675 if (!NULL_INTERVAL_P (tmp_interval3
))
4676 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4678 /* holds region 2 */
4679 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4680 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4681 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4682 memcpy (temp
, start2_addr
, len2_byte
);
4683 memcpy (start1_addr
+ len_mid
+ len2_byte
, start1_addr
, len1_byte
);
4684 memmove (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
4685 memcpy (start1_addr
, temp
, len2_byte
);
4688 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4689 len1
, current_buffer
, 0);
4690 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4691 len_mid
, current_buffer
, 0);
4692 graft_intervals_into_buffer (tmp_interval2
, start1
,
4693 len2
, current_buffer
, 0);
4696 /* Second region smaller than first. */
4700 record_change (start1
, (end2
- start1
));
4701 modify_region (current_buffer
, start1
, end2
, 0);
4703 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4704 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4705 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4707 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4708 if (!NULL_INTERVAL_P (tmp_interval3
))
4709 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4711 /* holds region 1 */
4712 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4713 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4714 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4715 memcpy (temp
, start1_addr
, len1_byte
);
4716 memcpy (start1_addr
, start2_addr
, len2_byte
);
4717 memcpy (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
4718 memcpy (start1_addr
+ len2_byte
+ len_mid
, temp
, len1_byte
);
4721 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4722 len1
, current_buffer
, 0);
4723 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4724 len_mid
, current_buffer
, 0);
4725 graft_intervals_into_buffer (tmp_interval2
, start1
,
4726 len2
, current_buffer
, 0);
4729 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4730 update_compositions (end2
- len1
, end2
, CHECK_BORDER
);
4733 /* When doing multiple transpositions, it might be nice
4734 to optimize this. Perhaps the markers in any one buffer
4735 should be organized in some sorted data tree. */
4736 if (NILP (leave_markers
))
4738 transpose_markers (start1
, end1
, start2
, end2
,
4739 start1_byte
, start1_byte
+ len1_byte
,
4740 start2_byte
, start2_byte
+ len2_byte
);
4741 fix_start_end_in_overlays (start1
, end2
);
4744 signal_after_change (start1
, end2
- start1
, end2
- start1
);
4750 syms_of_editfns (void)
4755 Qbuffer_access_fontify_functions
4756 = intern_c_string ("buffer-access-fontify-functions");
4757 staticpro (&Qbuffer_access_fontify_functions
);
4759 DEFVAR_LISP ("inhibit-field-text-motion", Vinhibit_field_text_motion
,
4760 doc
: /* Non-nil means text motion commands don't notice fields. */);
4761 Vinhibit_field_text_motion
= Qnil
;
4763 DEFVAR_LISP ("buffer-access-fontify-functions",
4764 Vbuffer_access_fontify_functions
,
4765 doc
: /* List of functions called by `buffer-substring' to fontify if necessary.
4766 Each function is called with two arguments which specify the range
4767 of the buffer being accessed. */);
4768 Vbuffer_access_fontify_functions
= Qnil
;
4772 obuf
= Fcurrent_buffer ();
4773 /* Do this here, because init_buffer_once is too early--it won't work. */
4774 Fset_buffer (Vprin1_to_string_buffer
);
4775 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
4776 Fset (Fmake_local_variable (intern_c_string ("buffer-access-fontify-functions")),
4781 DEFVAR_LISP ("buffer-access-fontified-property",
4782 Vbuffer_access_fontified_property
,
4783 doc
: /* Property which (if non-nil) indicates text has been fontified.
4784 `buffer-substring' need not call the `buffer-access-fontify-functions'
4785 functions if all the text being accessed has this property. */);
4786 Vbuffer_access_fontified_property
= Qnil
;
4788 DEFVAR_LISP ("system-name", Vsystem_name
,
4789 doc
: /* The host name of the machine Emacs is running on. */);
4791 DEFVAR_LISP ("user-full-name", Vuser_full_name
,
4792 doc
: /* The full name of the user logged in. */);
4794 DEFVAR_LISP ("user-login-name", Vuser_login_name
,
4795 doc
: /* The user's name, taken from environment variables if possible. */);
4797 DEFVAR_LISP ("user-real-login-name", Vuser_real_login_name
,
4798 doc
: /* The user's name, based upon the real uid only. */);
4800 DEFVAR_LISP ("operating-system-release", Voperating_system_release
,
4801 doc
: /* The release of the operating system Emacs is running on. */);
4803 defsubr (&Spropertize
);
4804 defsubr (&Schar_equal
);
4805 defsubr (&Sgoto_char
);
4806 defsubr (&Sstring_to_char
);
4807 defsubr (&Schar_to_string
);
4808 defsubr (&Sbyte_to_string
);
4809 defsubr (&Sbuffer_substring
);
4810 defsubr (&Sbuffer_substring_no_properties
);
4811 defsubr (&Sbuffer_string
);
4813 defsubr (&Spoint_marker
);
4814 defsubr (&Smark_marker
);
4816 defsubr (&Sregion_beginning
);
4817 defsubr (&Sregion_end
);
4819 staticpro (&Qfield
);
4820 Qfield
= intern_c_string ("field");
4821 staticpro (&Qboundary
);
4822 Qboundary
= intern_c_string ("boundary");
4823 defsubr (&Sfield_beginning
);
4824 defsubr (&Sfield_end
);
4825 defsubr (&Sfield_string
);
4826 defsubr (&Sfield_string_no_properties
);
4827 defsubr (&Sdelete_field
);
4828 defsubr (&Sconstrain_to_field
);
4830 defsubr (&Sline_beginning_position
);
4831 defsubr (&Sline_end_position
);
4833 /* defsubr (&Smark); */
4834 /* defsubr (&Sset_mark); */
4835 defsubr (&Ssave_excursion
);
4836 defsubr (&Ssave_current_buffer
);
4838 defsubr (&Sbufsize
);
4839 defsubr (&Spoint_max
);
4840 defsubr (&Spoint_min
);
4841 defsubr (&Spoint_min_marker
);
4842 defsubr (&Spoint_max_marker
);
4843 defsubr (&Sgap_position
);
4844 defsubr (&Sgap_size
);
4845 defsubr (&Sposition_bytes
);
4846 defsubr (&Sbyte_to_position
);
4852 defsubr (&Sfollowing_char
);
4853 defsubr (&Sprevious_char
);
4854 defsubr (&Schar_after
);
4855 defsubr (&Schar_before
);
4857 defsubr (&Sinsert_before_markers
);
4858 defsubr (&Sinsert_and_inherit
);
4859 defsubr (&Sinsert_and_inherit_before_markers
);
4860 defsubr (&Sinsert_char
);
4861 defsubr (&Sinsert_byte
);
4863 defsubr (&Suser_login_name
);
4864 defsubr (&Suser_real_login_name
);
4865 defsubr (&Suser_uid
);
4866 defsubr (&Suser_real_uid
);
4867 defsubr (&Suser_full_name
);
4868 defsubr (&Semacs_pid
);
4869 defsubr (&Scurrent_time
);
4870 defsubr (&Sget_internal_run_time
);
4871 defsubr (&Sformat_time_string
);
4872 defsubr (&Sfloat_time
);
4873 defsubr (&Sdecode_time
);
4874 defsubr (&Sencode_time
);
4875 defsubr (&Scurrent_time_string
);
4876 defsubr (&Scurrent_time_zone
);
4877 defsubr (&Sset_time_zone_rule
);
4878 defsubr (&Ssystem_name
);
4879 defsubr (&Smessage
);
4880 defsubr (&Smessage_box
);
4881 defsubr (&Smessage_or_box
);
4882 defsubr (&Scurrent_message
);
4885 defsubr (&Sinsert_buffer_substring
);
4886 defsubr (&Scompare_buffer_substrings
);
4887 defsubr (&Ssubst_char_in_region
);
4888 defsubr (&Stranslate_region_internal
);
4889 defsubr (&Sdelete_region
);
4890 defsubr (&Sdelete_and_extract_region
);
4892 defsubr (&Snarrow_to_region
);
4893 defsubr (&Ssave_restriction
);
4894 defsubr (&Stranspose_regions
);