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"
62 #define MAX_10_EXP DBL_MAX_10_EXP
64 #define MAX_10_EXP 310
72 extern char **environ
;
75 #define TM_YEAR_BASE 1900
77 /* Nonzero if TM_YEAR is a struct tm's tm_year value that causes
78 asctime to have well-defined behavior. */
79 #ifndef TM_YEAR_IN_ASCTIME_RANGE
80 # define TM_YEAR_IN_ASCTIME_RANGE(tm_year) \
81 (1000 - TM_YEAR_BASE <= (tm_year) && (tm_year) <= 9999 - TM_YEAR_BASE)
84 extern size_t emacs_strftimeu
P_ ((char *, size_t, const char *,
85 const struct tm
*, int));
86 static int tm_diff
P_ ((struct tm
*, struct tm
*));
87 static void find_field
P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
, int *, Lisp_Object
, int *));
88 static void update_buffer_properties
P_ ((int, int));
89 static Lisp_Object region_limit
P_ ((int));
90 int lisp_time_argument
P_ ((Lisp_Object
, time_t *, int *));
91 static size_t emacs_memftimeu
P_ ((char *, size_t, const char *,
92 size_t, const struct tm
*, int));
93 static void general_insert_function
P_ ((void (*) (const unsigned char *, int),
94 void (*) (Lisp_Object
, int, int, int,
96 int, int, Lisp_Object
*));
97 static Lisp_Object subst_char_in_region_unwind
P_ ((Lisp_Object
));
98 static Lisp_Object subst_char_in_region_unwind_1
P_ ((Lisp_Object
));
99 static void transpose_markers
P_ ((int, int, int, int, int, int, int, int));
102 extern char *index
P_ ((const char *, int));
105 Lisp_Object Vbuffer_access_fontify_functions
;
106 Lisp_Object Qbuffer_access_fontify_functions
;
107 Lisp_Object Vbuffer_access_fontified_property
;
109 Lisp_Object Fuser_full_name
P_ ((Lisp_Object
));
111 /* Non-nil means don't stop at field boundary in text motion commands. */
113 Lisp_Object Vinhibit_field_text_motion
;
115 /* Some static data, and a function to initialize it for each run */
117 Lisp_Object Vsystem_name
;
118 Lisp_Object Vuser_real_login_name
; /* login name of current user ID */
119 Lisp_Object Vuser_full_name
; /* full name of current user */
120 Lisp_Object Vuser_login_name
; /* user name from LOGNAME or USER */
121 Lisp_Object Voperating_system_release
; /* Operating System Release */
123 /* Symbol for the text property used to mark fields. */
127 /* A special value for Qfield properties. */
129 Lisp_Object Qboundary
;
136 register unsigned char *p
;
137 struct passwd
*pw
; /* password entry for the current user */
140 /* Set up system_name even when dumping. */
144 /* Don't bother with this on initial start when just dumping out */
147 #endif /* not CANNOT_DUMP */
149 pw
= (struct passwd
*) getpwuid (getuid ());
151 /* We let the real user name default to "root" because that's quite
152 accurate on MSDOG and because it lets Emacs find the init file.
153 (The DVX libraries override the Djgpp libraries here.) */
154 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "root");
156 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "unknown");
159 /* Get the effective user name, by consulting environment variables,
160 or the effective uid if those are unset. */
161 user_name
= (char *) getenv ("LOGNAME");
164 user_name
= (char *) getenv ("USERNAME"); /* it's USERNAME on NT */
165 #else /* WINDOWSNT */
166 user_name
= (char *) getenv ("USER");
167 #endif /* WINDOWSNT */
170 pw
= (struct passwd
*) getpwuid (geteuid ());
171 user_name
= (char *) (pw
? pw
->pw_name
: "unknown");
173 Vuser_login_name
= build_string (user_name
);
175 /* If the user name claimed in the environment vars differs from
176 the real uid, use the claimed name to find the full name. */
177 tem
= Fstring_equal (Vuser_login_name
, Vuser_real_login_name
);
178 Vuser_full_name
= Fuser_full_name (NILP (tem
)? make_number (geteuid())
181 p
= (unsigned char *) getenv ("NAME");
183 Vuser_full_name
= build_string (p
);
184 else if (NILP (Vuser_full_name
))
185 Vuser_full_name
= build_string ("unknown");
187 #ifdef HAVE_SYS_UTSNAME_H
191 Voperating_system_release
= build_string (uts
.release
);
194 Voperating_system_release
= Qnil
;
198 DEFUN ("char-to-string", Fchar_to_string
, Schar_to_string
, 1, 1, 0,
199 doc
: /* Convert arg CHAR to a string containing that character.
200 usage: (char-to-string CHAR) */)
202 Lisp_Object character
;
205 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
207 CHECK_NUMBER (character
);
209 len
= (SINGLE_BYTE_CHAR_P (XFASTINT (character
))
210 ? (*str
= (unsigned char)(XFASTINT (character
)), 1)
211 : char_to_string (XFASTINT (character
), str
));
212 return make_string_from_bytes (str
, 1, len
);
215 DEFUN ("string-to-char", Fstring_to_char
, Sstring_to_char
, 1, 1, 0,
216 doc
: /* Convert arg STRING to a character, the first character of that string.
217 A multibyte character is handled correctly. */)
219 register Lisp_Object string
;
221 register Lisp_Object val
;
222 CHECK_STRING (string
);
225 if (STRING_MULTIBYTE (string
))
226 XSETFASTINT (val
, STRING_CHAR (SDATA (string
), SBYTES (string
)));
228 XSETFASTINT (val
, SREF (string
, 0));
231 XSETFASTINT (val
, 0);
236 buildmark (charpos
, bytepos
)
237 int charpos
, bytepos
;
239 register Lisp_Object mark
;
240 mark
= Fmake_marker ();
241 set_marker_both (mark
, Qnil
, charpos
, bytepos
);
245 DEFUN ("point", Fpoint
, Spoint
, 0, 0, 0,
246 doc
: /* Return value of point, as an integer.
247 Beginning of buffer is position (point-min). */)
251 XSETFASTINT (temp
, PT
);
255 DEFUN ("point-marker", Fpoint_marker
, Spoint_marker
, 0, 0, 0,
256 doc
: /* Return value of point, as a marker object. */)
259 return buildmark (PT
, PT_BYTE
);
263 clip_to_bounds (lower
, num
, upper
)
264 int lower
, num
, upper
;
268 else if (num
> upper
)
274 DEFUN ("goto-char", Fgoto_char
, Sgoto_char
, 1, 1, "NGoto char: ",
275 doc
: /* Set point to POSITION, a number or marker.
276 Beginning of buffer is position (point-min), end is (point-max). */)
278 register Lisp_Object position
;
282 if (MARKERP (position
)
283 && current_buffer
== XMARKER (position
)->buffer
)
285 pos
= marker_position (position
);
287 SET_PT_BOTH (BEGV
, BEGV_BYTE
);
289 SET_PT_BOTH (ZV
, ZV_BYTE
);
291 SET_PT_BOTH (pos
, marker_byte_position (position
));
296 CHECK_NUMBER_COERCE_MARKER (position
);
298 pos
= clip_to_bounds (BEGV
, XINT (position
), ZV
);
304 /* Return the start or end position of the region.
305 BEGINNINGP non-zero means return the start.
306 If there is no region active, signal an error. */
309 region_limit (beginningp
)
312 extern Lisp_Object Vmark_even_if_inactive
; /* Defined in callint.c. */
315 if (!NILP (Vtransient_mark_mode
)
316 && NILP (Vmark_even_if_inactive
)
317 && NILP (current_buffer
->mark_active
))
318 Fsignal (Qmark_inactive
, Qnil
);
320 m
= Fmarker_position (current_buffer
->mark
);
322 error ("The mark is not set now, so there is no region");
324 if ((PT
< XFASTINT (m
)) == (beginningp
!= 0))
325 m
= make_number (PT
);
329 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
330 doc
: /* Return position of beginning of region, as an integer. */)
333 return region_limit (1);
336 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
337 doc
: /* Return position of end of region, as an integer. */)
340 return region_limit (0);
343 DEFUN ("mark-marker", Fmark_marker
, Smark_marker
, 0, 0, 0,
344 doc
: /* Return this buffer's mark, as a marker object.
345 Watch out! Moving this marker changes the mark position.
346 If you set the marker not to point anywhere, the buffer will have no mark. */)
349 return current_buffer
->mark
;
353 /* Find all the overlays in the current buffer that touch position POS.
354 Return the number found, and store them in a vector in VEC
358 overlays_around (pos
, vec
, len
)
363 Lisp_Object overlay
, start
, end
;
364 struct Lisp_Overlay
*tail
;
365 int startpos
, endpos
;
368 for (tail
= current_buffer
->overlays_before
; tail
; tail
= tail
->next
)
370 XSETMISC (overlay
, tail
);
372 end
= OVERLAY_END (overlay
);
373 endpos
= OVERLAY_POSITION (end
);
376 start
= OVERLAY_START (overlay
);
377 startpos
= OVERLAY_POSITION (start
);
382 /* Keep counting overlays even if we can't return them all. */
387 for (tail
= current_buffer
->overlays_after
; tail
; tail
= tail
->next
)
389 XSETMISC (overlay
, tail
);
391 start
= OVERLAY_START (overlay
);
392 startpos
= OVERLAY_POSITION (start
);
395 end
= OVERLAY_END (overlay
);
396 endpos
= OVERLAY_POSITION (end
);
408 /* Return the value of property PROP, in OBJECT at POSITION.
409 It's the value of PROP that a char inserted at POSITION would get.
410 OBJECT is optional and defaults to the current buffer.
411 If OBJECT is a buffer, then overlay properties are considered as well as
413 If OBJECT is a window, then that window's buffer is used, but
414 window-specific overlays are considered only if they are associated
417 get_pos_property (position
, prop
, object
)
418 Lisp_Object position
, object
;
419 register Lisp_Object prop
;
421 CHECK_NUMBER_COERCE_MARKER (position
);
424 XSETBUFFER (object
, current_buffer
);
425 else if (WINDOWP (object
))
426 object
= XWINDOW (object
)->buffer
;
428 if (!BUFFERP (object
))
429 /* pos-property only makes sense in buffers right now, since strings
430 have no overlays and no notion of insertion for which stickiness
432 return Fget_text_property (position
, prop
, object
);
435 int posn
= XINT (position
);
437 Lisp_Object
*overlay_vec
, tem
;
438 struct buffer
*obuf
= current_buffer
;
440 set_buffer_temp (XBUFFER (object
));
442 /* First try with room for 40 overlays. */
444 overlay_vec
= (Lisp_Object
*) alloca (noverlays
* sizeof (Lisp_Object
));
445 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
447 /* If there are more than 40,
448 make enough space for all, and try again. */
451 overlay_vec
= (Lisp_Object
*) alloca (noverlays
* sizeof (Lisp_Object
));
452 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
454 noverlays
= sort_overlays (overlay_vec
, noverlays
, NULL
);
456 set_buffer_temp (obuf
);
458 /* Now check the overlays in order of decreasing priority. */
459 while (--noverlays
>= 0)
461 Lisp_Object ol
= overlay_vec
[noverlays
];
462 tem
= Foverlay_get (ol
, prop
);
465 /* Check the overlay is indeed active at point. */
466 Lisp_Object start
= OVERLAY_START (ol
), finish
= OVERLAY_END (ol
);
467 if ((OVERLAY_POSITION (start
) == posn
468 && XMARKER (start
)->insertion_type
== 1)
469 || (OVERLAY_POSITION (finish
) == posn
470 && XMARKER (finish
)->insertion_type
== 0))
471 ; /* The overlay will not cover a char inserted at point. */
479 { /* Now check the text-properties. */
480 int stickiness
= text_property_stickiness (prop
, position
, object
);
482 return Fget_text_property (position
, prop
, object
);
483 else if (stickiness
< 0
484 && XINT (position
) > BUF_BEGV (XBUFFER (object
)))
485 return Fget_text_property (make_number (XINT (position
) - 1),
493 /* Find the field surrounding POS in *BEG and *END. If POS is nil,
494 the value of point is used instead. If BEG or END is null,
495 means don't store the beginning or end of the field.
497 BEG_LIMIT and END_LIMIT serve to limit the ranged of the returned
498 results; they do not effect boundary behavior.
500 If MERGE_AT_BOUNDARY is nonzero, then if POS is at the very first
501 position of a field, then the beginning of the previous field is
502 returned instead of the beginning of POS's field (since the end of a
503 field is actually also the beginning of the next input field, this
504 behavior is sometimes useful). Additionally in the MERGE_AT_BOUNDARY
505 true case, if two fields are separated by a field with the special
506 value `boundary', and POS lies within it, then the two separated
507 fields are considered to be adjacent, and POS between them, when
508 finding the beginning and ending of the "merged" field.
510 Either BEG or END may be 0, in which case the corresponding value
514 find_field (pos
, merge_at_boundary
, beg_limit
, beg
, end_limit
, end
)
516 Lisp_Object merge_at_boundary
;
517 Lisp_Object beg_limit
, end_limit
;
520 /* Fields right before and after the point. */
521 Lisp_Object before_field
, after_field
;
522 /* 1 if POS counts as the start of a field. */
523 int at_field_start
= 0;
524 /* 1 if POS counts as the end of a field. */
525 int at_field_end
= 0;
528 XSETFASTINT (pos
, PT
);
530 CHECK_NUMBER_COERCE_MARKER (pos
);
533 = get_char_property_and_overlay (pos
, Qfield
, Qnil
, NULL
);
535 = (XFASTINT (pos
) > BEGV
536 ? get_char_property_and_overlay (make_number (XINT (pos
) - 1),
538 /* Using nil here would be a more obvious choice, but it would
539 fail when the buffer starts with a non-sticky field. */
542 /* See if we need to handle the case where MERGE_AT_BOUNDARY is nil
543 and POS is at beginning of a field, which can also be interpreted
544 as the end of the previous field. Note that the case where if
545 MERGE_AT_BOUNDARY is non-nil (see function comment) is actually the
546 more natural one; then we avoid treating the beginning of a field
548 if (NILP (merge_at_boundary
))
550 Lisp_Object field
= get_pos_property (pos
, Qfield
, Qnil
);
551 if (!EQ (field
, after_field
))
553 if (!EQ (field
, before_field
))
555 if (NILP (field
) && at_field_start
&& at_field_end
)
556 /* If an inserted char would have a nil field while the surrounding
557 text is non-nil, we're probably not looking at a
558 zero-length field, but instead at a non-nil field that's
559 not intended for editing (such as comint's prompts). */
560 at_field_end
= at_field_start
= 0;
563 /* Note about special `boundary' fields:
565 Consider the case where the point (`.') is between the fields `x' and `y':
569 In this situation, if merge_at_boundary is true, we consider the
570 `x' and `y' fields as forming one big merged field, and so the end
571 of the field is the end of `y'.
573 However, if `x' and `y' are separated by a special `boundary' field
574 (a field with a `field' char-property of 'boundary), then we ignore
575 this special field when merging adjacent fields. Here's the same
576 situation, but with a `boundary' field between the `x' and `y' fields:
580 Here, if point is at the end of `x', the beginning of `y', or
581 anywhere in-between (within the `boundary' field), we merge all
582 three fields and consider the beginning as being the beginning of
583 the `x' field, and the end as being the end of the `y' field. */
588 /* POS is at the edge of a field, and we should consider it as
589 the beginning of the following field. */
590 *beg
= XFASTINT (pos
);
592 /* Find the previous field boundary. */
595 if (!NILP (merge_at_boundary
) && EQ (before_field
, Qboundary
))
596 /* Skip a `boundary' field. */
597 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
600 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
602 *beg
= NILP (p
) ? BEGV
: XFASTINT (p
);
609 /* POS is at the edge of a field, and we should consider it as
610 the end of the previous field. */
611 *end
= XFASTINT (pos
);
613 /* Find the next field boundary. */
615 if (!NILP (merge_at_boundary
) && EQ (after_field
, Qboundary
))
616 /* Skip a `boundary' field. */
617 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
620 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
622 *end
= NILP (pos
) ? ZV
: XFASTINT (pos
);
628 DEFUN ("delete-field", Fdelete_field
, Sdelete_field
, 0, 1, 0,
629 doc
: /* Delete the field surrounding POS.
630 A field is a region of text with the same `field' property.
631 If POS is nil, the value of point is used for POS. */)
636 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
638 del_range (beg
, end
);
642 DEFUN ("field-string", Ffield_string
, Sfield_string
, 0, 1, 0,
643 doc
: /* Return the contents of the field surrounding POS as a string.
644 A field is a region of text with the same `field' property.
645 If POS is nil, the value of point is used for POS. */)
650 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
651 return make_buffer_string (beg
, end
, 1);
654 DEFUN ("field-string-no-properties", Ffield_string_no_properties
, Sfield_string_no_properties
, 0, 1, 0,
655 doc
: /* Return the contents of the field around POS, without text-properties.
656 A field is a region of text with the same `field' property.
657 If POS is nil, the value of point is used for POS. */)
662 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
663 return make_buffer_string (beg
, end
, 0);
666 DEFUN ("field-beginning", Ffield_beginning
, Sfield_beginning
, 0, 3, 0,
667 doc
: /* Return the beginning of the field surrounding POS.
668 A field is a region of text with the same `field' property.
669 If POS is nil, the value of point is used for POS.
670 If ESCAPE-FROM-EDGE is non-nil and POS is at the beginning of its
671 field, then the beginning of the *previous* field is returned.
672 If LIMIT is non-nil, it is a buffer position; if the beginning of the field
673 is before LIMIT, then LIMIT will be returned instead. */)
674 (pos
, escape_from_edge
, limit
)
675 Lisp_Object pos
, escape_from_edge
, limit
;
678 find_field (pos
, escape_from_edge
, limit
, &beg
, Qnil
, 0);
679 return make_number (beg
);
682 DEFUN ("field-end", Ffield_end
, Sfield_end
, 0, 3, 0,
683 doc
: /* Return the end of the field surrounding POS.
684 A field is a region of text with the same `field' property.
685 If POS is nil, the value of point is used for POS.
686 If ESCAPE-FROM-EDGE is non-nil and POS is at the end of its field,
687 then the end of the *following* field is returned.
688 If LIMIT is non-nil, it is a buffer position; if the end of the field
689 is after LIMIT, then LIMIT will be returned instead. */)
690 (pos
, escape_from_edge
, limit
)
691 Lisp_Object pos
, escape_from_edge
, limit
;
694 find_field (pos
, escape_from_edge
, Qnil
, 0, limit
, &end
);
695 return make_number (end
);
698 DEFUN ("constrain-to-field", Fconstrain_to_field
, Sconstrain_to_field
, 2, 5, 0,
699 doc
: /* Return the position closest to NEW-POS that is in the same field as OLD-POS.
701 A field is a region of text with the same `field' property.
702 If NEW-POS is nil, then the current point is used instead, and set to the
703 constrained position if that is different.
705 If OLD-POS is at the boundary of two fields, then the allowable
706 positions for NEW-POS depends on the value of the optional argument
707 ESCAPE-FROM-EDGE: If ESCAPE-FROM-EDGE is nil, then NEW-POS is
708 constrained to the field that has the same `field' char-property
709 as any new characters inserted at OLD-POS, whereas if ESCAPE-FROM-EDGE
710 is non-nil, NEW-POS is constrained to the union of the two adjacent
711 fields. Additionally, if two fields are separated by another field with
712 the special value `boundary', then any point within this special field is
713 also considered to be `on the boundary'.
715 If the optional argument ONLY-IN-LINE is non-nil and constraining
716 NEW-POS would move it to a different line, NEW-POS is returned
717 unconstrained. This useful for commands that move by line, like
718 \\[next-line] or \\[beginning-of-line], which should generally respect field boundaries
719 only in the case where they can still move to the right line.
721 If the optional argument INHIBIT-CAPTURE-PROPERTY is non-nil, and OLD-POS has
722 a non-nil property of that name, then any field boundaries are ignored.
724 Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
725 (new_pos
, old_pos
, escape_from_edge
, only_in_line
, inhibit_capture_property
)
726 Lisp_Object new_pos
, old_pos
;
727 Lisp_Object escape_from_edge
, only_in_line
, inhibit_capture_property
;
729 /* If non-zero, then the original point, before re-positioning. */
732 Lisp_Object prev_old
, prev_new
;
735 /* Use the current point, and afterwards, set it. */
738 XSETFASTINT (new_pos
, PT
);
741 CHECK_NUMBER_COERCE_MARKER (new_pos
);
742 CHECK_NUMBER_COERCE_MARKER (old_pos
);
744 fwd
= (XFASTINT (new_pos
) > XFASTINT (old_pos
));
746 prev_old
= make_number (XFASTINT (old_pos
) - 1);
747 prev_new
= make_number (XFASTINT (new_pos
) - 1);
749 if (NILP (Vinhibit_field_text_motion
)
750 && !EQ (new_pos
, old_pos
)
751 && (!NILP (Fget_char_property (new_pos
, Qfield
, Qnil
))
752 || !NILP (Fget_char_property (old_pos
, Qfield
, Qnil
))
753 /* To recognize field boundaries, we must also look at the
754 previous positions; we could use `get_pos_property'
755 instead, but in itself that would fail inside non-sticky
756 fields (like comint prompts). */
757 || (XFASTINT (new_pos
) > BEGV
758 && !NILP (Fget_char_property (prev_new
, Qfield
, Qnil
)))
759 || (XFASTINT (old_pos
) > BEGV
760 && !NILP (Fget_char_property (prev_old
, Qfield
, Qnil
))))
761 && (NILP (inhibit_capture_property
)
762 /* Field boundaries are again a problem; but now we must
763 decide the case exactly, so we need to call
764 `get_pos_property' as well. */
765 || (NILP (get_pos_property (old_pos
, inhibit_capture_property
, Qnil
))
766 && (XFASTINT (old_pos
) <= BEGV
767 || NILP (Fget_char_property (old_pos
, inhibit_capture_property
, Qnil
))
768 || NILP (Fget_char_property (prev_old
, inhibit_capture_property
, Qnil
))))))
769 /* It is possible that NEW_POS is not within the same field as
770 OLD_POS; try to move NEW_POS so that it is. */
773 Lisp_Object field_bound
;
776 field_bound
= Ffield_end (old_pos
, escape_from_edge
, new_pos
);
778 field_bound
= Ffield_beginning (old_pos
, escape_from_edge
, new_pos
);
780 if (/* See if ESCAPE_FROM_EDGE caused FIELD_BOUND to jump to the
781 other side of NEW_POS, which would mean that NEW_POS is
782 already acceptable, and it's not necessary to constrain it
784 ((XFASTINT (field_bound
) < XFASTINT (new_pos
)) ? fwd
: !fwd
)
785 /* NEW_POS should be constrained, but only if either
786 ONLY_IN_LINE is nil (in which case any constraint is OK),
787 or NEW_POS and FIELD_BOUND are on the same line (in which
788 case the constraint is OK even if ONLY_IN_LINE is non-nil). */
789 && (NILP (only_in_line
)
790 /* This is the ONLY_IN_LINE case, check that NEW_POS and
791 FIELD_BOUND are on the same line by seeing whether
792 there's an intervening newline or not. */
793 || (scan_buffer ('\n',
794 XFASTINT (new_pos
), XFASTINT (field_bound
),
795 fwd
? -1 : 1, &shortage
, 1),
797 /* Constrain NEW_POS to FIELD_BOUND. */
798 new_pos
= field_bound
;
800 if (orig_point
&& XFASTINT (new_pos
) != orig_point
)
801 /* The NEW_POS argument was originally nil, so automatically set PT. */
802 SET_PT (XFASTINT (new_pos
));
809 DEFUN ("line-beginning-position",
810 Fline_beginning_position
, Sline_beginning_position
, 0, 1, 0,
811 doc
: /* Return the character position of the first character on the current line.
812 With argument N not nil or 1, move forward N - 1 lines first.
813 If scan reaches end of buffer, return that position.
815 This function constrains the returned position to the current field
816 unless that would be on a different line than the original,
817 unconstrained result. If N is nil or 1, and a front-sticky field
818 starts at point, the scan stops as soon as it starts. To ignore field
819 boundaries bind `inhibit-field-text-motion' to t.
821 This function does not move point. */)
825 int orig
, orig_byte
, end
;
826 int count
= SPECPDL_INDEX ();
827 specbind (Qinhibit_point_motion_hooks
, Qt
);
836 Fforward_line (make_number (XINT (n
) - 1));
839 SET_PT_BOTH (orig
, orig_byte
);
841 unbind_to (count
, Qnil
);
843 /* Return END constrained to the current input field. */
844 return Fconstrain_to_field (make_number (end
), make_number (orig
),
845 XINT (n
) != 1 ? Qt
: Qnil
,
849 DEFUN ("line-end-position", Fline_end_position
, Sline_end_position
, 0, 1, 0,
850 doc
: /* Return the character position of the last character on the current line.
851 With argument N not nil or 1, move forward N - 1 lines first.
852 If scan reaches end of buffer, return that position.
854 This function constrains the returned position to the current field
855 unless that would be on a different line than the original,
856 unconstrained result. If N is nil or 1, and a rear-sticky field ends
857 at point, the scan stops as soon as it starts. To ignore field
858 boundaries bind `inhibit-field-text-motion' to t.
860 This function does not move point. */)
872 end_pos
= find_before_next_newline (orig
, 0, XINT (n
) - (XINT (n
) <= 0));
874 /* Return END_POS constrained to the current input field. */
875 return Fconstrain_to_field (make_number (end_pos
), make_number (orig
),
881 save_excursion_save ()
883 int visible
= (XBUFFER (XWINDOW (selected_window
)->buffer
)
886 return Fcons (Fpoint_marker (),
887 Fcons (Fcopy_marker (current_buffer
->mark
, Qnil
),
888 Fcons (visible
? Qt
: Qnil
,
889 Fcons (current_buffer
->mark_active
,
894 save_excursion_restore (info
)
897 Lisp_Object tem
, tem1
, omark
, nmark
;
898 struct gcpro gcpro1
, gcpro2
, gcpro3
;
901 tem
= Fmarker_buffer (XCAR (info
));
902 /* If buffer being returned to is now deleted, avoid error */
903 /* Otherwise could get error here while unwinding to top level
905 /* In that case, Fmarker_buffer returns nil now. */
909 omark
= nmark
= Qnil
;
910 GCPRO3 (info
, omark
, nmark
);
917 unchain_marker (XMARKER (tem
));
922 omark
= Fmarker_position (current_buffer
->mark
);
923 Fset_marker (current_buffer
->mark
, tem
, Fcurrent_buffer ());
924 nmark
= Fmarker_position (tem
);
925 unchain_marker (XMARKER (tem
));
929 visible_p
= !NILP (XCAR (info
));
931 #if 0 /* We used to make the current buffer visible in the selected window
932 if that was true previously. That avoids some anomalies.
933 But it creates others, and it wasn't documented, and it is simpler
934 and cleaner never to alter the window/buffer connections. */
937 && current_buffer
!= XBUFFER (XWINDOW (selected_window
)->buffer
))
938 Fswitch_to_buffer (Fcurrent_buffer (), Qnil
);
944 tem1
= current_buffer
->mark_active
;
945 current_buffer
->mark_active
= tem
;
947 if (!NILP (Vrun_hooks
))
949 /* If mark is active now, and either was not active
950 or was at a different place, run the activate hook. */
951 if (! NILP (current_buffer
->mark_active
))
953 if (! EQ (omark
, nmark
))
954 call1 (Vrun_hooks
, intern ("activate-mark-hook"));
956 /* If mark has ceased to be active, run deactivate hook. */
957 else if (! NILP (tem1
))
958 call1 (Vrun_hooks
, intern ("deactivate-mark-hook"));
961 /* If buffer was visible in a window, and a different window was
962 selected, and the old selected window is still showing this
963 buffer, restore point in that window. */
966 && !EQ (tem
, selected_window
)
967 && (tem1
= XWINDOW (tem
)->buffer
,
968 (/* Window is live... */
970 /* ...and it shows the current buffer. */
971 && XBUFFER (tem1
) == current_buffer
)))
972 Fset_window_point (tem
, make_number (PT
));
978 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
979 doc
: /* Save point, mark, and current buffer; execute BODY; restore those things.
980 Executes BODY just like `progn'.
981 The values of point, mark and the current buffer are restored
982 even in case of abnormal exit (throw or error).
983 The state of activation of the mark is also restored.
985 This construct does not save `deactivate-mark', and therefore
986 functions that change the buffer will still cause deactivation
987 of the mark at the end of the command. To prevent that, bind
988 `deactivate-mark' with `let'.
990 usage: (save-excursion &rest BODY) */)
994 register Lisp_Object val
;
995 int count
= SPECPDL_INDEX ();
997 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
1000 return unbind_to (count
, val
);
1003 DEFUN ("save-current-buffer", Fsave_current_buffer
, Ssave_current_buffer
, 0, UNEVALLED
, 0,
1004 doc
: /* Save the current buffer; execute BODY; restore the current buffer.
1005 Executes BODY just like `progn'.
1006 usage: (save-current-buffer &rest BODY) */)
1011 int count
= SPECPDL_INDEX ();
1013 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
1015 val
= Fprogn (args
);
1016 return unbind_to (count
, val
);
1019 DEFUN ("buffer-size", Fbufsize
, Sbufsize
, 0, 1, 0,
1020 doc
: /* Return the number of characters in the current buffer.
1021 If BUFFER, return the number of characters in that buffer instead. */)
1026 return make_number (Z
- BEG
);
1029 CHECK_BUFFER (buffer
);
1030 return make_number (BUF_Z (XBUFFER (buffer
))
1031 - BUF_BEG (XBUFFER (buffer
)));
1035 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
1036 doc
: /* Return the minimum permissible value of point in the current buffer.
1037 This is 1, unless narrowing (a buffer restriction) is in effect. */)
1041 XSETFASTINT (temp
, BEGV
);
1045 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
1046 doc
: /* Return a marker to the minimum permissible value of point in this buffer.
1047 This is the beginning, unless narrowing (a buffer restriction) is in effect. */)
1050 return buildmark (BEGV
, BEGV_BYTE
);
1053 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
1054 doc
: /* Return the maximum permissible value of point in the current buffer.
1055 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1056 is in effect, in which case it is less. */)
1060 XSETFASTINT (temp
, ZV
);
1064 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
1065 doc
: /* Return a marker to the maximum permissible value of point in this buffer.
1066 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1067 is in effect, in which case it is less. */)
1070 return buildmark (ZV
, ZV_BYTE
);
1073 DEFUN ("gap-position", Fgap_position
, Sgap_position
, 0, 0, 0,
1074 doc
: /* Return the position of the gap, in the current buffer.
1075 See also `gap-size'. */)
1079 XSETFASTINT (temp
, GPT
);
1083 DEFUN ("gap-size", Fgap_size
, Sgap_size
, 0, 0, 0,
1084 doc
: /* Return the size of the current buffer's gap.
1085 See also `gap-position'. */)
1089 XSETFASTINT (temp
, GAP_SIZE
);
1093 DEFUN ("position-bytes", Fposition_bytes
, Sposition_bytes
, 1, 1, 0,
1094 doc
: /* Return the byte position for character position POSITION.
1095 If POSITION is out of range, the value is nil. */)
1097 Lisp_Object position
;
1099 CHECK_NUMBER_COERCE_MARKER (position
);
1100 if (XINT (position
) < BEG
|| XINT (position
) > Z
)
1102 return make_number (CHAR_TO_BYTE (XINT (position
)));
1105 DEFUN ("byte-to-position", Fbyte_to_position
, Sbyte_to_position
, 1, 1, 0,
1106 doc
: /* Return the character position for byte position BYTEPOS.
1107 If BYTEPOS is out of range, the value is nil. */)
1109 Lisp_Object bytepos
;
1111 CHECK_NUMBER (bytepos
);
1112 if (XINT (bytepos
) < BEG_BYTE
|| XINT (bytepos
) > Z_BYTE
)
1114 return make_number (BYTE_TO_CHAR (XINT (bytepos
)));
1117 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
1118 doc
: /* Return the character following point, as a number.
1119 At the end of the buffer or accessible region, return 0. */)
1124 XSETFASTINT (temp
, 0);
1126 XSETFASTINT (temp
, FETCH_CHAR (PT_BYTE
));
1130 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
1131 doc
: /* Return the character preceding point, as a number.
1132 At the beginning of the buffer or accessible region, return 0. */)
1137 XSETFASTINT (temp
, 0);
1138 else if (!NILP (current_buffer
->enable_multibyte_characters
))
1142 XSETFASTINT (temp
, FETCH_CHAR (pos
));
1145 XSETFASTINT (temp
, FETCH_BYTE (PT_BYTE
- 1));
1149 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
1150 doc
: /* Return t if point is at the beginning of the buffer.
1151 If the buffer is narrowed, this means the beginning of the narrowed part. */)
1159 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
1160 doc
: /* Return t if point is at the end of the buffer.
1161 If the buffer is narrowed, this means the end of the narrowed part. */)
1169 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
1170 doc
: /* Return t if point is at the beginning of a line. */)
1173 if (PT
== BEGV
|| FETCH_BYTE (PT_BYTE
- 1) == '\n')
1178 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
1179 doc
: /* Return t if point is at the end of a line.
1180 `End of a line' includes point being at the end of the buffer. */)
1183 if (PT
== ZV
|| FETCH_BYTE (PT_BYTE
) == '\n')
1188 DEFUN ("char-after", Fchar_after
, Schar_after
, 0, 1, 0,
1189 doc
: /* Return character in current buffer at position POS.
1190 POS is an integer or a marker and defaults to point.
1191 If POS is out of range, the value is nil. */)
1195 register int pos_byte
;
1200 XSETFASTINT (pos
, PT
);
1205 pos_byte
= marker_byte_position (pos
);
1206 if (pos_byte
< BEGV_BYTE
|| pos_byte
>= ZV_BYTE
)
1211 CHECK_NUMBER_COERCE_MARKER (pos
);
1212 if (XINT (pos
) < BEGV
|| XINT (pos
) >= ZV
)
1215 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1218 return make_number (FETCH_CHAR (pos_byte
));
1221 DEFUN ("char-before", Fchar_before
, Schar_before
, 0, 1, 0,
1222 doc
: /* Return character in current buffer preceding position POS.
1223 POS is an integer or a marker and defaults to point.
1224 If POS is out of range, the value is nil. */)
1228 register Lisp_Object val
;
1229 register int pos_byte
;
1234 XSETFASTINT (pos
, PT
);
1239 pos_byte
= marker_byte_position (pos
);
1241 if (pos_byte
<= BEGV_BYTE
|| pos_byte
> ZV_BYTE
)
1246 CHECK_NUMBER_COERCE_MARKER (pos
);
1248 if (XINT (pos
) <= BEGV
|| XINT (pos
) > ZV
)
1251 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1254 if (!NILP (current_buffer
->enable_multibyte_characters
))
1257 XSETFASTINT (val
, FETCH_CHAR (pos_byte
));
1262 XSETFASTINT (val
, FETCH_BYTE (pos_byte
));
1267 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 1, 0,
1268 doc
: /* Return the name under which the user logged in, as a string.
1269 This is based on the effective uid, not the real uid.
1270 Also, if the environment variables LOGNAME or USER are set,
1271 that determines the value of this function.
1273 If optional argument UID is an integer, return the login name of the user
1274 with that uid, or nil if there is no such user. */)
1280 /* Set up the user name info if we didn't do it before.
1281 (That can happen if Emacs is dumpable
1282 but you decide to run `temacs -l loadup' and not dump. */
1283 if (INTEGERP (Vuser_login_name
))
1287 return Vuser_login_name
;
1290 pw
= (struct passwd
*) getpwuid (XINT (uid
));
1291 return (pw
? build_string (pw
->pw_name
) : Qnil
);
1294 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
1296 doc
: /* Return the name of the user's real uid, as a string.
1297 This ignores the environment variables LOGNAME and USER, so it differs from
1298 `user-login-name' when running under `su'. */)
1301 /* Set up the user name info if we didn't do it before.
1302 (That can happen if Emacs is dumpable
1303 but you decide to run `temacs -l loadup' and not dump. */
1304 if (INTEGERP (Vuser_login_name
))
1306 return Vuser_real_login_name
;
1309 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
1310 doc
: /* Return the effective uid of Emacs.
1311 Value is an integer or float, depending on the value. */)
1314 return make_fixnum_or_float (geteuid ());
1317 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
1318 doc
: /* Return the real uid of Emacs.
1319 Value is an integer or float, depending on the value. */)
1322 return make_fixnum_or_float (getuid ());
1325 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 1, 0,
1326 doc
: /* Return the full name of the user logged in, as a string.
1327 If the full name corresponding to Emacs's userid is not known,
1330 If optional argument UID is an integer or float, return the full name
1331 of the user with that uid, or nil if there is no such user.
1332 If UID is a string, return the full name of the user with that login
1333 name, or nil if there is no such user. */)
1338 register unsigned char *p
, *q
;
1342 return Vuser_full_name
;
1343 else if (NUMBERP (uid
))
1344 pw
= (struct passwd
*) getpwuid ((uid_t
) XFLOATINT (uid
));
1345 else if (STRINGP (uid
))
1346 pw
= (struct passwd
*) getpwnam (SDATA (uid
));
1348 error ("Invalid UID specification");
1353 p
= (unsigned char *) USER_FULL_NAME
;
1354 /* Chop off everything after the first comma. */
1355 q
= (unsigned char *) index (p
, ',');
1356 full
= make_string (p
, q
? q
- p
: strlen (p
));
1358 #ifdef AMPERSAND_FULL_NAME
1360 q
= (unsigned char *) index (p
, '&');
1361 /* Substitute the login name for the &, upcasing the first character. */
1364 register unsigned char *r
;
1367 login
= Fuser_login_name (make_number (pw
->pw_uid
));
1368 r
= (unsigned char *) alloca (strlen (p
) + SCHARS (login
) + 1);
1369 bcopy (p
, r
, q
- p
);
1371 strcat (r
, SDATA (login
));
1372 r
[q
- p
] = UPCASE (r
[q
- p
]);
1374 full
= build_string (r
);
1376 #endif /* AMPERSAND_FULL_NAME */
1381 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
1382 doc
: /* Return the name of the machine you are running on, as a string. */)
1385 return Vsystem_name
;
1388 /* For the benefit of callers who don't want to include lisp.h */
1393 if (STRINGP (Vsystem_name
))
1394 return (char *) SDATA (Vsystem_name
);
1400 get_operating_system_release()
1402 if (STRINGP (Voperating_system_release
))
1403 return (char *) SDATA (Voperating_system_release
);
1408 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
1409 doc
: /* Return the process ID of Emacs, as an integer. */)
1412 return make_number (getpid ());
1415 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
1416 doc
: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
1417 The time is returned as a list of three integers. The first has the
1418 most significant 16 bits of the seconds, while the second has the
1419 least significant 16 bits. The third integer gives the microsecond
1422 The microsecond count is zero on systems that do not provide
1423 resolution finer than a second. */)
1427 Lisp_Object result
[3];
1430 XSETINT (result
[0], (EMACS_SECS (t
) >> 16) & 0xffff);
1431 XSETINT (result
[1], (EMACS_SECS (t
) >> 0) & 0xffff);
1432 XSETINT (result
[2], EMACS_USECS (t
));
1434 return Flist (3, result
);
1437 DEFUN ("get-internal-run-time", Fget_internal_run_time
, Sget_internal_run_time
,
1439 doc
: /* Return the current run time used by Emacs.
1440 The time is returned as a list of three integers. The first has the
1441 most significant 16 bits of the seconds, while the second has the
1442 least significant 16 bits. The third integer gives the microsecond
1445 On systems that can't determine the run time, get-internal-run-time
1446 does the same thing as current-time. The microsecond count is zero on
1447 systems that do not provide resolution finer than a second. */)
1450 #ifdef HAVE_GETRUSAGE
1451 struct rusage usage
;
1452 Lisp_Object result
[3];
1455 if (getrusage (RUSAGE_SELF
, &usage
) < 0)
1456 /* This shouldn't happen. What action is appropriate? */
1457 Fsignal (Qerror
, Qnil
);
1459 /* Sum up user time and system time. */
1460 secs
= usage
.ru_utime
.tv_sec
+ usage
.ru_stime
.tv_sec
;
1461 usecs
= usage
.ru_utime
.tv_usec
+ usage
.ru_stime
.tv_usec
;
1462 if (usecs
>= 1000000)
1468 XSETINT (result
[0], (secs
>> 16) & 0xffff);
1469 XSETINT (result
[1], (secs
>> 0) & 0xffff);
1470 XSETINT (result
[2], usecs
);
1472 return Flist (3, result
);
1474 return Fcurrent_time ();
1480 lisp_time_argument (specified_time
, result
, usec
)
1481 Lisp_Object specified_time
;
1485 if (NILP (specified_time
))
1492 *usec
= EMACS_USECS (t
);
1493 *result
= EMACS_SECS (t
);
1497 return time (result
) != -1;
1501 Lisp_Object high
, low
;
1502 high
= Fcar (specified_time
);
1503 CHECK_NUMBER (high
);
1504 low
= Fcdr (specified_time
);
1509 Lisp_Object usec_l
= Fcdr (low
);
1511 usec_l
= Fcar (usec_l
);
1516 CHECK_NUMBER (usec_l
);
1517 *usec
= XINT (usec_l
);
1525 *result
= (XINT (high
) << 16) + (XINT (low
) & 0xffff);
1526 return *result
>> 16 == XINT (high
);
1530 DEFUN ("float-time", Ffloat_time
, Sfloat_time
, 0, 1, 0,
1531 doc
: /* Return the current time, as a float number of seconds since the epoch.
1532 If SPECIFIED-TIME is given, it is the time to convert to float
1533 instead of the current time. The argument should have the form
1534 (HIGH LOW . IGNORED). Thus, you can use times obtained from
1535 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
1536 have the form (HIGH . LOW), but this is considered obsolete.
1538 WARNING: Since the result is floating point, it may not be exact.
1539 Do not use this function if precise time stamps are required. */)
1541 Lisp_Object specified_time
;
1546 if (! lisp_time_argument (specified_time
, &sec
, &usec
))
1547 error ("Invalid time specification");
1549 return make_float ((sec
* 1e6
+ usec
) / 1e6
);
1552 /* Write information into buffer S of size MAXSIZE, according to the
1553 FORMAT of length FORMAT_LEN, using time information taken from *TP.
1554 Default to Universal Time if UT is nonzero, local time otherwise.
1555 Return the number of bytes written, not including the terminating
1556 '\0'. If S is NULL, nothing will be written anywhere; so to
1557 determine how many bytes would be written, use NULL for S and
1558 ((size_t) -1) for MAXSIZE.
1560 This function behaves like emacs_strftimeu, except it allows null
1563 emacs_memftimeu (s
, maxsize
, format
, format_len
, tp
, ut
)
1568 const struct tm
*tp
;
1573 /* Loop through all the null-terminated strings in the format
1574 argument. Normally there's just one null-terminated string, but
1575 there can be arbitrarily many, concatenated together, if the
1576 format contains '\0' bytes. emacs_strftimeu stops at the first
1577 '\0' byte so we must invoke it separately for each such string. */
1586 result
= emacs_strftimeu (s
, maxsize
, format
, tp
, ut
);
1590 if (result
== 0 && s
[0] != '\0')
1595 maxsize
-= result
+ 1;
1597 len
= strlen (format
);
1598 if (len
== format_len
)
1602 format_len
-= len
+ 1;
1606 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 1, 3, 0,
1607 doc
: /* Use FORMAT-STRING to format the time TIME, or now if omitted.
1608 TIME is specified as (HIGH LOW . IGNORED), as returned by
1609 `current-time' or `file-attributes'. The obsolete form (HIGH . LOW)
1610 is also still accepted.
1611 The third, optional, argument UNIVERSAL, if non-nil, means describe TIME
1612 as Universal Time; nil means describe TIME in the local time zone.
1613 The value is a copy of FORMAT-STRING, but with certain constructs replaced
1614 by text that describes the specified date and time in TIME:
1616 %Y is the year, %y within the century, %C the century.
1617 %G is the year corresponding to the ISO week, %g within the century.
1618 %m is the numeric month.
1619 %b and %h are the locale's abbreviated month name, %B the full name.
1620 %d is the day of the month, zero-padded, %e is blank-padded.
1621 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
1622 %a is the locale's abbreviated name of the day of week, %A the full name.
1623 %U is the week number starting on Sunday, %W starting on Monday,
1624 %V according to ISO 8601.
1625 %j is the day of the year.
1627 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
1628 only blank-padded, %l is like %I blank-padded.
1629 %p is the locale's equivalent of either AM or PM.
1632 %Z is the time zone name, %z is the numeric form.
1633 %s is the number of seconds since 1970-01-01 00:00:00 +0000.
1635 %c is the locale's date and time format.
1636 %x is the locale's "preferred" date format.
1637 %D is like "%m/%d/%y".
1639 %R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
1640 %X is the locale's "preferred" time format.
1642 Finally, %n is a newline, %t is a tab, %% is a literal %.
1644 Certain flags and modifiers are available with some format controls.
1645 The flags are `_', `-', `^' and `#'. For certain characters X,
1646 %_X is like %X, but padded with blanks; %-X is like %X,
1647 but without padding. %^X is like %X, but with all textual
1648 characters up-cased; %#X is like %X, but with letter-case of
1649 all textual characters reversed.
1650 %NX (where N stands for an integer) is like %X,
1651 but takes up at least N (a number) positions.
1652 The modifiers are `E' and `O'. For certain characters X,
1653 %EX is a locale's alternative version of %X;
1654 %OX is like %X, but uses the locale's number symbols.
1656 For example, to produce full ISO 8601 format, use "%Y-%m-%dT%T%z". */)
1657 (format_string
, time
, universal
)
1658 Lisp_Object format_string
, time
, universal
;
1663 int ut
= ! NILP (universal
);
1665 CHECK_STRING (format_string
);
1667 if (! lisp_time_argument (time
, &value
, NULL
))
1668 error ("Invalid time specification");
1670 format_string
= code_convert_string_norecord (format_string
,
1671 Vlocale_coding_system
, 1);
1673 /* This is probably enough. */
1674 size
= SBYTES (format_string
) * 6 + 50;
1676 tm
= ut
? gmtime (&value
) : localtime (&value
);
1678 error ("Specified time is not representable");
1680 synchronize_system_time_locale ();
1684 char *buf
= (char *) alloca (size
+ 1);
1688 result
= emacs_memftimeu (buf
, size
, SDATA (format_string
),
1689 SBYTES (format_string
),
1691 if ((result
> 0 && result
< size
) || (result
== 0 && buf
[0] == '\0'))
1692 return code_convert_string_norecord (make_string (buf
, result
),
1693 Vlocale_coding_system
, 0);
1695 /* If buffer was too small, make it bigger and try again. */
1696 result
= emacs_memftimeu (NULL
, (size_t) -1,
1697 SDATA (format_string
),
1698 SBYTES (format_string
),
1704 DEFUN ("decode-time", Fdecode_time
, Sdecode_time
, 0, 1, 0,
1705 doc
: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST ZONE).
1706 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED),
1707 as from `current-time' and `file-attributes', or `nil' to use the
1708 current time. The obsolete form (HIGH . LOW) is also still accepted.
1709 The list has the following nine members: SEC is an integer between 0
1710 and 60; SEC is 60 for a leap second, which only some operating systems
1711 support. MINUTE is an integer between 0 and 59. HOUR is an integer
1712 between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
1713 integer between 1 and 12. YEAR is an integer indicating the
1714 four-digit year. DOW is the day of week, an integer between 0 and 6,
1715 where 0 is Sunday. DST is t if daylight savings time is effect,
1716 otherwise nil. ZONE is an integer indicating the number of seconds
1717 east of Greenwich. (Note that Common Lisp has different meanings for
1720 Lisp_Object specified_time
;
1724 struct tm
*decoded_time
;
1725 Lisp_Object list_args
[9];
1727 if (! lisp_time_argument (specified_time
, &time_spec
, NULL
))
1728 error ("Invalid time specification");
1730 decoded_time
= localtime (&time_spec
);
1732 error ("Specified time is not representable");
1733 XSETFASTINT (list_args
[0], decoded_time
->tm_sec
);
1734 XSETFASTINT (list_args
[1], decoded_time
->tm_min
);
1735 XSETFASTINT (list_args
[2], decoded_time
->tm_hour
);
1736 XSETFASTINT (list_args
[3], decoded_time
->tm_mday
);
1737 XSETFASTINT (list_args
[4], decoded_time
->tm_mon
+ 1);
1738 /* On 64-bit machines an int is narrower than EMACS_INT, thus the
1739 cast below avoids overflow in int arithmetics. */
1740 XSETINT (list_args
[5], TM_YEAR_BASE
+ (EMACS_INT
) decoded_time
->tm_year
);
1741 XSETFASTINT (list_args
[6], decoded_time
->tm_wday
);
1742 list_args
[7] = (decoded_time
->tm_isdst
)? Qt
: Qnil
;
1744 /* Make a copy, in case gmtime modifies the struct. */
1745 save_tm
= *decoded_time
;
1746 decoded_time
= gmtime (&time_spec
);
1747 if (decoded_time
== 0)
1748 list_args
[8] = Qnil
;
1750 XSETINT (list_args
[8], tm_diff (&save_tm
, decoded_time
));
1751 return Flist (9, list_args
);
1754 DEFUN ("encode-time", Fencode_time
, Sencode_time
, 6, MANY
, 0,
1755 doc
: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
1756 This is the reverse operation of `decode-time', which see.
1757 ZONE defaults to the current time zone rule. This can
1758 be a string or t (as from `set-time-zone-rule'), or it can be a list
1759 \(as from `current-time-zone') or an integer (as from `decode-time')
1760 applied without consideration for daylight savings time.
1762 You can pass more than 7 arguments; then the first six arguments
1763 are used as SECOND through YEAR, and the *last* argument is used as ZONE.
1764 The intervening arguments are ignored.
1765 This feature lets (apply 'encode-time (decode-time ...)) work.
1767 Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed;
1768 for example, a DAY of 0 means the day preceding the given month.
1769 Year numbers less than 100 are treated just like other year numbers.
1770 If you want them to stand for years in this century, you must do that yourself.
1772 Years before 1970 are not guaranteed to work. On some systems,
1773 year values as low as 1901 do work.
1775 usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
1778 register Lisp_Object
*args
;
1782 Lisp_Object zone
= (nargs
> 6 ? args
[nargs
- 1] : Qnil
);
1784 CHECK_NUMBER (args
[0]); /* second */
1785 CHECK_NUMBER (args
[1]); /* minute */
1786 CHECK_NUMBER (args
[2]); /* hour */
1787 CHECK_NUMBER (args
[3]); /* day */
1788 CHECK_NUMBER (args
[4]); /* month */
1789 CHECK_NUMBER (args
[5]); /* year */
1791 tm
.tm_sec
= XINT (args
[0]);
1792 tm
.tm_min
= XINT (args
[1]);
1793 tm
.tm_hour
= XINT (args
[2]);
1794 tm
.tm_mday
= XINT (args
[3]);
1795 tm
.tm_mon
= XINT (args
[4]) - 1;
1796 tm
.tm_year
= XINT (args
[5]) - TM_YEAR_BASE
;
1802 time
= mktime (&tm
);
1807 char **oldenv
= environ
, **newenv
;
1811 else if (STRINGP (zone
))
1812 tzstring
= (char *) SDATA (zone
);
1813 else if (INTEGERP (zone
))
1815 int abszone
= abs (XINT (zone
));
1816 sprintf (tzbuf
, "XXX%s%d:%02d:%02d", "-" + (XINT (zone
) < 0),
1817 abszone
/ (60*60), (abszone
/60) % 60, abszone
% 60);
1821 error ("Invalid time zone specification");
1823 /* Set TZ before calling mktime; merely adjusting mktime's returned
1824 value doesn't suffice, since that would mishandle leap seconds. */
1825 set_time_zone_rule (tzstring
);
1827 time
= mktime (&tm
);
1829 /* Restore TZ to previous value. */
1833 #ifdef LOCALTIME_CACHE
1838 if (time
== (time_t) -1)
1839 error ("Specified time is not representable");
1841 return make_time (time
);
1844 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
1845 doc
: /* Return the current time, as a human-readable string.
1846 Programs can use this function to decode a time,
1847 since the number of columns in each field is fixed
1848 if the year is in the range 1000-9999.
1849 The format is `Sun Sep 16 01:03:52 1973'.
1850 However, see also the functions `decode-time' and `format-time-string'
1851 which provide a much more powerful and general facility.
1853 If SPECIFIED-TIME is given, it is a time to format instead of the
1854 current time. The argument should have the form (HIGH LOW . IGNORED).
1855 Thus, you can use times obtained from `current-time' and from
1856 `file-attributes'. SPECIFIED-TIME can also have the form (HIGH . LOW),
1857 but this is considered obsolete. */)
1859 Lisp_Object specified_time
;
1865 if (! lisp_time_argument (specified_time
, &value
, NULL
))
1866 error ("Invalid time specification");
1868 /* Convert to a string, checking for out-of-range time stamps.
1869 Don't use 'ctime', as that might dump core if VALUE is out of
1871 tm
= localtime (&value
);
1872 if (! (tm
&& TM_YEAR_IN_ASCTIME_RANGE (tm
->tm_year
) && (tem
= asctime (tm
))))
1873 error ("Specified time is not representable");
1875 /* Remove the trailing newline. */
1876 tem
[strlen (tem
) - 1] = '\0';
1878 return build_string (tem
);
1881 /* Yield A - B, measured in seconds.
1882 This function is copied from the GNU C Library. */
1887 /* Compute intervening leap days correctly even if year is negative.
1888 Take care to avoid int overflow in leap day calculations,
1889 but it's OK to assume that A and B are close to each other. */
1890 int a4
= (a
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (a
->tm_year
& 3);
1891 int b4
= (b
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (b
->tm_year
& 3);
1892 int a100
= a4
/ 25 - (a4
% 25 < 0);
1893 int b100
= b4
/ 25 - (b4
% 25 < 0);
1894 int a400
= a100
>> 2;
1895 int b400
= b100
>> 2;
1896 int intervening_leap_days
= (a4
- b4
) - (a100
- b100
) + (a400
- b400
);
1897 int years
= a
->tm_year
- b
->tm_year
;
1898 int days
= (365 * years
+ intervening_leap_days
1899 + (a
->tm_yday
- b
->tm_yday
));
1900 return (60 * (60 * (24 * days
+ (a
->tm_hour
- b
->tm_hour
))
1901 + (a
->tm_min
- b
->tm_min
))
1902 + (a
->tm_sec
- b
->tm_sec
));
1905 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
1906 doc
: /* Return the offset and name for the local time zone.
1907 This returns a list of the form (OFFSET NAME).
1908 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
1909 A negative value means west of Greenwich.
1910 NAME is a string giving the name of the time zone.
1911 If SPECIFIED-TIME is given, the time zone offset is determined from it
1912 instead of using the current time. The argument should have the form
1913 (HIGH LOW . IGNORED). Thus, you can use times obtained from
1914 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
1915 have the form (HIGH . LOW), but this is considered obsolete.
1917 Some operating systems cannot provide all this information to Emacs;
1918 in this case, `current-time-zone' returns a list containing nil for
1919 the data it can't find. */)
1921 Lisp_Object specified_time
;
1927 if (lisp_time_argument (specified_time
, &value
, NULL
)
1928 && (t
= gmtime (&value
)) != 0
1929 && (gmt
= *t
, t
= localtime (&value
)) != 0)
1931 int offset
= tm_diff (t
, &gmt
);
1936 s
= (char *)t
->tm_zone
;
1937 #else /* not HAVE_TM_ZONE */
1939 if (t
->tm_isdst
== 0 || t
->tm_isdst
== 1)
1940 s
= tzname
[t
->tm_isdst
];
1942 #endif /* not HAVE_TM_ZONE */
1944 #if defined HAVE_TM_ZONE || defined HAVE_TZNAME
1947 /* On Japanese w32, we can get a Japanese string as time
1948 zone name. Don't accept that. */
1950 for (p
= s
; *p
&& (isalnum ((unsigned char)*p
) || *p
== ' '); ++p
)
1959 /* No local time zone name is available; use "+-NNNN" instead. */
1960 int am
= (offset
< 0 ? -offset
: offset
) / 60;
1961 sprintf (buf
, "%c%02d%02d", (offset
< 0 ? '-' : '+'), am
/60, am
%60);
1964 return Fcons (make_number (offset
), Fcons (build_string (s
), Qnil
));
1967 return Fmake_list (make_number (2), Qnil
);
1970 /* This holds the value of `environ' produced by the previous
1971 call to Fset_time_zone_rule, or 0 if Fset_time_zone_rule
1972 has never been called. */
1973 static char **environbuf
;
1975 DEFUN ("set-time-zone-rule", Fset_time_zone_rule
, Sset_time_zone_rule
, 1, 1, 0,
1976 doc
: /* Set the local time zone using TZ, a string specifying a time zone rule.
1977 If TZ is nil, use implementation-defined default time zone information.
1978 If TZ is t, use Universal Time. */)
1986 else if (EQ (tz
, Qt
))
1991 tzstring
= (char *) SDATA (tz
);
1994 set_time_zone_rule (tzstring
);
1997 environbuf
= environ
;
2002 #ifdef LOCALTIME_CACHE
2004 /* These two values are known to load tz files in buggy implementations,
2005 i.e. Solaris 1 executables running under either Solaris 1 or Solaris 2.
2006 Their values shouldn't matter in non-buggy implementations.
2007 We don't use string literals for these strings,
2008 since if a string in the environment is in readonly
2009 storage, it runs afoul of bugs in SVR4 and Solaris 2.3.
2010 See Sun bugs 1113095 and 1114114, ``Timezone routines
2011 improperly modify environment''. */
2013 static char set_time_zone_rule_tz1
[] = "TZ=GMT+0";
2014 static char set_time_zone_rule_tz2
[] = "TZ=GMT+1";
2018 /* Set the local time zone rule to TZSTRING.
2019 This allocates memory into `environ', which it is the caller's
2020 responsibility to free. */
2023 set_time_zone_rule (tzstring
)
2027 char **from
, **to
, **newenv
;
2029 /* Make the ENVIRON vector longer with room for TZSTRING. */
2030 for (from
= environ
; *from
; from
++)
2032 envptrs
= from
- environ
+ 2;
2033 newenv
= to
= (char **) xmalloc (envptrs
* sizeof (char *)
2034 + (tzstring
? strlen (tzstring
) + 4 : 0));
2036 /* Add TZSTRING to the end of environ, as a value for TZ. */
2039 char *t
= (char *) (to
+ envptrs
);
2041 strcat (t
, tzstring
);
2045 /* Copy the old environ vector elements into NEWENV,
2046 but don't copy the TZ variable.
2047 So we have only one definition of TZ, which came from TZSTRING. */
2048 for (from
= environ
; *from
; from
++)
2049 if (strncmp (*from
, "TZ=", 3) != 0)
2055 /* If we do have a TZSTRING, NEWENV points to the vector slot where
2056 the TZ variable is stored. If we do not have a TZSTRING,
2057 TO points to the vector slot which has the terminating null. */
2059 #ifdef LOCALTIME_CACHE
2061 /* In SunOS 4.1.3_U1 and 4.1.4, if TZ has a value like
2062 "US/Pacific" that loads a tz file, then changes to a value like
2063 "XXX0" that does not load a tz file, and then changes back to
2064 its original value, the last change is (incorrectly) ignored.
2065 Also, if TZ changes twice in succession to values that do
2066 not load a tz file, tzset can dump core (see Sun bug#1225179).
2067 The following code works around these bugs. */
2071 /* Temporarily set TZ to a value that loads a tz file
2072 and that differs from tzstring. */
2074 *newenv
= (strcmp (tzstring
, set_time_zone_rule_tz1
+ 3) == 0
2075 ? set_time_zone_rule_tz2
: set_time_zone_rule_tz1
);
2081 /* The implied tzstring is unknown, so temporarily set TZ to
2082 two different values that each load a tz file. */
2083 *to
= set_time_zone_rule_tz1
;
2086 *to
= set_time_zone_rule_tz2
;
2091 /* Now TZ has the desired value, and tzset can be invoked safely. */
2098 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
2099 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
2100 type of object is Lisp_String). INHERIT is passed to
2101 INSERT_FROM_STRING_FUNC as the last argument. */
2104 general_insert_function (insert_func
, insert_from_string_func
,
2105 inherit
, nargs
, args
)
2106 void (*insert_func
) P_ ((const unsigned char *, int));
2107 void (*insert_from_string_func
) P_ ((Lisp_Object
, int, int, int, int, int));
2109 register Lisp_Object
*args
;
2111 register int argnum
;
2112 register Lisp_Object val
;
2114 for (argnum
= 0; argnum
< nargs
; argnum
++)
2120 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2123 if (!NILP (current_buffer
->enable_multibyte_characters
))
2124 len
= CHAR_STRING (XFASTINT (val
), str
);
2127 str
[0] = (SINGLE_BYTE_CHAR_P (XINT (val
))
2129 : multibyte_char_to_unibyte (XINT (val
), Qnil
));
2132 (*insert_func
) (str
, len
);
2134 else if (STRINGP (val
))
2136 (*insert_from_string_func
) (val
, 0, 0,
2143 val
= wrong_type_argument (Qchar_or_string_p
, val
);
2157 /* Callers passing one argument to Finsert need not gcpro the
2158 argument "array", since the only element of the array will
2159 not be used after calling insert or insert_from_string, so
2160 we don't care if it gets trashed. */
2162 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
2163 doc
: /* Insert the arguments, either strings or characters, at point.
2164 Point and before-insertion markers move forward to end up
2165 after the inserted text.
2166 Any other markers at the point of insertion remain before the text.
2168 If the current buffer is multibyte, unibyte strings are converted
2169 to multibyte for insertion (see `string-make-multibyte').
2170 If the current buffer is unibyte, multibyte strings are converted
2171 to unibyte for insertion (see `string-make-unibyte').
2173 When operating on binary data, it may be necessary to preserve the
2174 original bytes of a unibyte string when inserting it into a multibyte
2175 buffer; to accomplish this, apply `string-as-multibyte' to the string
2176 and insert the result.
2178 usage: (insert &rest ARGS) */)
2181 register Lisp_Object
*args
;
2183 general_insert_function (insert
, insert_from_string
, 0, nargs
, args
);
2187 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
2189 doc
: /* Insert the arguments at point, inheriting properties from adjoining text.
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 `unibyte-char-to-multibyte').
2196 If the current buffer is unibyte, multibyte strings are converted
2197 to unibyte for insertion.
2199 usage: (insert-and-inherit &rest ARGS) */)
2202 register Lisp_Object
*args
;
2204 general_insert_function (insert_and_inherit
, insert_from_string
, 1,
2209 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
2210 doc
: /* Insert strings or characters at point, relocating markers after the text.
2211 Point and markers move forward to end up after the inserted text.
2213 If the current buffer is multibyte, unibyte strings are converted
2214 to multibyte for insertion (see `unibyte-char-to-multibyte').
2215 If the current buffer is unibyte, multibyte strings are converted
2216 to unibyte for insertion.
2218 usage: (insert-before-markers &rest ARGS) */)
2221 register Lisp_Object
*args
;
2223 general_insert_function (insert_before_markers
,
2224 insert_from_string_before_markers
, 0,
2229 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers
,
2230 Sinsert_and_inherit_before_markers
, 0, MANY
, 0,
2231 doc
: /* Insert text at point, relocating markers and inheriting properties.
2232 Point and markers move forward to end up after the inserted text.
2234 If the current buffer is multibyte, unibyte strings are converted
2235 to multibyte for insertion (see `unibyte-char-to-multibyte').
2236 If the current buffer is unibyte, multibyte strings are converted
2237 to unibyte for insertion.
2239 usage: (insert-before-markers-and-inherit &rest ARGS) */)
2242 register Lisp_Object
*args
;
2244 general_insert_function (insert_before_markers_and_inherit
,
2245 insert_from_string_before_markers
, 1,
2250 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 2, 3, 0,
2251 doc
: /* Insert COUNT (second arg) copies of CHARACTER (first arg).
2252 Both arguments are required.
2253 Point, and before-insertion markers, are relocated as in the function `insert'.
2254 The optional third arg INHERIT, if non-nil, says to inherit text properties
2255 from adjoining text, if those properties are sticky. */)
2256 (character
, count
, inherit
)
2257 Lisp_Object character
, count
, inherit
;
2259 register unsigned char *string
;
2260 register int strlen
;
2263 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2265 CHECK_NUMBER (character
);
2266 CHECK_NUMBER (count
);
2268 if (!NILP (current_buffer
->enable_multibyte_characters
))
2269 len
= CHAR_STRING (XFASTINT (character
), str
);
2271 str
[0] = XFASTINT (character
), len
= 1;
2272 n
= XINT (count
) * len
;
2275 strlen
= min (n
, 256 * len
);
2276 string
= (unsigned char *) alloca (strlen
);
2277 for (i
= 0; i
< strlen
; i
++)
2278 string
[i
] = str
[i
% len
];
2282 if (!NILP (inherit
))
2283 insert_and_inherit (string
, strlen
);
2285 insert (string
, strlen
);
2290 if (!NILP (inherit
))
2291 insert_and_inherit (string
, n
);
2299 /* Making strings from buffer contents. */
2301 /* Return a Lisp_String containing the text of the current buffer from
2302 START to END. If text properties are in use and the current buffer
2303 has properties in the range specified, the resulting string will also
2304 have them, if PROPS is nonzero.
2306 We don't want to use plain old make_string here, because it calls
2307 make_uninit_string, which can cause the buffer arena to be
2308 compacted. make_string has no way of knowing that the data has
2309 been moved, and thus copies the wrong data into the string. This
2310 doesn't effect most of the other users of make_string, so it should
2311 be left as is. But we should use this function when conjuring
2312 buffer substrings. */
2315 make_buffer_string (start
, end
, props
)
2319 int start_byte
= CHAR_TO_BYTE (start
);
2320 int end_byte
= CHAR_TO_BYTE (end
);
2322 return make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
);
2325 /* Return a Lisp_String containing the text of the current buffer from
2326 START / START_BYTE to END / END_BYTE.
2328 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_both (start
, start_byte
, end
, end_byte
, props
)
2342 int start
, start_byte
, end
, end_byte
;
2345 Lisp_Object result
, tem
, tem1
;
2347 if (start
< GPT
&& GPT
< end
)
2350 if (! NILP (current_buffer
->enable_multibyte_characters
))
2351 result
= make_uninit_multibyte_string (end
- start
, end_byte
- start_byte
);
2353 result
= make_uninit_string (end
- start
);
2354 bcopy (BYTE_POS_ADDR (start_byte
), SDATA (result
),
2355 end_byte
- start_byte
);
2357 /* If desired, update and copy the text properties. */
2360 update_buffer_properties (start
, end
);
2362 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
2363 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
2365 if (XINT (tem
) != end
|| !NILP (tem1
))
2366 copy_intervals_to_string (result
, current_buffer
, start
,
2373 /* Call Vbuffer_access_fontify_functions for the range START ... END
2374 in the current buffer, if necessary. */
2377 update_buffer_properties (start
, end
)
2380 /* If this buffer has some access functions,
2381 call them, specifying the range of the buffer being accessed. */
2382 if (!NILP (Vbuffer_access_fontify_functions
))
2384 Lisp_Object args
[3];
2387 args
[0] = Qbuffer_access_fontify_functions
;
2388 XSETINT (args
[1], start
);
2389 XSETINT (args
[2], end
);
2391 /* But don't call them if we can tell that the work
2392 has already been done. */
2393 if (!NILP (Vbuffer_access_fontified_property
))
2395 tem
= Ftext_property_any (args
[1], args
[2],
2396 Vbuffer_access_fontified_property
,
2399 Frun_hook_with_args (3, args
);
2402 Frun_hook_with_args (3, args
);
2406 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
2407 doc
: /* Return the contents of part of the current buffer as a string.
2408 The two arguments START and END are character positions;
2409 they can be in either order.
2410 The string returned is multibyte if the buffer is multibyte.
2412 This function copies the text properties of that part of the buffer
2413 into the result string; if you don't want the text properties,
2414 use `buffer-substring-no-properties' instead. */)
2416 Lisp_Object start
, end
;
2420 validate_region (&start
, &end
);
2424 return make_buffer_string (b
, e
, 1);
2427 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties
,
2428 Sbuffer_substring_no_properties
, 2, 2, 0,
2429 doc
: /* Return the characters of part of the buffer, without the text properties.
2430 The two arguments START and END are character positions;
2431 they can be in either order. */)
2433 Lisp_Object start
, end
;
2437 validate_region (&start
, &end
);
2441 return make_buffer_string (b
, e
, 0);
2444 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
2445 doc
: /* Return the contents of the current buffer as a string.
2446 If narrowing is in effect, this function returns only the visible part
2450 return make_buffer_string (BEGV
, ZV
, 1);
2453 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
2455 doc
: /* Insert before point a substring of the contents of BUFFER.
2456 BUFFER may be a buffer or a buffer name.
2457 Arguments START and END are character positions specifying the substring.
2458 They default to the values of (point-min) and (point-max) in BUFFER. */)
2459 (buffer
, start
, end
)
2460 Lisp_Object buffer
, start
, end
;
2462 register int b
, e
, temp
;
2463 register struct buffer
*bp
, *obuf
;
2466 buf
= Fget_buffer (buffer
);
2470 if (NILP (bp
->name
))
2471 error ("Selecting deleted buffer");
2477 CHECK_NUMBER_COERCE_MARKER (start
);
2484 CHECK_NUMBER_COERCE_MARKER (end
);
2489 temp
= b
, b
= e
, e
= temp
;
2491 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
2492 args_out_of_range (start
, end
);
2494 obuf
= current_buffer
;
2495 set_buffer_internal_1 (bp
);
2496 update_buffer_properties (b
, e
);
2497 set_buffer_internal_1 (obuf
);
2499 insert_from_buffer (bp
, b
, e
- b
, 0);
2503 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
2505 doc
: /* Compare two substrings of two buffers; return result as number.
2506 the value is -N if first string is less after N-1 chars,
2507 +N if first string is greater after N-1 chars, or 0 if strings match.
2508 Each substring is represented as three arguments: BUFFER, START and END.
2509 That makes six args in all, three for each substring.
2511 The value of `case-fold-search' in the current buffer
2512 determines whether case is significant or ignored. */)
2513 (buffer1
, start1
, end1
, buffer2
, start2
, end2
)
2514 Lisp_Object buffer1
, start1
, end1
, buffer2
, start2
, end2
;
2516 register int begp1
, endp1
, begp2
, endp2
, temp
;
2517 register struct buffer
*bp1
, *bp2
;
2518 register Lisp_Object trt
2519 = (!NILP (current_buffer
->case_fold_search
)
2520 ? current_buffer
->case_canon_table
: Qnil
);
2522 int i1
, i2
, i1_byte
, i2_byte
;
2524 /* Find the first buffer and its substring. */
2527 bp1
= current_buffer
;
2531 buf1
= Fget_buffer (buffer1
);
2534 bp1
= XBUFFER (buf1
);
2535 if (NILP (bp1
->name
))
2536 error ("Selecting deleted buffer");
2540 begp1
= BUF_BEGV (bp1
);
2543 CHECK_NUMBER_COERCE_MARKER (start1
);
2544 begp1
= XINT (start1
);
2547 endp1
= BUF_ZV (bp1
);
2550 CHECK_NUMBER_COERCE_MARKER (end1
);
2551 endp1
= XINT (end1
);
2555 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
2557 if (!(BUF_BEGV (bp1
) <= begp1
2559 && endp1
<= BUF_ZV (bp1
)))
2560 args_out_of_range (start1
, end1
);
2562 /* Likewise for second substring. */
2565 bp2
= current_buffer
;
2569 buf2
= Fget_buffer (buffer2
);
2572 bp2
= XBUFFER (buf2
);
2573 if (NILP (bp2
->name
))
2574 error ("Selecting deleted buffer");
2578 begp2
= BUF_BEGV (bp2
);
2581 CHECK_NUMBER_COERCE_MARKER (start2
);
2582 begp2
= XINT (start2
);
2585 endp2
= BUF_ZV (bp2
);
2588 CHECK_NUMBER_COERCE_MARKER (end2
);
2589 endp2
= XINT (end2
);
2593 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
2595 if (!(BUF_BEGV (bp2
) <= begp2
2597 && endp2
<= BUF_ZV (bp2
)))
2598 args_out_of_range (start2
, end2
);
2602 i1_byte
= buf_charpos_to_bytepos (bp1
, i1
);
2603 i2_byte
= buf_charpos_to_bytepos (bp2
, i2
);
2605 while (i1
< endp1
&& i2
< endp2
)
2607 /* When we find a mismatch, we must compare the
2608 characters, not just the bytes. */
2613 if (! NILP (bp1
->enable_multibyte_characters
))
2615 c1
= BUF_FETCH_MULTIBYTE_CHAR (bp1
, i1_byte
);
2616 BUF_INC_POS (bp1
, i1_byte
);
2621 c1
= BUF_FETCH_BYTE (bp1
, i1
);
2622 c1
= unibyte_char_to_multibyte (c1
);
2626 if (! NILP (bp2
->enable_multibyte_characters
))
2628 c2
= BUF_FETCH_MULTIBYTE_CHAR (bp2
, i2_byte
);
2629 BUF_INC_POS (bp2
, i2_byte
);
2634 c2
= BUF_FETCH_BYTE (bp2
, i2
);
2635 c2
= unibyte_char_to_multibyte (c2
);
2641 c1
= CHAR_TABLE_TRANSLATE (trt
, c1
);
2642 c2
= CHAR_TABLE_TRANSLATE (trt
, c2
);
2645 return make_number (- 1 - chars
);
2647 return make_number (chars
+ 1);
2652 /* The strings match as far as they go.
2653 If one is shorter, that one is less. */
2654 if (chars
< endp1
- begp1
)
2655 return make_number (chars
+ 1);
2656 else if (chars
< endp2
- begp2
)
2657 return make_number (- chars
- 1);
2659 /* Same length too => they are equal. */
2660 return make_number (0);
2664 subst_char_in_region_unwind (arg
)
2667 return current_buffer
->undo_list
= arg
;
2671 subst_char_in_region_unwind_1 (arg
)
2674 return current_buffer
->filename
= arg
;
2677 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
2678 Ssubst_char_in_region
, 4, 5, 0,
2679 doc
: /* From START to END, replace FROMCHAR with TOCHAR each time it occurs.
2680 If optional arg NOUNDO is non-nil, don't record this change for undo
2681 and don't mark the buffer as really changed.
2682 Both characters must have the same length of multi-byte form. */)
2683 (start
, end
, fromchar
, tochar
, noundo
)
2684 Lisp_Object start
, end
, fromchar
, tochar
, noundo
;
2686 register int pos
, pos_byte
, stop
, i
, len
, end_byte
;
2688 unsigned char fromstr
[MAX_MULTIBYTE_LENGTH
], tostr
[MAX_MULTIBYTE_LENGTH
];
2690 int count
= SPECPDL_INDEX ();
2691 #define COMBINING_NO 0
2692 #define COMBINING_BEFORE 1
2693 #define COMBINING_AFTER 2
2694 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
2695 int maybe_byte_combining
= COMBINING_NO
;
2696 int last_changed
= 0;
2697 int multibyte_p
= !NILP (current_buffer
->enable_multibyte_characters
);
2699 validate_region (&start
, &end
);
2700 CHECK_NUMBER (fromchar
);
2701 CHECK_NUMBER (tochar
);
2705 len
= CHAR_STRING (XFASTINT (fromchar
), fromstr
);
2706 if (CHAR_STRING (XFASTINT (tochar
), tostr
) != len
)
2707 error ("Characters in `subst-char-in-region' have different byte-lengths");
2708 if (!ASCII_BYTE_P (*tostr
))
2710 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
2711 complete multibyte character, it may be combined with the
2712 after bytes. If it is in the range 0xA0..0xFF, it may be
2713 combined with the before and after bytes. */
2714 if (!CHAR_HEAD_P (*tostr
))
2715 maybe_byte_combining
= COMBINING_BOTH
;
2716 else if (BYTES_BY_CHAR_HEAD (*tostr
) > len
)
2717 maybe_byte_combining
= COMBINING_AFTER
;
2723 fromstr
[0] = XFASTINT (fromchar
);
2724 tostr
[0] = XFASTINT (tochar
);
2728 pos_byte
= CHAR_TO_BYTE (pos
);
2729 stop
= CHAR_TO_BYTE (XINT (end
));
2732 /* If we don't want undo, turn off putting stuff on the list.
2733 That's faster than getting rid of things,
2734 and it prevents even the entry for a first change.
2735 Also inhibit locking the file. */
2738 record_unwind_protect (subst_char_in_region_unwind
,
2739 current_buffer
->undo_list
);
2740 current_buffer
->undo_list
= Qt
;
2741 /* Don't do file-locking. */
2742 record_unwind_protect (subst_char_in_region_unwind_1
,
2743 current_buffer
->filename
);
2744 current_buffer
->filename
= Qnil
;
2747 if (pos_byte
< GPT_BYTE
)
2748 stop
= min (stop
, GPT_BYTE
);
2751 int pos_byte_next
= pos_byte
;
2753 if (pos_byte
>= stop
)
2755 if (pos_byte
>= end_byte
) break;
2758 p
= BYTE_POS_ADDR (pos_byte
);
2760 INC_POS (pos_byte_next
);
2763 if (pos_byte_next
- pos_byte
== len
2764 && p
[0] == fromstr
[0]
2766 || (p
[1] == fromstr
[1]
2767 && (len
== 2 || (p
[2] == fromstr
[2]
2768 && (len
== 3 || p
[3] == fromstr
[3]))))))
2773 modify_region (current_buffer
, changed
, XINT (end
));
2775 if (! NILP (noundo
))
2777 if (MODIFF
- 1 == SAVE_MODIFF
)
2779 if (MODIFF
- 1 == current_buffer
->auto_save_modified
)
2780 current_buffer
->auto_save_modified
++;
2784 /* Take care of the case where the new character
2785 combines with neighboring bytes. */
2786 if (maybe_byte_combining
2787 && (maybe_byte_combining
== COMBINING_AFTER
2788 ? (pos_byte_next
< Z_BYTE
2789 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2790 : ((pos_byte_next
< Z_BYTE
2791 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2792 || (pos_byte
> BEG_BYTE
2793 && ! ASCII_BYTE_P (FETCH_BYTE (pos_byte
- 1))))))
2795 Lisp_Object tem
, string
;
2797 struct gcpro gcpro1
;
2799 tem
= current_buffer
->undo_list
;
2802 /* Make a multibyte string containing this single character. */
2803 string
= make_multibyte_string (tostr
, 1, len
);
2804 /* replace_range is less efficient, because it moves the gap,
2805 but it handles combining correctly. */
2806 replace_range (pos
, pos
+ 1, string
,
2808 pos_byte_next
= CHAR_TO_BYTE (pos
);
2809 if (pos_byte_next
> pos_byte
)
2810 /* Before combining happened. We should not increment
2811 POS. So, to cancel the later increment of POS,
2815 INC_POS (pos_byte_next
);
2817 if (! NILP (noundo
))
2818 current_buffer
->undo_list
= tem
;
2825 record_change (pos
, 1);
2826 for (i
= 0; i
< len
; i
++) *p
++ = tostr
[i
];
2828 last_changed
= pos
+ 1;
2830 pos_byte
= pos_byte_next
;
2836 signal_after_change (changed
,
2837 last_changed
- changed
, last_changed
- changed
);
2838 update_compositions (changed
, last_changed
, CHECK_ALL
);
2841 unbind_to (count
, Qnil
);
2845 DEFUN ("translate-region-internal", Ftranslate_region_internal
,
2846 Stranslate_region_internal
, 3, 3, 0,
2847 doc
: /* Internal use only.
2848 From START to END, translate characters according to TABLE.
2849 TABLE is a string; the Nth character in it is the mapping
2850 for the character with code N.
2851 It returns the number of characters changed. */)
2855 register Lisp_Object table
;
2857 register unsigned char *tt
; /* Trans table. */
2858 register int nc
; /* New character. */
2859 int cnt
; /* Number of changes made. */
2860 int size
; /* Size of translate table. */
2861 int pos
, pos_byte
, end_pos
;
2862 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
2863 int string_multibyte
;
2865 validate_region (&start
, &end
);
2866 if (CHAR_TABLE_P (table
))
2873 CHECK_STRING (table
);
2875 if (! multibyte
&& (SCHARS (table
) < SBYTES (table
)))
2876 table
= string_make_unibyte (table
);
2877 string_multibyte
= SCHARS (table
) < SBYTES (table
);
2878 size
= SCHARS (table
);
2883 pos_byte
= CHAR_TO_BYTE (pos
);
2884 end_pos
= XINT (end
);
2885 modify_region (current_buffer
, pos
, XINT (end
));
2888 for (; pos
< end_pos
; )
2890 register unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
2891 unsigned char *str
, buf
[MAX_MULTIBYTE_LENGTH
];
2896 oc
= STRING_CHAR_AND_LENGTH (p
, MAX_MULTIBYTE_LENGTH
, len
);
2903 /* Reload as signal_after_change in last iteration may GC. */
2905 if (string_multibyte
)
2907 str
= tt
+ string_char_to_byte (table
, oc
);
2908 nc
= STRING_CHAR_AND_LENGTH (str
, MAX_MULTIBYTE_LENGTH
,
2914 if (! ASCII_BYTE_P (nc
) && multibyte
)
2916 str_len
= CHAR_STRING (nc
, buf
);
2932 val
= CHAR_TABLE_REF (table
, oc
);
2934 && (c
= XINT (val
), CHAR_VALID_P (c
, 0)))
2937 str_len
= CHAR_STRING (nc
, buf
);
2948 /* This is less efficient, because it moves the gap,
2949 but it should multibyte characters correctly. */
2950 string
= make_multibyte_string (str
, 1, str_len
);
2951 replace_range (pos
, pos
+ 1, string
, 1, 0, 1);
2956 record_change (pos
, 1);
2957 while (str_len
-- > 0)
2959 signal_after_change (pos
, 1, 1);
2960 update_compositions (pos
, pos
+ 1, CHECK_BORDER
);
2969 return make_number (cnt
);
2972 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
2973 doc
: /* Delete the text between point and mark.
2975 When called from a program, expects two arguments,
2976 positions (integers or markers) specifying the stretch to be deleted. */)
2978 Lisp_Object start
, end
;
2980 validate_region (&start
, &end
);
2981 del_range (XINT (start
), XINT (end
));
2985 DEFUN ("delete-and-extract-region", Fdelete_and_extract_region
,
2986 Sdelete_and_extract_region
, 2, 2, 0,
2987 doc
: /* Delete the text between START and END and return it. */)
2989 Lisp_Object start
, end
;
2991 validate_region (&start
, &end
);
2992 if (XINT (start
) == XINT (end
))
2993 return build_string ("");
2994 return del_range_1 (XINT (start
), XINT (end
), 1, 1);
2997 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
2998 doc
: /* Remove restrictions (narrowing) from current buffer.
2999 This allows the buffer's full text to be seen and edited. */)
3002 if (BEG
!= BEGV
|| Z
!= ZV
)
3003 current_buffer
->clip_changed
= 1;
3005 BEGV_BYTE
= BEG_BYTE
;
3006 SET_BUF_ZV_BOTH (current_buffer
, Z
, Z_BYTE
);
3007 /* Changing the buffer bounds invalidates any recorded current column. */
3008 invalidate_current_column ();
3012 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
3013 doc
: /* Restrict editing in this buffer to the current region.
3014 The rest of the text becomes temporarily invisible and untouchable
3015 but is not deleted; if you save the buffer in a file, the invisible
3016 text is included in the file. \\[widen] makes all visible again.
3017 See also `save-restriction'.
3019 When calling from a program, pass two arguments; positions (integers
3020 or markers) bounding the text that should remain visible. */)
3022 register Lisp_Object start
, end
;
3024 CHECK_NUMBER_COERCE_MARKER (start
);
3025 CHECK_NUMBER_COERCE_MARKER (end
);
3027 if (XINT (start
) > XINT (end
))
3030 tem
= start
; start
= end
; end
= tem
;
3033 if (!(BEG
<= XINT (start
) && XINT (start
) <= XINT (end
) && XINT (end
) <= Z
))
3034 args_out_of_range (start
, end
);
3036 if (BEGV
!= XFASTINT (start
) || ZV
!= XFASTINT (end
))
3037 current_buffer
->clip_changed
= 1;
3039 SET_BUF_BEGV (current_buffer
, XFASTINT (start
));
3040 SET_BUF_ZV (current_buffer
, XFASTINT (end
));
3041 if (PT
< XFASTINT (start
))
3042 SET_PT (XFASTINT (start
));
3043 if (PT
> XFASTINT (end
))
3044 SET_PT (XFASTINT (end
));
3045 /* Changing the buffer bounds invalidates any recorded current column. */
3046 invalidate_current_column ();
3051 save_restriction_save ()
3053 if (BEGV
== BEG
&& ZV
== Z
)
3054 /* The common case that the buffer isn't narrowed.
3055 We return just the buffer object, which save_restriction_restore
3056 recognizes as meaning `no restriction'. */
3057 return Fcurrent_buffer ();
3059 /* We have to save a restriction, so return a pair of markers, one
3060 for the beginning and one for the end. */
3062 Lisp_Object beg
, end
;
3064 beg
= buildmark (BEGV
, BEGV_BYTE
);
3065 end
= buildmark (ZV
, ZV_BYTE
);
3067 /* END must move forward if text is inserted at its exact location. */
3068 XMARKER(end
)->insertion_type
= 1;
3070 return Fcons (beg
, end
);
3075 save_restriction_restore (data
)
3079 /* A pair of marks bounding a saved restriction. */
3081 struct Lisp_Marker
*beg
= XMARKER (XCAR (data
));
3082 struct Lisp_Marker
*end
= XMARKER (XCDR (data
));
3083 struct buffer
*buf
= beg
->buffer
; /* END should have the same buffer. */
3085 if (buf
/* Verify marker still points to a buffer. */
3086 && (beg
->charpos
!= BUF_BEGV (buf
) || end
->charpos
!= BUF_ZV (buf
)))
3087 /* The restriction has changed from the saved one, so restore
3088 the saved restriction. */
3090 int pt
= BUF_PT (buf
);
3092 SET_BUF_BEGV_BOTH (buf
, beg
->charpos
, beg
->bytepos
);
3093 SET_BUF_ZV_BOTH (buf
, end
->charpos
, end
->bytepos
);
3095 if (pt
< beg
->charpos
|| pt
> end
->charpos
)
3096 /* The point is outside the new visible range, move it inside. */
3097 SET_BUF_PT_BOTH (buf
,
3098 clip_to_bounds (beg
->charpos
, pt
, end
->charpos
),
3099 clip_to_bounds (beg
->bytepos
, BUF_PT_BYTE (buf
),
3102 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3106 /* A buffer, which means that there was no old restriction. */
3108 struct buffer
*buf
= XBUFFER (data
);
3110 if (buf
/* Verify marker still points to a buffer. */
3111 && (BUF_BEGV (buf
) != BUF_BEG (buf
) || BUF_ZV (buf
) != BUF_Z (buf
)))
3112 /* The buffer has been narrowed, get rid of the narrowing. */
3114 SET_BUF_BEGV_BOTH (buf
, BUF_BEG (buf
), BUF_BEG_BYTE (buf
));
3115 SET_BUF_ZV_BOTH (buf
, BUF_Z (buf
), BUF_Z_BYTE (buf
));
3117 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3124 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
3125 doc
: /* Execute BODY, saving and restoring current buffer's restrictions.
3126 The buffer's restrictions make parts of the beginning and end invisible.
3127 (They are set up with `narrow-to-region' and eliminated with `widen'.)
3128 This special form, `save-restriction', saves the current buffer's restrictions
3129 when it is entered, and restores them when it is exited.
3130 So any `narrow-to-region' within BODY lasts only until the end of the form.
3131 The old restrictions settings are restored
3132 even in case of abnormal exit (throw or error).
3134 The value returned is the value of the last form in BODY.
3136 Note: if you are using both `save-excursion' and `save-restriction',
3137 use `save-excursion' outermost:
3138 (save-excursion (save-restriction ...))
3140 usage: (save-restriction &rest BODY) */)
3144 register Lisp_Object val
;
3145 int count
= SPECPDL_INDEX ();
3147 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
3148 val
= Fprogn (body
);
3149 return unbind_to (count
, val
);
3152 /* Buffer for the most recent text displayed by Fmessage_box. */
3153 static char *message_text
;
3155 /* Allocated length of that buffer. */
3156 static int message_length
;
3158 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
3159 doc
: /* Print a one-line message at the bottom of the screen.
3160 The message also goes into the `*Messages*' buffer.
3161 \(In keyboard macros, that's all it does.)
3163 The first argument is a format control string, and the rest are data
3164 to be formatted under control of the string. See `format' for details.
3166 If the first argument is nil or the empty string, the function clears
3167 any existing message; this lets the minibuffer contents show. See
3168 also `current-message'.
3170 usage: (message FORMAT-STRING &rest ARGS) */)
3176 || (STRINGP (args
[0])
3177 && SBYTES (args
[0]) == 0))
3184 register Lisp_Object val
;
3185 val
= Fformat (nargs
, args
);
3186 message3 (val
, SBYTES (val
), STRING_MULTIBYTE (val
));
3191 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
3192 doc
: /* Display a message, in a dialog box if possible.
3193 If a dialog box is not available, use the echo area.
3194 The first argument is a format control string, and the rest are data
3195 to be formatted under control of the string. See `format' for details.
3197 If the first argument is nil or the empty string, clear any existing
3198 message; let the minibuffer contents show.
3200 usage: (message-box FORMAT-STRING &rest ARGS) */)
3212 register Lisp_Object val
;
3213 val
= Fformat (nargs
, args
);
3215 /* The MS-DOS frames support popup menus even though they are
3216 not FRAME_WINDOW_P. */
3217 if (FRAME_WINDOW_P (XFRAME (selected_frame
))
3218 || FRAME_MSDOS_P (XFRAME (selected_frame
)))
3220 Lisp_Object pane
, menu
, obj
;
3221 struct gcpro gcpro1
;
3222 pane
= Fcons (Fcons (build_string ("OK"), Qt
), Qnil
);
3224 menu
= Fcons (val
, pane
);
3225 obj
= Fx_popup_dialog (Qt
, menu
, Qt
);
3229 #endif /* HAVE_MENUS */
3230 /* Copy the data so that it won't move when we GC. */
3233 message_text
= (char *)xmalloc (80);
3234 message_length
= 80;
3236 if (SBYTES (val
) > message_length
)
3238 message_length
= SBYTES (val
);
3239 message_text
= (char *)xrealloc (message_text
, message_length
);
3241 bcopy (SDATA (val
), message_text
, SBYTES (val
));
3242 message2 (message_text
, SBYTES (val
),
3243 STRING_MULTIBYTE (val
));
3248 extern Lisp_Object last_nonmenu_event
;
3251 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
3252 doc
: /* Display a message in a dialog box or in the echo area.
3253 If this command was invoked with the mouse, use a dialog box if
3254 `use-dialog-box' is non-nil.
3255 Otherwise, use the echo area.
3256 The first argument is a format control string, and the rest are data
3257 to be formatted under control of the string. See `format' for details.
3259 If the first argument is nil or the empty string, clear any existing
3260 message; let the minibuffer contents show.
3262 usage: (message-or-box FORMAT-STRING &rest ARGS) */)
3268 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3270 return Fmessage_box (nargs
, args
);
3272 return Fmessage (nargs
, args
);
3275 DEFUN ("current-message", Fcurrent_message
, Scurrent_message
, 0, 0, 0,
3276 doc
: /* Return the string currently displayed in the echo area, or nil if none. */)
3279 return current_message ();
3283 DEFUN ("propertize", Fpropertize
, Spropertize
, 1, MANY
, 0,
3284 doc
: /* Return a copy of STRING with text properties added.
3285 First argument is the string to copy.
3286 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
3287 properties to add to the result.
3288 usage: (propertize STRING &rest PROPERTIES) */)
3293 Lisp_Object properties
, string
;
3294 struct gcpro gcpro1
, gcpro2
;
3297 /* Number of args must be odd. */
3298 if ((nargs
& 1) == 0 || nargs
< 1)
3299 error ("Wrong number of arguments");
3301 properties
= string
= Qnil
;
3302 GCPRO2 (properties
, string
);
3304 /* First argument must be a string. */
3305 CHECK_STRING (args
[0]);
3306 string
= Fcopy_sequence (args
[0]);
3308 for (i
= 1; i
< nargs
; i
+= 2)
3309 properties
= Fcons (args
[i
], Fcons (args
[i
+ 1], properties
));
3311 Fadd_text_properties (make_number (0),
3312 make_number (SCHARS (string
)),
3313 properties
, string
);
3314 RETURN_UNGCPRO (string
);
3318 /* Number of bytes that STRING will occupy when put into the result.
3319 MULTIBYTE is nonzero if the result should be multibyte. */
3321 #define CONVERTED_BYTE_SIZE(MULTIBYTE, STRING) \
3322 (((MULTIBYTE) && ! STRING_MULTIBYTE (STRING)) \
3323 ? count_size_as_multibyte (SDATA (STRING), SBYTES (STRING)) \
3326 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
3327 doc
: /* Format a string out of a format-string and arguments.
3328 The first argument is a format control string.
3329 The other arguments are substituted into it to make the result, a string.
3330 It may contain %-sequences meaning to substitute the next argument.
3331 %s means print a string argument. Actually, prints any object, with `princ'.
3332 %d means print as number in decimal (%o octal, %x hex).
3333 %X is like %x, but uses upper case.
3334 %e means print a number in exponential notation.
3335 %f means print a number in decimal-point notation.
3336 %g means print a number in exponential notation
3337 or decimal-point notation, whichever uses fewer characters.
3338 %c means print a number as a single character.
3339 %S means print any object as an s-expression (using `prin1').
3340 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
3341 Use %% to put a single % into the output.
3343 The basic structure of a %-sequence is
3344 % <flags> <width> <precision> character
3345 where flags is [- #0]+, width is [0-9]+, and precision is .[0-9]+
3347 usage: (format STRING &rest OBJECTS) */)
3350 register Lisp_Object
*args
;
3352 register int n
; /* The number of the next arg to substitute */
3353 register int total
; /* An estimate of the final length */
3355 register unsigned char *format
, *end
, *format_start
;
3357 /* Nonzero if the output should be a multibyte string,
3358 which is true if any of the inputs is one. */
3360 /* When we make a multibyte string, we must pay attention to the
3361 byte combining problem, i.e., a byte may be combined with a
3362 multibyte charcter of the previous string. This flag tells if we
3363 must consider such a situation or not. */
3364 int maybe_combine_byte
;
3365 unsigned char *this_format
;
3366 /* Precision for each spec, or -1, a flag value meaning no precision
3367 was given in that spec. Element 0, corresonding to the format
3368 string itself, will not be used. Element NARGS, corresponding to
3369 no argument, *will* be assigned to in the case that a `%' and `.'
3370 occur after the final format specifier. */
3371 int *precision
= (int *) (alloca((nargs
+ 1) * sizeof (int)));
3374 int arg_intervals
= 0;
3377 /* discarded[I] is 1 if byte I of the format
3378 string was not copied into the output.
3379 It is 2 if byte I was not the first byte of its character. */
3380 char *discarded
= 0;
3382 /* Each element records, for one argument,
3383 the start and end bytepos in the output string,
3384 and whether the argument is a string with intervals.
3385 info[0] is unused. Unused elements have -1 for start. */
3388 int start
, end
, intervals
;
3391 /* It should not be necessary to GCPRO ARGS, because
3392 the caller in the interpreter should take care of that. */
3394 /* Try to determine whether the result should be multibyte.
3395 This is not always right; sometimes the result needs to be multibyte
3396 because of an object that we will pass through prin1,
3397 and in that case, we won't know it here. */
3398 for (n
= 0; n
< nargs
; n
++)
3400 if (STRINGP (args
[n
]) && STRING_MULTIBYTE (args
[n
]))
3402 /* Piggyback on this loop to initialize precision[N]. */
3405 precision
[nargs
] = -1;
3407 CHECK_STRING (args
[0]);
3408 /* We may have to change "%S" to "%s". */
3409 args
[0] = Fcopy_sequence (args
[0]);
3411 /* GC should never happen here, so abort if it does. */
3414 /* If we start out planning a unibyte result,
3415 then discover it has to be multibyte, we jump back to retry.
3416 That can only happen from the first large while loop below. */
3419 format
= SDATA (args
[0]);
3420 format_start
= format
;
3421 end
= format
+ SBYTES (args
[0]);
3424 /* Make room in result for all the non-%-codes in the control string. */
3425 total
= 5 + CONVERTED_BYTE_SIZE (multibyte
, args
[0]) + 1;
3427 /* Allocate the info and discarded tables. */
3429 int nbytes
= (nargs
+1) * sizeof *info
;
3432 info
= (struct info
*) alloca (nbytes
);
3433 bzero (info
, nbytes
);
3434 for (i
= 0; i
<= nargs
; i
++)
3437 SAFE_ALLOCA (discarded
, char *, SBYTES (args
[0]));
3438 bzero (discarded
, SBYTES (args
[0]));
3441 /* Add to TOTAL enough space to hold the converted arguments. */
3444 while (format
!= end
)
3445 if (*format
++ == '%')
3448 int actual_width
= 0;
3449 unsigned char *this_format_start
= format
- 1;
3450 int field_width
= 0;
3452 /* General format specifications look like
3454 '%' [flags] [field-width] [precision] format
3459 field-width ::= [0-9]+
3460 precision ::= '.' [0-9]*
3462 If a field-width is specified, it specifies to which width
3463 the output should be padded with blanks, iff the output
3464 string is shorter than field-width.
3466 If precision is specified, it specifies the number of
3467 digits to print after the '.' for floats, or the max.
3468 number of chars to print from a string. */
3470 while (format
!= end
3471 && (*format
== '-' || *format
== '0' || *format
== '#'
3472 || * format
== ' '))
3475 if (*format
>= '0' && *format
<= '9')
3477 for (field_width
= 0; *format
>= '0' && *format
<= '9'; ++format
)
3478 field_width
= 10 * field_width
+ *format
- '0';
3481 /* N is not incremented for another few lines below, so refer to
3482 element N+1 (which might be precision[NARGS]). */
3486 for (precision
[n
+1] = 0; *format
>= '0' && *format
<= '9'; ++format
)
3487 precision
[n
+1] = 10 * precision
[n
+1] + *format
- '0';
3490 if (format
- this_format_start
+ 1 > longest_format
)
3491 longest_format
= format
- this_format_start
+ 1;
3494 error ("Format string ends in middle of format specifier");
3497 else if (++n
>= nargs
)
3498 error ("Not enough arguments for format string");
3499 else if (*format
== 'S')
3501 /* For `S', prin1 the argument and then treat like a string. */
3502 register Lisp_Object tem
;
3503 tem
= Fprin1_to_string (args
[n
], Qnil
);
3504 if (STRING_MULTIBYTE (tem
) && ! multibyte
)
3510 /* If we restart the loop, we should not come here again
3511 because args[n] is now a string and calling
3512 Fprin1_to_string on it produces superflous double
3513 quotes. So, change "%S" to "%s" now. */
3517 else if (SYMBOLP (args
[n
]))
3519 args
[n
] = SYMBOL_NAME (args
[n
]);
3520 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3527 else if (STRINGP (args
[n
]))
3530 if (*format
!= 's' && *format
!= 'S')
3531 error ("Format specifier doesn't match argument type");
3532 /* In the case (PRECISION[N] > 0), THISSIZE may not need
3533 to be as large as is calculated here. Easy check for
3534 the case PRECISION = 0. */
3535 thissize
= precision
[n
] ? CONVERTED_BYTE_SIZE (multibyte
, args
[n
]) : 0;
3536 actual_width
= lisp_string_width (args
[n
], -1, NULL
, NULL
);
3538 /* Would get MPV otherwise, since Lisp_Int's `point' to low memory. */
3539 else if (INTEGERP (args
[n
]) && *format
!= 's')
3541 /* The following loop assumes the Lisp type indicates
3542 the proper way to pass the argument.
3543 So make sure we have a flonum if the argument should
3545 if (*format
== 'e' || *format
== 'f' || *format
== 'g')
3546 args
[n
] = Ffloat (args
[n
]);
3548 if (*format
!= 'd' && *format
!= 'o' && *format
!= 'x'
3549 && *format
!= 'i' && *format
!= 'X' && *format
!= 'c')
3550 error ("Invalid format operation %%%c", *format
);
3555 if (! SINGLE_BYTE_CHAR_P (XINT (args
[n
]))
3556 /* Note: No one can remember why we have to treat
3557 the character 0 as a multibyte character here.
3558 But, until it causes a real problem, let's
3560 || XINT (args
[n
]) == 0)
3567 args
[n
] = Fchar_to_string (args
[n
]);
3568 thissize
= SBYTES (args
[n
]);
3570 else if (! ASCII_BYTE_P (XINT (args
[n
])) && multibyte
)
3573 = Fchar_to_string (Funibyte_char_to_multibyte (args
[n
]));
3574 thissize
= SBYTES (args
[n
]);
3578 else if (FLOATP (args
[n
]) && *format
!= 's')
3580 if (! (*format
== 'e' || *format
== 'f' || *format
== 'g'))
3582 if (*format
!= 'd' && *format
!= 'o' && *format
!= 'x'
3583 && *format
!= 'i' && *format
!= 'X' && *format
!= 'c')
3584 error ("Invalid format operation %%%c", *format
);
3585 args
[n
] = Ftruncate (args
[n
], Qnil
);
3588 /* Note that we're using sprintf to print floats,
3589 so we have to take into account what that function
3591 /* Filter out flag value of -1. */
3592 thissize
= (MAX_10_EXP
+ 100
3593 + (precision
[n
] > 0 ? precision
[n
] : 0));
3597 /* Anything but a string, convert to a string using princ. */
3598 register Lisp_Object tem
;
3599 tem
= Fprin1_to_string (args
[n
], Qt
);
3600 if (STRING_MULTIBYTE (tem
) && ! multibyte
)
3609 thissize
+= max (0, field_width
- actual_width
);
3610 total
+= thissize
+ 4;
3615 /* Now we can no longer jump to retry.
3616 TOTAL and LONGEST_FORMAT are known for certain. */
3618 this_format
= (unsigned char *) alloca (longest_format
+ 1);
3620 /* Allocate the space for the result.
3621 Note that TOTAL is an overestimate. */
3622 SAFE_ALLOCA (buf
, char *, total
);
3628 /* Scan the format and store result in BUF. */
3629 format
= SDATA (args
[0]);
3630 format_start
= format
;
3631 end
= format
+ SBYTES (args
[0]);
3632 maybe_combine_byte
= 0;
3633 while (format
!= end
)
3639 unsigned char *this_format_start
= format
;
3641 discarded
[format
- format_start
] = 1;
3644 while (index("-0# ", *format
))
3650 discarded
[format
- format_start
] = 1;
3654 minlen
= atoi (format
);
3656 while ((*format
>= '0' && *format
<= '9') || *format
== '.')
3658 discarded
[format
- format_start
] = 1;
3662 if (*format
++ == '%')
3671 discarded
[format
- format_start
- 1] = 1;
3672 info
[n
].start
= nchars
;
3674 if (STRINGP (args
[n
]))
3676 /* handle case (precision[n] >= 0) */
3679 int nbytes
, start
, end
;
3682 /* lisp_string_width ignores a precision of 0, but GNU
3683 libc functions print 0 characters when the precision
3684 is 0. Imitate libc behavior here. Changing
3685 lisp_string_width is the right thing, and will be
3686 done, but meanwhile we work with it. */
3688 if (precision
[n
] == 0)
3689 width
= nchars_string
= nbytes
= 0;
3690 else if (precision
[n
] > 0)
3691 width
= lisp_string_width (args
[n
], precision
[n
], &nchars_string
, &nbytes
);
3693 { /* no precision spec given for this argument */
3694 width
= lisp_string_width (args
[n
], -1, NULL
, NULL
);
3695 nbytes
= SBYTES (args
[n
]);
3696 nchars_string
= SCHARS (args
[n
]);
3699 /* If spec requires it, pad on right with spaces. */
3700 padding
= minlen
- width
;
3702 while (padding
-- > 0)
3708 info
[n
].start
= start
= nchars
;
3709 nchars
+= nchars_string
;
3714 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3715 && STRING_MULTIBYTE (args
[n
])
3716 && !CHAR_HEAD_P (SREF (args
[n
], 0)))
3717 maybe_combine_byte
= 1;
3719 p
+= copy_text (SDATA (args
[n
]), p
,
3721 STRING_MULTIBYTE (args
[n
]), multibyte
);
3723 info
[n
].end
= nchars
;
3726 while (padding
-- > 0)
3732 /* If this argument has text properties, record where
3733 in the result string it appears. */
3734 if (STRING_INTERVALS (args
[n
]))
3735 info
[n
].intervals
= arg_intervals
= 1;
3737 else if (INTEGERP (args
[n
]) || FLOATP (args
[n
]))
3741 bcopy (this_format_start
, this_format
,
3742 format
- this_format_start
);
3743 this_format
[format
- this_format_start
] = 0;
3745 if (INTEGERP (args
[n
]))
3746 sprintf (p
, this_format
, XINT (args
[n
]));
3748 sprintf (p
, this_format
, XFLOAT_DATA (args
[n
]));
3752 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3753 && !CHAR_HEAD_P (*((unsigned char *) p
)))
3754 maybe_combine_byte
= 1;
3755 this_nchars
= strlen (p
);
3757 p
+= str_to_multibyte (p
, buf
+ total
- 1 - p
, this_nchars
);
3760 nchars
+= this_nchars
;
3761 info
[n
].end
= nchars
;
3765 else if (STRING_MULTIBYTE (args
[0]))
3767 /* Copy a whole multibyte character. */
3770 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3771 && !CHAR_HEAD_P (*format
))
3772 maybe_combine_byte
= 1;
3774 while (! CHAR_HEAD_P (*format
))
3776 discarded
[format
- format_start
] = 2;
3783 /* Convert a single-byte character to multibyte. */
3784 int len
= copy_text (format
, p
, 1, 0, 1);
3791 *p
++ = *format
++, nchars
++;
3794 if (p
> buf
+ total
)
3797 if (maybe_combine_byte
)
3798 nchars
= multibyte_chars_in_text (buf
, p
- buf
);
3799 val
= make_specified_string (buf
, nchars
, p
- buf
, multibyte
);
3801 /* If we allocated BUF with malloc, free it too. */
3804 /* If the format string has text properties, or any of the string
3805 arguments has text properties, set up text properties of the
3808 if (STRING_INTERVALS (args
[0]) || arg_intervals
)
3810 Lisp_Object len
, new_len
, props
;
3811 struct gcpro gcpro1
;
3813 /* Add text properties from the format string. */
3814 len
= make_number (SCHARS (args
[0]));
3815 props
= text_property_list (args
[0], make_number (0), len
, Qnil
);
3820 int bytepos
= 0, position
= 0, translated
= 0, argn
= 1;
3823 /* Adjust the bounds of each text property
3824 to the proper start and end in the output string. */
3826 /* Put the positions in PROPS in increasing order, so that
3827 we can do (effectively) one scan through the position
3828 space of the format string. */
3829 props
= Fnreverse (props
);
3831 /* BYTEPOS is the byte position in the format string,
3832 POSITION is the untranslated char position in it,
3833 TRANSLATED is the translated char position in BUF,
3834 and ARGN is the number of the next arg we will come to. */
3835 for (list
= props
; CONSP (list
); list
= XCDR (list
))
3842 /* First adjust the property start position. */
3843 pos
= XINT (XCAR (item
));
3845 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
3846 up to this position. */
3847 for (; position
< pos
; bytepos
++)
3849 if (! discarded
[bytepos
])
3850 position
++, translated
++;
3851 else if (discarded
[bytepos
] == 1)
3854 if (translated
== info
[argn
].start
)
3856 translated
+= info
[argn
].end
- info
[argn
].start
;
3862 XSETCAR (item
, make_number (translated
));
3864 /* Likewise adjust the property end position. */
3865 pos
= XINT (XCAR (XCDR (item
)));
3867 for (; bytepos
< pos
; bytepos
++)
3869 if (! discarded
[bytepos
])
3870 position
++, translated
++;
3871 else if (discarded
[bytepos
] == 1)
3874 if (translated
== info
[argn
].start
)
3876 translated
+= info
[argn
].end
- info
[argn
].start
;
3882 XSETCAR (XCDR (item
), make_number (translated
));
3885 add_text_properties_from_list (val
, props
, make_number (0));
3888 /* Add text properties from arguments. */
3890 for (n
= 1; n
< nargs
; ++n
)
3891 if (info
[n
].intervals
)
3893 len
= make_number (SCHARS (args
[n
]));
3894 new_len
= make_number (info
[n
].end
- info
[n
].start
);
3895 props
= text_property_list (args
[n
], make_number (0), len
, Qnil
);
3896 extend_property_ranges (props
, len
, new_len
);
3897 /* If successive arguments have properites, be sure that
3898 the value of `composition' property be the copy. */
3899 if (n
> 1 && info
[n
- 1].end
)
3900 make_composition_value_copy (props
);
3901 add_text_properties_from_list (val
, props
,
3902 make_number (info
[n
].start
));
3912 format2 (string1
, arg0
, arg1
)
3914 Lisp_Object arg0
, arg1
;
3916 Lisp_Object args
[3];
3917 args
[0] = build_string (string1
);
3920 return Fformat (3, args
);
3923 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
3924 doc
: /* Return t if two characters match, optionally ignoring case.
3925 Both arguments must be characters (i.e. integers).
3926 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
3928 register Lisp_Object c1
, c2
;
3934 if (XINT (c1
) == XINT (c2
))
3936 if (NILP (current_buffer
->case_fold_search
))
3939 /* Do these in separate statements,
3940 then compare the variables.
3941 because of the way DOWNCASE uses temp variables. */
3942 i1
= DOWNCASE (XFASTINT (c1
));
3943 i2
= DOWNCASE (XFASTINT (c2
));
3944 return (i1
== i2
? Qt
: Qnil
);
3947 /* Transpose the markers in two regions of the current buffer, and
3948 adjust the ones between them if necessary (i.e.: if the regions
3951 START1, END1 are the character positions of the first region.
3952 START1_BYTE, END1_BYTE are the byte positions.
3953 START2, END2 are the character positions of the second region.
3954 START2_BYTE, END2_BYTE are the byte positions.
3956 Traverses the entire marker list of the buffer to do so, adding an
3957 appropriate amount to some, subtracting from some, and leaving the
3958 rest untouched. Most of this is copied from adjust_markers in insdel.c.
3960 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
3963 transpose_markers (start1
, end1
, start2
, end2
,
3964 start1_byte
, end1_byte
, start2_byte
, end2_byte
)
3965 register int start1
, end1
, start2
, end2
;
3966 register int start1_byte
, end1_byte
, start2_byte
, end2_byte
;
3968 register int amt1
, amt1_byte
, amt2
, amt2_byte
, diff
, diff_byte
, mpos
;
3969 register struct Lisp_Marker
*marker
;
3971 /* Update point as if it were a marker. */
3975 TEMP_SET_PT_BOTH (PT
+ (end2
- end1
),
3976 PT_BYTE
+ (end2_byte
- end1_byte
));
3977 else if (PT
< start2
)
3978 TEMP_SET_PT_BOTH (PT
+ (end2
- start2
) - (end1
- start1
),
3979 (PT_BYTE
+ (end2_byte
- start2_byte
)
3980 - (end1_byte
- start1_byte
)));
3982 TEMP_SET_PT_BOTH (PT
- (start2
- start1
),
3983 PT_BYTE
- (start2_byte
- start1_byte
));
3985 /* We used to adjust the endpoints here to account for the gap, but that
3986 isn't good enough. Even if we assume the caller has tried to move the
3987 gap out of our way, it might still be at start1 exactly, for example;
3988 and that places it `inside' the interval, for our purposes. The amount
3989 of adjustment is nontrivial if there's a `denormalized' marker whose
3990 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
3991 the dirty work to Fmarker_position, below. */
3993 /* The difference between the region's lengths */
3994 diff
= (end2
- start2
) - (end1
- start1
);
3995 diff_byte
= (end2_byte
- start2_byte
) - (end1_byte
- start1_byte
);
3997 /* For shifting each marker in a region by the length of the other
3998 region plus the distance between the regions. */
3999 amt1
= (end2
- start2
) + (start2
- end1
);
4000 amt2
= (end1
- start1
) + (start2
- end1
);
4001 amt1_byte
= (end2_byte
- start2_byte
) + (start2_byte
- end1_byte
);
4002 amt2_byte
= (end1_byte
- start1_byte
) + (start2_byte
- end1_byte
);
4004 for (marker
= BUF_MARKERS (current_buffer
); marker
; marker
= marker
->next
)
4006 mpos
= marker
->bytepos
;
4007 if (mpos
>= start1_byte
&& mpos
< end2_byte
)
4009 if (mpos
< end1_byte
)
4011 else if (mpos
< start2_byte
)
4015 marker
->bytepos
= mpos
;
4017 mpos
= marker
->charpos
;
4018 if (mpos
>= start1
&& mpos
< end2
)
4022 else if (mpos
< start2
)
4027 marker
->charpos
= mpos
;
4031 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
4032 doc
: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
4033 The regions may not be overlapping, because the size of the buffer is
4034 never changed in a transposition.
4036 Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
4037 any markers that happen to be located in the regions.
4039 Transposing beyond buffer boundaries is an error. */)
4040 (startr1
, endr1
, startr2
, endr2
, leave_markers
)
4041 Lisp_Object startr1
, endr1
, startr2
, endr2
, leave_markers
;
4043 register int start1
, end1
, start2
, end2
;
4044 int start1_byte
, start2_byte
, len1_byte
, len2_byte
;
4045 int gap
, len1
, len_mid
, len2
;
4046 unsigned char *start1_addr
, *start2_addr
, *temp
;
4048 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
;
4049 cur_intv
= BUF_INTERVALS (current_buffer
);
4051 validate_region (&startr1
, &endr1
);
4052 validate_region (&startr2
, &endr2
);
4054 start1
= XFASTINT (startr1
);
4055 end1
= XFASTINT (endr1
);
4056 start2
= XFASTINT (startr2
);
4057 end2
= XFASTINT (endr2
);
4060 /* Swap the regions if they're reversed. */
4063 register int glumph
= start1
;
4071 len1
= end1
- start1
;
4072 len2
= end2
- start2
;
4075 error ("Transposed regions overlap");
4076 else if (start1
== end1
|| start2
== end2
)
4077 error ("Transposed region has length 0");
4079 /* The possibilities are:
4080 1. Adjacent (contiguous) regions, or separate but equal regions
4081 (no, really equal, in this case!), or
4082 2. Separate regions of unequal size.
4084 The worst case is usually No. 2. It means that (aside from
4085 potential need for getting the gap out of the way), there also
4086 needs to be a shifting of the text between the two regions. So
4087 if they are spread far apart, we are that much slower... sigh. */
4089 /* It must be pointed out that the really studly thing to do would
4090 be not to move the gap at all, but to leave it in place and work
4091 around it if necessary. This would be extremely efficient,
4092 especially considering that people are likely to do
4093 transpositions near where they are working interactively, which
4094 is exactly where the gap would be found. However, such code
4095 would be much harder to write and to read. So, if you are
4096 reading this comment and are feeling squirrely, by all means have
4097 a go! I just didn't feel like doing it, so I will simply move
4098 the gap the minimum distance to get it out of the way, and then
4099 deal with an unbroken array. */
4101 /* Make sure the gap won't interfere, by moving it out of the text
4102 we will operate on. */
4103 if (start1
< gap
&& gap
< end2
)
4105 if (gap
- start1
< end2
- gap
)
4111 start1_byte
= CHAR_TO_BYTE (start1
);
4112 start2_byte
= CHAR_TO_BYTE (start2
);
4113 len1_byte
= CHAR_TO_BYTE (end1
) - start1_byte
;
4114 len2_byte
= CHAR_TO_BYTE (end2
) - start2_byte
;
4116 #ifdef BYTE_COMBINING_DEBUG
4119 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4120 len2_byte
, start1
, start1_byte
)
4121 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4122 len1_byte
, end2
, start2_byte
+ len2_byte
)
4123 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4124 len1_byte
, end2
, start2_byte
+ len2_byte
))
4129 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4130 len2_byte
, start1
, start1_byte
)
4131 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4132 len1_byte
, start2
, start2_byte
)
4133 || count_combining_after (BYTE_POS_ADDR (start2_byte
),
4134 len2_byte
, end1
, start1_byte
+ len1_byte
)
4135 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4136 len1_byte
, end2
, start2_byte
+ len2_byte
))
4141 /* Hmmm... how about checking to see if the gap is large
4142 enough to use as the temporary storage? That would avoid an
4143 allocation... interesting. Later, don't fool with it now. */
4145 /* Working without memmove, for portability (sigh), so must be
4146 careful of overlapping subsections of the array... */
4148 if (end1
== start2
) /* adjacent regions */
4150 modify_region (current_buffer
, start1
, end2
);
4151 record_change (start1
, len1
+ len2
);
4153 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4154 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4155 Fset_text_properties (make_number (start1
), make_number (end2
),
4158 /* First region smaller than second. */
4159 if (len1_byte
< len2_byte
)
4163 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4165 /* Don't precompute these addresses. We have to compute them
4166 at the last minute, because the relocating allocator might
4167 have moved the buffer around during the xmalloc. */
4168 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4169 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4171 bcopy (start2_addr
, temp
, len2_byte
);
4172 bcopy (start1_addr
, start1_addr
+ len2_byte
, len1_byte
);
4173 bcopy (temp
, start1_addr
, len2_byte
);
4177 /* First region not smaller than second. */
4181 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4182 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4183 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4184 bcopy (start1_addr
, temp
, len1_byte
);
4185 bcopy (start2_addr
, start1_addr
, len2_byte
);
4186 bcopy (temp
, start1_addr
+ len2_byte
, len1_byte
);
4189 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
4190 len1
, current_buffer
, 0);
4191 graft_intervals_into_buffer (tmp_interval2
, start1
,
4192 len2
, current_buffer
, 0);
4193 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4194 update_compositions (start1
+ len2
, end2
, CHECK_TAIL
);
4196 /* Non-adjacent regions, because end1 != start2, bleagh... */
4199 len_mid
= start2_byte
- (start1_byte
+ len1_byte
);
4201 if (len1_byte
== len2_byte
)
4202 /* Regions are same size, though, how nice. */
4206 modify_region (current_buffer
, start1
, end1
);
4207 modify_region (current_buffer
, start2
, end2
);
4208 record_change (start1
, len1
);
4209 record_change (start2
, len2
);
4210 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4211 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4212 Fset_text_properties (make_number (start1
), make_number (end1
),
4214 Fset_text_properties (make_number (start2
), make_number (end2
),
4217 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4218 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4219 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4220 bcopy (start1_addr
, temp
, len1_byte
);
4221 bcopy (start2_addr
, start1_addr
, len2_byte
);
4222 bcopy (temp
, start2_addr
, len1_byte
);
4225 graft_intervals_into_buffer (tmp_interval1
, start2
,
4226 len1
, current_buffer
, 0);
4227 graft_intervals_into_buffer (tmp_interval2
, start1
,
4228 len2
, current_buffer
, 0);
4231 else if (len1_byte
< len2_byte
) /* Second region larger than first */
4232 /* Non-adjacent & unequal size, area between must also be shifted. */
4236 modify_region (current_buffer
, start1
, end2
);
4237 record_change (start1
, (end2
- start1
));
4238 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4239 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4240 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4241 Fset_text_properties (make_number (start1
), make_number (end2
),
4244 /* holds region 2 */
4245 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4246 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4247 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4248 bcopy (start2_addr
, temp
, len2_byte
);
4249 bcopy (start1_addr
, start1_addr
+ len_mid
+ len2_byte
, len1_byte
);
4250 safe_bcopy (start1_addr
+ len1_byte
, start1_addr
+ len2_byte
, len_mid
);
4251 bcopy (temp
, start1_addr
, len2_byte
);
4254 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4255 len1
, current_buffer
, 0);
4256 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4257 len_mid
, current_buffer
, 0);
4258 graft_intervals_into_buffer (tmp_interval2
, start1
,
4259 len2
, current_buffer
, 0);
4262 /* Second region smaller than first. */
4266 record_change (start1
, (end2
- start1
));
4267 modify_region (current_buffer
, start1
, end2
);
4269 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4270 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4271 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4272 Fset_text_properties (make_number (start1
), make_number (end2
),
4275 /* holds region 1 */
4276 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4277 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4278 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4279 bcopy (start1_addr
, temp
, len1_byte
);
4280 bcopy (start2_addr
, start1_addr
, len2_byte
);
4281 bcopy (start1_addr
+ len1_byte
, start1_addr
+ len2_byte
, len_mid
);
4282 bcopy (temp
, start1_addr
+ len2_byte
+ len_mid
, len1_byte
);
4285 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4286 len1
, current_buffer
, 0);
4287 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4288 len_mid
, current_buffer
, 0);
4289 graft_intervals_into_buffer (tmp_interval2
, start1
,
4290 len2
, current_buffer
, 0);
4293 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4294 update_compositions (end2
- len1
, end2
, CHECK_BORDER
);
4297 /* When doing multiple transpositions, it might be nice
4298 to optimize this. Perhaps the markers in any one buffer
4299 should be organized in some sorted data tree. */
4300 if (NILP (leave_markers
))
4302 transpose_markers (start1
, end1
, start2
, end2
,
4303 start1_byte
, start1_byte
+ len1_byte
,
4304 start2_byte
, start2_byte
+ len2_byte
);
4305 fix_start_end_in_overlays (start1
, end2
);
4317 Qbuffer_access_fontify_functions
4318 = intern ("buffer-access-fontify-functions");
4319 staticpro (&Qbuffer_access_fontify_functions
);
4321 DEFVAR_LISP ("inhibit-field-text-motion", &Vinhibit_field_text_motion
,
4322 doc
: /* Non-nil means text motion commands don't notice fields. */);
4323 Vinhibit_field_text_motion
= Qnil
;
4325 DEFVAR_LISP ("buffer-access-fontify-functions",
4326 &Vbuffer_access_fontify_functions
,
4327 doc
: /* List of functions called by `buffer-substring' to fontify if necessary.
4328 Each function is called with two arguments which specify the range
4329 of the buffer being accessed. */);
4330 Vbuffer_access_fontify_functions
= Qnil
;
4334 extern Lisp_Object Vprin1_to_string_buffer
;
4335 obuf
= Fcurrent_buffer ();
4336 /* Do this here, because init_buffer_once is too early--it won't work. */
4337 Fset_buffer (Vprin1_to_string_buffer
);
4338 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
4339 Fset (Fmake_local_variable (intern ("buffer-access-fontify-functions")),
4344 DEFVAR_LISP ("buffer-access-fontified-property",
4345 &Vbuffer_access_fontified_property
,
4346 doc
: /* Property which (if non-nil) indicates text has been fontified.
4347 `buffer-substring' need not call the `buffer-access-fontify-functions'
4348 functions if all the text being accessed has this property. */);
4349 Vbuffer_access_fontified_property
= Qnil
;
4351 DEFVAR_LISP ("system-name", &Vsystem_name
,
4352 doc
: /* The name of the machine Emacs is running on. */);
4354 DEFVAR_LISP ("user-full-name", &Vuser_full_name
,
4355 doc
: /* The full name of the user logged in. */);
4357 DEFVAR_LISP ("user-login-name", &Vuser_login_name
,
4358 doc
: /* The user's name, taken from environment variables if possible. */);
4360 DEFVAR_LISP ("user-real-login-name", &Vuser_real_login_name
,
4361 doc
: /* The user's name, based upon the real uid only. */);
4363 DEFVAR_LISP ("operating-system-release", &Voperating_system_release
,
4364 doc
: /* The release of the operating system Emacs is running on. */);
4366 defsubr (&Spropertize
);
4367 defsubr (&Schar_equal
);
4368 defsubr (&Sgoto_char
);
4369 defsubr (&Sstring_to_char
);
4370 defsubr (&Schar_to_string
);
4371 defsubr (&Sbuffer_substring
);
4372 defsubr (&Sbuffer_substring_no_properties
);
4373 defsubr (&Sbuffer_string
);
4375 defsubr (&Spoint_marker
);
4376 defsubr (&Smark_marker
);
4378 defsubr (&Sregion_beginning
);
4379 defsubr (&Sregion_end
);
4381 staticpro (&Qfield
);
4382 Qfield
= intern ("field");
4383 staticpro (&Qboundary
);
4384 Qboundary
= intern ("boundary");
4385 defsubr (&Sfield_beginning
);
4386 defsubr (&Sfield_end
);
4387 defsubr (&Sfield_string
);
4388 defsubr (&Sfield_string_no_properties
);
4389 defsubr (&Sdelete_field
);
4390 defsubr (&Sconstrain_to_field
);
4392 defsubr (&Sline_beginning_position
);
4393 defsubr (&Sline_end_position
);
4395 /* defsubr (&Smark); */
4396 /* defsubr (&Sset_mark); */
4397 defsubr (&Ssave_excursion
);
4398 defsubr (&Ssave_current_buffer
);
4400 defsubr (&Sbufsize
);
4401 defsubr (&Spoint_max
);
4402 defsubr (&Spoint_min
);
4403 defsubr (&Spoint_min_marker
);
4404 defsubr (&Spoint_max_marker
);
4405 defsubr (&Sgap_position
);
4406 defsubr (&Sgap_size
);
4407 defsubr (&Sposition_bytes
);
4408 defsubr (&Sbyte_to_position
);
4414 defsubr (&Sfollowing_char
);
4415 defsubr (&Sprevious_char
);
4416 defsubr (&Schar_after
);
4417 defsubr (&Schar_before
);
4419 defsubr (&Sinsert_before_markers
);
4420 defsubr (&Sinsert_and_inherit
);
4421 defsubr (&Sinsert_and_inherit_before_markers
);
4422 defsubr (&Sinsert_char
);
4424 defsubr (&Suser_login_name
);
4425 defsubr (&Suser_real_login_name
);
4426 defsubr (&Suser_uid
);
4427 defsubr (&Suser_real_uid
);
4428 defsubr (&Suser_full_name
);
4429 defsubr (&Semacs_pid
);
4430 defsubr (&Scurrent_time
);
4431 defsubr (&Sget_internal_run_time
);
4432 defsubr (&Sformat_time_string
);
4433 defsubr (&Sfloat_time
);
4434 defsubr (&Sdecode_time
);
4435 defsubr (&Sencode_time
);
4436 defsubr (&Scurrent_time_string
);
4437 defsubr (&Scurrent_time_zone
);
4438 defsubr (&Sset_time_zone_rule
);
4439 defsubr (&Ssystem_name
);
4440 defsubr (&Smessage
);
4441 defsubr (&Smessage_box
);
4442 defsubr (&Smessage_or_box
);
4443 defsubr (&Scurrent_message
);
4446 defsubr (&Sinsert_buffer_substring
);
4447 defsubr (&Scompare_buffer_substrings
);
4448 defsubr (&Ssubst_char_in_region
);
4449 defsubr (&Stranslate_region_internal
);
4450 defsubr (&Sdelete_region
);
4451 defsubr (&Sdelete_and_extract_region
);
4453 defsubr (&Snarrow_to_region
);
4454 defsubr (&Ssave_restriction
);
4455 defsubr (&Stranspose_regions
);
4458 /* arch-tag: fc3827d8-6f60-4067-b11e-c3218031b018
4459 (do not change this comment) */