1 /* Lisp functions pertaining to editing.
2 Copyright (C) 1985, 1986, 1987, 1989, 1993, 1994, 1995, 1996,
3 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4 2005, 2006 Free Software Foundation, Inc.
6 This file is part of GNU Emacs.
8 GNU Emacs is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 2, or (at your option)
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs; see the file COPYING. If not, write to
20 the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
21 Boston, MA 02110-1301, USA. */
25 #include <sys/types.h>
36 #ifdef HAVE_SYS_UTSNAME_H
37 #include <sys/utsname.h>
42 /* systime.h includes <sys/time.h> which, on some systems, is required
43 for <sys/resource.h>; thus systime.h must be included before
47 #if defined HAVE_SYS_RESOURCE_H
48 #include <sys/resource.h>
53 #include "intervals.h"
59 #include "blockinput.h"
63 #define MAX_10_EXP DBL_MAX_10_EXP
65 #define MAX_10_EXP 310
73 extern char **environ
;
76 #define TM_YEAR_BASE 1900
78 /* Nonzero if TM_YEAR is a struct tm's tm_year value that causes
79 asctime to have well-defined behavior. */
80 #ifndef TM_YEAR_IN_ASCTIME_RANGE
81 # define TM_YEAR_IN_ASCTIME_RANGE(tm_year) \
82 (1000 - TM_YEAR_BASE <= (tm_year) && (tm_year) <= 9999 - TM_YEAR_BASE)
85 extern size_t emacs_strftimeu
P_ ((char *, size_t, const char *,
86 const struct tm
*, int));
87 static int tm_diff
P_ ((struct tm
*, struct tm
*));
88 static void find_field
P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
, int *, Lisp_Object
, int *));
89 static void update_buffer_properties
P_ ((int, int));
90 static Lisp_Object region_limit
P_ ((int));
91 int lisp_time_argument
P_ ((Lisp_Object
, time_t *, int *));
92 static size_t emacs_memftimeu
P_ ((char *, size_t, const char *,
93 size_t, const struct tm
*, int));
94 static void general_insert_function
P_ ((void (*) (const unsigned char *, int),
95 void (*) (Lisp_Object
, int, int, int,
97 int, int, Lisp_Object
*));
98 static Lisp_Object subst_char_in_region_unwind
P_ ((Lisp_Object
));
99 static Lisp_Object subst_char_in_region_unwind_1
P_ ((Lisp_Object
));
100 static void transpose_markers
P_ ((int, int, int, int, int, int, int, int));
103 extern char *index
P_ ((const char *, int));
106 Lisp_Object Vbuffer_access_fontify_functions
;
107 Lisp_Object Qbuffer_access_fontify_functions
;
108 Lisp_Object Vbuffer_access_fontified_property
;
110 Lisp_Object Fuser_full_name
P_ ((Lisp_Object
));
112 /* Non-nil means don't stop at field boundary in text motion commands. */
114 Lisp_Object Vinhibit_field_text_motion
;
116 /* Some static data, and a function to initialize it for each run */
118 Lisp_Object Vsystem_name
;
119 Lisp_Object Vuser_real_login_name
; /* login name of current user ID */
120 Lisp_Object Vuser_full_name
; /* full name of current user */
121 Lisp_Object Vuser_login_name
; /* user name from LOGNAME or USER */
122 Lisp_Object Voperating_system_release
; /* Operating System Release */
124 /* Symbol for the text property used to mark fields. */
128 /* A special value for Qfield properties. */
130 Lisp_Object Qboundary
;
137 register unsigned char *p
;
138 struct passwd
*pw
; /* password entry for the current user */
141 /* Set up system_name even when dumping. */
145 /* Don't bother with this on initial start when just dumping out */
148 #endif /* not CANNOT_DUMP */
150 pw
= (struct passwd
*) getpwuid (getuid ());
152 /* We let the real user name default to "root" because that's quite
153 accurate on MSDOG and because it lets Emacs find the init file.
154 (The DVX libraries override the Djgpp libraries here.) */
155 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "root");
157 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "unknown");
160 /* Get the effective user name, by consulting environment variables,
161 or the effective uid if those are unset. */
162 user_name
= (char *) getenv ("LOGNAME");
165 user_name
= (char *) getenv ("USERNAME"); /* it's USERNAME on NT */
166 #else /* WINDOWSNT */
167 user_name
= (char *) getenv ("USER");
168 #endif /* WINDOWSNT */
171 pw
= (struct passwd
*) getpwuid (geteuid ());
172 user_name
= (char *) (pw
? pw
->pw_name
: "unknown");
174 Vuser_login_name
= build_string (user_name
);
176 /* If the user name claimed in the environment vars differs from
177 the real uid, use the claimed name to find the full name. */
178 tem
= Fstring_equal (Vuser_login_name
, Vuser_real_login_name
);
179 Vuser_full_name
= Fuser_full_name (NILP (tem
)? make_number (geteuid())
182 p
= (unsigned char *) getenv ("NAME");
184 Vuser_full_name
= build_string (p
);
185 else if (NILP (Vuser_full_name
))
186 Vuser_full_name
= build_string ("unknown");
188 #ifdef HAVE_SYS_UTSNAME_H
192 Voperating_system_release
= build_string (uts
.release
);
195 Voperating_system_release
= Qnil
;
199 DEFUN ("char-to-string", Fchar_to_string
, Schar_to_string
, 1, 1, 0,
200 doc
: /* Convert arg CHAR to a string containing that character.
201 usage: (char-to-string CHAR) */)
203 Lisp_Object character
;
206 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
208 CHECK_NUMBER (character
);
210 len
= (SINGLE_BYTE_CHAR_P (XFASTINT (character
))
211 ? (*str
= (unsigned char)(XFASTINT (character
)), 1)
212 : char_to_string (XFASTINT (character
), str
));
213 return make_string_from_bytes (str
, 1, len
);
216 DEFUN ("string-to-char", Fstring_to_char
, Sstring_to_char
, 1, 1, 0,
217 doc
: /* Convert arg STRING to a character, the first character of that string.
218 A multibyte character is handled correctly. */)
220 register Lisp_Object string
;
222 register Lisp_Object val
;
223 CHECK_STRING (string
);
226 if (STRING_MULTIBYTE (string
))
227 XSETFASTINT (val
, STRING_CHAR (SDATA (string
), SBYTES (string
)));
229 XSETFASTINT (val
, SREF (string
, 0));
232 XSETFASTINT (val
, 0);
237 buildmark (charpos
, bytepos
)
238 int charpos
, bytepos
;
240 register Lisp_Object mark
;
241 mark
= Fmake_marker ();
242 set_marker_both (mark
, Qnil
, charpos
, bytepos
);
246 DEFUN ("point", Fpoint
, Spoint
, 0, 0, 0,
247 doc
: /* Return value of point, as an integer.
248 Beginning of buffer is position (point-min). */)
252 XSETFASTINT (temp
, PT
);
256 DEFUN ("point-marker", Fpoint_marker
, Spoint_marker
, 0, 0, 0,
257 doc
: /* Return value of point, as a marker object. */)
260 return buildmark (PT
, PT_BYTE
);
264 clip_to_bounds (lower
, num
, upper
)
265 int lower
, num
, upper
;
269 else if (num
> upper
)
275 DEFUN ("goto-char", Fgoto_char
, Sgoto_char
, 1, 1, "NGoto char: ",
276 doc
: /* Set point to POSITION, a number or marker.
277 Beginning of buffer is position (point-min), end is (point-max). */)
279 register Lisp_Object position
;
283 if (MARKERP (position
)
284 && current_buffer
== XMARKER (position
)->buffer
)
286 pos
= marker_position (position
);
288 SET_PT_BOTH (BEGV
, BEGV_BYTE
);
290 SET_PT_BOTH (ZV
, ZV_BYTE
);
292 SET_PT_BOTH (pos
, marker_byte_position (position
));
297 CHECK_NUMBER_COERCE_MARKER (position
);
299 pos
= clip_to_bounds (BEGV
, XINT (position
), ZV
);
305 /* Return the start or end position of the region.
306 BEGINNINGP non-zero means return the start.
307 If there is no region active, signal an error. */
310 region_limit (beginningp
)
313 extern Lisp_Object Vmark_even_if_inactive
; /* Defined in callint.c. */
316 if (!NILP (Vtransient_mark_mode
)
317 && NILP (Vmark_even_if_inactive
)
318 && NILP (current_buffer
->mark_active
))
319 Fsignal (Qmark_inactive
, Qnil
);
321 m
= Fmarker_position (current_buffer
->mark
);
323 error ("The mark is not set now, so there is no region");
325 if ((PT
< XFASTINT (m
)) == (beginningp
!= 0))
326 m
= make_number (PT
);
330 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
331 doc
: /* Return position of beginning of region, as an integer. */)
334 return region_limit (1);
337 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
338 doc
: /* Return position of end of region, as an integer. */)
341 return region_limit (0);
344 DEFUN ("mark-marker", Fmark_marker
, Smark_marker
, 0, 0, 0,
345 doc
: /* Return this buffer's mark, as a marker object.
346 Watch out! Moving this marker changes the mark position.
347 If you set the marker not to point anywhere, the buffer will have no mark. */)
350 return current_buffer
->mark
;
354 /* Find all the overlays in the current buffer that touch position POS.
355 Return the number found, and store them in a vector in VEC
359 overlays_around (pos
, vec
, len
)
364 Lisp_Object overlay
, start
, end
;
365 struct Lisp_Overlay
*tail
;
366 int startpos
, endpos
;
369 for (tail
= current_buffer
->overlays_before
; tail
; tail
= tail
->next
)
371 XSETMISC (overlay
, tail
);
373 end
= OVERLAY_END (overlay
);
374 endpos
= OVERLAY_POSITION (end
);
377 start
= OVERLAY_START (overlay
);
378 startpos
= OVERLAY_POSITION (start
);
383 /* Keep counting overlays even if we can't return them all. */
388 for (tail
= current_buffer
->overlays_after
; tail
; tail
= tail
->next
)
390 XSETMISC (overlay
, tail
);
392 start
= OVERLAY_START (overlay
);
393 startpos
= OVERLAY_POSITION (start
);
396 end
= OVERLAY_END (overlay
);
397 endpos
= OVERLAY_POSITION (end
);
409 /* Return the value of property PROP, in OBJECT at POSITION.
410 It's the value of PROP that a char inserted at POSITION would get.
411 OBJECT is optional and defaults to the current buffer.
412 If OBJECT is a buffer, then overlay properties are considered as well as
414 If OBJECT is a window, then that window's buffer is used, but
415 window-specific overlays are considered only if they are associated
418 get_pos_property (position
, prop
, object
)
419 Lisp_Object position
, object
;
420 register Lisp_Object prop
;
422 CHECK_NUMBER_COERCE_MARKER (position
);
425 XSETBUFFER (object
, current_buffer
);
426 else if (WINDOWP (object
))
427 object
= XWINDOW (object
)->buffer
;
429 if (!BUFFERP (object
))
430 /* pos-property only makes sense in buffers right now, since strings
431 have no overlays and no notion of insertion for which stickiness
433 return Fget_text_property (position
, prop
, object
);
436 int posn
= XINT (position
);
438 Lisp_Object
*overlay_vec
, tem
;
439 struct buffer
*obuf
= current_buffer
;
441 set_buffer_temp (XBUFFER (object
));
443 /* First try with room for 40 overlays. */
445 overlay_vec
= (Lisp_Object
*) alloca (noverlays
* sizeof (Lisp_Object
));
446 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
448 /* If there are more than 40,
449 make enough space for all, and try again. */
452 overlay_vec
= (Lisp_Object
*) alloca (noverlays
* sizeof (Lisp_Object
));
453 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
455 noverlays
= sort_overlays (overlay_vec
, noverlays
, NULL
);
457 set_buffer_temp (obuf
);
459 /* Now check the overlays in order of decreasing priority. */
460 while (--noverlays
>= 0)
462 Lisp_Object ol
= overlay_vec
[noverlays
];
463 tem
= Foverlay_get (ol
, prop
);
466 /* Check the overlay is indeed active at point. */
467 Lisp_Object start
= OVERLAY_START (ol
), finish
= OVERLAY_END (ol
);
468 if ((OVERLAY_POSITION (start
) == posn
469 && XMARKER (start
)->insertion_type
== 1)
470 || (OVERLAY_POSITION (finish
) == posn
471 && XMARKER (finish
)->insertion_type
== 0))
472 ; /* The overlay will not cover a char inserted at point. */
480 { /* Now check the text-properties. */
481 int stickiness
= text_property_stickiness (prop
, position
, object
);
483 return Fget_text_property (position
, prop
, object
);
484 else if (stickiness
< 0
485 && XINT (position
) > BUF_BEGV (XBUFFER (object
)))
486 return Fget_text_property (make_number (XINT (position
) - 1),
494 /* Find the field surrounding POS in *BEG and *END. If POS is nil,
495 the value of point is used instead. If BEG or END is null,
496 means don't store the beginning or end of the field.
498 BEG_LIMIT and END_LIMIT serve to limit the ranged of the returned
499 results; they do not effect boundary behavior.
501 If MERGE_AT_BOUNDARY is nonzero, then if POS is at the very first
502 position of a field, then the beginning of the previous field is
503 returned instead of the beginning of POS's field (since the end of a
504 field is actually also the beginning of the next input field, this
505 behavior is sometimes useful). Additionally in the MERGE_AT_BOUNDARY
506 true case, if two fields are separated by a field with the special
507 value `boundary', and POS lies within it, then the two separated
508 fields are considered to be adjacent, and POS between them, when
509 finding the beginning and ending of the "merged" field.
511 Either BEG or END may be 0, in which case the corresponding value
515 find_field (pos
, merge_at_boundary
, beg_limit
, beg
, end_limit
, end
)
517 Lisp_Object merge_at_boundary
;
518 Lisp_Object beg_limit
, end_limit
;
521 /* Fields right before and after the point. */
522 Lisp_Object before_field
, after_field
;
523 /* 1 if POS counts as the start of a field. */
524 int at_field_start
= 0;
525 /* 1 if POS counts as the end of a field. */
526 int at_field_end
= 0;
529 XSETFASTINT (pos
, PT
);
531 CHECK_NUMBER_COERCE_MARKER (pos
);
534 = get_char_property_and_overlay (pos
, Qfield
, Qnil
, NULL
);
536 = (XFASTINT (pos
) > BEGV
537 ? get_char_property_and_overlay (make_number (XINT (pos
) - 1),
539 /* Using nil here would be a more obvious choice, but it would
540 fail when the buffer starts with a non-sticky field. */
543 /* See if we need to handle the case where MERGE_AT_BOUNDARY is nil
544 and POS is at beginning of a field, which can also be interpreted
545 as the end of the previous field. Note that the case where if
546 MERGE_AT_BOUNDARY is non-nil (see function comment) is actually the
547 more natural one; then we avoid treating the beginning of a field
549 if (NILP (merge_at_boundary
))
551 Lisp_Object field
= get_pos_property (pos
, Qfield
, Qnil
);
552 if (!EQ (field
, after_field
))
554 if (!EQ (field
, before_field
))
556 if (NILP (field
) && at_field_start
&& at_field_end
)
557 /* If an inserted char would have a nil field while the surrounding
558 text is non-nil, we're probably not looking at a
559 zero-length field, but instead at a non-nil field that's
560 not intended for editing (such as comint's prompts). */
561 at_field_end
= at_field_start
= 0;
564 /* Note about special `boundary' fields:
566 Consider the case where the point (`.') is between the fields `x' and `y':
570 In this situation, if merge_at_boundary is true, we consider the
571 `x' and `y' fields as forming one big merged field, and so the end
572 of the field is the end of `y'.
574 However, if `x' and `y' are separated by a special `boundary' field
575 (a field with a `field' char-property of 'boundary), then we ignore
576 this special field when merging adjacent fields. Here's the same
577 situation, but with a `boundary' field between the `x' and `y' fields:
581 Here, if point is at the end of `x', the beginning of `y', or
582 anywhere in-between (within the `boundary' field), we merge all
583 three fields and consider the beginning as being the beginning of
584 the `x' field, and the end as being the end of the `y' field. */
589 /* POS is at the edge of a field, and we should consider it as
590 the beginning of the following field. */
591 *beg
= XFASTINT (pos
);
593 /* Find the previous field boundary. */
596 if (!NILP (merge_at_boundary
) && EQ (before_field
, Qboundary
))
597 /* Skip a `boundary' field. */
598 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
601 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
603 *beg
= NILP (p
) ? BEGV
: XFASTINT (p
);
610 /* POS is at the edge of a field, and we should consider it as
611 the end of the previous field. */
612 *end
= XFASTINT (pos
);
614 /* Find the next field boundary. */
616 if (!NILP (merge_at_boundary
) && EQ (after_field
, Qboundary
))
617 /* Skip a `boundary' field. */
618 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
621 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
623 *end
= NILP (pos
) ? ZV
: XFASTINT (pos
);
629 DEFUN ("delete-field", Fdelete_field
, Sdelete_field
, 0, 1, 0,
630 doc
: /* Delete the field surrounding POS.
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.
634 An `args-out-of-range' error is signaled if POS is outside the
635 buffer's accessible portion. */)
640 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
642 del_range (beg
, end
);
646 DEFUN ("field-string", Ffield_string
, Sfield_string
, 0, 1, 0,
647 doc
: /* Return the contents of the field surrounding POS as a string.
648 A field is a region of text with the same `field' property.
649 If POS is nil, the value of point is used for POS.
651 An `args-out-of-range' error is signaled if POS is outside the
652 buffer's accessible portion. */)
657 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
658 return make_buffer_string (beg
, end
, 1);
661 DEFUN ("field-string-no-properties", Ffield_string_no_properties
, Sfield_string_no_properties
, 0, 1, 0,
662 doc
: /* Return the contents of the field around POS, without text-properties.
663 A field is a region of text with the same `field' property.
664 If POS is nil, the value of point is used for POS.
666 An `args-out-of-range' error is signaled if POS is outside the
667 buffer's accessible portion. */)
672 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
673 return make_buffer_string (beg
, end
, 0);
676 DEFUN ("field-beginning", Ffield_beginning
, Sfield_beginning
, 0, 3, 0,
677 doc
: /* Return the beginning of the field surrounding POS.
678 A field is a region of text with the same `field' property.
679 If POS is nil, the value of point is used for POS.
680 If ESCAPE-FROM-EDGE is non-nil and POS is at the beginning of its
681 field, then the beginning of the *previous* field is returned.
682 If LIMIT is non-nil, it is a buffer position; if the beginning of the field
683 is before LIMIT, then LIMIT will be returned instead.
685 An `args-out-of-range' error is signaled if POS is outside the
686 buffer's accessible portion. */)
687 (pos
, escape_from_edge
, limit
)
688 Lisp_Object pos
, escape_from_edge
, limit
;
691 find_field (pos
, escape_from_edge
, limit
, &beg
, Qnil
, 0);
692 return make_number (beg
);
695 DEFUN ("field-end", Ffield_end
, Sfield_end
, 0, 3, 0,
696 doc
: /* Return the end of the field surrounding POS.
697 A field is a region of text with the same `field' property.
698 If POS is nil, the value of point is used for POS.
699 If ESCAPE-FROM-EDGE is non-nil and POS is at the end of its field,
700 then the end of the *following* field is returned.
701 If LIMIT is non-nil, it is a buffer position; if the end of the field
702 is after LIMIT, then LIMIT will be returned instead.
704 An `args-out-of-range' error is signaled if POS is outside the
705 buffer's accessible portion. */)
706 (pos
, escape_from_edge
, limit
)
707 Lisp_Object pos
, escape_from_edge
, limit
;
710 find_field (pos
, escape_from_edge
, Qnil
, 0, limit
, &end
);
711 return make_number (end
);
714 DEFUN ("constrain-to-field", Fconstrain_to_field
, Sconstrain_to_field
, 2, 5, 0,
715 doc
: /* Return the position closest to NEW-POS that is in the same field as OLD-POS.
717 A field is a region of text with the same `field' property.
718 If NEW-POS is nil, then the current point is used instead, and set to the
719 constrained position if that is different.
721 If OLD-POS is at the boundary of two fields, then the allowable
722 positions for NEW-POS depends on the value of the optional argument
723 ESCAPE-FROM-EDGE: If ESCAPE-FROM-EDGE is nil, then NEW-POS is
724 constrained to the field that has the same `field' char-property
725 as any new characters inserted at OLD-POS, whereas if ESCAPE-FROM-EDGE
726 is non-nil, NEW-POS is constrained to the union of the two adjacent
727 fields. Additionally, if two fields are separated by another field with
728 the special value `boundary', then any point within this special field is
729 also considered to be `on the boundary'.
731 If the optional argument ONLY-IN-LINE is non-nil and constraining
732 NEW-POS would move it to a different line, NEW-POS is returned
733 unconstrained. This useful for commands that move by line, like
734 \\[next-line] or \\[beginning-of-line], which should generally respect field boundaries
735 only in the case where they can still move to the right line.
737 If the optional argument INHIBIT-CAPTURE-PROPERTY is non-nil, and OLD-POS has
738 a non-nil property of that name, then any field boundaries are ignored.
740 Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
741 (new_pos
, old_pos
, escape_from_edge
, only_in_line
, inhibit_capture_property
)
742 Lisp_Object new_pos
, old_pos
;
743 Lisp_Object escape_from_edge
, only_in_line
, inhibit_capture_property
;
745 /* If non-zero, then the original point, before re-positioning. */
748 Lisp_Object prev_old
, prev_new
;
751 /* Use the current point, and afterwards, set it. */
754 XSETFASTINT (new_pos
, PT
);
757 CHECK_NUMBER_COERCE_MARKER (new_pos
);
758 CHECK_NUMBER_COERCE_MARKER (old_pos
);
760 fwd
= (XFASTINT (new_pos
) > XFASTINT (old_pos
));
762 prev_old
= make_number (XFASTINT (old_pos
) - 1);
763 prev_new
= make_number (XFASTINT (new_pos
) - 1);
765 if (NILP (Vinhibit_field_text_motion
)
766 && !EQ (new_pos
, old_pos
)
767 && (!NILP (Fget_char_property (new_pos
, Qfield
, Qnil
))
768 || !NILP (Fget_char_property (old_pos
, Qfield
, Qnil
))
769 /* To recognize field boundaries, we must also look at the
770 previous positions; we could use `get_pos_property'
771 instead, but in itself that would fail inside non-sticky
772 fields (like comint prompts). */
773 || (XFASTINT (new_pos
) > BEGV
774 && !NILP (Fget_char_property (prev_new
, Qfield
, Qnil
)))
775 || (XFASTINT (old_pos
) > BEGV
776 && !NILP (Fget_char_property (prev_old
, Qfield
, Qnil
))))
777 && (NILP (inhibit_capture_property
)
778 /* Field boundaries are again a problem; but now we must
779 decide the case exactly, so we need to call
780 `get_pos_property' as well. */
781 || (NILP (get_pos_property (old_pos
, inhibit_capture_property
, Qnil
))
782 && (XFASTINT (old_pos
) <= BEGV
783 || NILP (Fget_char_property (old_pos
, inhibit_capture_property
, Qnil
))
784 || NILP (Fget_char_property (prev_old
, inhibit_capture_property
, Qnil
))))))
785 /* It is possible that NEW_POS is not within the same field as
786 OLD_POS; try to move NEW_POS so that it is. */
789 Lisp_Object field_bound
;
792 field_bound
= Ffield_end (old_pos
, escape_from_edge
, new_pos
);
794 field_bound
= Ffield_beginning (old_pos
, escape_from_edge
, new_pos
);
796 if (/* See if ESCAPE_FROM_EDGE caused FIELD_BOUND to jump to the
797 other side of NEW_POS, which would mean that NEW_POS is
798 already acceptable, and it's not necessary to constrain it
800 ((XFASTINT (field_bound
) < XFASTINT (new_pos
)) ? fwd
: !fwd
)
801 /* NEW_POS should be constrained, but only if either
802 ONLY_IN_LINE is nil (in which case any constraint is OK),
803 or NEW_POS and FIELD_BOUND are on the same line (in which
804 case the constraint is OK even if ONLY_IN_LINE is non-nil). */
805 && (NILP (only_in_line
)
806 /* This is the ONLY_IN_LINE case, check that NEW_POS and
807 FIELD_BOUND are on the same line by seeing whether
808 there's an intervening newline or not. */
809 || (scan_buffer ('\n',
810 XFASTINT (new_pos
), XFASTINT (field_bound
),
811 fwd
? -1 : 1, &shortage
, 1),
813 /* Constrain NEW_POS to FIELD_BOUND. */
814 new_pos
= field_bound
;
816 if (orig_point
&& XFASTINT (new_pos
) != orig_point
)
817 /* The NEW_POS argument was originally nil, so automatically set PT. */
818 SET_PT (XFASTINT (new_pos
));
825 DEFUN ("line-beginning-position",
826 Fline_beginning_position
, Sline_beginning_position
, 0, 1, 0,
827 doc
: /* Return the character position of the first character on the current line.
828 With argument N not nil or 1, move forward N - 1 lines first.
829 If scan reaches end of buffer, return that position.
831 This function constrains the returned position to the current field
832 unless that would be on a different line than the original,
833 unconstrained result. If N is nil or 1, and a front-sticky field
834 starts at point, the scan stops as soon as it starts. To ignore field
835 boundaries bind `inhibit-field-text-motion' to t.
837 This function does not move point. */)
841 int orig
, orig_byte
, end
;
842 int count
= SPECPDL_INDEX ();
843 specbind (Qinhibit_point_motion_hooks
, Qt
);
852 Fforward_line (make_number (XINT (n
) - 1));
855 SET_PT_BOTH (orig
, orig_byte
);
857 unbind_to (count
, Qnil
);
859 /* Return END constrained to the current input field. */
860 return Fconstrain_to_field (make_number (end
), make_number (orig
),
861 XINT (n
) != 1 ? Qt
: Qnil
,
865 DEFUN ("line-end-position", Fline_end_position
, Sline_end_position
, 0, 1, 0,
866 doc
: /* Return the character position of the last character on the current line.
867 With argument N not nil or 1, move forward N - 1 lines first.
868 If scan reaches end of buffer, return that position.
870 This function constrains the returned position to the current field
871 unless that would be on a different line than the original,
872 unconstrained result. If N is nil or 1, and a rear-sticky field ends
873 at point, the scan stops as soon as it starts. To ignore field
874 boundaries bind `inhibit-field-text-motion' to t.
876 This function does not move point. */)
888 end_pos
= find_before_next_newline (orig
, 0, XINT (n
) - (XINT (n
) <= 0));
890 /* Return END_POS constrained to the current input field. */
891 return Fconstrain_to_field (make_number (end_pos
), make_number (orig
),
897 save_excursion_save ()
899 int visible
= (XBUFFER (XWINDOW (selected_window
)->buffer
)
902 return Fcons (Fpoint_marker (),
903 Fcons (Fcopy_marker (current_buffer
->mark
, Qnil
),
904 Fcons (visible
? Qt
: Qnil
,
905 Fcons (current_buffer
->mark_active
,
910 save_excursion_restore (info
)
913 Lisp_Object tem
, tem1
, omark
, nmark
;
914 struct gcpro gcpro1
, gcpro2
, gcpro3
;
917 tem
= Fmarker_buffer (XCAR (info
));
918 /* If buffer being returned to is now deleted, avoid error */
919 /* Otherwise could get error here while unwinding to top level
921 /* In that case, Fmarker_buffer returns nil now. */
925 omark
= nmark
= Qnil
;
926 GCPRO3 (info
, omark
, nmark
);
933 unchain_marker (XMARKER (tem
));
938 omark
= Fmarker_position (current_buffer
->mark
);
939 Fset_marker (current_buffer
->mark
, tem
, Fcurrent_buffer ());
940 nmark
= Fmarker_position (tem
);
941 unchain_marker (XMARKER (tem
));
945 visible_p
= !NILP (XCAR (info
));
947 #if 0 /* We used to make the current buffer visible in the selected window
948 if that was true previously. That avoids some anomalies.
949 But it creates others, and it wasn't documented, and it is simpler
950 and cleaner never to alter the window/buffer connections. */
953 && current_buffer
!= XBUFFER (XWINDOW (selected_window
)->buffer
))
954 Fswitch_to_buffer (Fcurrent_buffer (), Qnil
);
960 tem1
= current_buffer
->mark_active
;
961 current_buffer
->mark_active
= tem
;
963 if (!NILP (Vrun_hooks
))
965 /* If mark is active now, and either was not active
966 or was at a different place, run the activate hook. */
967 if (! NILP (current_buffer
->mark_active
))
969 if (! EQ (omark
, nmark
))
970 call1 (Vrun_hooks
, intern ("activate-mark-hook"));
972 /* If mark has ceased to be active, run deactivate hook. */
973 else if (! NILP (tem1
))
974 call1 (Vrun_hooks
, intern ("deactivate-mark-hook"));
977 /* If buffer was visible in a window, and a different window was
978 selected, and the old selected window is still showing this
979 buffer, restore point in that window. */
982 && !EQ (tem
, selected_window
)
983 && (tem1
= XWINDOW (tem
)->buffer
,
984 (/* Window is live... */
986 /* ...and it shows the current buffer. */
987 && XBUFFER (tem1
) == current_buffer
)))
988 Fset_window_point (tem
, make_number (PT
));
994 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
995 doc
: /* Save point, mark, and current buffer; execute BODY; restore those things.
996 Executes BODY just like `progn'.
997 The values of point, mark and the current buffer are restored
998 even in case of abnormal exit (throw or error).
999 The state of activation of the mark is also restored.
1001 This construct does not save `deactivate-mark', and therefore
1002 functions that change the buffer will still cause deactivation
1003 of the mark at the end of the command. To prevent that, bind
1004 `deactivate-mark' with `let'.
1006 usage: (save-excursion &rest BODY) */)
1010 register Lisp_Object val
;
1011 int count
= SPECPDL_INDEX ();
1013 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
1015 val
= Fprogn (args
);
1016 return unbind_to (count
, val
);
1019 DEFUN ("save-current-buffer", Fsave_current_buffer
, Ssave_current_buffer
, 0, UNEVALLED
, 0,
1020 doc
: /* Save the current buffer; execute BODY; restore the current buffer.
1021 Executes BODY just like `progn'.
1022 usage: (save-current-buffer &rest BODY) */)
1027 int count
= SPECPDL_INDEX ();
1029 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
1031 val
= Fprogn (args
);
1032 return unbind_to (count
, val
);
1035 DEFUN ("buffer-size", Fbufsize
, Sbufsize
, 0, 1, 0,
1036 doc
: /* Return the number of characters in the current buffer.
1037 If BUFFER, return the number of characters in that buffer instead. */)
1042 return make_number (Z
- BEG
);
1045 CHECK_BUFFER (buffer
);
1046 return make_number (BUF_Z (XBUFFER (buffer
))
1047 - BUF_BEG (XBUFFER (buffer
)));
1051 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
1052 doc
: /* Return the minimum permissible value of point in the current buffer.
1053 This is 1, unless narrowing (a buffer restriction) is in effect. */)
1057 XSETFASTINT (temp
, BEGV
);
1061 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
1062 doc
: /* Return a marker to the minimum permissible value of point in this buffer.
1063 This is the beginning, unless narrowing (a buffer restriction) is in effect. */)
1066 return buildmark (BEGV
, BEGV_BYTE
);
1069 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
1070 doc
: /* Return the maximum permissible value of point in the current buffer.
1071 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1072 is in effect, in which case it is less. */)
1076 XSETFASTINT (temp
, ZV
);
1080 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
1081 doc
: /* Return a marker to the maximum permissible value of point in this buffer.
1082 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1083 is in effect, in which case it is less. */)
1086 return buildmark (ZV
, ZV_BYTE
);
1089 DEFUN ("gap-position", Fgap_position
, Sgap_position
, 0, 0, 0,
1090 doc
: /* Return the position of the gap, in the current buffer.
1091 See also `gap-size'. */)
1095 XSETFASTINT (temp
, GPT
);
1099 DEFUN ("gap-size", Fgap_size
, Sgap_size
, 0, 0, 0,
1100 doc
: /* Return the size of the current buffer's gap.
1101 See also `gap-position'. */)
1105 XSETFASTINT (temp
, GAP_SIZE
);
1109 DEFUN ("position-bytes", Fposition_bytes
, Sposition_bytes
, 1, 1, 0,
1110 doc
: /* Return the byte position for character position POSITION.
1111 If POSITION is out of range, the value is nil. */)
1113 Lisp_Object position
;
1115 CHECK_NUMBER_COERCE_MARKER (position
);
1116 if (XINT (position
) < BEG
|| XINT (position
) > Z
)
1118 return make_number (CHAR_TO_BYTE (XINT (position
)));
1121 DEFUN ("byte-to-position", Fbyte_to_position
, Sbyte_to_position
, 1, 1, 0,
1122 doc
: /* Return the character position for byte position BYTEPOS.
1123 If BYTEPOS is out of range, the value is nil. */)
1125 Lisp_Object bytepos
;
1127 CHECK_NUMBER (bytepos
);
1128 if (XINT (bytepos
) < BEG_BYTE
|| XINT (bytepos
) > Z_BYTE
)
1130 return make_number (BYTE_TO_CHAR (XINT (bytepos
)));
1133 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
1134 doc
: /* Return the character following point, as a number.
1135 At the end of the buffer or accessible region, return 0. */)
1140 XSETFASTINT (temp
, 0);
1142 XSETFASTINT (temp
, FETCH_CHAR (PT_BYTE
));
1146 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
1147 doc
: /* Return the character preceding point, as a number.
1148 At the beginning of the buffer or accessible region, return 0. */)
1153 XSETFASTINT (temp
, 0);
1154 else if (!NILP (current_buffer
->enable_multibyte_characters
))
1158 XSETFASTINT (temp
, FETCH_CHAR (pos
));
1161 XSETFASTINT (temp
, FETCH_BYTE (PT_BYTE
- 1));
1165 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
1166 doc
: /* Return t if point is at the beginning of the buffer.
1167 If the buffer is narrowed, this means the beginning of the narrowed part. */)
1175 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
1176 doc
: /* Return t if point is at the end of the buffer.
1177 If the buffer is narrowed, this means the end of the narrowed part. */)
1185 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
1186 doc
: /* Return t if point is at the beginning of a line. */)
1189 if (PT
== BEGV
|| FETCH_BYTE (PT_BYTE
- 1) == '\n')
1194 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
1195 doc
: /* Return t if point is at the end of a line.
1196 `End of a line' includes point being at the end of the buffer. */)
1199 if (PT
== ZV
|| FETCH_BYTE (PT_BYTE
) == '\n')
1204 DEFUN ("char-after", Fchar_after
, Schar_after
, 0, 1, 0,
1205 doc
: /* Return character in current buffer at position POS.
1206 POS is an integer or a marker and defaults to point.
1207 If POS is out of range, the value is nil. */)
1211 register int pos_byte
;
1216 XSETFASTINT (pos
, PT
);
1221 pos_byte
= marker_byte_position (pos
);
1222 if (pos_byte
< BEGV_BYTE
|| pos_byte
>= ZV_BYTE
)
1227 CHECK_NUMBER_COERCE_MARKER (pos
);
1228 if (XINT (pos
) < BEGV
|| XINT (pos
) >= ZV
)
1231 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1234 return make_number (FETCH_CHAR (pos_byte
));
1237 DEFUN ("char-before", Fchar_before
, Schar_before
, 0, 1, 0,
1238 doc
: /* Return character in current buffer preceding position POS.
1239 POS is an integer or a marker and defaults to point.
1240 If POS is out of range, the value is nil. */)
1244 register Lisp_Object val
;
1245 register int pos_byte
;
1250 XSETFASTINT (pos
, PT
);
1255 pos_byte
= marker_byte_position (pos
);
1257 if (pos_byte
<= BEGV_BYTE
|| pos_byte
> ZV_BYTE
)
1262 CHECK_NUMBER_COERCE_MARKER (pos
);
1264 if (XINT (pos
) <= BEGV
|| XINT (pos
) > ZV
)
1267 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1270 if (!NILP (current_buffer
->enable_multibyte_characters
))
1273 XSETFASTINT (val
, FETCH_CHAR (pos_byte
));
1278 XSETFASTINT (val
, FETCH_BYTE (pos_byte
));
1283 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 1, 0,
1284 doc
: /* Return the name under which the user logged in, as a string.
1285 This is based on the effective uid, not the real uid.
1286 Also, if the environment variables LOGNAME or USER are set,
1287 that determines the value of this function.
1289 If optional argument UID is an integer, return the login name of the user
1290 with that uid, or nil if there is no such user. */)
1296 /* Set up the user name info if we didn't do it before.
1297 (That can happen if Emacs is dumpable
1298 but you decide to run `temacs -l loadup' and not dump. */
1299 if (INTEGERP (Vuser_login_name
))
1303 return Vuser_login_name
;
1307 pw
= (struct passwd
*) getpwuid (XINT (uid
));
1309 return (pw
? build_string (pw
->pw_name
) : Qnil
);
1312 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
1314 doc
: /* Return the name of the user's real uid, as a string.
1315 This ignores the environment variables LOGNAME and USER, so it differs from
1316 `user-login-name' when running under `su'. */)
1319 /* Set up the user name info if we didn't do it before.
1320 (That can happen if Emacs is dumpable
1321 but you decide to run `temacs -l loadup' and not dump. */
1322 if (INTEGERP (Vuser_login_name
))
1324 return Vuser_real_login_name
;
1327 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
1328 doc
: /* Return the effective uid of Emacs.
1329 Value is an integer or float, depending on the value. */)
1332 return make_fixnum_or_float (geteuid ());
1335 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
1336 doc
: /* Return the real uid of Emacs.
1337 Value is an integer or float, depending on the value. */)
1340 return make_fixnum_or_float (getuid ());
1343 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 1, 0,
1344 doc
: /* Return the full name of the user logged in, as a string.
1345 If the full name corresponding to Emacs's userid is not known,
1348 If optional argument UID is an integer or float, return the full name
1349 of the user with that uid, or nil if there is no such user.
1350 If UID is a string, return the full name of the user with that login
1351 name, or nil if there is no such user. */)
1356 register unsigned char *p
, *q
;
1360 return Vuser_full_name
;
1361 else if (NUMBERP (uid
))
1364 pw
= (struct passwd
*) getpwuid ((uid_t
) XFLOATINT (uid
));
1367 else if (STRINGP (uid
))
1370 pw
= (struct passwd
*) getpwnam (SDATA (uid
));
1374 error ("Invalid UID specification");
1379 p
= (unsigned char *) USER_FULL_NAME
;
1380 /* Chop off everything after the first comma. */
1381 q
= (unsigned char *) index (p
, ',');
1382 full
= make_string (p
, q
? q
- p
: strlen (p
));
1384 #ifdef AMPERSAND_FULL_NAME
1386 q
= (unsigned char *) index (p
, '&');
1387 /* Substitute the login name for the &, upcasing the first character. */
1390 register unsigned char *r
;
1393 login
= Fuser_login_name (make_number (pw
->pw_uid
));
1394 r
= (unsigned char *) alloca (strlen (p
) + SCHARS (login
) + 1);
1395 bcopy (p
, r
, q
- p
);
1397 strcat (r
, SDATA (login
));
1398 r
[q
- p
] = UPCASE (r
[q
- p
]);
1400 full
= build_string (r
);
1402 #endif /* AMPERSAND_FULL_NAME */
1407 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
1408 doc
: /* Return the name of the machine you are running on, as a string. */)
1411 return Vsystem_name
;
1414 /* For the benefit of callers who don't want to include lisp.h */
1419 if (STRINGP (Vsystem_name
))
1420 return (char *) SDATA (Vsystem_name
);
1426 get_operating_system_release()
1428 if (STRINGP (Voperating_system_release
))
1429 return (char *) SDATA (Voperating_system_release
);
1434 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
1435 doc
: /* Return the process ID of Emacs, as an integer. */)
1438 return make_number (getpid ());
1441 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
1442 doc
: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
1443 The time is returned as a list of three integers. The first has the
1444 most significant 16 bits of the seconds, while the second has the
1445 least significant 16 bits. The third integer gives the microsecond
1448 The microsecond count is zero on systems that do not provide
1449 resolution finer than a second. */)
1453 Lisp_Object result
[3];
1456 XSETINT (result
[0], (EMACS_SECS (t
) >> 16) & 0xffff);
1457 XSETINT (result
[1], (EMACS_SECS (t
) >> 0) & 0xffff);
1458 XSETINT (result
[2], EMACS_USECS (t
));
1460 return Flist (3, result
);
1463 DEFUN ("get-internal-run-time", Fget_internal_run_time
, Sget_internal_run_time
,
1465 doc
: /* Return the current run time used by Emacs.
1466 The time is returned as a list of three integers. The first has the
1467 most significant 16 bits of the seconds, while the second has the
1468 least significant 16 bits. The third integer gives the microsecond
1471 On systems that can't determine the run time, get-internal-run-time
1472 does the same thing as current-time. The microsecond count is zero on
1473 systems that do not provide resolution finer than a second. */)
1476 #ifdef HAVE_GETRUSAGE
1477 struct rusage usage
;
1478 Lisp_Object result
[3];
1481 if (getrusage (RUSAGE_SELF
, &usage
) < 0)
1482 /* This shouldn't happen. What action is appropriate? */
1483 Fsignal (Qerror
, Qnil
);
1485 /* Sum up user time and system time. */
1486 secs
= usage
.ru_utime
.tv_sec
+ usage
.ru_stime
.tv_sec
;
1487 usecs
= usage
.ru_utime
.tv_usec
+ usage
.ru_stime
.tv_usec
;
1488 if (usecs
>= 1000000)
1494 XSETINT (result
[0], (secs
>> 16) & 0xffff);
1495 XSETINT (result
[1], (secs
>> 0) & 0xffff);
1496 XSETINT (result
[2], usecs
);
1498 return Flist (3, result
);
1500 return Fcurrent_time ();
1506 lisp_time_argument (specified_time
, result
, usec
)
1507 Lisp_Object specified_time
;
1511 if (NILP (specified_time
))
1518 *usec
= EMACS_USECS (t
);
1519 *result
= EMACS_SECS (t
);
1523 return time (result
) != -1;
1527 Lisp_Object high
, low
;
1528 high
= Fcar (specified_time
);
1529 CHECK_NUMBER (high
);
1530 low
= Fcdr (specified_time
);
1535 Lisp_Object usec_l
= Fcdr (low
);
1537 usec_l
= Fcar (usec_l
);
1542 CHECK_NUMBER (usec_l
);
1543 *usec
= XINT (usec_l
);
1551 *result
= (XINT (high
) << 16) + (XINT (low
) & 0xffff);
1552 return *result
>> 16 == XINT (high
);
1556 DEFUN ("float-time", Ffloat_time
, Sfloat_time
, 0, 1, 0,
1557 doc
: /* Return the current time, as a float number of seconds since the epoch.
1558 If SPECIFIED-TIME is given, it is the time to convert to float
1559 instead of the current time. The argument should have the form
1560 (HIGH LOW . IGNORED). Thus, you can use times obtained from
1561 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
1562 have the form (HIGH . LOW), but this is considered obsolete.
1564 WARNING: Since the result is floating point, it may not be exact.
1565 Do not use this function if precise time stamps are required. */)
1567 Lisp_Object specified_time
;
1572 if (! lisp_time_argument (specified_time
, &sec
, &usec
))
1573 error ("Invalid time specification");
1575 return make_float ((sec
* 1e6
+ usec
) / 1e6
);
1578 /* Write information into buffer S of size MAXSIZE, according to the
1579 FORMAT of length FORMAT_LEN, using time information taken from *TP.
1580 Default to Universal Time if UT is nonzero, local time otherwise.
1581 Return the number of bytes written, not including the terminating
1582 '\0'. If S is NULL, nothing will be written anywhere; so to
1583 determine how many bytes would be written, use NULL for S and
1584 ((size_t) -1) for MAXSIZE.
1586 This function behaves like emacs_strftimeu, except it allows null
1589 emacs_memftimeu (s
, maxsize
, format
, format_len
, tp
, ut
)
1594 const struct tm
*tp
;
1599 /* Loop through all the null-terminated strings in the format
1600 argument. Normally there's just one null-terminated string, but
1601 there can be arbitrarily many, concatenated together, if the
1602 format contains '\0' bytes. emacs_strftimeu stops at the first
1603 '\0' byte so we must invoke it separately for each such string. */
1612 result
= emacs_strftimeu (s
, maxsize
, format
, tp
, ut
);
1616 if (result
== 0 && s
[0] != '\0')
1621 maxsize
-= result
+ 1;
1623 len
= strlen (format
);
1624 if (len
== format_len
)
1628 format_len
-= len
+ 1;
1632 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 1, 3, 0,
1633 doc
: /* Use FORMAT-STRING to format the time TIME, or now if omitted.
1634 TIME is specified as (HIGH LOW . IGNORED), as returned by
1635 `current-time' or `file-attributes'. The obsolete form (HIGH . LOW)
1636 is also still accepted.
1637 The third, optional, argument UNIVERSAL, if non-nil, means describe TIME
1638 as Universal Time; nil means describe TIME in the local time zone.
1639 The value is a copy of FORMAT-STRING, but with certain constructs replaced
1640 by text that describes the specified date and time in TIME:
1642 %Y is the year, %y within the century, %C the century.
1643 %G is the year corresponding to the ISO week, %g within the century.
1644 %m is the numeric month.
1645 %b and %h are the locale's abbreviated month name, %B the full name.
1646 %d is the day of the month, zero-padded, %e is blank-padded.
1647 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
1648 %a is the locale's abbreviated name of the day of week, %A the full name.
1649 %U is the week number starting on Sunday, %W starting on Monday,
1650 %V according to ISO 8601.
1651 %j is the day of the year.
1653 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
1654 only blank-padded, %l is like %I blank-padded.
1655 %p is the locale's equivalent of either AM or PM.
1658 %Z is the time zone name, %z is the numeric form.
1659 %s is the number of seconds since 1970-01-01 00:00:00 +0000.
1661 %c is the locale's date and time format.
1662 %x is the locale's "preferred" date format.
1663 %D is like "%m/%d/%y".
1665 %R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
1666 %X is the locale's "preferred" time format.
1668 Finally, %n is a newline, %t is a tab, %% is a literal %.
1670 Certain flags and modifiers are available with some format controls.
1671 The flags are `_', `-', `^' and `#'. For certain characters X,
1672 %_X is like %X, but padded with blanks; %-X is like %X,
1673 but without padding. %^X is like %X, but with all textual
1674 characters up-cased; %#X is like %X, but with letter-case of
1675 all textual characters reversed.
1676 %NX (where N stands for an integer) is like %X,
1677 but takes up at least N (a number) positions.
1678 The modifiers are `E' and `O'. For certain characters X,
1679 %EX is a locale's alternative version of %X;
1680 %OX is like %X, but uses the locale's number symbols.
1682 For example, to produce full ISO 8601 format, use "%Y-%m-%dT%T%z". */)
1683 (format_string
, time
, universal
)
1684 Lisp_Object format_string
, time
, universal
;
1689 int ut
= ! NILP (universal
);
1691 CHECK_STRING (format_string
);
1693 if (! lisp_time_argument (time
, &value
, NULL
))
1694 error ("Invalid time specification");
1696 format_string
= code_convert_string_norecord (format_string
,
1697 Vlocale_coding_system
, 1);
1699 /* This is probably enough. */
1700 size
= SBYTES (format_string
) * 6 + 50;
1702 tm
= ut
? gmtime (&value
) : localtime (&value
);
1704 error ("Specified time is not representable");
1706 synchronize_system_time_locale ();
1710 char *buf
= (char *) alloca (size
+ 1);
1714 result
= emacs_memftimeu (buf
, size
, SDATA (format_string
),
1715 SBYTES (format_string
),
1717 if ((result
> 0 && result
< size
) || (result
== 0 && buf
[0] == '\0'))
1718 return code_convert_string_norecord (make_string (buf
, result
),
1719 Vlocale_coding_system
, 0);
1721 /* If buffer was too small, make it bigger and try again. */
1722 result
= emacs_memftimeu (NULL
, (size_t) -1,
1723 SDATA (format_string
),
1724 SBYTES (format_string
),
1730 DEFUN ("decode-time", Fdecode_time
, Sdecode_time
, 0, 1, 0,
1731 doc
: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST ZONE).
1732 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED),
1733 as from `current-time' and `file-attributes', or `nil' to use the
1734 current time. The obsolete form (HIGH . LOW) is also still accepted.
1735 The list has the following nine members: SEC is an integer between 0
1736 and 60; SEC is 60 for a leap second, which only some operating systems
1737 support. MINUTE is an integer between 0 and 59. HOUR is an integer
1738 between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
1739 integer between 1 and 12. YEAR is an integer indicating the
1740 four-digit year. DOW is the day of week, an integer between 0 and 6,
1741 where 0 is Sunday. DST is t if daylight savings time is effect,
1742 otherwise nil. ZONE is an integer indicating the number of seconds
1743 east of Greenwich. (Note that Common Lisp has different meanings for
1746 Lisp_Object specified_time
;
1750 struct tm
*decoded_time
;
1751 Lisp_Object list_args
[9];
1753 if (! lisp_time_argument (specified_time
, &time_spec
, NULL
))
1754 error ("Invalid time specification");
1756 decoded_time
= localtime (&time_spec
);
1758 error ("Specified time is not representable");
1759 XSETFASTINT (list_args
[0], decoded_time
->tm_sec
);
1760 XSETFASTINT (list_args
[1], decoded_time
->tm_min
);
1761 XSETFASTINT (list_args
[2], decoded_time
->tm_hour
);
1762 XSETFASTINT (list_args
[3], decoded_time
->tm_mday
);
1763 XSETFASTINT (list_args
[4], decoded_time
->tm_mon
+ 1);
1764 /* On 64-bit machines an int is narrower than EMACS_INT, thus the
1765 cast below avoids overflow in int arithmetics. */
1766 XSETINT (list_args
[5], TM_YEAR_BASE
+ (EMACS_INT
) decoded_time
->tm_year
);
1767 XSETFASTINT (list_args
[6], decoded_time
->tm_wday
);
1768 list_args
[7] = (decoded_time
->tm_isdst
)? Qt
: Qnil
;
1770 /* Make a copy, in case gmtime modifies the struct. */
1771 save_tm
= *decoded_time
;
1772 decoded_time
= gmtime (&time_spec
);
1773 if (decoded_time
== 0)
1774 list_args
[8] = Qnil
;
1776 XSETINT (list_args
[8], tm_diff (&save_tm
, decoded_time
));
1777 return Flist (9, list_args
);
1780 DEFUN ("encode-time", Fencode_time
, Sencode_time
, 6, MANY
, 0,
1781 doc
: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
1782 This is the reverse operation of `decode-time', which see.
1783 ZONE defaults to the current time zone rule. This can
1784 be a string or t (as from `set-time-zone-rule'), or it can be a list
1785 \(as from `current-time-zone') or an integer (as from `decode-time')
1786 applied without consideration for daylight savings time.
1788 You can pass more than 7 arguments; then the first six arguments
1789 are used as SECOND through YEAR, and the *last* argument is used as ZONE.
1790 The intervening arguments are ignored.
1791 This feature lets (apply 'encode-time (decode-time ...)) work.
1793 Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed;
1794 for example, a DAY of 0 means the day preceding the given month.
1795 Year numbers less than 100 are treated just like other year numbers.
1796 If you want them to stand for years in this century, you must do that yourself.
1798 Years before 1970 are not guaranteed to work. On some systems,
1799 year values as low as 1901 do work.
1801 usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
1804 register Lisp_Object
*args
;
1808 Lisp_Object zone
= (nargs
> 6 ? args
[nargs
- 1] : Qnil
);
1810 CHECK_NUMBER (args
[0]); /* second */
1811 CHECK_NUMBER (args
[1]); /* minute */
1812 CHECK_NUMBER (args
[2]); /* hour */
1813 CHECK_NUMBER (args
[3]); /* day */
1814 CHECK_NUMBER (args
[4]); /* month */
1815 CHECK_NUMBER (args
[5]); /* year */
1817 tm
.tm_sec
= XINT (args
[0]);
1818 tm
.tm_min
= XINT (args
[1]);
1819 tm
.tm_hour
= XINT (args
[2]);
1820 tm
.tm_mday
= XINT (args
[3]);
1821 tm
.tm_mon
= XINT (args
[4]) - 1;
1822 tm
.tm_year
= XINT (args
[5]) - TM_YEAR_BASE
;
1828 time
= mktime (&tm
);
1833 char **oldenv
= environ
, **newenv
;
1837 else if (STRINGP (zone
))
1838 tzstring
= (char *) SDATA (zone
);
1839 else if (INTEGERP (zone
))
1841 int abszone
= abs (XINT (zone
));
1842 sprintf (tzbuf
, "XXX%s%d:%02d:%02d", "-" + (XINT (zone
) < 0),
1843 abszone
/ (60*60), (abszone
/60) % 60, abszone
% 60);
1847 error ("Invalid time zone specification");
1849 /* Set TZ before calling mktime; merely adjusting mktime's returned
1850 value doesn't suffice, since that would mishandle leap seconds. */
1851 set_time_zone_rule (tzstring
);
1853 time
= mktime (&tm
);
1855 /* Restore TZ to previous value. */
1859 #ifdef LOCALTIME_CACHE
1864 if (time
== (time_t) -1)
1865 error ("Specified time is not representable");
1867 return make_time (time
);
1870 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
1871 doc
: /* Return the current time, as a human-readable string.
1872 Programs can use this function to decode a time,
1873 since the number of columns in each field is fixed
1874 if the year is in the range 1000-9999.
1875 The format is `Sun Sep 16 01:03:52 1973'.
1876 However, see also the functions `decode-time' and `format-time-string'
1877 which provide a much more powerful and general facility.
1879 If SPECIFIED-TIME is given, it is a time to format instead of the
1880 current time. The argument should have the form (HIGH LOW . IGNORED).
1881 Thus, you can use times obtained from `current-time' and from
1882 `file-attributes'. SPECIFIED-TIME can also have the form (HIGH . LOW),
1883 but this is considered obsolete. */)
1885 Lisp_Object specified_time
;
1891 if (! lisp_time_argument (specified_time
, &value
, NULL
))
1892 error ("Invalid time specification");
1894 /* Convert to a string, checking for out-of-range time stamps.
1895 Don't use 'ctime', as that might dump core if VALUE is out of
1897 tm
= localtime (&value
);
1898 if (! (tm
&& TM_YEAR_IN_ASCTIME_RANGE (tm
->tm_year
) && (tem
= asctime (tm
))))
1899 error ("Specified time is not representable");
1901 /* Remove the trailing newline. */
1902 tem
[strlen (tem
) - 1] = '\0';
1904 return build_string (tem
);
1907 /* Yield A - B, measured in seconds.
1908 This function is copied from the GNU C Library. */
1913 /* Compute intervening leap days correctly even if year is negative.
1914 Take care to avoid int overflow in leap day calculations,
1915 but it's OK to assume that A and B are close to each other. */
1916 int a4
= (a
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (a
->tm_year
& 3);
1917 int b4
= (b
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (b
->tm_year
& 3);
1918 int a100
= a4
/ 25 - (a4
% 25 < 0);
1919 int b100
= b4
/ 25 - (b4
% 25 < 0);
1920 int a400
= a100
>> 2;
1921 int b400
= b100
>> 2;
1922 int intervening_leap_days
= (a4
- b4
) - (a100
- b100
) + (a400
- b400
);
1923 int years
= a
->tm_year
- b
->tm_year
;
1924 int days
= (365 * years
+ intervening_leap_days
1925 + (a
->tm_yday
- b
->tm_yday
));
1926 return (60 * (60 * (24 * days
+ (a
->tm_hour
- b
->tm_hour
))
1927 + (a
->tm_min
- b
->tm_min
))
1928 + (a
->tm_sec
- b
->tm_sec
));
1931 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
1932 doc
: /* Return the offset and name for the local time zone.
1933 This returns a list of the form (OFFSET NAME).
1934 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
1935 A negative value means west of Greenwich.
1936 NAME is a string giving the name of the time zone.
1937 If SPECIFIED-TIME is given, the time zone offset is determined from it
1938 instead of using the current time. The argument should have the form
1939 (HIGH LOW . IGNORED). Thus, you can use times obtained from
1940 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
1941 have the form (HIGH . LOW), but this is considered obsolete.
1943 Some operating systems cannot provide all this information to Emacs;
1944 in this case, `current-time-zone' returns a list containing nil for
1945 the data it can't find. */)
1947 Lisp_Object specified_time
;
1953 if (lisp_time_argument (specified_time
, &value
, NULL
)
1954 && (t
= gmtime (&value
)) != 0
1955 && (gmt
= *t
, t
= localtime (&value
)) != 0)
1957 int offset
= tm_diff (t
, &gmt
);
1962 s
= (char *)t
->tm_zone
;
1963 #else /* not HAVE_TM_ZONE */
1965 if (t
->tm_isdst
== 0 || t
->tm_isdst
== 1)
1966 s
= tzname
[t
->tm_isdst
];
1968 #endif /* not HAVE_TM_ZONE */
1970 #if defined HAVE_TM_ZONE || defined HAVE_TZNAME
1973 /* On Japanese w32, we can get a Japanese string as time
1974 zone name. Don't accept that. */
1976 for (p
= s
; *p
&& (isalnum ((unsigned char)*p
) || *p
== ' '); ++p
)
1985 /* No local time zone name is available; use "+-NNNN" instead. */
1986 int am
= (offset
< 0 ? -offset
: offset
) / 60;
1987 sprintf (buf
, "%c%02d%02d", (offset
< 0 ? '-' : '+'), am
/60, am
%60);
1990 return Fcons (make_number (offset
), Fcons (build_string (s
), Qnil
));
1993 return Fmake_list (make_number (2), Qnil
);
1996 /* This holds the value of `environ' produced by the previous
1997 call to Fset_time_zone_rule, or 0 if Fset_time_zone_rule
1998 has never been called. */
1999 static char **environbuf
;
2001 DEFUN ("set-time-zone-rule", Fset_time_zone_rule
, Sset_time_zone_rule
, 1, 1, 0,
2002 doc
: /* Set the local time zone using TZ, a string specifying a time zone rule.
2003 If TZ is nil, use implementation-defined default time zone information.
2004 If TZ is t, use Universal Time. */)
2012 else if (EQ (tz
, Qt
))
2017 tzstring
= (char *) SDATA (tz
);
2020 set_time_zone_rule (tzstring
);
2023 environbuf
= environ
;
2028 #ifdef LOCALTIME_CACHE
2030 /* These two values are known to load tz files in buggy implementations,
2031 i.e. Solaris 1 executables running under either Solaris 1 or Solaris 2.
2032 Their values shouldn't matter in non-buggy implementations.
2033 We don't use string literals for these strings,
2034 since if a string in the environment is in readonly
2035 storage, it runs afoul of bugs in SVR4 and Solaris 2.3.
2036 See Sun bugs 1113095 and 1114114, ``Timezone routines
2037 improperly modify environment''. */
2039 static char set_time_zone_rule_tz1
[] = "TZ=GMT+0";
2040 static char set_time_zone_rule_tz2
[] = "TZ=GMT+1";
2044 /* Set the local time zone rule to TZSTRING.
2045 This allocates memory into `environ', which it is the caller's
2046 responsibility to free. */
2049 set_time_zone_rule (tzstring
)
2053 char **from
, **to
, **newenv
;
2055 /* Make the ENVIRON vector longer with room for TZSTRING. */
2056 for (from
= environ
; *from
; from
++)
2058 envptrs
= from
- environ
+ 2;
2059 newenv
= to
= (char **) xmalloc (envptrs
* sizeof (char *)
2060 + (tzstring
? strlen (tzstring
) + 4 : 0));
2062 /* Add TZSTRING to the end of environ, as a value for TZ. */
2065 char *t
= (char *) (to
+ envptrs
);
2067 strcat (t
, tzstring
);
2071 /* Copy the old environ vector elements into NEWENV,
2072 but don't copy the TZ variable.
2073 So we have only one definition of TZ, which came from TZSTRING. */
2074 for (from
= environ
; *from
; from
++)
2075 if (strncmp (*from
, "TZ=", 3) != 0)
2081 /* If we do have a TZSTRING, NEWENV points to the vector slot where
2082 the TZ variable is stored. If we do not have a TZSTRING,
2083 TO points to the vector slot which has the terminating null. */
2085 #ifdef LOCALTIME_CACHE
2087 /* In SunOS 4.1.3_U1 and 4.1.4, if TZ has a value like
2088 "US/Pacific" that loads a tz file, then changes to a value like
2089 "XXX0" that does not load a tz file, and then changes back to
2090 its original value, the last change is (incorrectly) ignored.
2091 Also, if TZ changes twice in succession to values that do
2092 not load a tz file, tzset can dump core (see Sun bug#1225179).
2093 The following code works around these bugs. */
2097 /* Temporarily set TZ to a value that loads a tz file
2098 and that differs from tzstring. */
2100 *newenv
= (strcmp (tzstring
, set_time_zone_rule_tz1
+ 3) == 0
2101 ? set_time_zone_rule_tz2
: set_time_zone_rule_tz1
);
2107 /* The implied tzstring is unknown, so temporarily set TZ to
2108 two different values that each load a tz file. */
2109 *to
= set_time_zone_rule_tz1
;
2112 *to
= set_time_zone_rule_tz2
;
2117 /* Now TZ has the desired value, and tzset can be invoked safely. */
2124 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
2125 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
2126 type of object is Lisp_String). INHERIT is passed to
2127 INSERT_FROM_STRING_FUNC as the last argument. */
2130 general_insert_function (insert_func
, insert_from_string_func
,
2131 inherit
, nargs
, args
)
2132 void (*insert_func
) P_ ((const unsigned char *, int));
2133 void (*insert_from_string_func
) P_ ((Lisp_Object
, int, int, int, int, int));
2135 register Lisp_Object
*args
;
2137 register int argnum
;
2138 register Lisp_Object val
;
2140 for (argnum
= 0; argnum
< nargs
; argnum
++)
2146 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2149 if (!NILP (current_buffer
->enable_multibyte_characters
))
2150 len
= CHAR_STRING (XFASTINT (val
), str
);
2153 str
[0] = (SINGLE_BYTE_CHAR_P (XINT (val
))
2155 : multibyte_char_to_unibyte (XINT (val
), Qnil
));
2158 (*insert_func
) (str
, len
);
2160 else if (STRINGP (val
))
2162 (*insert_from_string_func
) (val
, 0, 0,
2169 val
= wrong_type_argument (Qchar_or_string_p
, val
);
2183 /* Callers passing one argument to Finsert need not gcpro the
2184 argument "array", since the only element of the array will
2185 not be used after calling insert or insert_from_string, so
2186 we don't care if it gets trashed. */
2188 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
2189 doc
: /* Insert the arguments, either strings or characters, at point.
2190 Point and before-insertion markers move forward to end up
2191 after the inserted text.
2192 Any other markers at the point of insertion remain before the text.
2194 If the current buffer is multibyte, unibyte strings are converted
2195 to multibyte for insertion (see `string-make-multibyte').
2196 If the current buffer is unibyte, multibyte strings are converted
2197 to unibyte for insertion (see `string-make-unibyte').
2199 When operating on binary data, it may be necessary to preserve the
2200 original bytes of a unibyte string when inserting it into a multibyte
2201 buffer; to accomplish this, apply `string-as-multibyte' to the string
2202 and insert the result.
2204 usage: (insert &rest ARGS) */)
2207 register Lisp_Object
*args
;
2209 general_insert_function (insert
, insert_from_string
, 0, nargs
, args
);
2213 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
2215 doc
: /* Insert the arguments at point, inheriting properties from adjoining text.
2216 Point and before-insertion markers move forward to end up
2217 after the inserted text.
2218 Any other markers at the point of insertion remain before the text.
2220 If the current buffer is multibyte, unibyte strings are converted
2221 to multibyte for insertion (see `unibyte-char-to-multibyte').
2222 If the current buffer is unibyte, multibyte strings are converted
2223 to unibyte for insertion.
2225 usage: (insert-and-inherit &rest ARGS) */)
2228 register Lisp_Object
*args
;
2230 general_insert_function (insert_and_inherit
, insert_from_string
, 1,
2235 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
2236 doc
: /* Insert strings or characters at point, relocating markers after the text.
2237 Point and markers move forward to end up after the inserted text.
2239 If the current buffer is multibyte, unibyte strings are converted
2240 to multibyte for insertion (see `unibyte-char-to-multibyte').
2241 If the current buffer is unibyte, multibyte strings are converted
2242 to unibyte for insertion.
2244 usage: (insert-before-markers &rest ARGS) */)
2247 register Lisp_Object
*args
;
2249 general_insert_function (insert_before_markers
,
2250 insert_from_string_before_markers
, 0,
2255 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers
,
2256 Sinsert_and_inherit_before_markers
, 0, MANY
, 0,
2257 doc
: /* Insert text at point, relocating markers and inheriting properties.
2258 Point and markers move forward to end up after the inserted text.
2260 If the current buffer is multibyte, unibyte strings are converted
2261 to multibyte for insertion (see `unibyte-char-to-multibyte').
2262 If the current buffer is unibyte, multibyte strings are converted
2263 to unibyte for insertion.
2265 usage: (insert-before-markers-and-inherit &rest ARGS) */)
2268 register Lisp_Object
*args
;
2270 general_insert_function (insert_before_markers_and_inherit
,
2271 insert_from_string_before_markers
, 1,
2276 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 2, 3, 0,
2277 doc
: /* Insert COUNT (second arg) copies of CHARACTER (first arg).
2278 Both arguments are required.
2279 Point, and before-insertion markers, are relocated as in the function `insert'.
2280 The optional third arg INHERIT, if non-nil, says to inherit text properties
2281 from adjoining text, if those properties are sticky. */)
2282 (character
, count
, inherit
)
2283 Lisp_Object character
, count
, inherit
;
2285 register unsigned char *string
;
2286 register int strlen
;
2289 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2291 CHECK_NUMBER (character
);
2292 CHECK_NUMBER (count
);
2294 if (!NILP (current_buffer
->enable_multibyte_characters
))
2295 len
= CHAR_STRING (XFASTINT (character
), str
);
2297 str
[0] = XFASTINT (character
), len
= 1;
2298 n
= XINT (count
) * len
;
2301 strlen
= min (n
, 256 * len
);
2302 string
= (unsigned char *) alloca (strlen
);
2303 for (i
= 0; i
< strlen
; i
++)
2304 string
[i
] = str
[i
% len
];
2308 if (!NILP (inherit
))
2309 insert_and_inherit (string
, strlen
);
2311 insert (string
, strlen
);
2316 if (!NILP (inherit
))
2317 insert_and_inherit (string
, n
);
2325 /* Making strings from buffer contents. */
2327 /* Return a Lisp_String containing the text of the current buffer from
2328 START to END. If text properties are in use and the current buffer
2329 has properties in the range specified, the resulting string will also
2330 have them, if PROPS is nonzero.
2332 We don't want to use plain old make_string here, because it calls
2333 make_uninit_string, which can cause the buffer arena to be
2334 compacted. make_string has no way of knowing that the data has
2335 been moved, and thus copies the wrong data into the string. This
2336 doesn't effect most of the other users of make_string, so it should
2337 be left as is. But we should use this function when conjuring
2338 buffer substrings. */
2341 make_buffer_string (start
, end
, props
)
2345 int start_byte
= CHAR_TO_BYTE (start
);
2346 int end_byte
= CHAR_TO_BYTE (end
);
2348 return make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
);
2351 /* Return a Lisp_String containing the text of the current buffer from
2352 START / START_BYTE to END / END_BYTE.
2354 If text properties are in use and the current buffer
2355 has properties in the range specified, the resulting string will also
2356 have them, if PROPS is nonzero.
2358 We don't want to use plain old make_string here, because it calls
2359 make_uninit_string, which can cause the buffer arena to be
2360 compacted. make_string has no way of knowing that the data has
2361 been moved, and thus copies the wrong data into the string. This
2362 doesn't effect most of the other users of make_string, so it should
2363 be left as is. But we should use this function when conjuring
2364 buffer substrings. */
2367 make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
)
2368 int start
, start_byte
, end
, end_byte
;
2371 Lisp_Object result
, tem
, tem1
;
2373 if (start
< GPT
&& GPT
< end
)
2376 if (! NILP (current_buffer
->enable_multibyte_characters
))
2377 result
= make_uninit_multibyte_string (end
- start
, end_byte
- start_byte
);
2379 result
= make_uninit_string (end
- start
);
2380 bcopy (BYTE_POS_ADDR (start_byte
), SDATA (result
),
2381 end_byte
- start_byte
);
2383 /* If desired, update and copy the text properties. */
2386 update_buffer_properties (start
, end
);
2388 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
2389 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
2391 if (XINT (tem
) != end
|| !NILP (tem1
))
2392 copy_intervals_to_string (result
, current_buffer
, start
,
2399 /* Call Vbuffer_access_fontify_functions for the range START ... END
2400 in the current buffer, if necessary. */
2403 update_buffer_properties (start
, end
)
2406 /* If this buffer has some access functions,
2407 call them, specifying the range of the buffer being accessed. */
2408 if (!NILP (Vbuffer_access_fontify_functions
))
2410 Lisp_Object args
[3];
2413 args
[0] = Qbuffer_access_fontify_functions
;
2414 XSETINT (args
[1], start
);
2415 XSETINT (args
[2], end
);
2417 /* But don't call them if we can tell that the work
2418 has already been done. */
2419 if (!NILP (Vbuffer_access_fontified_property
))
2421 tem
= Ftext_property_any (args
[1], args
[2],
2422 Vbuffer_access_fontified_property
,
2425 Frun_hook_with_args (3, args
);
2428 Frun_hook_with_args (3, args
);
2432 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
2433 doc
: /* Return the contents of part of the current buffer as a string.
2434 The two arguments START and END are character positions;
2435 they can be in either order.
2436 The string returned is multibyte if the buffer is multibyte.
2438 This function copies the text properties of that part of the buffer
2439 into the result string; if you don't want the text properties,
2440 use `buffer-substring-no-properties' instead. */)
2442 Lisp_Object start
, end
;
2446 validate_region (&start
, &end
);
2450 return make_buffer_string (b
, e
, 1);
2453 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties
,
2454 Sbuffer_substring_no_properties
, 2, 2, 0,
2455 doc
: /* Return the characters of part of the buffer, without the text properties.
2456 The two arguments START and END are character positions;
2457 they can be in either order. */)
2459 Lisp_Object start
, end
;
2463 validate_region (&start
, &end
);
2467 return make_buffer_string (b
, e
, 0);
2470 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
2471 doc
: /* Return the contents of the current buffer as a string.
2472 If narrowing is in effect, this function returns only the visible part
2476 return make_buffer_string (BEGV
, ZV
, 1);
2479 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
2481 doc
: /* Insert before point a substring of the contents of BUFFER.
2482 BUFFER may be a buffer or a buffer name.
2483 Arguments START and END are character positions specifying the substring.
2484 They default to the values of (point-min) and (point-max) in BUFFER. */)
2485 (buffer
, start
, end
)
2486 Lisp_Object buffer
, start
, end
;
2488 register int b
, e
, temp
;
2489 register struct buffer
*bp
, *obuf
;
2492 buf
= Fget_buffer (buffer
);
2496 if (NILP (bp
->name
))
2497 error ("Selecting deleted buffer");
2503 CHECK_NUMBER_COERCE_MARKER (start
);
2510 CHECK_NUMBER_COERCE_MARKER (end
);
2515 temp
= b
, b
= e
, e
= temp
;
2517 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
2518 args_out_of_range (start
, end
);
2520 obuf
= current_buffer
;
2521 set_buffer_internal_1 (bp
);
2522 update_buffer_properties (b
, e
);
2523 set_buffer_internal_1 (obuf
);
2525 insert_from_buffer (bp
, b
, e
- b
, 0);
2529 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
2531 doc
: /* Compare two substrings of two buffers; return result as number.
2532 the value is -N if first string is less after N-1 chars,
2533 +N if first string is greater after N-1 chars, or 0 if strings match.
2534 Each substring is represented as three arguments: BUFFER, START and END.
2535 That makes six args in all, three for each substring.
2537 The value of `case-fold-search' in the current buffer
2538 determines whether case is significant or ignored. */)
2539 (buffer1
, start1
, end1
, buffer2
, start2
, end2
)
2540 Lisp_Object buffer1
, start1
, end1
, buffer2
, start2
, end2
;
2542 register int begp1
, endp1
, begp2
, endp2
, temp
;
2543 register struct buffer
*bp1
, *bp2
;
2544 register Lisp_Object trt
2545 = (!NILP (current_buffer
->case_fold_search
)
2546 ? current_buffer
->case_canon_table
: Qnil
);
2548 int i1
, i2
, i1_byte
, i2_byte
;
2550 /* Find the first buffer and its substring. */
2553 bp1
= current_buffer
;
2557 buf1
= Fget_buffer (buffer1
);
2560 bp1
= XBUFFER (buf1
);
2561 if (NILP (bp1
->name
))
2562 error ("Selecting deleted buffer");
2566 begp1
= BUF_BEGV (bp1
);
2569 CHECK_NUMBER_COERCE_MARKER (start1
);
2570 begp1
= XINT (start1
);
2573 endp1
= BUF_ZV (bp1
);
2576 CHECK_NUMBER_COERCE_MARKER (end1
);
2577 endp1
= XINT (end1
);
2581 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
2583 if (!(BUF_BEGV (bp1
) <= begp1
2585 && endp1
<= BUF_ZV (bp1
)))
2586 args_out_of_range (start1
, end1
);
2588 /* Likewise for second substring. */
2591 bp2
= current_buffer
;
2595 buf2
= Fget_buffer (buffer2
);
2598 bp2
= XBUFFER (buf2
);
2599 if (NILP (bp2
->name
))
2600 error ("Selecting deleted buffer");
2604 begp2
= BUF_BEGV (bp2
);
2607 CHECK_NUMBER_COERCE_MARKER (start2
);
2608 begp2
= XINT (start2
);
2611 endp2
= BUF_ZV (bp2
);
2614 CHECK_NUMBER_COERCE_MARKER (end2
);
2615 endp2
= XINT (end2
);
2619 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
2621 if (!(BUF_BEGV (bp2
) <= begp2
2623 && endp2
<= BUF_ZV (bp2
)))
2624 args_out_of_range (start2
, end2
);
2628 i1_byte
= buf_charpos_to_bytepos (bp1
, i1
);
2629 i2_byte
= buf_charpos_to_bytepos (bp2
, i2
);
2631 while (i1
< endp1
&& i2
< endp2
)
2633 /* When we find a mismatch, we must compare the
2634 characters, not just the bytes. */
2639 if (! NILP (bp1
->enable_multibyte_characters
))
2641 c1
= BUF_FETCH_MULTIBYTE_CHAR (bp1
, i1_byte
);
2642 BUF_INC_POS (bp1
, i1_byte
);
2647 c1
= BUF_FETCH_BYTE (bp1
, i1
);
2648 c1
= unibyte_char_to_multibyte (c1
);
2652 if (! NILP (bp2
->enable_multibyte_characters
))
2654 c2
= BUF_FETCH_MULTIBYTE_CHAR (bp2
, i2_byte
);
2655 BUF_INC_POS (bp2
, i2_byte
);
2660 c2
= BUF_FETCH_BYTE (bp2
, i2
);
2661 c2
= unibyte_char_to_multibyte (c2
);
2667 c1
= CHAR_TABLE_TRANSLATE (trt
, c1
);
2668 c2
= CHAR_TABLE_TRANSLATE (trt
, c2
);
2671 return make_number (- 1 - chars
);
2673 return make_number (chars
+ 1);
2678 /* The strings match as far as they go.
2679 If one is shorter, that one is less. */
2680 if (chars
< endp1
- begp1
)
2681 return make_number (chars
+ 1);
2682 else if (chars
< endp2
- begp2
)
2683 return make_number (- chars
- 1);
2685 /* Same length too => they are equal. */
2686 return make_number (0);
2690 subst_char_in_region_unwind (arg
)
2693 return current_buffer
->undo_list
= arg
;
2697 subst_char_in_region_unwind_1 (arg
)
2700 return current_buffer
->filename
= arg
;
2703 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
2704 Ssubst_char_in_region
, 4, 5, 0,
2705 doc
: /* From START to END, replace FROMCHAR with TOCHAR each time it occurs.
2706 If optional arg NOUNDO is non-nil, don't record this change for undo
2707 and don't mark the buffer as really changed.
2708 Both characters must have the same length of multi-byte form. */)
2709 (start
, end
, fromchar
, tochar
, noundo
)
2710 Lisp_Object start
, end
, fromchar
, tochar
, noundo
;
2712 register int pos
, pos_byte
, stop
, i
, len
, end_byte
;
2714 unsigned char fromstr
[MAX_MULTIBYTE_LENGTH
], tostr
[MAX_MULTIBYTE_LENGTH
];
2716 int count
= SPECPDL_INDEX ();
2717 #define COMBINING_NO 0
2718 #define COMBINING_BEFORE 1
2719 #define COMBINING_AFTER 2
2720 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
2721 int maybe_byte_combining
= COMBINING_NO
;
2722 int last_changed
= 0;
2723 int multibyte_p
= !NILP (current_buffer
->enable_multibyte_characters
);
2725 validate_region (&start
, &end
);
2726 CHECK_NUMBER (fromchar
);
2727 CHECK_NUMBER (tochar
);
2731 len
= CHAR_STRING (XFASTINT (fromchar
), fromstr
);
2732 if (CHAR_STRING (XFASTINT (tochar
), tostr
) != len
)
2733 error ("Characters in `subst-char-in-region' have different byte-lengths");
2734 if (!ASCII_BYTE_P (*tostr
))
2736 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
2737 complete multibyte character, it may be combined with the
2738 after bytes. If it is in the range 0xA0..0xFF, it may be
2739 combined with the before and after bytes. */
2740 if (!CHAR_HEAD_P (*tostr
))
2741 maybe_byte_combining
= COMBINING_BOTH
;
2742 else if (BYTES_BY_CHAR_HEAD (*tostr
) > len
)
2743 maybe_byte_combining
= COMBINING_AFTER
;
2749 fromstr
[0] = XFASTINT (fromchar
);
2750 tostr
[0] = XFASTINT (tochar
);
2754 pos_byte
= CHAR_TO_BYTE (pos
);
2755 stop
= CHAR_TO_BYTE (XINT (end
));
2758 /* If we don't want undo, turn off putting stuff on the list.
2759 That's faster than getting rid of things,
2760 and it prevents even the entry for a first change.
2761 Also inhibit locking the file. */
2764 record_unwind_protect (subst_char_in_region_unwind
,
2765 current_buffer
->undo_list
);
2766 current_buffer
->undo_list
= Qt
;
2767 /* Don't do file-locking. */
2768 record_unwind_protect (subst_char_in_region_unwind_1
,
2769 current_buffer
->filename
);
2770 current_buffer
->filename
= Qnil
;
2773 if (pos_byte
< GPT_BYTE
)
2774 stop
= min (stop
, GPT_BYTE
);
2777 int pos_byte_next
= pos_byte
;
2779 if (pos_byte
>= stop
)
2781 if (pos_byte
>= end_byte
) break;
2784 p
= BYTE_POS_ADDR (pos_byte
);
2786 INC_POS (pos_byte_next
);
2789 if (pos_byte_next
- pos_byte
== len
2790 && p
[0] == fromstr
[0]
2792 || (p
[1] == fromstr
[1]
2793 && (len
== 2 || (p
[2] == fromstr
[2]
2794 && (len
== 3 || p
[3] == fromstr
[3]))))))
2799 modify_region (current_buffer
, changed
, XINT (end
));
2801 if (! NILP (noundo
))
2803 if (MODIFF
- 1 == SAVE_MODIFF
)
2805 if (MODIFF
- 1 == current_buffer
->auto_save_modified
)
2806 current_buffer
->auto_save_modified
++;
2810 /* Take care of the case where the new character
2811 combines with neighboring bytes. */
2812 if (maybe_byte_combining
2813 && (maybe_byte_combining
== COMBINING_AFTER
2814 ? (pos_byte_next
< Z_BYTE
2815 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2816 : ((pos_byte_next
< Z_BYTE
2817 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2818 || (pos_byte
> BEG_BYTE
2819 && ! ASCII_BYTE_P (FETCH_BYTE (pos_byte
- 1))))))
2821 Lisp_Object tem
, string
;
2823 struct gcpro gcpro1
;
2825 tem
= current_buffer
->undo_list
;
2828 /* Make a multibyte string containing this single character. */
2829 string
= make_multibyte_string (tostr
, 1, len
);
2830 /* replace_range is less efficient, because it moves the gap,
2831 but it handles combining correctly. */
2832 replace_range (pos
, pos
+ 1, string
,
2834 pos_byte_next
= CHAR_TO_BYTE (pos
);
2835 if (pos_byte_next
> pos_byte
)
2836 /* Before combining happened. We should not increment
2837 POS. So, to cancel the later increment of POS,
2841 INC_POS (pos_byte_next
);
2843 if (! NILP (noundo
))
2844 current_buffer
->undo_list
= tem
;
2851 record_change (pos
, 1);
2852 for (i
= 0; i
< len
; i
++) *p
++ = tostr
[i
];
2854 last_changed
= pos
+ 1;
2856 pos_byte
= pos_byte_next
;
2862 signal_after_change (changed
,
2863 last_changed
- changed
, last_changed
- changed
);
2864 update_compositions (changed
, last_changed
, CHECK_ALL
);
2867 unbind_to (count
, Qnil
);
2871 DEFUN ("translate-region-internal", Ftranslate_region_internal
,
2872 Stranslate_region_internal
, 3, 3, 0,
2873 doc
: /* Internal use only.
2874 From START to END, translate characters according to TABLE.
2875 TABLE is a string; the Nth character in it is the mapping
2876 for the character with code N.
2877 It returns the number of characters changed. */)
2881 register Lisp_Object table
;
2883 register unsigned char *tt
; /* Trans table. */
2884 register int nc
; /* New character. */
2885 int cnt
; /* Number of changes made. */
2886 int size
; /* Size of translate table. */
2887 int pos
, pos_byte
, end_pos
;
2888 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
2889 int string_multibyte
;
2891 validate_region (&start
, &end
);
2892 if (CHAR_TABLE_P (table
))
2899 CHECK_STRING (table
);
2901 if (! multibyte
&& (SCHARS (table
) < SBYTES (table
)))
2902 table
= string_make_unibyte (table
);
2903 string_multibyte
= SCHARS (table
) < SBYTES (table
);
2904 size
= SCHARS (table
);
2909 pos_byte
= CHAR_TO_BYTE (pos
);
2910 end_pos
= XINT (end
);
2911 modify_region (current_buffer
, pos
, XINT (end
));
2914 for (; pos
< end_pos
; )
2916 register unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
2917 unsigned char *str
, buf
[MAX_MULTIBYTE_LENGTH
];
2922 oc
= STRING_CHAR_AND_LENGTH (p
, MAX_MULTIBYTE_LENGTH
, len
);
2929 /* Reload as signal_after_change in last iteration may GC. */
2931 if (string_multibyte
)
2933 str
= tt
+ string_char_to_byte (table
, oc
);
2934 nc
= STRING_CHAR_AND_LENGTH (str
, MAX_MULTIBYTE_LENGTH
,
2940 if (! ASCII_BYTE_P (nc
) && multibyte
)
2942 str_len
= CHAR_STRING (nc
, buf
);
2958 val
= CHAR_TABLE_REF (table
, oc
);
2960 && (c
= XINT (val
), CHAR_VALID_P (c
, 0)))
2963 str_len
= CHAR_STRING (nc
, buf
);
2974 /* This is less efficient, because it moves the gap,
2975 but it should multibyte characters correctly. */
2976 string
= make_multibyte_string (str
, 1, str_len
);
2977 replace_range (pos
, pos
+ 1, string
, 1, 0, 1);
2982 record_change (pos
, 1);
2983 while (str_len
-- > 0)
2985 signal_after_change (pos
, 1, 1);
2986 update_compositions (pos
, pos
+ 1, CHECK_BORDER
);
2995 return make_number (cnt
);
2998 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
2999 doc
: /* Delete the text between point and mark.
3001 When called from a program, expects two arguments,
3002 positions (integers or markers) specifying the stretch to be deleted. */)
3004 Lisp_Object start
, end
;
3006 validate_region (&start
, &end
);
3007 del_range (XINT (start
), XINT (end
));
3011 DEFUN ("delete-and-extract-region", Fdelete_and_extract_region
,
3012 Sdelete_and_extract_region
, 2, 2, 0,
3013 doc
: /* Delete the text between START and END and return it. */)
3015 Lisp_Object start
, end
;
3017 validate_region (&start
, &end
);
3018 if (XINT (start
) == XINT (end
))
3019 return build_string ("");
3020 return del_range_1 (XINT (start
), XINT (end
), 1, 1);
3023 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
3024 doc
: /* Remove restrictions (narrowing) from current buffer.
3025 This allows the buffer's full text to be seen and edited. */)
3028 if (BEG
!= BEGV
|| Z
!= ZV
)
3029 current_buffer
->clip_changed
= 1;
3031 BEGV_BYTE
= BEG_BYTE
;
3032 SET_BUF_ZV_BOTH (current_buffer
, Z
, Z_BYTE
);
3033 /* Changing the buffer bounds invalidates any recorded current column. */
3034 invalidate_current_column ();
3038 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
3039 doc
: /* Restrict editing in this buffer to the current region.
3040 The rest of the text becomes temporarily invisible and untouchable
3041 but is not deleted; if you save the buffer in a file, the invisible
3042 text is included in the file. \\[widen] makes all visible again.
3043 See also `save-restriction'.
3045 When calling from a program, pass two arguments; positions (integers
3046 or markers) bounding the text that should remain visible. */)
3048 register Lisp_Object start
, end
;
3050 CHECK_NUMBER_COERCE_MARKER (start
);
3051 CHECK_NUMBER_COERCE_MARKER (end
);
3053 if (XINT (start
) > XINT (end
))
3056 tem
= start
; start
= end
; end
= tem
;
3059 if (!(BEG
<= XINT (start
) && XINT (start
) <= XINT (end
) && XINT (end
) <= Z
))
3060 args_out_of_range (start
, end
);
3062 if (BEGV
!= XFASTINT (start
) || ZV
!= XFASTINT (end
))
3063 current_buffer
->clip_changed
= 1;
3065 SET_BUF_BEGV (current_buffer
, XFASTINT (start
));
3066 SET_BUF_ZV (current_buffer
, XFASTINT (end
));
3067 if (PT
< XFASTINT (start
))
3068 SET_PT (XFASTINT (start
));
3069 if (PT
> XFASTINT (end
))
3070 SET_PT (XFASTINT (end
));
3071 /* Changing the buffer bounds invalidates any recorded current column. */
3072 invalidate_current_column ();
3077 save_restriction_save ()
3079 if (BEGV
== BEG
&& ZV
== Z
)
3080 /* The common case that the buffer isn't narrowed.
3081 We return just the buffer object, which save_restriction_restore
3082 recognizes as meaning `no restriction'. */
3083 return Fcurrent_buffer ();
3085 /* We have to save a restriction, so return a pair of markers, one
3086 for the beginning and one for the end. */
3088 Lisp_Object beg
, end
;
3090 beg
= buildmark (BEGV
, BEGV_BYTE
);
3091 end
= buildmark (ZV
, ZV_BYTE
);
3093 /* END must move forward if text is inserted at its exact location. */
3094 XMARKER(end
)->insertion_type
= 1;
3096 return Fcons (beg
, end
);
3101 save_restriction_restore (data
)
3105 /* A pair of marks bounding a saved restriction. */
3107 struct Lisp_Marker
*beg
= XMARKER (XCAR (data
));
3108 struct Lisp_Marker
*end
= XMARKER (XCDR (data
));
3109 struct buffer
*buf
= beg
->buffer
; /* END should have the same buffer. */
3111 if (buf
/* Verify marker still points to a buffer. */
3112 && (beg
->charpos
!= BUF_BEGV (buf
) || end
->charpos
!= BUF_ZV (buf
)))
3113 /* The restriction has changed from the saved one, so restore
3114 the saved restriction. */
3116 int pt
= BUF_PT (buf
);
3118 SET_BUF_BEGV_BOTH (buf
, beg
->charpos
, beg
->bytepos
);
3119 SET_BUF_ZV_BOTH (buf
, end
->charpos
, end
->bytepos
);
3121 if (pt
< beg
->charpos
|| pt
> end
->charpos
)
3122 /* The point is outside the new visible range, move it inside. */
3123 SET_BUF_PT_BOTH (buf
,
3124 clip_to_bounds (beg
->charpos
, pt
, end
->charpos
),
3125 clip_to_bounds (beg
->bytepos
, BUF_PT_BYTE (buf
),
3128 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3132 /* A buffer, which means that there was no old restriction. */
3134 struct buffer
*buf
= XBUFFER (data
);
3136 if (buf
/* Verify marker still points to a buffer. */
3137 && (BUF_BEGV (buf
) != BUF_BEG (buf
) || BUF_ZV (buf
) != BUF_Z (buf
)))
3138 /* The buffer has been narrowed, get rid of the narrowing. */
3140 SET_BUF_BEGV_BOTH (buf
, BUF_BEG (buf
), BUF_BEG_BYTE (buf
));
3141 SET_BUF_ZV_BOTH (buf
, BUF_Z (buf
), BUF_Z_BYTE (buf
));
3143 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3150 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
3151 doc
: /* Execute BODY, saving and restoring current buffer's restrictions.
3152 The buffer's restrictions make parts of the beginning and end invisible.
3153 (They are set up with `narrow-to-region' and eliminated with `widen'.)
3154 This special form, `save-restriction', saves the current buffer's restrictions
3155 when it is entered, and restores them when it is exited.
3156 So any `narrow-to-region' within BODY lasts only until the end of the form.
3157 The old restrictions settings are restored
3158 even in case of abnormal exit (throw or error).
3160 The value returned is the value of the last form in BODY.
3162 Note: if you are using both `save-excursion' and `save-restriction',
3163 use `save-excursion' outermost:
3164 (save-excursion (save-restriction ...))
3166 usage: (save-restriction &rest BODY) */)
3170 register Lisp_Object val
;
3171 int count
= SPECPDL_INDEX ();
3173 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
3174 val
= Fprogn (body
);
3175 return unbind_to (count
, val
);
3178 /* Buffer for the most recent text displayed by Fmessage_box. */
3179 static char *message_text
;
3181 /* Allocated length of that buffer. */
3182 static int message_length
;
3184 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
3185 doc
: /* Print a one-line message at the bottom of the screen.
3186 The message also goes into the `*Messages*' buffer.
3187 \(In keyboard macros, that's all it does.)
3189 The first argument is a format control string, and the rest are data
3190 to be formatted under control of the string. See `format' for details.
3192 If the first argument is nil or the empty string, the function clears
3193 any existing message; this lets the minibuffer contents show. See
3194 also `current-message'.
3196 usage: (message FORMAT-STRING &rest ARGS) */)
3202 || (STRINGP (args
[0])
3203 && SBYTES (args
[0]) == 0))
3210 register Lisp_Object val
;
3211 val
= Fformat (nargs
, args
);
3212 message3 (val
, SBYTES (val
), STRING_MULTIBYTE (val
));
3217 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
3218 doc
: /* Display a message, in a dialog box if possible.
3219 If a dialog box is not available, use the echo area.
3220 The first argument is a format control string, and the rest are data
3221 to be formatted under control of the string. See `format' for details.
3223 If the first argument is nil or the empty string, clear any existing
3224 message; let the minibuffer contents show.
3226 usage: (message-box FORMAT-STRING &rest ARGS) */)
3238 register Lisp_Object val
;
3239 val
= Fformat (nargs
, args
);
3241 /* The MS-DOS frames support popup menus even though they are
3242 not FRAME_WINDOW_P. */
3243 if (FRAME_WINDOW_P (XFRAME (selected_frame
))
3244 || FRAME_MSDOS_P (XFRAME (selected_frame
)))
3246 Lisp_Object pane
, menu
, obj
;
3247 struct gcpro gcpro1
;
3248 pane
= Fcons (Fcons (build_string ("OK"), Qt
), Qnil
);
3250 menu
= Fcons (val
, pane
);
3251 obj
= Fx_popup_dialog (Qt
, menu
, Qt
);
3255 #endif /* HAVE_MENUS */
3256 /* Copy the data so that it won't move when we GC. */
3259 message_text
= (char *)xmalloc (80);
3260 message_length
= 80;
3262 if (SBYTES (val
) > message_length
)
3264 message_length
= SBYTES (val
);
3265 message_text
= (char *)xrealloc (message_text
, message_length
);
3267 bcopy (SDATA (val
), message_text
, SBYTES (val
));
3268 message2 (message_text
, SBYTES (val
),
3269 STRING_MULTIBYTE (val
));
3274 extern Lisp_Object last_nonmenu_event
;
3277 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
3278 doc
: /* Display a message in a dialog box or in the echo area.
3279 If this command was invoked with the mouse, use a dialog box if
3280 `use-dialog-box' is non-nil.
3281 Otherwise, use the echo area.
3282 The first argument is a format control string, and the rest are data
3283 to be formatted under control of the string. See `format' for details.
3285 If the first argument is nil or the empty string, clear any existing
3286 message; let the minibuffer contents show.
3288 usage: (message-or-box FORMAT-STRING &rest ARGS) */)
3294 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3296 return Fmessage_box (nargs
, args
);
3298 return Fmessage (nargs
, args
);
3301 DEFUN ("current-message", Fcurrent_message
, Scurrent_message
, 0, 0, 0,
3302 doc
: /* Return the string currently displayed in the echo area, or nil if none. */)
3305 return current_message ();
3309 DEFUN ("propertize", Fpropertize
, Spropertize
, 1, MANY
, 0,
3310 doc
: /* Return a copy of STRING with text properties added.
3311 First argument is the string to copy.
3312 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
3313 properties to add to the result.
3314 usage: (propertize STRING &rest PROPERTIES) */)
3319 Lisp_Object properties
, string
;
3320 struct gcpro gcpro1
, gcpro2
;
3323 /* Number of args must be odd. */
3324 if ((nargs
& 1) == 0 || nargs
< 1)
3325 error ("Wrong number of arguments");
3327 properties
= string
= Qnil
;
3328 GCPRO2 (properties
, string
);
3330 /* First argument must be a string. */
3331 CHECK_STRING (args
[0]);
3332 string
= Fcopy_sequence (args
[0]);
3334 for (i
= 1; i
< nargs
; i
+= 2)
3335 properties
= Fcons (args
[i
], Fcons (args
[i
+ 1], properties
));
3337 Fadd_text_properties (make_number (0),
3338 make_number (SCHARS (string
)),
3339 properties
, string
);
3340 RETURN_UNGCPRO (string
);
3344 /* Number of bytes that STRING will occupy when put into the result.
3345 MULTIBYTE is nonzero if the result should be multibyte. */
3347 #define CONVERTED_BYTE_SIZE(MULTIBYTE, STRING) \
3348 (((MULTIBYTE) && ! STRING_MULTIBYTE (STRING)) \
3349 ? count_size_as_multibyte (SDATA (STRING), SBYTES (STRING)) \
3352 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
3353 doc
: /* Format a string out of a format-string and arguments.
3354 The first argument is a format control string.
3355 The other arguments are substituted into it to make the result, a string.
3356 It may contain %-sequences meaning to substitute the next argument.
3357 %s means print a string argument. Actually, prints any object, with `princ'.
3358 %d means print as number in decimal (%o octal, %x hex).
3359 %X is like %x, but uses upper case.
3360 %e means print a number in exponential notation.
3361 %f means print a number in decimal-point notation.
3362 %g means print a number in exponential notation
3363 or decimal-point notation, whichever uses fewer characters.
3364 %c means print a number as a single character.
3365 %S means print any object as an s-expression (using `prin1').
3366 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
3367 Use %% to put a single % into the output.
3369 The basic structure of a %-sequence is
3370 % <flags> <width> <precision> character
3371 where flags is [- #0]+, width is [0-9]+, and precision is .[0-9]+
3373 usage: (format STRING &rest OBJECTS) */)
3376 register Lisp_Object
*args
;
3378 register int n
; /* The number of the next arg to substitute */
3379 register int total
; /* An estimate of the final length */
3381 register unsigned char *format
, *end
, *format_start
;
3383 /* Nonzero if the output should be a multibyte string,
3384 which is true if any of the inputs is one. */
3386 /* When we make a multibyte string, we must pay attention to the
3387 byte combining problem, i.e., a byte may be combined with a
3388 multibyte charcter of the previous string. This flag tells if we
3389 must consider such a situation or not. */
3390 int maybe_combine_byte
;
3391 unsigned char *this_format
;
3392 /* Precision for each spec, or -1, a flag value meaning no precision
3393 was given in that spec. Element 0, corresonding to the format
3394 string itself, will not be used. Element NARGS, corresponding to
3395 no argument, *will* be assigned to in the case that a `%' and `.'
3396 occur after the final format specifier. */
3397 int *precision
= (int *) (alloca((nargs
+ 1) * sizeof (int)));
3400 int arg_intervals
= 0;
3403 /* discarded[I] is 1 if byte I of the format
3404 string was not copied into the output.
3405 It is 2 if byte I was not the first byte of its character. */
3406 char *discarded
= 0;
3408 /* Each element records, for one argument,
3409 the start and end bytepos in the output string,
3410 and whether the argument is a string with intervals.
3411 info[0] is unused. Unused elements have -1 for start. */
3414 int start
, end
, intervals
;
3417 /* It should not be necessary to GCPRO ARGS, because
3418 the caller in the interpreter should take care of that. */
3420 /* Try to determine whether the result should be multibyte.
3421 This is not always right; sometimes the result needs to be multibyte
3422 because of an object that we will pass through prin1,
3423 and in that case, we won't know it here. */
3424 for (n
= 0; n
< nargs
; n
++)
3426 if (STRINGP (args
[n
]) && STRING_MULTIBYTE (args
[n
]))
3428 /* Piggyback on this loop to initialize precision[N]. */
3431 precision
[nargs
] = -1;
3433 CHECK_STRING (args
[0]);
3434 /* We may have to change "%S" to "%s". */
3435 args
[0] = Fcopy_sequence (args
[0]);
3437 /* GC should never happen here, so abort if it does. */
3440 /* If we start out planning a unibyte result,
3441 then discover it has to be multibyte, we jump back to retry.
3442 That can only happen from the first large while loop below. */
3445 format
= SDATA (args
[0]);
3446 format_start
= format
;
3447 end
= format
+ SBYTES (args
[0]);
3450 /* Make room in result for all the non-%-codes in the control string. */
3451 total
= 5 + CONVERTED_BYTE_SIZE (multibyte
, args
[0]) + 1;
3453 /* Allocate the info and discarded tables. */
3455 int nbytes
= (nargs
+1) * sizeof *info
;
3458 info
= (struct info
*) alloca (nbytes
);
3459 bzero (info
, nbytes
);
3460 for (i
= 0; i
<= nargs
; i
++)
3463 SAFE_ALLOCA (discarded
, char *, SBYTES (args
[0]));
3464 bzero (discarded
, SBYTES (args
[0]));
3467 /* Add to TOTAL enough space to hold the converted arguments. */
3470 while (format
!= end
)
3471 if (*format
++ == '%')
3474 int actual_width
= 0;
3475 unsigned char *this_format_start
= format
- 1;
3476 int field_width
= 0;
3478 /* General format specifications look like
3480 '%' [flags] [field-width] [precision] format
3485 field-width ::= [0-9]+
3486 precision ::= '.' [0-9]*
3488 If a field-width is specified, it specifies to which width
3489 the output should be padded with blanks, iff the output
3490 string is shorter than field-width.
3492 If precision is specified, it specifies the number of
3493 digits to print after the '.' for floats, or the max.
3494 number of chars to print from a string. */
3496 while (format
!= end
3497 && (*format
== '-' || *format
== '0' || *format
== '#'
3498 || * format
== ' '))
3501 if (*format
>= '0' && *format
<= '9')
3503 for (field_width
= 0; *format
>= '0' && *format
<= '9'; ++format
)
3504 field_width
= 10 * field_width
+ *format
- '0';
3507 /* N is not incremented for another few lines below, so refer to
3508 element N+1 (which might be precision[NARGS]). */
3512 for (precision
[n
+1] = 0; *format
>= '0' && *format
<= '9'; ++format
)
3513 precision
[n
+1] = 10 * precision
[n
+1] + *format
- '0';
3516 if (format
- this_format_start
+ 1 > longest_format
)
3517 longest_format
= format
- this_format_start
+ 1;
3520 error ("Format string ends in middle of format specifier");
3523 else if (++n
>= nargs
)
3524 error ("Not enough arguments for format string");
3525 else if (*format
== 'S')
3527 /* For `S', prin1 the argument and then treat like a string. */
3528 register Lisp_Object tem
;
3529 tem
= Fprin1_to_string (args
[n
], Qnil
);
3530 if (STRING_MULTIBYTE (tem
) && ! multibyte
)
3536 /* If we restart the loop, we should not come here again
3537 because args[n] is now a string and calling
3538 Fprin1_to_string on it produces superflous double
3539 quotes. So, change "%S" to "%s" now. */
3543 else if (SYMBOLP (args
[n
]))
3545 args
[n
] = SYMBOL_NAME (args
[n
]);
3546 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3553 else if (STRINGP (args
[n
]))
3556 if (*format
!= 's' && *format
!= 'S')
3557 error ("Format specifier doesn't match argument type");
3558 /* In the case (PRECISION[N] > 0), THISSIZE may not need
3559 to be as large as is calculated here. Easy check for
3560 the case PRECISION = 0. */
3561 thissize
= precision
[n
] ? CONVERTED_BYTE_SIZE (multibyte
, args
[n
]) : 0;
3562 actual_width
= lisp_string_width (args
[n
], -1, NULL
, NULL
);
3564 /* Would get MPV otherwise, since Lisp_Int's `point' to low memory. */
3565 else if (INTEGERP (args
[n
]) && *format
!= 's')
3567 /* The following loop assumes the Lisp type indicates
3568 the proper way to pass the argument.
3569 So make sure we have a flonum if the argument should
3571 if (*format
== 'e' || *format
== 'f' || *format
== 'g')
3572 args
[n
] = Ffloat (args
[n
]);
3574 if (*format
!= 'd' && *format
!= 'o' && *format
!= 'x'
3575 && *format
!= 'i' && *format
!= 'X' && *format
!= 'c')
3576 error ("Invalid format operation %%%c", *format
);
3581 if (! SINGLE_BYTE_CHAR_P (XINT (args
[n
]))
3582 /* Note: No one can remember why we have to treat
3583 the character 0 as a multibyte character here.
3584 But, until it causes a real problem, let's
3586 || XINT (args
[n
]) == 0)
3593 args
[n
] = Fchar_to_string (args
[n
]);
3594 thissize
= SBYTES (args
[n
]);
3596 else if (! ASCII_BYTE_P (XINT (args
[n
])) && multibyte
)
3599 = Fchar_to_string (Funibyte_char_to_multibyte (args
[n
]));
3600 thissize
= SBYTES (args
[n
]);
3604 else if (FLOATP (args
[n
]) && *format
!= 's')
3606 if (! (*format
== 'e' || *format
== 'f' || *format
== 'g'))
3608 if (*format
!= 'd' && *format
!= 'o' && *format
!= 'x'
3609 && *format
!= 'i' && *format
!= 'X' && *format
!= 'c')
3610 error ("Invalid format operation %%%c", *format
);
3611 args
[n
] = Ftruncate (args
[n
], Qnil
);
3614 /* Note that we're using sprintf to print floats,
3615 so we have to take into account what that function
3617 /* Filter out flag value of -1. */
3618 thissize
= (MAX_10_EXP
+ 100
3619 + (precision
[n
] > 0 ? precision
[n
] : 0));
3623 /* Anything but a string, convert to a string using princ. */
3624 register Lisp_Object tem
;
3625 tem
= Fprin1_to_string (args
[n
], Qt
);
3626 if (STRING_MULTIBYTE (tem
) && ! multibyte
)
3635 thissize
+= max (0, field_width
- actual_width
);
3636 total
+= thissize
+ 4;
3641 /* Now we can no longer jump to retry.
3642 TOTAL and LONGEST_FORMAT are known for certain. */
3644 this_format
= (unsigned char *) alloca (longest_format
+ 1);
3646 /* Allocate the space for the result.
3647 Note that TOTAL is an overestimate. */
3648 SAFE_ALLOCA (buf
, char *, total
);
3654 /* Scan the format and store result in BUF. */
3655 format
= SDATA (args
[0]);
3656 format_start
= format
;
3657 end
= format
+ SBYTES (args
[0]);
3658 maybe_combine_byte
= 0;
3659 while (format
!= end
)
3665 unsigned char *this_format_start
= format
;
3667 discarded
[format
- format_start
] = 1;
3670 while (index("-0# ", *format
))
3676 discarded
[format
- format_start
] = 1;
3680 minlen
= atoi (format
);
3682 while ((*format
>= '0' && *format
<= '9') || *format
== '.')
3684 discarded
[format
- format_start
] = 1;
3688 if (*format
++ == '%')
3697 discarded
[format
- format_start
- 1] = 1;
3698 info
[n
].start
= nchars
;
3700 if (STRINGP (args
[n
]))
3702 /* handle case (precision[n] >= 0) */
3705 int nbytes
, start
, end
;
3708 /* lisp_string_width ignores a precision of 0, but GNU
3709 libc functions print 0 characters when the precision
3710 is 0. Imitate libc behavior here. Changing
3711 lisp_string_width is the right thing, and will be
3712 done, but meanwhile we work with it. */
3714 if (precision
[n
] == 0)
3715 width
= nchars_string
= nbytes
= 0;
3716 else if (precision
[n
] > 0)
3717 width
= lisp_string_width (args
[n
], precision
[n
], &nchars_string
, &nbytes
);
3719 { /* no precision spec given for this argument */
3720 width
= lisp_string_width (args
[n
], -1, NULL
, NULL
);
3721 nbytes
= SBYTES (args
[n
]);
3722 nchars_string
= SCHARS (args
[n
]);
3725 /* If spec requires it, pad on right with spaces. */
3726 padding
= minlen
- width
;
3728 while (padding
-- > 0)
3734 info
[n
].start
= start
= nchars
;
3735 nchars
+= nchars_string
;
3740 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3741 && STRING_MULTIBYTE (args
[n
])
3742 && !CHAR_HEAD_P (SREF (args
[n
], 0)))
3743 maybe_combine_byte
= 1;
3745 p
+= copy_text (SDATA (args
[n
]), p
,
3747 STRING_MULTIBYTE (args
[n
]), multibyte
);
3749 info
[n
].end
= nchars
;
3752 while (padding
-- > 0)
3758 /* If this argument has text properties, record where
3759 in the result string it appears. */
3760 if (STRING_INTERVALS (args
[n
]))
3761 info
[n
].intervals
= arg_intervals
= 1;
3763 else if (INTEGERP (args
[n
]) || FLOATP (args
[n
]))
3767 bcopy (this_format_start
, this_format
,
3768 format
- this_format_start
);
3769 this_format
[format
- this_format_start
] = 0;
3771 if (INTEGERP (args
[n
]))
3772 sprintf (p
, this_format
, XINT (args
[n
]));
3774 sprintf (p
, this_format
, XFLOAT_DATA (args
[n
]));
3778 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3779 && !CHAR_HEAD_P (*((unsigned char *) p
)))
3780 maybe_combine_byte
= 1;
3781 this_nchars
= strlen (p
);
3783 p
+= str_to_multibyte (p
, buf
+ total
- 1 - p
, this_nchars
);
3786 nchars
+= this_nchars
;
3787 info
[n
].end
= nchars
;
3791 else if (STRING_MULTIBYTE (args
[0]))
3793 /* Copy a whole multibyte character. */
3796 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3797 && !CHAR_HEAD_P (*format
))
3798 maybe_combine_byte
= 1;
3800 while (! CHAR_HEAD_P (*format
))
3802 discarded
[format
- format_start
] = 2;
3809 /* Convert a single-byte character to multibyte. */
3810 int len
= copy_text (format
, p
, 1, 0, 1);
3817 *p
++ = *format
++, nchars
++;
3820 if (p
> buf
+ total
)
3823 if (maybe_combine_byte
)
3824 nchars
= multibyte_chars_in_text (buf
, p
- buf
);
3825 val
= make_specified_string (buf
, nchars
, p
- buf
, multibyte
);
3827 /* If we allocated BUF with malloc, free it too. */
3830 /* If the format string has text properties, or any of the string
3831 arguments has text properties, set up text properties of the
3834 if (STRING_INTERVALS (args
[0]) || arg_intervals
)
3836 Lisp_Object len
, new_len
, props
;
3837 struct gcpro gcpro1
;
3839 /* Add text properties from the format string. */
3840 len
= make_number (SCHARS (args
[0]));
3841 props
= text_property_list (args
[0], make_number (0), len
, Qnil
);
3846 int bytepos
= 0, position
= 0, translated
= 0, argn
= 1;
3849 /* Adjust the bounds of each text property
3850 to the proper start and end in the output string. */
3852 /* Put the positions in PROPS in increasing order, so that
3853 we can do (effectively) one scan through the position
3854 space of the format string. */
3855 props
= Fnreverse (props
);
3857 /* BYTEPOS is the byte position in the format string,
3858 POSITION is the untranslated char position in it,
3859 TRANSLATED is the translated char position in BUF,
3860 and ARGN is the number of the next arg we will come to. */
3861 for (list
= props
; CONSP (list
); list
= XCDR (list
))
3868 /* First adjust the property start position. */
3869 pos
= XINT (XCAR (item
));
3871 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
3872 up to this position. */
3873 for (; position
< pos
; bytepos
++)
3875 if (! discarded
[bytepos
])
3876 position
++, translated
++;
3877 else if (discarded
[bytepos
] == 1)
3880 if (translated
== info
[argn
].start
)
3882 translated
+= info
[argn
].end
- info
[argn
].start
;
3888 XSETCAR (item
, make_number (translated
));
3890 /* Likewise adjust the property end position. */
3891 pos
= XINT (XCAR (XCDR (item
)));
3893 for (; bytepos
< pos
; bytepos
++)
3895 if (! discarded
[bytepos
])
3896 position
++, translated
++;
3897 else if (discarded
[bytepos
] == 1)
3900 if (translated
== info
[argn
].start
)
3902 translated
+= info
[argn
].end
- info
[argn
].start
;
3908 XSETCAR (XCDR (item
), make_number (translated
));
3911 add_text_properties_from_list (val
, props
, make_number (0));
3914 /* Add text properties from arguments. */
3916 for (n
= 1; n
< nargs
; ++n
)
3917 if (info
[n
].intervals
)
3919 len
= make_number (SCHARS (args
[n
]));
3920 new_len
= make_number (info
[n
].end
- info
[n
].start
);
3921 props
= text_property_list (args
[n
], make_number (0), len
, Qnil
);
3922 extend_property_ranges (props
, len
, new_len
);
3923 /* If successive arguments have properites, be sure that
3924 the value of `composition' property be the copy. */
3925 if (n
> 1 && info
[n
- 1].end
)
3926 make_composition_value_copy (props
);
3927 add_text_properties_from_list (val
, props
,
3928 make_number (info
[n
].start
));
3938 format2 (string1
, arg0
, arg1
)
3940 Lisp_Object arg0
, arg1
;
3942 Lisp_Object args
[3];
3943 args
[0] = build_string (string1
);
3946 return Fformat (3, args
);
3949 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
3950 doc
: /* Return t if two characters match, optionally ignoring case.
3951 Both arguments must be characters (i.e. integers).
3952 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
3954 register Lisp_Object c1
, c2
;
3960 if (XINT (c1
) == XINT (c2
))
3962 if (NILP (current_buffer
->case_fold_search
))
3965 /* Do these in separate statements,
3966 then compare the variables.
3967 because of the way DOWNCASE uses temp variables. */
3968 i1
= DOWNCASE (XFASTINT (c1
));
3969 i2
= DOWNCASE (XFASTINT (c2
));
3970 return (i1
== i2
? Qt
: Qnil
);
3973 /* Transpose the markers in two regions of the current buffer, and
3974 adjust the ones between them if necessary (i.e.: if the regions
3977 START1, END1 are the character positions of the first region.
3978 START1_BYTE, END1_BYTE are the byte positions.
3979 START2, END2 are the character positions of the second region.
3980 START2_BYTE, END2_BYTE are the byte positions.
3982 Traverses the entire marker list of the buffer to do so, adding an
3983 appropriate amount to some, subtracting from some, and leaving the
3984 rest untouched. Most of this is copied from adjust_markers in insdel.c.
3986 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
3989 transpose_markers (start1
, end1
, start2
, end2
,
3990 start1_byte
, end1_byte
, start2_byte
, end2_byte
)
3991 register int start1
, end1
, start2
, end2
;
3992 register int start1_byte
, end1_byte
, start2_byte
, end2_byte
;
3994 register int amt1
, amt1_byte
, amt2
, amt2_byte
, diff
, diff_byte
, mpos
;
3995 register struct Lisp_Marker
*marker
;
3997 /* Update point as if it were a marker. */
4001 TEMP_SET_PT_BOTH (PT
+ (end2
- end1
),
4002 PT_BYTE
+ (end2_byte
- end1_byte
));
4003 else if (PT
< start2
)
4004 TEMP_SET_PT_BOTH (PT
+ (end2
- start2
) - (end1
- start1
),
4005 (PT_BYTE
+ (end2_byte
- start2_byte
)
4006 - (end1_byte
- start1_byte
)));
4008 TEMP_SET_PT_BOTH (PT
- (start2
- start1
),
4009 PT_BYTE
- (start2_byte
- start1_byte
));
4011 /* We used to adjust the endpoints here to account for the gap, but that
4012 isn't good enough. Even if we assume the caller has tried to move the
4013 gap out of our way, it might still be at start1 exactly, for example;
4014 and that places it `inside' the interval, for our purposes. The amount
4015 of adjustment is nontrivial if there's a `denormalized' marker whose
4016 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
4017 the dirty work to Fmarker_position, below. */
4019 /* The difference between the region's lengths */
4020 diff
= (end2
- start2
) - (end1
- start1
);
4021 diff_byte
= (end2_byte
- start2_byte
) - (end1_byte
- start1_byte
);
4023 /* For shifting each marker in a region by the length of the other
4024 region plus the distance between the regions. */
4025 amt1
= (end2
- start2
) + (start2
- end1
);
4026 amt2
= (end1
- start1
) + (start2
- end1
);
4027 amt1_byte
= (end2_byte
- start2_byte
) + (start2_byte
- end1_byte
);
4028 amt2_byte
= (end1_byte
- start1_byte
) + (start2_byte
- end1_byte
);
4030 for (marker
= BUF_MARKERS (current_buffer
); marker
; marker
= marker
->next
)
4032 mpos
= marker
->bytepos
;
4033 if (mpos
>= start1_byte
&& mpos
< end2_byte
)
4035 if (mpos
< end1_byte
)
4037 else if (mpos
< start2_byte
)
4041 marker
->bytepos
= mpos
;
4043 mpos
= marker
->charpos
;
4044 if (mpos
>= start1
&& mpos
< end2
)
4048 else if (mpos
< start2
)
4053 marker
->charpos
= mpos
;
4057 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
4058 doc
: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
4059 The regions may not be overlapping, because the size of the buffer is
4060 never changed in a transposition.
4062 Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
4063 any markers that happen to be located in the regions.
4065 Transposing beyond buffer boundaries is an error. */)
4066 (startr1
, endr1
, startr2
, endr2
, leave_markers
)
4067 Lisp_Object startr1
, endr1
, startr2
, endr2
, leave_markers
;
4069 register int start1
, end1
, start2
, end2
;
4070 int start1_byte
, start2_byte
, len1_byte
, len2_byte
;
4071 int gap
, len1
, len_mid
, len2
;
4072 unsigned char *start1_addr
, *start2_addr
, *temp
;
4074 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
;
4075 cur_intv
= BUF_INTERVALS (current_buffer
);
4077 validate_region (&startr1
, &endr1
);
4078 validate_region (&startr2
, &endr2
);
4080 start1
= XFASTINT (startr1
);
4081 end1
= XFASTINT (endr1
);
4082 start2
= XFASTINT (startr2
);
4083 end2
= XFASTINT (endr2
);
4086 /* Swap the regions if they're reversed. */
4089 register int glumph
= start1
;
4097 len1
= end1
- start1
;
4098 len2
= end2
- start2
;
4101 error ("Transposed regions overlap");
4102 else if (start1
== end1
|| start2
== end2
)
4103 error ("Transposed region has length 0");
4105 /* The possibilities are:
4106 1. Adjacent (contiguous) regions, or separate but equal regions
4107 (no, really equal, in this case!), or
4108 2. Separate regions of unequal size.
4110 The worst case is usually No. 2. It means that (aside from
4111 potential need for getting the gap out of the way), there also
4112 needs to be a shifting of the text between the two regions. So
4113 if they are spread far apart, we are that much slower... sigh. */
4115 /* It must be pointed out that the really studly thing to do would
4116 be not to move the gap at all, but to leave it in place and work
4117 around it if necessary. This would be extremely efficient,
4118 especially considering that people are likely to do
4119 transpositions near where they are working interactively, which
4120 is exactly where the gap would be found. However, such code
4121 would be much harder to write and to read. So, if you are
4122 reading this comment and are feeling squirrely, by all means have
4123 a go! I just didn't feel like doing it, so I will simply move
4124 the gap the minimum distance to get it out of the way, and then
4125 deal with an unbroken array. */
4127 /* Make sure the gap won't interfere, by moving it out of the text
4128 we will operate on. */
4129 if (start1
< gap
&& gap
< end2
)
4131 if (gap
- start1
< end2
- gap
)
4137 start1_byte
= CHAR_TO_BYTE (start1
);
4138 start2_byte
= CHAR_TO_BYTE (start2
);
4139 len1_byte
= CHAR_TO_BYTE (end1
) - start1_byte
;
4140 len2_byte
= CHAR_TO_BYTE (end2
) - start2_byte
;
4142 #ifdef BYTE_COMBINING_DEBUG
4145 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4146 len2_byte
, start1
, start1_byte
)
4147 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4148 len1_byte
, end2
, start2_byte
+ len2_byte
)
4149 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4150 len1_byte
, end2
, start2_byte
+ len2_byte
))
4155 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4156 len2_byte
, start1
, start1_byte
)
4157 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4158 len1_byte
, start2
, start2_byte
)
4159 || count_combining_after (BYTE_POS_ADDR (start2_byte
),
4160 len2_byte
, end1
, start1_byte
+ len1_byte
)
4161 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4162 len1_byte
, end2
, start2_byte
+ len2_byte
))
4167 /* Hmmm... how about checking to see if the gap is large
4168 enough to use as the temporary storage? That would avoid an
4169 allocation... interesting. Later, don't fool with it now. */
4171 /* Working without memmove, for portability (sigh), so must be
4172 careful of overlapping subsections of the array... */
4174 if (end1
== start2
) /* adjacent regions */
4176 modify_region (current_buffer
, start1
, end2
);
4177 record_change (start1
, len1
+ len2
);
4179 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4180 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4181 Fset_text_properties (make_number (start1
), make_number (end2
),
4184 /* First region smaller than second. */
4185 if (len1_byte
< len2_byte
)
4189 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4191 /* Don't precompute these addresses. We have to compute them
4192 at the last minute, because the relocating allocator might
4193 have moved the buffer around during the xmalloc. */
4194 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4195 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4197 bcopy (start2_addr
, temp
, len2_byte
);
4198 bcopy (start1_addr
, start1_addr
+ len2_byte
, len1_byte
);
4199 bcopy (temp
, start1_addr
, len2_byte
);
4203 /* First region not smaller than second. */
4207 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4208 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4209 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4210 bcopy (start1_addr
, temp
, len1_byte
);
4211 bcopy (start2_addr
, start1_addr
, len2_byte
);
4212 bcopy (temp
, start1_addr
+ len2_byte
, len1_byte
);
4215 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
4216 len1
, current_buffer
, 0);
4217 graft_intervals_into_buffer (tmp_interval2
, start1
,
4218 len2
, current_buffer
, 0);
4219 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4220 update_compositions (start1
+ len2
, end2
, CHECK_TAIL
);
4222 /* Non-adjacent regions, because end1 != start2, bleagh... */
4225 len_mid
= start2_byte
- (start1_byte
+ len1_byte
);
4227 if (len1_byte
== len2_byte
)
4228 /* Regions are same size, though, how nice. */
4232 modify_region (current_buffer
, start1
, end1
);
4233 modify_region (current_buffer
, start2
, end2
);
4234 record_change (start1
, len1
);
4235 record_change (start2
, len2
);
4236 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4237 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4238 Fset_text_properties (make_number (start1
), make_number (end1
),
4240 Fset_text_properties (make_number (start2
), make_number (end2
),
4243 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4244 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4245 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4246 bcopy (start1_addr
, temp
, len1_byte
);
4247 bcopy (start2_addr
, start1_addr
, len2_byte
);
4248 bcopy (temp
, start2_addr
, len1_byte
);
4251 graft_intervals_into_buffer (tmp_interval1
, start2
,
4252 len1
, current_buffer
, 0);
4253 graft_intervals_into_buffer (tmp_interval2
, start1
,
4254 len2
, current_buffer
, 0);
4257 else if (len1_byte
< len2_byte
) /* Second region larger than first */
4258 /* Non-adjacent & unequal size, area between must also be shifted. */
4262 modify_region (current_buffer
, start1
, end2
);
4263 record_change (start1
, (end2
- start1
));
4264 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4265 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4266 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4267 Fset_text_properties (make_number (start1
), make_number (end2
),
4270 /* holds region 2 */
4271 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4272 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4273 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4274 bcopy (start2_addr
, temp
, len2_byte
);
4275 bcopy (start1_addr
, start1_addr
+ len_mid
+ len2_byte
, len1_byte
);
4276 safe_bcopy (start1_addr
+ len1_byte
, start1_addr
+ len2_byte
, len_mid
);
4277 bcopy (temp
, start1_addr
, len2_byte
);
4280 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4281 len1
, current_buffer
, 0);
4282 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4283 len_mid
, current_buffer
, 0);
4284 graft_intervals_into_buffer (tmp_interval2
, start1
,
4285 len2
, current_buffer
, 0);
4288 /* Second region smaller than first. */
4292 record_change (start1
, (end2
- start1
));
4293 modify_region (current_buffer
, start1
, end2
);
4295 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4296 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4297 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4298 Fset_text_properties (make_number (start1
), make_number (end2
),
4301 /* holds region 1 */
4302 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4303 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4304 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4305 bcopy (start1_addr
, temp
, len1_byte
);
4306 bcopy (start2_addr
, start1_addr
, len2_byte
);
4307 bcopy (start1_addr
+ len1_byte
, start1_addr
+ len2_byte
, len_mid
);
4308 bcopy (temp
, start1_addr
+ len2_byte
+ len_mid
, len1_byte
);
4311 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4312 len1
, current_buffer
, 0);
4313 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4314 len_mid
, current_buffer
, 0);
4315 graft_intervals_into_buffer (tmp_interval2
, start1
,
4316 len2
, current_buffer
, 0);
4319 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4320 update_compositions (end2
- len1
, end2
, CHECK_BORDER
);
4323 /* When doing multiple transpositions, it might be nice
4324 to optimize this. Perhaps the markers in any one buffer
4325 should be organized in some sorted data tree. */
4326 if (NILP (leave_markers
))
4328 transpose_markers (start1
, end1
, start2
, end2
,
4329 start1_byte
, start1_byte
+ len1_byte
,
4330 start2_byte
, start2_byte
+ len2_byte
);
4331 fix_start_end_in_overlays (start1
, end2
);
4343 Qbuffer_access_fontify_functions
4344 = intern ("buffer-access-fontify-functions");
4345 staticpro (&Qbuffer_access_fontify_functions
);
4347 DEFVAR_LISP ("inhibit-field-text-motion", &Vinhibit_field_text_motion
,
4348 doc
: /* Non-nil means text motion commands don't notice fields. */);
4349 Vinhibit_field_text_motion
= Qnil
;
4351 DEFVAR_LISP ("buffer-access-fontify-functions",
4352 &Vbuffer_access_fontify_functions
,
4353 doc
: /* List of functions called by `buffer-substring' to fontify if necessary.
4354 Each function is called with two arguments which specify the range
4355 of the buffer being accessed. */);
4356 Vbuffer_access_fontify_functions
= Qnil
;
4360 extern Lisp_Object Vprin1_to_string_buffer
;
4361 obuf
= Fcurrent_buffer ();
4362 /* Do this here, because init_buffer_once is too early--it won't work. */
4363 Fset_buffer (Vprin1_to_string_buffer
);
4364 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
4365 Fset (Fmake_local_variable (intern ("buffer-access-fontify-functions")),
4370 DEFVAR_LISP ("buffer-access-fontified-property",
4371 &Vbuffer_access_fontified_property
,
4372 doc
: /* Property which (if non-nil) indicates text has been fontified.
4373 `buffer-substring' need not call the `buffer-access-fontify-functions'
4374 functions if all the text being accessed has this property. */);
4375 Vbuffer_access_fontified_property
= Qnil
;
4377 DEFVAR_LISP ("system-name", &Vsystem_name
,
4378 doc
: /* The name of the machine Emacs is running on. */);
4380 DEFVAR_LISP ("user-full-name", &Vuser_full_name
,
4381 doc
: /* The full name of the user logged in. */);
4383 DEFVAR_LISP ("user-login-name", &Vuser_login_name
,
4384 doc
: /* The user's name, taken from environment variables if possible. */);
4386 DEFVAR_LISP ("user-real-login-name", &Vuser_real_login_name
,
4387 doc
: /* The user's name, based upon the real uid only. */);
4389 DEFVAR_LISP ("operating-system-release", &Voperating_system_release
,
4390 doc
: /* The release of the operating system Emacs is running on. */);
4392 defsubr (&Spropertize
);
4393 defsubr (&Schar_equal
);
4394 defsubr (&Sgoto_char
);
4395 defsubr (&Sstring_to_char
);
4396 defsubr (&Schar_to_string
);
4397 defsubr (&Sbuffer_substring
);
4398 defsubr (&Sbuffer_substring_no_properties
);
4399 defsubr (&Sbuffer_string
);
4401 defsubr (&Spoint_marker
);
4402 defsubr (&Smark_marker
);
4404 defsubr (&Sregion_beginning
);
4405 defsubr (&Sregion_end
);
4407 staticpro (&Qfield
);
4408 Qfield
= intern ("field");
4409 staticpro (&Qboundary
);
4410 Qboundary
= intern ("boundary");
4411 defsubr (&Sfield_beginning
);
4412 defsubr (&Sfield_end
);
4413 defsubr (&Sfield_string
);
4414 defsubr (&Sfield_string_no_properties
);
4415 defsubr (&Sdelete_field
);
4416 defsubr (&Sconstrain_to_field
);
4418 defsubr (&Sline_beginning_position
);
4419 defsubr (&Sline_end_position
);
4421 /* defsubr (&Smark); */
4422 /* defsubr (&Sset_mark); */
4423 defsubr (&Ssave_excursion
);
4424 defsubr (&Ssave_current_buffer
);
4426 defsubr (&Sbufsize
);
4427 defsubr (&Spoint_max
);
4428 defsubr (&Spoint_min
);
4429 defsubr (&Spoint_min_marker
);
4430 defsubr (&Spoint_max_marker
);
4431 defsubr (&Sgap_position
);
4432 defsubr (&Sgap_size
);
4433 defsubr (&Sposition_bytes
);
4434 defsubr (&Sbyte_to_position
);
4440 defsubr (&Sfollowing_char
);
4441 defsubr (&Sprevious_char
);
4442 defsubr (&Schar_after
);
4443 defsubr (&Schar_before
);
4445 defsubr (&Sinsert_before_markers
);
4446 defsubr (&Sinsert_and_inherit
);
4447 defsubr (&Sinsert_and_inherit_before_markers
);
4448 defsubr (&Sinsert_char
);
4450 defsubr (&Suser_login_name
);
4451 defsubr (&Suser_real_login_name
);
4452 defsubr (&Suser_uid
);
4453 defsubr (&Suser_real_uid
);
4454 defsubr (&Suser_full_name
);
4455 defsubr (&Semacs_pid
);
4456 defsubr (&Scurrent_time
);
4457 defsubr (&Sget_internal_run_time
);
4458 defsubr (&Sformat_time_string
);
4459 defsubr (&Sfloat_time
);
4460 defsubr (&Sdecode_time
);
4461 defsubr (&Sencode_time
);
4462 defsubr (&Scurrent_time_string
);
4463 defsubr (&Scurrent_time_zone
);
4464 defsubr (&Sset_time_zone_rule
);
4465 defsubr (&Ssystem_name
);
4466 defsubr (&Smessage
);
4467 defsubr (&Smessage_box
);
4468 defsubr (&Smessage_or_box
);
4469 defsubr (&Scurrent_message
);
4472 defsubr (&Sinsert_buffer_substring
);
4473 defsubr (&Scompare_buffer_substrings
);
4474 defsubr (&Ssubst_char_in_region
);
4475 defsubr (&Stranslate_region_internal
);
4476 defsubr (&Sdelete_region
);
4477 defsubr (&Sdelete_and_extract_region
);
4479 defsubr (&Snarrow_to_region
);
4480 defsubr (&Ssave_restriction
);
4481 defsubr (&Stranspose_regions
);
4484 /* arch-tag: fc3827d8-6f60-4067-b11e-c3218031b018
4485 (do not change this comment) */