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>
52 #include "intervals.h"
54 #include "character.h"
58 #include "blockinput.h"
62 #define MAX_10_EXP DBL_MAX_10_EXP
64 #define MAX_10_EXP 310
71 #ifndef USER_FULL_NAME
72 #define USER_FULL_NAME pw->pw_gecos
76 extern char **environ
;
79 #define TM_YEAR_BASE 1900
81 /* Nonzero if TM_YEAR is a struct tm's tm_year value that causes
82 asctime to have well-defined behavior. */
83 #ifndef TM_YEAR_IN_ASCTIME_RANGE
84 # define TM_YEAR_IN_ASCTIME_RANGE(tm_year) \
85 (1000 - TM_YEAR_BASE <= (tm_year) && (tm_year) <= 9999 - TM_YEAR_BASE)
89 extern Lisp_Object
w32_get_internal_run_time (void);
92 static void time_overflow (void) NO_RETURN
;
93 static int tm_diff (struct tm
*, struct tm
*);
94 static void find_field (Lisp_Object
, Lisp_Object
, Lisp_Object
,
95 EMACS_INT
*, Lisp_Object
, EMACS_INT
*);
96 static void update_buffer_properties (EMACS_INT
, EMACS_INT
);
97 static Lisp_Object
region_limit (int);
98 static size_t emacs_nmemftime (char *, size_t, const char *,
99 size_t, const struct tm
*, int, int);
100 static void general_insert_function (void (*) (const char *, EMACS_INT
),
101 void (*) (Lisp_Object
, EMACS_INT
,
102 EMACS_INT
, EMACS_INT
,
104 int, int, Lisp_Object
*);
105 static Lisp_Object
subst_char_in_region_unwind (Lisp_Object
);
106 static Lisp_Object
subst_char_in_region_unwind_1 (Lisp_Object
);
107 static void transpose_markers (EMACS_INT
, EMACS_INT
, EMACS_INT
, EMACS_INT
,
108 EMACS_INT
, EMACS_INT
, EMACS_INT
, EMACS_INT
);
110 Lisp_Object Qbuffer_access_fontify_functions
;
111 Lisp_Object
Fuser_full_name (Lisp_Object
);
113 /* Symbol for the text property used to mark fields. */
117 /* A special value for Qfield properties. */
119 Lisp_Object Qboundary
;
127 struct passwd
*pw
; /* password entry for the current user */
130 /* Set up system_name even when dumping. */
134 /* Don't bother with this on initial start when just dumping out */
137 #endif /* not CANNOT_DUMP */
139 pw
= (struct passwd
*) getpwuid (getuid ());
141 /* We let the real user name default to "root" because that's quite
142 accurate on MSDOG and because it lets Emacs find the init file.
143 (The DVX libraries override the Djgpp libraries here.) */
144 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "root");
146 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "unknown");
149 /* Get the effective user name, by consulting environment variables,
150 or the effective uid if those are unset. */
151 user_name
= (char *) getenv ("LOGNAME");
154 user_name
= (char *) getenv ("USERNAME"); /* it's USERNAME on NT */
155 #else /* WINDOWSNT */
156 user_name
= (char *) getenv ("USER");
157 #endif /* WINDOWSNT */
160 pw
= (struct passwd
*) getpwuid (geteuid ());
161 user_name
= (char *) (pw
? pw
->pw_name
: "unknown");
163 Vuser_login_name
= build_string (user_name
);
165 /* If the user name claimed in the environment vars differs from
166 the real uid, use the claimed name to find the full name. */
167 tem
= Fstring_equal (Vuser_login_name
, Vuser_real_login_name
);
168 Vuser_full_name
= Fuser_full_name (NILP (tem
)? make_number (geteuid())
173 Vuser_full_name
= build_string (p
);
174 else if (NILP (Vuser_full_name
))
175 Vuser_full_name
= build_string ("unknown");
177 #ifdef HAVE_SYS_UTSNAME_H
181 Voperating_system_release
= build_string (uts
.release
);
184 Voperating_system_release
= Qnil
;
188 DEFUN ("char-to-string", Fchar_to_string
, Schar_to_string
, 1, 1, 0,
189 doc
: /* Convert arg CHAR to a string containing that character.
190 usage: (char-to-string CHAR) */)
191 (Lisp_Object character
)
194 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
196 CHECK_CHARACTER (character
);
198 len
= CHAR_STRING (XFASTINT (character
), str
);
199 return make_string_from_bytes ((char *) str
, 1, len
);
202 DEFUN ("byte-to-string", Fbyte_to_string
, Sbyte_to_string
, 1, 1, 0,
203 doc
: /* Convert arg BYTE to a unibyte string containing that byte. */)
208 if (XINT (byte
) < 0 || XINT (byte
) > 255)
209 error ("Invalid byte");
211 return make_string_from_bytes ((char *) &b
, 1, 1);
214 DEFUN ("string-to-char", Fstring_to_char
, Sstring_to_char
, 1, 1, 0,
215 doc
: /* Convert arg STRING to a character, the first character of that string.
216 A multibyte character is handled correctly. */)
217 (register Lisp_Object string
)
219 register Lisp_Object val
;
220 CHECK_STRING (string
);
223 if (STRING_MULTIBYTE (string
))
224 XSETFASTINT (val
, STRING_CHAR (SDATA (string
)));
226 XSETFASTINT (val
, SREF (string
, 0));
229 XSETFASTINT (val
, 0);
234 buildmark (EMACS_INT charpos
, EMACS_INT bytepos
)
236 register Lisp_Object mark
;
237 mark
= Fmake_marker ();
238 set_marker_both (mark
, Qnil
, charpos
, bytepos
);
242 DEFUN ("point", Fpoint
, Spoint
, 0, 0, 0,
243 doc
: /* Return value of point, as an integer.
244 Beginning of buffer is position (point-min). */)
248 XSETFASTINT (temp
, PT
);
252 DEFUN ("point-marker", Fpoint_marker
, Spoint_marker
, 0, 0, 0,
253 doc
: /* Return value of point, as a marker object. */)
256 return buildmark (PT
, PT_BYTE
);
260 clip_to_bounds (EMACS_INT lower
, EMACS_INT num
, EMACS_INT upper
)
264 else if (num
> upper
)
270 DEFUN ("goto-char", Fgoto_char
, Sgoto_char
, 1, 1, "NGoto char: ",
271 doc
: /* Set point to POSITION, a number or marker.
272 Beginning of buffer is position (point-min), end is (point-max).
274 The return value is POSITION. */)
275 (register Lisp_Object position
)
279 if (MARKERP (position
)
280 && current_buffer
== XMARKER (position
)->buffer
)
282 pos
= marker_position (position
);
284 SET_PT_BOTH (BEGV
, BEGV_BYTE
);
286 SET_PT_BOTH (ZV
, ZV_BYTE
);
288 SET_PT_BOTH (pos
, marker_byte_position (position
));
293 CHECK_NUMBER_COERCE_MARKER (position
);
295 pos
= clip_to_bounds (BEGV
, XINT (position
), ZV
);
301 /* Return the start or end position of the region.
302 BEGINNINGP non-zero means return the start.
303 If there is no region active, signal an error. */
306 region_limit (int beginningp
)
310 if (!NILP (Vtransient_mark_mode
)
311 && NILP (Vmark_even_if_inactive
)
312 && NILP (BVAR (current_buffer
, mark_active
)))
313 xsignal0 (Qmark_inactive
);
315 m
= Fmarker_position (BVAR (current_buffer
, mark
));
317 error ("The mark is not set now, so there is no region");
319 if ((PT
< XFASTINT (m
)) == (beginningp
!= 0))
320 m
= make_number (PT
);
324 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
325 doc
: /* Return the integer value of point or mark, whichever is smaller. */)
328 return region_limit (1);
331 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
332 doc
: /* Return the integer value of point or mark, whichever is larger. */)
335 return region_limit (0);
338 DEFUN ("mark-marker", Fmark_marker
, Smark_marker
, 0, 0, 0,
339 doc
: /* Return this buffer's mark, as a marker object.
340 Watch out! Moving this marker changes the mark position.
341 If you set the marker not to point anywhere, the buffer will have no mark. */)
344 return BVAR (current_buffer
, mark
);
348 /* Find all the overlays in the current buffer that touch position POS.
349 Return the number found, and store them in a vector in VEC
353 overlays_around (EMACS_INT pos
, Lisp_Object
*vec
, int len
)
355 Lisp_Object overlay
, start
, end
;
356 struct Lisp_Overlay
*tail
;
357 EMACS_INT startpos
, endpos
;
360 for (tail
= current_buffer
->overlays_before
; tail
; tail
= tail
->next
)
362 XSETMISC (overlay
, tail
);
364 end
= OVERLAY_END (overlay
);
365 endpos
= OVERLAY_POSITION (end
);
368 start
= OVERLAY_START (overlay
);
369 startpos
= OVERLAY_POSITION (start
);
374 /* Keep counting overlays even if we can't return them all. */
379 for (tail
= current_buffer
->overlays_after
; tail
; tail
= tail
->next
)
381 XSETMISC (overlay
, tail
);
383 start
= OVERLAY_START (overlay
);
384 startpos
= OVERLAY_POSITION (start
);
387 end
= OVERLAY_END (overlay
);
388 endpos
= OVERLAY_POSITION (end
);
400 /* Return the value of property PROP, in OBJECT at POSITION.
401 It's the value of PROP that a char inserted at POSITION would get.
402 OBJECT is optional and defaults to the current buffer.
403 If OBJECT is a buffer, then overlay properties are considered as well as
405 If OBJECT is a window, then that window's buffer is used, but
406 window-specific overlays are considered only if they are associated
409 get_pos_property (Lisp_Object position
, register Lisp_Object prop
, Lisp_Object object
)
411 CHECK_NUMBER_COERCE_MARKER (position
);
414 XSETBUFFER (object
, current_buffer
);
415 else if (WINDOWP (object
))
416 object
= XWINDOW (object
)->buffer
;
418 if (!BUFFERP (object
))
419 /* pos-property only makes sense in buffers right now, since strings
420 have no overlays and no notion of insertion for which stickiness
422 return Fget_text_property (position
, prop
, object
);
425 EMACS_INT posn
= XINT (position
);
427 Lisp_Object
*overlay_vec
, tem
;
428 struct buffer
*obuf
= current_buffer
;
430 set_buffer_temp (XBUFFER (object
));
432 /* First try with room for 40 overlays. */
434 overlay_vec
= (Lisp_Object
*) alloca (noverlays
* sizeof (Lisp_Object
));
435 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
437 /* If there are more than 40,
438 make enough space for all, and try again. */
441 overlay_vec
= (Lisp_Object
*) alloca (noverlays
* sizeof (Lisp_Object
));
442 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
444 noverlays
= sort_overlays (overlay_vec
, noverlays
, NULL
);
446 set_buffer_temp (obuf
);
448 /* Now check the overlays in order of decreasing priority. */
449 while (--noverlays
>= 0)
451 Lisp_Object ol
= overlay_vec
[noverlays
];
452 tem
= Foverlay_get (ol
, prop
);
455 /* Check the overlay is indeed active at point. */
456 Lisp_Object start
= OVERLAY_START (ol
), finish
= OVERLAY_END (ol
);
457 if ((OVERLAY_POSITION (start
) == posn
458 && XMARKER (start
)->insertion_type
== 1)
459 || (OVERLAY_POSITION (finish
) == posn
460 && XMARKER (finish
)->insertion_type
== 0))
461 ; /* The overlay will not cover a char inserted at point. */
469 { /* Now check the text properties. */
470 int stickiness
= text_property_stickiness (prop
, position
, object
);
472 return Fget_text_property (position
, prop
, object
);
473 else if (stickiness
< 0
474 && XINT (position
) > BUF_BEGV (XBUFFER (object
)))
475 return Fget_text_property (make_number (XINT (position
) - 1),
483 /* Find the field surrounding POS in *BEG and *END. If POS is nil,
484 the value of point is used instead. If BEG or END is null,
485 means don't store the beginning or end of the field.
487 BEG_LIMIT and END_LIMIT serve to limit the ranged of the returned
488 results; they do not effect boundary behavior.
490 If MERGE_AT_BOUNDARY is nonzero, then if POS is at the very first
491 position of a field, then the beginning of the previous field is
492 returned instead of the beginning of POS's field (since the end of a
493 field is actually also the beginning of the next input field, this
494 behavior is sometimes useful). Additionally in the MERGE_AT_BOUNDARY
495 true case, if two fields are separated by a field with the special
496 value `boundary', and POS lies within it, then the two separated
497 fields are considered to be adjacent, and POS between them, when
498 finding the beginning and ending of the "merged" field.
500 Either BEG or END may be 0, in which case the corresponding value
504 find_field (Lisp_Object pos
, Lisp_Object merge_at_boundary
,
505 Lisp_Object beg_limit
,
506 EMACS_INT
*beg
, Lisp_Object end_limit
, EMACS_INT
*end
)
508 /* Fields right before and after the point. */
509 Lisp_Object before_field
, after_field
;
510 /* 1 if POS counts as the start of a field. */
511 int at_field_start
= 0;
512 /* 1 if POS counts as the end of a field. */
513 int at_field_end
= 0;
516 XSETFASTINT (pos
, PT
);
518 CHECK_NUMBER_COERCE_MARKER (pos
);
521 = get_char_property_and_overlay (pos
, Qfield
, Qnil
, NULL
);
523 = (XFASTINT (pos
) > BEGV
524 ? get_char_property_and_overlay (make_number (XINT (pos
) - 1),
526 /* Using nil here would be a more obvious choice, but it would
527 fail when the buffer starts with a non-sticky field. */
530 /* See if we need to handle the case where MERGE_AT_BOUNDARY is nil
531 and POS is at beginning of a field, which can also be interpreted
532 as the end of the previous field. Note that the case where if
533 MERGE_AT_BOUNDARY is non-nil (see function comment) is actually the
534 more natural one; then we avoid treating the beginning of a field
536 if (NILP (merge_at_boundary
))
538 Lisp_Object field
= get_pos_property (pos
, Qfield
, Qnil
);
539 if (!EQ (field
, after_field
))
541 if (!EQ (field
, before_field
))
543 if (NILP (field
) && at_field_start
&& at_field_end
)
544 /* If an inserted char would have a nil field while the surrounding
545 text is non-nil, we're probably not looking at a
546 zero-length field, but instead at a non-nil field that's
547 not intended for editing (such as comint's prompts). */
548 at_field_end
= at_field_start
= 0;
551 /* Note about special `boundary' fields:
553 Consider the case where the point (`.') is between the fields `x' and `y':
557 In this situation, if merge_at_boundary is true, we consider the
558 `x' and `y' fields as forming one big merged field, and so the end
559 of the field is the end of `y'.
561 However, if `x' and `y' are separated by a special `boundary' field
562 (a field with a `field' char-property of 'boundary), then we ignore
563 this special field when merging adjacent fields. Here's the same
564 situation, but with a `boundary' field between the `x' and `y' fields:
568 Here, if point is at the end of `x', the beginning of `y', or
569 anywhere in-between (within the `boundary' field), we merge all
570 three fields and consider the beginning as being the beginning of
571 the `x' field, and the end as being the end of the `y' field. */
576 /* POS is at the edge of a field, and we should consider it as
577 the beginning of the following field. */
578 *beg
= XFASTINT (pos
);
580 /* Find the previous field boundary. */
583 if (!NILP (merge_at_boundary
) && EQ (before_field
, Qboundary
))
584 /* Skip a `boundary' field. */
585 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
588 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
590 *beg
= NILP (p
) ? BEGV
: XFASTINT (p
);
597 /* POS is at the edge of a field, and we should consider it as
598 the end of the previous field. */
599 *end
= XFASTINT (pos
);
601 /* Find the next field boundary. */
603 if (!NILP (merge_at_boundary
) && EQ (after_field
, Qboundary
))
604 /* Skip a `boundary' field. */
605 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
608 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
610 *end
= NILP (pos
) ? ZV
: XFASTINT (pos
);
616 DEFUN ("delete-field", Fdelete_field
, Sdelete_field
, 0, 1, 0,
617 doc
: /* Delete the field surrounding POS.
618 A field is a region of text with the same `field' property.
619 If POS is nil, the value of point is used for POS. */)
623 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
625 del_range (beg
, end
);
629 DEFUN ("field-string", Ffield_string
, Sfield_string
, 0, 1, 0,
630 doc
: /* Return the contents of the field surrounding POS as a string.
631 A field is a region of text with the same `field' property.
632 If POS is nil, the value of point is used for POS. */)
636 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
637 return make_buffer_string (beg
, end
, 1);
640 DEFUN ("field-string-no-properties", Ffield_string_no_properties
, Sfield_string_no_properties
, 0, 1, 0,
641 doc
: /* Return the contents of the field around POS, without text properties.
642 A field is a region of text with the same `field' property.
643 If POS is nil, the value of point is used for POS. */)
647 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
648 return make_buffer_string (beg
, end
, 0);
651 DEFUN ("field-beginning", Ffield_beginning
, Sfield_beginning
, 0, 3, 0,
652 doc
: /* Return the beginning of the field surrounding POS.
653 A field is a region of text with the same `field' property.
654 If POS is nil, the value of point is used for POS.
655 If ESCAPE-FROM-EDGE is non-nil and POS is at the beginning of its
656 field, then the beginning of the *previous* field is returned.
657 If LIMIT is non-nil, it is a buffer position; if the beginning of the field
658 is before LIMIT, then LIMIT will be returned instead. */)
659 (Lisp_Object pos
, Lisp_Object escape_from_edge
, Lisp_Object limit
)
662 find_field (pos
, escape_from_edge
, limit
, &beg
, Qnil
, 0);
663 return make_number (beg
);
666 DEFUN ("field-end", Ffield_end
, Sfield_end
, 0, 3, 0,
667 doc
: /* Return the end of the field surrounding POS.
668 A field is a region of text with the same `field' property.
669 If POS is nil, the value of point is used for POS.
670 If ESCAPE-FROM-EDGE is non-nil and POS is at the end of its field,
671 then the end of the *following* field is returned.
672 If LIMIT is non-nil, it is a buffer position; if the end of the field
673 is after LIMIT, then LIMIT will be returned instead. */)
674 (Lisp_Object pos
, Lisp_Object escape_from_edge
, Lisp_Object limit
)
677 find_field (pos
, escape_from_edge
, Qnil
, 0, limit
, &end
);
678 return make_number (end
);
681 DEFUN ("constrain-to-field", Fconstrain_to_field
, Sconstrain_to_field
, 2, 5, 0,
682 doc
: /* Return the position closest to NEW-POS that is in the same field as OLD-POS.
684 A field is a region of text with the same `field' property.
685 If NEW-POS is nil, then the current point is used instead, and set to the
686 constrained position if that is different.
688 If OLD-POS is at the boundary of two fields, then the allowable
689 positions for NEW-POS depends on the value of the optional argument
690 ESCAPE-FROM-EDGE: If ESCAPE-FROM-EDGE is nil, then NEW-POS is
691 constrained to the field that has the same `field' char-property
692 as any new characters inserted at OLD-POS, whereas if ESCAPE-FROM-EDGE
693 is non-nil, NEW-POS is constrained to the union of the two adjacent
694 fields. Additionally, if two fields are separated by another field with
695 the special value `boundary', then any point within this special field is
696 also considered to be `on the boundary'.
698 If the optional argument ONLY-IN-LINE is non-nil and constraining
699 NEW-POS would move it to a different line, NEW-POS is returned
700 unconstrained. This useful for commands that move by line, like
701 \\[next-line] or \\[beginning-of-line], which should generally respect field boundaries
702 only in the case where they can still move to the right line.
704 If the optional argument INHIBIT-CAPTURE-PROPERTY is non-nil, and OLD-POS has
705 a non-nil property of that name, then any field boundaries are ignored.
707 Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
708 (Lisp_Object new_pos
, Lisp_Object old_pos
, Lisp_Object escape_from_edge
, Lisp_Object only_in_line
, Lisp_Object inhibit_capture_property
)
710 /* If non-zero, then the original point, before re-positioning. */
711 EMACS_INT orig_point
= 0;
713 Lisp_Object prev_old
, prev_new
;
716 /* Use the current point, and afterwards, set it. */
719 XSETFASTINT (new_pos
, PT
);
722 CHECK_NUMBER_COERCE_MARKER (new_pos
);
723 CHECK_NUMBER_COERCE_MARKER (old_pos
);
725 fwd
= (XFASTINT (new_pos
) > XFASTINT (old_pos
));
727 prev_old
= make_number (XFASTINT (old_pos
) - 1);
728 prev_new
= make_number (XFASTINT (new_pos
) - 1);
730 if (NILP (Vinhibit_field_text_motion
)
731 && !EQ (new_pos
, old_pos
)
732 && (!NILP (Fget_char_property (new_pos
, Qfield
, Qnil
))
733 || !NILP (Fget_char_property (old_pos
, Qfield
, Qnil
))
734 /* To recognize field boundaries, we must also look at the
735 previous positions; we could use `get_pos_property'
736 instead, but in itself that would fail inside non-sticky
737 fields (like comint prompts). */
738 || (XFASTINT (new_pos
) > BEGV
739 && !NILP (Fget_char_property (prev_new
, Qfield
, Qnil
)))
740 || (XFASTINT (old_pos
) > BEGV
741 && !NILP (Fget_char_property (prev_old
, Qfield
, Qnil
))))
742 && (NILP (inhibit_capture_property
)
743 /* Field boundaries are again a problem; but now we must
744 decide the case exactly, so we need to call
745 `get_pos_property' as well. */
746 || (NILP (get_pos_property (old_pos
, inhibit_capture_property
, Qnil
))
747 && (XFASTINT (old_pos
) <= BEGV
748 || NILP (Fget_char_property (old_pos
, inhibit_capture_property
, Qnil
))
749 || NILP (Fget_char_property (prev_old
, inhibit_capture_property
, Qnil
))))))
750 /* It is possible that NEW_POS is not within the same field as
751 OLD_POS; try to move NEW_POS so that it is. */
754 Lisp_Object field_bound
;
757 field_bound
= Ffield_end (old_pos
, escape_from_edge
, new_pos
);
759 field_bound
= Ffield_beginning (old_pos
, escape_from_edge
, new_pos
);
761 if (/* See if ESCAPE_FROM_EDGE caused FIELD_BOUND to jump to the
762 other side of NEW_POS, which would mean that NEW_POS is
763 already acceptable, and it's not necessary to constrain it
765 ((XFASTINT (field_bound
) < XFASTINT (new_pos
)) ? fwd
: !fwd
)
766 /* NEW_POS should be constrained, but only if either
767 ONLY_IN_LINE is nil (in which case any constraint is OK),
768 or NEW_POS and FIELD_BOUND are on the same line (in which
769 case the constraint is OK even if ONLY_IN_LINE is non-nil). */
770 && (NILP (only_in_line
)
771 /* This is the ONLY_IN_LINE case, check that NEW_POS and
772 FIELD_BOUND are on the same line by seeing whether
773 there's an intervening newline or not. */
774 || (scan_buffer ('\n',
775 XFASTINT (new_pos
), XFASTINT (field_bound
),
776 fwd
? -1 : 1, &shortage
, 1),
778 /* Constrain NEW_POS to FIELD_BOUND. */
779 new_pos
= field_bound
;
781 if (orig_point
&& XFASTINT (new_pos
) != orig_point
)
782 /* The NEW_POS argument was originally nil, so automatically set PT. */
783 SET_PT (XFASTINT (new_pos
));
790 DEFUN ("line-beginning-position",
791 Fline_beginning_position
, Sline_beginning_position
, 0, 1, 0,
792 doc
: /* Return the character position of the first character on the current line.
793 With argument N not nil or 1, move forward N - 1 lines first.
794 If scan reaches end of buffer, return that position.
796 The returned position is of the first character in the logical order,
797 i.e. the one that has the smallest character position.
799 This function constrains the returned position to the current field
800 unless that would be on a different line than the original,
801 unconstrained result. If N is nil or 1, and a front-sticky field
802 starts at point, the scan stops as soon as it starts. To ignore field
803 boundaries bind `inhibit-field-text-motion' to t.
805 This function does not move point. */)
808 EMACS_INT orig
, orig_byte
, end
;
809 int count
= SPECPDL_INDEX ();
810 specbind (Qinhibit_point_motion_hooks
, Qt
);
819 Fforward_line (make_number (XINT (n
) - 1));
822 SET_PT_BOTH (orig
, orig_byte
);
824 unbind_to (count
, Qnil
);
826 /* Return END constrained to the current input field. */
827 return Fconstrain_to_field (make_number (end
), make_number (orig
),
828 XINT (n
) != 1 ? Qt
: Qnil
,
832 DEFUN ("line-end-position", Fline_end_position
, Sline_end_position
, 0, 1, 0,
833 doc
: /* Return the character position of the last character on the current line.
834 With argument N not nil or 1, move forward N - 1 lines first.
835 If scan reaches end of buffer, return that position.
837 The returned position is of the last character in the logical order,
838 i.e. the character whose buffer position is the largest one.
840 This function constrains the returned position to the current field
841 unless that would be on a different line than the original,
842 unconstrained result. If N is nil or 1, and a rear-sticky field ends
843 at point, the scan stops as soon as it starts. To ignore field
844 boundaries bind `inhibit-field-text-motion' to t.
846 This function does not move point. */)
857 end_pos
= find_before_next_newline (orig
, 0, XINT (n
) - (XINT (n
) <= 0));
859 /* Return END_POS constrained to the current input field. */
860 return Fconstrain_to_field (make_number (end_pos
), make_number (orig
),
866 save_excursion_save (void)
868 int visible
= (XBUFFER (XWINDOW (selected_window
)->buffer
)
871 return Fcons (Fpoint_marker (),
872 Fcons (Fcopy_marker (BVAR (current_buffer
, mark
), Qnil
),
873 Fcons (visible
? Qt
: Qnil
,
874 Fcons (BVAR (current_buffer
, mark_active
),
879 save_excursion_restore (Lisp_Object info
)
881 Lisp_Object tem
, tem1
, omark
, nmark
;
882 struct gcpro gcpro1
, gcpro2
, gcpro3
;
885 tem
= Fmarker_buffer (XCAR (info
));
886 /* If buffer being returned to is now deleted, avoid error */
887 /* Otherwise could get error here while unwinding to top level
889 /* In that case, Fmarker_buffer returns nil now. */
893 omark
= nmark
= Qnil
;
894 GCPRO3 (info
, omark
, nmark
);
901 unchain_marker (XMARKER (tem
));
906 omark
= Fmarker_position (BVAR (current_buffer
, mark
));
907 Fset_marker (BVAR (current_buffer
, mark
), tem
, Fcurrent_buffer ());
908 nmark
= Fmarker_position (tem
);
909 unchain_marker (XMARKER (tem
));
913 visible_p
= !NILP (XCAR (info
));
915 #if 0 /* We used to make the current buffer visible in the selected window
916 if that was true previously. That avoids some anomalies.
917 But it creates others, and it wasn't documented, and it is simpler
918 and cleaner never to alter the window/buffer connections. */
921 && current_buffer
!= XBUFFER (XWINDOW (selected_window
)->buffer
))
922 Fswitch_to_buffer (Fcurrent_buffer (), Qnil
);
928 tem1
= BVAR (current_buffer
, mark_active
);
929 BVAR (current_buffer
, mark_active
) = tem
;
931 if (!NILP (Vrun_hooks
))
933 /* If mark is active now, and either was not active
934 or was at a different place, run the activate hook. */
935 if (! NILP (BVAR (current_buffer
, mark_active
)))
937 if (! EQ (omark
, nmark
))
938 call1 (Vrun_hooks
, intern ("activate-mark-hook"));
940 /* If mark has ceased to be active, run deactivate hook. */
941 else if (! NILP (tem1
))
942 call1 (Vrun_hooks
, intern ("deactivate-mark-hook"));
945 /* If buffer was visible in a window, and a different window was
946 selected, and the old selected window is still showing this
947 buffer, restore point in that window. */
950 && !EQ (tem
, selected_window
)
951 && (tem1
= XWINDOW (tem
)->buffer
,
952 (/* Window is live... */
954 /* ...and it shows the current buffer. */
955 && XBUFFER (tem1
) == current_buffer
)))
956 Fset_window_point (tem
, make_number (PT
));
962 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
963 doc
: /* Save point, mark, and current buffer; execute BODY; restore those things.
964 Executes BODY just like `progn'.
965 The values of point, mark and the current buffer are restored
966 even in case of abnormal exit (throw or error).
967 The state of activation of the mark is also restored.
969 This construct does not save `deactivate-mark', and therefore
970 functions that change the buffer will still cause deactivation
971 of the mark at the end of the command. To prevent that, bind
972 `deactivate-mark' with `let'.
974 If you only want to save the current buffer but not point nor mark,
975 then just use `save-current-buffer', or even `with-current-buffer'.
977 usage: (save-excursion &rest BODY) */)
980 register Lisp_Object val
;
981 int count
= SPECPDL_INDEX ();
983 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
986 return unbind_to (count
, val
);
989 DEFUN ("save-current-buffer", Fsave_current_buffer
, Ssave_current_buffer
, 0, UNEVALLED
, 0,
990 doc
: /* Save the current buffer; execute BODY; restore the current buffer.
991 Executes BODY just like `progn'.
992 usage: (save-current-buffer &rest BODY) */)
996 int count
= SPECPDL_INDEX ();
998 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
1000 val
= Fprogn (args
);
1001 return unbind_to (count
, val
);
1004 DEFUN ("buffer-size", Fbufsize
, Sbufsize
, 0, 1, 0,
1005 doc
: /* Return the number of characters in the current buffer.
1006 If BUFFER, return the number of characters in that buffer instead. */)
1007 (Lisp_Object buffer
)
1010 return make_number (Z
- BEG
);
1013 CHECK_BUFFER (buffer
);
1014 return make_number (BUF_Z (XBUFFER (buffer
))
1015 - BUF_BEG (XBUFFER (buffer
)));
1019 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
1020 doc
: /* Return the minimum permissible value of point in the current buffer.
1021 This is 1, unless narrowing (a buffer restriction) is in effect. */)
1025 XSETFASTINT (temp
, BEGV
);
1029 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
1030 doc
: /* Return a marker to the minimum permissible value of point in this buffer.
1031 This is the beginning, unless narrowing (a buffer restriction) is in effect. */)
1034 return buildmark (BEGV
, BEGV_BYTE
);
1037 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
1038 doc
: /* Return the maximum permissible value of point in the current buffer.
1039 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1040 is in effect, in which case it is less. */)
1044 XSETFASTINT (temp
, ZV
);
1048 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
1049 doc
: /* Return a marker to the maximum permissible value of point in this buffer.
1050 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1051 is in effect, in which case it is less. */)
1054 return buildmark (ZV
, ZV_BYTE
);
1057 DEFUN ("gap-position", Fgap_position
, Sgap_position
, 0, 0, 0,
1058 doc
: /* Return the position of the gap, in the current buffer.
1059 See also `gap-size'. */)
1063 XSETFASTINT (temp
, GPT
);
1067 DEFUN ("gap-size", Fgap_size
, Sgap_size
, 0, 0, 0,
1068 doc
: /* Return the size of the current buffer's gap.
1069 See also `gap-position'. */)
1073 XSETFASTINT (temp
, GAP_SIZE
);
1077 DEFUN ("position-bytes", Fposition_bytes
, Sposition_bytes
, 1, 1, 0,
1078 doc
: /* Return the byte position for character position POSITION.
1079 If POSITION is out of range, the value is nil. */)
1080 (Lisp_Object position
)
1082 CHECK_NUMBER_COERCE_MARKER (position
);
1083 if (XINT (position
) < BEG
|| XINT (position
) > Z
)
1085 return make_number (CHAR_TO_BYTE (XINT (position
)));
1088 DEFUN ("byte-to-position", Fbyte_to_position
, Sbyte_to_position
, 1, 1, 0,
1089 doc
: /* Return the character position for byte position BYTEPOS.
1090 If BYTEPOS is out of range, the value is nil. */)
1091 (Lisp_Object bytepos
)
1093 CHECK_NUMBER (bytepos
);
1094 if (XINT (bytepos
) < BEG_BYTE
|| XINT (bytepos
) > Z_BYTE
)
1096 return make_number (BYTE_TO_CHAR (XINT (bytepos
)));
1099 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
1100 doc
: /* Return the character following point, as a number.
1101 At the end of the buffer or accessible region, return 0. */)
1106 XSETFASTINT (temp
, 0);
1108 XSETFASTINT (temp
, FETCH_CHAR (PT_BYTE
));
1112 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
1113 doc
: /* Return the character preceding point, as a number.
1114 At the beginning of the buffer or accessible region, return 0. */)
1119 XSETFASTINT (temp
, 0);
1120 else if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1122 EMACS_INT pos
= PT_BYTE
;
1124 XSETFASTINT (temp
, FETCH_CHAR (pos
));
1127 XSETFASTINT (temp
, FETCH_BYTE (PT_BYTE
- 1));
1131 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
1132 doc
: /* Return t if point is at the beginning of the buffer.
1133 If the buffer is narrowed, this means the beginning of the narrowed part. */)
1141 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
1142 doc
: /* Return t if point is at the end of the buffer.
1143 If the buffer is narrowed, this means the end of the narrowed part. */)
1151 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
1152 doc
: /* Return t if point is at the beginning of a line. */)
1155 if (PT
== BEGV
|| FETCH_BYTE (PT_BYTE
- 1) == '\n')
1160 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
1161 doc
: /* Return t if point is at the end of a line.
1162 `End of a line' includes point being at the end of the buffer. */)
1165 if (PT
== ZV
|| FETCH_BYTE (PT_BYTE
) == '\n')
1170 DEFUN ("char-after", Fchar_after
, Schar_after
, 0, 1, 0,
1171 doc
: /* Return character in current buffer at position POS.
1172 POS is an integer or a marker and defaults to point.
1173 If POS is out of range, the value is nil. */)
1176 register EMACS_INT pos_byte
;
1181 XSETFASTINT (pos
, PT
);
1186 pos_byte
= marker_byte_position (pos
);
1187 if (pos_byte
< BEGV_BYTE
|| pos_byte
>= ZV_BYTE
)
1192 CHECK_NUMBER_COERCE_MARKER (pos
);
1193 if (XINT (pos
) < BEGV
|| XINT (pos
) >= ZV
)
1196 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1199 return make_number (FETCH_CHAR (pos_byte
));
1202 DEFUN ("char-before", Fchar_before
, Schar_before
, 0, 1, 0,
1203 doc
: /* Return character in current buffer preceding position POS.
1204 POS is an integer or a marker and defaults to point.
1205 If POS is out of range, the value is nil. */)
1208 register Lisp_Object val
;
1209 register EMACS_INT pos_byte
;
1214 XSETFASTINT (pos
, PT
);
1219 pos_byte
= marker_byte_position (pos
);
1221 if (pos_byte
<= BEGV_BYTE
|| pos_byte
> ZV_BYTE
)
1226 CHECK_NUMBER_COERCE_MARKER (pos
);
1228 if (XINT (pos
) <= BEGV
|| XINT (pos
) > ZV
)
1231 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1234 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1237 XSETFASTINT (val
, FETCH_CHAR (pos_byte
));
1242 XSETFASTINT (val
, FETCH_BYTE (pos_byte
));
1247 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 1, 0,
1248 doc
: /* Return the name under which the user logged in, as a string.
1249 This is based on the effective uid, not the real uid.
1250 Also, if the environment variables LOGNAME or USER are set,
1251 that determines the value of this function.
1253 If optional argument UID is an integer or a float, return the login name
1254 of the user with that uid, or nil if there is no such user. */)
1260 /* Set up the user name info if we didn't do it before.
1261 (That can happen if Emacs is dumpable
1262 but you decide to run `temacs -l loadup' and not dump. */
1263 if (INTEGERP (Vuser_login_name
))
1267 return Vuser_login_name
;
1269 id
= (uid_t
)XFLOATINT (uid
);
1271 pw
= (struct passwd
*) getpwuid (id
);
1273 return (pw
? build_string (pw
->pw_name
) : Qnil
);
1276 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
1278 doc
: /* Return the name of the user's real uid, as a string.
1279 This ignores the environment variables LOGNAME and USER, so it differs from
1280 `user-login-name' when running under `su'. */)
1283 /* Set up the user name info if we didn't do it before.
1284 (That can happen if Emacs is dumpable
1285 but you decide to run `temacs -l loadup' and not dump. */
1286 if (INTEGERP (Vuser_login_name
))
1288 return Vuser_real_login_name
;
1291 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
1292 doc
: /* Return the effective uid of Emacs.
1293 Value is an integer or a float, depending on the value. */)
1296 /* Assignment to EMACS_INT stops GCC whining about limited range of
1298 EMACS_INT euid
= geteuid ();
1300 /* Make sure we don't produce a negative UID due to signed integer
1303 return make_float ((double)geteuid ());
1304 return make_fixnum_or_float (euid
);
1307 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
1308 doc
: /* Return the real uid of Emacs.
1309 Value is an integer or a float, depending on the value. */)
1312 /* Assignment to EMACS_INT stops GCC whining about limited range of
1314 EMACS_INT uid
= getuid ();
1316 /* Make sure we don't produce a negative UID due to signed integer
1319 return make_float ((double)getuid ());
1320 return make_fixnum_or_float (uid
);
1323 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 1, 0,
1324 doc
: /* Return the full name of the user logged in, as a string.
1325 If the full name corresponding to Emacs's userid is not known,
1328 If optional argument UID is an integer or float, return the full name
1329 of the user with that uid, or nil if there is no such user.
1330 If UID is a string, return the full name of the user with that login
1331 name, or nil if there is no such user. */)
1335 register char *p
, *q
;
1339 return Vuser_full_name
;
1340 else if (NUMBERP (uid
))
1343 pw
= (struct passwd
*) getpwuid ((uid_t
) XFLOATINT (uid
));
1346 else if (STRINGP (uid
))
1349 pw
= (struct passwd
*) getpwnam (SSDATA (uid
));
1353 error ("Invalid UID specification");
1359 /* Chop off everything after the first comma. */
1360 q
= strchr (p
, ',');
1361 full
= make_string (p
, q
? q
- p
: strlen (p
));
1363 #ifdef AMPERSAND_FULL_NAME
1365 q
= strchr (p
, '&');
1366 /* Substitute the login name for the &, upcasing the first character. */
1372 login
= Fuser_login_name (make_number (pw
->pw_uid
));
1373 r
= (char *) alloca (strlen (p
) + SCHARS (login
) + 1);
1374 memcpy (r
, p
, q
- p
);
1376 strcat (r
, SSDATA (login
));
1377 r
[q
- p
] = UPCASE ((unsigned char) r
[q
- p
]);
1379 full
= build_string (r
);
1381 #endif /* AMPERSAND_FULL_NAME */
1386 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
1387 doc
: /* Return the host name of the machine you are running on, as a string. */)
1390 return Vsystem_name
;
1393 /* For the benefit of callers who don't want to include lisp.h */
1396 get_system_name (void)
1398 if (STRINGP (Vsystem_name
))
1399 return SSDATA (Vsystem_name
);
1405 get_operating_system_release (void)
1407 if (STRINGP (Voperating_system_release
))
1408 return SSDATA (Voperating_system_release
);
1413 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
1414 doc
: /* Return the process ID of Emacs, as an integer. */)
1417 return make_number (getpid ());
1423 # define TIME_T_MIN TYPE_MINIMUM (time_t)
1426 # define TIME_T_MAX TYPE_MAXIMUM (time_t)
1429 /* Report that a time value is out of range for Emacs. */
1431 time_overflow (void)
1433 error ("Specified time is not representable");
1436 /* Return the upper part of the time T (everything but the bottom 16 bits),
1437 making sure that it is representable. */
1441 time_t hi
= t
>> 16;
1443 /* Check for overflow, helping the compiler for common cases where
1444 no runtime check is needed, and taking care not to convert
1445 negative numbers to unsigned before comparing them. */
1446 if (! ((! TYPE_SIGNED (time_t)
1447 || MOST_NEGATIVE_FIXNUM
<= TIME_T_MIN
>> 16
1448 || MOST_NEGATIVE_FIXNUM
<= hi
)
1449 && (TIME_T_MAX
>> 16 <= MOST_POSITIVE_FIXNUM
1450 || hi
<= MOST_POSITIVE_FIXNUM
)))
1456 /* Return the bottom 16 bits of the time T. */
1460 return t
& ((1 << 16) - 1);
1463 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
1464 doc
: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
1465 The time is returned as a list of three integers. The first has the
1466 most significant 16 bits of the seconds, while the second has the
1467 least significant 16 bits. The third integer gives the microsecond
1470 The microsecond count is zero on systems that do not provide
1471 resolution finer than a second. */)
1477 return list3 (make_number (hi_time (EMACS_SECS (t
))),
1478 make_number (lo_time (EMACS_SECS (t
))),
1479 make_number (EMACS_USECS (t
)));
1482 DEFUN ("get-internal-run-time", Fget_internal_run_time
, Sget_internal_run_time
,
1484 doc
: /* Return the current run time used by Emacs.
1485 The time is returned as a list of three integers. The first has the
1486 most significant 16 bits of the seconds, while the second has the
1487 least significant 16 bits. The third integer gives the microsecond
1490 On systems that can't determine the run time, `get-internal-run-time'
1491 does the same thing as `current-time'. The microsecond count is zero
1492 on systems that do not provide resolution finer than a second. */)
1495 #ifdef HAVE_GETRUSAGE
1496 struct rusage usage
;
1500 if (getrusage (RUSAGE_SELF
, &usage
) < 0)
1501 /* This shouldn't happen. What action is appropriate? */
1504 /* Sum up user time and system time. */
1505 secs
= usage
.ru_utime
.tv_sec
+ usage
.ru_stime
.tv_sec
;
1506 usecs
= usage
.ru_utime
.tv_usec
+ usage
.ru_stime
.tv_usec
;
1507 if (usecs
>= 1000000)
1513 return list3 (make_number (hi_time (secs
)),
1514 make_number (lo_time (secs
)),
1515 make_number (usecs
));
1516 #else /* ! HAVE_GETRUSAGE */
1518 return w32_get_internal_run_time ();
1519 #else /* ! WINDOWSNT */
1520 return Fcurrent_time ();
1521 #endif /* WINDOWSNT */
1522 #endif /* HAVE_GETRUSAGE */
1526 /* Make a Lisp list that represents the time T. */
1528 make_time (time_t t
)
1530 return list2 (make_number (hi_time (t
)),
1531 make_number (lo_time (t
)));
1534 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1535 If SPECIFIED_TIME is nil, use the current time.
1536 Set *RESULT to seconds since the Epoch.
1537 If USEC is not null, set *USEC to the microseconds component.
1538 Return nonzero if successful. */
1540 lisp_time_argument (Lisp_Object specified_time
, time_t *result
, int *usec
)
1542 if (NILP (specified_time
))
1549 *usec
= EMACS_USECS (t
);
1550 *result
= EMACS_SECS (t
);
1554 return time (result
) != -1;
1558 Lisp_Object high
, low
;
1560 high
= Fcar (specified_time
);
1561 CHECK_NUMBER (high
);
1562 low
= Fcdr (specified_time
);
1567 Lisp_Object usec_l
= Fcdr (low
);
1569 usec_l
= Fcar (usec_l
);
1574 CHECK_NUMBER (usec_l
);
1575 *usec
= XINT (usec_l
);
1585 /* Check for overflow, helping the compiler for common cases
1586 where no runtime check is needed, and taking care not to
1587 convert negative numbers to unsigned before comparing them. */
1588 if (! ((TYPE_SIGNED (time_t)
1589 ? (TIME_T_MIN
>> 16 <= MOST_NEGATIVE_FIXNUM
1590 || TIME_T_MIN
>> 16 <= hi
)
1592 && (MOST_POSITIVE_FIXNUM
<= TIME_T_MAX
>> 16
1593 || hi
<= TIME_T_MAX
>> 16)))
1596 *result
= (hi
<< 16) + (XINT (low
) & 0xffff);
1601 DEFUN ("float-time", Ffloat_time
, Sfloat_time
, 0, 1, 0,
1602 doc
: /* Return the current time, as a float number of seconds since the epoch.
1603 If SPECIFIED-TIME is given, it is the time to convert to float
1604 instead of the current time. The argument should have the form
1605 (HIGH LOW) or (HIGH LOW USEC). Thus, you can use times obtained from
1606 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
1607 have the form (HIGH . LOW), but this is considered obsolete.
1609 WARNING: Since the result is floating point, it may not be exact.
1610 If precise time stamps are required, use either `current-time',
1611 or (if you need time as a string) `format-time-string'. */)
1612 (Lisp_Object specified_time
)
1617 if (! lisp_time_argument (specified_time
, &sec
, &usec
))
1618 error ("Invalid time specification");
1620 return make_float ((sec
* 1e6
+ usec
) / 1e6
);
1623 /* Write information into buffer S of size MAXSIZE, according to the
1624 FORMAT of length FORMAT_LEN, using time information taken from *TP.
1625 Default to Universal Time if UT is nonzero, local time otherwise.
1626 Use NS as the number of nanoseconds in the %N directive.
1627 Return the number of bytes written, not including the terminating
1628 '\0'. If S is NULL, nothing will be written anywhere; so to
1629 determine how many bytes would be written, use NULL for S and
1630 ((size_t) -1) for MAXSIZE.
1632 This function behaves like nstrftime, except it allows null
1633 bytes in FORMAT and it does not support nanoseconds. */
1635 emacs_nmemftime (char *s
, size_t maxsize
, const char *format
,
1636 size_t format_len
, const struct tm
*tp
, int ut
, int ns
)
1640 /* Loop through all the null-terminated strings in the format
1641 argument. Normally there's just one null-terminated string, but
1642 there can be arbitrarily many, concatenated together, if the
1643 format contains '\0' bytes. nstrftime stops at the first
1644 '\0' byte so we must invoke it separately for each such string. */
1653 result
= nstrftime (s
, maxsize
, format
, tp
, ut
, ns
);
1657 if (result
== 0 && s
[0] != '\0')
1662 maxsize
-= result
+ 1;
1664 len
= strlen (format
);
1665 if (len
== format_len
)
1669 format_len
-= len
+ 1;
1673 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 1, 3, 0,
1674 doc
: /* Use FORMAT-STRING to format the time TIME, or now if omitted.
1675 TIME is specified as (HIGH LOW . IGNORED), as returned by
1676 `current-time' or `file-attributes'. The obsolete form (HIGH . LOW)
1677 is also still accepted.
1678 The third, optional, argument UNIVERSAL, if non-nil, means describe TIME
1679 as Universal Time; nil means describe TIME in the local time zone.
1680 The value is a copy of FORMAT-STRING, but with certain constructs replaced
1681 by text that describes the specified date and time in TIME:
1683 %Y is the year, %y within the century, %C the century.
1684 %G is the year corresponding to the ISO week, %g within the century.
1685 %m is the numeric month.
1686 %b and %h are the locale's abbreviated month name, %B the full name.
1687 %d is the day of the month, zero-padded, %e is blank-padded.
1688 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
1689 %a is the locale's abbreviated name of the day of week, %A the full name.
1690 %U is the week number starting on Sunday, %W starting on Monday,
1691 %V according to ISO 8601.
1692 %j is the day of the year.
1694 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
1695 only blank-padded, %l is like %I blank-padded.
1696 %p is the locale's equivalent of either AM or PM.
1699 %N is the nanosecond, %6N the microsecond, %3N the millisecond, etc.
1700 %Z is the time zone name, %z is the numeric form.
1701 %s is the number of seconds since 1970-01-01 00:00:00 +0000.
1703 %c is the locale's date and time format.
1704 %x is the locale's "preferred" date format.
1705 %D is like "%m/%d/%y".
1707 %R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
1708 %X is the locale's "preferred" time format.
1710 Finally, %n is a newline, %t is a tab, %% is a literal %.
1712 Certain flags and modifiers are available with some format controls.
1713 The flags are `_', `-', `^' and `#'. For certain characters X,
1714 %_X is like %X, but padded with blanks; %-X is like %X,
1715 but without padding. %^X is like %X, but with all textual
1716 characters up-cased; %#X is like %X, but with letter-case of
1717 all textual characters reversed.
1718 %NX (where N stands for an integer) is like %X,
1719 but takes up at least N (a number) positions.
1720 The modifiers are `E' and `O'. For certain characters X,
1721 %EX is a locale's alternative version of %X;
1722 %OX is like %X, but uses the locale's number symbols.
1724 For example, to produce full ISO 8601 format, use "%Y-%m-%dT%T%z". */)
1725 (Lisp_Object format_string
, Lisp_Object time
, Lisp_Object universal
)
1732 int ut
= ! NILP (universal
);
1734 CHECK_STRING (format_string
);
1736 if (! (lisp_time_argument (time
, &value
, &usec
)
1737 && 0 <= usec
&& usec
< 1000000))
1738 error ("Invalid time specification");
1741 format_string
= code_convert_string_norecord (format_string
,
1742 Vlocale_coding_system
, 1);
1744 /* This is probably enough. */
1745 size
= SBYTES (format_string
) * 6 + 50;
1748 tm
= ut
? gmtime (&value
) : localtime (&value
);
1753 synchronize_system_time_locale ();
1757 char *buf
= (char *) alloca (size
+ 1);
1762 result
= emacs_nmemftime (buf
, size
, SSDATA (format_string
),
1763 SBYTES (format_string
),
1766 if ((result
> 0 && result
< size
) || (result
== 0 && buf
[0] == '\0'))
1767 return code_convert_string_norecord (make_unibyte_string (buf
, result
),
1768 Vlocale_coding_system
, 0);
1770 /* If buffer was too small, make it bigger and try again. */
1772 result
= emacs_nmemftime (NULL
, (size_t) -1,
1773 SSDATA (format_string
),
1774 SBYTES (format_string
),
1781 DEFUN ("decode-time", Fdecode_time
, Sdecode_time
, 0, 1, 0,
1782 doc
: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST ZONE).
1783 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED),
1784 as from `current-time' and `file-attributes', or nil to use the
1785 current time. The obsolete form (HIGH . LOW) is also still accepted.
1786 The list has the following nine members: SEC is an integer between 0
1787 and 60; SEC is 60 for a leap second, which only some operating systems
1788 support. MINUTE is an integer between 0 and 59. HOUR is an integer
1789 between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
1790 integer between 1 and 12. YEAR is an integer indicating the
1791 four-digit year. DOW is the day of week, an integer between 0 and 6,
1792 where 0 is Sunday. DST is t if daylight saving time is in effect,
1793 otherwise nil. ZONE is an integer indicating the number of seconds
1794 east of Greenwich. (Note that Common Lisp has different meanings for
1796 (Lisp_Object specified_time
)
1800 struct tm
*decoded_time
;
1801 Lisp_Object list_args
[9];
1803 if (! lisp_time_argument (specified_time
, &time_spec
, NULL
))
1804 error ("Invalid time specification");
1807 decoded_time
= localtime (&time_spec
);
1810 && MOST_NEGATIVE_FIXNUM
- TM_YEAR_BASE
<= decoded_time
->tm_year
1811 && decoded_time
->tm_year
<= MOST_POSITIVE_FIXNUM
- TM_YEAR_BASE
))
1813 XSETFASTINT (list_args
[0], decoded_time
->tm_sec
);
1814 XSETFASTINT (list_args
[1], decoded_time
->tm_min
);
1815 XSETFASTINT (list_args
[2], decoded_time
->tm_hour
);
1816 XSETFASTINT (list_args
[3], decoded_time
->tm_mday
);
1817 XSETFASTINT (list_args
[4], decoded_time
->tm_mon
+ 1);
1818 /* On 64-bit machines an int is narrower than EMACS_INT, thus the
1819 cast below avoids overflow in int arithmetics. */
1820 XSETINT (list_args
[5], TM_YEAR_BASE
+ (EMACS_INT
) decoded_time
->tm_year
);
1821 XSETFASTINT (list_args
[6], decoded_time
->tm_wday
);
1822 list_args
[7] = (decoded_time
->tm_isdst
)? Qt
: Qnil
;
1824 /* Make a copy, in case gmtime modifies the struct. */
1825 save_tm
= *decoded_time
;
1827 decoded_time
= gmtime (&time_spec
);
1829 if (decoded_time
== 0)
1830 list_args
[8] = Qnil
;
1832 XSETINT (list_args
[8], tm_diff (&save_tm
, decoded_time
));
1833 return Flist (9, list_args
);
1836 /* Return OBJ - OFFSET, checking that OBJ is a valid fixnum and that
1837 the result is representable as an int. Assume OFFSET is small and
1840 check_tm_member (Lisp_Object obj
, int offset
)
1845 if (! (INT_MIN
+ offset
<= n
&& n
- offset
<= INT_MAX
))
1850 DEFUN ("encode-time", Fencode_time
, Sencode_time
, 6, MANY
, 0,
1851 doc
: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
1852 This is the reverse operation of `decode-time', which see.
1853 ZONE defaults to the current time zone rule. This can
1854 be a string or t (as from `set-time-zone-rule'), or it can be a list
1855 \(as from `current-time-zone') or an integer (as from `decode-time')
1856 applied without consideration for daylight saving time.
1858 You can pass more than 7 arguments; then the first six arguments
1859 are used as SECOND through YEAR, and the *last* argument is used as ZONE.
1860 The intervening arguments are ignored.
1861 This feature lets (apply 'encode-time (decode-time ...)) work.
1863 Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed;
1864 for example, a DAY of 0 means the day preceding the given month.
1865 Year numbers less than 100 are treated just like other year numbers.
1866 If you want them to stand for years in this century, you must do that yourself.
1868 Years before 1970 are not guaranteed to work. On some systems,
1869 year values as low as 1901 do work.
1871 usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
1872 (int nargs
, register Lisp_Object
*args
)
1876 Lisp_Object zone
= (nargs
> 6 ? args
[nargs
- 1] : Qnil
);
1878 tm
.tm_sec
= check_tm_member (args
[0], 0);
1879 tm
.tm_min
= check_tm_member (args
[1], 0);
1880 tm
.tm_hour
= check_tm_member (args
[2], 0);
1881 tm
.tm_mday
= check_tm_member (args
[3], 0);
1882 tm
.tm_mon
= check_tm_member (args
[4], 1);
1883 tm
.tm_year
= check_tm_member (args
[5], TM_YEAR_BASE
);
1891 time
= mktime (&tm
);
1897 const char *tzstring
;
1898 char **oldenv
= environ
, **newenv
;
1902 else if (STRINGP (zone
))
1903 tzstring
= SSDATA (zone
);
1904 else if (INTEGERP (zone
))
1906 int abszone
= eabs (XINT (zone
));
1907 sprintf (tzbuf
, "XXX%s%d:%02d:%02d", "-" + (XINT (zone
) < 0),
1908 abszone
/ (60*60), (abszone
/60) % 60, abszone
% 60);
1912 error ("Invalid time zone specification");
1914 /* Set TZ before calling mktime; merely adjusting mktime's returned
1915 value doesn't suffice, since that would mishandle leap seconds. */
1916 set_time_zone_rule (tzstring
);
1919 time
= mktime (&tm
);
1922 /* Restore TZ to previous value. */
1926 #ifdef LOCALTIME_CACHE
1931 if (time
== (time_t) -1)
1934 return make_time (time
);
1937 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
1938 doc
: /* Return the current local time, as a human-readable string.
1939 Programs can use this function to decode a time,
1940 since the number of columns in each field is fixed
1941 if the year is in the range 1000-9999.
1942 The format is `Sun Sep 16 01:03:52 1973'.
1943 However, see also the functions `decode-time' and `format-time-string'
1944 which provide a much more powerful and general facility.
1946 If SPECIFIED-TIME is given, it is a time to format instead of the
1947 current time. The argument should have the form (HIGH LOW . IGNORED).
1948 Thus, you can use times obtained from `current-time' and from
1949 `file-attributes'. SPECIFIED-TIME can also have the form (HIGH . LOW),
1950 but this is considered obsolete. */)
1951 (Lisp_Object specified_time
)
1957 if (! lisp_time_argument (specified_time
, &value
, NULL
))
1958 error ("Invalid time specification");
1960 /* Convert to a string, checking for out-of-range time stamps.
1961 Don't use 'ctime', as that might dump core if VALUE is out of
1964 tm
= localtime (&value
);
1966 if (! (tm
&& TM_YEAR_IN_ASCTIME_RANGE (tm
->tm_year
) && (tem
= asctime (tm
))))
1969 /* Remove the trailing newline. */
1970 tem
[strlen (tem
) - 1] = '\0';
1972 return build_string (tem
);
1975 /* Yield A - B, measured in seconds.
1976 This function is copied from the GNU C Library. */
1978 tm_diff (struct tm
*a
, struct tm
*b
)
1980 /* Compute intervening leap days correctly even if year is negative.
1981 Take care to avoid int overflow in leap day calculations,
1982 but it's OK to assume that A and B are close to each other. */
1983 int a4
= (a
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (a
->tm_year
& 3);
1984 int b4
= (b
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (b
->tm_year
& 3);
1985 int a100
= a4
/ 25 - (a4
% 25 < 0);
1986 int b100
= b4
/ 25 - (b4
% 25 < 0);
1987 int a400
= a100
>> 2;
1988 int b400
= b100
>> 2;
1989 int intervening_leap_days
= (a4
- b4
) - (a100
- b100
) + (a400
- b400
);
1990 int years
= a
->tm_year
- b
->tm_year
;
1991 int days
= (365 * years
+ intervening_leap_days
1992 + (a
->tm_yday
- b
->tm_yday
));
1993 return (60 * (60 * (24 * days
+ (a
->tm_hour
- b
->tm_hour
))
1994 + (a
->tm_min
- b
->tm_min
))
1995 + (a
->tm_sec
- b
->tm_sec
));
1998 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
1999 doc
: /* Return the offset and name for the local time zone.
2000 This returns a list of the form (OFFSET NAME).
2001 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
2002 A negative value means west of Greenwich.
2003 NAME is a string giving the name of the time zone.
2004 If SPECIFIED-TIME is given, the time zone offset is determined from it
2005 instead of using the current time. The argument should have the form
2006 (HIGH LOW . IGNORED). Thus, you can use times obtained from
2007 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
2008 have the form (HIGH . LOW), but this is considered obsolete.
2010 Some operating systems cannot provide all this information to Emacs;
2011 in this case, `current-time-zone' returns a list containing nil for
2012 the data it can't find. */)
2013 (Lisp_Object specified_time
)
2019 if (!lisp_time_argument (specified_time
, &value
, NULL
))
2024 t
= gmtime (&value
);
2028 t
= localtime (&value
);
2035 int offset
= tm_diff (t
, &gmt
);
2041 s
= (char *)t
->tm_zone
;
2042 #else /* not HAVE_TM_ZONE */
2044 if (t
->tm_isdst
== 0 || t
->tm_isdst
== 1)
2045 s
= tzname
[t
->tm_isdst
];
2047 #endif /* not HAVE_TM_ZONE */
2051 /* No local time zone name is available; use "+-NNNN" instead. */
2052 int am
= (offset
< 0 ? -offset
: offset
) / 60;
2053 sprintf (buf
, "%c%02d%02d", (offset
< 0 ? '-' : '+'), am
/60, am
%60);
2057 return Fcons (make_number (offset
), Fcons (build_string (s
), Qnil
));
2060 return Fmake_list (make_number (2), Qnil
);
2063 /* This holds the value of `environ' produced by the previous
2064 call to Fset_time_zone_rule, or 0 if Fset_time_zone_rule
2065 has never been called. */
2066 static char **environbuf
;
2068 /* This holds the startup value of the TZ environment variable so it
2069 can be restored if the user calls set-time-zone-rule with a nil
2071 static char *initial_tz
;
2073 DEFUN ("set-time-zone-rule", Fset_time_zone_rule
, Sset_time_zone_rule
, 1, 1, 0,
2074 doc
: /* Set the local time zone using TZ, a string specifying a time zone rule.
2075 If TZ is nil, use implementation-defined default time zone information.
2076 If TZ is t, use Universal Time. */)
2079 const char *tzstring
;
2081 /* When called for the first time, save the original TZ. */
2083 initial_tz
= (char *) getenv ("TZ");
2086 tzstring
= initial_tz
;
2087 else if (EQ (tz
, Qt
))
2092 tzstring
= SSDATA (tz
);
2095 set_time_zone_rule (tzstring
);
2097 environbuf
= environ
;
2102 #ifdef LOCALTIME_CACHE
2104 /* These two values are known to load tz files in buggy implementations,
2105 i.e. Solaris 1 executables running under either Solaris 1 or Solaris 2.
2106 Their values shouldn't matter in non-buggy implementations.
2107 We don't use string literals for these strings,
2108 since if a string in the environment is in readonly
2109 storage, it runs afoul of bugs in SVR4 and Solaris 2.3.
2110 See Sun bugs 1113095 and 1114114, ``Timezone routines
2111 improperly modify environment''. */
2113 static char set_time_zone_rule_tz1
[] = "TZ=GMT+0";
2114 static char set_time_zone_rule_tz2
[] = "TZ=GMT+1";
2118 /* Set the local time zone rule to TZSTRING.
2119 This allocates memory into `environ', which it is the caller's
2120 responsibility to free. */
2123 set_time_zone_rule (const char *tzstring
)
2126 char **from
, **to
, **newenv
;
2128 /* Make the ENVIRON vector longer with room for TZSTRING. */
2129 for (from
= environ
; *from
; from
++)
2131 envptrs
= from
- environ
+ 2;
2132 newenv
= to
= (char **) xmalloc (envptrs
* sizeof (char *)
2133 + (tzstring
? strlen (tzstring
) + 4 : 0));
2135 /* Add TZSTRING to the end of environ, as a value for TZ. */
2138 char *t
= (char *) (to
+ envptrs
);
2140 strcat (t
, tzstring
);
2144 /* Copy the old environ vector elements into NEWENV,
2145 but don't copy the TZ variable.
2146 So we have only one definition of TZ, which came from TZSTRING. */
2147 for (from
= environ
; *from
; from
++)
2148 if (strncmp (*from
, "TZ=", 3) != 0)
2154 /* If we do have a TZSTRING, NEWENV points to the vector slot where
2155 the TZ variable is stored. If we do not have a TZSTRING,
2156 TO points to the vector slot which has the terminating null. */
2158 #ifdef LOCALTIME_CACHE
2160 /* In SunOS 4.1.3_U1 and 4.1.4, if TZ has a value like
2161 "US/Pacific" that loads a tz file, then changes to a value like
2162 "XXX0" that does not load a tz file, and then changes back to
2163 its original value, the last change is (incorrectly) ignored.
2164 Also, if TZ changes twice in succession to values that do
2165 not load a tz file, tzset can dump core (see Sun bug#1225179).
2166 The following code works around these bugs. */
2170 /* Temporarily set TZ to a value that loads a tz file
2171 and that differs from tzstring. */
2173 *newenv
= (strcmp (tzstring
, set_time_zone_rule_tz1
+ 3) == 0
2174 ? set_time_zone_rule_tz2
: set_time_zone_rule_tz1
);
2180 /* The implied tzstring is unknown, so temporarily set TZ to
2181 two different values that each load a tz file. */
2182 *to
= set_time_zone_rule_tz1
;
2185 *to
= set_time_zone_rule_tz2
;
2190 /* Now TZ has the desired value, and tzset can be invoked safely. */
2197 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
2198 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
2199 type of object is Lisp_String). INHERIT is passed to
2200 INSERT_FROM_STRING_FUNC as the last argument. */
2203 general_insert_function (void (*insert_func
)
2204 (const char *, EMACS_INT
),
2205 void (*insert_from_string_func
)
2206 (Lisp_Object
, EMACS_INT
, EMACS_INT
,
2207 EMACS_INT
, EMACS_INT
, int),
2208 int inherit
, int nargs
, Lisp_Object
*args
)
2210 register int argnum
;
2211 register Lisp_Object val
;
2213 for (argnum
= 0; argnum
< nargs
; argnum
++)
2216 if (CHARACTERP (val
))
2218 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2221 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2222 len
= CHAR_STRING (XFASTINT (val
), str
);
2225 str
[0] = (ASCII_CHAR_P (XINT (val
))
2227 : multibyte_char_to_unibyte (XINT (val
), Qnil
));
2230 (*insert_func
) ((char *) str
, len
);
2232 else if (STRINGP (val
))
2234 (*insert_from_string_func
) (val
, 0, 0,
2240 wrong_type_argument (Qchar_or_string_p
, val
);
2245 insert1 (Lisp_Object arg
)
2251 /* Callers passing one argument to Finsert need not gcpro the
2252 argument "array", since the only element of the array will
2253 not be used after calling insert or insert_from_string, so
2254 we don't care if it gets trashed. */
2256 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
2257 doc
: /* Insert the arguments, either strings or characters, at point.
2258 Point and before-insertion markers move forward to end up
2259 after the inserted text.
2260 Any other markers at the point of insertion remain before the text.
2262 If the current buffer is multibyte, unibyte strings are converted
2263 to multibyte for insertion (see `string-make-multibyte').
2264 If the current buffer is unibyte, multibyte strings are converted
2265 to unibyte for insertion (see `string-make-unibyte').
2267 When operating on binary data, it may be necessary to preserve the
2268 original bytes of a unibyte string when inserting it into a multibyte
2269 buffer; to accomplish this, apply `string-as-multibyte' to the string
2270 and insert the result.
2272 usage: (insert &rest ARGS) */)
2273 (int nargs
, register Lisp_Object
*args
)
2275 general_insert_function (insert
, insert_from_string
, 0, nargs
, args
);
2279 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
2281 doc
: /* Insert the arguments at point, inheriting properties from adjoining text.
2282 Point and before-insertion markers move forward to end up
2283 after the inserted text.
2284 Any other markers at the point of insertion remain before the text.
2286 If the current buffer is multibyte, unibyte strings are converted
2287 to multibyte for insertion (see `unibyte-char-to-multibyte').
2288 If the current buffer is unibyte, multibyte strings are converted
2289 to unibyte for insertion.
2291 usage: (insert-and-inherit &rest ARGS) */)
2292 (int nargs
, register Lisp_Object
*args
)
2294 general_insert_function (insert_and_inherit
, insert_from_string
, 1,
2299 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
2300 doc
: /* Insert strings or characters at point, relocating markers after the text.
2301 Point and markers move forward to end up after the inserted text.
2303 If the current buffer is multibyte, unibyte strings are converted
2304 to multibyte for insertion (see `unibyte-char-to-multibyte').
2305 If the current buffer is unibyte, multibyte strings are converted
2306 to unibyte for insertion.
2308 usage: (insert-before-markers &rest ARGS) */)
2309 (int nargs
, register Lisp_Object
*args
)
2311 general_insert_function (insert_before_markers
,
2312 insert_from_string_before_markers
, 0,
2317 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers
,
2318 Sinsert_and_inherit_before_markers
, 0, MANY
, 0,
2319 doc
: /* Insert text at point, relocating markers and inheriting properties.
2320 Point and markers move forward to end up after the inserted text.
2322 If the current buffer is multibyte, unibyte strings are converted
2323 to multibyte for insertion (see `unibyte-char-to-multibyte').
2324 If the current buffer is unibyte, multibyte strings are converted
2325 to unibyte for insertion.
2327 usage: (insert-before-markers-and-inherit &rest ARGS) */)
2328 (int nargs
, register Lisp_Object
*args
)
2330 general_insert_function (insert_before_markers_and_inherit
,
2331 insert_from_string_before_markers
, 1,
2336 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 2, 3, 0,
2337 doc
: /* Insert COUNT copies of CHARACTER.
2338 Point, and before-insertion markers, are relocated as in the function `insert'.
2339 The optional third arg INHERIT, if non-nil, says to inherit text properties
2340 from adjoining text, if those properties are sticky. */)
2341 (Lisp_Object character
, Lisp_Object count
, Lisp_Object inherit
)
2343 register char *string
;
2344 register EMACS_INT strlen
;
2346 register EMACS_INT n
;
2348 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2350 CHECK_NUMBER (character
);
2351 CHECK_NUMBER (count
);
2353 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2354 len
= CHAR_STRING (XFASTINT (character
), str
);
2356 str
[0] = XFASTINT (character
), len
= 1;
2357 if (MOST_POSITIVE_FIXNUM
/ len
< XINT (count
))
2358 error ("Maximum buffer size would be exceeded");
2359 n
= XINT (count
) * len
;
2362 strlen
= min (n
, 256 * len
);
2363 string
= (char *) alloca (strlen
);
2364 for (i
= 0; i
< strlen
; i
++)
2365 string
[i
] = str
[i
% len
];
2369 if (!NILP (inherit
))
2370 insert_and_inherit (string
, strlen
);
2372 insert (string
, strlen
);
2377 if (!NILP (inherit
))
2378 insert_and_inherit (string
, n
);
2385 DEFUN ("insert-byte", Finsert_byte
, Sinsert_byte
, 2, 3, 0,
2386 doc
: /* Insert COUNT (second arg) copies of BYTE (first arg).
2387 Both arguments are required.
2388 BYTE is a number of the range 0..255.
2390 If BYTE is 128..255 and the current buffer is multibyte, the
2391 corresponding eight-bit character is inserted.
2393 Point, and before-insertion markers, are relocated as in the function `insert'.
2394 The optional third arg INHERIT, if non-nil, says to inherit text properties
2395 from adjoining text, if those properties are sticky. */)
2396 (Lisp_Object byte
, Lisp_Object count
, Lisp_Object inherit
)
2398 CHECK_NUMBER (byte
);
2399 if (XINT (byte
) < 0 || XINT (byte
) > 255)
2400 args_out_of_range_3 (byte
, make_number (0), make_number (255));
2401 if (XINT (byte
) >= 128
2402 && ! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2403 XSETFASTINT (byte
, BYTE8_TO_CHAR (XINT (byte
)));
2404 return Finsert_char (byte
, count
, inherit
);
2408 /* Making strings from buffer contents. */
2410 /* Return a Lisp_String containing the text of the current buffer from
2411 START to END. If text properties are in use and the current buffer
2412 has properties in the range specified, the resulting string will also
2413 have them, if PROPS is nonzero.
2415 We don't want to use plain old make_string here, because it calls
2416 make_uninit_string, which can cause the buffer arena to be
2417 compacted. make_string has no way of knowing that the data has
2418 been moved, and thus copies the wrong data into the string. This
2419 doesn't effect most of the other users of make_string, so it should
2420 be left as is. But we should use this function when conjuring
2421 buffer substrings. */
2424 make_buffer_string (EMACS_INT start
, EMACS_INT end
, int props
)
2426 EMACS_INT start_byte
= CHAR_TO_BYTE (start
);
2427 EMACS_INT end_byte
= CHAR_TO_BYTE (end
);
2429 return make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
);
2432 /* Return a Lisp_String containing the text of the current buffer from
2433 START / START_BYTE to END / END_BYTE.
2435 If text properties are in use and the current buffer
2436 has properties in the range specified, the resulting string will also
2437 have them, if PROPS is nonzero.
2439 We don't want to use plain old make_string here, because it calls
2440 make_uninit_string, which can cause the buffer arena to be
2441 compacted. make_string has no way of knowing that the data has
2442 been moved, and thus copies the wrong data into the string. This
2443 doesn't effect most of the other users of make_string, so it should
2444 be left as is. But we should use this function when conjuring
2445 buffer substrings. */
2448 make_buffer_string_both (EMACS_INT start
, EMACS_INT start_byte
,
2449 EMACS_INT end
, EMACS_INT end_byte
, int props
)
2451 Lisp_Object result
, tem
, tem1
;
2453 if (start
< GPT
&& GPT
< end
)
2456 if (! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2457 result
= make_uninit_multibyte_string (end
- start
, end_byte
- start_byte
);
2459 result
= make_uninit_string (end
- start
);
2460 memcpy (SDATA (result
), BYTE_POS_ADDR (start_byte
), end_byte
- start_byte
);
2462 /* If desired, update and copy the text properties. */
2465 update_buffer_properties (start
, end
);
2467 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
2468 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
2470 if (XINT (tem
) != end
|| !NILP (tem1
))
2471 copy_intervals_to_string (result
, current_buffer
, start
,
2478 /* Call Vbuffer_access_fontify_functions for the range START ... END
2479 in the current buffer, if necessary. */
2482 update_buffer_properties (EMACS_INT start
, EMACS_INT end
)
2484 /* If this buffer has some access functions,
2485 call them, specifying the range of the buffer being accessed. */
2486 if (!NILP (Vbuffer_access_fontify_functions
))
2488 Lisp_Object args
[3];
2491 args
[0] = Qbuffer_access_fontify_functions
;
2492 XSETINT (args
[1], start
);
2493 XSETINT (args
[2], end
);
2495 /* But don't call them if we can tell that the work
2496 has already been done. */
2497 if (!NILP (Vbuffer_access_fontified_property
))
2499 tem
= Ftext_property_any (args
[1], args
[2],
2500 Vbuffer_access_fontified_property
,
2503 Frun_hook_with_args (3, args
);
2506 Frun_hook_with_args (3, args
);
2510 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
2511 doc
: /* Return the contents of part of the current buffer as a string.
2512 The two arguments START and END are character positions;
2513 they can be in either order.
2514 The string returned is multibyte if the buffer is multibyte.
2516 This function copies the text properties of that part of the buffer
2517 into the result string; if you don't want the text properties,
2518 use `buffer-substring-no-properties' instead. */)
2519 (Lisp_Object start
, Lisp_Object end
)
2521 register EMACS_INT b
, e
;
2523 validate_region (&start
, &end
);
2527 return make_buffer_string (b
, e
, 1);
2530 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties
,
2531 Sbuffer_substring_no_properties
, 2, 2, 0,
2532 doc
: /* Return the characters of part of the buffer, without the text properties.
2533 The two arguments START and END are character positions;
2534 they can be in either order. */)
2535 (Lisp_Object start
, Lisp_Object end
)
2537 register EMACS_INT b
, e
;
2539 validate_region (&start
, &end
);
2543 return make_buffer_string (b
, e
, 0);
2546 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
2547 doc
: /* Return the contents of the current buffer as a string.
2548 If narrowing is in effect, this function returns only the visible part
2552 return make_buffer_string (BEGV
, ZV
, 1);
2555 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
2557 doc
: /* Insert before point a substring of the contents of BUFFER.
2558 BUFFER may be a buffer or a buffer name.
2559 Arguments START and END are character positions specifying the substring.
2560 They default to the values of (point-min) and (point-max) in BUFFER. */)
2561 (Lisp_Object buffer
, Lisp_Object start
, Lisp_Object end
)
2563 register EMACS_INT b
, e
, temp
;
2564 register struct buffer
*bp
, *obuf
;
2567 buf
= Fget_buffer (buffer
);
2571 if (NILP (BVAR (bp
, name
)))
2572 error ("Selecting deleted buffer");
2578 CHECK_NUMBER_COERCE_MARKER (start
);
2585 CHECK_NUMBER_COERCE_MARKER (end
);
2590 temp
= b
, b
= e
, e
= temp
;
2592 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
2593 args_out_of_range (start
, end
);
2595 obuf
= current_buffer
;
2596 set_buffer_internal_1 (bp
);
2597 update_buffer_properties (b
, e
);
2598 set_buffer_internal_1 (obuf
);
2600 insert_from_buffer (bp
, b
, e
- b
, 0);
2604 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
2606 doc
: /* Compare two substrings of two buffers; return result as number.
2607 the value is -N if first string is less after N-1 chars,
2608 +N if first string is greater after N-1 chars, or 0 if strings match.
2609 Each substring is represented as three arguments: BUFFER, START and END.
2610 That makes six args in all, three for each substring.
2612 The value of `case-fold-search' in the current buffer
2613 determines whether case is significant or ignored. */)
2614 (Lisp_Object buffer1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object buffer2
, Lisp_Object start2
, Lisp_Object end2
)
2616 register EMACS_INT begp1
, endp1
, begp2
, endp2
, temp
;
2617 register struct buffer
*bp1
, *bp2
;
2618 register Lisp_Object trt
2619 = (!NILP (BVAR (current_buffer
, case_fold_search
))
2620 ? BVAR (current_buffer
, case_canon_table
) : Qnil
);
2621 EMACS_INT chars
= 0;
2622 EMACS_INT i1
, i2
, i1_byte
, i2_byte
;
2624 /* Find the first buffer and its substring. */
2627 bp1
= current_buffer
;
2631 buf1
= Fget_buffer (buffer1
);
2634 bp1
= XBUFFER (buf1
);
2635 if (NILP (BVAR (bp1
, name
)))
2636 error ("Selecting deleted buffer");
2640 begp1
= BUF_BEGV (bp1
);
2643 CHECK_NUMBER_COERCE_MARKER (start1
);
2644 begp1
= XINT (start1
);
2647 endp1
= BUF_ZV (bp1
);
2650 CHECK_NUMBER_COERCE_MARKER (end1
);
2651 endp1
= XINT (end1
);
2655 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
2657 if (!(BUF_BEGV (bp1
) <= begp1
2659 && endp1
<= BUF_ZV (bp1
)))
2660 args_out_of_range (start1
, end1
);
2662 /* Likewise for second substring. */
2665 bp2
= current_buffer
;
2669 buf2
= Fget_buffer (buffer2
);
2672 bp2
= XBUFFER (buf2
);
2673 if (NILP (BVAR (bp2
, name
)))
2674 error ("Selecting deleted buffer");
2678 begp2
= BUF_BEGV (bp2
);
2681 CHECK_NUMBER_COERCE_MARKER (start2
);
2682 begp2
= XINT (start2
);
2685 endp2
= BUF_ZV (bp2
);
2688 CHECK_NUMBER_COERCE_MARKER (end2
);
2689 endp2
= XINT (end2
);
2693 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
2695 if (!(BUF_BEGV (bp2
) <= begp2
2697 && endp2
<= BUF_ZV (bp2
)))
2698 args_out_of_range (start2
, end2
);
2702 i1_byte
= buf_charpos_to_bytepos (bp1
, i1
);
2703 i2_byte
= buf_charpos_to_bytepos (bp2
, i2
);
2705 while (i1
< endp1
&& i2
< endp2
)
2707 /* When we find a mismatch, we must compare the
2708 characters, not just the bytes. */
2713 if (! NILP (BVAR (bp1
, enable_multibyte_characters
)))
2715 c1
= BUF_FETCH_MULTIBYTE_CHAR (bp1
, i1_byte
);
2716 BUF_INC_POS (bp1
, i1_byte
);
2721 c1
= BUF_FETCH_BYTE (bp1
, i1
);
2722 MAKE_CHAR_MULTIBYTE (c1
);
2726 if (! NILP (BVAR (bp2
, enable_multibyte_characters
)))
2728 c2
= BUF_FETCH_MULTIBYTE_CHAR (bp2
, i2_byte
);
2729 BUF_INC_POS (bp2
, i2_byte
);
2734 c2
= BUF_FETCH_BYTE (bp2
, i2
);
2735 MAKE_CHAR_MULTIBYTE (c2
);
2741 c1
= CHAR_TABLE_TRANSLATE (trt
, c1
);
2742 c2
= CHAR_TABLE_TRANSLATE (trt
, c2
);
2745 return make_number (- 1 - chars
);
2747 return make_number (chars
+ 1);
2752 /* The strings match as far as they go.
2753 If one is shorter, that one is less. */
2754 if (chars
< endp1
- begp1
)
2755 return make_number (chars
+ 1);
2756 else if (chars
< endp2
- begp2
)
2757 return make_number (- chars
- 1);
2759 /* Same length too => they are equal. */
2760 return make_number (0);
2764 subst_char_in_region_unwind (Lisp_Object arg
)
2766 return BVAR (current_buffer
, undo_list
) = arg
;
2770 subst_char_in_region_unwind_1 (Lisp_Object arg
)
2772 return BVAR (current_buffer
, filename
) = arg
;
2775 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
2776 Ssubst_char_in_region
, 4, 5, 0,
2777 doc
: /* From START to END, replace FROMCHAR with TOCHAR each time it occurs.
2778 If optional arg NOUNDO is non-nil, don't record this change for undo
2779 and don't mark the buffer as really changed.
2780 Both characters must have the same length of multi-byte form. */)
2781 (Lisp_Object start
, Lisp_Object end
, Lisp_Object fromchar
, Lisp_Object tochar
, Lisp_Object noundo
)
2783 register EMACS_INT pos
, pos_byte
, stop
, i
, len
, end_byte
;
2784 /* Keep track of the first change in the buffer:
2785 if 0 we haven't found it yet.
2786 if < 0 we've found it and we've run the before-change-function.
2787 if > 0 we've actually performed it and the value is its position. */
2788 EMACS_INT changed
= 0;
2789 unsigned char fromstr
[MAX_MULTIBYTE_LENGTH
], tostr
[MAX_MULTIBYTE_LENGTH
];
2791 int count
= SPECPDL_INDEX ();
2792 #define COMBINING_NO 0
2793 #define COMBINING_BEFORE 1
2794 #define COMBINING_AFTER 2
2795 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
2796 int maybe_byte_combining
= COMBINING_NO
;
2797 EMACS_INT last_changed
= 0;
2798 int multibyte_p
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
2802 validate_region (&start
, &end
);
2803 CHECK_NUMBER (fromchar
);
2804 CHECK_NUMBER (tochar
);
2808 len
= CHAR_STRING (XFASTINT (fromchar
), fromstr
);
2809 if (CHAR_STRING (XFASTINT (tochar
), tostr
) != len
)
2810 error ("Characters in `subst-char-in-region' have different byte-lengths");
2811 if (!ASCII_BYTE_P (*tostr
))
2813 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
2814 complete multibyte character, it may be combined with the
2815 after bytes. If it is in the range 0xA0..0xFF, it may be
2816 combined with the before and after bytes. */
2817 if (!CHAR_HEAD_P (*tostr
))
2818 maybe_byte_combining
= COMBINING_BOTH
;
2819 else if (BYTES_BY_CHAR_HEAD (*tostr
) > len
)
2820 maybe_byte_combining
= COMBINING_AFTER
;
2826 fromstr
[0] = XFASTINT (fromchar
);
2827 tostr
[0] = XFASTINT (tochar
);
2831 pos_byte
= CHAR_TO_BYTE (pos
);
2832 stop
= CHAR_TO_BYTE (XINT (end
));
2835 /* If we don't want undo, turn off putting stuff on the list.
2836 That's faster than getting rid of things,
2837 and it prevents even the entry for a first change.
2838 Also inhibit locking the file. */
2839 if (!changed
&& !NILP (noundo
))
2841 record_unwind_protect (subst_char_in_region_unwind
,
2842 BVAR (current_buffer
, undo_list
));
2843 BVAR (current_buffer
, undo_list
) = Qt
;
2844 /* Don't do file-locking. */
2845 record_unwind_protect (subst_char_in_region_unwind_1
,
2846 BVAR (current_buffer
, filename
));
2847 BVAR (current_buffer
, filename
) = Qnil
;
2850 if (pos_byte
< GPT_BYTE
)
2851 stop
= min (stop
, GPT_BYTE
);
2854 EMACS_INT pos_byte_next
= pos_byte
;
2856 if (pos_byte
>= stop
)
2858 if (pos_byte
>= end_byte
) break;
2861 p
= BYTE_POS_ADDR (pos_byte
);
2863 INC_POS (pos_byte_next
);
2866 if (pos_byte_next
- pos_byte
== len
2867 && p
[0] == fromstr
[0]
2869 || (p
[1] == fromstr
[1]
2870 && (len
== 2 || (p
[2] == fromstr
[2]
2871 && (len
== 3 || p
[3] == fromstr
[3]))))))
2874 /* We've already seen this and run the before-change-function;
2875 this time we only need to record the actual position. */
2880 modify_region (current_buffer
, pos
, XINT (end
), 0);
2882 if (! NILP (noundo
))
2884 if (MODIFF
- 1 == SAVE_MODIFF
)
2886 if (MODIFF
- 1 == BUF_AUTOSAVE_MODIFF (current_buffer
))
2887 BUF_AUTOSAVE_MODIFF (current_buffer
)++;
2890 /* The before-change-function may have moved the gap
2891 or even modified the buffer so we should start over. */
2895 /* Take care of the case where the new character
2896 combines with neighboring bytes. */
2897 if (maybe_byte_combining
2898 && (maybe_byte_combining
== COMBINING_AFTER
2899 ? (pos_byte_next
< Z_BYTE
2900 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2901 : ((pos_byte_next
< Z_BYTE
2902 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2903 || (pos_byte
> BEG_BYTE
2904 && ! ASCII_BYTE_P (FETCH_BYTE (pos_byte
- 1))))))
2906 Lisp_Object tem
, string
;
2908 struct gcpro gcpro1
;
2910 tem
= BVAR (current_buffer
, undo_list
);
2913 /* Make a multibyte string containing this single character. */
2914 string
= make_multibyte_string ((char *) tostr
, 1, len
);
2915 /* replace_range is less efficient, because it moves the gap,
2916 but it handles combining correctly. */
2917 replace_range (pos
, pos
+ 1, string
,
2919 pos_byte_next
= CHAR_TO_BYTE (pos
);
2920 if (pos_byte_next
> pos_byte
)
2921 /* Before combining happened. We should not increment
2922 POS. So, to cancel the later increment of POS,
2926 INC_POS (pos_byte_next
);
2928 if (! NILP (noundo
))
2929 BVAR (current_buffer
, undo_list
) = tem
;
2936 record_change (pos
, 1);
2937 for (i
= 0; i
< len
; i
++) *p
++ = tostr
[i
];
2939 last_changed
= pos
+ 1;
2941 pos_byte
= pos_byte_next
;
2947 signal_after_change (changed
,
2948 last_changed
- changed
, last_changed
- changed
);
2949 update_compositions (changed
, last_changed
, CHECK_ALL
);
2952 unbind_to (count
, Qnil
);
2957 static Lisp_Object
check_translation (EMACS_INT
, EMACS_INT
, EMACS_INT
,
2960 /* Helper function for Ftranslate_region_internal.
2962 Check if a character sequence at POS (POS_BYTE) matches an element
2963 of VAL. VAL is a list (([FROM-CHAR ...] . TO) ...). If a matching
2964 element is found, return it. Otherwise return Qnil. */
2967 check_translation (EMACS_INT pos
, EMACS_INT pos_byte
, EMACS_INT end
,
2970 int buf_size
= 16, buf_used
= 0;
2971 int *buf
= alloca (sizeof (int) * buf_size
);
2973 for (; CONSP (val
); val
= XCDR (val
))
2982 if (! VECTORP (elt
))
2985 if (len
<= end
- pos
)
2987 for (i
= 0; i
< len
; i
++)
2991 unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
2994 if (buf_used
== buf_size
)
2999 newbuf
= alloca (sizeof (int) * buf_size
);
3000 memcpy (newbuf
, buf
, sizeof (int) * buf_used
);
3003 buf
[buf_used
++] = STRING_CHAR_AND_LENGTH (p
, len1
);
3006 if (XINT (AREF (elt
, i
)) != buf
[i
])
3017 DEFUN ("translate-region-internal", Ftranslate_region_internal
,
3018 Stranslate_region_internal
, 3, 3, 0,
3019 doc
: /* Internal use only.
3020 From START to END, translate characters according to TABLE.
3021 TABLE is a string or a char-table; the Nth character in it is the
3022 mapping for the character with code N.
3023 It returns the number of characters changed. */)
3024 (Lisp_Object start
, Lisp_Object end
, register Lisp_Object table
)
3026 register unsigned char *tt
; /* Trans table. */
3027 register int nc
; /* New character. */
3028 int cnt
; /* Number of changes made. */
3029 EMACS_INT size
; /* Size of translate table. */
3030 EMACS_INT pos
, pos_byte
, end_pos
;
3031 int multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3032 int string_multibyte
;
3035 validate_region (&start
, &end
);
3036 if (CHAR_TABLE_P (table
))
3038 if (! EQ (XCHAR_TABLE (table
)->purpose
, Qtranslation_table
))
3039 error ("Not a translation table");
3045 CHECK_STRING (table
);
3047 if (! multibyte
&& (SCHARS (table
) < SBYTES (table
)))
3048 table
= string_make_unibyte (table
);
3049 string_multibyte
= SCHARS (table
) < SBYTES (table
);
3050 size
= SBYTES (table
);
3055 pos_byte
= CHAR_TO_BYTE (pos
);
3056 end_pos
= XINT (end
);
3057 modify_region (current_buffer
, pos
, end_pos
, 0);
3060 for (; pos
< end_pos
; )
3062 register unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
3063 unsigned char *str
, buf
[MAX_MULTIBYTE_LENGTH
];
3069 oc
= STRING_CHAR_AND_LENGTH (p
, len
);
3076 /* Reload as signal_after_change in last iteration may GC. */
3078 if (string_multibyte
)
3080 str
= tt
+ string_char_to_byte (table
, oc
);
3081 nc
= STRING_CHAR_AND_LENGTH (str
, str_len
);
3086 if (! ASCII_BYTE_P (nc
) && multibyte
)
3088 str_len
= BYTE8_STRING (nc
, buf
);
3103 val
= CHAR_TABLE_REF (table
, oc
);
3104 if (CHARACTERP (val
)
3105 && (c
= XINT (val
), CHAR_VALID_P (c
, 0)))
3108 str_len
= CHAR_STRING (nc
, buf
);
3111 else if (VECTORP (val
) || (CONSP (val
)))
3113 /* VAL is [TO_CHAR ...] or (([FROM-CHAR ...] . TO) ...)
3114 where TO is TO-CHAR or [TO-CHAR ...]. */
3119 if (nc
!= oc
&& nc
>= 0)
3121 /* Simple one char to one char translation. */
3126 /* This is less efficient, because it moves the gap,
3127 but it should handle multibyte characters correctly. */
3128 string
= make_multibyte_string ((char *) str
, 1, str_len
);
3129 replace_range (pos
, pos
+ 1, string
, 1, 0, 1);
3134 record_change (pos
, 1);
3135 while (str_len
-- > 0)
3137 signal_after_change (pos
, 1, 1);
3138 update_compositions (pos
, pos
+ 1, CHECK_BORDER
);
3148 val
= check_translation (pos
, pos_byte
, end_pos
, val
);
3155 /* VAL is ([FROM-CHAR ...] . TO). */
3156 len
= ASIZE (XCAR (val
));
3164 string
= Fconcat (1, &val
);
3168 string
= Fmake_string (make_number (1), val
);
3170 replace_range (pos
, pos
+ len
, string
, 1, 0, 1);
3171 pos_byte
+= SBYTES (string
);
3172 pos
+= SCHARS (string
);
3173 cnt
+= SCHARS (string
);
3174 end_pos
+= SCHARS (string
) - len
;
3182 return make_number (cnt
);
3185 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
3186 doc
: /* Delete the text between point and mark.
3188 When called from a program, expects two arguments,
3189 positions (integers or markers) specifying the stretch to be deleted. */)
3190 (Lisp_Object start
, Lisp_Object end
)
3192 validate_region (&start
, &end
);
3193 del_range (XINT (start
), XINT (end
));
3197 DEFUN ("delete-and-extract-region", Fdelete_and_extract_region
,
3198 Sdelete_and_extract_region
, 2, 2, 0,
3199 doc
: /* Delete the text between START and END and return it. */)
3200 (Lisp_Object start
, Lisp_Object end
)
3202 validate_region (&start
, &end
);
3203 if (XINT (start
) == XINT (end
))
3204 return empty_unibyte_string
;
3205 return del_range_1 (XINT (start
), XINT (end
), 1, 1);
3208 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
3209 doc
: /* Remove restrictions (narrowing) from current buffer.
3210 This allows the buffer's full text to be seen and edited. */)
3213 if (BEG
!= BEGV
|| Z
!= ZV
)
3214 current_buffer
->clip_changed
= 1;
3216 BEGV_BYTE
= BEG_BYTE
;
3217 SET_BUF_ZV_BOTH (current_buffer
, Z
, Z_BYTE
);
3218 /* Changing the buffer bounds invalidates any recorded current column. */
3219 invalidate_current_column ();
3223 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
3224 doc
: /* Restrict editing in this buffer to the current region.
3225 The rest of the text becomes temporarily invisible and untouchable
3226 but is not deleted; if you save the buffer in a file, the invisible
3227 text is included in the file. \\[widen] makes all visible again.
3228 See also `save-restriction'.
3230 When calling from a program, pass two arguments; positions (integers
3231 or markers) bounding the text that should remain visible. */)
3232 (register Lisp_Object start
, Lisp_Object end
)
3234 CHECK_NUMBER_COERCE_MARKER (start
);
3235 CHECK_NUMBER_COERCE_MARKER (end
);
3237 if (XINT (start
) > XINT (end
))
3240 tem
= start
; start
= end
; end
= tem
;
3243 if (!(BEG
<= XINT (start
) && XINT (start
) <= XINT (end
) && XINT (end
) <= Z
))
3244 args_out_of_range (start
, end
);
3246 if (BEGV
!= XFASTINT (start
) || ZV
!= XFASTINT (end
))
3247 current_buffer
->clip_changed
= 1;
3249 SET_BUF_BEGV (current_buffer
, XFASTINT (start
));
3250 SET_BUF_ZV (current_buffer
, XFASTINT (end
));
3251 if (PT
< XFASTINT (start
))
3252 SET_PT (XFASTINT (start
));
3253 if (PT
> XFASTINT (end
))
3254 SET_PT (XFASTINT (end
));
3255 /* Changing the buffer bounds invalidates any recorded current column. */
3256 invalidate_current_column ();
3261 save_restriction_save (void)
3263 if (BEGV
== BEG
&& ZV
== Z
)
3264 /* The common case that the buffer isn't narrowed.
3265 We return just the buffer object, which save_restriction_restore
3266 recognizes as meaning `no restriction'. */
3267 return Fcurrent_buffer ();
3269 /* We have to save a restriction, so return a pair of markers, one
3270 for the beginning and one for the end. */
3272 Lisp_Object beg
, end
;
3274 beg
= buildmark (BEGV
, BEGV_BYTE
);
3275 end
= buildmark (ZV
, ZV_BYTE
);
3277 /* END must move forward if text is inserted at its exact location. */
3278 XMARKER(end
)->insertion_type
= 1;
3280 return Fcons (beg
, end
);
3285 save_restriction_restore (Lisp_Object data
)
3287 struct buffer
*cur
= NULL
;
3288 struct buffer
*buf
= (CONSP (data
)
3289 ? XMARKER (XCAR (data
))->buffer
3292 if (buf
&& buf
!= current_buffer
&& !NILP (BVAR (buf
, pt_marker
)))
3293 { /* If `buf' uses markers to keep track of PT, BEGV, and ZV (as
3294 is the case if it is or has an indirect buffer), then make
3295 sure it is current before we update BEGV, so
3296 set_buffer_internal takes care of managing those markers. */
3297 cur
= current_buffer
;
3298 set_buffer_internal (buf
);
3302 /* A pair of marks bounding a saved restriction. */
3304 struct Lisp_Marker
*beg
= XMARKER (XCAR (data
));
3305 struct Lisp_Marker
*end
= XMARKER (XCDR (data
));
3306 eassert (buf
== end
->buffer
);
3308 if (buf
/* Verify marker still points to a buffer. */
3309 && (beg
->charpos
!= BUF_BEGV (buf
) || end
->charpos
!= BUF_ZV (buf
)))
3310 /* The restriction has changed from the saved one, so restore
3311 the saved restriction. */
3313 EMACS_INT pt
= BUF_PT (buf
);
3315 SET_BUF_BEGV_BOTH (buf
, beg
->charpos
, beg
->bytepos
);
3316 SET_BUF_ZV_BOTH (buf
, end
->charpos
, end
->bytepos
);
3318 if (pt
< beg
->charpos
|| pt
> end
->charpos
)
3319 /* The point is outside the new visible range, move it inside. */
3320 SET_BUF_PT_BOTH (buf
,
3321 clip_to_bounds (beg
->charpos
, pt
, end
->charpos
),
3322 clip_to_bounds (beg
->bytepos
, BUF_PT_BYTE (buf
),
3325 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3329 /* A buffer, which means that there was no old restriction. */
3331 if (buf
/* Verify marker still points to a buffer. */
3332 && (BUF_BEGV (buf
) != BUF_BEG (buf
) || BUF_ZV (buf
) != BUF_Z (buf
)))
3333 /* The buffer has been narrowed, get rid of the narrowing. */
3335 SET_BUF_BEGV_BOTH (buf
, BUF_BEG (buf
), BUF_BEG_BYTE (buf
));
3336 SET_BUF_ZV_BOTH (buf
, BUF_Z (buf
), BUF_Z_BYTE (buf
));
3338 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3342 /* Changing the buffer bounds invalidates any recorded current column. */
3343 invalidate_current_column ();
3346 set_buffer_internal (cur
);
3351 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
3352 doc
: /* Execute BODY, saving and restoring current buffer's restrictions.
3353 The buffer's restrictions make parts of the beginning and end invisible.
3354 \(They are set up with `narrow-to-region' and eliminated with `widen'.)
3355 This special form, `save-restriction', saves the current buffer's restrictions
3356 when it is entered, and restores them when it is exited.
3357 So any `narrow-to-region' within BODY lasts only until the end of the form.
3358 The old restrictions settings are restored
3359 even in case of abnormal exit (throw or error).
3361 The value returned is the value of the last form in BODY.
3363 Note: if you are using both `save-excursion' and `save-restriction',
3364 use `save-excursion' outermost:
3365 (save-excursion (save-restriction ...))
3367 usage: (save-restriction &rest BODY) */)
3370 register Lisp_Object val
;
3371 int count
= SPECPDL_INDEX ();
3373 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
3374 val
= Fprogn (body
);
3375 return unbind_to (count
, val
);
3378 /* Buffer for the most recent text displayed by Fmessage_box. */
3379 static char *message_text
;
3381 /* Allocated length of that buffer. */
3382 static int message_length
;
3384 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
3385 doc
: /* Display a message at the bottom of the screen.
3386 The message also goes into the `*Messages*' buffer.
3387 \(In keyboard macros, that's all it does.)
3390 The first argument is a format control string, and the rest are data
3391 to be formatted under control of the string. See `format' for details.
3393 Note: Use (message "%s" VALUE) to print the value of expressions and
3394 variables to avoid accidentally interpreting `%' as format specifiers.
3396 If the first argument is nil or the empty string, the function clears
3397 any existing message; this lets the minibuffer contents show. See
3398 also `current-message'.
3400 usage: (message FORMAT-STRING &rest ARGS) */)
3401 (int nargs
, Lisp_Object
*args
)
3404 || (STRINGP (args
[0])
3405 && SBYTES (args
[0]) == 0))
3412 register Lisp_Object val
;
3413 val
= Fformat (nargs
, args
);
3414 message3 (val
, SBYTES (val
), STRING_MULTIBYTE (val
));
3419 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
3420 doc
: /* Display a message, in a dialog box if possible.
3421 If a dialog box is not available, use the echo area.
3422 The first argument is a format control string, and the rest are data
3423 to be formatted under control of the string. See `format' for details.
3425 If the first argument is nil or the empty string, clear any existing
3426 message; let the minibuffer contents show.
3428 usage: (message-box FORMAT-STRING &rest ARGS) */)
3429 (int nargs
, Lisp_Object
*args
)
3438 register Lisp_Object val
;
3439 val
= Fformat (nargs
, args
);
3441 /* The MS-DOS frames support popup menus even though they are
3442 not FRAME_WINDOW_P. */
3443 if (FRAME_WINDOW_P (XFRAME (selected_frame
))
3444 || FRAME_MSDOS_P (XFRAME (selected_frame
)))
3446 Lisp_Object pane
, menu
, obj
;
3447 struct gcpro gcpro1
;
3448 pane
= Fcons (Fcons (build_string ("OK"), Qt
), Qnil
);
3450 menu
= Fcons (val
, pane
);
3451 obj
= Fx_popup_dialog (Qt
, menu
, Qt
);
3455 #endif /* HAVE_MENUS */
3456 /* Copy the data so that it won't move when we GC. */
3459 message_text
= (char *)xmalloc (80);
3460 message_length
= 80;
3462 if (SBYTES (val
) > message_length
)
3464 message_length
= SBYTES (val
);
3465 message_text
= (char *)xrealloc (message_text
, message_length
);
3467 memcpy (message_text
, SDATA (val
), SBYTES (val
));
3468 message2 (message_text
, SBYTES (val
),
3469 STRING_MULTIBYTE (val
));
3474 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
3475 doc
: /* Display a message in a dialog box or in the echo area.
3476 If this command was invoked with the mouse, use a dialog box if
3477 `use-dialog-box' is non-nil.
3478 Otherwise, use the echo area.
3479 The first argument is a format control string, and the rest are data
3480 to be formatted under control of the string. See `format' for details.
3482 If the first argument is nil or the empty string, clear any existing
3483 message; let the minibuffer contents show.
3485 usage: (message-or-box FORMAT-STRING &rest ARGS) */)
3486 (int nargs
, Lisp_Object
*args
)
3489 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3491 return Fmessage_box (nargs
, args
);
3493 return Fmessage (nargs
, args
);
3496 DEFUN ("current-message", Fcurrent_message
, Scurrent_message
, 0, 0, 0,
3497 doc
: /* Return the string currently displayed in the echo area, or nil if none. */)
3500 return current_message ();
3504 DEFUN ("propertize", Fpropertize
, Spropertize
, 1, MANY
, 0,
3505 doc
: /* Return a copy of STRING with text properties added.
3506 First argument is the string to copy.
3507 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
3508 properties to add to the result.
3509 usage: (propertize STRING &rest PROPERTIES) */)
3510 (int nargs
, Lisp_Object
*args
)
3512 Lisp_Object properties
, string
;
3513 struct gcpro gcpro1
, gcpro2
;
3516 /* Number of args must be odd. */
3517 if ((nargs
& 1) == 0 || nargs
< 1)
3518 error ("Wrong number of arguments");
3520 properties
= string
= Qnil
;
3521 GCPRO2 (properties
, string
);
3523 /* First argument must be a string. */
3524 CHECK_STRING (args
[0]);
3525 string
= Fcopy_sequence (args
[0]);
3527 for (i
= 1; i
< nargs
; i
+= 2)
3528 properties
= Fcons (args
[i
], Fcons (args
[i
+ 1], properties
));
3530 Fadd_text_properties (make_number (0),
3531 make_number (SCHARS (string
)),
3532 properties
, string
);
3533 RETURN_UNGCPRO (string
);
3537 /* Number of bytes that STRING will occupy when put into the result.
3538 MULTIBYTE is nonzero if the result should be multibyte. */
3540 #define CONVERTED_BYTE_SIZE(MULTIBYTE, STRING) \
3541 (((MULTIBYTE) && ! STRING_MULTIBYTE (STRING)) \
3542 ? count_size_as_multibyte (SDATA (STRING), SBYTES (STRING)) \
3545 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
3546 doc
: /* Format a string out of a format-string and arguments.
3547 The first argument is a format control string.
3548 The other arguments are substituted into it to make the result, a string.
3550 The format control string may contain %-sequences meaning to substitute
3551 the next available argument:
3553 %s means print a string argument. Actually, prints any object, with `princ'.
3554 %d means print as number in decimal (%o octal, %x hex).
3555 %X is like %x, but uses upper case.
3556 %e means print a number in exponential notation.
3557 %f means print a number in decimal-point notation.
3558 %g means print a number in exponential notation
3559 or decimal-point notation, whichever uses fewer characters.
3560 %c means print a number as a single character.
3561 %S means print any object as an s-expression (using `prin1').
3563 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
3564 Use %% to put a single % into the output.
3566 A %-sequence may contain optional flag, width, and precision
3567 specifiers, as follows:
3569 %<flags><width><precision>character
3571 where flags is [+ #-0]+, width is [0-9]+, and precision is .[0-9]+
3573 The + flag character inserts a + before any positive number, while a
3574 space inserts a space before any positive number; these flags only
3575 affect %d, %e, %f, and %g sequences, and the + flag takes precedence.
3576 The # flag means to use an alternate display form for %o, %x, %X, %e,
3577 %f, and %g sequences. The - and 0 flags affect the width specifier,
3580 The width specifier supplies a lower limit for the length of the
3581 printed representation. The padding, if any, normally goes on the
3582 left, but it goes on the right if the - flag is present. The padding
3583 character is normally a space, but it is 0 if the 0 flag is present.
3584 The - flag takes precedence over the 0 flag.
3586 For %e, %f, and %g sequences, the number after the "." in the
3587 precision specifier says how many decimal places to show; if zero, the
3588 decimal point itself is omitted. For %s and %S, the precision
3589 specifier truncates the string to the given width.
3591 usage: (format STRING &rest OBJECTS) */)
3592 (int nargs
, register Lisp_Object
*args
)
3594 register int n
; /* The number of the next arg to substitute */
3595 register EMACS_INT total
; /* An estimate of the final length */
3597 register char *format
, *end
, *format_start
;
3599 /* Nonzero if the output should be a multibyte string,
3600 which is true if any of the inputs is one. */
3602 /* When we make a multibyte string, we must pay attention to the
3603 byte combining problem, i.e., a byte may be combined with a
3604 multibyte character of the previous string. This flag tells if we
3605 must consider such a situation or not. */
3606 int maybe_combine_byte
;
3608 /* Precision for each spec, or -1, a flag value meaning no precision
3609 was given in that spec. Element 0, corresponding to the format
3610 string itself, will not be used. Element NARGS, corresponding to
3611 no argument, *will* be assigned to in the case that a `%' and `.'
3612 occur after the final format specifier. */
3613 int *precision
= (int *) (alloca ((nargs
+ 1) * sizeof (int)));
3616 int arg_intervals
= 0;
3619 /* discarded[I] is 1 if byte I of the format
3620 string was not copied into the output.
3621 It is 2 if byte I was not the first byte of its character. */
3622 char *discarded
= 0;
3624 /* Each element records, for one argument,
3625 the start and end bytepos in the output string,
3626 and whether the argument is a string with intervals.
3627 info[0] is unused. Unused elements have -1 for start. */
3630 int start
, end
, intervals
;
3633 /* It should not be necessary to GCPRO ARGS, because
3634 the caller in the interpreter should take care of that. */
3636 /* Try to determine whether the result should be multibyte.
3637 This is not always right; sometimes the result needs to be multibyte
3638 because of an object that we will pass through prin1,
3639 and in that case, we won't know it here. */
3640 for (n
= 0; n
< nargs
; n
++)
3642 if (STRINGP (args
[n
]) && STRING_MULTIBYTE (args
[n
]))
3644 /* Piggyback on this loop to initialize precision[N]. */
3647 precision
[nargs
] = -1;
3649 CHECK_STRING (args
[0]);
3650 /* We may have to change "%S" to "%s". */
3651 args
[0] = Fcopy_sequence (args
[0]);
3653 /* GC should never happen here, so abort if it does. */
3656 /* If we start out planning a unibyte result,
3657 then discover it has to be multibyte, we jump back to retry.
3658 That can only happen from the first large while loop below. */
3661 format
= SSDATA (args
[0]);
3662 format_start
= format
;
3663 end
= format
+ SBYTES (args
[0]);
3666 /* Make room in result for all the non-%-codes in the control string. */
3667 total
= 5 + CONVERTED_BYTE_SIZE (multibyte
, args
[0]) + 1;
3669 /* Allocate the info and discarded tables. */
3671 int nbytes
= (nargs
+1) * sizeof *info
;
3674 info
= (struct info
*) alloca (nbytes
);
3675 memset (info
, 0, nbytes
);
3676 for (i
= 0; i
<= nargs
; i
++)
3679 SAFE_ALLOCA (discarded
, char *, SBYTES (args
[0]));
3680 memset (discarded
, 0, SBYTES (args
[0]));
3683 /* Add to TOTAL enough space to hold the converted arguments. */
3686 while (format
!= end
)
3687 if (*format
++ == '%')
3689 EMACS_INT thissize
= 0;
3690 EMACS_INT actual_width
= 0;
3691 char *this_format_start
= format
- 1;
3692 int field_width
= 0;
3694 /* General format specifications look like
3696 '%' [flags] [field-width] [precision] format
3701 field-width ::= [0-9]+
3702 precision ::= '.' [0-9]*
3704 If a field-width is specified, it specifies to which width
3705 the output should be padded with blanks, if the output
3706 string is shorter than field-width.
3708 If precision is specified, it specifies the number of
3709 digits to print after the '.' for floats, or the max.
3710 number of chars to print from a string. */
3712 while (format
!= end
3713 && (*format
== '-' || *format
== '0' || *format
== '#'
3714 || * format
== ' ' || *format
== '+'))
3717 if (*format
>= '0' && *format
<= '9')
3719 for (field_width
= 0; *format
>= '0' && *format
<= '9'; ++format
)
3720 field_width
= 10 * field_width
+ *format
- '0';
3723 /* N is not incremented for another few lines below, so refer to
3724 element N+1 (which might be precision[NARGS]). */
3728 for (precision
[n
+1] = 0; *format
>= '0' && *format
<= '9'; ++format
)
3729 precision
[n
+1] = 10 * precision
[n
+1] + *format
- '0';
3732 /* Extra +1 for 'l' that we may need to insert into the
3734 if (format
- this_format_start
+ 2 > longest_format
)
3735 longest_format
= format
- this_format_start
+ 2;
3738 error ("Format string ends in middle of format specifier");
3741 else if (++n
>= nargs
)
3742 error ("Not enough arguments for format string");
3743 else if (*format
== 'S')
3745 /* For `S', prin1 the argument and then treat like a string. */
3746 register Lisp_Object tem
;
3747 tem
= Fprin1_to_string (args
[n
], Qnil
);
3748 if (STRING_MULTIBYTE (tem
) && ! multibyte
)
3754 /* If we restart the loop, we should not come here again
3755 because args[n] is now a string and calling
3756 Fprin1_to_string on it produces superflous double
3757 quotes. So, change "%S" to "%s" now. */
3761 else if (SYMBOLP (args
[n
]))
3763 args
[n
] = SYMBOL_NAME (args
[n
]);
3764 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3771 else if (STRINGP (args
[n
]))
3774 if (*format
!= 's' && *format
!= 'S')
3775 error ("Format specifier doesn't match argument type");
3776 /* In the case (PRECISION[N] > 0), THISSIZE may not need
3777 to be as large as is calculated here. Easy check for
3778 the case PRECISION = 0. */
3779 thissize
= precision
[n
] ? CONVERTED_BYTE_SIZE (multibyte
, args
[n
]) : 0;
3780 /* The precision also constrains how much of the argument
3781 string will finally appear (Bug#5710). */
3782 actual_width
= lisp_string_width (args
[n
], -1, NULL
, NULL
);
3783 if (precision
[n
] != -1)
3784 actual_width
= min (actual_width
, precision
[n
]);
3786 /* Would get MPV otherwise, since Lisp_Int's `point' to low memory. */
3787 else if (INTEGERP (args
[n
]) && *format
!= 's')
3789 /* The following loop assumes the Lisp type indicates
3790 the proper way to pass the argument.
3791 So make sure we have a flonum if the argument should
3793 if (*format
== 'e' || *format
== 'f' || *format
== 'g')
3794 args
[n
] = Ffloat (args
[n
]);
3796 if (*format
!= 'd' && *format
!= 'o' && *format
!= 'x'
3797 && *format
!= 'i' && *format
!= 'X' && *format
!= 'c')
3798 error ("Invalid format operation %%%c", *format
);
3800 thissize
= 30 + (precision
[n
] > 0 ? precision
[n
] : 0);
3803 if (! ASCII_CHAR_P (XINT (args
[n
]))
3804 /* Note: No one can remeber why we have to treat
3805 the character 0 as a multibyte character here.
3806 But, until it causes a real problem, let's
3808 || XINT (args
[n
]) == 0)
3815 args
[n
] = Fchar_to_string (args
[n
]);
3816 thissize
= SBYTES (args
[n
]);
3818 else if (! ASCII_BYTE_P (XINT (args
[n
])) && multibyte
)
3821 = Fchar_to_string (Funibyte_char_to_multibyte (args
[n
]));
3822 thissize
= SBYTES (args
[n
]);
3826 else if (FLOATP (args
[n
]) && *format
!= 's')
3828 if (! (*format
== 'e' || *format
== 'f' || *format
== 'g'))
3830 if (*format
!= 'd' && *format
!= 'o' && *format
!= 'x'
3831 && *format
!= 'i' && *format
!= 'X' && *format
!= 'c')
3832 error ("Invalid format operation %%%c", *format
);
3833 /* This fails unnecessarily if args[n] is bigger than
3834 most-positive-fixnum but smaller than MAXINT.
3835 These cases are important because we sometimes use floats
3836 to represent such integer values (typically such values
3837 come from UIDs or PIDs). */
3838 /* args[n] = Ftruncate (args[n], Qnil); */
3841 /* Note that we're using sprintf to print floats,
3842 so we have to take into account what that function
3844 /* Filter out flag value of -1. */
3845 thissize
= (MAX_10_EXP
+ 100
3846 + (precision
[n
] > 0 ? precision
[n
] : 0));
3850 /* Anything but a string, convert to a string using princ. */
3851 register Lisp_Object tem
;
3852 tem
= Fprin1_to_string (args
[n
], Qt
);
3853 if (STRING_MULTIBYTE (tem
) && ! multibyte
)
3862 thissize
+= max (0, field_width
- actual_width
);
3863 total
+= thissize
+ 4;
3868 /* Now we can no longer jump to retry.
3869 TOTAL and LONGEST_FORMAT are known for certain. */
3871 this_format
= (char *) alloca (longest_format
+ 1);
3873 /* Allocate the space for the result.
3874 Note that TOTAL is an overestimate. */
3875 SAFE_ALLOCA (buf
, char *, total
);
3881 /* Scan the format and store result in BUF. */
3882 format
= SSDATA (args
[0]);
3883 format_start
= format
;
3884 end
= format
+ SBYTES (args
[0]);
3885 maybe_combine_byte
= 0;
3886 while (format
!= end
)
3892 char *this_format_start
= format
;
3894 discarded
[format
- format_start
] = 1;
3897 while (strchr ("-+0# ", *format
))
3903 discarded
[format
- format_start
] = 1;
3907 minlen
= atoi (format
);
3909 while ((*format
>= '0' && *format
<= '9') || *format
== '.')
3911 discarded
[format
- format_start
] = 1;
3915 if (*format
++ == '%')
3924 discarded
[format
- format_start
- 1] = 1;
3925 info
[n
].start
= nchars
;
3927 if (STRINGP (args
[n
]))
3929 /* handle case (precision[n] >= 0) */
3932 EMACS_INT nbytes
, start
, end
;
3933 EMACS_INT nchars_string
;
3935 /* lisp_string_width ignores a precision of 0, but GNU
3936 libc functions print 0 characters when the precision
3937 is 0. Imitate libc behavior here. Changing
3938 lisp_string_width is the right thing, and will be
3939 done, but meanwhile we work with it. */
3941 if (precision
[n
] == 0)
3942 width
= nchars_string
= nbytes
= 0;
3943 else if (precision
[n
] > 0)
3944 width
= lisp_string_width (args
[n
], precision
[n
],
3945 &nchars_string
, &nbytes
);
3947 { /* no precision spec given for this argument */
3948 width
= lisp_string_width (args
[n
], -1, NULL
, NULL
);
3949 nbytes
= SBYTES (args
[n
]);
3950 nchars_string
= SCHARS (args
[n
]);
3953 /* If spec requires it, pad on right with spaces. */
3954 padding
= minlen
- width
;
3956 while (padding
-- > 0)
3962 info
[n
].start
= start
= nchars
;
3963 nchars
+= nchars_string
;
3968 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3969 && STRING_MULTIBYTE (args
[n
])
3970 && !CHAR_HEAD_P (SREF (args
[n
], 0)))
3971 maybe_combine_byte
= 1;
3973 p
+= copy_text (SDATA (args
[n
]), (unsigned char *) p
,
3975 STRING_MULTIBYTE (args
[n
]), multibyte
);
3977 info
[n
].end
= nchars
;
3980 while (padding
-- > 0)
3986 /* If this argument has text properties, record where
3987 in the result string it appears. */
3988 if (STRING_INTERVALS (args
[n
]))
3989 info
[n
].intervals
= arg_intervals
= 1;
3991 else if (INTEGERP (args
[n
]) || FLOATP (args
[n
]))
3995 memcpy (this_format
, this_format_start
,
3996 format
- this_format_start
);
3997 this_format
[format
- this_format_start
] = 0;
3999 if (format
[-1] == 'e' || format
[-1] == 'f' || format
[-1] == 'g')
4000 sprintf (p
, this_format
, XFLOAT_DATA (args
[n
]));
4003 if (sizeof (EMACS_INT
) > sizeof (int)
4004 && format
[-1] != 'c')
4006 /* Insert 'l' before format spec. */
4007 this_format
[format
- this_format_start
]
4008 = this_format
[format
- this_format_start
- 1];
4009 this_format
[format
- this_format_start
- 1] = 'l';
4010 this_format
[format
- this_format_start
+ 1] = 0;
4013 if (INTEGERP (args
[n
]))
4015 if (format
[-1] == 'c')
4016 sprintf (p
, this_format
, (int) XINT (args
[n
]));
4017 else if (format
[-1] == 'd')
4018 sprintf (p
, this_format
, XINT (args
[n
]));
4019 /* Don't sign-extend for octal or hex printing. */
4021 sprintf (p
, this_format
, XUINT (args
[n
]));
4023 else if (format
[-1] == 'c')
4024 sprintf (p
, this_format
, (int) XFLOAT_DATA (args
[n
]));
4025 else if (format
[-1] == 'd')
4026 /* Maybe we should use "%1.0f" instead so it also works
4027 for values larger than MAXINT. */
4028 sprintf (p
, this_format
, (EMACS_INT
) XFLOAT_DATA (args
[n
]));
4030 /* Don't sign-extend for octal or hex printing. */
4031 sprintf (p
, this_format
, (EMACS_UINT
) XFLOAT_DATA (args
[n
]));
4036 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
4037 && !CHAR_HEAD_P (*((unsigned char *) p
)))
4038 maybe_combine_byte
= 1;
4039 this_nchars
= strlen (p
);
4041 p
+= str_to_multibyte ((unsigned char *) p
,
4042 buf
+ total
- 1 - p
, this_nchars
);
4045 nchars
+= this_nchars
;
4046 info
[n
].end
= nchars
;
4050 else if (STRING_MULTIBYTE (args
[0]))
4052 /* Copy a whole multibyte character. */
4055 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
4056 && !CHAR_HEAD_P (*format
))
4057 maybe_combine_byte
= 1;
4059 while (! CHAR_HEAD_P (*format
))
4061 discarded
[format
- format_start
] = 2;
4068 /* Convert a single-byte character to multibyte. */
4069 int len
= copy_text ((unsigned char *) format
, (unsigned char *) p
,
4077 *p
++ = *format
++, nchars
++;
4080 if (p
> buf
+ total
)
4083 if (maybe_combine_byte
)
4084 nchars
= multibyte_chars_in_text ((unsigned char *) buf
, p
- buf
);
4085 val
= make_specified_string (buf
, nchars
, p
- buf
, multibyte
);
4087 /* If we allocated BUF with malloc, free it too. */
4090 /* If the format string has text properties, or any of the string
4091 arguments has text properties, set up text properties of the
4094 if (STRING_INTERVALS (args
[0]) || arg_intervals
)
4096 Lisp_Object len
, new_len
, props
;
4097 struct gcpro gcpro1
;
4099 /* Add text properties from the format string. */
4100 len
= make_number (SCHARS (args
[0]));
4101 props
= text_property_list (args
[0], make_number (0), len
, Qnil
);
4106 EMACS_INT bytepos
= 0, position
= 0, translated
= 0;
4110 /* Adjust the bounds of each text property
4111 to the proper start and end in the output string. */
4113 /* Put the positions in PROPS in increasing order, so that
4114 we can do (effectively) one scan through the position
4115 space of the format string. */
4116 props
= Fnreverse (props
);
4118 /* BYTEPOS is the byte position in the format string,
4119 POSITION is the untranslated char position in it,
4120 TRANSLATED is the translated char position in BUF,
4121 and ARGN is the number of the next arg we will come to. */
4122 for (list
= props
; CONSP (list
); list
= XCDR (list
))
4129 /* First adjust the property start position. */
4130 pos
= XINT (XCAR (item
));
4132 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
4133 up to this position. */
4134 for (; position
< pos
; bytepos
++)
4136 if (! discarded
[bytepos
])
4137 position
++, translated
++;
4138 else if (discarded
[bytepos
] == 1)
4141 if (translated
== info
[argn
].start
)
4143 translated
+= info
[argn
].end
- info
[argn
].start
;
4149 XSETCAR (item
, make_number (translated
));
4151 /* Likewise adjust the property end position. */
4152 pos
= XINT (XCAR (XCDR (item
)));
4154 for (; position
< pos
; bytepos
++)
4156 if (! discarded
[bytepos
])
4157 position
++, translated
++;
4158 else if (discarded
[bytepos
] == 1)
4161 if (translated
== info
[argn
].start
)
4163 translated
+= info
[argn
].end
- info
[argn
].start
;
4169 XSETCAR (XCDR (item
), make_number (translated
));
4172 add_text_properties_from_list (val
, props
, make_number (0));
4175 /* Add text properties from arguments. */
4177 for (n
= 1; n
< nargs
; ++n
)
4178 if (info
[n
].intervals
)
4180 len
= make_number (SCHARS (args
[n
]));
4181 new_len
= make_number (info
[n
].end
- info
[n
].start
);
4182 props
= text_property_list (args
[n
], make_number (0), len
, Qnil
);
4183 props
= extend_property_ranges (props
, new_len
);
4184 /* If successive arguments have properties, be sure that
4185 the value of `composition' property be the copy. */
4186 if (n
> 1 && info
[n
- 1].end
)
4187 make_composition_value_copy (props
);
4188 add_text_properties_from_list (val
, props
,
4189 make_number (info
[n
].start
));
4199 format2 (const char *string1
, Lisp_Object arg0
, Lisp_Object arg1
)
4201 Lisp_Object args
[3];
4202 args
[0] = build_string (string1
);
4205 return Fformat (3, args
);
4208 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
4209 doc
: /* Return t if two characters match, optionally ignoring case.
4210 Both arguments must be characters (i.e. integers).
4211 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
4212 (register Lisp_Object c1
, Lisp_Object c2
)
4215 /* Check they're chars, not just integers, otherwise we could get array
4216 bounds violations in DOWNCASE. */
4217 CHECK_CHARACTER (c1
);
4218 CHECK_CHARACTER (c2
);
4220 if (XINT (c1
) == XINT (c2
))
4222 if (NILP (BVAR (current_buffer
, case_fold_search
)))
4225 /* Do these in separate statements,
4226 then compare the variables.
4227 because of the way DOWNCASE uses temp variables. */
4229 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
))
4230 && ! ASCII_CHAR_P (i1
))
4232 MAKE_CHAR_MULTIBYTE (i1
);
4235 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
))
4236 && ! ASCII_CHAR_P (i2
))
4238 MAKE_CHAR_MULTIBYTE (i2
);
4242 return (i1
== i2
? Qt
: Qnil
);
4245 /* Transpose the markers in two regions of the current buffer, and
4246 adjust the ones between them if necessary (i.e.: if the regions
4249 START1, END1 are the character positions of the first region.
4250 START1_BYTE, END1_BYTE are the byte positions.
4251 START2, END2 are the character positions of the second region.
4252 START2_BYTE, END2_BYTE are the byte positions.
4254 Traverses the entire marker list of the buffer to do so, adding an
4255 appropriate amount to some, subtracting from some, and leaving the
4256 rest untouched. Most of this is copied from adjust_markers in insdel.c.
4258 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
4261 transpose_markers (EMACS_INT start1
, EMACS_INT end1
,
4262 EMACS_INT start2
, EMACS_INT end2
,
4263 EMACS_INT start1_byte
, EMACS_INT end1_byte
,
4264 EMACS_INT start2_byte
, EMACS_INT end2_byte
)
4266 register EMACS_INT amt1
, amt1_byte
, amt2
, amt2_byte
, diff
, diff_byte
, mpos
;
4267 register struct Lisp_Marker
*marker
;
4269 /* Update point as if it were a marker. */
4273 TEMP_SET_PT_BOTH (PT
+ (end2
- end1
),
4274 PT_BYTE
+ (end2_byte
- end1_byte
));
4275 else if (PT
< start2
)
4276 TEMP_SET_PT_BOTH (PT
+ (end2
- start2
) - (end1
- start1
),
4277 (PT_BYTE
+ (end2_byte
- start2_byte
)
4278 - (end1_byte
- start1_byte
)));
4280 TEMP_SET_PT_BOTH (PT
- (start2
- start1
),
4281 PT_BYTE
- (start2_byte
- start1_byte
));
4283 /* We used to adjust the endpoints here to account for the gap, but that
4284 isn't good enough. Even if we assume the caller has tried to move the
4285 gap out of our way, it might still be at start1 exactly, for example;
4286 and that places it `inside' the interval, for our purposes. The amount
4287 of adjustment is nontrivial if there's a `denormalized' marker whose
4288 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
4289 the dirty work to Fmarker_position, below. */
4291 /* The difference between the region's lengths */
4292 diff
= (end2
- start2
) - (end1
- start1
);
4293 diff_byte
= (end2_byte
- start2_byte
) - (end1_byte
- start1_byte
);
4295 /* For shifting each marker in a region by the length of the other
4296 region plus the distance between the regions. */
4297 amt1
= (end2
- start2
) + (start2
- end1
);
4298 amt2
= (end1
- start1
) + (start2
- end1
);
4299 amt1_byte
= (end2_byte
- start2_byte
) + (start2_byte
- end1_byte
);
4300 amt2_byte
= (end1_byte
- start1_byte
) + (start2_byte
- end1_byte
);
4302 for (marker
= BUF_MARKERS (current_buffer
); marker
; marker
= marker
->next
)
4304 mpos
= marker
->bytepos
;
4305 if (mpos
>= start1_byte
&& mpos
< end2_byte
)
4307 if (mpos
< end1_byte
)
4309 else if (mpos
< start2_byte
)
4313 marker
->bytepos
= mpos
;
4315 mpos
= marker
->charpos
;
4316 if (mpos
>= start1
&& mpos
< end2
)
4320 else if (mpos
< start2
)
4325 marker
->charpos
= mpos
;
4329 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
4330 doc
: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
4331 The regions should not be overlapping, because the size of the buffer is
4332 never changed in a transposition.
4334 Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
4335 any markers that happen to be located in the regions.
4337 Transposing beyond buffer boundaries is an error. */)
4338 (Lisp_Object startr1
, Lisp_Object endr1
, Lisp_Object startr2
, Lisp_Object endr2
, Lisp_Object leave_markers
)
4340 register EMACS_INT start1
, end1
, start2
, end2
;
4341 EMACS_INT start1_byte
, start2_byte
, len1_byte
, len2_byte
;
4342 EMACS_INT gap
, len1
, len_mid
, len2
;
4343 unsigned char *start1_addr
, *start2_addr
, *temp
;
4345 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
, tmp_interval3
;
4348 XSETBUFFER (buf
, current_buffer
);
4349 cur_intv
= BUF_INTERVALS (current_buffer
);
4351 validate_region (&startr1
, &endr1
);
4352 validate_region (&startr2
, &endr2
);
4354 start1
= XFASTINT (startr1
);
4355 end1
= XFASTINT (endr1
);
4356 start2
= XFASTINT (startr2
);
4357 end2
= XFASTINT (endr2
);
4360 /* Swap the regions if they're reversed. */
4363 register EMACS_INT glumph
= start1
;
4371 len1
= end1
- start1
;
4372 len2
= end2
- start2
;
4375 error ("Transposed regions overlap");
4376 else if (start1
== end1
|| start2
== end2
)
4377 error ("Transposed region has length 0");
4379 /* The possibilities are:
4380 1. Adjacent (contiguous) regions, or separate but equal regions
4381 (no, really equal, in this case!), or
4382 2. Separate regions of unequal size.
4384 The worst case is usually No. 2. It means that (aside from
4385 potential need for getting the gap out of the way), there also
4386 needs to be a shifting of the text between the two regions. So
4387 if they are spread far apart, we are that much slower... sigh. */
4389 /* It must be pointed out that the really studly thing to do would
4390 be not to move the gap at all, but to leave it in place and work
4391 around it if necessary. This would be extremely efficient,
4392 especially considering that people are likely to do
4393 transpositions near where they are working interactively, which
4394 is exactly where the gap would be found. However, such code
4395 would be much harder to write and to read. So, if you are
4396 reading this comment and are feeling squirrely, by all means have
4397 a go! I just didn't feel like doing it, so I will simply move
4398 the gap the minimum distance to get it out of the way, and then
4399 deal with an unbroken array. */
4401 /* Make sure the gap won't interfere, by moving it out of the text
4402 we will operate on. */
4403 if (start1
< gap
&& gap
< end2
)
4405 if (gap
- start1
< end2
- gap
)
4411 start1_byte
= CHAR_TO_BYTE (start1
);
4412 start2_byte
= CHAR_TO_BYTE (start2
);
4413 len1_byte
= CHAR_TO_BYTE (end1
) - start1_byte
;
4414 len2_byte
= CHAR_TO_BYTE (end2
) - start2_byte
;
4416 #ifdef BYTE_COMBINING_DEBUG
4419 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4420 len2_byte
, start1
, start1_byte
)
4421 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4422 len1_byte
, end2
, start2_byte
+ len2_byte
)
4423 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4424 len1_byte
, end2
, start2_byte
+ len2_byte
))
4429 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4430 len2_byte
, start1
, start1_byte
)
4431 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4432 len1_byte
, start2
, start2_byte
)
4433 || count_combining_after (BYTE_POS_ADDR (start2_byte
),
4434 len2_byte
, end1
, start1_byte
+ len1_byte
)
4435 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4436 len1_byte
, end2
, start2_byte
+ len2_byte
))
4441 /* Hmmm... how about checking to see if the gap is large
4442 enough to use as the temporary storage? That would avoid an
4443 allocation... interesting. Later, don't fool with it now. */
4445 /* Working without memmove, for portability (sigh), so must be
4446 careful of overlapping subsections of the array... */
4448 if (end1
== start2
) /* adjacent regions */
4450 modify_region (current_buffer
, start1
, end2
, 0);
4451 record_change (start1
, len1
+ len2
);
4453 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4454 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4455 /* Don't use Fset_text_properties: that can cause GC, which can
4456 clobber objects stored in the tmp_intervals. */
4457 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4458 if (!NULL_INTERVAL_P (tmp_interval3
))
4459 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4461 /* First region smaller than second. */
4462 if (len1_byte
< len2_byte
)
4466 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4468 /* Don't precompute these addresses. We have to compute them
4469 at the last minute, because the relocating allocator might
4470 have moved the buffer around during the xmalloc. */
4471 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4472 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4474 memcpy (temp
, start2_addr
, len2_byte
);
4475 memcpy (start1_addr
+ len2_byte
, start1_addr
, len1_byte
);
4476 memcpy (start1_addr
, temp
, len2_byte
);
4480 /* First region not smaller than second. */
4484 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4485 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4486 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4487 memcpy (temp
, start1_addr
, len1_byte
);
4488 memcpy (start1_addr
, start2_addr
, len2_byte
);
4489 memcpy (start1_addr
+ len2_byte
, temp
, len1_byte
);
4492 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
4493 len1
, current_buffer
, 0);
4494 graft_intervals_into_buffer (tmp_interval2
, start1
,
4495 len2
, current_buffer
, 0);
4496 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4497 update_compositions (start1
+ len2
, end2
, CHECK_TAIL
);
4499 /* Non-adjacent regions, because end1 != start2, bleagh... */
4502 len_mid
= start2_byte
- (start1_byte
+ len1_byte
);
4504 if (len1_byte
== len2_byte
)
4505 /* Regions are same size, though, how nice. */
4509 modify_region (current_buffer
, start1
, end1
, 0);
4510 modify_region (current_buffer
, start2
, end2
, 0);
4511 record_change (start1
, len1
);
4512 record_change (start2
, len2
);
4513 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4514 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4516 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr1
, 0);
4517 if (!NULL_INTERVAL_P (tmp_interval3
))
4518 set_text_properties_1 (startr1
, endr1
, Qnil
, buf
, tmp_interval3
);
4520 tmp_interval3
= validate_interval_range (buf
, &startr2
, &endr2
, 0);
4521 if (!NULL_INTERVAL_P (tmp_interval3
))
4522 set_text_properties_1 (startr2
, endr2
, Qnil
, buf
, tmp_interval3
);
4524 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4525 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4526 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4527 memcpy (temp
, start1_addr
, len1_byte
);
4528 memcpy (start1_addr
, start2_addr
, len2_byte
);
4529 memcpy (start2_addr
, temp
, len1_byte
);
4532 graft_intervals_into_buffer (tmp_interval1
, start2
,
4533 len1
, current_buffer
, 0);
4534 graft_intervals_into_buffer (tmp_interval2
, start1
,
4535 len2
, current_buffer
, 0);
4538 else if (len1_byte
< len2_byte
) /* Second region larger than first */
4539 /* Non-adjacent & unequal size, area between must also be shifted. */
4543 modify_region (current_buffer
, start1
, end2
, 0);
4544 record_change (start1
, (end2
- start1
));
4545 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4546 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4547 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4549 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4550 if (!NULL_INTERVAL_P (tmp_interval3
))
4551 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4553 /* holds region 2 */
4554 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4555 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4556 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4557 memcpy (temp
, start2_addr
, len2_byte
);
4558 memcpy (start1_addr
+ len_mid
+ len2_byte
, start1_addr
, len1_byte
);
4559 memmove (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
4560 memcpy (start1_addr
, temp
, len2_byte
);
4563 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4564 len1
, current_buffer
, 0);
4565 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4566 len_mid
, current_buffer
, 0);
4567 graft_intervals_into_buffer (tmp_interval2
, start1
,
4568 len2
, current_buffer
, 0);
4571 /* Second region smaller than first. */
4575 record_change (start1
, (end2
- start1
));
4576 modify_region (current_buffer
, start1
, end2
, 0);
4578 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4579 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4580 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4582 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4583 if (!NULL_INTERVAL_P (tmp_interval3
))
4584 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4586 /* holds region 1 */
4587 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4588 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4589 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4590 memcpy (temp
, start1_addr
, len1_byte
);
4591 memcpy (start1_addr
, start2_addr
, len2_byte
);
4592 memcpy (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
4593 memcpy (start1_addr
+ len2_byte
+ len_mid
, temp
, len1_byte
);
4596 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4597 len1
, current_buffer
, 0);
4598 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4599 len_mid
, current_buffer
, 0);
4600 graft_intervals_into_buffer (tmp_interval2
, start1
,
4601 len2
, current_buffer
, 0);
4604 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4605 update_compositions (end2
- len1
, end2
, CHECK_BORDER
);
4608 /* When doing multiple transpositions, it might be nice
4609 to optimize this. Perhaps the markers in any one buffer
4610 should be organized in some sorted data tree. */
4611 if (NILP (leave_markers
))
4613 transpose_markers (start1
, end1
, start2
, end2
,
4614 start1_byte
, start1_byte
+ len1_byte
,
4615 start2_byte
, start2_byte
+ len2_byte
);
4616 fix_start_end_in_overlays (start1
, end2
);
4619 signal_after_change (start1
, end2
- start1
, end2
- start1
);
4625 syms_of_editfns (void)
4630 Qbuffer_access_fontify_functions
4631 = intern_c_string ("buffer-access-fontify-functions");
4632 staticpro (&Qbuffer_access_fontify_functions
);
4634 DEFVAR_LISP ("inhibit-field-text-motion", Vinhibit_field_text_motion
,
4635 doc
: /* Non-nil means text motion commands don't notice fields. */);
4636 Vinhibit_field_text_motion
= Qnil
;
4638 DEFVAR_LISP ("buffer-access-fontify-functions",
4639 Vbuffer_access_fontify_functions
,
4640 doc
: /* List of functions called by `buffer-substring' to fontify if necessary.
4641 Each function is called with two arguments which specify the range
4642 of the buffer being accessed. */);
4643 Vbuffer_access_fontify_functions
= Qnil
;
4647 obuf
= Fcurrent_buffer ();
4648 /* Do this here, because init_buffer_once is too early--it won't work. */
4649 Fset_buffer (Vprin1_to_string_buffer
);
4650 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
4651 Fset (Fmake_local_variable (intern_c_string ("buffer-access-fontify-functions")),
4656 DEFVAR_LISP ("buffer-access-fontified-property",
4657 Vbuffer_access_fontified_property
,
4658 doc
: /* Property which (if non-nil) indicates text has been fontified.
4659 `buffer-substring' need not call the `buffer-access-fontify-functions'
4660 functions if all the text being accessed has this property. */);
4661 Vbuffer_access_fontified_property
= Qnil
;
4663 DEFVAR_LISP ("system-name", Vsystem_name
,
4664 doc
: /* The host name of the machine Emacs is running on. */);
4666 DEFVAR_LISP ("user-full-name", Vuser_full_name
,
4667 doc
: /* The full name of the user logged in. */);
4669 DEFVAR_LISP ("user-login-name", Vuser_login_name
,
4670 doc
: /* The user's name, taken from environment variables if possible. */);
4672 DEFVAR_LISP ("user-real-login-name", Vuser_real_login_name
,
4673 doc
: /* The user's name, based upon the real uid only. */);
4675 DEFVAR_LISP ("operating-system-release", Voperating_system_release
,
4676 doc
: /* The release of the operating system Emacs is running on. */);
4678 defsubr (&Spropertize
);
4679 defsubr (&Schar_equal
);
4680 defsubr (&Sgoto_char
);
4681 defsubr (&Sstring_to_char
);
4682 defsubr (&Schar_to_string
);
4683 defsubr (&Sbyte_to_string
);
4684 defsubr (&Sbuffer_substring
);
4685 defsubr (&Sbuffer_substring_no_properties
);
4686 defsubr (&Sbuffer_string
);
4688 defsubr (&Spoint_marker
);
4689 defsubr (&Smark_marker
);
4691 defsubr (&Sregion_beginning
);
4692 defsubr (&Sregion_end
);
4694 staticpro (&Qfield
);
4695 Qfield
= intern_c_string ("field");
4696 staticpro (&Qboundary
);
4697 Qboundary
= intern_c_string ("boundary");
4698 defsubr (&Sfield_beginning
);
4699 defsubr (&Sfield_end
);
4700 defsubr (&Sfield_string
);
4701 defsubr (&Sfield_string_no_properties
);
4702 defsubr (&Sdelete_field
);
4703 defsubr (&Sconstrain_to_field
);
4705 defsubr (&Sline_beginning_position
);
4706 defsubr (&Sline_end_position
);
4708 /* defsubr (&Smark); */
4709 /* defsubr (&Sset_mark); */
4710 defsubr (&Ssave_excursion
);
4711 defsubr (&Ssave_current_buffer
);
4713 defsubr (&Sbufsize
);
4714 defsubr (&Spoint_max
);
4715 defsubr (&Spoint_min
);
4716 defsubr (&Spoint_min_marker
);
4717 defsubr (&Spoint_max_marker
);
4718 defsubr (&Sgap_position
);
4719 defsubr (&Sgap_size
);
4720 defsubr (&Sposition_bytes
);
4721 defsubr (&Sbyte_to_position
);
4727 defsubr (&Sfollowing_char
);
4728 defsubr (&Sprevious_char
);
4729 defsubr (&Schar_after
);
4730 defsubr (&Schar_before
);
4732 defsubr (&Sinsert_before_markers
);
4733 defsubr (&Sinsert_and_inherit
);
4734 defsubr (&Sinsert_and_inherit_before_markers
);
4735 defsubr (&Sinsert_char
);
4736 defsubr (&Sinsert_byte
);
4738 defsubr (&Suser_login_name
);
4739 defsubr (&Suser_real_login_name
);
4740 defsubr (&Suser_uid
);
4741 defsubr (&Suser_real_uid
);
4742 defsubr (&Suser_full_name
);
4743 defsubr (&Semacs_pid
);
4744 defsubr (&Scurrent_time
);
4745 defsubr (&Sget_internal_run_time
);
4746 defsubr (&Sformat_time_string
);
4747 defsubr (&Sfloat_time
);
4748 defsubr (&Sdecode_time
);
4749 defsubr (&Sencode_time
);
4750 defsubr (&Scurrent_time_string
);
4751 defsubr (&Scurrent_time_zone
);
4752 defsubr (&Sset_time_zone_rule
);
4753 defsubr (&Ssystem_name
);
4754 defsubr (&Smessage
);
4755 defsubr (&Smessage_box
);
4756 defsubr (&Smessage_or_box
);
4757 defsubr (&Scurrent_message
);
4760 defsubr (&Sinsert_buffer_substring
);
4761 defsubr (&Scompare_buffer_substrings
);
4762 defsubr (&Ssubst_char_in_region
);
4763 defsubr (&Stranslate_region_internal
);
4764 defsubr (&Sdelete_region
);
4765 defsubr (&Sdelete_and_extract_region
);
4767 defsubr (&Snarrow_to_region
);
4768 defsubr (&Ssave_restriction
);
4769 defsubr (&Stranspose_regions
);