1 /* Lisp functions pertaining to editing.
2 Copyright (C) 1985,86,87,89,93,94,95,96,97,98,1999,2000,01,02,03,2004
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
24 #include <sys/types.h>
37 #ifdef HAVE_SYS_UTSNAME_H
38 #include <sys/utsname.h>
41 /* systime.h includes <sys/time.h> which, on some systems, is required
42 for <sys/resource.h>; thus systime.h must be included before
46 #if defined HAVE_SYS_RESOURCE_H
47 #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 extern Lisp_Object make_time
P_ ((time_t));
76 extern size_t emacs_strftimeu
P_ ((char *, size_t, const char *,
77 const struct tm
*, int));
78 static int tm_diff
P_ ((struct tm
*, struct tm
*));
79 static void find_field
P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
, int *, Lisp_Object
, int *));
80 static void update_buffer_properties
P_ ((int, int));
81 static Lisp_Object region_limit
P_ ((int));
82 int lisp_time_argument
P_ ((Lisp_Object
, time_t *, int *));
83 static size_t emacs_memftimeu
P_ ((char *, size_t, const char *,
84 size_t, const struct tm
*, int));
85 static void general_insert_function
P_ ((void (*) (const unsigned char *, int),
86 void (*) (Lisp_Object
, int, int, int,
88 int, int, Lisp_Object
*));
89 static Lisp_Object subst_char_in_region_unwind
P_ ((Lisp_Object
));
90 static Lisp_Object subst_char_in_region_unwind_1
P_ ((Lisp_Object
));
91 static void transpose_markers
P_ ((int, int, int, int, int, int, int, int));
94 extern char *index
P_ ((const char *, int));
97 Lisp_Object Vbuffer_access_fontify_functions
;
98 Lisp_Object Qbuffer_access_fontify_functions
;
99 Lisp_Object Vbuffer_access_fontified_property
;
101 Lisp_Object Fuser_full_name
P_ ((Lisp_Object
));
103 /* Non-nil means don't stop at field boundary in text motion commands. */
105 Lisp_Object Vinhibit_field_text_motion
;
107 /* Some static data, and a function to initialize it for each run */
109 Lisp_Object Vsystem_name
;
110 Lisp_Object Vuser_real_login_name
; /* login name of current user ID */
111 Lisp_Object Vuser_full_name
; /* full name of current user */
112 Lisp_Object Vuser_login_name
; /* user name from LOGNAME or USER */
113 Lisp_Object Voperating_system_release
; /* Operating System Release */
115 /* Symbol for the text property used to mark fields. */
119 /* A special value for Qfield properties. */
121 Lisp_Object Qboundary
;
128 register unsigned char *p
;
129 struct passwd
*pw
; /* password entry for the current user */
132 /* Set up system_name even when dumping. */
136 /* Don't bother with this on initial start when just dumping out */
139 #endif /* not CANNOT_DUMP */
141 pw
= (struct passwd
*) getpwuid (getuid ());
143 /* We let the real user name default to "root" because that's quite
144 accurate on MSDOG and because it lets Emacs find the init file.
145 (The DVX libraries override the Djgpp libraries here.) */
146 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "root");
148 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "unknown");
151 /* Get the effective user name, by consulting environment variables,
152 or the effective uid if those are unset. */
153 user_name
= (char *) getenv ("LOGNAME");
156 user_name
= (char *) getenv ("USERNAME"); /* it's USERNAME on NT */
157 #else /* WINDOWSNT */
158 user_name
= (char *) getenv ("USER");
159 #endif /* WINDOWSNT */
162 pw
= (struct passwd
*) getpwuid (geteuid ());
163 user_name
= (char *) (pw
? pw
->pw_name
: "unknown");
165 Vuser_login_name
= build_string (user_name
);
167 /* If the user name claimed in the environment vars differs from
168 the real uid, use the claimed name to find the full name. */
169 tem
= Fstring_equal (Vuser_login_name
, Vuser_real_login_name
);
170 Vuser_full_name
= Fuser_full_name (NILP (tem
)? make_number (geteuid())
173 p
= (unsigned char *) getenv ("NAME");
175 Vuser_full_name
= build_string (p
);
176 else if (NILP (Vuser_full_name
))
177 Vuser_full_name
= build_string ("unknown");
179 #ifdef HAVE_SYS_UTSNAME_H
183 Voperating_system_release
= build_string (uts
.release
);
186 Voperating_system_release
= Qnil
;
190 DEFUN ("char-to-string", Fchar_to_string
, Schar_to_string
, 1, 1, 0,
191 doc
: /* Convert arg CHAR to a string containing that character.
192 usage: (char-to-string CHAR) */)
194 Lisp_Object character
;
197 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
199 CHECK_NUMBER (character
);
201 len
= (SINGLE_BYTE_CHAR_P (XFASTINT (character
))
202 ? (*str
= (unsigned char)(XFASTINT (character
)), 1)
203 : char_to_string (XFASTINT (character
), str
));
204 return make_string_from_bytes (str
, 1, len
);
207 DEFUN ("string-to-char", Fstring_to_char
, Sstring_to_char
, 1, 1, 0,
208 doc
: /* Convert arg STRING to a character, the first character of that string.
209 A multibyte character is handled correctly. */)
211 register Lisp_Object string
;
213 register Lisp_Object val
;
214 CHECK_STRING (string
);
217 if (STRING_MULTIBYTE (string
))
218 XSETFASTINT (val
, STRING_CHAR (SDATA (string
), SBYTES (string
)));
220 XSETFASTINT (val
, SREF (string
, 0));
223 XSETFASTINT (val
, 0);
228 buildmark (charpos
, bytepos
)
229 int charpos
, bytepos
;
231 register Lisp_Object mark
;
232 mark
= Fmake_marker ();
233 set_marker_both (mark
, Qnil
, charpos
, bytepos
);
237 DEFUN ("point", Fpoint
, Spoint
, 0, 0, 0,
238 doc
: /* Return value of point, as an integer.
239 Beginning of buffer is position (point-min). */)
243 XSETFASTINT (temp
, PT
);
247 DEFUN ("point-marker", Fpoint_marker
, Spoint_marker
, 0, 0, 0,
248 doc
: /* Return value of point, as a marker object. */)
251 return buildmark (PT
, PT_BYTE
);
255 clip_to_bounds (lower
, num
, upper
)
256 int lower
, num
, upper
;
260 else if (num
> upper
)
266 DEFUN ("goto-char", Fgoto_char
, Sgoto_char
, 1, 1, "NGoto char: ",
267 doc
: /* Set point to POSITION, a number or marker.
268 Beginning of buffer is position (point-min), end is (point-max).
269 If the position is in the middle of a multibyte form,
270 the actual point is set at the head of the multibyte form
271 except in the case that `enable-multibyte-characters' is nil. */)
273 register Lisp_Object position
;
277 if (MARKERP (position
)
278 && current_buffer
== XMARKER (position
)->buffer
)
280 pos
= marker_position (position
);
282 SET_PT_BOTH (BEGV
, BEGV_BYTE
);
284 SET_PT_BOTH (ZV
, ZV_BYTE
);
286 SET_PT_BOTH (pos
, marker_byte_position (position
));
291 CHECK_NUMBER_COERCE_MARKER (position
);
293 pos
= clip_to_bounds (BEGV
, XINT (position
), ZV
);
299 /* Return the start or end position of the region.
300 BEGINNINGP non-zero means return the start.
301 If there is no region active, signal an error. */
304 region_limit (beginningp
)
307 extern Lisp_Object Vmark_even_if_inactive
; /* Defined in callint.c. */
310 if (!NILP (Vtransient_mark_mode
)
311 && NILP (Vmark_even_if_inactive
)
312 && NILP (current_buffer
->mark_active
))
313 Fsignal (Qmark_inactive
, Qnil
);
315 m
= Fmarker_position (current_buffer
->mark
);
317 error ("The mark is not set now, so there is no region");
319 if ((PT
< XFASTINT (m
)) == (beginningp
!= 0))
320 m
= make_number (PT
);
324 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
325 doc
: /* Return position of beginning of region, as an integer. */)
328 return region_limit (1);
331 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
332 doc
: /* Return position of end of region, as an integer. */)
335 return region_limit (0);
338 DEFUN ("mark-marker", Fmark_marker
, Smark_marker
, 0, 0, 0,
339 doc
: /* Return this buffer's mark, as a marker object.
340 Watch out! Moving this marker changes the mark position.
341 If you set the marker not to point anywhere, the buffer will have no mark. */)
344 return current_buffer
->mark
;
348 /* Find all the overlays in the current buffer that touch position POS.
349 Return the number found, and store them in a vector in VEC
353 overlays_around (pos
, vec
, len
)
358 Lisp_Object overlay
, start
, end
;
359 struct Lisp_Overlay
*tail
;
360 int startpos
, endpos
;
363 for (tail
= current_buffer
->overlays_before
; tail
; tail
= tail
->next
)
365 XSETMISC (overlay
, tail
);
367 end
= OVERLAY_END (overlay
);
368 endpos
= OVERLAY_POSITION (end
);
371 start
= OVERLAY_START (overlay
);
372 startpos
= OVERLAY_POSITION (start
);
377 /* Keep counting overlays even if we can't return them all. */
382 for (tail
= current_buffer
->overlays_after
; tail
; tail
= tail
->next
)
384 XSETMISC (overlay
, tail
);
386 start
= OVERLAY_START (overlay
);
387 startpos
= OVERLAY_POSITION (start
);
390 end
= OVERLAY_END (overlay
);
391 endpos
= OVERLAY_POSITION (end
);
403 /* Return the value of property PROP, in OBJECT at POSITION.
404 It's the value of PROP that a char inserted at POSITION would get.
405 OBJECT is optional and defaults to the current buffer.
406 If OBJECT is a buffer, then overlay properties are considered as well as
408 If OBJECT is a window, then that window's buffer is used, but
409 window-specific overlays are considered only if they are associated
412 get_pos_property (position
, prop
, object
)
413 Lisp_Object position
, object
;
414 register Lisp_Object prop
;
416 CHECK_NUMBER_COERCE_MARKER (position
);
419 XSETBUFFER (object
, current_buffer
);
420 else if (WINDOWP (object
))
421 object
= XWINDOW (object
)->buffer
;
423 if (!BUFFERP (object
))
424 /* pos-property only makes sense in buffers right now, since strings
425 have no overlays and no notion of insertion for which stickiness
427 return Fget_text_property (position
, prop
, object
);
430 int posn
= XINT (position
);
432 Lisp_Object
*overlay_vec
, tem
;
433 struct buffer
*obuf
= current_buffer
;
435 set_buffer_temp (XBUFFER (object
));
437 /* First try with room for 40 overlays. */
439 overlay_vec
= (Lisp_Object
*) alloca (noverlays
* sizeof (Lisp_Object
));
440 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
442 /* If there are more than 40,
443 make enough space for all, and try again. */
446 overlay_vec
= (Lisp_Object
*) alloca (noverlays
* sizeof (Lisp_Object
));
447 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
449 noverlays
= sort_overlays (overlay_vec
, noverlays
, NULL
);
451 set_buffer_temp (obuf
);
453 /* Now check the overlays in order of decreasing priority. */
454 while (--noverlays
>= 0)
456 Lisp_Object ol
= overlay_vec
[noverlays
];
457 tem
= Foverlay_get (ol
, prop
);
460 /* Check the overlay is indeed active at point. */
461 Lisp_Object start
= OVERLAY_START (ol
), finish
= OVERLAY_END (ol
);
462 if ((OVERLAY_POSITION (start
) == posn
463 && XMARKER (start
)->insertion_type
== 1)
464 || (OVERLAY_POSITION (finish
) == posn
465 && XMARKER (finish
)->insertion_type
== 0))
466 ; /* The overlay will not cover a char inserted at point. */
474 { /* Now check the text-properties. */
475 int stickiness
= text_property_stickiness (prop
, position
, object
);
477 return Fget_text_property (position
, prop
, object
);
478 else if (stickiness
< 0
479 && XINT (position
) > BUF_BEGV (XBUFFER (object
)))
480 return Fget_text_property (make_number (XINT (position
) - 1),
488 /* Find the field surrounding POS in *BEG and *END. If POS is nil,
489 the value of point is used instead. If BEG or END null,
490 means don't store the beginning or end of the field.
492 BEG_LIMIT and END_LIMIT serve to limit the ranged of the returned
493 results; they do not effect boundary behavior.
495 If MERGE_AT_BOUNDARY is nonzero, then if POS is at the very first
496 position of a field, then the beginning of the previous field is
497 returned instead of the beginning of POS's field (since the end of a
498 field is actually also the beginning of the next input field, this
499 behavior is sometimes useful). Additionally in the MERGE_AT_BOUNDARY
500 true case, if two fields are separated by a field with the special
501 value `boundary', and POS lies within it, then the two separated
502 fields are considered to be adjacent, and POS between them, when
503 finding the beginning and ending of the "merged" field.
505 Either BEG or END may be 0, in which case the corresponding value
509 find_field (pos
, merge_at_boundary
, beg_limit
, beg
, end_limit
, end
)
511 Lisp_Object merge_at_boundary
;
512 Lisp_Object beg_limit
, end_limit
;
515 /* Fields right before and after the point. */
516 Lisp_Object before_field
, after_field
;
517 /* 1 if POS counts as the start of a field. */
518 int at_field_start
= 0;
519 /* 1 if POS counts as the end of a field. */
520 int at_field_end
= 0;
523 XSETFASTINT (pos
, PT
);
525 CHECK_NUMBER_COERCE_MARKER (pos
);
528 = get_char_property_and_overlay (pos
, Qfield
, Qnil
, NULL
);
530 = (XFASTINT (pos
) > BEGV
531 ? get_char_property_and_overlay (make_number (XINT (pos
) - 1),
535 /* See if we need to handle the case where MERGE_AT_BOUNDARY is nil
536 and POS is at beginning of a field, which can also be interpreted
537 as the end of the previous field. Note that the case where if
538 MERGE_AT_BOUNDARY is non-nil (see function comment) is actually the
539 more natural one; then we avoid treating the beginning of a field
541 if (NILP (merge_at_boundary
))
543 Lisp_Object field
= get_pos_property (pos
, Qfield
, Qnil
);
544 if (!EQ (field
, after_field
))
546 if (!EQ (field
, before_field
))
548 if (NILP (field
) && at_field_start
&& at_field_end
)
549 /* If an inserted char would have a nil field while the surrounding
550 text is non-nil, we're probably not looking at a
551 zero-length field, but instead at a non-nil field that's
552 not intended for editing (such as comint's prompts). */
553 at_field_end
= at_field_start
= 0;
556 /* Note about special `boundary' fields:
558 Consider the case where the point (`.') is between the fields `x' and `y':
562 In this situation, if merge_at_boundary is true, we consider the
563 `x' and `y' fields as forming one big merged field, and so the end
564 of the field is the end of `y'.
566 However, if `x' and `y' are separated by a special `boundary' field
567 (a field with a `field' char-property of 'boundary), then we ignore
568 this special field when merging adjacent fields. Here's the same
569 situation, but with a `boundary' field between the `x' and `y' fields:
573 Here, if point is at the end of `x', the beginning of `y', or
574 anywhere in-between (within the `boundary' field), we merge all
575 three fields and consider the beginning as being the beginning of
576 the `x' field, and the end as being the end of the `y' field. */
581 /* POS is at the edge of a field, and we should consider it as
582 the beginning of the following field. */
583 *beg
= XFASTINT (pos
);
585 /* Find the previous field boundary. */
588 if (!NILP (merge_at_boundary
) && EQ (before_field
, Qboundary
))
589 /* Skip a `boundary' field. */
590 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
593 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
595 *beg
= NILP (p
) ? BEGV
: XFASTINT (p
);
602 /* POS is at the edge of a field, and we should consider it as
603 the end of the previous field. */
604 *end
= XFASTINT (pos
);
606 /* Find the next field boundary. */
608 if (!NILP (merge_at_boundary
) && EQ (after_field
, Qboundary
))
609 /* Skip a `boundary' field. */
610 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
613 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
615 *end
= NILP (pos
) ? ZV
: XFASTINT (pos
);
621 DEFUN ("delete-field", Fdelete_field
, Sdelete_field
, 0, 1, 0,
622 doc
: /* Delete the field surrounding POS.
623 A field is a region of text with the same `field' property.
624 If POS is nil, the value of point is used for POS. */)
629 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
631 del_range (beg
, end
);
635 DEFUN ("field-string", Ffield_string
, Sfield_string
, 0, 1, 0,
636 doc
: /* Return the contents of the field surrounding POS as a string.
637 A field is a region of text with the same `field' property.
638 If POS is nil, the value of point is used for POS. */)
643 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
644 return make_buffer_string (beg
, end
, 1);
647 DEFUN ("field-string-no-properties", Ffield_string_no_properties
, Sfield_string_no_properties
, 0, 1, 0,
648 doc
: /* Return the contents of the field around POS, without text-properties.
649 A field is a region of text with the same `field' property.
650 If POS is nil, the value of point is used for POS. */)
655 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
656 return make_buffer_string (beg
, end
, 0);
659 DEFUN ("field-beginning", Ffield_beginning
, Sfield_beginning
, 0, 3, 0,
660 doc
: /* Return the beginning of the field surrounding POS.
661 A field is a region of text with the same `field' property.
662 If POS is nil, the value of point is used for POS.
663 If ESCAPE-FROM-EDGE is non-nil and POS is at the beginning of its
664 field, then the beginning of the *previous* field is returned.
665 If LIMIT is non-nil, it is a buffer position; if the beginning of the field
666 is before LIMIT, then LIMIT will be returned instead. */)
667 (pos
, escape_from_edge
, limit
)
668 Lisp_Object pos
, escape_from_edge
, limit
;
671 find_field (pos
, escape_from_edge
, limit
, &beg
, Qnil
, 0);
672 return make_number (beg
);
675 DEFUN ("field-end", Ffield_end
, Sfield_end
, 0, 3, 0,
676 doc
: /* Return the end of the field surrounding POS.
677 A field is a region of text with the same `field' property.
678 If POS is nil, the value of point is used for POS.
679 If ESCAPE-FROM-EDGE is non-nil and POS is at the end of its field,
680 then the end of the *following* field is returned.
681 If LIMIT is non-nil, it is a buffer position; if the end of the field
682 is after LIMIT, then LIMIT will be returned instead. */)
683 (pos
, escape_from_edge
, limit
)
684 Lisp_Object pos
, escape_from_edge
, limit
;
687 find_field (pos
, escape_from_edge
, Qnil
, 0, limit
, &end
);
688 return make_number (end
);
691 DEFUN ("constrain-to-field", Fconstrain_to_field
, Sconstrain_to_field
, 2, 5, 0,
692 doc
: /* Return the position closest to NEW-POS that is in the same field as OLD-POS.
694 A field is a region of text with the same `field' property.
695 If NEW-POS is nil, then the current point is used instead, and set to the
696 constrained position if that is different.
698 If OLD-POS is at the boundary of two fields, then the allowable
699 positions for NEW-POS depends on the value of the optional argument
700 ESCAPE-FROM-EDGE: If ESCAPE-FROM-EDGE is nil, then NEW-POS is
701 constrained to the field that has the same `field' char-property
702 as any new characters inserted at OLD-POS, whereas if ESCAPE-FROM-EDGE
703 is non-nil, NEW-POS is constrained to the union of the two adjacent
704 fields. Additionally, if two fields are separated by another field with
705 the special value `boundary', then any point within this special field is
706 also considered to be `on the boundary'.
708 If the optional argument ONLY-IN-LINE is non-nil and constraining
709 NEW-POS would move it to a different line, NEW-POS is returned
710 unconstrained. This useful for commands that move by line, like
711 \\[next-line] or \\[beginning-of-line], which should generally respect field boundaries
712 only in the case where they can still move to the right line.
714 If the optional argument INHIBIT-CAPTURE-PROPERTY is non-nil, and OLD-POS has
715 a non-nil property of that name, then any field boundaries are ignored.
717 Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
718 (new_pos
, old_pos
, escape_from_edge
, only_in_line
, inhibit_capture_property
)
719 Lisp_Object new_pos
, old_pos
;
720 Lisp_Object escape_from_edge
, only_in_line
, inhibit_capture_property
;
722 /* If non-zero, then the original point, before re-positioning. */
726 /* Use the current point, and afterwards, set it. */
729 XSETFASTINT (new_pos
, PT
);
732 if (NILP (Vinhibit_field_text_motion
)
733 && !EQ (new_pos
, old_pos
)
734 && (!NILP (Fget_char_property (new_pos
, Qfield
, Qnil
))
735 || !NILP (Fget_char_property (old_pos
, Qfield
, Qnil
)))
736 && (NILP (inhibit_capture_property
)
737 || NILP (Fget_char_property(old_pos
, inhibit_capture_property
, Qnil
))))
738 /* NEW_POS is not within the same field as OLD_POS; try to
739 move NEW_POS so that it is. */
742 Lisp_Object field_bound
;
744 CHECK_NUMBER_COERCE_MARKER (new_pos
);
745 CHECK_NUMBER_COERCE_MARKER (old_pos
);
747 fwd
= (XFASTINT (new_pos
) > XFASTINT (old_pos
));
750 field_bound
= Ffield_end (old_pos
, escape_from_edge
, new_pos
);
752 field_bound
= Ffield_beginning (old_pos
, escape_from_edge
, new_pos
);
754 if (/* See if ESCAPE_FROM_EDGE caused FIELD_BOUND to jump to the
755 other side of NEW_POS, which would mean that NEW_POS is
756 already acceptable, and it's not necessary to constrain it
758 ((XFASTINT (field_bound
) < XFASTINT (new_pos
)) ? fwd
: !fwd
)
759 /* NEW_POS should be constrained, but only if either
760 ONLY_IN_LINE is nil (in which case any constraint is OK),
761 or NEW_POS and FIELD_BOUND are on the same line (in which
762 case the constraint is OK even if ONLY_IN_LINE is non-nil). */
763 && (NILP (only_in_line
)
764 /* This is the ONLY_IN_LINE case, check that NEW_POS and
765 FIELD_BOUND are on the same line by seeing whether
766 there's an intervening newline or not. */
767 || (scan_buffer ('\n',
768 XFASTINT (new_pos
), XFASTINT (field_bound
),
769 fwd
? -1 : 1, &shortage
, 1),
771 /* Constrain NEW_POS to FIELD_BOUND. */
772 new_pos
= field_bound
;
774 if (orig_point
&& XFASTINT (new_pos
) != orig_point
)
775 /* The NEW_POS argument was originally nil, so automatically set PT. */
776 SET_PT (XFASTINT (new_pos
));
783 DEFUN ("line-beginning-position",
784 Fline_beginning_position
, Sline_beginning_position
, 0, 1, 0,
785 doc
: /* Return the character position of the first character on the current line.
786 With argument N not nil or 1, move forward N - 1 lines first.
787 If scan reaches end of buffer, return that position.
789 The scan does not cross a field boundary unless doing so would move
790 beyond there to a different line; if N is nil or 1, and scan starts at a
791 field boundary, the scan stops as soon as it starts. To ignore field
792 boundaries bind `inhibit-field-text-motion' to t.
794 This function does not move point. */)
798 int orig
, orig_byte
, end
;
807 Fforward_line (make_number (XINT (n
) - 1));
810 SET_PT_BOTH (orig
, orig_byte
);
812 /* Return END constrained to the current input field. */
813 return Fconstrain_to_field (make_number (end
), make_number (orig
),
814 XINT (n
) != 1 ? Qt
: Qnil
,
818 DEFUN ("line-end-position", Fline_end_position
, Sline_end_position
, 0, 1, 0,
819 doc
: /* Return the character position of the last character on the current line.
820 With argument N not nil or 1, move forward N - 1 lines first.
821 If scan reaches end of buffer, return that position.
823 The scan does not cross a field boundary unless doing so would move
824 beyond there to a different line; if N is nil or 1, and scan starts at a
825 field boundary, the scan stops as soon as it starts. To ignore field
826 boundaries bind `inhibit-field-text-motion' to t.
828 This function does not move point. */)
840 end_pos
= find_before_next_newline (orig
, 0, XINT (n
) - (XINT (n
) <= 0));
842 /* Return END_POS constrained to the current input field. */
843 return Fconstrain_to_field (make_number (end_pos
), make_number (orig
),
849 save_excursion_save ()
851 int visible
= (XBUFFER (XWINDOW (selected_window
)->buffer
)
854 return Fcons (Fpoint_marker (),
855 Fcons (Fcopy_marker (current_buffer
->mark
, Qnil
),
856 Fcons (visible
? Qt
: Qnil
,
857 Fcons (current_buffer
->mark_active
,
862 save_excursion_restore (info
)
865 Lisp_Object tem
, tem1
, omark
, nmark
;
866 struct gcpro gcpro1
, gcpro2
, gcpro3
;
869 tem
= Fmarker_buffer (XCAR (info
));
870 /* If buffer being returned to is now deleted, avoid error */
871 /* Otherwise could get error here while unwinding to top level
873 /* In that case, Fmarker_buffer returns nil now. */
877 omark
= nmark
= Qnil
;
878 GCPRO3 (info
, omark
, nmark
);
885 unchain_marker (XMARKER (tem
));
890 omark
= Fmarker_position (current_buffer
->mark
);
891 Fset_marker (current_buffer
->mark
, tem
, Fcurrent_buffer ());
892 nmark
= Fmarker_position (tem
);
893 unchain_marker (XMARKER (tem
));
897 visible_p
= !NILP (XCAR (info
));
899 #if 0 /* We used to make the current buffer visible in the selected window
900 if that was true previously. That avoids some anomalies.
901 But it creates others, and it wasn't documented, and it is simpler
902 and cleaner never to alter the window/buffer connections. */
905 && current_buffer
!= XBUFFER (XWINDOW (selected_window
)->buffer
))
906 Fswitch_to_buffer (Fcurrent_buffer (), Qnil
);
912 tem1
= current_buffer
->mark_active
;
913 current_buffer
->mark_active
= tem
;
915 if (!NILP (Vrun_hooks
))
917 /* If mark is active now, and either was not active
918 or was at a different place, run the activate hook. */
919 if (! NILP (current_buffer
->mark_active
))
921 if (! EQ (omark
, nmark
))
922 call1 (Vrun_hooks
, intern ("activate-mark-hook"));
924 /* If mark has ceased to be active, run deactivate hook. */
925 else if (! NILP (tem1
))
926 call1 (Vrun_hooks
, intern ("deactivate-mark-hook"));
929 /* If buffer was visible in a window, and a different window was
930 selected, and the old selected window is still showing this
931 buffer, restore point in that window. */
934 && !EQ (tem
, selected_window
)
935 && (tem1
= XWINDOW (tem
)->buffer
,
936 (/* Window is live... */
938 /* ...and it shows the current buffer. */
939 && XBUFFER (tem1
) == current_buffer
)))
940 Fset_window_point (tem
, make_number (PT
));
946 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
947 doc
: /* Save point, mark, and current buffer; execute BODY; restore those things.
948 Executes BODY just like `progn'.
949 The values of point, mark and the current buffer are restored
950 even in case of abnormal exit (throw or error).
951 The state of activation of the mark is also restored.
953 This construct does not save `deactivate-mark', and therefore
954 functions that change the buffer will still cause deactivation
955 of the mark at the end of the command. To prevent that, bind
956 `deactivate-mark' with `let'.
958 usage: (save-excursion &rest BODY) */)
962 register Lisp_Object val
;
963 int count
= SPECPDL_INDEX ();
965 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
968 return unbind_to (count
, val
);
971 DEFUN ("save-current-buffer", Fsave_current_buffer
, Ssave_current_buffer
, 0, UNEVALLED
, 0,
972 doc
: /* Save the current buffer; execute BODY; restore the current buffer.
973 Executes BODY just like `progn'.
974 usage: (save-current-buffer &rest BODY) */)
979 int count
= SPECPDL_INDEX ();
981 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
984 return unbind_to (count
, val
);
987 DEFUN ("buffer-size", Fbufsize
, Sbufsize
, 0, 1, 0,
988 doc
: /* Return the number of characters in the current buffer.
989 If BUFFER, return the number of characters in that buffer instead. */)
994 return make_number (Z
- BEG
);
997 CHECK_BUFFER (buffer
);
998 return make_number (BUF_Z (XBUFFER (buffer
))
999 - BUF_BEG (XBUFFER (buffer
)));
1003 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
1004 doc
: /* Return the minimum permissible value of point in the current buffer.
1005 This is 1, unless narrowing (a buffer restriction) is in effect. */)
1009 XSETFASTINT (temp
, BEGV
);
1013 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
1014 doc
: /* Return a marker to the minimum permissible value of point in this buffer.
1015 This is the beginning, unless narrowing (a buffer restriction) is in effect. */)
1018 return buildmark (BEGV
, BEGV_BYTE
);
1021 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
1022 doc
: /* Return the maximum permissible value of point in the current buffer.
1023 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1024 is in effect, in which case it is less. */)
1028 XSETFASTINT (temp
, ZV
);
1032 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
1033 doc
: /* Return a marker to the maximum permissible value of point in this buffer.
1034 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1035 is in effect, in which case it is less. */)
1038 return buildmark (ZV
, ZV_BYTE
);
1041 DEFUN ("gap-position", Fgap_position
, Sgap_position
, 0, 0, 0,
1042 doc
: /* Return the position of the gap, in the current buffer.
1043 See also `gap-size'. */)
1047 XSETFASTINT (temp
, GPT
);
1051 DEFUN ("gap-size", Fgap_size
, Sgap_size
, 0, 0, 0,
1052 doc
: /* Return the size of the current buffer's gap.
1053 See also `gap-position'. */)
1057 XSETFASTINT (temp
, GAP_SIZE
);
1061 DEFUN ("position-bytes", Fposition_bytes
, Sposition_bytes
, 1, 1, 0,
1062 doc
: /* Return the byte position for character position POSITION.
1063 If POSITION is out of range, the value is nil. */)
1065 Lisp_Object position
;
1067 CHECK_NUMBER_COERCE_MARKER (position
);
1068 if (XINT (position
) < BEG
|| XINT (position
) > Z
)
1070 return make_number (CHAR_TO_BYTE (XINT (position
)));
1073 DEFUN ("byte-to-position", Fbyte_to_position
, Sbyte_to_position
, 1, 1, 0,
1074 doc
: /* Return the character position for byte position BYTEPOS.
1075 If BYTEPOS is out of range, the value is nil. */)
1077 Lisp_Object bytepos
;
1079 CHECK_NUMBER (bytepos
);
1080 if (XINT (bytepos
) < BEG_BYTE
|| XINT (bytepos
) > Z_BYTE
)
1082 return make_number (BYTE_TO_CHAR (XINT (bytepos
)));
1085 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
1086 doc
: /* Return the character following point, as a number.
1087 At the end of the buffer or accessible region, return 0. */)
1092 XSETFASTINT (temp
, 0);
1094 XSETFASTINT (temp
, FETCH_CHAR (PT_BYTE
));
1098 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
1099 doc
: /* Return the character preceding point, as a number.
1100 At the beginning of the buffer or accessible region, return 0. */)
1105 XSETFASTINT (temp
, 0);
1106 else if (!NILP (current_buffer
->enable_multibyte_characters
))
1110 XSETFASTINT (temp
, FETCH_CHAR (pos
));
1113 XSETFASTINT (temp
, FETCH_BYTE (PT_BYTE
- 1));
1117 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
1118 doc
: /* Return t if point is at the beginning of the buffer.
1119 If the buffer is narrowed, this means the beginning of the narrowed part. */)
1127 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
1128 doc
: /* Return t if point is at the end of the buffer.
1129 If the buffer is narrowed, this means the end of the narrowed part. */)
1137 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
1138 doc
: /* Return t if point is at the beginning of a line. */)
1141 if (PT
== BEGV
|| FETCH_BYTE (PT_BYTE
- 1) == '\n')
1146 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
1147 doc
: /* Return t if point is at the end of a line.
1148 `End of a line' includes point being at the end of the buffer. */)
1151 if (PT
== ZV
|| FETCH_BYTE (PT_BYTE
) == '\n')
1156 DEFUN ("char-after", Fchar_after
, Schar_after
, 0, 1, 0,
1157 doc
: /* Return character in current buffer at position POS.
1158 POS is an integer or a marker and defaults to point.
1159 If POS is out of range, the value is nil. */)
1163 register int pos_byte
;
1168 XSETFASTINT (pos
, PT
);
1173 pos_byte
= marker_byte_position (pos
);
1174 if (pos_byte
< BEGV_BYTE
|| pos_byte
>= ZV_BYTE
)
1179 CHECK_NUMBER_COERCE_MARKER (pos
);
1180 if (XINT (pos
) < BEGV
|| XINT (pos
) >= ZV
)
1183 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1186 return make_number (FETCH_CHAR (pos_byte
));
1189 DEFUN ("char-before", Fchar_before
, Schar_before
, 0, 1, 0,
1190 doc
: /* Return character in current buffer preceding position POS.
1191 POS is an integer or a marker and defaults to point.
1192 If POS is out of range, the value is nil. */)
1196 register Lisp_Object val
;
1197 register int pos_byte
;
1202 XSETFASTINT (pos
, PT
);
1207 pos_byte
= marker_byte_position (pos
);
1209 if (pos_byte
<= BEGV_BYTE
|| pos_byte
> ZV_BYTE
)
1214 CHECK_NUMBER_COERCE_MARKER (pos
);
1216 if (XINT (pos
) <= BEGV
|| XINT (pos
) > ZV
)
1219 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1222 if (!NILP (current_buffer
->enable_multibyte_characters
))
1225 XSETFASTINT (val
, FETCH_CHAR (pos_byte
));
1230 XSETFASTINT (val
, FETCH_BYTE (pos_byte
));
1235 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 1, 0,
1236 doc
: /* Return the name under which the user logged in, as a string.
1237 This is based on the effective uid, not the real uid.
1238 Also, if the environment variables LOGNAME or USER are set,
1239 that determines the value of this function.
1241 If optional argument UID is an integer, return the login name of the user
1242 with that uid, or nil if there is no such user. */)
1248 /* Set up the user name info if we didn't do it before.
1249 (That can happen if Emacs is dumpable
1250 but you decide to run `temacs -l loadup' and not dump. */
1251 if (INTEGERP (Vuser_login_name
))
1255 return Vuser_login_name
;
1258 pw
= (struct passwd
*) getpwuid (XINT (uid
));
1259 return (pw
? build_string (pw
->pw_name
) : Qnil
);
1262 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
1264 doc
: /* Return the name of the user's real uid, as a string.
1265 This ignores the environment variables LOGNAME and USER, so it differs from
1266 `user-login-name' when running under `su'. */)
1269 /* Set up the user name info if we didn't do it before.
1270 (That can happen if Emacs is dumpable
1271 but you decide to run `temacs -l loadup' and not dump. */
1272 if (INTEGERP (Vuser_login_name
))
1274 return Vuser_real_login_name
;
1277 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
1278 doc
: /* Return the effective uid of Emacs.
1279 Value is an integer or float, depending on the value. */)
1282 return make_fixnum_or_float (geteuid ());
1285 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
1286 doc
: /* Return the real uid of Emacs.
1287 Value is an integer or float, depending on the value. */)
1290 return make_fixnum_or_float (getuid ());
1293 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 1, 0,
1294 doc
: /* Return the full name of the user logged in, as a string.
1295 If the full name corresponding to Emacs's userid is not known,
1298 If optional argument UID is an integer or float, return the full name
1299 of the user with that uid, or nil if there is no such user.
1300 If UID is a string, return the full name of the user with that login
1301 name, or nil if there is no such user. */)
1306 register unsigned char *p
, *q
;
1310 return Vuser_full_name
;
1311 else if (NUMBERP (uid
))
1312 pw
= (struct passwd
*) getpwuid ((uid_t
) XFLOATINT (uid
));
1313 else if (STRINGP (uid
))
1314 pw
= (struct passwd
*) getpwnam (SDATA (uid
));
1316 error ("Invalid UID specification");
1321 p
= (unsigned char *) USER_FULL_NAME
;
1322 /* Chop off everything after the first comma. */
1323 q
= (unsigned char *) index (p
, ',');
1324 full
= make_string (p
, q
? q
- p
: strlen (p
));
1326 #ifdef AMPERSAND_FULL_NAME
1328 q
= (unsigned char *) index (p
, '&');
1329 /* Substitute the login name for the &, upcasing the first character. */
1332 register unsigned char *r
;
1335 login
= Fuser_login_name (make_number (pw
->pw_uid
));
1336 r
= (unsigned char *) alloca (strlen (p
) + SCHARS (login
) + 1);
1337 bcopy (p
, r
, q
- p
);
1339 strcat (r
, SDATA (login
));
1340 r
[q
- p
] = UPCASE (r
[q
- p
]);
1342 full
= build_string (r
);
1344 #endif /* AMPERSAND_FULL_NAME */
1349 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
1350 doc
: /* Return the name of the machine you are running on, as a string. */)
1353 return Vsystem_name
;
1356 /* For the benefit of callers who don't want to include lisp.h */
1361 if (STRINGP (Vsystem_name
))
1362 return (char *) SDATA (Vsystem_name
);
1367 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
1368 doc
: /* Return the process ID of Emacs, as an integer. */)
1371 return make_number (getpid ());
1374 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
1375 doc
: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
1376 The time is returned as a list of three integers. The first has the
1377 most significant 16 bits of the seconds, while the second has the
1378 least significant 16 bits. The third integer gives the microsecond
1381 The microsecond count is zero on systems that do not provide
1382 resolution finer than a second. */)
1386 Lisp_Object result
[3];
1389 XSETINT (result
[0], (EMACS_SECS (t
) >> 16) & 0xffff);
1390 XSETINT (result
[1], (EMACS_SECS (t
) >> 0) & 0xffff);
1391 XSETINT (result
[2], EMACS_USECS (t
));
1393 return Flist (3, result
);
1396 DEFUN ("get-internal-run-time", Fget_internal_run_time
, Sget_internal_run_time
,
1398 doc
: /* Return the current run time used by Emacs.
1399 The time is returned as a list of three integers. The first has the
1400 most significant 16 bits of the seconds, while the second has the
1401 least significant 16 bits. The third integer gives the microsecond
1404 On systems that can't determine the run time, get-internal-run-time
1405 does the same thing as current-time. The microsecond count is zero on
1406 systems that do not provide resolution finer than a second. */)
1409 #ifdef HAVE_GETRUSAGE
1410 struct rusage usage
;
1411 Lisp_Object result
[3];
1414 if (getrusage (RUSAGE_SELF
, &usage
) < 0)
1415 /* This shouldn't happen. What action is appropriate? */
1416 Fsignal (Qerror
, Qnil
);
1418 /* Sum up user time and system time. */
1419 secs
= usage
.ru_utime
.tv_sec
+ usage
.ru_stime
.tv_sec
;
1420 usecs
= usage
.ru_utime
.tv_usec
+ usage
.ru_stime
.tv_usec
;
1421 if (usecs
>= 1000000)
1427 XSETINT (result
[0], (secs
>> 16) & 0xffff);
1428 XSETINT (result
[1], (secs
>> 0) & 0xffff);
1429 XSETINT (result
[2], usecs
);
1431 return Flist (3, result
);
1433 return Fcurrent_time ();
1439 lisp_time_argument (specified_time
, result
, usec
)
1440 Lisp_Object specified_time
;
1444 if (NILP (specified_time
))
1451 *usec
= EMACS_USECS (t
);
1452 *result
= EMACS_SECS (t
);
1456 return time (result
) != -1;
1460 Lisp_Object high
, low
;
1461 high
= Fcar (specified_time
);
1462 CHECK_NUMBER (high
);
1463 low
= Fcdr (specified_time
);
1468 Lisp_Object usec_l
= Fcdr (low
);
1470 usec_l
= Fcar (usec_l
);
1475 CHECK_NUMBER (usec_l
);
1476 *usec
= XINT (usec_l
);
1484 *result
= (XINT (high
) << 16) + (XINT (low
) & 0xffff);
1485 return *result
>> 16 == XINT (high
);
1489 DEFUN ("float-time", Ffloat_time
, Sfloat_time
, 0, 1, 0,
1490 doc
: /* Return the current time, as a float number of seconds since the epoch.
1491 If SPECIFIED-TIME is given, it is the time to convert to float
1492 instead of the current time. The argument should have the form
1493 (HIGH LOW . IGNORED). Thus, you can use times obtained from
1494 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
1495 have the form (HIGH . LOW), but this is considered obsolete.
1497 WARNING: Since the result is floating point, it may not be exact.
1498 Do not use this function if precise time stamps are required. */)
1500 Lisp_Object specified_time
;
1505 if (! lisp_time_argument (specified_time
, &sec
, &usec
))
1506 error ("Invalid time specification");
1508 return make_float ((sec
* 1e6
+ usec
) / 1e6
);
1511 /* Write information into buffer S of size MAXSIZE, according to the
1512 FORMAT of length FORMAT_LEN, using time information taken from *TP.
1513 Default to Universal Time if UT is nonzero, local time otherwise.
1514 Return the number of bytes written, not including the terminating
1515 '\0'. If S is NULL, nothing will be written anywhere; so to
1516 determine how many bytes would be written, use NULL for S and
1517 ((size_t) -1) for MAXSIZE.
1519 This function behaves like emacs_strftimeu, except it allows null
1522 emacs_memftimeu (s
, maxsize
, format
, format_len
, tp
, ut
)
1527 const struct tm
*tp
;
1532 /* Loop through all the null-terminated strings in the format
1533 argument. Normally there's just one null-terminated string, but
1534 there can be arbitrarily many, concatenated together, if the
1535 format contains '\0' bytes. emacs_strftimeu stops at the first
1536 '\0' byte so we must invoke it separately for each such string. */
1545 result
= emacs_strftimeu (s
, maxsize
, format
, tp
, ut
);
1549 if (result
== 0 && s
[0] != '\0')
1554 maxsize
-= result
+ 1;
1556 len
= strlen (format
);
1557 if (len
== format_len
)
1561 format_len
-= len
+ 1;
1565 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 1, 3, 0,
1566 doc
: /* Use FORMAT-STRING to format the time TIME, or now if omitted.
1567 TIME is specified as (HIGH LOW . IGNORED), as returned by
1568 `current-time' or `file-attributes'. The obsolete form (HIGH . LOW)
1569 is also still accepted.
1570 The third, optional, argument UNIVERSAL, if non-nil, means describe TIME
1571 as Universal Time; nil means describe TIME in the local time zone.
1572 The value is a copy of FORMAT-STRING, but with certain constructs replaced
1573 by text that describes the specified date and time in TIME:
1575 %Y is the year, %y within the century, %C the century.
1576 %G is the year corresponding to the ISO week, %g within the century.
1577 %m is the numeric month.
1578 %b and %h are the locale's abbreviated month name, %B the full name.
1579 %d is the day of the month, zero-padded, %e is blank-padded.
1580 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
1581 %a is the locale's abbreviated name of the day of week, %A the full name.
1582 %U is the week number starting on Sunday, %W starting on Monday,
1583 %V according to ISO 8601.
1584 %j is the day of the year.
1586 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
1587 only blank-padded, %l is like %I blank-padded.
1588 %p is the locale's equivalent of either AM or PM.
1591 %Z is the time zone name, %z is the numeric form.
1592 %s is the number of seconds since 1970-01-01 00:00:00 +0000.
1594 %c is the locale's date and time format.
1595 %x is the locale's "preferred" date format.
1596 %D is like "%m/%d/%y".
1598 %R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
1599 %X is the locale's "preferred" time format.
1601 Finally, %n is a newline, %t is a tab, %% is a literal %.
1603 Certain flags and modifiers are available with some format controls.
1604 The flags are `_', `-', `^' and `#'. For certain characters X,
1605 %_X is like %X, but padded with blanks; %-X is like %X,
1606 but without padding. %^X is like %X, but with all textual
1607 characters up-cased; %#X is like %X, but with letter-case of
1608 all textual characters reversed.
1609 %NX (where N stands for an integer) is like %X,
1610 but takes up at least N (a number) positions.
1611 The modifiers are `E' and `O'. For certain characters X,
1612 %EX is a locale's alternative version of %X;
1613 %OX is like %X, but uses the locale's number symbols.
1615 For example, to produce full ISO 8601 format, use "%Y-%m-%dT%T%z". */)
1616 (format_string
, time
, universal
)
1617 Lisp_Object format_string
, time
, universal
;
1622 int ut
= ! NILP (universal
);
1624 CHECK_STRING (format_string
);
1626 if (! lisp_time_argument (time
, &value
, NULL
))
1627 error ("Invalid time specification");
1629 format_string
= code_convert_string_norecord (format_string
,
1630 Vlocale_coding_system
, 1);
1632 /* This is probably enough. */
1633 size
= SBYTES (format_string
) * 6 + 50;
1635 tm
= ut
? gmtime (&value
) : localtime (&value
);
1637 error ("Specified time is not representable");
1639 synchronize_system_time_locale ();
1643 char *buf
= (char *) alloca (size
+ 1);
1647 result
= emacs_memftimeu (buf
, size
, SDATA (format_string
),
1648 SBYTES (format_string
),
1650 if ((result
> 0 && result
< size
) || (result
== 0 && buf
[0] == '\0'))
1651 return code_convert_string_norecord (make_string (buf
, result
),
1652 Vlocale_coding_system
, 0);
1654 /* If buffer was too small, make it bigger and try again. */
1655 result
= emacs_memftimeu (NULL
, (size_t) -1,
1656 SDATA (format_string
),
1657 SBYTES (format_string
),
1663 DEFUN ("decode-time", Fdecode_time
, Sdecode_time
, 0, 1, 0,
1664 doc
: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST ZONE).
1665 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED),
1666 as from `current-time' and `file-attributes', or `nil' to use the
1667 current time. The obsolete form (HIGH . LOW) is also still accepted.
1668 The list has the following nine members: SEC is an integer between 0
1669 and 60; SEC is 60 for a leap second, which only some operating systems
1670 support. MINUTE is an integer between 0 and 59. HOUR is an integer
1671 between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
1672 integer between 1 and 12. YEAR is an integer indicating the
1673 four-digit year. DOW is the day of week, an integer between 0 and 6,
1674 where 0 is Sunday. DST is t if daylight savings time is effect,
1675 otherwise nil. ZONE is an integer indicating the number of seconds
1676 east of Greenwich. (Note that Common Lisp has different meanings for
1679 Lisp_Object specified_time
;
1683 struct tm
*decoded_time
;
1684 Lisp_Object list_args
[9];
1686 if (! lisp_time_argument (specified_time
, &time_spec
, NULL
))
1687 error ("Invalid time specification");
1689 decoded_time
= localtime (&time_spec
);
1691 error ("Specified time is not representable");
1692 XSETFASTINT (list_args
[0], decoded_time
->tm_sec
);
1693 XSETFASTINT (list_args
[1], decoded_time
->tm_min
);
1694 XSETFASTINT (list_args
[2], decoded_time
->tm_hour
);
1695 XSETFASTINT (list_args
[3], decoded_time
->tm_mday
);
1696 XSETFASTINT (list_args
[4], decoded_time
->tm_mon
+ 1);
1697 XSETINT (list_args
[5], decoded_time
->tm_year
+ 1900);
1698 XSETFASTINT (list_args
[6], decoded_time
->tm_wday
);
1699 list_args
[7] = (decoded_time
->tm_isdst
)? Qt
: Qnil
;
1701 /* Make a copy, in case gmtime modifies the struct. */
1702 save_tm
= *decoded_time
;
1703 decoded_time
= gmtime (&time_spec
);
1704 if (decoded_time
== 0)
1705 list_args
[8] = Qnil
;
1707 XSETINT (list_args
[8], tm_diff (&save_tm
, decoded_time
));
1708 return Flist (9, list_args
);
1711 DEFUN ("encode-time", Fencode_time
, Sencode_time
, 6, MANY
, 0,
1712 doc
: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
1713 This is the reverse operation of `decode-time', which see.
1714 ZONE defaults to the current time zone rule. This can
1715 be a string or t (as from `set-time-zone-rule'), or it can be a list
1716 \(as from `current-time-zone') or an integer (as from `decode-time')
1717 applied without consideration for daylight savings time.
1719 You can pass more than 7 arguments; then the first six arguments
1720 are used as SECOND through YEAR, and the *last* argument is used as ZONE.
1721 The intervening arguments are ignored.
1722 This feature lets (apply 'encode-time (decode-time ...)) work.
1724 Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed;
1725 for example, a DAY of 0 means the day preceding the given month.
1726 Year numbers less than 100 are treated just like other year numbers.
1727 If you want them to stand for years in this century, you must do that yourself.
1729 Years before 1970 are not guaranteed to work. On some systems,
1730 year values as low as 1901 do work.
1732 usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
1735 register Lisp_Object
*args
;
1739 Lisp_Object zone
= (nargs
> 6 ? args
[nargs
- 1] : Qnil
);
1741 CHECK_NUMBER (args
[0]); /* second */
1742 CHECK_NUMBER (args
[1]); /* minute */
1743 CHECK_NUMBER (args
[2]); /* hour */
1744 CHECK_NUMBER (args
[3]); /* day */
1745 CHECK_NUMBER (args
[4]); /* month */
1746 CHECK_NUMBER (args
[5]); /* year */
1748 tm
.tm_sec
= XINT (args
[0]);
1749 tm
.tm_min
= XINT (args
[1]);
1750 tm
.tm_hour
= XINT (args
[2]);
1751 tm
.tm_mday
= XINT (args
[3]);
1752 tm
.tm_mon
= XINT (args
[4]) - 1;
1753 tm
.tm_year
= XINT (args
[5]) - 1900;
1759 time
= mktime (&tm
);
1764 char **oldenv
= environ
, **newenv
;
1768 else if (STRINGP (zone
))
1769 tzstring
= (char *) SDATA (zone
);
1770 else if (INTEGERP (zone
))
1772 int abszone
= abs (XINT (zone
));
1773 sprintf (tzbuf
, "XXX%s%d:%02d:%02d", "-" + (XINT (zone
) < 0),
1774 abszone
/ (60*60), (abszone
/60) % 60, abszone
% 60);
1778 error ("Invalid time zone specification");
1780 /* Set TZ before calling mktime; merely adjusting mktime's returned
1781 value doesn't suffice, since that would mishandle leap seconds. */
1782 set_time_zone_rule (tzstring
);
1784 time
= mktime (&tm
);
1786 /* Restore TZ to previous value. */
1790 #ifdef LOCALTIME_CACHE
1795 if (time
== (time_t) -1)
1796 error ("Specified time is not representable");
1798 return make_time (time
);
1801 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
1802 doc
: /* Return the current time, as a human-readable string.
1803 Programs can use this function to decode a time,
1804 since the number of columns in each field is fixed.
1805 The format is `Sun Sep 16 01:03:52 1973'.
1806 However, see also the functions `decode-time' and `format-time-string'
1807 which provide a much more powerful and general facility.
1809 If SPECIFIED-TIME is given, it is a time to format instead of the
1810 current time. The argument should have the form (HIGH LOW . IGNORED).
1811 Thus, you can use times obtained from `current-time' and from
1812 `file-attributes'. SPECIFIED-TIME can also have the form (HIGH . LOW),
1813 but this is considered obsolete. */)
1815 Lisp_Object specified_time
;
1821 if (! lisp_time_argument (specified_time
, &value
, NULL
))
1823 tem
= (char *) ctime (&value
);
1825 strncpy (buf
, tem
, 24);
1828 return build_string (buf
);
1831 #define TM_YEAR_BASE 1900
1833 /* Yield A - B, measured in seconds.
1834 This function is copied from the GNU C Library. */
1839 /* Compute intervening leap days correctly even if year is negative.
1840 Take care to avoid int overflow in leap day calculations,
1841 but it's OK to assume that A and B are close to each other. */
1842 int a4
= (a
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (a
->tm_year
& 3);
1843 int b4
= (b
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (b
->tm_year
& 3);
1844 int a100
= a4
/ 25 - (a4
% 25 < 0);
1845 int b100
= b4
/ 25 - (b4
% 25 < 0);
1846 int a400
= a100
>> 2;
1847 int b400
= b100
>> 2;
1848 int intervening_leap_days
= (a4
- b4
) - (a100
- b100
) + (a400
- b400
);
1849 int years
= a
->tm_year
- b
->tm_year
;
1850 int days
= (365 * years
+ intervening_leap_days
1851 + (a
->tm_yday
- b
->tm_yday
));
1852 return (60 * (60 * (24 * days
+ (a
->tm_hour
- b
->tm_hour
))
1853 + (a
->tm_min
- b
->tm_min
))
1854 + (a
->tm_sec
- b
->tm_sec
));
1857 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
1858 doc
: /* Return the offset and name for the local time zone.
1859 This returns a list of the form (OFFSET NAME).
1860 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
1861 A negative value means west of Greenwich.
1862 NAME is a string giving the name of the time zone.
1863 If SPECIFIED-TIME is given, the time zone offset is determined from it
1864 instead of using the current time. The argument should have the form
1865 (HIGH LOW . IGNORED). Thus, you can use times obtained from
1866 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
1867 have the form (HIGH . LOW), but this is considered obsolete.
1869 Some operating systems cannot provide all this information to Emacs;
1870 in this case, `current-time-zone' returns a list containing nil for
1871 the data it can't find. */)
1873 Lisp_Object specified_time
;
1879 if (lisp_time_argument (specified_time
, &value
, NULL
)
1880 && (t
= gmtime (&value
)) != 0
1881 && (gmt
= *t
, t
= localtime (&value
)) != 0)
1883 int offset
= tm_diff (t
, &gmt
);
1888 s
= (char *)t
->tm_zone
;
1889 #else /* not HAVE_TM_ZONE */
1891 if (t
->tm_isdst
== 0 || t
->tm_isdst
== 1)
1892 s
= tzname
[t
->tm_isdst
];
1894 #endif /* not HAVE_TM_ZONE */
1896 #if defined HAVE_TM_ZONE || defined HAVE_TZNAME
1899 /* On Japanese w32, we can get a Japanese string as time
1900 zone name. Don't accept that. */
1902 for (p
= s
; *p
&& (isalnum ((unsigned char)*p
) || *p
== ' '); ++p
)
1911 /* No local time zone name is available; use "+-NNNN" instead. */
1912 int am
= (offset
< 0 ? -offset
: offset
) / 60;
1913 sprintf (buf
, "%c%02d%02d", (offset
< 0 ? '-' : '+'), am
/60, am
%60);
1916 return Fcons (make_number (offset
), Fcons (build_string (s
), Qnil
));
1919 return Fmake_list (make_number (2), Qnil
);
1922 /* This holds the value of `environ' produced by the previous
1923 call to Fset_time_zone_rule, or 0 if Fset_time_zone_rule
1924 has never been called. */
1925 static char **environbuf
;
1927 DEFUN ("set-time-zone-rule", Fset_time_zone_rule
, Sset_time_zone_rule
, 1, 1, 0,
1928 doc
: /* Set the local time zone using TZ, a string specifying a time zone rule.
1929 If TZ is nil, use implementation-defined default time zone information.
1930 If TZ is t, use Universal Time. */)
1938 else if (EQ (tz
, Qt
))
1943 tzstring
= (char *) SDATA (tz
);
1946 set_time_zone_rule (tzstring
);
1949 environbuf
= environ
;
1954 #ifdef LOCALTIME_CACHE
1956 /* These two values are known to load tz files in buggy implementations,
1957 i.e. Solaris 1 executables running under either Solaris 1 or Solaris 2.
1958 Their values shouldn't matter in non-buggy implementations.
1959 We don't use string literals for these strings,
1960 since if a string in the environment is in readonly
1961 storage, it runs afoul of bugs in SVR4 and Solaris 2.3.
1962 See Sun bugs 1113095 and 1114114, ``Timezone routines
1963 improperly modify environment''. */
1965 static char set_time_zone_rule_tz1
[] = "TZ=GMT+0";
1966 static char set_time_zone_rule_tz2
[] = "TZ=GMT+1";
1970 /* Set the local time zone rule to TZSTRING.
1971 This allocates memory into `environ', which it is the caller's
1972 responsibility to free. */
1975 set_time_zone_rule (tzstring
)
1979 char **from
, **to
, **newenv
;
1981 /* Make the ENVIRON vector longer with room for TZSTRING. */
1982 for (from
= environ
; *from
; from
++)
1984 envptrs
= from
- environ
+ 2;
1985 newenv
= to
= (char **) xmalloc (envptrs
* sizeof (char *)
1986 + (tzstring
? strlen (tzstring
) + 4 : 0));
1988 /* Add TZSTRING to the end of environ, as a value for TZ. */
1991 char *t
= (char *) (to
+ envptrs
);
1993 strcat (t
, tzstring
);
1997 /* Copy the old environ vector elements into NEWENV,
1998 but don't copy the TZ variable.
1999 So we have only one definition of TZ, which came from TZSTRING. */
2000 for (from
= environ
; *from
; from
++)
2001 if (strncmp (*from
, "TZ=", 3) != 0)
2007 /* If we do have a TZSTRING, NEWENV points to the vector slot where
2008 the TZ variable is stored. If we do not have a TZSTRING,
2009 TO points to the vector slot which has the terminating null. */
2011 #ifdef LOCALTIME_CACHE
2013 /* In SunOS 4.1.3_U1 and 4.1.4, if TZ has a value like
2014 "US/Pacific" that loads a tz file, then changes to a value like
2015 "XXX0" that does not load a tz file, and then changes back to
2016 its original value, the last change is (incorrectly) ignored.
2017 Also, if TZ changes twice in succession to values that do
2018 not load a tz file, tzset can dump core (see Sun bug#1225179).
2019 The following code works around these bugs. */
2023 /* Temporarily set TZ to a value that loads a tz file
2024 and that differs from tzstring. */
2026 *newenv
= (strcmp (tzstring
, set_time_zone_rule_tz1
+ 3) == 0
2027 ? set_time_zone_rule_tz2
: set_time_zone_rule_tz1
);
2033 /* The implied tzstring is unknown, so temporarily set TZ to
2034 two different values that each load a tz file. */
2035 *to
= set_time_zone_rule_tz1
;
2038 *to
= set_time_zone_rule_tz2
;
2043 /* Now TZ has the desired value, and tzset can be invoked safely. */
2050 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
2051 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
2052 type of object is Lisp_String). INHERIT is passed to
2053 INSERT_FROM_STRING_FUNC as the last argument. */
2056 general_insert_function (insert_func
, insert_from_string_func
,
2057 inherit
, nargs
, args
)
2058 void (*insert_func
) P_ ((const unsigned char *, int));
2059 void (*insert_from_string_func
) P_ ((Lisp_Object
, int, int, int, int, int));
2061 register Lisp_Object
*args
;
2063 register int argnum
;
2064 register Lisp_Object val
;
2066 for (argnum
= 0; argnum
< nargs
; argnum
++)
2072 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2075 if (!NILP (current_buffer
->enable_multibyte_characters
))
2076 len
= CHAR_STRING (XFASTINT (val
), str
);
2079 str
[0] = (SINGLE_BYTE_CHAR_P (XINT (val
))
2081 : multibyte_char_to_unibyte (XINT (val
), Qnil
));
2084 (*insert_func
) (str
, len
);
2086 else if (STRINGP (val
))
2088 (*insert_from_string_func
) (val
, 0, 0,
2095 val
= wrong_type_argument (Qchar_or_string_p
, val
);
2109 /* Callers passing one argument to Finsert need not gcpro the
2110 argument "array", since the only element of the array will
2111 not be used after calling insert or insert_from_string, so
2112 we don't care if it gets trashed. */
2114 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
2115 doc
: /* Insert the arguments, either strings or characters, at point.
2116 Point and before-insertion markers move forward to end up
2117 after the inserted text.
2118 Any other markers at the point of insertion remain before the text.
2120 If the current buffer is multibyte, unibyte strings are converted
2121 to multibyte for insertion (see `string-make-multibyte').
2122 If the current buffer is unibyte, multibyte strings are converted
2123 to unibyte for insertion (see `string-make-unibyte').
2125 When operating on binary data, it may be necessary to preserve the
2126 original bytes of a unibyte string when inserting it into a multibyte
2127 buffer; to accomplish this, apply `string-as-multibyte' to the string
2128 and insert the result.
2130 usage: (insert &rest ARGS) */)
2133 register Lisp_Object
*args
;
2135 general_insert_function (insert
, insert_from_string
, 0, nargs
, args
);
2139 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
2141 doc
: /* Insert the arguments at point, inheriting properties from adjoining text.
2142 Point and before-insertion markers move forward to end up
2143 after the inserted text.
2144 Any other markers at the point of insertion remain before the text.
2146 If the current buffer is multibyte, unibyte strings are converted
2147 to multibyte for insertion (see `unibyte-char-to-multibyte').
2148 If the current buffer is unibyte, multibyte strings are converted
2149 to unibyte for insertion.
2151 usage: (insert-and-inherit &rest ARGS) */)
2154 register Lisp_Object
*args
;
2156 general_insert_function (insert_and_inherit
, insert_from_string
, 1,
2161 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
2162 doc
: /* Insert strings or characters at point, relocating markers after the text.
2163 Point and markers move forward to end up after the inserted text.
2165 If the current buffer is multibyte, unibyte strings are converted
2166 to multibyte for insertion (see `unibyte-char-to-multibyte').
2167 If the current buffer is unibyte, multibyte strings are converted
2168 to unibyte for insertion.
2170 usage: (insert-before-markers &rest ARGS) */)
2173 register Lisp_Object
*args
;
2175 general_insert_function (insert_before_markers
,
2176 insert_from_string_before_markers
, 0,
2181 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers
,
2182 Sinsert_and_inherit_before_markers
, 0, MANY
, 0,
2183 doc
: /* Insert text at point, relocating markers and inheriting properties.
2184 Point and markers move forward to end up after the inserted text.
2186 If the current buffer is multibyte, unibyte strings are converted
2187 to multibyte for insertion (see `unibyte-char-to-multibyte').
2188 If the current buffer is unibyte, multibyte strings are converted
2189 to unibyte for insertion.
2191 usage: (insert-before-markers-and-inherit &rest ARGS) */)
2194 register Lisp_Object
*args
;
2196 general_insert_function (insert_before_markers_and_inherit
,
2197 insert_from_string_before_markers
, 1,
2202 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 2, 3, 0,
2203 doc
: /* Insert COUNT (second arg) copies of CHARACTER (first arg).
2204 Both arguments are required.
2205 Point, and before-insertion markers, are relocated as in the function `insert'.
2206 The optional third arg INHERIT, if non-nil, says to inherit text properties
2207 from adjoining text, if those properties are sticky. */)
2208 (character
, count
, inherit
)
2209 Lisp_Object character
, count
, inherit
;
2211 register unsigned char *string
;
2212 register int strlen
;
2215 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2217 CHECK_NUMBER (character
);
2218 CHECK_NUMBER (count
);
2220 if (!NILP (current_buffer
->enable_multibyte_characters
))
2221 len
= CHAR_STRING (XFASTINT (character
), str
);
2223 str
[0] = XFASTINT (character
), len
= 1;
2224 n
= XINT (count
) * len
;
2227 strlen
= min (n
, 256 * len
);
2228 string
= (unsigned char *) alloca (strlen
);
2229 for (i
= 0; i
< strlen
; i
++)
2230 string
[i
] = str
[i
% len
];
2234 if (!NILP (inherit
))
2235 insert_and_inherit (string
, strlen
);
2237 insert (string
, strlen
);
2242 if (!NILP (inherit
))
2243 insert_and_inherit (string
, n
);
2251 /* Making strings from buffer contents. */
2253 /* Return a Lisp_String containing the text of the current buffer from
2254 START to END. If text properties are in use and the current buffer
2255 has properties in the range specified, the resulting string will also
2256 have them, if PROPS is nonzero.
2258 We don't want to use plain old make_string here, because it calls
2259 make_uninit_string, which can cause the buffer arena to be
2260 compacted. make_string has no way of knowing that the data has
2261 been moved, and thus copies the wrong data into the string. This
2262 doesn't effect most of the other users of make_string, so it should
2263 be left as is. But we should use this function when conjuring
2264 buffer substrings. */
2267 make_buffer_string (start
, end
, props
)
2271 int start_byte
= CHAR_TO_BYTE (start
);
2272 int end_byte
= CHAR_TO_BYTE (end
);
2274 return make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
);
2277 /* Return a Lisp_String containing the text of the current buffer from
2278 START / START_BYTE to END / END_BYTE.
2280 If text properties are in use and the current buffer
2281 has properties in the range specified, the resulting string will also
2282 have them, if PROPS is nonzero.
2284 We don't want to use plain old make_string here, because it calls
2285 make_uninit_string, which can cause the buffer arena to be
2286 compacted. make_string has no way of knowing that the data has
2287 been moved, and thus copies the wrong data into the string. This
2288 doesn't effect most of the other users of make_string, so it should
2289 be left as is. But we should use this function when conjuring
2290 buffer substrings. */
2293 make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
)
2294 int start
, start_byte
, end
, end_byte
;
2297 Lisp_Object result
, tem
, tem1
;
2299 if (start
< GPT
&& GPT
< end
)
2302 if (! NILP (current_buffer
->enable_multibyte_characters
))
2303 result
= make_uninit_multibyte_string (end
- start
, end_byte
- start_byte
);
2305 result
= make_uninit_string (end
- start
);
2306 bcopy (BYTE_POS_ADDR (start_byte
), SDATA (result
),
2307 end_byte
- start_byte
);
2309 /* If desired, update and copy the text properties. */
2312 update_buffer_properties (start
, end
);
2314 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
2315 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
2317 if (XINT (tem
) != end
|| !NILP (tem1
))
2318 copy_intervals_to_string (result
, current_buffer
, start
,
2325 /* Call Vbuffer_access_fontify_functions for the range START ... END
2326 in the current buffer, if necessary. */
2329 update_buffer_properties (start
, end
)
2332 /* If this buffer has some access functions,
2333 call them, specifying the range of the buffer being accessed. */
2334 if (!NILP (Vbuffer_access_fontify_functions
))
2336 Lisp_Object args
[3];
2339 args
[0] = Qbuffer_access_fontify_functions
;
2340 XSETINT (args
[1], start
);
2341 XSETINT (args
[2], end
);
2343 /* But don't call them if we can tell that the work
2344 has already been done. */
2345 if (!NILP (Vbuffer_access_fontified_property
))
2347 tem
= Ftext_property_any (args
[1], args
[2],
2348 Vbuffer_access_fontified_property
,
2351 Frun_hook_with_args (3, args
);
2354 Frun_hook_with_args (3, args
);
2358 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
2359 doc
: /* Return the contents of part of the current buffer as a string.
2360 The two arguments START and END are character positions;
2361 they can be in either order.
2362 The string returned is multibyte if the buffer is multibyte.
2364 This function copies the text properties of that part of the buffer
2365 into the result string; if you don't want the text properties,
2366 use `buffer-substring-no-properties' instead. */)
2368 Lisp_Object start
, end
;
2372 validate_region (&start
, &end
);
2376 return make_buffer_string (b
, e
, 1);
2379 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties
,
2380 Sbuffer_substring_no_properties
, 2, 2, 0,
2381 doc
: /* Return the characters of part of the buffer, without the text properties.
2382 The two arguments START and END are character positions;
2383 they can be in either order. */)
2385 Lisp_Object start
, end
;
2389 validate_region (&start
, &end
);
2393 return make_buffer_string (b
, e
, 0);
2396 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
2397 doc
: /* Return the contents of the current buffer as a string.
2398 If narrowing is in effect, this function returns only the visible part
2402 return make_buffer_string (BEGV
, ZV
, 1);
2405 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
2407 doc
: /* Insert before point a substring of the contents of BUFFER.
2408 BUFFER may be a buffer or a buffer name.
2409 Arguments START and END are character positions specifying the substring.
2410 They default to the values of (point-min) and (point-max) in BUFFER. */)
2411 (buffer
, start
, end
)
2412 Lisp_Object buffer
, start
, end
;
2414 register int b
, e
, temp
;
2415 register struct buffer
*bp
, *obuf
;
2418 buf
= Fget_buffer (buffer
);
2422 if (NILP (bp
->name
))
2423 error ("Selecting deleted buffer");
2429 CHECK_NUMBER_COERCE_MARKER (start
);
2436 CHECK_NUMBER_COERCE_MARKER (end
);
2441 temp
= b
, b
= e
, e
= temp
;
2443 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
2444 args_out_of_range (start
, end
);
2446 obuf
= current_buffer
;
2447 set_buffer_internal_1 (bp
);
2448 update_buffer_properties (b
, e
);
2449 set_buffer_internal_1 (obuf
);
2451 insert_from_buffer (bp
, b
, e
- b
, 0);
2455 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
2457 doc
: /* Compare two substrings of two buffers; return result as number.
2458 the value is -N if first string is less after N-1 chars,
2459 +N if first string is greater after N-1 chars, or 0 if strings match.
2460 Each substring is represented as three arguments: BUFFER, START and END.
2461 That makes six args in all, three for each substring.
2463 The value of `case-fold-search' in the current buffer
2464 determines whether case is significant or ignored. */)
2465 (buffer1
, start1
, end1
, buffer2
, start2
, end2
)
2466 Lisp_Object buffer1
, start1
, end1
, buffer2
, start2
, end2
;
2468 register int begp1
, endp1
, begp2
, endp2
, temp
;
2469 register struct buffer
*bp1
, *bp2
;
2470 register Lisp_Object
*trt
2471 = (!NILP (current_buffer
->case_fold_search
)
2472 ? XCHAR_TABLE (current_buffer
->case_canon_table
)->contents
: 0);
2474 int i1
, i2
, i1_byte
, i2_byte
;
2476 /* Find the first buffer and its substring. */
2479 bp1
= current_buffer
;
2483 buf1
= Fget_buffer (buffer1
);
2486 bp1
= XBUFFER (buf1
);
2487 if (NILP (bp1
->name
))
2488 error ("Selecting deleted buffer");
2492 begp1
= BUF_BEGV (bp1
);
2495 CHECK_NUMBER_COERCE_MARKER (start1
);
2496 begp1
= XINT (start1
);
2499 endp1
= BUF_ZV (bp1
);
2502 CHECK_NUMBER_COERCE_MARKER (end1
);
2503 endp1
= XINT (end1
);
2507 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
2509 if (!(BUF_BEGV (bp1
) <= begp1
2511 && endp1
<= BUF_ZV (bp1
)))
2512 args_out_of_range (start1
, end1
);
2514 /* Likewise for second substring. */
2517 bp2
= current_buffer
;
2521 buf2
= Fget_buffer (buffer2
);
2524 bp2
= XBUFFER (buf2
);
2525 if (NILP (bp2
->name
))
2526 error ("Selecting deleted buffer");
2530 begp2
= BUF_BEGV (bp2
);
2533 CHECK_NUMBER_COERCE_MARKER (start2
);
2534 begp2
= XINT (start2
);
2537 endp2
= BUF_ZV (bp2
);
2540 CHECK_NUMBER_COERCE_MARKER (end2
);
2541 endp2
= XINT (end2
);
2545 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
2547 if (!(BUF_BEGV (bp2
) <= begp2
2549 && endp2
<= BUF_ZV (bp2
)))
2550 args_out_of_range (start2
, end2
);
2554 i1_byte
= buf_charpos_to_bytepos (bp1
, i1
);
2555 i2_byte
= buf_charpos_to_bytepos (bp2
, i2
);
2557 while (i1
< endp1
&& i2
< endp2
)
2559 /* When we find a mismatch, we must compare the
2560 characters, not just the bytes. */
2565 if (! NILP (bp1
->enable_multibyte_characters
))
2567 c1
= BUF_FETCH_MULTIBYTE_CHAR (bp1
, i1_byte
);
2568 BUF_INC_POS (bp1
, i1_byte
);
2573 c1
= BUF_FETCH_BYTE (bp1
, i1
);
2574 c1
= unibyte_char_to_multibyte (c1
);
2578 if (! NILP (bp2
->enable_multibyte_characters
))
2580 c2
= BUF_FETCH_MULTIBYTE_CHAR (bp2
, i2_byte
);
2581 BUF_INC_POS (bp2
, i2_byte
);
2586 c2
= BUF_FETCH_BYTE (bp2
, i2
);
2587 c2
= unibyte_char_to_multibyte (c2
);
2593 c1
= XINT (trt
[c1
]);
2594 c2
= XINT (trt
[c2
]);
2597 return make_number (- 1 - chars
);
2599 return make_number (chars
+ 1);
2604 /* The strings match as far as they go.
2605 If one is shorter, that one is less. */
2606 if (chars
< endp1
- begp1
)
2607 return make_number (chars
+ 1);
2608 else if (chars
< endp2
- begp2
)
2609 return make_number (- chars
- 1);
2611 /* Same length too => they are equal. */
2612 return make_number (0);
2616 subst_char_in_region_unwind (arg
)
2619 return current_buffer
->undo_list
= arg
;
2623 subst_char_in_region_unwind_1 (arg
)
2626 return current_buffer
->filename
= arg
;
2629 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
2630 Ssubst_char_in_region
, 4, 5, 0,
2631 doc
: /* From START to END, replace FROMCHAR with TOCHAR each time it occurs.
2632 If optional arg NOUNDO is non-nil, don't record this change for undo
2633 and don't mark the buffer as really changed.
2634 Both characters must have the same length of multi-byte form. */)
2635 (start
, end
, fromchar
, tochar
, noundo
)
2636 Lisp_Object start
, end
, fromchar
, tochar
, noundo
;
2638 register int pos
, pos_byte
, stop
, i
, len
, end_byte
;
2640 unsigned char fromstr
[MAX_MULTIBYTE_LENGTH
], tostr
[MAX_MULTIBYTE_LENGTH
];
2642 int count
= SPECPDL_INDEX ();
2643 #define COMBINING_NO 0
2644 #define COMBINING_BEFORE 1
2645 #define COMBINING_AFTER 2
2646 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
2647 int maybe_byte_combining
= COMBINING_NO
;
2648 int last_changed
= 0;
2649 int multibyte_p
= !NILP (current_buffer
->enable_multibyte_characters
);
2651 validate_region (&start
, &end
);
2652 CHECK_NUMBER (fromchar
);
2653 CHECK_NUMBER (tochar
);
2657 len
= CHAR_STRING (XFASTINT (fromchar
), fromstr
);
2658 if (CHAR_STRING (XFASTINT (tochar
), tostr
) != len
)
2659 error ("Characters in subst-char-in-region have different byte-lengths");
2660 if (!ASCII_BYTE_P (*tostr
))
2662 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
2663 complete multibyte character, it may be combined with the
2664 after bytes. If it is in the range 0xA0..0xFF, it may be
2665 combined with the before and after bytes. */
2666 if (!CHAR_HEAD_P (*tostr
))
2667 maybe_byte_combining
= COMBINING_BOTH
;
2668 else if (BYTES_BY_CHAR_HEAD (*tostr
) > len
)
2669 maybe_byte_combining
= COMBINING_AFTER
;
2675 fromstr
[0] = XFASTINT (fromchar
);
2676 tostr
[0] = XFASTINT (tochar
);
2680 pos_byte
= CHAR_TO_BYTE (pos
);
2681 stop
= CHAR_TO_BYTE (XINT (end
));
2684 /* If we don't want undo, turn off putting stuff on the list.
2685 That's faster than getting rid of things,
2686 and it prevents even the entry for a first change.
2687 Also inhibit locking the file. */
2690 record_unwind_protect (subst_char_in_region_unwind
,
2691 current_buffer
->undo_list
);
2692 current_buffer
->undo_list
= Qt
;
2693 /* Don't do file-locking. */
2694 record_unwind_protect (subst_char_in_region_unwind_1
,
2695 current_buffer
->filename
);
2696 current_buffer
->filename
= Qnil
;
2699 if (pos_byte
< GPT_BYTE
)
2700 stop
= min (stop
, GPT_BYTE
);
2703 int pos_byte_next
= pos_byte
;
2705 if (pos_byte
>= stop
)
2707 if (pos_byte
>= end_byte
) break;
2710 p
= BYTE_POS_ADDR (pos_byte
);
2712 INC_POS (pos_byte_next
);
2715 if (pos_byte_next
- pos_byte
== len
2716 && p
[0] == fromstr
[0]
2718 || (p
[1] == fromstr
[1]
2719 && (len
== 2 || (p
[2] == fromstr
[2]
2720 && (len
== 3 || p
[3] == fromstr
[3]))))))
2725 modify_region (current_buffer
, changed
, XINT (end
));
2727 if (! NILP (noundo
))
2729 if (MODIFF
- 1 == SAVE_MODIFF
)
2731 if (MODIFF
- 1 == current_buffer
->auto_save_modified
)
2732 current_buffer
->auto_save_modified
++;
2736 /* Take care of the case where the new character
2737 combines with neighboring bytes. */
2738 if (maybe_byte_combining
2739 && (maybe_byte_combining
== COMBINING_AFTER
2740 ? (pos_byte_next
< Z_BYTE
2741 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2742 : ((pos_byte_next
< Z_BYTE
2743 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2744 || (pos_byte
> BEG_BYTE
2745 && ! ASCII_BYTE_P (FETCH_BYTE (pos_byte
- 1))))))
2747 Lisp_Object tem
, string
;
2749 struct gcpro gcpro1
;
2751 tem
= current_buffer
->undo_list
;
2754 /* Make a multibyte string containing this single character. */
2755 string
= make_multibyte_string (tostr
, 1, len
);
2756 /* replace_range is less efficient, because it moves the gap,
2757 but it handles combining correctly. */
2758 replace_range (pos
, pos
+ 1, string
,
2760 pos_byte_next
= CHAR_TO_BYTE (pos
);
2761 if (pos_byte_next
> pos_byte
)
2762 /* Before combining happened. We should not increment
2763 POS. So, to cancel the later increment of POS,
2767 INC_POS (pos_byte_next
);
2769 if (! NILP (noundo
))
2770 current_buffer
->undo_list
= tem
;
2777 record_change (pos
, 1);
2778 for (i
= 0; i
< len
; i
++) *p
++ = tostr
[i
];
2780 last_changed
= pos
+ 1;
2782 pos_byte
= pos_byte_next
;
2788 signal_after_change (changed
,
2789 last_changed
- changed
, last_changed
- changed
);
2790 update_compositions (changed
, last_changed
, CHECK_ALL
);
2793 unbind_to (count
, Qnil
);
2797 DEFUN ("translate-region-internal", Ftranslate_region_internal
,
2798 Stranslate_region_internal
, 3, 3, 0,
2799 doc
: /* Internal use only.
2800 From START to END, translate characters according to TABLE.
2801 TABLE is a string; the Nth character in it is the mapping
2802 for the character with code N.
2803 It returns the number of characters changed. */)
2807 register Lisp_Object table
;
2809 register unsigned char *tt
; /* Trans table. */
2810 register int nc
; /* New character. */
2811 int cnt
; /* Number of changes made. */
2812 int size
; /* Size of translate table. */
2813 int pos
, pos_byte
, end_pos
;
2814 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
2815 int string_multibyte
;
2817 validate_region (&start
, &end
);
2818 if (CHAR_TABLE_P (table
))
2825 CHECK_STRING (table
);
2827 if (! multibyte
&& (SCHARS (table
) < SBYTES (table
)))
2828 table
= string_make_unibyte (table
);
2829 string_multibyte
= SCHARS (table
) < SBYTES (table
);
2830 size
= SCHARS (table
);
2835 pos_byte
= CHAR_TO_BYTE (pos
);
2836 end_pos
= XINT (end
);
2837 modify_region (current_buffer
, pos
, XINT (end
));
2840 for (; pos
< end_pos
; )
2842 register unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
2843 unsigned char *str
, buf
[MAX_MULTIBYTE_LENGTH
];
2848 oc
= STRING_CHAR_AND_LENGTH (p
, MAX_MULTIBYTE_LENGTH
, len
);
2855 if (string_multibyte
)
2857 str
= tt
+ string_char_to_byte (table
, oc
);
2858 nc
= STRING_CHAR_AND_LENGTH (str
, MAX_MULTIBYTE_LENGTH
,
2864 if (! ASCII_BYTE_P (nc
) && multibyte
)
2866 str_len
= CHAR_STRING (nc
, buf
);
2882 val
= CHAR_TABLE_REF (table
, oc
);
2884 && (c
= XINT (val
), CHAR_VALID_P (c
, 0)))
2887 str_len
= CHAR_STRING (nc
, buf
);
2898 /* This is less efficient, because it moves the gap,
2899 but it should multibyte characters correctly. */
2900 string
= make_multibyte_string (str
, 1, str_len
);
2901 replace_range (pos
, pos
+ 1, string
, 1, 0, 1);
2906 record_change (pos
, 1);
2907 while (str_len
-- > 0)
2909 signal_after_change (pos
, 1, 1);
2910 update_compositions (pos
, pos
+ 1, CHECK_BORDER
);
2919 return make_number (cnt
);
2922 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
2923 doc
: /* Delete the text between point and mark.
2925 When called from a program, expects two arguments,
2926 positions (integers or markers) specifying the stretch to be deleted. */)
2928 Lisp_Object start
, end
;
2930 validate_region (&start
, &end
);
2931 del_range (XINT (start
), XINT (end
));
2935 DEFUN ("delete-and-extract-region", Fdelete_and_extract_region
,
2936 Sdelete_and_extract_region
, 2, 2, 0,
2937 doc
: /* Delete the text between START and END and return it. */)
2939 Lisp_Object start
, end
;
2941 validate_region (&start
, &end
);
2942 if (XINT (start
) == XINT (end
))
2943 return build_string ("");
2944 return del_range_1 (XINT (start
), XINT (end
), 1, 1);
2947 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
2948 doc
: /* Remove restrictions (narrowing) from current buffer.
2949 This allows the buffer's full text to be seen and edited. */)
2952 if (BEG
!= BEGV
|| Z
!= ZV
)
2953 current_buffer
->clip_changed
= 1;
2955 BEGV_BYTE
= BEG_BYTE
;
2956 SET_BUF_ZV_BOTH (current_buffer
, Z
, Z_BYTE
);
2957 /* Changing the buffer bounds invalidates any recorded current column. */
2958 invalidate_current_column ();
2962 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
2963 doc
: /* Restrict editing in this buffer to the current region.
2964 The rest of the text becomes temporarily invisible and untouchable
2965 but is not deleted; if you save the buffer in a file, the invisible
2966 text is included in the file. \\[widen] makes all visible again.
2967 See also `save-restriction'.
2969 When calling from a program, pass two arguments; positions (integers
2970 or markers) bounding the text that should remain visible. */)
2972 register Lisp_Object start
, end
;
2974 CHECK_NUMBER_COERCE_MARKER (start
);
2975 CHECK_NUMBER_COERCE_MARKER (end
);
2977 if (XINT (start
) > XINT (end
))
2980 tem
= start
; start
= end
; end
= tem
;
2983 if (!(BEG
<= XINT (start
) && XINT (start
) <= XINT (end
) && XINT (end
) <= Z
))
2984 args_out_of_range (start
, end
);
2986 if (BEGV
!= XFASTINT (start
) || ZV
!= XFASTINT (end
))
2987 current_buffer
->clip_changed
= 1;
2989 SET_BUF_BEGV (current_buffer
, XFASTINT (start
));
2990 SET_BUF_ZV (current_buffer
, XFASTINT (end
));
2991 if (PT
< XFASTINT (start
))
2992 SET_PT (XFASTINT (start
));
2993 if (PT
> XFASTINT (end
))
2994 SET_PT (XFASTINT (end
));
2995 /* Changing the buffer bounds invalidates any recorded current column. */
2996 invalidate_current_column ();
3001 save_restriction_save ()
3003 if (BEGV
== BEG
&& ZV
== Z
)
3004 /* The common case that the buffer isn't narrowed.
3005 We return just the buffer object, which save_restriction_restore
3006 recognizes as meaning `no restriction'. */
3007 return Fcurrent_buffer ();
3009 /* We have to save a restriction, so return a pair of markers, one
3010 for the beginning and one for the end. */
3012 Lisp_Object beg
, end
;
3014 beg
= buildmark (BEGV
, BEGV_BYTE
);
3015 end
= buildmark (ZV
, ZV_BYTE
);
3017 /* END must move forward if text is inserted at its exact location. */
3018 XMARKER(end
)->insertion_type
= 1;
3020 return Fcons (beg
, end
);
3025 save_restriction_restore (data
)
3029 /* A pair of marks bounding a saved restriction. */
3031 struct Lisp_Marker
*beg
= XMARKER (XCAR (data
));
3032 struct Lisp_Marker
*end
= XMARKER (XCDR (data
));
3033 struct buffer
*buf
= beg
->buffer
; /* END should have the same buffer. */
3035 if (buf
/* Verify marker still points to a buffer. */
3036 && (beg
->charpos
!= BUF_BEGV (buf
) || end
->charpos
!= BUF_ZV (buf
)))
3037 /* The restriction has changed from the saved one, so restore
3038 the saved restriction. */
3040 int pt
= BUF_PT (buf
);
3042 SET_BUF_BEGV_BOTH (buf
, beg
->charpos
, beg
->bytepos
);
3043 SET_BUF_ZV_BOTH (buf
, end
->charpos
, end
->bytepos
);
3045 if (pt
< beg
->charpos
|| pt
> end
->charpos
)
3046 /* The point is outside the new visible range, move it inside. */
3047 SET_BUF_PT_BOTH (buf
,
3048 clip_to_bounds (beg
->charpos
, pt
, end
->charpos
),
3049 clip_to_bounds (beg
->bytepos
, BUF_PT_BYTE (buf
),
3052 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3056 /* A buffer, which means that there was no old restriction. */
3058 struct buffer
*buf
= XBUFFER (data
);
3060 if (buf
/* Verify marker still points to a buffer. */
3061 && (BUF_BEGV (buf
) != BUF_BEG (buf
) || BUF_ZV (buf
) != BUF_Z (buf
)))
3062 /* The buffer has been narrowed, get rid of the narrowing. */
3064 SET_BUF_BEGV_BOTH (buf
, BUF_BEG (buf
), BUF_BEG_BYTE (buf
));
3065 SET_BUF_ZV_BOTH (buf
, BUF_Z (buf
), BUF_Z_BYTE (buf
));
3067 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3074 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
3075 doc
: /* Execute BODY, saving and restoring current buffer's restrictions.
3076 The buffer's restrictions make parts of the beginning and end invisible.
3077 (They are set up with `narrow-to-region' and eliminated with `widen'.)
3078 This special form, `save-restriction', saves the current buffer's restrictions
3079 when it is entered, and restores them when it is exited.
3080 So any `narrow-to-region' within BODY lasts only until the end of the form.
3081 The old restrictions settings are restored
3082 even in case of abnormal exit (throw or error).
3084 The value returned is the value of the last form in BODY.
3086 Note: if you are using both `save-excursion' and `save-restriction',
3087 use `save-excursion' outermost:
3088 (save-excursion (save-restriction ...))
3090 usage: (save-restriction &rest BODY) */)
3094 register Lisp_Object val
;
3095 int count
= SPECPDL_INDEX ();
3097 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
3098 val
= Fprogn (body
);
3099 return unbind_to (count
, val
);
3102 /* Buffer for the most recent text displayed by Fmessage_box. */
3103 static char *message_text
;
3105 /* Allocated length of that buffer. */
3106 static int message_length
;
3108 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
3109 doc
: /* Print a one-line message at the bottom of the screen.
3110 The message also goes into the `*Messages*' buffer.
3111 \(In keyboard macros, that's all it does.)
3113 The first argument is a format control string, and the rest are data
3114 to be formatted under control of the string. See `format' for details.
3116 If the first argument is nil, the function clears any existing message;
3117 this lets the minibuffer contents show. See also `current-message'.
3119 usage: (message STRING &rest ARGS) */)
3125 || (STRINGP (args
[0])
3126 && SBYTES (args
[0]) == 0))
3133 register Lisp_Object val
;
3134 val
= Fformat (nargs
, args
);
3135 message3 (val
, SBYTES (val
), STRING_MULTIBYTE (val
));
3140 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
3141 doc
: /* Display a message, in a dialog box if possible.
3142 If a dialog box is not available, use the echo area.
3143 The first argument is a format control string, and the rest are data
3144 to be formatted under control of the string. See `format' for details.
3146 If the first argument is nil, clear any existing message; let the
3147 minibuffer contents show.
3149 usage: (message-box STRING &rest ARGS) */)
3161 register Lisp_Object val
;
3162 val
= Fformat (nargs
, args
);
3164 /* The MS-DOS frames support popup menus even though they are
3165 not FRAME_WINDOW_P. */
3166 if (FRAME_WINDOW_P (XFRAME (selected_frame
))
3167 || FRAME_MSDOS_P (XFRAME (selected_frame
)))
3169 Lisp_Object pane
, menu
, obj
;
3170 struct gcpro gcpro1
;
3171 pane
= Fcons (Fcons (build_string ("OK"), Qt
), Qnil
);
3173 menu
= Fcons (val
, pane
);
3174 obj
= Fx_popup_dialog (Qt
, menu
);
3178 #endif /* HAVE_MENUS */
3179 /* Copy the data so that it won't move when we GC. */
3182 message_text
= (char *)xmalloc (80);
3183 message_length
= 80;
3185 if (SBYTES (val
) > message_length
)
3187 message_length
= SBYTES (val
);
3188 message_text
= (char *)xrealloc (message_text
, message_length
);
3190 bcopy (SDATA (val
), message_text
, SBYTES (val
));
3191 message2 (message_text
, SBYTES (val
),
3192 STRING_MULTIBYTE (val
));
3197 extern Lisp_Object last_nonmenu_event
;
3200 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
3201 doc
: /* Display a message in a dialog box or in the echo area.
3202 If this command was invoked with the mouse, use a dialog box if
3203 `use-dialog-box' is non-nil.
3204 Otherwise, use the echo area.
3205 The first argument is a format control string, and the rest are data
3206 to be formatted under control of the string. See `format' for details.
3208 If the first argument is nil, clear any existing message; let the
3209 minibuffer contents show.
3211 usage: (message-or-box STRING &rest ARGS) */)
3217 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3219 return Fmessage_box (nargs
, args
);
3221 return Fmessage (nargs
, args
);
3224 DEFUN ("current-message", Fcurrent_message
, Scurrent_message
, 0, 0, 0,
3225 doc
: /* Return the string currently displayed in the echo area, or nil if none. */)
3228 return current_message ();
3232 DEFUN ("propertize", Fpropertize
, Spropertize
, 1, MANY
, 0,
3233 doc
: /* Return a copy of STRING with text properties added.
3234 First argument is the string to copy.
3235 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
3236 properties to add to the result.
3237 usage: (propertize STRING &rest PROPERTIES) */)
3242 Lisp_Object properties
, string
;
3243 struct gcpro gcpro1
, gcpro2
;
3246 /* Number of args must be odd. */
3247 if ((nargs
& 1) == 0 || nargs
< 1)
3248 error ("Wrong number of arguments");
3250 properties
= string
= Qnil
;
3251 GCPRO2 (properties
, string
);
3253 /* First argument must be a string. */
3254 CHECK_STRING (args
[0]);
3255 string
= Fcopy_sequence (args
[0]);
3257 for (i
= 1; i
< nargs
; i
+= 2)
3259 CHECK_SYMBOL (args
[i
]);
3260 properties
= Fcons (args
[i
], Fcons (args
[i
+ 1], properties
));
3263 Fadd_text_properties (make_number (0),
3264 make_number (SCHARS (string
)),
3265 properties
, string
);
3266 RETURN_UNGCPRO (string
);
3270 /* Number of bytes that STRING will occupy when put into the result.
3271 MULTIBYTE is nonzero if the result should be multibyte. */
3273 #define CONVERTED_BYTE_SIZE(MULTIBYTE, STRING) \
3274 (((MULTIBYTE) && ! STRING_MULTIBYTE (STRING)) \
3275 ? count_size_as_multibyte (SDATA (STRING), SBYTES (STRING)) \
3278 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
3279 doc
: /* Format a string out of a control-string and arguments.
3280 The first argument is a control string.
3281 The other arguments are substituted into it to make the result, a string.
3282 It may contain %-sequences meaning to substitute the next argument.
3283 %s means print a string argument. Actually, prints any object, with `princ'.
3284 %d means print as number in decimal (%o octal, %x hex).
3285 %X is like %x, but uses upper case.
3286 %e means print a number in exponential notation.
3287 %f means print a number in decimal-point notation.
3288 %g means print a number in exponential notation
3289 or decimal-point notation, whichever uses fewer characters.
3290 %c means print a number as a single character.
3291 %S means print any object as an s-expression (using `prin1').
3292 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
3293 Use %% to put a single % into the output.
3295 The basic structure of a %-sequence is
3296 % <flags> <width> <precision> character
3297 where flags is [- #0]+, width is [0-9]+, and precision is .[0-9]+
3299 usage: (format STRING &rest OBJECTS) */)
3302 register Lisp_Object
*args
;
3304 register int n
; /* The number of the next arg to substitute */
3305 register int total
; /* An estimate of the final length */
3307 register unsigned char *format
, *end
, *format_start
;
3309 /* Nonzero if the output should be a multibyte string,
3310 which is true if any of the inputs is one. */
3312 /* When we make a multibyte string, we must pay attention to the
3313 byte combining problem, i.e., a byte may be combined with a
3314 multibyte charcter of the previous string. This flag tells if we
3315 must consider such a situation or not. */
3316 int maybe_combine_byte
;
3317 unsigned char *this_format
;
3318 /* Precision for each spec, or -1, a flag value meaning no precision
3319 was given in that spec. Element 0, corresonding to the format
3320 string itself, will not be used. Element NARGS, corresponding to
3321 no argument, *will* be assigned to in the case that a `%' and `.'
3322 occur after the final format specifier. */
3323 int *precision
= (int *) (alloca((nargs
+ 1) * sizeof (int)));
3326 int arg_intervals
= 0;
3329 /* discarded[I] is 1 if byte I of the format
3330 string was not copied into the output.
3331 It is 2 if byte I was not the first byte of its character. */
3332 char *discarded
= 0;
3334 /* Each element records, for one argument,
3335 the start and end bytepos in the output string,
3336 and whether the argument is a string with intervals.
3337 info[0] is unused. Unused elements have -1 for start. */
3340 int start
, end
, intervals
;
3343 /* It should not be necessary to GCPRO ARGS, because
3344 the caller in the interpreter should take care of that. */
3346 /* Try to determine whether the result should be multibyte.
3347 This is not always right; sometimes the result needs to be multibyte
3348 because of an object that we will pass through prin1,
3349 and in that case, we won't know it here. */
3350 for (n
= 0; n
< nargs
; n
++)
3352 if (STRINGP (args
[n
]) && STRING_MULTIBYTE (args
[n
]))
3354 /* Piggyback on this loop to initialize precision[N]. */
3357 precision
[nargs
] = -1;
3359 CHECK_STRING (args
[0]);
3360 /* We may have to change "%S" to "%s". */
3361 args
[0] = Fcopy_sequence (args
[0]);
3363 /* GC should never happen here, so abort if it does. */
3366 /* If we start out planning a unibyte result,
3367 then discover it has to be multibyte, we jump back to retry.
3368 That can only happen from the first large while loop below. */
3371 format
= SDATA (args
[0]);
3372 format_start
= format
;
3373 end
= format
+ SBYTES (args
[0]);
3376 /* Make room in result for all the non-%-codes in the control string. */
3377 total
= 5 + CONVERTED_BYTE_SIZE (multibyte
, args
[0]) + 1;
3379 /* Allocate the info and discarded tables. */
3381 int nbytes
= (nargs
+1) * sizeof *info
;
3384 info
= (struct info
*) alloca (nbytes
);
3385 bzero (info
, nbytes
);
3386 for (i
= 0; i
<= nargs
; i
++)
3389 SAFE_ALLOCA (discarded
, char *, SBYTES (args
[0]));
3390 bzero (discarded
, SBYTES (args
[0]));
3393 /* Add to TOTAL enough space to hold the converted arguments. */
3396 while (format
!= end
)
3397 if (*format
++ == '%')
3400 int actual_width
= 0;
3401 unsigned char *this_format_start
= format
- 1;
3402 int field_width
= 0;
3404 /* General format specifications look like
3406 '%' [flags] [field-width] [precision] format
3411 field-width ::= [0-9]+
3412 precision ::= '.' [0-9]*
3414 If a field-width is specified, it specifies to which width
3415 the output should be padded with blanks, iff the output
3416 string is shorter than field-width.
3418 If precision is specified, it specifies the number of
3419 digits to print after the '.' for floats, or the max.
3420 number of chars to print from a string. */
3422 while (index ("-0# ", *format
))
3425 if (*format
>= '0' && *format
<= '9')
3427 for (field_width
= 0; *format
>= '0' && *format
<= '9'; ++format
)
3428 field_width
= 10 * field_width
+ *format
- '0';
3431 /* N is not incremented for another few lines below, so refer to
3432 element N+1 (which might be precision[NARGS]). */
3436 for (precision
[n
+1] = 0; *format
>= '0' && *format
<= '9'; ++format
)
3437 precision
[n
+1] = 10 * precision
[n
+1] + *format
- '0';
3440 if (format
- this_format_start
+ 1 > longest_format
)
3441 longest_format
= format
- this_format_start
+ 1;
3444 error ("Format string ends in middle of format specifier");
3447 else if (++n
>= nargs
)
3448 error ("Not enough arguments for format string");
3449 else if (*format
== 'S')
3451 /* For `S', prin1 the argument and then treat like a string. */
3452 register Lisp_Object tem
;
3453 tem
= Fprin1_to_string (args
[n
], Qnil
);
3454 if (STRING_MULTIBYTE (tem
) && ! multibyte
)
3460 /* If we restart the loop, we should not come here again
3461 because args[n] is now a string and calling
3462 Fprin1_to_string on it produces superflous double
3463 quotes. So, change "%S" to "%s" now. */
3467 else if (SYMBOLP (args
[n
]))
3469 args
[n
] = SYMBOL_NAME (args
[n
]);
3470 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3477 else if (STRINGP (args
[n
]))
3480 if (*format
!= 's' && *format
!= 'S')
3481 error ("Format specifier doesn't match argument type");
3482 /* In the case (PRECISION[N] > 0), THISSIZE may not need
3483 to be as large as is calculated here. Easy check for
3484 the case PRECISION = 0. */
3485 thissize
= precision
[n
] ? CONVERTED_BYTE_SIZE (multibyte
, args
[n
]) : 0;
3486 actual_width
= lisp_string_width (args
[n
], -1, NULL
, NULL
);
3488 /* Would get MPV otherwise, since Lisp_Int's `point' to low memory. */
3489 else if (INTEGERP (args
[n
]) && *format
!= 's')
3491 /* The following loop assumes the Lisp type indicates
3492 the proper way to pass the argument.
3493 So make sure we have a flonum if the argument should
3495 if (*format
== 'e' || *format
== 'f' || *format
== 'g')
3496 args
[n
] = Ffloat (args
[n
]);
3498 if (*format
!= 'd' && *format
!= 'o' && *format
!= 'x'
3499 && *format
!= 'i' && *format
!= 'X' && *format
!= 'c')
3500 error ("Invalid format operation %%%c", *format
);
3505 if (! SINGLE_BYTE_CHAR_P (XINT (args
[n
]))
3506 /* Note: No one can remember why we have to treat
3507 the character 0 as a multibyte character here.
3508 But, until it causes a real problem, let's
3510 || XINT (args
[n
]) == 0)
3517 args
[n
] = Fchar_to_string (args
[n
]);
3518 thissize
= SBYTES (args
[n
]);
3520 else if (! ASCII_BYTE_P (XINT (args
[n
])) && multibyte
)
3523 = Fchar_to_string (Funibyte_char_to_multibyte (args
[n
]));
3524 thissize
= SBYTES (args
[n
]);
3528 else if (FLOATP (args
[n
]) && *format
!= 's')
3530 if (! (*format
== 'e' || *format
== 'f' || *format
== 'g'))
3532 if (*format
!= 'd' && *format
!= 'o' && *format
!= 'x'
3533 && *format
!= 'i' && *format
!= 'X' && *format
!= 'c')
3534 error ("Invalid format operation %%%c", *format
);
3535 args
[n
] = Ftruncate (args
[n
], Qnil
);
3538 /* Note that we're using sprintf to print floats,
3539 so we have to take into account what that function
3541 /* Filter out flag value of -1. */
3542 thissize
= (MAX_10_EXP
+ 100
3543 + (precision
[n
] > 0 ? precision
[n
] : 0));
3547 /* Anything but a string, convert to a string using princ. */
3548 register Lisp_Object tem
;
3549 tem
= Fprin1_to_string (args
[n
], Qt
);
3550 if (STRING_MULTIBYTE (tem
) && ! multibyte
)
3559 thissize
+= max (0, field_width
- actual_width
);
3560 total
+= thissize
+ 4;
3565 /* Now we can no longer jump to retry.
3566 TOTAL and LONGEST_FORMAT are known for certain. */
3568 this_format
= (unsigned char *) alloca (longest_format
+ 1);
3570 /* Allocate the space for the result.
3571 Note that TOTAL is an overestimate. */
3572 SAFE_ALLOCA (buf
, char *, total
);
3578 /* Scan the format and store result in BUF. */
3579 format
= SDATA (args
[0]);
3580 format_start
= format
;
3581 end
= format
+ SBYTES (args
[0]);
3582 maybe_combine_byte
= 0;
3583 while (format
!= end
)
3589 unsigned char *this_format_start
= format
;
3591 discarded
[format
- format_start
] = 1;
3594 while (index("-0# ", *format
))
3600 discarded
[format
- format_start
] = 1;
3604 minlen
= atoi (format
);
3606 while ((*format
>= '0' && *format
<= '9') || *format
== '.')
3608 discarded
[format
- format_start
] = 1;
3612 if (*format
++ == '%')
3621 discarded
[format
- format_start
- 1] = 1;
3622 info
[n
].start
= nchars
;
3624 if (STRINGP (args
[n
]))
3626 /* handle case (precision[n] >= 0) */
3629 int nbytes
, start
, end
;
3632 /* lisp_string_width ignores a precision of 0, but GNU
3633 libc functions print 0 characters when the precision
3634 is 0. Imitate libc behavior here. Changing
3635 lisp_string_width is the right thing, and will be
3636 done, but meanwhile we work with it. */
3638 if (precision
[n
] == 0)
3639 width
= nchars_string
= nbytes
= 0;
3640 else if (precision
[n
] > 0)
3641 width
= lisp_string_width (args
[n
], precision
[n
], &nchars_string
, &nbytes
);
3643 { /* no precision spec given for this argument */
3644 width
= lisp_string_width (args
[n
], -1, NULL
, NULL
);
3645 nbytes
= SBYTES (args
[n
]);
3646 nchars_string
= SCHARS (args
[n
]);
3649 /* If spec requires it, pad on right with spaces. */
3650 padding
= minlen
- width
;
3652 while (padding
-- > 0)
3659 nchars
+= nchars_string
;
3664 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3665 && STRING_MULTIBYTE (args
[n
])
3666 && !CHAR_HEAD_P (SREF (args
[n
], 0)))
3667 maybe_combine_byte
= 1;
3669 p
+= copy_text (SDATA (args
[n
]), p
,
3671 STRING_MULTIBYTE (args
[n
]), multibyte
);
3674 while (padding
-- > 0)
3680 /* If this argument has text properties, record where
3681 in the result string it appears. */
3682 if (STRING_INTERVALS (args
[n
]))
3683 info
[n
].intervals
= arg_intervals
= 1;
3685 else if (INTEGERP (args
[n
]) || FLOATP (args
[n
]))
3689 bcopy (this_format_start
, this_format
,
3690 format
- this_format_start
);
3691 this_format
[format
- this_format_start
] = 0;
3693 if (INTEGERP (args
[n
]))
3694 sprintf (p
, this_format
, XINT (args
[n
]));
3696 sprintf (p
, this_format
, XFLOAT_DATA (args
[n
]));
3700 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3701 && !CHAR_HEAD_P (*((unsigned char *) p
)))
3702 maybe_combine_byte
= 1;
3703 this_nchars
= strlen (p
);
3705 p
+= str_to_multibyte (p
, buf
+ total
- 1 - p
, this_nchars
);
3708 nchars
+= this_nchars
;
3711 info
[n
].end
= nchars
;
3713 else if (STRING_MULTIBYTE (args
[0]))
3715 /* Copy a whole multibyte character. */
3718 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3719 && !CHAR_HEAD_P (*format
))
3720 maybe_combine_byte
= 1;
3722 while (! CHAR_HEAD_P (*format
))
3724 discarded
[format
- format_start
] = 2;
3731 /* Convert a single-byte character to multibyte. */
3732 int len
= copy_text (format
, p
, 1, 0, 1);
3739 *p
++ = *format
++, nchars
++;
3742 if (p
> buf
+ total
)
3745 if (maybe_combine_byte
)
3746 nchars
= multibyte_chars_in_text (buf
, p
- buf
);
3747 val
= make_specified_string (buf
, nchars
, p
- buf
, multibyte
);
3749 /* If we allocated BUF with malloc, free it too. */
3752 /* If the format string has text properties, or any of the string
3753 arguments has text properties, set up text properties of the
3756 if (STRING_INTERVALS (args
[0]) || arg_intervals
)
3758 Lisp_Object len
, new_len
, props
;
3759 struct gcpro gcpro1
;
3761 /* Add text properties from the format string. */
3762 len
= make_number (SCHARS (args
[0]));
3763 props
= text_property_list (args
[0], make_number (0), len
, Qnil
);
3768 int bytepos
= 0, position
= 0, translated
= 0, argn
= 1;
3771 /* Adjust the bounds of each text property
3772 to the proper start and end in the output string. */
3774 /* Put the positions in PROPS in increasing order, so that
3775 we can do (effectively) one scan through the position
3776 space of the format string. */
3777 props
= Fnreverse (props
);
3779 /* BYTEPOS is the byte position in the format string,
3780 POSITION is the untranslated char position in it,
3781 TRANSLATED is the translated char position in BUF,
3782 and ARGN is the number of the next arg we will come to. */
3783 for (list
= props
; CONSP (list
); list
= XCDR (list
))
3790 /* First adjust the property start position. */
3791 pos
= XINT (XCAR (item
));
3793 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
3794 up to this position. */
3795 for (; position
< pos
; bytepos
++)
3797 if (! discarded
[bytepos
])
3798 position
++, translated
++;
3799 else if (discarded
[bytepos
] == 1)
3802 if (translated
== info
[argn
].start
)
3804 translated
+= info
[argn
].end
- info
[argn
].start
;
3810 XSETCAR (item
, make_number (translated
));
3812 /* Likewise adjust the property end position. */
3813 pos
= XINT (XCAR (XCDR (item
)));
3815 for (; bytepos
< pos
; bytepos
++)
3817 if (! discarded
[bytepos
])
3818 position
++, translated
++;
3819 else if (discarded
[bytepos
] == 1)
3822 if (translated
== info
[argn
].start
)
3824 translated
+= info
[argn
].end
- info
[argn
].start
;
3830 XSETCAR (XCDR (item
), make_number (translated
));
3833 add_text_properties_from_list (val
, props
, make_number (0));
3836 /* Add text properties from arguments. */
3838 for (n
= 1; n
< nargs
; ++n
)
3839 if (info
[n
].intervals
)
3841 len
= make_number (SCHARS (args
[n
]));
3842 new_len
= make_number (info
[n
].end
- info
[n
].start
);
3843 props
= text_property_list (args
[n
], make_number (0), len
, Qnil
);
3844 extend_property_ranges (props
, len
, new_len
);
3845 /* If successive arguments have properites, be sure that
3846 the value of `composition' property be the copy. */
3847 if (n
> 1 && info
[n
- 1].end
)
3848 make_composition_value_copy (props
);
3849 add_text_properties_from_list (val
, props
,
3850 make_number (info
[n
].start
));
3860 format2 (string1
, arg0
, arg1
)
3862 Lisp_Object arg0
, arg1
;
3864 Lisp_Object args
[3];
3865 args
[0] = build_string (string1
);
3868 return Fformat (3, args
);
3871 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
3872 doc
: /* Return t if two characters match, optionally ignoring case.
3873 Both arguments must be characters (i.e. integers).
3874 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
3876 register Lisp_Object c1
, c2
;
3882 if (XINT (c1
) == XINT (c2
))
3884 if (NILP (current_buffer
->case_fold_search
))
3887 /* Do these in separate statements,
3888 then compare the variables.
3889 because of the way DOWNCASE uses temp variables. */
3890 i1
= DOWNCASE (XFASTINT (c1
));
3891 i2
= DOWNCASE (XFASTINT (c2
));
3892 return (i1
== i2
? Qt
: Qnil
);
3895 /* Transpose the markers in two regions of the current buffer, and
3896 adjust the ones between them if necessary (i.e.: if the regions
3899 START1, END1 are the character positions of the first region.
3900 START1_BYTE, END1_BYTE are the byte positions.
3901 START2, END2 are the character positions of the second region.
3902 START2_BYTE, END2_BYTE are the byte positions.
3904 Traverses the entire marker list of the buffer to do so, adding an
3905 appropriate amount to some, subtracting from some, and leaving the
3906 rest untouched. Most of this is copied from adjust_markers in insdel.c.
3908 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
3911 transpose_markers (start1
, end1
, start2
, end2
,
3912 start1_byte
, end1_byte
, start2_byte
, end2_byte
)
3913 register int start1
, end1
, start2
, end2
;
3914 register int start1_byte
, end1_byte
, start2_byte
, end2_byte
;
3916 register int amt1
, amt1_byte
, amt2
, amt2_byte
, diff
, diff_byte
, mpos
;
3917 register struct Lisp_Marker
*marker
;
3919 /* Update point as if it were a marker. */
3923 TEMP_SET_PT_BOTH (PT
+ (end2
- end1
),
3924 PT_BYTE
+ (end2_byte
- end1_byte
));
3925 else if (PT
< start2
)
3926 TEMP_SET_PT_BOTH (PT
+ (end2
- start2
) - (end1
- start1
),
3927 (PT_BYTE
+ (end2_byte
- start2_byte
)
3928 - (end1_byte
- start1_byte
)));
3930 TEMP_SET_PT_BOTH (PT
- (start2
- start1
),
3931 PT_BYTE
- (start2_byte
- start1_byte
));
3933 /* We used to adjust the endpoints here to account for the gap, but that
3934 isn't good enough. Even if we assume the caller has tried to move the
3935 gap out of our way, it might still be at start1 exactly, for example;
3936 and that places it `inside' the interval, for our purposes. The amount
3937 of adjustment is nontrivial if there's a `denormalized' marker whose
3938 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
3939 the dirty work to Fmarker_position, below. */
3941 /* The difference between the region's lengths */
3942 diff
= (end2
- start2
) - (end1
- start1
);
3943 diff_byte
= (end2_byte
- start2_byte
) - (end1_byte
- start1_byte
);
3945 /* For shifting each marker in a region by the length of the other
3946 region plus the distance between the regions. */
3947 amt1
= (end2
- start2
) + (start2
- end1
);
3948 amt2
= (end1
- start1
) + (start2
- end1
);
3949 amt1_byte
= (end2_byte
- start2_byte
) + (start2_byte
- end1_byte
);
3950 amt2_byte
= (end1_byte
- start1_byte
) + (start2_byte
- end1_byte
);
3952 for (marker
= BUF_MARKERS (current_buffer
); marker
; marker
= marker
->next
)
3954 mpos
= marker
->bytepos
;
3955 if (mpos
>= start1_byte
&& mpos
< end2_byte
)
3957 if (mpos
< end1_byte
)
3959 else if (mpos
< start2_byte
)
3963 marker
->bytepos
= mpos
;
3965 mpos
= marker
->charpos
;
3966 if (mpos
>= start1
&& mpos
< end2
)
3970 else if (mpos
< start2
)
3975 marker
->charpos
= mpos
;
3979 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
3980 doc
: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
3981 The regions may not be overlapping, because the size of the buffer is
3982 never changed in a transposition.
3984 Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
3985 any markers that happen to be located in the regions.
3987 Transposing beyond buffer boundaries is an error. */)
3988 (startr1
, endr1
, startr2
, endr2
, leave_markers
)
3989 Lisp_Object startr1
, endr1
, startr2
, endr2
, leave_markers
;
3991 register int start1
, end1
, start2
, end2
;
3992 int start1_byte
, start2_byte
, len1_byte
, len2_byte
;
3993 int gap
, len1
, len_mid
, len2
;
3994 unsigned char *start1_addr
, *start2_addr
, *temp
;
3996 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
;
3997 cur_intv
= BUF_INTERVALS (current_buffer
);
3999 validate_region (&startr1
, &endr1
);
4000 validate_region (&startr2
, &endr2
);
4002 start1
= XFASTINT (startr1
);
4003 end1
= XFASTINT (endr1
);
4004 start2
= XFASTINT (startr2
);
4005 end2
= XFASTINT (endr2
);
4008 /* Swap the regions if they're reversed. */
4011 register int glumph
= start1
;
4019 len1
= end1
- start1
;
4020 len2
= end2
- start2
;
4023 error ("Transposed regions overlap");
4024 else if (start1
== end1
|| start2
== end2
)
4025 error ("Transposed region has length 0");
4027 /* The possibilities are:
4028 1. Adjacent (contiguous) regions, or separate but equal regions
4029 (no, really equal, in this case!), or
4030 2. Separate regions of unequal size.
4032 The worst case is usually No. 2. It means that (aside from
4033 potential need for getting the gap out of the way), there also
4034 needs to be a shifting of the text between the two regions. So
4035 if they are spread far apart, we are that much slower... sigh. */
4037 /* It must be pointed out that the really studly thing to do would
4038 be not to move the gap at all, but to leave it in place and work
4039 around it if necessary. This would be extremely efficient,
4040 especially considering that people are likely to do
4041 transpositions near where they are working interactively, which
4042 is exactly where the gap would be found. However, such code
4043 would be much harder to write and to read. So, if you are
4044 reading this comment and are feeling squirrely, by all means have
4045 a go! I just didn't feel like doing it, so I will simply move
4046 the gap the minimum distance to get it out of the way, and then
4047 deal with an unbroken array. */
4049 /* Make sure the gap won't interfere, by moving it out of the text
4050 we will operate on. */
4051 if (start1
< gap
&& gap
< end2
)
4053 if (gap
- start1
< end2
- gap
)
4059 start1_byte
= CHAR_TO_BYTE (start1
);
4060 start2_byte
= CHAR_TO_BYTE (start2
);
4061 len1_byte
= CHAR_TO_BYTE (end1
) - start1_byte
;
4062 len2_byte
= CHAR_TO_BYTE (end2
) - start2_byte
;
4064 #ifdef BYTE_COMBINING_DEBUG
4067 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4068 len2_byte
, start1
, start1_byte
)
4069 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4070 len1_byte
, end2
, start2_byte
+ len2_byte
)
4071 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4072 len1_byte
, end2
, start2_byte
+ len2_byte
))
4077 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4078 len2_byte
, start1
, start1_byte
)
4079 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4080 len1_byte
, start2
, start2_byte
)
4081 || count_combining_after (BYTE_POS_ADDR (start2_byte
),
4082 len2_byte
, end1
, start1_byte
+ len1_byte
)
4083 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4084 len1_byte
, end2
, start2_byte
+ len2_byte
))
4089 /* Hmmm... how about checking to see if the gap is large
4090 enough to use as the temporary storage? That would avoid an
4091 allocation... interesting. Later, don't fool with it now. */
4093 /* Working without memmove, for portability (sigh), so must be
4094 careful of overlapping subsections of the array... */
4096 if (end1
== start2
) /* adjacent regions */
4098 modify_region (current_buffer
, start1
, end2
);
4099 record_change (start1
, len1
+ len2
);
4101 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4102 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4103 Fset_text_properties (make_number (start1
), make_number (end2
),
4106 /* First region smaller than second. */
4107 if (len1_byte
< len2_byte
)
4111 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4113 /* Don't precompute these addresses. We have to compute them
4114 at the last minute, because the relocating allocator might
4115 have moved the buffer around during the xmalloc. */
4116 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4117 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4119 bcopy (start2_addr
, temp
, len2_byte
);
4120 bcopy (start1_addr
, start1_addr
+ len2_byte
, len1_byte
);
4121 bcopy (temp
, start1_addr
, len2_byte
);
4125 /* First region not smaller than second. */
4129 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4130 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4131 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4132 bcopy (start1_addr
, temp
, len1_byte
);
4133 bcopy (start2_addr
, start1_addr
, len2_byte
);
4134 bcopy (temp
, start1_addr
+ len2_byte
, len1_byte
);
4137 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
4138 len1
, current_buffer
, 0);
4139 graft_intervals_into_buffer (tmp_interval2
, start1
,
4140 len2
, current_buffer
, 0);
4141 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4142 update_compositions (start1
+ len2
, end2
, CHECK_TAIL
);
4144 /* Non-adjacent regions, because end1 != start2, bleagh... */
4147 len_mid
= start2_byte
- (start1_byte
+ len1_byte
);
4149 if (len1_byte
== len2_byte
)
4150 /* Regions are same size, though, how nice. */
4154 modify_region (current_buffer
, start1
, end1
);
4155 modify_region (current_buffer
, start2
, end2
);
4156 record_change (start1
, len1
);
4157 record_change (start2
, len2
);
4158 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4159 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4160 Fset_text_properties (make_number (start1
), make_number (end1
),
4162 Fset_text_properties (make_number (start2
), make_number (end2
),
4165 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4166 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4167 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4168 bcopy (start1_addr
, temp
, len1_byte
);
4169 bcopy (start2_addr
, start1_addr
, len2_byte
);
4170 bcopy (temp
, start2_addr
, len1_byte
);
4173 graft_intervals_into_buffer (tmp_interval1
, start2
,
4174 len1
, current_buffer
, 0);
4175 graft_intervals_into_buffer (tmp_interval2
, start1
,
4176 len2
, current_buffer
, 0);
4179 else if (len1_byte
< len2_byte
) /* Second region larger than first */
4180 /* Non-adjacent & unequal size, area between must also be shifted. */
4184 modify_region (current_buffer
, start1
, end2
);
4185 record_change (start1
, (end2
- start1
));
4186 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4187 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4188 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4189 Fset_text_properties (make_number (start1
), make_number (end2
),
4192 /* holds region 2 */
4193 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4194 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4195 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4196 bcopy (start2_addr
, temp
, len2_byte
);
4197 bcopy (start1_addr
, start1_addr
+ len_mid
+ len2_byte
, len1_byte
);
4198 safe_bcopy (start1_addr
+ len1_byte
, start1_addr
+ len2_byte
, len_mid
);
4199 bcopy (temp
, start1_addr
, len2_byte
);
4202 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4203 len1
, current_buffer
, 0);
4204 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4205 len_mid
, current_buffer
, 0);
4206 graft_intervals_into_buffer (tmp_interval2
, start1
,
4207 len2
, current_buffer
, 0);
4210 /* Second region smaller than first. */
4214 record_change (start1
, (end2
- start1
));
4215 modify_region (current_buffer
, start1
, end2
);
4217 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4218 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4219 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4220 Fset_text_properties (make_number (start1
), make_number (end2
),
4223 /* holds region 1 */
4224 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4225 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4226 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4227 bcopy (start1_addr
, temp
, len1_byte
);
4228 bcopy (start2_addr
, start1_addr
, len2_byte
);
4229 bcopy (start1_addr
+ len1_byte
, start1_addr
+ len2_byte
, len_mid
);
4230 bcopy (temp
, start1_addr
+ len2_byte
+ len_mid
, len1_byte
);
4233 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4234 len1
, current_buffer
, 0);
4235 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4236 len_mid
, current_buffer
, 0);
4237 graft_intervals_into_buffer (tmp_interval2
, start1
,
4238 len2
, current_buffer
, 0);
4241 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4242 update_compositions (end2
- len1
, end2
, CHECK_BORDER
);
4245 /* When doing multiple transpositions, it might be nice
4246 to optimize this. Perhaps the markers in any one buffer
4247 should be organized in some sorted data tree. */
4248 if (NILP (leave_markers
))
4250 transpose_markers (start1
, end1
, start2
, end2
,
4251 start1_byte
, start1_byte
+ len1_byte
,
4252 start2_byte
, start2_byte
+ len2_byte
);
4253 fix_start_end_in_overlays (start1
, end2
);
4265 Qbuffer_access_fontify_functions
4266 = intern ("buffer-access-fontify-functions");
4267 staticpro (&Qbuffer_access_fontify_functions
);
4269 DEFVAR_LISP ("inhibit-field-text-motion", &Vinhibit_field_text_motion
,
4270 doc
: /* Non-nil means text motion commands don't notice fields. */);
4271 Vinhibit_field_text_motion
= Qnil
;
4273 DEFVAR_LISP ("buffer-access-fontify-functions",
4274 &Vbuffer_access_fontify_functions
,
4275 doc
: /* List of functions called by `buffer-substring' to fontify if necessary.
4276 Each function is called with two arguments which specify the range
4277 of the buffer being accessed. */);
4278 Vbuffer_access_fontify_functions
= Qnil
;
4282 extern Lisp_Object Vprin1_to_string_buffer
;
4283 obuf
= Fcurrent_buffer ();
4284 /* Do this here, because init_buffer_once is too early--it won't work. */
4285 Fset_buffer (Vprin1_to_string_buffer
);
4286 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
4287 Fset (Fmake_local_variable (intern ("buffer-access-fontify-functions")),
4292 DEFVAR_LISP ("buffer-access-fontified-property",
4293 &Vbuffer_access_fontified_property
,
4294 doc
: /* Property which (if non-nil) indicates text has been fontified.
4295 `buffer-substring' need not call the `buffer-access-fontify-functions'
4296 functions if all the text being accessed has this property. */);
4297 Vbuffer_access_fontified_property
= Qnil
;
4299 DEFVAR_LISP ("system-name", &Vsystem_name
,
4300 doc
: /* The name of the machine Emacs is running on. */);
4302 DEFVAR_LISP ("user-full-name", &Vuser_full_name
,
4303 doc
: /* The full name of the user logged in. */);
4305 DEFVAR_LISP ("user-login-name", &Vuser_login_name
,
4306 doc
: /* The user's name, taken from environment variables if possible. */);
4308 DEFVAR_LISP ("user-real-login-name", &Vuser_real_login_name
,
4309 doc
: /* The user's name, based upon the real uid only. */);
4311 DEFVAR_LISP ("operating-system-release", &Voperating_system_release
,
4312 doc
: /* The release of the operating system Emacs is running on. */);
4314 defsubr (&Spropertize
);
4315 defsubr (&Schar_equal
);
4316 defsubr (&Sgoto_char
);
4317 defsubr (&Sstring_to_char
);
4318 defsubr (&Schar_to_string
);
4319 defsubr (&Sbuffer_substring
);
4320 defsubr (&Sbuffer_substring_no_properties
);
4321 defsubr (&Sbuffer_string
);
4323 defsubr (&Spoint_marker
);
4324 defsubr (&Smark_marker
);
4326 defsubr (&Sregion_beginning
);
4327 defsubr (&Sregion_end
);
4329 staticpro (&Qfield
);
4330 Qfield
= intern ("field");
4331 staticpro (&Qboundary
);
4332 Qboundary
= intern ("boundary");
4333 defsubr (&Sfield_beginning
);
4334 defsubr (&Sfield_end
);
4335 defsubr (&Sfield_string
);
4336 defsubr (&Sfield_string_no_properties
);
4337 defsubr (&Sdelete_field
);
4338 defsubr (&Sconstrain_to_field
);
4340 defsubr (&Sline_beginning_position
);
4341 defsubr (&Sline_end_position
);
4343 /* defsubr (&Smark); */
4344 /* defsubr (&Sset_mark); */
4345 defsubr (&Ssave_excursion
);
4346 defsubr (&Ssave_current_buffer
);
4348 defsubr (&Sbufsize
);
4349 defsubr (&Spoint_max
);
4350 defsubr (&Spoint_min
);
4351 defsubr (&Spoint_min_marker
);
4352 defsubr (&Spoint_max_marker
);
4353 defsubr (&Sgap_position
);
4354 defsubr (&Sgap_size
);
4355 defsubr (&Sposition_bytes
);
4356 defsubr (&Sbyte_to_position
);
4362 defsubr (&Sfollowing_char
);
4363 defsubr (&Sprevious_char
);
4364 defsubr (&Schar_after
);
4365 defsubr (&Schar_before
);
4367 defsubr (&Sinsert_before_markers
);
4368 defsubr (&Sinsert_and_inherit
);
4369 defsubr (&Sinsert_and_inherit_before_markers
);
4370 defsubr (&Sinsert_char
);
4372 defsubr (&Suser_login_name
);
4373 defsubr (&Suser_real_login_name
);
4374 defsubr (&Suser_uid
);
4375 defsubr (&Suser_real_uid
);
4376 defsubr (&Suser_full_name
);
4377 defsubr (&Semacs_pid
);
4378 defsubr (&Scurrent_time
);
4379 defsubr (&Sget_internal_run_time
);
4380 defsubr (&Sformat_time_string
);
4381 defsubr (&Sfloat_time
);
4382 defsubr (&Sdecode_time
);
4383 defsubr (&Sencode_time
);
4384 defsubr (&Scurrent_time_string
);
4385 defsubr (&Scurrent_time_zone
);
4386 defsubr (&Sset_time_zone_rule
);
4387 defsubr (&Ssystem_name
);
4388 defsubr (&Smessage
);
4389 defsubr (&Smessage_box
);
4390 defsubr (&Smessage_or_box
);
4391 defsubr (&Scurrent_message
);
4394 defsubr (&Sinsert_buffer_substring
);
4395 defsubr (&Scompare_buffer_substrings
);
4396 defsubr (&Ssubst_char_in_region
);
4397 defsubr (&Stranslate_region_internal
);
4398 defsubr (&Sdelete_region
);
4399 defsubr (&Sdelete_and_extract_region
);
4401 defsubr (&Snarrow_to_region
);
4402 defsubr (&Ssave_restriction
);
4403 defsubr (&Stranspose_regions
);
4406 /* arch-tag: fc3827d8-6f60-4067-b11e-c3218031b018
4407 (do not change this comment) */