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 (EMACS_INT
, EMACS_INT
);
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
);
149 Vuser_full_name
= Fuser_full_name (NILP (tem
)? make_number (geteuid())
154 Vuser_full_name
= build_string (p
);
155 else if (NILP (Vuser_full_name
))
156 Vuser_full_name
= build_string ("unknown");
158 #ifdef HAVE_SYS_UTSNAME_H
162 Voperating_system_release
= build_string (uts
.release
);
165 Voperating_system_release
= Qnil
;
169 DEFUN ("char-to-string", Fchar_to_string
, Schar_to_string
, 1, 1, 0,
170 doc
: /* Convert arg CHAR to a string containing that character.
171 usage: (char-to-string CHAR) */)
172 (Lisp_Object character
)
175 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
177 CHECK_CHARACTER (character
);
178 c
= XFASTINT (character
);
180 len
= CHAR_STRING (c
, str
);
181 return make_string_from_bytes ((char *) str
, 1, len
);
184 DEFUN ("byte-to-string", Fbyte_to_string
, Sbyte_to_string
, 1, 1, 0,
185 doc
: /* Convert arg BYTE to a unibyte string containing that byte. */)
190 if (XINT (byte
) < 0 || XINT (byte
) > 255)
191 error ("Invalid byte");
193 return make_string_from_bytes ((char *) &b
, 1, 1);
196 DEFUN ("string-to-char", Fstring_to_char
, Sstring_to_char
, 1, 1, 0,
197 doc
: /* Return the first character in STRING.
198 A multibyte character is handled correctly.
199 The value returned is a Unicode codepoint if it is below #x110000 (in
200 hex). Codepoints beyond that are Emacs extensions of Unicode. In
201 particular, eight-bit characters are returned as codepoints in the
202 range #x3FFF80 through #x3FFFFF, inclusive. */)
203 (register Lisp_Object string
)
205 register Lisp_Object val
;
206 CHECK_STRING (string
);
209 if (STRING_MULTIBYTE (string
))
210 XSETFASTINT (val
, STRING_CHAR (SDATA (string
)));
212 XSETFASTINT (val
, SREF (string
, 0));
215 XSETFASTINT (val
, 0);
220 buildmark (EMACS_INT charpos
, EMACS_INT bytepos
)
222 register Lisp_Object mark
;
223 mark
= Fmake_marker ();
224 set_marker_both (mark
, Qnil
, charpos
, bytepos
);
228 DEFUN ("point", Fpoint
, Spoint
, 0, 0, 0,
229 doc
: /* Return value of point, as an integer.
230 Beginning of buffer is position (point-min). */)
234 XSETFASTINT (temp
, PT
);
238 DEFUN ("point-marker", Fpoint_marker
, Spoint_marker
, 0, 0, 0,
239 doc
: /* Return value of point, as a marker object. */)
242 return buildmark (PT
, PT_BYTE
);
246 clip_to_bounds (EMACS_INT lower
, EMACS_INT num
, EMACS_INT upper
)
250 else if (num
> upper
)
256 DEFUN ("goto-char", Fgoto_char
, Sgoto_char
, 1, 1, "NGoto char: ",
257 doc
: /* Set point to POSITION, a number or marker.
258 Beginning of buffer is position (point-min), end is (point-max).
260 The return value is POSITION. */)
261 (register Lisp_Object position
)
265 if (MARKERP (position
)
266 && current_buffer
== XMARKER (position
)->buffer
)
268 pos
= marker_position (position
);
270 SET_PT_BOTH (BEGV
, BEGV_BYTE
);
272 SET_PT_BOTH (ZV
, ZV_BYTE
);
274 SET_PT_BOTH (pos
, marker_byte_position (position
));
279 CHECK_NUMBER_COERCE_MARKER (position
);
281 pos
= clip_to_bounds (BEGV
, XINT (position
), ZV
);
287 /* Return the start or end position of the region.
288 BEGINNINGP non-zero means return the start.
289 If there is no region active, signal an error. */
292 region_limit (int beginningp
)
296 if (!NILP (Vtransient_mark_mode
)
297 && NILP (Vmark_even_if_inactive
)
298 && NILP (BVAR (current_buffer
, mark_active
)))
299 xsignal0 (Qmark_inactive
);
301 m
= Fmarker_position (BVAR (current_buffer
, mark
));
303 error ("The mark is not set now, so there is no region");
305 if ((PT
< XFASTINT (m
)) == (beginningp
!= 0))
306 m
= make_number (PT
);
310 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
311 doc
: /* Return the integer value of point or mark, whichever is smaller. */)
314 return region_limit (1);
317 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
318 doc
: /* Return the integer value of point or mark, whichever is larger. */)
321 return region_limit (0);
324 DEFUN ("mark-marker", Fmark_marker
, Smark_marker
, 0, 0, 0,
325 doc
: /* Return this buffer's mark, as a marker object.
326 Watch out! Moving this marker changes the mark position.
327 If you set the marker not to point anywhere, the buffer will have no mark. */)
330 return BVAR (current_buffer
, mark
);
334 /* Find all the overlays in the current buffer that touch position POS.
335 Return the number found, and store them in a vector in VEC
339 overlays_around (EMACS_INT pos
, Lisp_Object
*vec
, ptrdiff_t len
)
341 Lisp_Object overlay
, start
, end
;
342 struct Lisp_Overlay
*tail
;
343 EMACS_INT startpos
, endpos
;
346 for (tail
= current_buffer
->overlays_before
; tail
; tail
= tail
->next
)
348 XSETMISC (overlay
, tail
);
350 end
= OVERLAY_END (overlay
);
351 endpos
= OVERLAY_POSITION (end
);
354 start
= OVERLAY_START (overlay
);
355 startpos
= OVERLAY_POSITION (start
);
360 /* Keep counting overlays even if we can't return them all. */
365 for (tail
= current_buffer
->overlays_after
; tail
; tail
= tail
->next
)
367 XSETMISC (overlay
, tail
);
369 start
= OVERLAY_START (overlay
);
370 startpos
= OVERLAY_POSITION (start
);
373 end
= OVERLAY_END (overlay
);
374 endpos
= OVERLAY_POSITION (end
);
386 /* Return the value of property PROP, in OBJECT at POSITION.
387 It's the value of PROP that a char inserted at POSITION would get.
388 OBJECT is optional and defaults to the current buffer.
389 If OBJECT is a buffer, then overlay properties are considered as well as
391 If OBJECT is a window, then that window's buffer is used, but
392 window-specific overlays are considered only if they are associated
395 get_pos_property (Lisp_Object position
, register Lisp_Object prop
, Lisp_Object object
)
397 CHECK_NUMBER_COERCE_MARKER (position
);
400 XSETBUFFER (object
, current_buffer
);
401 else if (WINDOWP (object
))
402 object
= XWINDOW (object
)->buffer
;
404 if (!BUFFERP (object
))
405 /* pos-property only makes sense in buffers right now, since strings
406 have no overlays and no notion of insertion for which stickiness
408 return Fget_text_property (position
, prop
, object
);
411 EMACS_INT posn
= XINT (position
);
413 Lisp_Object
*overlay_vec
, tem
;
414 struct buffer
*obuf
= current_buffer
;
416 set_buffer_temp (XBUFFER (object
));
418 /* First try with room for 40 overlays. */
420 overlay_vec
= (Lisp_Object
*) alloca (noverlays
* sizeof (Lisp_Object
));
421 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
423 /* If there are more than 40,
424 make enough space for all, and try again. */
427 overlay_vec
= (Lisp_Object
*) alloca (noverlays
* sizeof (Lisp_Object
));
428 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
430 noverlays
= sort_overlays (overlay_vec
, noverlays
, NULL
);
432 set_buffer_temp (obuf
);
434 /* Now check the overlays in order of decreasing priority. */
435 while (--noverlays
>= 0)
437 Lisp_Object ol
= overlay_vec
[noverlays
];
438 tem
= Foverlay_get (ol
, prop
);
441 /* Check the overlay is indeed active at point. */
442 Lisp_Object start
= OVERLAY_START (ol
), finish
= OVERLAY_END (ol
);
443 if ((OVERLAY_POSITION (start
) == posn
444 && XMARKER (start
)->insertion_type
== 1)
445 || (OVERLAY_POSITION (finish
) == posn
446 && XMARKER (finish
)->insertion_type
== 0))
447 ; /* The overlay will not cover a char inserted at point. */
455 { /* Now check the text properties. */
456 int stickiness
= text_property_stickiness (prop
, position
, object
);
458 return Fget_text_property (position
, prop
, object
);
459 else if (stickiness
< 0
460 && XINT (position
) > BUF_BEGV (XBUFFER (object
)))
461 return Fget_text_property (make_number (XINT (position
) - 1),
469 /* Find the field surrounding POS in *BEG and *END. If POS is nil,
470 the value of point is used instead. If BEG or END is null,
471 means don't store the beginning or end of the field.
473 BEG_LIMIT and END_LIMIT serve to limit the ranged of the returned
474 results; they do not effect boundary behavior.
476 If MERGE_AT_BOUNDARY is nonzero, then if POS is at the very first
477 position of a field, then the beginning of the previous field is
478 returned instead of the beginning of POS's field (since the end of a
479 field is actually also the beginning of the next input field, this
480 behavior is sometimes useful). Additionally in the MERGE_AT_BOUNDARY
481 true case, if two fields are separated by a field with the special
482 value `boundary', and POS lies within it, then the two separated
483 fields are considered to be adjacent, and POS between them, when
484 finding the beginning and ending of the "merged" field.
486 Either BEG or END may be 0, in which case the corresponding value
490 find_field (Lisp_Object pos
, Lisp_Object merge_at_boundary
,
491 Lisp_Object beg_limit
,
492 EMACS_INT
*beg
, Lisp_Object end_limit
, EMACS_INT
*end
)
494 /* Fields right before and after the point. */
495 Lisp_Object before_field
, after_field
;
496 /* 1 if POS counts as the start of a field. */
497 int at_field_start
= 0;
498 /* 1 if POS counts as the end of a field. */
499 int at_field_end
= 0;
502 XSETFASTINT (pos
, PT
);
504 CHECK_NUMBER_COERCE_MARKER (pos
);
507 = get_char_property_and_overlay (pos
, Qfield
, Qnil
, NULL
);
509 = (XFASTINT (pos
) > BEGV
510 ? get_char_property_and_overlay (make_number (XINT (pos
) - 1),
512 /* Using nil here would be a more obvious choice, but it would
513 fail when the buffer starts with a non-sticky field. */
516 /* See if we need to handle the case where MERGE_AT_BOUNDARY is nil
517 and POS is at beginning of a field, which can also be interpreted
518 as the end of the previous field. Note that the case where if
519 MERGE_AT_BOUNDARY is non-nil (see function comment) is actually the
520 more natural one; then we avoid treating the beginning of a field
522 if (NILP (merge_at_boundary
))
524 Lisp_Object field
= get_pos_property (pos
, Qfield
, Qnil
);
525 if (!EQ (field
, after_field
))
527 if (!EQ (field
, before_field
))
529 if (NILP (field
) && at_field_start
&& at_field_end
)
530 /* If an inserted char would have a nil field while the surrounding
531 text is non-nil, we're probably not looking at a
532 zero-length field, but instead at a non-nil field that's
533 not intended for editing (such as comint's prompts). */
534 at_field_end
= at_field_start
= 0;
537 /* Note about special `boundary' fields:
539 Consider the case where the point (`.') is between the fields `x' and `y':
543 In this situation, if merge_at_boundary is true, we consider the
544 `x' and `y' fields as forming one big merged field, and so the end
545 of the field is the end of `y'.
547 However, if `x' and `y' are separated by a special `boundary' field
548 (a field with a `field' char-property of 'boundary), then we ignore
549 this special field when merging adjacent fields. Here's the same
550 situation, but with a `boundary' field between the `x' and `y' fields:
554 Here, if point is at the end of `x', the beginning of `y', or
555 anywhere in-between (within the `boundary' field), we merge all
556 three fields and consider the beginning as being the beginning of
557 the `x' field, and the end as being the end of the `y' field. */
562 /* POS is at the edge of a field, and we should consider it as
563 the beginning of the following field. */
564 *beg
= XFASTINT (pos
);
566 /* Find the previous field boundary. */
569 if (!NILP (merge_at_boundary
) && EQ (before_field
, Qboundary
))
570 /* Skip a `boundary' field. */
571 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
574 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
576 *beg
= NILP (p
) ? BEGV
: XFASTINT (p
);
583 /* POS is at the edge of a field, and we should consider it as
584 the end of the previous field. */
585 *end
= XFASTINT (pos
);
587 /* Find the next field boundary. */
589 if (!NILP (merge_at_boundary
) && EQ (after_field
, Qboundary
))
590 /* Skip a `boundary' field. */
591 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
594 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
596 *end
= NILP (pos
) ? ZV
: XFASTINT (pos
);
602 DEFUN ("delete-field", Fdelete_field
, Sdelete_field
, 0, 1, 0,
603 doc
: /* Delete the field surrounding POS.
604 A field is a region of text with the same `field' property.
605 If POS is nil, the value of point is used for POS. */)
609 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
611 del_range (beg
, end
);
615 DEFUN ("field-string", Ffield_string
, Sfield_string
, 0, 1, 0,
616 doc
: /* Return the contents of the field surrounding POS as a string.
617 A field is a region of text with the same `field' property.
618 If POS is nil, the value of point is used for POS. */)
622 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
623 return make_buffer_string (beg
, end
, 1);
626 DEFUN ("field-string-no-properties", Ffield_string_no_properties
, Sfield_string_no_properties
, 0, 1, 0,
627 doc
: /* Return the contents of the field around POS, without text properties.
628 A field is a region of text with the same `field' property.
629 If POS is nil, the value of point is used for POS. */)
633 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
634 return make_buffer_string (beg
, end
, 0);
637 DEFUN ("field-beginning", Ffield_beginning
, Sfield_beginning
, 0, 3, 0,
638 doc
: /* Return the beginning of the field surrounding POS.
639 A field is a region of text with the same `field' property.
640 If POS is nil, the value of point is used for POS.
641 If ESCAPE-FROM-EDGE is non-nil and POS is at the beginning of its
642 field, then the beginning of the *previous* field is returned.
643 If LIMIT is non-nil, it is a buffer position; if the beginning of the field
644 is before LIMIT, then LIMIT will be returned instead. */)
645 (Lisp_Object pos
, Lisp_Object escape_from_edge
, Lisp_Object limit
)
648 find_field (pos
, escape_from_edge
, limit
, &beg
, Qnil
, 0);
649 return make_number (beg
);
652 DEFUN ("field-end", Ffield_end
, Sfield_end
, 0, 3, 0,
653 doc
: /* Return the end of the field surrounding POS.
654 A field is a region of text with the same `field' property.
655 If POS is nil, the value of point is used for POS.
656 If ESCAPE-FROM-EDGE is non-nil and POS is at the end of its field,
657 then the end of the *following* field is returned.
658 If LIMIT is non-nil, it is a buffer position; if the end of the field
659 is after LIMIT, then LIMIT will be returned instead. */)
660 (Lisp_Object pos
, Lisp_Object escape_from_edge
, Lisp_Object limit
)
663 find_field (pos
, escape_from_edge
, Qnil
, 0, limit
, &end
);
664 return make_number (end
);
667 DEFUN ("constrain-to-field", Fconstrain_to_field
, Sconstrain_to_field
, 2, 5, 0,
668 doc
: /* Return the position closest to NEW-POS that is in the same field as OLD-POS.
670 A field is a region of text with the same `field' property.
671 If NEW-POS is nil, then the current point is used instead, and set to the
672 constrained position if that is different.
674 If OLD-POS is at the boundary of two fields, then the allowable
675 positions for NEW-POS depends on the value of the optional argument
676 ESCAPE-FROM-EDGE: If ESCAPE-FROM-EDGE is nil, then NEW-POS is
677 constrained to the field that has the same `field' char-property
678 as any new characters inserted at OLD-POS, whereas if ESCAPE-FROM-EDGE
679 is non-nil, NEW-POS is constrained to the union of the two adjacent
680 fields. Additionally, if two fields are separated by another field with
681 the special value `boundary', then any point within this special field is
682 also considered to be `on the boundary'.
684 If the optional argument ONLY-IN-LINE is non-nil and constraining
685 NEW-POS would move it to a different line, NEW-POS is returned
686 unconstrained. This useful for commands that move by line, like
687 \\[next-line] or \\[beginning-of-line], which should generally respect field boundaries
688 only in the case where they can still move to the right line.
690 If the optional argument INHIBIT-CAPTURE-PROPERTY is non-nil, and OLD-POS has
691 a non-nil property of that name, then any field boundaries are ignored.
693 Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
694 (Lisp_Object new_pos
, Lisp_Object old_pos
, Lisp_Object escape_from_edge
, Lisp_Object only_in_line
, Lisp_Object inhibit_capture_property
)
696 /* If non-zero, then the original point, before re-positioning. */
697 EMACS_INT orig_point
= 0;
699 Lisp_Object prev_old
, prev_new
;
702 /* Use the current point, and afterwards, set it. */
705 XSETFASTINT (new_pos
, PT
);
708 CHECK_NUMBER_COERCE_MARKER (new_pos
);
709 CHECK_NUMBER_COERCE_MARKER (old_pos
);
711 fwd
= (XFASTINT (new_pos
) > XFASTINT (old_pos
));
713 prev_old
= make_number (XFASTINT (old_pos
) - 1);
714 prev_new
= make_number (XFASTINT (new_pos
) - 1);
716 if (NILP (Vinhibit_field_text_motion
)
717 && !EQ (new_pos
, old_pos
)
718 && (!NILP (Fget_char_property (new_pos
, Qfield
, Qnil
))
719 || !NILP (Fget_char_property (old_pos
, Qfield
, Qnil
))
720 /* To recognize field boundaries, we must also look at the
721 previous positions; we could use `get_pos_property'
722 instead, but in itself that would fail inside non-sticky
723 fields (like comint prompts). */
724 || (XFASTINT (new_pos
) > BEGV
725 && !NILP (Fget_char_property (prev_new
, Qfield
, Qnil
)))
726 || (XFASTINT (old_pos
) > BEGV
727 && !NILP (Fget_char_property (prev_old
, Qfield
, Qnil
))))
728 && (NILP (inhibit_capture_property
)
729 /* Field boundaries are again a problem; but now we must
730 decide the case exactly, so we need to call
731 `get_pos_property' as well. */
732 || (NILP (get_pos_property (old_pos
, inhibit_capture_property
, Qnil
))
733 && (XFASTINT (old_pos
) <= BEGV
734 || NILP (Fget_char_property (old_pos
, inhibit_capture_property
, Qnil
))
735 || NILP (Fget_char_property (prev_old
, inhibit_capture_property
, Qnil
))))))
736 /* It is possible that NEW_POS is not within the same field as
737 OLD_POS; try to move NEW_POS so that it is. */
740 Lisp_Object field_bound
;
743 field_bound
= Ffield_end (old_pos
, escape_from_edge
, new_pos
);
745 field_bound
= Ffield_beginning (old_pos
, escape_from_edge
, new_pos
);
747 if (/* See if ESCAPE_FROM_EDGE caused FIELD_BOUND to jump to the
748 other side of NEW_POS, which would mean that NEW_POS is
749 already acceptable, and it's not necessary to constrain it
751 ((XFASTINT (field_bound
) < XFASTINT (new_pos
)) ? fwd
: !fwd
)
752 /* NEW_POS should be constrained, but only if either
753 ONLY_IN_LINE is nil (in which case any constraint is OK),
754 or NEW_POS and FIELD_BOUND are on the same line (in which
755 case the constraint is OK even if ONLY_IN_LINE is non-nil). */
756 && (NILP (only_in_line
)
757 /* This is the ONLY_IN_LINE case, check that NEW_POS and
758 FIELD_BOUND are on the same line by seeing whether
759 there's an intervening newline or not. */
760 || (scan_buffer ('\n',
761 XFASTINT (new_pos
), XFASTINT (field_bound
),
762 fwd
? -1 : 1, &shortage
, 1),
764 /* Constrain NEW_POS to FIELD_BOUND. */
765 new_pos
= field_bound
;
767 if (orig_point
&& XFASTINT (new_pos
) != orig_point
)
768 /* The NEW_POS argument was originally nil, so automatically set PT. */
769 SET_PT (XFASTINT (new_pos
));
776 DEFUN ("line-beginning-position",
777 Fline_beginning_position
, Sline_beginning_position
, 0, 1, 0,
778 doc
: /* Return the character position of the first character on the current line.
779 With argument N not nil or 1, move forward N - 1 lines first.
780 If scan reaches end of buffer, return that position.
782 The returned position is of the first character in the logical order,
783 i.e. the one that has the smallest character position.
785 This function constrains the returned position to the current field
786 unless that would be on a different line than the original,
787 unconstrained result. If N is nil or 1, and a front-sticky field
788 starts at point, the scan stops as soon as it starts. To ignore field
789 boundaries bind `inhibit-field-text-motion' to t.
791 This function does not move point. */)
794 EMACS_INT orig
, orig_byte
, end
;
795 int count
= SPECPDL_INDEX ();
796 specbind (Qinhibit_point_motion_hooks
, Qt
);
805 Fforward_line (make_number (XINT (n
) - 1));
808 SET_PT_BOTH (orig
, orig_byte
);
810 unbind_to (count
, Qnil
);
812 /* Return END constrained to the current input field. */
813 return Fconstrain_to_field (make_number (end
), make_number (orig
),
814 XINT (n
) != 1 ? Qt
: Qnil
,
818 DEFUN ("line-end-position", Fline_end_position
, Sline_end_position
, 0, 1, 0,
819 doc
: /* Return the character position of the last character on the current line.
820 With argument N not nil or 1, move forward N - 1 lines first.
821 If scan reaches end of buffer, return that position.
823 The returned position is of the last character in the logical order,
824 i.e. the character whose buffer position is the largest one.
826 This function constrains the returned position to the current field
827 unless that would be on a different line than the original,
828 unconstrained result. If N is nil or 1, and a rear-sticky field ends
829 at point, the scan stops as soon as it starts. To ignore field
830 boundaries bind `inhibit-field-text-motion' to t.
832 This function does not move point. */)
843 end_pos
= find_before_next_newline (orig
, 0, XINT (n
) - (XINT (n
) <= 0));
845 /* Return END_POS constrained to the current input field. */
846 return Fconstrain_to_field (make_number (end_pos
), make_number (orig
),
852 save_excursion_save (void)
854 int visible
= (XBUFFER (XWINDOW (selected_window
)->buffer
)
857 return Fcons (Fpoint_marker (),
858 Fcons (Fcopy_marker (BVAR (current_buffer
, mark
), Qnil
),
859 Fcons (visible
? Qt
: Qnil
,
860 Fcons (BVAR (current_buffer
, mark_active
),
865 save_excursion_restore (Lisp_Object info
)
867 Lisp_Object tem
, tem1
, omark
, nmark
;
868 struct gcpro gcpro1
, gcpro2
, gcpro3
;
871 tem
= Fmarker_buffer (XCAR (info
));
872 /* If buffer being returned to is now deleted, avoid error */
873 /* Otherwise could get error here while unwinding to top level
875 /* In that case, Fmarker_buffer returns nil now. */
879 omark
= nmark
= Qnil
;
880 GCPRO3 (info
, omark
, nmark
);
887 unchain_marker (XMARKER (tem
));
892 omark
= Fmarker_position (BVAR (current_buffer
, mark
));
893 Fset_marker (BVAR (current_buffer
, mark
), tem
, Fcurrent_buffer ());
894 nmark
= Fmarker_position (tem
);
895 unchain_marker (XMARKER (tem
));
899 visible_p
= !NILP (XCAR (info
));
901 #if 0 /* We used to make the current buffer visible in the selected window
902 if that was true previously. That avoids some anomalies.
903 But it creates others, and it wasn't documented, and it is simpler
904 and cleaner never to alter the window/buffer connections. */
907 && current_buffer
!= XBUFFER (XWINDOW (selected_window
)->buffer
))
908 Fswitch_to_buffer (Fcurrent_buffer (), Qnil
);
914 tem1
= BVAR (current_buffer
, mark_active
);
915 BVAR (current_buffer
, mark_active
) = tem
;
917 /* If mark is active now, and either was not active
918 or was at a different place, run the activate hook. */
921 if (! EQ (omark
, nmark
))
923 tem
= intern ("activate-mark-hook");
924 Frun_hooks (1, &tem
);
927 /* If mark has ceased to be active, run deactivate hook. */
928 else if (! NILP (tem1
))
930 tem
= intern ("deactivate-mark-hook");
931 Frun_hooks (1, &tem
);
934 /* If buffer was visible in a window, and a different window was
935 selected, and the old selected window is still showing this
936 buffer, restore point in that window. */
939 && !EQ (tem
, selected_window
)
940 && (tem1
= XWINDOW (tem
)->buffer
,
941 (/* Window is live... */
943 /* ...and it shows the current buffer. */
944 && XBUFFER (tem1
) == current_buffer
)))
945 Fset_window_point (tem
, make_number (PT
));
951 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
952 doc
: /* Save point, mark, and current buffer; execute BODY; restore those things.
953 Executes BODY just like `progn'.
954 The values of point, mark and the current buffer are restored
955 even in case of abnormal exit (throw or error).
956 The state of activation of the mark is also restored.
958 This construct does not save `deactivate-mark', and therefore
959 functions that change the buffer will still cause deactivation
960 of the mark at the end of the command. To prevent that, bind
961 `deactivate-mark' with `let'.
963 If you only want to save the current buffer but not point nor mark,
964 then just use `save-current-buffer', or even `with-current-buffer'.
966 usage: (save-excursion &rest BODY) */)
969 register Lisp_Object val
;
970 int count
= SPECPDL_INDEX ();
972 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
975 return unbind_to (count
, val
);
978 DEFUN ("save-current-buffer", Fsave_current_buffer
, Ssave_current_buffer
, 0, UNEVALLED
, 0,
979 doc
: /* Save the current buffer; execute BODY; restore the current buffer.
980 Executes BODY just like `progn'.
981 usage: (save-current-buffer &rest BODY) */)
985 int count
= SPECPDL_INDEX ();
987 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
990 return unbind_to (count
, val
);
993 DEFUN ("buffer-size", Fbufsize
, Sbufsize
, 0, 1, 0,
994 doc
: /* Return the number of characters in the current buffer.
995 If BUFFER, return the number of characters in that buffer instead. */)
999 return make_number (Z
- BEG
);
1002 CHECK_BUFFER (buffer
);
1003 return make_number (BUF_Z (XBUFFER (buffer
))
1004 - BUF_BEG (XBUFFER (buffer
)));
1008 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
1009 doc
: /* Return the minimum permissible value of point in the current buffer.
1010 This is 1, unless narrowing (a buffer restriction) is in effect. */)
1014 XSETFASTINT (temp
, BEGV
);
1018 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
1019 doc
: /* Return a marker to the minimum permissible value of point in this buffer.
1020 This is the beginning, unless narrowing (a buffer restriction) is in effect. */)
1023 return buildmark (BEGV
, BEGV_BYTE
);
1026 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
1027 doc
: /* Return the maximum permissible value of point in the current buffer.
1028 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1029 is in effect, in which case it is less. */)
1033 XSETFASTINT (temp
, ZV
);
1037 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
1038 doc
: /* Return a marker to the maximum permissible value of point in this buffer.
1039 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1040 is in effect, in which case it is less. */)
1043 return buildmark (ZV
, ZV_BYTE
);
1046 DEFUN ("gap-position", Fgap_position
, Sgap_position
, 0, 0, 0,
1047 doc
: /* Return the position of the gap, in the current buffer.
1048 See also `gap-size'. */)
1052 XSETFASTINT (temp
, GPT
);
1056 DEFUN ("gap-size", Fgap_size
, Sgap_size
, 0, 0, 0,
1057 doc
: /* Return the size of the current buffer's gap.
1058 See also `gap-position'. */)
1062 XSETFASTINT (temp
, GAP_SIZE
);
1066 DEFUN ("position-bytes", Fposition_bytes
, Sposition_bytes
, 1, 1, 0,
1067 doc
: /* Return the byte position for character position POSITION.
1068 If POSITION is out of range, the value is nil. */)
1069 (Lisp_Object position
)
1071 CHECK_NUMBER_COERCE_MARKER (position
);
1072 if (XINT (position
) < BEG
|| XINT (position
) > Z
)
1074 return make_number (CHAR_TO_BYTE (XINT (position
)));
1077 DEFUN ("byte-to-position", Fbyte_to_position
, Sbyte_to_position
, 1, 1, 0,
1078 doc
: /* Return the character position for byte position BYTEPOS.
1079 If BYTEPOS is out of range, the value is nil. */)
1080 (Lisp_Object bytepos
)
1082 CHECK_NUMBER (bytepos
);
1083 if (XINT (bytepos
) < BEG_BYTE
|| XINT (bytepos
) > Z_BYTE
)
1085 return make_number (BYTE_TO_CHAR (XINT (bytepos
)));
1088 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
1089 doc
: /* Return the character following point, as a number.
1090 At the end of the buffer or accessible region, return 0. */)
1095 XSETFASTINT (temp
, 0);
1097 XSETFASTINT (temp
, FETCH_CHAR (PT_BYTE
));
1101 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
1102 doc
: /* Return the character preceding point, as a number.
1103 At the beginning of the buffer or accessible region, return 0. */)
1108 XSETFASTINT (temp
, 0);
1109 else if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1111 EMACS_INT pos
= PT_BYTE
;
1113 XSETFASTINT (temp
, FETCH_CHAR (pos
));
1116 XSETFASTINT (temp
, FETCH_BYTE (PT_BYTE
- 1));
1120 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
1121 doc
: /* Return t if point is at the beginning of the buffer.
1122 If the buffer is narrowed, this means the beginning of the narrowed part. */)
1130 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
1131 doc
: /* Return t if point is at the end of the buffer.
1132 If the buffer is narrowed, this means the end of the narrowed part. */)
1140 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
1141 doc
: /* Return t if point is at the beginning of a line. */)
1144 if (PT
== BEGV
|| FETCH_BYTE (PT_BYTE
- 1) == '\n')
1149 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
1150 doc
: /* Return t if point is at the end of a line.
1151 `End of a line' includes point being at the end of the buffer. */)
1154 if (PT
== ZV
|| FETCH_BYTE (PT_BYTE
) == '\n')
1159 DEFUN ("char-after", Fchar_after
, Schar_after
, 0, 1, 0,
1160 doc
: /* Return character in current buffer at position POS.
1161 POS is an integer or a marker and defaults to point.
1162 If POS is out of range, the value is nil. */)
1165 register EMACS_INT pos_byte
;
1170 XSETFASTINT (pos
, PT
);
1175 pos_byte
= marker_byte_position (pos
);
1176 if (pos_byte
< BEGV_BYTE
|| pos_byte
>= ZV_BYTE
)
1181 CHECK_NUMBER_COERCE_MARKER (pos
);
1182 if (XINT (pos
) < BEGV
|| XINT (pos
) >= ZV
)
1185 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1188 return make_number (FETCH_CHAR (pos_byte
));
1191 DEFUN ("char-before", Fchar_before
, Schar_before
, 0, 1, 0,
1192 doc
: /* Return character in current buffer preceding position POS.
1193 POS is an integer or a marker and defaults to point.
1194 If POS is out of range, the value is nil. */)
1197 register Lisp_Object val
;
1198 register EMACS_INT pos_byte
;
1203 XSETFASTINT (pos
, PT
);
1208 pos_byte
= marker_byte_position (pos
);
1210 if (pos_byte
<= BEGV_BYTE
|| pos_byte
> ZV_BYTE
)
1215 CHECK_NUMBER_COERCE_MARKER (pos
);
1217 if (XINT (pos
) <= BEGV
|| XINT (pos
) > ZV
)
1220 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1223 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1226 XSETFASTINT (val
, FETCH_CHAR (pos_byte
));
1231 XSETFASTINT (val
, FETCH_BYTE (pos_byte
));
1236 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 1, 0,
1237 doc
: /* Return the name under which the user logged in, as a string.
1238 This is based on the effective uid, not the real uid.
1239 Also, if the environment variables LOGNAME or USER are set,
1240 that determines the value of this function.
1242 If optional argument UID is an integer or a float, return the login name
1243 of the user with that uid, or nil if there is no such user. */)
1249 /* Set up the user name info if we didn't do it before.
1250 (That can happen if Emacs is dumpable
1251 but you decide to run `temacs -l loadup' and not dump. */
1252 if (INTEGERP (Vuser_login_name
))
1256 return Vuser_login_name
;
1258 id
= XFLOATINT (uid
);
1262 return (pw
? build_string (pw
->pw_name
) : Qnil
);
1265 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
1267 doc
: /* Return the name of the user's real uid, as a string.
1268 This ignores the environment variables LOGNAME and USER, so it differs from
1269 `user-login-name' when running under `su'. */)
1272 /* Set up the user name info if we didn't do it before.
1273 (That can happen if Emacs is dumpable
1274 but you decide to run `temacs -l loadup' and not dump. */
1275 if (INTEGERP (Vuser_login_name
))
1277 return Vuser_real_login_name
;
1280 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
1281 doc
: /* Return the effective uid of Emacs.
1282 Value is an integer or a float, depending on the value. */)
1285 /* Assignment to EMACS_INT stops GCC whining about limited range of
1287 EMACS_INT euid
= geteuid ();
1289 /* Make sure we don't produce a negative UID due to signed integer
1292 return make_float (geteuid ());
1293 return make_fixnum_or_float (euid
);
1296 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
1297 doc
: /* Return the real uid of Emacs.
1298 Value is an integer or a float, depending on the value. */)
1301 /* Assignment to EMACS_INT stops GCC whining about limited range of
1303 EMACS_INT uid
= getuid ();
1305 /* Make sure we don't produce a negative UID due to signed integer
1308 return make_float (getuid ());
1309 return make_fixnum_or_float (uid
);
1312 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 1, 0,
1313 doc
: /* Return the full name of the user logged in, as a string.
1314 If the full name corresponding to Emacs's userid is not known,
1317 If optional argument UID is an integer or float, return the full name
1318 of the user with that uid, or nil if there is no such user.
1319 If UID is a string, return the full name of the user with that login
1320 name, or nil if there is no such user. */)
1324 register char *p
, *q
;
1328 return Vuser_full_name
;
1329 else if (NUMBERP (uid
))
1331 uid_t u
= XFLOATINT (uid
);
1336 else if (STRINGP (uid
))
1339 pw
= getpwnam (SSDATA (uid
));
1343 error ("Invalid UID specification");
1349 /* Chop off everything after the first comma. */
1350 q
= strchr (p
, ',');
1351 full
= make_string (p
, q
? q
- p
: strlen (p
));
1353 #ifdef AMPERSAND_FULL_NAME
1355 q
= strchr (p
, '&');
1356 /* Substitute the login name for the &, upcasing the first character. */
1362 login
= Fuser_login_name (make_number (pw
->pw_uid
));
1363 r
= (char *) alloca (strlen (p
) + SCHARS (login
) + 1);
1364 memcpy (r
, p
, q
- p
);
1366 strcat (r
, SSDATA (login
));
1367 r
[q
- p
] = upcase ((unsigned char) r
[q
- p
]);
1369 full
= build_string (r
);
1371 #endif /* AMPERSAND_FULL_NAME */
1376 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
1377 doc
: /* Return the host name of the machine you are running on, as a string. */)
1380 return Vsystem_name
;
1384 get_system_name (void)
1386 if (STRINGP (Vsystem_name
))
1387 return SSDATA (Vsystem_name
);
1392 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
1393 doc
: /* Return the process ID of Emacs, as an integer. */)
1396 return make_number (getpid ());
1402 # define TIME_T_MIN TYPE_MINIMUM (time_t)
1405 # define TIME_T_MAX TYPE_MAXIMUM (time_t)
1408 /* Report that a time value is out of range for Emacs. */
1410 time_overflow (void)
1412 error ("Specified time is not representable");
1415 /* Return the upper part of the time T (everything but the bottom 16 bits),
1416 making sure that it is representable. */
1420 time_t hi
= t
>> 16;
1422 /* Check for overflow, helping the compiler for common cases where
1423 no runtime check is needed, and taking care not to convert
1424 negative numbers to unsigned before comparing them. */
1425 if (! ((! TYPE_SIGNED (time_t)
1426 || MOST_NEGATIVE_FIXNUM
<= TIME_T_MIN
>> 16
1427 || MOST_NEGATIVE_FIXNUM
<= hi
)
1428 && (TIME_T_MAX
>> 16 <= MOST_POSITIVE_FIXNUM
1429 || hi
<= MOST_POSITIVE_FIXNUM
)))
1435 /* Return the bottom 16 bits of the time T. */
1439 return t
& ((1 << 16) - 1);
1442 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
1443 doc
: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
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 The microsecond count is zero on systems that do not provide
1450 resolution finer than a second. */)
1456 return list3 (make_number (hi_time (EMACS_SECS (t
))),
1457 make_number (lo_time (EMACS_SECS (t
))),
1458 make_number (EMACS_USECS (t
)));
1461 DEFUN ("get-internal-run-time", Fget_internal_run_time
, Sget_internal_run_time
,
1463 doc
: /* Return the current run time used by Emacs.
1464 The time is returned as a list of three integers. The first has the
1465 most significant 16 bits of the seconds, while the second has the
1466 least significant 16 bits. The third integer gives the microsecond
1469 On systems that can't determine the run time, `get-internal-run-time'
1470 does the same thing as `current-time'. The microsecond count is zero
1471 on systems that do not provide resolution finer than a second. */)
1474 #ifdef HAVE_GETRUSAGE
1475 struct rusage usage
;
1479 if (getrusage (RUSAGE_SELF
, &usage
) < 0)
1480 /* This shouldn't happen. What action is appropriate? */
1483 /* Sum up user time and system time. */
1484 secs
= usage
.ru_utime
.tv_sec
+ usage
.ru_stime
.tv_sec
;
1485 usecs
= usage
.ru_utime
.tv_usec
+ usage
.ru_stime
.tv_usec
;
1486 if (usecs
>= 1000000)
1492 return list3 (make_number (hi_time (secs
)),
1493 make_number (lo_time (secs
)),
1494 make_number (usecs
));
1495 #else /* ! HAVE_GETRUSAGE */
1497 return w32_get_internal_run_time ();
1498 #else /* ! WINDOWSNT */
1499 return Fcurrent_time ();
1500 #endif /* WINDOWSNT */
1501 #endif /* HAVE_GETRUSAGE */
1505 /* Make a Lisp list that represents the time T. */
1507 make_time (time_t t
)
1509 return list2 (make_number (hi_time (t
)),
1510 make_number (lo_time (t
)));
1513 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1514 If SPECIFIED_TIME is nil, use the current time.
1515 Set *RESULT to seconds since the Epoch.
1516 If USEC is not null, set *USEC to the microseconds component.
1517 Return nonzero if successful. */
1519 lisp_time_argument (Lisp_Object specified_time
, time_t *result
, int *usec
)
1521 if (NILP (specified_time
))
1528 *usec
= EMACS_USECS (t
);
1529 *result
= EMACS_SECS (t
);
1533 return time (result
) != -1;
1537 Lisp_Object high
, low
;
1539 high
= Fcar (specified_time
);
1540 CHECK_NUMBER (high
);
1541 low
= Fcdr (specified_time
);
1546 Lisp_Object usec_l
= Fcdr (low
);
1548 usec_l
= Fcar (usec_l
);
1553 CHECK_NUMBER (usec_l
);
1554 *usec
= XINT (usec_l
);
1564 /* Check for overflow, helping the compiler for common cases
1565 where no runtime check is needed, and taking care not to
1566 convert negative numbers to unsigned before comparing them. */
1567 if (! ((TYPE_SIGNED (time_t)
1568 ? (TIME_T_MIN
>> 16 <= MOST_NEGATIVE_FIXNUM
1569 || TIME_T_MIN
>> 16 <= hi
)
1571 && (MOST_POSITIVE_FIXNUM
<= TIME_T_MAX
>> 16
1572 || hi
<= TIME_T_MAX
>> 16)))
1575 *result
= (hi
<< 16) + (XINT (low
) & 0xffff);
1580 DEFUN ("float-time", Ffloat_time
, Sfloat_time
, 0, 1, 0,
1581 doc
: /* Return the current time, as a float number of seconds since the epoch.
1582 If SPECIFIED-TIME is given, it is the time to convert to float
1583 instead of the current time. The argument should have the form
1584 (HIGH LOW) or (HIGH LOW USEC). Thus, you can use times obtained from
1585 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
1586 have the form (HIGH . LOW), but this is considered obsolete.
1588 WARNING: Since the result is floating point, it may not be exact.
1589 If precise time stamps are required, use either `current-time',
1590 or (if you need time as a string) `format-time-string'. */)
1591 (Lisp_Object specified_time
)
1596 if (! lisp_time_argument (specified_time
, &sec
, &usec
))
1597 error ("Invalid time specification");
1599 return make_float ((sec
* 1e6
+ usec
) / 1e6
);
1602 /* Write information into buffer S of size MAXSIZE, according to the
1603 FORMAT of length FORMAT_LEN, using time information taken from *TP.
1604 Default to Universal Time if UT is nonzero, local time otherwise.
1605 Use NS as the number of nanoseconds in the %N directive.
1606 Return the number of bytes written, not including the terminating
1607 '\0'. If S is NULL, nothing will be written anywhere; so to
1608 determine how many bytes would be written, use NULL for S and
1609 ((size_t) -1) for MAXSIZE.
1611 This function behaves like nstrftime, except it allows null
1612 bytes in FORMAT and it does not support nanoseconds. */
1614 emacs_nmemftime (char *s
, size_t maxsize
, const char *format
,
1615 size_t format_len
, const struct tm
*tp
, int ut
, int ns
)
1619 /* Loop through all the null-terminated strings in the format
1620 argument. Normally there's just one null-terminated string, but
1621 there can be arbitrarily many, concatenated together, if the
1622 format contains '\0' bytes. nstrftime stops at the first
1623 '\0' byte so we must invoke it separately for each such string. */
1632 result
= nstrftime (s
, maxsize
, format
, tp
, ut
, ns
);
1636 if (result
== 0 && s
[0] != '\0')
1641 maxsize
-= result
+ 1;
1643 len
= strlen (format
);
1644 if (len
== format_len
)
1648 format_len
-= len
+ 1;
1652 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 1, 3, 0,
1653 doc
: /* Use FORMAT-STRING to format the time TIME, or now if omitted.
1654 TIME is specified as (HIGH LOW . IGNORED), as returned by
1655 `current-time' or `file-attributes'. The obsolete form (HIGH . LOW)
1656 is also still accepted.
1657 The third, optional, argument UNIVERSAL, if non-nil, means describe TIME
1658 as Universal Time; nil means describe TIME in the local time zone.
1659 The value is a copy of FORMAT-STRING, but with certain constructs replaced
1660 by text that describes the specified date and time in TIME:
1662 %Y is the year, %y within the century, %C the century.
1663 %G is the year corresponding to the ISO week, %g within the century.
1664 %m is the numeric month.
1665 %b and %h are the locale's abbreviated month name, %B the full name.
1666 %d is the day of the month, zero-padded, %e is blank-padded.
1667 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
1668 %a is the locale's abbreviated name of the day of week, %A the full name.
1669 %U is the week number starting on Sunday, %W starting on Monday,
1670 %V according to ISO 8601.
1671 %j is the day of the year.
1673 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
1674 only blank-padded, %l is like %I blank-padded.
1675 %p is the locale's equivalent of either AM or PM.
1678 %N is the nanosecond, %6N the microsecond, %3N the millisecond, etc.
1679 %Z is the time zone name, %z is the numeric form.
1680 %s is the number of seconds since 1970-01-01 00:00:00 +0000.
1682 %c is the locale's date and time format.
1683 %x is the locale's "preferred" date format.
1684 %D is like "%m/%d/%y".
1686 %R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
1687 %X is the locale's "preferred" time format.
1689 Finally, %n is a newline, %t is a tab, %% is a literal %.
1691 Certain flags and modifiers are available with some format controls.
1692 The flags are `_', `-', `^' and `#'. For certain characters X,
1693 %_X is like %X, but padded with blanks; %-X is like %X,
1694 but without padding. %^X is like %X, but with all textual
1695 characters up-cased; %#X is like %X, but with letter-case of
1696 all textual characters reversed.
1697 %NX (where N stands for an integer) is like %X,
1698 but takes up at least N (a number) positions.
1699 The modifiers are `E' and `O'. For certain characters X,
1700 %EX is a locale's alternative version of %X;
1701 %OX is like %X, but uses the locale's number symbols.
1703 For example, to produce full ISO 8601 format, use "%Y-%m-%dT%T%z". */)
1704 (Lisp_Object format_string
, Lisp_Object timeval
, Lisp_Object universal
)
1711 int ut
= ! NILP (universal
);
1713 CHECK_STRING (format_string
);
1715 if (! (lisp_time_argument (timeval
, &value
, &usec
)
1716 && 0 <= usec
&& usec
< 1000000))
1717 error ("Invalid time specification");
1720 format_string
= code_convert_string_norecord (format_string
,
1721 Vlocale_coding_system
, 1);
1723 /* This is probably enough. */
1724 size
= SBYTES (format_string
);
1725 if (size
<= (STRING_BYTES_BOUND
- 50) / 6)
1726 size
= size
* 6 + 50;
1729 tm
= ut
? gmtime (&value
) : localtime (&value
);
1734 synchronize_system_time_locale ();
1738 char *buf
= (char *) alloca (size
+ 1);
1743 result
= emacs_nmemftime (buf
, size
, SSDATA (format_string
),
1744 SBYTES (format_string
),
1747 if ((result
> 0 && result
< size
) || (result
== 0 && buf
[0] == '\0'))
1748 return code_convert_string_norecord (make_unibyte_string (buf
, result
),
1749 Vlocale_coding_system
, 0);
1751 /* If buffer was too small, make it bigger and try again. */
1753 result
= emacs_nmemftime (NULL
, (size_t) -1,
1754 SSDATA (format_string
),
1755 SBYTES (format_string
),
1758 if (STRING_BYTES_BOUND
<= result
)
1764 DEFUN ("decode-time", Fdecode_time
, Sdecode_time
, 0, 1, 0,
1765 doc
: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST ZONE).
1766 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED),
1767 as from `current-time' and `file-attributes', or nil to use the
1768 current time. The obsolete form (HIGH . LOW) is also still accepted.
1769 The list has the following nine members: SEC is an integer between 0
1770 and 60; SEC is 60 for a leap second, which only some operating systems
1771 support. MINUTE is an integer between 0 and 59. HOUR is an integer
1772 between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
1773 integer between 1 and 12. YEAR is an integer indicating the
1774 four-digit year. DOW is the day of week, an integer between 0 and 6,
1775 where 0 is Sunday. DST is t if daylight saving time is in effect,
1776 otherwise nil. ZONE is an integer indicating the number of seconds
1777 east of Greenwich. (Note that Common Lisp has different meanings for
1779 (Lisp_Object specified_time
)
1783 struct tm
*decoded_time
;
1784 Lisp_Object list_args
[9];
1786 if (! lisp_time_argument (specified_time
, &time_spec
, NULL
))
1787 error ("Invalid time specification");
1790 decoded_time
= localtime (&time_spec
);
1793 && MOST_NEGATIVE_FIXNUM
- TM_YEAR_BASE
<= decoded_time
->tm_year
1794 && decoded_time
->tm_year
<= MOST_POSITIVE_FIXNUM
- TM_YEAR_BASE
))
1796 XSETFASTINT (list_args
[0], decoded_time
->tm_sec
);
1797 XSETFASTINT (list_args
[1], decoded_time
->tm_min
);
1798 XSETFASTINT (list_args
[2], decoded_time
->tm_hour
);
1799 XSETFASTINT (list_args
[3], decoded_time
->tm_mday
);
1800 XSETFASTINT (list_args
[4], decoded_time
->tm_mon
+ 1);
1801 /* On 64-bit machines an int is narrower than EMACS_INT, thus the
1802 cast below avoids overflow in int arithmetics. */
1803 XSETINT (list_args
[5], TM_YEAR_BASE
+ (EMACS_INT
) decoded_time
->tm_year
);
1804 XSETFASTINT (list_args
[6], decoded_time
->tm_wday
);
1805 list_args
[7] = (decoded_time
->tm_isdst
)? Qt
: Qnil
;
1807 /* Make a copy, in case gmtime modifies the struct. */
1808 save_tm
= *decoded_time
;
1810 decoded_time
= gmtime (&time_spec
);
1812 if (decoded_time
== 0)
1813 list_args
[8] = Qnil
;
1815 XSETINT (list_args
[8], tm_diff (&save_tm
, decoded_time
));
1816 return Flist (9, list_args
);
1819 /* Return OBJ - OFFSET, checking that OBJ is a valid fixnum and that
1820 the result is representable as an int. Assume OFFSET is small and
1823 check_tm_member (Lisp_Object obj
, int offset
)
1828 if (! (INT_MIN
+ offset
<= n
&& n
- offset
<= INT_MAX
))
1833 DEFUN ("encode-time", Fencode_time
, Sencode_time
, 6, MANY
, 0,
1834 doc
: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
1835 This is the reverse operation of `decode-time', which see.
1836 ZONE defaults to the current time zone rule. This can
1837 be a string or t (as from `set-time-zone-rule'), or it can be a list
1838 \(as from `current-time-zone') or an integer (as from `decode-time')
1839 applied without consideration for daylight saving time.
1841 You can pass more than 7 arguments; then the first six arguments
1842 are used as SECOND through YEAR, and the *last* argument is used as ZONE.
1843 The intervening arguments are ignored.
1844 This feature lets (apply 'encode-time (decode-time ...)) work.
1846 Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed;
1847 for example, a DAY of 0 means the day preceding the given month.
1848 Year numbers less than 100 are treated just like other year numbers.
1849 If you want them to stand for years in this century, you must do that yourself.
1851 Years before 1970 are not guaranteed to work. On some systems,
1852 year values as low as 1901 do work.
1854 usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
1855 (ptrdiff_t nargs
, Lisp_Object
*args
)
1859 Lisp_Object zone
= (nargs
> 6 ? args
[nargs
- 1] : Qnil
);
1861 tm
.tm_sec
= check_tm_member (args
[0], 0);
1862 tm
.tm_min
= check_tm_member (args
[1], 0);
1863 tm
.tm_hour
= check_tm_member (args
[2], 0);
1864 tm
.tm_mday
= check_tm_member (args
[3], 0);
1865 tm
.tm_mon
= check_tm_member (args
[4], 1);
1866 tm
.tm_year
= check_tm_member (args
[5], TM_YEAR_BASE
);
1874 value
= mktime (&tm
);
1880 const char *tzstring
;
1881 char **oldenv
= environ
, **newenv
;
1885 else if (STRINGP (zone
))
1886 tzstring
= SSDATA (zone
);
1887 else if (INTEGERP (zone
))
1889 int abszone
= eabs (XINT (zone
));
1890 sprintf (tzbuf
, "XXX%s%d:%02d:%02d", "-" + (XINT (zone
) < 0),
1891 abszone
/ (60*60), (abszone
/60) % 60, abszone
% 60);
1895 error ("Invalid time zone specification");
1897 /* Set TZ before calling mktime; merely adjusting mktime's returned
1898 value doesn't suffice, since that would mishandle leap seconds. */
1899 set_time_zone_rule (tzstring
);
1902 value
= mktime (&tm
);
1905 /* Restore TZ to previous value. */
1909 #ifdef LOCALTIME_CACHE
1914 if (value
== (time_t) -1)
1917 return make_time (value
);
1920 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
1921 doc
: /* Return the current local time, as a human-readable string.
1922 Programs can use this function to decode a time,
1923 since the number of columns in each field is fixed
1924 if the year is in the range 1000-9999.
1925 The format is `Sun Sep 16 01:03:52 1973'.
1926 However, see also the functions `decode-time' and `format-time-string'
1927 which provide a much more powerful and general facility.
1929 If SPECIFIED-TIME is given, it is a time to format instead of the
1930 current time. The argument should have the form (HIGH LOW . IGNORED).
1931 Thus, you can use times obtained from `current-time' and from
1932 `file-attributes'. SPECIFIED-TIME can also have the form (HIGH . LOW),
1933 but this is considered obsolete. */)
1934 (Lisp_Object specified_time
)
1940 if (! lisp_time_argument (specified_time
, &value
, NULL
))
1941 error ("Invalid time specification");
1943 /* Convert to a string, checking for out-of-range time stamps.
1944 Don't use 'ctime', as that might dump core if VALUE is out of
1947 tm
= localtime (&value
);
1949 if (! (tm
&& TM_YEAR_IN_ASCTIME_RANGE (tm
->tm_year
) && (tem
= asctime (tm
))))
1952 /* Remove the trailing newline. */
1953 tem
[strlen (tem
) - 1] = '\0';
1955 return build_string (tem
);
1958 /* Yield A - B, measured in seconds.
1959 This function is copied from the GNU C Library. */
1961 tm_diff (struct tm
*a
, struct tm
*b
)
1963 /* Compute intervening leap days correctly even if year is negative.
1964 Take care to avoid int overflow in leap day calculations,
1965 but it's OK to assume that A and B are close to each other. */
1966 int a4
= (a
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (a
->tm_year
& 3);
1967 int b4
= (b
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (b
->tm_year
& 3);
1968 int a100
= a4
/ 25 - (a4
% 25 < 0);
1969 int b100
= b4
/ 25 - (b4
% 25 < 0);
1970 int a400
= a100
>> 2;
1971 int b400
= b100
>> 2;
1972 int intervening_leap_days
= (a4
- b4
) - (a100
- b100
) + (a400
- b400
);
1973 int years
= a
->tm_year
- b
->tm_year
;
1974 int days
= (365 * years
+ intervening_leap_days
1975 + (a
->tm_yday
- b
->tm_yday
));
1976 return (60 * (60 * (24 * days
+ (a
->tm_hour
- b
->tm_hour
))
1977 + (a
->tm_min
- b
->tm_min
))
1978 + (a
->tm_sec
- b
->tm_sec
));
1981 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
1982 doc
: /* Return the offset and name for the local time zone.
1983 This returns a list of the form (OFFSET NAME).
1984 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
1985 A negative value means west of Greenwich.
1986 NAME is a string giving the name of the time zone.
1987 If SPECIFIED-TIME is given, the time zone offset is determined from it
1988 instead of using the current time. The argument should have the form
1989 (HIGH LOW . IGNORED). Thus, you can use times obtained from
1990 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
1991 have the form (HIGH . LOW), but this is considered obsolete.
1993 Some operating systems cannot provide all this information to Emacs;
1994 in this case, `current-time-zone' returns a list containing nil for
1995 the data it can't find. */)
1996 (Lisp_Object specified_time
)
2002 if (!lisp_time_argument (specified_time
, &value
, NULL
))
2007 t
= gmtime (&value
);
2011 t
= localtime (&value
);
2018 int offset
= tm_diff (t
, &gmt
);
2024 s
= (char *)t
->tm_zone
;
2025 #else /* not HAVE_TM_ZONE */
2027 if (t
->tm_isdst
== 0 || t
->tm_isdst
== 1)
2028 s
= tzname
[t
->tm_isdst
];
2030 #endif /* not HAVE_TM_ZONE */
2034 /* No local time zone name is available; use "+-NNNN" instead. */
2035 int am
= (offset
< 0 ? -offset
: offset
) / 60;
2036 sprintf (buf
, "%c%02d%02d", (offset
< 0 ? '-' : '+'), am
/60, am
%60);
2040 return Fcons (make_number (offset
), Fcons (build_string (s
), Qnil
));
2043 return Fmake_list (make_number (2), Qnil
);
2046 /* This holds the value of `environ' produced by the previous
2047 call to Fset_time_zone_rule, or 0 if Fset_time_zone_rule
2048 has never been called. */
2049 static char **environbuf
;
2051 /* This holds the startup value of the TZ environment variable so it
2052 can be restored if the user calls set-time-zone-rule with a nil
2054 static char *initial_tz
;
2056 DEFUN ("set-time-zone-rule", Fset_time_zone_rule
, Sset_time_zone_rule
, 1, 1, 0,
2057 doc
: /* Set the local time zone using TZ, a string specifying a time zone rule.
2058 If TZ is nil, use implementation-defined default time zone information.
2059 If TZ is t, use Universal Time. */)
2062 const char *tzstring
;
2064 /* When called for the first time, save the original TZ. */
2066 initial_tz
= (char *) getenv ("TZ");
2069 tzstring
= initial_tz
;
2070 else if (EQ (tz
, Qt
))
2075 tzstring
= SSDATA (tz
);
2078 set_time_zone_rule (tzstring
);
2080 environbuf
= environ
;
2085 #ifdef LOCALTIME_CACHE
2087 /* These two values are known to load tz files in buggy implementations,
2088 i.e. Solaris 1 executables running under either Solaris 1 or Solaris 2.
2089 Their values shouldn't matter in non-buggy implementations.
2090 We don't use string literals for these strings,
2091 since if a string in the environment is in readonly
2092 storage, it runs afoul of bugs in SVR4 and Solaris 2.3.
2093 See Sun bugs 1113095 and 1114114, ``Timezone routines
2094 improperly modify environment''. */
2096 static char set_time_zone_rule_tz1
[] = "TZ=GMT+0";
2097 static char set_time_zone_rule_tz2
[] = "TZ=GMT+1";
2101 /* Set the local time zone rule to TZSTRING.
2102 This allocates memory into `environ', which it is the caller's
2103 responsibility to free. */
2106 set_time_zone_rule (const char *tzstring
)
2109 char **from
, **to
, **newenv
;
2111 /* Make the ENVIRON vector longer with room for TZSTRING. */
2112 for (from
= environ
; *from
; from
++)
2114 envptrs
= from
- environ
+ 2;
2115 newenv
= to
= (char **) xmalloc (envptrs
* sizeof (char *)
2116 + (tzstring
? strlen (tzstring
) + 4 : 0));
2118 /* Add TZSTRING to the end of environ, as a value for TZ. */
2121 char *t
= (char *) (to
+ envptrs
);
2123 strcat (t
, tzstring
);
2127 /* Copy the old environ vector elements into NEWENV,
2128 but don't copy the TZ variable.
2129 So we have only one definition of TZ, which came from TZSTRING. */
2130 for (from
= environ
; *from
; from
++)
2131 if (strncmp (*from
, "TZ=", 3) != 0)
2137 /* If we do have a TZSTRING, NEWENV points to the vector slot where
2138 the TZ variable is stored. If we do not have a TZSTRING,
2139 TO points to the vector slot which has the terminating null. */
2141 #ifdef LOCALTIME_CACHE
2143 /* In SunOS 4.1.3_U1 and 4.1.4, if TZ has a value like
2144 "US/Pacific" that loads a tz file, then changes to a value like
2145 "XXX0" that does not load a tz file, and then changes back to
2146 its original value, the last change is (incorrectly) ignored.
2147 Also, if TZ changes twice in succession to values that do
2148 not load a tz file, tzset can dump core (see Sun bug#1225179).
2149 The following code works around these bugs. */
2153 /* Temporarily set TZ to a value that loads a tz file
2154 and that differs from tzstring. */
2156 *newenv
= (strcmp (tzstring
, set_time_zone_rule_tz1
+ 3) == 0
2157 ? set_time_zone_rule_tz2
: set_time_zone_rule_tz1
);
2163 /* The implied tzstring is unknown, so temporarily set TZ to
2164 two different values that each load a tz file. */
2165 *to
= set_time_zone_rule_tz1
;
2168 *to
= set_time_zone_rule_tz2
;
2173 /* Now TZ has the desired value, and tzset can be invoked safely. */
2180 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
2181 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
2182 type of object is Lisp_String). INHERIT is passed to
2183 INSERT_FROM_STRING_FUNC as the last argument. */
2186 general_insert_function (void (*insert_func
)
2187 (const char *, EMACS_INT
),
2188 void (*insert_from_string_func
)
2189 (Lisp_Object
, EMACS_INT
, EMACS_INT
,
2190 EMACS_INT
, EMACS_INT
, int),
2191 int inherit
, ptrdiff_t nargs
, Lisp_Object
*args
)
2194 register Lisp_Object val
;
2196 for (argnum
= 0; argnum
< nargs
; argnum
++)
2199 if (CHARACTERP (val
))
2201 int c
= XFASTINT (val
);
2202 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2205 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2206 len
= CHAR_STRING (c
, str
);
2209 str
[0] = ASCII_CHAR_P (c
) ? c
: multibyte_char_to_unibyte (c
);
2212 (*insert_func
) ((char *) str
, len
);
2214 else if (STRINGP (val
))
2216 (*insert_from_string_func
) (val
, 0, 0,
2222 wrong_type_argument (Qchar_or_string_p
, val
);
2227 insert1 (Lisp_Object arg
)
2233 /* Callers passing one argument to Finsert need not gcpro the
2234 argument "array", since the only element of the array will
2235 not be used after calling insert or insert_from_string, so
2236 we don't care if it gets trashed. */
2238 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
2239 doc
: /* Insert the arguments, either strings or characters, at point.
2240 Point and before-insertion markers move forward to end up
2241 after the inserted text.
2242 Any other markers at the point of insertion remain before the text.
2244 If the current buffer is multibyte, unibyte strings are converted
2245 to multibyte for insertion (see `string-make-multibyte').
2246 If the current buffer is unibyte, multibyte strings are converted
2247 to unibyte for insertion (see `string-make-unibyte').
2249 When operating on binary data, it may be necessary to preserve the
2250 original bytes of a unibyte string when inserting it into a multibyte
2251 buffer; to accomplish this, apply `string-as-multibyte' to the string
2252 and insert the result.
2254 usage: (insert &rest ARGS) */)
2255 (ptrdiff_t nargs
, Lisp_Object
*args
)
2257 general_insert_function (insert
, insert_from_string
, 0, nargs
, args
);
2261 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
2263 doc
: /* Insert the arguments at point, inheriting properties from adjoining text.
2264 Point and before-insertion markers move forward to end up
2265 after the inserted text.
2266 Any other markers at the point of insertion remain before the text.
2268 If the current buffer is multibyte, unibyte strings are converted
2269 to multibyte for insertion (see `unibyte-char-to-multibyte').
2270 If the current buffer is unibyte, multibyte strings are converted
2271 to unibyte for insertion.
2273 usage: (insert-and-inherit &rest ARGS) */)
2274 (ptrdiff_t nargs
, Lisp_Object
*args
)
2276 general_insert_function (insert_and_inherit
, insert_from_string
, 1,
2281 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
2282 doc
: /* Insert strings or characters at point, relocating markers after the text.
2283 Point and markers move forward to end up after the inserted text.
2285 If the current buffer is multibyte, unibyte strings are converted
2286 to multibyte for insertion (see `unibyte-char-to-multibyte').
2287 If the current buffer is unibyte, multibyte strings are converted
2288 to unibyte for insertion.
2290 usage: (insert-before-markers &rest ARGS) */)
2291 (ptrdiff_t nargs
, Lisp_Object
*args
)
2293 general_insert_function (insert_before_markers
,
2294 insert_from_string_before_markers
, 0,
2299 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers
,
2300 Sinsert_and_inherit_before_markers
, 0, MANY
, 0,
2301 doc
: /* Insert text at point, relocating markers and inheriting properties.
2302 Point and markers move forward to end up after the inserted text.
2304 If the current buffer is multibyte, unibyte strings are converted
2305 to multibyte for insertion (see `unibyte-char-to-multibyte').
2306 If the current buffer is unibyte, multibyte strings are converted
2307 to unibyte for insertion.
2309 usage: (insert-before-markers-and-inherit &rest ARGS) */)
2310 (ptrdiff_t nargs
, Lisp_Object
*args
)
2312 general_insert_function (insert_before_markers_and_inherit
,
2313 insert_from_string_before_markers
, 1,
2318 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 2, 3, 0,
2319 doc
: /* Insert COUNT copies of CHARACTER.
2320 Point, and before-insertion markers, are relocated as in the function `insert'.
2321 The optional third arg INHERIT, if non-nil, says to inherit text properties
2322 from adjoining text, if those properties are sticky. */)
2323 (Lisp_Object character
, Lisp_Object count
, Lisp_Object inherit
)
2326 register EMACS_INT n
;
2328 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2331 CHECK_CHARACTER (character
);
2332 CHECK_NUMBER (count
);
2333 c
= XFASTINT (character
);
2335 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2336 len
= CHAR_STRING (c
, str
);
2338 str
[0] = c
, len
= 1;
2339 if (XINT (count
) <= 0)
2341 if (BUF_BYTES_MAX
/ len
< XINT (count
))
2343 n
= XINT (count
) * len
;
2344 stringlen
= min (n
, sizeof string
- sizeof string
% len
);
2345 for (i
= 0; i
< stringlen
; i
++)
2346 string
[i
] = str
[i
% len
];
2347 while (n
> stringlen
)
2350 if (!NILP (inherit
))
2351 insert_and_inherit (string
, stringlen
);
2353 insert (string
, stringlen
);
2356 if (!NILP (inherit
))
2357 insert_and_inherit (string
, n
);
2363 DEFUN ("insert-byte", Finsert_byte
, Sinsert_byte
, 2, 3, 0,
2364 doc
: /* Insert COUNT (second arg) copies of BYTE (first arg).
2365 Both arguments are required.
2366 BYTE is a number of the range 0..255.
2368 If BYTE is 128..255 and the current buffer is multibyte, the
2369 corresponding eight-bit character is inserted.
2371 Point, and before-insertion markers, are relocated as in the function `insert'.
2372 The optional third arg INHERIT, if non-nil, says to inherit text properties
2373 from adjoining text, if those properties are sticky. */)
2374 (Lisp_Object byte
, Lisp_Object count
, Lisp_Object inherit
)
2376 CHECK_NUMBER (byte
);
2377 if (XINT (byte
) < 0 || XINT (byte
) > 255)
2378 args_out_of_range_3 (byte
, make_number (0), make_number (255));
2379 if (XINT (byte
) >= 128
2380 && ! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2381 XSETFASTINT (byte
, BYTE8_TO_CHAR (XINT (byte
)));
2382 return Finsert_char (byte
, count
, inherit
);
2386 /* Making strings from buffer contents. */
2388 /* Return a Lisp_String containing the text of the current buffer from
2389 START to END. If text properties are in use and the current buffer
2390 has properties in the range specified, the resulting string will also
2391 have them, if PROPS is nonzero.
2393 We don't want to use plain old make_string here, because it calls
2394 make_uninit_string, which can cause the buffer arena to be
2395 compacted. make_string has no way of knowing that the data has
2396 been moved, and thus copies the wrong data into the string. This
2397 doesn't effect most of the other users of make_string, so it should
2398 be left as is. But we should use this function when conjuring
2399 buffer substrings. */
2402 make_buffer_string (EMACS_INT start
, EMACS_INT end
, int props
)
2404 EMACS_INT start_byte
= CHAR_TO_BYTE (start
);
2405 EMACS_INT end_byte
= CHAR_TO_BYTE (end
);
2407 return make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
);
2410 /* Return a Lisp_String containing the text of the current buffer from
2411 START / START_BYTE to END / END_BYTE.
2413 If text properties are in use and the current buffer
2414 has properties in the range specified, the resulting string will also
2415 have them, if PROPS is nonzero.
2417 We don't want to use plain old make_string here, because it calls
2418 make_uninit_string, which can cause the buffer arena to be
2419 compacted. make_string has no way of knowing that the data has
2420 been moved, and thus copies the wrong data into the string. This
2421 doesn't effect most of the other users of make_string, so it should
2422 be left as is. But we should use this function when conjuring
2423 buffer substrings. */
2426 make_buffer_string_both (EMACS_INT start
, EMACS_INT start_byte
,
2427 EMACS_INT end
, EMACS_INT end_byte
, int props
)
2429 Lisp_Object result
, tem
, tem1
;
2431 if (start
< GPT
&& GPT
< end
)
2434 if (! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2435 result
= make_uninit_multibyte_string (end
- start
, end_byte
- start_byte
);
2437 result
= make_uninit_string (end
- start
);
2438 memcpy (SDATA (result
), BYTE_POS_ADDR (start_byte
), end_byte
- start_byte
);
2440 /* If desired, update and copy the text properties. */
2443 update_buffer_properties (start
, end
);
2445 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
2446 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
2448 if (XINT (tem
) != end
|| !NILP (tem1
))
2449 copy_intervals_to_string (result
, current_buffer
, start
,
2456 /* Call Vbuffer_access_fontify_functions for the range START ... END
2457 in the current buffer, if necessary. */
2460 update_buffer_properties (EMACS_INT start
, EMACS_INT end
)
2462 /* If this buffer has some access functions,
2463 call them, specifying the range of the buffer being accessed. */
2464 if (!NILP (Vbuffer_access_fontify_functions
))
2466 Lisp_Object args
[3];
2469 args
[0] = Qbuffer_access_fontify_functions
;
2470 XSETINT (args
[1], start
);
2471 XSETINT (args
[2], end
);
2473 /* But don't call them if we can tell that the work
2474 has already been done. */
2475 if (!NILP (Vbuffer_access_fontified_property
))
2477 tem
= Ftext_property_any (args
[1], args
[2],
2478 Vbuffer_access_fontified_property
,
2481 Frun_hook_with_args (3, args
);
2484 Frun_hook_with_args (3, args
);
2488 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
2489 doc
: /* Return the contents of part of the current buffer as a string.
2490 The two arguments START and END are character positions;
2491 they can be in either order.
2492 The string returned is multibyte if the buffer is multibyte.
2494 This function copies the text properties of that part of the buffer
2495 into the result string; if you don't want the text properties,
2496 use `buffer-substring-no-properties' instead. */)
2497 (Lisp_Object start
, Lisp_Object end
)
2499 register EMACS_INT b
, e
;
2501 validate_region (&start
, &end
);
2505 return make_buffer_string (b
, e
, 1);
2508 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties
,
2509 Sbuffer_substring_no_properties
, 2, 2, 0,
2510 doc
: /* Return the characters of part of the buffer, without the text properties.
2511 The two arguments START and END are character positions;
2512 they can be in either order. */)
2513 (Lisp_Object start
, Lisp_Object end
)
2515 register EMACS_INT b
, e
;
2517 validate_region (&start
, &end
);
2521 return make_buffer_string (b
, e
, 0);
2524 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
2525 doc
: /* Return the contents of the current buffer as a string.
2526 If narrowing is in effect, this function returns only the visible part
2530 return make_buffer_string (BEGV
, ZV
, 1);
2533 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
2535 doc
: /* Insert before point a substring of the contents of BUFFER.
2536 BUFFER may be a buffer or a buffer name.
2537 Arguments START and END are character positions specifying the substring.
2538 They default to the values of (point-min) and (point-max) in BUFFER. */)
2539 (Lisp_Object buffer
, Lisp_Object start
, Lisp_Object end
)
2541 register EMACS_INT b
, e
, temp
;
2542 register struct buffer
*bp
, *obuf
;
2545 buf
= Fget_buffer (buffer
);
2549 if (NILP (BVAR (bp
, name
)))
2550 error ("Selecting deleted buffer");
2556 CHECK_NUMBER_COERCE_MARKER (start
);
2563 CHECK_NUMBER_COERCE_MARKER (end
);
2568 temp
= b
, b
= e
, e
= temp
;
2570 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
2571 args_out_of_range (start
, end
);
2573 obuf
= current_buffer
;
2574 set_buffer_internal_1 (bp
);
2575 update_buffer_properties (b
, e
);
2576 set_buffer_internal_1 (obuf
);
2578 insert_from_buffer (bp
, b
, e
- b
, 0);
2582 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
2584 doc
: /* Compare two substrings of two buffers; return result as number.
2585 the value is -N if first string is less after N-1 chars,
2586 +N if first string is greater after N-1 chars, or 0 if strings match.
2587 Each substring is represented as three arguments: BUFFER, START and END.
2588 That makes six args in all, three for each substring.
2590 The value of `case-fold-search' in the current buffer
2591 determines whether case is significant or ignored. */)
2592 (Lisp_Object buffer1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object buffer2
, Lisp_Object start2
, Lisp_Object end2
)
2594 register EMACS_INT begp1
, endp1
, begp2
, endp2
, temp
;
2595 register struct buffer
*bp1
, *bp2
;
2596 register Lisp_Object trt
2597 = (!NILP (BVAR (current_buffer
, case_fold_search
))
2598 ? BVAR (current_buffer
, case_canon_table
) : Qnil
);
2599 EMACS_INT chars
= 0;
2600 EMACS_INT i1
, i2
, i1_byte
, i2_byte
;
2602 /* Find the first buffer and its substring. */
2605 bp1
= current_buffer
;
2609 buf1
= Fget_buffer (buffer1
);
2612 bp1
= XBUFFER (buf1
);
2613 if (NILP (BVAR (bp1
, name
)))
2614 error ("Selecting deleted buffer");
2618 begp1
= BUF_BEGV (bp1
);
2621 CHECK_NUMBER_COERCE_MARKER (start1
);
2622 begp1
= XINT (start1
);
2625 endp1
= BUF_ZV (bp1
);
2628 CHECK_NUMBER_COERCE_MARKER (end1
);
2629 endp1
= XINT (end1
);
2633 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
2635 if (!(BUF_BEGV (bp1
) <= begp1
2637 && endp1
<= BUF_ZV (bp1
)))
2638 args_out_of_range (start1
, end1
);
2640 /* Likewise for second substring. */
2643 bp2
= current_buffer
;
2647 buf2
= Fget_buffer (buffer2
);
2650 bp2
= XBUFFER (buf2
);
2651 if (NILP (BVAR (bp2
, name
)))
2652 error ("Selecting deleted buffer");
2656 begp2
= BUF_BEGV (bp2
);
2659 CHECK_NUMBER_COERCE_MARKER (start2
);
2660 begp2
= XINT (start2
);
2663 endp2
= BUF_ZV (bp2
);
2666 CHECK_NUMBER_COERCE_MARKER (end2
);
2667 endp2
= XINT (end2
);
2671 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
2673 if (!(BUF_BEGV (bp2
) <= begp2
2675 && endp2
<= BUF_ZV (bp2
)))
2676 args_out_of_range (start2
, end2
);
2680 i1_byte
= buf_charpos_to_bytepos (bp1
, i1
);
2681 i2_byte
= buf_charpos_to_bytepos (bp2
, i2
);
2683 while (i1
< endp1
&& i2
< endp2
)
2685 /* When we find a mismatch, we must compare the
2686 characters, not just the bytes. */
2691 if (! NILP (BVAR (bp1
, enable_multibyte_characters
)))
2693 c1
= BUF_FETCH_MULTIBYTE_CHAR (bp1
, i1_byte
);
2694 BUF_INC_POS (bp1
, i1_byte
);
2699 c1
= BUF_FETCH_BYTE (bp1
, i1
);
2700 MAKE_CHAR_MULTIBYTE (c1
);
2704 if (! NILP (BVAR (bp2
, enable_multibyte_characters
)))
2706 c2
= BUF_FETCH_MULTIBYTE_CHAR (bp2
, i2_byte
);
2707 BUF_INC_POS (bp2
, i2_byte
);
2712 c2
= BUF_FETCH_BYTE (bp2
, i2
);
2713 MAKE_CHAR_MULTIBYTE (c2
);
2719 c1
= CHAR_TABLE_TRANSLATE (trt
, c1
);
2720 c2
= CHAR_TABLE_TRANSLATE (trt
, c2
);
2723 return make_number (- 1 - chars
);
2725 return make_number (chars
+ 1);
2730 /* The strings match as far as they go.
2731 If one is shorter, that one is less. */
2732 if (chars
< endp1
- begp1
)
2733 return make_number (chars
+ 1);
2734 else if (chars
< endp2
- begp2
)
2735 return make_number (- chars
- 1);
2737 /* Same length too => they are equal. */
2738 return make_number (0);
2742 subst_char_in_region_unwind (Lisp_Object arg
)
2744 return BVAR (current_buffer
, undo_list
) = arg
;
2748 subst_char_in_region_unwind_1 (Lisp_Object arg
)
2750 return BVAR (current_buffer
, filename
) = arg
;
2753 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
2754 Ssubst_char_in_region
, 4, 5, 0,
2755 doc
: /* From START to END, replace FROMCHAR with TOCHAR each time it occurs.
2756 If optional arg NOUNDO is non-nil, don't record this change for undo
2757 and don't mark the buffer as really changed.
2758 Both characters must have the same length of multi-byte form. */)
2759 (Lisp_Object start
, Lisp_Object end
, Lisp_Object fromchar
, Lisp_Object tochar
, Lisp_Object noundo
)
2761 register EMACS_INT pos
, pos_byte
, stop
, i
, len
, end_byte
;
2762 /* Keep track of the first change in the buffer:
2763 if 0 we haven't found it yet.
2764 if < 0 we've found it and we've run the before-change-function.
2765 if > 0 we've actually performed it and the value is its position. */
2766 EMACS_INT changed
= 0;
2767 unsigned char fromstr
[MAX_MULTIBYTE_LENGTH
], tostr
[MAX_MULTIBYTE_LENGTH
];
2769 int count
= SPECPDL_INDEX ();
2770 #define COMBINING_NO 0
2771 #define COMBINING_BEFORE 1
2772 #define COMBINING_AFTER 2
2773 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
2774 int maybe_byte_combining
= COMBINING_NO
;
2775 EMACS_INT last_changed
= 0;
2776 int multibyte_p
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
2781 validate_region (&start
, &end
);
2782 CHECK_CHARACTER (fromchar
);
2783 CHECK_CHARACTER (tochar
);
2784 fromc
= XFASTINT (fromchar
);
2785 toc
= XFASTINT (tochar
);
2789 len
= CHAR_STRING (fromc
, fromstr
);
2790 if (CHAR_STRING (toc
, tostr
) != len
)
2791 error ("Characters in `subst-char-in-region' have different byte-lengths");
2792 if (!ASCII_BYTE_P (*tostr
))
2794 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
2795 complete multibyte character, it may be combined with the
2796 after bytes. If it is in the range 0xA0..0xFF, it may be
2797 combined with the before and after bytes. */
2798 if (!CHAR_HEAD_P (*tostr
))
2799 maybe_byte_combining
= COMBINING_BOTH
;
2800 else if (BYTES_BY_CHAR_HEAD (*tostr
) > len
)
2801 maybe_byte_combining
= COMBINING_AFTER
;
2812 pos_byte
= CHAR_TO_BYTE (pos
);
2813 stop
= CHAR_TO_BYTE (XINT (end
));
2816 /* If we don't want undo, turn off putting stuff on the list.
2817 That's faster than getting rid of things,
2818 and it prevents even the entry for a first change.
2819 Also inhibit locking the file. */
2820 if (!changed
&& !NILP (noundo
))
2822 record_unwind_protect (subst_char_in_region_unwind
,
2823 BVAR (current_buffer
, undo_list
));
2824 BVAR (current_buffer
, undo_list
) = Qt
;
2825 /* Don't do file-locking. */
2826 record_unwind_protect (subst_char_in_region_unwind_1
,
2827 BVAR (current_buffer
, filename
));
2828 BVAR (current_buffer
, filename
) = Qnil
;
2831 if (pos_byte
< GPT_BYTE
)
2832 stop
= min (stop
, GPT_BYTE
);
2835 EMACS_INT pos_byte_next
= pos_byte
;
2837 if (pos_byte
>= stop
)
2839 if (pos_byte
>= end_byte
) break;
2842 p
= BYTE_POS_ADDR (pos_byte
);
2844 INC_POS (pos_byte_next
);
2847 if (pos_byte_next
- pos_byte
== len
2848 && p
[0] == fromstr
[0]
2850 || (p
[1] == fromstr
[1]
2851 && (len
== 2 || (p
[2] == fromstr
[2]
2852 && (len
== 3 || p
[3] == fromstr
[3]))))))
2855 /* We've already seen this and run the before-change-function;
2856 this time we only need to record the actual position. */
2861 modify_region (current_buffer
, pos
, XINT (end
), 0);
2863 if (! NILP (noundo
))
2865 if (MODIFF
- 1 == SAVE_MODIFF
)
2867 if (MODIFF
- 1 == BUF_AUTOSAVE_MODIFF (current_buffer
))
2868 BUF_AUTOSAVE_MODIFF (current_buffer
)++;
2871 /* The before-change-function may have moved the gap
2872 or even modified the buffer so we should start over. */
2876 /* Take care of the case where the new character
2877 combines with neighboring bytes. */
2878 if (maybe_byte_combining
2879 && (maybe_byte_combining
== COMBINING_AFTER
2880 ? (pos_byte_next
< Z_BYTE
2881 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2882 : ((pos_byte_next
< Z_BYTE
2883 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2884 || (pos_byte
> BEG_BYTE
2885 && ! ASCII_BYTE_P (FETCH_BYTE (pos_byte
- 1))))))
2887 Lisp_Object tem
, string
;
2889 struct gcpro gcpro1
;
2891 tem
= BVAR (current_buffer
, undo_list
);
2894 /* Make a multibyte string containing this single character. */
2895 string
= make_multibyte_string ((char *) tostr
, 1, len
);
2896 /* replace_range is less efficient, because it moves the gap,
2897 but it handles combining correctly. */
2898 replace_range (pos
, pos
+ 1, string
,
2900 pos_byte_next
= CHAR_TO_BYTE (pos
);
2901 if (pos_byte_next
> pos_byte
)
2902 /* Before combining happened. We should not increment
2903 POS. So, to cancel the later increment of POS,
2907 INC_POS (pos_byte_next
);
2909 if (! NILP (noundo
))
2910 BVAR (current_buffer
, undo_list
) = tem
;
2917 record_change (pos
, 1);
2918 for (i
= 0; i
< len
; i
++) *p
++ = tostr
[i
];
2920 last_changed
= pos
+ 1;
2922 pos_byte
= pos_byte_next
;
2928 signal_after_change (changed
,
2929 last_changed
- changed
, last_changed
- changed
);
2930 update_compositions (changed
, last_changed
, CHECK_ALL
);
2933 unbind_to (count
, Qnil
);
2938 static Lisp_Object
check_translation (EMACS_INT
, EMACS_INT
, EMACS_INT
,
2941 /* Helper function for Ftranslate_region_internal.
2943 Check if a character sequence at POS (POS_BYTE) matches an element
2944 of VAL. VAL is a list (([FROM-CHAR ...] . TO) ...). If a matching
2945 element is found, return it. Otherwise return Qnil. */
2948 check_translation (EMACS_INT pos
, EMACS_INT pos_byte
, EMACS_INT end
,
2951 int buf_size
= 16, buf_used
= 0;
2952 int *buf
= alloca (sizeof (int) * buf_size
);
2954 for (; CONSP (val
); val
= XCDR (val
))
2963 if (! VECTORP (elt
))
2966 if (len
<= end
- pos
)
2968 for (i
= 0; i
< len
; i
++)
2972 unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
2975 if (buf_used
== buf_size
)
2980 newbuf
= alloca (sizeof (int) * buf_size
);
2981 memcpy (newbuf
, buf
, sizeof (int) * buf_used
);
2984 buf
[buf_used
++] = STRING_CHAR_AND_LENGTH (p
, len1
);
2987 if (XINT (AREF (elt
, i
)) != buf
[i
])
2998 DEFUN ("translate-region-internal", Ftranslate_region_internal
,
2999 Stranslate_region_internal
, 3, 3, 0,
3000 doc
: /* Internal use only.
3001 From START to END, translate characters according to TABLE.
3002 TABLE is a string or a char-table; the Nth character in it is the
3003 mapping for the character with code N.
3004 It returns the number of characters changed. */)
3005 (Lisp_Object start
, Lisp_Object end
, register Lisp_Object table
)
3007 register unsigned char *tt
; /* Trans table. */
3008 register int nc
; /* New character. */
3009 int cnt
; /* Number of changes made. */
3010 EMACS_INT size
; /* Size of translate table. */
3011 EMACS_INT pos
, pos_byte
, end_pos
;
3012 int multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3013 int string_multibyte
IF_LINT (= 0);
3015 validate_region (&start
, &end
);
3016 if (CHAR_TABLE_P (table
))
3018 if (! EQ (XCHAR_TABLE (table
)->purpose
, Qtranslation_table
))
3019 error ("Not a translation table");
3025 CHECK_STRING (table
);
3027 if (! multibyte
&& (SCHARS (table
) < SBYTES (table
)))
3028 table
= string_make_unibyte (table
);
3029 string_multibyte
= SCHARS (table
) < SBYTES (table
);
3030 size
= SBYTES (table
);
3035 pos_byte
= CHAR_TO_BYTE (pos
);
3036 end_pos
= XINT (end
);
3037 modify_region (current_buffer
, pos
, end_pos
, 0);
3040 for (; pos
< end_pos
; )
3042 register unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
3043 unsigned char *str
, buf
[MAX_MULTIBYTE_LENGTH
];
3049 oc
= STRING_CHAR_AND_LENGTH (p
, len
);
3056 /* Reload as signal_after_change in last iteration may GC. */
3058 if (string_multibyte
)
3060 str
= tt
+ string_char_to_byte (table
, oc
);
3061 nc
= STRING_CHAR_AND_LENGTH (str
, str_len
);
3066 if (! ASCII_BYTE_P (nc
) && multibyte
)
3068 str_len
= BYTE8_STRING (nc
, buf
);
3081 val
= CHAR_TABLE_REF (table
, oc
);
3082 if (CHARACTERP (val
))
3084 nc
= XFASTINT (val
);
3085 str_len
= CHAR_STRING (nc
, buf
);
3088 else if (VECTORP (val
) || (CONSP (val
)))
3090 /* VAL is [TO_CHAR ...] or (([FROM-CHAR ...] . TO) ...)
3091 where TO is TO-CHAR or [TO-CHAR ...]. */
3096 if (nc
!= oc
&& nc
>= 0)
3098 /* Simple one char to one char translation. */
3103 /* This is less efficient, because it moves the gap,
3104 but it should handle multibyte characters correctly. */
3105 string
= make_multibyte_string ((char *) str
, 1, str_len
);
3106 replace_range (pos
, pos
+ 1, string
, 1, 0, 1);
3111 record_change (pos
, 1);
3112 while (str_len
-- > 0)
3114 signal_after_change (pos
, 1, 1);
3115 update_compositions (pos
, pos
+ 1, CHECK_BORDER
);
3125 val
= check_translation (pos
, pos_byte
, end_pos
, val
);
3132 /* VAL is ([FROM-CHAR ...] . TO). */
3133 len
= ASIZE (XCAR (val
));
3141 string
= Fconcat (1, &val
);
3145 string
= Fmake_string (make_number (1), val
);
3147 replace_range (pos
, pos
+ len
, string
, 1, 0, 1);
3148 pos_byte
+= SBYTES (string
);
3149 pos
+= SCHARS (string
);
3150 cnt
+= SCHARS (string
);
3151 end_pos
+= SCHARS (string
) - len
;
3159 return make_number (cnt
);
3162 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
3163 doc
: /* Delete the text between START and END.
3164 If called interactively, delete the region between point and mark. */)
3165 (Lisp_Object start
, Lisp_Object end
)
3167 validate_region (&start
, &end
);
3168 del_range (XINT (start
), XINT (end
));
3172 DEFUN ("delete-and-extract-region", Fdelete_and_extract_region
,
3173 Sdelete_and_extract_region
, 2, 2, 0,
3174 doc
: /* Delete the text between START and END and return it. */)
3175 (Lisp_Object start
, Lisp_Object end
)
3177 validate_region (&start
, &end
);
3178 if (XINT (start
) == XINT (end
))
3179 return empty_unibyte_string
;
3180 return del_range_1 (XINT (start
), XINT (end
), 1, 1);
3183 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
3184 doc
: /* Remove restrictions (narrowing) from current buffer.
3185 This allows the buffer's full text to be seen and edited. */)
3188 if (BEG
!= BEGV
|| Z
!= ZV
)
3189 current_buffer
->clip_changed
= 1;
3191 BEGV_BYTE
= BEG_BYTE
;
3192 SET_BUF_ZV_BOTH (current_buffer
, Z
, Z_BYTE
);
3193 /* Changing the buffer bounds invalidates any recorded current column. */
3194 invalidate_current_column ();
3198 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
3199 doc
: /* Restrict editing in this buffer to the current region.
3200 The rest of the text becomes temporarily invisible and untouchable
3201 but is not deleted; if you save the buffer in a file, the invisible
3202 text is included in the file. \\[widen] makes all visible again.
3203 See also `save-restriction'.
3205 When calling from a program, pass two arguments; positions (integers
3206 or markers) bounding the text that should remain visible. */)
3207 (register Lisp_Object start
, Lisp_Object end
)
3209 CHECK_NUMBER_COERCE_MARKER (start
);
3210 CHECK_NUMBER_COERCE_MARKER (end
);
3212 if (XINT (start
) > XINT (end
))
3215 tem
= start
; start
= end
; end
= tem
;
3218 if (!(BEG
<= XINT (start
) && XINT (start
) <= XINT (end
) && XINT (end
) <= Z
))
3219 args_out_of_range (start
, end
);
3221 if (BEGV
!= XFASTINT (start
) || ZV
!= XFASTINT (end
))
3222 current_buffer
->clip_changed
= 1;
3224 SET_BUF_BEGV (current_buffer
, XFASTINT (start
));
3225 SET_BUF_ZV (current_buffer
, XFASTINT (end
));
3226 if (PT
< XFASTINT (start
))
3227 SET_PT (XFASTINT (start
));
3228 if (PT
> XFASTINT (end
))
3229 SET_PT (XFASTINT (end
));
3230 /* Changing the buffer bounds invalidates any recorded current column. */
3231 invalidate_current_column ();
3236 save_restriction_save (void)
3238 if (BEGV
== BEG
&& ZV
== Z
)
3239 /* The common case that the buffer isn't narrowed.
3240 We return just the buffer object, which save_restriction_restore
3241 recognizes as meaning `no restriction'. */
3242 return Fcurrent_buffer ();
3244 /* We have to save a restriction, so return a pair of markers, one
3245 for the beginning and one for the end. */
3247 Lisp_Object beg
, end
;
3249 beg
= buildmark (BEGV
, BEGV_BYTE
);
3250 end
= buildmark (ZV
, ZV_BYTE
);
3252 /* END must move forward if text is inserted at its exact location. */
3253 XMARKER(end
)->insertion_type
= 1;
3255 return Fcons (beg
, end
);
3260 save_restriction_restore (Lisp_Object data
)
3262 struct buffer
*cur
= NULL
;
3263 struct buffer
*buf
= (CONSP (data
)
3264 ? XMARKER (XCAR (data
))->buffer
3267 if (buf
&& buf
!= current_buffer
&& !NILP (BVAR (buf
, pt_marker
)))
3268 { /* If `buf' uses markers to keep track of PT, BEGV, and ZV (as
3269 is the case if it is or has an indirect buffer), then make
3270 sure it is current before we update BEGV, so
3271 set_buffer_internal takes care of managing those markers. */
3272 cur
= current_buffer
;
3273 set_buffer_internal (buf
);
3277 /* A pair of marks bounding a saved restriction. */
3279 struct Lisp_Marker
*beg
= XMARKER (XCAR (data
));
3280 struct Lisp_Marker
*end
= XMARKER (XCDR (data
));
3281 eassert (buf
== end
->buffer
);
3283 if (buf
/* Verify marker still points to a buffer. */
3284 && (beg
->charpos
!= BUF_BEGV (buf
) || end
->charpos
!= BUF_ZV (buf
)))
3285 /* The restriction has changed from the saved one, so restore
3286 the saved restriction. */
3288 EMACS_INT pt
= BUF_PT (buf
);
3290 SET_BUF_BEGV_BOTH (buf
, beg
->charpos
, beg
->bytepos
);
3291 SET_BUF_ZV_BOTH (buf
, end
->charpos
, end
->bytepos
);
3293 if (pt
< beg
->charpos
|| pt
> end
->charpos
)
3294 /* The point is outside the new visible range, move it inside. */
3295 SET_BUF_PT_BOTH (buf
,
3296 clip_to_bounds (beg
->charpos
, pt
, end
->charpos
),
3297 clip_to_bounds (beg
->bytepos
, BUF_PT_BYTE (buf
),
3300 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3304 /* A buffer, which means that there was no old restriction. */
3306 if (buf
/* Verify marker still points to a buffer. */
3307 && (BUF_BEGV (buf
) != BUF_BEG (buf
) || BUF_ZV (buf
) != BUF_Z (buf
)))
3308 /* The buffer has been narrowed, get rid of the narrowing. */
3310 SET_BUF_BEGV_BOTH (buf
, BUF_BEG (buf
), BUF_BEG_BYTE (buf
));
3311 SET_BUF_ZV_BOTH (buf
, BUF_Z (buf
), BUF_Z_BYTE (buf
));
3313 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3317 /* Changing the buffer bounds invalidates any recorded current column. */
3318 invalidate_current_column ();
3321 set_buffer_internal (cur
);
3326 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
3327 doc
: /* Execute BODY, saving and restoring current buffer's restrictions.
3328 The buffer's restrictions make parts of the beginning and end invisible.
3329 \(They are set up with `narrow-to-region' and eliminated with `widen'.)
3330 This special form, `save-restriction', saves the current buffer's restrictions
3331 when it is entered, and restores them when it is exited.
3332 So any `narrow-to-region' within BODY lasts only until the end of the form.
3333 The old restrictions settings are restored
3334 even in case of abnormal exit (throw or error).
3336 The value returned is the value of the last form in BODY.
3338 Note: if you are using both `save-excursion' and `save-restriction',
3339 use `save-excursion' outermost:
3340 (save-excursion (save-restriction ...))
3342 usage: (save-restriction &rest BODY) */)
3345 register Lisp_Object val
;
3346 int count
= SPECPDL_INDEX ();
3348 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
3349 val
= Fprogn (body
);
3350 return unbind_to (count
, val
);
3353 /* Buffer for the most recent text displayed by Fmessage_box. */
3354 static char *message_text
;
3356 /* Allocated length of that buffer. */
3357 static int message_length
;
3359 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
3360 doc
: /* Display a message at the bottom of the screen.
3361 The message also goes into the `*Messages*' buffer.
3362 \(In keyboard macros, that's all it does.)
3365 The first argument is a format control string, and the rest are data
3366 to be formatted under control of the string. See `format' for details.
3368 Note: Use (message "%s" VALUE) to print the value of expressions and
3369 variables to avoid accidentally interpreting `%' as format specifiers.
3371 If the first argument is nil or the empty string, the function clears
3372 any existing message; this lets the minibuffer contents show. See
3373 also `current-message'.
3375 usage: (message FORMAT-STRING &rest ARGS) */)
3376 (ptrdiff_t nargs
, Lisp_Object
*args
)
3379 || (STRINGP (args
[0])
3380 && SBYTES (args
[0]) == 0))
3387 register Lisp_Object val
;
3388 val
= Fformat (nargs
, args
);
3389 message3 (val
, SBYTES (val
), STRING_MULTIBYTE (val
));
3394 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
3395 doc
: /* Display a message, in a dialog box if possible.
3396 If a dialog box is not available, use the echo area.
3397 The first argument is a format control string, and the rest are data
3398 to be formatted under control of the string. See `format' for details.
3400 If the first argument is nil or the empty string, clear any existing
3401 message; let the minibuffer contents show.
3403 usage: (message-box FORMAT-STRING &rest ARGS) */)
3404 (ptrdiff_t nargs
, Lisp_Object
*args
)
3413 register Lisp_Object val
;
3414 val
= Fformat (nargs
, args
);
3416 /* The MS-DOS frames support popup menus even though they are
3417 not FRAME_WINDOW_P. */
3418 if (FRAME_WINDOW_P (XFRAME (selected_frame
))
3419 || FRAME_MSDOS_P (XFRAME (selected_frame
)))
3421 Lisp_Object pane
, menu
;
3422 struct gcpro gcpro1
;
3423 pane
= Fcons (Fcons (build_string ("OK"), Qt
), Qnil
);
3425 menu
= Fcons (val
, pane
);
3426 Fx_popup_dialog (Qt
, menu
, Qt
);
3430 #endif /* HAVE_MENUS */
3431 /* Copy the data so that it won't move when we GC. */
3434 message_text
= (char *)xmalloc (80);
3435 message_length
= 80;
3437 if (SBYTES (val
) > message_length
)
3439 message_length
= SBYTES (val
);
3440 message_text
= (char *)xrealloc (message_text
, message_length
);
3442 memcpy (message_text
, SDATA (val
), SBYTES (val
));
3443 message2 (message_text
, SBYTES (val
),
3444 STRING_MULTIBYTE (val
));
3449 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
3450 doc
: /* Display a message in a dialog box or in the echo area.
3451 If this command was invoked with the mouse, use a dialog box if
3452 `use-dialog-box' is non-nil.
3453 Otherwise, use the echo area.
3454 The first argument is a format control string, and the rest are data
3455 to be formatted under control of the string. See `format' for details.
3457 If the first argument is nil or the empty string, clear any existing
3458 message; let the minibuffer contents show.
3460 usage: (message-or-box FORMAT-STRING &rest ARGS) */)
3461 (ptrdiff_t nargs
, Lisp_Object
*args
)
3464 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3466 return Fmessage_box (nargs
, args
);
3468 return Fmessage (nargs
, args
);
3471 DEFUN ("current-message", Fcurrent_message
, Scurrent_message
, 0, 0, 0,
3472 doc
: /* Return the string currently displayed in the echo area, or nil if none. */)
3475 return current_message ();
3479 DEFUN ("propertize", Fpropertize
, Spropertize
, 1, MANY
, 0,
3480 doc
: /* Return a copy of STRING with text properties added.
3481 First argument is the string to copy.
3482 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
3483 properties to add to the result.
3484 usage: (propertize STRING &rest PROPERTIES) */)
3485 (ptrdiff_t nargs
, Lisp_Object
*args
)
3487 Lisp_Object properties
, string
;
3488 struct gcpro gcpro1
, gcpro2
;
3491 /* Number of args must be odd. */
3492 if ((nargs
& 1) == 0)
3493 error ("Wrong number of arguments");
3495 properties
= string
= Qnil
;
3496 GCPRO2 (properties
, string
);
3498 /* First argument must be a string. */
3499 CHECK_STRING (args
[0]);
3500 string
= Fcopy_sequence (args
[0]);
3502 for (i
= 1; i
< nargs
; i
+= 2)
3503 properties
= Fcons (args
[i
], Fcons (args
[i
+ 1], properties
));
3505 Fadd_text_properties (make_number (0),
3506 make_number (SCHARS (string
)),
3507 properties
, string
);
3508 RETURN_UNGCPRO (string
);
3511 /* pWIDE is a conversion for printing large decimal integers (possibly with a
3512 trailing "d" that is ignored). pWIDElen is its length. signed_wide and
3513 unsigned_wide are signed and unsigned types for printing them. Use widest
3514 integers if available so that more floating point values can be converted. */
3516 # define pWIDE PRIdMAX
3517 enum { pWIDElen
= sizeof PRIdMAX
- 2 }; /* Don't count trailing "d". */
3518 typedef intmax_t signed_wide
;
3519 typedef uintmax_t unsigned_wide
;
3522 enum { pWIDElen
= sizeof pI
- 1 };
3523 typedef EMACS_INT signed_wide
;
3524 typedef EMACS_UINT unsigned_wide
;
3527 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
3528 doc
: /* Format a string out of a format-string and arguments.
3529 The first argument is a format control string.
3530 The other arguments are substituted into it to make the result, a string.
3532 The format control string may contain %-sequences meaning to substitute
3533 the next available argument:
3535 %s means print a string argument. Actually, prints any object, with `princ'.
3536 %d means print as number in decimal (%o octal, %x hex).
3537 %X is like %x, but uses upper case.
3538 %e means print a number in exponential notation.
3539 %f means print a number in decimal-point notation.
3540 %g means print a number in exponential notation
3541 or decimal-point notation, whichever uses fewer characters.
3542 %c means print a number as a single character.
3543 %S means print any object as an s-expression (using `prin1').
3545 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
3546 Use %% to put a single % into the output.
3548 A %-sequence may contain optional flag, width, and precision
3549 specifiers, as follows:
3551 %<flags><width><precision>character
3553 where flags is [+ #-0]+, width is [0-9]+, and precision is .[0-9]+
3555 The + flag character inserts a + before any positive number, while a
3556 space inserts a space before any positive number; these flags only
3557 affect %d, %e, %f, and %g sequences, and the + flag takes precedence.
3558 The # flag means to use an alternate display form for %o, %x, %X, %e,
3559 %f, and %g sequences. The - and 0 flags affect the width specifier,
3562 The width specifier supplies a lower limit for the length of the
3563 printed representation. The padding, if any, normally goes on the
3564 left, but it goes on the right if the - flag is present. The padding
3565 character is normally a space, but it is 0 if the 0 flag is present.
3566 The 0 flag is ignored if the - flag is present, or the format sequence
3567 is something other than %d, %e, %f, and %g.
3569 For %e, %f, and %g sequences, the number after the "." in the
3570 precision specifier says how many decimal places to show; if zero, the
3571 decimal point itself is omitted. For %s and %S, the precision
3572 specifier truncates the string to the given width.
3574 usage: (format STRING &rest OBJECTS) */)
3575 (ptrdiff_t nargs
, Lisp_Object
*args
)
3577 ptrdiff_t n
; /* The number of the next arg to substitute */
3578 char initial_buffer
[4000];
3579 char *buf
= initial_buffer
;
3580 EMACS_INT bufsize
= sizeof initial_buffer
;
3581 EMACS_INT max_bufsize
= STRING_BYTES_BOUND
+ 1;
3583 Lisp_Object buf_save_value
IF_LINT (= {0});
3584 register char *format
, *end
, *format_start
;
3585 EMACS_INT formatlen
, nchars
;
3586 /* Nonzero if the format is multibyte. */
3587 int multibyte_format
= 0;
3588 /* Nonzero if the output should be a multibyte string,
3589 which is true if any of the inputs is one. */
3591 /* When we make a multibyte string, we must pay attention to the
3592 byte combining problem, i.e., a byte may be combined with a
3593 multibyte character of the previous string. This flag tells if we
3594 must consider such a situation or not. */
3595 int maybe_combine_byte
;
3597 int arg_intervals
= 0;
3600 /* discarded[I] is 1 if byte I of the format
3601 string was not copied into the output.
3602 It is 2 if byte I was not the first byte of its character. */
3605 /* Each element records, for one argument,
3606 the start and end bytepos in the output string,
3607 whether the argument has been converted to string (e.g., due to "%S"),
3608 and whether the argument is a string with intervals.
3609 info[0] is unused. Unused elements have -1 for start. */
3612 EMACS_INT start
, end
;
3613 int converted_to_string
;
3617 /* It should not be necessary to GCPRO ARGS, because
3618 the caller in the interpreter should take care of that. */
3620 CHECK_STRING (args
[0]);
3621 format_start
= SSDATA (args
[0]);
3622 formatlen
= SBYTES (args
[0]);
3624 /* Allocate the info and discarded tables. */
3627 if ((SIZE_MAX
- formatlen
) / sizeof (struct info
) <= nargs
)
3628 memory_full (SIZE_MAX
);
3629 SAFE_ALLOCA (info
, struct info
*, (nargs
+ 1) * sizeof *info
+ formatlen
);
3630 discarded
= (char *) &info
[nargs
+ 1];
3631 for (i
= 0; i
< nargs
+ 1; i
++)
3634 info
[i
].intervals
= info
[i
].converted_to_string
= 0;
3636 memset (discarded
, 0, formatlen
);
3639 /* Try to determine whether the result should be multibyte.
3640 This is not always right; sometimes the result needs to be multibyte
3641 because of an object that we will pass through prin1,
3642 and in that case, we won't know it here. */
3643 multibyte_format
= STRING_MULTIBYTE (args
[0]);
3644 multibyte
= multibyte_format
;
3645 for (n
= 1; !multibyte
&& n
< nargs
; n
++)
3646 if (STRINGP (args
[n
]) && STRING_MULTIBYTE (args
[n
]))
3649 /* If we start out planning a unibyte result,
3650 then discover it has to be multibyte, we jump back to retry. */
3657 /* Scan the format and store result in BUF. */
3658 format
= format_start
;
3659 end
= format
+ formatlen
;
3660 maybe_combine_byte
= 0;
3662 while (format
!= end
)
3664 /* The values of N and FORMAT when the loop body is entered. */
3666 char *format0
= format
;
3668 /* Bytes needed to represent the output of this conversion. */
3669 EMACS_INT convbytes
;
3673 /* General format specifications look like
3675 '%' [flags] [field-width] [precision] format
3680 field-width ::= [0-9]+
3681 precision ::= '.' [0-9]*
3683 If a field-width is specified, it specifies to which width
3684 the output should be padded with blanks, if the output
3685 string is shorter than field-width.
3687 If precision is specified, it specifies the number of
3688 digits to print after the '.' for floats, or the max.
3689 number of chars to print from a string. */
3696 EMACS_INT field_width
;
3697 int precision_given
;
3698 uintmax_t precision
= UINTMAX_MAX
;
3706 case '-': minus_flag
= 1; continue;
3707 case '+': plus_flag
= 1; continue;
3708 case ' ': space_flag
= 1; continue;
3709 case '#': sharp_flag
= 1; continue;
3710 case '0': zero_flag
= 1; continue;
3715 /* Ignore flags when sprintf ignores them. */
3716 space_flag
&= ~ plus_flag
;
3717 zero_flag
&= ~ minus_flag
;
3720 uintmax_t w
= strtoumax (format
, &num_end
, 10);
3721 if (max_bufsize
<= w
)
3725 precision_given
= *num_end
== '.';
3726 if (precision_given
)
3727 precision
= strtoumax (num_end
+ 1, &num_end
, 10);
3731 error ("Format string ends in middle of format specifier");
3733 memset (&discarded
[format0
- format_start
], 1, format
- format0
);
3734 conversion
= *format
;
3735 if (conversion
== '%')
3737 discarded
[format
- format_start
] = 1;
3742 error ("Not enough arguments for format string");
3744 /* For 'S', prin1 the argument, and then treat like 's'.
3745 For 's', princ any argument that is not a string or
3746 symbol. But don't do this conversion twice, which might
3747 happen after retrying. */
3748 if ((conversion
== 'S'
3749 || (conversion
== 's'
3750 && ! STRINGP (args
[n
]) && ! SYMBOLP (args
[n
]))))
3752 if (! info
[n
].converted_to_string
)
3754 Lisp_Object noescape
= conversion
== 'S' ? Qnil
: Qt
;
3755 args
[n
] = Fprin1_to_string (args
[n
], noescape
);
3756 info
[n
].converted_to_string
= 1;
3757 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3765 else if (conversion
== 'c')
3767 if (FLOATP (args
[n
]))
3769 double d
= XFLOAT_DATA (args
[n
]);
3770 args
[n
] = make_number (FIXNUM_OVERFLOW_P (d
) ? -1 : d
);
3773 if (INTEGERP (args
[n
]) && ! ASCII_CHAR_P (XINT (args
[n
])))
3780 args
[n
] = Fchar_to_string (args
[n
]);
3781 info
[n
].converted_to_string
= 1;
3784 if (info
[n
].converted_to_string
)
3789 if (SYMBOLP (args
[n
]))
3791 args
[n
] = SYMBOL_NAME (args
[n
]);
3792 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3799 if (conversion
== 's')
3801 /* handle case (precision[n] >= 0) */
3803 EMACS_INT width
, padding
, nbytes
;
3804 EMACS_INT nchars_string
;
3806 EMACS_INT prec
= -1;
3807 if (precision_given
&& precision
<= TYPE_MAXIMUM (EMACS_INT
))
3810 /* lisp_string_width ignores a precision of 0, but GNU
3811 libc functions print 0 characters when the precision
3812 is 0. Imitate libc behavior here. Changing
3813 lisp_string_width is the right thing, and will be
3814 done, but meanwhile we work with it. */
3817 width
= nchars_string
= nbytes
= 0;
3821 width
= lisp_string_width (args
[n
], prec
, &nch
, &nby
);
3824 nchars_string
= SCHARS (args
[n
]);
3825 nbytes
= SBYTES (args
[n
]);
3829 nchars_string
= nch
;
3835 if (convbytes
&& multibyte
&& ! STRING_MULTIBYTE (args
[n
]))
3836 convbytes
= count_size_as_multibyte (SDATA (args
[n
]), nbytes
);
3838 padding
= width
< field_width
? field_width
- width
: 0;
3840 if (max_bufsize
- padding
<= convbytes
)
3842 convbytes
+= padding
;
3843 if (convbytes
<= buf
+ bufsize
- p
)
3847 memset (p
, ' ', padding
);
3854 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3855 && STRING_MULTIBYTE (args
[n
])
3856 && !CHAR_HEAD_P (SREF (args
[n
], 0)))
3857 maybe_combine_byte
= 1;
3859 p
+= copy_text (SDATA (args
[n
]), (unsigned char *) p
,
3861 STRING_MULTIBYTE (args
[n
]), multibyte
);
3863 info
[n
].start
= nchars
;
3864 nchars
+= nchars_string
;
3865 info
[n
].end
= nchars
;
3869 memset (p
, ' ', padding
);
3874 /* If this argument has text properties, record where
3875 in the result string it appears. */
3876 if (STRING_INTERVALS (args
[n
]))
3877 info
[n
].intervals
= arg_intervals
= 1;
3882 else if (! (conversion
== 'c' || conversion
== 'd'
3883 || conversion
== 'e' || conversion
== 'f'
3884 || conversion
== 'g' || conversion
== 'i'
3885 || conversion
== 'o' || conversion
== 'x'
3886 || conversion
== 'X'))
3887 error ("Invalid format operation %%%c",
3888 STRING_CHAR ((unsigned char *) format
- 1));
3889 else if (! (INTEGERP (args
[n
]) || FLOATP (args
[n
])))
3890 error ("Format specifier doesn't match argument type");
3895 /* Maximum precision for a %f conversion such that the
3896 trailing output digit might be nonzero. Any precisions
3897 larger than this will not yield useful information. */
3898 USEFUL_PRECISION_MAX
=
3900 * (FLT_RADIX
== 2 || FLT_RADIX
== 10 ? 1
3901 : FLT_RADIX
== 16 ? 4
3904 /* Maximum number of bytes generated by any format, if
3905 precision is no more than DBL_USEFUL_PRECISION_MAX.
3906 On all practical hosts, %f is the worst case. */
3908 sizeof "-." + (DBL_MAX_10_EXP
+ 1) + USEFUL_PRECISION_MAX
3910 verify (0 < USEFUL_PRECISION_MAX
);
3913 EMACS_INT padding
, sprintf_bytes
;
3914 uintmax_t excess_precision
, numwidth
;
3915 uintmax_t leading_zeros
= 0, trailing_zeros
= 0;
3917 char sprintf_buf
[SPRINTF_BUFSIZE
];
3919 /* Copy of conversion specification, modified somewhat.
3920 At most three flags F can be specified at once. */
3921 char convspec
[sizeof "%FFF.*d" + pWIDElen
];
3923 /* Avoid undefined behavior in underlying sprintf. */
3924 if (conversion
== 'd' || conversion
== 'i')
3927 /* Create the copy of the conversion specification, with
3928 any width and precision removed, with ".*" inserted,
3929 and with pWIDE inserted for integer formats. */
3933 *f
= '-'; f
+= minus_flag
;
3934 *f
= '+'; f
+= plus_flag
;
3935 *f
= ' '; f
+= space_flag
;
3936 *f
= '#'; f
+= sharp_flag
;
3937 *f
= '0'; f
+= zero_flag
;
3940 if (conversion
== 'd' || conversion
== 'i'
3941 || conversion
== 'o' || conversion
== 'x'
3942 || conversion
== 'X')
3944 memcpy (f
, pWIDE
, pWIDElen
);
3946 zero_flag
&= ~ precision_given
;
3953 if (precision_given
)
3954 prec
= min (precision
, USEFUL_PRECISION_MAX
);
3956 /* Use sprintf to format this number into sprintf_buf. Omit
3957 padding and excess precision, though, because sprintf limits
3958 output length to INT_MAX.
3960 There are four types of conversion: double, unsigned
3961 char (passed as int), wide signed int, and wide
3962 unsigned int. Treat them separately because the
3963 sprintf ABI is sensitive to which type is passed. Be
3964 careful about integer overflow, NaNs, infinities, and
3965 conversions; for example, the min and max macros are
3966 not suitable here. */
3967 if (conversion
== 'e' || conversion
== 'f' || conversion
== 'g')
3969 double x
= (INTEGERP (args
[n
])
3971 : XFLOAT_DATA (args
[n
]));
3972 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
3974 else if (conversion
== 'c')
3976 /* Don't use sprintf here, as it might mishandle prec. */
3977 sprintf_buf
[0] = XINT (args
[n
]);
3978 sprintf_bytes
= prec
!= 0;
3980 else if (conversion
== 'd')
3982 /* For float, maybe we should use "%1.0f"
3983 instead so it also works for values outside
3984 the integer range. */
3986 if (INTEGERP (args
[n
]))
3990 double d
= XFLOAT_DATA (args
[n
]);
3993 x
= TYPE_MINIMUM (signed_wide
);
3999 x
= TYPE_MAXIMUM (signed_wide
);
4004 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4008 /* Don't sign-extend for octal or hex printing. */
4010 if (INTEGERP (args
[n
]))
4011 x
= XUINT (args
[n
]);
4014 double d
= XFLOAT_DATA (args
[n
]);
4019 x
= TYPE_MAXIMUM (unsigned_wide
);
4024 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4027 /* Now the length of the formatted item is known, except it omits
4028 padding and excess precision. Deal with excess precision
4029 first. This happens only when the format specifies
4030 ridiculously large precision. */
4031 excess_precision
= precision
- prec
;
4032 if (excess_precision
)
4034 if (conversion
== 'e' || conversion
== 'f'
4035 || conversion
== 'g')
4037 if ((conversion
== 'g' && ! sharp_flag
)
4038 || ! ('0' <= sprintf_buf
[sprintf_bytes
- 1]
4039 && sprintf_buf
[sprintf_bytes
- 1] <= '9'))
4040 excess_precision
= 0;
4043 if (conversion
== 'g')
4045 char *dot
= strchr (sprintf_buf
, '.');
4047 excess_precision
= 0;
4050 trailing_zeros
= excess_precision
;
4053 leading_zeros
= excess_precision
;
4056 /* Compute the total bytes needed for this item, including
4057 excess precision and padding. */
4058 numwidth
= sprintf_bytes
+ excess_precision
;
4059 padding
= numwidth
< field_width
? field_width
- numwidth
: 0;
4060 if (max_bufsize
- sprintf_bytes
<= excess_precision
4061 || max_bufsize
- padding
<= numwidth
)
4063 convbytes
= numwidth
+ padding
;
4065 if (convbytes
<= buf
+ bufsize
- p
)
4067 /* Copy the formatted item from sprintf_buf into buf,
4068 inserting padding and excess-precision zeros. */
4070 char *src
= sprintf_buf
;
4072 int exponent_bytes
= 0;
4073 int signedp
= src0
== '-' || src0
== '+' || src0
== ' ';
4074 int significand_bytes
;
4076 && ((src
[signedp
] >= '0' && src
[signedp
] <= '9')
4077 || (src
[signedp
] >= 'a' && src
[signedp
] <= 'f')
4078 || (src
[signedp
] >= 'A' && src
[signedp
] <= 'F')))
4080 leading_zeros
+= padding
;
4084 if (excess_precision
4085 && (conversion
== 'e' || conversion
== 'g'))
4087 char *e
= strchr (src
, 'e');
4089 exponent_bytes
= src
+ sprintf_bytes
- e
;
4094 memset (p
, ' ', padding
);
4102 memset (p
, '0', leading_zeros
);
4104 significand_bytes
= sprintf_bytes
- signedp
- exponent_bytes
;
4105 memcpy (p
, src
, significand_bytes
);
4106 p
+= significand_bytes
;
4107 src
+= significand_bytes
;
4108 memset (p
, '0', trailing_zeros
);
4109 p
+= trailing_zeros
;
4110 memcpy (p
, src
, exponent_bytes
);
4111 p
+= exponent_bytes
;
4113 info
[n
].start
= nchars
;
4114 nchars
+= leading_zeros
+ sprintf_bytes
+ trailing_zeros
;
4115 info
[n
].end
= nchars
;
4119 memset (p
, ' ', padding
);
4131 /* Copy a single character from format to buf. */
4134 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
4136 if (multibyte_format
)
4138 /* Copy a whole multibyte character. */
4140 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
4141 && !CHAR_HEAD_P (*format
))
4142 maybe_combine_byte
= 1;
4146 while (! CHAR_HEAD_P (*format
));
4148 convbytes
= format
- format0
;
4149 memset (&discarded
[format0
+ 1 - format_start
], 2, convbytes
- 1);
4153 unsigned char uc
= *format
++;
4154 if (! multibyte
|| ASCII_BYTE_P (uc
))
4158 int c
= BYTE8_TO_CHAR (uc
);
4159 convbytes
= CHAR_STRING (c
, str
);
4164 if (convbytes
<= buf
+ bufsize
- p
)
4166 memcpy (p
, src
, convbytes
);
4173 /* There wasn't enough room to store this conversion or single
4174 character. CONVBYTES says how much room is needed. Allocate
4175 enough room (and then some) and do it again. */
4177 EMACS_INT used
= p
- buf
;
4179 if (max_bufsize
- used
< convbytes
)
4181 bufsize
= used
+ convbytes
;
4182 bufsize
= bufsize
< max_bufsize
/ 2 ? bufsize
* 2 : max_bufsize
;
4184 if (buf
== initial_buffer
)
4186 buf
= xmalloc (bufsize
);
4188 buf_save_value
= make_save_value (buf
, 0);
4189 record_unwind_protect (safe_alloca_unwind
, buf_save_value
);
4190 memcpy (buf
, initial_buffer
, used
);
4193 XSAVE_VALUE (buf_save_value
)->pointer
= buf
= xrealloc (buf
, bufsize
);
4202 if (bufsize
< p
- buf
)
4205 if (maybe_combine_byte
)
4206 nchars
= multibyte_chars_in_text ((unsigned char *) buf
, p
- buf
);
4207 val
= make_specified_string (buf
, nchars
, p
- buf
, multibyte
);
4209 /* If we allocated BUF with malloc, free it too. */
4212 /* If the format string has text properties, or any of the string
4213 arguments has text properties, set up text properties of the
4216 if (STRING_INTERVALS (args
[0]) || arg_intervals
)
4218 Lisp_Object len
, new_len
, props
;
4219 struct gcpro gcpro1
;
4221 /* Add text properties from the format string. */
4222 len
= make_number (SCHARS (args
[0]));
4223 props
= text_property_list (args
[0], make_number (0), len
, Qnil
);
4228 EMACS_INT bytepos
= 0, position
= 0, translated
= 0;
4232 /* Adjust the bounds of each text property
4233 to the proper start and end in the output string. */
4235 /* Put the positions in PROPS in increasing order, so that
4236 we can do (effectively) one scan through the position
4237 space of the format string. */
4238 props
= Fnreverse (props
);
4240 /* BYTEPOS is the byte position in the format string,
4241 POSITION is the untranslated char position in it,
4242 TRANSLATED is the translated char position in BUF,
4243 and ARGN is the number of the next arg we will come to. */
4244 for (list
= props
; CONSP (list
); list
= XCDR (list
))
4251 /* First adjust the property start position. */
4252 pos
= XINT (XCAR (item
));
4254 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
4255 up to this position. */
4256 for (; position
< pos
; bytepos
++)
4258 if (! discarded
[bytepos
])
4259 position
++, translated
++;
4260 else if (discarded
[bytepos
] == 1)
4263 if (translated
== info
[argn
].start
)
4265 translated
+= info
[argn
].end
- info
[argn
].start
;
4271 XSETCAR (item
, make_number (translated
));
4273 /* Likewise adjust the property end position. */
4274 pos
= XINT (XCAR (XCDR (item
)));
4276 for (; position
< pos
; bytepos
++)
4278 if (! discarded
[bytepos
])
4279 position
++, translated
++;
4280 else if (discarded
[bytepos
] == 1)
4283 if (translated
== info
[argn
].start
)
4285 translated
+= info
[argn
].end
- info
[argn
].start
;
4291 XSETCAR (XCDR (item
), make_number (translated
));
4294 add_text_properties_from_list (val
, props
, make_number (0));
4297 /* Add text properties from arguments. */
4299 for (n
= 1; n
< nargs
; ++n
)
4300 if (info
[n
].intervals
)
4302 len
= make_number (SCHARS (args
[n
]));
4303 new_len
= make_number (info
[n
].end
- info
[n
].start
);
4304 props
= text_property_list (args
[n
], make_number (0), len
, Qnil
);
4305 props
= extend_property_ranges (props
, new_len
);
4306 /* If successive arguments have properties, be sure that
4307 the value of `composition' property be the copy. */
4308 if (n
> 1 && info
[n
- 1].end
)
4309 make_composition_value_copy (props
);
4310 add_text_properties_from_list (val
, props
,
4311 make_number (info
[n
].start
));
4321 format2 (const char *string1
, Lisp_Object arg0
, Lisp_Object arg1
)
4323 Lisp_Object args
[3];
4324 args
[0] = build_string (string1
);
4327 return Fformat (3, args
);
4330 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
4331 doc
: /* Return t if two characters match, optionally ignoring case.
4332 Both arguments must be characters (i.e. integers).
4333 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
4334 (register Lisp_Object c1
, Lisp_Object c2
)
4337 /* Check they're chars, not just integers, otherwise we could get array
4338 bounds violations in downcase. */
4339 CHECK_CHARACTER (c1
);
4340 CHECK_CHARACTER (c2
);
4342 if (XINT (c1
) == XINT (c2
))
4344 if (NILP (BVAR (current_buffer
, case_fold_search
)))
4348 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
))
4349 && ! ASCII_CHAR_P (i1
))
4351 MAKE_CHAR_MULTIBYTE (i1
);
4354 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
))
4355 && ! ASCII_CHAR_P (i2
))
4357 MAKE_CHAR_MULTIBYTE (i2
);
4359 return (downcase (i1
) == downcase (i2
) ? Qt
: Qnil
);
4362 /* Transpose the markers in two regions of the current buffer, and
4363 adjust the ones between them if necessary (i.e.: if the regions
4366 START1, END1 are the character positions of the first region.
4367 START1_BYTE, END1_BYTE are the byte positions.
4368 START2, END2 are the character positions of the second region.
4369 START2_BYTE, END2_BYTE are the byte positions.
4371 Traverses the entire marker list of the buffer to do so, adding an
4372 appropriate amount to some, subtracting from some, and leaving the
4373 rest untouched. Most of this is copied from adjust_markers in insdel.c.
4375 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
4378 transpose_markers (EMACS_INT start1
, EMACS_INT end1
,
4379 EMACS_INT start2
, EMACS_INT end2
,
4380 EMACS_INT start1_byte
, EMACS_INT end1_byte
,
4381 EMACS_INT start2_byte
, EMACS_INT end2_byte
)
4383 register EMACS_INT amt1
, amt1_byte
, amt2
, amt2_byte
, diff
, diff_byte
, mpos
;
4384 register struct Lisp_Marker
*marker
;
4386 /* Update point as if it were a marker. */
4390 TEMP_SET_PT_BOTH (PT
+ (end2
- end1
),
4391 PT_BYTE
+ (end2_byte
- end1_byte
));
4392 else if (PT
< start2
)
4393 TEMP_SET_PT_BOTH (PT
+ (end2
- start2
) - (end1
- start1
),
4394 (PT_BYTE
+ (end2_byte
- start2_byte
)
4395 - (end1_byte
- start1_byte
)));
4397 TEMP_SET_PT_BOTH (PT
- (start2
- start1
),
4398 PT_BYTE
- (start2_byte
- start1_byte
));
4400 /* We used to adjust the endpoints here to account for the gap, but that
4401 isn't good enough. Even if we assume the caller has tried to move the
4402 gap out of our way, it might still be at start1 exactly, for example;
4403 and that places it `inside' the interval, for our purposes. The amount
4404 of adjustment is nontrivial if there's a `denormalized' marker whose
4405 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
4406 the dirty work to Fmarker_position, below. */
4408 /* The difference between the region's lengths */
4409 diff
= (end2
- start2
) - (end1
- start1
);
4410 diff_byte
= (end2_byte
- start2_byte
) - (end1_byte
- start1_byte
);
4412 /* For shifting each marker in a region by the length of the other
4413 region plus the distance between the regions. */
4414 amt1
= (end2
- start2
) + (start2
- end1
);
4415 amt2
= (end1
- start1
) + (start2
- end1
);
4416 amt1_byte
= (end2_byte
- start2_byte
) + (start2_byte
- end1_byte
);
4417 amt2_byte
= (end1_byte
- start1_byte
) + (start2_byte
- end1_byte
);
4419 for (marker
= BUF_MARKERS (current_buffer
); marker
; marker
= marker
->next
)
4421 mpos
= marker
->bytepos
;
4422 if (mpos
>= start1_byte
&& mpos
< end2_byte
)
4424 if (mpos
< end1_byte
)
4426 else if (mpos
< start2_byte
)
4430 marker
->bytepos
= mpos
;
4432 mpos
= marker
->charpos
;
4433 if (mpos
>= start1
&& mpos
< end2
)
4437 else if (mpos
< start2
)
4442 marker
->charpos
= mpos
;
4446 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
4447 doc
: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
4448 The regions should not be overlapping, because the size of the buffer is
4449 never changed in a transposition.
4451 Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
4452 any markers that happen to be located in the regions.
4454 Transposing beyond buffer boundaries is an error. */)
4455 (Lisp_Object startr1
, Lisp_Object endr1
, Lisp_Object startr2
, Lisp_Object endr2
, Lisp_Object leave_markers
)
4457 register EMACS_INT start1
, end1
, start2
, end2
;
4458 EMACS_INT start1_byte
, start2_byte
, len1_byte
, len2_byte
;
4459 EMACS_INT gap
, len1
, len_mid
, len2
;
4460 unsigned char *start1_addr
, *start2_addr
, *temp
;
4462 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
, tmp_interval3
;
4465 XSETBUFFER (buf
, current_buffer
);
4466 cur_intv
= BUF_INTERVALS (current_buffer
);
4468 validate_region (&startr1
, &endr1
);
4469 validate_region (&startr2
, &endr2
);
4471 start1
= XFASTINT (startr1
);
4472 end1
= XFASTINT (endr1
);
4473 start2
= XFASTINT (startr2
);
4474 end2
= XFASTINT (endr2
);
4477 /* Swap the regions if they're reversed. */
4480 register EMACS_INT glumph
= start1
;
4488 len1
= end1
- start1
;
4489 len2
= end2
- start2
;
4492 error ("Transposed regions overlap");
4493 /* Nothing to change for adjacent regions with one being empty */
4494 else if ((start1
== end1
|| start2
== end2
) && end1
== start2
)
4497 /* The possibilities are:
4498 1. Adjacent (contiguous) regions, or separate but equal regions
4499 (no, really equal, in this case!), or
4500 2. Separate regions of unequal size.
4502 The worst case is usually No. 2. It means that (aside from
4503 potential need for getting the gap out of the way), there also
4504 needs to be a shifting of the text between the two regions. So
4505 if they are spread far apart, we are that much slower... sigh. */
4507 /* It must be pointed out that the really studly thing to do would
4508 be not to move the gap at all, but to leave it in place and work
4509 around it if necessary. This would be extremely efficient,
4510 especially considering that people are likely to do
4511 transpositions near where they are working interactively, which
4512 is exactly where the gap would be found. However, such code
4513 would be much harder to write and to read. So, if you are
4514 reading this comment and are feeling squirrely, by all means have
4515 a go! I just didn't feel like doing it, so I will simply move
4516 the gap the minimum distance to get it out of the way, and then
4517 deal with an unbroken array. */
4519 /* Make sure the gap won't interfere, by moving it out of the text
4520 we will operate on. */
4521 if (start1
< gap
&& gap
< end2
)
4523 if (gap
- start1
< end2
- gap
)
4529 start1_byte
= CHAR_TO_BYTE (start1
);
4530 start2_byte
= CHAR_TO_BYTE (start2
);
4531 len1_byte
= CHAR_TO_BYTE (end1
) - start1_byte
;
4532 len2_byte
= CHAR_TO_BYTE (end2
) - start2_byte
;
4534 #ifdef BYTE_COMBINING_DEBUG
4537 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4538 len2_byte
, start1
, start1_byte
)
4539 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4540 len1_byte
, end2
, start2_byte
+ len2_byte
)
4541 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4542 len1_byte
, end2
, start2_byte
+ len2_byte
))
4547 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4548 len2_byte
, start1
, start1_byte
)
4549 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4550 len1_byte
, start2
, start2_byte
)
4551 || count_combining_after (BYTE_POS_ADDR (start2_byte
),
4552 len2_byte
, end1
, start1_byte
+ len1_byte
)
4553 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4554 len1_byte
, end2
, start2_byte
+ len2_byte
))
4559 /* Hmmm... how about checking to see if the gap is large
4560 enough to use as the temporary storage? That would avoid an
4561 allocation... interesting. Later, don't fool with it now. */
4563 /* Working without memmove, for portability (sigh), so must be
4564 careful of overlapping subsections of the array... */
4566 if (end1
== start2
) /* adjacent regions */
4568 modify_region (current_buffer
, start1
, end2
, 0);
4569 record_change (start1
, len1
+ len2
);
4571 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4572 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4573 /* Don't use Fset_text_properties: that can cause GC, which can
4574 clobber objects stored in the tmp_intervals. */
4575 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4576 if (!NULL_INTERVAL_P (tmp_interval3
))
4577 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4579 /* First region smaller than second. */
4580 if (len1_byte
< len2_byte
)
4584 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4586 /* Don't precompute these addresses. We have to compute them
4587 at the last minute, because the relocating allocator might
4588 have moved the buffer around during the xmalloc. */
4589 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4590 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4592 memcpy (temp
, start2_addr
, len2_byte
);
4593 memcpy (start1_addr
+ len2_byte
, start1_addr
, len1_byte
);
4594 memcpy (start1_addr
, temp
, len2_byte
);
4598 /* First region not smaller than second. */
4602 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4603 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4604 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4605 memcpy (temp
, start1_addr
, len1_byte
);
4606 memcpy (start1_addr
, start2_addr
, len2_byte
);
4607 memcpy (start1_addr
+ len2_byte
, temp
, len1_byte
);
4610 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
4611 len1
, current_buffer
, 0);
4612 graft_intervals_into_buffer (tmp_interval2
, start1
,
4613 len2
, current_buffer
, 0);
4614 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4615 update_compositions (start1
+ len2
, end2
, CHECK_TAIL
);
4617 /* Non-adjacent regions, because end1 != start2, bleagh... */
4620 len_mid
= start2_byte
- (start1_byte
+ len1_byte
);
4622 if (len1_byte
== len2_byte
)
4623 /* Regions are same size, though, how nice. */
4627 modify_region (current_buffer
, start1
, end1
, 0);
4628 modify_region (current_buffer
, start2
, end2
, 0);
4629 record_change (start1
, len1
);
4630 record_change (start2
, len2
);
4631 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4632 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4634 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr1
, 0);
4635 if (!NULL_INTERVAL_P (tmp_interval3
))
4636 set_text_properties_1 (startr1
, endr1
, Qnil
, buf
, tmp_interval3
);
4638 tmp_interval3
= validate_interval_range (buf
, &startr2
, &endr2
, 0);
4639 if (!NULL_INTERVAL_P (tmp_interval3
))
4640 set_text_properties_1 (startr2
, endr2
, Qnil
, buf
, tmp_interval3
);
4642 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4643 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4644 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4645 memcpy (temp
, start1_addr
, len1_byte
);
4646 memcpy (start1_addr
, start2_addr
, len2_byte
);
4647 memcpy (start2_addr
, temp
, len1_byte
);
4650 graft_intervals_into_buffer (tmp_interval1
, start2
,
4651 len1
, current_buffer
, 0);
4652 graft_intervals_into_buffer (tmp_interval2
, start1
,
4653 len2
, current_buffer
, 0);
4656 else if (len1_byte
< len2_byte
) /* Second region larger than first */
4657 /* Non-adjacent & unequal size, area between must also be shifted. */
4661 modify_region (current_buffer
, start1
, end2
, 0);
4662 record_change (start1
, (end2
- start1
));
4663 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4664 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4665 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4667 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4668 if (!NULL_INTERVAL_P (tmp_interval3
))
4669 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4671 /* holds region 2 */
4672 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4673 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4674 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4675 memcpy (temp
, start2_addr
, len2_byte
);
4676 memcpy (start1_addr
+ len_mid
+ len2_byte
, start1_addr
, len1_byte
);
4677 memmove (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
4678 memcpy (start1_addr
, temp
, len2_byte
);
4681 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4682 len1
, current_buffer
, 0);
4683 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4684 len_mid
, current_buffer
, 0);
4685 graft_intervals_into_buffer (tmp_interval2
, start1
,
4686 len2
, current_buffer
, 0);
4689 /* Second region smaller than first. */
4693 record_change (start1
, (end2
- start1
));
4694 modify_region (current_buffer
, start1
, end2
, 0);
4696 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4697 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4698 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4700 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4701 if (!NULL_INTERVAL_P (tmp_interval3
))
4702 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4704 /* holds region 1 */
4705 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4706 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4707 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4708 memcpy (temp
, start1_addr
, len1_byte
);
4709 memcpy (start1_addr
, start2_addr
, len2_byte
);
4710 memcpy (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
4711 memcpy (start1_addr
+ len2_byte
+ len_mid
, temp
, len1_byte
);
4714 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4715 len1
, current_buffer
, 0);
4716 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4717 len_mid
, current_buffer
, 0);
4718 graft_intervals_into_buffer (tmp_interval2
, start1
,
4719 len2
, current_buffer
, 0);
4722 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4723 update_compositions (end2
- len1
, end2
, CHECK_BORDER
);
4726 /* When doing multiple transpositions, it might be nice
4727 to optimize this. Perhaps the markers in any one buffer
4728 should be organized in some sorted data tree. */
4729 if (NILP (leave_markers
))
4731 transpose_markers (start1
, end1
, start2
, end2
,
4732 start1_byte
, start1_byte
+ len1_byte
,
4733 start2_byte
, start2_byte
+ len2_byte
);
4734 fix_start_end_in_overlays (start1
, end2
);
4737 signal_after_change (start1
, end2
- start1
, end2
- start1
);
4743 syms_of_editfns (void)
4748 DEFSYM (Qbuffer_access_fontify_functions
, "buffer-access-fontify-functions");
4750 DEFVAR_LISP ("inhibit-field-text-motion", Vinhibit_field_text_motion
,
4751 doc
: /* Non-nil means text motion commands don't notice fields. */);
4752 Vinhibit_field_text_motion
= Qnil
;
4754 DEFVAR_LISP ("buffer-access-fontify-functions",
4755 Vbuffer_access_fontify_functions
,
4756 doc
: /* List of functions called by `buffer-substring' to fontify if necessary.
4757 Each function is called with two arguments which specify the range
4758 of the buffer being accessed. */);
4759 Vbuffer_access_fontify_functions
= Qnil
;
4763 obuf
= Fcurrent_buffer ();
4764 /* Do this here, because init_buffer_once is too early--it won't work. */
4765 Fset_buffer (Vprin1_to_string_buffer
);
4766 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
4767 Fset (Fmake_local_variable (intern_c_string ("buffer-access-fontify-functions")),
4772 DEFVAR_LISP ("buffer-access-fontified-property",
4773 Vbuffer_access_fontified_property
,
4774 doc
: /* Property which (if non-nil) indicates text has been fontified.
4775 `buffer-substring' need not call the `buffer-access-fontify-functions'
4776 functions if all the text being accessed has this property. */);
4777 Vbuffer_access_fontified_property
= Qnil
;
4779 DEFVAR_LISP ("system-name", Vsystem_name
,
4780 doc
: /* The host name of the machine Emacs is running on. */);
4782 DEFVAR_LISP ("user-full-name", Vuser_full_name
,
4783 doc
: /* The full name of the user logged in. */);
4785 DEFVAR_LISP ("user-login-name", Vuser_login_name
,
4786 doc
: /* The user's name, taken from environment variables if possible. */);
4788 DEFVAR_LISP ("user-real-login-name", Vuser_real_login_name
,
4789 doc
: /* The user's name, based upon the real uid only. */);
4791 DEFVAR_LISP ("operating-system-release", Voperating_system_release
,
4792 doc
: /* The release of the operating system Emacs is running on. */);
4794 defsubr (&Spropertize
);
4795 defsubr (&Schar_equal
);
4796 defsubr (&Sgoto_char
);
4797 defsubr (&Sstring_to_char
);
4798 defsubr (&Schar_to_string
);
4799 defsubr (&Sbyte_to_string
);
4800 defsubr (&Sbuffer_substring
);
4801 defsubr (&Sbuffer_substring_no_properties
);
4802 defsubr (&Sbuffer_string
);
4804 defsubr (&Spoint_marker
);
4805 defsubr (&Smark_marker
);
4807 defsubr (&Sregion_beginning
);
4808 defsubr (&Sregion_end
);
4810 DEFSYM (Qfield
, "field");
4811 DEFSYM (Qboundary
, "boundary");
4812 defsubr (&Sfield_beginning
);
4813 defsubr (&Sfield_end
);
4814 defsubr (&Sfield_string
);
4815 defsubr (&Sfield_string_no_properties
);
4816 defsubr (&Sdelete_field
);
4817 defsubr (&Sconstrain_to_field
);
4819 defsubr (&Sline_beginning_position
);
4820 defsubr (&Sline_end_position
);
4822 /* defsubr (&Smark); */
4823 /* defsubr (&Sset_mark); */
4824 defsubr (&Ssave_excursion
);
4825 defsubr (&Ssave_current_buffer
);
4827 defsubr (&Sbufsize
);
4828 defsubr (&Spoint_max
);
4829 defsubr (&Spoint_min
);
4830 defsubr (&Spoint_min_marker
);
4831 defsubr (&Spoint_max_marker
);
4832 defsubr (&Sgap_position
);
4833 defsubr (&Sgap_size
);
4834 defsubr (&Sposition_bytes
);
4835 defsubr (&Sbyte_to_position
);
4841 defsubr (&Sfollowing_char
);
4842 defsubr (&Sprevious_char
);
4843 defsubr (&Schar_after
);
4844 defsubr (&Schar_before
);
4846 defsubr (&Sinsert_before_markers
);
4847 defsubr (&Sinsert_and_inherit
);
4848 defsubr (&Sinsert_and_inherit_before_markers
);
4849 defsubr (&Sinsert_char
);
4850 defsubr (&Sinsert_byte
);
4852 defsubr (&Suser_login_name
);
4853 defsubr (&Suser_real_login_name
);
4854 defsubr (&Suser_uid
);
4855 defsubr (&Suser_real_uid
);
4856 defsubr (&Suser_full_name
);
4857 defsubr (&Semacs_pid
);
4858 defsubr (&Scurrent_time
);
4859 defsubr (&Sget_internal_run_time
);
4860 defsubr (&Sformat_time_string
);
4861 defsubr (&Sfloat_time
);
4862 defsubr (&Sdecode_time
);
4863 defsubr (&Sencode_time
);
4864 defsubr (&Scurrent_time_string
);
4865 defsubr (&Scurrent_time_zone
);
4866 defsubr (&Sset_time_zone_rule
);
4867 defsubr (&Ssystem_name
);
4868 defsubr (&Smessage
);
4869 defsubr (&Smessage_box
);
4870 defsubr (&Smessage_or_box
);
4871 defsubr (&Scurrent_message
);
4874 defsubr (&Sinsert_buffer_substring
);
4875 defsubr (&Scompare_buffer_substrings
);
4876 defsubr (&Ssubst_char_in_region
);
4877 defsubr (&Stranslate_region_internal
);
4878 defsubr (&Sdelete_region
);
4879 defsubr (&Sdelete_and_extract_region
);
4881 defsubr (&Snarrow_to_region
);
4882 defsubr (&Ssave_restriction
);
4883 defsubr (&Stranspose_regions
);