1 /* Lisp functions pertaining to editing.
3 Copyright (C) 1985-1987, 1989, 1993-2011 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software: you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation, either version 3 of the License, or
10 (at your option) any later version.
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
22 #include <sys/types.h>
32 #ifdef HAVE_SYS_UTSNAME_H
33 #include <sys/utsname.h>
38 /* systime.h includes <sys/time.h> which, on some systems, is required
39 for <sys/resource.h>; thus systime.h must be included before
43 #if defined HAVE_SYS_RESOURCE_H
44 #include <sys/resource.h>
54 #include "intervals.h"
56 #include "character.h"
60 #include "blockinput.h"
66 #ifndef USER_FULL_NAME
67 #define USER_FULL_NAME pw->pw_gecos
71 extern char **environ
;
74 #define TM_YEAR_BASE 1900
76 /* Nonzero if TM_YEAR is a struct tm's tm_year value that causes
77 asctime to have well-defined behavior. */
78 #ifndef TM_YEAR_IN_ASCTIME_RANGE
79 # define TM_YEAR_IN_ASCTIME_RANGE(tm_year) \
80 (1000 - TM_YEAR_BASE <= (tm_year) && (tm_year) <= 9999 - TM_YEAR_BASE)
84 extern Lisp_Object
w32_get_internal_run_time (void);
87 static void time_overflow (void) NO_RETURN
;
88 static int tm_diff (struct tm
*, struct tm
*);
89 static void update_buffer_properties (ptrdiff_t, ptrdiff_t);
91 static Lisp_Object Qbuffer_access_fontify_functions
;
92 static Lisp_Object
Fuser_full_name (Lisp_Object
);
94 /* Symbol for the text property used to mark fields. */
98 /* A special value for Qfield properties. */
100 static Lisp_Object Qboundary
;
106 const char *user_name
;
108 struct passwd
*pw
; /* password entry for the current user */
111 /* Set up system_name even when dumping. */
115 /* Don't bother with this on initial start when just dumping out */
118 #endif /* not CANNOT_DUMP */
120 pw
= getpwuid (getuid ());
122 /* We let the real user name default to "root" because that's quite
123 accurate on MSDOG and because it lets Emacs find the init file.
124 (The DVX libraries override the Djgpp libraries here.) */
125 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "root");
127 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "unknown");
130 /* Get the effective user name, by consulting environment variables,
131 or the effective uid if those are unset. */
132 user_name
= getenv ("LOGNAME");
135 user_name
= getenv ("USERNAME"); /* it's USERNAME on NT */
136 #else /* WINDOWSNT */
137 user_name
= getenv ("USER");
138 #endif /* WINDOWSNT */
141 pw
= getpwuid (geteuid ());
142 user_name
= pw
? pw
->pw_name
: "unknown";
144 Vuser_login_name
= build_string (user_name
);
146 /* If the user name claimed in the environment vars differs from
147 the real uid, use the claimed name to find the full name. */
148 tem
= Fstring_equal (Vuser_login_name
, Vuser_real_login_name
);
150 tem
= Vuser_login_name
;
153 uid_t euid
= geteuid ();
154 tem
= make_fixnum_or_float (euid
);
156 Vuser_full_name
= Fuser_full_name (tem
);
160 Vuser_full_name
= build_string (p
);
161 else if (NILP (Vuser_full_name
))
162 Vuser_full_name
= build_string ("unknown");
164 #ifdef HAVE_SYS_UTSNAME_H
168 Voperating_system_release
= build_string (uts
.release
);
171 Voperating_system_release
= Qnil
;
175 DEFUN ("char-to-string", Fchar_to_string
, Schar_to_string
, 1, 1, 0,
176 doc
: /* Convert arg CHAR to a string containing that character.
177 usage: (char-to-string CHAR) */)
178 (Lisp_Object character
)
181 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
183 CHECK_CHARACTER (character
);
184 c
= XFASTINT (character
);
186 len
= CHAR_STRING (c
, str
);
187 return make_string_from_bytes ((char *) str
, 1, len
);
190 DEFUN ("byte-to-string", Fbyte_to_string
, Sbyte_to_string
, 1, 1, 0,
191 doc
: /* Convert arg BYTE to a unibyte string containing that byte. */)
196 if (XINT (byte
) < 0 || XINT (byte
) > 255)
197 error ("Invalid byte");
199 return make_string_from_bytes ((char *) &b
, 1, 1);
202 DEFUN ("string-to-char", Fstring_to_char
, Sstring_to_char
, 1, 1, 0,
203 doc
: /* Return the first character in STRING. */)
204 (register Lisp_Object string
)
206 register Lisp_Object val
;
207 CHECK_STRING (string
);
210 if (STRING_MULTIBYTE (string
))
211 XSETFASTINT (val
, STRING_CHAR (SDATA (string
)));
213 XSETFASTINT (val
, SREF (string
, 0));
216 XSETFASTINT (val
, 0);
221 buildmark (ptrdiff_t charpos
, ptrdiff_t bytepos
)
223 register Lisp_Object mark
;
224 mark
= Fmake_marker ();
225 set_marker_both (mark
, Qnil
, charpos
, bytepos
);
229 DEFUN ("point", Fpoint
, Spoint
, 0, 0, 0,
230 doc
: /* Return value of point, as an integer.
231 Beginning of buffer is position (point-min). */)
235 XSETFASTINT (temp
, PT
);
239 DEFUN ("point-marker", Fpoint_marker
, Spoint_marker
, 0, 0, 0,
240 doc
: /* Return value of point, as a marker object. */)
243 return buildmark (PT
, PT_BYTE
);
246 DEFUN ("goto-char", Fgoto_char
, Sgoto_char
, 1, 1, "NGoto char: ",
247 doc
: /* Set point to POSITION, a number or marker.
248 Beginning of buffer is position (point-min), end is (point-max).
250 The return value is POSITION. */)
251 (register Lisp_Object position
)
255 if (MARKERP (position
)
256 && current_buffer
== XMARKER (position
)->buffer
)
258 pos
= marker_position (position
);
260 SET_PT_BOTH (BEGV
, BEGV_BYTE
);
262 SET_PT_BOTH (ZV
, ZV_BYTE
);
264 SET_PT_BOTH (pos
, marker_byte_position (position
));
269 CHECK_NUMBER_COERCE_MARKER (position
);
271 pos
= clip_to_bounds (BEGV
, XINT (position
), ZV
);
277 /* Return the start or end position of the region.
278 BEGINNINGP non-zero means return the start.
279 If there is no region active, signal an error. */
282 region_limit (int beginningp
)
286 if (!NILP (Vtransient_mark_mode
)
287 && NILP (Vmark_even_if_inactive
)
288 && NILP (BVAR (current_buffer
, mark_active
)))
289 xsignal0 (Qmark_inactive
);
291 m
= Fmarker_position (BVAR (current_buffer
, mark
));
293 error ("The mark is not set now, so there is no region");
295 if ((PT
< XFASTINT (m
)) == (beginningp
!= 0))
296 m
= make_number (PT
);
300 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
301 doc
: /* Return the integer value of point or mark, whichever is smaller. */)
304 return region_limit (1);
307 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
308 doc
: /* Return the integer value of point or mark, whichever is larger. */)
311 return region_limit (0);
314 DEFUN ("mark-marker", Fmark_marker
, Smark_marker
, 0, 0, 0,
315 doc
: /* Return this buffer's mark, as a marker object.
316 Watch out! Moving this marker changes the mark position.
317 If you set the marker not to point anywhere, the buffer will have no mark. */)
320 return BVAR (current_buffer
, mark
);
324 /* Find all the overlays in the current buffer that touch position POS.
325 Return the number found, and store them in a vector in VEC
329 overlays_around (EMACS_INT pos
, Lisp_Object
*vec
, ptrdiff_t len
)
331 Lisp_Object overlay
, start
, end
;
332 struct Lisp_Overlay
*tail
;
333 ptrdiff_t startpos
, endpos
;
336 for (tail
= current_buffer
->overlays_before
; tail
; tail
= tail
->next
)
338 XSETMISC (overlay
, tail
);
340 end
= OVERLAY_END (overlay
);
341 endpos
= OVERLAY_POSITION (end
);
344 start
= OVERLAY_START (overlay
);
345 startpos
= OVERLAY_POSITION (start
);
350 /* Keep counting overlays even if we can't return them all. */
355 for (tail
= current_buffer
->overlays_after
; tail
; tail
= tail
->next
)
357 XSETMISC (overlay
, tail
);
359 start
= OVERLAY_START (overlay
);
360 startpos
= OVERLAY_POSITION (start
);
363 end
= OVERLAY_END (overlay
);
364 endpos
= OVERLAY_POSITION (end
);
376 /* Return the value of property PROP, in OBJECT at POSITION.
377 It's the value of PROP that a char inserted at POSITION would get.
378 OBJECT is optional and defaults to the current buffer.
379 If OBJECT is a buffer, then overlay properties are considered as well as
381 If OBJECT is a window, then that window's buffer is used, but
382 window-specific overlays are considered only if they are associated
385 get_pos_property (Lisp_Object position
, register Lisp_Object prop
, Lisp_Object object
)
387 CHECK_NUMBER_COERCE_MARKER (position
);
390 XSETBUFFER (object
, current_buffer
);
391 else if (WINDOWP (object
))
392 object
= XWINDOW (object
)->buffer
;
394 if (!BUFFERP (object
))
395 /* pos-property only makes sense in buffers right now, since strings
396 have no overlays and no notion of insertion for which stickiness
398 return Fget_text_property (position
, prop
, object
);
401 EMACS_INT posn
= XINT (position
);
403 Lisp_Object
*overlay_vec
, tem
;
404 struct buffer
*obuf
= current_buffer
;
406 set_buffer_temp (XBUFFER (object
));
408 /* First try with room for 40 overlays. */
410 overlay_vec
= (Lisp_Object
*) alloca (noverlays
* sizeof (Lisp_Object
));
411 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
413 /* If there are more than 40,
414 make enough space for all, and try again. */
417 overlay_vec
= (Lisp_Object
*) alloca (noverlays
* sizeof (Lisp_Object
));
418 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
420 noverlays
= sort_overlays (overlay_vec
, noverlays
, NULL
);
422 set_buffer_temp (obuf
);
424 /* Now check the overlays in order of decreasing priority. */
425 while (--noverlays
>= 0)
427 Lisp_Object ol
= overlay_vec
[noverlays
];
428 tem
= Foverlay_get (ol
, prop
);
431 /* Check the overlay is indeed active at point. */
432 Lisp_Object start
= OVERLAY_START (ol
), finish
= OVERLAY_END (ol
);
433 if ((OVERLAY_POSITION (start
) == posn
434 && XMARKER (start
)->insertion_type
== 1)
435 || (OVERLAY_POSITION (finish
) == posn
436 && XMARKER (finish
)->insertion_type
== 0))
437 ; /* The overlay will not cover a char inserted at point. */
445 { /* Now check the text properties. */
446 int stickiness
= text_property_stickiness (prop
, position
, object
);
448 return Fget_text_property (position
, prop
, object
);
449 else if (stickiness
< 0
450 && XINT (position
) > BUF_BEGV (XBUFFER (object
)))
451 return Fget_text_property (make_number (XINT (position
) - 1),
459 /* Find the field surrounding POS in *BEG and *END. If POS is nil,
460 the value of point is used instead. If BEG or END is null,
461 means don't store the beginning or end of the field.
463 BEG_LIMIT and END_LIMIT serve to limit the ranged of the returned
464 results; they do not effect boundary behavior.
466 If MERGE_AT_BOUNDARY is nonzero, then if POS is at the very first
467 position of a field, then the beginning of the previous field is
468 returned instead of the beginning of POS's field (since the end of a
469 field is actually also the beginning of the next input field, this
470 behavior is sometimes useful). Additionally in the MERGE_AT_BOUNDARY
471 true case, if two fields are separated by a field with the special
472 value `boundary', and POS lies within it, then the two separated
473 fields are considered to be adjacent, and POS between them, when
474 finding the beginning and ending of the "merged" field.
476 Either BEG or END may be 0, in which case the corresponding value
480 find_field (Lisp_Object pos
, Lisp_Object merge_at_boundary
,
481 Lisp_Object beg_limit
,
482 ptrdiff_t *beg
, Lisp_Object end_limit
, ptrdiff_t *end
)
484 /* Fields right before and after the point. */
485 Lisp_Object before_field
, after_field
;
486 /* 1 if POS counts as the start of a field. */
487 int at_field_start
= 0;
488 /* 1 if POS counts as the end of a field. */
489 int at_field_end
= 0;
492 XSETFASTINT (pos
, PT
);
494 CHECK_NUMBER_COERCE_MARKER (pos
);
497 = get_char_property_and_overlay (pos
, Qfield
, Qnil
, NULL
);
499 = (XFASTINT (pos
) > BEGV
500 ? get_char_property_and_overlay (make_number (XINT (pos
) - 1),
502 /* Using nil here would be a more obvious choice, but it would
503 fail when the buffer starts with a non-sticky field. */
506 /* See if we need to handle the case where MERGE_AT_BOUNDARY is nil
507 and POS is at beginning of a field, which can also be interpreted
508 as the end of the previous field. Note that the case where if
509 MERGE_AT_BOUNDARY is non-nil (see function comment) is actually the
510 more natural one; then we avoid treating the beginning of a field
512 if (NILP (merge_at_boundary
))
514 Lisp_Object field
= get_pos_property (pos
, Qfield
, Qnil
);
515 if (!EQ (field
, after_field
))
517 if (!EQ (field
, before_field
))
519 if (NILP (field
) && at_field_start
&& at_field_end
)
520 /* If an inserted char would have a nil field while the surrounding
521 text is non-nil, we're probably not looking at a
522 zero-length field, but instead at a non-nil field that's
523 not intended for editing (such as comint's prompts). */
524 at_field_end
= at_field_start
= 0;
527 /* Note about special `boundary' fields:
529 Consider the case where the point (`.') is between the fields `x' and `y':
533 In this situation, if merge_at_boundary is true, we consider the
534 `x' and `y' fields as forming one big merged field, and so the end
535 of the field is the end of `y'.
537 However, if `x' and `y' are separated by a special `boundary' field
538 (a field with a `field' char-property of 'boundary), then we ignore
539 this special field when merging adjacent fields. Here's the same
540 situation, but with a `boundary' field between the `x' and `y' fields:
544 Here, if point is at the end of `x', the beginning of `y', or
545 anywhere in-between (within the `boundary' field), we merge all
546 three fields and consider the beginning as being the beginning of
547 the `x' field, and the end as being the end of the `y' field. */
552 /* POS is at the edge of a field, and we should consider it as
553 the beginning of the following field. */
554 *beg
= XFASTINT (pos
);
556 /* Find the previous field boundary. */
559 if (!NILP (merge_at_boundary
) && EQ (before_field
, Qboundary
))
560 /* Skip a `boundary' field. */
561 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
564 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
566 *beg
= NILP (p
) ? BEGV
: XFASTINT (p
);
573 /* POS is at the edge of a field, and we should consider it as
574 the end of the previous field. */
575 *end
= XFASTINT (pos
);
577 /* Find the next field boundary. */
579 if (!NILP (merge_at_boundary
) && EQ (after_field
, Qboundary
))
580 /* Skip a `boundary' field. */
581 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
584 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
586 *end
= NILP (pos
) ? ZV
: XFASTINT (pos
);
592 DEFUN ("delete-field", Fdelete_field
, Sdelete_field
, 0, 1, 0,
593 doc
: /* Delete the field surrounding POS.
594 A field is a region of text with the same `field' property.
595 If POS is nil, the value of point is used for POS. */)
599 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
601 del_range (beg
, end
);
605 DEFUN ("field-string", Ffield_string
, Sfield_string
, 0, 1, 0,
606 doc
: /* Return the contents of the field surrounding POS as a string.
607 A field is a region of text with the same `field' property.
608 If POS is nil, the value of point is used for POS. */)
612 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
613 return make_buffer_string (beg
, end
, 1);
616 DEFUN ("field-string-no-properties", Ffield_string_no_properties
, Sfield_string_no_properties
, 0, 1, 0,
617 doc
: /* Return the contents of the field around POS, without text properties.
618 A field is a region of text with the same `field' property.
619 If POS is nil, the value of point is used for POS. */)
623 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
624 return make_buffer_string (beg
, end
, 0);
627 DEFUN ("field-beginning", Ffield_beginning
, Sfield_beginning
, 0, 3, 0,
628 doc
: /* Return the beginning of the field surrounding POS.
629 A field is a region of text with the same `field' property.
630 If POS is nil, the value of point is used for POS.
631 If ESCAPE-FROM-EDGE is non-nil and POS is at the beginning of its
632 field, then the beginning of the *previous* field is returned.
633 If LIMIT is non-nil, it is a buffer position; if the beginning of the field
634 is before LIMIT, then LIMIT will be returned instead. */)
635 (Lisp_Object pos
, Lisp_Object escape_from_edge
, Lisp_Object limit
)
638 find_field (pos
, escape_from_edge
, limit
, &beg
, Qnil
, 0);
639 return make_number (beg
);
642 DEFUN ("field-end", Ffield_end
, Sfield_end
, 0, 3, 0,
643 doc
: /* Return the end of the field surrounding POS.
644 A field is a region of text with the same `field' property.
645 If POS is nil, the value of point is used for POS.
646 If ESCAPE-FROM-EDGE is non-nil and POS is at the end of its field,
647 then the end of the *following* field is returned.
648 If LIMIT is non-nil, it is a buffer position; if the end of the field
649 is after LIMIT, then LIMIT will be returned instead. */)
650 (Lisp_Object pos
, Lisp_Object escape_from_edge
, Lisp_Object limit
)
653 find_field (pos
, escape_from_edge
, Qnil
, 0, limit
, &end
);
654 return make_number (end
);
657 DEFUN ("constrain-to-field", Fconstrain_to_field
, Sconstrain_to_field
, 2, 5, 0,
658 doc
: /* Return the position closest to NEW-POS that is in the same field as OLD-POS.
660 A field is a region of text with the same `field' property.
661 If NEW-POS is nil, then the current point is used instead, and set to the
662 constrained position if that is different.
664 If OLD-POS is at the boundary of two fields, then the allowable
665 positions for NEW-POS depends on the value of the optional argument
666 ESCAPE-FROM-EDGE: If ESCAPE-FROM-EDGE is nil, then NEW-POS is
667 constrained to the field that has the same `field' char-property
668 as any new characters inserted at OLD-POS, whereas if ESCAPE-FROM-EDGE
669 is non-nil, NEW-POS is constrained to the union of the two adjacent
670 fields. Additionally, if two fields are separated by another field with
671 the special value `boundary', then any point within this special field is
672 also considered to be `on the boundary'.
674 If the optional argument ONLY-IN-LINE is non-nil and constraining
675 NEW-POS would move it to a different line, NEW-POS is returned
676 unconstrained. This useful for commands that move by line, like
677 \\[next-line] or \\[beginning-of-line], which should generally respect field boundaries
678 only in the case where they can still move to the right line.
680 If the optional argument INHIBIT-CAPTURE-PROPERTY is non-nil, and OLD-POS has
681 a non-nil property of that name, then any field boundaries are ignored.
683 Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
684 (Lisp_Object new_pos
, Lisp_Object old_pos
, Lisp_Object escape_from_edge
, Lisp_Object only_in_line
, Lisp_Object inhibit_capture_property
)
686 /* If non-zero, then the original point, before re-positioning. */
687 ptrdiff_t orig_point
= 0;
689 Lisp_Object prev_old
, prev_new
;
692 /* Use the current point, and afterwards, set it. */
695 XSETFASTINT (new_pos
, PT
);
698 CHECK_NUMBER_COERCE_MARKER (new_pos
);
699 CHECK_NUMBER_COERCE_MARKER (old_pos
);
701 fwd
= (XINT (new_pos
) > XINT (old_pos
));
703 prev_old
= make_number (XINT (old_pos
) - 1);
704 prev_new
= make_number (XINT (new_pos
) - 1);
706 if (NILP (Vinhibit_field_text_motion
)
707 && !EQ (new_pos
, old_pos
)
708 && (!NILP (Fget_char_property (new_pos
, Qfield
, Qnil
))
709 || !NILP (Fget_char_property (old_pos
, Qfield
, Qnil
))
710 /* To recognize field boundaries, we must also look at the
711 previous positions; we could use `get_pos_property'
712 instead, but in itself that would fail inside non-sticky
713 fields (like comint prompts). */
714 || (XFASTINT (new_pos
) > BEGV
715 && !NILP (Fget_char_property (prev_new
, Qfield
, Qnil
)))
716 || (XFASTINT (old_pos
) > BEGV
717 && !NILP (Fget_char_property (prev_old
, Qfield
, Qnil
))))
718 && (NILP (inhibit_capture_property
)
719 /* Field boundaries are again a problem; but now we must
720 decide the case exactly, so we need to call
721 `get_pos_property' as well. */
722 || (NILP (get_pos_property (old_pos
, inhibit_capture_property
, Qnil
))
723 && (XFASTINT (old_pos
) <= BEGV
724 || NILP (Fget_char_property (old_pos
, inhibit_capture_property
, Qnil
))
725 || NILP (Fget_char_property (prev_old
, inhibit_capture_property
, Qnil
))))))
726 /* It is possible that NEW_POS is not within the same field as
727 OLD_POS; try to move NEW_POS so that it is. */
730 Lisp_Object field_bound
;
733 field_bound
= Ffield_end (old_pos
, escape_from_edge
, new_pos
);
735 field_bound
= Ffield_beginning (old_pos
, escape_from_edge
, new_pos
);
737 if (/* See if ESCAPE_FROM_EDGE caused FIELD_BOUND to jump to the
738 other side of NEW_POS, which would mean that NEW_POS is
739 already acceptable, and it's not necessary to constrain it
741 ((XFASTINT (field_bound
) < XFASTINT (new_pos
)) ? fwd
: !fwd
)
742 /* NEW_POS should be constrained, but only if either
743 ONLY_IN_LINE is nil (in which case any constraint is OK),
744 or NEW_POS and FIELD_BOUND are on the same line (in which
745 case the constraint is OK even if ONLY_IN_LINE is non-nil). */
746 && (NILP (only_in_line
)
747 /* This is the ONLY_IN_LINE case, check that NEW_POS and
748 FIELD_BOUND are on the same line by seeing whether
749 there's an intervening newline or not. */
750 || (scan_buffer ('\n',
751 XFASTINT (new_pos
), XFASTINT (field_bound
),
752 fwd
? -1 : 1, &shortage
, 1),
754 /* Constrain NEW_POS to FIELD_BOUND. */
755 new_pos
= field_bound
;
757 if (orig_point
&& XFASTINT (new_pos
) != orig_point
)
758 /* The NEW_POS argument was originally nil, so automatically set PT. */
759 SET_PT (XFASTINT (new_pos
));
766 DEFUN ("line-beginning-position",
767 Fline_beginning_position
, Sline_beginning_position
, 0, 1, 0,
768 doc
: /* Return the character position of the first character on the current line.
769 With argument N not nil or 1, move forward N - 1 lines first.
770 If scan reaches end of buffer, return that position.
772 The returned position is of the first character in the logical order,
773 i.e. the one that has the smallest character position.
775 This function constrains the returned position to the current field
776 unless that would be on a different line than the original,
777 unconstrained result. If N is nil or 1, and a front-sticky field
778 starts at point, the scan stops as soon as it starts. To ignore field
779 boundaries bind `inhibit-field-text-motion' to t.
781 This function does not move point. */)
784 ptrdiff_t orig
, orig_byte
, end
;
785 ptrdiff_t count
= SPECPDL_INDEX ();
786 specbind (Qinhibit_point_motion_hooks
, Qt
);
795 Fforward_line (make_number (XINT (n
) - 1));
798 SET_PT_BOTH (orig
, orig_byte
);
800 unbind_to (count
, Qnil
);
802 /* Return END constrained to the current input field. */
803 return Fconstrain_to_field (make_number (end
), make_number (orig
),
804 XINT (n
) != 1 ? Qt
: Qnil
,
808 DEFUN ("line-end-position", Fline_end_position
, Sline_end_position
, 0, 1, 0,
809 doc
: /* Return the character position of the last character on the current line.
810 With argument N not nil or 1, move forward N - 1 lines first.
811 If scan reaches end of buffer, return that position.
813 The returned position is of the last character in the logical order,
814 i.e. the character whose buffer position is the largest one.
816 This function constrains the returned position to the current field
817 unless that would be on a different line than the original,
818 unconstrained result. If N is nil or 1, and a rear-sticky field ends
819 at point, the scan stops as soon as it starts. To ignore field
820 boundaries bind `inhibit-field-text-motion' to t.
822 This function does not move point. */)
834 clipped_n
= clip_to_bounds (PTRDIFF_MIN
+ 1, XINT (n
), PTRDIFF_MAX
);
835 end_pos
= find_before_next_newline (orig
, 0, clipped_n
- (clipped_n
<= 0));
837 /* Return END_POS constrained to the current input field. */
838 return Fconstrain_to_field (make_number (end_pos
), make_number (orig
),
844 save_excursion_save (void)
846 int visible
= (XBUFFER (XWINDOW (selected_window
)->buffer
)
849 return Fcons (Fpoint_marker (),
850 Fcons (Fcopy_marker (BVAR (current_buffer
, mark
), Qnil
),
851 Fcons (visible
? Qt
: Qnil
,
852 Fcons (BVAR (current_buffer
, mark_active
),
857 save_excursion_restore (Lisp_Object info
)
859 Lisp_Object tem
, tem1
, omark
, nmark
;
860 struct gcpro gcpro1
, gcpro2
, gcpro3
;
863 tem
= Fmarker_buffer (XCAR (info
));
864 /* If buffer being returned to is now deleted, avoid error */
865 /* Otherwise could get error here while unwinding to top level
867 /* In that case, Fmarker_buffer returns nil now. */
871 omark
= nmark
= Qnil
;
872 GCPRO3 (info
, omark
, nmark
);
879 unchain_marker (XMARKER (tem
));
884 omark
= Fmarker_position (BVAR (current_buffer
, mark
));
885 Fset_marker (BVAR (current_buffer
, mark
), tem
, Fcurrent_buffer ());
886 nmark
= Fmarker_position (tem
);
887 unchain_marker (XMARKER (tem
));
891 visible_p
= !NILP (XCAR (info
));
893 #if 0 /* We used to make the current buffer visible in the selected window
894 if that was true previously. That avoids some anomalies.
895 But it creates others, and it wasn't documented, and it is simpler
896 and cleaner never to alter the window/buffer connections. */
899 && current_buffer
!= XBUFFER (XWINDOW (selected_window
)->buffer
))
900 Fswitch_to_buffer (Fcurrent_buffer (), Qnil
);
906 tem1
= BVAR (current_buffer
, mark_active
);
907 BVAR (current_buffer
, mark_active
) = tem
;
909 /* If mark is active now, and either was not active
910 or was at a different place, run the activate hook. */
913 if (! EQ (omark
, nmark
))
915 tem
= intern ("activate-mark-hook");
916 Frun_hooks (1, &tem
);
919 /* If mark has ceased to be active, run deactivate hook. */
920 else if (! NILP (tem1
))
922 tem
= intern ("deactivate-mark-hook");
923 Frun_hooks (1, &tem
);
926 /* If buffer was visible in a window, and a different window was
927 selected, and the old selected window is still showing this
928 buffer, restore point in that window. */
931 && !EQ (tem
, selected_window
)
932 && (tem1
= XWINDOW (tem
)->buffer
,
933 (/* Window is live... */
935 /* ...and it shows the current buffer. */
936 && XBUFFER (tem1
) == current_buffer
)))
937 Fset_window_point (tem
, make_number (PT
));
943 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
944 doc
: /* Save point, mark, and current buffer; execute BODY; restore those things.
945 Executes BODY just like `progn'.
946 The values of point, mark and the current buffer are restored
947 even in case of abnormal exit (throw or error).
948 The state of activation of the mark is also restored.
950 This construct does not save `deactivate-mark', and therefore
951 functions that change the buffer will still cause deactivation
952 of the mark at the end of the command. To prevent that, bind
953 `deactivate-mark' with `let'.
955 If you only want to save the current buffer but not point nor mark,
956 then just use `save-current-buffer', or even `with-current-buffer'.
958 usage: (save-excursion &rest BODY) */)
961 register Lisp_Object val
;
962 ptrdiff_t count
= SPECPDL_INDEX ();
964 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
967 return unbind_to (count
, val
);
970 DEFUN ("save-current-buffer", Fsave_current_buffer
, Ssave_current_buffer
, 0, UNEVALLED
, 0,
971 doc
: /* Save the current buffer; execute BODY; restore the current buffer.
972 Executes BODY just like `progn'.
973 usage: (save-current-buffer &rest BODY) */)
977 ptrdiff_t count
= SPECPDL_INDEX ();
979 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
982 return unbind_to (count
, val
);
985 DEFUN ("buffer-size", Fbufsize
, Sbufsize
, 0, 1, 0,
986 doc
: /* Return the number of characters in the current buffer.
987 If BUFFER, return the number of characters in that buffer instead. */)
991 return make_number (Z
- BEG
);
994 CHECK_BUFFER (buffer
);
995 return make_number (BUF_Z (XBUFFER (buffer
))
996 - BUF_BEG (XBUFFER (buffer
)));
1000 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
1001 doc
: /* Return the minimum permissible value of point in the current buffer.
1002 This is 1, unless narrowing (a buffer restriction) is in effect. */)
1006 XSETFASTINT (temp
, BEGV
);
1010 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
1011 doc
: /* Return a marker to the minimum permissible value of point in this buffer.
1012 This is the beginning, unless narrowing (a buffer restriction) is in effect. */)
1015 return buildmark (BEGV
, BEGV_BYTE
);
1018 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
1019 doc
: /* Return the maximum permissible value of point in the current buffer.
1020 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1021 is in effect, in which case it is less. */)
1025 XSETFASTINT (temp
, ZV
);
1029 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
1030 doc
: /* Return a marker to the maximum permissible value of point in this buffer.
1031 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1032 is in effect, in which case it is less. */)
1035 return buildmark (ZV
, ZV_BYTE
);
1038 DEFUN ("gap-position", Fgap_position
, Sgap_position
, 0, 0, 0,
1039 doc
: /* Return the position of the gap, in the current buffer.
1040 See also `gap-size'. */)
1044 XSETFASTINT (temp
, GPT
);
1048 DEFUN ("gap-size", Fgap_size
, Sgap_size
, 0, 0, 0,
1049 doc
: /* Return the size of the current buffer's gap.
1050 See also `gap-position'. */)
1054 XSETFASTINT (temp
, GAP_SIZE
);
1058 DEFUN ("position-bytes", Fposition_bytes
, Sposition_bytes
, 1, 1, 0,
1059 doc
: /* Return the byte position for character position POSITION.
1060 If POSITION is out of range, the value is nil. */)
1061 (Lisp_Object position
)
1063 CHECK_NUMBER_COERCE_MARKER (position
);
1064 if (XINT (position
) < BEG
|| XINT (position
) > Z
)
1066 return make_number (CHAR_TO_BYTE (XINT (position
)));
1069 DEFUN ("byte-to-position", Fbyte_to_position
, Sbyte_to_position
, 1, 1, 0,
1070 doc
: /* Return the character position for byte position BYTEPOS.
1071 If BYTEPOS is out of range, the value is nil. */)
1072 (Lisp_Object bytepos
)
1074 CHECK_NUMBER (bytepos
);
1075 if (XINT (bytepos
) < BEG_BYTE
|| XINT (bytepos
) > Z_BYTE
)
1077 return make_number (BYTE_TO_CHAR (XINT (bytepos
)));
1080 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
1081 doc
: /* Return the character following point, as a number.
1082 At the end of the buffer or accessible region, return 0. */)
1087 XSETFASTINT (temp
, 0);
1089 XSETFASTINT (temp
, FETCH_CHAR (PT_BYTE
));
1093 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
1094 doc
: /* Return the character preceding point, as a number.
1095 At the beginning of the buffer or accessible region, return 0. */)
1100 XSETFASTINT (temp
, 0);
1101 else if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1103 ptrdiff_t pos
= PT_BYTE
;
1105 XSETFASTINT (temp
, FETCH_CHAR (pos
));
1108 XSETFASTINT (temp
, FETCH_BYTE (PT_BYTE
- 1));
1112 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
1113 doc
: /* Return t if point is at the beginning of the buffer.
1114 If the buffer is narrowed, this means the beginning of the narrowed part. */)
1122 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
1123 doc
: /* Return t if point is at the end of the buffer.
1124 If the buffer is narrowed, this means the end of the narrowed part. */)
1132 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
1133 doc
: /* Return t if point is at the beginning of a line. */)
1136 if (PT
== BEGV
|| FETCH_BYTE (PT_BYTE
- 1) == '\n')
1141 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
1142 doc
: /* Return t if point is at the end of a line.
1143 `End of a line' includes point being at the end of the buffer. */)
1146 if (PT
== ZV
|| FETCH_BYTE (PT_BYTE
) == '\n')
1151 DEFUN ("char-after", Fchar_after
, Schar_after
, 0, 1, 0,
1152 doc
: /* Return character in current buffer at position POS.
1153 POS is an integer or a marker and defaults to point.
1154 If POS is out of range, the value is nil. */)
1157 register ptrdiff_t pos_byte
;
1162 XSETFASTINT (pos
, PT
);
1167 pos_byte
= marker_byte_position (pos
);
1168 if (pos_byte
< BEGV_BYTE
|| pos_byte
>= ZV_BYTE
)
1173 CHECK_NUMBER_COERCE_MARKER (pos
);
1174 if (XINT (pos
) < BEGV
|| XINT (pos
) >= ZV
)
1177 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1180 return make_number (FETCH_CHAR (pos_byte
));
1183 DEFUN ("char-before", Fchar_before
, Schar_before
, 0, 1, 0,
1184 doc
: /* Return character in current buffer preceding position POS.
1185 POS is an integer or a marker and defaults to point.
1186 If POS is out of range, the value is nil. */)
1189 register Lisp_Object val
;
1190 register ptrdiff_t pos_byte
;
1195 XSETFASTINT (pos
, PT
);
1200 pos_byte
= marker_byte_position (pos
);
1202 if (pos_byte
<= BEGV_BYTE
|| pos_byte
> ZV_BYTE
)
1207 CHECK_NUMBER_COERCE_MARKER (pos
);
1209 if (XINT (pos
) <= BEGV
|| XINT (pos
) > ZV
)
1212 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1215 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1218 XSETFASTINT (val
, FETCH_CHAR (pos_byte
));
1223 XSETFASTINT (val
, FETCH_BYTE (pos_byte
));
1228 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 1, 0,
1229 doc
: /* Return the name under which the user logged in, as a string.
1230 This is based on the effective uid, not the real uid.
1231 Also, if the environment variables LOGNAME or USER are set,
1232 that determines the value of this function.
1234 If optional argument UID is an integer or a float, return the login name
1235 of the user with that uid, or nil if there is no such user. */)
1241 /* Set up the user name info if we didn't do it before.
1242 (That can happen if Emacs is dumpable
1243 but you decide to run `temacs -l loadup' and not dump. */
1244 if (INTEGERP (Vuser_login_name
))
1248 return Vuser_login_name
;
1250 CONS_TO_INTEGER (uid
, uid_t
, id
);
1254 return (pw
? build_string (pw
->pw_name
) : Qnil
);
1257 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
1259 doc
: /* Return the name of the user's real uid, as a string.
1260 This ignores the environment variables LOGNAME and USER, so it differs from
1261 `user-login-name' when running under `su'. */)
1264 /* Set up the user name info if we didn't do it before.
1265 (That can happen if Emacs is dumpable
1266 but you decide to run `temacs -l loadup' and not dump. */
1267 if (INTEGERP (Vuser_login_name
))
1269 return Vuser_real_login_name
;
1272 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
1273 doc
: /* Return the effective uid of Emacs.
1274 Value is an integer or a float, depending on the value. */)
1277 uid_t euid
= geteuid ();
1278 return make_fixnum_or_float (euid
);
1281 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
1282 doc
: /* Return the real uid of Emacs.
1283 Value is an integer or a float, depending on the value. */)
1286 uid_t uid
= getuid ();
1287 return make_fixnum_or_float (uid
);
1290 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 1, 0,
1291 doc
: /* Return the full name of the user logged in, as a string.
1292 If the full name corresponding to Emacs's userid is not known,
1295 If optional argument UID is an integer or float, return the full name
1296 of the user with that uid, or nil if there is no such user.
1297 If UID is a string, return the full name of the user with that login
1298 name, or nil if there is no such user. */)
1302 register char *p
, *q
;
1306 return Vuser_full_name
;
1307 else if (NUMBERP (uid
))
1310 CONS_TO_INTEGER (uid
, uid_t
, u
);
1315 else if (STRINGP (uid
))
1318 pw
= getpwnam (SSDATA (uid
));
1322 error ("Invalid UID specification");
1328 /* Chop off everything after the first comma. */
1329 q
= strchr (p
, ',');
1330 full
= make_string (p
, q
? q
- p
: strlen (p
));
1332 #ifdef AMPERSAND_FULL_NAME
1334 q
= strchr (p
, '&');
1335 /* Substitute the login name for the &, upcasing the first character. */
1341 login
= Fuser_login_name (make_number (pw
->pw_uid
));
1342 r
= (char *) alloca (strlen (p
) + SCHARS (login
) + 1);
1343 memcpy (r
, p
, q
- p
);
1345 strcat (r
, SSDATA (login
));
1346 r
[q
- p
] = upcase ((unsigned char) r
[q
- p
]);
1348 full
= build_string (r
);
1350 #endif /* AMPERSAND_FULL_NAME */
1355 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
1356 doc
: /* Return the host name of the machine you are running on, as a string. */)
1359 return Vsystem_name
;
1363 get_system_name (void)
1365 if (STRINGP (Vsystem_name
))
1366 return SSDATA (Vsystem_name
);
1371 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
1372 doc
: /* Return the process ID of Emacs, as a number. */)
1375 pid_t pid
= getpid ();
1376 return make_fixnum_or_float (pid
);
1382 # define TIME_T_MIN TYPE_MINIMUM (time_t)
1385 # define TIME_T_MAX TYPE_MAXIMUM (time_t)
1388 /* Report that a time value is out of range for Emacs. */
1390 time_overflow (void)
1392 error ("Specified time is not representable");
1395 /* Return the upper part of the time T (everything but the bottom 16 bits),
1396 making sure that it is representable. */
1400 time_t hi
= t
>> 16;
1402 /* Check for overflow, helping the compiler for common cases where
1403 no runtime check is needed, and taking care not to convert
1404 negative numbers to unsigned before comparing them. */
1405 if (! ((! TYPE_SIGNED (time_t)
1406 || MOST_NEGATIVE_FIXNUM
<= TIME_T_MIN
>> 16
1407 || MOST_NEGATIVE_FIXNUM
<= hi
)
1408 && (TIME_T_MAX
>> 16 <= MOST_POSITIVE_FIXNUM
1409 || hi
<= MOST_POSITIVE_FIXNUM
)))
1415 /* Return the bottom 16 bits of the time T. */
1419 return t
& ((1 << 16) - 1);
1422 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
1423 doc
: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
1424 The time is returned as a list of three integers. The first has the
1425 most significant 16 bits of the seconds, while the second has the
1426 least significant 16 bits. The third integer gives the microsecond
1429 The microsecond count is zero on systems that do not provide
1430 resolution finer than a second. */)
1436 return list3 (make_number (hi_time (EMACS_SECS (t
))),
1437 make_number (lo_time (EMACS_SECS (t
))),
1438 make_number (EMACS_USECS (t
)));
1441 DEFUN ("get-internal-run-time", Fget_internal_run_time
, Sget_internal_run_time
,
1443 doc
: /* Return the current run time used by Emacs.
1444 The time is returned as a list of three integers. The first has the
1445 most significant 16 bits of the seconds, while the second has the
1446 least significant 16 bits. The third integer gives the microsecond
1449 On systems that can't determine the run time, `get-internal-run-time'
1450 does the same thing as `current-time'. The microsecond count is zero
1451 on systems that do not provide resolution finer than a second. */)
1454 #ifdef HAVE_GETRUSAGE
1455 struct rusage usage
;
1459 if (getrusage (RUSAGE_SELF
, &usage
) < 0)
1460 /* This shouldn't happen. What action is appropriate? */
1463 /* Sum up user time and system time. */
1464 secs
= usage
.ru_utime
.tv_sec
+ usage
.ru_stime
.tv_sec
;
1465 usecs
= usage
.ru_utime
.tv_usec
+ usage
.ru_stime
.tv_usec
;
1466 if (usecs
>= 1000000)
1472 return list3 (make_number (hi_time (secs
)),
1473 make_number (lo_time (secs
)),
1474 make_number (usecs
));
1475 #else /* ! HAVE_GETRUSAGE */
1477 return w32_get_internal_run_time ();
1478 #else /* ! WINDOWSNT */
1479 return Fcurrent_time ();
1480 #endif /* WINDOWSNT */
1481 #endif /* HAVE_GETRUSAGE */
1485 /* Make a Lisp list that represents the time T. */
1487 make_time (time_t t
)
1489 return list2 (make_number (hi_time (t
)),
1490 make_number (lo_time (t
)));
1493 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1494 If SPECIFIED_TIME is nil, use the current time.
1495 Set *RESULT to seconds since the Epoch.
1496 If USEC is not null, set *USEC to the microseconds component.
1497 Return nonzero if successful. */
1499 lisp_time_argument (Lisp_Object specified_time
, time_t *result
, int *usec
)
1501 if (NILP (specified_time
))
1508 *usec
= EMACS_USECS (t
);
1509 *result
= EMACS_SECS (t
);
1513 return time (result
) != -1;
1517 Lisp_Object high
, low
;
1519 high
= Fcar (specified_time
);
1520 CHECK_NUMBER (high
);
1521 low
= Fcdr (specified_time
);
1526 Lisp_Object usec_l
= Fcdr (low
);
1528 usec_l
= Fcar (usec_l
);
1533 CHECK_NUMBER (usec_l
);
1534 if (! (0 <= XINT (usec_l
) && XINT (usec_l
) < 1000000))
1536 *usec
= XINT (usec_l
);
1546 /* Check for overflow, helping the compiler for common cases
1547 where no runtime check is needed, and taking care not to
1548 convert negative numbers to unsigned before comparing them. */
1549 if (! ((TYPE_SIGNED (time_t)
1550 ? (TIME_T_MIN
>> 16 <= MOST_NEGATIVE_FIXNUM
1551 || TIME_T_MIN
>> 16 <= hi
)
1553 && (MOST_POSITIVE_FIXNUM
<= TIME_T_MAX
>> 16
1554 || hi
<= TIME_T_MAX
>> 16)))
1557 *result
= (hi
<< 16) + (XINT (low
) & 0xffff);
1562 DEFUN ("float-time", Ffloat_time
, Sfloat_time
, 0, 1, 0,
1563 doc
: /* Return the current time, as a float number of seconds since the epoch.
1564 If SPECIFIED-TIME is given, it is the time to convert to float
1565 instead of the current time. The argument should have the form
1566 (HIGH LOW) or (HIGH LOW USEC). Thus, you can use times obtained from
1567 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
1568 have the form (HIGH . LOW), but this is considered obsolete.
1570 WARNING: Since the result is floating point, it may not be exact.
1571 If precise time stamps are required, use either `current-time',
1572 or (if you need time as a string) `format-time-string'. */)
1573 (Lisp_Object specified_time
)
1578 if (! lisp_time_argument (specified_time
, &sec
, &usec
))
1579 error ("Invalid time specification");
1581 return make_float ((sec
* 1e6
+ usec
) / 1e6
);
1584 /* Write information into buffer S of size MAXSIZE, according to the
1585 FORMAT of length FORMAT_LEN, using time information taken from *TP.
1586 Default to Universal Time if UT is nonzero, local time otherwise.
1587 Use NS as the number of nanoseconds in the %N directive.
1588 Return the number of bytes written, not including the terminating
1589 '\0'. If S is NULL, nothing will be written anywhere; so to
1590 determine how many bytes would be written, use NULL for S and
1591 ((size_t) -1) for MAXSIZE.
1593 This function behaves like nstrftime, except it allows null
1594 bytes in FORMAT and it does not support nanoseconds. */
1596 emacs_nmemftime (char *s
, size_t maxsize
, const char *format
,
1597 size_t format_len
, const struct tm
*tp
, int ut
, int ns
)
1601 /* Loop through all the null-terminated strings in the format
1602 argument. Normally there's just one null-terminated string, but
1603 there can be arbitrarily many, concatenated together, if the
1604 format contains '\0' bytes. nstrftime stops at the first
1605 '\0' byte so we must invoke it separately for each such string. */
1614 result
= nstrftime (s
, maxsize
, format
, tp
, ut
, ns
);
1618 if (result
== 0 && s
[0] != '\0')
1623 maxsize
-= result
+ 1;
1625 len
= strlen (format
);
1626 if (len
== format_len
)
1630 format_len
-= len
+ 1;
1634 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 1, 3, 0,
1635 doc
: /* Use FORMAT-STRING to format the time TIME, or now if omitted.
1636 TIME is specified as (HIGH LOW . IGNORED), as returned by
1637 `current-time' or `file-attributes'. The obsolete form (HIGH . LOW)
1638 is also still accepted.
1639 The third, optional, argument UNIVERSAL, if non-nil, means describe TIME
1640 as Universal Time; nil means describe TIME in the local time zone.
1641 The value is a copy of FORMAT-STRING, but with certain constructs replaced
1642 by text that describes the specified date and time in TIME:
1644 %Y is the year, %y within the century, %C the century.
1645 %G is the year corresponding to the ISO week, %g within the century.
1646 %m is the numeric month.
1647 %b and %h are the locale's abbreviated month name, %B the full name.
1648 %d is the day of the month, zero-padded, %e is blank-padded.
1649 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
1650 %a is the locale's abbreviated name of the day of week, %A the full name.
1651 %U is the week number starting on Sunday, %W starting on Monday,
1652 %V according to ISO 8601.
1653 %j is the day of the year.
1655 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
1656 only blank-padded, %l is like %I blank-padded.
1657 %p is the locale's equivalent of either AM or PM.
1660 %N is the nanosecond, %6N the microsecond, %3N the millisecond, etc.
1661 %Z is the time zone name, %z is the numeric form.
1662 %s is the number of seconds since 1970-01-01 00:00:00 +0000.
1664 %c is the locale's date and time format.
1665 %x is the locale's "preferred" date format.
1666 %D is like "%m/%d/%y".
1668 %R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
1669 %X is the locale's "preferred" time format.
1671 Finally, %n is a newline, %t is a tab, %% is a literal %.
1673 Certain flags and modifiers are available with some format controls.
1674 The flags are `_', `-', `^' and `#'. For certain characters X,
1675 %_X is like %X, but padded with blanks; %-X is like %X,
1676 but without padding. %^X is like %X, but with all textual
1677 characters up-cased; %#X is like %X, but with letter-case of
1678 all textual characters reversed.
1679 %NX (where N stands for an integer) is like %X,
1680 but takes up at least N (a number) positions.
1681 The modifiers are `E' and `O'. For certain characters X,
1682 %EX is a locale's alternative version of %X;
1683 %OX is like %X, but uses the locale's number symbols.
1685 For example, to produce full ISO 8601 format, use "%Y-%m-%dT%T%z".
1687 usage: (format-time-string FORMAT-STRING &optional TIME UNIVERSAL) */)
1688 (Lisp_Object format_string
, Lisp_Object timeval
, Lisp_Object universal
)
1695 int ut
= ! NILP (universal
);
1697 CHECK_STRING (format_string
);
1699 if (! (lisp_time_argument (timeval
, &value
, &usec
)
1700 && 0 <= usec
&& usec
< 1000000))
1701 error ("Invalid time specification");
1704 format_string
= code_convert_string_norecord (format_string
,
1705 Vlocale_coding_system
, 1);
1707 /* This is probably enough. */
1708 size
= SBYTES (format_string
);
1709 if (size
<= (STRING_BYTES_BOUND
- 50) / 6)
1710 size
= size
* 6 + 50;
1713 tm
= ut
? gmtime (&value
) : localtime (&value
);
1718 synchronize_system_time_locale ();
1722 char *buf
= (char *) alloca (size
+ 1);
1727 result
= emacs_nmemftime (buf
, size
, SSDATA (format_string
),
1728 SBYTES (format_string
),
1731 if ((result
> 0 && result
< size
) || (result
== 0 && buf
[0] == '\0'))
1732 return code_convert_string_norecord (make_unibyte_string (buf
, result
),
1733 Vlocale_coding_system
, 0);
1735 /* If buffer was too small, make it bigger and try again. */
1737 result
= emacs_nmemftime (NULL
, (size_t) -1,
1738 SSDATA (format_string
),
1739 SBYTES (format_string
),
1742 if (STRING_BYTES_BOUND
<= result
)
1748 DEFUN ("decode-time", Fdecode_time
, Sdecode_time
, 0, 1, 0,
1749 doc
: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST ZONE).
1750 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED),
1751 as from `current-time' and `file-attributes', or nil to use the
1752 current time. The obsolete form (HIGH . LOW) is also still accepted.
1753 The list has the following nine members: SEC is an integer between 0
1754 and 60; SEC is 60 for a leap second, which only some operating systems
1755 support. MINUTE is an integer between 0 and 59. HOUR is an integer
1756 between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
1757 integer between 1 and 12. YEAR is an integer indicating the
1758 four-digit year. DOW is the day of week, an integer between 0 and 6,
1759 where 0 is Sunday. DST is t if daylight saving time is in effect,
1760 otherwise nil. ZONE is an integer indicating the number of seconds
1761 east of Greenwich. (Note that Common Lisp has different meanings for
1763 (Lisp_Object specified_time
)
1767 struct tm
*decoded_time
;
1768 Lisp_Object list_args
[9];
1770 if (! lisp_time_argument (specified_time
, &time_spec
, NULL
))
1771 error ("Invalid time specification");
1774 decoded_time
= localtime (&time_spec
);
1777 && MOST_NEGATIVE_FIXNUM
- TM_YEAR_BASE
<= decoded_time
->tm_year
1778 && decoded_time
->tm_year
<= MOST_POSITIVE_FIXNUM
- TM_YEAR_BASE
))
1780 XSETFASTINT (list_args
[0], decoded_time
->tm_sec
);
1781 XSETFASTINT (list_args
[1], decoded_time
->tm_min
);
1782 XSETFASTINT (list_args
[2], decoded_time
->tm_hour
);
1783 XSETFASTINT (list_args
[3], decoded_time
->tm_mday
);
1784 XSETFASTINT (list_args
[4], decoded_time
->tm_mon
+ 1);
1785 /* On 64-bit machines an int is narrower than EMACS_INT, thus the
1786 cast below avoids overflow in int arithmetics. */
1787 XSETINT (list_args
[5], TM_YEAR_BASE
+ (EMACS_INT
) decoded_time
->tm_year
);
1788 XSETFASTINT (list_args
[6], decoded_time
->tm_wday
);
1789 list_args
[7] = (decoded_time
->tm_isdst
)? Qt
: Qnil
;
1791 /* Make a copy, in case gmtime modifies the struct. */
1792 save_tm
= *decoded_time
;
1794 decoded_time
= gmtime (&time_spec
);
1796 if (decoded_time
== 0)
1797 list_args
[8] = Qnil
;
1799 XSETINT (list_args
[8], tm_diff (&save_tm
, decoded_time
));
1800 return Flist (9, list_args
);
1803 /* Return OBJ - OFFSET, checking that OBJ is a valid fixnum and that
1804 the result is representable as an int. Assume OFFSET is small and
1807 check_tm_member (Lisp_Object obj
, int offset
)
1812 if (! (INT_MIN
+ offset
<= n
&& n
- offset
<= INT_MAX
))
1817 DEFUN ("encode-time", Fencode_time
, Sencode_time
, 6, MANY
, 0,
1818 doc
: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
1819 This is the reverse operation of `decode-time', which see.
1820 ZONE defaults to the current time zone rule. This can
1821 be a string or t (as from `set-time-zone-rule'), or it can be a list
1822 \(as from `current-time-zone') or an integer (as from `decode-time')
1823 applied without consideration for daylight saving time.
1825 You can pass more than 7 arguments; then the first six arguments
1826 are used as SECOND through YEAR, and the *last* argument is used as ZONE.
1827 The intervening arguments are ignored.
1828 This feature lets (apply 'encode-time (decode-time ...)) work.
1830 Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed;
1831 for example, a DAY of 0 means the day preceding the given month.
1832 Year numbers less than 100 are treated just like other year numbers.
1833 If you want them to stand for years in this century, you must do that yourself.
1835 Years before 1970 are not guaranteed to work. On some systems,
1836 year values as low as 1901 do work.
1838 usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
1839 (ptrdiff_t nargs
, Lisp_Object
*args
)
1843 Lisp_Object zone
= (nargs
> 6 ? args
[nargs
- 1] : Qnil
);
1845 tm
.tm_sec
= check_tm_member (args
[0], 0);
1846 tm
.tm_min
= check_tm_member (args
[1], 0);
1847 tm
.tm_hour
= check_tm_member (args
[2], 0);
1848 tm
.tm_mday
= check_tm_member (args
[3], 0);
1849 tm
.tm_mon
= check_tm_member (args
[4], 1);
1850 tm
.tm_year
= check_tm_member (args
[5], TM_YEAR_BASE
);
1858 value
= mktime (&tm
);
1864 const char *tzstring
;
1865 char **oldenv
= environ
, **newenv
;
1869 else if (STRINGP (zone
))
1870 tzstring
= SSDATA (zone
);
1871 else if (INTEGERP (zone
))
1873 EMACS_INT abszone
= eabs (XINT (zone
));
1874 EMACS_INT zone_hr
= abszone
/ (60*60);
1875 int zone_min
= (abszone
/60) % 60;
1876 int zone_sec
= abszone
% 60;
1877 sprintf (tzbuf
, "XXX%s%"pI
"d:%02d:%02d", "-" + (XINT (zone
) < 0),
1878 zone_hr
, zone_min
, zone_sec
);
1882 error ("Invalid time zone specification");
1884 /* Set TZ before calling mktime; merely adjusting mktime's returned
1885 value doesn't suffice, since that would mishandle leap seconds. */
1886 set_time_zone_rule (tzstring
);
1889 value
= mktime (&tm
);
1892 /* Restore TZ to previous value. */
1896 #ifdef LOCALTIME_CACHE
1901 if (value
== (time_t) -1)
1904 return make_time (value
);
1907 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
1908 doc
: /* Return the current local time, as a human-readable string.
1909 Programs can use this function to decode a time,
1910 since the number of columns in each field is fixed
1911 if the year is in the range 1000-9999.
1912 The format is `Sun Sep 16 01:03:52 1973'.
1913 However, see also the functions `decode-time' and `format-time-string'
1914 which provide a much more powerful and general facility.
1916 If SPECIFIED-TIME is given, it is a time to format instead of the
1917 current time. The argument should have the form (HIGH LOW . IGNORED).
1918 Thus, you can use times obtained from `current-time' and from
1919 `file-attributes'. SPECIFIED-TIME can also have the form (HIGH . LOW),
1920 but this is considered obsolete. */)
1921 (Lisp_Object specified_time
)
1927 if (! lisp_time_argument (specified_time
, &value
, NULL
))
1928 error ("Invalid time specification");
1930 /* Convert to a string, checking for out-of-range time stamps.
1931 Don't use 'ctime', as that might dump core if VALUE is out of
1934 tm
= localtime (&value
);
1936 if (! (tm
&& TM_YEAR_IN_ASCTIME_RANGE (tm
->tm_year
) && (tem
= asctime (tm
))))
1939 /* Remove the trailing newline. */
1940 tem
[strlen (tem
) - 1] = '\0';
1942 return build_string (tem
);
1945 /* Yield A - B, measured in seconds.
1946 This function is copied from the GNU C Library. */
1948 tm_diff (struct tm
*a
, struct tm
*b
)
1950 /* Compute intervening leap days correctly even if year is negative.
1951 Take care to avoid int overflow in leap day calculations,
1952 but it's OK to assume that A and B are close to each other. */
1953 int a4
= (a
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (a
->tm_year
& 3);
1954 int b4
= (b
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (b
->tm_year
& 3);
1955 int a100
= a4
/ 25 - (a4
% 25 < 0);
1956 int b100
= b4
/ 25 - (b4
% 25 < 0);
1957 int a400
= a100
>> 2;
1958 int b400
= b100
>> 2;
1959 int intervening_leap_days
= (a4
- b4
) - (a100
- b100
) + (a400
- b400
);
1960 int years
= a
->tm_year
- b
->tm_year
;
1961 int days
= (365 * years
+ intervening_leap_days
1962 + (a
->tm_yday
- b
->tm_yday
));
1963 return (60 * (60 * (24 * days
+ (a
->tm_hour
- b
->tm_hour
))
1964 + (a
->tm_min
- b
->tm_min
))
1965 + (a
->tm_sec
- b
->tm_sec
));
1968 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
1969 doc
: /* Return the offset and name for the local time zone.
1970 This returns a list of the form (OFFSET NAME).
1971 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
1972 A negative value means west of Greenwich.
1973 NAME is a string giving the name of the time zone.
1974 If SPECIFIED-TIME is given, the time zone offset is determined from it
1975 instead of using the current time. The argument should have the form
1976 (HIGH LOW . IGNORED). Thus, you can use times obtained from
1977 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
1978 have the form (HIGH . LOW), but this is considered obsolete.
1980 Some operating systems cannot provide all this information to Emacs;
1981 in this case, `current-time-zone' returns a list containing nil for
1982 the data it can't find. */)
1983 (Lisp_Object specified_time
)
1989 if (!lisp_time_argument (specified_time
, &value
, NULL
))
1994 t
= gmtime (&value
);
1998 t
= localtime (&value
);
2005 int offset
= tm_diff (t
, &gmt
);
2007 char buf
[sizeof "+00" + INT_STRLEN_BOUND (int)];
2011 s
= (char *)t
->tm_zone
;
2012 #else /* not HAVE_TM_ZONE */
2014 if (t
->tm_isdst
== 0 || t
->tm_isdst
== 1)
2015 s
= tzname
[t
->tm_isdst
];
2017 #endif /* not HAVE_TM_ZONE */
2021 /* No local time zone name is available; use "+-NNNN" instead. */
2022 int m
= offset
/ 60;
2023 int am
= offset
< 0 ? - m
: m
;
2024 sprintf (buf
, "%c%02d%02d", (offset
< 0 ? '-' : '+'), am
/60, am
%60);
2028 return Fcons (make_number (offset
), Fcons (build_string (s
), Qnil
));
2031 return Fmake_list (make_number (2), Qnil
);
2034 /* This holds the value of `environ' produced by the previous
2035 call to Fset_time_zone_rule, or 0 if Fset_time_zone_rule
2036 has never been called. */
2037 static char **environbuf
;
2039 /* This holds the startup value of the TZ environment variable so it
2040 can be restored if the user calls set-time-zone-rule with a nil
2042 static char *initial_tz
;
2044 DEFUN ("set-time-zone-rule", Fset_time_zone_rule
, Sset_time_zone_rule
, 1, 1, 0,
2045 doc
: /* Set the local time zone using TZ, a string specifying a time zone rule.
2046 If TZ is nil, use implementation-defined default time zone information.
2047 If TZ is t, use Universal Time.
2049 Instead of calling this function, you typically want (setenv "TZ" TZ).
2050 That changes both the environment of the Emacs process and the
2051 variable `process-environment', whereas `set-time-zone-rule' affects
2052 only the former. */)
2055 const char *tzstring
;
2057 /* When called for the first time, save the original TZ. */
2059 initial_tz
= (char *) getenv ("TZ");
2062 tzstring
= initial_tz
;
2063 else if (EQ (tz
, Qt
))
2068 tzstring
= SSDATA (tz
);
2071 set_time_zone_rule (tzstring
);
2073 environbuf
= environ
;
2078 #ifdef LOCALTIME_CACHE
2080 /* These two values are known to load tz files in buggy implementations,
2081 i.e. Solaris 1 executables running under either Solaris 1 or Solaris 2.
2082 Their values shouldn't matter in non-buggy implementations.
2083 We don't use string literals for these strings,
2084 since if a string in the environment is in readonly
2085 storage, it runs afoul of bugs in SVR4 and Solaris 2.3.
2086 See Sun bugs 1113095 and 1114114, ``Timezone routines
2087 improperly modify environment''. */
2089 static char set_time_zone_rule_tz1
[] = "TZ=GMT+0";
2090 static char set_time_zone_rule_tz2
[] = "TZ=GMT+1";
2094 /* Set the local time zone rule to TZSTRING.
2095 This allocates memory into `environ', which it is the caller's
2096 responsibility to free. */
2099 set_time_zone_rule (const char *tzstring
)
2102 char **from
, **to
, **newenv
;
2104 /* Make the ENVIRON vector longer with room for TZSTRING. */
2105 for (from
= environ
; *from
; from
++)
2107 envptrs
= from
- environ
+ 2;
2108 newenv
= to
= (char **) xmalloc (envptrs
* sizeof (char *)
2109 + (tzstring
? strlen (tzstring
) + 4 : 0));
2111 /* Add TZSTRING to the end of environ, as a value for TZ. */
2114 char *t
= (char *) (to
+ envptrs
);
2116 strcat (t
, tzstring
);
2120 /* Copy the old environ vector elements into NEWENV,
2121 but don't copy the TZ variable.
2122 So we have only one definition of TZ, which came from TZSTRING. */
2123 for (from
= environ
; *from
; from
++)
2124 if (strncmp (*from
, "TZ=", 3) != 0)
2130 /* If we do have a TZSTRING, NEWENV points to the vector slot where
2131 the TZ variable is stored. If we do not have a TZSTRING,
2132 TO points to the vector slot which has the terminating null. */
2134 #ifdef LOCALTIME_CACHE
2136 /* In SunOS 4.1.3_U1 and 4.1.4, if TZ has a value like
2137 "US/Pacific" that loads a tz file, then changes to a value like
2138 "XXX0" that does not load a tz file, and then changes back to
2139 its original value, the last change is (incorrectly) ignored.
2140 Also, if TZ changes twice in succession to values that do
2141 not load a tz file, tzset can dump core (see Sun bug#1225179).
2142 The following code works around these bugs. */
2146 /* Temporarily set TZ to a value that loads a tz file
2147 and that differs from tzstring. */
2149 *newenv
= (strcmp (tzstring
, set_time_zone_rule_tz1
+ 3) == 0
2150 ? set_time_zone_rule_tz2
: set_time_zone_rule_tz1
);
2156 /* The implied tzstring is unknown, so temporarily set TZ to
2157 two different values that each load a tz file. */
2158 *to
= set_time_zone_rule_tz1
;
2161 *to
= set_time_zone_rule_tz2
;
2166 /* Now TZ has the desired value, and tzset can be invoked safely. */
2173 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
2174 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
2175 type of object is Lisp_String). INHERIT is passed to
2176 INSERT_FROM_STRING_FUNC as the last argument. */
2179 general_insert_function (void (*insert_func
)
2180 (const char *, ptrdiff_t),
2181 void (*insert_from_string_func
)
2182 (Lisp_Object
, ptrdiff_t, ptrdiff_t,
2183 ptrdiff_t, ptrdiff_t, int),
2184 int inherit
, ptrdiff_t nargs
, Lisp_Object
*args
)
2187 register Lisp_Object val
;
2189 for (argnum
= 0; argnum
< nargs
; argnum
++)
2192 if (CHARACTERP (val
))
2194 int c
= XFASTINT (val
);
2195 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2198 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2199 len
= CHAR_STRING (c
, str
);
2202 str
[0] = ASCII_CHAR_P (c
) ? c
: multibyte_char_to_unibyte (c
);
2205 (*insert_func
) ((char *) str
, len
);
2207 else if (STRINGP (val
))
2209 (*insert_from_string_func
) (val
, 0, 0,
2215 wrong_type_argument (Qchar_or_string_p
, val
);
2220 insert1 (Lisp_Object arg
)
2226 /* Callers passing one argument to Finsert need not gcpro the
2227 argument "array", since the only element of the array will
2228 not be used after calling insert or insert_from_string, so
2229 we don't care if it gets trashed. */
2231 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
2232 doc
: /* Insert the arguments, either strings or characters, at point.
2233 Point and before-insertion markers move forward to end up
2234 after the inserted text.
2235 Any other markers at the point of insertion remain before the text.
2237 If the current buffer is multibyte, unibyte strings are converted
2238 to multibyte for insertion (see `string-make-multibyte').
2239 If the current buffer is unibyte, multibyte strings are converted
2240 to unibyte for insertion (see `string-make-unibyte').
2242 When operating on binary data, it may be necessary to preserve the
2243 original bytes of a unibyte string when inserting it into a multibyte
2244 buffer; to accomplish this, apply `string-as-multibyte' to the string
2245 and insert the result.
2247 usage: (insert &rest ARGS) */)
2248 (ptrdiff_t nargs
, Lisp_Object
*args
)
2250 general_insert_function (insert
, insert_from_string
, 0, nargs
, args
);
2254 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
2256 doc
: /* Insert the arguments at point, inheriting properties from adjoining text.
2257 Point and before-insertion markers move forward to end up
2258 after the inserted text.
2259 Any other markers at the point of insertion remain before the text.
2261 If the current buffer is multibyte, unibyte strings are converted
2262 to multibyte for insertion (see `unibyte-char-to-multibyte').
2263 If the current buffer is unibyte, multibyte strings are converted
2264 to unibyte for insertion.
2266 usage: (insert-and-inherit &rest ARGS) */)
2267 (ptrdiff_t nargs
, Lisp_Object
*args
)
2269 general_insert_function (insert_and_inherit
, insert_from_string
, 1,
2274 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
2275 doc
: /* Insert strings or characters at point, relocating markers after the text.
2276 Point and markers move forward to end up after the inserted text.
2278 If the current buffer is multibyte, unibyte strings are converted
2279 to multibyte for insertion (see `unibyte-char-to-multibyte').
2280 If the current buffer is unibyte, multibyte strings are converted
2281 to unibyte for insertion.
2283 usage: (insert-before-markers &rest ARGS) */)
2284 (ptrdiff_t nargs
, Lisp_Object
*args
)
2286 general_insert_function (insert_before_markers
,
2287 insert_from_string_before_markers
, 0,
2292 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers
,
2293 Sinsert_and_inherit_before_markers
, 0, MANY
, 0,
2294 doc
: /* Insert text at point, relocating markers and inheriting properties.
2295 Point and markers move forward to end up after the inserted text.
2297 If the current buffer is multibyte, unibyte strings are converted
2298 to multibyte for insertion (see `unibyte-char-to-multibyte').
2299 If the current buffer is unibyte, multibyte strings are converted
2300 to unibyte for insertion.
2302 usage: (insert-before-markers-and-inherit &rest ARGS) */)
2303 (ptrdiff_t nargs
, Lisp_Object
*args
)
2305 general_insert_function (insert_before_markers_and_inherit
,
2306 insert_from_string_before_markers
, 1,
2311 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 2, 3, 0,
2312 doc
: /* Insert COUNT copies of CHARACTER.
2313 Point, and before-insertion markers, are relocated as in the function `insert'.
2314 The optional third arg INHERIT, if non-nil, says to inherit text properties
2315 from adjoining text, if those properties are sticky. */)
2316 (Lisp_Object character
, Lisp_Object count
, Lisp_Object inherit
)
2319 register ptrdiff_t n
;
2321 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2324 CHECK_CHARACTER (character
);
2325 CHECK_NUMBER (count
);
2326 c
= XFASTINT (character
);
2328 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2329 len
= CHAR_STRING (c
, str
);
2331 str
[0] = c
, len
= 1;
2332 if (XINT (count
) <= 0)
2334 if (BUF_BYTES_MAX
/ len
< XINT (count
))
2336 n
= XINT (count
) * len
;
2337 stringlen
= min (n
, sizeof string
- sizeof string
% len
);
2338 for (i
= 0; i
< stringlen
; i
++)
2339 string
[i
] = str
[i
% len
];
2340 while (n
> stringlen
)
2343 if (!NILP (inherit
))
2344 insert_and_inherit (string
, stringlen
);
2346 insert (string
, stringlen
);
2349 if (!NILP (inherit
))
2350 insert_and_inherit (string
, n
);
2356 DEFUN ("insert-byte", Finsert_byte
, Sinsert_byte
, 2, 3, 0,
2357 doc
: /* Insert COUNT (second arg) copies of BYTE (first arg).
2358 Both arguments are required.
2359 BYTE is a number of the range 0..255.
2361 If BYTE is 128..255 and the current buffer is multibyte, the
2362 corresponding eight-bit character is inserted.
2364 Point, and before-insertion markers, are relocated as in the function `insert'.
2365 The optional third arg INHERIT, if non-nil, says to inherit text properties
2366 from adjoining text, if those properties are sticky. */)
2367 (Lisp_Object byte
, Lisp_Object count
, Lisp_Object inherit
)
2369 CHECK_NUMBER (byte
);
2370 if (XINT (byte
) < 0 || XINT (byte
) > 255)
2371 args_out_of_range_3 (byte
, make_number (0), make_number (255));
2372 if (XINT (byte
) >= 128
2373 && ! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2374 XSETFASTINT (byte
, BYTE8_TO_CHAR (XINT (byte
)));
2375 return Finsert_char (byte
, count
, inherit
);
2379 /* Making strings from buffer contents. */
2381 /* Return a Lisp_String containing the text of the current buffer from
2382 START to END. If text properties are in use and the current buffer
2383 has properties in the range specified, the resulting string will also
2384 have them, if PROPS is nonzero.
2386 We don't want to use plain old make_string here, because it calls
2387 make_uninit_string, which can cause the buffer arena to be
2388 compacted. make_string has no way of knowing that the data has
2389 been moved, and thus copies the wrong data into the string. This
2390 doesn't effect most of the other users of make_string, so it should
2391 be left as is. But we should use this function when conjuring
2392 buffer substrings. */
2395 make_buffer_string (ptrdiff_t start
, ptrdiff_t end
, int props
)
2397 ptrdiff_t start_byte
= CHAR_TO_BYTE (start
);
2398 ptrdiff_t end_byte
= CHAR_TO_BYTE (end
);
2400 return make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
);
2403 /* Return a Lisp_String containing the text of the current buffer from
2404 START / START_BYTE to END / END_BYTE.
2406 If text properties are in use and the current buffer
2407 has properties in the range specified, the resulting string will also
2408 have them, if PROPS is nonzero.
2410 We don't want to use plain old make_string here, because it calls
2411 make_uninit_string, which can cause the buffer arena to be
2412 compacted. make_string has no way of knowing that the data has
2413 been moved, and thus copies the wrong data into the string. This
2414 doesn't effect most of the other users of make_string, so it should
2415 be left as is. But we should use this function when conjuring
2416 buffer substrings. */
2419 make_buffer_string_both (ptrdiff_t start
, ptrdiff_t start_byte
,
2420 ptrdiff_t end
, ptrdiff_t end_byte
, int props
)
2422 Lisp_Object result
, tem
, tem1
;
2424 if (start
< GPT
&& GPT
< end
)
2427 if (! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2428 result
= make_uninit_multibyte_string (end
- start
, end_byte
- start_byte
);
2430 result
= make_uninit_string (end
- start
);
2431 memcpy (SDATA (result
), BYTE_POS_ADDR (start_byte
), end_byte
- start_byte
);
2433 /* If desired, update and copy the text properties. */
2436 update_buffer_properties (start
, end
);
2438 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
2439 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
2441 if (XINT (tem
) != end
|| !NILP (tem1
))
2442 copy_intervals_to_string (result
, current_buffer
, start
,
2449 /* Call Vbuffer_access_fontify_functions for the range START ... END
2450 in the current buffer, if necessary. */
2453 update_buffer_properties (ptrdiff_t start
, ptrdiff_t end
)
2455 /* If this buffer has some access functions,
2456 call them, specifying the range of the buffer being accessed. */
2457 if (!NILP (Vbuffer_access_fontify_functions
))
2459 Lisp_Object args
[3];
2462 args
[0] = Qbuffer_access_fontify_functions
;
2463 XSETINT (args
[1], start
);
2464 XSETINT (args
[2], end
);
2466 /* But don't call them if we can tell that the work
2467 has already been done. */
2468 if (!NILP (Vbuffer_access_fontified_property
))
2470 tem
= Ftext_property_any (args
[1], args
[2],
2471 Vbuffer_access_fontified_property
,
2474 Frun_hook_with_args (3, args
);
2477 Frun_hook_with_args (3, args
);
2481 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
2482 doc
: /* Return the contents of part of the current buffer as a string.
2483 The two arguments START and END are character positions;
2484 they can be in either order.
2485 The string returned is multibyte if the buffer is multibyte.
2487 This function copies the text properties of that part of the buffer
2488 into the result string; if you don't want the text properties,
2489 use `buffer-substring-no-properties' instead. */)
2490 (Lisp_Object start
, Lisp_Object end
)
2492 register ptrdiff_t b
, e
;
2494 validate_region (&start
, &end
);
2498 return make_buffer_string (b
, e
, 1);
2501 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties
,
2502 Sbuffer_substring_no_properties
, 2, 2, 0,
2503 doc
: /* Return the characters of part of the buffer, without the text properties.
2504 The two arguments START and END are character positions;
2505 they can be in either order. */)
2506 (Lisp_Object start
, Lisp_Object end
)
2508 register ptrdiff_t b
, e
;
2510 validate_region (&start
, &end
);
2514 return make_buffer_string (b
, e
, 0);
2517 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
2518 doc
: /* Return the contents of the current buffer as a string.
2519 If narrowing is in effect, this function returns only the visible part
2523 return make_buffer_string (BEGV
, ZV
, 1);
2526 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
2528 doc
: /* Insert before point a substring of the contents of BUFFER.
2529 BUFFER may be a buffer or a buffer name.
2530 Arguments START and END are character positions specifying the substring.
2531 They default to the values of (point-min) and (point-max) in BUFFER. */)
2532 (Lisp_Object buffer
, Lisp_Object start
, Lisp_Object end
)
2534 register EMACS_INT b
, e
, temp
;
2535 register struct buffer
*bp
, *obuf
;
2538 buf
= Fget_buffer (buffer
);
2542 if (NILP (BVAR (bp
, name
)))
2543 error ("Selecting deleted buffer");
2549 CHECK_NUMBER_COERCE_MARKER (start
);
2556 CHECK_NUMBER_COERCE_MARKER (end
);
2561 temp
= b
, b
= e
, e
= temp
;
2563 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
2564 args_out_of_range (start
, end
);
2566 obuf
= current_buffer
;
2567 set_buffer_internal_1 (bp
);
2568 update_buffer_properties (b
, e
);
2569 set_buffer_internal_1 (obuf
);
2571 insert_from_buffer (bp
, b
, e
- b
, 0);
2575 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
2577 doc
: /* Compare two substrings of two buffers; return result as number.
2578 the value is -N if first string is less after N-1 chars,
2579 +N if first string is greater after N-1 chars, or 0 if strings match.
2580 Each substring is represented as three arguments: BUFFER, START and END.
2581 That makes six args in all, three for each substring.
2583 The value of `case-fold-search' in the current buffer
2584 determines whether case is significant or ignored. */)
2585 (Lisp_Object buffer1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object buffer2
, Lisp_Object start2
, Lisp_Object end2
)
2587 register EMACS_INT begp1
, endp1
, begp2
, endp2
, temp
;
2588 register struct buffer
*bp1
, *bp2
;
2589 register Lisp_Object trt
2590 = (!NILP (BVAR (current_buffer
, case_fold_search
))
2591 ? BVAR (current_buffer
, case_canon_table
) : Qnil
);
2592 ptrdiff_t chars
= 0;
2593 ptrdiff_t i1
, i2
, i1_byte
, i2_byte
;
2595 /* Find the first buffer and its substring. */
2598 bp1
= current_buffer
;
2602 buf1
= Fget_buffer (buffer1
);
2605 bp1
= XBUFFER (buf1
);
2606 if (NILP (BVAR (bp1
, name
)))
2607 error ("Selecting deleted buffer");
2611 begp1
= BUF_BEGV (bp1
);
2614 CHECK_NUMBER_COERCE_MARKER (start1
);
2615 begp1
= XINT (start1
);
2618 endp1
= BUF_ZV (bp1
);
2621 CHECK_NUMBER_COERCE_MARKER (end1
);
2622 endp1
= XINT (end1
);
2626 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
2628 if (!(BUF_BEGV (bp1
) <= begp1
2630 && endp1
<= BUF_ZV (bp1
)))
2631 args_out_of_range (start1
, end1
);
2633 /* Likewise for second substring. */
2636 bp2
= current_buffer
;
2640 buf2
= Fget_buffer (buffer2
);
2643 bp2
= XBUFFER (buf2
);
2644 if (NILP (BVAR (bp2
, name
)))
2645 error ("Selecting deleted buffer");
2649 begp2
= BUF_BEGV (bp2
);
2652 CHECK_NUMBER_COERCE_MARKER (start2
);
2653 begp2
= XINT (start2
);
2656 endp2
= BUF_ZV (bp2
);
2659 CHECK_NUMBER_COERCE_MARKER (end2
);
2660 endp2
= XINT (end2
);
2664 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
2666 if (!(BUF_BEGV (bp2
) <= begp2
2668 && endp2
<= BUF_ZV (bp2
)))
2669 args_out_of_range (start2
, end2
);
2673 i1_byte
= buf_charpos_to_bytepos (bp1
, i1
);
2674 i2_byte
= buf_charpos_to_bytepos (bp2
, i2
);
2676 while (i1
< endp1
&& i2
< endp2
)
2678 /* When we find a mismatch, we must compare the
2679 characters, not just the bytes. */
2684 if (! NILP (BVAR (bp1
, enable_multibyte_characters
)))
2686 c1
= BUF_FETCH_MULTIBYTE_CHAR (bp1
, i1_byte
);
2687 BUF_INC_POS (bp1
, i1_byte
);
2692 c1
= BUF_FETCH_BYTE (bp1
, i1
);
2693 MAKE_CHAR_MULTIBYTE (c1
);
2697 if (! NILP (BVAR (bp2
, enable_multibyte_characters
)))
2699 c2
= BUF_FETCH_MULTIBYTE_CHAR (bp2
, i2_byte
);
2700 BUF_INC_POS (bp2
, i2_byte
);
2705 c2
= BUF_FETCH_BYTE (bp2
, i2
);
2706 MAKE_CHAR_MULTIBYTE (c2
);
2712 c1
= CHAR_TABLE_TRANSLATE (trt
, c1
);
2713 c2
= CHAR_TABLE_TRANSLATE (trt
, c2
);
2716 return make_number (- 1 - chars
);
2718 return make_number (chars
+ 1);
2723 /* The strings match as far as they go.
2724 If one is shorter, that one is less. */
2725 if (chars
< endp1
- begp1
)
2726 return make_number (chars
+ 1);
2727 else if (chars
< endp2
- begp2
)
2728 return make_number (- chars
- 1);
2730 /* Same length too => they are equal. */
2731 return make_number (0);
2735 subst_char_in_region_unwind (Lisp_Object arg
)
2737 return BVAR (current_buffer
, undo_list
) = arg
;
2741 subst_char_in_region_unwind_1 (Lisp_Object arg
)
2743 return BVAR (current_buffer
, filename
) = arg
;
2746 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
2747 Ssubst_char_in_region
, 4, 5, 0,
2748 doc
: /* From START to END, replace FROMCHAR with TOCHAR each time it occurs.
2749 If optional arg NOUNDO is non-nil, don't record this change for undo
2750 and don't mark the buffer as really changed.
2751 Both characters must have the same length of multi-byte form. */)
2752 (Lisp_Object start
, Lisp_Object end
, Lisp_Object fromchar
, Lisp_Object tochar
, Lisp_Object noundo
)
2754 register ptrdiff_t pos
, pos_byte
, stop
, i
, len
, end_byte
;
2755 /* Keep track of the first change in the buffer:
2756 if 0 we haven't found it yet.
2757 if < 0 we've found it and we've run the before-change-function.
2758 if > 0 we've actually performed it and the value is its position. */
2759 ptrdiff_t changed
= 0;
2760 unsigned char fromstr
[MAX_MULTIBYTE_LENGTH
], tostr
[MAX_MULTIBYTE_LENGTH
];
2762 ptrdiff_t count
= SPECPDL_INDEX ();
2763 #define COMBINING_NO 0
2764 #define COMBINING_BEFORE 1
2765 #define COMBINING_AFTER 2
2766 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
2767 int maybe_byte_combining
= COMBINING_NO
;
2768 ptrdiff_t last_changed
= 0;
2769 int multibyte_p
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
2774 validate_region (&start
, &end
);
2775 CHECK_CHARACTER (fromchar
);
2776 CHECK_CHARACTER (tochar
);
2777 fromc
= XFASTINT (fromchar
);
2778 toc
= XFASTINT (tochar
);
2782 len
= CHAR_STRING (fromc
, fromstr
);
2783 if (CHAR_STRING (toc
, tostr
) != len
)
2784 error ("Characters in `subst-char-in-region' have different byte-lengths");
2785 if (!ASCII_BYTE_P (*tostr
))
2787 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
2788 complete multibyte character, it may be combined with the
2789 after bytes. If it is in the range 0xA0..0xFF, it may be
2790 combined with the before and after bytes. */
2791 if (!CHAR_HEAD_P (*tostr
))
2792 maybe_byte_combining
= COMBINING_BOTH
;
2793 else if (BYTES_BY_CHAR_HEAD (*tostr
) > len
)
2794 maybe_byte_combining
= COMBINING_AFTER
;
2805 pos_byte
= CHAR_TO_BYTE (pos
);
2806 stop
= CHAR_TO_BYTE (XINT (end
));
2809 /* If we don't want undo, turn off putting stuff on the list.
2810 That's faster than getting rid of things,
2811 and it prevents even the entry for a first change.
2812 Also inhibit locking the file. */
2813 if (!changed
&& !NILP (noundo
))
2815 record_unwind_protect (subst_char_in_region_unwind
,
2816 BVAR (current_buffer
, undo_list
));
2817 BVAR (current_buffer
, undo_list
) = Qt
;
2818 /* Don't do file-locking. */
2819 record_unwind_protect (subst_char_in_region_unwind_1
,
2820 BVAR (current_buffer
, filename
));
2821 BVAR (current_buffer
, filename
) = Qnil
;
2824 if (pos_byte
< GPT_BYTE
)
2825 stop
= min (stop
, GPT_BYTE
);
2828 ptrdiff_t pos_byte_next
= pos_byte
;
2830 if (pos_byte
>= stop
)
2832 if (pos_byte
>= end_byte
) break;
2835 p
= BYTE_POS_ADDR (pos_byte
);
2837 INC_POS (pos_byte_next
);
2840 if (pos_byte_next
- pos_byte
== len
2841 && p
[0] == fromstr
[0]
2843 || (p
[1] == fromstr
[1]
2844 && (len
== 2 || (p
[2] == fromstr
[2]
2845 && (len
== 3 || p
[3] == fromstr
[3]))))))
2848 /* We've already seen this and run the before-change-function;
2849 this time we only need to record the actual position. */
2854 modify_region (current_buffer
, pos
, XINT (end
), 0);
2856 if (! NILP (noundo
))
2858 if (MODIFF
- 1 == SAVE_MODIFF
)
2860 if (MODIFF
- 1 == BUF_AUTOSAVE_MODIFF (current_buffer
))
2861 BUF_AUTOSAVE_MODIFF (current_buffer
)++;
2864 /* The before-change-function may have moved the gap
2865 or even modified the buffer so we should start over. */
2869 /* Take care of the case where the new character
2870 combines with neighboring bytes. */
2871 if (maybe_byte_combining
2872 && (maybe_byte_combining
== COMBINING_AFTER
2873 ? (pos_byte_next
< Z_BYTE
2874 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2875 : ((pos_byte_next
< Z_BYTE
2876 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2877 || (pos_byte
> BEG_BYTE
2878 && ! ASCII_BYTE_P (FETCH_BYTE (pos_byte
- 1))))))
2880 Lisp_Object tem
, string
;
2882 struct gcpro gcpro1
;
2884 tem
= BVAR (current_buffer
, undo_list
);
2887 /* Make a multibyte string containing this single character. */
2888 string
= make_multibyte_string ((char *) tostr
, 1, len
);
2889 /* replace_range is less efficient, because it moves the gap,
2890 but it handles combining correctly. */
2891 replace_range (pos
, pos
+ 1, string
,
2893 pos_byte_next
= CHAR_TO_BYTE (pos
);
2894 if (pos_byte_next
> pos_byte
)
2895 /* Before combining happened. We should not increment
2896 POS. So, to cancel the later increment of POS,
2900 INC_POS (pos_byte_next
);
2902 if (! NILP (noundo
))
2903 BVAR (current_buffer
, undo_list
) = tem
;
2910 record_change (pos
, 1);
2911 for (i
= 0; i
< len
; i
++) *p
++ = tostr
[i
];
2913 last_changed
= pos
+ 1;
2915 pos_byte
= pos_byte_next
;
2921 signal_after_change (changed
,
2922 last_changed
- changed
, last_changed
- changed
);
2923 update_compositions (changed
, last_changed
, CHECK_ALL
);
2926 unbind_to (count
, Qnil
);
2931 static Lisp_Object
check_translation (ptrdiff_t, ptrdiff_t, ptrdiff_t,
2934 /* Helper function for Ftranslate_region_internal.
2936 Check if a character sequence at POS (POS_BYTE) matches an element
2937 of VAL. VAL is a list (([FROM-CHAR ...] . TO) ...). If a matching
2938 element is found, return it. Otherwise return Qnil. */
2941 check_translation (ptrdiff_t pos
, ptrdiff_t pos_byte
, ptrdiff_t end
,
2944 int buf_size
= 16, buf_used
= 0;
2945 int *buf
= alloca (sizeof (int) * buf_size
);
2947 for (; CONSP (val
); val
= XCDR (val
))
2956 if (! VECTORP (elt
))
2959 if (len
<= end
- pos
)
2961 for (i
= 0; i
< len
; i
++)
2965 unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
2968 if (buf_used
== buf_size
)
2973 newbuf
= alloca (sizeof (int) * buf_size
);
2974 memcpy (newbuf
, buf
, sizeof (int) * buf_used
);
2977 buf
[buf_used
++] = STRING_CHAR_AND_LENGTH (p
, len1
);
2980 if (XINT (AREF (elt
, i
)) != buf
[i
])
2991 DEFUN ("translate-region-internal", Ftranslate_region_internal
,
2992 Stranslate_region_internal
, 3, 3, 0,
2993 doc
: /* Internal use only.
2994 From START to END, translate characters according to TABLE.
2995 TABLE is a string or a char-table; the Nth character in it is the
2996 mapping for the character with code N.
2997 It returns the number of characters changed. */)
2998 (Lisp_Object start
, Lisp_Object end
, register Lisp_Object table
)
3000 register unsigned char *tt
; /* Trans table. */
3001 register int nc
; /* New character. */
3002 int cnt
; /* Number of changes made. */
3003 ptrdiff_t size
; /* Size of translate table. */
3004 ptrdiff_t pos
, pos_byte
, end_pos
;
3005 int multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3006 int string_multibyte
IF_LINT (= 0);
3008 validate_region (&start
, &end
);
3009 if (CHAR_TABLE_P (table
))
3011 if (! EQ (XCHAR_TABLE (table
)->purpose
, Qtranslation_table
))
3012 error ("Not a translation table");
3018 CHECK_STRING (table
);
3020 if (! multibyte
&& (SCHARS (table
) < SBYTES (table
)))
3021 table
= string_make_unibyte (table
);
3022 string_multibyte
= SCHARS (table
) < SBYTES (table
);
3023 size
= SBYTES (table
);
3028 pos_byte
= CHAR_TO_BYTE (pos
);
3029 end_pos
= XINT (end
);
3030 modify_region (current_buffer
, pos
, end_pos
, 0);
3033 for (; pos
< end_pos
; )
3035 register unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
3036 unsigned char *str
, buf
[MAX_MULTIBYTE_LENGTH
];
3042 oc
= STRING_CHAR_AND_LENGTH (p
, len
);
3049 /* Reload as signal_after_change in last iteration may GC. */
3051 if (string_multibyte
)
3053 str
= tt
+ string_char_to_byte (table
, oc
);
3054 nc
= STRING_CHAR_AND_LENGTH (str
, str_len
);
3059 if (! ASCII_BYTE_P (nc
) && multibyte
)
3061 str_len
= BYTE8_STRING (nc
, buf
);
3074 val
= CHAR_TABLE_REF (table
, oc
);
3075 if (CHARACTERP (val
))
3077 nc
= XFASTINT (val
);
3078 str_len
= CHAR_STRING (nc
, buf
);
3081 else if (VECTORP (val
) || (CONSP (val
)))
3083 /* VAL is [TO_CHAR ...] or (([FROM-CHAR ...] . TO) ...)
3084 where TO is TO-CHAR or [TO-CHAR ...]. */
3089 if (nc
!= oc
&& nc
>= 0)
3091 /* Simple one char to one char translation. */
3096 /* This is less efficient, because it moves the gap,
3097 but it should handle multibyte characters correctly. */
3098 string
= make_multibyte_string ((char *) str
, 1, str_len
);
3099 replace_range (pos
, pos
+ 1, string
, 1, 0, 1);
3104 record_change (pos
, 1);
3105 while (str_len
-- > 0)
3107 signal_after_change (pos
, 1, 1);
3108 update_compositions (pos
, pos
+ 1, CHECK_BORDER
);
3118 val
= check_translation (pos
, pos_byte
, end_pos
, val
);
3125 /* VAL is ([FROM-CHAR ...] . TO). */
3126 len
= ASIZE (XCAR (val
));
3134 string
= Fconcat (1, &val
);
3138 string
= Fmake_string (make_number (1), val
);
3140 replace_range (pos
, pos
+ len
, string
, 1, 0, 1);
3141 pos_byte
+= SBYTES (string
);
3142 pos
+= SCHARS (string
);
3143 cnt
+= SCHARS (string
);
3144 end_pos
+= SCHARS (string
) - len
;
3152 return make_number (cnt
);
3155 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
3156 doc
: /* Delete the text between START and END.
3157 If called interactively, delete the region between point and mark.
3158 This command deletes buffer text without modifying the kill ring. */)
3159 (Lisp_Object start
, Lisp_Object end
)
3161 validate_region (&start
, &end
);
3162 del_range (XINT (start
), XINT (end
));
3166 DEFUN ("delete-and-extract-region", Fdelete_and_extract_region
,
3167 Sdelete_and_extract_region
, 2, 2, 0,
3168 doc
: /* Delete the text between START and END and return it. */)
3169 (Lisp_Object start
, Lisp_Object end
)
3171 validate_region (&start
, &end
);
3172 if (XINT (start
) == XINT (end
))
3173 return empty_unibyte_string
;
3174 return del_range_1 (XINT (start
), XINT (end
), 1, 1);
3177 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
3178 doc
: /* Remove restrictions (narrowing) from current buffer.
3179 This allows the buffer's full text to be seen and edited. */)
3182 if (BEG
!= BEGV
|| Z
!= ZV
)
3183 current_buffer
->clip_changed
= 1;
3185 BEGV_BYTE
= BEG_BYTE
;
3186 SET_BUF_ZV_BOTH (current_buffer
, Z
, Z_BYTE
);
3187 /* Changing the buffer bounds invalidates any recorded current column. */
3188 invalidate_current_column ();
3192 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
3193 doc
: /* Restrict editing in this buffer to the current region.
3194 The rest of the text becomes temporarily invisible and untouchable
3195 but is not deleted; if you save the buffer in a file, the invisible
3196 text is included in the file. \\[widen] makes all visible again.
3197 See also `save-restriction'.
3199 When calling from a program, pass two arguments; positions (integers
3200 or markers) bounding the text that should remain visible. */)
3201 (register Lisp_Object start
, Lisp_Object end
)
3203 CHECK_NUMBER_COERCE_MARKER (start
);
3204 CHECK_NUMBER_COERCE_MARKER (end
);
3206 if (XINT (start
) > XINT (end
))
3209 tem
= start
; start
= end
; end
= tem
;
3212 if (!(BEG
<= XINT (start
) && XINT (start
) <= XINT (end
) && XINT (end
) <= Z
))
3213 args_out_of_range (start
, end
);
3215 if (BEGV
!= XFASTINT (start
) || ZV
!= XFASTINT (end
))
3216 current_buffer
->clip_changed
= 1;
3218 SET_BUF_BEGV (current_buffer
, XFASTINT (start
));
3219 SET_BUF_ZV (current_buffer
, XFASTINT (end
));
3220 if (PT
< XFASTINT (start
))
3221 SET_PT (XFASTINT (start
));
3222 if (PT
> XFASTINT (end
))
3223 SET_PT (XFASTINT (end
));
3224 /* Changing the buffer bounds invalidates any recorded current column. */
3225 invalidate_current_column ();
3230 save_restriction_save (void)
3232 if (BEGV
== BEG
&& ZV
== Z
)
3233 /* The common case that the buffer isn't narrowed.
3234 We return just the buffer object, which save_restriction_restore
3235 recognizes as meaning `no restriction'. */
3236 return Fcurrent_buffer ();
3238 /* We have to save a restriction, so return a pair of markers, one
3239 for the beginning and one for the end. */
3241 Lisp_Object beg
, end
;
3243 beg
= buildmark (BEGV
, BEGV_BYTE
);
3244 end
= buildmark (ZV
, ZV_BYTE
);
3246 /* END must move forward if text is inserted at its exact location. */
3247 XMARKER (end
)->insertion_type
= 1;
3249 return Fcons (beg
, end
);
3254 save_restriction_restore (Lisp_Object data
)
3256 struct buffer
*cur
= NULL
;
3257 struct buffer
*buf
= (CONSP (data
)
3258 ? XMARKER (XCAR (data
))->buffer
3261 if (buf
&& buf
!= current_buffer
&& !NILP (BVAR (buf
, pt_marker
)))
3262 { /* If `buf' uses markers to keep track of PT, BEGV, and ZV (as
3263 is the case if it is or has an indirect buffer), then make
3264 sure it is current before we update BEGV, so
3265 set_buffer_internal takes care of managing those markers. */
3266 cur
= current_buffer
;
3267 set_buffer_internal (buf
);
3271 /* A pair of marks bounding a saved restriction. */
3273 struct Lisp_Marker
*beg
= XMARKER (XCAR (data
));
3274 struct Lisp_Marker
*end
= XMARKER (XCDR (data
));
3275 eassert (buf
== end
->buffer
);
3277 if (buf
/* Verify marker still points to a buffer. */
3278 && (beg
->charpos
!= BUF_BEGV (buf
) || end
->charpos
!= BUF_ZV (buf
)))
3279 /* The restriction has changed from the saved one, so restore
3280 the saved restriction. */
3282 ptrdiff_t pt
= BUF_PT (buf
);
3284 SET_BUF_BEGV_BOTH (buf
, beg
->charpos
, beg
->bytepos
);
3285 SET_BUF_ZV_BOTH (buf
, end
->charpos
, end
->bytepos
);
3287 if (pt
< beg
->charpos
|| pt
> end
->charpos
)
3288 /* The point is outside the new visible range, move it inside. */
3289 SET_BUF_PT_BOTH (buf
,
3290 clip_to_bounds (beg
->charpos
, pt
, end
->charpos
),
3291 clip_to_bounds (beg
->bytepos
, BUF_PT_BYTE (buf
),
3294 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3298 /* A buffer, which means that there was no old restriction. */
3300 if (buf
/* Verify marker still points to a buffer. */
3301 && (BUF_BEGV (buf
) != BUF_BEG (buf
) || BUF_ZV (buf
) != BUF_Z (buf
)))
3302 /* The buffer has been narrowed, get rid of the narrowing. */
3304 SET_BUF_BEGV_BOTH (buf
, BUF_BEG (buf
), BUF_BEG_BYTE (buf
));
3305 SET_BUF_ZV_BOTH (buf
, BUF_Z (buf
), BUF_Z_BYTE (buf
));
3307 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3311 /* Changing the buffer bounds invalidates any recorded current column. */
3312 invalidate_current_column ();
3315 set_buffer_internal (cur
);
3320 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
3321 doc
: /* Execute BODY, saving and restoring current buffer's restrictions.
3322 The buffer's restrictions make parts of the beginning and end invisible.
3323 \(They are set up with `narrow-to-region' and eliminated with `widen'.)
3324 This special form, `save-restriction', saves the current buffer's restrictions
3325 when it is entered, and restores them when it is exited.
3326 So any `narrow-to-region' within BODY lasts only until the end of the form.
3327 The old restrictions settings are restored
3328 even in case of abnormal exit (throw or error).
3330 The value returned is the value of the last form in BODY.
3332 Note: if you are using both `save-excursion' and `save-restriction',
3333 use `save-excursion' outermost:
3334 (save-excursion (save-restriction ...))
3336 usage: (save-restriction &rest BODY) */)
3339 register Lisp_Object val
;
3340 ptrdiff_t count
= SPECPDL_INDEX ();
3342 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
3343 val
= Fprogn (body
);
3344 return unbind_to (count
, val
);
3347 /* Buffer for the most recent text displayed by Fmessage_box. */
3348 static char *message_text
;
3350 /* Allocated length of that buffer. */
3351 static ptrdiff_t message_length
;
3353 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
3354 doc
: /* Display a message at the bottom of the screen.
3355 The message also goes into the `*Messages*' buffer.
3356 \(In keyboard macros, that's all it does.)
3359 The first argument is a format control string, and the rest are data
3360 to be formatted under control of the string. See `format' for details.
3362 Note: Use (message "%s" VALUE) to print the value of expressions and
3363 variables to avoid accidentally interpreting `%' as format specifiers.
3365 If the first argument is nil or the empty string, the function clears
3366 any existing message; this lets the minibuffer contents show. See
3367 also `current-message'.
3369 usage: (message FORMAT-STRING &rest ARGS) */)
3370 (ptrdiff_t nargs
, Lisp_Object
*args
)
3373 || (STRINGP (args
[0])
3374 && SBYTES (args
[0]) == 0))
3381 register Lisp_Object val
;
3382 val
= Fformat (nargs
, args
);
3383 message3 (val
, SBYTES (val
), STRING_MULTIBYTE (val
));
3388 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
3389 doc
: /* Display a message, in a dialog box if possible.
3390 If a dialog box is not available, use the echo area.
3391 The first argument is a format control string, and the rest are data
3392 to be formatted under control of the string. See `format' for details.
3394 If the first argument is nil or the empty string, clear any existing
3395 message; let the minibuffer contents show.
3397 usage: (message-box FORMAT-STRING &rest ARGS) */)
3398 (ptrdiff_t nargs
, Lisp_Object
*args
)
3407 register Lisp_Object val
;
3408 val
= Fformat (nargs
, args
);
3410 /* The MS-DOS frames support popup menus even though they are
3411 not FRAME_WINDOW_P. */
3412 if (FRAME_WINDOW_P (XFRAME (selected_frame
))
3413 || FRAME_MSDOS_P (XFRAME (selected_frame
)))
3415 Lisp_Object pane
, menu
;
3416 struct gcpro gcpro1
;
3417 pane
= Fcons (Fcons (build_string ("OK"), Qt
), Qnil
);
3419 menu
= Fcons (val
, pane
);
3420 Fx_popup_dialog (Qt
, menu
, Qt
);
3424 #endif /* HAVE_MENUS */
3425 /* Copy the data so that it won't move when we GC. */
3428 message_text
= (char *)xmalloc (80);
3429 message_length
= 80;
3431 if (SBYTES (val
) > message_length
)
3433 message_text
= (char *) xrealloc (message_text
, SBYTES (val
));
3434 message_length
= SBYTES (val
);
3436 memcpy (message_text
, SDATA (val
), SBYTES (val
));
3437 message2 (message_text
, SBYTES (val
),
3438 STRING_MULTIBYTE (val
));
3443 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
3444 doc
: /* Display a message in a dialog box or in the echo area.
3445 If this command was invoked with the mouse, use a dialog box if
3446 `use-dialog-box' is non-nil.
3447 Otherwise, use the echo area.
3448 The first argument is a format control string, and the rest are data
3449 to be formatted under control of the string. See `format' for details.
3451 If the first argument is nil or the empty string, clear any existing
3452 message; let the minibuffer contents show.
3454 usage: (message-or-box FORMAT-STRING &rest ARGS) */)
3455 (ptrdiff_t nargs
, Lisp_Object
*args
)
3458 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3460 return Fmessage_box (nargs
, args
);
3462 return Fmessage (nargs
, args
);
3465 DEFUN ("current-message", Fcurrent_message
, Scurrent_message
, 0, 0, 0,
3466 doc
: /* Return the string currently displayed in the echo area, or nil if none. */)
3469 return current_message ();
3473 DEFUN ("propertize", Fpropertize
, Spropertize
, 1, MANY
, 0,
3474 doc
: /* Return a copy of STRING with text properties added.
3475 First argument is the string to copy.
3476 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
3477 properties to add to the result.
3478 usage: (propertize STRING &rest PROPERTIES) */)
3479 (ptrdiff_t nargs
, Lisp_Object
*args
)
3481 Lisp_Object properties
, string
;
3482 struct gcpro gcpro1
, gcpro2
;
3485 /* Number of args must be odd. */
3486 if ((nargs
& 1) == 0)
3487 error ("Wrong number of arguments");
3489 properties
= string
= Qnil
;
3490 GCPRO2 (properties
, string
);
3492 /* First argument must be a string. */
3493 CHECK_STRING (args
[0]);
3494 string
= Fcopy_sequence (args
[0]);
3496 for (i
= 1; i
< nargs
; i
+= 2)
3497 properties
= Fcons (args
[i
], Fcons (args
[i
+ 1], properties
));
3499 Fadd_text_properties (make_number (0),
3500 make_number (SCHARS (string
)),
3501 properties
, string
);
3502 RETURN_UNGCPRO (string
);
3505 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
3506 doc
: /* Format a string out of a format-string and arguments.
3507 The first argument is a format control string.
3508 The other arguments are substituted into it to make the result, a string.
3510 The format control string may contain %-sequences meaning to substitute
3511 the next available argument:
3513 %s means print a string argument. Actually, prints any object, with `princ'.
3514 %d means print as number in decimal (%o octal, %x hex).
3515 %X is like %x, but uses upper case.
3516 %e means print a number in exponential notation.
3517 %f means print a number in decimal-point notation.
3518 %g means print a number in exponential notation
3519 or decimal-point notation, whichever uses fewer characters.
3520 %c means print a number as a single character.
3521 %S means print any object as an s-expression (using `prin1').
3523 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
3524 Use %% to put a single % into the output.
3526 A %-sequence may contain optional flag, width, and precision
3527 specifiers, as follows:
3529 %<flags><width><precision>character
3531 where flags is [+ #-0]+, width is [0-9]+, and precision is .[0-9]+
3533 The + flag character inserts a + before any positive number, while a
3534 space inserts a space before any positive number; these flags only
3535 affect %d, %e, %f, and %g sequences, and the + flag takes precedence.
3536 The # flag means to use an alternate display form for %o, %x, %X, %e,
3537 %f, and %g sequences. The - and 0 flags affect the width specifier,
3540 The width specifier supplies a lower limit for the length of the
3541 printed representation. The padding, if any, normally goes on the
3542 left, but it goes on the right if the - flag is present. The padding
3543 character is normally a space, but it is 0 if the 0 flag is present.
3544 The 0 flag is ignored if the - flag is present, or the format sequence
3545 is something other than %d, %e, %f, and %g.
3547 For %e, %f, and %g sequences, the number after the "." in the
3548 precision specifier says how many decimal places to show; if zero, the
3549 decimal point itself is omitted. For %s and %S, the precision
3550 specifier truncates the string to the given width.
3552 usage: (format STRING &rest OBJECTS) */)
3553 (ptrdiff_t nargs
, Lisp_Object
*args
)
3555 ptrdiff_t n
; /* The number of the next arg to substitute */
3556 char initial_buffer
[4000];
3557 char *buf
= initial_buffer
;
3558 ptrdiff_t bufsize
= sizeof initial_buffer
;
3559 ptrdiff_t max_bufsize
= STRING_BYTES_BOUND
+ 1;
3561 Lisp_Object buf_save_value
IF_LINT (= {0});
3562 register char *format
, *end
, *format_start
;
3563 ptrdiff_t formatlen
, nchars
;
3564 /* Nonzero if the format is multibyte. */
3565 int multibyte_format
= 0;
3566 /* Nonzero if the output should be a multibyte string,
3567 which is true if any of the inputs is one. */
3569 /* When we make a multibyte string, we must pay attention to the
3570 byte combining problem, i.e., a byte may be combined with a
3571 multibyte character of the previous string. This flag tells if we
3572 must consider such a situation or not. */
3573 int maybe_combine_byte
;
3575 int arg_intervals
= 0;
3578 /* discarded[I] is 1 if byte I of the format
3579 string was not copied into the output.
3580 It is 2 if byte I was not the first byte of its character. */
3583 /* Each element records, for one argument,
3584 the start and end bytepos in the output string,
3585 whether the argument has been converted to string (e.g., due to "%S"),
3586 and whether the argument is a string with intervals.
3587 info[0] is unused. Unused elements have -1 for start. */
3590 ptrdiff_t start
, end
;
3591 int converted_to_string
;
3595 /* It should not be necessary to GCPRO ARGS, because
3596 the caller in the interpreter should take care of that. */
3598 CHECK_STRING (args
[0]);
3599 format_start
= SSDATA (args
[0]);
3600 formatlen
= SBYTES (args
[0]);
3602 /* Allocate the info and discarded tables. */
3605 if ((SIZE_MAX
- formatlen
) / sizeof (struct info
) <= nargs
)
3606 memory_full (SIZE_MAX
);
3607 SAFE_ALLOCA (info
, struct info
*, (nargs
+ 1) * sizeof *info
+ formatlen
);
3608 discarded
= (char *) &info
[nargs
+ 1];
3609 for (i
= 0; i
< nargs
+ 1; i
++)
3612 info
[i
].intervals
= info
[i
].converted_to_string
= 0;
3614 memset (discarded
, 0, formatlen
);
3617 /* Try to determine whether the result should be multibyte.
3618 This is not always right; sometimes the result needs to be multibyte
3619 because of an object that we will pass through prin1,
3620 and in that case, we won't know it here. */
3621 multibyte_format
= STRING_MULTIBYTE (args
[0]);
3622 multibyte
= multibyte_format
;
3623 for (n
= 1; !multibyte
&& n
< nargs
; n
++)
3624 if (STRINGP (args
[n
]) && STRING_MULTIBYTE (args
[n
]))
3627 /* If we start out planning a unibyte result,
3628 then discover it has to be multibyte, we jump back to retry. */
3635 /* Scan the format and store result in BUF. */
3636 format
= format_start
;
3637 end
= format
+ formatlen
;
3638 maybe_combine_byte
= 0;
3640 while (format
!= end
)
3642 /* The values of N and FORMAT when the loop body is entered. */
3644 char *format0
= format
;
3646 /* Bytes needed to represent the output of this conversion. */
3647 ptrdiff_t convbytes
;
3651 /* General format specifications look like
3653 '%' [flags] [field-width] [precision] format
3658 field-width ::= [0-9]+
3659 precision ::= '.' [0-9]*
3661 If a field-width is specified, it specifies to which width
3662 the output should be padded with blanks, if the output
3663 string is shorter than field-width.
3665 If precision is specified, it specifies the number of
3666 digits to print after the '.' for floats, or the max.
3667 number of chars to print from a string. */
3674 ptrdiff_t field_width
;
3675 int precision_given
;
3676 uintmax_t precision
= UINTMAX_MAX
;
3684 case '-': minus_flag
= 1; continue;
3685 case '+': plus_flag
= 1; continue;
3686 case ' ': space_flag
= 1; continue;
3687 case '#': sharp_flag
= 1; continue;
3688 case '0': zero_flag
= 1; continue;
3693 /* Ignore flags when sprintf ignores them. */
3694 space_flag
&= ~ plus_flag
;
3695 zero_flag
&= ~ minus_flag
;
3698 uintmax_t w
= strtoumax (format
, &num_end
, 10);
3699 if (max_bufsize
<= w
)
3703 precision_given
= *num_end
== '.';
3704 if (precision_given
)
3705 precision
= strtoumax (num_end
+ 1, &num_end
, 10);
3709 error ("Format string ends in middle of format specifier");
3711 memset (&discarded
[format0
- format_start
], 1, format
- format0
);
3712 conversion
= *format
;
3713 if (conversion
== '%')
3715 discarded
[format
- format_start
] = 1;
3720 error ("Not enough arguments for format string");
3722 /* For 'S', prin1 the argument, and then treat like 's'.
3723 For 's', princ any argument that is not a string or
3724 symbol. But don't do this conversion twice, which might
3725 happen after retrying. */
3726 if ((conversion
== 'S'
3727 || (conversion
== 's'
3728 && ! STRINGP (args
[n
]) && ! SYMBOLP (args
[n
]))))
3730 if (! info
[n
].converted_to_string
)
3732 Lisp_Object noescape
= conversion
== 'S' ? Qnil
: Qt
;
3733 args
[n
] = Fprin1_to_string (args
[n
], noescape
);
3734 info
[n
].converted_to_string
= 1;
3735 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3743 else if (conversion
== 'c')
3745 if (FLOATP (args
[n
]))
3747 double d
= XFLOAT_DATA (args
[n
]);
3748 args
[n
] = make_number (FIXNUM_OVERFLOW_P (d
) ? -1 : d
);
3751 if (INTEGERP (args
[n
]) && ! ASCII_CHAR_P (XINT (args
[n
])))
3758 args
[n
] = Fchar_to_string (args
[n
]);
3759 info
[n
].converted_to_string
= 1;
3762 if (info
[n
].converted_to_string
)
3767 if (SYMBOLP (args
[n
]))
3769 args
[n
] = SYMBOL_NAME (args
[n
]);
3770 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3777 if (conversion
== 's')
3779 /* handle case (precision[n] >= 0) */
3781 ptrdiff_t width
, padding
, nbytes
;
3782 ptrdiff_t nchars_string
;
3784 ptrdiff_t prec
= -1;
3785 if (precision_given
&& precision
<= TYPE_MAXIMUM (ptrdiff_t))
3788 /* lisp_string_width ignores a precision of 0, but GNU
3789 libc functions print 0 characters when the precision
3790 is 0. Imitate libc behavior here. Changing
3791 lisp_string_width is the right thing, and will be
3792 done, but meanwhile we work with it. */
3795 width
= nchars_string
= nbytes
= 0;
3799 width
= lisp_string_width (args
[n
], prec
, &nch
, &nby
);
3802 nchars_string
= SCHARS (args
[n
]);
3803 nbytes
= SBYTES (args
[n
]);
3807 nchars_string
= nch
;
3813 if (convbytes
&& multibyte
&& ! STRING_MULTIBYTE (args
[n
]))
3814 convbytes
= count_size_as_multibyte (SDATA (args
[n
]), nbytes
);
3816 padding
= width
< field_width
? field_width
- width
: 0;
3818 if (max_bufsize
- padding
<= convbytes
)
3820 convbytes
+= padding
;
3821 if (convbytes
<= buf
+ bufsize
- p
)
3825 memset (p
, ' ', padding
);
3832 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3833 && STRING_MULTIBYTE (args
[n
])
3834 && !CHAR_HEAD_P (SREF (args
[n
], 0)))
3835 maybe_combine_byte
= 1;
3837 p
+= copy_text (SDATA (args
[n
]), (unsigned char *) p
,
3839 STRING_MULTIBYTE (args
[n
]), multibyte
);
3841 info
[n
].start
= nchars
;
3842 nchars
+= nchars_string
;
3843 info
[n
].end
= nchars
;
3847 memset (p
, ' ', padding
);
3852 /* If this argument has text properties, record where
3853 in the result string it appears. */
3854 if (STRING_INTERVALS (args
[n
]))
3855 info
[n
].intervals
= arg_intervals
= 1;
3860 else if (! (conversion
== 'c' || conversion
== 'd'
3861 || conversion
== 'e' || conversion
== 'f'
3862 || conversion
== 'g' || conversion
== 'i'
3863 || conversion
== 'o' || conversion
== 'x'
3864 || conversion
== 'X'))
3865 error ("Invalid format operation %%%c",
3866 STRING_CHAR ((unsigned char *) format
- 1));
3867 else if (! (INTEGERP (args
[n
]) || FLOATP (args
[n
])))
3868 error ("Format specifier doesn't match argument type");
3873 /* Maximum precision for a %f conversion such that the
3874 trailing output digit might be nonzero. Any precisions
3875 larger than this will not yield useful information. */
3876 USEFUL_PRECISION_MAX
=
3878 * (FLT_RADIX
== 2 || FLT_RADIX
== 10 ? 1
3879 : FLT_RADIX
== 16 ? 4
3882 /* Maximum number of bytes generated by any format, if
3883 precision is no more than USEFUL_PRECISION_MAX.
3884 On all practical hosts, %f is the worst case. */
3886 sizeof "-." + (DBL_MAX_10_EXP
+ 1) + USEFUL_PRECISION_MAX
,
3888 /* Length of pM (that is, of pMd without the
3890 pMlen
= sizeof pMd
- 2
3892 verify (0 < USEFUL_PRECISION_MAX
);
3895 ptrdiff_t padding
, sprintf_bytes
;
3896 uintmax_t excess_precision
, numwidth
;
3897 uintmax_t leading_zeros
= 0, trailing_zeros
= 0;
3899 char sprintf_buf
[SPRINTF_BUFSIZE
];
3901 /* Copy of conversion specification, modified somewhat.
3902 At most three flags F can be specified at once. */
3903 char convspec
[sizeof "%FFF.*d" + pMlen
];
3905 /* Avoid undefined behavior in underlying sprintf. */
3906 if (conversion
== 'd' || conversion
== 'i')
3909 /* Create the copy of the conversion specification, with
3910 any width and precision removed, with ".*" inserted,
3911 and with pM inserted for integer formats. */
3915 *f
= '-'; f
+= minus_flag
;
3916 *f
= '+'; f
+= plus_flag
;
3917 *f
= ' '; f
+= space_flag
;
3918 *f
= '#'; f
+= sharp_flag
;
3919 *f
= '0'; f
+= zero_flag
;
3922 if (conversion
== 'd' || conversion
== 'i'
3923 || conversion
== 'o' || conversion
== 'x'
3924 || conversion
== 'X')
3926 memcpy (f
, pMd
, pMlen
);
3928 zero_flag
&= ~ precision_given
;
3935 if (precision_given
)
3936 prec
= min (precision
, USEFUL_PRECISION_MAX
);
3938 /* Use sprintf to format this number into sprintf_buf. Omit
3939 padding and excess precision, though, because sprintf limits
3940 output length to INT_MAX.
3942 There are four types of conversion: double, unsigned
3943 char (passed as int), wide signed int, and wide
3944 unsigned int. Treat them separately because the
3945 sprintf ABI is sensitive to which type is passed. Be
3946 careful about integer overflow, NaNs, infinities, and
3947 conversions; for example, the min and max macros are
3948 not suitable here. */
3949 if (conversion
== 'e' || conversion
== 'f' || conversion
== 'g')
3951 double x
= (INTEGERP (args
[n
])
3953 : XFLOAT_DATA (args
[n
]));
3954 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
3956 else if (conversion
== 'c')
3958 /* Don't use sprintf here, as it might mishandle prec. */
3959 sprintf_buf
[0] = XINT (args
[n
]);
3960 sprintf_bytes
= prec
!= 0;
3962 else if (conversion
== 'd')
3964 /* For float, maybe we should use "%1.0f"
3965 instead so it also works for values outside
3966 the integer range. */
3968 if (INTEGERP (args
[n
]))
3972 double d
= XFLOAT_DATA (args
[n
]);
3975 x
= TYPE_MINIMUM (printmax_t
);
3981 x
= TYPE_MAXIMUM (printmax_t
);
3986 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
3990 /* Don't sign-extend for octal or hex printing. */
3992 if (INTEGERP (args
[n
]))
3993 x
= XUINT (args
[n
]);
3996 double d
= XFLOAT_DATA (args
[n
]);
4001 x
= TYPE_MAXIMUM (uprintmax_t
);
4006 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4009 /* Now the length of the formatted item is known, except it omits
4010 padding and excess precision. Deal with excess precision
4011 first. This happens only when the format specifies
4012 ridiculously large precision. */
4013 excess_precision
= precision
- prec
;
4014 if (excess_precision
)
4016 if (conversion
== 'e' || conversion
== 'f'
4017 || conversion
== 'g')
4019 if ((conversion
== 'g' && ! sharp_flag
)
4020 || ! ('0' <= sprintf_buf
[sprintf_bytes
- 1]
4021 && sprintf_buf
[sprintf_bytes
- 1] <= '9'))
4022 excess_precision
= 0;
4025 if (conversion
== 'g')
4027 char *dot
= strchr (sprintf_buf
, '.');
4029 excess_precision
= 0;
4032 trailing_zeros
= excess_precision
;
4035 leading_zeros
= excess_precision
;
4038 /* Compute the total bytes needed for this item, including
4039 excess precision and padding. */
4040 numwidth
= sprintf_bytes
+ excess_precision
;
4041 padding
= numwidth
< field_width
? field_width
- numwidth
: 0;
4042 if (max_bufsize
- sprintf_bytes
<= excess_precision
4043 || max_bufsize
- padding
<= numwidth
)
4045 convbytes
= numwidth
+ padding
;
4047 if (convbytes
<= buf
+ bufsize
- p
)
4049 /* Copy the formatted item from sprintf_buf into buf,
4050 inserting padding and excess-precision zeros. */
4052 char *src
= sprintf_buf
;
4054 int exponent_bytes
= 0;
4055 int signedp
= src0
== '-' || src0
== '+' || src0
== ' ';
4056 int significand_bytes
;
4058 && ((src
[signedp
] >= '0' && src
[signedp
] <= '9')
4059 || (src
[signedp
] >= 'a' && src
[signedp
] <= 'f')
4060 || (src
[signedp
] >= 'A' && src
[signedp
] <= 'F')))
4062 leading_zeros
+= padding
;
4066 if (excess_precision
4067 && (conversion
== 'e' || conversion
== 'g'))
4069 char *e
= strchr (src
, 'e');
4071 exponent_bytes
= src
+ sprintf_bytes
- e
;
4076 memset (p
, ' ', padding
);
4084 memset (p
, '0', leading_zeros
);
4086 significand_bytes
= sprintf_bytes
- signedp
- exponent_bytes
;
4087 memcpy (p
, src
, significand_bytes
);
4088 p
+= significand_bytes
;
4089 src
+= significand_bytes
;
4090 memset (p
, '0', trailing_zeros
);
4091 p
+= trailing_zeros
;
4092 memcpy (p
, src
, exponent_bytes
);
4093 p
+= exponent_bytes
;
4095 info
[n
].start
= nchars
;
4096 nchars
+= leading_zeros
+ sprintf_bytes
+ trailing_zeros
;
4097 info
[n
].end
= nchars
;
4101 memset (p
, ' ', padding
);
4113 /* Copy a single character from format to buf. */
4116 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
4118 if (multibyte_format
)
4120 /* Copy a whole multibyte character. */
4122 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
4123 && !CHAR_HEAD_P (*format
))
4124 maybe_combine_byte
= 1;
4128 while (! CHAR_HEAD_P (*format
));
4130 convbytes
= format
- src
;
4131 memset (&discarded
[src
+ 1 - format_start
], 2, convbytes
- 1);
4135 unsigned char uc
= *format
++;
4136 if (! multibyte
|| ASCII_BYTE_P (uc
))
4140 int c
= BYTE8_TO_CHAR (uc
);
4141 convbytes
= CHAR_STRING (c
, str
);
4146 if (convbytes
<= buf
+ bufsize
- p
)
4148 memcpy (p
, src
, convbytes
);
4155 /* There wasn't enough room to store this conversion or single
4156 character. CONVBYTES says how much room is needed. Allocate
4157 enough room (and then some) and do it again. */
4159 ptrdiff_t used
= p
- buf
;
4161 if (max_bufsize
- used
< convbytes
)
4163 bufsize
= used
+ convbytes
;
4164 bufsize
= bufsize
< max_bufsize
/ 2 ? bufsize
* 2 : max_bufsize
;
4166 if (buf
== initial_buffer
)
4168 buf
= xmalloc (bufsize
);
4170 buf_save_value
= make_save_value (buf
, 0);
4171 record_unwind_protect (safe_alloca_unwind
, buf_save_value
);
4172 memcpy (buf
, initial_buffer
, used
);
4175 XSAVE_VALUE (buf_save_value
)->pointer
= buf
= xrealloc (buf
, bufsize
);
4184 if (bufsize
< p
- buf
)
4187 if (maybe_combine_byte
)
4188 nchars
= multibyte_chars_in_text ((unsigned char *) buf
, p
- buf
);
4189 val
= make_specified_string (buf
, nchars
, p
- buf
, multibyte
);
4191 /* If we allocated BUF with malloc, free it too. */
4194 /* If the format string has text properties, or any of the string
4195 arguments has text properties, set up text properties of the
4198 if (STRING_INTERVALS (args
[0]) || arg_intervals
)
4200 Lisp_Object len
, new_len
, props
;
4201 struct gcpro gcpro1
;
4203 /* Add text properties from the format string. */
4204 len
= make_number (SCHARS (args
[0]));
4205 props
= text_property_list (args
[0], make_number (0), len
, Qnil
);
4210 ptrdiff_t bytepos
= 0, position
= 0, translated
= 0;
4214 /* Adjust the bounds of each text property
4215 to the proper start and end in the output string. */
4217 /* Put the positions in PROPS in increasing order, so that
4218 we can do (effectively) one scan through the position
4219 space of the format string. */
4220 props
= Fnreverse (props
);
4222 /* BYTEPOS is the byte position in the format string,
4223 POSITION is the untranslated char position in it,
4224 TRANSLATED is the translated char position in BUF,
4225 and ARGN is the number of the next arg we will come to. */
4226 for (list
= props
; CONSP (list
); list
= XCDR (list
))
4233 /* First adjust the property start position. */
4234 pos
= XINT (XCAR (item
));
4236 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
4237 up to this position. */
4238 for (; position
< pos
; bytepos
++)
4240 if (! discarded
[bytepos
])
4241 position
++, translated
++;
4242 else if (discarded
[bytepos
] == 1)
4245 if (translated
== info
[argn
].start
)
4247 translated
+= info
[argn
].end
- info
[argn
].start
;
4253 XSETCAR (item
, make_number (translated
));
4255 /* Likewise adjust the property end position. */
4256 pos
= XINT (XCAR (XCDR (item
)));
4258 for (; position
< pos
; bytepos
++)
4260 if (! discarded
[bytepos
])
4261 position
++, translated
++;
4262 else if (discarded
[bytepos
] == 1)
4265 if (translated
== info
[argn
].start
)
4267 translated
+= info
[argn
].end
- info
[argn
].start
;
4273 XSETCAR (XCDR (item
), make_number (translated
));
4276 add_text_properties_from_list (val
, props
, make_number (0));
4279 /* Add text properties from arguments. */
4281 for (n
= 1; n
< nargs
; ++n
)
4282 if (info
[n
].intervals
)
4284 len
= make_number (SCHARS (args
[n
]));
4285 new_len
= make_number (info
[n
].end
- info
[n
].start
);
4286 props
= text_property_list (args
[n
], make_number (0), len
, Qnil
);
4287 props
= extend_property_ranges (props
, new_len
);
4288 /* If successive arguments have properties, be sure that
4289 the value of `composition' property be the copy. */
4290 if (n
> 1 && info
[n
- 1].end
)
4291 make_composition_value_copy (props
);
4292 add_text_properties_from_list (val
, props
,
4293 make_number (info
[n
].start
));
4303 format2 (const char *string1
, Lisp_Object arg0
, Lisp_Object arg1
)
4305 Lisp_Object args
[3];
4306 args
[0] = build_string (string1
);
4309 return Fformat (3, args
);
4312 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
4313 doc
: /* Return t if two characters match, optionally ignoring case.
4314 Both arguments must be characters (i.e. integers).
4315 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
4316 (register Lisp_Object c1
, Lisp_Object c2
)
4319 /* Check they're chars, not just integers, otherwise we could get array
4320 bounds violations in downcase. */
4321 CHECK_CHARACTER (c1
);
4322 CHECK_CHARACTER (c2
);
4324 if (XINT (c1
) == XINT (c2
))
4326 if (NILP (BVAR (current_buffer
, case_fold_search
)))
4330 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
))
4331 && ! ASCII_CHAR_P (i1
))
4333 MAKE_CHAR_MULTIBYTE (i1
);
4336 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
))
4337 && ! ASCII_CHAR_P (i2
))
4339 MAKE_CHAR_MULTIBYTE (i2
);
4341 return (downcase (i1
) == downcase (i2
) ? Qt
: Qnil
);
4344 /* Transpose the markers in two regions of the current buffer, and
4345 adjust the ones between them if necessary (i.e.: if the regions
4348 START1, END1 are the character positions of the first region.
4349 START1_BYTE, END1_BYTE are the byte positions.
4350 START2, END2 are the character positions of the second region.
4351 START2_BYTE, END2_BYTE are the byte positions.
4353 Traverses the entire marker list of the buffer to do so, adding an
4354 appropriate amount to some, subtracting from some, and leaving the
4355 rest untouched. Most of this is copied from adjust_markers in insdel.c.
4357 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
4360 transpose_markers (ptrdiff_t start1
, ptrdiff_t end1
,
4361 ptrdiff_t start2
, ptrdiff_t end2
,
4362 ptrdiff_t start1_byte
, ptrdiff_t end1_byte
,
4363 ptrdiff_t start2_byte
, ptrdiff_t end2_byte
)
4365 register ptrdiff_t amt1
, amt1_byte
, amt2
, amt2_byte
, diff
, diff_byte
, mpos
;
4366 register struct Lisp_Marker
*marker
;
4368 /* Update point as if it were a marker. */
4372 TEMP_SET_PT_BOTH (PT
+ (end2
- end1
),
4373 PT_BYTE
+ (end2_byte
- end1_byte
));
4374 else if (PT
< start2
)
4375 TEMP_SET_PT_BOTH (PT
+ (end2
- start2
) - (end1
- start1
),
4376 (PT_BYTE
+ (end2_byte
- start2_byte
)
4377 - (end1_byte
- start1_byte
)));
4379 TEMP_SET_PT_BOTH (PT
- (start2
- start1
),
4380 PT_BYTE
- (start2_byte
- start1_byte
));
4382 /* We used to adjust the endpoints here to account for the gap, but that
4383 isn't good enough. Even if we assume the caller has tried to move the
4384 gap out of our way, it might still be at start1 exactly, for example;
4385 and that places it `inside' the interval, for our purposes. The amount
4386 of adjustment is nontrivial if there's a `denormalized' marker whose
4387 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
4388 the dirty work to Fmarker_position, below. */
4390 /* The difference between the region's lengths */
4391 diff
= (end2
- start2
) - (end1
- start1
);
4392 diff_byte
= (end2_byte
- start2_byte
) - (end1_byte
- start1_byte
);
4394 /* For shifting each marker in a region by the length of the other
4395 region plus the distance between the regions. */
4396 amt1
= (end2
- start2
) + (start2
- end1
);
4397 amt2
= (end1
- start1
) + (start2
- end1
);
4398 amt1_byte
= (end2_byte
- start2_byte
) + (start2_byte
- end1_byte
);
4399 amt2_byte
= (end1_byte
- start1_byte
) + (start2_byte
- end1_byte
);
4401 for (marker
= BUF_MARKERS (current_buffer
); marker
; marker
= marker
->next
)
4403 mpos
= marker
->bytepos
;
4404 if (mpos
>= start1_byte
&& mpos
< end2_byte
)
4406 if (mpos
< end1_byte
)
4408 else if (mpos
< start2_byte
)
4412 marker
->bytepos
= mpos
;
4414 mpos
= marker
->charpos
;
4415 if (mpos
>= start1
&& mpos
< end2
)
4419 else if (mpos
< start2
)
4424 marker
->charpos
= mpos
;
4428 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
4429 doc
: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
4430 The regions should not be overlapping, because the size of the buffer is
4431 never changed in a transposition.
4433 Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
4434 any markers that happen to be located in the regions.
4436 Transposing beyond buffer boundaries is an error. */)
4437 (Lisp_Object startr1
, Lisp_Object endr1
, Lisp_Object startr2
, Lisp_Object endr2
, Lisp_Object leave_markers
)
4439 register ptrdiff_t start1
, end1
, start2
, end2
;
4440 ptrdiff_t start1_byte
, start2_byte
, len1_byte
, len2_byte
;
4441 ptrdiff_t gap
, len1
, len_mid
, len2
;
4442 unsigned char *start1_addr
, *start2_addr
, *temp
;
4444 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
, tmp_interval3
;
4447 XSETBUFFER (buf
, current_buffer
);
4448 cur_intv
= BUF_INTERVALS (current_buffer
);
4450 validate_region (&startr1
, &endr1
);
4451 validate_region (&startr2
, &endr2
);
4453 start1
= XFASTINT (startr1
);
4454 end1
= XFASTINT (endr1
);
4455 start2
= XFASTINT (startr2
);
4456 end2
= XFASTINT (endr2
);
4459 /* Swap the regions if they're reversed. */
4462 register ptrdiff_t glumph
= start1
;
4470 len1
= end1
- start1
;
4471 len2
= end2
- start2
;
4474 error ("Transposed regions overlap");
4475 /* Nothing to change for adjacent regions with one being empty */
4476 else if ((start1
== end1
|| start2
== end2
) && end1
== start2
)
4479 /* The possibilities are:
4480 1. Adjacent (contiguous) regions, or separate but equal regions
4481 (no, really equal, in this case!), or
4482 2. Separate regions of unequal size.
4484 The worst case is usually No. 2. It means that (aside from
4485 potential need for getting the gap out of the way), there also
4486 needs to be a shifting of the text between the two regions. So
4487 if they are spread far apart, we are that much slower... sigh. */
4489 /* It must be pointed out that the really studly thing to do would
4490 be not to move the gap at all, but to leave it in place and work
4491 around it if necessary. This would be extremely efficient,
4492 especially considering that people are likely to do
4493 transpositions near where they are working interactively, which
4494 is exactly where the gap would be found. However, such code
4495 would be much harder to write and to read. So, if you are
4496 reading this comment and are feeling squirrely, by all means have
4497 a go! I just didn't feel like doing it, so I will simply move
4498 the gap the minimum distance to get it out of the way, and then
4499 deal with an unbroken array. */
4501 /* Make sure the gap won't interfere, by moving it out of the text
4502 we will operate on. */
4503 if (start1
< gap
&& gap
< end2
)
4505 if (gap
- start1
< end2
- gap
)
4511 start1_byte
= CHAR_TO_BYTE (start1
);
4512 start2_byte
= CHAR_TO_BYTE (start2
);
4513 len1_byte
= CHAR_TO_BYTE (end1
) - start1_byte
;
4514 len2_byte
= CHAR_TO_BYTE (end2
) - start2_byte
;
4516 #ifdef BYTE_COMBINING_DEBUG
4519 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4520 len2_byte
, start1
, start1_byte
)
4521 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4522 len1_byte
, end2
, start2_byte
+ len2_byte
)
4523 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4524 len1_byte
, end2
, start2_byte
+ len2_byte
))
4529 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4530 len2_byte
, start1
, start1_byte
)
4531 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4532 len1_byte
, start2
, start2_byte
)
4533 || count_combining_after (BYTE_POS_ADDR (start2_byte
),
4534 len2_byte
, end1
, start1_byte
+ len1_byte
)
4535 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4536 len1_byte
, end2
, start2_byte
+ len2_byte
))
4541 /* Hmmm... how about checking to see if the gap is large
4542 enough to use as the temporary storage? That would avoid an
4543 allocation... interesting. Later, don't fool with it now. */
4545 /* Working without memmove, for portability (sigh), so must be
4546 careful of overlapping subsections of the array... */
4548 if (end1
== start2
) /* adjacent regions */
4550 modify_region (current_buffer
, start1
, end2
, 0);
4551 record_change (start1
, len1
+ len2
);
4553 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4554 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4555 /* Don't use Fset_text_properties: that can cause GC, which can
4556 clobber objects stored in the tmp_intervals. */
4557 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4558 if (!NULL_INTERVAL_P (tmp_interval3
))
4559 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4561 /* First region smaller than second. */
4562 if (len1_byte
< len2_byte
)
4566 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4568 /* Don't precompute these addresses. We have to compute them
4569 at the last minute, because the relocating allocator might
4570 have moved the buffer around during the xmalloc. */
4571 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4572 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4574 memcpy (temp
, start2_addr
, len2_byte
);
4575 memcpy (start1_addr
+ len2_byte
, start1_addr
, len1_byte
);
4576 memcpy (start1_addr
, temp
, len2_byte
);
4580 /* First region not smaller than second. */
4584 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4585 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4586 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4587 memcpy (temp
, start1_addr
, len1_byte
);
4588 memcpy (start1_addr
, start2_addr
, len2_byte
);
4589 memcpy (start1_addr
+ len2_byte
, temp
, len1_byte
);
4592 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
4593 len1
, current_buffer
, 0);
4594 graft_intervals_into_buffer (tmp_interval2
, start1
,
4595 len2
, current_buffer
, 0);
4596 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4597 update_compositions (start1
+ len2
, end2
, CHECK_TAIL
);
4599 /* Non-adjacent regions, because end1 != start2, bleagh... */
4602 len_mid
= start2_byte
- (start1_byte
+ len1_byte
);
4604 if (len1_byte
== len2_byte
)
4605 /* Regions are same size, though, how nice. */
4609 modify_region (current_buffer
, start1
, end1
, 0);
4610 modify_region (current_buffer
, start2
, end2
, 0);
4611 record_change (start1
, len1
);
4612 record_change (start2
, len2
);
4613 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4614 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4616 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr1
, 0);
4617 if (!NULL_INTERVAL_P (tmp_interval3
))
4618 set_text_properties_1 (startr1
, endr1
, Qnil
, buf
, tmp_interval3
);
4620 tmp_interval3
= validate_interval_range (buf
, &startr2
, &endr2
, 0);
4621 if (!NULL_INTERVAL_P (tmp_interval3
))
4622 set_text_properties_1 (startr2
, endr2
, Qnil
, buf
, tmp_interval3
);
4624 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4625 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4626 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4627 memcpy (temp
, start1_addr
, len1_byte
);
4628 memcpy (start1_addr
, start2_addr
, len2_byte
);
4629 memcpy (start2_addr
, temp
, len1_byte
);
4632 graft_intervals_into_buffer (tmp_interval1
, start2
,
4633 len1
, current_buffer
, 0);
4634 graft_intervals_into_buffer (tmp_interval2
, start1
,
4635 len2
, current_buffer
, 0);
4638 else if (len1_byte
< len2_byte
) /* Second region larger than first */
4639 /* Non-adjacent & unequal size, area between must also be shifted. */
4643 modify_region (current_buffer
, start1
, end2
, 0);
4644 record_change (start1
, (end2
- start1
));
4645 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4646 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4647 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4649 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4650 if (!NULL_INTERVAL_P (tmp_interval3
))
4651 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4653 /* holds region 2 */
4654 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4655 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4656 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4657 memcpy (temp
, start2_addr
, len2_byte
);
4658 memcpy (start1_addr
+ len_mid
+ len2_byte
, start1_addr
, len1_byte
);
4659 memmove (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
4660 memcpy (start1_addr
, temp
, len2_byte
);
4663 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4664 len1
, current_buffer
, 0);
4665 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4666 len_mid
, current_buffer
, 0);
4667 graft_intervals_into_buffer (tmp_interval2
, start1
,
4668 len2
, current_buffer
, 0);
4671 /* Second region smaller than first. */
4675 record_change (start1
, (end2
- start1
));
4676 modify_region (current_buffer
, start1
, end2
, 0);
4678 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4679 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4680 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4682 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4683 if (!NULL_INTERVAL_P (tmp_interval3
))
4684 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4686 /* holds region 1 */
4687 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4688 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4689 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4690 memcpy (temp
, start1_addr
, len1_byte
);
4691 memcpy (start1_addr
, start2_addr
, len2_byte
);
4692 memcpy (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
4693 memcpy (start1_addr
+ len2_byte
+ len_mid
, temp
, len1_byte
);
4696 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4697 len1
, current_buffer
, 0);
4698 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4699 len_mid
, current_buffer
, 0);
4700 graft_intervals_into_buffer (tmp_interval2
, start1
,
4701 len2
, current_buffer
, 0);
4704 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4705 update_compositions (end2
- len1
, end2
, CHECK_BORDER
);
4708 /* When doing multiple transpositions, it might be nice
4709 to optimize this. Perhaps the markers in any one buffer
4710 should be organized in some sorted data tree. */
4711 if (NILP (leave_markers
))
4713 transpose_markers (start1
, end1
, start2
, end2
,
4714 start1_byte
, start1_byte
+ len1_byte
,
4715 start2_byte
, start2_byte
+ len2_byte
);
4716 fix_start_end_in_overlays (start1
, end2
);
4719 signal_after_change (start1
, end2
- start1
, end2
- start1
);
4725 syms_of_editfns (void)
4730 DEFSYM (Qbuffer_access_fontify_functions
, "buffer-access-fontify-functions");
4732 DEFVAR_LISP ("inhibit-field-text-motion", Vinhibit_field_text_motion
,
4733 doc
: /* Non-nil means text motion commands don't notice fields. */);
4734 Vinhibit_field_text_motion
= Qnil
;
4736 DEFVAR_LISP ("buffer-access-fontify-functions",
4737 Vbuffer_access_fontify_functions
,
4738 doc
: /* List of functions called by `buffer-substring' to fontify if necessary.
4739 Each function is called with two arguments which specify the range
4740 of the buffer being accessed. */);
4741 Vbuffer_access_fontify_functions
= Qnil
;
4745 obuf
= Fcurrent_buffer ();
4746 /* Do this here, because init_buffer_once is too early--it won't work. */
4747 Fset_buffer (Vprin1_to_string_buffer
);
4748 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
4749 Fset (Fmake_local_variable (intern_c_string ("buffer-access-fontify-functions")),
4754 DEFVAR_LISP ("buffer-access-fontified-property",
4755 Vbuffer_access_fontified_property
,
4756 doc
: /* Property which (if non-nil) indicates text has been fontified.
4757 `buffer-substring' need not call the `buffer-access-fontify-functions'
4758 functions if all the text being accessed has this property. */);
4759 Vbuffer_access_fontified_property
= Qnil
;
4761 DEFVAR_LISP ("system-name", Vsystem_name
,
4762 doc
: /* The host name of the machine Emacs is running on. */);
4764 DEFVAR_LISP ("user-full-name", Vuser_full_name
,
4765 doc
: /* The full name of the user logged in. */);
4767 DEFVAR_LISP ("user-login-name", Vuser_login_name
,
4768 doc
: /* The user's name, taken from environment variables if possible. */);
4770 DEFVAR_LISP ("user-real-login-name", Vuser_real_login_name
,
4771 doc
: /* The user's name, based upon the real uid only. */);
4773 DEFVAR_LISP ("operating-system-release", Voperating_system_release
,
4774 doc
: /* The release of the operating system Emacs is running on. */);
4776 defsubr (&Spropertize
);
4777 defsubr (&Schar_equal
);
4778 defsubr (&Sgoto_char
);
4779 defsubr (&Sstring_to_char
);
4780 defsubr (&Schar_to_string
);
4781 defsubr (&Sbyte_to_string
);
4782 defsubr (&Sbuffer_substring
);
4783 defsubr (&Sbuffer_substring_no_properties
);
4784 defsubr (&Sbuffer_string
);
4786 defsubr (&Spoint_marker
);
4787 defsubr (&Smark_marker
);
4789 defsubr (&Sregion_beginning
);
4790 defsubr (&Sregion_end
);
4792 DEFSYM (Qfield
, "field");
4793 DEFSYM (Qboundary
, "boundary");
4794 defsubr (&Sfield_beginning
);
4795 defsubr (&Sfield_end
);
4796 defsubr (&Sfield_string
);
4797 defsubr (&Sfield_string_no_properties
);
4798 defsubr (&Sdelete_field
);
4799 defsubr (&Sconstrain_to_field
);
4801 defsubr (&Sline_beginning_position
);
4802 defsubr (&Sline_end_position
);
4804 /* defsubr (&Smark); */
4805 /* defsubr (&Sset_mark); */
4806 defsubr (&Ssave_excursion
);
4807 defsubr (&Ssave_current_buffer
);
4809 defsubr (&Sbufsize
);
4810 defsubr (&Spoint_max
);
4811 defsubr (&Spoint_min
);
4812 defsubr (&Spoint_min_marker
);
4813 defsubr (&Spoint_max_marker
);
4814 defsubr (&Sgap_position
);
4815 defsubr (&Sgap_size
);
4816 defsubr (&Sposition_bytes
);
4817 defsubr (&Sbyte_to_position
);
4823 defsubr (&Sfollowing_char
);
4824 defsubr (&Sprevious_char
);
4825 defsubr (&Schar_after
);
4826 defsubr (&Schar_before
);
4828 defsubr (&Sinsert_before_markers
);
4829 defsubr (&Sinsert_and_inherit
);
4830 defsubr (&Sinsert_and_inherit_before_markers
);
4831 defsubr (&Sinsert_char
);
4832 defsubr (&Sinsert_byte
);
4834 defsubr (&Suser_login_name
);
4835 defsubr (&Suser_real_login_name
);
4836 defsubr (&Suser_uid
);
4837 defsubr (&Suser_real_uid
);
4838 defsubr (&Suser_full_name
);
4839 defsubr (&Semacs_pid
);
4840 defsubr (&Scurrent_time
);
4841 defsubr (&Sget_internal_run_time
);
4842 defsubr (&Sformat_time_string
);
4843 defsubr (&Sfloat_time
);
4844 defsubr (&Sdecode_time
);
4845 defsubr (&Sencode_time
);
4846 defsubr (&Scurrent_time_string
);
4847 defsubr (&Scurrent_time_zone
);
4848 defsubr (&Sset_time_zone_rule
);
4849 defsubr (&Ssystem_name
);
4850 defsubr (&Smessage
);
4851 defsubr (&Smessage_box
);
4852 defsubr (&Smessage_or_box
);
4853 defsubr (&Scurrent_message
);
4856 defsubr (&Sinsert_buffer_substring
);
4857 defsubr (&Scompare_buffer_substrings
);
4858 defsubr (&Ssubst_char_in_region
);
4859 defsubr (&Stranslate_region_internal
);
4860 defsubr (&Sdelete_region
);
4861 defsubr (&Sdelete_and_extract_region
);
4863 defsubr (&Snarrow_to_region
);
4864 defsubr (&Ssave_restriction
);
4865 defsubr (&Stranspose_regions
);